packages feed

ghc 9.2.8 → 9.4.1

raw patch · 627 files changed

+122954/−82566 lines, 627 filesdep +stmdep ~basedep ~ghc-bootdep ~ghc-heapbuild-type:Customsetup-changed

Dependencies added: stm

Dependency ranges changed: base, ghc-boot, ghc-heap, ghci, template-haskell, time

Files

+ Bytecodes.h view
@@ -0,0 +1,109 @@+/* -----------------------------------------------------------------------------+ *+ * (c) The GHC Team, 1998-2009+ *+ * Bytecode definitions.+ *+ * ---------------------------------------------------------------------------*/++/* --------------------------------------------------------------------------+ * Instructions+ *+ * Notes:+ * o CASEFAIL is generated by the compiler whenever it tests an "irrefutable"+ *   pattern which fails.  If we don't see too many of these, we could+ *   optimise out the redundant test.+ * ------------------------------------------------------------------------*/++/* NOTE:++   THIS FILE IS INCLUDED IN HASKELL SOURCES (ghc/compiler/GHC/ByteCode/Asm.hs).+   DO NOT PUT C-SPECIFIC STUFF IN HERE!++   I hope that's clear :-)+*/++#define bci_STKCHECK                    1+#define bci_PUSH_L                      2+#define bci_PUSH_LL                     3+#define bci_PUSH_LLL                    4+#define bci_PUSH8                       5+#define bci_PUSH16                      6+#define bci_PUSH32                      7+#define bci_PUSH8_W                     8+#define bci_PUSH16_W                    9+#define bci_PUSH32_W                    10+#define bci_PUSH_G                      11+#define bci_PUSH_ALTS                   12+#define bci_PUSH_ALTS_P                 13+#define bci_PUSH_ALTS_N                 14+#define bci_PUSH_ALTS_F                 15+#define bci_PUSH_ALTS_D                 16+#define bci_PUSH_ALTS_L                 17+#define bci_PUSH_ALTS_V                 18+#define bci_PUSH_PAD8                   19+#define bci_PUSH_PAD16                  20+#define bci_PUSH_PAD32                  21+#define bci_PUSH_UBX8                   22+#define bci_PUSH_UBX16                  23+#define bci_PUSH_UBX32                  24+#define bci_PUSH_UBX                    25+#define bci_PUSH_APPLY_N                26+#define bci_PUSH_APPLY_F                27+#define bci_PUSH_APPLY_D                28+#define bci_PUSH_APPLY_L                29+#define bci_PUSH_APPLY_V                30+#define bci_PUSH_APPLY_P                31+#define bci_PUSH_APPLY_PP               32+#define bci_PUSH_APPLY_PPP              33+#define bci_PUSH_APPLY_PPPP             34+#define bci_PUSH_APPLY_PPPPP            35+#define bci_PUSH_APPLY_PPPPPP           36+/* #define bci_PUSH_APPLY_PPPPPPP          37 */+#define bci_SLIDE                       38+#define bci_ALLOC_AP                    39+#define bci_ALLOC_AP_NOUPD              40+#define bci_ALLOC_PAP                   41+#define bci_MKAP                        42+#define bci_MKPAP                       43+#define bci_UNPACK                      44+#define bci_PACK                        45+#define bci_TESTLT_I                    46+#define bci_TESTEQ_I                    47+#define bci_TESTLT_F                    48+#define bci_TESTEQ_F                    49+#define bci_TESTLT_D                    50+#define bci_TESTEQ_D                    51+#define bci_TESTLT_P                    52+#define bci_TESTEQ_P                    53+#define bci_CASEFAIL                    54+#define bci_JMP                         55+#define bci_CCALL                       56+#define bci_SWIZZLE                     57+#define bci_ENTER                       58+#define bci_RETURN                      59+#define bci_RETURN_P                    60+#define bci_RETURN_N                    61+#define bci_RETURN_F                    62+#define bci_RETURN_D                    63+#define bci_RETURN_L                    64+#define bci_RETURN_V                    65+#define bci_BRK_FUN                     66+#define bci_TESTLT_W                    67+#define bci_TESTEQ_W                    68++#define bci_RETURN_T                    69+#define bci_PUSH_ALTS_T                 70+/* If you need to go past 255 then you will run into the flags */++/* If you need to go below 0x0100 then you will run into the instructions */+#define bci_FLAG_LARGE_ARGS 0x8000++/* If a BCO definitely requires less than this many words of stack,+   don't include an explicit STKCHECK insn in it.  The interpreter+   will check for this many words of stack before running each BCO,+   rendering an explicit check unnecessary in the majority of+   cases. */+#define INTERP_STACK_CHECK_THRESH 50++/*-------------------------------------------------------------------------*/
+ ClosureTypes.h view
@@ -0,0 +1,90 @@+/* ----------------------------------------------------------------------------+ *+ * (c) The GHC Team, 1998-2005+ *+ * Closure Type Constants: out here because the native code generator+ * needs to get at them.+ *+ * -------------------------------------------------------------------------- */++#pragma once++/*+ * WARNING WARNING WARNING+ *+ * If you add or delete any closure types, don't forget to update the following,+ *   - the closure flags table in rts/ClosureFlags.c+ *   - isRetainer in rts/RetainerProfile.c+ *   - the closure_type_names list in rts/Printer.c+ */++/* CONSTR/THUNK/FUN_$A_$B mean they have $A pointers followed by $B+ * non-pointers in their payloads.+ */++/* Object tag 0 raises an internal error */+#define INVALID_OBJECT                0+#define CONSTR                        1+#define CONSTR_1_0                    2+#define CONSTR_0_1                    3+#define CONSTR_2_0                    4+#define CONSTR_1_1                    5+#define CONSTR_0_2                    6+#define CONSTR_NOCAF                  7+#define FUN                           8+#define FUN_1_0                       9+#define FUN_0_1                       10+#define FUN_2_0                       11+#define FUN_1_1                       12+#define FUN_0_2                       13+#define FUN_STATIC                    14+#define THUNK                         15+#define THUNK_1_0                     16+#define THUNK_0_1                     17+#define THUNK_2_0                     18+#define THUNK_1_1                     19+#define THUNK_0_2                     20+#define THUNK_STATIC                  21+#define THUNK_SELECTOR                22+#define BCO                           23+#define AP                            24+#define PAP                           25+#define AP_STACK                      26+#define IND                           27+#define IND_STATIC                    28+#define RET_BCO                       29+#define RET_SMALL                     30+#define RET_BIG                       31+#define RET_FUN                       32+#define UPDATE_FRAME                  33+#define CATCH_FRAME                   34+#define UNDERFLOW_FRAME               35+#define STOP_FRAME                    36+#define BLOCKING_QUEUE                37+#define BLACKHOLE                     38+#define MVAR_CLEAN                    39+#define MVAR_DIRTY                    40+#define TVAR                          41+#define ARR_WORDS                     42+#define MUT_ARR_PTRS_CLEAN            43+#define MUT_ARR_PTRS_DIRTY            44+#define MUT_ARR_PTRS_FROZEN_DIRTY     45+#define MUT_ARR_PTRS_FROZEN_CLEAN     46+#define MUT_VAR_CLEAN                 47+#define MUT_VAR_DIRTY                 48+#define WEAK                          49+#define PRIM                          50+#define MUT_PRIM                      51+#define TSO                           52+#define STACK                         53+#define TREC_CHUNK                    54+#define ATOMICALLY_FRAME              55+#define CATCH_RETRY_FRAME             56+#define CATCH_STM_FRAME               57+#define WHITEHOLE                     58+#define SMALL_MUT_ARR_PTRS_CLEAN      59+#define SMALL_MUT_ARR_PTRS_DIRTY      60+#define SMALL_MUT_ARR_PTRS_FROZEN_DIRTY 61+#define SMALL_MUT_ARR_PTRS_FROZEN_CLEAN 62+#define COMPACT_NFDATA                63+#define N_CLOSURE_TYPES               64
+ CodeGen.Platform.h view
@@ -0,0 +1,1014 @@++import GHC.Cmm.Expr+#if !(defined(MACHREGS_i386) || defined(MACHREGS_x86_64) \+    || defined(MACHREGS_powerpc) || defined(MACHREGS_aarch64))+import GHC.Utils.Panic.Plain+#endif+import GHC.Platform.Reg++#include "MachRegs.h"++#if defined(MACHREGS_i386) || defined(MACHREGS_x86_64)++# if defined(MACHREGS_i386)+#  define eax 0+#  define ebx 1+#  define ecx 2+#  define edx 3+#  define esi 4+#  define edi 5+#  define ebp 6+#  define esp 7+# endif++# if defined(MACHREGS_x86_64)+#  define rax   0+#  define rbx   1+#  define rcx   2+#  define rdx   3+#  define rsi   4+#  define rdi   5+#  define rbp   6+#  define rsp   7+#  define r8    8+#  define r9    9+#  define r10   10+#  define r11   11+#  define r12   12+#  define r13   13+#  define r14   14+#  define r15   15+# endif+++-- N.B. XMM, YMM, and ZMM are all aliased to the same hardware registers hence+-- being assigned the same RegNos.+# define xmm0  16+# define xmm1  17+# define xmm2  18+# define xmm3  19+# define xmm4  20+# define xmm5  21+# define xmm6  22+# define xmm7  23+# define xmm8  24+# define xmm9  25+# define xmm10 26+# define xmm11 27+# define xmm12 28+# define xmm13 29+# define xmm14 30+# define xmm15 31++# define ymm0  16+# define ymm1  17+# define ymm2  18+# define ymm3  19+# define ymm4  20+# define ymm5  21+# define ymm6  22+# define ymm7  23+# define ymm8  24+# define ymm9  25+# define ymm10 26+# define ymm11 27+# define ymm12 28+# define ymm13 29+# define ymm14 30+# define ymm15 31++# define zmm0  16+# define zmm1  17+# define zmm2  18+# define zmm3  19+# define zmm4  20+# define zmm5  21+# define zmm6  22+# define zmm7  23+# define zmm8  24+# define zmm9  25+# define zmm10 26+# define zmm11 27+# define zmm12 28+# define zmm13 29+# define zmm14 30+# define zmm15 31++-- Note: these are only needed for ARM/AArch64 because globalRegMaybe is now used in CmmSink.hs.+-- Since it's only used to check 'isJust', the actual values don't matter, thus+-- I'm not sure if these are the correct numberings.+-- Normally, the register names are just stringified as part of the REG() macro++#elif defined(MACHREGS_powerpc) || defined(MACHREGS_arm) \+    || defined(MACHREGS_aarch64)++# define r0 0+# define r1 1+# define r2 2+# define r3 3+# define r4 4+# define r5 5+# define r6 6+# define r7 7+# define r8 8+# define r9 9+# define r10 10+# define r11 11+# define r12 12+# define r13 13+# define r14 14+# define r15 15+# define r16 16+# define r17 17+# define r18 18+# define r19 19+# define r20 20+# define r21 21+# define r22 22+# define r23 23+# define r24 24+# define r25 25+# define r26 26+# define r27 27+# define r28 28+# define r29 29+# define r30 30+# define r31 31++-- See note above. These aren't actually used for anything except satisfying the compiler for globalRegMaybe+-- so I'm unsure if they're the correct numberings, should they ever be attempted to be used in the NCG.+#if defined(MACHREGS_aarch64) || defined(MACHREGS_arm)+# define s0 32+# define s1 33+# define s2 34+# define s3 35+# define s4 36+# define s5 37+# define s6 38+# define s7 39+# define s8 40+# define s9 41+# define s10 42+# define s11 43+# define s12 44+# define s13 45+# define s14 46+# define s15 47+# define s16 48+# define s17 49+# define s18 50+# define s19 51+# define s20 52+# define s21 53+# define s22 54+# define s23 55+# define s24 56+# define s25 57+# define s26 58+# define s27 59+# define s28 60+# define s29 61+# define s30 62+# define s31 63++# define d0 32+# define d1 33+# define d2 34+# define d3 35+# define d4 36+# define d5 37+# define d6 38+# define d7 39+# define d8 40+# define d9 41+# define d10 42+# define d11 43+# define d12 44+# define d13 45+# define d14 46+# define d15 47+# define d16 48+# define d17 49+# define d18 50+# define d19 51+# define d20 52+# define d21 53+# define d22 54+# define d23 55+# define d24 56+# define d25 57+# define d26 58+# define d27 59+# define d28 60+# define d29 61+# define d30 62+# define d31 63+#endif++# if defined(MACHREGS_darwin)+#  define f0  32+#  define f1  33+#  define f2  34+#  define f3  35+#  define f4  36+#  define f5  37+#  define f6  38+#  define f7  39+#  define f8  40+#  define f9  41+#  define f10 42+#  define f11 43+#  define f12 44+#  define f13 45+#  define f14 46+#  define f15 47+#  define f16 48+#  define f17 49+#  define f18 50+#  define f19 51+#  define f20 52+#  define f21 53+#  define f22 54+#  define f23 55+#  define f24 56+#  define f25 57+#  define f26 58+#  define f27 59+#  define f28 60+#  define f29 61+#  define f30 62+#  define f31 63+# else+#  define fr0  32+#  define fr1  33+#  define fr2  34+#  define fr3  35+#  define fr4  36+#  define fr5  37+#  define fr6  38+#  define fr7  39+#  define fr8  40+#  define fr9  41+#  define fr10 42+#  define fr11 43+#  define fr12 44+#  define fr13 45+#  define fr14 46+#  define fr15 47+#  define fr16 48+#  define fr17 49+#  define fr18 50+#  define fr19 51+#  define fr20 52+#  define fr21 53+#  define fr22 54+#  define fr23 55+#  define fr24 56+#  define fr25 57+#  define fr26 58+#  define fr27 59+#  define fr28 60+#  define fr29 61+#  define fr30 62+#  define fr31 63+# endif++#elif defined(MACHREGS_s390x)++# define r0   0+# define r1   1+# define r2   2+# define r3   3+# define r4   4+# define r5   5+# define r6   6+# define r7   7+# define r8   8+# define r9   9+# define r10 10+# define r11 11+# define r12 12+# define r13 13+# define r14 14+# define r15 15++# define f0  16+# define f1  17+# define f2  18+# define f3  19+# define f4  20+# define f5  21+# define f6  22+# define f7  23+# define f8  24+# define f9  25+# define f10 26+# define f11 27+# define f12 28+# define f13 29+# define f14 30+# define f15 31++#elif defined(MACHREGS_riscv64)++# define zero 0+# define ra   1+# define sp   2+# define gp   3+# define tp   4+# define t0   5+# define t1   6+# define t2   7+# define s0   8+# define s1   9+# define a0  10+# define a1  11+# define a2  12+# define a3  13+# define a4  14+# define a5  15+# define a6  16+# define a7  17+# define s2  18+# define s3  19+# define s4  20+# define s5  21+# define s6  22+# define s7  23+# define s8  24+# define s9  25+# define s10 26+# define s11 27+# define t3  28+# define t4  29+# define t5  30+# define t6  31++# define ft0  32+# define ft1  33+# define ft2  34+# define ft3  35+# define ft4  36+# define ft5  37+# define ft6  38+# define ft7  39+# define fs0  40+# define fs1  41+# define fa0  42+# define fa1  43+# define fa2  44+# define fa3  45+# define fa4  46+# define fa5  47+# define fa6  48+# define fa7  49+# define fs2  50+# define fs3  51+# define fs4  52+# define fs5  53+# define fs6  54+# define fs7  55+# define fs8  56+# define fs9  57+# define fs10 58+# define fs11 59+# define ft8  60+# define ft9  61+# define ft10 62+# define ft11 63++#endif++callerSaves :: GlobalReg -> Bool+#if defined(CALLER_SAVES_Base)+callerSaves BaseReg           = True+#endif+#if defined(CALLER_SAVES_R1)+callerSaves (VanillaReg 1 _)  = True+#endif+#if defined(CALLER_SAVES_R2)+callerSaves (VanillaReg 2 _)  = True+#endif+#if defined(CALLER_SAVES_R3)+callerSaves (VanillaReg 3 _)  = True+#endif+#if defined(CALLER_SAVES_R4)+callerSaves (VanillaReg 4 _)  = True+#endif+#if defined(CALLER_SAVES_R5)+callerSaves (VanillaReg 5 _)  = True+#endif+#if defined(CALLER_SAVES_R6)+callerSaves (VanillaReg 6 _)  = True+#endif+#if defined(CALLER_SAVES_R7)+callerSaves (VanillaReg 7 _)  = True+#endif+#if defined(CALLER_SAVES_R8)+callerSaves (VanillaReg 8 _)  = True+#endif+#if defined(CALLER_SAVES_R9)+callerSaves (VanillaReg 9 _)  = True+#endif+#if defined(CALLER_SAVES_R10)+callerSaves (VanillaReg 10 _) = True+#endif+#if defined(CALLER_SAVES_F1)+callerSaves (FloatReg 1)      = True+#endif+#if defined(CALLER_SAVES_F2)+callerSaves (FloatReg 2)      = True+#endif+#if defined(CALLER_SAVES_F3)+callerSaves (FloatReg 3)      = True+#endif+#if defined(CALLER_SAVES_F4)+callerSaves (FloatReg 4)      = True+#endif+#if defined(CALLER_SAVES_F5)+callerSaves (FloatReg 5)      = True+#endif+#if defined(CALLER_SAVES_F6)+callerSaves (FloatReg 6)      = True+#endif+#if defined(CALLER_SAVES_D1)+callerSaves (DoubleReg 1)     = True+#endif+#if defined(CALLER_SAVES_D2)+callerSaves (DoubleReg 2)     = True+#endif+#if defined(CALLER_SAVES_D3)+callerSaves (DoubleReg 3)     = True+#endif+#if defined(CALLER_SAVES_D4)+callerSaves (DoubleReg 4)     = True+#endif+#if defined(CALLER_SAVES_D5)+callerSaves (DoubleReg 5)     = True+#endif+#if defined(CALLER_SAVES_D6)+callerSaves (DoubleReg 6)     = True+#endif+#if defined(CALLER_SAVES_L1)+callerSaves (LongReg 1)       = True+#endif+#if defined(CALLER_SAVES_Sp)+callerSaves Sp                = True+#endif+#if defined(CALLER_SAVES_SpLim)+callerSaves SpLim             = True+#endif+#if defined(CALLER_SAVES_Hp)+callerSaves Hp                = True+#endif+#if defined(CALLER_SAVES_HpLim)+callerSaves HpLim             = True+#endif+#if defined(CALLER_SAVES_CCCS)+callerSaves CCCS              = True+#endif+#if defined(CALLER_SAVES_CurrentTSO)+callerSaves CurrentTSO        = True+#endif+#if defined(CALLER_SAVES_CurrentNursery)+callerSaves CurrentNursery    = True+#endif+callerSaves _                 = False++activeStgRegs :: [GlobalReg]+activeStgRegs = [+#if defined(REG_Base)+    BaseReg+#endif+#if defined(REG_Sp)+    ,Sp+#endif+#if defined(REG_Hp)+    ,Hp+#endif+#if defined(REG_R1)+    ,VanillaReg 1 VGcPtr+#endif+#if defined(REG_R2)+    ,VanillaReg 2 VGcPtr+#endif+#if defined(REG_R3)+    ,VanillaReg 3 VGcPtr+#endif+#if defined(REG_R4)+    ,VanillaReg 4 VGcPtr+#endif+#if defined(REG_R5)+    ,VanillaReg 5 VGcPtr+#endif+#if defined(REG_R6)+    ,VanillaReg 6 VGcPtr+#endif+#if defined(REG_R7)+    ,VanillaReg 7 VGcPtr+#endif+#if defined(REG_R8)+    ,VanillaReg 8 VGcPtr+#endif+#if defined(REG_R9)+    ,VanillaReg 9 VGcPtr+#endif+#if defined(REG_R10)+    ,VanillaReg 10 VGcPtr+#endif+#if defined(REG_SpLim)+    ,SpLim+#endif+#if MAX_REAL_XMM_REG != 0+#if defined(REG_F1)+    ,FloatReg 1+#endif+#if defined(REG_D1)+    ,DoubleReg 1+#endif+#if defined(REG_XMM1)+    ,XmmReg 1+#endif+#if defined(REG_YMM1)+    ,YmmReg 1+#endif+#if defined(REG_ZMM1)+    ,ZmmReg 1+#endif+#if defined(REG_F2)+    ,FloatReg 2+#endif+#if defined(REG_D2)+    ,DoubleReg 2+#endif+#if defined(REG_XMM2)+    ,XmmReg 2+#endif+#if defined(REG_YMM2)+    ,YmmReg 2+#endif+#if defined(REG_ZMM2)+    ,ZmmReg 2+#endif+#if defined(REG_F3)+    ,FloatReg 3+#endif+#if defined(REG_D3)+    ,DoubleReg 3+#endif+#if defined(REG_XMM3)+    ,XmmReg 3+#endif+#if defined(REG_YMM3)+    ,YmmReg 3+#endif+#if defined(REG_ZMM3)+    ,ZmmReg 3+#endif+#if defined(REG_F4)+    ,FloatReg 4+#endif+#if defined(REG_D4)+    ,DoubleReg 4+#endif+#if defined(REG_XMM4)+    ,XmmReg 4+#endif+#if defined(REG_YMM4)+    ,YmmReg 4+#endif+#if defined(REG_ZMM4)+    ,ZmmReg 4+#endif+#if defined(REG_F5)+    ,FloatReg 5+#endif+#if defined(REG_D5)+    ,DoubleReg 5+#endif+#if defined(REG_XMM5)+    ,XmmReg 5+#endif+#if defined(REG_YMM5)+    ,YmmReg 5+#endif+#if defined(REG_ZMM5)+    ,ZmmReg 5+#endif+#if defined(REG_F6)+    ,FloatReg 6+#endif+#if defined(REG_D6)+    ,DoubleReg 6+#endif+#if defined(REG_XMM6)+    ,XmmReg 6+#endif+#if defined(REG_YMM6)+    ,YmmReg 6+#endif+#if defined(REG_ZMM6)+    ,ZmmReg 6+#endif+#else /* MAX_REAL_XMM_REG == 0 */+#if defined(REG_F1)+    ,FloatReg 1+#endif+#if defined(REG_F2)+    ,FloatReg 2+#endif+#if defined(REG_F3)+    ,FloatReg 3+#endif+#if defined(REG_F4)+    ,FloatReg 4+#endif+#if defined(REG_F5)+    ,FloatReg 5+#endif+#if defined(REG_F6)+    ,FloatReg 6+#endif+#if defined(REG_D1)+    ,DoubleReg 1+#endif+#if defined(REG_D2)+    ,DoubleReg 2+#endif+#if defined(REG_D3)+    ,DoubleReg 3+#endif+#if defined(REG_D4)+    ,DoubleReg 4+#endif+#if defined(REG_D5)+    ,DoubleReg 5+#endif+#if defined(REG_D6)+    ,DoubleReg 6+#endif+#endif /* MAX_REAL_XMM_REG == 0 */+    ]++haveRegBase :: Bool+#if defined(REG_Base)+haveRegBase = True+#else+haveRegBase = False+#endif++--  | Returns 'Nothing' if this global register is not stored+-- in a real machine register, otherwise returns @'Just' reg@, where+-- reg is the machine register it is stored in.+globalRegMaybe :: GlobalReg -> Maybe RealReg+#if defined(MACHREGS_i386) || defined(MACHREGS_x86_64) \+    || defined(MACHREGS_powerpc) \+    || defined(MACHREGS_arm) || defined(MACHREGS_aarch64) \+    || defined(MACHREGS_s390x) || defined(MACHREGS_riscv64)+# if defined(REG_Base)+globalRegMaybe BaseReg                  = Just (RealRegSingle REG_Base)+# endif+# if defined(REG_R1)+globalRegMaybe (VanillaReg 1 _)         = Just (RealRegSingle REG_R1)+# endif+# if defined(REG_R2)+globalRegMaybe (VanillaReg 2 _)         = Just (RealRegSingle REG_R2)+# endif+# if defined(REG_R3)+globalRegMaybe (VanillaReg 3 _)         = Just (RealRegSingle REG_R3)+# endif+# if defined(REG_R4)+globalRegMaybe (VanillaReg 4 _)         = Just (RealRegSingle REG_R4)+# endif+# if defined(REG_R5)+globalRegMaybe (VanillaReg 5 _)         = Just (RealRegSingle REG_R5)+# endif+# if defined(REG_R6)+globalRegMaybe (VanillaReg 6 _)         = Just (RealRegSingle REG_R6)+# endif+# if defined(REG_R7)+globalRegMaybe (VanillaReg 7 _)         = Just (RealRegSingle REG_R7)+# endif+# if defined(REG_R8)+globalRegMaybe (VanillaReg 8 _)         = Just (RealRegSingle REG_R8)+# endif+# if defined(REG_R9)+globalRegMaybe (VanillaReg 9 _)         = Just (RealRegSingle REG_R9)+# endif+# if defined(REG_R10)+globalRegMaybe (VanillaReg 10 _)        = Just (RealRegSingle REG_R10)+# endif+# if defined(REG_F1)+globalRegMaybe (FloatReg 1)             = Just (RealRegSingle REG_F1)+# endif+# if defined(REG_F2)+globalRegMaybe (FloatReg 2)             = Just (RealRegSingle REG_F2)+# endif+# if defined(REG_F3)+globalRegMaybe (FloatReg 3)             = Just (RealRegSingle REG_F3)+# endif+# if defined(REG_F4)+globalRegMaybe (FloatReg 4)             = Just (RealRegSingle REG_F4)+# endif+# if defined(REG_F5)+globalRegMaybe (FloatReg 5)             = Just (RealRegSingle REG_F5)+# endif+# if defined(REG_F6)+globalRegMaybe (FloatReg 6)             = Just (RealRegSingle REG_F6)+# endif+# if defined(REG_D1)+globalRegMaybe (DoubleReg 1)            = Just (RealRegSingle REG_D1)+# endif+# if defined(REG_D2)+globalRegMaybe (DoubleReg 2)            = Just (RealRegSingle REG_D2)+# endif+# if defined(REG_D3)+globalRegMaybe (DoubleReg 3)            = Just (RealRegSingle REG_D3)+# endif+# if defined(REG_D4)+globalRegMaybe (DoubleReg 4)            = Just (RealRegSingle REG_D4)+# endif+# if defined(REG_D5)+globalRegMaybe (DoubleReg 5)            = Just (RealRegSingle REG_D5)+# endif+# if defined(REG_D6)+globalRegMaybe (DoubleReg 6)            = Just (RealRegSingle REG_D6)+# endif+# if MAX_REAL_XMM_REG != 0+#  if defined(REG_XMM1)+globalRegMaybe (XmmReg 1)               = Just (RealRegSingle REG_XMM1)+#  endif+#  if defined(REG_XMM2)+globalRegMaybe (XmmReg 2)               = Just (RealRegSingle REG_XMM2)+#  endif+#  if defined(REG_XMM3)+globalRegMaybe (XmmReg 3)               = Just (RealRegSingle REG_XMM3)+#  endif+#  if defined(REG_XMM4)+globalRegMaybe (XmmReg 4)               = Just (RealRegSingle REG_XMM4)+#  endif+#  if defined(REG_XMM5)+globalRegMaybe (XmmReg 5)               = Just (RealRegSingle REG_XMM5)+#  endif+#  if defined(REG_XMM6)+globalRegMaybe (XmmReg 6)               = Just (RealRegSingle REG_XMM6)+#  endif+# endif+# if defined(MAX_REAL_YMM_REG) && MAX_REAL_YMM_REG != 0+#  if defined(REG_YMM1)+globalRegMaybe (YmmReg 1)               = Just (RealRegSingle REG_YMM1)+#  endif+#  if defined(REG_YMM2)+globalRegMaybe (YmmReg 2)               = Just (RealRegSingle REG_YMM2)+#  endif+#  if defined(REG_YMM3)+globalRegMaybe (YmmReg 3)               = Just (RealRegSingle REG_YMM3)+#  endif+#  if defined(REG_YMM4)+globalRegMaybe (YmmReg 4)               = Just (RealRegSingle REG_YMM4)+#  endif+#  if defined(REG_YMM5)+globalRegMaybe (YmmReg 5)               = Just (RealRegSingle REG_YMM5)+#  endif+#  if defined(REG_YMM6)+globalRegMaybe (YmmReg 6)               = Just (RealRegSingle REG_YMM6)+#  endif+# endif+# if defined(MAX_REAL_ZMM_REG) && MAX_REAL_ZMM_REG != 0+#  if defined(REG_ZMM1)+globalRegMaybe (ZmmReg 1)               = Just (RealRegSingle REG_ZMM1)+#  endif+#  if defined(REG_ZMM2)+globalRegMaybe (ZmmReg 2)               = Just (RealRegSingle REG_ZMM2)+#  endif+#  if defined(REG_ZMM3)+globalRegMaybe (ZmmReg 3)               = Just (RealRegSingle REG_ZMM3)+#  endif+#  if defined(REG_ZMM4)+globalRegMaybe (ZmmReg 4)               = Just (RealRegSingle REG_ZMM4)+#  endif+#  if defined(REG_ZMM5)+globalRegMaybe (ZmmReg 5)               = Just (RealRegSingle REG_ZMM5)+#  endif+#  if defined(REG_ZMM6)+globalRegMaybe (ZmmReg 6)               = Just (RealRegSingle REG_ZMM6)+#  endif+# endif+# if defined(REG_Sp)+globalRegMaybe Sp                       = Just (RealRegSingle REG_Sp)+# endif+# if defined(REG_Lng1)+globalRegMaybe (LongReg 1)              = Just (RealRegSingle REG_Lng1)+# endif+# if defined(REG_Lng2)+globalRegMaybe (LongReg 2)              = Just (RealRegSingle REG_Lng2)+# endif+# if defined(REG_SpLim)+globalRegMaybe SpLim                    = Just (RealRegSingle REG_SpLim)+# endif+# if defined(REG_Hp)+globalRegMaybe Hp                       = Just (RealRegSingle REG_Hp)+# endif+# if defined(REG_HpLim)+globalRegMaybe HpLim                    = Just (RealRegSingle REG_HpLim)+# endif+# if defined(REG_CurrentTSO)+globalRegMaybe CurrentTSO               = Just (RealRegSingle REG_CurrentTSO)+# endif+# if defined(REG_CurrentNursery)+globalRegMaybe CurrentNursery           = Just (RealRegSingle REG_CurrentNursery)+# endif+# if defined(REG_MachSp)+globalRegMaybe MachSp                   = Just (RealRegSingle REG_MachSp)+# endif+globalRegMaybe _                        = Nothing+#elif defined(MACHREGS_NO_REGS)+globalRegMaybe _ = Nothing+#else+globalRegMaybe = panic "globalRegMaybe not defined for this platform"+#endif++freeReg :: RegNo -> Bool++#if defined(MACHREGS_i386) || defined(MACHREGS_x86_64)++# if defined(MACHREGS_i386)+freeReg esp = False -- %esp is the C stack pointer+freeReg esi = False -- See Note [esi/edi/ebp not allocatable]+freeReg edi = False+freeReg ebp = False+# endif+# if defined(MACHREGS_x86_64)+freeReg rsp = False  --        %rsp is the C stack pointer+# endif++{-+Note [esi/edi/ebp not allocatable]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+%esi is mapped to R1, so %esi would normally be allocatable while it+is not being used for R1.  However, %esi has no 8-bit version on x86,+and the linear register allocator is not sophisticated enough to+handle this irregularity (we need more RegClasses).  The+graph-colouring allocator also cannot handle this - it was designed+with more flexibility in mind, but the current implementation is+restricted to the same set of classes as the linear allocator.++Hence, on x86 esi, edi and ebp are treated as not allocatable.+-}++-- split patterns in two functions to prevent overlaps+freeReg r         = freeRegBase r++freeRegBase :: RegNo -> Bool+# if defined(REG_Base)+freeRegBase REG_Base  = False+# endif+# if defined(REG_Sp)+freeRegBase REG_Sp    = False+# endif+# if defined(REG_SpLim)+freeRegBase REG_SpLim = False+# endif+# if defined(REG_Hp)+freeRegBase REG_Hp    = False+# endif+# if defined(REG_HpLim)+freeRegBase REG_HpLim = False+# endif+-- All other regs are considered to be "free", because we can track+-- their liveness accurately.+freeRegBase _ = True++#elif defined(MACHREGS_powerpc)++freeReg 0 = False -- Used by code setting the back chain pointer+                  -- in stack reallocations on Linux.+                  -- Moreover r0 is not usable in all insns.+freeReg 1 = False -- The Stack Pointer+-- most ELF PowerPC OSes use r2 as a TOC pointer+freeReg 2 = False+freeReg 13 = False -- reserved for system thread ID on 64 bit+-- at least linux in -fPIC relies on r30 in PLT stubs+freeReg 30 = False+{- TODO: reserve r13 on 64 bit systems only and r30 on 32 bit respectively.+   For now we use r30 on 64 bit and r13 on 32 bit as a temporary register+   in stack handling code. See compiler/GHC/CmmToAsm/PPC/Instr.hs.++   Later we might want to reserve r13 and r30 only where it is required.+   Then use r12 as temporary register, which is also what the C ABI does.+-}++# if defined(REG_Base)+freeReg REG_Base  = False+# endif+# if defined(REG_Sp)+freeReg REG_Sp    = False+# endif+# if defined(REG_SpLim)+freeReg REG_SpLim = False+# endif+# if defined(REG_Hp)+freeReg REG_Hp    = False+# endif+# if defined(REG_HpLim)+freeReg REG_HpLim = False+# endif+freeReg _ = True++#elif defined(MACHREGS_aarch64)++-- stack pointer / zero reg+freeReg 31 = False+-- link register+freeReg 30 = False+-- frame pointer+freeReg 29 = False+-- ip0 -- used for spill offset computations+freeReg 16 = False++# if defined(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
+ 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
@@ -1,4 +1,5 @@-{-# LANGUAGE CPP, NondecreasingIndentation, ScopedTypeVariables #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE NondecreasingIndentation, ScopedTypeVariables #-} {-# LANGUAGE TupleSections, NamedFieldPuns #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE TypeFamilies #-}@@ -24,13 +25,15 @@         runGhc, runGhcT, initGhcMonad,         printException,         handleSourceError,-        needsTemplateHaskellOrQQ,          -- * Flags and settings         DynFlags(..), GeneralFlag(..), Severity(..), Backend(..), gopt,         GhcMode(..), GhcLink(..),         parseDynamicFlags, parseTargetFiles,-        getSessionDynFlags, setSessionDynFlags,+        getSessionDynFlags,+        setTopSessionDynFlags,+        setSessionDynFlags,+        setUnitDynFlags,         getProgramDynFlags, setProgramDynFlags,         getInteractiveDynFlags, setInteractiveDynFlags,         interpretPackageEnv,@@ -52,16 +55,17 @@          -- * Loading\/compiling the program         depanal, depanalE,-        load, LoadHowMuch(..), InteractiveImport(..),+        load, loadWithCache, LoadHowMuch(..), InteractiveImport(..),         SuccessFlag(..), succeeded, failed,         defaultWarnErrLogger, WarnErrLogger,         workingDirectoryChanged,-        parseModule, typecheckModule, desugarModule, loadModule,+        parseModule, typecheckModule, desugarModule,         ParsedModule(..), TypecheckedModule(..), DesugaredModule(..),         TypecheckedSource, ParsedSource, RenamedSource,   -- ditto         TypecheckedMod, ParsedMod,         moduleInfo, renamedSource, typecheckedSource,         parsedSource, coreModule,+        PkgQual(..),          -- ** Compiling to Core         CoreModule(..),@@ -74,6 +78,7 @@         getModSummary,         getModuleGraph,         isLoaded,+        isLoadedModule,         topSortModuleGraph,          -- * Inspecting modules@@ -95,9 +100,6 @@         ModIface, ModIface_(..),         SafeHaskellMode(..), -        -- * Querying the environment-        -- packageDbModules,-         -- * Printing         PrintUnqualified, alwaysQualify, @@ -118,6 +120,8 @@         -- ** Inspecting the current context         getBindings, getInsts, getPrintUnqual,         findModule, lookupModule,+        findQualifiedModule, lookupQualifiedModule,+        renamePkgQualM, renameRawPkgQualM,         isModuleTrusted, moduleTrustReqs,         getNamesInScope,         getRdrNamesInScope,@@ -296,8 +300,6 @@   * inline bits of GHC.Driver.Main here to simplify layering: hscTcExpr, hscStmt. -} -#include "HsVersions.h"- import GHC.Prelude hiding (init)  import GHC.Platform@@ -307,14 +309,17 @@                            , isSourceFilename, startPhase ) import GHC.Driver.Env import GHC.Driver.Errors+import GHC.Driver.Errors.Types import GHC.Driver.CmdLine-import GHC.Driver.Session hiding (WarnReason(..))+import GHC.Driver.Session import GHC.Driver.Backend-import GHC.Driver.Config+import GHC.Driver.Config.Finder (initFinderOpts)+import GHC.Driver.Config.Parser (initParserOpts)+import GHC.Driver.Config.Logger (initLogFlags)+import GHC.Driver.Config.Diagnostic import GHC.Driver.Main import GHC.Driver.Make import GHC.Driver.Hooks-import GHC.Driver.Pipeline   ( compileOne' ) import GHC.Driver.Monad import GHC.Driver.Ppr @@ -322,7 +327,6 @@ import qualified GHC.Linker.Loader as Loader import GHC.Runtime.Loader import GHC.Runtime.Eval-import GHC.Runtime.Eval.Types import GHC.Runtime.Interpreter import GHC.Runtime.Context import GHCi.RemoteTypes@@ -330,17 +334,15 @@ import qualified GHC.Parser as Parser import GHC.Parser.Lexer import GHC.Parser.Annotation-import GHC.Parser.Errors.Ppr import GHC.Parser.Utils  import GHC.Iface.Load        ( loadSysInterface ) import GHC.Hs import GHC.Builtin.Types.Prim ( alphaTyVars )-import GHC.Iface.Tidy-import GHC.Data.Bag        ( listToBag ) 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@@ -359,6 +361,7 @@ 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 )@@ -381,6 +384,7 @@ 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@@ -388,12 +392,12 @@ import GHC.Types.Name.Env import GHC.Types.Name.Ppr import GHC.Types.TypeEnv-import GHC.Types.SourceFile+import GHC.Types.BreakInfo+import GHC.Types.PkgQual  import GHC.Unit import GHC.Unit.Env import GHC.Unit.External-import GHC.Unit.State import GHC.Unit.Finder import GHC.Unit.Module.ModIface import GHC.Unit.Module.ModGuts@@ -405,10 +409,8 @@ import Data.Foldable import qualified Data.Map.Strict as Map import Data.Set (Set)-import qualified Data.Set as S import qualified Data.Sequence as Seq import Data.Maybe-import Data.Time import Data.Typeable    ( Typeable ) import Data.Word        ( Word8 ) import Control.Monad@@ -422,9 +424,10 @@  import GHC.Data.Maybe import System.IO.Error  ( isDoesNotExistError )-import System.Environment ( getEnv )+import System.Environment ( getEnv, getProgName ) import System.Directory import Data.List (isPrefixOf)+import qualified Data.Set as S   -- %************************************************************************@@ -447,19 +450,18 @@            case fromException exception of                 -- an IO exception probably isn't our fault, so don't panic                 Just (ioe :: IOException) ->-                  fatalErrorMsg'' fm (show ioe)+                  fm (show ioe)                 _ -> case fromException exception of                      Just UserInterrupt ->                          -- Important to let this one propagate out so our                          -- calling process knows we were interrupted by ^C                          liftIO $ throwIO UserInterrupt                      Just StackOverflow ->-                         fatalErrorMsg'' fm "stack overflow: use +RTS -K<size> to increase it"+                         fm "stack overflow: use +RTS -K<size> to increase it"                      _ -> case fromException exception of                           Just (ex :: ExitCode) -> liftIO $ throwIO ex                           _ ->-                              fatalErrorMsg'' fm-                                  (show (Panic (show exception)))+                              fm (show (Panic (show exception)))            exitWith (ExitFailure 1)          ) $ @@ -468,9 +470,13 @@             (\ge -> liftIO $ do                 flushOut                 case ge of-                     Signal _ -> exitWith (ExitFailure 1)-                     _ -> do fatalErrorMsg'' fm (show ge)-                             exitWith (ExitFailure 1)+                  Signal _       -> return ()+                  ProgramError _ -> fm (show ge)+                  CmdLineError _ -> fm ("<command line>: " ++ show ge)+                  _              -> do+                                    progName <- getProgName+                                    fm (progName ++ ": " ++ show ge)+                exitWith (ExitFailure 1)             ) $   inner @@ -533,8 +539,9 @@       let logger = hsc_logger hsc_env       let tmpfs  = hsc_tmpfs hsc_env       liftIO $ do-          cleanTempFiles logger tmpfs dflags-          cleanTempDirs logger tmpfs dflags+          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@@ -554,12 +561,7 @@  initGhcMonad :: GhcMonad m => Maybe FilePath -> m () initGhcMonad mb_top_dir-  = do { -- 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 <- liftIO $ c_keepCAFsForGHCi-       ; MASSERT( keep_cafs )-       ; env <- liftIO $+  = do { env <- liftIO $                 do { top_dir <- findTopDir mb_top_dir                    ; mySettings <- initSysTools top_dir                    ; myLlvmConfig <- lazyInitLlvmConfig top_dir@@ -593,10 +595,10 @@  checkBrokenTablesNextToCode' :: MonadIO m => Logger -> DynFlags -> m Bool checkBrokenTablesNextToCode' logger dflags-  | not (isARM arch)                 = return False-  | WayDyn `S.notMember` ways dflags = return False-  | not tablesNextToCode             = return False-  | otherwise                        = do+  | not (isARM arch)               = return False+  | ways dflags `hasNotWay` WayDyn = return False+  | not tablesNextToCode           = return False+  | otherwise                      = do     linkerInfo <- liftIO $ getLinkerInfo logger dflags     case linkerInfo of       GnuLD _  -> return True@@ -605,6 +607,7 @@         arch = platformArch platform         tablesNextToCode = platformTablesNextToCode platform + -- %************************************************************************ -- %*                                                                      * --             Flags & settings@@ -632,22 +635,85 @@ -- 'setSessionDynFlags' sets both @DynFlags@, and 'getSessionDynFlags' -- retrieves the program @DynFlags@ (for backwards compatibility). ---- | Updates both the interactive and program DynFlags in a Session.--- This also reads the package database (unless it has already been--- read), and prepares the compilers knowledge about packages.  It can--- be called again to load new packages: just add new package flags to--- (packageFlags dflags).-setSessionDynFlags :: GhcMonad m => DynFlags -> m ()+-- This is a compatability 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 (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 cached_unit_dbs = hsc_unit_dbs hsc_env-  (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 cached_unit_dbs -  dflags <- liftIO $ updatePlatformConstants dflags1 mconstants+  let old_hue = ue_findHomeUnitEnv uid (hsc_unit_env hsc_env)+  let cached_unit_dbs = homeUnitEnv_unit_dbs old_hue+  (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 cached_unit_dbs (hsc_all_home_unit_ids hsc_env)+  updated_dflags <- liftIO $ updatePlatformConstants dflags1 mconstants +  let upd hue =+       hue+          { homeUnitEnv_units = unit_state+          , homeUnitEnv_unit_dbs = Just dbs+          , homeUnitEnv_dflags = updated_dflags+          , homeUnitEnv_home_unit = Just home_unit+          }++  let unit_env = ue_updateHomeUnitEnv upd uid (hsc_unit_env hsc_env)++  let dflags = updated_dflags++  let unit_env0 = unit_env+        { ue_platform        = targetPlatform dflags+        , ue_namever         = ghcNameVersion dflags+        }++  -- if necessary, change the key for the currently active unit+  -- as the dynflags might have been changed++  -- This function is called on every --make invocation because at the start of+  -- the session there is one fake unit called main which is immediately replaced+  -- after the DynFlags are parsed.+  let !unit_env1 =+        if homeUnitId_ dflags /= uid+          then+            ue_renameUnitId+                  uid+                  (homeUnitId_ dflags)+                  unit_env0+          else unit_env0++  modifySession $ \h -> h{ hsc_unit_env  = unit_env1+                         }++  invalidateModSummaryCache+++++setTopSessionDynFlags :: GhcMonad m => DynFlags -> m ()+setTopSessionDynFlags dflags = do+  hsc_env <- getSession+  logger  <- getLogger+   -- Interpreter   interp <- if gopt Opt_ExternalInterpreter dflags     then do@@ -661,7 +727,7 @@              | otherwise = ""            msg = text "Starting " <> text prog          tr <- if verbosity dflags >= 3-                then return (logInfo logger dflags $ withPprStyle defaultDumpStyle msg)+                then return (logInfo logger $ withPprStyle defaultDumpStyle msg)                 else return (pure ())          let           conf = IServConfig@@ -684,20 +750,12 @@       return Nothing #endif -  let unit_env = UnitEnv-        { ue_platform  = targetPlatform dflags-        , ue_namever   = ghcNameVersion dflags-        , ue_home_unit = home_unit-        , ue_units     = unit_state-        }-  modifySession $ \h -> h{ hsc_dflags = dflags-                         , hsc_IC = (hsc_IC h){ ic_dflags = dflags }++  modifySession $ \h -> hscSetFlags dflags+                        h{ hsc_IC = (hsc_IC h){ ic_dflags = dflags }                          , hsc_interp = hsc_interp h <|> interp-                           -- we only update the interpreter if there wasn't-                           -- already one set up-                         , hsc_unit_env = unit_env-                         , hsc_unit_dbs = Just dbs                          }+   invalidateModSummaryCache  -- | Sets the program 'DynFlags'.  Note: this invalidates the internal@@ -717,23 +775,37 @@   let changed = packageFlagsChanged dflags_prev dflags0   if changed     then do-        hsc_env <- getSession-        let cached_unit_dbs = hsc_unit_dbs hsc_env-        (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags0 cached_unit_dbs+        -- additionally, set checked dflags so we don't lose fixes+        old_unit_env <- ue_setFlags dflags0 . hsc_unit_env <$> getSession -        dflags1 <- liftIO $ updatePlatformConstants dflags0 mconstants+        home_unit_graph <- forM (ue_home_unit_graph old_unit_env) $ \homeUnitEnv -> do+          let cached_unit_dbs = homeUnitEnv_unit_dbs homeUnitEnv+              dflags = homeUnitEnv_dflags homeUnitEnv+              old_hpt = homeUnitEnv_hpt homeUnitEnv+              home_units = unitEnv_keys (ue_home_unit_graph old_unit_env) +          (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags cached_unit_dbs home_units++          updated_dflags <- liftIO $ updatePlatformConstants dflags0 mconstants+          pure HomeUnitEnv+            { homeUnitEnv_units = unit_state+            , homeUnitEnv_unit_dbs = Just dbs+            , homeUnitEnv_dflags = updated_dflags+            , homeUnitEnv_hpt = old_hpt+            , homeUnitEnv_home_unit = Just home_unit+            }++        let dflags1 = homeUnitEnv_dflags $ unitEnv_lookup (ue_currentUnit old_unit_env) home_unit_graph         let unit_env = UnitEnv-              { ue_platform  = targetPlatform dflags1-              , ue_namever   = ghcNameVersion dflags1-              , ue_home_unit = home_unit-              , ue_units     = unit_state+              { ue_platform        = targetPlatform dflags1+              , ue_namever         = ghcNameVersion dflags1+              , ue_home_unit_graph = home_unit_graph+              , ue_current_unit    = ue_currentUnit old_unit_env+              , ue_eps             = ue_eps old_unit_env               }-        modifySession $ \h -> h{ hsc_dflags   = dflags1-                               , hsc_unit_dbs = Just dbs-                               , hsc_unit_env = unit_env-                               }-    else modifySession $ \h -> h{ hsc_dflags = dflags0 }+        modifySession $ \h -> hscSetFlags dflags1 h{ hsc_unit_env = unit_env }+    else modifySession (hscSetFlags dflags0)+   when invalidate_needed $ invalidateModSummaryCache   return changed @@ -750,7 +822,7 @@ -- old log_action.  This is definitely wrong (#7478). -- -- Hence, we invalidate the ModSummary cache after changing the--- DynFlags.  We do this by tweaking the date on each ModSummary, so+-- 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@@ -761,7 +833,7 @@ invalidateModSummaryCache =   modifySession $ \h -> h { hsc_mod_graph = mapMG inval (hsc_mod_graph h) }  where-  inval ms = ms { ms_hs_date = addUTCTime (-1) (ms_hs_date ms) }+  inval ms = ms { ms_hs_hash = fingerprint0 }  -- | Returns the program 'DynFlags'. getProgramDynFlags :: GhcMonad m => m DynFlags@@ -808,7 +880,10 @@     -> m (DynFlags, [Located String], [Warn]) parseDynamicFlags logger dflags cmdline = do   (dflags1, leftovers, warns) <- parseDynamicFlagsCmdLine dflags cmdline-  dflags2 <- liftIO $ interpretPackageEnv logger dflags1+  -- 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.@@ -819,7 +894,8 @@ parseTargetFiles dflags0 fileish_args =   let     normal_fileish_paths = map normalise_hyp fileish_args-    (srcs, objs)         = partition_args normal_fileish_paths [] []+    (srcs, raw_objs)         = partition_args normal_fileish_paths [] []+    objs = map (augmentByWorkingDirectory dflags0) raw_objs      dflags1 = dflags0 { ldInputs = map (FileOption "") objs                                    ++ ldInputs dflags0 }@@ -901,7 +977,8 @@ checkNewDynFlags logger dflags = do   -- See Note [DynFlags consistency]   let (dflags', warnings) = makeDynFlagsConsistent dflags-  liftIO $ handleFlagWarnings logger dflags (map (Warn NoReason) warnings)+  let diag_opts = initDiagOpts dflags+  liftIO $ handleFlagWarnings logger diag_opts (map (Warn WarningWithoutFlag) warnings)   return dflags'  checkNewInteractiveDynFlags :: MonadIO m => Logger -> DynFlags -> m DynFlags@@ -909,10 +986,12 @@   -- We currently don't support use of StaticPointers in expressions entered on   -- the REPL. See #12356.   if xopt LangExt.StaticPointers dflags0-  then do liftIO $ printOrThrowWarnings logger dflags0 $ listToBag-            [mkPlainWarnMsg interactiveSrcSpan-             $ text "StaticPointers is not supported in GHCi interactive expressions."]-          return $ xopt_unset dflags0 LangExt.StaticPointers+  then do+    let diag_opts = initDiagOpts dflags0+    liftIO $ printOrThrowDiagnostics logger diag_opts $ singleMessage+      $ fmap GhcDriverMessage+      $ mkPlainMsgEnvelope diag_opts interactiveSrcSpan DriverStaticPointersNotSupported+    return $ xopt_unset dflags0 LangExt.StaticPointers   else return dflags0  @@ -946,7 +1025,7 @@ removeTarget target_id   = modifySession (\h -> h{ hsc_targets = filter (hsc_targets h) })   where-   filter targets = [ t | t@(Target id _ _) <- targets, id /= target_id ]+   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:@@ -959,23 +1038,25 @@ -- --   - otherwise interpret the string as a module name ---guessTarget :: GhcMonad m => String -> Maybe Phase -> m Target-guessTarget str (Just phase)-   = return (Target (TargetFile str (Just phase)) True Nothing)-guessTarget str Nothing+guessTarget :: GhcMonad m => String -> Maybe UnitId -> Maybe Phase -> m Target+guessTarget str mUnitId (Just phase)+   = do+     tuid <- unitIdOrHomeUnit mUnitId+     return (Target (TargetFile str (Just phase)) True tuid Nothing)+guessTarget str mUnitId Nothing    | isHaskellSrcFilename file-   = return (target (TargetFile file Nothing))+   = target (TargetFile file Nothing)    | otherwise    = do exists <- liftIO $ doesFileExist hs_file         if exists-           then return (target (TargetFile hs_file Nothing))+           then target (TargetFile hs_file Nothing)            else do         exists <- liftIO $ doesFileExist lhs_file         if exists-           then return (target (TargetFile lhs_file Nothing))+           then target (TargetFile lhs_file Nothing)            else do         if looksLikeModuleName file-           then return (target (TargetModule (mkModuleName file)))+           then target (TargetModule (mkModuleName file))            else do         dflags <- getDynFlags         liftIO $ throwGhcExceptionIO@@ -990,8 +1071,16 @@          hs_file  = file <.> "hs"          lhs_file = file <.> "lhs" -         target tid = Target tid obj_allowed Nothing+         target tid = do+           tuid <- unitIdOrHomeUnit mUnitId+           pure $ Target tid obj_allowed tuid Nothing +-- | Unwrap 'UnitId' or retrieve the 'UnitId'+-- of the current 'HomeUnit'.+unitIdOrHomeUnit :: GhcMonad m => Maybe UnitId -> m UnitId+unitIdOrHomeUnit mUnitId = do+  currentHomeUnitId <- homeUnitId . hsc_home_unit <$> getSession+  pure (fromMaybe currentHomeUnitId mUnitId)  -- | Inform GHC that the working directory has changed.  GHC will flush -- its cache of module locations, since it may no longer be valid.@@ -1001,7 +1090,9 @@ -- you should also unload the current program (set targets to empty, -- followed by load). workingDirectoryChanged :: GhcMonad m => m ()-workingDirectoryChanged = withSession $ (liftIO . flushFinderCaches)+workingDirectoryChanged = do+  hsc_env <- getSession+  liftIO $ flushFinderCaches (hsc_FC hsc_env) (hsc_unit_env hsc_env)   -- %************************************************************************@@ -1080,7 +1171,7 @@  type ParsedSource      = Located HsModule type RenamedSource     = (HsGroup GhcRn, [LImportDecl GhcRn], Maybe [(LIE GhcRn, Avails)],-                          Maybe LHsDocString)+                          Maybe (LHsDoc GhcRn)) type TypecheckedSource = LHsBinds GhcTc  -- NOTE:@@ -1122,9 +1213,10 @@ parseModule :: GhcMonad m => ModSummary -> m ParsedModule parseModule ms = do    hsc_env <- getSession-   let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms }-   hpm <- liftIO $ hscParse hsc_env_tmp ms-   return (ParsedModule ms (hpm_module hpm) (hpm_src_files hpm))+   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.@@ -1132,17 +1224,20 @@ -- Throws a 'SourceError' if either fails. typecheckModule :: GhcMonad m => ParsedModule -> m TypecheckedModule typecheckModule pmod = do- let ms = modSummary pmod  hsc_env <- getSession- let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms }- (tc_gbl_env, rn_info)-       <- liftIO $ hscTypecheckRename hsc_env_tmp ms $-                      HsParsedModule { hpm_module = parsedSource pmod,-                                       hpm_src_files = pm_extra_src_files pmod }- details <- liftIO $ makeSimpleDetails hsc_env_tmp tc_gbl_env- safe    <- liftIO $ finalSafeMode (ms_hspp_opts ms) tc_gbl_env - return $+ liftIO $ do+   let ms          = modSummary pmod+   let lcl_dflags  = ms_hspp_opts ms -- take into account pragmas (OPTIONS_GHC, etc.)+   let lcl_hsc_env = hscSetFlags lcl_dflags hsc_env+   let lcl_logger  = hsc_logger lcl_hsc_env+   (tc_gbl_env, rn_info) <- hscTypecheckRename lcl_hsc_env ms $+                        HsParsedModule { hpm_module = parsedSource pmod,+                                         hpm_src_files = pm_extra_src_files pmod }+   details <- makeSimpleDetails lcl_logger tc_gbl_env+   safe    <- finalSafeMode lcl_dflags tc_gbl_env++   return $      TypecheckedModule {        tm_internals_          = (tc_gbl_env, details),        tm_parsed_module       = pmod,@@ -1153,7 +1248,7 @@            minf_type_env  = md_types details,            minf_exports   = md_exports details,            minf_rdr_env   = Just (tcg_rdr_env tc_gbl_env),-           minf_instances = fixSafeInstances safe $ md_insts details,+           minf_instances = fixSafeInstances safe $ instEnvElts $ md_insts details,            minf_iface     = Nothing,            minf_safe      = safe,            minf_modBreaks = emptyModBreaks@@ -1162,54 +1257,20 @@ -- | Desugar a typechecked module. desugarModule :: GhcMonad m => TypecheckedModule -> m DesugaredModule desugarModule tcm = do- let ms = modSummary tcm- let (tcg, _) = tm_internals tcm  hsc_env <- getSession- let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms }- guts <- liftIO $ hscDesugar hsc_env_tmp ms tcg- return $+ 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      } --- | Load a module.  Input doesn't need to be desugared.------ A module must be loaded before dependent modules can be typechecked.  This--- always includes generating a 'ModIface' and, depending on the--- @DynFlags@\'s 'GHC.Driver.Session.backend', may also include code generation.------ This function will always cause recompilation and will always overwrite--- previous compilation results (potentially files on disk).----loadModule :: (TypecheckedMod mod, GhcMonad m) => mod -> m mod-loadModule tcm = do-   let ms = modSummary tcm-   let mod = ms_mod_name ms-   let loc = ms_location ms-   let (tcg, _details) = tm_internals tcm -   mb_linkable <- case ms_obj_date ms of-                     Just t | t > ms_hs_date ms  -> do-                         l <- liftIO $ findObjectLinkable (ms_mod ms)-                                                  (ml_obj_file loc) t-                         return (Just l)-                     _otherwise -> return Nothing -   let source_modified | isNothing mb_linkable = SourceModified-                       | otherwise             = SourceUnmodified-                       -- we can't determine stability here--   -- compile doesn't change the session-   hsc_env <- getSession-   mod_info <- liftIO $ compileOne' (Just tcg) Nothing-                                    hsc_env ms 1 1 Nothing mb_linkable-                                    source_modified--   modifySession $ \e -> e{ hsc_HPT = addToHpt (hsc_HPT e) mod mod_info }-   return tcm-- -- %************************************************************************ -- %*                                                                      * --             Dealing with Core@@ -1252,7 +1313,7 @@ compileCore :: GhcMonad m => Bool -> FilePath -> m CoreModule compileCore simplify fn = do    -- First, set the target to the desired filename-   target <- guessTarget fn Nothing+   target <- guessTarget fn Nothing Nothing    addTarget target    _ <- load LoadAllTargets    -- Then find dependencies@@ -1269,12 +1330,12 @@          if simplify           then do              -- If simplify is true: simplify (hscSimplify), then tidy-             -- (tidyProgram).+             -- (hscTidy).              hsc_env <- getSession              simpl_guts <- liftIO $ do                plugins <- readIORef (tcg_th_coreplugins tcg)                hscSimplify hsc_env plugins mod_guts-             tidy_guts <- liftIO $ tidyProgram hsc_env simpl_guts+             tidy_guts <- liftIO $ hscTidy hsc_env simpl_guts              return $ Left tidy_guts           else              return $ Right mod_guts@@ -1317,6 +1378,10 @@ isLoaded m = withSession $ \hsc_env ->   return $! isJust (lookupHpt (hsc_HPT hsc_env) m) +isLoadedModule :: GhcMonad m => UnitId -> ModuleName -> m Bool+isLoadedModule uid m = withSession $ \hsc_env ->+  return $! isJust (lookupHug (hsc_HUG hsc_env) uid m)+ -- | Return the bindings for the current interactive session. getBindings :: GhcMonad m => m [TyThing] getBindings = withSession $ \hsc_env ->@@ -1325,7 +1390,8 @@ -- | Return the instances for the current interactive session. getInsts :: GhcMonad m => m ([ClsInst], [FamInst]) getInsts = withSession $ \hsc_env ->-    return $ ic_instances (hsc_IC hsc_env)+    let (inst_env, fam_env) = ic_instances (hsc_IC hsc_env)+    in return (instEnvElts inst_env, fam_env)  getPrintUnqual :: GhcMonad m => m PrintUnqualified getPrintUnqual = withSession $ \hsc_env -> do@@ -1344,22 +1410,13 @@         -- We don't want HomeModInfo here, because a ModuleInfo applies         -- to package modules too. + -- | Request information about a loaded 'Module' getModuleInfo :: GhcMonad m => Module -> m (Maybe ModuleInfo)  -- XXX: Maybe X getModuleInfo mdl = withSession $ \hsc_env -> do-  let mg = hsc_mod_graph hsc_env-  if mgElemModule mg mdl+  if moduleUnitId mdl `S.member` hsc_all_home_unit_ids hsc_env         then liftIO $ getHomeModuleInfo hsc_env mdl-        else do-  {- if isHomeModule (hsc_dflags hsc_env) mdl-        then return Nothing-        else -} liftIO $ getPackageModuleInfo hsc_env mdl-   -- ToDo: we don't understand what the following comment means.-   --    (SDM, 19/7/2011)-   -- getPackageModuleInfo will attempt to find the interface, so-   -- we don't want to call it for a home module, just in case there-   -- was a problem loading the module and the interface doesn't-   -- exist... hence the isHomeModule test here.  (ToDo: reinstate)+        else liftIO $ getPackageModuleInfo hsc_env mdl  getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo) getPackageModuleInfo hsc_env mdl@@ -1395,7 +1452,7 @@  getHomeModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo) getHomeModuleInfo hsc_env mdl =-  case lookupHpt (hsc_HPT hsc_env) (moduleName mdl) of+  case lookupHugByModule mdl (hsc_HUG hsc_env) of     Nothing  -> return Nothing     Just hmi -> do       let details = hm_details hmi@@ -1404,7 +1461,7 @@                         minf_type_env  = md_types details,                         minf_exports   = md_exports details,                         minf_rdr_env   = mi_globals $! hm_iface hmi,-                        minf_instances = md_insts details,+                        minf_instances = instEnvElts $ md_insts details,                         minf_iface     = Just iface,                         minf_safe      = getSafeMode $ mi_trust iface                        ,minf_modBreaks = getModBreaks hmi@@ -1480,7 +1537,7 @@  -- | get the GlobalRdrEnv for a session getGRE :: GhcMonad m => m GlobalRdrEnv-getGRE = withSession $ \hsc_env-> return $ ic_rn_gbl_env (hsc_IC hsc_env)+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@@ -1490,7 +1547,7 @@                      -- 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 DecoratedSDoc, Maybe (NameEnv ([ClsInst], [FamInst])))+  -> m (Messages TcRnMessage, Maybe (NameEnv ([ClsInst], [FamInst]))) getNameToInstancesIndex visible_mods mods_to_load = do   hsc_env <- getSession   liftIO $ runTcInteractive hsc_env $@@ -1525,27 +1582,6 @@            ] }  -- -------------------------------------------------------------------------------{- ToDo: Move the primary logic here to "GHC.Unit.State"--- | Return all /external/ modules available in the package database.--- Modules from the current session (i.e., from the 'HomePackageTable') are--- not included.  This includes module names which are reexported by packages.-packageDbModules :: GhcMonad m =>-                    Bool  -- ^ Only consider exposed packages.-                 -> m [Module]-packageDbModules only_exposed = do-   dflags <- getSessionDynFlags-   let pkgs = eltsUFM (unitInfoMap (unitState dflags))-   return $-     [ mkModule pid modname-     | p <- pkgs-     , not only_exposed || exposed p-     , let pid = mkUnit p-     , modname <- exposedModules p-               ++ map exportName (reexportedModules p) ]-               -}---- ----------------------------------------------------------------------------- -- Misc exported utils  dataConType :: DataCon -> Type@@ -1571,42 +1607,43 @@ -- on whether the module is interpreted or not.  --- Extract the filename, stringbuffer content and dynflags associed to a module+-- 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 :: GhcMonad m => Module -> m (String, StringBuffer, DynFlags)-getModuleSourceAndFlags mod = do-  m <- getModSummary (moduleName mod)+getModuleSourceAndFlags :: ModSummary -> IO (String, StringBuffer, DynFlags)+getModuleSourceAndFlags m = do   case ml_hs_file $ ms_location m of-    Nothing -> do dflags <- getDynFlags-                  liftIO $ throwIO $ mkApiErr dflags (text "No source available for module " <+> ppr mod)+    Nothing -> throwIO $ mkApiErr (ms_hspp_opts m) (text "No source available for module " <+> ppr (ms_mod m))     Just sourceFile -> do-        source <- liftIO $ hGetStringBuffer sourceFile+        source <- hGetStringBuffer sourceFile         return (sourceFile, source, ms_hspp_opts m)   -- | Return module source as token stream, including comments. ----- The module must be in the module graph and its source must be available.+-- 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 :: GhcMonad m => Module -> m [Located Token]+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 (fmap pprError (getErrorMessages pst))+    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 :: GhcMonad m => Module -> m [(Located Token, String)]+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 (fmap pprError (getErrorMessages pst))+    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@@ -1662,32 +1699,46 @@ -- filesystem and package database to find the corresponding 'Module', -- using the algorithm that is used for an @import@ declaration. findModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module-findModule mod_name maybe_pkg = withSession $ \hsc_env -> do-  let dflags     = hsc_dflags hsc_env-      home_unit  = hsc_home_unit hsc_env-  case maybe_pkg of-    Just pkg | not (isHomeUnit home_unit (fsToUnit pkg)) && pkg /= fsLit "this" -> liftIO $ do-      res <- findImportedModule hsc_env mod_name maybe_pkg-      case res of-        Found _ m -> return m-        err       -> throwOneError $ noModError hsc_env noSrcSpan mod_name err-    _otherwise -> do-      home <- lookupLoadedHomeModule mod_name+findModule mod_name maybe_pkg = do+  pkg_qual <- renamePkgQualM mod_name maybe_pkg+  findQualifiedModule pkg_qual mod_name+++findQualifiedModule :: GhcMonad m => PkgQual -> ModuleName -> m Module+findQualifiedModule pkgqual mod_name = withSession $ \hsc_env -> do+  let mhome_unit = hsc_home_unit_maybe hsc_env+  let dflags    = hsc_dflags hsc_env+  case pkgqual of+    ThisPkg uid -> do+      home <- lookupLoadedHomeModule uid mod_name       case home of         Just m  -> return m         Nothing -> liftIO $ do-           res <- findImportedModule hsc_env mod_name maybe_pkg+           res <- findImportedModule hsc_env mod_name pkgqual            case res of-             Found loc m | not (isHomeModule home_unit m) -> return m+             Found loc m | notHomeModuleMaybe mhome_unit m -> return m                          | otherwise -> modNotLoadedError dflags m loc              err -> throwOneError $ noModError hsc_env noSrcSpan mod_name err +    _ -> liftIO $ do+      res <- findImportedModule hsc_env mod_name pkgqual+      case res of+        Found _ m -> return m+        err       -> throwOneError $ noModError hsc_env noSrcSpan mod_name err++ modNotLoadedError :: DynFlags -> Module -> ModLocation -> IO a modNotLoadedError dflags m loc = throwGhcExceptionIO $ CmdLineError $ showSDoc dflags $    text "module is not loaded:" <+>    quotes (ppr (moduleName m)) <+>    parens (text (expectJust "modNotLoadedError" (ml_hs_file loc))) +renamePkgQualM :: GhcMonad m => ModuleName -> Maybe FastString -> m PkgQual+renamePkgQualM mn p = withSession $ \hsc_env -> pure (renamePkgQual (hsc_unit_env hsc_env) mn p)++renameRawPkgQualM :: GhcMonad m => ModuleName -> RawPkgQual -> m PkgQual+renameRawPkgQualM mn p = withSession $ \hsc_env -> pure (renameRawPkgQual (hsc_unit_env hsc_env) mn p)+ -- | Like 'findModule', but differs slightly when the module refers to -- a source file, and the file has not been loaded via 'load'.  In -- this case, 'findModule' will throw an error (module not loaded),@@ -1696,20 +1747,29 @@ -- returned.  If not, the usual module-not-found error will be thrown. -- lookupModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module-lookupModule mod_name (Just pkg) = findModule mod_name (Just pkg)-lookupModule mod_name Nothing = withSession $ \hsc_env -> do-  home <- lookupLoadedHomeModule mod_name+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-      res <- findExposedPackageModule hsc_env mod_name Nothing+      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 => ModuleName -> m (Maybe Module)-lookupLoadedHomeModule mod_name = withSession $ \hsc_env ->-  case lookupHpt (hsc_HPT hsc_env) mod_name of+lookupLoadedHomeModule :: GhcMonad m => UnitId -> ModuleName -> m (Maybe Module)+lookupLoadedHomeModule uid mod_name = withSession $ \hsc_env ->+  case lookupHug  (hsc_HUG hsc_env) uid mod_name  of     Just mod_info      -> return (Just (mi_module (hm_iface mod_info)))     _not_a_home_module -> return Nothing @@ -1780,12 +1840,12 @@    case unP Parser.parseModule (initParserState (initParserOpts dflags) buf loc) of       PFailed pst ->-         let (warns,errs) = getMessages pst in-         (fmap pprWarning warns, Left (fmap pprError errs))+         let (warns,errs) = getPsMessages pst in+         (GhcPsMessage <$> warns, Left $ GhcPsMessage <$> errs)       POk pst rdr_module ->-         let (warns,_) = getMessages pst in-         (fmap pprWarning warns, Right rdr_module)+         let (warns,_) = getPsMessages pst in+         (GhcPsMessage <$> warns, Right rdr_module)  -- ----------------------------------------------------------------------------- -- | Find the package environment (if one exists)@@ -1844,8 +1904,8 @@         return dflags       Just envfile -> do         content <- readFile envfile-        compilationProgressMsg logger dflags (text "Loaded package environment from " <> text envfile)-        let (_, dflags') = runCmdLine (runEwM (setFlagsFromEnvFile envfile content)) dflags+        compilationProgressMsg logger (text "Loaded package environment from " <> text envfile)+        let (_, dflags') = runCmdLineP (runEwM (setFlagsFromEnvFile envfile content)) dflags          return dflags'   where@@ -1934,6 +1994,3 @@  mkApiErr :: DynFlags -> SDoc -> GhcApiError mkApiErr dflags msg = GhcApiError (showSDoc dflags msg)--foreign import ccall unsafe "keepCAFsForGHCi"-    c_keepCAFsForGHCi   :: IO Bool
GHC/Builtin/Names.hs view
@@ -133,8 +133,6 @@    ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Unit.Types@@ -221,7 +219,6 @@         monoidClassName, memptyName, mappendName, mconcatName,          -- The IO type-        -- See Note [TyConRepNames for non-wired-in TyCons]         ioTyConName, ioDataConName,         runMainIOName,         runRWName,@@ -261,6 +258,9 @@         starArrStarKindRepName,         starArrStarArrStarKindRepName, +        -- WithDict+        withDictClassName,+         -- Dynamic         toDynName, @@ -323,6 +323,7 @@          -- Strings and lists         unpackCStringName, unpackCStringUtf8Name,+        unpackCStringAppendName, unpackCStringAppendUtf8Name,         unpackCStringFoldrName, unpackCStringFoldrUtf8Name,         cstringLengthName, @@ -346,10 +347,9 @@          -- Others         otherwiseIdName, inlineIdName,-        eqStringName, assertName, breakpointName, breakpointCondName,-        opaqueTyConName,+        eqStringName, assertName,         assertErrorName, traceName,-        printName, fstName, sndName,+        printName,         dollarName,          -- ghc-bignum@@ -368,15 +368,7 @@         integerMulName,         integerSubName,         integerNegateName,-        integerEqName,-        integerNeName,-        integerLeName,-        integerGtName,-        integerLtName,-        integerGeName,         integerAbsName,-        integerSignumName,-        integerCompareName,         integerPopCountName,         integerQuotName,         integerRemName,@@ -398,14 +390,6 @@         integerShiftRName,          naturalToWordName,-        naturalToWordClampName,-        naturalEqName,-        naturalNeName,-        naturalGeName,-        naturalLeName,-        naturalGtName,-        naturalLtName,-        naturalCompareName,         naturalPopCountName,         naturalShiftRName,         naturalShiftLName,@@ -414,8 +398,6 @@         naturalSubThrowName,         naturalSubUnsafeName,         naturalMulName,-        naturalSignumName,-        naturalNegateName,         naturalQuotRemName,         naturalQuotName,         naturalRemName,@@ -434,6 +416,7 @@         naturalSizeInBaseName,          bignatFromWordListName,+        bignatEqName,          -- Float/Double         integerToFloatName,@@ -474,6 +457,9 @@         -- The Either type         , eitherTyConName, leftDataConName, rightDataConName +        -- The Void type+        , voidTyConName+         -- Plugins         , pluginTyConName         , frontendPluginTyConName@@ -519,7 +505,7 @@     k1TyConName, m1TyConName, sumTyConName, prodTyConName,     compTyConName, rTyConName, dTyConName,     cTyConName, sTyConName, rec0TyConName,-    d1TyConName, c1TyConName, s1TyConName, noSelTyConName,+    d1TyConName, c1TyConName, s1TyConName,     repTyConName, rep1TyConName, uRecTyConName,     uAddrTyConName, uCharTyConName, uDoubleTyConName,     uFloatTyConName, uIntTyConName, uWordTyConName,@@ -547,21 +533,21 @@ pRELUDE         = mkBaseModule_ pRELUDE_NAME  gHC_PRIM, gHC_PRIM_PANIC, gHC_PRIM_EXCEPTION,-    gHC_TYPES, gHC_GENERICS, gHC_MAGIC,+    gHC_TYPES, gHC_GENERICS, gHC_MAGIC, gHC_MAGIC_DICT,     gHC_CLASSES, gHC_PRIMOPWRAPPERS, gHC_BASE, gHC_ENUM,     gHC_GHCI, gHC_GHCI_HELPERS, gHC_CSTRING,     gHC_SHOW, gHC_READ, gHC_NUM, gHC_MAYBE,     gHC_NUM_INTEGER, gHC_NUM_NATURAL, gHC_NUM_BIGNAT,-    gHC_LIST, gHC_TUPLE, dATA_TUPLE, dATA_EITHER, dATA_LIST, dATA_STRING,+    gHC_LIST, gHC_TUPLE, dATA_EITHER, dATA_VOID, dATA_LIST, dATA_STRING,     dATA_FOLDABLE, dATA_TRAVERSABLE,     gHC_CONC, gHC_IO, gHC_IO_Exception,     gHC_ST, gHC_IX, gHC_STABLE, gHC_PTR, gHC_ERR, gHC_REAL,     gHC_FLOAT, gHC_TOP_HANDLER, sYSTEM_IO, dYNAMIC,     tYPEABLE, tYPEABLE_INTERNAL, gENERICS,     rEAD_PREC, lEX, gHC_INT, gHC_WORD, mONAD, mONAD_FIX, mONAD_ZIP, mONAD_FAIL,-    aRROW, cONTROL_APPLICATIVE, gHC_DESUGAR, rANDOM, gHC_EXTS,-    cONTROL_EXCEPTION_BASE, gHC_TYPELITS, gHC_TYPELITS_INTERNAL,-    gHC_TYPENATS, gHC_TYPENATS_INTERNAL, dATA_TYPE_EQUALITY,+    aRROW, gHC_DESUGAR, rANDOM, gHC_EXTS, gHC_IS_LIST,+    cONTROL_EXCEPTION_BASE, gHC_TYPEERROR, gHC_TYPELITS, gHC_TYPELITS_INTERNAL,+    gHC_TYPENATS, gHC_TYPENATS_INTERNAL,     dATA_COERCE, dEBUG_TRACE, uNSAFE_COERCE :: Module  gHC_PRIM        = mkPrimModule (fsLit "GHC.Prim")   -- Primitive types and values@@ -569,6 +555,7 @@ gHC_PRIM_EXCEPTION = mkPrimModule (fsLit "GHC.Prim.Exception") gHC_TYPES       = mkPrimModule (fsLit "GHC.Types") gHC_MAGIC       = mkPrimModule (fsLit "GHC.Magic")+gHC_MAGIC_DICT  = mkPrimModule (fsLit "GHC.Magic.Dict") gHC_CSTRING     = mkPrimModule (fsLit "GHC.CString") gHC_CLASSES     = mkPrimModule (fsLit "GHC.Classes") gHC_PRIMOPWRAPPERS = mkPrimModule (fsLit "GHC.PrimopWrappers")@@ -586,8 +573,8 @@ gHC_NUM_BIGNAT  = mkBignumModule (fsLit "GHC.Num.BigNat") gHC_LIST        = mkBaseModule (fsLit "GHC.List") gHC_TUPLE       = mkPrimModule (fsLit "GHC.Tuple")-dATA_TUPLE      = mkBaseModule (fsLit "Data.Tuple") dATA_EITHER     = mkBaseModule (fsLit "Data.Either")+dATA_VOID       = mkBaseModule (fsLit "Data.Void") dATA_LIST       = mkBaseModule (fsLit "Data.List") dATA_STRING     = mkBaseModule (fsLit "Data.String") dATA_FOLDABLE   = mkBaseModule (fsLit "Data.Foldable")@@ -617,17 +604,17 @@ mONAD_ZIP       = mkBaseModule (fsLit "Control.Monad.Zip") mONAD_FAIL      = mkBaseModule (fsLit "Control.Monad.Fail") aRROW           = mkBaseModule (fsLit "Control.Arrow")-cONTROL_APPLICATIVE = mkBaseModule (fsLit "Control.Applicative") gHC_DESUGAR = mkBaseModule (fsLit "GHC.Desugar") rANDOM          = mkBaseModule (fsLit "System.Random") gHC_EXTS        = mkBaseModule (fsLit "GHC.Exts")+gHC_IS_LIST     = mkBaseModule (fsLit "GHC.IsList") cONTROL_EXCEPTION_BASE = mkBaseModule (fsLit "Control.Exception.Base") gHC_GENERICS    = mkBaseModule (fsLit "GHC.Generics")+gHC_TYPEERROR   = mkBaseModule (fsLit "GHC.TypeError") gHC_TYPELITS    = mkBaseModule (fsLit "GHC.TypeLits") gHC_TYPELITS_INTERNAL = mkBaseModule (fsLit "GHC.TypeLits.Internal") gHC_TYPENATS    = mkBaseModule (fsLit "GHC.TypeNats") gHC_TYPENATS_INTERNAL = mkBaseModule (fsLit "GHC.TypeNats.Internal")-dATA_TYPE_EQUALITY = mkBaseModule (fsLit "Data.Type.Equality") dATA_COERCE     = mkBaseModule (fsLit "Data.Coerce") dEBUG_TRACE     = mkBaseModule (fsLit "Debug.Trace") uNSAFE_COERCE   = mkBaseModule (fsLit "Unsafe.Coerce")@@ -665,10 +652,6 @@ pRELUDE_NAME   = mkModuleNameFS (fsLit "Prelude") mAIN_NAME      = mkModuleNameFS (fsLit "Main") -dATA_ARRAY_PARALLEL_NAME, dATA_ARRAY_PARALLEL_PRIM_NAME :: ModuleName-dATA_ARRAY_PARALLEL_NAME      = mkModuleNameFS (fsLit "Data.Array.Parallel")-dATA_ARRAY_PARALLEL_PRIM_NAME = mkModuleNameFS (fsLit "Data.Array.Parallel.Prim")- mkPrimModule :: FastString -> Module mkPrimModule m = mkModule primUnit (mkModuleNameFS m) @@ -760,14 +743,6 @@ ioDataCon_RDR :: RdrName ioDataCon_RDR           = nameRdrName ioDataConName -eqString_RDR, unpackCString_RDR, unpackCStringFoldr_RDR,-    unpackCStringFoldrUtf8_RDR, unpackCStringUtf8_RDR :: RdrName-eqString_RDR            = nameRdrName eqStringName-unpackCString_RDR       = nameRdrName unpackCStringName-unpackCStringFoldr_RDR  = nameRdrName unpackCStringFoldrName-unpackCStringUtf8_RDR   = nameRdrName unpackCStringUtf8Name-unpackCStringFoldrUtf8_RDR  = nameRdrName unpackCStringFoldrUtf8Name- newStablePtr_RDR :: RdrName newStablePtr_RDR        = nameRdrName newStablePtrName @@ -798,12 +773,11 @@ compose_RDR :: RdrName compose_RDR             = varQual_RDR gHC_BASE (fsLit ".") -not_RDR, getTag_RDR, dataToTag_RDR, succ_RDR, pred_RDR, minBound_RDR, maxBound_RDR,+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")-getTag_RDR              = varQual_RDR gHC_BASE (fsLit "getTag") dataToTag_RDR           = varQual_RDR gHC_PRIM (fsLit "dataToTag#") succ_RDR                = varQual_RDR gHC_ENUM (fsLit "succ") pred_RDR                = varQual_RDR gHC_ENUM (fsLit "pred")@@ -979,12 +953,15 @@ leftDataConName   = dcQual dATA_EITHER (fsLit "Left")   leftDataConKey rightDataConName  = dcQual dATA_EITHER (fsLit "Right")  rightDataConKey +voidTyConName :: Name+voidTyConName = tcQual dATA_VOID (fsLit "Void") voidTyConKey+ -- Generics (types) v1TyConName, u1TyConName, par1TyConName, rec1TyConName,   k1TyConName, m1TyConName, sumTyConName, prodTyConName,   compTyConName, rTyConName, dTyConName,   cTyConName, sTyConName, rec0TyConName,-  d1TyConName, c1TyConName, s1TyConName, noSelTyConName,+  d1TyConName, c1TyConName, s1TyConName,   repTyConName, rep1TyConName, uRecTyConName,   uAddrTyConName, uCharTyConName, uDoubleTyConName,   uFloatTyConName, uIntTyConName, uWordTyConName,@@ -1016,7 +993,6 @@ d1TyConName  = tcQual gHC_GENERICS (fsLit "D1") d1TyConKey c1TyConName  = tcQual gHC_GENERICS (fsLit "C1") c1TyConKey s1TyConName  = tcQual gHC_GENERICS (fsLit "S1") s1TyConKey-noSelTyConName = tcQual gHC_GENERICS (fsLit "NoSelector") noSelTyConKey  repTyConName  = tcQual gHC_GENERICS (fsLit "Rep")  repTyConKey rep1TyConName = tcQual gHC_GENERICS (fsLit "Rep1") rep1TyConKey@@ -1057,14 +1033,20 @@ -- Base strings Strings unpackCStringName, unpackCStringFoldrName,     unpackCStringUtf8Name, unpackCStringFoldrUtf8Name,+    unpackCStringAppendName, unpackCStringAppendUtf8Name,     eqStringName, cstringLengthName :: Name-unpackCStringName       = varQual gHC_CSTRING (fsLit "unpackCString#") unpackCStringIdKey-unpackCStringFoldrName  = varQual gHC_CSTRING (fsLit "unpackFoldrCString#") unpackCStringFoldrIdKey-unpackCStringUtf8Name   = varQual gHC_CSTRING (fsLit "unpackCStringUtf8#") unpackCStringUtf8IdKey cstringLengthName       = varQual gHC_CSTRING (fsLit "cstringLength#") cstringLengthIdKey eqStringName            = varQual gHC_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@@ -1135,11 +1117,10 @@ groupWithName          = varQual gHC_EXTS (fsLit "groupWith")          groupWithIdKey considerAccessibleName = varQual gHC_EXTS (fsLit "considerAccessible") considerAccessibleIdKey --- Random PrelBase functions+-- Random GHC.Base functions fromStringName, otherwiseIdName, foldrName, buildName, augmentName,     mapName, appendName, assertName,-    breakpointName, breakpointCondName,-    opaqueTyConName, dollarName :: Name+    dollarName :: Name dollarName        = varQual gHC_BASE (fsLit "$")          dollarIdKey otherwiseIdName   = varQual gHC_BASE (fsLit "otherwise")  otherwiseIdKey foldrName         = varQual gHC_BASE (fsLit "foldr")      foldrIdKey@@ -1148,16 +1129,8 @@ mapName           = varQual gHC_BASE (fsLit "map")        mapIdKey appendName        = varQual gHC_BASE (fsLit "++")         appendIdKey assertName        = varQual gHC_BASE (fsLit "assert")     assertIdKey-breakpointName    = varQual gHC_BASE (fsLit "breakpoint") breakpointIdKey-breakpointCondName= varQual gHC_BASE (fsLit "breakpointCond") breakpointCondIdKey-opaqueTyConName   = tcQual  gHC_BASE (fsLit "Opaque")     opaqueTyConKey fromStringName = varQual dATA_STRING (fsLit "fromString") fromStringClassOpKey --- PrelTup-fstName, sndName :: Name-fstName           = varQual dATA_TUPLE (fsLit "fst") fstIdKey-sndName           = varQual dATA_TUPLE (fsLit "snd") sndIdKey- -- Module GHC.Num numClassName, fromIntegerName, minusName, negateName :: Name numClassName      = clsQual gHC_NUM (fsLit "Num")         numClassKey@@ -1183,15 +1156,7 @@    , integerMulName    , integerSubName    , integerNegateName-   , integerEqName-   , integerNeName-   , integerLeName-   , integerGtName-   , integerLtName-   , integerGeName    , integerAbsName-   , integerSignumName-   , integerCompareName    , integerPopCountName    , integerQuotName    , integerRemName@@ -1212,14 +1177,6 @@    , integerShiftLName    , integerShiftRName    , naturalToWordName-   , naturalToWordClampName-   , naturalEqName-   , naturalNeName-   , naturalGeName-   , naturalLeName-   , naturalGtName-   , naturalLtName-   , naturalCompareName    , naturalPopCountName    , naturalShiftRName    , naturalShiftLName@@ -1228,8 +1185,6 @@    , naturalSubThrowName    , naturalSubUnsafeName    , naturalMulName-   , naturalSignumName-   , naturalNegateName    , naturalQuotRemName    , naturalQuotName    , naturalRemName@@ -1247,6 +1202,9 @@    , naturalPowModName    , naturalSizeInBaseName    , bignatFromWordListName+   , bignatEqName+   , bignatCompareName+   , bignatCompareWordName    :: Name  bnbVarQual, bnnVarQual, bniVarQual :: String -> Unique -> Name@@ -1256,16 +1214,11 @@  -- Types and DataCons bignatFromWordListName    = bnbVarQual "bigNatFromWordList#"       bignatFromWordListIdKey+bignatEqName              = bnbVarQual "bigNatEq#"                 bignatEqIdKey+bignatCompareName         = bnbVarQual "bigNatCompare"             bignatCompareIdKey+bignatCompareWordName     = bnbVarQual "bigNatCompareWord#"        bignatCompareWordIdKey  naturalToWordName         = bnnVarQual "naturalToWord#"            naturalToWordIdKey-naturalToWordClampName    = bnnVarQual "naturalToWordClamp#"       naturalToWordClampIdKey-naturalEqName             = bnnVarQual "naturalEq#"                naturalEqIdKey-naturalNeName             = bnnVarQual "naturalNe#"                naturalNeIdKey-naturalGeName             = bnnVarQual "naturalGe#"                naturalGeIdKey-naturalLeName             = bnnVarQual "naturalLe#"                naturalLeIdKey-naturalGtName             = bnnVarQual "naturalGt#"                naturalGtIdKey-naturalLtName             = bnnVarQual "naturalLt#"                naturalLtIdKey-naturalCompareName        = bnnVarQual "naturalCompare"            naturalCompareIdKey naturalPopCountName       = bnnVarQual "naturalPopCount#"          naturalPopCountIdKey naturalShiftRName         = bnnVarQual "naturalShiftR#"            naturalShiftRIdKey naturalShiftLName         = bnnVarQual "naturalShiftL#"            naturalShiftLIdKey@@ -1274,8 +1227,6 @@ naturalSubThrowName       = bnnVarQual "naturalSubThrow"           naturalSubThrowIdKey naturalSubUnsafeName      = bnnVarQual "naturalSubUnsafe"          naturalSubUnsafeIdKey naturalMulName            = bnnVarQual "naturalMul"                naturalMulIdKey-naturalSignumName         = bnnVarQual "naturalSignum"             naturalSignumIdKey-naturalNegateName         = bnnVarQual "naturalNegate"             naturalNegateIdKey naturalQuotRemName        = bnnVarQual "naturalQuotRem#"           naturalQuotRemIdKey naturalQuotName           = bnnVarQual "naturalQuot"               naturalQuotIdKey naturalRemName            = bnnVarQual "naturalRem"                naturalRemIdKey@@ -1308,15 +1259,7 @@ integerMulName            = bniVarQual "integerMul"                integerMulIdKey integerSubName            = bniVarQual "integerSub"                integerSubIdKey integerNegateName         = bniVarQual "integerNegate"             integerNegateIdKey-integerEqName             = bniVarQual "integerEq#"                integerEqIdKey-integerNeName             = bniVarQual "integerNe#"                integerNeIdKey-integerLeName             = bniVarQual "integerLe#"                integerLeIdKey-integerGtName             = bniVarQual "integerGt#"                integerGtIdKey-integerLtName             = bniVarQual "integerLt#"                integerLtIdKey-integerGeName             = bniVarQual "integerGe#"                integerGeIdKey integerAbsName            = bniVarQual "integerAbs"                integerAbsIdKey-integerSignumName         = bniVarQual "integerSignum"             integerSignumIdKey-integerCompareName        = bniVarQual "integerCompare"            integerCompareIdKey integerPopCountName       = bniVarQual "integerPopCount#"          integerPopCountIdKey integerQuotName           = bniVarQual "integerQuot"               integerQuotIdKey integerRemName            = bniVarQual "integerRem"                integerRemIdKey@@ -1362,7 +1305,7 @@ realToFracName      = varQual  gHC_REAL (fsLit "realToFrac")  realToFracIdKey mkRationalBase2Name  = varQual  gHC_REAL  (fsLit "mkRationalBase2")  mkRationalBase2IdKey mkRationalBase10Name = varQual  gHC_REAL  (fsLit "mkRationalBase10") mkRationalBase10IdKey--- PrelFloat classes+-- GHC.Float classes floatingClassName, realFloatClassName :: Name floatingClassName  = clsQual gHC_FLOAT (fsLit "Floating")  floatingClassKey realFloatClassName = clsQual gHC_FLOAT (fsLit "RealFloat") realFloatClassKey@@ -1464,6 +1407,10 @@ starArrStarKindRepName = varQual gHC_TYPES         (fsLit "krep$*Arr*")     starArrStarKindRepKey starArrStarArrStarKindRepName = varQual gHC_TYPES  (fsLit "krep$*->*->*")   starArrStarArrStarKindRepKey +-- WithDict+withDictClassName :: Name+withDictClassName     = clsQual gHC_MAGIC_DICT (fsLit "WithDict") withDictClassKey+ -- Custom type errors errorMessageTypeErrorFamName   , typeErrorTextDataConName@@ -1473,19 +1420,19 @@   :: Name  errorMessageTypeErrorFamName =-  tcQual gHC_TYPELITS (fsLit "TypeError") errorMessageTypeErrorFamKey+  tcQual gHC_TYPEERROR (fsLit "TypeError") errorMessageTypeErrorFamKey  typeErrorTextDataConName =-  dcQual gHC_TYPELITS (fsLit "Text") typeErrorTextDataConKey+  dcQual gHC_TYPEERROR (fsLit "Text") typeErrorTextDataConKey  typeErrorAppendDataConName =-  dcQual gHC_TYPELITS (fsLit ":<>:") typeErrorAppendDataConKey+  dcQual gHC_TYPEERROR (fsLit ":<>:") typeErrorAppendDataConKey  typeErrorVAppendDataConName =-  dcQual gHC_TYPELITS (fsLit ":$$:") typeErrorVAppendDataConKey+  dcQual gHC_TYPEERROR (fsLit ":$$:") typeErrorVAppendDataConKey  typeErrorShowTypeDataConName =-  dcQual gHC_TYPELITS (fsLit "ShowType") typeErrorShowTypeDataConKey+  dcQual gHC_TYPEERROR (fsLit "ShowType") typeErrorShowTypeDataConKey  -- Unsafe coercion proofs unsafeEqualityProofName, unsafeEqualityTyConName, unsafeCoercePrimName,@@ -1529,10 +1476,10 @@  -- Overloaded lists isListClassName, fromListName, fromListNName, toListName :: Name-isListClassName = clsQual gHC_EXTS (fsLit "IsList")    isListClassKey-fromListName    = varQual gHC_EXTS (fsLit "fromList")  fromListClassOpKey-fromListNName   = varQual gHC_EXTS (fsLit "fromListN") fromListNClassOpKey-toListName      = varQual gHC_EXTS (fsLit "toList")    toListClassOpKey+isListClassName = clsQual gHC_IS_LIST (fsLit "IsList")    isListClassKey+fromListName    = varQual gHC_IS_LIST (fsLit "fromList")  fromListClassOpKey+fromListNName   = varQual gHC_IS_LIST (fsLit "fromListN") fromListNClassOpKey+toListName      = varQual gHC_IS_LIST (fsLit "toList")    toListClassOpKey  -- HasField class ops getFieldName, setFieldName :: Name@@ -1768,6 +1715,9 @@ typeableClassKey :: Unique typeableClassKey        = mkPreludeClassUnique 20 +withDictClassKey :: Unique+withDictClassKey        = mkPreludeClassUnique 21+ monadFixClassKey :: Unique monadFixClassKey        = mkPreludeClassUnique 28 @@ -1835,7 +1785,7 @@ ************************************************************************ -} -addrPrimTyConKey, arrayPrimTyConKey, arrayArrayPrimTyConKey, boolTyConKey,+addrPrimTyConKey, arrayPrimTyConKey, boolTyConKey,     byteArrayPrimTyConKey, charPrimTyConKey, charTyConKey, doublePrimTyConKey,     doubleTyConKey, floatPrimTyConKey, floatTyConKey, funTyConKey,     intPrimTyConKey, intTyConKey, int8TyConKey, int16TyConKey,@@ -1843,7 +1793,7 @@     int64PrimTyConKey, int64TyConKey,     integerTyConKey, naturalTyConKey,     listTyConKey, foreignObjPrimTyConKey, maybeTyConKey,-    weakPrimTyConKey, mutableArrayPrimTyConKey, mutableArrayArrayPrimTyConKey,+    weakPrimTyConKey, mutableArrayPrimTyConKey,     mutableByteArrayPrimTyConKey, orderingTyConKey, mVarPrimTyConKey,     ratioTyConKey, rationalTyConKey, realWorldTyConKey, stablePtrPrimTyConKey,     stablePtrTyConKey, eqTyConKey, heqTyConKey, ioPortPrimTyConKey,@@ -1890,19 +1840,17 @@ stablePtrTyConKey                       = mkPreludeTyConUnique 39 eqTyConKey                              = mkPreludeTyConUnique 40 heqTyConKey                             = mkPreludeTyConUnique 41-arrayArrayPrimTyConKey                  = mkPreludeTyConUnique 42-mutableArrayArrayPrimTyConKey           = mkPreludeTyConUnique 43  statePrimTyConKey, stableNamePrimTyConKey, stableNameTyConKey,     mutVarPrimTyConKey, ioTyConKey,     wordPrimTyConKey, wordTyConKey, word8PrimTyConKey, word8TyConKey,     word16PrimTyConKey, word16TyConKey, word32PrimTyConKey, word32TyConKey,     word64PrimTyConKey, word64TyConKey,-    anyBoxConKey, kindConKey, boxityConKey,+    kindConKey, boxityConKey,     typeConKey, threadIdPrimTyConKey, bcoPrimTyConKey, ptrTyConKey,     funPtrTyConKey, tVarPrimTyConKey, eqPrimTyConKey,     eqReprPrimTyConKey, eqPhantPrimTyConKey,-    compactPrimTyConKey :: Unique+    compactPrimTyConKey, stackSnapshotPrimTyConKey :: Unique statePrimTyConKey                       = mkPreludeTyConUnique 50 stableNamePrimTyConKey                  = mkPreludeTyConUnique 51 stableNameTyConKey                      = mkPreludeTyConUnique 52@@ -1921,7 +1869,6 @@ word32TyConKey                          = mkPreludeTyConUnique 66 word64PrimTyConKey                      = mkPreludeTyConUnique 67 word64TyConKey                          = mkPreludeTyConUnique 68-anyBoxConKey                            = mkPreludeTyConUnique 71 kindConKey                              = mkPreludeTyConUnique 72 boxityConKey                            = mkPreludeTyConUnique 73 typeConKey                              = mkPreludeTyConUnique 74@@ -1931,21 +1878,26 @@ funPtrTyConKey                          = mkPreludeTyConUnique 78 tVarPrimTyConKey                        = mkPreludeTyConUnique 79 compactPrimTyConKey                     = mkPreludeTyConUnique 80+stackSnapshotPrimTyConKey               = mkPreludeTyConUnique 81  eitherTyConKey :: Unique eitherTyConKey                          = mkPreludeTyConUnique 84 +voidTyConKey :: Unique+voidTyConKey                            = mkPreludeTyConUnique 85+ nonEmptyTyConKey :: Unique-nonEmptyTyConKey                        = mkPreludeTyConUnique 85+nonEmptyTyConKey                        = mkPreludeTyConUnique 86  -- Kind constructors liftedTypeKindTyConKey, unliftedTypeKindTyConKey,   tYPETyConKey, liftedRepTyConKey, unliftedRepTyConKey,   constraintKindTyConKey, levityTyConKey, runtimeRepTyConKey,-  vecCountTyConKey, vecElemTyConKey :: Unique-liftedTypeKindTyConKey                  = mkPreludeTyConUnique 87-unliftedTypeKindTyConKey                = mkPreludeTyConUnique 88-tYPETyConKey                            = mkPreludeTyConUnique 89+  vecCountTyConKey, vecElemTyConKey,+  zeroBitRepTyConKey, zeroBitTypeTyConKey :: Unique+liftedTypeKindTyConKey                  = mkPreludeTyConUnique 88+unliftedTypeKindTyConKey                = mkPreludeTyConUnique 89+tYPETyConKey                            = mkPreludeTyConUnique 90 constraintKindTyConKey                  = mkPreludeTyConUnique 92 levityTyConKey                          = mkPreludeTyConUnique 94 runtimeRepTyConKey                      = mkPreludeTyConUnique 95@@ -1953,25 +1905,28 @@ vecElemTyConKey                         = mkPreludeTyConUnique 97 liftedRepTyConKey                       = mkPreludeTyConUnique 98 unliftedRepTyConKey                     = mkPreludeTyConUnique 99+zeroBitRepTyConKey                         = mkPreludeTyConUnique 100+zeroBitTypeTyConKey                        = mkPreludeTyConUnique 101  pluginTyConKey, frontendPluginTyConKey :: Unique pluginTyConKey                          = mkPreludeTyConUnique 102 frontendPluginTyConKey                  = mkPreludeTyConUnique 103 -unknownTyConKey, unknown1TyConKey, unknown2TyConKey, unknown3TyConKey,-    opaqueTyConKey :: Unique-unknownTyConKey                         = mkPreludeTyConUnique 129-unknown1TyConKey                        = mkPreludeTyConUnique 130-unknown2TyConKey                        = mkPreludeTyConUnique 131-unknown3TyConKey                        = mkPreludeTyConUnique 132-opaqueTyConKey                          = mkPreludeTyConUnique 133+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, noSelTyConKey,+  d1TyConKey, c1TyConKey, s1TyConKey,   repTyConKey, rep1TyConKey, uRecTyConKey,   uAddrTyConKey, uCharTyConKey, uDoubleTyConKey,   uFloatTyConKey, uIntTyConKey, uWordTyConKey :: Unique@@ -1996,7 +1951,6 @@ d1TyConKey    = mkPreludeTyConUnique 151 c1TyConKey    = mkPreludeTyConUnique 152 s1TyConKey    = mkPreludeTyConUnique 153-noSelTyConKey = mkPreludeTyConUnique 154  repTyConKey  = mkPreludeTyConUnique 155 rep1TyConKey = mkPreludeTyConUnique 156@@ -2168,21 +2122,14 @@ srcLocDataConKey :: Unique srcLocDataConKey                        = mkPreludeDataConUnique 37 -trTyConTyConKey, trTyConDataConKey,-  trModuleTyConKey, trModuleDataConKey,-  trNameTyConKey, trNameSDataConKey, trNameDDataConKey,-  trGhcPrimModuleKey, kindRepTyConKey,-  typeLitSortTyConKey :: Unique-trTyConTyConKey                         = mkPreludeDataConUnique 40+trTyConDataConKey, trModuleDataConKey,+  trNameSDataConKey, trNameDDataConKey,+  trGhcPrimModuleKey :: Unique trTyConDataConKey                       = mkPreludeDataConUnique 41-trModuleTyConKey                        = mkPreludeDataConUnique 42 trModuleDataConKey                      = mkPreludeDataConUnique 43-trNameTyConKey                          = mkPreludeDataConUnique 44 trNameSDataConKey                       = mkPreludeDataConUnique 45 trNameDDataConKey                       = mkPreludeDataConUnique 46 trGhcPrimModuleKey                      = mkPreludeDataConUnique 47-kindRepTyConKey                         = mkPreludeDataConUnique 48-typeLitSortTyConKey                     = mkPreludeDataConUnique 49  typeErrorTextDataConKey,   typeErrorAppendDataConKey,@@ -2219,13 +2166,19 @@ metaConsDataConKey                      = mkPreludeDataConUnique 69 metaSelDataConKey                       = mkPreludeDataConUnique 70 -vecRepDataConKey, tupleRepDataConKey, sumRepDataConKey,-  boxedRepDataConKey :: Unique+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.@@ -2299,14 +2252,13 @@ -}  wildCardKey, absentErrorIdKey, augmentIdKey, appendIdKey,-    buildIdKey, errorIdKey, foldrIdKey, recSelErrorIdKey,+    buildIdKey, foldrIdKey, recSelErrorIdKey,     seqIdKey, eqStringIdKey,     noMethodBindingErrorIdKey, nonExhaustiveGuardsErrorIdKey,     runtimeErrorIdKey, patErrorIdKey, voidPrimIdKey,     realWorldPrimIdKey, recConErrorIdKey,-    unpackCStringUtf8IdKey, unpackCStringAppendIdKey,-    unpackCStringFoldrIdKey, unpackCStringFoldrUtf8IdKey,-    unpackCStringIdKey,+    unpackCStringUtf8IdKey, unpackCStringAppendUtf8IdKey, unpackCStringFoldrUtf8IdKey,+    unpackCStringIdKey, unpackCStringAppendIdKey, unpackCStringFoldrIdKey,     typeErrorIdKey, divIntIdKey, modIntIdKey,     absentSumFieldErrorIdKey, cstringLengthIdKey,     raiseOverflowIdKey, raiseUnderflowIdKey, raiseDivZeroIdKey@@ -2317,7 +2269,6 @@ augmentIdKey                  = mkPreludeMiscIdUnique  2 appendIdKey                   = mkPreludeMiscIdUnique  3 buildIdKey                    = mkPreludeMiscIdUnique  4-errorIdKey                    = mkPreludeMiscIdUnique  5 foldrIdKey                    = mkPreludeMiscIdUnique  6 recSelErrorIdKey              = mkPreludeMiscIdUnique  7 seqIdKey                      = mkPreludeMiscIdUnique  8@@ -2329,25 +2280,28 @@ patErrorIdKey                 = mkPreludeMiscIdUnique 14 realWorldPrimIdKey            = mkPreludeMiscIdUnique 15 recConErrorIdKey              = mkPreludeMiscIdUnique 16+ unpackCStringUtf8IdKey        = mkPreludeMiscIdUnique 17-unpackCStringAppendIdKey      = mkPreludeMiscIdUnique 18-unpackCStringFoldrIdKey       = mkPreludeMiscIdUnique 19+unpackCStringAppendUtf8IdKey  = mkPreludeMiscIdUnique 18+unpackCStringFoldrUtf8IdKey   = mkPreludeMiscIdUnique 19  unpackCStringIdKey            = mkPreludeMiscIdUnique 20-unpackCStringFoldrUtf8IdKey   = mkPreludeMiscIdUnique 21-voidPrimIdKey                 = mkPreludeMiscIdUnique 22-typeErrorIdKey                = mkPreludeMiscIdUnique 23-divIntIdKey                   = mkPreludeMiscIdUnique 24-modIntIdKey                   = mkPreludeMiscIdUnique 25-cstringLengthIdKey            = mkPreludeMiscIdUnique 26-raiseOverflowIdKey            = mkPreludeMiscIdUnique 27-raiseUnderflowIdKey           = mkPreludeMiscIdUnique 28-raiseDivZeroIdKey             = mkPreludeMiscIdUnique 29+unpackCStringAppendIdKey      = mkPreludeMiscIdUnique 21+unpackCStringFoldrIdKey       = mkPreludeMiscIdUnique 22 +voidPrimIdKey                 = mkPreludeMiscIdUnique 23+typeErrorIdKey                = mkPreludeMiscIdUnique 24+divIntIdKey                   = mkPreludeMiscIdUnique 25+modIntIdKey                   = mkPreludeMiscIdUnique 26+cstringLengthIdKey            = mkPreludeMiscIdUnique 27+raiseOverflowIdKey            = mkPreludeMiscIdUnique 28+raiseUnderflowIdKey           = mkPreludeMiscIdUnique 29+raiseDivZeroIdKey             = mkPreludeMiscIdUnique 30+ concatIdKey, filterIdKey, zipIdKey,     bindIOIdKey, returnIOIdKey, newStablePtrIdKey,     printIdKey, failIOIdKey, nullAddrIdKey, voidArgIdKey,-    fstIdKey, sndIdKey, otherwiseIdKey, assertIdKey :: Unique+    otherwiseIdKey, assertIdKey :: Unique concatIdKey                   = mkPreludeMiscIdUnique 31 filterIdKey                   = mkPreludeMiscIdUnique 32 zipIdKey                      = mkPreludeMiscIdUnique 33@@ -2358,8 +2312,6 @@ failIOIdKey                   = mkPreludeMiscIdUnique 38 nullAddrIdKey                 = mkPreludeMiscIdUnique 39 voidArgIdKey                  = mkPreludeMiscIdUnique 40-fstIdKey                      = mkPreludeMiscIdUnique 41-sndIdKey                      = mkPreludeMiscIdUnique 42 otherwiseIdKey                = mkPreludeMiscIdUnique 43 assertIdKey                   = mkPreludeMiscIdUnique 44 @@ -2381,10 +2333,6 @@ traceKey :: Unique traceKey                      = mkPreludeMiscIdUnique 108 -breakpointIdKey, breakpointCondIdKey :: Unique-breakpointIdKey               = mkPreludeMiscIdUnique 110-breakpointCondIdKey           = mkPreludeMiscIdUnique 111- inlineIdKey, noinlineIdKey :: Unique inlineIdKey                   = mkPreludeMiscIdUnique 120 -- see below@@ -2407,9 +2355,6 @@ rationalToFloatIdKey   = mkPreludeMiscIdUnique 132 rationalToDoubleIdKey  = mkPreludeMiscIdUnique 133 -magicDictKey :: Unique-magicDictKey                  = mkPreludeMiscIdUnique 156- coerceKey :: Unique coerceKey                     = mkPreludeMiscIdUnique 157 @@ -2600,15 +2545,7 @@    , integerMulIdKey    , integerSubIdKey    , integerNegateIdKey-   , integerEqIdKey-   , integerNeIdKey-   , integerLeIdKey-   , integerGtIdKey-   , integerLtIdKey-   , integerGeIdKey    , integerAbsIdKey-   , integerSignumIdKey-   , integerCompareIdKey    , integerPopCountIdKey    , integerQuotIdKey    , integerRemIdKey@@ -2632,14 +2569,6 @@    , integerFromWord64IdKey    , integerFromInt64IdKey    , naturalToWordIdKey-   , naturalToWordClampIdKey-   , naturalEqIdKey-   , naturalNeIdKey-   , naturalGeIdKey-   , naturalLeIdKey-   , naturalGtIdKey-   , naturalLtIdKey-   , naturalCompareIdKey    , naturalPopCountIdKey    , naturalShiftRIdKey    , naturalShiftLIdKey@@ -2648,8 +2577,6 @@    , naturalSubThrowIdKey    , naturalSubUnsafeIdKey    , naturalMulIdKey-   , naturalSignumIdKey-   , naturalNegateIdKey    , naturalQuotRemIdKey    , naturalQuotIdKey    , naturalRemIdKey@@ -2667,6 +2594,9 @@    , naturalPowModIdKey    , naturalSizeInBaseIdKey    , bignatFromWordListIdKey+   , bignatEqIdKey+   , bignatCompareIdKey+   , bignatCompareWordIdKey    :: Unique  integerFromNaturalIdKey    = mkPreludeMiscIdUnique 600@@ -2681,15 +2611,7 @@ integerMulIdKey            = mkPreludeMiscIdUnique 609 integerSubIdKey            = mkPreludeMiscIdUnique 610 integerNegateIdKey         = mkPreludeMiscIdUnique 611-integerEqIdKey             = mkPreludeMiscIdUnique 612-integerNeIdKey             = mkPreludeMiscIdUnique 613-integerLeIdKey             = mkPreludeMiscIdUnique 614-integerGtIdKey             = mkPreludeMiscIdUnique 615-integerLtIdKey             = mkPreludeMiscIdUnique 616-integerGeIdKey             = mkPreludeMiscIdUnique 617 integerAbsIdKey            = mkPreludeMiscIdUnique 618-integerSignumIdKey         = mkPreludeMiscIdUnique 619-integerCompareIdKey        = mkPreludeMiscIdUnique 620 integerPopCountIdKey       = mkPreludeMiscIdUnique 621 integerQuotIdKey           = mkPreludeMiscIdUnique 622 integerRemIdKey            = mkPreludeMiscIdUnique 623@@ -2714,14 +2636,6 @@ integerFromInt64IdKey      = mkPreludeMiscIdUnique 644  naturalToWordIdKey         = mkPreludeMiscIdUnique 650-naturalToWordClampIdKey    = mkPreludeMiscIdUnique 651-naturalEqIdKey             = mkPreludeMiscIdUnique 652-naturalNeIdKey             = mkPreludeMiscIdUnique 653-naturalGeIdKey             = mkPreludeMiscIdUnique 654-naturalLeIdKey             = mkPreludeMiscIdUnique 655-naturalGtIdKey             = mkPreludeMiscIdUnique 656-naturalLtIdKey             = mkPreludeMiscIdUnique 657-naturalCompareIdKey        = mkPreludeMiscIdUnique 658 naturalPopCountIdKey       = mkPreludeMiscIdUnique 659 naturalShiftRIdKey         = mkPreludeMiscIdUnique 660 naturalShiftLIdKey         = mkPreludeMiscIdUnique 661@@ -2730,8 +2644,6 @@ naturalSubThrowIdKey       = mkPreludeMiscIdUnique 664 naturalSubUnsafeIdKey      = mkPreludeMiscIdUnique 665 naturalMulIdKey            = mkPreludeMiscIdUnique 666-naturalSignumIdKey         = mkPreludeMiscIdUnique 667-naturalNegateIdKey         = mkPreludeMiscIdUnique 668 naturalQuotRemIdKey        = mkPreludeMiscIdUnique 669 naturalQuotIdKey           = mkPreludeMiscIdUnique 670 naturalRemIdKey            = mkPreludeMiscIdUnique 671@@ -2750,7 +2662,11 @@ naturalSizeInBaseIdKey     = mkPreludeMiscIdUnique 684  bignatFromWordListIdKey    = mkPreludeMiscIdUnique 690+bignatEqIdKey              = mkPreludeMiscIdUnique 691+bignatCompareIdKey         = mkPreludeMiscIdUnique 692+bignatCompareWordIdKey     = mkPreludeMiscIdUnique 693 + ------------------------------------------------------ -- ghci optimization for big rationals 700-749 uniques ------------------------------------------------------@@ -2830,18 +2746,46 @@ *                                                                      * ************************************************************************ -GHCi's :info command will usually filter out instances mentioning types whose-names are not in scope. GHCi makes 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. The list in the definition of-pretendNameIsInScope below contains these commonly used 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-  = any (n `hasKey`)+  = isBuiltInSyntax n+  || any (n `hasKey`)     [ liftedTypeKindTyConKey, unliftedTypeKindTyConKey     , liftedDataConKey, unliftedDataConKey     , tYPETyConKey-    , runtimeRepTyConKey, boxedRepDataConKey ]+    , runtimeRepTyConKey, boxedRepDataConKey+    , eqTyConKey+    , oneDataConKey+    , manyDataConKey+    , funTyConKey ]
GHC/Builtin/Names/TH.hs view
@@ -54,7 +54,7 @@     -- Exp     varEName, conEName, litEName, appEName, appTypeEName, infixEName,     infixAppName, sectionLName, sectionRName, lamEName, lamCaseEName,-    tupEName, unboxedTupEName, unboxedSumEName,+    lamCasesEName, tupEName, unboxedTupEName, unboxedSumEName,     condEName, multiIfEName, letEName, caseEName, doEName, mdoEName, compEName,     fromEName, fromThenEName, fromToEName, fromThenToEName,     listEName, sigEName, recConEName, recUpdEName, staticEName, unboundVarEName,@@ -71,8 +71,8 @@     funDName, valDName, dataDName, newtypeDName, tySynDName,     classDName, instanceWithOverlapDName,     standaloneDerivWithStrategyDName, sigDName, kiSigDName, forImpDName,-    pragInlDName, pragSpecDName, pragSpecInlDName, pragSpecInstDName,-    pragRuleDName, pragCompleteDName, pragAnnDName, defaultSigDName,+    pragInlDName, pragOpaqueDName, pragSpecDName, pragSpecInlDName, pragSpecInstDName,+    pragRuleDName, pragCompleteDName, pragAnnDName, defaultSigDName, defaultDName,     dataFamilyDName, openTypeFamilyDName, closedTypeFamilyDName,     dataInstDName, newtypeInstDName, tySynInstDName,     infixLDName, infixRDName, infixNDName,@@ -285,7 +285,7 @@  -- data Exp = ... varEName, conEName, litEName, appEName, appTypeEName, infixEName, infixAppName,-    sectionLName, sectionRName, lamEName, lamCaseEName, tupEName,+    sectionLName, sectionRName, lamEName, lamCaseEName, lamCasesEName, tupEName,     unboxedTupEName, unboxedSumEName, condEName, multiIfEName, letEName,     caseEName, doEName, mdoEName, compEName, staticEName, unboundVarEName,     labelEName, implicitParamVarEName, getFieldEName, projectionEName :: Name@@ -300,6 +300,7 @@ 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@@ -355,11 +356,11 @@ funDName, valDName, dataDName, newtypeDName, tySynDName, classDName,     instanceWithOverlapDName, sigDName, kiSigDName, forImpDName, pragInlDName,     pragSpecDName, pragSpecInlDName, pragSpecInstDName, pragRuleDName,-    pragAnnDName, standaloneDerivWithStrategyDName, defaultSigDName,+    pragAnnDName, standaloneDerivWithStrategyDName, defaultSigDName, defaultDName,     dataInstDName, newtypeInstDName, tySynInstDName, dataFamilyDName,     openTypeFamilyDName, closedTypeFamilyDName, infixLDName, infixRDName,     infixNDName, roleAnnotDName, patSynDName, patSynSigDName,-    pragCompleteDName, implicitParamBindDName :: Name+    pragCompleteDName, implicitParamBindDName, pragOpaqueDName :: Name funDName                         = libFun (fsLit "funD")                         funDIdKey valDName                         = libFun (fsLit "valD")                         valDIdKey dataDName                        = libFun (fsLit "dataD")                        dataDIdKey@@ -370,9 +371,11 @@ standaloneDerivWithStrategyDName = libFun (fsLit "standaloneDerivWithStrategyD") standaloneDerivWithStrategyDIdKey sigDName                         = libFun (fsLit "sigD")                         sigDIdKey kiSigDName                       = libFun (fsLit "kiSigD")                       kiSigDIdKey+defaultDName                     = libFun (fsLit "defaultD")                     defaultDIdKey defaultSigDName                  = libFun (fsLit "defaultSigD")                  defaultSigDIdKey forImpDName                      = libFun (fsLit "forImpD")                      forImpDIdKey pragInlDName                     = libFun (fsLit "pragInlD")                     pragInlDIdKey+pragOpaqueDName                  = libFun (fsLit "pragOpaqueD")                  pragOpaqueDIdKey pragSpecDName                    = libFun (fsLit "pragSpecD")                    pragSpecDIdKey pragSpecInlDName                 = libFun (fsLit "pragSpecInlD")                 pragSpecInlDIdKey pragSpecInstDName                = libFun (fsLit "pragSpecInstD")                pragSpecInstDIdKey@@ -706,14 +709,14 @@  -- data RuleMatch = ... conLikeDataConKey, funLikeDataConKey :: Unique-conLikeDataConKey = mkPreludeDataConUnique 203-funLikeDataConKey = mkPreludeDataConUnique 204+conLikeDataConKey = mkPreludeDataConUnique 204+funLikeDataConKey = mkPreludeDataConUnique 205  -- data Phases = ... allPhasesDataConKey, fromPhaseDataConKey, beforePhaseDataConKey :: Unique-allPhasesDataConKey   = mkPreludeDataConUnique 205-fromPhaseDataConKey   = mkPreludeDataConUnique 206-beforePhaseDataConKey = mkPreludeDataConUnique 207+allPhasesDataConKey   = mkPreludeDataConUnique 206+fromPhaseDataConKey   = mkPreludeDataConUnique 207+beforePhaseDataConKey = mkPreludeDataConUnique 208  -- data Overlap = .. overlappableDataConKey,@@ -810,8 +813,8 @@ -- data Exp = ... varEIdKey, conEIdKey, litEIdKey, appEIdKey, appTypeEIdKey, infixEIdKey,     infixAppIdKey, sectionLIdKey, sectionRIdKey, lamEIdKey, lamCaseEIdKey,-    tupEIdKey, unboxedTupEIdKey, unboxedSumEIdKey, condEIdKey, multiIfEIdKey,-    letEIdKey, caseEIdKey, doEIdKey, compEIdKey,+    lamCasesEIdKey, tupEIdKey, unboxedTupEIdKey, unboxedSumEIdKey, condEIdKey,+    multiIfEIdKey, letEIdKey, caseEIdKey, doEIdKey, compEIdKey,     fromEIdKey, fromThenEIdKey, fromToEIdKey, fromThenToEIdKey,     listEIdKey, sigEIdKey, recConEIdKey, recUpdEIdKey, staticEIdKey,     unboundVarEIdKey, labelEIdKey, implicitParamVarEIdKey, mdoEIdKey,@@ -827,52 +830,53 @@ sectionRIdKey          = mkPreludeMiscIdUnique 278 lamEIdKey              = mkPreludeMiscIdUnique 279 lamCaseEIdKey          = mkPreludeMiscIdUnique 280-tupEIdKey              = mkPreludeMiscIdUnique 281-unboxedTupEIdKey       = mkPreludeMiscIdUnique 282-unboxedSumEIdKey       = mkPreludeMiscIdUnique 283-condEIdKey             = mkPreludeMiscIdUnique 284-multiIfEIdKey          = mkPreludeMiscIdUnique 285-letEIdKey              = mkPreludeMiscIdUnique 286-caseEIdKey             = mkPreludeMiscIdUnique 287-doEIdKey               = mkPreludeMiscIdUnique 288-compEIdKey             = mkPreludeMiscIdUnique 289-fromEIdKey             = mkPreludeMiscIdUnique 290-fromThenEIdKey         = mkPreludeMiscIdUnique 291-fromToEIdKey           = mkPreludeMiscIdUnique 292-fromThenToEIdKey       = mkPreludeMiscIdUnique 293-listEIdKey             = mkPreludeMiscIdUnique 294-sigEIdKey              = mkPreludeMiscIdUnique 295-recConEIdKey           = mkPreludeMiscIdUnique 296-recUpdEIdKey           = mkPreludeMiscIdUnique 297-staticEIdKey           = mkPreludeMiscIdUnique 298-unboundVarEIdKey       = mkPreludeMiscIdUnique 299-labelEIdKey            = mkPreludeMiscIdUnique 300-implicitParamVarEIdKey = mkPreludeMiscIdUnique 301-mdoEIdKey              = mkPreludeMiscIdUnique 302-getFieldEIdKey         = mkPreludeMiscIdUnique 303-projectionEIdKey       = mkPreludeMiscIdUnique 304+lamCasesEIdKey         = mkPreludeMiscIdUnique 281+tupEIdKey              = mkPreludeMiscIdUnique 282+unboxedTupEIdKey       = mkPreludeMiscIdUnique 283+unboxedSumEIdKey       = mkPreludeMiscIdUnique 284+condEIdKey             = mkPreludeMiscIdUnique 285+multiIfEIdKey          = mkPreludeMiscIdUnique 286+letEIdKey              = mkPreludeMiscIdUnique 287+caseEIdKey             = mkPreludeMiscIdUnique 288+doEIdKey               = mkPreludeMiscIdUnique 289+compEIdKey             = mkPreludeMiscIdUnique 290+fromEIdKey             = mkPreludeMiscIdUnique 291+fromThenEIdKey         = mkPreludeMiscIdUnique 292+fromToEIdKey           = mkPreludeMiscIdUnique 293+fromThenToEIdKey       = mkPreludeMiscIdUnique 294+listEIdKey             = mkPreludeMiscIdUnique 295+sigEIdKey              = mkPreludeMiscIdUnique 296+recConEIdKey           = mkPreludeMiscIdUnique 297+recUpdEIdKey           = mkPreludeMiscIdUnique 298+staticEIdKey           = mkPreludeMiscIdUnique 299+unboundVarEIdKey       = mkPreludeMiscIdUnique 300+labelEIdKey            = mkPreludeMiscIdUnique 301+implicitParamVarEIdKey = mkPreludeMiscIdUnique 302+mdoEIdKey              = mkPreludeMiscIdUnique 303+getFieldEIdKey         = mkPreludeMiscIdUnique 304+projectionEIdKey       = mkPreludeMiscIdUnique 305  -- type FieldExp = ... fieldExpIdKey :: Unique-fieldExpIdKey       = mkPreludeMiscIdUnique 305+fieldExpIdKey       = mkPreludeMiscIdUnique 306  -- data Body = ... guardedBIdKey, normalBIdKey :: Unique-guardedBIdKey     = mkPreludeMiscIdUnique 306-normalBIdKey      = mkPreludeMiscIdUnique 307+guardedBIdKey     = mkPreludeMiscIdUnique 307+normalBIdKey      = mkPreludeMiscIdUnique 308  -- data Guard = ... normalGEIdKey, patGEIdKey :: Unique-normalGEIdKey     = mkPreludeMiscIdUnique 308-patGEIdKey        = mkPreludeMiscIdUnique 309+normalGEIdKey     = mkPreludeMiscIdUnique 309+patGEIdKey        = mkPreludeMiscIdUnique 310  -- data Stmt = ... bindSIdKey, letSIdKey, noBindSIdKey, parSIdKey, recSIdKey :: Unique-bindSIdKey       = mkPreludeMiscIdUnique 310-letSIdKey        = mkPreludeMiscIdUnique 311-noBindSIdKey     = mkPreludeMiscIdUnique 312-parSIdKey        = mkPreludeMiscIdUnique 313-recSIdKey        = mkPreludeMiscIdUnique 314+bindSIdKey       = mkPreludeMiscIdUnique 311+letSIdKey        = mkPreludeMiscIdUnique 312+noBindSIdKey     = mkPreludeMiscIdUnique 313+parSIdKey        = mkPreludeMiscIdUnique 314+recSIdKey        = mkPreludeMiscIdUnique 315  -- data Dec = ... funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey, classDIdKey,@@ -883,7 +887,7 @@     newtypeInstDIdKey, tySynInstDIdKey, standaloneDerivWithStrategyDIdKey,     infixLDIdKey, infixRDIdKey, infixNDIdKey, roleAnnotDIdKey, patSynDIdKey,     patSynSigDIdKey, pragCompleteDIdKey, implicitParamBindDIdKey,-    kiSigDIdKey :: Unique+    kiSigDIdKey, defaultDIdKey, pragOpaqueDIdKey :: Unique funDIdKey                         = mkPreludeMiscIdUnique 320 valDIdKey                         = mkPreludeMiscIdUnique 321 dataDIdKey                        = mkPreludeMiscIdUnique 322@@ -917,6 +921,8 @@ pragCompleteDIdKey                = mkPreludeMiscIdUnique 350 implicitParamBindDIdKey           = mkPreludeMiscIdUnique 351 kiSigDIdKey                       = mkPreludeMiscIdUnique 352+defaultDIdKey                     = mkPreludeMiscIdUnique 353+pragOpaqueDIdKey                   = mkPreludeMiscIdUnique 354  -- type Cxt = ... cxtIdKey :: Unique
GHC/Builtin/PrimOps.hs view
@@ -24,31 +24,34 @@         PrimCall(..)     ) where -#include "HsVersions.h"- 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    ( TyCon, isPrimTyCon, PrimRep(..) )+import GHC.Core.Type+ import GHC.Cmm.Type+ import GHC.Types.Demand-import GHC.Types.Id      ( Id, mkVanillaGlobalWithInfo )-import GHC.Types.Id.Info ( vanillaIdInfo, setCafInfo, CafInfo(NoCafRefs) )+import GHC.Types.Id+import GHC.Types.Id.Info import GHC.Types.Name-import GHC.Builtin.Names ( gHC_PRIMOPWRAPPERS )-import GHC.Core.TyCon    ( TyCon, isPrimTyCon, PrimRep(..) )-import GHC.Core.Type import GHC.Types.RepType ( tyConPrimRep1 )-import GHC.Types.Basic   ( Arity, Boxity(..) )+import GHC.Types.Basic import GHC.Types.Fixity  ( Fixity(..), FixityDirection(..) ) import GHC.Types.SrcLoc  ( wiredInSrcSpan ) import GHC.Types.ForeignCall ( CLabelString ) import GHC.Types.SourceText  ( SourceText(..) ) import GHC.Types.Unique  ( Unique)-import GHC.Builtin.Uniques (mkPrimOpIdUnique, mkPrimOpWrapperUnique )+ import GHC.Unit.Types    ( Unit )+ import GHC.Utils.Outputable+ import GHC.Data.FastString  {-@@ -111,14 +114,14 @@   = Compare     OccName         -- string :: T -> T -> Int#                 Type   | GenPrimOp   OccName         -- string :: \/a1..an . T1 -> .. -> Tk -> T-                [TyVar]+                [TyVarBinder]                 [Type]                 Type  mkCompare :: FastString -> Type -> PrimOpInfo mkCompare str ty = Compare (mkVarOccFS str) ty -mkGenPrimOp :: FastString -> [TyVar] -> [Type] -> Type -> PrimOpInfo+mkGenPrimOp :: FastString -> [TyVarBinder] -> [Type] -> Type -> PrimOpInfo mkGenPrimOp str tvs tys ty = GenPrimOp (mkVarOccFS str) tvs tys ty  {-@@ -131,8 +134,8 @@ Not all primops are strict! -} -primOpStrictness :: PrimOp -> Arity -> StrictSig-        -- See Demand.StrictnessInfo for discussion of what the results+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"@@ -333,16 +336,18 @@ some effect that is not captured entirely by its result value.  ----------  has_side_effects ----------------------A primop "has_side_effects" if it has some *write* effect, visible-elsewhere-    - writing to the world (I/O)-    - writing to a mutable data structure (writeIORef)+A primop "has_side_effects" if it has some side effect, visible+elsewhere, apart from the result it returns+    - reading or writing to the world (I/O)+    - reading or writing to a mutable data structure (writeIORef)     - throwing a synchronous Haskell exception  Often such primops have a type like    State -> input -> (State, output)-so the state token guarantees ordering.  In general we rely *only* on-data dependencies of the state token to enforce write-effect ordering+so the state token guarantees ordering.  In general we rely on+data dependencies of the state token to enforce write-effect ordering,+but as the notes below make clear, the matter is a bit more complicated+than that.   * NB1: if you inline unsafePerformIO, you may end up with    side-effecting ops whose 'state' output is discarded.@@ -355,11 +360,21 @@    "can_fail".  We must be careful about not discarding such things;    see the paper "A semantics for imprecise exceptions". - * NB3: *Read* effects (like reading an IORef) don't count here,-   because it doesn't matter if we don't do them, or do them more than-   once.  *Sequencing* is maintained by the data dependency of the state-   token.+ * NB3: *Read* effects on *mutable* cells (like reading an IORef or a+   MutableArray#) /are/ included.  You may find this surprising because it+   doesn't matter if we don't do them, or do them more than once.  *Sequencing*+   is maintained by the data dependency of the state token.  But see+   "Duplication" below under+   Note [Transformations affected by can_fail and has_side_effects] +   Note that read operations on *immutable* values (like indexArray#) do not+   have has_side_effects.   (They might be marked can_fail, however, because+   you might index out of bounds.)++   Using has_side_effects in this way is a bit of a blunt instrument.  We could+   be more refined by splitting read and write effects (see comments with #3207+   and #20195)+ ----------  can_fail ---------------------------- A primop "can_fail" if it can fail with an *unchecked* exception on some elements of its input domain. Main examples:@@ -457,7 +472,7 @@ How do we ensure that floating/duplication/discarding are done right in the simplifier? -Two main predicates on primpops test these flags:+Two main predicates on primops test these flags:   primOpOkForSideEffects <=> not has_side_effects   primOpOkForSpeculation <=> not (has_side_effects || can_fail) @@ -609,7 +624,7 @@     Compare _occ ty -> compare_fun_ty ty      GenPrimOp _occ tyvars arg_tys res_ty ->-        mkSpecForAllTys tyvars (mkVisFunTysMany arg_tys res_ty)+        mkForAllTys tyvars (mkVisFunTysMany arg_tys res_ty)  primOpResultType :: PrimOp -> Type primOpResultType op@@ -638,14 +653,13 @@     plusInt# a b = P.plusInt# a b  The Id for the wrapper of a primop can be found using-'GHC.Builtin.PrimOp.primOpWrapperId'. However, GHCi does not use this mechanism+'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 breathern in that they may exhibit less levity-polymorphism. For instance, consider the case of mkWeakNoFinalizer# which has-type:+Note that these wrappers aren't *quite* as expressive as their unwrapped+breathren, 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@@ -657,10 +671,10 @@      mkWeakNoFinalizer# k v s = GHC.Prim.mkWeakNoFinalizer# k v s -However, this would require that 'k' bind the levity-polymorphic key,-which is disallowed by our levity polymorphism validity checks (see Note-[Levity polymorphism invariants] in GHC.Core). Consequently, we give the-wrapper the simpler, less polymorphic type+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@@ -668,8 +682,8 @@                        -> (# State# RealWorld, Weak# v #)  This simplification tends to be good enough for GHCi uses given that there are-few levity polymorphic primops and we do little simplification on interpreted-code anyways.+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@@ -680,9 +694,10 @@  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 levity polymorphism.+convention for curried applications that can accommodate representation+polymorphism. -To ensure saturation, CorePrep eta expands expand all primop applications as+To ensure saturation, CorePrep eta expands all primop applications as described in Note [Eta expansion of hasNoBinding things in CorePrep] in GHC.Core.Prep. @@ -724,7 +739,7 @@ -- (type variables, argument types, result type) -- It also gives arity, strictness info -primOpSig :: PrimOp -> ([TyVar], [Type], Type, Arity, StrictSig)+primOpSig :: PrimOp -> ([TyVarBinder], [Type], Type, Arity, DmdSig) primOpSig op   = (tyvars, arg_tys, res_ty, arity, primOpStrictness op arity)   where
+ GHC/Builtin/PrimOps/Ids.hs view
@@ -0,0 +1,80 @@+-- | 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.Type (mkForAllTys, mkVisFunTysMany)+import GHC.Core.FVs (mkRuleInfo)++import GHC.Builtin.PrimOps+import GHC.Builtin.Uniques+import GHC.Builtin.Names++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.Data.SmallArray+import Data.Maybe ( 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) name ty info++    -- 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+           `setLevityInfoWithType` res_ty+               -- 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+++-------------------------------------------------------------+-- 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
@@ -4,7 +4,6 @@ Wired-in knowledge about {\em non-primitive} types -} -{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-}  {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}@@ -106,7 +105,7 @@         isLiftedTypeKindTyConName,         typeToTypeKind,         liftedRepTyCon, unliftedRepTyCon,-        constraintKind, liftedTypeKind, unliftedTypeKind,+        constraintKind, liftedTypeKind, unliftedTypeKind, zeroBitTypeKind,         constraintKindTyCon, liftedTypeKindTyCon, unliftedTypeKindTyCon,         constraintKindTyConName, liftedTypeKindTyConName, unliftedTypeKindTyConName,         liftedRepTyConName, unliftedRepTyConName,@@ -120,7 +119,7 @@         runtimeRepTyCon, levityTyCon, vecCountTyCon, vecElemTyCon,          boxedRepDataConTyCon,-        runtimeRepTy, liftedRepTy, unliftedRepTy,+        runtimeRepTy, levityTy, liftedRepTy, unliftedRepTy, zeroBitRepTy,          vecRepDataConTyCon, tupleRepDataConTyCon, sumRepDataConTyCon, @@ -159,11 +158,8 @@         naturalTy, naturalTyCon, naturalTyConName,         naturalNSDataCon, naturalNSDataConName,         naturalNBDataCon, naturalNBDataConName-     ) where -#include "HsVersions.h"- import GHC.Prelude  import {-# SOURCE #-} GHC.Types.Id.Make ( mkDataConWorkId, mkDictSelId )@@ -201,10 +197,11 @@ import GHC.Utils.Outputable import GHC.Utils.Misc import GHC.Utils.Panic+import GHC.Utils.Panic.Plain  import qualified Data.ByteString.Char8 as BS -import Data.List        ( elemIndex )+import Data.List        ( elemIndex, intersperse )  alpha_tyvar :: [TyVar] alpha_tyvar = [alphaTyVar]@@ -213,18 +210,6 @@ alpha_ty = [alphaTy]  {--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.-- Note [Wired-in Types and Type Constructors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -330,6 +315,8 @@                 , integerTyCon                 , liftedRepTyCon                 , unliftedRepTyCon+                , zeroBitRepTyCon+                , zeroBitTypeTyCon                 , nonEmptyTyCon                 ] @@ -356,27 +343,6 @@ eqDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "Eq#") eqDataConKey eqDataCon eqSCSelIdName = mkWiredInIdName gHC_TYPES (fsLit "eq_sel") eqSCSelIdKey eqSCSelId -{- Note [eqTyCon (~) is built-in syntax]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The (~) type operator used in equality constraints (a~b) is considered built-in-syntax. This has a few consequences:--* The user is not allowed to define their own type constructors with this name:--    ghci> class a ~ b-    <interactive>:1:1: error: Illegal binding of built-in syntax: ~--* Writing (a ~ b) does not require enabling -XTypeOperators. It does, however,-  require -XGADTs or -XTypeFamilies.--* The (~) type operator is always in scope. It doesn't need to be imported,-  and it cannot be hidden.--* We have a bunch of special cases in the compiler to arrange all of the above.--There's no particular reason for (~) to be special, but fixing this would be a-breaking change.--} eqTyCon_RDR :: RdrName eqTyCon_RDR = nameRdrName eqTyConName @@ -473,12 +439,6 @@   * It is 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) -  * If (Any k) is the type of a value, it must be a /lifted/ value. So-    if we have (Any @(TYPE rr)) then rr must be 'LiftedRep.  See-    Note [TYPE and RuntimeRep] in GHC.Builtin.Types.Prim.  This is a convenient-    invariant, and makes isUnliftedTyCon well-defined; otherwise what-    would (isUnliftedTyCon Any) be?- It's used to instantiate un-constrained type variables after type checking. For example, 'length' has type @@ -551,27 +511,23 @@ constraintKindTyConName :: Name constraintKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Constraint") constraintKindTyConKey   constraintKindTyCon -liftedTypeKindTyConName, unliftedTypeKindTyConName :: Name-liftedTypeKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Type") liftedTypeKindTyConKey liftedTypeKindTyCon+liftedTypeKindTyConName, unliftedTypeKindTyConName, zeroBitTypeTyConName :: Name+liftedTypeKindTyConName   = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Type")         liftedTypeKindTyConKey   liftedTypeKindTyCon unliftedTypeKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "UnliftedType") unliftedTypeKindTyConKey unliftedTypeKindTyCon+zeroBitTypeTyConName      = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "ZeroBitType")  zeroBitTypeTyConKey      zeroBitTypeTyCon -liftedRepTyConName, unliftedRepTyConName :: Name-liftedRepTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "LiftedRep") liftedRepTyConKey liftedRepTyCon+liftedRepTyConName, unliftedRepTyConName, zeroBitRepTyConName :: Name+liftedRepTyConName   = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "LiftedRep")   liftedRepTyConKey   liftedRepTyCon unliftedRepTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "UnliftedRep") unliftedRepTyConKey unliftedRepTyCon+zeroBitRepTyConName  = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "ZeroBitRep")  zeroBitRepTyConKey  zeroBitRepTyCon  multiplicityTyConName :: Name multiplicityTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Multiplicity")                           multiplicityTyConKey multiplicityTyCon  oneDataConName, manyDataConName :: Name-oneDataConName = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit "One") oneDataConKey oneDataCon-manyDataConName = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit "Many") manyDataConKey manyDataCon- -- It feels wrong to have One and Many be BuiltInSyntax. But otherwise,- -- `Many`, in particular, is considered out of scope unless an appropriate- -- file is open. The problem with this is that `Many` appears implicitly in- -- types every time there is an `(->)`, hence out-of-scope errors get- -- reported. Making them built-in make it so that they are always considered in- -- scope.+oneDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "One") oneDataConKey oneDataCon+manyDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "Many") manyDataConKey manyDataCon  runtimeRepTyConName, vecRepDataConName, tupleRepDataConName, sumRepDataConName, boxedRepDataConName :: Name runtimeRepTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "RuntimeRep") runtimeRepTyConKey runtimeRepTyCon@@ -737,7 +693,7 @@     mkWiredInName modu wrk_occ wrk_key                   (AnId (dataConWorkId data_con)) UserSyntax   where-    modu     = ASSERT( isExternalName dc_name )+    modu     = assert (isExternalName dc_name) $                nameModule dc_name     dc_name = dataConName data_con     dc_occ  = nameOccName dc_name@@ -768,10 +724,7 @@ -- 'TyCon.isConstraintKindCon' assumes that this is an AlgTyCon! constraintKindTyCon = pcTyCon constraintKindTyConName Nothing [] [] --- See Note [Prefer Type over TYPE 'LiftedRep] in GHC.Core.TyCo.Rep.-liftedTypeKind, unliftedTypeKind, typeToTypeKind, constraintKind :: Kind-liftedTypeKind   = mkTyConTy liftedTypeKindTyCon-unliftedTypeKind = mkTyConTy unliftedTypeKindTyCon+typeToTypeKind, constraintKind :: Kind typeToTypeKind   = liftedTypeKind `mkVisFunTyMany` liftedTypeKind constraintKind   = mkTyConTy constraintKindTyCon @@ -782,7 +735,7 @@ *                                                                      * ************************************************************************ -Note [How tuples work]  See also Note [Known-key names] in GHC.Builtin.Names+Note [How tuples work] ~~~~~~~~~~~~~~~~~~~~~~ * There are three families of tuple TyCons and corresponding   DataCons, expressed by the type BasicTypes.TupleSort:@@ -834,6 +787,8 @@   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:@@ -911,9 +866,6 @@       "[]" -> Just $ choose_ns listTyConName nilDataConName       ":"    -> Just consDataConName -      -- equality tycon-      "~"    -> Just eqTyConName-       -- function tycon       "FUN"  -> Just funTyConName       "->"  -> Just unrestrictedFunTyConName@@ -937,23 +889,31 @@        -- unboxed sum tycon       _ | Just rest <- "(#" `BS.stripPrefix` name-        , (pipes, rest') <- BS.span (=='|') rest+        , (nb_pipes, rest') <- span_pipes rest         , "#)" <- rest'-             -> Just $ tyConName $ sumTyCon (1+BS.length pipes)+             -> Just $ tyConName $ sumTyCon (1+nb_pipes)        -- unboxed sum datacon       _ | Just rest <- "(#" `BS.stripPrefix` name-        , (pipes1, rest') <- BS.span (=='|') rest+        , (nb_pipes1, rest') <- span_pipes rest         , Just rest'' <- "_" `BS.stripPrefix` rest'-        , (pipes2, rest''') <- BS.span (=='|') rest''+        , (nb_pipes2, rest''') <- span_pipes rest''         , "#)" <- rest'''-             -> let arity = BS.length pipes1 + BS.length pipes2 + 1-                    alt = BS.length pipes1 + 1+             -> let arity = nb_pipes1 + nb_pipes2 + 1+                    alt = nb_pipes1 + 1                 in Just $ dataConName $ sumDataCon alt arity       _ -> Nothing   where     name = bytesFS $ occNameFS occ +    span_pipes :: BS.ByteString -> (Int, BS.ByteString)+    span_pipes = go 0+      where+        go nb_pipes bs = case BS.uncons bs of+          Just ('|',rest) -> go (nb_pipes + 1) rest+          Just (' ',rest) -> go nb_pipes       rest+          _               -> (nb_pipes, bs)+     choose_ns :: Name -> Name -> Name     choose_ns tc dc       | isTcClsNameSpace ns   = tc@@ -1011,7 +971,7 @@  isCTupleTyConName :: Name -> Bool isCTupleTyConName n- = ASSERT2( isExternalName n, ppr n )+ = assertPpr (isExternalName n) (ppr n) $    getUnique n `elementOfUniqSet` cTupleTyConKeys  -- | If the given name is that of a constraint tuple, return its arity.@@ -1119,7 +1079,7 @@ -- [IntRep, LiftedRep])@ unboxedTupleSumKind :: TyCon -> [Type] -> Kind unboxedTupleSumKind tc rr_tys-  = tYPE (mkTyConApp tc [mkPromotedListTy runtimeRepTy rr_tys])+  = mkTYPEapp (mkTyConApp tc [mkPromotedListTy runtimeRepTy rr_tys])  -- | Specialization of 'unboxedTupleSumKind' for tuples unboxedTupleKind :: [Type] -> Kind@@ -1155,14 +1115,14 @@                          UnboxedTuple flavour      -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon-    -- Kind:  forall (k1:RuntimeRep) (k2:RuntimeRep). TYPE k1 -> TYPE k2 -> #+    -- Kind:  forall (k1:RuntimeRep) (k2:RuntimeRep). TYPE k1 -> TYPE k2 -> TYPE (TupleRep [k1, k2])     tc_binders = mkTemplateTyConBinders (replicate arity runtimeRepTy)-                                        (\ks -> map tYPE ks)+                                        (\ks -> map mkTYPEapp ks)      tc_res_kind = unboxedTupleKind rr_tys      tc_arity    = arity * 2-    flavour     = UnboxedAlgTyCon $ Just (mkPrelTyConRepName tc_name)+    flavour     = VanillaAlgTyCon (mkPrelTyConRepName tc_name)      dc_tvs               = binderVars tc_binders     (rr_tys, dc_arg_tys) = splitAt arity (mkTyVarTys dc_tvs)@@ -1235,13 +1195,13 @@ pairTyCon = tupleTyCon Boxed 2  unboxedUnitTy :: Type-unboxedUnitTy = mkTyConApp unboxedUnitTyCon []+unboxedUnitTy = mkTyConTy unboxedUnitTyCon  unboxedUnitTyCon :: TyCon unboxedUnitTyCon = tupleTyCon Unboxed 0  unboxedUnitDataCon :: DataCon-unboxedUnitDataCon = tupleDataCon   Unboxed 0+unboxedUnitDataCon = tupleDataCon Unboxed 0   {- *********************************************************************@@ -1255,16 +1215,16 @@ mkSumTyConOcc n = mkOccName tcName str   where     -- No need to cache these, the caching is done in mk_sum-    str = '(' : '#' : bars ++ "#)"-    bars = replicate (n-1) '|'+    str = '(' : '#' : ' ' : bars ++ " #)"+    bars = intersperse ' ' $ replicate (n-1) '|'  -- | 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 = replicate i '|'+    str = '(' : '#' : ' ' : bars alt ++ '_' : bars (n - alt - 1) ++ " #)"+    bars i = intersperse ' ' $ replicate i '|'  -- | Type constructor for n-ary unboxed sum. sumTyCon :: Arity -> TyCon@@ -1316,13 +1276,10 @@ mk_sum arity = (tycon, sum_cons)   where     tycon   = mkSumTyCon tc_name tc_binders tc_res_kind (arity * 2) tyvars (elems sum_cons)-                         (UnboxedAlgTyCon rep_name)--    -- Unboxed sums are currently not Typeable due to efficiency concerns. See #13276.-    rep_name = Nothing -- Just $ mkPrelTyConRepName tc_name+                         UnboxedSumTyCon      tc_binders = mkTemplateTyConBinders (replicate arity runtimeRepTy)-                                        (\ks -> map tYPE ks)+                                        (\ks -> map mkTYPEapp ks)      tyvars = binderVars tc_binders @@ -1438,7 +1395,7 @@ *                                                                      * ********************************************************************* -} -{- Multiplicity polymorphism is implemented very similarly to levity+{- 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. @@ -1486,66 +1443,163 @@         binders = [ Bndr runtimeRep1TyVar (NamedTCB Inferred)                   , Bndr runtimeRep2TyVar (NamedTCB Inferred)                   ]-                  ++ mkTemplateAnonTyConBinders [ tYPE runtimeRep1Ty-                                                , tYPE runtimeRep2Ty+                  ++ mkTemplateAnonTyConBinders [ mkTYPEapp runtimeRep1Ty+                                                , mkTYPEapp runtimeRep2Ty                                                 ]  unrestrictedFunTyConName :: Name-unrestrictedFunTyConName = mkWiredInTyConName BuiltInSyntax gHC_TYPES (fsLit "->") unrestrictedFunTyConKey unrestrictedFunTyCon+unrestrictedFunTyConName = mkWiredInTyConName BuiltInSyntax gHC_TYPES (fsLit "->")+                                              unrestrictedFunTyConKey unrestrictedFunTyCon + {- ********************************************************************* *                                                                      *-                Kinds and RuntimeRep+      Type synonyms (all declared in ghc-prim:GHC.Types)++         type Type         = TYPE LiftedRep    -- liftedTypeKind+         type UnliftedType = TYPE UnliftedRep  -- unliftedTypeKind+         type LiftedRep    = BoxedRep Lifted   -- liftedRepTy+         type UnliftedRep  = BoxedRep Unlifted -- unliftedRepTy+ *                                                                      * ********************************************************************* -} --- For information about the usage of the following type,--- see Note [TYPE and RuntimeRep] in module GHC.Builtin.Types.Prim-runtimeRepTy :: Type-runtimeRepTy = mkTyConTy runtimeRepTyCon+-- For these synonyms, see+-- Note [TYPE and RuntimeRep] in GHC.Builtin.Types.Prim, and+-- Note [Using synonyms to compress types] in GHC.Core.Type --- Type synonyms; see Note [TYPE and RuntimeRep] in GHC.Builtin.Types.Prim--- and Note [Prefer Type over TYPE 'LiftedRep] in GHC.Core.TyCo.Rep.---+---------------------- -- @type Type = TYPE ('BoxedRep 'Lifted)@ liftedTypeKindTyCon :: TyCon-liftedTypeKindTyCon =-    buildSynTyCon liftedTypeKindTyConName [] liftedTypeKind [] rhs-  where rhs = TyCoRep.TyConApp tYPETyCon [mkTyConApp liftedRepTyCon []]+liftedTypeKindTyCon+  = buildSynTyCon liftedTypeKindTyConName [] liftedTypeKind [] rhs+  where+    rhs = TyCoRep.TyConApp tYPETyCon [liftedRepTy] +liftedTypeKind :: Type+liftedTypeKind = mkTyConTy liftedTypeKindTyCon++---------------------- -- | @type UnliftedType = TYPE ('BoxedRep 'Unlifted)@ unliftedTypeKindTyCon :: TyCon-unliftedTypeKindTyCon =-    buildSynTyCon unliftedTypeKindTyConName [] liftedTypeKind [] rhs-  where rhs = TyCoRep.TyConApp tYPETyCon [mkTyConApp unliftedRepTyCon []]+unliftedTypeKindTyCon+  = buildSynTyCon unliftedTypeKindTyConName [] liftedTypeKind [] rhs+  where+    rhs = TyCoRep.TyConApp tYPETyCon [unliftedRepTy] +unliftedTypeKind :: Type+unliftedTypeKind = mkTyConTy unliftedTypeKindTyCon++----------------------+-- @type ZeroBitType = TYPE ZeroBitRep+zeroBitTypeTyCon :: TyCon+zeroBitTypeTyCon+  = buildSynTyCon zeroBitTypeTyConName [] liftedTypeKind [] rhs+  where+    rhs = TyCoRep.TyConApp tYPETyCon [zeroBitRepTy]++zeroBitTypeKind :: Type+zeroBitTypeKind = mkTyConTy zeroBitTypeTyCon++---------------------- -- | @type LiftedRep = 'BoxedRep 'Lifted@ liftedRepTyCon :: TyCon-liftedRepTyCon = buildSynTyCon-  liftedRepTyConName [] runtimeRepTy [] liftedRepTy+liftedRepTyCon+  = buildSynTyCon liftedRepTyConName [] runtimeRepTy [] rhs+  where+    rhs = TyCoRep.TyConApp boxedRepDataConTyCon [liftedDataConTy] +liftedRepTy :: Type+liftedRepTy = mkTyConTy liftedRepTyCon++---------------------- -- | @type UnliftedRep = 'BoxedRep 'Unlifted@ unliftedRepTyCon :: TyCon-unliftedRepTyCon = buildSynTyCon-  unliftedRepTyConName [] runtimeRepTy [] unliftedRepTy+unliftedRepTyCon+  = buildSynTyCon unliftedRepTyConName [] runtimeRepTy [] rhs+  where+    rhs = TyCoRep.TyConApp boxedRepDataConTyCon [unliftedDataConTy] -runtimeRepTyCon :: TyCon-runtimeRepTyCon = pcTyCon runtimeRepTyConName Nothing []-    (vecRepDataCon : tupleRepDataCon :-     sumRepDataCon : boxedRepDataCon : runtimeRepSimpleDataCons)+unliftedRepTy :: Type+unliftedRepTy = mkTyConTy unliftedRepTyCon +----------------------+-- | @type ZeroBitRep = 'Tuple '[]+zeroBitRepTyCon :: TyCon+zeroBitRepTyCon+  = buildSynTyCon zeroBitRepTyConName [] runtimeRepTy [] rhs+  where+    rhs = TyCoRep.TyConApp tupleRepDataConTyCon [mkPromotedListTy runtimeRepTy []]++zeroBitRepTy :: Type+zeroBitRepTy = mkTyConTy zeroBitRepTyCon+++{- *********************************************************************+*                                                                      *+      data Levity = Lifted | Unlifted+*                                                                      *+********************************************************************* -}+ levityTyCon :: TyCon levityTyCon = pcTyCon levityTyConName Nothing [] [liftedDataCon,unliftedDataCon] +levityTy :: Type+levityTy = mkTyConTy levityTyCon+ liftedDataCon, unliftedDataCon :: DataCon liftedDataCon = pcSpecialDataCon liftedDataConName     [] levityTyCon LiftedInfo unliftedDataCon = pcSpecialDataCon unliftedDataConName     [] levityTyCon UnliftedInfo +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 []+    (vecRepDataCon : tupleRepDataCon :+     sumRepDataCon : boxedRepDataCon : runtimeRepSimpleDataCons)++runtimeRepTy :: Type+runtimeRepTy = mkTyConTy runtimeRepTyCon+ boxedRepDataCon :: DataCon boxedRepDataCon = pcSpecialDataCon boxedRepDataConName-  [ mkTyConTy levityTyCon ] runtimeRepTyCon (RuntimeRep prim_rep_fun)+  [ levityTy ] runtimeRepTyCon (RuntimeRep prim_rep_fun)   where     -- See Note [Getting from RuntimeRep to PrimRep] in RepType     prim_rep_fun [lev]@@ -1556,6 +1610,10 @@     prim_rep_fun args       = pprPanic "boxedRepDataCon" (ppr args) ++boxedRepDataConTyCon :: TyCon+boxedRepDataConTyCon = promoteDataCon boxedRepDataCon+ vecRepDataCon :: DataCon vecRepDataCon = pcSpecialDataCon vecRepDataConName [ mkTyConTy vecCountTyCon                                                    , mkTyConTy vecElemTyCon ]@@ -1682,30 +1740,6 @@   doubleElemRepDataConTy] = map (mkTyConTy . promoteDataCon)                                 vecElemDataCons --liftedDataConTyCon :: TyCon-liftedDataConTyCon = promoteDataCon liftedDataCon--unliftedDataConTyCon :: TyCon-unliftedDataConTyCon = promoteDataCon unliftedDataCon--liftedDataConTy :: Type-liftedDataConTy = mkTyConTy liftedDataConTyCon--unliftedDataConTy :: Type-unliftedDataConTy = mkTyConTy unliftedDataConTyCon--boxedRepDataConTyCon :: TyCon-boxedRepDataConTyCon = promoteDataCon boxedRepDataCon---- The type ('BoxedRep 'Lifted)-liftedRepTy :: Type-liftedRepTy = mkTyConApp boxedRepDataConTyCon [liftedDataConTy]---- The type ('BoxedRep 'Unlifted)-unliftedRepTy :: Type-unliftedRepTy = mkTyConApp boxedRepDataConTyCon [unliftedDataConTy]- {- ********************************************************************* *                                                                      *      The boxed primitive types: Char, Int, etc@@ -1748,7 +1782,7 @@ charDataCon = pcDataCon charDataConName [] [charPrimTy] charTyCon  stringTy :: Type-stringTy = mkTyConApp stringTyCon []+stringTy = mkTyConTy stringTyCon  stringTyCon :: TyCon -- We have this wired-in so that Haskell literal strings@@ -2094,11 +2128,11 @@   where     go list_ty       | Just (tc, [_k, t, ts]) <- splitTyConApp_maybe list_ty-      = ASSERT( tc `hasKey` consDataConKey )+      = assert (tc `hasKey` consDataConKey) $         t : go ts        | Just (tc, [_k]) <- splitTyConApp_maybe list_ty-      = ASSERT( tc `hasKey` nilDataConKey )+      = assert (tc `hasKey` nilDataConKey)         []        | otherwise
GHC/Builtin/Types.hs-boot view
@@ -16,25 +16,24 @@  unitTy :: Type -liftedTypeKind :: Kind-unliftedTypeKind :: Kind -liftedTypeKindTyCon :: TyCon-unliftedTypeKindTyCon :: TyCon+liftedTypeKindTyConName :: Name -liftedRepTyCon :: TyCon-unliftedRepTyCon :: TyCon+liftedTypeKind, unliftedTypeKind, zeroBitTypeKind :: Kind +liftedTypeKindTyCon, unliftedTypeKindTyCon :: TyCon++liftedRepTyCon, unliftedRepTyCon :: TyCon+ constraintKind :: Kind  runtimeRepTyCon, levityTyCon, vecCountTyCon, vecElemTyCon :: TyCon-runtimeRepTy :: Type+runtimeRepTy, levityTy :: Type -boxedRepDataConTyCon :: TyCon-liftedDataConTyCon :: TyCon+boxedRepDataConTyCon, liftedDataConTyCon :: TyCon vecRepDataConTyCon, tupleRepDataConTyCon :: TyCon -liftedRepTy, unliftedRepTy :: Type+liftedRepTy, unliftedRepTy, zeroBitRepTy :: Type liftedDataConTy, unliftedDataConTy :: Type  intRepDataConTy,@@ -54,7 +53,6 @@  anyTypeOfKind :: Kind -> Type unboxedTupleKind :: [Type] -> Type-mkPromotedListTy :: Type -> [Type] -> Type  multiplicityTyCon :: TyCon multiplicityTy :: Type
GHC/Builtin/Types/Prim.hs view
@@ -11,8 +11,6 @@ -- | 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(-        mkPrimTyConName, -- For implicit parameters in GHC.Builtin.Types only-         mkTemplateKindVar, mkTemplateKindVars,         mkTemplateTyVars, mkTemplateTyVarsFrom,         mkTemplateKiTyVars, mkTemplateKiTyVar,@@ -21,22 +19,32 @@         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,          openAlphaTyVar, openBetaTyVar, openGammaTyVar,+        openAlphaTyVarSpec, openBetaTyVarSpec, openGammaTyVarSpec,         openAlphaTy, openBetaTy, openGammaTy, +        levPolyAlphaTyVar, levPolyBetaTyVar,+        levPolyAlphaTyVarSpec, levPolyBetaTyVarSpec,+        levPolyAlphaTy, levPolyBetaTy,+         multiplicityTyVar1, multiplicityTyVar2,          -- Kind constructors...         tYPETyCon, tYPETyConName,          -- Kinds-        tYPE, primRepToRuntimeRep, primRepsToRuntimeRep,+        mkTYPEapp,          functionWithMultiplicity,         funTyCon, funTyConName,@@ -56,11 +64,9 @@          arrayPrimTyCon, mkArrayPrimTy,         byteArrayPrimTyCon,     byteArrayPrimTy,-        arrayArrayPrimTyCon, mkArrayArrayPrimTy,         smallArrayPrimTyCon, mkSmallArrayPrimTy,         mutableArrayPrimTyCon, mkMutableArrayPrimTy,         mutableByteArrayPrimTyCon, mkMutableByteArrayPrimTy,-        mutableArrayArrayPrimTyCon, mkMutableArrayArrayPrimTy,         smallMutableArrayPrimTyCon, mkSmallMutableArrayPrimTy,         mutVarPrimTyCon, mkMutVarPrimTy, @@ -73,6 +79,7 @@         bcoPrimTyCon,                   bcoPrimTy,         weakPrimTyCon,                  mkWeakPrimTy,         threadIdPrimTyCon,              threadIdPrimTy,+        stackSnapshotPrimTyCon,         stackSnapshotPrimTy,          int8PrimTyCon,          int8PrimTy, int8PrimTyConName,         word8PrimTyCon,         word8PrimTy, word8PrimTyConName,@@ -95,14 +102,12 @@ #include "primop-vector-tys-exports.hs-incl"   ) where -#include "HsVersions.h"- import GHC.Prelude  import {-# SOURCE #-} GHC.Builtin.Types-  ( runtimeRepTy, unboxedTupleKind, liftedTypeKind-  , vecRepDataConTyCon, tupleRepDataConTyCon-  , liftedRepTy, unliftedRepTy+  ( runtimeRepTy, levityTy, unboxedTupleKind, liftedTypeKind+  , boxedRepDataConTyCon, vecRepDataConTyCon+  , liftedRepTy, unliftedRepTy, zeroBitRepTy   , intRepDataConTy   , int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy   , wordRepDataConTy@@ -115,9 +120,10 @@   , int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy   , word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy   , doubleElemRepDataConTy-  , mkPromotedListTy, multiplicityTy )+  , multiplicityTy ) -import GHC.Types.Var    ( TyVar, mkTyVar )+import GHC.Types.Var    ( TyVarBinder, TyVar+                        , mkTyVar, mkTyVarBinder, mkTyVarBinders ) import GHC.Types.Name import {-# SOURCE #-} GHC.Types.TyThing import GHC.Core.TyCon@@ -126,11 +132,10 @@ import GHC.Builtin.Uniques import GHC.Builtin.Names import GHC.Data.FastString-import GHC.Utils.Outputable-import GHC.Utils.Panic+import GHC.Utils.Misc ( changeLast ) 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 {-# SOURCE #-} GHC.Core.Type ( mkTyConTy, tYPE )+import {-# SOURCE #-} GHC.Core.Type ( mkTyConTy, mkTyConApp, mkTYPEapp, getLevity )  import Data.Char @@ -162,7 +167,6 @@   = [ addrPrimTyCon     , arrayPrimTyCon     , byteArrayPrimTyCon-    , arrayArrayPrimTyCon     , smallArrayPrimTyCon     , charPrimTyCon     , doublePrimTyCon@@ -176,7 +180,6 @@     , weakPrimTyCon     , mutableArrayPrimTyCon     , mutableByteArrayPrimTyCon-    , mutableArrayArrayPrimTyCon     , smallMutableArrayPrimTyCon     , mVarPrimTyCon     , ioPortPrimTyCon@@ -194,6 +197,7 @@     , word16PrimTyCon     , word32PrimTyCon     , word64PrimTyCon+    , stackSnapshotPrimTyCon      , tYPETyCon     , funTyCon@@ -216,7 +220,18 @@                   BuiltInSyntax  -charPrimTyConName, intPrimTyConName, int8PrimTyConName, int16PrimTyConName, int32PrimTyConName, int64PrimTyConName, wordPrimTyConName, word32PrimTyConName, word8PrimTyConName, word16PrimTyConName, word64PrimTyConName, addrPrimTyConName, floatPrimTyConName, doublePrimTyConName, statePrimTyConName, proxyPrimTyConName, realWorldTyConName, arrayPrimTyConName, arrayArrayPrimTyConName, smallArrayPrimTyConName, byteArrayPrimTyConName, mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, mutableArrayArrayPrimTyConName, smallMutableArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, ioPortPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName, stableNamePrimTyConName, compactPrimTyConName, bcoPrimTyConName, weakPrimTyConName, threadIdPrimTyConName, eqPrimTyConName, eqReprPrimTyConName, eqPhantPrimTyConName :: Name+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,+  ioPortPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName,+  stableNamePrimTyConName, compactPrimTyConName, bcoPrimTyConName,+  weakPrimTyConName, threadIdPrimTyConName,+  eqPrimTyConName, eqReprPrimTyConName, eqPhantPrimTyConName,+  stackSnapshotPrimTyConName :: Name charPrimTyConName             = mkPrimTc (fsLit "Char#") charPrimTyConKey charPrimTyCon intPrimTyConName              = mkPrimTc (fsLit "Int#") intPrimTyConKey  intPrimTyCon int8PrimTyConName             = mkPrimTc (fsLit "Int8#") int8PrimTyConKey int8PrimTyCon@@ -239,11 +254,9 @@ realWorldTyConName            = mkPrimTc (fsLit "RealWorld") realWorldTyConKey realWorldTyCon arrayPrimTyConName            = mkPrimTc (fsLit "Array#") arrayPrimTyConKey arrayPrimTyCon byteArrayPrimTyConName        = mkPrimTc (fsLit "ByteArray#") byteArrayPrimTyConKey byteArrayPrimTyCon-arrayArrayPrimTyConName       = mkPrimTc (fsLit "ArrayArray#") arrayArrayPrimTyConKey arrayArrayPrimTyCon smallArrayPrimTyConName       = mkPrimTc (fsLit "SmallArray#") smallArrayPrimTyConKey smallArrayPrimTyCon mutableArrayPrimTyConName     = mkPrimTc (fsLit "MutableArray#") mutableArrayPrimTyConKey mutableArrayPrimTyCon mutableByteArrayPrimTyConName = mkPrimTc (fsLit "MutableByteArray#") mutableByteArrayPrimTyConKey mutableByteArrayPrimTyCon-mutableArrayArrayPrimTyConName= mkPrimTc (fsLit "MutableArrayArray#") mutableArrayArrayPrimTyConKey mutableArrayArrayPrimTyCon smallMutableArrayPrimTyConName= mkPrimTc (fsLit "SmallMutableArray#") smallMutableArrayPrimTyConKey smallMutableArrayPrimTyCon mutVarPrimTyConName           = mkPrimTc (fsLit "MutVar#") mutVarPrimTyConKey mutVarPrimTyCon ioPortPrimTyConName           = mkPrimTc (fsLit "IOPort#") ioPortPrimTyConKey ioPortPrimTyCon@@ -252,6 +265,7 @@ 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@@ -363,13 +377,16 @@ alphaTyVar, betaTyVar, gammaTyVar, deltaTyVar :: TyVar (alphaTyVar:betaTyVar:gammaTyVar:deltaTyVar:_) = alphaTyVars +alphaTyVarSpec, betaTyVarSpec, gammaTyVarSpec, deltaTyVarSpec :: TyVarBinder+(alphaTyVarSpec:betaTyVarSpec:gammaTyVarSpec:deltaTyVarSpec:_) = mkTyVarBinders Specified alphaTyVars+ alphaTys :: [Type] alphaTys = mkTyVarTys alphaTyVars alphaTy, betaTy, gammaTy, deltaTy :: Type (alphaTy:betaTy:gammaTy:deltaTy:_) = alphaTys  alphaTyVarsUnliftedRep :: [TyVar]-alphaTyVarsUnliftedRep = mkTemplateTyVars $ repeat (tYPE unliftedRepTy)+alphaTyVarsUnliftedRep = mkTemplateTyVars $ repeat (mkTYPEapp unliftedRepTy)  alphaTyVarUnliftedRep :: TyVar (alphaTyVarUnliftedRep:_) = alphaTyVarsUnliftedRep@@ -383,23 +400,61 @@ (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 :: Type 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 [tYPE runtimeRep1Ty, tYPE runtimeRep2Ty, tYPE runtimeRep3Ty]+  = mkTemplateTyVars [mkTYPEapp runtimeRep1Ty, mkTYPEapp runtimeRep2Ty, mkTYPEapp 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+    [mkTYPEapp (mkTyConApp boxedRepDataConTyCon [levity1Ty])+    ,mkTYPEapp (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'@@ -414,7 +469,7 @@ -}  funTyConName :: Name-funTyConName = mkPrimTyConName (fsLit "FUN") funTyConKey funTyCon+funTyConName = mkPrimTcName UserSyntax (fsLit "FUN") funTyConKey funTyCon  -- | The @FUN@ type constructor. --@@ -444,8 +499,8 @@     tc_bndrs = [ mkNamedTyConBinder Required multiplicityTyVar1                , mkNamedTyConBinder Inferred runtimeRep1TyVar                , mkNamedTyConBinder Inferred runtimeRep2TyVar ]-               ++ mkTemplateAnonTyConBinders [ tYPE runtimeRep1Ty-                                             , tYPE runtimeRep2Ty+               ++ mkTemplateAnonTyConBinders [ mkTYPEapp runtimeRep1Ty+                                             , mkTYPEapp runtimeRep2Ty                                              ]     tc_rep_nm = mkPrelTyConRepName funTyConName @@ -512,51 +567,22 @@                      (a :: TYPE r1) (b :: TYPE r2).                      a -> b -> TYPE ('TupleRep '[r1, r2]) -Note [PrimRep and kindPrimRep]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-As part of its source code, in GHC.Core.TyCon, GHC has-  data PrimRep = BoxedRep Levity | IntRep | FloatRep | ...etc...--Notice that- * RuntimeRep is part of the syntax tree of the program being compiled-     (defined in a library: ghc-prim:GHC.Types)- * PrimRep is part of GHC's source code.-     (defined in GHC.Core.TyCon)--We need to get from one to the other; that is what kindPrimRep does.-Suppose we have a value-   (v :: t) where (t :: k)-Given this kind-    k = TyConApp "TYPE" [rep]-GHC needs to be able to figure out how 'v' is represented at runtime.-It expects 'rep' to be form-    TyConApp rr_dc args-where 'rr_dc' is a promoteed data constructor from RuntimeRep. So-now we need to go from 'dc' to the corresponding PrimRep.  We store this-PrimRep in the promoted data constructor itself: see TyCon.promDcRepInfo.- -}  tYPETyCon :: TyCon tYPETyConName :: Name -tYPETyCon = mkKindTyCon tYPETyConName+tYPETyCon = mkPrimTyCon tYPETyConName                         (mkTemplateAnonTyConBinders [runtimeRepTy])                         liftedTypeKind                         [Nominal]-                        (mkPrelTyConRepName tYPETyConName)  -------------------------- -- ... and now their names  -- If you edit these, you may need to update the GHC formalism -- See Note [GHC Formalism] in GHC.Core.Lint-tYPETyConName             = mkPrimTyConName (fsLit "TYPE") tYPETyConKey tYPETyCon--mkPrimTyConName :: FastString -> Unique -> TyCon -> Name-mkPrimTyConName = mkPrimTcName BuiltInSyntax-  -- All of the super kinds and kinds are defined in Prim,-  -- and use BuiltInSyntax, because they are never in scope in the source+tYPETyConName             = mkPrimTcName UserSyntax (fsLit "TYPE") tYPETyConKey tYPETyCon  mkPrimTcName :: BuiltInSyntax -> FastString -> Unique -> TyCon -> Name mkPrimTcName built_in_syntax occ key tycon@@ -576,141 +602,119 @@ ************************************************************************ -} --- only used herein-pcPrimTyCon :: Name -> [Role] -> PrimRep -> TyCon-pcPrimTyCon name roles rep+-- | 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-    binders     = mkTemplateAnonTyConBinders (map (const liftedTypeKind) roles)-    result_kind = tYPE (primRepToRuntimeRep rep)---- | Convert a 'PrimRep' to a 'Type' of kind RuntimeRep--- Defined here to avoid (more) module loops-primRepToRuntimeRep :: PrimRep -> Type-primRepToRuntimeRep rep = case rep of-  VoidRep       -> mkTupleRep []-  LiftedRep     -> liftedRepTy-  UnliftedRep   -> unliftedRepTy-  IntRep        -> intRepDataConTy-  Int8Rep       -> int8RepDataConTy-  Int16Rep      -> int16RepDataConTy-  Int32Rep      -> int32RepDataConTy-  Int64Rep      -> int64RepDataConTy-  WordRep       -> wordRepDataConTy-  Word8Rep      -> word8RepDataConTy-  Word16Rep     -> word16RepDataConTy-  Word32Rep     -> word32RepDataConTy-  Word64Rep     -> word64RepDataConTy-  AddrRep       -> addrRepDataConTy-  FloatRep      -> floatRepDataConTy-  DoubleRep     -> doubleRepDataConTy-  VecRep n elem -> TyConApp vecRepDataConTyCon [n', elem']-    where-      n' = case n of-        2  -> vec2DataConTy-        4  -> vec4DataConTy-        8  -> vec8DataConTy-        16 -> vec16DataConTy-        32 -> vec32DataConTy-        64 -> vec64DataConTy-        _  -> pprPanic "Disallowed VecCount" (ppr n)--      elem' = case elem of-        Int8ElemRep   -> int8ElemRepDataConTy-        Int16ElemRep  -> int16ElemRepDataConTy-        Int32ElemRep  -> int32ElemRepDataConTy-        Int64ElemRep  -> int64ElemRepDataConTy-        Word8ElemRep  -> word8ElemRepDataConTy-        Word16ElemRep -> word16ElemRepDataConTy-        Word32ElemRep -> word32ElemRepDataConTy-        Word64ElemRep -> word64ElemRepDataConTy-        FloatElemRep  -> floatElemRepDataConTy-        DoubleElemRep -> doubleElemRepDataConTy+    bndr_kis    = liftedTypeKind <$ roles+    binders     = mkTemplateAnonTyConBinders bndr_kis+    result_kind = mkTYPEapp res_rep --- | Given a list of types representing 'RuntimeRep's @reps@, construct--- @'TupleRep' reps@.-mkTupleRep :: [Type] -> Type-mkTupleRep reps = TyConApp tupleRepDataConTyCon [mkPromotedListTy runtimeRepTy reps]+-- | 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 --- | Convert a list of 'PrimRep's to a 'Type' of kind RuntimeRep--- Defined here to avoid (more) module loops-primRepsToRuntimeRep :: [PrimRep] -> Type-primRepsToRuntimeRep [rep] = primRepToRuntimeRep rep-primRepsToRuntimeRep reps  = mkTupleRep $ map primRepToRuntimeRep reps+-- | Create a primitive 'TyCon' like 'pcPrimTyCon', except the last+-- argument is levity-polymorphic.+--+-- 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 = mkTYPEapp res_rep+      lev_bndr = mkNamedTyConBinder Inferred levity1TyVar+      binders  = lev_bndr : mkTemplateAnonTyConBinders anon_bndr_kis+      lev_tv   = mkTyVarTy (binderVar lev_bndr) -pcPrimTyCon0 :: Name -> PrimRep -> TyCon-pcPrimTyCon0 name rep-  = pcPrimTyCon name [] rep+      -- [ Type, ..., Type, TYPE (BoxedRep l) ]+      anon_bndr_kis = changeLast (liftedTypeKind <$ roles)+                        (mkTYPEapp $ mkTyConApp boxedRepDataConTyCon [lev_tv])  charPrimTy :: Type charPrimTy      = mkTyConTy charPrimTyCon charPrimTyCon :: TyCon-charPrimTyCon   = pcPrimTyCon0 charPrimTyConName WordRep+charPrimTyCon   = pcPrimTyCon0 charPrimTyConName wordRepDataConTy  intPrimTy :: Type intPrimTy       = mkTyConTy intPrimTyCon intPrimTyCon :: TyCon-intPrimTyCon    = pcPrimTyCon0 intPrimTyConName IntRep+intPrimTyCon    = pcPrimTyCon0 intPrimTyConName intRepDataConTy  int8PrimTy :: Type int8PrimTy     = mkTyConTy int8PrimTyCon int8PrimTyCon :: TyCon-int8PrimTyCon  = pcPrimTyCon0 int8PrimTyConName Int8Rep+int8PrimTyCon  = pcPrimTyCon0 int8PrimTyConName int8RepDataConTy  int16PrimTy :: Type int16PrimTy    = mkTyConTy int16PrimTyCon int16PrimTyCon :: TyCon-int16PrimTyCon = pcPrimTyCon0 int16PrimTyConName Int16Rep+int16PrimTyCon = pcPrimTyCon0 int16PrimTyConName int16RepDataConTy  int32PrimTy :: Type int32PrimTy     = mkTyConTy int32PrimTyCon int32PrimTyCon :: TyCon-int32PrimTyCon  = pcPrimTyCon0 int32PrimTyConName Int32Rep+int32PrimTyCon  = pcPrimTyCon0 int32PrimTyConName int32RepDataConTy  int64PrimTy :: Type int64PrimTy     = mkTyConTy int64PrimTyCon int64PrimTyCon :: TyCon-int64PrimTyCon  = pcPrimTyCon0 int64PrimTyConName Int64Rep+int64PrimTyCon  = pcPrimTyCon0 int64PrimTyConName int64RepDataConTy  wordPrimTy :: Type wordPrimTy      = mkTyConTy wordPrimTyCon wordPrimTyCon :: TyCon-wordPrimTyCon   = pcPrimTyCon0 wordPrimTyConName WordRep+wordPrimTyCon   = pcPrimTyCon0 wordPrimTyConName wordRepDataConTy  word8PrimTy :: Type word8PrimTy     = mkTyConTy word8PrimTyCon word8PrimTyCon :: TyCon-word8PrimTyCon  = pcPrimTyCon0 word8PrimTyConName Word8Rep+word8PrimTyCon  = pcPrimTyCon0 word8PrimTyConName word8RepDataConTy  word16PrimTy :: Type word16PrimTy    = mkTyConTy word16PrimTyCon word16PrimTyCon :: TyCon-word16PrimTyCon = pcPrimTyCon0 word16PrimTyConName Word16Rep+word16PrimTyCon = pcPrimTyCon0 word16PrimTyConName word16RepDataConTy  word32PrimTy :: Type word32PrimTy    = mkTyConTy word32PrimTyCon word32PrimTyCon :: TyCon-word32PrimTyCon = pcPrimTyCon0 word32PrimTyConName Word32Rep+word32PrimTyCon = pcPrimTyCon0 word32PrimTyConName word32RepDataConTy  word64PrimTy :: Type word64PrimTy    = mkTyConTy word64PrimTyCon word64PrimTyCon :: TyCon-word64PrimTyCon = pcPrimTyCon0 word64PrimTyConName Word64Rep+word64PrimTyCon = pcPrimTyCon0 word64PrimTyConName word64RepDataConTy  addrPrimTy :: Type addrPrimTy      = mkTyConTy addrPrimTyCon addrPrimTyCon :: TyCon-addrPrimTyCon   = pcPrimTyCon0 addrPrimTyConName AddrRep+addrPrimTyCon   = pcPrimTyCon0 addrPrimTyConName addrRepDataConTy  floatPrimTy     :: Type floatPrimTy     = mkTyConTy floatPrimTyCon floatPrimTyCon :: TyCon-floatPrimTyCon  = pcPrimTyCon0 floatPrimTyConName FloatRep+floatPrimTyCon  = pcPrimTyCon0 floatPrimTyConName floatRepDataConTy  doublePrimTy :: Type doublePrimTy    = mkTyConTy doublePrimTyCon doublePrimTyCon :: TyCon-doublePrimTyCon = pcPrimTyCon0 doublePrimTyConName DoubleRep+doublePrimTyCon = pcPrimTyCon0 doublePrimTyConName doubleRepDataConTy  {- ************************************************************************@@ -749,7 +753,7 @@ Let's take these one at a time:      ---------------------------    (~#) :: forall k1 k2. k1 -> k2 -> #+    (~#) :: 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.@@ -829,7 +833,7 @@       ---------------------------    (~R#) :: forall k1 k2. k1 -> k2 -> #+    (~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@@ -864,7 +868,7 @@       ---------------------------    (~P#) :: forall k1 k2. k1 -> k2 -> #+    (~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:@@ -899,7 +903,7 @@ mkStatePrimTy ty = TyConApp statePrimTyCon [ty]  statePrimTyCon :: TyCon   -- See Note [The State# TyCon]-statePrimTyCon   = pcPrimTyCon statePrimTyConName [Nominal] VoidRep+statePrimTyCon   = pcPrimTyCon statePrimTyConName [Nominal] zeroBitRepTy  {- RealWorld is deeply magical.  It is *primitive*, but it is not@@ -908,7 +912,7 @@ -}  realWorldTyCon :: TyCon-realWorldTyCon = mkLiftedPrimTyCon realWorldTyConName [] liftedTypeKind []+realWorldTyCon = mkPrimTyCon realWorldTyConName [] liftedTypeKind [] realWorldTy :: Type realWorldTy          = mkTyConTy realWorldTyCon realWorldStatePrimTy :: Type@@ -924,7 +928,7 @@ proxyPrimTyCon :: TyCon proxyPrimTyCon = mkPrimTyCon proxyPrimTyConName binders res_kind [Nominal,Phantom]   where-     -- Kind: forall k. k -> TYPE (Tuple '[])+     -- Kind: forall k. k -> TYPE (TupleRep '[])      binders = mkTemplateTyConBinders [liftedTypeKind] id      res_kind = unboxedTupleKind [] @@ -940,7 +944,7 @@                       -- See Note [The equality types story] eqPrimTyCon  = mkPrimTyCon eqPrimTyConName binders res_kind roles   where-    -- Kind :: forall k1 k2. k1 -> k2 -> TYPE (Tuple '[])+    -- Kind :: forall k1 k2. k1 -> k2 -> TYPE (TupleRep '[])     binders  = mkTemplateTyConBinders [liftedTypeKind, liftedTypeKind] id     res_kind = unboxedTupleKind []     roles    = [Nominal, Nominal, Nominal, Nominal]@@ -951,7 +955,7 @@ eqReprPrimTyCon :: TyCon   -- See Note [The equality types story] eqReprPrimTyCon = mkPrimTyCon eqReprPrimTyConName binders res_kind roles   where-    -- Kind :: forall k1 k2. k1 -> k2 -> TYPE (Tuple '[])+    -- Kind :: forall k1 k2. k1 -> k2 -> TYPE (TupleRep '[])     binders  = mkTemplateTyConBinders [liftedTypeKind, liftedTypeKind] id     res_kind = unboxedTupleKind []     roles    = [Nominal, Nominal, Representational, Representational]@@ -962,7 +966,7 @@ eqPhantPrimTyCon :: TyCon eqPhantPrimTyCon = mkPrimTyCon eqPhantPrimTyConName binders res_kind roles   where-    -- Kind :: forall k1 k2. k1 -> k2 -> TYPE (Tuple '[])+    -- Kind :: forall k1 k2. k1 -> k2 -> TYPE (TupleRep '[])     binders  = mkTemplateTyConBinders [liftedTypeKind, liftedTypeKind] id     res_kind = unboxedTupleKind []     roles    = [Nominal, Nominal, Phantom, Phantom]@@ -980,33 +984,27 @@ ********************************************************************* -}  arrayPrimTyCon, mutableArrayPrimTyCon, mutableByteArrayPrimTyCon,-    byteArrayPrimTyCon, arrayArrayPrimTyCon, mutableArrayArrayPrimTyCon,+    byteArrayPrimTyCon,     smallArrayPrimTyCon, smallMutableArrayPrimTyCon :: TyCon-arrayPrimTyCon             = pcPrimTyCon arrayPrimTyConName             [Representational] UnliftedRep-mutableArrayPrimTyCon      = pcPrimTyCon  mutableArrayPrimTyConName     [Nominal, Representational] UnliftedRep-mutableByteArrayPrimTyCon  = pcPrimTyCon mutableByteArrayPrimTyConName  [Nominal] UnliftedRep-byteArrayPrimTyCon         = pcPrimTyCon0 byteArrayPrimTyConName        UnliftedRep-arrayArrayPrimTyCon        = pcPrimTyCon0 arrayArrayPrimTyConName       UnliftedRep-mutableArrayArrayPrimTyCon = pcPrimTyCon mutableArrayArrayPrimTyConName [Nominal] UnliftedRep-smallArrayPrimTyCon        = pcPrimTyCon smallArrayPrimTyConName        [Representational] UnliftedRep-smallMutableArrayPrimTyCon = pcPrimTyCon smallMutableArrayPrimTyConName [Nominal, Representational] UnliftedRep+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 [elt]+mkArrayPrimTy elt           = TyConApp arrayPrimTyCon [getLevity elt, elt] byteArrayPrimTy :: Type byteArrayPrimTy             = mkTyConTy byteArrayPrimTyCon-mkArrayArrayPrimTy :: Type-mkArrayArrayPrimTy = mkTyConTy arrayArrayPrimTyCon mkSmallArrayPrimTy :: Type -> Type-mkSmallArrayPrimTy elt = TyConApp smallArrayPrimTyCon [elt]+mkSmallArrayPrimTy elt = TyConApp smallArrayPrimTyCon [getLevity elt, elt] mkMutableArrayPrimTy :: Type -> Type -> Type-mkMutableArrayPrimTy s elt  = TyConApp mutableArrayPrimTyCon [s, elt]+mkMutableArrayPrimTy s elt  = TyConApp mutableArrayPrimTyCon [getLevity elt, s, elt] mkMutableByteArrayPrimTy :: Type -> Type mkMutableByteArrayPrimTy s  = TyConApp mutableByteArrayPrimTyCon [s]-mkMutableArrayArrayPrimTy :: Type -> Type-mkMutableArrayArrayPrimTy s = TyConApp mutableArrayArrayPrimTyCon [s] mkSmallMutableArrayPrimTy :: Type -> Type -> Type-mkSmallMutableArrayPrimTy s elt = TyConApp smallMutableArrayPrimTyCon [s, elt]+mkSmallMutableArrayPrimTy s elt = TyConApp smallMutableArrayPrimTyCon [getLevity elt, s, elt]   {- *********************************************************************@@ -1016,10 +1014,10 @@ ********************************************************************* -}  mutVarPrimTyCon :: TyCon-mutVarPrimTyCon = pcPrimTyCon mutVarPrimTyConName [Nominal, Representational] UnliftedRep+mutVarPrimTyCon = pcPrimTyCon_LevPolyLastArg mutVarPrimTyConName [Nominal, Representational] unliftedRepTy  mkMutVarPrimTy :: Type -> Type -> Type-mkMutVarPrimTy s elt        = TyConApp mutVarPrimTyCon [s, elt]+mkMutVarPrimTy s elt        = TyConApp mutVarPrimTyCon [getLevity elt, s, elt]  {- ************************************************************************@@ -1030,10 +1028,10 @@ -}  ioPortPrimTyCon :: TyCon-ioPortPrimTyCon = pcPrimTyCon ioPortPrimTyConName [Nominal, Representational] UnliftedRep+ioPortPrimTyCon = pcPrimTyCon_LevPolyLastArg ioPortPrimTyConName [Nominal, Representational] unliftedRepTy  mkIOPortPrimTy :: Type -> Type -> Type-mkIOPortPrimTy s elt          = TyConApp ioPortPrimTyCon [s, elt]+mkIOPortPrimTy s elt          = TyConApp ioPortPrimTyCon [getLevity elt, s, elt]  {- ************************************************************************@@ -1045,10 +1043,10 @@ -}  mVarPrimTyCon :: TyCon-mVarPrimTyCon = pcPrimTyCon mVarPrimTyConName [Nominal, Representational] UnliftedRep+mVarPrimTyCon = pcPrimTyCon_LevPolyLastArg mVarPrimTyConName [Nominal, Representational] unliftedRepTy  mkMVarPrimTy :: Type -> Type -> Type-mkMVarPrimTy s elt          = TyConApp mVarPrimTyCon [s, elt]+mkMVarPrimTy s elt          = TyConApp mVarPrimTyCon [getLevity elt, s, elt]  {- ************************************************************************@@ -1059,10 +1057,10 @@ -}  tVarPrimTyCon :: TyCon-tVarPrimTyCon = pcPrimTyCon tVarPrimTyConName [Nominal, Representational] UnliftedRep+tVarPrimTyCon = pcPrimTyCon_LevPolyLastArg tVarPrimTyConName [Nominal, Representational] unliftedRepTy  mkTVarPrimTy :: Type -> Type -> Type-mkTVarPrimTy s elt = TyConApp tVarPrimTyCon [s, elt]+mkTVarPrimTy s elt = TyConApp tVarPrimTyCon [getLevity elt, s, elt]  {- ************************************************************************@@ -1073,10 +1071,10 @@ -}  stablePtrPrimTyCon :: TyCon-stablePtrPrimTyCon = pcPrimTyCon stablePtrPrimTyConName [Representational] AddrRep+stablePtrPrimTyCon = pcPrimTyCon_LevPolyLastArg stablePtrPrimTyConName [Representational] addrRepDataConTy  mkStablePtrPrimTy :: Type -> Type-mkStablePtrPrimTy ty = TyConApp stablePtrPrimTyCon [ty]+mkStablePtrPrimTy ty = TyConApp stablePtrPrimTyCon [getLevity ty, ty]  {- ************************************************************************@@ -1087,10 +1085,10 @@ -}  stableNamePrimTyCon :: TyCon-stableNamePrimTyCon = pcPrimTyCon stableNamePrimTyConName [Phantom] UnliftedRep+stableNamePrimTyCon = pcPrimTyCon_LevPolyLastArg stableNamePrimTyConName [Phantom] unliftedRepTy  mkStableNamePrimTy :: Type -> Type-mkStableNamePrimTy ty = TyConApp stableNamePrimTyCon [ty]+mkStableNamePrimTy ty = TyConApp stableNamePrimTyCon [getLevity ty, ty]  {- ************************************************************************@@ -1101,7 +1099,7 @@ -}  compactPrimTyCon :: TyCon-compactPrimTyCon = pcPrimTyCon0 compactPrimTyConName UnliftedRep+compactPrimTyCon = pcPrimTyCon0 compactPrimTyConName unliftedRepTy  compactPrimTy :: Type compactPrimTy = mkTyConTy compactPrimTyCon@@ -1109,6 +1107,21 @@ {- ************************************************************************ *                                                                      *+   The @StackSnapshot#@ type+*                                                                      *+************************************************************************+-}++stackSnapshotPrimTyCon :: TyCon+stackSnapshotPrimTyCon = pcPrimTyCon0 stackSnapshotPrimTyConName unliftedRepTy++stackSnapshotPrimTy :: Type+stackSnapshotPrimTy = mkTyConTy stackSnapshotPrimTyCon+++{-+************************************************************************+*                                                                      *    The ``bytecode object'' type *                                                                      * ************************************************************************@@ -1120,7 +1133,7 @@ bcoPrimTy    :: Type bcoPrimTy    = mkTyConTy bcoPrimTyCon bcoPrimTyCon :: TyCon-bcoPrimTyCon = pcPrimTyCon0 bcoPrimTyConName LiftedRep+bcoPrimTyCon = pcPrimTyCon0 bcoPrimTyConName liftedRepTy  {- ************************************************************************@@ -1131,10 +1144,10 @@ -}  weakPrimTyCon :: TyCon-weakPrimTyCon = pcPrimTyCon weakPrimTyConName [Representational] UnliftedRep+weakPrimTyCon = pcPrimTyCon_LevPolyLastArg weakPrimTyConName [Representational] unliftedRepTy  mkWeakPrimTy :: Type -> Type-mkWeakPrimTy v = TyConApp weakPrimTyCon [v]+mkWeakPrimTy v = TyConApp weakPrimTyCon [getLevity v, v]  {- ************************************************************************@@ -1156,7 +1169,7 @@ threadIdPrimTy :: Type threadIdPrimTy    = mkTyConTy threadIdPrimTyCon threadIdPrimTyCon :: TyCon-threadIdPrimTyCon = pcPrimTyCon0 threadIdPrimTyConName UnliftedRep+threadIdPrimTyCon = pcPrimTyCon0 threadIdPrimTyConName unliftedRepTy  {- ************************************************************************
GHC/Builtin/Uniques.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE CPP #-} + -- | 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,@@ -29,16 +29,13 @@     , mkPrimOpIdUnique, mkPrimOpWrapperUnique     , mkPreludeMiscIdUnique, mkPreludeDataConUnique     , mkPreludeTyConUnique, mkPreludeClassUnique-    , mkCoVarUnique      , mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique     , mkRegSingleUnique, mkRegPairUnique, mkRegClassUnique, mkRegSubUnique     , mkCostCentreUnique      , mkBuiltinUnique-    , mkPseudoUniqueD     , mkPseudoUniqueE-    , mkPseudoUniqueH        -- ** Deriving uniquesc       -- *** From TyCon name uniques@@ -46,13 +43,10 @@       -- *** From DataCon name uniques     , dataConWorkerUnique, dataConTyRepNameUnique -    , initTyVarUnique     , initExitJoinUnique      ) where -#include "HsVersions.h"- import GHC.Prelude  import {-# SOURCE #-} GHC.Builtin.Types@@ -65,8 +59,8 @@ import GHC.Data.FastString  import GHC.Utils.Outputable-import GHC.Utils.Misc import GHC.Utils.Panic+import GHC.Utils.Panic.Plain  import Data.Maybe @@ -113,8 +107,8 @@  mkSumTyConUnique :: Arity -> Unique mkSumTyConUnique arity =-    ASSERT(arity < 0x3f) -- 0x3f since we only have 6 bits to encode the-                         -- alternative+    assert (arity < 0x3f) $ -- 0x3f since we only have 6 bits to encode the+                            -- alternative     mkUnique 'z' (arity `shiftL` 8 .|. 0xfc)  mkSumDataConUnique :: ConTagZ -> Arity -> Unique@@ -149,7 +143,6 @@  -- 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@@ -162,7 +155,6 @@ {- 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@@ -292,7 +284,7 @@ Note [Uniques for wired-in prelude things and known masks] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Allocation of unique supply characters:-        v,t,u : for renumbering value-, type- and usage- vars.+        v,u: for renumbering value-, and usage- vars.         B:   builtin         C-E: pseudo uniques     (used in native-code generator)         I:   GHCi evaluation@@ -308,7 +300,6 @@         c       StgToCmm/Renamer         d       desugarer         f       AbsC flattener-        g       SimplStg         i       TypeChecking interface files         j       constraint tuple superclass selectors         k       constraint tuple tycons@@ -327,10 +318,8 @@ -- See Note [Primop wrappers] in GHC.Builtin.PrimOps. mkPrimOpWrapperUnique  :: Int -> Unique mkPreludeMiscIdUnique  :: Int -> Unique-mkCoVarUnique          :: Int -> Unique  mkAlphaTyVarUnique   i = mkUnique '1' i-mkCoVarUnique        i = mkUnique 'g' i mkPreludeClassUnique i = mkUnique '2' i  --------------------------------------------------@@ -338,19 +327,10 @@ mkPrimOpWrapperUnique op    = mkUnique '9' (2*op+1) mkPreludeMiscIdUnique  i    = mkUnique '0' i --- The "tyvar uniques" print specially nicely: a, b, c, etc.--- See pprUnique for details--initTyVarUnique :: Unique-initTyVarUnique = mkUnique 't' 0--mkPseudoUniqueD, mkPseudoUniqueE, mkPseudoUniqueH,-  mkBuiltinUnique :: Int -> Unique+mkPseudoUniqueE, mkBuiltinUnique :: Int -> Unique  mkBuiltinUnique i = mkUnique 'B' i-mkPseudoUniqueD i = mkUnique 'D' i -- used in NCG for getUnique on RealRegs mkPseudoUniqueE i = mkUnique 'E' i -- used in NCG spiller to create spill VirtualRegs-mkPseudoUniqueH i = mkUnique 'H' i -- used in NCG spiller to create spill VirtualRegs  mkRegSingleUnique, mkRegPairUnique, mkRegSubUnique, mkRegClassUnique :: Int -> Unique mkRegSingleUnique = mkUnique 'R'@@ -390,7 +370,7 @@ --    * u+2: the TyConRepName of the promoted TyCon -- Prelude data constructors are too simple to need wrappers. -mkPreludeDataConUnique :: Arity -> Unique+mkPreludeDataConUnique :: Int -> Unique mkPreludeDataConUnique i              = mkUnique '6' (3*i)    -- Must be alphabetic  --------------------------------------------------
GHC/Builtin/Uniques.hs-boot view
@@ -23,18 +23,16 @@ mkPrimOpIdUnique       :: Int -> Unique mkPrimOpWrapperUnique  :: Int -> Unique mkPreludeMiscIdUnique  :: Int -> Unique-mkCoVarUnique          :: Int -> Unique -mkPseudoUniqueD, mkPseudoUniqueE, mkPseudoUniqueH,-  mkBuiltinUnique :: Int -> Unique+mkPseudoUniqueE, mkBuiltinUnique :: Int -> Unique  mkRegSingleUnique, mkRegPairUnique, mkRegSubUnique, mkRegClassUnique :: Int -> Unique mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique :: FastString -> Unique -initExitJoinUnique, initTyVarUnique :: Unique+initExitJoinUnique :: Unique  mkPreludeTyConUnique   :: Int -> Unique tyConRepNameUnique :: Unique -> Unique -mkPreludeDataConUnique :: Arity -> Unique+mkPreludeDataConUnique :: Int -> Unique dataConTyRepNameUnique, dataConWorkerUnique :: Unique -> Unique
GHC/Builtin/Utils.hs view
@@ -3,8 +3,8 @@  -} -{-# LANGUAGE CPP #-} + -- | The @GHC.Builtin.Utils@ interface to the compiler's prelude knowledge. -- -- This module serves as the central gathering point for names which the@@ -31,11 +31,9 @@          -- * Miscellaneous         wiredInIds, ghcPrimIds,-        primOpRules, builtinRules,          ghcPrimExports,         ghcPrimDeclDocs,-        primOpId,          -- * Random other things         maybeCharLikeCon, maybeIntLikeCon,@@ -45,12 +43,11 @@      ) where -#include "HsVersions.h"- 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@@ -58,7 +55,6 @@ import GHC.Builtin.Names  import GHC.Core.ConLike ( ConLike(..) )-import GHC.Core.Opt.ConstantFold import GHC.Core.DataCon import GHC.Core.Class import GHC.Core.TyCon@@ -69,20 +65,22 @@ import GHC.Types.Name.Env import GHC.Types.Id.Make import GHC.Types.Unique.FM+import GHC.Types.Unique.Map import GHC.Types.TyThing import GHC.Types.Unique ( isValidKnownKeyUnique )  import GHC.Utils.Outputable import GHC.Utils.Misc as Utils import GHC.Utils.Panic+import GHC.Utils.Constants (debugIsOn) import GHC.Hs.Doc import GHC.Unit.Module.ModIface (IfaceExport) +import GHC.Data.List.SetOps+ import Control.Applicative ((<|>)) import Data.List        ( intercalate , find )-import Data.Array import Data.Maybe-import qualified Data.Map as Map  {- ************************************************************************@@ -132,7 +130,7 @@              , concatMap wired_tycon_kk_names wiredInTyCons              , concatMap wired_tycon_kk_names typeNatTyCons              , map idName wiredInIds-             , map (idName . primOpId) allThePrimOps+             , map idName allThePrimOpIds              , map (idName . primOpWrapperId) allThePrimOps              , basicKnownKeyNames              , templateHaskellNames@@ -229,22 +227,8 @@ We let a lot of "non-standard" values be visible, so that we can make sense of them in interface pragmas. It's cool, though they all have "non-standard" names, so they won't get past the parser in user code.--************************************************************************-*                                                                      *-                PrimOpIds-*                                                                      *-************************************************************************ -} -primOpIds :: Array Int Id--- A cache of the PrimOp Ids, indexed by PrimOp tag-primOpIds = array (1,maxPrimOpTag) [ (primOpTag op, mkPrimOpId op)-                                   | op <- allThePrimOps ]--primOpId :: PrimOp -> Id-primOpId op = primOpIds ! primOpTag op- {- ************************************************************************ *                                                                      *@@ -256,19 +240,19 @@ ghcPrimExports :: [IfaceExport] ghcPrimExports  = map (avail . idName) ghcPrimIds ++-   map (avail . idName . primOpId) allThePrimOps +++   map (avail . idName) allThePrimOpIds ++    [ availTC n [n] []    | tc <- exposedPrimTyCons, let n = tyConName tc  ] -ghcPrimDeclDocs :: DeclDocMap-ghcPrimDeclDocs = DeclDocMap $ Map.fromList $ mapMaybe findName primOpDocs+ghcPrimDeclDocs :: Docs+ghcPrimDeclDocs = emptyDocs { docs_decls = listToUniqMap $ mapMaybe findName primOpDocs }   where     names = map idName ghcPrimIds ++-            map (idName . primOpId) allThePrimOps +++            map idName allThePrimOpIds ++             map tyConName exposedPrimTyCons     findName (nameStr, doc)       | Just name <- find ((nameStr ==) . getOccString) names-      = Just (name, mkHsDocString doc)+      = Just (name, [WithHsDocIdentifiers (mkGeneratedHsDocString doc) []])       | otherwise = Nothing  {-
+ GHC/Builtin/bytearray-ops.txt.pp view
@@ -0,0 +1,551 @@++------------------------------------+-- ByteArray# operations+------------------------------------+++-- Do not edit. This file is generated by utils/genprimopcode/gen_bytearray_ops.py.+-- To regenerate run,+--+--      python3 utils/genprimops/gen_bytearray_ops.py > compiler/GHC/Builtin/bytearray-ops.txt.pp+++------------------------------------+-- aligned index operations+------------------------------------++primop IndexByteArrayOp_Char "indexCharArray#" GenPrimOp+   ByteArray# -> Int# -> Char#+   {Read a 8-bit character; offset in bytes.}+   with can_fail = True++primop IndexByteArrayOp_WideChar "indexWideCharArray#" GenPrimOp+   ByteArray# -> Int# -> Char#+   {Read a 32-bit character; offset in 4-byte words.}+   with can_fail = True++primop IndexByteArrayOp_Int "indexIntArray#" GenPrimOp+   ByteArray# -> Int# -> Int#+   {Read a word-sized integer; offset in machine words.}+   with can_fail = True++primop IndexByteArrayOp_Word "indexWordArray#" GenPrimOp+   ByteArray# -> Int# -> Word#+   {Read a word-sized unsigned integer; offset in machine words.}+   with can_fail = True++primop IndexByteArrayOp_Addr "indexAddrArray#" GenPrimOp+   ByteArray# -> Int# -> Addr#+   {Read a machine address; offset in machine words.}+   with can_fail = True++primop IndexByteArrayOp_Float "indexFloatArray#" GenPrimOp+   ByteArray# -> Int# -> Float#+   {Read a single-precision floating-point value; offset in 4-byte words.}+   with can_fail = True++primop IndexByteArrayOp_Double "indexDoubleArray#" GenPrimOp+   ByteArray# -> Int# -> Double#+   {Read a double-precision floating-point value; offset in 8-byte words.}+   with can_fail = True++primop IndexByteArrayOp_StablePtr "indexStablePtrArray#" GenPrimOp+   ByteArray# -> Int# -> StablePtr# a+   {Read a {\tt StablePtr#} value; offset in machine words.}+   with can_fail = True++primop IndexByteArrayOp_Int8 "indexInt8Array#" GenPrimOp+   ByteArray# -> Int# -> Int8#+   {Read a 8-bit signed integer; offset in bytes.}+   with can_fail = True++primop IndexByteArrayOp_Int16 "indexInt16Array#" GenPrimOp+   ByteArray# -> Int# -> Int16#+   {Read a 16-bit signed integer; offset in 2-byte words.}+   with can_fail = True++primop IndexByteArrayOp_Int32 "indexInt32Array#" GenPrimOp+   ByteArray# -> Int# -> Int32#+   {Read a 32-bit signed integer; offset in 4-byte words.}+   with can_fail = True++primop IndexByteArrayOp_Int64 "indexInt64Array#" GenPrimOp+   ByteArray# -> Int# -> Int64#+   {Read a 64-bit signed integer; offset in 8-byte words.}+   with can_fail = True++primop IndexByteArrayOp_Word8 "indexWord8Array#" GenPrimOp+   ByteArray# -> Int# -> Word8#+   {Read a 8-bit unsigned integer; offset in bytes.}+   with can_fail = True++primop IndexByteArrayOp_Word16 "indexWord16Array#" GenPrimOp+   ByteArray# -> Int# -> Word16#+   {Read a 16-bit unsigned integer; offset in 2-byte words.}+   with can_fail = True++primop IndexByteArrayOp_Word32 "indexWord32Array#" GenPrimOp+   ByteArray# -> Int# -> Word32#+   {Read a 32-bit unsigned integer; offset in 4-byte words.}+   with can_fail = True++primop IndexByteArrayOp_Word64 "indexWord64Array#" GenPrimOp+   ByteArray# -> Int# -> Word64#+   {Read a 64-bit unsigned integer; offset in 8-byte words.}+   with can_fail = True+++------------------------------------+-- unaligned index operations+------------------------------------++primop IndexByteArrayOp_Word8AsChar "indexWord8ArrayAsChar#" GenPrimOp+   ByteArray# -> Int# -> Char#+   {Read a 8-bit character; offset in bytes.}+   with can_fail = True++primop IndexByteArrayOp_Word8AsWideChar "indexWord8ArrayAsWideChar#" GenPrimOp+   ByteArray# -> Int# -> Char#+   {Read a 32-bit character; offset in bytes.}+   with can_fail = True++primop IndexByteArrayOp_Word8AsInt "indexWord8ArrayAsInt#" GenPrimOp+   ByteArray# -> Int# -> Int#+   {Read a word-sized integer; offset in bytes.}+   with can_fail = True++primop IndexByteArrayOp_Word8AsWord "indexWord8ArrayAsWord#" GenPrimOp+   ByteArray# -> Int# -> Word#+   {Read a word-sized unsigned integer; offset in bytes.}+   with can_fail = True++primop IndexByteArrayOp_Word8AsAddr "indexWord8ArrayAsAddr#" GenPrimOp+   ByteArray# -> Int# -> Addr#+   {Read a machine address; offset in bytes.}+   with can_fail = True++primop IndexByteArrayOp_Word8AsFloat "indexWord8ArrayAsFloat#" GenPrimOp+   ByteArray# -> Int# -> Float#+   {Read a single-precision floating-point value; offset in bytes.}+   with can_fail = True++primop IndexByteArrayOp_Word8AsDouble "indexWord8ArrayAsDouble#" GenPrimOp+   ByteArray# -> Int# -> Double#+   {Read a double-precision floating-point value; offset in bytes.}+   with can_fail = True++primop IndexByteArrayOp_Word8AsStablePtr "indexWord8ArrayAsStablePtr#" GenPrimOp+   ByteArray# -> Int# -> StablePtr# a+   {Read a {\tt StablePtr#} value; offset in bytes.}+   with can_fail = True++primop IndexByteArrayOp_Word8AsInt16 "indexWord8ArrayAsInt16#" GenPrimOp+   ByteArray# -> Int# -> Int16#+   {Read a 16-bit signed integer; offset in bytes.}+   with can_fail = True++primop IndexByteArrayOp_Word8AsInt32 "indexWord8ArrayAsInt32#" GenPrimOp+   ByteArray# -> Int# -> Int32#+   {Read a 32-bit signed integer; offset in bytes.}+   with can_fail = True++primop IndexByteArrayOp_Word8AsInt64 "indexWord8ArrayAsInt64#" GenPrimOp+   ByteArray# -> Int# -> Int64#+   {Read a 64-bit signed integer; offset in bytes.}+   with can_fail = True++primop IndexByteArrayOp_Word8AsWord16 "indexWord8ArrayAsWord16#" GenPrimOp+   ByteArray# -> Int# -> Word16#+   {Read a 16-bit unsigned integer; offset in bytes.}+   with can_fail = True++primop IndexByteArrayOp_Word8AsWord32 "indexWord8ArrayAsWord32#" GenPrimOp+   ByteArray# -> Int# -> Word32#+   {Read a 32-bit unsigned integer; offset in bytes.}+   with can_fail = True++primop IndexByteArrayOp_Word8AsWord64 "indexWord8ArrayAsWord64#" GenPrimOp+   ByteArray# -> Int# -> Word64#+   {Read a 64-bit unsigned integer; offset in bytes.}+   with can_fail = True+++------------------------------------+-- aligned read operations+------------------------------------++primop ReadByteArrayOp_Char "readCharArray#" GenPrimOp+   MutableByteArray# s -> Int# -> State# s -> (# State# s, Char# #)+   {Read a 8-bit character; offset in bytes.}+   with has_side_effects = True+        can_fail = True++primop ReadByteArrayOp_WideChar "readWideCharArray#" GenPrimOp+   MutableByteArray# s -> Int# -> State# s -> (# State# s, Char# #)+   {Read a 32-bit character; offset in 4-byte words.}+   with has_side_effects = True+        can_fail = True++primop ReadByteArrayOp_Int "readIntArray#" GenPrimOp+   MutableByteArray# s -> Int# -> State# s -> (# State# s, Int# #)+   {Read a word-sized integer; offset in machine words.}+   with has_side_effects = True+        can_fail = True++primop ReadByteArrayOp_Word "readWordArray#" GenPrimOp+   MutableByteArray# s -> Int# -> State# s -> (# State# s, Word# #)+   {Read a word-sized unsigned integer; offset in machine words.}+   with has_side_effects = True+        can_fail = True++primop ReadByteArrayOp_Addr "readAddrArray#" GenPrimOp+   MutableByteArray# s -> Int# -> State# s -> (# State# s, Addr# #)+   {Read a machine address; offset in machine words.}+   with has_side_effects = True+        can_fail = True++primop ReadByteArrayOp_Float "readFloatArray#" GenPrimOp+   MutableByteArray# s -> Int# -> State# s -> (# State# s, Float# #)+   {Read a single-precision floating-point value; offset in 4-byte words.}+   with has_side_effects = True+        can_fail = True++primop ReadByteArrayOp_Double "readDoubleArray#" GenPrimOp+   MutableByteArray# s -> Int# -> State# s -> (# State# s, Double# #)+   {Read a double-precision floating-point value; offset in 8-byte words.}+   with has_side_effects = True+        can_fail = True++primop ReadByteArrayOp_StablePtr "readStablePtrArray#" GenPrimOp+   MutableByteArray# s -> Int# -> State# s -> (# State# s, StablePtr# a #)+   {Read a {\tt StablePtr#} value; offset in machine words.}+   with has_side_effects = True+        can_fail = True++primop ReadByteArrayOp_Int8 "readInt8Array#" GenPrimOp+   MutableByteArray# s -> Int# -> State# s -> (# State# s, Int8# #)+   {Read a 8-bit signed integer; offset in bytes.}+   with has_side_effects = True+        can_fail = True++primop ReadByteArrayOp_Int16 "readInt16Array#" GenPrimOp+   MutableByteArray# s -> Int# -> State# s -> (# State# s, Int16# #)+   {Read a 16-bit signed integer; offset in 2-byte words.}+   with has_side_effects = True+        can_fail = True++primop ReadByteArrayOp_Int32 "readInt32Array#" GenPrimOp+   MutableByteArray# s -> Int# -> State# s -> (# State# s, Int32# #)+   {Read a 32-bit signed integer; offset in 4-byte words.}+   with has_side_effects = True+        can_fail = True++primop ReadByteArrayOp_Int64 "readInt64Array#" GenPrimOp+   MutableByteArray# s -> Int# -> State# s -> (# State# s, Int64# #)+   {Read a 64-bit signed integer; offset in 8-byte words.}+   with has_side_effects = True+        can_fail = True++primop ReadByteArrayOp_Word8 "readWord8Array#" GenPrimOp+   MutableByteArray# s -> Int# -> State# s -> (# State# s, Word8# #)+   {Read a 8-bit unsigned integer; offset in bytes.}+   with has_side_effects = True+        can_fail = True++primop ReadByteArrayOp_Word16 "readWord16Array#" GenPrimOp+   MutableByteArray# s -> Int# -> State# s -> (# State# s, Word16# #)+   {Read a 16-bit unsigned integer; offset in 2-byte words.}+   with has_side_effects = True+        can_fail = True++primop ReadByteArrayOp_Word32 "readWord32Array#" GenPrimOp+   MutableByteArray# s -> Int# -> State# s -> (# State# s, Word32# #)+   {Read a 32-bit unsigned integer; offset in 4-byte words.}+   with has_side_effects = True+        can_fail = True++primop ReadByteArrayOp_Word64 "readWord64Array#" GenPrimOp+   MutableByteArray# s -> Int# -> State# s -> (# State# s, Word64# #)+   {Read a 64-bit unsigned integer; offset in 8-byte words.}+   with has_side_effects = True+        can_fail = True+++------------------------------------+-- unaligned read operations+------------------------------------++primop ReadByteArrayOp_Word8AsChar "readWord8ArrayAsChar#" GenPrimOp+   MutableByteArray# s -> Int# -> State# s -> (# State# s, Char# #)+   {Read a 8-bit character; offset in bytes.}+   with has_side_effects = True+        can_fail = True++primop ReadByteArrayOp_Word8AsWideChar "readWord8ArrayAsWideChar#" GenPrimOp+   MutableByteArray# s -> Int# -> State# s -> (# State# s, Char# #)+   {Read a 32-bit character; offset in bytes.}+   with has_side_effects = True+        can_fail = True++primop ReadByteArrayOp_Word8AsInt "readWord8ArrayAsInt#" GenPrimOp+   MutableByteArray# s -> Int# -> State# s -> (# State# s, Int# #)+   {Read a word-sized integer; offset in bytes.}+   with has_side_effects = True+        can_fail = True++primop ReadByteArrayOp_Word8AsWord "readWord8ArrayAsWord#" GenPrimOp+   MutableByteArray# s -> Int# -> State# s -> (# State# s, Word# #)+   {Read a word-sized unsigned integer; offset in bytes.}+   with has_side_effects = True+        can_fail = True++primop ReadByteArrayOp_Word8AsAddr "readWord8ArrayAsAddr#" GenPrimOp+   MutableByteArray# s -> Int# -> State# s -> (# State# s, Addr# #)+   {Read a machine address; offset in bytes.}+   with has_side_effects = True+        can_fail = True++primop ReadByteArrayOp_Word8AsFloat "readWord8ArrayAsFloat#" GenPrimOp+   MutableByteArray# s -> Int# -> State# s -> (# State# s, Float# #)+   {Read a single-precision floating-point value; offset in bytes.}+   with has_side_effects = True+        can_fail = True++primop ReadByteArrayOp_Word8AsDouble "readWord8ArrayAsDouble#" GenPrimOp+   MutableByteArray# s -> Int# -> State# s -> (# State# s, Double# #)+   {Read a double-precision floating-point value; offset in bytes.}+   with has_side_effects = True+        can_fail = True++primop ReadByteArrayOp_Word8AsStablePtr "readWord8ArrayAsStablePtr#" GenPrimOp+   MutableByteArray# s -> Int# -> State# s -> (# State# s, StablePtr# a #)+   {Read a {\tt StablePtr#} value; offset in bytes.}+   with has_side_effects = True+        can_fail = True++primop ReadByteArrayOp_Word8AsInt16 "readWord8ArrayAsInt16#" GenPrimOp+   MutableByteArray# s -> Int# -> State# s -> (# State# s, Int16# #)+   {Read a 16-bit signed integer; offset in bytes.}+   with has_side_effects = True+        can_fail = True++primop ReadByteArrayOp_Word8AsInt32 "readWord8ArrayAsInt32#" GenPrimOp+   MutableByteArray# s -> Int# -> State# s -> (# State# s, Int32# #)+   {Read a 32-bit signed integer; offset in bytes.}+   with has_side_effects = True+        can_fail = True++primop ReadByteArrayOp_Word8AsInt64 "readWord8ArrayAsInt64#" GenPrimOp+   MutableByteArray# s -> Int# -> State# s -> (# State# s, Int64# #)+   {Read a 64-bit signed integer; offset in bytes.}+   with has_side_effects = True+        can_fail = True++primop ReadByteArrayOp_Word8AsWord16 "readWord8ArrayAsWord16#" GenPrimOp+   MutableByteArray# s -> Int# -> State# s -> (# State# s, Word16# #)+   {Read a 16-bit unsigned integer; offset in bytes.}+   with has_side_effects = True+        can_fail = True++primop ReadByteArrayOp_Word8AsWord32 "readWord8ArrayAsWord32#" GenPrimOp+   MutableByteArray# s -> Int# -> State# s -> (# State# s, Word32# #)+   {Read a 32-bit unsigned integer; offset in bytes.}+   with has_side_effects = True+        can_fail = True++primop ReadByteArrayOp_Word8AsWord64 "readWord8ArrayAsWord64#" GenPrimOp+   MutableByteArray# s -> Int# -> State# s -> (# State# s, Word64# #)+   {Read a 64-bit unsigned integer; offset in bytes.}+   with has_side_effects = True+        can_fail = True+++------------------------------------+-- aligned write operations+------------------------------------++primop WriteByteArrayOp_Char "writeCharArray#" GenPrimOp+   MutableByteArray# s -> Int# -> Char# -> State# s -> State# s+   {Write a 8-bit character; offset in bytes.}+   with has_side_effects = True+        can_fail = True++primop WriteByteArrayOp_WideChar "writeWideCharArray#" GenPrimOp+   MutableByteArray# s -> Int# -> Char# -> State# s -> State# s+   {Write a 32-bit character; offset in 4-byte words.}+   with has_side_effects = True+        can_fail = True++primop WriteByteArrayOp_Int "writeIntArray#" GenPrimOp+   MutableByteArray# s -> Int# -> Int# -> State# s -> State# s+   {Write a word-sized integer; offset in machine words.}+   with has_side_effects = True+        can_fail = True++primop WriteByteArrayOp_Word "writeWordArray#" GenPrimOp+   MutableByteArray# s -> Int# -> Word# -> State# s -> State# s+   {Write a word-sized unsigned integer; offset in machine words.}+   with has_side_effects = True+        can_fail = True++primop WriteByteArrayOp_Addr "writeAddrArray#" GenPrimOp+   MutableByteArray# s -> Int# -> Addr# -> State# s -> State# s+   {Write a machine address; offset in machine words.}+   with has_side_effects = True+        can_fail = True++primop WriteByteArrayOp_Float "writeFloatArray#" GenPrimOp+   MutableByteArray# s -> Int# -> Float# -> State# s -> State# s+   {Write a single-precision floating-point value; offset in 4-byte words.}+   with has_side_effects = True+        can_fail = True++primop WriteByteArrayOp_Double "writeDoubleArray#" GenPrimOp+   MutableByteArray# s -> Int# -> Double# -> State# s -> State# s+   {Write a double-precision floating-point value; offset in 8-byte words.}+   with has_side_effects = True+        can_fail = True++primop WriteByteArrayOp_StablePtr "writeStablePtrArray#" GenPrimOp+   MutableByteArray# s -> Int# -> StablePtr# a -> State# s -> State# s+   {Write a {\tt StablePtr#} value; offset in machine words.}+   with has_side_effects = True+        can_fail = True++primop WriteByteArrayOp_Int8 "writeInt8Array#" GenPrimOp+   MutableByteArray# s -> Int# -> Int8# -> State# s -> State# s+   {Write a 8-bit signed integer; offset in bytes.}+   with has_side_effects = True+        can_fail = True++primop WriteByteArrayOp_Int16 "writeInt16Array#" GenPrimOp+   MutableByteArray# s -> Int# -> Int16# -> State# s -> State# s+   {Write a 16-bit signed integer; offset in 2-byte words.}+   with has_side_effects = True+        can_fail = True++primop WriteByteArrayOp_Int32 "writeInt32Array#" GenPrimOp+   MutableByteArray# s -> Int# -> Int32# -> State# s -> State# s+   {Write a 32-bit signed integer; offset in 4-byte words.}+   with has_side_effects = True+        can_fail = True++primop WriteByteArrayOp_Int64 "writeInt64Array#" GenPrimOp+   MutableByteArray# s -> Int# -> Int64# -> State# s -> State# s+   {Write a 64-bit signed integer; offset in 8-byte words.}+   with has_side_effects = True+        can_fail = True++primop WriteByteArrayOp_Word8 "writeWord8Array#" GenPrimOp+   MutableByteArray# s -> Int# -> Word8# -> State# s -> State# s+   {Write a 8-bit unsigned integer; offset in bytes.}+   with has_side_effects = True+        can_fail = True++primop WriteByteArrayOp_Word16 "writeWord16Array#" GenPrimOp+   MutableByteArray# s -> Int# -> Word16# -> State# s -> State# s+   {Write a 16-bit unsigned integer; offset in 2-byte words.}+   with has_side_effects = True+        can_fail = True++primop WriteByteArrayOp_Word32 "writeWord32Array#" GenPrimOp+   MutableByteArray# s -> Int# -> Word32# -> State# s -> State# s+   {Write a 32-bit unsigned integer; offset in 4-byte words.}+   with has_side_effects = True+        can_fail = True++primop WriteByteArrayOp_Word64 "writeWord64Array#" GenPrimOp+   MutableByteArray# s -> Int# -> Word64# -> State# s -> State# s+   {Write a 64-bit unsigned integer; offset in 8-byte words.}+   with has_side_effects = True+        can_fail = True+++------------------------------------+-- unaligned write operations+------------------------------------++primop WriteByteArrayOp_Word8AsChar "writeWord8ArrayAsChar#" GenPrimOp+   MutableByteArray# s -> Int# -> Char# -> State# s -> State# s+   {Write a 8-bit character; offset in bytes.}+   with has_side_effects = True+        can_fail = True++primop WriteByteArrayOp_Word8AsWideChar "writeWord8ArrayAsWideChar#" GenPrimOp+   MutableByteArray# s -> Int# -> Char# -> State# s -> State# s+   {Write a 32-bit character; offset in bytes.}+   with has_side_effects = True+        can_fail = True++primop WriteByteArrayOp_Word8AsInt "writeWord8ArrayAsInt#" GenPrimOp+   MutableByteArray# s -> Int# -> Int# -> State# s -> State# s+   {Write a word-sized integer; offset in bytes.}+   with has_side_effects = True+        can_fail = True++primop WriteByteArrayOp_Word8AsWord "writeWord8ArrayAsWord#" GenPrimOp+   MutableByteArray# s -> Int# -> Word# -> State# s -> State# s+   {Write a word-sized unsigned integer; offset in bytes.}+   with has_side_effects = True+        can_fail = True++primop WriteByteArrayOp_Word8AsAddr "writeWord8ArrayAsAddr#" GenPrimOp+   MutableByteArray# s -> Int# -> Addr# -> State# s -> State# s+   {Write a machine address; offset in bytes.}+   with has_side_effects = True+        can_fail = True++primop WriteByteArrayOp_Word8AsFloat "writeWord8ArrayAsFloat#" GenPrimOp+   MutableByteArray# s -> Int# -> Float# -> State# s -> State# s+   {Write a single-precision floating-point value; offset in bytes.}+   with has_side_effects = True+        can_fail = True++primop WriteByteArrayOp_Word8AsDouble "writeWord8ArrayAsDouble#" GenPrimOp+   MutableByteArray# s -> Int# -> Double# -> State# s -> State# s+   {Write a double-precision floating-point value; offset in bytes.}+   with has_side_effects = True+        can_fail = True++primop WriteByteArrayOp_Word8AsStablePtr "writeWord8ArrayAsStablePtr#" GenPrimOp+   MutableByteArray# s -> Int# -> StablePtr# a -> State# s -> State# s+   {Write a {\tt StablePtr#} value; offset in bytes.}+   with has_side_effects = True+        can_fail = True++primop WriteByteArrayOp_Word8AsInt16 "writeWord8ArrayAsInt16#" GenPrimOp+   MutableByteArray# s -> Int# -> Int16# -> State# s -> State# s+   {Write a 16-bit signed integer; offset in bytes.}+   with has_side_effects = True+        can_fail = True++primop WriteByteArrayOp_Word8AsInt32 "writeWord8ArrayAsInt32#" GenPrimOp+   MutableByteArray# s -> Int# -> Int32# -> State# s -> State# s+   {Write a 32-bit signed integer; offset in bytes.}+   with has_side_effects = True+        can_fail = True++primop WriteByteArrayOp_Word8AsInt64 "writeWord8ArrayAsInt64#" GenPrimOp+   MutableByteArray# s -> Int# -> Int64# -> State# s -> State# s+   {Write a 64-bit signed integer; offset in bytes.}+   with has_side_effects = True+        can_fail = True++primop WriteByteArrayOp_Word8AsWord16 "writeWord8ArrayAsWord16#" GenPrimOp+   MutableByteArray# s -> Int# -> Word16# -> State# s -> State# s+   {Write a 16-bit unsigned integer; offset in bytes.}+   with has_side_effects = True+        can_fail = True++primop WriteByteArrayOp_Word8AsWord32 "writeWord8ArrayAsWord32#" GenPrimOp+   MutableByteArray# s -> Int# -> Word32# -> State# s -> State# s+   {Write a 32-bit unsigned integer; offset in bytes.}+   with has_side_effects = True+        can_fail = True++primop WriteByteArrayOp_Word8AsWord64 "writeWord8ArrayAsWord64#" GenPrimOp+   MutableByteArray# s -> Int# -> Word64# -> State# s -> State# s+   {Write a 64-bit unsigned integer; offset in bytes.}+   with has_side_effects = True+        can_fail = True+
+ GHC/Builtin/primops.txt.pp view
@@ -0,0 +1,3916 @@+-----------------------------------------------------------------------+--+-- (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 genprimopcode.+--+--   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" {description}+--+-- This information is used solely when producing documentation; it is+-- otherwise ignored.  The description is optional.+--+-- The format of each primop entry is as follows:+--+--      primop internal-name "name-in-program-text" category type {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+   has_side_effects = False+   out_of_line      = False   -- See Note [When do out-of-line primops go in primops.txt.pp]+   can_fail         = False   -- See Note [PrimOp can_fail and has_side_effects] in PrimOp+   commutable       = False+   code_size        = { primOpCodeSizeDefault }+   strictness       = { \ arity -> mkClosedDmdSig (replicate arity topDmd) topDiv }+   fixity           = Nothing+   llvm_only        = False+   vector           = []+   deprecated_msg   = {}      -- A non-empty message indicates deprecation++-- 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>`+--   - `can_fail         = False`+--   - `has_side_effects = True`+--+-- 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.++-- Currently, documentation is produced using latex, so contents of+-- description fields should be legal latex. Descriptions can contain+-- matched pairs of embedded curly brackets.++-- 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 `v` and `w` stand for levity-polymorphic+--   type variables.+--   For example:+--      op :: v -> w -> Int+--   really means+--      op :: forall {l :: Levity} (a :: TYPE (BoxedRep l))+--                   {k :: Levity} (b :: TYPE (BoxedRep k)).+--            a -> b -> Int+--  Two important things to note:+--     - `v` and `w` have independent levities `l` and `k` (respectively), and+--       these are inferred (not specified), as seen from the curly brackets.+--     - `v` and `w` end up written as `a` and `b` (respectively) in types,+--       which means that one shouldn't write a primop type involving both+--       `a` and `v`, nor `b` and `w`.+--+-- * The names `o` and `p` stand for representation-polymorphic+--   type variables, similarly to `v` and `w` above. For example:+--      op :: o -> p -> Int+--   really means+--      op :: forall {q :: RuntimeRep} (a :: TYPE q)+--                   {r :: RuntimeRep} (b :: TYPE r)+--            a -> b -> Int+--   We note:+--    - `o` and `p` have independent `RuntimeRep`s `q` and `r`, which are+--       inferred type variables (like for `v` and `w` above).+--    - `o` and `p` share textual names with `a` and `b` (respectively).+--      This means one shouldn't write a type involving both `a` and `o`,+--      nor `b` and `p`, nor `o` and `v`, etc.++section "The word size story."+        {Haskell98 specifies that signed integers (type {\tt Int})+         must contain at least 30 bits. GHC always implements {\tt+         Int} using the primitive type {\tt Int\#}, whose size equals+         the {\tt MachDeps.h} constant {\tt WORD\_SIZE\_IN\_BITS}.+         This is normally set based on the {\tt config.h} parameter+         {\tt SIZEOF\_HSWORD}, i.e., 32 bits on 32-bit machines, 64+         bits on 64-bit machines.++         GHC also implements a primitive unsigned integer type {\tt+         Word\#} which always has the same number of bits as {\tt+         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 {\tt Addr\#}, the primitive type of machine+         addresses, and {\tt 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 {\tt 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+    can_fail = True++primop Int8RemOp "remInt8#" GenPrimOp Int8# -> Int8# -> Int8#+  with+    can_fail = True++primop Int8QuotRemOp "quotRemInt8#" GenPrimOp Int8# -> Int8# -> (# Int8#, Int8# #)+  with+    can_fail = 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+    can_fail = True++primop Word8RemOp "remWord8#" GenPrimOp Word8# -> Word8# -> Word8#+  with+    can_fail = True++primop Word8QuotRemOp "quotRemWord8#" GenPrimOp Word8# -> Word8# -> (# Word8#, Word8# #)+  with+    can_fail = 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+    can_fail = True++primop Int16RemOp "remInt16#" GenPrimOp Int16# -> Int16# -> Int16#+  with+    can_fail = True++primop Int16QuotRemOp "quotRemInt16#" GenPrimOp Int16# -> Int16# -> (# Int16#, Int16# #)+  with+    can_fail = 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+    can_fail = True++primop Word16RemOp "remWord16#" GenPrimOp Word16# -> Word16# -> Word16#+  with+    can_fail = True++primop Word16QuotRemOp "quotRemWord16#" GenPrimOp Word16# -> Word16# -> (# Word16#, Word16# #)+  with+    can_fail = 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+    can_fail = True++primop Int32RemOp "remInt32#" GenPrimOp Int32# -> Int32# -> Int32#+  with+    can_fail = True++primop Int32QuotRemOp "quotRemInt32#" GenPrimOp Int32# -> Int32# -> (# Int32#, Int32# #)+  with+    can_fail = 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+    can_fail = True++primop Word32RemOp "remWord32#" GenPrimOp Word32# -> Word32# -> Word32#+  with+    can_fail = True++primop Word32QuotRemOp "quotRemWord32#" GenPrimOp Word32# -> Word32# -> (# Word32#, Word32# #)+  with+    can_fail = 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+    can_fail = True++primop Int64RemOp "remInt64#" GenPrimOp Int64# -> Int64# -> Int64#+  with+    can_fail = 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+    can_fail = True++primop Word64RemOp "remWord64#" GenPrimOp Word64# -> Word64# -> Word64#+  with+    can_fail = 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+    \texttt{(*) :: 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 can_fail = True++primop   IntRemOp    "remInt#"    GenPrimOp+   Int# -> Int# -> Int#+   {Satisfies \texttt{(quotInt\# x y) *\# y +\# (remInt\# x y) == x}. The+    behavior is undefined if the second argument is zero.+   }+   with can_fail = True++primop   IntQuotRemOp "quotRemInt#"    GenPrimOp+   Int# -> Int# -> (# Int#, Int# #)+   {Rounds towards zero.}+   with can_fail = 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 {\tt Int#} range extends one further than the+    positive range, {\tt negateInt#} of the most negative number is an+    identity operation. This way, {\tt 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 {\tt Int#};+          second member is zero if the true sum fits in an {\tt Int#},+          nonzero if overflow occurred (the sum is either too large+          or too small to fit in an {\tt 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 {\tt Int#};+          second member is zero if the true difference fits in an {\tt Int#},+          nonzero if overflow occurred (the difference is either too large+          or too small to fit in an {\tt 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 {\tt Int#} to the corresponding {\tt Float#} with the same+    integral value (up to truncation due to floating-point precision). e.g.+    {\tt int2Float# 1# == 1.0#}}+primop   IntToDoubleOp   "int2Double#"          GenPrimOp  Int# -> Double#+   {Convert an {\tt Int#} to the corresponding {\tt Double#} with the same+    integral value (up to truncation due to floating-point precision). e.g.+    {\tt int2Double# 1# == 1.0##}}++primop   WordToFloatOp   "word2Float#"      GenPrimOp  Word# -> Float#+   {Convert an {\tt Word#} to the corresponding {\tt Float#} with the same+    integral value (up to truncation due to floating-point precision). e.g.+    {\tt word2Float# 1## == 1.0#}}+primop   WordToDoubleOp   "word2Double#"          GenPrimOp  Word# -> Double#+   {Convert an {\tt Word#} to the corresponding {\tt Double#} with the same+    integral value (up to truncation due to floating-point precision). e.g.+    {\tt 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 {\tt 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 {\tt 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 can_fail = True++primop   WordRemOp   "remWord#"   GenPrimOp   Word# -> Word# -> Word#+   with can_fail = True++primop   WordQuotRemOp "quotRemWord#" GenPrimOp+   Word# -> Word# -> (# Word#, Word# #)+   with can_fail = 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 can_fail = 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.}+primop   Pdep16Op   "pdep16#"   GenPrimOp   Word# -> Word# -> Word#+    {Deposit bits to lower 16 bits of a word at locations specified by a mask.}+primop   Pdep32Op   "pdep32#"   GenPrimOp   Word# -> Word# -> Word#+    {Deposit bits to lower 32 bits of a word at locations specified by a mask.}+primop   Pdep64Op   "pdep64#"   GenPrimOp   Word64# -> Word64# -> Word64#+    {Deposit bits to a word at locations specified by a mask.}+primop   PdepOp   "pdep#"   GenPrimOp   Word# -> Word# -> Word#+    {Deposit bits to a word at locations specified by a mask.}++primop   Pext8Op   "pext8#"   GenPrimOp   Word# -> Word# -> Word#+    {Extract bits from lower 8 bits of a word at locations specified by a mask.}+primop   Pext16Op   "pext16#"   GenPrimOp   Word# -> Word# -> Word#+    {Extract bits from lower 16 bits of a word at locations specified by a mask.}+primop   Pext32Op   "pext32#"   GenPrimOp   Word# -> Word# -> Word#+    {Extract bits from lower 32 bits of a word at locations specified by a mask.}+primop   Pext64Op   "pext64#"   GenPrimOp   Word64# -> Word64# -> Word64#+    {Extract bits from a word at locations specified by a mask.}+primop   PextOp   "pext#"   GenPrimOp   Word# -> Word# -> Word#+    {Extract bits from a word at locations specified by a mask.}++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. }+primop   BSwap32Op   "byteSwap32#"   GenPrimOp   Word# -> Word#+    {Swap bytes in the lower 32 bits of a word. The higher bytes are undefined. }+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.}+primop   BRev16Op   "bitReverse16#"   GenPrimOp   Word# -> Word#+    {Reverse the order of the bits in a 16-bit word.}+primop   BRev32Op   "bitReverse32#"   GenPrimOp   Word# -> Word#+    {Reverse the order of the bits in a 32-bit word.}+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   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 can_fail = True+        fixity = infixl 7++primop   DoubleNegOp   "negateDouble#"  GenPrimOp   Double# -> Double#++primop   DoubleFabsOp  "fabsDouble#"    GenPrimOp   Double# -> Double#++primop   DoubleToIntOp   "double2Int#"          GenPrimOp  Double# -> Int#+   {Truncates a {\tt Double#} value to the nearest {\tt Int#}.+    Results are undefined if the truncation if truncation yields+    a value outside the range of {\tt 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 }+   can_fail = True++primop   DoubleLog1POp   "log1pDouble#"      GenPrimOp+   Double# -> Double#+   with+   code_size = { primOpCodeSizeForeignCall }+   can_fail = True++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 }+   can_fail = True++primop   DoubleAcosOp   "acosDouble#"      GenPrimOp+   Double# -> Double#+   with+   code_size = { primOpCodeSizeForeignCall }+   can_fail = True++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 {\tt Double\#} into mantissa and base-2 exponent.}+   with out_of_line = True++------------------------------------------------------------------------+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   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 can_fail = True++primop   FloatNegOp   "negateFloat#"      GenPrimOp    Float# -> Float#++primop   FloatFabsOp  "fabsFloat#"        GenPrimOp    Float# -> Float#++primop   FloatToIntOp   "float2Int#"      GenPrimOp  Float# -> Int#+   {Truncates a {\tt Float#} value to the nearest {\tt Int#}.+    Results are undefined if the truncation if truncation yields+    a value outside the range of {\tt 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 }+   can_fail = True++primop   FloatLog1POp  "log1pFloat#"     GenPrimOp+   Float# -> Float#+   with+   code_size = { primOpCodeSizeForeignCall }+   can_fail = True++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 }+   can_fail = True++primop   FloatAcosOp   "acosFloat#"      GenPrimOp+   Float# -> Float#+   with+   code_size = { primOpCodeSizeForeignCall }+   can_fail = True++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 {\tt Int\#} in result is the mantissa; second is the exponent.}+   with out_of_line = True++------------------------------------------------------------------------+section "Arrays"+        {Operations on {\tt Array\#}.}+------------------------------------------------------------------------++primtype Array# a++primtype MutableArray# s a++primop  NewArrayOp "newArray#" GenPrimOp+   Int# -> v -> State# s -> (# State# s, MutableArray# s v #)+   {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+   has_side_effects = True++primop  ReadArrayOp "readArray#" GenPrimOp+   MutableArray# s v -> Int# -> State# s -> (# State# s, v #)+   {Read from specified index of mutable array. Result is not yet evaluated.}+   with+   has_side_effects = True+   can_fail         = True++primop  WriteArrayOp "writeArray#" GenPrimOp+   MutableArray# s v -> Int# -> v -> State# s -> State# s+   {Write to specified index of mutable array.}+   with+   has_side_effects = True+   can_fail         = True+   code_size        = 2 -- card update too++primop  SizeofArrayOp "sizeofArray#" GenPrimOp+   Array# v -> Int#+   {Return the number of elements in the array.}++primop  SizeofMutableArrayOp "sizeofMutableArray#" GenPrimOp+   MutableArray# s v -> Int#+   {Return the number of elements in the array.}++primop  IndexArrayOp "indexArray#" GenPrimOp+   Array# v -> Int# -> (# v #)+   {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+   can_fail         = True++primop  UnsafeFreezeArrayOp "unsafeFreezeArray#" GenPrimOp+   MutableArray# s v -> State# s -> (# State# s, Array# v #)+   {Make a mutable array immutable, without copying.}+   with+   has_side_effects = True++primop  UnsafeThawArrayOp  "unsafeThawArray#" GenPrimOp+   Array# v -> State# s -> (# State# s, MutableArray# s v #)+   {Make an immutable array mutable, without copying.}+   with+   out_of_line = True+   has_side_effects = True++primop  CopyArrayOp "copyArray#" GenPrimOp+  Array# v -> Int# -> MutableArray# s v -> 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+  has_side_effects = True+  can_fail         = True++primop  CopyMutableArrayOp "copyMutableArray#" GenPrimOp+  MutableArray# s v -> Int# -> MutableArray# s v -> 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+  has_side_effects = True+  can_fail         = True++primop  CloneArrayOp "cloneArray#" GenPrimOp+  Array# v -> Int# -> Int# -> Array# v+  {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+  has_side_effects = True+  can_fail         = True++primop  CloneMutableArrayOp "cloneMutableArray#" GenPrimOp+  MutableArray# s v -> Int# -> Int# -> State# s -> (# State# s, MutableArray# s v #)+  {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+  has_side_effects = True+  can_fail         = True++primop  FreezeArrayOp "freezeArray#" GenPrimOp+  MutableArray# s v -> Int# -> Int# -> State# s -> (# State# s, Array# v #)+  {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+  has_side_effects = True+  can_fail         = True++primop  ThawArrayOp "thawArray#" GenPrimOp+  Array# v -> Int# -> Int# -> State# s -> (# State# s, MutableArray# s v #)+  {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+  has_side_effects = True+  can_fail         = True++primop CasArrayOp  "casArray#" GenPrimOp+   MutableArray# s v -> Int# -> v -> v -> State# s -> (# State# s, Int#, v #)+   {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 {\tt casIntArray\#}. All of the difficulties+    of using {\tt reallyUnsafePtrEquality\#} correctly apply to+    {\tt casArray\#} as well.+   }+   with+   out_of_line = True+   has_side_effects = True+   can_fail = True -- Might index out of bounds+++------------------------------------------------------------------------+section "Small Arrays"++        {Operations on {\tt SmallArray\#}. A {\tt SmallArray\#} works+         just like an {\tt Array\#}, but with different space use and+         performance characteristics (that are often useful with small+         arrays). The {\tt SmallArray\#} and {\tt 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 {\tt 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 {\tt SmallArray\#}.+        }++------------------------------------------------------------------------++primtype SmallArray# a++primtype SmallMutableArray# s a++primop  NewSmallArrayOp "newSmallArray#" GenPrimOp+   Int# -> v -> State# s -> (# State# s, SmallMutableArray# s v #)+   {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+   has_side_effects = True++primop  ShrinkSmallMutableArrayOp_Char "shrinkSmallMutableArray#" GenPrimOp+   SmallMutableArray# s v -> 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 {\tt getSizeofSmallMutableArray\#}.}+   with out_of_line = True+        has_side_effects = True++primop  ReadSmallArrayOp "readSmallArray#" GenPrimOp+   SmallMutableArray# s v -> Int# -> State# s -> (# State# s, v #)+   {Read from specified index of mutable array. Result is not yet evaluated.}+   with+   has_side_effects = True+   can_fail         = True++primop  WriteSmallArrayOp "writeSmallArray#" GenPrimOp+   SmallMutableArray# s v -> Int# -> v -> State# s -> State# s+   {Write to specified index of mutable array.}+   with+   has_side_effects = True+   can_fail         = True++primop  SizeofSmallArrayOp "sizeofSmallArray#" GenPrimOp+   SmallArray# v -> Int#+   {Return the number of elements in the array.}++primop  SizeofSmallMutableArrayOp "sizeofSmallMutableArray#" GenPrimOp+   SmallMutableArray# s v -> Int#+   {Return the number of elements in the array. Note that this is deprecated+   as it is unsafe in the presence of shrink and resize operations on the+   same small mutable array.}+   with deprecated_msg = { Use 'getSizeofSmallMutableArray#' instead }++primop  GetSizeofSmallMutableArrayOp "getSizeofSmallMutableArray#" GenPrimOp+   SmallMutableArray# s v -> State# s -> (# State# s, Int# #)+   {Return the number of elements in the array.}++primop  IndexSmallArrayOp "indexSmallArray#" GenPrimOp+   SmallArray# v -> Int# -> (# v #)+   {Read from specified index of immutable array. Result is packaged into+    an unboxed singleton; the result itself is not yet evaluated.}+   with+   can_fail         = True++primop  UnsafeFreezeSmallArrayOp "unsafeFreezeSmallArray#" GenPrimOp+   SmallMutableArray# s v -> State# s -> (# State# s, SmallArray# v #)+   {Make a mutable array immutable, without copying.}+   with+   has_side_effects = True++primop  UnsafeThawSmallArrayOp  "unsafeThawSmallArray#" GenPrimOp+   SmallArray# v -> State# s -> (# State# s, SmallMutableArray# s v #)+   {Make an immutable array mutable, without copying.}+   with+   out_of_line = True+   has_side_effects = True++-- 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# v -> Int# -> SmallMutableArray# s v -> 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+  has_side_effects = True+  can_fail         = True++primop  CopySmallMutableArrayOp "copySmallMutableArray#" GenPrimOp+  SmallMutableArray# s v -> Int# -> SmallMutableArray# s v -> 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+  has_side_effects = True+  can_fail         = True++primop  CloneSmallArrayOp "cloneSmallArray#" GenPrimOp+  SmallArray# v -> Int# -> Int# -> SmallArray# v+  {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+  has_side_effects = True+  can_fail         = True++primop  CloneSmallMutableArrayOp "cloneSmallMutableArray#" GenPrimOp+  SmallMutableArray# s v -> Int# -> Int# -> State# s -> (# State# s, SmallMutableArray# s v #)+  {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+  has_side_effects = True+  can_fail         = True++primop  FreezeSmallArrayOp "freezeSmallArray#" GenPrimOp+  SmallMutableArray# s v -> Int# -> Int# -> State# s -> (# State# s, SmallArray# v #)+  {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+  has_side_effects = True+  can_fail         = True++primop  ThawSmallArrayOp "thawSmallArray#" GenPrimOp+  SmallArray# v -> Int# -> Int# -> State# s -> (# State# s, SmallMutableArray# s v #)+  {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+  has_side_effects = True+  can_fail         = True++primop CasSmallArrayOp  "casSmallArray#" GenPrimOp+   SmallMutableArray# s v -> Int# -> v -> v -> State# s -> (# State# s, Int#, v #)+   {Unsafe, machine-level atomic compare and swap on an element within an array.+    See the documentation of {\tt casArray\#}.}+   with+   out_of_line = True+   has_side_effects = True+   can_fail = True -- Might index out of bounds++------------------------------------------------------------------------+section "Byte Arrays"+        {A {\tt 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+        has_side_effects = True++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+        has_side_effects = True++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+        has_side_effects = True++primop  MutableByteArrayIsPinnedOp "isMutableByteArrayPinned#" GenPrimOp+   MutableByteArray# s -> Int#+   {Determine whether a {\tt MutableByteArray\#} is guaranteed not to move+   during GC.}+   with out_of_line = True++primop  ByteArrayIsPinnedOp "isByteArrayPinned#" GenPrimOp+   ByteArray# -> Int#+   {Determine whether a {\tt ByteArray\#} is guaranteed not to move during GC.}+   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 {\tt getSizeofMutableByteArray\#}.}+   with out_of_line = True+        has_side_effects = True++primop  ResizeMutableByteArrayOp_Char "resizeMutableByteArray#" GenPrimOp+   MutableByteArray# s -> Int# -> State# s -> (# State# s,MutableByteArray# s #)+   {Resize (unpinned) mutable byte array to new specified size (in bytes).+    The returned {\tt MutableByteArray\#} is either the original+    {\tt MutableByteArray\#} resized in-place or, if not possible, a newly+    allocated (unpinned) {\tt MutableByteArray\#} (with the original content+    copied over).++    To avoid undefined behaviour, the original {\tt MutableByteArray\#} shall+    not be accessed anymore after a {\tt resizeMutableByteArray\#} has been+    performed.  Moreover, no reference to the old one should be kept in order+    to allow garbage collection of the original {\tt MutableByteArray\#} in+    case a new {\tt MutableByteArray\#} had to be allocated.}+   with out_of_line = True+        has_side_effects = True++primop  UnsafeFreezeByteArrayOp "unsafeFreezeByteArray#" GenPrimOp+   MutableByteArray# s -> State# s -> (# State# s, ByteArray# #)+   {Make a mutable byte array immutable, without copying.}+   with+   has_side_effects = True++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. Note that this is deprecated as it is+   unsafe in the presence of shrink and resize 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.}++#include "bytearray-ops.txt.pp"++primop  CompareByteArraysOp "compareByteArrays#" GenPrimOp+   ByteArray# -> Int# -> ByteArray# -> Int# -> Int# -> Int#+   {{\tt compareByteArrays# src1 src1_ofs src2 src2_ofs n} compares+    {\tt n} bytes starting at offset {\tt src1_ofs} in the first+    {\tt ByteArray#} {\tt src1} to the range of {\tt n} bytes+    (i.e. same length) starting at offset {\tt src2_ofs} of the second+    {\tt ByteArray#} {\tt src2}.  Both arrays must fully contain the+    specified ranges, but this is not checked.  Returns an {\tt 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.}+   with+   can_fail = True++primop  CopyByteArrayOp "copyByteArray#" GenPrimOp+  ByteArray# -> Int# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s+  {{\tt copyByteArray# src src_ofs dst dst_ofs n} copies the range+   starting at offset {\tt src_ofs} of length {\tt n} from the+   {\tt ByteArray#} {\tt src} to the {\tt MutableByteArray#} {\tt dst}+   starting at offset {\tt 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+  has_side_effects = True+  code_size = { primOpCodeSizeForeignCall + 4}+  can_fail = True++primop  CopyMutableByteArrayOp "copyMutableByteArray#" GenPrimOp+  MutableByteArray# s -> Int# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s+  {Copy a range of the first MutableByteArray\# to the specified region in the second MutableByteArray\#.+   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+  has_side_effects = True+  code_size = { primOpCodeSizeForeignCall + 4 }+  can_fail = True++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+  has_side_effects = True+  code_size = { primOpCodeSizeForeignCall + 4}+  can_fail = True++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+  has_side_effects = True+  code_size = { primOpCodeSizeForeignCall + 4}+  can_fail = True++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+  has_side_effects = True+  code_size = { primOpCodeSizeForeignCall + 4}+  can_fail = True++primop  SetByteArrayOp "setByteArray#" GenPrimOp+  MutableByteArray# s -> Int# -> Int# -> Int# -> State# s -> State# s+  {{\tt setByteArray# ba off len c} sets the byte range {\tt [off, off+len)} of+   the {\tt MutableByteArray#} to the byte {\tt c}.}+  with+  has_side_effects = True+  code_size = { primOpCodeSizeForeignCall + 4 }+  can_fail = True++-- 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 has_side_effects = True+        can_fail = True++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 has_side_effects = True+        can_fail = True++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 has_side_effects = True+        can_fail = True++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 has_side_effects = True+        can_fail = True++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 has_side_effects = True+        can_fail = True++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 has_side_effects = True+        can_fail = True++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 has_side_effects = True+        can_fail = True++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 has_side_effects = True+        can_fail = True++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 has_side_effects = True+        can_fail = True++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 has_side_effects = True+        can_fail = True++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 has_side_effects = True+        can_fail = True++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 has_side_effects = True+        can_fail = True++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 has_side_effects = True+        can_fail = True++------------------------------------------------------------------------+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 {\tt Addr\#}s are so far apart that their+         difference doesn't fit in an {\tt Int\#}.}+primop   AddrRemOp "remAddr#" GenPrimOp Addr# -> Int# -> Int#+         {Return the remainder when the {\tt Addr\#} arg, treated like an {\tt Int\#},+          is divided by the {\tt Int\#} arg.}+primop   AddrToIntOp  "addr2Int#"     GenPrimOp   Addr# -> Int#+        {Coerce directly from address to int.}+   with code_size = 0+        deprecated_msg = { This operation is strongly deprecated. }+primop   IntToAddrOp   "int2Addr#"    GenPrimOp  Int# -> Addr#+        {Coerce directly from int to address.}+   with code_size = 0+        deprecated_msg = { This operation is strongly deprecated. }++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#++primop IndexOffAddrOp_Char "indexCharOffAddr#" GenPrimOp+   Addr# -> Int# -> Char#+   {Reads 8-bit character; offset in bytes.}+   with can_fail = True++primop IndexOffAddrOp_WideChar "indexWideCharOffAddr#" GenPrimOp+   Addr# -> Int# -> Char#+   {Reads 31-bit character; offset in 4-byte words.}+   with can_fail = True++primop IndexOffAddrOp_Int "indexIntOffAddr#" GenPrimOp+   Addr# -> Int# -> Int#+   with can_fail = True++primop IndexOffAddrOp_Word "indexWordOffAddr#" GenPrimOp+   Addr# -> Int# -> Word#+   with can_fail = True++primop IndexOffAddrOp_Addr "indexAddrOffAddr#" GenPrimOp+   Addr# -> Int# -> Addr#+   with can_fail = True++primop IndexOffAddrOp_Float "indexFloatOffAddr#" GenPrimOp+   Addr# -> Int# -> Float#+   with can_fail = True++primop IndexOffAddrOp_Double "indexDoubleOffAddr#" GenPrimOp+   Addr# -> Int# -> Double#+   with can_fail = True++primop IndexOffAddrOp_StablePtr "indexStablePtrOffAddr#" GenPrimOp+   Addr# -> Int# -> StablePtr# a+   with can_fail = True++primop IndexOffAddrOp_Int8 "indexInt8OffAddr#" GenPrimOp+   Addr# -> Int# -> Int8#+   with can_fail = True++primop IndexOffAddrOp_Int16 "indexInt16OffAddr#" GenPrimOp+   Addr# -> Int# -> Int16#+   with can_fail = True++primop IndexOffAddrOp_Int32 "indexInt32OffAddr#" GenPrimOp+   Addr# -> Int# -> Int32#+   with can_fail = True++primop IndexOffAddrOp_Int64 "indexInt64OffAddr#" GenPrimOp+   Addr# -> Int# -> Int64#+   with can_fail = True++primop IndexOffAddrOp_Word8 "indexWord8OffAddr#" GenPrimOp+   Addr# -> Int# -> Word8#+   with can_fail = True++primop IndexOffAddrOp_Word16 "indexWord16OffAddr#" GenPrimOp+   Addr# -> Int# -> Word16#+   with can_fail = True++primop IndexOffAddrOp_Word32 "indexWord32OffAddr#" GenPrimOp+   Addr# -> Int# -> Word32#+   with can_fail = True++primop IndexOffAddrOp_Word64 "indexWord64OffAddr#" GenPrimOp+   Addr# -> Int# -> Word64#+   with can_fail = True++primop ReadOffAddrOp_Char "readCharOffAddr#" GenPrimOp+   Addr# -> Int# -> State# s -> (# State# s, Char# #)+   {Reads 8-bit character; offset in bytes.}+   with has_side_effects = True+        can_fail         = True++primop ReadOffAddrOp_WideChar "readWideCharOffAddr#" GenPrimOp+   Addr# -> Int# -> State# s -> (# State# s, Char# #)+   {Reads 31-bit character; offset in 4-byte words.}+   with has_side_effects = True+        can_fail         = True++primop ReadOffAddrOp_Int "readIntOffAddr#" GenPrimOp+   Addr# -> Int# -> State# s -> (# State# s, Int# #)+   with has_side_effects = True+        can_fail         = True++primop ReadOffAddrOp_Word "readWordOffAddr#" GenPrimOp+   Addr# -> Int# -> State# s -> (# State# s, Word# #)+   with has_side_effects = True+        can_fail         = True++primop ReadOffAddrOp_Addr "readAddrOffAddr#" GenPrimOp+   Addr# -> Int# -> State# s -> (# State# s, Addr# #)+   with has_side_effects = True+        can_fail         = True++primop ReadOffAddrOp_Float "readFloatOffAddr#" GenPrimOp+   Addr# -> Int# -> State# s -> (# State# s, Float# #)+   with has_side_effects = True+        can_fail         = True++primop ReadOffAddrOp_Double "readDoubleOffAddr#" GenPrimOp+   Addr# -> Int# -> State# s -> (# State# s, Double# #)+   with has_side_effects = True+        can_fail         = True++primop ReadOffAddrOp_StablePtr "readStablePtrOffAddr#" GenPrimOp+   Addr# -> Int# -> State# s -> (# State# s, StablePtr# a #)+   with has_side_effects = True+        can_fail         = True++primop ReadOffAddrOp_Int8 "readInt8OffAddr#" GenPrimOp+   Addr# -> Int# -> State# s -> (# State# s, Int8# #)+   with has_side_effects = True+        can_fail         = True++primop ReadOffAddrOp_Int16 "readInt16OffAddr#" GenPrimOp+   Addr# -> Int# -> State# s -> (# State# s, Int16# #)+   with has_side_effects = True+        can_fail         = True++primop ReadOffAddrOp_Int32 "readInt32OffAddr#" GenPrimOp+   Addr# -> Int# -> State# s -> (# State# s, Int32# #)+   with has_side_effects = True+        can_fail         = True++primop ReadOffAddrOp_Int64 "readInt64OffAddr#" GenPrimOp+   Addr# -> Int# -> State# s -> (# State# s, Int64# #)+   with has_side_effects = True+        can_fail         = True++primop ReadOffAddrOp_Word8 "readWord8OffAddr#" GenPrimOp+   Addr# -> Int# -> State# s -> (# State# s, Word8# #)+   with has_side_effects = True+        can_fail         = True++primop ReadOffAddrOp_Word16 "readWord16OffAddr#" GenPrimOp+   Addr# -> Int# -> State# s -> (# State# s, Word16# #)+   with has_side_effects = True+        can_fail         = True++primop ReadOffAddrOp_Word32 "readWord32OffAddr#" GenPrimOp+   Addr# -> Int# -> State# s -> (# State# s, Word32# #)+   with has_side_effects = True+        can_fail         = True++primop ReadOffAddrOp_Word64 "readWord64OffAddr#" GenPrimOp+   Addr# -> Int# -> State# s -> (# State# s, Word64# #)+   with has_side_effects = True+        can_fail         = True++primop  WriteOffAddrOp_Char "writeCharOffAddr#" GenPrimOp+   Addr# -> Int# -> Char# -> State# s -> State# s+   with has_side_effects = True+        can_fail         = True++primop  WriteOffAddrOp_WideChar "writeWideCharOffAddr#" GenPrimOp+   Addr# -> Int# -> Char# -> State# s -> State# s+   with has_side_effects = True+        can_fail         = True++primop  WriteOffAddrOp_Int "writeIntOffAddr#" GenPrimOp+   Addr# -> Int# -> Int# -> State# s -> State# s+   with has_side_effects = True+        can_fail         = True++primop  WriteOffAddrOp_Word "writeWordOffAddr#" GenPrimOp+   Addr# -> Int# -> Word# -> State# s -> State# s+   with has_side_effects = True+        can_fail         = True++primop  WriteOffAddrOp_Addr "writeAddrOffAddr#" GenPrimOp+   Addr# -> Int# -> Addr# -> State# s -> State# s+   with has_side_effects = True+        can_fail         = True++primop  WriteOffAddrOp_Float "writeFloatOffAddr#" GenPrimOp+   Addr# -> Int# -> Float# -> State# s -> State# s+   with has_side_effects = True+        can_fail         = True++primop  WriteOffAddrOp_Double "writeDoubleOffAddr#" GenPrimOp+   Addr# -> Int# -> Double# -> State# s -> State# s+   with has_side_effects = True+        can_fail         = True++primop  WriteOffAddrOp_StablePtr "writeStablePtrOffAddr#" GenPrimOp+   Addr# -> Int# -> StablePtr# a -> State# s -> State# s+   with has_side_effects = True+        can_fail         = True++primop  WriteOffAddrOp_Int8 "writeInt8OffAddr#" GenPrimOp+   Addr# -> Int# -> Int8# -> State# s -> State# s+   with has_side_effects = True+        can_fail         = True++primop  WriteOffAddrOp_Int16 "writeInt16OffAddr#" GenPrimOp+   Addr# -> Int# -> Int16# -> State# s -> State# s+   with has_side_effects = True+        can_fail         = True++primop  WriteOffAddrOp_Int32 "writeInt32OffAddr#" GenPrimOp+   Addr# -> Int# -> Int32# -> State# s -> State# s+   with has_side_effects = True+        can_fail         = True++primop  WriteOffAddrOp_Int64 "writeInt64OffAddr#" GenPrimOp+   Addr# -> Int# -> Int64# -> State# s -> State# s+   with has_side_effects = True+        can_fail         = True++primop  WriteOffAddrOp_Word8 "writeWord8OffAddr#" GenPrimOp+   Addr# -> Int# -> Word8# -> State# s -> State# s+   with has_side_effects = True+        can_fail         = True++primop  WriteOffAddrOp_Word16 "writeWord16OffAddr#" GenPrimOp+   Addr# -> Int# -> Word16# -> State# s -> State# s+   with has_side_effects = True+        can_fail         = True++primop  WriteOffAddrOp_Word32 "writeWord32OffAddr#" GenPrimOp+   Addr# -> Int# -> Word32# -> State# s -> State# s+   with has_side_effects = True+        can_fail         = True++primop  WriteOffAddrOp_Word64 "writeWord64OffAddr#" GenPrimOp+   Addr# -> Int# -> Word64# -> State# s -> State# s+   with has_side_effects = True+        can_fail         = True++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 has_side_effects = True+        can_fail         = True++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 has_side_effects = True+        can_fail         = True++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 has_side_effects = True+        can_fail         = True++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 has_side_effects = True+        can_fail         = True++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 has_side_effects = True+        can_fail         = True++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 has_side_effects = True+        can_fail         = True++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 has_side_effects = True+        can_fail         = True++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 has_side_effects = True+        can_fail         = True++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 has_side_effects = True+        can_fail = True++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 has_side_effects = True+        can_fail = True++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 has_side_effects = True+        can_fail = True++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 has_side_effects = True+        can_fail = True++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 has_side_effects = True+        can_fail = True++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 has_side_effects = True+        can_fail = True++primop  AtomicReadAddrOp_Word "atomicReadWordAddr#" GenPrimOp+   Addr# -> State# s -> (# State# s, Word# #)+   {Given an address, read a machine word.  Implies a full memory barrier.}+   with has_side_effects = True+        can_fail = True++primop  AtomicWriteAddrOp_Word "atomicWriteWordAddr#" GenPrimOp+   Addr# -> Word# -> State# s -> State# s+   {Given an address, write a machine word. Implies a full memory barrier.}+   with has_side_effects = True+        can_fail = True+++------------------------------------------------------------------------+section "Mutable variables"+        {Operations on MutVar\#s.}+------------------------------------------------------------------------++primtype MutVar# s a+        {A {\tt MutVar\#} behaves like a single-element mutable array.}++primop  NewMutVarOp "newMutVar#" GenPrimOp+   v -> State# s -> (# State# s, MutVar# s v #)+   {Create {\tt MutVar\#} with specified initial value in specified state thread.}+   with+   out_of_line = True+   has_side_effects = True++-- Note [Why MutVar# ops can't fail]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- We don't label readMutVar# or writeMutVar# as can_fail.+-- 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, has_side_effects 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 v -> State# s -> (# State# s, v #)+   {Read contents of {\tt MutVar\#}. Result is not yet evaluated.}+   with+   -- See Note [Why MutVar# ops can't fail]+   has_side_effects = True++primop  WriteMutVarOp "writeMutVar#"  GenPrimOp+   MutVar# s v -> v -> State# s -> State# s+   {Write contents of {\tt MutVar\#}.}+   with+   -- See Note [Why MutVar# ops can't fail]+   has_side_effects = True+   code_size = { primOpCodeSizeForeignCall } -- for the write barrier++-- 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 {\tt MutVar\#}, returning the previous+     contents and the result of applying the given function to the+     previous contents. Note that this isn't strictly+     speaking the correct type for this function; it should really be+     {\tt MutVar\# s a -> (a -> (a,b)) -> State\# s -> (\# State\# s, a, (a, b) \#)},+     but we don't know about pairs here. }+   with+   out_of_line = True+   has_side_effects = True+   can_fail         = True++primop  AtomicModifyMutVar_Op "atomicModifyMutVar_#" GenPrimOp+   MutVar# s a -> (a -> a) -> State# s -> (# State# s, a, a #)+   { Modify the contents of a {\tt MutVar\#}, returning the previous+     contents and the result of applying the given function to the+     previous contents. }+   with+   out_of_line = True+   has_side_effects = True+   can_fail         = True++primop  CasMutVarOp "casMutVar#" GenPrimOp+  MutVar# s v -> v -> v -> State# s -> (# State# s, Int#, v #)+   { Compare-and-swap: perform a pointer equality test between+     the first value passed to this function and the value+     stored inside the {\tt 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 {\tt MutVar\#}.+     The {\tt Int\#} indicates whether a swap took place,+     with {\tt 1\#} meaning that we didn't swap, and {\tt 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+     {\tt reallyUnsafePtrEquality\#} correctly apply to+     {\tt casMutVar\#} as well.+   }+   with+   out_of_line = True+   has_side_effects = True++------------------------------------------------------------------------+section "Exceptions"+------------------------------------------------------------------------++-- Note [Strictness for mask/unmask/catch]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Consider this example, which comes from GHC.IO.Handle.Internals:+--    wantReadableHandle3 f ma b st+--      = case ... of+--          DEFAULT -> case ma of MVar a -> ...+--          0#      -> maskAsyncExceptions# (\st -> case ma of MVar a -> ...)+-- The outer case just decides whether to mask exceptions, but we don't want+-- thereby to hide the strictness in 'ma'!  Hence the use of strictOnceApply1Dmd+-- in mask and unmask. But catch really is lazy in its first argument, see+-- #11555. So for IO actions 'ma' we often use a wrapper around it that is+-- head-strict in 'ma': GHC.IO.catchException.++primop  CatchOp "catch#" GenPrimOp+          (State# RealWorld -> (# State# RealWorld, o #) )+       -> (w -> State# RealWorld -> (# State# RealWorld, o #) )+       -> State# RealWorld+       -> (# State# RealWorld, o #)+   with+   strictness  = { \ _arity -> mkClosedDmdSig [ lazyApply1Dmd+                                                 , lazyApply2Dmd+                                                 , topDmd] topDiv }+                 -- See Note [Strictness for mask/unmask/catch]+   out_of_line = True+   has_side_effects = True++primop  RaiseOp "raise#" GenPrimOp+   v -> p+      -- NB: "v" is the same as "a" except levity-polymorphic,+      -- and "p" is the same as "b" except representation-polymorphic+      -- See Note [Levity and representation polymorphic primops]+   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'.+   -- For the same reasons, 'raise#' is marked as "can_fail" (which 'raiseIO#'+   -- is not), but not as "has_side_effects" (which 'raiseIO#' is).+   -- See Note [PrimOp can_fail and has_side_effects] in "GHC.Builtin.PrimOps".+   strictness  = { \ _arity -> mkClosedDmdSig [topDmd] botDiv }+   out_of_line = True+   can_fail = True++primop  RaiseIOOp "raiseIO#" GenPrimOp+   v -> State# RealWorld -> (# State# RealWorld, p #)+   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+   has_side_effects = True++primop  MaskAsyncExceptionsOp "maskAsyncExceptions#" GenPrimOp+        (State# RealWorld -> (# State# RealWorld, o #))+     -> (State# RealWorld -> (# State# RealWorld, o #))+   with+   strictness  = { \ _arity -> mkClosedDmdSig [strictOnceApply1Dmd,topDmd] topDiv }+                 -- See Note [Strictness for mask/unmask/catch]+   out_of_line = True+   has_side_effects = True++primop  MaskUninterruptibleOp "maskUninterruptible#" GenPrimOp+        (State# RealWorld -> (# State# RealWorld, o #))+     -> (State# RealWorld -> (# State# RealWorld, o #))+   with+   strictness  = { \ _arity -> mkClosedDmdSig [strictOnceApply1Dmd,topDmd] topDiv }+   out_of_line = True+   has_side_effects = True++primop  UnmaskAsyncExceptionsOp "unmaskAsyncExceptions#" GenPrimOp+        (State# RealWorld -> (# State# RealWorld, o #))+     -> (State# RealWorld -> (# State# RealWorld, o #))+   with+   strictness  = { \ _arity -> mkClosedDmdSig [strictOnceApply1Dmd,topDmd] topDiv }+                 -- See Note [Strictness for mask/unmask/catch]+   out_of_line = True+   has_side_effects = True++primop  MaskStatus "getMaskingState#" GenPrimOp+        State# RealWorld -> (# State# RealWorld, Int# #)+   with+   out_of_line = True+   has_side_effects = True++------------------------------------------------------------------------+section "STM-accessible Mutable Variables"+------------------------------------------------------------------------++primtype TVar# s a++primop  AtomicallyOp "atomically#" GenPrimOp+      (State# RealWorld -> (# State# RealWorld, v #) )+   -> State# RealWorld -> (# State# RealWorld, v #)+   with+   strictness  = { \ _arity -> mkClosedDmdSig [strictManyApply1Dmd,topDmd] topDiv }+                 -- See Note [Strictness for mask/unmask/catch]+   out_of_line = True+   has_side_effects = True++-- 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, v #)+   with+   strictness  = { \ _arity -> mkClosedDmdSig [topDmd] botDiv }+   out_of_line = True+   has_side_effects = True++primop  CatchRetryOp "catchRetry#" GenPrimOp+      (State# RealWorld -> (# State# RealWorld, v #) )+   -> (State# RealWorld -> (# State# RealWorld, v #) )+   -> (State# RealWorld -> (# State# RealWorld, v #) )+   with+   strictness  = { \ _arity -> mkClosedDmdSig [ lazyApply1Dmd+                                                 , lazyApply1Dmd+                                                 , topDmd ] topDiv }+                 -- See Note [Strictness for mask/unmask/catch]+   out_of_line = True+   has_side_effects = True++primop  CatchSTMOp "catchSTM#" GenPrimOp+      (State# RealWorld -> (# State# RealWorld, v #) )+   -> (b -> State# RealWorld -> (# State# RealWorld, v #) )+   -> (State# RealWorld -> (# State# RealWorld, v #) )+   with+   strictness  = { \ _arity -> mkClosedDmdSig [ lazyApply1Dmd+                                                 , lazyApply2Dmd+                                                 , topDmd ] topDiv }+                 -- See Note [Strictness for mask/unmask/catch]+   out_of_line = True+   has_side_effects = True++primop  NewTVarOp "newTVar#" GenPrimOp+       v+    -> State# s -> (# State# s, TVar# s v #)+   {Create a new {\tt TVar\#} holding a specified initial value.}+   with+   out_of_line  = True+   has_side_effects = True++primop  ReadTVarOp "readTVar#" GenPrimOp+       TVar# s v+    -> State# s -> (# State# s, v #)+   {Read contents of {\tt TVar\#} inside an STM transaction,+    i.e. within a call to {\tt atomically\#}.+    Does not force evaluation of the result.}+   with+   out_of_line  = True+   has_side_effects = True++primop ReadTVarIOOp "readTVarIO#" GenPrimOp+       TVar# s v+    -> State# s -> (# State# s, v #)+   {Read contents of {\tt TVar\#} outside an STM transaction.+   Does not force evaluation of the result.}+   with+   out_of_line      = True+   has_side_effects = True++primop  WriteTVarOp "writeTVar#" GenPrimOp+       TVar# s v+    -> v+    -> State# s -> State# s+   {Write contents of {\tt TVar\#}.}+   with+   out_of_line      = True+   has_side_effects = True+++------------------------------------------------------------------------+section "Synchronized Mutable Variables"+        {Operations on {\tt MVar\#}s. }+------------------------------------------------------------------------++primtype MVar# s a+        { A shared mutable variable ({\it not} the same as a {\tt MutVar\#}!).+        (Note: in a non-concurrent implementation, {\tt (MVar\# a)} can be+        represented by {\tt (MutVar\# (Maybe a))}.) }++primop  NewMVarOp "newMVar#"  GenPrimOp+   State# s -> (# State# s, MVar# s v #)+   {Create new {\tt MVar\#}; initially empty.}+   with+   out_of_line = True+   has_side_effects = True++primop  TakeMVarOp "takeMVar#" GenPrimOp+   MVar# s v -> State# s -> (# State# s, v #)+   {If {\tt MVar\#} is empty, block until it becomes full.+   Then remove and return its contents, and set it empty.}+   with+   out_of_line      = True+   has_side_effects = True++primop  TryTakeMVarOp "tryTakeMVar#" GenPrimOp+   MVar# s v -> State# s -> (# State# s, Int#, v #)+   {If {\tt MVar\#} is empty, immediately return with integer 0 and value undefined.+   Otherwise, return with integer 1 and contents of {\tt MVar\#}, and set {\tt MVar\#} empty.}+   with+   out_of_line      = True+   has_side_effects = True++primop  PutMVarOp "putMVar#" GenPrimOp+   MVar# s v -> v -> State# s -> State# s+   {If {\tt MVar\#} is full, block until it becomes empty.+   Then store value arg as its new contents.}+   with+   out_of_line      = True+   has_side_effects = True++primop  TryPutMVarOp "tryPutMVar#" GenPrimOp+   MVar# s v -> v -> State# s -> (# State# s, Int# #)+   {If {\tt MVar\#} is full, immediately return with integer 0.+    Otherwise, store value arg as {\tt MVar\#}'s new contents, and return with integer 1.}+   with+   out_of_line      = True+   has_side_effects = True++primop  ReadMVarOp "readMVar#" GenPrimOp+   MVar# s v -> State# s -> (# State# s, v #)+   {If {\tt 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+   has_side_effects = True++primop  TryReadMVarOp "tryReadMVar#" GenPrimOp+   MVar# s v -> State# s -> (# State# s, Int#, v #)+   {If {\tt MVar\#} is empty, immediately return with integer 0 and value undefined.+   Otherwise, return with integer 1 and contents of {\tt MVar\#}.}+   with+   out_of_line      = True+   has_side_effects = True++primop  IsEmptyMVarOp "isEmptyMVar#" GenPrimOp+   MVar# s v -> State# s -> (# State# s, Int# #)+   {Return 1 if {\tt MVar\#} is empty; 0 otherwise.}+   with+   out_of_line = True+   has_side_effects = True+++------------------------------------------------------------------------+section "Synchronized I/O Ports"+        {Operations on {\tt IOPort\#}s. }+------------------------------------------------------------------------++primtype IOPort# s a+        { A shared I/O port is almost the same as a {\tt MVar\#}!).+        The main difference is that IOPort has no deadlock detection or+        deadlock breaking code that forcibly releases the lock. }++primop  NewIOPortOp "newIOPort#"  GenPrimOp+   State# s -> (# State# s, IOPort# s v #)+   {Create new {\tt IOPort\#}; initially empty.}+   with+   out_of_line = True+   has_side_effects = True++primop  ReadIOPortOp "readIOPort#" GenPrimOp+   IOPort# s v -> State# s -> (# State# s, v #)+   {If {\tt IOPort\#} is empty, block until it becomes full.+   Then remove and return its contents, and set it empty.+   Throws an {\tt IOPortException} if another thread is already+   waiting to read this {\tt IOPort\#}.}+   with+   out_of_line      = True+   has_side_effects = True++primop  WriteIOPortOp "writeIOPort#" GenPrimOp+   IOPort# s v -> v -> State# s -> (# State# s, Int# #)+   {If {\tt IOPort\#} is full, immediately return with integer 0,+    throwing an {\tt IOPortException}.+    Otherwise, store value arg as {\tt IOPort\#}'s new contents,+    and return with integer 1. }+   with+   out_of_line      = True+   has_side_effects = True++------------------------------------------------------------------------+section "Delay/wait operations"+------------------------------------------------------------------------++primop  DelayOp "delay#" GenPrimOp+   Int# -> State# s -> State# s+   {Sleep specified number of microseconds.}+   with+   has_side_effects = True+   out_of_line      = True++primop  WaitReadOp "waitRead#" GenPrimOp+   Int# -> State# s -> State# s+   {Block until input is available on specified file descriptor.}+   with+   has_side_effects = True+   out_of_line      = True++primop  WaitWriteOp "waitWrite#" GenPrimOp+   Int# -> State# s -> State# s+   {Block until output is possible on specified file descriptor.}+   with+   has_side_effects = True+   out_of_line      = True++------------------------------------------------------------------------+section "Concurrency primitives"+------------------------------------------------------------------------++primtype State# s+        { {\tt State\#} is the primitive, unlifted type of states.  It has+        one type parameter, thus {\tt State\# RealWorld}, or {\tt 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+        { {\tt RealWorld} is deeply magical.  It is {\it primitive}, but it is not+        {\it unlifted} (hence {\tt ptrArg}).  We never manipulate values of type+        {\tt RealWorld}; it's only used in the type system, to parameterise {\tt State\#}. }++primtype ThreadId#+        {(In a non-concurrent implementation, this can be a singleton+        type, whose (unique) value is returned by {\tt myThreadId\#}.  The+        other operations can be omitted.)}++primop  ForkOp "fork#" GenPrimOp+   (State# RealWorld -> (# State# RealWorld, o #))+   -> State# RealWorld -> (# State# RealWorld, ThreadId# #)+   with+   has_side_effects = True+   out_of_line      = True+   strictness  = { \ _arity -> mkClosedDmdSig [ lazyApply1Dmd+                                              , topDmd ] topDiv }++primop  ForkOnOp "forkOn#" GenPrimOp+   Int# -> (State# RealWorld -> (# State# RealWorld, o #))+   -> State# RealWorld -> (# State# RealWorld, ThreadId# #)+   with+   has_side_effects = True+   out_of_line      = True+   strictness  = { \ _arity -> mkClosedDmdSig [ topDmd+                                              , lazyApply1Dmd+                                              , topDmd ] topDiv }++primop  KillThreadOp "killThread#"  GenPrimOp+   ThreadId# -> a -> State# RealWorld -> State# RealWorld+   with+   has_side_effects = True+   out_of_line      = True++primop  YieldOp "yield#" GenPrimOp+   State# RealWorld -> State# RealWorld+   with+   has_side_effects = True+   out_of_line      = True++primop  MyThreadIdOp "myThreadId#" GenPrimOp+   State# RealWorld -> (# State# RealWorld, ThreadId# #)+   with+   has_side_effects = True++primop LabelThreadOp "labelThread#" GenPrimOp+   ThreadId# -> Addr# -> State# RealWorld -> State# RealWorld+   with+   has_side_effects = True+   out_of_line      = True++primop  IsCurrentThreadBoundOp "isCurrentThreadBound#" GenPrimOp+   State# RealWorld -> (# State# RealWorld, Int# #)+   with+   out_of_line = True+   has_side_effects = True++primop  NoDuplicateOp "noDuplicate#" GenPrimOp+   State# s -> State# s+   with+   out_of_line = True+   has_side_effects = True++primop  ThreadStatusOp "threadStatus#" GenPrimOp+   ThreadId# -> State# RealWorld -> (# State# RealWorld, Int#, Int#, Int# #)+   with+   out_of_line = True+   has_side_effects = True++------------------------------------------------------------------------+section "Weak pointers"+------------------------------------------------------------------------++primtype Weak# b++-- N.B. "v" and "w" denote levity-polymorphic type variables.+-- See Note [Levity and representation polymorphic primops]++primop  MkWeakOp "mkWeak#" GenPrimOp+   v -> w -> (State# RealWorld -> (# State# RealWorld, c #))+     -> State# RealWorld -> (# State# RealWorld, Weak# w #)+   { {\tt mkWeak# k v finalizer s} creates a weak reference to value {\tt k},+     with an associated reference to some value {\tt v}. If {\tt k} is still+     alive then {\tt v} can be retrieved using {\tt deRefWeak#}. Note that+     the type of {\tt k} must be represented by a pointer (i.e. of kind {\tt+     TYPE 'LiftedRep} or {\tt TYPE 'UnliftedRep}). }+   with+   has_side_effects = True+   out_of_line      = True++primop  MkWeakNoFinalizerOp "mkWeakNoFinalizer#" GenPrimOp+   v -> w -> State# RealWorld -> (# State# RealWorld, Weak# w #)+   with+   has_side_effects = True+   out_of_line      = True++primop  AddCFinalizerToWeakOp "addCFinalizerToWeak#" GenPrimOp+   Addr# -> Addr# -> Int# -> Addr# -> Weak# w+          -> State# RealWorld -> (# State# RealWorld, Int# #)+   { {\tt addCFinalizerToWeak# fptr ptr flag eptr w} attaches a C+     function pointer {\tt fptr} to a weak pointer {\tt w} as a finalizer. If+     {\tt flag} is zero, {\tt fptr} will be called with one argument,+     {\tt ptr}. Otherwise, it will be called with two arguments,+     {\tt eptr} and {\tt ptr}. {\tt addCFinalizerToWeak#} returns+     1 on success, or 0 if {\tt w} is already dead. }+   with+   has_side_effects = True+   out_of_line      = True++primop  DeRefWeakOp "deRefWeak#" GenPrimOp+   Weak# v -> State# RealWorld -> (# State# RealWorld, Int#, v #)+   with+   has_side_effects = True+   out_of_line      = True++primop  FinalizeWeakOp "finalizeWeak#" GenPrimOp+   Weak# v -> 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 {\tt Int#} and a (possibly invalid) finalization+     action. An {\tt Int#} of {\tt 1} indicates that the finalizer is valid. The+     return value {\tt b} from the finalizer should be ignored. }+   with+   has_side_effects = True+   out_of_line      = True++primop TouchOp "touch#" GenPrimOp+   v -> State# RealWorld -> State# RealWorld+   with+   code_size = { 0 }+   has_side_effects = True++------------------------------------------------------------------------+section "Stable pointers and names"+------------------------------------------------------------------------++primtype StablePtr# a++primtype StableName# a++primop  MakeStablePtrOp "makeStablePtr#" GenPrimOp+   v -> State# RealWorld -> (# State# RealWorld, StablePtr# v #)+   with+   has_side_effects = True+   out_of_line      = True++primop  DeRefStablePtrOp "deRefStablePtr#" GenPrimOp+   StablePtr# v -> State# RealWorld -> (# State# RealWorld, v #)+   with+   has_side_effects = True+   out_of_line      = True++primop  EqStablePtrOp "eqStablePtr#" GenPrimOp+   StablePtr# v -> StablePtr# v -> Int#+   with+   has_side_effects = True++primop  MakeStableNameOp "makeStableName#" GenPrimOp+   v -> State# RealWorld -> (# State# RealWorld, StableName# v #)+   with+   has_side_effects = True+   out_of_line      = True++primop  StableNameToIntOp "stableNameToInt#" GenPrimOp+   StableName# v -> Int#++------------------------------------------------------------------------+section "Compact normal form"++        {Primitives for working with compact regions. The {\tt ghc\-compact}+         library and the {\tt 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 {\tt 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+   has_side_effects = True+   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+   has_side_effects = True+   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 {\tt 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 {\texttt Addr\#} is a pointer+     to previous compact block of the CNF or {\texttt nullAddr\#} to create a+     new CNF with a single compact block.++     The resulting block is not known to the GC until+     {\texttt compactFixupPointers\#} is called on it, and care must be taken+     so that the address does not escape or memory will be leaked.+   }+   with+   has_side_effects = True+   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+   has_side_effects = True+   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+     {\texttt Compact\#} (a CNF), evaluating any unevaluated components+     at the same time. Note: {\texttt compactAdd\#} is not thread-safe, so+     only one thread may call {\texttt compactAdd\#} with a particular+     {\texttt Compact\#} at any given time. The primop does not+     enforce any mutual exclusion; the caller is expected to+     arrange this. }+   with+   has_side_effects = True+   out_of_line      = True++primop CompactAddWithSharing "compactAddWithSharing#" GenPrimOp+   Compact# -> a -> State# RealWorld -> (# State# RealWorld, a #)+   { Like {\texttt compactAdd\#}, but retains sharing and cycles+   during compaction. }+   with+   has_side_effects = True+   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+   has_side_effects = True+   out_of_line      = True++------------------------------------------------------------------------+section "Unsafe pointer equality"+--  (#1 Bad Guy: Alastair Reid :)+------------------------------------------------------------------------++-- `v` and `w` are levity-polymorphic type variables with independent levities.+-- See Note [Levity and representation polymorphic primops]+primop  ReallyUnsafePtrEqualityOp "reallyUnsafePtrEquality#" GenPrimOp+   v -> w -> Int#+   { Returns {\texttt 1\#} if the given pointers are equal and {\texttt 0\#} otherwise. }+   with+   can_fail   = True -- See Note [reallyUnsafePtrEquality# can_fail]++-- Note [Pointer comparison operations]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- The primop `reallyUnsafePtrEquality#` does a direct pointer+-- equality between two (boxed) values.  Several things to note:+--+-- * 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+--   "v" and "w". See Note [Levity and representation polymorphic primops]+--+-- * It does not evaluate its arguments. The user of the primop is responsible+--   for doing so.+--+-- * It is hetero-typed; you can compare pointers of different types.+--   This is used in various packages such as containers & unordered-containers.+--+-- * It is obviously very dangerous, because+--      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).+--+-- * reallyUnsafePtrEquality# can't fail, but it is marked as such+--   to prevent it from floating out.+--   See Note [reallyUnsafePtrEquality# can_fail]+--+-- The library GHC.Exts provides several 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#+--   sameIOPort# :: IOPort# s a -> IOPort# s a -> Int#+--   eqStableName# :: StableName# a -> StableName# b -> Int#+--+-- These operations are all specialisations of reallyUnsafePtrEquality#.++-- Note [reallyUnsafePtrEquality# can_fail]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- reallyUnsafePtrEquality# can't actually fail, per se, but we mark it+-- can_fail 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/app 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#+   with+      -- Note that Par is lazy to avoid that the sparked thing+      -- gets evaluated strictly, which it should *not* be+   has_side_effects = True+   code_size = { primOpCodeSizeForeignCall }+   deprecated_msg = { Use 'spark#' instead }++primop SparkOp "spark#" GenPrimOp+   a -> State# s -> (# State# s, a #)+   with has_side_effects = True+   code_size = { primOpCodeSizeForeignCall }++primop SeqOp "seq#" GenPrimOp+   a -> State# s -> (# State# s, a #)+   -- See Note [seq# magic] in GHC.Core.Op.ConstantFold++primop GetSparkOp "getSpark#" GenPrimOp+   State# s -> (# State# s, Int#, a #)+   with+   has_side_effects = True+   out_of_line = True++primop NumSparks "numSparks#" GenPrimOp+   State# s -> (# State# s, Int# #)+   { Returns the number of sparks in the local spark pool. }+   with+   has_side_effects = True+   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.+-- NB: "v" is the same as "a" except levity-polymorphic,+-- and "p" is the same as "b" except representation-polymorphic.+-- See Note [Levity and representation polymorphic primops]+primop KeepAliveOp "keepAlive#" GenPrimOp+   v -> State# RealWorld -> (State# RealWorld -> p) -> p+   { \tt{keepAlive# x s k} keeps the value \tt{x} alive during the execution+     of the computation \tt{k}.++     Note that the result type here isn't quite as unrestricted as the+     polymorphic type might suggest; ticket \#21868 for details. }+   with+   out_of_line = True+   strictness = { \ _arity -> mkClosedDmdSig [topDmd, topDmd, strictOnceApply1Dmd] topDiv }+++------------------------------------------------------------------------+section "Tag to enum stuff"+        {Convert back and forth between values of enumerated types+        and small integers.}+------------------------------------------------------------------------++primop  DataToTagOp "dataToTag#" GenPrimOp+   a -> Int#  -- Zero-indexed; the first constructor has tag zero+   with+   strictness = { \ _arity -> mkClosedDmdSig [evalDmd] topDiv }+   -- See Note [dataToTag# magic] in GHC.Core.Opt.ConstantFold++primop  TagToEnumOp "tagToEnum#" GenPrimOp+   Int# -> a++------------------------------------------------------------------------+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 #)+   { Convert an {\tt 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 {\texttt 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 {\texttt 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 {\tt 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 #)+   { {\tt 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 {\tt instrs}, and a static reference table usage bitmap given by+     {\tt bitmap}. }+   with+   has_side_effects = True+   out_of_line      = True++primop  UnpackClosureOp "unpackClosure#" GenPrimOp+   a -> (# Addr#, ByteArray#, Array# b #)+   { {\tt 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#+   { {\tt 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 {\tt CostCentreStack} (value is {\tt NULL} if+     not profiling).  Takes a dummy argument which can be used to+     avoid the call to {\tt 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 "Info Table Origin"+------------------------------------------------------------------------+primop WhereFromOp "whereFrom#" GenPrimOp+   a -> State# s -> (# State# s, Addr# #)+   { Returns the {\tt InfoProvEnt } for the info table of the given object+     (value is {\tt NULL} if the table does not exist or there is no information+     about the closure).}+   with+   out_of_line = True++------------------------------------------------------------------------+section "Etc"+        {Miscellaneous built-ins}+------------------------------------------------------------------------++primtype FUN m a b+  {The builtin function type, written in infix form as {\tt a # m -> b}.+   Values of this type are functions taking inputs of type {\tt a} and+   producing outputs of type {\tt b}. The multiplicity of the input is+   {\tt m}.++   Note that {\tt FUN m a b} permits representation polymorphism in both+   {\tt a} and {\tt b}, so that types like {\tt 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 {\tt GHC.Magic.runRW\#}. }++pseudoop "void#"+   (# #)+   { This is an alias for the unboxed unit tuple constructor.+     In earlier versions of GHC, {\tt void\#} was a value+     of the primitive type {\tt Void\#}, which is now defined to be {\tt (\# \#)}.+   }+   with deprecated_msg = { Use an unboxed unit tuple instead }++primtype Proxy# a+   { The type constructor {\tt 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 {\tt 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 {\tt Proxy#} value, which has no runtime+   representation. }++pseudoop   "seq"+   a -> b -> b+   { The value of {\tt seq a b} is bottom if {\tt a} is bottom, and+     otherwise equal to {\tt b}. In other words, it evaluates the first+     argument {\tt a} to weak head normal form (WHNF). {\tt seq} is usually+     introduced to improve performance by avoiding unneeded laziness.++     A note on evaluation order: the expression {\tt seq a b} does+     {\it not} guarantee that {\tt a} will be evaluated before {\tt b}.+     The only guarantee given by {\tt seq} is that the both {\tt a}+     and {\tt b} will be evaluated before {\tt seq} returns a value.+     In particular, this means that {\tt b} may be evaluated before+     {\tt a}. If you need to guarantee a specific order of evaluation,+     you must use the function {\tt 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'.++pseudoop   "unsafeCoerce#"+   a -> b+   { The function {\tt unsafeCoerce\#} allows you to side-step the typechecker entirely. That+        is, it allows you to coerce any type into any other type. If you use this function,+        you had better get it right, otherwise segmentation faults await. It is generally+        used when you want to write a program that you know is well-typed, but where Haskell's+        type system is not expressive enough to prove that it is well typed.++        The following uses of {\tt unsafeCoerce\#} are supposed to work (i.e. not lead to+        spurious compile-time or run-time crashes):++         * Casting any lifted type to {\tt Any}++         * Casting {\tt Any} back to the real type++         * Casting an unboxed type to another unboxed type of the same size.+           (Casting between floating-point and integral types does not work.+           See the {\tt GHC.Float} module for functions to do work.)++         * Casting between two types that have the same runtime representation.  One case is when+           the two types differ only in "phantom" type parameters, for example+           {\tt Ptr Int} to {\tt Ptr Float}, or {\tt [Int]} to {\tt [Float]} when the list is+           known to be empty.  Also, a {\tt newtype} of a type {\tt T} has the same representation+           at runtime as {\tt T}.++        Other uses of {\tt unsafeCoerce\#} are undefined.  In particular, you should not use+        {\tt unsafeCoerce\#} to cast a T to an algebraic data type D, unless T is also+        an algebraic data type.  For example, do not cast {\tt Int->Int} to {\tt Bool}, even if+        you later cast that {\tt Bool} back to {\tt Int->Int} before applying it.  The reasons+        have to do with GHC's internal representation details (for the cognoscenti, data values+        can be entered but function closures cannot).  If you want a safe type to cast things+        to, use {\tt Any}, which is not an algebraic data type.++        }+   with can_fail = True++-- NB. It is tempting to think that casting a value to a type that it doesn't have is safe+-- as long as you don't "do anything" with the value in its cast form, such as seq on it.  This+-- isn't the case: the compiler can insert seqs itself, and if these happen at the wrong type,+-- Bad Things Might Happen.  See bug #1616: in this case we cast a function of type (a,b) -> (a,b)+-- to () -> () and back again.  The strictness analyser saw that the function was strict, but+-- the wrapper had type () -> (), and hence the wrapper de-constructed the (), the worker re-constructed+-- a new (), with the result that the code ended up with "case () of (a,b) -> ...".++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 {\tt .eventlog} file,+     or to stderr, depending on the runtime RTS flags. }+   with+   has_side_effects = True+   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 {\tt .eventlog} file. }+   with+   has_side_effects = True+   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 {\tt .eventlog} file,+     or to stderr, depending on the runtime RTS flags. }+   with+   has_side_effects = True+   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+   has_side_effects = True+   out_of_line      = True++primtype StackSnapshot#+   { Haskell representation of a {\tt StgStack*} that was created (cloned)+     with a function in {\tt GHC.Stack.CloneStack}. Please check the+     documentation in this module for more detailed explanations. }++------------------------------------------------------------------------+section "Safe coercions"+------------------------------------------------------------------------++pseudoop   "coerce"+   Coercible a b => a -> b+   { The function {\tt 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.++     This function is representation-polymorphic, but the+     {\tt RuntimeRep} type argument is marked as {\tt Inferred}, meaning+     that it is not available for visible type application. This means+     the typechecker will accept {\tt coerce @Int @Age 42}.+   }++------------------------------------------------------------------------+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,Word#,16>,<Word16,Word#,8>,<Word32,Word32#,4>,<Word64,Word64#,2> \+  ,<Word8,Word#,32>,<Word16,Word#,16>,<Word32,Word32#,8>,<Word64,Word64#,4> \+  ,<Word8,Word#,64>,<Word16,Word#,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,Word#,16>,<Word16,Word#,8>,<Word32,Word32#,4>,<Word64,Word64#,2> \+  ,<Word8,Word#,32>,<Word16,Word#,16>,<Word32,Word32#,8>,<Word64,Word64#,4> \+  ,<Word8,Word#,64>,<Word16,Word#,32>,<Word32,Word32#,16>,<Word64,Word64#,8>]++primtype VECTOR+   with llvm_only = True+        vector = ALL_VECTOR_TYPES++primop VecBroadcastOp "broadcast#" GenPrimOp+   SCALAR -> VECTOR+   { Broadcast a scalar to all elements of a vector. }+   with llvm_only = True+        vector = ALL_VECTOR_TYPES++primop VecPackOp "pack#" GenPrimOp+   VECTUPLE -> VECTOR+   { Pack the elements of an unboxed tuple into a vector. }+   with llvm_only = True+        vector = ALL_VECTOR_TYPES++primop VecUnpackOp "unpack#" GenPrimOp+   VECTOR -> VECTUPLE+   { Unpack the elements of a vector into an unboxed tuple. #}+   with llvm_only = True+        vector = ALL_VECTOR_TYPES++primop VecInsertOp "insert#" GenPrimOp+   VECTOR -> SCALAR -> Int# -> VECTOR+   { Insert a scalar at the given position in a vector. }+   with can_fail = True+        llvm_only = True+        vector = ALL_VECTOR_TYPES++primop VecAddOp "plus#" GenPrimOp+   VECTOR -> VECTOR -> VECTOR+   { Add two vectors element-wise. }+   with commutable = True+        llvm_only = True+        vector = ALL_VECTOR_TYPES++primop VecSubOp "minus#" GenPrimOp+   VECTOR -> VECTOR -> VECTOR+   { Subtract two vectors element-wise. }+   with llvm_only = True+        vector = ALL_VECTOR_TYPES++primop VecMulOp "times#" GenPrimOp+   VECTOR -> VECTOR -> VECTOR+   { Multiply two vectors element-wise. }+   with commutable = True+        llvm_only = True+        vector = ALL_VECTOR_TYPES++primop VecDivOp "divide#" GenPrimOp+   VECTOR -> VECTOR -> VECTOR+   { Divide two vectors element-wise. }+   with can_fail = True+        llvm_only = True+        vector = FLOAT_VECTOR_TYPES++primop VecQuotOp "quot#" GenPrimOp+   VECTOR -> VECTOR -> VECTOR+   { Rounds towards zero element-wise. }+   with can_fail = True+        llvm_only = True+        vector = INT_VECTOR_TYPES++primop VecRemOp "rem#" GenPrimOp+   VECTOR -> VECTOR -> VECTOR+   { Satisfies \texttt{(quot\# x y) times\# y plus\# (rem\# x y) == x}. }+   with can_fail = True+        llvm_only = True+        vector = INT_VECTOR_TYPES++primop VecNegOp "negate#" GenPrimOp+   VECTOR -> VECTOR+   { Negate element-wise. }+   with llvm_only = True+        vector = SIGNED_VECTOR_TYPES++primop VecIndexByteArrayOp "indexArray#" GenPrimOp+   ByteArray# -> Int# -> VECTOR+   { Read a vector from specified index of immutable array. }+   with can_fail = True+        llvm_only = True+        vector = ALL_VECTOR_TYPES++primop VecReadByteArrayOp "readArray#" GenPrimOp+   MutableByteArray# s -> Int# -> State# s -> (# State# s, VECTOR #)+   { Read a vector from specified index of mutable array. }+   with has_side_effects = True+        can_fail = True+        llvm_only = True+        vector = ALL_VECTOR_TYPES++primop VecWriteByteArrayOp "writeArray#" GenPrimOp+   MutableByteArray# s -> Int# -> VECTOR -> State# s -> State# s+   { Write a vector to specified index of mutable array. }+   with has_side_effects = True+        can_fail = True+        llvm_only = True+        vector = ALL_VECTOR_TYPES++primop VecIndexOffAddrOp "indexOffAddr#" GenPrimOp+   Addr# -> Int# -> VECTOR+   { Reads vector; offset in bytes. }+   with can_fail = True+        llvm_only = True+        vector = ALL_VECTOR_TYPES++primop VecReadOffAddrOp "readOffAddr#" GenPrimOp+   Addr# -> Int# -> State# s -> (# State# s, VECTOR #)+   { Reads vector; offset in bytes. }+   with has_side_effects = True+        can_fail = True+        llvm_only = True+        vector = ALL_VECTOR_TYPES++primop VecWriteOffAddrOp "writeOffAddr#" GenPrimOp+   Addr# -> Int# -> VECTOR -> State# s -> State# s+   { Write vector; offset in bytes. }+   with has_side_effects = True+        can_fail = True+        llvm_only = True+        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 can_fail = True+        llvm_only = True+        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 has_side_effects = True+        can_fail = True+        llvm_only = True+        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 has_side_effects = True+        can_fail = True+        llvm_only = True+        vector = ALL_VECTOR_TYPES++primop VecIndexScalarOffAddrOp "indexOffAddrAs#" GenPrimOp+   Addr# -> Int# -> VECTOR+   { Reads vector; offset in scalar elements. }+   with can_fail = True+        llvm_only = True+        vector = ALL_VECTOR_TYPES++primop VecReadScalarOffAddrOp "readOffAddrAs#" GenPrimOp+   Addr# -> Int# -> State# s -> (# State# s, VECTOR #)+   { Reads vector; offset in scalar elements. }+   with has_side_effects = True+        can_fail = True+        llvm_only = True+        vector = ALL_VECTOR_TYPES++primop VecWriteScalarOffAddrOp "writeOffAddrAs#" GenPrimOp+   Addr# -> Int# -> VECTOR -> State# s -> State# s+   { Write vector; offset in scalar elements. }+   with has_side_effects = True+        can_fail = True+        llvm_only = True+        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 {\tt prefetch*} family of operations has the order of operations+  determined by passing around the {\tt State#} token.++  To get a "pure" version of these operations, use {\tt 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 has_side_effects=True+  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/app 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 has_side_effects =  True++primop PrefetchMutableByteArrayOp3 "prefetchMutableByteArray3#" GenPrimOp+  MutableByteArray# s -> Int# -> State# s -> State# s+  with has_side_effects =  True++primop PrefetchAddrOp3 "prefetchAddr3#" GenPrimOp+  Addr# -> Int# -> State# s -> State# s+  with has_side_effects =  True++primop PrefetchValueOp3 "prefetchValue3#" GenPrimOp+   a -> State# s -> State# s+   with has_side_effects =  True+----++primop PrefetchByteArrayOp2 "prefetchByteArray2#" GenPrimOp+  ByteArray# -> Int# ->  State# s -> State# s+  with has_side_effects =  True++primop PrefetchMutableByteArrayOp2 "prefetchMutableByteArray2#" GenPrimOp+  MutableByteArray# s -> Int# -> State# s -> State# s+  with has_side_effects =  True++primop PrefetchAddrOp2 "prefetchAddr2#" GenPrimOp+  Addr# -> Int# ->  State# s -> State# s+  with has_side_effects =  True++primop PrefetchValueOp2 "prefetchValue2#" GenPrimOp+   a ->  State# s -> State# s+   with has_side_effects =  True+----++primop PrefetchByteArrayOp1 "prefetchByteArray1#" GenPrimOp+   ByteArray# -> Int# -> State# s -> State# s+   with has_side_effects =  True++primop PrefetchMutableByteArrayOp1 "prefetchMutableByteArray1#" GenPrimOp+  MutableByteArray# s -> Int# -> State# s -> State# s+  with has_side_effects =  True++primop PrefetchAddrOp1 "prefetchAddr1#" GenPrimOp+  Addr# -> Int# -> State# s -> State# s+  with has_side_effects =  True++primop PrefetchValueOp1 "prefetchValue1#" GenPrimOp+   a -> State# s -> State# s+   with has_side_effects =  True+----++primop PrefetchByteArrayOp0 "prefetchByteArray0#" GenPrimOp+  ByteArray# -> Int# ->  State# s -> State# s+  with has_side_effects =  True++primop PrefetchMutableByteArrayOp0 "prefetchMutableByteArray0#" GenPrimOp+  MutableByteArray# s -> Int# -> State# s -> State# s+  with has_side_effects =  True++primop PrefetchAddrOp0 "prefetchAddr0#" GenPrimOp+  Addr# -> Int# -> State# s -> State# s+  with has_side_effects =  True++primop PrefetchValueOp0 "prefetchValue0#" GenPrimOp+   a -> State# s -> State# s+   with has_side_effects =  True++------------------------------------------------------------------------+---                                                                  ---+------------------------------------------------------------------------++thats_all_folks
GHC/ByteCode/Asm.hs view
@@ -15,8 +15,6 @@         mkTupleInfoLit   ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.ByteCode.Instr@@ -34,7 +32,7 @@  import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Misc+import GHC.Utils.Panic.Plain  import GHC.Core.TyCon import GHC.Data.FastString@@ -204,7 +202,7 @@   (final_insns, final_lits, final_ptrs) <- flip execStateT initial_state $ runAsm platform long_jumps env asm    -- precomputed size should be equal to final size-  ASSERT(n_insns == sizeSS final_insns) return ()+  massert (n_insns == sizeSS final_insns)    let asm_insns = ssElts final_insns       insns_arr = Array.listArray (0, fromIntegral n_insns - 1) asm_insns@@ -342,7 +340,7 @@ --      count (LargeOp _) = largeArg16s platform  -- Bring in all the bci_ bytecode constants.-#include "rts/Bytecodes.h"+#include "Bytecodes.h"  largeArgInstr :: Word16 -> Word16 largeArgInstr bci = bci_FLAG_LARGE_ARGS .|. bci@@ -490,8 +488,7 @@       LitNumWord32  -> int32 (fromIntegral i)       LitNumInt64   -> int64 (fromIntegral i)       LitNumWord64  -> int64 (fromIntegral i)-      LitNumInteger -> panic "GHC.ByteCode.Asm.literal: LitNumInteger"-      LitNumNatural -> panic "GHC.ByteCode.Asm.literal: LitNumNatural"+      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@@ -500,7 +497,7 @@      litlabel fs = lit [BCONPtrLbl fs]     addr (RemotePtr a) = words [fromIntegral a]-    float = words . mkLitF+    float = words . mkLitF platform     double = words . mkLitD platform     int = words . mkLitI     int8 = words . mkLitI64 platform@@ -569,9 +566,9 @@               text "Use -fobject-code to get around this limit"              )   | otherwise-  = ASSERT(length regs <= 24) {- 24 bits for bitmap -}-    ASSERT(tupleNativeStackSize < 255) {- 8 bits for stack size -}-    ASSERT(all (`elem` regs) (regSetToList tupleRegs)) {- all regs accounted for -}+  = assert (length regs <= 24) {- 24 bits for bitmap -}+    assert (tupleNativeStackSize < 255) {- 8 bits for stack size -}+    assert (all (`elem` regs) (regSetToList tupleRegs)) {- all regs accounted for -}     foldl' reg_bit 0 (zip regs [0..]) .|.       (fromIntegral tupleNativeStackSize `shiftL` 24)   where@@ -589,18 +586,28 @@ -- words are placed in memory at increasing addresses, the -- bit pattern is correct for the host's word size and endianness. mkLitI   ::             Int    -> [Word]-mkLitF   ::             Float  -> [Word]+mkLitF   :: Platform -> Float  -> [Word] mkLitD   :: Platform -> Double -> [Word] mkLitI64 :: Platform -> Int64  -> [Word] -mkLitF f-   = runST (do+mkLitF platform f = case platformWordSize platform of+  PW4 -> runST $ do         arr <- newArray_ ((0::Int),0)         writeArray arr 0 f         f_arr <- castSTUArray arr         w0 <- readArray f_arr 0         return [w0 :: Word]-     )++  PW8 -> runST $ do+        arr <- newArray_ ((0::Int),1)+        writeArray arr 0 f+        -- on 64-bit architectures we read two (32-bit) Float cells when we read+        -- a (64-bit) Word: so we write a dummy value in the second cell to+        -- avoid an out-of-bound read.+        writeArray arr 1 0.0+        f_arr <- castSTUArray arr+        w0 <- readArray f_arr 0+        return [w0 :: Word]  mkLitD platform d = case platformWordSize platform of    PW4 -> runST (do
GHC/ByteCode/InfoTable.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP                 #-}+ {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-} --@@ -8,11 +8,7 @@ -- | Generate infotables for interpreter-made bytecodes module GHC.ByteCode.InfoTable ( mkITbls ) where -#include "HsVersions.h"- import GHC.Prelude--import GHC.Driver.Session  import GHC.Platform import GHC.Platform.Profile
GHC/ByteCode/Instr.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP              #-}+ {-# LANGUAGE FlexibleContexts #-} {-# OPTIONS_GHC -funbox-strict-fields #-} --@@ -10,8 +10,6 @@         BCInstr(..), ProtoBCO(..), bciStackUse, LocalLabel(..)   ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.ByteCode.Types@@ -225,7 +223,7 @@   char '{' <+> ppr (fst (head bs)) <+> text "= ...; ... }"  pprStgAltShort :: OutputablePass pass => StgPprOpts -> GenStgAlt pass -> SDoc-pprStgAltShort opts (con, args, expr) =+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
GHC/ByteCode/Linker.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP                   #-} {-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE MagicHash             #-} {-# LANGUAGE MultiParamTypeClasses #-}@@ -20,8 +19,6 @@   ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Runtime.Interpreter@@ -31,6 +28,7 @@ import GHCi.BreakArray  import GHC.Builtin.PrimOps+import GHC.Builtin.Names  import GHC.Unit.Types import GHC.Unit.Module.Name@@ -39,8 +37,8 @@ import GHC.Data.SizedSeq  import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Utils.Outputable-import GHC.Utils.Misc  import GHC.Types.Name import GHC.Types.Name.Env@@ -150,7 +148,7 @@     -> return (ResolvedBCOPtr (unsafeForeignRefToRemoteRef rhv))      | otherwise-    -> ASSERT2(isExternalName nm, ppr nm)+    -> assertPpr (isExternalName nm) (ppr nm) $        do           let sym_to_find = nameToCLabel nm "closure"           m <- lookupSymbol interp sym_to_find@@ -187,7 +185,11 @@ nameToCLabel n suffix = mkFastString label   where     encodeZ = zString . zEncodeFS-    (Module pkgKey modName) = ASSERT( isExternalName n ) nameModule n+    (Module pkgKey modName) = assert (isExternalName n) $ case nameModule n of+        -- Primops are exported from GHC.Prim, their HValues live in GHC.PrimopWrappers+        -- See Note [Primop wrappers] in GHC.Builtin.PrimOps.+        mod | mod == gHC_PRIM -> gHC_PRIMOPWRAPPERS+        mod -> mod     packagePart = encodeZ (unitFS pkgKey)     modulePart  = encodeZ (moduleNameFS modName)     occPart     = encodeZ (occNameFS (nameOccName n))
GHC/ByteCode/Types.hs view
@@ -68,7 +68,7 @@ seqCompiledByteCode :: CompiledByteCode -> () seqCompiledByteCode CompiledByteCode{..} =   rnf bc_bcos `seq`-  rnf (nameEnvElts bc_itbls) `seq`+  seqEltsNameEnv rnf bc_itbls `seq`   rnf bc_ffis `seq`   rnf bc_strs `seq`   rnf (fmap seqModBreaks bc_breaks)@@ -84,7 +84,6 @@  {- Note [GHCi TupleInfo] ~~~~~~~~~~~~~~~~~~~~~~~~-    This contains the data we need for passing unboxed tuples between    bytecode and native code
GHC/Cmm.hs view
@@ -167,12 +167,12 @@         -- place to convey this information from the code generator to         -- where we build the static closures in         -- GHC.Cmm.Info.Build.doSRTs.-    }+    } deriving Eq  data ProfilingInfo   = NoProfilingInfo   | ProfilingInfo ByteString ByteString -- closure_type, closure_desc-+  deriving Eq ----------------------------------------------------------------------------- --              Static Data -----------------------------------------------------------------------------@@ -184,6 +184,9 @@   | RelocatableReadOnlyData   | UninitialisedData   | ReadOnlyData16      -- .rodata.cst16 on x86_64, 16-byte aligned+    -- 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)@@ -201,6 +204,8 @@     ReadOnlyData            -> ReadOnlySection     RelocatableReadOnlyData -> WriteProtectedSection     ReadOnlyData16          -> ReadOnlySection+    InitArray               -> ReadOnlySection+    FiniArray               -> ReadOnlySection     CString                 -> ReadOnlySection     Data                    -> ReadWriteSection     UninitialisedData       -> ReadWriteSection@@ -288,4 +293,3 @@ pprBBlock :: Outputable stmt => GenBasicBlock stmt -> SDoc pprBBlock (BasicBlock ident stmts) =     hang (ppr ident <> colon) 4 (vcat (map ppr stmts))-
GHC/Cmm/CLabel.hs view
@@ -6,9 +6,7 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} @@ -27,6 +25,7 @@         mkInfoTableLabel,         mkEntryLabel,         mkRednCountsLabel,+        mkTagHitLabel,         mkConInfoTableLabel,         mkApEntryLabel,         mkApInfoTableLabel,@@ -34,15 +33,17 @@         mkBytesLabel,          mkLocalBlockLabel,-        mkLocalClosureLabel,-        mkLocalInfoTableLabel,-        mkLocalClosureTableLabel,          mkBlockInfoTableLabel,          mkBitmapLabel,         mkStringLitLabel, +        mkInitializerStubLabel,+        mkInitializerArrayLabel,+        mkFinalizerStubLabel,+        mkFinalizerArrayLabel,+         mkAsmTempLabel,         mkAsmTempDerivedLabel,         mkAsmTempEndLabel,@@ -50,6 +51,7 @@         mkAsmTempDieLabel,          mkDirty_MUT_VAR_Label,+        mkMUT_VAR_CLEAN_infoLabel,         mkNonmovingWriteBarrierEnabledLabel,         mkUpdInfoLabel,         mkBHUpdInfoLabel,@@ -134,8 +136,6 @@         foreignLabelStdcallInfo     ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Types.Id.Info@@ -148,14 +148,14 @@ import GHC.Types.CostCentre import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Data.FastString-import GHC.Driver.Session import GHC.Platform import GHC.Types.Unique.Set import GHC.Utils.Misc import GHC.Core.Ppr ( {- instances -} )-import GHC.CmmToAsm.Config import GHC.Types.SrcLoc+ -- ----------------------------------------------------------------------------- -- The CLabel type @@ -260,6 +260,8 @@   | 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@@ -276,7 +278,6 @@   -- | A label before an info table to prevent excessive dead-stripping on darwin   | DeadStripPreventer CLabel -   -- | Per-module table of tick locations   | HpcTicksLabel Module @@ -296,6 +297,19 @@ instance Outputable CLabel where   ppr = text . show +data ModuleLabelKind+    = MLK_Initializer String+    | MLK_InitializerArray+    | MLK_Finalizer String+    | MLK_FinalizerArray+    deriving (Eq, Ord)++instance Outputable ModuleLabelKind where+    ppr MLK_InitializerArray = text "init_arr"+    ppr (MLK_Initializer s)  = text ("init__" ++ s)+    ppr MLK_FinalizerArray   = text "fini_arr"+    ppr (MLK_Finalizer s)    = text ("fini__" ++ s)+ isIdLabel :: CLabel -> Bool isIdLabel IdLabel{} = True isIdLabel _ = False@@ -303,14 +317,14 @@ -- Used in SRT analysis. See Note [Ticky labels in SRT analysis] in -- GHC.Cmm.Info.Build. isTickyLabel :: CLabel -> Bool-isTickyLabel (IdLabel _ _ RednCounts) = True+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 "includes/Stg.h" with the appropriate type. See 'needsCDecl'.+-- 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@@ -337,6 +351,8 @@   compare (CmmLabel a1 b1 c1 d1) (CmmLabel a2 b2 c2 d2) =     compare a1 a2 `thenCmp`     compare b1 b2 `thenCmp`+    -- This non-determinism is "safe" in the sense that it only affects object code,+    -- which is currently not covered by GHC's determinism guarantees. See #12935.     uniqCompareFS c1 c2 `thenCmp`     compare d1 d2   compare (RtsLabel a1) (RtsLabel a2) = compare a1 a2@@ -349,7 +365,7 @@   compare (AsmTempLabel u1) (AsmTempLabel u2) = nonDetCmpUnique u1 u2   compare (AsmTempDerivedLabel a1 b1) (AsmTempDerivedLabel a2 b2) =     compare a1 a2 `thenCmp`-    uniqCompareFS b1 b2+    lexicalCompareFS b1 b2   compare (StringLitLabel u1) (StringLitLabel u2) =     nonDetCmpUnique u1 u2   compare (CC_Label a1) (CC_Label a2) =@@ -358,6 +374,9 @@     compare a1 a2   compare (IPE_Label a1) (IPE_Label a2) =     compare a1 a2+  compare (ModuleLabel m1 k1) (ModuleLabel m2 k2) =+    compare m1 m2 `thenCmp`+    compare k1 k2   compare (DynamicLinkerLabel a1 b1) (DynamicLinkerLabel a2 b2) =     compare a1 a2 `thenCmp`     compare b1 b2@@ -402,6 +421,8 @@   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@@ -447,7 +468,27 @@           _  -> 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@@ -457,7 +498,7 @@   | LocalInfoTable      -- ^ Like InfoTable but not externally visible   | LocalEntry          -- ^ Like Entry but not externally visible -  | RednCounts          -- ^ Label of place to keep Ticky-ticky  info for this Id+  | 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@@ -478,7 +519,7 @@                         -- Note [Bytes label].   | BlockInfoTable      -- ^ Like LocalInfoTable but for a proc-point block                         -- instead of a closure entry-point.-                        -- See Note [Proc-point local block entry-point].+                        -- See Note [Proc-point local block entry-points].    deriving (Eq, Ord) @@ -504,12 +545,12 @@   ppr LocalInfoTable  = text "LocalInfoTable"   ppr LocalEntry      = text "LocalEntry" -  ppr RednCounts      = text "RednCounts"   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@@ -559,16 +600,12 @@ mkSRTLabel     :: Unique -> CLabel mkSRTLabel u = SRTLabel u +-- See Note [ticky for LNE] mkRednCountsLabel :: Name -> CLabel-mkRednCountsLabel name = IdLabel name NoCafRefs RednCounts  -- Note [ticky for LNE]+mkRednCountsLabel name = IdLabel name NoCafRefs (IdTickyInfo TickyRednCounts) --- These have local & (possibly) external variants:-mkLocalClosureLabel      :: Name -> CafInfo -> CLabel-mkLocalInfoTableLabel    :: Name -> CafInfo -> CLabel-mkLocalClosureTableLabel :: Name -> CafInfo -> CLabel-mkLocalClosureLabel   !name !c  = IdLabel name  c Closure-mkLocalInfoTableLabel   name c  = IdLabel name  c LocalInfoTable-mkLocalClosureTableLabel name c = IdLabel name  c ClosureTable+mkTagHitLabel :: Name -> Unique -> CLabel+mkTagHitLabel name !uniq = IdLabel name NoCafRefs (IdTickyInfo (TickyInferedTag uniq))  mkClosureLabel              :: Name -> CafInfo -> CLabel mkInfoTableLabel            :: Name -> CafInfo -> CLabel@@ -577,7 +614,10 @@ mkConInfoTableLabel         :: Name -> ConInfoTableLocation -> CLabel mkBytesLabel                :: Name -> CLabel mkClosureLabel name         c     = IdLabel name c Closure-mkInfoTableLabel name       c     = IdLabel name c InfoTable+-- | Decicdes 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.@@ -587,7 +627,7 @@  mkBlockInfoTableLabel :: Name -> CafInfo -> CLabel mkBlockInfoTableLabel name c = IdLabel name c BlockInfoTable-                               -- See Note [Proc-point local block entry-point].+                               -- See Note [Proc-point local block entry-points].  -- Constructing Cmm Labels mkDirty_MUT_VAR_Label,@@ -601,7 +641,7 @@     mkCAFBlackHoleInfoTableLabel,     mkSMAP_FROZEN_CLEAN_infoLabel, mkSMAP_FROZEN_DIRTY_infoLabel,     mkSMAP_DIRTY_infoLabel, mkBadAlignmentLabel,-    mkOutOfBoundsAccessLabel :: CLabel+    mkOutOfBoundsAccessLabel, mkMUT_VAR_CLEAN_infoLabel :: CLabel mkDirty_MUT_VAR_Label           = mkForeignLabel (fsLit "dirty_MUT_VAR") Nothing ForeignLabelInExternalPackage IsFunction mkNonmovingWriteBarrierEnabledLabel                                 = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "nonmoving_write_barrier_enabled") CmmData@@ -620,6 +660,7 @@ 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") Nothing 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@@ -662,7 +703,7 @@ mkRtsCmmDataLabel    str         = CmmLabel rtsUnitId (NeedExternDecl False)  str CmmData                                     -- RTS symbols don't need "GHC.CmmToC" to                                     -- generate \"extern\" declaration (they are-                                    -- exposed via includes/Stg.h)+                                    -- exposed via rts/include/Stg.h)  mkLocalBlockLabel :: Unique -> CLabel mkLocalBlockLabel u = LocalBlockLabel u@@ -673,22 +714,22 @@  mkSelectorInfoLabel :: Platform -> Bool -> Int -> CLabel mkSelectorInfoLabel platform upd offset =-   ASSERT(offset >= 0 && offset <= pc_MAX_SPEC_SELECTEE_SIZE (platformConstants platform))+   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))+   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))+   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))+   assert (arity > 0 && arity <= pc_MAX_SPEC_AP_SIZE (platformConstants platform)) $    RtsLabel (RtsApEntry upd arity)  @@ -825,6 +866,19 @@ mkStringLitLabel :: Unique -> CLabel mkStringLitLabel                = StringLitLabel +mkInitializerStubLabel :: Module -> String -> CLabel+mkInitializerStubLabel mod s    = ModuleLabel mod (MLK_Initializer s)++mkInitializerArrayLabel :: Module -> CLabel+mkInitializerArrayLabel mod     = ModuleLabel mod MLK_InitializerArray+++mkFinalizerStubLabel :: Module -> String -> CLabel+mkFinalizerStubLabel mod s      = ModuleLabel mod (MLK_Finalizer s)++mkFinalizerArrayLabel :: Module -> CLabel+mkFinalizerArrayLabel mod       = ModuleLabel mod MLK_FinalizerArray+ mkAsmTempLabel :: Uniquable a => a -> CLabel mkAsmTempLabel a                = AsmTempLabel (getUnique a) @@ -864,7 +918,7 @@    IdLabel n c (ConInfoTable k)  -> IdLabel n c (ConEntry k)     IdLabel n _ BlockInfoTable    -> mkLocalBlockLabel (nameUnique n)-                   -- See Note [Proc-point local block entry-point].+                   -- 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@@ -891,13 +945,12 @@ -- ----------------------------------------------------------------------------- -- Does a CLabel's referent itself refer to a CAF? hasCAF :: CLabel -> Bool-hasCAF (IdLabel _ _ RednCounts) = False -- Note [ticky for LNE]+hasCAF (IdLabel _ _ (IdTickyInfo TickyRednCounts)) = False -- See Note [ticky for LNE] hasCAF (IdLabel _ MayHaveCafRefs _) = True hasCAF _                            = False  -- Note [ticky for LNE] -- ~~~~~~~~~~~~~~~~~~~~~- -- Until 14 Feb 2013, every ticky counter was associated with a -- closure. Thus, ticky labels used IdLabel. It is odd that -- GHC.Cmm.Info.Build.cafTransfers would consider such a ticky label@@ -938,7 +991,7 @@         | not external                  = False          -- Prototypes for labels defined in the runtime system are imported-        --      into HC files via includes/Stg.h.+        --      into HC files via rts/include/Stg.h.         | pkgId == rtsUnitId            = False          -- For other labels we inline one into the HC file directly.@@ -948,11 +1001,20 @@ 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+-- 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@@ -1071,6 +1133,7 @@ externallyVisibleCLabel (CC_Label _)            = True externallyVisibleCLabel (CCS_Label _)           = True externallyVisibleCLabel (IPE_Label {})          = True+externallyVisibleCLabel (ModuleLabel {})        = True externallyVisibleCLabel (DynamicLinkerLabel _ _)  = False externallyVisibleCLabel (HpcTicksLabel _)       = True externallyVisibleCLabel (LargeBitmapLabel _)    = False@@ -1131,12 +1194,21 @@ 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+ idInfoLabelType :: IdLabelInfo -> CLabelType idInfoLabelType info =   case info of@@ -1146,7 +1218,7 @@     Closure       -> GcPtrLabel     ConInfoTable {} -> DataLabel     ClosureTable  -> DataLabel-    RednCounts    -> DataLabel+    IdTickyInfo{} -> DataLabel     Bytes         -> DataLabel     _             -> CodeLabel @@ -1175,21 +1247,21 @@ -- 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 :: NCGConfig -> CLabel -> Bool-labelDynamic config lbl =+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 _ ->-     externalDynamicRefs && (this_unit /= rtsUnitId)+     external_dynamic_refs && (this_unit /= rtsUnitId)     IdLabel n _ _ ->-     externalDynamicRefs && isDynLinkName platform this_mod 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 -> externalDynamicRefs && (this_unit /= lbl_unit)-    | otherwise       -> externalDynamicRefs+    | os == OSMinGW32 -> external_dynamic_refs && (this_unit /= lbl_unit)+    | otherwise       -> external_dynamic_refs     LocalBlockLabel _    -> False @@ -1207,7 +1279,7 @@             -- When compiling in the "dyn" way, each package is to be             -- linked into its own DLL.             ForeignLabelInPackage pkgId ->-                externalDynamicRefs && (this_unit /= 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@@ -1215,25 +1287,21 @@             True     CC_Label cc ->-     externalDynamicRefs && not (ccFromThisModule cc this_mod)+     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 ->-     externalDynamicRefs && this_mod /= m+     external_dynamic_refs && this_mod /= m     -- Note that DynamicLinkerLabels do NOT require dynamic linking themselves.    _                 -> False   where-    externalDynamicRefs = ncgExternalDynamicRefs config-    platform = ncgPlatform config-    os = platformOS platform-    this_mod = ncgThisModule config+    os        = platformOS platform     this_unit = toUnitId (moduleUnit this_mod) - ----------------------------------------------------------------------------- -- Printing out CLabels. @@ -1312,28 +1380,38 @@  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!+ -}  instance OutputableP Platform CLabel where-  pdoc platform lbl = getPprStyle $ \case-                        PprCode CStyle   -> pprCLabel platform CStyle lbl-                        PprCode AsmStyle -> pprCLabel platform AsmStyle lbl-                        _                -> pprCLabel platform CStyle lbl-                                            -- default to CStyle+  {-# INLINE pdoc #-} -- see Note [Bangs in CLabel]+  pdoc !platform lbl = getPprStyle $ \pp_sty ->+                        let !sty = case pp_sty of+                                    PprCode sty -> sty+                                    _           -> CStyle+                        in pprCLabel platform sty lbl  pprCLabel :: Platform -> LabelStyle -> CLabel -> SDoc-pprCLabel platform sty lbl =+pprCLabel !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 :: SDoc -> SDoc     maybe_underscore doc = case sty of-      AsmStyle | platformLeadingUnderscore platform -> pp_cSEP <> doc-      _                                             -> doc+      AsmStyle | use_leading_underscores -> pp_cSEP <> doc+      _                                  -> doc      tempLabelPrefixOrUnderscore :: Platform -> SDoc     tempLabelPrefixOrUnderscore platform = case sty of-      AsmStyle -> ptext (asmTempLabelPrefix platform)+      AsmStyle -> asmTempLabelPrefix platform       CStyle   -> char '_'  @@ -1346,7 +1424,7 @@       -> tempLabelPrefixOrUnderscore platform <> pprUniqueAlways u     AsmTempDerivedLabel l suf-      -> ptext (asmTempLabelPrefix platform)+      -> asmTempLabelPrefix platform          <> case l of AsmTempLabel u    -> pprUniqueAlways u                       LocalBlockLabel u -> pprUniqueAlways u                       _other            -> pprCLabel platform sty l@@ -1369,7 +1447,7 @@       maybe_underscore $ text "dsp_" <> pprCLabel platform sty lbl <> text "_dsp"     StringLitLabel u-      -> maybe_underscore $ pprUniqueAlways u <> ptext (sLit "_str")+      -> maybe_underscore $ pprUniqueAlways u <> text "_str"     ForeignLabel fs (Just sz) _ _       | AsmStyle <- sty@@ -1388,7 +1466,7 @@                       isRandomGenerated = not (isExternalName name)                       internalNamePrefix =                          if isRandomGenerated-                            then ptext (asmTempLabelPrefix platform)+                            then asmTempLabelPrefix platform                             else empty       CStyle   -> ppr name <> ppIdFlavor flavor @@ -1399,38 +1477,38 @@       -> maybe_underscore $ ftext str <> text "_fast"     RtsLabel (RtsSelectorInfoTable upd_reqd offset)-      -> maybe_underscore $ hcat [text "stg_sel_", text (show offset),-                                  ptext (if upd_reqd-                                         then (sLit "_upd_info")-                                         else (sLit "_noupd_info"))+      -> maybe_underscore $ hcat [ text "stg_sel_", text (show offset)+                                 , if upd_reqd+                                    then text "_upd_info"+                                    else text "_noupd_info"                                  ]     RtsLabel (RtsSelectorEntry upd_reqd offset)-      -> maybe_underscore $ hcat [text "stg_sel_", text (show offset),-                                        ptext (if upd_reqd-                                                then (sLit "_upd_entry")-                                                else (sLit "_noupd_entry"))+      -> maybe_underscore $ hcat [ text "stg_sel_", text (show offset)+                                 , if upd_reqd+                                    then text "_upd_entry"+                                    else text "_noupd_entry"                                  ]     RtsLabel (RtsApInfoTable upd_reqd arity)-      -> maybe_underscore $ hcat [text "stg_ap_", text (show arity),-                                        ptext (if upd_reqd-                                                then (sLit "_upd_info")-                                                else (sLit "_noupd_info"))+      -> maybe_underscore $ hcat [ text "stg_ap_", text (show arity)+                                 , if upd_reqd+                                    then text "_upd_info"+                                    else text "_noupd_info"                                  ]     RtsLabel (RtsApEntry upd_reqd arity)-      -> maybe_underscore $ hcat [text "stg_ap_", text (show arity),-                                        ptext (if upd_reqd-                                                then (sLit "_upd_entry")-                                                else (sLit "_noupd_entry"))+      -> maybe_underscore $ hcat [ text "stg_ap_", text (show arity)+                                 , if upd_reqd+                                    then text "_upd_entry"+                                    else text "_noupd_entry"                                  ]     RtsLabel (RtsPrimOp primop)       -> maybe_underscore $ text "stg_" <> ppr primop     RtsLabel (RtsSlowFastTickyCtr pat)-      -> maybe_underscore $ text "SLOW_CALL_fast_" <> text pat <> ptext (sLit "_ctr")+      -> maybe_underscore $ text "SLOW_CALL_fast_" <> text pat <> text "_ctr"     LargeBitmapLabel u       -> maybe_underscore $ tempLabelPrefixOrUnderscore platform@@ -1440,12 +1518,12 @@                             -- with a letter so the label will be legal assembly code.     HpcTicksLabel mod-      -> maybe_underscore $ text "_hpc_tickboxes_"  <> ppr mod <> ptext (sLit "_hpc")+      -> maybe_underscore $ text "_hpc_tickboxes_"  <> ppr mod <> text "_hpc"     CC_Label cc   -> maybe_underscore $ ppr cc    CCS_Label ccs -> maybe_underscore $ ppr ccs    IPE_Label (InfoProvEnt l _ _ m _) -> maybe_underscore $ (pprCode CStyle (pdoc platform l) <> text "_" <> ppr m <> text "_ipe")-+   ModuleLabel mod kind        -> maybe_underscore $ ppr mod <> text "_" <> ppr kind     CmmLabel _ _ fs CmmCode     -> maybe_underscore $ ftext fs    CmmLabel _ _ fs CmmData     -> maybe_underscore $ ftext fs@@ -1458,7 +1536,6 @@  -- 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@@ -1498,7 +1575,10 @@    Entry            -> text "entry"    LocalEntry       -> text "entry"    Slow             -> text "slow"-   RednCounts       -> text "ct"+   IdTickyInfo TickyRednCounts+      -> text "ct"+   IdTickyInfo (TickyInferedTag unique)+      -> text "ct_inf_tag" <> char '_' <> ppr unique    ConEntry loc      ->       case loc of         DefinitionSite -> text "con_entry"@@ -1527,14 +1607,14 @@ -- ----------------------------------------------------------------------------- -- Machine-dependent knowledge about labels. -asmTempLabelPrefix :: Platform -> PtrString  -- for formatting labels-asmTempLabelPrefix platform = case platformOS platform of-    OSDarwin -> sLit "L"-    OSAIX    -> sLit "__L" -- follow IBM XL C's convention-    _        -> sLit ".L"+asmTempLabelPrefix :: Platform -> SDoc  -- for formatting labels+asmTempLabelPrefix !platform = case platformOS platform of+    OSDarwin -> text "L"+    OSAIX    -> text "__L" -- follow IBM XL C's convention+    _        -> text ".L"  pprDynamicLinkerAsmLabel :: Platform -> DynamicLinkerLabelInfo -> SDoc -> SDoc-pprDynamicLinkerAsmLabel platform dllInfo ppLbl =+pprDynamicLinkerAsmLabel !platform dllInfo ppLbl =     case platformOS platform of       OSDarwin         | platformArch platform == ArchX86_64 ->@@ -1610,7 +1690,7 @@ -- 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].+-- See Note [emit-time elimination of static indirections]. -- -- Precondition is that both labels represent the -- same semantic value.
+ GHC/Cmm/CLabel.hs-boot view
@@ -0,0 +1,9 @@+module GHC.Cmm.CLabel where++import GHC.Utils.Outputable+import GHC.Platform++data CLabel++pprCLabel :: Platform -> LabelStyle -> CLabel -> SDoc+
GHC/Cmm/CallConv.hs view
@@ -14,7 +14,6 @@ import GHC.Cmm (Convention(..)) import GHC.Cmm.Ppr () -- For Outputable instances -import GHC.Driver.Session import GHC.Platform import GHC.Platform.Profile import GHC.Utils.Outputable
GHC/Cmm/CommonBlockElim.hs view
@@ -222,7 +222,7 @@ 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+  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 && es1 `eqs` es2
+ GHC/Cmm/Config.hs view
@@ -0,0 +1,31 @@+-- | Cmm compilation configuration++{-# LANGUAGE DerivingStrategies         #-}++module GHC.Cmm.Config+  ( CmmConfig(..)+  , cmmPlatform+  ) where++import GHC.Prelude++import GHC.Platform+import GHC.Platform.Profile+++data CmmConfig = CmmConfig+  { cmmProfile             :: !Profile -- ^ Target Profile+  , cmmOptControlFlow      :: !Bool    -- ^ Optimize Cmm Control Flow or not+  , cmmDoLinting           :: !Bool    -- ^ Do Cmm Linting Optimization or not+  , cmmOptElimCommonBlks   :: !Bool    -- ^ Eliminate common blocks or not+  , cmmOptSink             :: !Bool    -- ^ Perform sink after stack layout or not+  , cmmGenStackUnwindInstr :: !Bool    -- ^ Generate stack unwinding instructions (for debugging)+  , cmmExternalDynamicRefs :: !Bool    -- ^ Generate code to link against dynamic libraries+  , cmmDoCmmSwitchPlans    :: !Bool    -- ^ Should the Cmm pass replace Stg switch statements+  , cmmSplitProcPoints     :: !Bool    -- ^ Should Cmm split proc points or not+  }++-- | retrieve the target Cmm platform+cmmPlatform :: CmmConfig -> Platform+cmmPlatform = profilePlatform . cmmProfile+
GHC/Cmm/ContFlowOpt.hs view
@@ -29,7 +29,6 @@  -- Note [What is shortcutting] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~--- -- Consider this Cmm code: -- -- L1: ...@@ -53,7 +52,6 @@  -- Note [Control-flow optimisations] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- -- This optimisation does three things: -- --   - If a block finishes in an unconditional branch to another block@@ -80,7 +78,6 @@  -- 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@@ -106,7 +103,6 @@  -- Note [Shortcut call returns and proc-points] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- -- Consider this code that you might get from a recursive -- let-no-escape: --
GHC/Cmm/Dataflow.hs view
@@ -82,6 +82,11 @@  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 rewrtiting and analysis combined. To be used with -- @rewriteCmm@. --@@ -90,20 +95,26 @@ -- to the particular monads through SPECIALIZE). type RewriteFun f = CmmBlock -> FactBase f -> UniqSM (CmmBlock, FactBase f) +-- | `RewriteFun` abstracted over `n` (the node type)+type RewriteFun' (n :: Extensibility -> Extensibility -> Type) f =+    Block n C C -> FactBase f -> UniqSM (Block n C C, FactBase f)+ analyzeCmmBwd, analyzeCmmFwd-    :: DataflowLattice f-    -> TransferFun f-    -> CmmGraph+    :: (NonLocal node)+    => DataflowLattice f+    -> TransferFun' node f+    -> GenCmmGraph node     -> FactBase f     -> FactBase f analyzeCmmBwd = analyzeCmm Bwd analyzeCmmFwd = analyzeCmm Fwd  analyzeCmm-    :: Direction+    :: (NonLocal node)+    => Direction     -> DataflowLattice f-    -> TransferFun f-    -> CmmGraph+    -> TransferFun' node f+    -> GenCmmGraph node     -> FactBase f     -> FactBase f analyzeCmm dir lattice transfer cmmGraph initFact =@@ -117,12 +128,13 @@  -- Fixpoint algorithm. fixpointAnalysis-    :: forall f.-       Direction+    :: forall f node.+       (NonLocal node)+    => Direction     -> DataflowLattice f-    -> TransferFun f+    -> TransferFun' node f     -> Label-    -> LabelMap CmmBlock+    -> LabelMap (Block node C C)     -> FactBase f     -> FactBase f fixpointAnalysis direction lattice do_block entry blockmap = loop start@@ -139,8 +151,8 @@     join       = fact_join lattice      loop-        :: IntHeap     -- ^ Worklist, i.e., blocks to process-        -> FactBase f  -- ^ Current result (increases monotonically)+        :: 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@@ -155,20 +167,22 @@     loop _ !fbase1 = fbase1  rewriteCmmBwd-    :: DataflowLattice f-    -> RewriteFun f-    -> CmmGraph+    :: (NonLocal node)+    => DataflowLattice f+    -> RewriteFun' node f+    -> GenCmmGraph node     -> FactBase f-    -> UniqSM (CmmGraph, FactBase f)+    -> UniqSM (GenCmmGraph node, FactBase f) rewriteCmmBwd = rewriteCmm Bwd  rewriteCmm-    :: Direction+    :: (NonLocal node)+    => Direction     -> DataflowLattice f-    -> RewriteFun f-    -> CmmGraph+    -> RewriteFun' node f+    -> GenCmmGraph node     -> FactBase f-    -> UniqSM (CmmGraph, FactBase f)+    -> UniqSM (GenCmmGraph node, FactBase f) rewriteCmm dir lattice rwFun cmmGraph initFact = {-# SCC rewriteCmm #-} do     let entry = g_entry cmmGraph         hooplGraph = g_graph cmmGraph@@ -180,14 +194,15 @@     return (cmmGraph {g_graph = GMany NothingO blockMap2 NothingO}, facts)  fixpointRewrite-    :: forall f.-       Direction+    :: forall f node.+       NonLocal node+    => Direction     -> DataflowLattice f-    -> RewriteFun f+    -> RewriteFun' node f     -> Label-    -> LabelMap CmmBlock+    -> LabelMap (Block node C C)     -> FactBase f-    -> UniqSM (LabelMap CmmBlock, FactBase f)+    -> UniqSM (LabelMap (Block node C C), FactBase f) fixpointRewrite dir lattice do_block entry blockmap = loop start blockmap   where     -- Sorting the blocks helps to minimize the number of times we need to@@ -203,10 +218,10 @@     join       = fact_join lattice      loop-        :: IntHeap            -- ^ Worklist, i.e., blocks to process-        -> LabelMap CmmBlock  -- ^ Rewritten blocks.-        -> FactBase f         -- ^ Current facts.-        -> UniqSM (LabelMap CmmBlock, FactBase f)+        :: IntHeap                    -- Worklist, i.e., blocks to process+        -> LabelMap (Block node C C)  -- Rewritten blocks.+        -> FactBase f                 -- Current facts.+        -> UniqSM (LabelMap (Block node C C), FactBase f)     loop todo !blocks1 !fbase1       | Just (index, todo1) <- IntSet.minView todo = do         -- Note that we use the *original* block here. This is important.@@ -279,7 +294,7 @@     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@@ -309,7 +324,7 @@ -- * for a backward analysis we need to re-analyze all the predecessors, but -- * for a forward analysis, we only need to re-analyze the current block --   (and that will in turn propagate facts into its successors).-mkDepBlocks :: Direction -> [CmmBlock] -> LabelMap IntSet+mkDepBlocks :: NonLocal node => Direction -> [Block node C C] -> LabelMap IntSet mkDepBlocks Fwd blocks = go blocks 0 mapEmpty   where     go []     !_ !dep_map = dep_map@@ -335,7 +350,7 @@ updateFact fact_join dep_blocks (todo, fbase) lbl new_fact   = case lookupFact lbl fbase of       Nothing ->-          -- Note [No old fact]+          -- 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@@ -347,7 +362,7 @@  {- 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@@ -396,7 +411,7 @@  -- | Folds backward over all nodes of an open-open block. -- Strict in the accumulator.-foldNodesBwdOO :: (CmmNode O O -> f -> f) -> Block CmmNode O O -> f -> f+foldNodesBwdOO :: (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@@ -411,11 +426,11 @@ -- dataflow facts). -- Strict in both accumulated parts. foldRewriteNodesBwdOO-    :: forall f.-       (CmmNode O O -> f -> UniqSM (Block CmmNode O O, f))-    -> Block CmmNode O O+    :: forall f node.+       (node O O -> f -> UniqSM (Block node O O, f))+    -> Block node O O     -> f-    -> UniqSM (Block CmmNode O O, f)+    -> UniqSM (Block node O O, f) foldRewriteNodesBwdOO rewriteOO initBlock initFacts = go initBlock initFacts   where     go (BCons node1 block1) !fact1 = (rewriteOO node1 `comp` go block1) fact1
GHC/Cmm/Dataflow/Graph.hs view
@@ -154,13 +154,13 @@   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+    -- 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+    -- - @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*
GHC/Cmm/Expr.hs view
@@ -91,7 +91,7 @@ data Area   = Old            -- See Note [Old Area]   | Young {-# UNPACK #-} !BlockId  -- Invariant: must be a continuation BlockId-                   -- See Note [Continuation BlockId] in GHC.Cmm.Node.+                   -- See Note [Continuation BlockIds] in GHC.Cmm.Node.   deriving (Eq, Ord, Show)  {- Note [Old Area]@@ -208,7 +208,7 @@    | CmmBlock {-# UNPACK #-} !BlockId     -- Code label         -- Invariant: must be a continuation BlockId-        -- See Note [Continuation BlockId] in GHC.Cmm.Node.+        -- 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.@@ -415,7 +415,7 @@ ----------------------------------------------------------------------------- {- 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
GHC/Cmm/Graph.hs view
@@ -38,8 +38,8 @@ import GHC.Data.OrdList import GHC.Runtime.Heap.Layout (ByteOff) import GHC.Types.Unique.Supply-import GHC.Utils.Misc import GHC.Utils.Panic+import GHC.Utils.Constants (debugIsOn)   -----------------------------------------------------------------------------@@ -426,7 +426,7 @@   -- Note [Width of parameters]---+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~ -- Consider passing a small (< word width) primitive like Int8# to a function. -- It's actually non-trivial to do this without extending/narrowing: -- * Global registers are considered to have native word width (i.e., 64-bits on
GHC/Cmm/Info.hs view
@@ -1,11 +1,10 @@-{-# LANGUAGE CPP #-}+ module GHC.Cmm.Info (   mkEmptyContInfoTable,   cmmToRawCmm,   srtEscape,    -- info table accessors-  PtrOpts (..),   closureInfoPtr,   entryCode,   getConstrTag,@@ -32,8 +31,6 @@   stdPtrsOffset, stdNonPtrsOffset, ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Cmm@@ -48,9 +45,9 @@ import GHC.Platform import GHC.Platform.Profile import GHC.Data.Maybe-import GHC.Driver.Session import GHC.Utils.Error (withTimingSilent) import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Types.Unique.Supply import GHC.Utils.Logger import GHC.Utils.Monad@@ -68,20 +65,19 @@                  , cit_srt  = Nothing                  , cit_clo  = Nothing } -cmmToRawCmm :: Logger -> DynFlags -> Stream IO CmmGroupSRTs a+cmmToRawCmm :: Logger -> Profile -> Stream IO CmmGroupSRTs a             -> IO (Stream IO RawCmmGroup a)-cmmToRawCmm logger dflags cmms+cmmToRawCmm logger profile cmms   = do {        ; let do_one :: [CmmDeclSRTs] -> IO [RawCmmDecl]              do_one cmm = do                uniqs <- mkSplitUniqSupply 'i'                -- NB. strictness fixes a space leak.  DO NOT REMOVE.-               withTimingSilent logger dflags (text "Cmm -> Raw Cmm")-                          (\x -> seqList x ())+               withTimingSilent logger (text "Cmm -> Raw Cmm") (\x -> seqList x ())                   -- TODO: It might be better to make `mkInfoTable` run in                   -- IO as well so we don't have to pass around                   -- a UniqSupply (see #16843)-                 (return $ initUs_ uniqs $ concatMapM (mkInfoTable dflags) cmm)+                 (return $ initUs_ uniqs $ concatMapM (mkInfoTable profile) cmm)        ; return (Stream.mapM do_one cmms)        } @@ -101,7 +97,7 @@ --      <normal forward rest of StgInfoTable> --      <forward variable part> -----      See includes/rts/storage/InfoTables.h+--      See rts/include/rts/storage/InfoTables.h -- -- For return-points these are as follows --@@ -119,15 +115,15 @@ -- --  * The SRT slot is only there if there is SRT info to record -mkInfoTable :: DynFlags -> CmmDeclSRTs -> UniqSM [RawCmmDecl]+mkInfoTable :: Profile -> CmmDeclSRTs -> UniqSM [RawCmmDecl] mkInfoTable _ (CmmData sec dat) = return [CmmData sec dat] -mkInfoTable dflags proc@(CmmProc infos entry_lbl live blocks)+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 (targetPlatform dflags))+  | not (platformTablesNextToCode platform)   = case topInfoTable proc of   --  must be at most one       -- no info table       Nothing ->@@ -135,7 +131,7 @@        Just info@CmmInfoTable { cit_lbl = info_lbl } -> do         (top_decls, (std_info, extra_bits)) <--             mkInfoTableContents dflags info Nothing+             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@@ -162,10 +158,10 @@             [CmmProc (mapFromList raw_infos) entry_lbl live blocks])    where-   platform = targetPlatform dflags+   platform = profilePlatform profile    do_one_info (lbl,itbl) = do      (top_decls, (std_info, extra_bits)) <--         mkInfoTableContents dflags itbl Nothing+         mkInfoTableContents profile itbl Nothing      let         info_lbl = cit_lbl itbl         rel_std_info   = map (makeRelativeRefTo platform info_lbl) std_info@@ -179,20 +175,20 @@                          , [CmmLit] )        -- The "extra bits" -- These Lits have *not* had mkRelativeTo applied to them -mkInfoTableContents :: DynFlags+mkInfoTableContents :: Profile                     -> CmmInfoTable                     -> Maybe Int               -- Override default RTS type tag?                     -> UniqSM ([RawCmmDecl],             -- Auxiliary top decls                                InfoTableContents)       -- Info tbl + extra bits -mkInfoTableContents dflags+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 dflags info{cit_rep = rep} (Just rts_tag)+  = 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)@@ -200,9 +196,9 @@   | 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 dflags frame+       ; (liveness_lit, liveness_data) <- mkLivenessBits platform frame        ; let-             std_info = mkStdInfoTable dflags prof_lits rts_tag srt_bitmap liveness_lit+             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@@ -215,13 +211,13 @@        ; 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 dflags prof_lits+       ; 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 = targetPlatform dflags+    platform = profilePlatform profile     mk_pieces :: ClosureTypeInfo -> [CmmLit]               -> UniqSM ( Maybe CmmLit  -- Override the SRT field with this                         , Maybe CmmLit  -- Override the layout field with this@@ -246,7 +242,7 @@            ; return (Nothing, Nothing,  extra_bits, []) }      mk_pieces (Fun arity (ArgGen arg_bits)) srt_label-      = do { (liveness_lit, liveness_data) <- mkLivenessBits dflags arg_bits+      = 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 ]@@ -257,7 +253,7 @@         slow_entry = CmmLabel (toSlowEntryLbl platform info_lbl)         srt_lit = case srt_label of                     []          -> mkIntCLit platform 0-                    (lit:_rest) -> ASSERT( null _rest ) lit+                    (lit:_rest) -> assert (null _rest) lit      mk_pieces other _ = pprPanic "mk_pieces" (ppr other) @@ -286,8 +282,7 @@ -- See the section "Referring to an SRT from the info table" in -- Note [SRTs] in "GHC.Cmm.Info.Build" inlineSRT :: Platform -> Bool-inlineSRT platform = platformArch platform == ArchX86_64-  && platformTablesNextToCode platform+inlineSRT = pc_USE_INLINE_SRT_FIELD . platformConstants  ------------------------------------------------------------------------- --@@ -344,12 +339,12 @@ -- The head of the stack layout is the top of the stack and -- the least-significant bit. -mkLivenessBits :: DynFlags -> Liveness -> UniqSM (CmmLit, [RawCmmDecl])+mkLivenessBits :: Platform -> Liveness -> UniqSM (CmmLit, [RawCmmDecl])               -- ^ Returns:               --   1. The bitmap (literal value or label)               --   2. Large bitmap CmmData if needed -mkLivenessBits dflags liveness+mkLivenessBits platform liveness   | n_bits > mAX_SMALL_BITMAP_SIZE platform -- does not fit in one word   = do { uniq <- getUniqueM        ; let bitmap_lbl = mkBitmapLabel uniq@@ -359,7 +354,6 @@   | otherwise -- Fits in one word   = return (mkStgWordCLit platform bitmap_word, [])   where-    platform = targetPlatform dflags     n_bits = length liveness      bitmap :: Bitmap@@ -375,7 +369,7 @@     lits = mkWordCLit platform (fromIntegral n_bits)          : map (mkStgWordCLit platform) bitmap       -- The first word is the size.  The structure must match-      -- StgLargeBitmap in includes/rts/storage/InfoTable.h+      -- StgLargeBitmap in rts/include/rts/storage/InfoTable.h  ------------------------------------------------------------------------- --@@ -385,20 +379,20 @@  -- The standard bits of an info table.  This part of the info table -- corresponds to the StgInfoTable type defined in--- includes/rts/storage/InfoTables.h.+-- 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-   :: DynFlags+   :: Profile    -> (CmmLit,CmmLit)   -- Closure type descr and closure descr  (profiling)    -> Int               -- Closure RTS tag    -> CmmLit            -- SRT length    -> CmmLit            -- layout field    -> [CmmLit] -mkStdInfoTable dflags (type_descr, closure_descr) cl_type srt layout_lit+mkStdInfoTable profile (type_descr, closure_descr) cl_type srt layout_lit  =      -- Parallel revertible-black hole field     prof_info         -- Ticky info (none at present)@@ -406,9 +400,9 @@  ++ [layout_lit, tag, srt]   where-    platform = targetPlatform dflags+    platform = profilePlatform profile     prof_info-        | sccProfilingEnabled dflags = [type_descr, closure_descr]+        | profileIsProfiling profile = [type_descr, closure_descr]         | otherwise = []      tag = CmmInt (fromIntegral cl_type) (halfWordWidth platform)@@ -444,25 +438,19 @@ -- ------------------------------------------------------------------------- -data PtrOpts = PtrOpts-   { po_profile     :: !Profile -- ^ Platform profile-   , po_align_check :: !Bool    -- ^ Insert alignment check (cf @-falignment-sanitisation@)-   }- -- | Wrap a 'CmmExpr' in an alignment check when @-falignment-sanitisation@ is -- enabled.-wordAligned :: PtrOpts -> CmmExpr -> CmmExpr-wordAligned opts e-  | po_align_check opts+wordAligned :: Platform -> DoAlignSanitisation -> CmmExpr -> CmmExpr+wordAligned platform align_check e+  | align_check   = CmmMachOp (MO_AlignmentCheck (platformWordSizeInBytes platform) (wordWidth platform)) [e]   | otherwise   = e-  where platform = profilePlatform (po_profile opts)  -- | Takes a closure pointer and returns the info table pointer-closureInfoPtr :: PtrOpts -> CmmExpr -> CmmExpr-closureInfoPtr opts@(PtrOpts profile _) e =-    cmmLoadBWord  (profilePlatform profile) (wordAligned opts e)+closureInfoPtr :: Platform -> DoAlignSanitisation -> CmmExpr -> CmmExpr+closureInfoPtr platform align_check e =+    cmmLoadBWord platform (wordAligned platform align_check e)  -- | Takes an info pointer (the first word of a closure) and returns its entry -- code@@ -476,23 +464,21 @@ -- constructor tag obtained from the info table -- This lives in the SRT field of the info table -- (constructors don't need SRTs).-getConstrTag :: PtrOpts -> CmmExpr -> CmmExpr-getConstrTag opts closure_ptr+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 opts closure_ptr)+    info_table = infoTable profile (closureInfoPtr platform align_check closure_ptr)     platform   = profilePlatform profile-    profile    = po_profile opts  -- | Takes a closure pointer, and return the closure type -- obtained from the info table-cmmGetClosureType :: PtrOpts -> CmmExpr -> CmmExpr-cmmGetClosureType opts closure_ptr+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 opts closure_ptr)+    info_table = infoTable profile (closureInfoPtr platform align_check closure_ptr)     platform   = profilePlatform profile-    profile    = po_profile opts  -- | Takes an info pointer (the first word of a closure) -- and returns a pointer to the first word of the standard-form
GHC/Cmm/Info/Build.hs view
@@ -23,6 +23,7 @@ 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@@ -33,7 +34,6 @@ import GHC.Cmm.CLabel import GHC.Cmm import GHC.Cmm.Utils-import GHC.Driver.Session import GHC.Data.Maybe import GHC.Utils.Outputable import GHC.Utils.Panic@@ -41,7 +41,6 @@ import GHC.Types.Unique.Supply import GHC.Types.CostCentre import GHC.StgToCmm.Heap-import GHC.CmmToAsm  import Control.Monad import Data.Map.Strict (Map)@@ -55,9 +54,11 @@ import GHC.Types.Name.Set  {- Note [SRTs]--SRTs are the mechanism by which the garbage collector can determine-the live CAFs in the program.+   ~~~~~~~~~~~+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 ^^^^^^^^^^^^^^@@ -112,9 +113,15 @@ - Static thunks (THUNK), ie. CAFs - Continuations (RET_SMALL, etc.) -In each case, the info table points to the SRT.+In each case, the info table points to the SRT.  There are three ways which we+may encode the location of the SRT in the info table, described below. -- info->srt is zero if there's no SRT, otherwise:+USE_SRT_OFFSET+--------------+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 0 if there's no SRT, otherwise, - info->srt == 1 and info->f.srt_offset points to the SRT  e.g. for a FUN with an SRT:@@ -128,12 +135,27 @@   info->type          | ...  |                       |------| -On x86_64, we optimise the info table representation further.  The-offset to the SRT can be stored in 32 bits (all code lives within a-2GB region in x86_64's small memory model), so we can save a word in-the info table by storing the srt_offset in the srt field, which is-half a word.+USE_SRT_POINTER+---------------+When tables-next-to-code isn't in use we rather encode an absolute pointer to+the SRT in info->srt. e.g. for a FUN with an SRT: +StgFunInfoTable       +------++  info->f.srt_offset  |  ------------> pointer to SRT object+StgStdInfoTable       +------++  info->layout.ptrs   | ...  |+  info->layout.nptrs  | ...  |+  info->srt           |  1   |+  info->type          | ...  |+                      |------|+USE_INLINE_SRT_FIELD+--------------------+When using TNTC on x86_64 (and other platforms using the 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.+ On x86_64 with TABLES_NEXT_TO_CODE (except on MachO, due to #15169):  - info->srt is zero if there's no SRT, otherwise:@@ -201,22 +223,23 @@ Algorithm ^^^^^^^^^ -0. let srtMap :: Map CAFLabel (Maybe SRTEntry) = {}+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 (cpsTop), resulting in a list [CmmDecl]. There might-   be multiple CmmDecls in the result, due to proc-point splitting.+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 CAFLabel),-     representing all the CAFLabels reachable from this label.+   * 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.@@ -241,20 +264,21 @@  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 CAFLabel+7. Dependency-analyse the decls using CAFEnv and CAFSets, giving us SCC CAFfyLabel  8. For each SCC in dependency order-   - Let lbls :: [CAFLabel] be the non-recursive labels in this SCC-   - Apply CAFEnv to each label and concat the result :: [CAFLabel]-   - For each CAFLabel in the set apply srtMap (and ignore Nothing) to get+   - 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, for every top-level binding x, if srtMap x == Nothing, then the-   binding is non-CAFFY, otherwise it is CAFFY.+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 ^^^^^^^^^^^^^@@ -476,34 +500,39 @@ -- --------------------------------------------------------------------- -- Label types --- Labels that come from cafAnal can be:---   - _closure labels for static functions or CAFs---   - _info labels for dynamic functions, thunks, or continuations---   - _entry labels for functions or thunks+-- |+-- The label of a CAFfy thing. ----- Meanwhile the labels on top-level blocks are _entry labels.+-- 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+-- closure labels using 'toClosureLbl'.  Note that some of these -- labels will not actually exist; that's ok because we're going to -- map them to SRTEntry later, which ranges over labels that do exist. ---newtype CAFLabel = CAFLabel CLabel+newtype CAFfyLabel = CAFfyLabel CLabel   deriving (Eq,Ord) -deriving newtype instance OutputableP env CLabel => OutputableP env CAFLabel+deriving newtype instance OutputableP env CLabel => OutputableP env CAFfyLabel -type CAFSet = Set CAFLabel+type CAFSet = Set CAFfyLabel type CAFEnv = LabelMap CAFSet  -- | Records the CAFfy references of a set of static data decls. type DataCAFEnv = Map CLabel CAFSet -mkCAFLabel :: Platform -> CLabel -> CAFLabel-mkCAFLabel platform lbl = CAFLabel (toClosureLbl platform lbl) +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.+-- pointing to either a @FUN_STATIC@, @THUNK_STATIC@, or @CONSTR@. newtype SRTEntry = SRTEntry CLabel   deriving (Eq, Ord) @@ -516,7 +545,7 @@ addCafLabel :: Platform -> CLabel -> CAFSet -> CAFSet addCafLabel platform l s   | Just _ <- hasHaskellName l-  , let caf_label = mkCAFLabel platform 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@@ -525,6 +554,7 @@   | otherwise   = s +-- | Collect possible CAFfy references from a 'CmmData' decl. cafAnalData   :: Platform   -> CmmStatics@@ -544,17 +574,17 @@ -- | -- For each code block: --   - collect the references reachable from this code block to FUN,---     THUNK or RET labels for which hasCAF == True+--     THUNK or RET labels for which @hasCAF == True@ ----- This gives us a `CAFEnv`: a mapping from code block to sets of labels+-- This gives us a 'CAFEnv': a mapping from code block to sets of labels -- cafAnal   :: Platform-  -> LabelSet   -- The blocks representing continuations, ie. those+  -> 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+  -> CLabel     -- ^ The top label of the proc   -> CmmGraph   -> CAFEnv cafAnal platform contLbls topLbl cmmGraph =@@ -579,13 +609,13 @@         result :: CAFSet         !result = foldNodesBwdOO cafsInNode middle joined -        facts :: [Set CAFLabel]+        facts :: [Set CAFfyLabel]         facts = mapMaybe successorFact (successors xNode)          live' :: CAFSet         live' = joinFacts cafLattice facts -        successorFact :: Label -> Maybe (Set CAFLabel)+        successorFact :: Label -> Maybe (Set CAFfyLabel)         successorFact s           -- If this is a loop back to the entry, we can refer to the           -- entry label.@@ -593,7 +623,7 @@           -- If this is a continuation, we want to refer to the           -- SRT for the continuation's info table           | s `setMember` contLbls-          = Just (Set.singleton (mkCAFLabel platform (infoTblLbl s)))+          = Just (Set.singleton (mkCAFfyLabel platform (infoTblLbl s)))           -- Otherwise, takes the CAF references from the destination           | otherwise           = lookupFact s fBase@@ -601,7 +631,7 @@         cafsInNode :: CmmNode e x -> CAFSet -> CAFSet         cafsInNode node set = foldExpDeep addCafExpr node set -        addCafExpr :: CmmExpr -> Set CAFLabel -> Set CAFLabel+        addCafExpr :: CmmExpr -> Set CAFfyLabel -> Set CAFfyLabel         addCafExpr expr !set =           case expr of             CmmLit (CmmLabel c) ->@@ -689,64 +719,73 @@ getBlockLabels :: [SomeLabel] -> [Label] getBlockLabels = mapMaybe getBlockLabel --- | Return a (Label,CLabel) pair for each labelled block of a CmmDecl,+-- | 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, CAFLabel)]+getLabelledBlocks :: Platform -> CmmDecl -> [(SomeLabel, CAFfyLabel)] getLabelledBlocks platform decl = case decl of    CmmData _ (CmmStaticsRaw _ _)    -> []-   CmmData _ (CmmStatics lbl _ _ _) -> [ (DeclLabel lbl, mkCAFLabel platform lbl) ]+   CmmData _ (CmmStatics lbl _ _ _) -> [ (DeclLabel lbl, mkCAFfyLabel platform lbl) ]    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 = mkCAFLabel platform (cit_lbl info)+                                       , 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.+-- SRTs. CAFs themselves are not included here; see 'getCAFs' below. depAnalSRTs   :: Platform-  -> CAFEnv-  -> Map CLabel CAFSet -- CAFEnv for statics-  -> [CmmDecl]-  -> [SCC (SomeLabel, CAFLabel, Set CAFLabel)]+  -> 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, CAFLabel)]+  labelledBlocks :: [(SomeLabel, CAFfyLabel)]   labelledBlocks = concatMap (getLabelledBlocks platform) decls-  labelToBlock :: Map CAFLabel SomeLabel+  labelToBlock :: Map CAFfyLabel SomeLabel   labelToBlock = foldl' (\m (v,k) -> Map.insert k v m) Map.empty labelledBlocks -  nodes :: [Node SomeLabel (SomeLabel, CAFLabel, Set CAFLabel)]+  -- 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 CAFLabel) <-+          , 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, CAFLabel, Set CAFLabel)]+  graph :: [SCC (SomeLabel, CAFfyLabel, Set CAFfyLabel)]   graph = stronglyConnCompFromEdgedVerticesOrd nodes --- | Get (Label, CAFLabel, Set CAFLabel) for each block that represents a CAF.--- These are treated differently from other labelled blocks:+-- | Get @(Label, CAFfyLabel, Set CAFfyLabel)@ for each CAF block.+-- The @Set CafLabel@ represents the set of CAFfy things which this CAF's code+-- depends upon.+--+-- 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] -> [(Label, CAFLabel, Set CAFLabel)]+--+getCAFs :: Platform -> CAFEnv -> [CmmDecl] -> [(Label, CAFfyLabel, Set CAFfyLabel)] getCAFs platform cafEnv decls =-  [ (g_entry g, mkCAFLabel platform topLbl, cafs)+  [ (g_entry g, mkCAFfyLabel platform topLbl, cafs)   | CmmProc top_info topLbl _ g <- decls   , Just info <- [mapLookup (g_entry g) (info_tbls top_info)]   , let rep = cit_rep info@@ -756,7 +795,7 @@   -- | 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+-- @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 =@@ -766,7 +805,7 @@   , Just (id, _) <- [cit_clo info]   , let rep = cit_rep info   , isStaticRep rep && isFunRep rep-  , let !lbl = mkLocalClosureLabel (idName id) (idCafInfo id)+  , let !lbl = mkClosureLabel (idName id) (idCafInfo id)   ]  @@ -777,7 +816,7 @@ --   - CAFs must not map to anything! --   - if a labels maps to Nothing, we found that this label's SRT --     is empty, so we don't need to refer to it from other SRTs.-type SRTMap = Map CAFLabel (Maybe SRTEntry)+type SRTMap = Map CAFfyLabel (Maybe SRTEntry)   -- | Given 'SRTMap' of a module, returns the set of non-CAFFY names in the@@ -786,30 +825,35 @@ srtMapNonCAFs srtMap =     NonCaffySet $ mkNameSet (mapMaybe get_name (Map.toList srtMap))   where-    get_name (CAFLabel l, Nothing) = hasHaskellName l+    get_name (CAFfyLabel l, Nothing) = hasHaskellName l     get_name (_l, Just _srt_entry) = Nothing --- | resolve a CAFLabel to its SRTEntry using the SRTMap-resolveCAF :: Platform -> SRTMap -> CAFLabel -> Maybe SRTEntry-resolveCAF platform srtMap lbl@(CAFLabel l) =+-- | 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 --- | Attach SRTs to all info tables in the CmmDecls, and add SRT--- declarations to the ModuleSRTInfo.+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-  :: DynFlags+  :: CmmConfig   -> ModuleSRTInfo-  -> [(CAFEnv, [CmmDecl])]-  -> [(CAFSet, CmmDecl)]+  -> [(CAFEnv, [CmmDecl])]   -- ^ 'CAFEnv's and 'CmmDecl's for code blocks+  -> [(CAFSet, CmmDecl)]     -- ^ static data decls and their 'CAFSet's   -> IO (ModuleSRTInfo, [CmmDeclSRTs]) -doSRTs dflags moduleSRTInfo procs data_ = do+doSRTs cfg moduleSRTInfo procs data_ = do   us <- mkSplitUniqSupply 'u' -  let profile = targetProfile dflags+  let profile = cmmProfile cfg    -- Ignore the original grouping of decls, and combine all the   -- CAFEnvs into a single CAFEnv.@@ -831,7 +875,7 @@       decls = map snd data_ ++ concat procss       staticFuns = mapFromList (getStaticFuns decls) -      platform = targetPlatform dflags+      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@@ -840,10 +884,10 @@   -- to do this we need to process blocks before things that depend on   -- them.   let-    sccs :: [SCC (SomeLabel, CAFLabel, Set CAFLabel)]+    sccs :: [SCC (SomeLabel, CAFfyLabel, Set CAFfyLabel)]     sccs = {-# SCC depAnalSRTs #-} depAnalSRTs platform cafEnv static_data_env decls -    cafsWithSRTs :: [(Label, CAFLabel, Set CAFLabel)]+    cafsWithSRTs :: [(Label, CAFfyLabel, Set CAFfyLabel)]     cafsWithSRTs = getCAFs platform cafEnv decls    srtTraceM "doSRTs" (text "data:"            <+> pdoc platform data_ $$@@ -858,15 +902,15 @@         [ ( [CmmDeclSRTs]          -- generated SRTs           , [(Label, CLabel)]      -- SRT fields for info tables           , [(Label, [SRTEntry])]  -- SRTs to attach to static functions-          , Bool                   -- Whether the group has CAF references+          , CafInfo                -- Whether the group has CAF references           ) ]        (result, moduleSRTInfo') =         initUs_ us $         flip runStateT moduleSRTInfo $ do-          nonCAFs <- mapM (doSCC dflags staticFuns static_data_env) sccs+          nonCAFs <- mapM (doSCC cfg staticFuns static_data_env) sccs           cAFs <- forM cafsWithSRTs $ \(l, cafLbl, cafs) ->-            oneSRT dflags staticFuns [BlockLabel l] [cafLbl]+            oneSRT cfg staticFuns [BlockLabel l] [cafLbl]                    True{-is a CAF-} cafs static_data_env           return (nonCAFs ++ cAFs) @@ -877,7 +921,7 @@   let     srtFieldMap = mapFromList (concat pairs)     funSRTMap = mapFromList (concat funSRTs)-    has_caf_refs' = or has_caf_refs+    has_caf_refs' = anyCafRefs has_caf_refs     decls' =       concatMap (updInfoSRTs profile srtFieldMap funSRTMap has_caf_refs') decls @@ -895,7 +939,7 @@                           -- be CAFFY.                           -- See Note [Ticky labels in SRT analysis] above for                           -- why we exclude ticky labels here.-                          Map.insert (mkCAFLabel platform lbl) Nothing srtMap+                          Map.insert (mkCAFfyLabel platform lbl) Nothing srtMap                       | otherwise ->                           -- Not an IdLabel, ignore                           srtMap@@ -906,31 +950,31 @@   return (moduleSRTInfo'{ moduleSRTMap = srtMap_w_raws }, srt_decls ++ decls')  --- | Build the SRT for a strongly-connected component of blocks+-- | Build the SRT for a strongly-connected component of blocks. doSCC-  :: DynFlags-  -> LabelMap CLabel -- which blocks are static function entry points+  :: CmmConfig+  -> LabelMap CLabel -- ^ which blocks are static function entry points   -> DataCAFEnv      -- ^ static data-  -> SCC (SomeLabel, CAFLabel, Set CAFLabel)+  -> SCC (SomeLabel, CAFfyLabel, Set CAFfyLabel)   -> StateT ModuleSRTInfo UniqSM         ( [CmmDeclSRTs]          -- generated SRTs         , [(Label, CLabel)]      -- SRT fields for info tables         , [(Label, [SRTEntry])]  -- SRTs to attach to static functions-        , Bool                   -- Whether the group has CAF references+        , CafInfo                -- Whether the group has CAF references         ) -doSCC dflags staticFuns static_data_env (AcyclicSCC (l, cafLbl, cafs)) =-  oneSRT dflags staticFuns [l] [cafLbl] False cafs static_data_env+doSCC cfg staticFuns static_data_env (AcyclicSCC (l, cafLbl, cafs)) =+  oneSRT cfg staticFuns [l] [cafLbl] False cafs static_data_env -doSCC dflags staticFuns static_data_env (CyclicSCC nodes) = do+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 dflags staticFuns lbls caf_lbls False cafs static_data_env+  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@@ -960,29 +1004,28 @@  -- | Build an SRT for a set of blocks oneSRT-  :: DynFlags-  -> LabelMap CLabel            -- which blocks are static function entry points-  -> [SomeLabel]                -- blocks in this set-  -> [CAFLabel]                 -- labels for those blocks-  -> Bool                       -- True <=> this SRT is for a CAF-  -> Set CAFLabel               -- SRT for this set+  :: CmmConfig+  -> LabelMap CLabel            -- ^ which blocks are static function entry points+  -> [SomeLabel]                -- ^ blocks in this set+  -> [CAFfyLabel]               -- ^ labels for those blocks+  -> Bool                       -- ^ True <=> this SRT is for a CAF+  -> Set CAFfyLabel             -- ^ SRT for this set   -> DataCAFEnv                 -- Static data labels in this group   -> StateT ModuleSRTInfo UniqSM        ( [CmmDeclSRTs]                -- SRT objects we built        , [(Label, CLabel)]            -- SRT fields for these blocks' itbls        , [(Label, [SRTEntry])]        -- SRTs to attach to static functions-       , Bool                         -- Whether the group has CAF references+       , CafInfo                      -- Whether the group has CAF references        ) -oneSRT dflags staticFuns lbls caf_lbls isCAF cafs static_data_env = do+oneSRT cfg staticFuns lbls caf_lbls isCAF cafs static_data_env = do   topSRT <- get    let     this_mod = thisModule topSRT-    config = initNCGConfig dflags this_mod-    profile = targetProfile dflags+    profile  = cmmProfile cfg     platform = profilePlatform profile-    srtMap = moduleSRTMap topSRT+    srtMap   = moduleSRTMap topSRT      blockids = getBlockLabels lbls @@ -998,7 +1041,7 @@     -- 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 CAFLabel+    nonRec :: Set CAFfyLabel     nonRec = cafs `Set.difference` Set.fromList caf_lbls      -- Resolve references to their SRT entries@@ -1043,7 +1086,7 @@       when (not isCAF && (not isStaticFun || isNothing srtEntry)) $         modify' $ \state ->            let !srt_map =-                 foldl' (\srt_map cafLbl@(CAFLabel clbl) ->+                 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@@ -1056,12 +1099,12 @@                state{ moduleSRTMap = srt_map }      allStaticData =-      all (\(CAFLabel clbl) -> Map.member clbl static_data_env) caf_lbls+      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 ([], [], [], False)+    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].@@ -1091,7 +1134,7 @@           -- 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 config lbl)+          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.@@ -1104,7 +1147,7 @@           -- recursive group, see Note [recursive SRTs])           case maybeFunClosure of             Just (staticFunLbl,staticFunBlock) ->-                return ([], withLabels, [], True)+                return ([], withLabels, [], MayHaveCafRefs)               where                 withLabels =                   [ (b, if b == staticFunBlock then lbl else staticFunLbl)@@ -1113,10 +1156,11 @@               srtTraceM "oneSRT: one" (text "caf_lbls:" <+> pdoc platform caf_lbls $$                                        text "one:"      <+> pdoc platform one)               updateSRTMap (Just one)-              return ([], map (,lbl) blockids, [], True)+              return ([], map (,lbl) blockids, [], MayHaveCafRefs)        cafList | allStaticData ->-        return ([], [], [], not (null cafList))+        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.@@ -1125,7 +1169,7 @@           Just srtEntry@(SRTEntry srtLbl)  -> do             srtTraceM "oneSRT [Common]" (pdoc platform caf_lbls <+> pdoc platform srtLbl)             updateSRTMap (Just srtEntry)-            return ([], map (,srtLbl) blockids, [], True)+            return ([], map (,srtLbl) blockids, [], MayHaveCafRefs)           Nothing -> do             -- No duplicates: we have to build a new SRT object             (decls, funSRTs, srtEntry) <-@@ -1149,11 +1193,11 @@                                       text "newDedupSRTs:" <+> pdoc platform newDedupSRTs $$                                       text "newFlatSRTs:"  <+> pdoc platform newFlatSRTs)             let SRTEntry lbl = srtEntry-            return (decls, map (,lbl) blockids, funSRTs, True)+            return (decls, map (,lbl) blockids, funSRTs, MayHaveCafRefs)   -- | Build a static SRT object (or a chain of objects) from a list of--- SRTEntries.+-- 'SRTEntry's. buildSRTChain    :: Profile    -> [SRTEntry]@@ -1194,9 +1238,9 @@ -- 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-  -> Bool                          -- Whether the CmmDecl's group has CAF references+  -> 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] @@ -1206,14 +1250,12 @@ updInfoSRTs profile _ _ caffy (CmmData s (CmmStatics lbl itbl ccs payload))   = [CmmData s (CmmStaticsRaw lbl (map CmmStaticLit field_lits))]   where-    caf_info = if caffy then MayHaveCafRefs else NoCafRefs-    field_lits = mkStaticClosureFields profile itbl ccs caf_info payload+    field_lits = mkStaticClosureFields profile itbl ccs caffy payload  updInfoSRTs profile srt_env funSRTEnv caffy (CmmProc top_info top_l live g)   | Just (_,closure) <- maybeStaticClosure = [ proc, closure ]   | otherwise = [ proc ]   where-    caf_info = if caffy then MayHaveCafRefs else NoCafRefs     proc = CmmProc top_info { info_tbls = newTopInfo } top_l live g     newTopInfo = mapMapWithKey updInfoTbl (info_tbls top_info)     updInfoTbl l info_tbl@@ -1238,12 +1280,12 @@             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 caf_info 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 = mkLocalClosureLabel (idName id) caf_info+          lbl = mkClosureLabel (idName id) caffy         in           Just (newInfo, mkDataLits (Section Data lbl) lbl fields)       | otherwise = Nothing
+ 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/LayoutStack.hs view
@@ -12,14 +12,12 @@ import GHC.StgToCmm.Utils      ( callerSaveVolatileRegs  ) -- XXX layering violation import GHC.StgToCmm.Foreign    ( saveThreadState, loadThreadState ) -- XXX layering violation -import GHC.Types.Basic import GHC.Cmm import GHC.Cmm.Info import GHC.Cmm.BlockId-import GHC.Cmm.CLabel+import GHC.Cmm.Config import GHC.Cmm.Utils import GHC.Cmm.Graph-import GHC.Types.ForeignCall import GHC.Cmm.Liveness import GHC.Cmm.ProcPoint import GHC.Runtime.Heap.Layout@@ -33,8 +31,6 @@ import GHC.Types.Unique.FM import GHC.Utils.Misc -import GHC.Driver.Session-import GHC.Data.FastString import GHC.Utils.Outputable hiding ( isEmpty ) import GHC.Utils.Panic import qualified Data.Set as Set@@ -43,7 +39,7 @@ import Data.List (nub)  {- Note [Stack Layout]-+   ~~~~~~~~~~~~~~~~~~~ The job of this pass is to   - replace references to abstract stack Areas with fixed offsets from Sp.@@ -145,7 +141,7 @@   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:@@ -239,21 +235,21 @@      text "sm_regs = " <> pprUFM sm_regs ppr  -cmmLayoutStack :: DynFlags -> ProcPointSet -> ByteOff -> CmmGraph+cmmLayoutStack :: CmmConfig -> ProcPointSet -> ByteOff -> CmmGraph                -> UniqSM (CmmGraph, LabelMap StackMap)-cmmLayoutStack dflags procpoints entry_args+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  = targetProfile dflags+        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 dflags procpoints liveness entry entry_args+            layout cfg procpoints liveness entry entry_args                    rec_stackmaps rec_high_sp blocks      blocks_with_reloads <-@@ -265,7 +261,7 @@ -- Pass 1 -- ----------------------------------------------------------------------------- -layout :: DynFlags+layout :: CmmConfig        -> LabelSet                      -- proc points        -> LabelMap CmmLocalLive         -- liveness        -> BlockId                       -- entry@@ -282,7 +278,7 @@           , [CmmBlock]                  -- [out] new blocks           ) -layout dflags procpoints liveness entry entry_args final_stackmaps final_sp_high 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@@ -315,7 +311,7 @@        --     each of the successor blocks.  See handleLastNode for        --     details.        (middle1, sp_off, last1, fixup_blocks, out)-           <- handleLastNode dflags procpoints liveness cont_info+           <- handleLastNode cfg procpoints liveness cont_info                              acc_stackmaps stack1 tscope middle0 last0         -- (c) Manifest Sp: run over the nodes in the block and replace@@ -330,7 +326,7 @@        let middle_pre = blockToList $ foldl' blockSnoc middle0 middle1         let final_blocks =-               manifestSp dflags final_stackmaps stack0 sp0 final_sp_high+               manifestSp cfg final_stackmaps stack0 sp0 final_sp_high                           entry0 middle_pre sp_off last1 fixup_blocks         let acc_stackmaps' = mapUnion acc_stackmaps out@@ -437,7 +433,7 @@ -- extra code that goes *after* the Sp adjustment.  handleLastNode-   :: DynFlags -> ProcPointSet -> LabelMap CmmLocalLive -> LabelMap ByteOff+   :: CmmConfig -> ProcPointSet -> LabelMap CmmLocalLive -> LabelMap ByteOff    -> LabelMap StackMap -> StackMap -> CmmTickScope    -> Block CmmNode O O    -> CmmNode O C@@ -449,7 +445,7 @@       , LabelMap StackMap  -- stackmaps for the continuations       ) -handleLastNode dflags procpoints liveness cont_info stackmaps+handleLastNode cfg procpoints liveness cont_info stackmaps                stack0@StackMap { sm_sp = sp0 } tscp middle last   = case last of       --  At each return / tail call,@@ -471,7 +467,7 @@       CmmCondBranch {} ->  handleBranches       CmmSwitch {}     ->  handleBranches   where-     platform = targetPlatform dflags+     platform = cmmPlatform cfg      -- Calls and ForeignCalls are handled the same way:      lastCall :: BlockId -> ByteOff -> ByteOff -> ByteOff               -> ( [CmmNode O O]@@ -514,7 +510,7 @@                                 , LabelMap StackMap )       handleBranches-         -- Note [diamond proc point]+         -- See Note [diamond proc point]        | Just l <- futureContinuation middle        , (nub $ filter (`setMember` procpoints) $ successors last) == [l]        = do@@ -548,7 +544,7 @@         | Just stack2 <- mapLookup l stackmaps         = do              let assigs = fixupStack stack0 stack2-             (tmp_lbl, block) <- makeFixupBlock dflags sp0 l stack2 tscp assigs+             (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@@ -559,7 +555,7 @@                  (stack2, assigs) =                       setupStackFrame platform l liveness (sm_ret_off stack0)                                                         cont_args stack0-             (tmp_lbl, block) <- makeFixupBlock dflags sp0 l stack2 tscp assigs+             (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@@ -573,16 +569,16 @@               is_live (r,_) = r `elemRegSet` live  -makeFixupBlock :: DynFlags -> ByteOff -> Label -> StackMap+makeFixupBlock :: CmmConfig -> ByteOff -> Label -> StackMap                -> CmmTickScope -> [CmmNode O O]                -> UniqSM (Label, [CmmBlock])-makeFixupBlock dflags sp0 l stack tscope assigs+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 dflags sp0 sp_off+                          ( maybeAddSpAdj cfg sp0 sp_off                            $ blockFromList assigs )                           (CmmBranch l)     return (tmp_lbl, [block])@@ -649,9 +645,8 @@                          }  --- ----------------------------------------------------------------------------- -- Note [diamond proc point]---+-- ~~~~~~~~~~~~~~~~~~~~~~~~~ -- This special case looks for the pattern we get from a typical -- tagged case expression: --@@ -829,7 +824,7 @@ -- middle_post, because the Sp adjustment intervenes. -- manifestSp-   :: DynFlags+   :: CmmConfig    -> LabelMap StackMap  -- StackMaps for other blocks    -> StackMap           -- StackMap for this block    -> ByteOff            -- Sp on entry to the block@@ -841,18 +836,18 @@    -> [CmmBlock]         -- new blocks    -> [CmmBlock]         -- final blocks with Sp manifest -manifestSp dflags stackmaps stack0 sp0 sp_high+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 = targetPlatform dflags+    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 dflags sp0 sp_off+    final_middle = maybeAddSpAdj cfg sp0 sp_off                  . blockFromList                  . map adj_pre_sp                  . elimStackStores stack0 stackmaps area_off@@ -872,11 +867,12 @@   maybeAddSpAdj-  :: DynFlags -> ByteOff -> ByteOff -> Block CmmNode O O -> Block CmmNode O O-maybeAddSpAdj dflags sp0 sp_off block =+  :: 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 = targetPlatform dflags+    platform             = cmmPlatform            cfg+    do_stk_unwinding_gen = cmmGenStackUnwindInstr cfg     adj block       | sp_off /= 0       = block `blockSnoc` CmmAssign spReg (cmmOffset platform spExpr sp_off)@@ -884,7 +880,7 @@     -- Add unwind pseudo-instruction at the beginning of each block to     -- document Sp level for debugging     add_initial_unwind block-      | debugLevel dflags > 0+      | do_stk_unwinding_gen       = CmmUnwind [(Sp, Just sp_unwind)] `blockCons` block       | otherwise       = block@@ -893,7 +889,7 @@     -- Add unwind pseudo-instruction right after the Sp adjustment     -- if there is one.     add_adj_unwind block-      | debugLevel dflags > 0+      | do_stk_unwinding_gen       , sp_off /= 0       = block `blockSnoc` CmmUnwind [(Sp, Just sp_unwind)]       | otherwise@@ -901,7 +897,7 @@       where sp_unwind = CmmRegOff spReg (sp0 - platformWordSizeInBytes platform - sp_off)  {- Note [SP old/young offsets]-+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~ Sp(L) is the Sp offset on entry to block L relative to the base of the OLD area. @@ -1105,7 +1101,7 @@  {- Note [Lower safe foreign calls]-+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We start with     Sp[young(L1)] = L1@@ -1194,21 +1190,14 @@   | otherwise = return block  -foreignLbl :: FastString -> CmmExpr-foreignLbl name = CmmLit (CmmLabel (mkForeignLabel name Nothing ForeignLabelInExternalPackage IsFunction))- callSuspendThread :: Platform -> LocalReg -> Bool -> CmmNode O O callSuspendThread platform id intrbl =-  CmmUnsafeForeignCall-       (ForeignTarget (foreignLbl (fsLit "suspendThread"))-        (ForeignConvention CCallConv [AddrHint, NoHint] [AddrHint] CmmMayReturn))+  CmmUnsafeForeignCall (PrimTarget MO_SuspendThread)        [id] [baseExpr, mkIntExpr platform (fromEnum intrbl)]  callResumeThread :: LocalReg -> LocalReg -> CmmNode O O callResumeThread new_base id =-  CmmUnsafeForeignCall-       (ForeignTarget (foreignLbl (fsLit "resumeThread"))-            (ForeignConvention CCallConv [AddrHint] [AddrHint] CmmMayReturn))+  CmmUnsafeForeignCall (PrimTarget MO_ResumeThread)        [new_base] [CmmReg (CmmLocal id)]  -- -----------------------------------------------------------------------------
+ GHC/Cmm/Lexer.hs view
@@ -0,0 +1,886 @@+{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-missing-signatures #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+{-# LINE 13 "_build/source-dist/ghc-9.4.1-src/ghc-9.4.1/compiler/GHC/Cmm/Lexer.x" #-}+module GHC.Cmm.Lexer (+   CmmToken(..), cmmlex,+  ) where++import GHC.Prelude++import GHC.Cmm.Expr++import GHC.Parser.Lexer+import GHC.Cmm.Parser.Monad+import GHC.Types.SrcLoc+import GHC.Types.Unique.FM+import GHC.Data.StringBuffer+import GHC.Data.FastString+import GHC.Parser.CharClass+import GHC.Parser.Errors.Types+import GHC.Parser.Errors.Ppr ()+import GHC.Utils.Error+import GHC.Utils.Misc+--import TRACE++import Data.Word+import Data.Char+#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\x4e\x00\x00\x00\xb9\x00\x00\x00\x03\x01\x00\x00\xd6\x01\x00\x00\x88\xff\xff\xff\x00\x00\x00\x00\xdf\xff\xff\xff\x00\x00\x00\x00\xe8\xff\xff\xff\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\xa9\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x00\x00\x59\x00\x00\x00\xc2\x00\x00\x00\x56\x00\x00\x00\x60\x00\x00\x00\x62\x00\x00\x00\x6a\x00\x00\x00\x6f\x00\x00\x00\x6e\x00\x00\x00\x68\x00\x00\x00\x7c\x03\x00\x00\x4f\x04\x00\x00\x22\x05\x00\x00\xf5\x05\x00\x00\x3e\x00\x00\x00\xd1\x00\x00\x00\x00\x00\x00\x00\x3a\x01\x00\x00\x42\x00\x00\x00\xf6\xff\xff\xff\xe9\xff\xff\xff\xea\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\xc8\x06\x00\x00\x9b\x07\x00\x00\x6e\x08\x00\x00\x41\x09\x00\x00\x14\x0a\x00\x00\xe7\x0a\x00\x00\xba\x0b\x00\x00\x8d\x0c\x00\x00\x60\x0d\x00\x00\x33\x0e\x00\x00\x06\x0f\x00\x00\xd9\x0f\x00\x00\xac\x10\x00\x00\x7f\x11\x00\x00\x52\x12\x00\x00\x25\x13\x00\x00\xf8\x13\x00\x00\xcb\x14\x00\x00\x9e\x15\x00\x00\x71\x16\x00\x00\xf3\xff\xff\xff\x06\x00\x00\x00\x44\x01\x00\x00\x39\x17\x00\x00\x02\x00\x00\x00\xfb\xff\xff\xff\x0a\x00\x00\x00\x19\x17\x00\x00\x65\x00\x00\x00\x00\x00\x00\x00\x28\x01\x00\x00\xd3\x00\x00\x00\x00\x00\x00\x00\x9f\x17\x00\x00\xc0\x17\x00\x00\xbe\x17\x00\x00\x07\x02\x00\x00\x15\x02\x00\x00\xdd\x02\x00\x00\xf7\x17\x00\x00\x0e\x18\x00\x00\x30\x18\x00\x00\x48\x18\x00\x00\x81\x18\x00\x00\xc2\x18\x00\x00\x95\x19\x00\x00\x68\x1a\x00\x00\x3b\x1b\x00\x00\x0e\x1c\x00\x00\xe1\x1c\x00\x00\xb4\x1d\x00\x00\x87\x1e\x00\x00\x5a\x1f\x00\x00\x2d\x20\x00\x00\x00\x21\x00\x00\xd3\x21\x00\x00\xa6\x22\x00\x00\x79\x23\x00\x00\x4c\x24\x00\x00\x1f\x25\x00\x00\xf2\x25\x00\x00\xc5\x26\x00\x00\x98\x27\x00\x00\x6b\x28\x00\x00\x3e\x29\x00\x00\x11\x2a\x00\x00\xe4\x2a\x00\x00\xb7\x2b\x00\x00\x8a\x2c\x00\x00\x5d\x2d\x00\x00\x30\x2e\x00\x00\x03\x2f\x00\x00\xd6\x2f\x00\x00\xa9\x30\x00\x00\x7c\x31\x00\x00\x4f\x32\x00\x00\x17\x33\x00\x00\x16\x34\x00\x00\x16\x35\x00\x00\xe9\x35\x00\x00\xbc\x36\x00\x00\x8f\x37\x00\x00\x62\x38\x00\x00\x35\x39\x00\x00\x08\x3a\x00\x00\xdb\x3a\x00\x00\xae\x3b\x00\x00\x81\x3c\x00\x00\x54\x3d\x00\x00\x27\x3e\x00\x00\xfa\x3e\x00\x00\xcd\x3f\x00\x00\xa0\x40\x00\x00\x73\x41\x00\x00\x46\x42\x00\x00\x19\x43\x00\x00\xec\x43\x00\x00\xb4\x44\x00\x00\xb3\x45\x00\x00\xb2\x46\x00\x00\xb1\x47\x00\x00\xb0\x48\x00\x00\xaf\x49\x00\x00\xae\x4a\x00\x00\xad\x4b\x00\x00\xad\x4c\x00\x00\x80\x4d\x00\x00"#++alex_table :: AlexAddr+alex_table = AlexA#+  "\x00\x00\xff\xff\x5a\x00\xff\xff\x07\x00\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\x18\x00\x4f\x00\x4f\x00\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\x0a\x00\x52\x00\x2c\x00\x0b\x00\x17\x00\x08\x00\xff\xff\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x7c\x00\x17\x00\x5b\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x14\x00\x17\x00\x10\x00\x0c\x00\x12\x00\xff\xff\x0d\x00\x15\x00\x38\x00\x76\x00\x95\x00\x4e\x00\x7d\x00\xff\xff\x8f\x00\x11\x00\x0e\x00\xff\xff\x93\x00\x23\x00\x0f\x00\x13\x00\x7e\x00\x2e\x00\x98\x00\x77\x00\x6a\x00\x72\x00\x4f\x00\x2f\x00\x4f\x00\x4f\x00\x4f\x00\x17\x00\xff\xff\x17\x00\x17\x00\xff\xff\x17\x00\x2d\x00\xff\xff\x30\x00\x46\x00\x45\x00\x49\x00\x4b\x00\x4a\x00\xff\xff\x4d\x00\xff\xff\x40\x00\x4f\x00\x4e\x00\x50\x00\x2c\x00\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\x00\x00\x00\x00\x17\x00\x06\x00\x17\x00\x17\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1e\x00\x1b\x00\xff\xff\x1b\x00\x1b\x00\x1b\x00\x28\x00\x1d\x00\x1f\x00\x2a\x00\x1b\x00\xff\xff\x1b\x00\x1b\x00\x1b\x00\x19\x00\x1a\x00\x4f\x00\x00\x00\x4f\x00\x4f\x00\x4f\x00\x20\x00\xff\xff\x1b\x00\x22\x00\xff\xff\x21\x00\xff\xff\x1c\x00\x00\x00\x00\x00\x00\x00\x1b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4f\x00\x00\x00\x00\x00\x2c\x00\x00\x00\x4f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x29\x00\x00\x00\x00\x00\xff\xff\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\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\x4f\x00\xff\xff\x4f\x00\x4f\x00\x4f\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2a\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x48\x00\x00\x00\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\x1b\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x05\x00\x4f\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\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\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\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\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\x55\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\x56\x00\xff\xff\x56\x00\x00\x00\x00\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x00\x00\x00\x00\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\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x25\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x26\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x84\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\x32\x00\x00\x00\x00\x00\x00\x00\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\x33\x00\x00\x00\x00\x00\x00\x00\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\x34\x00\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\x86\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x36\x00\x00\x00\x00\x00\x00\x00\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\x37\x00\x00\x00\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\x9b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x3a\x00\x00\x00\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\x3b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x3c\x00\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\x3d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\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\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x43\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x44\x00\x00\x00\x00\x00\x00\x00\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\x9a\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\x48\x00\x52\x00\x00\x00\x00\x00\x00\x00\x00\x00\x52\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\xff\xff\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x00\x00\x00\x00\x52\x00\x00\x00\x00\x00\x00\x00\x00\x00\x52\x00\x52\x00\x00\x00\x00\x00\x57\x00\x52\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x52\x00\x00\x00\x00\x00\x00\x00\x52\x00\x00\x00\x52\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\x57\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\x51\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\x51\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\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x58\x00\x00\x00\x00\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x00\x00\x00\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x00\x00\x00\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\x00\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\x00\x00\x00\x00\x00\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\x47\x00\x00\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\x57\x00\x47\x00\x00\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5a\x00\x5a\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x00\x00\x47\x00\x00\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5a\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\x57\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x57\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\x88\x00\x00\x00\x00\x00\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\x5e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x5f\x00\x00\x00\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\x60\x00\x00\x00\x00\x00\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\x61\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\x62\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7b\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\x63\x00\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\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\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\x82\x00\x00\x00\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\x66\x00\x00\x00\x00\x00\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\x67\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\x04\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\x69\x00\x00\x00\x00\x00\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\x68\x00\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\x6b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x6c\x00\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\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\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\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\x70\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\x71\x00\x00\x00\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\x65\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x73\x00\x00\x00\x00\x00\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\x74\x00\x00\x00\x00\x00\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\x79\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x75\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\x91\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\x8a\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\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x89\x00\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\x7a\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\x16\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\x96\x00\x00\x00\x5d\x00\x5d\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\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\xff\xff\x96\x00\x96\x00\x96\x00\x96\x00\x96\x00\x96\x00\x96\x00\x96\x00\x96\x00\x96\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x35\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x99\x00\x00\x00\x5d\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\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\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\x81\x00\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\x83\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\x87\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\x8b\x00\x00\x00\x00\x00\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\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\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\x31\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x8e\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\x3e\x00\x00\x00\x00\x00\x00\x00\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\x92\x00\x00\x00\x5d\x00\x5d\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\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\xff\xff\x92\x00\x92\x00\x92\x00\x92\x00\x92\x00\x92\x00\x92\x00\x92\x00\x92\x00\x92\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x92\x00\x00\x00\x5d\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x92\x00\x92\x00\x92\x00\x92\x00\x92\x00\x92\x00\x92\x00\x92\x00\x92\x00\x92\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x94\x00\x00\x00\x5d\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x94\x00\x00\x00\x5d\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x96\x00\x00\x00\x5d\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x96\x00\x96\x00\x96\x00\x96\x00\x96\x00\x96\x00\x96\x00\x96\x00\x96\x00\x96\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x97\x00\x00\x00\x5d\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x97\x00\x97\x00\x97\x00\x97\x00\x97\x00\x97\x00\x97\x00\x97\x00\x97\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x97\x00\x00\x00\x5d\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x97\x00\x97\x00\x97\x00\x97\x00\x97\x00\x97\x00\x97\x00\x97\x00\x97\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x99\x00\x00\x00\x5d\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\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\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"#++alex_check :: AlexAddr+alex_check = AlexA#+  "\xff\xff\x00\x00\x01\x00\x02\x00\x7c\x00\x26\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\x3d\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\x3d\x00\x3a\x00\x42\x00\x43\x00\x44\x00\x0a\x00\x46\x00\x0a\x00\x48\x00\x3c\x00\x3d\x00\x0a\x00\x4c\x00\x4d\x00\x3d\x00\x3e\x00\x50\x00\x69\x00\x52\x00\x53\x00\x54\x00\x55\x00\x09\x00\x6e\x00\x0b\x00\x0c\x00\x0d\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x0a\x00\x60\x00\x6c\x00\x0a\x00\x65\x00\x72\x00\x70\x00\x61\x00\x6d\x00\x67\x00\x0a\x00\x61\x00\x0a\x00\x6c\x00\x20\x00\x0a\x00\x22\x00\x23\x00\x0a\x00\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\x0a\x00\x0a\x00\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\x61\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x6e\x00\x72\x00\x67\x00\x01\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x61\x00\x69\x00\x09\x00\xff\xff\x0b\x00\x0c\x00\x0d\x00\x6d\x00\xd7\x00\x20\x00\x6c\x00\x0a\x00\x23\x00\x0a\x00\x70\x00\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\x23\x00\xff\xff\xa0\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x22\x00\xff\xff\xff\xff\xf7\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\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\x09\x00\x2f\x00\x0b\x00\x0c\x00\x0d\x00\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\x01\x00\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xa0\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xa0\x00\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xa0\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\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\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xa0\x00\xff\xff\xff\xff\xff\xff\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\x01\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\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\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\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\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\x01\x00\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\x2b\x00\x60\x00\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\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\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\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\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\xd7\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\xff\xff\xff\xff\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\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\x62\x00\xff\xff\xff\xff\x45\x00\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\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\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\x01\x00\x00\x00\x22\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\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x01\x00\xff\xff\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\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\x5c\x00\xff\xff\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\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\x01\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x01\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\xff\xff\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\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\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x45\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\x01\x00\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\x65\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\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\x78\x00\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\x45\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\x65\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\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\xff\xff\xff\xff\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\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\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\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\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\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\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\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\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"#++alex_deflt :: AlexAddr+alex_deflt = AlexA#+  "\x5d\x00\xff\xff\xff\xff\x27\x00\x5d\x00\x5d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5d\x00\xff\xff\xff\xff\x19\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x27\x00\x27\x00\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\x50\x00\xff\xff\x52\x00\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\xff\xff\xff\xff\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5d\x00\x5d\x00"#++alex_accept = listArray (0 :: Int, 155)+  [ AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , 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+  , AlexAcc 118+  , AlexAcc 117+  , AlexAcc 116+  , AlexAcc 115+  , AlexAcc 114+  , AlexAcc 113+  , AlexAcc 112+  , AlexAccSkip+  , AlexAcc 111+  , AlexAcc 110+  , AlexAccSkip+  , AlexAcc 109+  , AlexAcc 108+  , AlexAcc 107+  , AlexAcc 106+  , AlexAcc 105+  , AlexAccPred 104 (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAcc 103)+  , AlexAcc 102+  , AlexAcc 101+  , AlexAcc 100+  , AlexAcc 99+  , AlexAcc 98+  , AlexAcc 97+  , AlexAcc 96+  , AlexAcc 95+  , AlexAcc 94+  , AlexAccPred 93 (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAcc 92)+  , AlexAccPred 91 (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAccNone)+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAccPred 90 (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAccNone)+  , 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+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAcc 69+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAccSkipPred (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAccNone)+  , AlexAccSkip+  , AlexAccNone+  , AlexAcc 68+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAcc 67+  , AlexAccNone+  , AlexAccNone+  , AlexAcc 66+  , AlexAccNone+  , 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, 133)+  [ (132,alex_action_5)+  , (131,alex_action_37)+  , (130,alex_action_18)+  , (129,alex_action_7)+  , (128,alex_action_17)+  , (127,alex_action_7)+  , (126,alex_action_16)+  , (125,alex_action_7)+  , (124,alex_action_15)+  , (123,alex_action_7)+  , (122,alex_action_14)+  , (121,alex_action_13)+  , (120,alex_action_12)+  , (119,alex_action_7)+  , (118,alex_action_11)+  , (117,alex_action_7)+  , (116,alex_action_10)+  , (115,alex_action_7)+  , (114,alex_action_9)+  , (113,alex_action_8)+  , (112,alex_action_7)+  , (111,alex_action_5)+  , (110,alex_action_5)+  , (109,alex_action_5)+  , (108,alex_action_5)+  , (107,alex_action_5)+  , (106,alex_action_5)+  , (105,alex_action_5)+  , (104,alex_action_2)+  , (103,alex_action_5)+  , (102,alex_action_5)+  , (101,alex_action_37)+  , (100,alex_action_37)+  , (99,alex_action_37)+  , (98,alex_action_37)+  , (97,alex_action_5)+  , (96,alex_action_5)+  , (95,alex_action_4)+  , (94,alex_action_3)+  , (93,alex_action_2)+  , (92,alex_action_5)+  , (91,alex_action_2)+  , (90,alex_action_2)+  , (89,alex_action_37)+  , (88,alex_action_37)+  , (87,alex_action_37)+  , (86,alex_action_37)+  , (85,alex_action_37)+  , (84,alex_action_37)+  , (83,alex_action_37)+  , (82,alex_action_37)+  , (81,alex_action_37)+  , (80,alex_action_37)+  , (79,alex_action_37)+  , (78,alex_action_37)+  , (77,alex_action_37)+  , (76,alex_action_37)+  , (75,alex_action_37)+  , (74,alex_action_37)+  , (73,alex_action_37)+  , (72,alex_action_37)+  , (71,alex_action_37)+  , (70,alex_action_37)+  , (69,alex_action_41)+  , (68,alex_action_42)+  , (67,alex_action_41)+  , (66,alex_action_40)+  , (65,alex_action_39)+  , (64,alex_action_39)+  , (63,alex_action_38)+  , (62,alex_action_37)+  , (61,alex_action_37)+  , (60,alex_action_37)+  , (59,alex_action_37)+  , (58,alex_action_37)+  , (57,alex_action_37)+  , (56,alex_action_37)+  , (55,alex_action_37)+  , (54,alex_action_37)+  , (53,alex_action_37)+  , (52,alex_action_37)+  , (51,alex_action_37)+  , (50,alex_action_37)+  , (49,alex_action_37)+  , (48,alex_action_37)+  , (47,alex_action_37)+  , (46,alex_action_37)+  , (45,alex_action_37)+  , (44,alex_action_37)+  , (43,alex_action_37)+  , (42,alex_action_37)+  , (41,alex_action_37)+  , (40,alex_action_37)+  , (39,alex_action_37)+  , (38,alex_action_37)+  , (37,alex_action_37)+  , (36,alex_action_37)+  , (35,alex_action_37)+  , (34,alex_action_37)+  , (33,alex_action_37)+  , (32,alex_action_37)+  , (31,alex_action_37)+  , (30,alex_action_37)+  , (29,alex_action_37)+  , (28,alex_action_36)+  , (27,alex_action_37)+  , (26,alex_action_37)+  , (25,alex_action_37)+  , (24,alex_action_35)+  , (23,alex_action_37)+  , (22,alex_action_34)+  , (21,alex_action_33)+  , (20,alex_action_32)+  , (19,alex_action_37)+  , (18,alex_action_31)+  , (17,alex_action_30)+  , (16,alex_action_29)+  , (15,alex_action_37)+  , (14,alex_action_37)+  , (13,alex_action_28)+  , (12,alex_action_37)+  , (11,alex_action_27)+  , (10,alex_action_26)+  , (9,alex_action_25)+  , (8,alex_action_37)+  , (7,alex_action_24)+  , (6,alex_action_37)+  , (5,alex_action_23)+  , (4,alex_action_22)+  , (3,alex_action_37)+  , (2,alex_action_21)+  , (1,alex_action_20)+  , (0,alex_action_19)+  ]++{-# LINE 129 "_build/source-dist/ghc-9.4.1-src/ghc-9.4.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_bits128+  | CmmT_bits256+  | CmmT_bits512+  | CmmT_float32+  | CmmT_float64+  | CmmT_gcptr+  | CmmT_GlobalReg GlobalReg+  | CmmT_Name      FastString+  | CmmT_String    String+  | CmmT_Int       Integer+  | CmmT_Float     Rational+  | CmmT_EOF+  | CmmT_False+  | CmmT_True+  | CmmT_likely+  deriving (Show)++-- -----------------------------------------------------------------------------+-- Lexer actions++type Action = PsSpan -> StringBuffer -> Int -> PD (PsLocated CmmToken)++begin :: Int -> Action+begin code _span _str _len = do liftP (pushLexState code); lexToken++pop :: Action+pop _span _buf _len = liftP popLexState >> lexToken++special_char :: Action+special_char span buf _len = return (L span (CmmT_SpecChar (currentChar buf)))++kw :: CmmToken -> Action+kw tok span _buf _len = return (L span tok)++global_regN :: (Int -> GlobalReg) -> Action+global_regN con span buf len+  = return (L span (CmmT_GlobalReg (con (fromIntegral n))))+  where buf' = stepOn buf+        n = parseUnsignedInteger buf' (len-1) 10 octDecDigit++global_reg :: GlobalReg -> Action+global_reg r span _buf _len = return (L span (CmmT_GlobalReg r))++strtoken :: (String -> CmmToken) -> Action+strtoken f span buf len =+  return (L span $! (f $! lexemeToString buf len))++name :: Action+name span buf len =+  case lookupUFM reservedWordsFM fs of+        Just tok -> return (L span tok)+        Nothing  -> return (L span (CmmT_Name fs))+  where+        fs = lexemeToFastString buf len++reservedWordsFM = listToUFM $+        map (\(x, y) -> (mkFastString x, y)) [+        ( "CLOSURE",            CmmT_CLOSURE ),+        ( "INFO_TABLE",         CmmT_INFO_TABLE ),+        ( "INFO_TABLE_RET",     CmmT_INFO_TABLE_RET ),+        ( "INFO_TABLE_FUN",     CmmT_INFO_TABLE_FUN ),+        ( "INFO_TABLE_CONSTR",  CmmT_INFO_TABLE_CONSTR ),+        ( "INFO_TABLE_SELECTOR",CmmT_INFO_TABLE_SELECTOR ),+        ( "else",               CmmT_else ),+        ( "export",             CmmT_export ),+        ( "section",            CmmT_section ),+        ( "goto",               CmmT_goto ),+        ( "if",                 CmmT_if ),+        ( "call",               CmmT_call ),+        ( "jump",               CmmT_jump ),+        ( "foreign",            CmmT_foreign ),+        ( "never",              CmmT_never ),+        ( "prim",               CmmT_prim ),+        ( "reserve",            CmmT_reserve ),+        ( "return",             CmmT_return ),+        ( "returns",            CmmT_returns ),+        ( "import",             CmmT_import ),+        ( "switch",             CmmT_switch ),+        ( "case",               CmmT_case ),+        ( "default",            CmmT_default ),+        ( "push",               CmmT_push ),+        ( "unwind",             CmmT_unwind ),+        ( "bits8",              CmmT_bits8 ),+        ( "bits16",             CmmT_bits16 ),+        ( "bits32",             CmmT_bits32 ),+        ( "bits64",             CmmT_bits64 ),+        ( "bits128",            CmmT_bits128 ),+        ( "bits256",            CmmT_bits256 ),+        ( "bits512",            CmmT_bits512 ),+        ( "float32",            CmmT_float32 ),+        ( "float64",            CmmT_float64 ),+-- New forms+        ( "b8",                 CmmT_bits8 ),+        ( "b16",                CmmT_bits16 ),+        ( "b32",                CmmT_bits32 ),+        ( "b64",                CmmT_bits64 ),+        ( "b128",               CmmT_bits128 ),+        ( "b256",               CmmT_bits256 ),+        ( "b512",               CmmT_bits512 ),+        ( "f32",                CmmT_float32 ),+        ( "f64",                CmmT_float64 ),+        ( "gcptr",              CmmT_gcptr ),+        ( "likely",             CmmT_likely),+        ( "True",               CmmT_True  ),+        ( "False",              CmmT_False )+        ]++tok_decimal span buf len+  = return (L span (CmmT_Int  $! parseUnsignedInteger buf len 10 octDecDigit))++tok_octal span buf len+  = return (L span (CmmT_Int  $! parseUnsignedInteger (offsetBytes 1 buf) (len-1) 8 octDecDigit))++tok_hexadecimal span buf len+  = return (L span (CmmT_Int  $! parseUnsignedInteger (offsetBytes 2 buf) (len-2) 16 hexDigit))++tok_float str = CmmT_Float $! readRational str++tok_string str = CmmT_String (read str)+                 -- urk, not quite right, but it'll do for now++-- -----------------------------------------------------------------------------+-- Line pragmas++setLine :: Int -> Action+setLine code (PsSpan span _) buf len = do+  let line = parseUnsignedInteger buf len 10 octDecDigit+  liftP $ do+    setSrcLoc (mkRealSrcLoc (srcSpanFile span) (fromIntegral line - 1) 1)+          -- subtract one: the line number refers to the *following* line+    -- trace ("setLine "  ++ show line) $ do+    popLexState >> pushLexState code+  lexToken++setFile :: Int -> Action+setFile code (PsSpan span _) buf len = do+  let file = lexemeToFastString (stepOn buf) (len-2)+  liftP $ do+    setSrcLoc (mkRealSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span))+    popLexState >> pushLexState code+  lexToken++-- -----------------------------------------------------------------------------+-- This is the top-level function: called from the parser each time a+-- new token is to be read from the input.++cmmlex :: (Located CmmToken -> PD a) -> PD a+cmmlex cont = do+  (L span tok) <- lexToken+  --trace ("token: " ++ show tok) $ do+  cont (L (mkSrcSpanPs span) tok)++lexToken :: PD (PsLocated CmmToken)+lexToken = do+  inp@(loc1,buf) <- getInput+  sc <- liftP getLexState+  case alexScan inp sc of+    AlexEOF -> do let span = mkPsSpan loc1 loc1+                  liftP (setLastToken span 0)+                  return (L span CmmT_EOF)+    AlexError (loc2,_) ->+      let msg srcLoc = mkPlainErrorMsgEnvelope srcLoc PsErrCmmLexer+      in liftP $ failLocMsgP (psRealLoc loc1) (psRealLoc loc2) msg+    AlexSkip inp2 _ -> do+        setInput inp2+        lexToken+    AlexToken inp2@(end,_buf2) len t -> do+        setInput inp2+        let span = mkPsSpan loc1 end+        span `seq` liftP (setLastToken span len)+        t span buf len++-- -----------------------------------------------------------------------------+-- Monad stuff++-- Stuff that Alex needs to know about our input type:+type AlexInput = (PsLoc,StringBuffer)++alexInputPrevChar :: AlexInput -> Char+alexInputPrevChar (_,s) = prevChar s '\n'++-- backwards compatibility for Alex 2.x+alexGetChar :: AlexInput -> Maybe (Char,AlexInput)+alexGetChar inp = case alexGetByte inp of+                    Nothing    -> Nothing+                    Just (b,i) -> c `seq` Just (c,i)+                       where c = chr $ fromIntegral b++alexGetByte :: AlexInput -> Maybe (Word8,AlexInput)+alexGetByte (loc,s)+  | atEnd s   = Nothing+  | otherwise = b `seq` loc' `seq` s' `seq` Just (b, (loc', s'))+  where c    = currentChar s+        b    = fromIntegral $ ord $ c+        loc' = advancePsLoc loc c+        s'   = stepOn s++getInput :: PD AlexInput+getInput = PD $ \_ _ s@PState{ loc=l, buffer=b } -> POk s (l,b)++setInput :: AlexInput -> PD ()+setInput (l,b) = PD $ \_ _ s -> POk s{ loc=l, buffer=b } ()++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_True+alex_action_19 = kw CmmT_False+alex_action_20 = kw CmmT_likely+alex_action_21 = global_regN (\n -> VanillaReg n VGcPtr)+alex_action_22 = global_regN (\n -> VanillaReg n VNonGcPtr)+alex_action_23 = global_regN FloatReg+alex_action_24 = global_regN DoubleReg+alex_action_25 = global_regN LongReg+alex_action_26 = global_reg Sp+alex_action_27 = global_reg SpLim+alex_action_28 = global_reg Hp+alex_action_29 = global_reg HpLim+alex_action_30 = global_reg CCCS+alex_action_31 = global_reg CurrentTSO+alex_action_32 = global_reg CurrentNursery+alex_action_33 = global_reg HpAlloc+alex_action_34 = global_reg BaseReg+alex_action_35 = global_reg MachSp+alex_action_36 = global_reg UnwindReturnReg+alex_action_37 = name+alex_action_38 = tok_octal+alex_action_39 = tok_decimal+alex_action_40 = tok_hexadecimal+alex_action_41 = strtoken tok_float+alex_action_42 = 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)+                check  = alexIndexInt16OffAddr alex_check offset++                new_s = if GTE(offset,ILIT(0)) && 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
− GHC/Cmm/Lexer.x 
@@ -1,369 +0,0 @@------------------------------------------------------------------------------------ (c) The University of Glasgow, 2004-2006------ Lexer for concrete Cmm.  We try to stay close to the C-- spec, but there--- are a few minor differences:------   * extra keywords for our macros, and float32/float64 types---   * global registers (Sp,Hp, etc.)-----------------------------------------------------------------------------------{-module GHC.Cmm.Lexer (-   CmmToken(..), cmmlex,-  ) where--import GHC.Prelude--import GHC.Cmm.Expr--import GHC.Parser.Lexer-import GHC.Cmm.Parser.Monad-import GHC.Types.SrcLoc-import GHC.Types.Unique.FM-import GHC.Data.StringBuffer-import GHC.Data.FastString-import GHC.Parser.CharClass-import GHC.Parser.Errors-import GHC.Utils.Misc---import TRACE--import Data.Word-import Data.Char-}--$whitechar   = [\ \t\n\r\f\v\xa0] -- \xa0 is Unicode no-break space-$white_no_nl = $whitechar # \n--$ascdigit  = 0-9-$unidigit  = \x01 -- Trick Alex into handling Unicode. See alexGetChar.-$digit     = [$ascdigit $unidigit]-$octit     = 0-7-$hexit     = [$digit A-F a-f]--$unilarge  = \x03 -- Trick Alex into handling Unicode. See alexGetChar.-$asclarge  = [A-Z \xc0-\xd6 \xd8-\xde]-$large     = [$asclarge $unilarge]--$unismall  = \x04 -- Trick Alex into handling Unicode. See alexGetChar.-$ascsmall  = [a-z \xdf-\xf6 \xf8-\xff]-$small     = [$ascsmall $unismall \_]--$namebegin = [$large $small \. \$ \@]-$namechar  = [$namebegin $digit]--@decimal     = $digit+-@octal       = $octit+-@hexadecimal = $hexit+-@exponent    = [eE] [\-\+]? @decimal--@floating_point = @decimal \. @decimal @exponent? | @decimal @exponent--@escape      = \\ ([abfnrt\\\'\"\?] | x $hexit{1,2} | $octit{1,3})-@strchar     = ($printable # [\"\\]) | @escape--cmm :---$white_no_nl+           ;-^\# pragma .* \n        ; -- Apple GCC 3.3 CPP generates pragmas in its output--^\# (line)?             { begin line_prag }---- single-line line pragmas, of the form---    # <line> "<file>" <extra-stuff> \n-<line_prag> $digit+                     { setLine line_prag1 }-<line_prag1> \" [^\"]* \"       { setFile line_prag2 }-<line_prag2> .*                         { pop }--<0> {-  \n                    ;--  [\:\;\{\}\[\]\(\)\=\`\~\/\*\%\-\+\&\^\|\>\<\,\!]      { special_char }--  ".."                  { kw CmmT_DotDot }-  "::"                  { kw CmmT_DoubleColon }-  ">>"                  { kw CmmT_Shr }-  "<<"                  { kw CmmT_Shl }-  ">="                  { kw CmmT_Ge }-  "<="                  { kw CmmT_Le }-  "=="                  { kw CmmT_Eq }-  "!="                  { kw CmmT_Ne }-  "&&"                  { kw CmmT_BoolAnd }-  "||"                  { kw CmmT_BoolOr }--  "True"                { kw CmmT_True  }-  "False"               { kw CmmT_False }-  "likely"              { kw CmmT_likely}--  P@decimal             { global_regN (\n -> VanillaReg n VGcPtr) }-  R@decimal             { global_regN (\n -> VanillaReg n VNonGcPtr) }-  F@decimal             { global_regN FloatReg }-  D@decimal             { global_regN DoubleReg }-  L@decimal             { global_regN LongReg }-  Sp                    { global_reg Sp }-  SpLim                 { global_reg SpLim }-  Hp                    { global_reg Hp }-  HpLim                 { global_reg HpLim }-  CCCS                  { global_reg CCCS }-  CurrentTSO            { global_reg CurrentTSO }-  CurrentNursery        { global_reg CurrentNursery }-  HpAlloc               { global_reg HpAlloc }-  BaseReg               { global_reg BaseReg }-  MachSp                { global_reg MachSp }-  UnwindReturnReg       { global_reg UnwindReturnReg }--  $namebegin $namechar* { name }--  0 @octal              { tok_octal }-  @decimal              { tok_decimal }-  0[xX] @hexadecimal    { tok_hexadecimal }-  @floating_point       { strtoken tok_float }--  \" @strchar* \"       { strtoken tok_string }-}--{-data CmmToken-  = CmmT_SpecChar  Char-  | CmmT_DotDot-  | CmmT_DoubleColon-  | CmmT_Shr-  | CmmT_Shl-  | CmmT_Ge-  | CmmT_Le-  | CmmT_Eq-  | CmmT_Ne-  | CmmT_BoolAnd-  | CmmT_BoolOr-  | CmmT_CLOSURE-  | CmmT_INFO_TABLE-  | CmmT_INFO_TABLE_RET-  | CmmT_INFO_TABLE_FUN-  | CmmT_INFO_TABLE_CONSTR-  | CmmT_INFO_TABLE_SELECTOR-  | CmmT_else-  | CmmT_export-  | CmmT_section-  | CmmT_goto-  | CmmT_if-  | CmmT_call-  | CmmT_jump-  | CmmT_foreign-  | CmmT_never-  | CmmT_prim-  | CmmT_reserve-  | CmmT_return-  | CmmT_returns-  | CmmT_import-  | CmmT_switch-  | CmmT_case-  | CmmT_default-  | CmmT_push-  | CmmT_unwind-  | CmmT_bits8-  | CmmT_bits16-  | CmmT_bits32-  | CmmT_bits64-  | CmmT_bits128-  | CmmT_bits256-  | CmmT_bits512-  | CmmT_float32-  | CmmT_float64-  | CmmT_gcptr-  | CmmT_GlobalReg GlobalReg-  | CmmT_Name      FastString-  | CmmT_String    String-  | CmmT_Int       Integer-  | CmmT_Float     Rational-  | CmmT_EOF-  | CmmT_False-  | CmmT_True-  | CmmT_likely-  deriving (Show)---- -------------------------------------------------------------------------------- Lexer actions--type Action = PsSpan -> StringBuffer -> Int -> PD (PsLocated CmmToken)--begin :: Int -> Action-begin code _span _str _len = do liftP (pushLexState code); lexToken--pop :: Action-pop _span _buf _len = liftP popLexState >> lexToken--special_char :: Action-special_char span buf _len = return (L span (CmmT_SpecChar (currentChar buf)))--kw :: CmmToken -> Action-kw tok span _buf _len = return (L span tok)--global_regN :: (Int -> GlobalReg) -> Action-global_regN con span buf len-  = return (L span (CmmT_GlobalReg (con (fromIntegral n))))-  where buf' = stepOn buf-        n = parseUnsignedInteger buf' (len-1) 10 octDecDigit--global_reg :: GlobalReg -> Action-global_reg r span _buf _len = return (L span (CmmT_GlobalReg r))--strtoken :: (String -> CmmToken) -> Action-strtoken f span buf len =-  return (L span $! (f $! lexemeToString buf len))--name :: Action-name span buf len =-  case lookupUFM reservedWordsFM fs of-        Just tok -> return (L span tok)-        Nothing  -> return (L span (CmmT_Name fs))-  where-        fs = lexemeToFastString buf len--reservedWordsFM = listToUFM $-        map (\(x, y) -> (mkFastString x, y)) [-        ( "CLOSURE",            CmmT_CLOSURE ),-        ( "INFO_TABLE",         CmmT_INFO_TABLE ),-        ( "INFO_TABLE_RET",     CmmT_INFO_TABLE_RET ),-        ( "INFO_TABLE_FUN",     CmmT_INFO_TABLE_FUN ),-        ( "INFO_TABLE_CONSTR",  CmmT_INFO_TABLE_CONSTR ),-        ( "INFO_TABLE_SELECTOR",CmmT_INFO_TABLE_SELECTOR ),-        ( "else",               CmmT_else ),-        ( "export",             CmmT_export ),-        ( "section",            CmmT_section ),-        ( "goto",               CmmT_goto ),-        ( "if",                 CmmT_if ),-        ( "call",               CmmT_call ),-        ( "jump",               CmmT_jump ),-        ( "foreign",            CmmT_foreign ),-        ( "never",              CmmT_never ),-        ( "prim",               CmmT_prim ),-        ( "reserve",            CmmT_reserve ),-        ( "return",             CmmT_return ),-        ( "returns",            CmmT_returns ),-        ( "import",             CmmT_import ),-        ( "switch",             CmmT_switch ),-        ( "case",               CmmT_case ),-        ( "default",            CmmT_default ),-        ( "push",               CmmT_push ),-        ( "unwind",             CmmT_unwind ),-        ( "bits8",              CmmT_bits8 ),-        ( "bits16",             CmmT_bits16 ),-        ( "bits32",             CmmT_bits32 ),-        ( "bits64",             CmmT_bits64 ),-        ( "bits128",            CmmT_bits128 ),-        ( "bits256",            CmmT_bits256 ),-        ( "bits512",            CmmT_bits512 ),-        ( "float32",            CmmT_float32 ),-        ( "float64",            CmmT_float64 ),--- New forms-        ( "b8",                 CmmT_bits8 ),-        ( "b16",                CmmT_bits16 ),-        ( "b32",                CmmT_bits32 ),-        ( "b64",                CmmT_bits64 ),-        ( "b128",               CmmT_bits128 ),-        ( "b256",               CmmT_bits256 ),-        ( "b512",               CmmT_bits512 ),-        ( "f32",                CmmT_float32 ),-        ( "f64",                CmmT_float64 ),-        ( "gcptr",              CmmT_gcptr ),-        ( "likely",             CmmT_likely),-        ( "True",               CmmT_True  ),-        ( "False",              CmmT_False )-        ]--tok_decimal span buf len-  = return (L span (CmmT_Int  $! parseUnsignedInteger buf len 10 octDecDigit))--tok_octal span buf len-  = return (L span (CmmT_Int  $! parseUnsignedInteger (offsetBytes 1 buf) (len-1) 8 octDecDigit))--tok_hexadecimal span buf len-  = return (L span (CmmT_Int  $! parseUnsignedInteger (offsetBytes 2 buf) (len-2) 16 hexDigit))--tok_float str = CmmT_Float $! readRational str--tok_string str = CmmT_String (read str)-                 -- urk, not quite right, but it'll do for now---- -------------------------------------------------------------------------------- Line pragmas--setLine :: Int -> Action-setLine code (PsSpan span _) buf len = do-  let line = parseUnsignedInteger buf len 10 octDecDigit-  liftP $ do-    setSrcLoc (mkRealSrcLoc (srcSpanFile span) (fromIntegral line - 1) 1)-          -- subtract one: the line number refers to the *following* line-    -- trace ("setLine "  ++ show line) $ do-    popLexState >> pushLexState code-  lexToken--setFile :: Int -> Action-setFile code (PsSpan span _) buf len = do-  let file = lexemeToFastString (stepOn buf) (len-2)-  liftP $ do-    setSrcLoc (mkRealSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span))-    popLexState >> pushLexState code-  lexToken---- -------------------------------------------------------------------------------- This is the top-level function: called from the parser each time a--- new token is to be read from the input.--cmmlex :: (Located CmmToken -> PD a) -> PD a-cmmlex cont = do-  (L span tok) <- lexToken-  --trace ("token: " ++ show tok) $ do-  cont (L (mkSrcSpanPs span) tok)--lexToken :: PD (PsLocated CmmToken)-lexToken = do-  inp@(loc1,buf) <- getInput-  sc <- liftP getLexState-  case alexScan inp sc of-    AlexEOF -> do let span = mkPsSpan loc1 loc1-                  liftP (setLastToken span 0)-                  return (L span CmmT_EOF)-    AlexError (loc2,_) -> liftP $ failLocMsgP (psRealLoc loc1) (psRealLoc loc2) (PsError PsErrCmmLexer [])-    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
@@ -170,21 +170,9 @@             platform <- getPlatform             erep <- lintCmmExpr expr             let reg_ty = cmmRegType platform reg-            unless (compat_regs erep reg_ty) $-              cmmLintAssignErr (CmmAssign reg expr) erep reg_ty-    where-      compat_regs :: CmmType -> CmmType -> Bool-      compat_regs ty1 ty2-        -- As noted in #22297, SIMD vector registers can be used for-        -- multiple different purposes, e.g. xmm1 can be used to hold 4 Floats,-        -- or 4 Int32s, or 2 Word64s, ...-        -- To allow this, we relax the check: we only ensure that the widths-        -- match, until we can find a more robust solution.-        | isVecType ty1-        , isVecType ty2-        = typeWidth ty1 == typeWidth ty2-        | otherwise-        = cmmEqType_ignoring_ptrhood ty1 ty2+            if (erep `cmmEqType_ignoring_ptrhood` reg_ty)+                then return ()+                else cmmLintAssignErr (CmmAssign reg expr) erep reg_ty    CmmStore l r _alignment -> do             _ <- lintCmmExpr l@@ -216,10 +204,9 @@             platform <- getPlatform             mapM_ checkTarget $ switchTargetsToList ids             erep <- lintCmmExpr e-            if (erep `cmmEqType_ignoring_ptrhood` bWord platform)-              then return ()-              else cmmLintErr (text "switch scrutinee is not a word: " <>-                               pdoc platform e <> text " :: " <> ppr erep)+            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
GHC/Cmm/Liveness.hs view
@@ -71,6 +71,8 @@     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
GHC/Cmm/MachOp.hs view
@@ -340,9 +340,8 @@     MO_F_Lt {} -> True     _other     -> False --- -------------------------------------------------------------------------------- Inverting conditions-+-- 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@@ -515,8 +514,8 @@     MO_FS_Conv from _   -> [from]     MO_FF_Conv from _   -> [from] -    MO_V_Insert   l r   -> [typeWidth (vec l (cmmBits r)),r, W32]-    MO_V_Extract  l r   -> [typeWidth (vec l (cmmBits r)), W32]+    MO_V_Insert  l r    -> [typeWidth (vec l (cmmBits r)),r,wordWidth platform]+    MO_V_Extract l r    -> [typeWidth (vec l (cmmBits r)),wordWidth platform]      MO_V_Add _ r        -> [r,r]     MO_V_Sub _ r        -> [r,r]@@ -529,8 +528,8 @@     MO_VU_Quot _ r      -> [r,r]     MO_VU_Rem  _ r      -> [r,r] -    MO_VF_Insert  l r   -> [typeWidth (vec l (cmmFloat r)),r,W32]-    MO_VF_Extract l r   -> [typeWidth (vec l (cmmFloat r)),W32]+    MO_VF_Insert  l r   -> [typeWidth (vec l (cmmFloat r)),r,wordWidth platform]+    MO_VF_Extract l r   -> [typeWidth (vec l (cmmFloat r)),wordWidth platform]      MO_VF_Add  _ r      -> [r,r]     MO_VF_Sub  _ r      -> [r,r]@@ -671,10 +670,18 @@   | MO_AtomicRMW Width AtomicMachOp   | MO_AtomicRead Width   | MO_AtomicWrite Width+  -- | Atomic compare-and-swap. Arguments are @[dest, expected, new]@.+  -- Sequentially consistent.+  -- Possible future refactoring: should this be an'MO_AtomicRMW' variant?   | MO_Cmpxchg Width-  -- Should be an AtomicRMW variant eventually.-  -- Sequential consistent.+  -- | 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)  -- | The operation to perform atomically.@@ -690,13 +697,16 @@ 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_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.
GHC/Cmm/Node.hs view
@@ -105,7 +105,7 @@    CmmSwitch     :: CmmExpr       -- Scrutinee, of some integral type-    -> SwitchTargets -- Cases. See [Note SwitchTargets]+    -> SwitchTargets -- Cases. See Note [SwitchTargets]     -> CmmNode O C    CmmCall :: {                -- A native call or tail call@@ -114,7 +114,9 @@       cml_cont :: Maybe Label,           -- Label of continuation (Nothing for return or tail call)           ---          -- Note [Continuation BlockIds]: these BlockIds are called+          -- 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) _).@@ -196,7 +198,6 @@  {- 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.@@ -386,7 +387,6 @@  -- 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@@ -642,8 +642,8 @@     -- 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]:---+-- 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
GHC/Cmm/Opt.hs view
@@ -118,10 +118,6 @@         intconv True  = MO_SS_Conv         intconv False = MO_UU_Conv --- ToDo: a narrow of a load can be collapsed into a narrow load, right?--- but what if the architecture only supports word-sized loads, should--- we do the transformation anyway?- cmmMachOpFoldM platform mop [CmmLit (CmmInt x xrep), CmmLit (CmmInt y _)]   = case mop of         -- for comparisons: don't forget to narrow the arguments before@@ -367,7 +363,7 @@              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 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@@ -401,7 +397,7 @@       where         bits = fromIntegral (widthInBits rep) - 1         shr = if p == 1 then MO_U_Shr rep else MO_S_Shr rep-        x1 = CmmMachOp shr [x, CmmLit (CmmInt bits rep)]+        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)]
+ GHC/Cmm/Parser.hs view
@@ -0,0 +1,3714 @@+{-# OPTIONS_GHC -w #-}+{-# OPTIONS -XMagicHash -XBangPatterns -XTypeSynonymInstances -XFlexibleInstances -cpp #-}+#if __GLASGOW_HASKELL__ >= 710+{-# OPTIONS_GHC -XPartialTypeSignatures #-}+#endif+{-# LANGUAGE TupleSections #-}++module GHC.Cmm.Parser ( parseCmmFile ) where++import GHC.Prelude+import qualified Prelude -- for happy-generated code++import GHC.Driver.Session+import GHC.Driver.Ppr+import GHC.Driver.Config.Parser (initParserOpts)+import GHC.Driver.Config.StgToCmm++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.Cmm.Opt+import GHC.Cmm.Graph+import GHC.Cmm+import GHC.Cmm.Utils+import GHC.Cmm.Switch     ( mkSwitchTargets )+import GHC.Cmm.Info+import GHC.Cmm.BlockId+import GHC.Cmm.Lexer+import GHC.Cmm.CLabel+import GHC.Cmm.Parser.Monad hiding (getPlatform, getProfile)+import qualified GHC.Cmm.Parser.Monad as PD+import GHC.Cmm.CallConv+import GHC.Runtime.Heap.Layout+import GHC.Parser.Lexer+import GHC.Parser.Errors.Types+import GHC.Parser.Errors.Ppr++import GHC.Types.CostCentre+import GHC.Types.ForeignCall+import GHC.Unit.Module+import GHC.Unit.Home+import GHC.Types.Literal+import GHC.Types.Unique+import GHC.Types.Unique.FM+import GHC.Types.SrcLoc+import GHC.Types.Tickish  ( GenTickish(SourceNote) )+import GHC.Utils.Error+import GHC.Data.StringBuffer+import GHC.Data.FastString+import GHC.Utils.Panic+import GHC.Settings.Constants+import GHC.Utils.Outputable+import GHC.Types.Basic+import GHC.Data.Bag     ( Bag, emptyBag, unitBag, isEmptyBag )+import GHC.Types.Var++import Control.Monad+import Data.Array+import Data.Char        ( ord )+import System.Exit+import Data.Maybe+import qualified Data.Map as M+import qualified Data.ByteString.Char8 as BS8+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.0++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 (Maybe CmmExpr))+happyIn22 :: (CmmParse (Maybe CmmExpr)) -> (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 CmmExpr)+happyIn23 :: (CmmParse 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 (CmmReturnInfo)+happyIn24 :: (CmmReturnInfo) -> (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 (CmmParse BoolExpr)+happyIn25 :: (CmmParse BoolExpr) -> (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 (Safety)+happyIn27 :: (Safety) -> (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 ([GlobalReg])+happyIn28 :: ([GlobalReg]) -> (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 ([GlobalReg])+happyIn29 :: ([GlobalReg]) -> (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 (Maybe (Integer,Integer))+happyIn30 :: (Maybe (Integer,Integer)) -> (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 ([CmmParse ([Integer],Either BlockId (CmmParse ()))])+happyIn31 :: ([CmmParse ([Integer],Either BlockId (CmmParse ()))]) -> (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 (Either BlockId (CmmParse ())))+happyIn33 :: (CmmParse (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 ([Integer])+happyIn34 :: ([Integer]) -> (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 (Maybe (CmmParse ()))+happyIn35 :: (Maybe (CmmParse ())) -> (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 (CmmParse ())+happyIn36 :: (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 (Maybe Bool)+happyIn37 :: (Maybe Bool) -> (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 (CmmParse CmmExpr)+happyIn38 :: (CmmParse CmmExpr) -> (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 (AlignmentSpec, CmmExpr))+happyIn40 :: (CmmParse (AlignmentSpec, 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\xc0\x6f\x00\x82\xff\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x0d\x40\xf0\xbf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x40\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\x10\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\x04\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\x04\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\x10\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\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\x01\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\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x02\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\x04\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\x08\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\x02\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\x80\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\x00\x00\x00\x00\x00\x00\x00\x00\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\xc0\xff\x00\x00\x00\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\x08\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\x02\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\x80\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\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\x00\x00\x00\x00\x00\x01\x00\x00\x00\x30\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\xc0\xff\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\x01\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\x40\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\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\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\x08\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x01\x00\x00\x00\xa0\xc7\xe6\xff\x07\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\xe8\xb1\xf9\xff\x01\x00\x00\x00\x00\x00\x00\x00\x21\x00\x00\x00\x00\xf4\xd8\xfc\xff\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\x20\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\x00\x00\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\xff\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x40\x64\x40\x00\x00\x00\x00\xe0\xff\x0f\x00\x00\x00\x00\x00\x00\x00\x20\x32\x00\x00\x00\x00\x00\xf0\xff\x07\x00\x00\x00\x00\x00\x00\x00\x10\x19\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x88\x0c\x00\x00\x00\x00\x00\xfc\xff\x01\x00\x00\x00\x00\x00\x00\x00\x04\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\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\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\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\x00\x00\x00\x00\x00\xfc\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\x01\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\x01\x40\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\x10\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\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\xff\x03\x00\x00\x00\x00\x00\x00\x00\x08\x91\x01\x00\x00\x00\x00\x80\xff\x3f\x00\x00\x00\x00\x00\x00\x00\x20\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\x08\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\x01\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\x40\x00\x00\x00\x00\x00\x00\x00\x10\xc0\xff\xf0\x03\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\x10\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\x10\x19\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x88\x0c\x00\x00\x00\x00\x00\xfc\xff\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x22\x03\x00\x00\x00\x00\x00\xff\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x20\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\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\xf0\x3f\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x06\x00\x00\x00\x00\x00\xfe\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\xc8\x00\x00\x00\x00\x00\xc0\xff\x1f\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\x10\x19\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x88\x0c\x00\x00\x00\x00\x00\xfc\xff\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x22\x03\x00\x00\x00\x00\x00\xff\x7f\x00\x00\x00\x00\x00\x00\x00\x00\xe4\x7f\xf8\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\xf0\x3f\xfc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\xf8\x1f\x7e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\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\xff\xc3\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x06\x04\x00\x00\x00\x00\xfe\xff\x00\x00\x00\x00\x00\x00\x00\x00\x22\x03\x02\x00\x00\x00\x00\xff\x7f\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\x01\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\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\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x22\x03\x00\x00\x00\x00\x00\xff\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x80\xff\x3f\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x08\x00\x00\x00\x00\x00\x00\x00\x08\xe0\x7f\xf8\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\xf0\x3f\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\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\xc0\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\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\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\xf8\x1f\x7e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x32\x00\x00\x00\x00\x00\xf0\xff\x07\x00\x00\x00\x00\x00\x00\x00\x10\x19\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x88\x0c\x00\x00\x00\x00\x00\xfc\xff\x01\x00\x00\x00\x00\x00\x00\x00\x44\x06\x00\x00\x00\x00\x00\xfe\xff\x00\x00\x00\x00\x00\x00\x00\x00\x22\x03\x00\x00\x00\x00\x00\xff\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x80\xff\x3f\x00\x00\x00\x00\x00\x00\x00\x80\xc8\x00\x00\x00\x00\x00\xc0\xff\x1f\x00\x00\x00\x00\x00\x00\x00\x40\x64\x00\x00\x00\x00\x00\xe0\xff\x0f\x00\x00\x00\x00\x00\x00\x00\x20\x32\x00\x00\x00\x00\x00\xf0\xff\x07\x00\x00\x00\x00\x00\x00\x00\x10\x19\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x88\x0c\x00\x00\x00\x00\x00\xfc\xff\x01\x00\x00\x00\x00\x00\x00\x00\x44\x06\x00\x00\x00\x00\x00\xfe\xff\x00\x00\x00\x00\x00\x00\x00\x00\x22\x03\x00\x00\x00\x00\x00\xff\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x80\xff\x3f\x00\x00\x00\x00\x00\x00\x00\x80\xc8\x00\x00\x00\x00\x00\xc0\xff\x1f\x00\x00\x00\x00\x00\x00\x00\x40\x64\x00\x00\x00\x00\x00\xe0\xff\x0f\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x10\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\x88\x0c\x08\x00\x00\x00\x00\xfc\xff\x01\x00\x00\x00\x00\x00\x00\x00\x44\x06\x04\x00\x00\x00\x00\xfe\xff\x00\x00\x00\x00\x00\x00\x00\x00\x22\x03\x00\x00\x00\x00\x00\xff\x7f\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x20\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x40\x64\x00\x00\x00\x00\x00\xe0\xff\x0f\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\xfe\x8f\x1f\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\x04\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\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x64\x00\x00\x00\x00\x20\xe0\xff\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\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xc7\x0f\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\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\x40\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\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\xfc\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\xc0\x01\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\x80\xf8\x1f\x7e\x00\x00\x00\x00\x00\x00\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\x19\x00\x00\x00\x00\x00\xf8\xff\x03\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\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\x80\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\x02\x00\x00\x00\x00\x00\x00\x00\x10\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\x40\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\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\x80\xc8\x00\x00\x00\x00\x00\xc0\xff\x1f\x00\x00\x00\x00\x00\x00\x00\x20\xf8\x1f\x7e\x00\x00\x00\x00\x00\x00\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\x19\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\x20\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\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\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\x40\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\xc0\xff\xf0\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\x0c\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\x02\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x0c\x00\x00\x00\x00\x00\xfc\xff\x01\x00\x00\x00\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x10\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\x08\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\x00\x00\x00\x00\x00\x02\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\x42\x00\x00\x00\x00\xe8\xb1\xf9\xff\x01\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\xfe\x81\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xc0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x7f\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x3f\x30\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\xf0\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf8\x07\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfc\x03\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfe\x80\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3f\xc0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x0f\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x01\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\x04\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\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\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x0c\x00\x00\x00\x00\x00\xfc\xff\x01\x00\x00\x00\x00\x00\x00\x00\x44\x06\x00\x00\x00\x00\x00\xfe\xff\x00\x00\x00\x00\x00\x00\x00\x00\x22\x03\x00\x00\x00\x00\x00\xff\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x80\xff\x3f\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\x03\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\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\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\x08\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\x20\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\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\x10\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\x04\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\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\x40\xf0\x3f\xfc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x20\x00\x00\x00\x00\x00\xe0\xff\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x02\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\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\x08\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\x08\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x06\x00\x00\x00\x00\x00\xfe\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x80\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\x10\xfe\x87\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\xff\xc3\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\xff\xe1\x07\x00\x00\x00\x00\x20\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\x80\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\x10\x19\x00\x00\x00\x00\x00\xf8\xff\x03\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\x91\x01\x00\x00\x00\x00\x80\xff\x3f\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\x00\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\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\x10\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x40\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\x10\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\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\x10\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\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\x21\x00\x00\x00\x00\xf4\xd8\xfc\xff\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\x20\x04\x00\x00\x00\x80\x1e\x9b\xff\x1f\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x01\x00\x00\x00\xa0\xc7\xe6\xff\x07\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\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\x20\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\x08\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\x04\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\x01\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\x01\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\x04\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\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","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","dereference","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'","'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'","'bits128'","'bits256'","'bits512'","'float32'","'float64'","'gcptr'","GLOBALREG","NAME","STRING","INT","FLOAT","%eof"]+        bit_start = st Prelude.* 135+        bit_end = (st Prelude.+ 1) Prelude.* 135+        read_bit = readArrayBit happyExpList+        bits = Prelude.map read_bit [bit_start..bit_end Prelude.- 1]+        bits_indexed = Prelude.zip bits [0..134]+        token_strs_expected = Prelude.concatMap f bits_indexed+        f (Prelude.False, _) = []+        f (Prelude.True, nr) = [token_strs Prelude.!! nr]++happyActOffsets :: HappyAddr+happyActOffsets = HappyA# "\x24\x01\x00\x00\xcb\xff\x24\x01\x00\x00\x00\x00\xe5\xff\x00\x00\xe1\xff\x00\x00\x29\x00\x35\x00\x64\x00\x78\x00\x98\x00\xbb\x00\x83\x00\x84\x00\xef\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf8\x00\xeb\x00\xb6\x00\x00\x00\xbe\x00\x12\x01\x1d\x01\x14\x01\xd8\x00\xdb\x00\x06\x01\x11\x01\x16\x01\x23\x01\x2a\x01\x27\x01\x00\x00\x00\x00\x1c\x00\x5e\x04\x00\x00\x32\x01\x64\x01\x6d\x01\x6f\x01\x71\x01\x73\x01\x44\x01\x00\x00\x57\x01\x00\x00\x00\x00\xef\xff\x00\x00\x00\x00\xfe\x00\xa5\x01\x00\x00\x5c\x01\x6e\x01\x81\x01\x83\x01\x94\x01\x84\x01\x9a\x01\x00\x00\x92\x01\x98\x01\x00\x00\x00\x00\x20\x00\xb4\x01\x20\x00\x20\x00\xf2\xff\xb1\x01\x23\x00\x00\x00\x51\x04\x99\x01\x63\x00\x72\x00\x72\x00\x72\x00\xec\x01\xef\x01\xee\x01\xae\x01\x00\x00\x16\x00\x00\x00\x5e\x04\x00\x00\xe8\x01\xea\x01\x0a\x00\xeb\x01\xed\x01\xf9\x01\x00\x00\xfe\x01\xfe\x00\xff\xff\x09\x02\x0a\x02\x0b\x02\x02\x00\xd0\x01\xcf\x01\xa1\x01\x11\x02\x00\x00\x11\x00\x00\x00\x72\x00\x72\x00\xd3\x01\x72\x00\x00\x00\x00\x00\x00\x00\x04\x02\x04\x02\x00\x00\x00\x00\xde\x01\xdf\x01\xe0\x01\x00\x00\x5e\x04\xe9\x01\x20\x02\x72\x00\x00\x00\x00\x00\x72\x00\x31\x02\x2d\x02\x72\x00\x72\x00\xf7\x01\x72\x00\xa7\x02\xf8\x01\x5f\x02\x0c\x00\x00\x00\x3b\x04\x63\x00\x63\x00\x33\x02\x2f\x02\x2e\x02\x00\x00\x3b\x02\x00\x00\xfc\x01\x72\x00\x72\x00\x03\x02\x40\x02\x00\x00\x00\x00\x00\x00\x06\x02\x07\x02\xb5\x01\x12\x02\x00\x00\x48\x02\x26\x00\x53\x02\x00\x00\x00\x00\x57\x00\x55\x02\x90\x02\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x08\x00\x3a\x02\x63\x00\x63\x00\x72\x00\x5d\x02\x25\x00\x72\x00\x7f\x00\x13\x04\x60\x02\x00\x00\x4f\x02\xdd\x01\x61\x02\x4c\x00\x00\x00\x62\x02\x27\x04\x73\x02\x6a\x02\x6e\x02\x6b\x02\x6c\x02\x6d\x02\x00\x00\x5e\x04\x00\x00\x77\x00\x70\x02\x00\x00\x90\x02\x00\x00\x72\x00\x89\x02\x47\x02\x00\x00\x72\x02\x79\x02\x50\x02\x8b\x02\x97\x02\x99\x02\x9e\x02\xa6\x02\x9d\x02\x72\x00\x2c\x02\x00\x00\x72\x00\x00\x00\x67\x02\x5e\x02\x74\x02\x00\x00\x75\x02\x00\x00\x00\x00\xb0\x02\xb3\x02\x3b\x04\x00\x00\xe9\x00\x83\x02\x81\x02\xbc\x02\x72\x00\xe9\x00\x00\x00\xc5\x02\xce\x02\x00\x00\xcf\x02\xc0\x02\x00\x00\xd4\x02\xd6\x00\xb7\x02\xe1\x02\x20\x00\x9a\x02\x4f\x04\x4f\x04\x4f\x04\x4f\x04\x8e\x00\x8e\x00\x4f\x04\x4f\x04\x63\x04\x6a\x04\x73\x04\x77\x00\x77\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x02\xdc\x02\x00\x00\xec\x02\x00\x00\xed\x02\x72\x00\x72\x00\x72\x00\x72\x00\x00\x00\xe4\x02\x0e\x01\xf3\x02\xae\x02\x00\x00\x00\x00\x1a\x00\x00\x00\x00\x00\x00\x00\xf5\x02\xc6\x02\xc8\x02\xb8\x02\x00\x00\xbf\x02\x00\x00\xee\x02\xfc\x02\xfd\x02\xff\x02\x0c\x03\x00\x00\x46\x02\x92\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcc\x02\xdf\x02\xcd\x02\xd0\x02\x00\x00\x1e\x03\x15\x03\x00\x00\x2a\x03\x2b\x03\x00\x00\x00\x00\x72\x00\x00\x00\x00\x00\x27\x03\x35\x03\x07\x03\x78\x02\xc9\x01\xd3\x00\x37\x03\x00\x00\x2d\x03\x38\x03\x3f\x03\x72\x00\x08\x03\x00\x00\x00\x00\x72\x00\x00\x00\x42\x03\x00\x00\x00\x00\x3e\x03\x44\x03\x00\x00\x09\x03\x09\x00\x46\x03\x4a\x03\x4b\x03\x4d\x03\x00\x00\x0e\x03\x10\x03\x11\x03\x00\x00\x20\x00\x24\x03\x00\x00\x20\x00\x6d\x03\x20\x00\x69\x03\x2f\x03\x00\x00\x00\x00\x00\x00\x70\x03\x3c\x03\x73\x03\x72\x03\x00\x00\x80\x03\x84\x03\x83\x03\x82\x03\x61\x03\x76\x03\x4f\x03\x3d\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x85\x03\x86\x03\x00\x00\x00\x00\x00\x00"#++happyGotoOffsets :: HappyAddr+happyGotoOffsets = HappyA# "\xbf\x00\x00\x00\x00\x00\xc3\x00\x00\x00\x00\x00\x93\x03\x00\x00\x8d\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x92\x03\x00\x00\x39\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\x6e\x03\x00\x00\x00\x00\x99\x03\xde\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x94\x03\x00\x00\xa4\x03\x00\x00\x00\x00\x4b\x01\x00\x00\x00\x00\xfe\xff\x00\x00\x00\x00\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\xff\x00\x00\x05\x00\xf0\x00\x00\x00\x00\x00\x9a\x03\x00\x00\xe1\x03\x00\x00\x59\x01\x53\x00\xe3\x00\x02\x03\x00\x00\x8e\x03\x00\x00\xa3\x03\x00\x00\x00\x00\x00\x00\x43\x01\x00\x00\xb0\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe5\x00\x13\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x95\x03\x00\x00\x17\x03\x19\x03\x00\x00\x28\x03\x00\x00\x00\x00\x00\x00\x97\x03\x98\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x01\x00\x00\x00\x00\x2e\x03\x00\x00\x00\x00\xa5\x02\x00\x00\x00\x00\xa8\x02\x34\x03\x00\x00\xb6\x02\x00\x00\xa0\x03\x00\x00\x9d\x03\x00\x00\x00\x00\x5b\x01\x5d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8b\x03\x43\x03\x45\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x03\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\x03\x5a\x03\x5e\x03\x60\x03\x6f\x03\x75\x03\x7b\x03\x8a\x03\x8c\x03\x90\x03\xa1\x03\xa5\x03\xa7\x03\xb6\x03\xbc\x03\xc2\x03\x00\x00\x00\x00\x5f\x01\x76\x01\xc4\x02\x00\x00\xb4\x03\xc7\x02\x9e\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe1\x00\x00\x00\x00\x00\xc9\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x28\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd1\x03\x00\x00\x00\x00\x00\x00\x00\x00\xcb\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd3\x03\x00\x00\x00\x00\xd5\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\xca\x03\x82\x01\x00\x00\x00\x00\x51\x00\xcc\x03\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\x00\x00\x00\x00\x00\x00\x00\x00\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\x02\x74\x01\xd7\x03\xe8\x03\x00\x00\x00\x00\x00\x00\x00\x00\xbb\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc1\x03\x89\x01\xc4\x03\x00\x00\xd2\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe4\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x02\x00\x00\x00\x00\x00\x00\x00\x00\xc6\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfb\x02\xd8\x03\x00\x00\x00\x00\xfe\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd0\x03\xcd\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfd\x00\x00\x00\x00\x00\xff\x00\x00\x00\x2b\x01\x00\x00\xd4\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"#++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\x5d\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5e\xff\x5c\xff\x5b\xff\x5a\xff\x59\xff\x58\xff\x57\xff\x56\xff\x55\xff\x54\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\x66\xff\xea\xff\xfd\xff\x00\x00\x64\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\x63\xff\x61\xff\x00\x00\xec\xff\xe9\xff\xe0\xff\x00\x00\xe0\xff\xe0\xff\x00\x00\x00\x00\x00\x00\xd3\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaa\xff\x00\x00\x00\x00\x67\xff\x68\xff\x5f\xff\x62\xff\x65\xff\xee\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf7\xff\x00\x00\xf6\xff\x00\x00\x5d\xff\x00\x00\x5e\xff\x00\x00\x00\x00\x00\x00\x00\x00\x88\xff\x84\xff\x00\x00\xf3\xff\x00\x00\x00\x00\x00\x00\x00\x00\x71\xff\x72\xff\x85\xff\x7e\xff\x7e\xff\xf5\xff\xf8\xff\x00\x00\x00\x00\x00\x00\xe2\xff\x64\xff\x00\x00\x00\x00\x00\x00\x60\xff\xd2\xff\x76\xff\x00\x00\x00\x00\x76\xff\x00\x00\x00\x00\x76\xff\x00\x00\x00\x00\x00\x00\x9c\xff\xb8\xff\xb7\xff\x00\x00\x00\x00\x00\x00\x00\x00\x6e\xff\x6b\xff\x00\x00\x69\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xde\xff\xdf\xff\xe8\xff\x00\x00\x00\x00\x00\x00\x00\x00\x6a\xff\x00\x00\x6d\xff\x00\x00\xcb\xff\xb4\xff\x00\x00\xb8\xff\xb7\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x76\xff\x00\x00\x00\x00\x76\xff\x00\x00\x74\xff\x00\x00\x75\xff\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xff\x00\x00\xee\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x86\xff\x00\x00\x87\xff\x8a\xff\x00\x00\x8b\xff\x00\x00\x83\xff\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\x81\xff\x76\xff\x7d\xff\x00\x00\x00\x00\x00\x00\xe1\xff\x00\x00\xf9\xff\xed\xff\x00\x00\xbe\xff\xbc\xff\xbd\xff\x00\x00\xa9\xff\x00\x00\x00\x00\x00\x00\x00\x00\x68\xff\x00\x00\x00\x00\xb0\xff\x00\x00\xad\xff\xc9\xff\x00\x00\xb5\xff\xb6\xff\x00\x00\xe0\xff\x00\x00\x8d\xff\x8c\xff\x8f\xff\x91\xff\x95\xff\x96\xff\x8e\xff\x90\xff\x92\xff\x93\xff\x94\xff\x97\xff\x98\xff\x99\xff\x9a\xff\x9b\xff\xb3\xff\x6f\xff\x6c\xff\x00\x00\x00\x00\xd1\xff\x00\x00\xbb\xff\x00\x00\x76\xff\x7c\xff\x00\x00\x00\x00\xc4\xff\x00\x00\x00\x00\x00\x00\x00\x00\xaf\xff\xae\xff\x00\x00\xc1\xff\x73\xff\xca\xff\x00\x00\xa1\xff\xa9\xff\x00\x00\xc2\xff\x00\x00\xcd\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7f\xff\x00\x00\x00\x00\xf0\xff\xef\xff\xf2\xff\xf1\xff\x89\xff\x80\xff\x82\xff\x00\x00\x00\x00\x00\x00\x00\x00\xbf\xff\x00\x00\xa4\xff\xa8\xff\x00\x00\x00\x00\xab\xff\xc8\xff\x76\xff\xac\xff\xc6\xff\x00\x00\x00\x00\xa0\xff\x00\x00\x00\x00\x78\xff\x00\x00\x7b\xff\x7a\xff\x00\x00\x00\x00\x00\x00\xb2\xff\x77\xff\xd0\xff\x76\xff\xc3\xff\x00\x00\x9d\xff\x9e\xff\x00\x00\x00\x00\xcc\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\xff\x00\x00\x00\x00\x00\x00\xa7\xff\xe0\xff\x00\x00\xa3\xff\xe0\xff\x00\x00\xe0\xff\x00\x00\xba\xff\xb1\xff\x79\xff\xce\xff\x00\x00\x00\x00\x00\x00\x00\x00\xc7\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe6\xff\xa6\xff\xa5\xff\xa2\xff\x9f\xff\xc5\xff\xb9\xff\xcf\xff\x00\x00\x00\x00\xe4\xff\xe5\xff"#++happyCheck :: HappyAddr+happyCheck = HappyA# "\xff\xff\x02\x00\x04\x00\x05\x00\x0b\x00\x0c\x00\x07\x00\x23\x00\x06\x00\x10\x00\x0b\x00\x03\x00\x03\x00\x0e\x00\x0f\x00\x2b\x00\x0b\x00\x0c\x00\x08\x00\x07\x00\x25\x00\x10\x00\x05\x00\x01\x00\x4d\x00\x35\x00\x36\x00\x36\x00\x02\x00\x07\x00\x02\x00\x03\x00\x16\x00\x07\x00\x02\x00\x12\x00\x32\x00\x2c\x00\x34\x00\x07\x00\x05\x00\x30\x00\x49\x00\x06\x00\x20\x00\x21\x00\x35\x00\x36\x00\x07\x00\x2c\x00\x0d\x00\x35\x00\x36\x00\x30\x00\x2e\x00\x2e\x00\x49\x00\x4a\x00\x35\x00\x36\x00\x07\x00\x3e\x00\x3f\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\x2c\x00\x4b\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x07\x00\x34\x00\x35\x00\x36\x00\x0b\x00\x38\x00\x39\x00\x0e\x00\x0f\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x07\x00\x07\x00\x49\x00\x48\x00\x0b\x00\x49\x00\x4a\x00\x0e\x00\x0f\x00\x22\x00\x23\x00\x22\x00\x23\x00\x20\x00\x21\x00\x07\x00\x17\x00\x2a\x00\x2b\x00\x0b\x00\x2b\x00\x07\x00\x0e\x00\x0f\x00\x36\x00\x0c\x00\x0d\x00\x0e\x00\x35\x00\x36\x00\x35\x00\x36\x00\x3e\x00\x3f\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\x07\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x07\x00\x0e\x00\x3e\x00\x3f\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\x3e\x00\x3f\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\x00\x00\x01\x00\x02\x00\x07\x00\x00\x00\x01\x00\x02\x00\x07\x00\x48\x00\x49\x00\x0a\x00\x07\x00\x0c\x00\x49\x00\x0a\x00\x4a\x00\x0c\x00\x3e\x00\x3f\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\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x04\x00\x05\x00\x02\x00\x03\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x12\x00\x35\x00\x36\x00\x20\x00\x21\x00\x35\x00\x36\x00\x02\x00\x0b\x00\x0c\x00\x0b\x00\x0c\x00\x49\x00\x10\x00\x16\x00\x10\x00\x22\x00\x23\x00\x22\x00\x23\x00\x49\x00\x0b\x00\x0c\x00\x0b\x00\x0c\x00\x2b\x00\x10\x00\x2b\x00\x10\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x03\x00\x35\x00\x36\x00\x35\x00\x36\x00\x35\x00\x36\x00\x2c\x00\x4a\x00\x2c\x00\x02\x00\x30\x00\x49\x00\x30\x00\x25\x00\x49\x00\x35\x00\x36\x00\x35\x00\x36\x00\x2c\x00\x16\x00\x2c\x00\x02\x00\x30\x00\x07\x00\x30\x00\x22\x00\x23\x00\x35\x00\x36\x00\x35\x00\x36\x00\x0b\x00\x0c\x00\x2d\x00\x2e\x00\x2f\x00\x10\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x0d\x00\x0e\x00\x16\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x49\x00\x2c\x00\x2d\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x2c\x00\x0d\x00\x0e\x00\x49\x00\x30\x00\x38\x00\x35\x00\x36\x00\x49\x00\x35\x00\x36\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x49\x00\x49\x00\x15\x00\x16\x00\x15\x00\x16\x00\x15\x00\x16\x00\x15\x00\x16\x00\x33\x00\x34\x00\x35\x00\x36\x00\x16\x00\x22\x00\x23\x00\x22\x00\x23\x00\x22\x00\x23\x00\x22\x00\x23\x00\x16\x00\x2b\x00\x16\x00\x2b\x00\x16\x00\x2b\x00\x16\x00\x2b\x00\x15\x00\x16\x00\x49\x00\x35\x00\x36\x00\x35\x00\x36\x00\x35\x00\x36\x00\x35\x00\x36\x00\x22\x00\x23\x00\x22\x00\x23\x00\x26\x00\x27\x00\x28\x00\x1b\x00\x1c\x00\x2b\x00\x49\x00\x2b\x00\x08\x00\x02\x00\x1b\x00\x1c\x00\x01\x00\x4b\x00\x16\x00\x35\x00\x36\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\x02\x00\x04\x00\x4b\x00\x09\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\x4b\x00\x49\x00\x4b\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\x4b\x00\x03\x00\x49\x00\x49\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\x07\x00\x05\x00\x07\x00\x48\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x05\x00\x16\x00\x07\x00\x16\x00\x16\x00\x04\x00\x16\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\x05\x00\x07\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x06\x00\x49\x00\x4b\x00\x0a\x00\x49\x00\x19\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x08\x00\x4b\x00\x4b\x00\x4b\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x06\x00\x02\x00\x4b\x00\x02\x00\x09\x00\x08\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x4b\x00\x08\x00\x16\x00\x49\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x06\x00\x4a\x00\x0e\x00\x49\x00\x49\x00\x09\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x09\x00\x08\x00\x24\x00\x02\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x07\x00\x18\x00\x08\x00\x08\x00\x08\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\x07\x00\x06\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x07\x00\x16\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\x05\x00\x16\x00\x49\x00\x06\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x08\x00\x02\x00\x4a\x00\x02\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x08\x00\x0a\x00\x02\x00\x4b\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x09\x00\x4a\x00\x02\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x3a\x00\x02\x00\x4b\x00\x4b\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x22\x00\x23\x00\x16\x00\x22\x00\x23\x00\x4b\x00\x08\x00\x29\x00\x2a\x00\x2b\x00\x29\x00\x2a\x00\x2b\x00\x06\x00\x06\x00\x16\x00\x20\x00\x22\x00\x23\x00\x35\x00\x36\x00\x08\x00\x35\x00\x36\x00\x29\x00\x2a\x00\x2b\x00\x01\x00\x49\x00\x30\x00\x09\x00\x22\x00\x23\x00\x04\x00\x22\x00\x23\x00\x35\x00\x36\x00\x29\x00\x2a\x00\x2b\x00\x29\x00\x2a\x00\x2b\x00\x07\x00\x07\x00\x02\x00\x48\x00\x22\x00\x23\x00\x35\x00\x36\x00\x06\x00\x35\x00\x36\x00\x29\x00\x2a\x00\x2b\x00\x3b\x00\x3a\x00\x4b\x00\x16\x00\x22\x00\x23\x00\x48\x00\x22\x00\x23\x00\x35\x00\x36\x00\x29\x00\x2a\x00\x2b\x00\x29\x00\x2a\x00\x2b\x00\x16\x00\x16\x00\x08\x00\x16\x00\x4a\x00\x4a\x00\x35\x00\x36\x00\x4a\x00\x35\x00\x36\x00\x22\x00\x23\x00\x01\x00\x22\x00\x23\x00\x27\x00\x28\x00\x22\x00\x23\x00\x2b\x00\x29\x00\x2a\x00\x2b\x00\x4b\x00\x16\x00\x01\x00\x2b\x00\x04\x00\x08\x00\x35\x00\x36\x00\x2b\x00\x35\x00\x36\x00\x22\x00\x23\x00\x35\x00\x36\x00\x22\x00\x23\x00\x22\x00\x23\x00\x08\x00\x2b\x00\x08\x00\x08\x00\x02\x00\x2b\x00\x16\x00\x2b\x00\x03\x00\x08\x00\x03\x00\x35\x00\x36\x00\x22\x00\x23\x00\x35\x00\x36\x00\x35\x00\x36\x00\x22\x00\x23\x00\x4a\x00\x2b\x00\x4b\x00\x08\x00\x22\x00\x23\x00\x4a\x00\x2b\x00\x4a\x00\x4a\x00\x16\x00\x35\x00\x36\x00\x2b\x00\x16\x00\x16\x00\x33\x00\x35\x00\x36\x00\x22\x00\x23\x00\x22\x00\x23\x00\x35\x00\x36\x00\x22\x00\x23\x00\x49\x00\x2b\x00\x02\x00\x2b\x00\x08\x00\x02\x00\x37\x00\x2b\x00\x02\x00\x04\x00\x16\x00\x35\x00\x36\x00\x35\x00\x36\x00\x22\x00\x23\x00\x35\x00\x36\x00\x22\x00\x23\x00\x22\x00\x23\x00\x04\x00\x2b\x00\x02\x00\x04\x00\x4b\x00\x2b\x00\x08\x00\x2b\x00\x16\x00\x08\x00\x08\x00\x35\x00\x36\x00\x22\x00\x23\x00\x35\x00\x36\x00\x35\x00\x36\x00\x22\x00\x23\x00\x4a\x00\x2b\x00\x08\x00\x0f\x00\x22\x00\x23\x00\x31\x00\x2b\x00\x0f\x00\x09\x00\x0f\x00\x35\x00\x36\x00\x2b\x00\x03\x00\x1a\x00\x0f\x00\x35\x00\x36\x00\x22\x00\x23\x00\x22\x00\x23\x00\x35\x00\x36\x00\x22\x00\x23\x00\x11\x00\x2b\x00\x06\x00\x2b\x00\x18\x00\x24\x00\x2f\x00\x2b\x00\x25\x00\x25\x00\x21\x00\x35\x00\x36\x00\x35\x00\x36\x00\x22\x00\x23\x00\x35\x00\x36\x00\x22\x00\x23\x00\x22\x00\x23\x00\x13\x00\x2b\x00\x19\x00\x30\x00\x06\x00\x2b\x00\x06\x00\x2b\x00\x09\x00\x19\x00\x09\x00\x35\x00\x36\x00\x22\x00\x23\x00\x35\x00\x36\x00\x35\x00\x36\x00\x22\x00\x23\x00\x1f\x00\x2b\x00\x1e\x00\x11\x00\x22\x00\x23\x00\x20\x00\x2b\x00\x14\x00\xff\xff\x1d\x00\x35\x00\x36\x00\x2b\x00\x1e\x00\x17\x00\xff\xff\x35\x00\x36\x00\x22\x00\x23\x00\x22\x00\x23\x00\x35\x00\x36\x00\x22\x00\x23\x00\xff\xff\x2b\x00\xff\xff\x2b\x00\xff\xff\xff\xff\xff\xff\x2b\x00\xff\xff\xff\xff\xff\xff\x35\x00\x36\x00\x35\x00\x36\x00\x22\x00\x23\x00\x35\x00\x36\x00\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\x2b\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x35\x00\x36\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\xff\xff\xff\xff\xff\xff\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\xff\xff\xff\xff\xff\xff\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\xff\xff\xff\xff\xff\xff\xff\xff\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\xff\xff\xff\xff\xff\xff\xff\xff\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\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\xff\xff\x1a\x00\x1b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x1a\x00\x1b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\xff\xff\x49\x00\x4a\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\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\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"#++happyTable :: HappyAddr+happyTable = HappyA# "\x00\x00\x7c\x00\x6e\x00\x6f\x00\x51\x00\x52\x00\x7d\x00\x57\x01\xf3\x00\x53\x00\x7e\x00\x1b\x01\x8c\x01\x7f\x00\x80\x00\x79\x00\xac\x00\x52\x00\x8b\x00\xcd\x00\x21\x00\x53\x00\xed\x00\x91\x00\xff\xff\x7a\x00\x09\x00\x2f\x00\x66\x01\x92\x00\x50\x00\x51\x00\x8c\x00\x67\x01\x58\x00\xee\x00\xaa\x00\x54\x00\xab\x00\x59\x00\xa8\x00\x55\x00\x26\x00\x13\x01\xce\x00\xcf\x00\x56\x00\x09\x00\x2c\x00\x54\x00\x14\x01\x70\x00\x71\x00\x55\x00\x1c\x01\x8d\x01\x22\x00\x23\x00\x56\x00\x09\x00\x2b\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x11\x00\xf4\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x70\xff\x7d\x00\x70\xff\x5e\x00\x5f\x00\x7e\x00\x13\x00\x60\x00\x7f\x00\x80\x00\x61\x00\x62\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x63\x00\x64\x00\x9f\x00\x2a\x00\x26\x00\x15\x01\x7e\x00\xa6\x00\xa7\x00\x7f\x00\x80\x00\xd4\x00\x78\x00\x9a\x00\x78\x00\xce\x00\xcf\x00\x7d\x00\xa0\x00\x42\x01\x79\x00\x7e\x00\x79\x00\x29\x00\x7f\x00\x80\x00\x09\x01\xbc\x00\xbd\x00\xbe\x00\x7a\x00\x09\x00\x7a\x00\x09\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x7d\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\x28\x00\x7f\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x02\x00\x03\x00\x04\x00\x27\x00\x2f\x00\x03\x00\x04\x00\x05\x00\x63\x00\x10\x01\x06\x00\x05\x00\x07\x00\x26\x00\x06\x00\x24\x00\x07\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\x85\x00\x6f\x00\x50\x00\x51\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\x06\x01\x08\x00\x09\x00\xce\x00\xcf\x00\x08\x00\x09\x00\x40\x00\xab\x00\x52\x00\x3a\x01\x52\x00\x3e\x00\x53\x00\x3f\x00\x53\x00\x07\x01\x78\x00\x99\x00\x78\x00\x3d\x00\x9d\x01\x52\x00\x9b\x01\x52\x00\x79\x00\x53\x00\x79\x00\x53\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x09\x00\x3c\x00\x7a\x00\x09\x00\x7a\x00\x09\x00\x70\x00\x71\x00\x54\x00\x77\x01\x54\x00\x3b\x00\x55\x00\x39\x00\x55\x00\x73\x00\x38\x00\x56\x00\x09\x00\x56\x00\x09\x00\x54\x00\x3a\x00\x54\x00\x33\x00\x55\x00\x32\x00\x55\x00\x6a\x01\x6b\x01\x56\x00\x09\x00\x56\x00\x09\x00\x99\x01\x52\x00\x2e\x01\xa2\x00\xa3\x00\x53\x00\x74\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x4a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x37\x00\x11\x00\x12\x00\xe0\x00\x4b\x00\x4c\x00\x4d\x00\x09\x00\x54\x00\x40\x00\x1f\x00\x36\x00\x55\x00\x13\x00\xfd\x00\x09\x00\x35\x00\x56\x00\x09\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x34\x00\x1e\x00\x9b\x00\x9c\x00\xb8\x00\xb9\x00\xb7\x00\x9c\x00\x18\x01\x9c\x00\x8f\x00\x4c\x00\x4d\x00\x09\x00\x49\x00\x9d\x00\x78\x00\xba\x00\x78\x00\x9d\x00\x78\x00\x9d\x00\x78\x00\x48\x00\x79\x00\x47\x00\x79\x00\x46\x00\x79\x00\x45\x00\x79\x00\x17\x01\x9c\x00\x26\x00\x7a\x00\x09\x00\x7a\x00\x09\x00\x7a\x00\x09\x00\x7a\x00\x09\x00\x6e\x01\x78\x00\x9d\x00\x78\x00\x6f\x01\x70\x01\x71\x01\x45\x01\x46\x01\x79\x00\x43\x00\x79\x00\x67\x00\xf0\x00\x61\x01\x46\x01\x6e\x00\x6d\x00\x66\x00\x7a\x00\x09\x00\x7a\x00\x09\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\x32\x01\xae\x00\x6c\x00\xa9\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\x78\x01\x6b\x00\x68\x00\x6a\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\x69\x00\x0b\x01\x65\x00\xa1\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\x98\x00\x97\x00\x95\x00\x94\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xd2\x00\x8f\x00\xd3\x00\x8d\x00\x8a\x00\x87\x00\x89\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\x77\x00\x88\x00\x75\x00\x76\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\x31\x01\xf2\x00\xf1\x00\xef\x00\xe9\x00\xe6\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xdf\x00\xe4\x00\xe3\x00\xe2\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\x51\x01\xdc\x00\xe0\x00\xb7\x00\xdb\x00\xb6\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xd8\x00\xb4\x00\xb5\x00\xa6\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\x59\x01\xb0\x00\xaf\x00\x35\x01\x34\x01\x30\x01\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\x2e\x01\x2d\x01\x1a\x01\x16\x01\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xd0\x00\x0c\x01\x0d\x01\x0a\x01\x06\x01\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\x04\x01\x02\x01\xfd\x00\xf8\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\x79\x01\x03\x01\x01\x01\x00\x01\xff\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xfa\x00\x8f\x00\xf9\x00\xf5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xfc\x00\x57\x01\xf6\x00\x56\x01\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\x55\x01\x53\x01\x54\x01\x4e\x01\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xd4\x00\x4f\x01\x4b\x01\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\x48\x01\x44\x01\x4d\x01\x4c\x01\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xd4\x00\x78\x00\x4a\x01\xd4\x00\x78\x00\x45\x01\x41\x01\xdc\x00\xd6\x00\x79\x00\xd9\x00\xd6\x00\x79\x00\x40\x01\x3f\x01\x3e\x01\xce\x00\xd4\x00\x78\x00\x7a\x00\x09\x00\x3d\x01\x7a\x00\x09\x00\xd5\x00\xd6\x00\x79\x00\x3c\x01\x3a\x01\x39\x01\x38\x01\xd4\x00\x78\x00\x6c\x01\xd4\x00\x78\x00\x7a\x00\x09\x00\x16\x01\xd6\x00\x79\x00\x10\x01\xd6\x00\x79\x00\x37\x01\x36\x01\x69\x01\x15\x01\xd4\x00\x78\x00\x7a\x00\x09\x00\x65\x01\x7a\x00\x09\x00\x4f\x01\xd6\x00\x79\x00\x64\x01\x48\x01\x61\x01\x5e\x01\xd4\x00\x78\x00\x94\x00\xd4\x00\x78\x00\x7a\x00\x09\x00\x72\x01\xd6\x00\x79\x00\x7d\x01\xd6\x00\x79\x00\x5d\x01\x5c\x01\x5a\x01\x5b\x01\x86\x01\x84\x01\x7a\x00\x09\x00\x83\x01\x7a\x00\x09\x00\x6e\x01\x78\x00\x82\x01\xd4\x00\x78\x00\x94\x01\x71\x01\x98\x00\x78\x00\x79\x00\x91\x01\xd6\x00\x79\x00\x85\x01\x81\x01\x7f\x01\x79\x00\x80\x01\x7d\x01\x7a\x00\x09\x00\x7b\x01\x7a\x00\x09\x00\x77\x00\x78\x00\x7a\x00\x09\x00\xea\x00\x78\x00\xe9\x00\x78\x00\x7c\x01\x79\x00\x76\x01\x74\x01\x96\x01\x79\x00\x75\x01\x79\x00\x91\x01\x90\x01\x8f\x01\x7a\x00\x09\x00\xe7\x00\x78\x00\x7a\x00\x09\x00\x7a\x00\x09\x00\xdd\x00\x78\x00\x94\x01\x79\x00\x61\x01\x87\x01\xd8\x00\x78\x00\xa1\x01\x79\x00\xa0\x01\x9f\x01\x8a\x01\x7a\x00\x09\x00\x79\x00\x89\x01\x88\x01\x98\x01\x7a\x00\x09\x00\xb1\x00\x78\x00\xb0\x00\x78\x00\x7a\x00\x09\x00\x2b\x01\x78\x00\x9d\x01\x79\x00\x9b\x01\x79\x00\x99\x01\xab\x01\xaa\x01\x79\x00\xa9\x01\xa8\x01\xa3\x01\x7a\x00\x09\x00\x7a\x00\x09\x00\x2a\x01\x78\x00\x7a\x00\x09\x00\x29\x01\x78\x00\x28\x01\x78\x00\xa7\x01\x79\x00\xa6\x01\xa5\x01\xac\x01\x79\x00\xa4\x01\x79\x00\xa2\x01\xaf\x01\xae\x01\x7a\x00\x09\x00\x27\x01\x78\x00\x7a\x00\x09\x00\x7a\x00\x09\x00\x26\x01\x78\x00\xad\x01\x79\x00\x2d\x00\x2c\x00\x25\x01\x78\x00\x30\x00\x79\x00\x24\x00\x4e\x00\x43\x00\x7a\x00\x09\x00\x79\x00\x41\x00\x95\x00\x2c\x00\x7a\x00\x09\x00\x24\x01\x78\x00\x23\x01\x78\x00\x7a\x00\x09\x00\x22\x01\x78\x00\x92\x00\x79\x00\x8d\x00\x79\x00\xd0\x00\xeb\x00\xb2\x00\x79\x00\xe6\x00\xe4\x00\xcb\x00\x7a\x00\x09\x00\x7a\x00\x09\x00\x21\x01\x78\x00\x7a\x00\x09\x00\x20\x01\x78\x00\x1f\x01\x78\x00\x32\x01\x79\x00\x11\x01\x0e\x01\x04\x01\x79\x00\xf6\x00\x79\x00\x48\x01\x67\x01\x41\x01\x7a\x00\x09\x00\x1e\x01\x78\x00\x7a\x00\x09\x00\x7a\x00\x09\x00\x1d\x01\x78\x00\x62\x01\x79\x00\x5f\x01\x5e\x01\x1c\x01\x78\x00\x79\x01\x79\x00\x96\x01\x00\x00\x8a\x01\x7a\x00\x09\x00\x79\x00\x8d\x01\x92\x01\x00\x00\x7a\x00\x09\x00\xfa\x00\x78\x00\x51\x01\x78\x00\x7a\x00\x09\x00\x6d\x01\x78\x00\x00\x00\x79\x00\x00\x00\x79\x00\x00\x00\x00\x00\x00\x00\x79\x00\x00\x00\x00\x00\x00\x00\x7a\x00\x09\x00\x7a\x00\x09\x00\x6c\x01\x78\x00\x7a\x00\x09\x00\xa1\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x79\x00\xa4\x00\x4c\x00\x4d\x00\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7a\x00\x09\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\x0e\x01\x00\x00\x00\x00\x00\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\x8f\x00\x00\x00\x00\x00\x00\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc6\x00\xc7\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\x00\x00\xc6\x00\xc7\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc6\x00\xc7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc6\x00\xc7\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x00\x00\xa6\x00\xa7\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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, 171) [+	(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)+	]++happy_n_terms = 78 :: 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 happyOut38 happy_x_2 of { (HappyWrap38 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 Nothing 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 happyOut38 happy_x_2 of { (HappyWrap38 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 (renderWithContext ctx (pdoc 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 16# 10# happyReduction_26+happyReduction_26 (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)) -> +	( do+                      home_unit_id <- getHomeUnitId+                      liftP $ pure $ do+                        profile <- getProfile+                        let prof = profilingInfo profile happy_var_11 happy_var_13+                            ty   = Fun 0 (ArgSpec (fromIntegral happy_var_15))+                                  -- Arity zero, arg_type happy_var_15+                            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 Nothing 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 Nothing 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 happyOut38 happy_x_3 of { (HappyWrap38 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 7# 16# happyReduction_47+happyReduction_47 (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 happyOut38 happy_x_3 of { (HappyWrap38 happy_var_3) -> +	case happyOut38 happy_x_6 of { (HappyWrap38 happy_var_6) -> +	case happyOutTok happy_x_7 of { happy_var_7 -> +	happyIn20+		 (withSourceNote happy_var_2 happy_var_7 (doStore happy_var_1 happy_var_3 happy_var_6)+	) `HappyStk` happyRest}}}}}++happyReduce_48 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_48 = happyMonadReduce 10# 16# happyReduction_48+happyReduction_48 (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 happyOut23 happy_x_4 of { (HappyWrap23 happy_var_4) -> +	case happyOut42 happy_x_6 of { (HappyWrap42 happy_var_6) -> +	case happyOut27 happy_x_8 of { (HappyWrap27 happy_var_8) -> +	case happyOut24 happy_x_9 of { (HappyWrap24 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_49 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_49 = happyMonadReduce 8# 16# happyReduction_49+happyReduction_49 (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_50 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_50 = happyMonadReduce 5# 16# happyReduction_50+happyReduction_50 (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_51 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_51 = happyReduce 7# 16# happyReduction_51+happyReduction_51 (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 happyOut30 happy_x_2 of { (HappyWrap30 happy_var_2) -> +	case happyOut38 happy_x_3 of { (HappyWrap38 happy_var_3) -> +	case happyOut31 happy_x_5 of { (HappyWrap31 happy_var_5) -> +	case happyOut35 happy_x_6 of { (HappyWrap35 happy_var_6) -> +	happyIn20+		 (do as <- sequence happy_var_5; doSwitch happy_var_2 happy_var_3 as happy_var_6+	) `HappyStk` happyRest}}}}++happyReduce_52 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_52 = happySpecReduce_3  16# happyReduction_52+happyReduction_52 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_53 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_53 = happyReduce 5# 16# happyReduction_53+happyReduction_53 (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_54 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_54 = happyReduce 4# 16# happyReduction_54+happyReduction_54 (happy_x_4 `HappyStk`+	happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest)+	 = case happyOut38 happy_x_2 of { (HappyWrap38 happy_var_2) -> +	case happyOut28 happy_x_3 of { (HappyWrap28 happy_var_3) -> +	happyIn20+		 (doRawJump happy_var_2 happy_var_3+	) `HappyStk` happyRest}}++happyReduce_55 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_55 = happyReduce 6# 16# happyReduction_55+happyReduction_55 (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 happyOut38 happy_x_2 of { (HappyWrap38 happy_var_2) -> +	case happyOut45 happy_x_4 of { (HappyWrap45 happy_var_4) -> +	happyIn20+		 (doJumpWithStack happy_var_2 [] happy_var_4+	) `HappyStk` happyRest}}++happyReduce_56 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_56 = happyReduce 9# 16# happyReduction_56+happyReduction_56 (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 happyOut38 happy_x_2 of { (HappyWrap38 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_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 happyOut38 happy_x_2 of { (HappyWrap38 happy_var_2) -> +	case happyOut45 happy_x_4 of { (HappyWrap45 happy_var_4) -> +	happyIn20+		 (doCall 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 10# 16# happyReduction_58+happyReduction_58 (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 happyOut38 happy_x_6 of { (HappyWrap38 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_59 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_59 = happyReduce 5# 16# happyReduction_59+happyReduction_59 (happy_x_5 `HappyStk`+	happy_x_4 `HappyStk`+	happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest)+	 = case happyOut25 happy_x_2 of { (HappyWrap25 happy_var_2) -> +	case happyOut37 happy_x_3 of { (HappyWrap37 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_60 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_60 = happyReduce 7# 16# happyReduction_60+happyReduction_60 (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 happyOut25 happy_x_2 of { (HappyWrap25 happy_var_2) -> +	case happyOut37 happy_x_3 of { (HappyWrap37 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 happyOut36 happy_x_7 of { (HappyWrap36 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_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 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_62 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_62 = happyReduce 5# 16# happyReduction_62+happyReduction_62 (happy_x_5 `HappyStk`+	happy_x_4 `HappyStk`+	happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest)+	 = case happyOut38 happy_x_2 of { (HappyWrap38 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_63 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_63 = happySpecReduce_3  16# happyReduction_63+happyReduction_63 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_64 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_64 = happyReduce 5# 17# 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 happyOutTok happy_x_1 of { (L _ (CmmT_GlobalReg   happy_var_1)) -> +	case happyOut22 happy_x_3 of { (HappyWrap22 happy_var_3) -> +	case happyOut21 happy_x_5 of { (HappyWrap21 happy_var_5) -> +	happyIn21+		 (do e <- happy_var_3; rest <- happy_var_5; return ((happy_var_1, e) : rest)+	) `HappyStk` happyRest}}}++happyReduce_65 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_65 = happySpecReduce_3  17# happyReduction_65+happyReduction_65 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_1 of { (L _ (CmmT_GlobalReg   happy_var_1)) -> +	case happyOut22 happy_x_3 of { (HappyWrap22 happy_var_3) -> +	happyIn21+		 (do e <- happy_var_3; return [(happy_var_1, e)]+	)}}++happyReduce_66 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_66 = happySpecReduce_1  18# happyReduction_66+happyReduction_66 happy_x_1+	 =  happyIn22+		 (do return Nothing+	)++happyReduce_67 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_67 = happySpecReduce_1  18# happyReduction_67+happyReduction_67 happy_x_1+	 =  case happyOut38 happy_x_1 of { (HappyWrap38 happy_var_1) -> +	happyIn22+		 (do e <- happy_var_1; return (Just e)+	)}++happyReduce_68 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_68 = happySpecReduce_1  19# happyReduction_68+happyReduction_68 happy_x_1+	 =  case happyOutTok happy_x_1 of { (L _ (CmmT_Name        happy_var_1)) -> +	happyIn23+		 (return (CmmLit (CmmLabel (mkForeignLabel happy_var_1 Nothing ForeignLabelInThisPackage IsFunction)))+	)}++happyReduce_69 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_69 = happySpecReduce_0  20# happyReduction_69+happyReduction_69  =  happyIn24+		 (CmmMayReturn+	)++happyReduce_70 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_70 = happySpecReduce_2  20# happyReduction_70+happyReduction_70 happy_x_2+	happy_x_1+	 =  happyIn24+		 (CmmNeverReturns+	)++happyReduce_71 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_71 = happySpecReduce_1  21# happyReduction_71+happyReduction_71 happy_x_1+	 =  case happyOut26 happy_x_1 of { (HappyWrap26 happy_var_1) -> +	happyIn25+		 (happy_var_1+	)}++happyReduce_72 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_72 = happySpecReduce_1  21# happyReduction_72+happyReduction_72 happy_x_1+	 =  case happyOut38 happy_x_1 of { (HappyWrap38 happy_var_1) -> +	happyIn25+		 (do e <- happy_var_1; return (BoolTest e)+	)}++happyReduce_73 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_73 = happySpecReduce_3  22# happyReduction_73+happyReduction_73 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut25 happy_x_1 of { (HappyWrap25 happy_var_1) -> +	case happyOut25 happy_x_3 of { (HappyWrap25 happy_var_3) -> +	happyIn26+		 (do e1 <- happy_var_1; e2 <- happy_var_3;+                                          return (BoolAnd e1 e2)+	)}}++happyReduce_74 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_74 = happySpecReduce_3  22# happyReduction_74+happyReduction_74 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut25 happy_x_1 of { (HappyWrap25 happy_var_1) -> +	case happyOut25 happy_x_3 of { (HappyWrap25 happy_var_3) -> +	happyIn26+		 (do e1 <- happy_var_1; e2 <- happy_var_3;+                                          return (BoolOr e1 e2)+	)}}++happyReduce_75 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_75 = happySpecReduce_2  22# happyReduction_75+happyReduction_75 happy_x_2+	happy_x_1+	 =  case happyOut25 happy_x_2 of { (HappyWrap25 happy_var_2) -> +	happyIn26+		 (do e <- happy_var_2; return (BoolNot e)+	)}++happyReduce_76 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_76 = happySpecReduce_3  22# happyReduction_76+happyReduction_76 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut26 happy_x_2 of { (HappyWrap26 happy_var_2) -> +	happyIn26+		 (happy_var_2+	)}++happyReduce_77 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_77 = happySpecReduce_0  23# happyReduction_77+happyReduction_77  =  happyIn27+		 (PlayRisky+	)++happyReduce_78 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_78 = happyMonadReduce 1# 23# happyReduction_78+happyReduction_78 (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 (happyIn27 r))++happyReduce_79 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_79 = happySpecReduce_2  24# happyReduction_79+happyReduction_79 happy_x_2+	happy_x_1+	 =  happyIn28+		 ([]+	)++happyReduce_80 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_80 = happyMonadReduce 3# 24# happyReduction_80+happyReduction_80 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((( do platform <- PD.getPlatform+                                         ; return (realArgRegsCover platform)))+	) (\r -> happyReturn (happyIn28 r))++happyReduce_81 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_81 = happySpecReduce_3  24# happyReduction_81+happyReduction_81 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut29 happy_x_2 of { (HappyWrap29 happy_var_2) -> +	happyIn28+		 (happy_var_2+	)}++happyReduce_82 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_82 = happySpecReduce_1  25# happyReduction_82+happyReduction_82 happy_x_1+	 =  case happyOutTok happy_x_1 of { (L _ (CmmT_GlobalReg   happy_var_1)) -> +	happyIn29+		 ([happy_var_1]+	)}++happyReduce_83 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_83 = happySpecReduce_3  25# happyReduction_83+happyReduction_83 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_1 of { (L _ (CmmT_GlobalReg   happy_var_1)) -> +	case happyOut29 happy_x_3 of { (HappyWrap29 happy_var_3) -> +	happyIn29+		 (happy_var_1 : happy_var_3+	)}}++happyReduce_84 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_84 = happyReduce 5# 26# happyReduction_84+happyReduction_84 (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)) -> +	happyIn30+		 (Just (happy_var_2, happy_var_4)+	) `HappyStk` happyRest}}++happyReduce_85 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_85 = happySpecReduce_0  26# happyReduction_85+happyReduction_85  =  happyIn30+		 (Nothing+	)++happyReduce_86 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_86 = happySpecReduce_0  27# happyReduction_86+happyReduction_86  =  happyIn31+		 ([]+	)++happyReduce_87 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_87 = happySpecReduce_2  27# happyReduction_87+happyReduction_87 happy_x_2+	happy_x_1+	 =  case happyOut32 happy_x_1 of { (HappyWrap32 happy_var_1) -> +	case happyOut31 happy_x_2 of { (HappyWrap31 happy_var_2) -> +	happyIn31+		 (happy_var_1 : happy_var_2+	)}}++happyReduce_88 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_88 = happyReduce 4# 28# happyReduction_88+happyReduction_88 (happy_x_4 `HappyStk`+	happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest)+	 = case happyOut34 happy_x_2 of { (HappyWrap34 happy_var_2) -> +	case happyOut33 happy_x_4 of { (HappyWrap33 happy_var_4) -> +	happyIn32+		 (do b <- happy_var_4; return (happy_var_2, b)+	) `HappyStk` happyRest}}++happyReduce_89 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_89 = happySpecReduce_3  29# happyReduction_89+happyReduction_89 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 -> +	happyIn33+		 (return (Right (withSourceNote happy_var_1 happy_var_3 happy_var_2))+	)}}}++happyReduce_90 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_90 = happySpecReduce_3  29# happyReduction_90+happyReduction_90 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_2 of { (L _ (CmmT_Name        happy_var_2)) -> +	happyIn33+		 (do l <- lookupLabel happy_var_2; return (Left l)+	)}++happyReduce_91 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_91 = happySpecReduce_1  30# happyReduction_91+happyReduction_91 happy_x_1+	 =  case happyOutTok happy_x_1 of { (L _ (CmmT_Int         happy_var_1)) -> +	happyIn34+		 ([ happy_var_1 ]+	)}++happyReduce_92 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_92 = happySpecReduce_3  30# happyReduction_92+happyReduction_92 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_1 of { (L _ (CmmT_Int         happy_var_1)) -> +	case happyOut34 happy_x_3 of { (HappyWrap34 happy_var_3) -> +	happyIn34+		 (happy_var_1 : happy_var_3+	)}}++happyReduce_93 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_93 = happyReduce 5# 31# happyReduction_93+happyReduction_93 (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 -> +	happyIn35+		 (Just (withSourceNote happy_var_3 happy_var_5 happy_var_4)+	) `HappyStk` happyRest}}}++happyReduce_94 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_94 = happySpecReduce_0  31# happyReduction_94+happyReduction_94  =  happyIn35+		 (Nothing+	)++happyReduce_95 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_95 = happySpecReduce_0  32# happyReduction_95+happyReduction_95  =  happyIn36+		 (return ()+	)++happyReduce_96 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_96 = happyReduce 4# 32# happyReduction_96+happyReduction_96 (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 -> +	happyIn36+		 (withSourceNote happy_var_2 happy_var_4 happy_var_3+	) `HappyStk` happyRest}}}++happyReduce_97 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_97 = happyReduce 5# 33# happyReduction_97+happyReduction_97 (happy_x_5 `HappyStk`+	happy_x_4 `HappyStk`+	happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest)+	 = happyIn37+		 (Just True+	) `HappyStk` happyRest++happyReduce_98 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_98 = happyReduce 5# 33# happyReduction_98+happyReduction_98 (happy_x_5 `HappyStk`+	happy_x_4 `HappyStk`+	happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest)+	 = happyIn37+		 (Just False+	) `HappyStk` happyRest++happyReduce_99 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_99 = happySpecReduce_0  33# happyReduction_99+happyReduction_99  =  happyIn37+		 (Nothing+	)++happyReduce_100 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_100 = happySpecReduce_3  34# happyReduction_100+happyReduction_100 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut38 happy_x_1 of { (HappyWrap38 happy_var_1) -> +	case happyOut38 happy_x_3 of { (HappyWrap38 happy_var_3) -> +	happyIn38+		 (mkMachOp MO_U_Quot [happy_var_1,happy_var_3]+	)}}++happyReduce_101 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_101 = happySpecReduce_3  34# happyReduction_101+happyReduction_101 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut38 happy_x_1 of { (HappyWrap38 happy_var_1) -> +	case happyOut38 happy_x_3 of { (HappyWrap38 happy_var_3) -> +	happyIn38+		 (mkMachOp MO_Mul [happy_var_1,happy_var_3]+	)}}++happyReduce_102 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_102 = happySpecReduce_3  34# happyReduction_102+happyReduction_102 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut38 happy_x_1 of { (HappyWrap38 happy_var_1) -> +	case happyOut38 happy_x_3 of { (HappyWrap38 happy_var_3) -> +	happyIn38+		 (mkMachOp MO_U_Rem [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 = happySpecReduce_3  34# happyReduction_103+happyReduction_103 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut38 happy_x_1 of { (HappyWrap38 happy_var_1) -> +	case happyOut38 happy_x_3 of { (HappyWrap38 happy_var_3) -> +	happyIn38+		 (mkMachOp MO_Sub [happy_var_1,happy_var_3]+	)}}++happyReduce_104 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_104 = happySpecReduce_3  34# happyReduction_104+happyReduction_104 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut38 happy_x_1 of { (HappyWrap38 happy_var_1) -> +	case happyOut38 happy_x_3 of { (HappyWrap38 happy_var_3) -> +	happyIn38+		 (mkMachOp MO_Add [happy_var_1,happy_var_3]+	)}}++happyReduce_105 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_105 = happySpecReduce_3  34# happyReduction_105+happyReduction_105 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut38 happy_x_1 of { (HappyWrap38 happy_var_1) -> +	case happyOut38 happy_x_3 of { (HappyWrap38 happy_var_3) -> +	happyIn38+		 (mkMachOp MO_U_Shr [happy_var_1,happy_var_3]+	)}}++happyReduce_106 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_106 = happySpecReduce_3  34# happyReduction_106+happyReduction_106 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut38 happy_x_1 of { (HappyWrap38 happy_var_1) -> +	case happyOut38 happy_x_3 of { (HappyWrap38 happy_var_3) -> +	happyIn38+		 (mkMachOp MO_Shl [happy_var_1,happy_var_3]+	)}}++happyReduce_107 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_107 = happySpecReduce_3  34# happyReduction_107+happyReduction_107 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut38 happy_x_1 of { (HappyWrap38 happy_var_1) -> +	case happyOut38 happy_x_3 of { (HappyWrap38 happy_var_3) -> +	happyIn38+		 (mkMachOp MO_And [happy_var_1,happy_var_3]+	)}}++happyReduce_108 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_108 = happySpecReduce_3  34# happyReduction_108+happyReduction_108 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut38 happy_x_1 of { (HappyWrap38 happy_var_1) -> +	case happyOut38 happy_x_3 of { (HappyWrap38 happy_var_3) -> +	happyIn38+		 (mkMachOp MO_Xor [happy_var_1,happy_var_3]+	)}}++happyReduce_109 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_109 = happySpecReduce_3  34# happyReduction_109+happyReduction_109 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut38 happy_x_1 of { (HappyWrap38 happy_var_1) -> +	case happyOut38 happy_x_3 of { (HappyWrap38 happy_var_3) -> +	happyIn38+		 (mkMachOp MO_Or [happy_var_1,happy_var_3]+	)}}++happyReduce_110 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_110 = happySpecReduce_3  34# happyReduction_110+happyReduction_110 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut38 happy_x_1 of { (HappyWrap38 happy_var_1) -> +	case happyOut38 happy_x_3 of { (HappyWrap38 happy_var_3) -> +	happyIn38+		 (mkMachOp MO_U_Ge [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  34# happyReduction_111+happyReduction_111 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut38 happy_x_1 of { (HappyWrap38 happy_var_1) -> +	case happyOut38 happy_x_3 of { (HappyWrap38 happy_var_3) -> +	happyIn38+		 (mkMachOp MO_U_Gt [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  34# happyReduction_112+happyReduction_112 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut38 happy_x_1 of { (HappyWrap38 happy_var_1) -> +	case happyOut38 happy_x_3 of { (HappyWrap38 happy_var_3) -> +	happyIn38+		 (mkMachOp MO_U_Le [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  34# happyReduction_113+happyReduction_113 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut38 happy_x_1 of { (HappyWrap38 happy_var_1) -> +	case happyOut38 happy_x_3 of { (HappyWrap38 happy_var_3) -> +	happyIn38+		 (mkMachOp MO_U_Lt [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  34# happyReduction_114+happyReduction_114 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut38 happy_x_1 of { (HappyWrap38 happy_var_1) -> +	case happyOut38 happy_x_3 of { (HappyWrap38 happy_var_3) -> +	happyIn38+		 (mkMachOp MO_Ne [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  34# happyReduction_115+happyReduction_115 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut38 happy_x_1 of { (HappyWrap38 happy_var_1) -> +	case happyOut38 happy_x_3 of { (HappyWrap38 happy_var_3) -> +	happyIn38+		 (mkMachOp MO_Eq [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_2  34# happyReduction_116+happyReduction_116 happy_x_2+	happy_x_1+	 =  case happyOut38 happy_x_2 of { (HappyWrap38 happy_var_2) -> +	happyIn38+		 (mkMachOp MO_Not [happy_var_2]+	)}++happyReduce_117 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_117 = happySpecReduce_2  34# happyReduction_117+happyReduction_117 happy_x_2+	happy_x_1+	 =  case happyOut38 happy_x_2 of { (HappyWrap38 happy_var_2) -> +	happyIn38+		 (mkMachOp MO_S_Neg [happy_var_2]+	)}++happyReduce_118 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_118 = happyMonadReduce 5# 34# happyReduction_118+happyReduction_118 (happy_x_5 `HappyStk`+	happy_x_4 `HappyStk`+	happy_x_3 `HappyStk`+	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_3 of { (L _ (CmmT_Name        happy_var_3)) -> +	case happyOut39 happy_x_5 of { (HappyWrap39 happy_var_5) -> +	( do { mo <- nameToMachOp happy_var_3 ;+                                                return (mkMachOp mo [happy_var_1,happy_var_5]) })}}})+	) (\r -> happyReturn (happyIn38 r))++happyReduce_119 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_119 = happySpecReduce_1  34# happyReduction_119+happyReduction_119 happy_x_1+	 =  case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> +	happyIn38+		 (happy_var_1+	)}++happyReduce_120 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_120 = happySpecReduce_2  35# happyReduction_120+happyReduction_120 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) -> +	happyIn39+		 (return (CmmLit (CmmInt happy_var_1 (typeWidth happy_var_2)))+	)}}++happyReduce_121 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_121 = happySpecReduce_2  35# happyReduction_121+happyReduction_121 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) -> +	happyIn39+		 (return (CmmLit (CmmFloat happy_var_1 (typeWidth happy_var_2)))+	)}}++happyReduce_122 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_122 = happySpecReduce_1  35# happyReduction_122+happyReduction_122 happy_x_1+	 =  case happyOutTok happy_x_1 of { (L _ (CmmT_String      happy_var_1)) -> +	happyIn39+		 (do s <- code (newStringCLit happy_var_1);+                                      return (CmmLit s)+	)}++happyReduce_123 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_123 = happySpecReduce_1  35# happyReduction_123+happyReduction_123 happy_x_1+	 =  case happyOut47 happy_x_1 of { (HappyWrap47 happy_var_1) -> +	happyIn39+		 (happy_var_1+	)}++happyReduce_124 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_124 = happySpecReduce_2  35# happyReduction_124+happyReduction_124 happy_x_2+	happy_x_1+	 =  case happyOut57 happy_x_1 of { (HappyWrap57 happy_var_1) -> +	case happyOut40 happy_x_2 of { (HappyWrap40 happy_var_2) -> +	happyIn39+		 (do (align, ptr) <- happy_var_2; return (CmmLoad ptr happy_var_1 align)+	)}}++happyReduce_125 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_125 = happyMonadReduce 5# 35# happyReduction_125+happyReduction_125 (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 (happyIn39 r))++happyReduce_126 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_126 = happySpecReduce_3  35# happyReduction_126+happyReduction_126 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut38 happy_x_2 of { (HappyWrap38 happy_var_2) -> +	happyIn39+		 (happy_var_2+	)}++happyReduce_127 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_127 = happyReduce 4# 36# happyReduction_127+happyReduction_127 (happy_x_4 `HappyStk`+	happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest)+	 = case happyOut38 happy_x_3 of { (HappyWrap38 happy_var_3) -> +	happyIn40+		 (do ptr <- happy_var_3; return (Unaligned, ptr)+	) `HappyStk` happyRest}++happyReduce_128 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_128 = happySpecReduce_3  36# happyReduction_128+happyReduction_128 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut38 happy_x_2 of { (HappyWrap38 happy_var_2) -> +	happyIn40+		 (do ptr <- happy_var_2; return (NaturallyAligned, ptr)+	)}++happyReduce_129 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_129 = happyMonadReduce 0# 37# happyReduction_129+happyReduction_129 (happyRest) tk+	 = happyThen ((( do platform <- PD.getPlatform; return $ bWord platform))+	) (\r -> happyReturn (happyIn41 r))++happyReduce_130 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_130 = happySpecReduce_2  37# happyReduction_130+happyReduction_130 happy_x_2+	happy_x_1+	 =  case happyOut57 happy_x_2 of { (HappyWrap57 happy_var_2) -> +	happyIn41+		 (happy_var_2+	)}++happyReduce_131 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_131 = happySpecReduce_0  38# happyReduction_131+happyReduction_131  =  happyIn42+		 ([]+	)++happyReduce_132 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_132 = happySpecReduce_1  38# happyReduction_132+happyReduction_132 happy_x_1+	 =  case happyOut43 happy_x_1 of { (HappyWrap43 happy_var_1) -> +	happyIn42+		 (happy_var_1+	)}++happyReduce_133 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_133 = happySpecReduce_1  39# happyReduction_133+happyReduction_133 happy_x_1+	 =  case happyOut44 happy_x_1 of { (HappyWrap44 happy_var_1) -> +	happyIn43+		 ([happy_var_1]+	)}++happyReduce_134 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_134 = happySpecReduce_3  39# happyReduction_134+happyReduction_134 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_135 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_135 = happySpecReduce_1  40# happyReduction_135+happyReduction_135 happy_x_1+	 =  case happyOut38 happy_x_1 of { (HappyWrap38 happy_var_1) -> +	happyIn44+		 (do e <- happy_var_1;+                                             return (e, inferCmmHint e)+	)}++happyReduce_136 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_136 = happyMonadReduce 2# 40# happyReduction_136+happyReduction_136 (happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut38 happy_x_1 of { (HappyWrap38 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_137 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_137 = happySpecReduce_0  41# happyReduction_137+happyReduction_137  =  happyIn45+		 ([]+	)++happyReduce_138 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_138 = happySpecReduce_1  41# happyReduction_138+happyReduction_138 happy_x_1+	 =  case happyOut46 happy_x_1 of { (HappyWrap46 happy_var_1) -> +	happyIn45+		 (happy_var_1+	)}++happyReduce_139 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_139 = happySpecReduce_1  42# happyReduction_139+happyReduction_139 happy_x_1+	 =  case happyOut38 happy_x_1 of { (HappyWrap38 happy_var_1) -> +	happyIn46+		 ([ happy_var_1 ]+	)}++happyReduce_140 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_140 = happySpecReduce_3  42# happyReduction_140+happyReduction_140 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut38 happy_x_1 of { (HappyWrap38 happy_var_1) -> +	case happyOut46 happy_x_3 of { (HappyWrap46 happy_var_3) -> +	happyIn46+		 (happy_var_1 : happy_var_3+	)}}++happyReduce_141 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_141 = happySpecReduce_1  43# happyReduction_141+happyReduction_141 happy_x_1+	 =  case happyOutTok happy_x_1 of { (L _ (CmmT_Name        happy_var_1)) -> +	happyIn47+		 (lookupName happy_var_1+	)}++happyReduce_142 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_142 = happySpecReduce_1  43# happyReduction_142+happyReduction_142 happy_x_1+	 =  case happyOutTok happy_x_1 of { (L _ (CmmT_GlobalReg   happy_var_1)) -> +	happyIn47+		 (return (CmmReg (CmmGlobal happy_var_1))+	)}++happyReduce_143 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_143 = happySpecReduce_0  44# happyReduction_143+happyReduction_143  =  happyIn48+		 ([]+	)++happyReduce_144 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_144 = happyReduce 4# 44# happyReduction_144+happyReduction_144 (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_145 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_145 = happySpecReduce_1  45# happyReduction_145+happyReduction_145 happy_x_1+	 =  case happyOut50 happy_x_1 of { (HappyWrap50 happy_var_1) -> +	happyIn49+		 ([happy_var_1]+	)}++happyReduce_146 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_146 = happySpecReduce_2  45# happyReduction_146+happyReduction_146 happy_x_2+	happy_x_1+	 =  case happyOut50 happy_x_1 of { (HappyWrap50 happy_var_1) -> +	happyIn49+		 ([happy_var_1]+	)}++happyReduce_147 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_147 = happySpecReduce_3  45# happyReduction_147+happyReduction_147 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_148 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_148 = happySpecReduce_1  46# happyReduction_148+happyReduction_148 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_149 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_149 = happyMonadReduce 2# 46# happyReduction_149+happyReduction_149 (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_150 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_150 = happySpecReduce_1  47# happyReduction_150+happyReduction_150 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_151 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_151 = happySpecReduce_1  48# happyReduction_151+happyReduction_151 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_152 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_152 = happySpecReduce_1  48# happyReduction_152+happyReduction_152 happy_x_1+	 =  case happyOutTok happy_x_1 of { (L _ (CmmT_GlobalReg   happy_var_1)) -> +	happyIn52+		 (return (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  49# happyReduction_153+happyReduction_153  =  happyIn53+		 (Nothing+	)++happyReduce_154 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_154 = happySpecReduce_3  49# happyReduction_154+happyReduction_154 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_155 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_155 = happySpecReduce_0  50# happyReduction_155+happyReduction_155  =  happyIn54+		 ([]+	)++happyReduce_156 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_156 = happySpecReduce_1  50# happyReduction_156+happyReduction_156 happy_x_1+	 =  case happyOut55 happy_x_1 of { (HappyWrap55 happy_var_1) -> +	happyIn54+		 (happy_var_1+	)}++happyReduce_157 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_157 = happySpecReduce_2  51# happyReduction_157+happyReduction_157 happy_x_2+	happy_x_1+	 =  case happyOut56 happy_x_1 of { (HappyWrap56 happy_var_1) -> +	happyIn55+		 ([happy_var_1]+	)}++happyReduce_158 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_158 = happySpecReduce_1  51# happyReduction_158+happyReduction_158 happy_x_1+	 =  case happyOut56 happy_x_1 of { (HappyWrap56 happy_var_1) -> +	happyIn55+		 ([happy_var_1]+	)}++happyReduce_159 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_159 = happySpecReduce_3  51# happyReduction_159+happyReduction_159 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_160 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_160 = happySpecReduce_2  52# happyReduction_160+happyReduction_160 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_161 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_161 = happySpecReduce_1  53# happyReduction_161+happyReduction_161 happy_x_1+	 =  happyIn57+		 (b8+	)++happyReduce_162 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_162 = happySpecReduce_1  53# happyReduction_162+happyReduction_162 happy_x_1+	 =  case happyOut58 happy_x_1 of { (HappyWrap58 happy_var_1) -> +	happyIn57+		 (happy_var_1+	)}++happyReduce_163 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_163 = happySpecReduce_1  54# happyReduction_163+happyReduction_163 happy_x_1+	 =  happyIn58+		 (b16+	)++happyReduce_164 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_164 = happySpecReduce_1  54# happyReduction_164+happyReduction_164 happy_x_1+	 =  happyIn58+		 (b32+	)++happyReduce_165 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_165 = happySpecReduce_1  54# happyReduction_165+happyReduction_165 happy_x_1+	 =  happyIn58+		 (b64+	)++happyReduce_166 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_166 = happySpecReduce_1  54# happyReduction_166+happyReduction_166 happy_x_1+	 =  happyIn58+		 (b128+	)++happyReduce_167 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_167 = happySpecReduce_1  54# happyReduction_167+happyReduction_167 happy_x_1+	 =  happyIn58+		 (b256+	)++happyReduce_168 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_168 = happySpecReduce_1  54# happyReduction_168+happyReduction_168 happy_x_1+	 =  happyIn58+		 (b512+	)++happyReduce_169 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_169 = happySpecReduce_1  54# happyReduction_169+happyReduction_169 happy_x_1+	 =  happyIn58+		 (f32+	)++happyReduce_170 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_170 = happySpecReduce_1  54# happyReduction_170+happyReduction_170 happy_x_1+	 =  happyIn58+		 (f64+	)++happyReduce_171 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_171 = happyMonadReduce 1# 54# happyReduction_171+happyReduction_171 (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 77# 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_CLOSURE) -> cont 37#;+	L _ (CmmT_INFO_TABLE) -> cont 38#;+	L _ (CmmT_INFO_TABLE_RET) -> cont 39#;+	L _ (CmmT_INFO_TABLE_FUN) -> cont 40#;+	L _ (CmmT_INFO_TABLE_CONSTR) -> cont 41#;+	L _ (CmmT_INFO_TABLE_SELECTOR) -> cont 42#;+	L _ (CmmT_else) -> cont 43#;+	L _ (CmmT_export) -> cont 44#;+	L _ (CmmT_section) -> cont 45#;+	L _ (CmmT_goto) -> cont 46#;+	L _ (CmmT_if) -> cont 47#;+	L _ (CmmT_call) -> cont 48#;+	L _ (CmmT_jump) -> cont 49#;+	L _ (CmmT_foreign) -> cont 50#;+	L _ (CmmT_never) -> cont 51#;+	L _ (CmmT_prim) -> cont 52#;+	L _ (CmmT_reserve) -> cont 53#;+	L _ (CmmT_return) -> cont 54#;+	L _ (CmmT_returns) -> cont 55#;+	L _ (CmmT_import) -> cont 56#;+	L _ (CmmT_switch) -> cont 57#;+	L _ (CmmT_case) -> cont 58#;+	L _ (CmmT_default) -> cont 59#;+	L _ (CmmT_push) -> cont 60#;+	L _ (CmmT_unwind) -> cont 61#;+	L _ (CmmT_bits8) -> cont 62#;+	L _ (CmmT_bits16) -> cont 63#;+	L _ (CmmT_bits32) -> cont 64#;+	L _ (CmmT_bits64) -> cont 65#;+	L _ (CmmT_bits128) -> cont 66#;+	L _ (CmmT_bits256) -> cont 67#;+	L _ (CmmT_bits512) -> cont 68#;+	L _ (CmmT_float32) -> cont 69#;+	L _ (CmmT_float64) -> cont 70#;+	L _ (CmmT_gcptr) -> cont 71#;+	L _ (CmmT_GlobalReg   happy_dollar_dollar) -> cont 72#;+	L _ (CmmT_Name        happy_dollar_dollar) -> cont 73#;+	L _ (CmmT_String      happy_dollar_dollar) -> cont 74#;+	L _ (CmmT_Int         happy_dollar_dollar) -> cont 75#;+	L _ (CmmT_Float       happy_dollar_dollar) -> cont 76#;+	_ -> happyError' (tk, [])+	})++happyError_ explist 77# 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+  profile     <- PD.getProfile+  align_check <- gopt Opt_AlignmentSanitisation <$> getDynFlags+  case lookupUFM (exprMacros profile align_check) name of+     Just f  -> return $ do+        args <- sequence args_code+        return (f args)+     Nothing -> do+        mo <- nameToMachOp name+        return $ mkMachOp mo args_code++exprMacros :: Profile -> DoAlignSanitisation -> UniqFM FastString ([CmmExpr] -> CmmExpr)+exprMacros profile align_check = listToUFM [+  ( fsLit "ENTRY_CODE",   \ [x] -> entryCode platform x ),+  ( fsLit "INFO_PTR",     \ [x] -> closureInfoPtr platform align_check x ),+  ( fsLit "STD_INFO",     \ [x] -> infoTable    profile x ),+  ( fsLit "FUN_INFO",     \ [x] -> funInfoTable profile x ),+  ( fsLit "GET_ENTRY",    \ [x] -> entryCode platform   (closureInfoPtr platform align_check x) ),+  ( fsLit "GET_STD_INFO", \ [x] -> infoTable profile    (closureInfoPtr platform align_check x) ),+  ( fsLit "GET_FUN_INFO", \ [x] -> funInfoTable profile (closureInfoPtr platform align_check x) ),+  ( fsLit "INFO_TYPE",    \ [x] -> infoTableClosureType profile x ),+  ( fsLit "INFO_PTRS",    \ [x] -> infoTablePtrs profile x ),+  ( fsLit "INFO_NPTRS",   \ [x] -> infoTableNonPtrs profile x )+  ]+  where+    platform = profilePlatform profile++-- we understand a subset of C-- primitives:+machOps = listToUFM $+        map (\(x, y) -> (mkFastString x, y)) [+        ( "add",        MO_Add ),+        ( "sub",        MO_Sub ),+        ( "eq",         MO_Eq ),+        ( "ne",         MO_Ne ),+        ( "mul",        MO_Mul ),+        ( "mulmayoflo",  MO_S_MulMayOflo ),+        ( "mulmayoflou", MO_U_MulMayOflo ),+        ( "neg",        MO_S_Neg ),+        ( "quot",       MO_S_Quot ),+        ( "rem",        MO_S_Rem ),+        ( "divu",       MO_U_Quot ),+        ( "modu",       MO_U_Rem ),++        ( "ge",         MO_S_Ge ),+        ( "le",         MO_S_Le ),+        ( "gt",         MO_S_Gt ),+        ( "lt",         MO_S_Lt ),++        ( "geu",        MO_U_Ge ),+        ( "leu",        MO_U_Le ),+        ( "gtu",        MO_U_Gt ),+        ( "ltu",        MO_U_Lt ),++        ( "and",        MO_And ),+        ( "or",         MO_Or ),+        ( "xor",        MO_Xor ),+        ( "com",        MO_Not ),+        ( "shl",        MO_Shl ),+        ( "shrl",       MO_U_Shr ),+        ( "shra",       MO_S_Shr ),++        ( "fadd",       MO_F_Add ),+        ( "fsub",       MO_F_Sub ),+        ( "fneg",       MO_F_Neg ),+        ( "fmul",       MO_F_Mul ),+        ( "fquot",      MO_F_Quot ),++        ( "feq",        MO_F_Eq ),+        ( "fne",        MO_F_Ne ),+        ( "fge",        MO_F_Ge ),+        ( "fle",        MO_F_Le ),+        ( "fgt",        MO_F_Gt ),+        ( "flt",        MO_F_Lt ),++        ( "lobits8",  flip MO_UU_Conv W8  ),+        ( "lobits16", flip MO_UU_Conv W16 ),+        ( "lobits32", flip MO_UU_Conv W32 ),+        ( "lobits64", flip MO_UU_Conv W64 ),++        ( "zx16",     flip MO_UU_Conv W16 ),+        ( "zx32",     flip MO_UU_Conv W32 ),+        ( "zx64",     flip MO_UU_Conv W64 ),++        ( "sx16",     flip MO_SS_Conv W16 ),+        ( "sx32",     flip MO_SS_Conv W32 ),+        ( "sx64",     flip MO_SS_Conv W64 ),++        ( "f2f32",    flip MO_FF_Conv W32 ),  -- TODO; rounding mode+        ( "f2f64",    flip MO_FF_Conv W64 ),  -- TODO; rounding mode+        ( "f2i8",     flip MO_FS_Conv W8 ),+        ( "f2i16",    flip MO_FS_Conv W16 ),+        ( "f2i32",    flip MO_FS_Conv W32 ),+        ( "f2i64",    flip MO_FS_Conv W64 ),+        ( "i2f32",    flip MO_SF_Conv W32 ),+        ( "i2f64",    flip MO_SF_Conv W64 )+        ]++callishMachOps :: Platform -> UniqFM FastString ([CmmExpr] -> (CallishMachOp, [CmmExpr]))+callishMachOps platform = listToUFM $+        map (\(x, y) -> (mkFastString x, y)) [++        ( "pow64f", (MO_F64_Pwr,) ),+        ( "sin64f", (MO_F64_Sin,) ),+        ( "cos64f", (MO_F64_Cos,) ),+        ( "tan64f", (MO_F64_Tan,) ),+        ( "sinh64f", (MO_F64_Sinh,) ),+        ( "cosh64f", (MO_F64_Cosh,) ),+        ( "tanh64f", (MO_F64_Tanh,) ),+        ( "asin64f", (MO_F64_Asin,) ),+        ( "acos64f", (MO_F64_Acos,) ),+        ( "atan64f", (MO_F64_Atan,) ),+        ( "asinh64f", (MO_F64_Asinh,) ),+        ( "acosh64f", (MO_F64_Acosh,) ),+        ( "log64f", (MO_F64_Log,) ),+        ( "log1p64f", (MO_F64_Log1P,) ),+        ( "exp64f", (MO_F64_Exp,) ),+        ( "expM164f", (MO_F64_ExpM1,) ),+        ( "fabs64f", (MO_F64_Fabs,) ),+        ( "sqrt64f", (MO_F64_Sqrt,) ),++        ( "pow32f", (MO_F32_Pwr,) ),+        ( "sin32f", (MO_F32_Sin,) ),+        ( "cos32f", (MO_F32_Cos,) ),+        ( "tan32f", (MO_F32_Tan,) ),+        ( "sinh32f", (MO_F32_Sinh,) ),+        ( "cosh32f", (MO_F32_Cosh,) ),+        ( "tanh32f", (MO_F32_Tanh,) ),+        ( "asin32f", (MO_F32_Asin,) ),+        ( "acos32f", (MO_F32_Acos,) ),+        ( "atan32f", (MO_F32_Atan,) ),+        ( "asinh32f", (MO_F32_Asinh,) ),+        ( "acosh32f", (MO_F32_Acosh,) ),+        ( "log32f", (MO_F32_Log,) ),+        ( "log1p32f", (MO_F32_Log1P,) ),+        ( "exp32f", (MO_F32_Exp,) ),+        ( "expM132f", (MO_F32_ExpM1,) ),+        ( "fabs32f", (MO_F32_Fabs,) ),+        ( "sqrt32f", (MO_F32_Sqrt,) ),++        ( "read_barrier", (MO_ReadBarrier,)),+        ( "write_barrier", (MO_WriteBarrier,)),+        ( "memcpy", memcpyLikeTweakArgs MO_Memcpy ),+        ( "memset", memcpyLikeTweakArgs MO_Memset ),+        ( "memmove", memcpyLikeTweakArgs MO_Memmove ),+        ( "memcmp", memcpyLikeTweakArgs MO_Memcmp ),++        ( "suspendThread", (MO_SuspendThread,) ),+        ( "resumeThread",  (MO_ResumeThread,) ),++        ("prefetch0", (MO_Prefetch_Data 0,)),+        ("prefetch1", (MO_Prefetch_Data 1,)),+        ("prefetch2", (MO_Prefetch_Data 2,)),+        ("prefetch3", (MO_Prefetch_Data 3,)),++        ( "popcnt8",  (MO_PopCnt W8,)),+        ( "popcnt16", (MO_PopCnt W16,)),+        ( "popcnt32", (MO_PopCnt W32,)),+        ( "popcnt64", (MO_PopCnt W64,)),++        ( "pdep8",  (MO_Pdep W8,)),+        ( "pdep16", (MO_Pdep W16,)),+        ( "pdep32", (MO_Pdep W32,)),+        ( "pdep64", (MO_Pdep W64,)),++        ( "pext8",  (MO_Pext W8,)),+        ( "pext16", (MO_Pext W16,)),+        ( "pext32", (MO_Pext W32,)),+        ( "pext64", (MO_Pext W64,)),++        ( "cmpxchg8",  (MO_Cmpxchg W8,)),+        ( "cmpxchg16", (MO_Cmpxchg W16,)),+        ( "cmpxchg32", (MO_Cmpxchg W32,)),+        ( "cmpxchg64", (MO_Cmpxchg W64,)),++        ( "xchg8",  (MO_Xchg W8,)),+        ( "xchg16", (MO_Xchg W16,)),+        ( "xchg32", (MO_Xchg W32,)),+        ( "xchg64", (MO_Xchg W64,))+    ]+  where+    memcpyLikeTweakArgs :: (Int -> CallishMachOp) -> [CmmExpr] -> (CallishMachOp, [CmmExpr])+    memcpyLikeTweakArgs op [] = pgmError "memcpy-like function requires at least one argument"+    memcpyLikeTweakArgs op args@(_:_) =+        (op align, args')+      where+        args' = init args+        align = case last args of+          CmmLit (CmmInt alignInteger _) -> fromInteger alignInteger+          e -> pgmErrorDoc "Non-constant alignment in memcpy-like function:" (pdoc platform e)+        -- The alignment of memcpy-ish operations must be a+        -- compile-time constant. We verify this here, passing it around+        -- in the MO_* constructor. In order to do this, however, we+        -- must intercept the arguments in primCall.++parseSafety :: String -> PD Safety+parseSafety "safe"   = return PlaySafe+parseSafety "unsafe" = return PlayRisky+parseSafety "interruptible" = return PlayInterruptible+parseSafety str      = failMsgPD $ \span -> mkPlainErrorMsgEnvelope span $+                                              PsErrCmmParser (CmmUnrecognisedSafety str)++parseCmmHint :: String -> PD ForeignHint+parseCmmHint "ptr"    = return AddrHint+parseCmmHint "signed" = return SignedHint+parseCmmHint str      = failMsgPD $ \span -> mkPlainErrorMsgEnvelope span $+                                               PsErrCmmParser (CmmUnrecognisedHint str)++-- labels are always pointers, so we might as well infer the hint+inferCmmHint :: CmmExpr -> ForeignHint+inferCmmHint (CmmLit (CmmLabel _)) = AddrHint+inferCmmHint (CmmReg (CmmGlobal g)) | isPtrGlobalReg g = AddrHint+inferCmmHint _ = NoHint++isPtrGlobalReg Sp                    = True+isPtrGlobalReg SpLim                 = True+isPtrGlobalReg Hp                    = True+isPtrGlobalReg HpLim                 = True+isPtrGlobalReg CCCS                  = True+isPtrGlobalReg CurrentTSO            = True+isPtrGlobalReg CurrentNursery        = True+isPtrGlobalReg (VanillaReg _ VGcPtr) = True+isPtrGlobalReg _                     = False++happyError :: PD a+happyError = PD $ \_ _ s -> unP srcParseFail s++-- -----------------------------------------------------------------------------+-- Statement-level macros++stmtMacro :: FastString -> [CmmParse CmmExpr] -> PD (CmmParse ())+stmtMacro fun args_code = do+  case lookupUFM stmtMacros fun of+    Nothing -> failMsgPD $ \span -> mkPlainErrorMsgEnvelope span $ PsErrCmmParser (CmmUnknownMacro fun)+    Just fcode -> return $ do+        args <- sequence args_code+        code (fcode args)++stmtMacros :: UniqFM FastString ([CmmExpr] -> FCode ())+stmtMacros = listToUFM [+  ( fsLit "CCS_ALLOC",             \[words,ccs]  -> profAlloc words ccs ),+  ( fsLit "ENTER_CCS_THUNK",       \[e] -> enterCostCentreThunk e ),++  ( fsLit "CLOSE_NURSERY",         \[]  -> emitCloseNursery ),+  ( fsLit "OPEN_NURSERY",          \[]  -> emitOpenNursery ),++  -- completely generic heap and stack checks, for use in high-level cmm.+  ( fsLit "HP_CHK_GEN",            \[bytes] ->+                                      heapStackCheckGen Nothing (Just bytes) ),+  ( fsLit "STK_CHK_GEN",           \[] ->+                                      heapStackCheckGen (Just (CmmLit CmmHighStackMark)) Nothing ),++  -- A stack check for a fixed amount of stack.  Sounds a bit strange, but+  -- we use the stack for a bit of temporary storage in a couple of primops+  ( fsLit "STK_CHK_GEN_N",         \[bytes] ->+                                      heapStackCheckGen (Just bytes) Nothing ),++  -- A stack check on entry to a thunk, where the argument is the thunk pointer.+  ( fsLit "STK_CHK_NP"   ,         \[node] -> entryHeapCheck' False node 0 [] (return ())),++  ( fsLit "LOAD_THREAD_STATE",     \[] -> emitLoadThreadState ),+  ( fsLit "SAVE_THREAD_STATE",     \[] -> emitSaveThreadState ),++  ( fsLit "SAVE_REGS",             \[] -> emitSaveRegs ),+  ( fsLit "RESTORE_REGS",          \[] -> emitRestoreRegs ),++  ( fsLit "PUSH_TUPLE_REGS",      \[live_regs] -> emitPushTupleRegs live_regs ),+  ( fsLit "POP_TUPLE_REGS",       \[live_regs] -> emitPopTupleRegs live_regs ),++  ( fsLit "LDV_ENTER",             \[e] -> ldvEnter e ),+  ( fsLit "LDV_RECORD_CREATE",     \[e] -> ldvRecordCreate e ),++  ( fsLit "PUSH_UPD_FRAME",        \[sp,e] -> emitPushUpdateFrame sp e ),+  ( fsLit "SET_HDR",               \[ptr,info,ccs] ->+                                        emitSetDynHdr ptr info ccs ),+  ( fsLit "TICK_ALLOC_PRIM",       \[hdr,goods,slop] ->+                                        tickyAllocPrim hdr goods slop ),+  ( fsLit "TICK_ALLOC_PAP",        \[goods,slop] ->+                                        tickyAllocPAP goods slop ),+  ( fsLit "TICK_ALLOC_UP_THK",     \[goods,slop] ->+                                        tickyAllocThunk goods slop ),+  ( fsLit "UPD_BH_UPDATABLE",      \[reg] -> emitBlackHoleCode reg )+ ]++emitPushUpdateFrame :: CmmExpr -> CmmExpr -> FCode ()+emitPushUpdateFrame sp e = do+  emitUpdateFrame sp mkUpdInfoLabel e++pushStackFrame :: [CmmParse CmmExpr] -> CmmParse () -> CmmParse ()+pushStackFrame fields body = do+  profile <- getProfile+  exprs <- sequence fields+  updfr_off <- getUpdFrameOff+  let (new_updfr_off, _, g) = copyOutOflow profile NativeReturn Ret Old+                                           [] updfr_off exprs+  emit g+  withUpdFrameOff new_updfr_off body++reserveStackFrame+  :: CmmParse CmmExpr+  -> CmmParse CmmReg+  -> CmmParse ()+  -> CmmParse ()+reserveStackFrame psize preg body = do+  platform <- getPlatform+  old_updfr_off <- getUpdFrameOff+  reg <- preg+  esize <- psize+  let size = case constantFoldExpr platform esize of+               CmmLit (CmmInt n _) -> n+               _other -> pprPanic "CmmParse: not a compile-time integer: "+                            (pdoc platform esize)+  let frame = old_updfr_off + platformWordSizeInBytes platform * fromIntegral size+  emitAssign reg (CmmStackSlot Old frame)+  withUpdFrameOff frame body++profilingInfo profile desc_str ty_str+  = if not (profileIsProfiling profile)+    then NoProfilingInfo+    else ProfilingInfo (BS8.pack desc_str) (BS8.pack ty_str)++staticClosure :: UnitId -> FastString -> FastString -> [CmmLit] -> CmmParse ()+staticClosure pkg cl_label info payload+  = do profile <- getProfile+       let lits = mkStaticClosure profile (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] []+       code $ emitDataLits (mkCmmDataLabel pkg (NeedExternDecl True) cl_label) lits++foreignCall+        :: String+        -> [CmmParse (LocalReg, ForeignHint)]+        -> CmmParse CmmExpr+        -> [CmmParse (CmmExpr, ForeignHint)]+        -> Safety+        -> CmmReturnInfo+        -> PD (CmmParse ())+foreignCall conv_string results_code expr_code args_code safety ret+  = do  conv <- case conv_string of+          "C"       -> return CCallConv+          "stdcall" -> return StdCallConv+          _         -> failMsgPD $ \span -> mkPlainErrorMsgEnvelope span $+                                              PsErrCmmParser (CmmUnknownCConv conv_string)+        return $ do+          platform <- getPlatform+          results <- sequence results_code+          expr <- expr_code+          args <- sequence args_code+          let+                  expr' = adjCallTarget platform conv expr args+                  (arg_exprs, arg_hints) = unzip args+                  (res_regs,  res_hints) = unzip results+                  fc = ForeignConvention conv arg_hints res_hints ret+                  target = ForeignTarget expr' fc+          _ <- code $ emitForeignCall safety res_regs target arg_exprs+          return ()+++doReturn :: [CmmParse CmmExpr] -> CmmParse ()+doReturn exprs_code = do+  profile <- getProfile+  exprs <- sequence exprs_code+  updfr_off <- getUpdFrameOff+  emit (mkReturnSimple profile exprs updfr_off)++mkReturnSimple  :: Profile -> [CmmActual] -> UpdFrameOffset -> CmmAGraph+mkReturnSimple profile actuals updfr_off =+  mkReturn profile e actuals updfr_off+  where e = entryCode platform (cmmLoadGCWord platform (CmmStackSlot Old updfr_off))+        platform = profilePlatform profile++doRawJump :: CmmParse CmmExpr -> [GlobalReg] -> CmmParse ()+doRawJump expr_code vols = do+  profile <- getProfile+  expr <- expr_code+  updfr_off <- getUpdFrameOff+  emit (mkRawJump profile expr updfr_off vols)++doJumpWithStack :: CmmParse CmmExpr -> [CmmParse CmmExpr]+                -> [CmmParse CmmExpr] -> CmmParse ()+doJumpWithStack expr_code stk_code args_code = do+  profile <- getProfile+  expr <- expr_code+  stk_args <- sequence stk_code+  args <- sequence args_code+  updfr_off <- getUpdFrameOff+  emit (mkJumpExtra profile NativeNodeCall expr args updfr_off stk_args)++doCall :: CmmParse CmmExpr -> [CmmParse LocalReg] -> [CmmParse CmmExpr]+       -> CmmParse ()+doCall expr_code res_code args_code = do+  expr <- expr_code+  args <- sequence args_code+  ress <- sequence res_code+  updfr_off <- getUpdFrameOff+  c <- code $ mkCall expr (NativeNodeCall,NativeReturn) ress args updfr_off []+  emit c++adjCallTarget :: Platform -> CCallConv -> CmmExpr -> [(CmmExpr, ForeignHint) ]+              -> CmmExpr+-- On Windows, we have to add the '@N' suffix to the label when making+-- a call with the stdcall calling convention.+adjCallTarget platform StdCallConv (CmmLit (CmmLabel lbl)) args+ | platformOS platform == OSMinGW32+  = CmmLit (CmmLabel (addLabelSize lbl (sum (map size args))))+  where size (e, _) = max (platformWordSizeInBytes platform) (widthInBytes (typeWidth (cmmExprType platform e)))+                 -- c.f. CgForeignCall.emitForeignCall+adjCallTarget _ _ expr _+  = expr++primCall+        :: [CmmParse (CmmFormal, ForeignHint)]+        -> FastString+        -> [CmmParse CmmExpr]+        -> PD (CmmParse ())+primCall results_code name args_code+  = do+    platform <- PD.getPlatform+    case lookupUFM (callishMachOps platform) name of+        Nothing -> failMsgPD $ \span -> mkPlainErrorMsgEnvelope span $ PsErrCmmParser (CmmUnknownPrimitive name)+        Just f  -> return $ do+                results <- sequence results_code+                args <- sequence args_code+                let (p, args') = f args+                code (emitPrimCall (map fst results) p args')++doStore :: CmmType -> CmmParse CmmExpr  -> CmmParse CmmExpr -> CmmParse ()+doStore rep addr_code val_code+  = do platform <- getPlatform+       addr <- addr_code+       val <- val_code+        -- if the specified store type does not match the type of the expr+        -- on the rhs, then we insert a coercion that will cause the type+        -- mismatch to be flagged by cmm-lint.  If we don't do this, then+        -- the store will happen at the wrong type, and the error will not+        -- be noticed.+       let val_width = typeWidth (cmmExprType platform val)+           rep_width = typeWidth rep+       let coerce_val+                | val_width /= rep_width = CmmMachOp (MO_UU_Conv val_width rep_width) [val]+                | otherwise              = val+       emitStore addr coerce_val++-- -----------------------------------------------------------------------------+-- If-then-else and boolean expressions++data BoolExpr+  = BoolExpr `BoolAnd` BoolExpr+  | BoolExpr `BoolOr`  BoolExpr+  | BoolNot BoolExpr+  | BoolTest CmmExpr++-- ToDo: smart constructors which simplify the boolean expression.++cmmIfThenElse cond then_part else_part likely = do+     then_id <- newBlockId+     join_id <- newBlockId+     c <- cond+     emitCond c then_id likely+     else_part+     emit (mkBranch join_id)+     emitLabel then_id+     then_part+     -- fall through to join+     emitLabel join_id++cmmRawIf cond then_id likely = do+    c <- cond+    emitCond c then_id likely++-- 'emitCond cond true_id'  emits code to test whether the cond is true,+-- branching to true_id if so, and falling through otherwise.+emitCond (BoolTest e) then_id likely = do+  else_id <- newBlockId+  emit (mkCbranch e then_id else_id likely)+  emitLabel else_id+emitCond (BoolNot (BoolTest (CmmMachOp op args))) then_id likely+  | Just op' <- maybeInvertComparison op+  = emitCond (BoolTest (CmmMachOp op' args)) then_id (not <$> likely)+emitCond (BoolNot e) then_id likely = do+  else_id <- newBlockId+  emitCond e else_id likely+  emit (mkBranch then_id)+  emitLabel else_id+emitCond (e1 `BoolOr` e2) then_id likely = do+  emitCond e1 then_id likely+  emitCond e2 then_id likely+emitCond (e1 `BoolAnd` e2) then_id likely = do+        -- we'd like to invert one of the conditionals here to avoid an+        -- extra branch instruction, but we can't use maybeInvertComparison+        -- here because we can't look too closely at the expression since+        -- we're in a loop.+  and_id <- newBlockId+  else_id <- newBlockId+  emitCond e1 and_id likely+  emit (mkBranch else_id)+  emitLabel and_id+  emitCond e2 then_id likely+  emitLabel else_id++-- -----------------------------------------------------------------------------+-- Source code notes++-- | Generate a source note spanning from "a" to "b" (inclusive), then+-- proceed with parsing. This allows debugging tools to reason about+-- locations in Cmm code.+withSourceNote :: Located a -> Located b -> CmmParse c -> CmmParse c+withSourceNote a b parse = do+  name <- getName+  case combineSrcSpans (getLoc a) (getLoc b) of+    RealSrcSpan span _ -> code (emitTick (SourceNote span name)) >> parse+    _other           -> parse++-- -----------------------------------------------------------------------------+-- Table jumps++-- We use a simplified form of C-- switch statements for now.  A+-- switch statement always compiles to a table jump.  Each arm can+-- specify a list of values (not ranges), and there can be a single+-- default branch.  The range of the table is given either by the+-- optional range on the switch (eg. switch [0..7] {...}), or by+-- the minimum/maximum values from the branches.++doSwitch :: Maybe (Integer,Integer)+         -> CmmParse CmmExpr+         -> [([Integer],Either BlockId (CmmParse ()))]+         -> Maybe (CmmParse ()) -> CmmParse ()+doSwitch mb_range scrut arms deflt+   = do+        -- Compile code for the default branch+        dflt_entry <-+                case deflt of+                  Nothing -> return Nothing+                  Just e  -> do b <- forkLabelledCode e; return (Just b)++        -- Compile each case branch+        table_entries <- mapM emitArm arms+        let table = M.fromList (concat table_entries)++        platform <- getPlatform+        let range = fromMaybe (0, platformMaxWord platform) mb_range++        expr <- scrut+        -- ToDo: check for out of range and jump to default if necessary+        emit $ mkSwitch expr (mkSwitchTargets False range dflt_entry table)+   where+        emitArm :: ([Integer],Either BlockId (CmmParse ())) -> CmmParse [(Integer,BlockId)]+        emitArm (ints,Left blockid) = return [ (i,blockid) | i <- ints ]+        emitArm (ints,Right code) = do+           blockid <- forkLabelledCode code+           return [ (i,blockid) | i <- ints ]++forkLabelledCode :: CmmParse () -> CmmParse BlockId+forkLabelledCode p = do+  (_,ag) <- getCodeScoped p+  l <- newBlockId+  emitOutOfLine l ag+  return l++-- -----------------------------------------------------------------------------+-- Putting it all together++-- The initial environment: we define some constants that the compiler+-- knows about here.+initEnv :: Profile -> Env+initEnv profile = listToUFM [+  ( fsLit "SIZEOF_StgHeader",+    VarN (CmmLit (CmmInt (fromIntegral (fixedHdrSize profile)) (wordWidth platform)) )),+  ( fsLit "SIZEOF_StgInfoTable",+    VarN (CmmLit (CmmInt (fromIntegral (stdInfoTableSizeB profile)) (wordWidth platform)) ))+  ]+  where platform = profilePlatform profile+++parseCmmFile :: DynFlags+             -> Module+             -> HomeUnit+             -> FilePath+             -> IO (Messages PsMessage, Messages PsMessage, Maybe (CmmGroup, [InfoProvEnt]))+parseCmmFile dflags this_mod home_unit filename = do+  buf <- hGetStringBuffer filename+  let+        init_loc = mkRealSrcLoc (mkFastString filename) 1 1+        opts       = initParserOpts dflags+        init_state = (initParserState opts buf init_loc) { lex_state = [0] }+                -- reset the lex_state: the Lexer monad leaves some stuff+                -- in there we don't want.+  case unPD cmmParse dflags 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 $ targetProfile dflags)+        let fcode = do+              ((), cmm) <- getCmm $ unEC code "global" (initEnv (targetProfile dflags)) [] >> return ()+              -- See Note [Mapping Info Tables to Source Positions] (IPE Maps)+              let used_info = map (cmmInfoTableToInfoProvEnt this_mod)+                                              (mapMaybe topInfoTable cmm)+              ((), cmm2) <- getCmm $ mapM_ emitInfoTableProv used_info+              return (cmm ++ cmm2, used_info)+            (cmm, _) = runC (initStgToCmmConfig dflags no_module) fstate st fcode+            (warnings,errors) = getPsMessages pst+        if not (isEmptyMessages errors)+         then return (warnings, errors, Nothing)+         else return (warnings, errors, Just cmm)+  where+        no_module = panic "parseCmmFile: no module"+{-# 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.y 
@@ -1,1523 +0,0 @@------------------------------------------------------------------------------------ (c) The University of Glasgow, 2004-2012------ Parser for concrete Cmm.-----------------------------------------------------------------------------------{- ------------------------------------------------------------------------------Note [Syntax of .cmm files]--NOTE: You are very much on your own in .cmm.  There is very little-error checking at all:--  * Type errors are detected by the (optional) -dcmm-lint pass, if you-    don't turn this on then a type error will likely result in a panic-    from the native code generator.--  * Passing the wrong number of arguments or arguments of the wrong-    type is not detected.--There are two ways to write .cmm code:-- (1) High-level Cmm code delegates the stack handling to GHC, and-     never explicitly mentions Sp or registers.-- (2) Low-level Cmm manages the stack itself, and must know about-     calling conventions.--Whether you want high-level or low-level Cmm is indicated by the-presence of an argument list on a procedure.  For example:--foo ( gcptr a, bits32 b )-{-  // this is high-level cmm code--  if (b > 0) {-     // we can make tail calls passing arguments:-     jump stg_ap_0_fast(a);-  }--  push (stg_upd_frame_info, a) {-    // stack frames can be explicitly pushed--    (x,y) = call wibble(a,b,3,4);-      // calls pass arguments and return results using the native-      // Haskell calling convention.  The code generator will automatically-      // construct a stack frame and an info table for the continuation.--    return (x,y);-      // we can return multiple values from the current proc-  }-}--bar-{-  // this is low-level cmm code, indicated by the fact that we did not-  // put an argument list on bar.--  x = R1;  // the calling convention is explicit: better be careful-           // that this works on all platforms!--  jump %ENTRY_CODE(Sp(0))-}--Here is a list of rules for high-level and low-level code.  If you-break the rules, you get a panic (for using a high-level construct in-a low-level proc), or wrong code (when using low-level code in a-high-level proc).  This stuff isn't checked! (TODO!)--High-level only:--  - tail-calls with arguments, e.g.-    jump stg_fun (arg1, arg2);--  - function calls:-    (ret1,ret2) = call stg_fun (arg1, arg2);--    This makes a call with the NativeNodeCall convention, and the-    values are returned to the following code using the NativeReturn-    convention.--  - returning:-    return (ret1, ret2)--    These use the NativeReturn convention to return zero or more-    results to the caller.--  - pushing stack frames:-    push (info_ptr, field1, ..., fieldN) { ... statements ... }--  - reserving temporary stack space:--      reserve N = x { ... }--    this reserves an area of size N (words) on the top of the stack,-    and binds its address to x (a local register).  Typically this is-    used for allocating temporary storage for passing to foreign-    functions.--    Note that if you make any native calls or invoke the GC in the-    scope of the reserve block, you are responsible for ensuring that-    the stack you reserved is laid out correctly with an info table.--Low-level only:--  - References to Sp, R1-R8, F1-F4 etc.--    NB. foreign calls may clobber the argument registers R1-R8, F1-F4-    etc., so ensure they are saved into variables around foreign-    calls.--  - SAVE_THREAD_STATE() and LOAD_THREAD_STATE(), which modify Sp-    directly.--Both high-level and low-level code can use a raw tail-call:--    jump stg_fun [R1,R2]--NB. you *must* specify the list of GlobalRegs that are passed via a-jump, otherwise the register allocator will assume that all the-GlobalRegs are dead at the jump.---Calling Conventions----------------------High-level procedures use the NativeNode calling convention, or the-NativeReturn convention if the 'return' keyword is used (see Stack-Frames below).--Low-level procedures implement their own calling convention, so it can-be anything at all.--If a low-level procedure implements the NativeNode calling convention,-then it can be called by high-level code using an ordinary function-call.  In general this is hard to arrange because the calling-convention depends on the number of physical registers available for-parameter passing, but there are two cases where the calling-convention is platform-independent:-- - Zero arguments.-- - One argument of pointer or non-pointer word type; this is always-   passed in R1 according to the NativeNode convention.-- - Returning a single value; these conventions are fixed and platform-   independent.---Stack Frames---------------A stack frame is written like this:--INFO_TABLE_RET ( label, FRAME_TYPE, info_ptr, field1, ..., fieldN )-               return ( arg1, ..., argM )-{-  ... code ...-}--where field1 ... fieldN are the fields of the stack frame (with types)-arg1...argN are the values returned to the stack frame (with types).-The return values are assumed to be passed according to the-NativeReturn convention.--On entry to the code, the stack frame looks like:--   |----------|-   | fieldN   |-   |   ...    |-   | field1   |-   |----------|-   | info_ptr |-   |----------|-   |  argN    |-   |   ...    | <- Sp--and some of the args may be in registers.--We prepend the code by a copyIn of the args, and assign all the stack-frame fields to their formals.  The initial "arg offset" for stack-layout purposes consists of the whole stack frame plus any args that-might be on the stack.--A tail-call may pass a stack frame to the callee using the following-syntax:--jump f (info_ptr, field1,..,fieldN) (arg1,..,argN)--where info_ptr and field1..fieldN describe the stack frame, and-arg1..argN are the arguments passed to f using the NativeNodeCall-convention. Note if a field is longer than a word (e.g. a D_ on-a 32-bit machine) then the call will push as many words as-necessary to the stack to accommodate it (e.g. 2).-------------------------------------------------------------------------------- -}--{-{-# LANGUAGE TupleSections #-}--module GHC.Cmm.Parser ( parseCmmFile ) 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.Prof-import GHC.StgToCmm.Heap-import GHC.StgToCmm.Monad hiding ( getCode, getCodeR, getCodeScoped, emitLabel, emit-                                 , emitStore, emitAssign, emitOutOfLine, withUpdFrameOff-                                 , getUpdFrameOff, getProfile, getPlatform, getPtrOpts )-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.Layout     hiding (ArgRep(..))-import GHC.StgToCmm.Ticky-import GHC.StgToCmm.Prof-import GHC.StgToCmm.Bind  ( emitBlackHoleCode, emitUpdateFrame )--import GHC.Cmm.Opt-import GHC.Cmm.Graph-import GHC.Cmm-import GHC.Cmm.Utils-import GHC.Cmm.Switch     ( mkSwitchTargets )-import GHC.Cmm.Info-import GHC.Cmm.BlockId-import GHC.Cmm.Lexer-import GHC.Cmm.CLabel-import GHC.Cmm.Parser.Monad hiding (getPlatform, getProfile, getPtrOpts)-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--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.Driver.Session-import GHC.Driver.Ppr-import GHC.Driver.Config-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--#include "HsVersions.h"-}--%expect 0--%token-        ':'     { L _ (CmmT_SpecChar ':') }-        ';'     { L _ (CmmT_SpecChar ';') }-        '{'     { L _ (CmmT_SpecChar '{') }-        '}'     { L _ (CmmT_SpecChar '}') }-        '['     { L _ (CmmT_SpecChar '[') }-        ']'     { L _ (CmmT_SpecChar ']') }-        '('     { L _ (CmmT_SpecChar '(') }-        ')'     { L _ (CmmT_SpecChar ')') }-        '='     { L _ (CmmT_SpecChar '=') }-        '`'     { L _ (CmmT_SpecChar '`') }-        '~'     { L _ (CmmT_SpecChar '~') }-        '/'     { L _ (CmmT_SpecChar '/') }-        '*'     { L _ (CmmT_SpecChar '*') }-        '%'     { L _ (CmmT_SpecChar '%') }-        '-'     { L _ (CmmT_SpecChar '-') }-        '+'     { L _ (CmmT_SpecChar '+') }-        '&'     { L _ (CmmT_SpecChar '&') }-        '^'     { L _ (CmmT_SpecChar '^') }-        '|'     { L _ (CmmT_SpecChar '|') }-        '>'     { L _ (CmmT_SpecChar '>') }-        '<'     { L _ (CmmT_SpecChar '<') }-        ','     { L _ (CmmT_SpecChar ',') }-        '!'     { L _ (CmmT_SpecChar '!') }--        '..'    { L _ (CmmT_DotDot) }-        '::'    { L _ (CmmT_DoubleColon) }-        '>>'    { L _ (CmmT_Shr) }-        '<<'    { L _ (CmmT_Shl) }-        '>='    { L _ (CmmT_Ge) }-        '<='    { L _ (CmmT_Le) }-        '=='    { L _ (CmmT_Eq) }-        '!='    { L _ (CmmT_Ne) }-        '&&'    { L _ (CmmT_BoolAnd) }-        '||'    { L _ (CmmT_BoolOr) }--        'True'  { L _ (CmmT_True ) }-        'False' { L _ (CmmT_False) }-        'likely'{ L _ (CmmT_likely)}--        'CLOSURE'       { L _ (CmmT_CLOSURE) }-        'INFO_TABLE'    { L _ (CmmT_INFO_TABLE) }-        'INFO_TABLE_RET'{ L _ (CmmT_INFO_TABLE_RET) }-        'INFO_TABLE_FUN'{ L _ (CmmT_INFO_TABLE_FUN) }-        'INFO_TABLE_CONSTR'{ L _ (CmmT_INFO_TABLE_CONSTR) }-        'INFO_TABLE_SELECTOR'{ L _ (CmmT_INFO_TABLE_SELECTOR) }-        'else'          { L _ (CmmT_else) }-        'export'        { L _ (CmmT_export) }-        'section'       { L _ (CmmT_section) }-        'goto'          { L _ (CmmT_goto) }-        'if'            { L _ (CmmT_if) }-        'call'          { L _ (CmmT_call) }-        'jump'          { L _ (CmmT_jump) }-        'foreign'       { L _ (CmmT_foreign) }-        'never'         { L _ (CmmT_never) }-        'prim'          { L _ (CmmT_prim) }-        'reserve'       { L _ (CmmT_reserve) }-        'return'        { L _ (CmmT_return) }-        'returns'       { L _ (CmmT_returns) }-        'import'        { L _ (CmmT_import) }-        'switch'        { L _ (CmmT_switch) }-        'case'          { L _ (CmmT_case) }-        'default'       { L _ (CmmT_default) }-        'push'          { L _ (CmmT_push) }-        'unwind'        { L _ (CmmT_unwind) }-        'bits8'         { L _ (CmmT_bits8) }-        'bits16'        { L _ (CmmT_bits16) }-        'bits32'        { L _ (CmmT_bits32) }-        'bits64'        { L _ (CmmT_bits64) }-        'bits128'       { L _ (CmmT_bits128) }-        'bits256'       { L _ (CmmT_bits256) }-        'bits512'       { L _ (CmmT_bits512) }-        'float32'       { L _ (CmmT_float32) }-        'float64'       { L _ (CmmT_float64) }-        'gcptr'         { L _ (CmmT_gcptr) }--        GLOBALREG       { L _ (CmmT_GlobalReg   $$) }-        NAME            { L _ (CmmT_Name        $$) }-        STRING          { L _ (CmmT_String      $$) }-        INT             { L _ (CmmT_Int         $$) }-        FLOAT           { L _ (CmmT_Float       $$) }--%monad { PD } { >>= } { return }-%lexer { cmmlex } { L _ CmmT_EOF }-%name cmmParse cmm-%tokentype { Located CmmToken }---- C-- operator precedences, taken from the C-- spec-%right '||'     -- non-std extension, called %disjoin in C---%right '&&'     -- non-std extension, called %conjoin in C---%right '!'-%nonassoc '>=' '>' '<=' '<' '!=' '=='-%left '|'-%left '^'-%left '&'-%left '>>' '<<'-%left '-' '+'-%left '/' '*' '%'-%right '~'--%%--cmm     :: { CmmParse () }-        : {- empty -}                   { return () }-        | cmmtop cmm                    { do $1; $2 }--cmmtop  :: { CmmParse () }-        : cmmproc                       { $1 }-        | cmmdata                       { $1 }-        | decl                          { $1 }-        | 'CLOSURE' '(' NAME ',' NAME lits ')' ';'-                {% do-                      home_unit_id <- getHomeUnitId-                      liftP $ pure $ do-                        lits <- sequence $6;-                        staticClosure home_unit_id $3 $5 (map getLit lits) }---- The only static closures in the RTS are dummy closures like--- stg_END_TSO_QUEUE_closure and stg_dummy_ret.  We don't need--- to provide the full generality of static closures here.--- In particular:---      * CCS can always be CCS_DONT_CARE---      * closure is always extern---      * payload is always empty---      * we can derive closure and info table labels from a single NAME--cmmdata :: { CmmParse () }-        : 'section' STRING '{' data_label statics '}'-                { do lbl <- $4;-                     ss <- sequence $5;-                     code (emitDecl (CmmData (Section (section $2) lbl) (CmmStaticsRaw lbl (concat ss)))) }--data_label :: { CmmParse CLabel }-    : NAME ':'-                {% do-                   home_unit_id <- getHomeUnitId-                   liftP $ pure $ do-                     pure (mkCmmDataLabel home_unit_id (NeedExternDecl False) $1) }--statics :: { [CmmParse [CmmStatic]] }-        : {- empty -}                   { [] }-        | static statics                { $1 : $2 }--static  :: { CmmParse [CmmStatic] }-        : type expr ';' { do e <- $2;-                             return [CmmStaticLit (getLit e)] }-        | type ';'                      { return [CmmUninitialised-                                                        (widthInBytes (typeWidth $1))] }-        | 'bits8' '[' ']' STRING ';'    { return [mkString $4] }-        | 'bits8' '[' INT ']' ';'       { return [CmmUninitialised-                                                        (fromIntegral $3)] }-        | typenot8 '[' INT ']' ';'      { return [CmmUninitialised-                                                (widthInBytes (typeWidth $1) *-                                                        fromIntegral $3)] }-        | 'CLOSURE' '(' NAME lits ')'-                { do { lits <- sequence $4-                ; profile <- getProfile-                     ; return $ map CmmStaticLit $-                        mkStaticClosure profile (mkForeignLabel $3 Nothing ForeignLabelInExternalPackage IsData)-                         -- mkForeignLabel because these are only used-                         -- for CHARLIKE and INTLIKE closures in the RTS.-                        dontCareCCS (map getLit lits) [] [] [] } }-        -- arrays of closures required for the CHARLIKE & INTLIKE arrays--lits    :: { [CmmParse CmmExpr] }-        : {- empty -}           { [] }-        | ',' expr lits         { $2 : $3 }--cmmproc :: { CmmParse () }-        : info maybe_conv maybe_formals maybe_body-                { do ((entry_ret_label, info, stk_formals, formals), agraph) <--                       getCodeScoped $ loopDecls $ do {-                         (entry_ret_label, info, stk_formals) <- $1;-                         dflags <- getDynFlags;-                         platform <- getPlatform;-                         formals <- sequence (fromMaybe [] $3);-                         withName (showSDoc dflags (pdoc platform entry_ret_label))-                           $4;-                         return (entry_ret_label, info, stk_formals, formals) }-                     let do_layout = isJust $3-                     code (emitProcWithStackFrame $2 info-                                entry_ret_label stk_formals formals agraph-                                do_layout ) }--maybe_conv :: { Convention }-           : {- empty -}        { NativeNodeCall }-           | 'return'           { NativeReturn }--maybe_body :: { CmmParse () }-           : ';'                { return () }-           | '{' body '}'       { withSourceNote $1 $3 $2 }--info    :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }-        : NAME-                {% do-                     home_unit_id <- getHomeUnitId-                     liftP $ pure $ do-                       newFunctionName $1 home_unit_id-                       return (mkCmmCodeLabel home_unit_id $1, Nothing, []) }---        | 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'-                -- ptrs, nptrs, closure type, description, type-                {% do-                      home_unit_id <- getHomeUnitId-                      liftP $ pure $ do-                        profile <- getProfile-                        let prof = profilingInfo profile $11 $13-                            rep  = mkRTSRep (fromIntegral $9) $-                                     mkHeapRep profile False (fromIntegral $5)-                                                     (fromIntegral $7) Thunk-                                -- not really Thunk, but that makes the info table-                                -- we want.-                        return (mkCmmEntryLabel home_unit_id $3,-                                Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel home_unit_id $3-                                             , cit_rep = rep-                                             , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },-                                []) }--        | 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')'-                -- ptrs, nptrs, closure type, description, type, fun type-                {% do-                      home_unit_id <- getHomeUnitId-                      liftP $ pure $ do-                        profile <- getProfile-                        let prof = profilingInfo profile $11 $13-                            ty   = Fun 0 (ArgSpec (fromIntegral $15))-                                  -- Arity zero, arg_type $15-                            rep = mkRTSRep (fromIntegral $9) $-                                      mkHeapRep profile False (fromIntegral $5)-                                                      (fromIntegral $7) ty-                        return (mkCmmEntryLabel home_unit_id $3,-                                Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel home_unit_id $3-                                             , cit_rep = rep-                                             , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },-                                []) }-                -- we leave most of the fields zero here.  This is only used-                -- to generate the BCO info table in the RTS at the moment.--        | 'INFO_TABLE_CONSTR' '(' NAME ',' INT ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'-                -- ptrs, nptrs, tag, closure type, description, type-                {% do-                      home_unit_id <- getHomeUnitId-                      liftP $ pure $ do-                        profile <- getProfile-                        let prof = profilingInfo profile $13 $15-                            ty  = Constr (fromIntegral $9)  -- Tag-                                         (BS8.pack $13)-                            rep = mkRTSRep (fromIntegral $11) $-                                    mkHeapRep profile False (fromIntegral $5)-                                                    (fromIntegral $7) ty-                        return (mkCmmEntryLabel home_unit_id $3,-                                Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel home_unit_id $3-                                             , cit_rep = rep-                                             , cit_prof = prof, cit_srt = Nothing,cit_clo = Nothing },-                                []) }--                     -- If profiling is on, this string gets duplicated,-                     -- but that's the way the old code did it we can fix it some other time.--        | 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')'-                -- selector, closure type, description, type-                {% do-                      home_unit_id <- getHomeUnitId-                      liftP $ pure $ do-                        profile <- getProfile-                        let prof = profilingInfo profile $9 $11-                            ty  = ThunkSelector (fromIntegral $5)-                            rep = mkRTSRep (fromIntegral $7) $-                                     mkHeapRep profile False 0 0 ty-                        return (mkCmmEntryLabel home_unit_id $3,-                                Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel home_unit_id $3-                                             , cit_rep = rep-                                             , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },-                                []) }--        | 'INFO_TABLE_RET' '(' NAME ',' INT ')'-                -- closure type (no live regs)-                {% do-                      home_unit_id <- getHomeUnitId-                      liftP $ pure $ do-                        let prof = NoProfilingInfo-                            rep  = mkRTSRep (fromIntegral $5) $ mkStackRep []-                        return (mkCmmRetLabel home_unit_id $3,-                                Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel home_unit_id $3-                                             , cit_rep = rep-                                             , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },-                                []) }--        | 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals0 ')'-                -- closure type, live regs-                {% do-                      home_unit_id <- getHomeUnitId-                      liftP $ pure $ do-                        platform <- getPlatform-                        live <- sequence $7-                        let prof = NoProfilingInfo-                            -- drop one for the info pointer-                            bitmap = mkLiveness platform (drop 1 live)-                            rep  = mkRTSRep (fromIntegral $5) $ mkStackRep bitmap-                        return (mkCmmRetLabel home_unit_id $3,-                                Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel home_unit_id $3-                                             , cit_rep = rep-                                             , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },-                                live) }--body    :: { CmmParse () }-        : {- empty -}                   { return () }-        | decl body                     { do $1; $2 }-        | stmt body                     { do $1; $2 }--decl    :: { CmmParse () }-        : type names ';'                { mapM_ (newLocal $1) $2 }-        | 'import' importNames ';'      { mapM_ newImport $2 }-        | 'export' names ';'            { return () }  -- ignore exports----- an imported function name, with optional packageId-importNames-        :: { [(FastString, CLabel)] }-        : importName                    { [$1] }-        | importName ',' importNames    { $1 : $3 }--importName-        :: { (FastString,  CLabel) }--        -- A label imported without an explicit packageId.-        --      These are taken to come from some foreign, unnamed package.-        : NAME-        { ($1, mkForeignLabel $1 Nothing ForeignLabelInExternalPackage IsFunction) }--        -- as previous 'NAME', but 'IsData'-        | 'CLOSURE' NAME-        { ($2, mkForeignLabel $2 Nothing ForeignLabelInExternalPackage IsData) }--        -- A label imported with an explicit UnitId.-        | STRING NAME-        { ($2, mkCmmCodeLabel (UnitId (mkFastString $1)) $2) }---names   :: { [FastString] }-        : NAME                          { [$1] }-        | NAME ',' names                { $1 : $3 }--stmt    :: { CmmParse () }-        : ';'                                   { return () }--        | NAME ':'-                { do l <- newLabel $1; emitLabel l }----        | lreg '=' expr ';'-                { do reg <- $1; e <- $3; withSourceNote $2 $4 (emitAssign reg e) }-        | type '[' expr ']' '=' expr ';'-                { withSourceNote $2 $7 (doStore $1 $3 $6) }--        -- Gah! We really want to say "foreign_results" but that causes-        -- a shift/reduce conflict with assignment.  We either-        -- we expand out the no-result and single result cases or-        -- we tweak the syntax to avoid the conflict.  The later-        -- option is taken here because the other way would require-        -- multiple levels of expanding and get unwieldy.-        | foreign_results 'foreign' STRING foreignLabel '(' cmm_hint_exprs0 ')' safety opt_never_returns ';'-                {% foreignCall $3 $1 $4 $6 $8 $9 }-        | foreign_results 'prim' '%' NAME '(' exprs0 ')' ';'-                {% primCall $1 $4 $6 }-        -- stmt-level macros, stealing syntax from ordinary C-- function calls.-        -- Perhaps we ought to use the %%-form?-        | NAME '(' exprs0 ')' ';'-                {% stmtMacro $1 $3  }-        | 'switch' maybe_range expr '{' arms default '}'-                { do as <- sequence $5; doSwitch $2 $3 as $6 }-        | 'goto' NAME ';'-                { do l <- lookupLabel $2; emit (mkBranch l) }-        | 'return' '(' exprs0 ')' ';'-                { doReturn $3 }-        | 'jump' expr vols ';'-                { doRawJump $2 $3 }-        | 'jump' expr '(' exprs0 ')' ';'-                { doJumpWithStack $2 [] $4 }-        | 'jump' expr '(' exprs0 ')' '(' exprs0 ')' ';'-                { doJumpWithStack $2 $4 $7 }-        | 'call' expr '(' exprs0 ')' ';'-                { doCall $2 [] $4 }-        | '(' formals ')' '=' 'call' expr '(' exprs0 ')' ';'-                { doCall $6 $2 $8 }-        | 'if' bool_expr cond_likely 'goto' NAME-                { do l <- lookupLabel $5; cmmRawIf $2 l $3 }-        | 'if' bool_expr cond_likely '{' body '}' else-                { cmmIfThenElse $2 (withSourceNote $4 $6 $5) $7 $3 }-        | 'push' '(' exprs0 ')' maybe_body-                { pushStackFrame $3 $5 }-        | 'reserve' expr '=' lreg maybe_body-                { reserveStackFrame $2 $4 $5 }-        | 'unwind' unwind_regs ';'-                { $2 >>= code . emitUnwind }--unwind_regs-        :: { CmmParse [(GlobalReg, Maybe CmmExpr)] }-        : GLOBALREG '=' expr_or_unknown ',' unwind_regs-                { do e <- $3; rest <- $5; return (($1, e) : rest) }-        | GLOBALREG '=' expr_or_unknown-                { do e <- $3; return [($1, e)] }---- | Used by unwind to indicate unknown unwinding values.-expr_or_unknown-        :: { CmmParse (Maybe CmmExpr) }-        : 'return'-                { do return Nothing }-        | expr-                { do e <- $1; return (Just e) }--foreignLabel     :: { CmmParse CmmExpr }-        : NAME                          { return (CmmLit (CmmLabel (mkForeignLabel $1 Nothing ForeignLabelInThisPackage IsFunction))) }--opt_never_returns :: { CmmReturnInfo }-        :                               { CmmMayReturn }-        | 'never' 'returns'             { CmmNeverReturns }--bool_expr :: { CmmParse BoolExpr }-        : bool_op                       { $1 }-        | expr                          { do e <- $1; return (BoolTest e) }--bool_op :: { CmmParse BoolExpr }-        : bool_expr '&&' bool_expr      { do e1 <- $1; e2 <- $3;-                                          return (BoolAnd e1 e2) }-        | bool_expr '||' bool_expr      { do e1 <- $1; e2 <- $3;-                                          return (BoolOr e1 e2)  }-        | '!' bool_expr                 { do e <- $2; return (BoolNot e) }-        | '(' bool_op ')'               { $2 }--safety  :: { Safety }-        : {- empty -}                   { PlayRisky }-        | STRING                        {% parseSafety $1 }--vols    :: { [GlobalReg] }-        : '[' ']'                       { [] }-        | '[' '*' ']'                   {% do platform <- PD.getPlatform-                                         ; return (realArgRegsCover platform) }-                                           -- All of them. See comment attached-                                           -- to realArgRegsCover-        | '[' globals ']'               { $2 }--globals :: { [GlobalReg] }-        : GLOBALREG                     { [$1] }-        | GLOBALREG ',' globals         { $1 : $3 }--maybe_range :: { Maybe (Integer,Integer) }-        : '[' INT '..' INT ']'  { Just ($2, $4) }-        | {- empty -}           { Nothing }--arms    :: { [CmmParse ([Integer],Either BlockId (CmmParse ()))] }-        : {- empty -}                   { [] }-        | arm arms                      { $1 : $2 }--arm     :: { CmmParse ([Integer],Either BlockId (CmmParse ())) }-        : 'case' ints ':' arm_body      { do b <- $4; return ($2, b) }--arm_body :: { CmmParse (Either BlockId (CmmParse ())) }-        : '{' body '}'                  { return (Right (withSourceNote $1 $3 $2)) }-        | 'goto' NAME ';'               { do l <- lookupLabel $2; return (Left l) }--ints    :: { [Integer] }-        : INT                           { [ $1 ] }-        | INT ',' ints                  { $1 : $3 }--default :: { Maybe (CmmParse ()) }-        : 'default' ':' '{' body '}'    { Just (withSourceNote $3 $5 $4) }-        -- taking a few liberties with the C-- syntax here; C-- doesn't have-        -- 'default' branches-        | {- empty -}                   { Nothing }---- Note: OldCmm doesn't support a first class 'else' statement, though--- CmmNode does.-else    :: { CmmParse () }-        : {- empty -}                   { return () }-        | 'else' '{' body '}'           { withSourceNote $2 $4 $3 }--cond_likely :: { Maybe Bool }-        : '(' 'likely' ':' 'True'  ')'  { Just True  }-        | '(' 'likely' ':' 'False' ')'  { Just False }-        | {- empty -}                   { Nothing }----- we have to write this out longhand so that Happy's precedence rules--- can kick in.-expr    :: { CmmParse CmmExpr }-        : expr '/' expr                 { mkMachOp MO_U_Quot [$1,$3] }-        | expr '*' expr                 { mkMachOp MO_Mul [$1,$3] }-        | expr '%' expr                 { mkMachOp MO_U_Rem [$1,$3] }-        | expr '-' expr                 { mkMachOp MO_Sub [$1,$3] }-        | expr '+' expr                 { mkMachOp MO_Add [$1,$3] }-        | expr '>>' expr                { mkMachOp MO_U_Shr [$1,$3] }-        | expr '<<' expr                { mkMachOp MO_Shl [$1,$3] }-        | expr '&' expr                 { mkMachOp MO_And [$1,$3] }-        | expr '^' expr                 { mkMachOp MO_Xor [$1,$3] }-        | expr '|' expr                 { mkMachOp MO_Or [$1,$3] }-        | expr '>=' expr                { mkMachOp MO_U_Ge [$1,$3] }-        | expr '>' expr                 { mkMachOp MO_U_Gt [$1,$3] }-        | expr '<=' expr                { mkMachOp MO_U_Le [$1,$3] }-        | expr '<' expr                 { mkMachOp MO_U_Lt [$1,$3] }-        | expr '!=' expr                { mkMachOp MO_Ne [$1,$3] }-        | expr '==' expr                { mkMachOp MO_Eq [$1,$3] }-        | '~' expr                      { mkMachOp MO_Not [$2] }-        | '-' expr                      { mkMachOp MO_S_Neg [$2] }-        | expr0 '`' NAME '`' expr0      {% do { mo <- nameToMachOp $3 ;-                                                return (mkMachOp mo [$1,$5]) } }-        | expr0                         { $1 }--expr0   :: { CmmParse CmmExpr }-        : INT   maybe_ty         { return (CmmLit (CmmInt $1 (typeWidth $2))) }-        | FLOAT maybe_ty         { return (CmmLit (CmmFloat $1 (typeWidth $2))) }-        | STRING                 { do s <- code (newStringCLit $1);-                                      return (CmmLit s) }-        | reg                    { $1 }-        | type dereference       { do (align, ptr) <- $2; return (CmmLoad ptr $1 align) }-        | '%' NAME '(' exprs0 ')' {% exprOp $2 $4 }-        | '(' expr ')'           { $2 }--dereference :: { CmmParse (AlignmentSpec, CmmExpr) }-        : '^' '[' expr ']'       { do ptr <- $3; return (Unaligned, ptr) }-        | '[' expr ']'           { do ptr <- $2; return (NaturallyAligned, ptr) }---- leaving out the type of a literal gives you the native word size in C---maybe_ty :: { CmmType }-        : {- empty -}                   {% do platform <- PD.getPlatform; return $ bWord platform }-        | '::' type                     { $2 }--cmm_hint_exprs0 :: { [CmmParse (CmmExpr, ForeignHint)] }-        : {- empty -}                   { [] }-        | cmm_hint_exprs                { $1 }--cmm_hint_exprs :: { [CmmParse (CmmExpr, ForeignHint)] }-        : cmm_hint_expr                 { [$1] }-        | cmm_hint_expr ',' cmm_hint_exprs      { $1 : $3 }--cmm_hint_expr :: { CmmParse (CmmExpr, ForeignHint) }-        : expr                          { do e <- $1;-                                             return (e, inferCmmHint e) }-        | expr STRING                   {% do h <- parseCmmHint $2;-                                              return $ do-                                                e <- $1; return (e, h) }--exprs0  :: { [CmmParse CmmExpr] }-        : {- empty -}                   { [] }-        | exprs                         { $1 }--exprs   :: { [CmmParse CmmExpr] }-        : expr                          { [ $1 ] }-        | expr ',' exprs                { $1 : $3 }--reg     :: { CmmParse CmmExpr }-        : NAME                  { lookupName $1 }-        | GLOBALREG             { return (CmmReg (CmmGlobal $1)) }--foreign_results :: { [CmmParse (LocalReg, ForeignHint)] }-        : {- empty -}                   { [] }-        | '(' foreign_formals ')' '='   { $2 }--foreign_formals :: { [CmmParse (LocalReg, ForeignHint)] }-        : foreign_formal                        { [$1] }-        | foreign_formal ','                    { [$1] }-        | foreign_formal ',' foreign_formals    { $1 : $3 }--foreign_formal :: { CmmParse (LocalReg, ForeignHint) }-        : local_lreg            { do e <- $1; return (e, inferCmmHint (CmmReg (CmmLocal e))) }-        | STRING local_lreg     {% do h <- parseCmmHint $1;-                                      return $ do-                                         e <- $2; return (e,h) }--local_lreg :: { CmmParse LocalReg }-        : NAME                  { do e <- lookupName $1;-                                     return $-                                       case e of-                                        CmmReg (CmmLocal r) -> r-                                        other -> pprPanic "CmmParse:" (ftext $1 <> text " not a local register") }--lreg    :: { CmmParse CmmReg }-        : NAME                  { do e <- lookupName $1;-                                     return $-                                       case e of-                                        CmmReg r -> r-                                        other -> pprPanic "CmmParse:" (ftext $1 <> text " not a register") }-        | GLOBALREG             { return (CmmGlobal $1) }--maybe_formals :: { Maybe [CmmParse LocalReg] }-        : {- empty -}           { Nothing }-        | '(' formals0 ')'      { Just $2 }--formals0 :: { [CmmParse LocalReg] }-        : {- empty -}           { [] }-        | formals               { $1 }--formals :: { [CmmParse LocalReg] }-        : formal ','            { [$1] }-        | formal                { [$1] }-        | formal ',' formals       { $1 : $3 }--formal :: { CmmParse LocalReg }-        : type NAME             { newLocal $1 $2 }--type    :: { CmmType }-        : 'bits8'               { b8 }-        | typenot8              { $1 }--typenot8 :: { CmmType }-        : 'bits16'              { b16 }-        | 'bits32'              { b32 }-        | 'bits64'              { b64 }-        | 'bits128'             { b128 }-        | 'bits256'             { b256 }-        | 'bits512'             { b512 }-        | 'float32'             { f32 }-        | 'float64'             { f64 }-        | 'gcptr'               {% do platform <- PD.getPlatform; return $ gcWord platform }--{-section :: String -> SectionType-section "text"      = Text-section "data"      = Data-section "rodata"    = ReadOnlyData-section "relrodata" = RelocatableReadOnlyData-section "bss"       = UninitialisedData-section s           = OtherSection s--mkString :: String -> CmmStatic-mkString s = CmmString (BS8.pack s)---- mkMachOp infers the type of the MachOp from the type of its first--- argument.  We assume that this is correct: for MachOps that don't have--- symmetrical args (e.g. shift ops), the first arg determines the type of--- the op.-mkMachOp :: (Width -> MachOp) -> [CmmParse CmmExpr] -> CmmParse CmmExpr-mkMachOp fn args = do-  platform <- getPlatform-  arg_exprs <- sequence args-  return (CmmMachOp (fn (typeWidth (cmmExprType platform (head arg_exprs)))) arg_exprs)--getLit :: CmmExpr -> CmmLit-getLit (CmmLit l) = l-getLit (CmmMachOp (MO_S_Neg _) [CmmLit (CmmInt i r)])  = CmmInt (negate i) r-getLit _ = panic "invalid literal" -- TODO messy failure--nameToMachOp :: FastString -> PD (Width -> MachOp)-nameToMachOp name =-  case lookupUFM machOps name of-        Nothing -> failMsgPD $ PsError (PsErrCmmParser (CmmUnknownPrimitive name)) []-        Just m  -> return m--exprOp :: FastString -> [CmmParse CmmExpr] -> PD (CmmParse CmmExpr)-exprOp name args_code = do-  ptr_opts <- PD.getPtrOpts-  case lookupUFM (exprMacros ptr_opts) name of-     Just f  -> return $ do-        args <- sequence args_code-        return (f args)-     Nothing -> do-        mo <- nameToMachOp name-        return $ mkMachOp mo args_code--exprMacros :: PtrOpts -> UniqFM FastString ([CmmExpr] -> CmmExpr)-exprMacros ptr_opts = listToUFM [-  ( fsLit "ENTRY_CODE",   \ [x] -> entryCode platform x ),-  ( fsLit "INFO_PTR",     \ [x] -> closureInfoPtr ptr_opts x ),-  ( fsLit "STD_INFO",     \ [x] -> infoTable profile x ),-  ( fsLit "FUN_INFO",     \ [x] -> funInfoTable profile x ),-  ( fsLit "GET_ENTRY",    \ [x] -> entryCode platform (closureInfoPtr ptr_opts x) ),-  ( fsLit "GET_STD_INFO", \ [x] -> infoTable profile (closureInfoPtr ptr_opts x) ),-  ( fsLit "GET_FUN_INFO", \ [x] -> funInfoTable profile (closureInfoPtr ptr_opts x) ),-  ( fsLit "INFO_TYPE",    \ [x] -> infoTableClosureType profile x ),-  ( fsLit "INFO_PTRS",    \ [x] -> infoTablePtrs profile x ),-  ( fsLit "INFO_NPTRS",   \ [x] -> infoTableNonPtrs profile x )-  ]-  where-    profile  = po_profile ptr_opts-    platform = profilePlatform profile---- we understand a subset of C-- primitives:-machOps = listToUFM $-        map (\(x, y) -> (mkFastString x, y)) [-        ( "add",        MO_Add ),-        ( "sub",        MO_Sub ),-        ( "eq",         MO_Eq ),-        ( "ne",         MO_Ne ),-        ( "mul",        MO_Mul ),-        ( "mulmayoflo",  MO_S_MulMayOflo ),-        ( "mulmayoflou", MO_U_MulMayOflo ),-        ( "neg",        MO_S_Neg ),-        ( "quot",       MO_S_Quot ),-        ( "rem",        MO_S_Rem ),-        ( "divu",       MO_U_Quot ),-        ( "modu",       MO_U_Rem ),--        ( "ge",         MO_S_Ge ),-        ( "le",         MO_S_Le ),-        ( "gt",         MO_S_Gt ),-        ( "lt",         MO_S_Lt ),--        ( "geu",        MO_U_Ge ),-        ( "leu",        MO_U_Le ),-        ( "gtu",        MO_U_Gt ),-        ( "ltu",        MO_U_Lt ),--        ( "and",        MO_And ),-        ( "or",         MO_Or ),-        ( "xor",        MO_Xor ),-        ( "com",        MO_Not ),-        ( "shl",        MO_Shl ),-        ( "shrl",       MO_U_Shr ),-        ( "shra",       MO_S_Shr ),--        ( "fadd",       MO_F_Add ),-        ( "fsub",       MO_F_Sub ),-        ( "fneg",       MO_F_Neg ),-        ( "fmul",       MO_F_Mul ),-        ( "fquot",      MO_F_Quot ),--        ( "feq",        MO_F_Eq ),-        ( "fne",        MO_F_Ne ),-        ( "fge",        MO_F_Ge ),-        ( "fle",        MO_F_Le ),-        ( "fgt",        MO_F_Gt ),-        ( "flt",        MO_F_Lt ),--        ( "lobits8",  flip MO_UU_Conv W8  ),-        ( "lobits16", flip MO_UU_Conv W16 ),-        ( "lobits32", flip MO_UU_Conv W32 ),-        ( "lobits64", flip MO_UU_Conv W64 ),--        ( "zx16",     flip MO_UU_Conv W16 ),-        ( "zx32",     flip MO_UU_Conv W32 ),-        ( "zx64",     flip MO_UU_Conv W64 ),--        ( "sx16",     flip MO_SS_Conv W16 ),-        ( "sx32",     flip MO_SS_Conv W32 ),-        ( "sx64",     flip MO_SS_Conv W64 ),--        ( "f2f32",    flip MO_FF_Conv W32 ),  -- TODO; rounding mode-        ( "f2f64",    flip MO_FF_Conv W64 ),  -- TODO; rounding mode-        ( "f2i8",     flip MO_FS_Conv W8 ),-        ( "f2i16",    flip MO_FS_Conv W16 ),-        ( "f2i32",    flip MO_FS_Conv W32 ),-        ( "f2i64",    flip MO_FS_Conv W64 ),-        ( "i2f32",    flip MO_SF_Conv W32 ),-        ( "i2f64",    flip MO_SF_Conv W64 )-        ]--callishMachOps :: Platform -> UniqFM FastString ([CmmExpr] -> (CallishMachOp, [CmmExpr]))-callishMachOps platform = listToUFM $-        map (\(x, y) -> (mkFastString x, y)) [--        ( "pow64f", (MO_F64_Pwr,) ),-        ( "sin64f", (MO_F64_Sin,) ),-        ( "cos64f", (MO_F64_Cos,) ),-        ( "tan64f", (MO_F64_Tan,) ),-        ( "sinh64f", (MO_F64_Sinh,) ),-        ( "cosh64f", (MO_F64_Cosh,) ),-        ( "tanh64f", (MO_F64_Tanh,) ),-        ( "asin64f", (MO_F64_Asin,) ),-        ( "acos64f", (MO_F64_Acos,) ),-        ( "atan64f", (MO_F64_Atan,) ),-        ( "asinh64f", (MO_F64_Asinh,) ),-        ( "acosh64f", (MO_F64_Acosh,) ),-        ( "log64f", (MO_F64_Log,) ),-        ( "log1p64f", (MO_F64_Log1P,) ),-        ( "exp64f", (MO_F64_Exp,) ),-        ( "expM164f", (MO_F64_ExpM1,) ),-        ( "fabs64f", (MO_F64_Fabs,) ),-        ( "sqrt64f", (MO_F64_Sqrt,) ),--        ( "pow32f", (MO_F32_Pwr,) ),-        ( "sin32f", (MO_F32_Sin,) ),-        ( "cos32f", (MO_F32_Cos,) ),-        ( "tan32f", (MO_F32_Tan,) ),-        ( "sinh32f", (MO_F32_Sinh,) ),-        ( "cosh32f", (MO_F32_Cosh,) ),-        ( "tanh32f", (MO_F32_Tanh,) ),-        ( "asin32f", (MO_F32_Asin,) ),-        ( "acos32f", (MO_F32_Acos,) ),-        ( "atan32f", (MO_F32_Atan,) ),-        ( "asinh32f", (MO_F32_Asinh,) ),-        ( "acosh32f", (MO_F32_Acosh,) ),-        ( "log32f", (MO_F32_Log,) ),-        ( "log1p32f", (MO_F32_Log1P,) ),-        ( "exp32f", (MO_F32_Exp,) ),-        ( "expM132f", (MO_F32_ExpM1,) ),-        ( "fabs32f", (MO_F32_Fabs,) ),-        ( "sqrt32f", (MO_F32_Sqrt,) ),--        ( "read_barrier", (MO_ReadBarrier,)),-        ( "write_barrier", (MO_WriteBarrier,)),-        ( "memcpy", memcpyLikeTweakArgs MO_Memcpy ),-        ( "memset", memcpyLikeTweakArgs MO_Memset ),-        ( "memmove", memcpyLikeTweakArgs MO_Memmove ),-        ( "memcmp", memcpyLikeTweakArgs MO_Memcmp ),--        ("prefetch0", (MO_Prefetch_Data 0,)),-        ("prefetch1", (MO_Prefetch_Data 1,)),-        ("prefetch2", (MO_Prefetch_Data 2,)),-        ("prefetch3", (MO_Prefetch_Data 3,)),--        ( "popcnt8",  (MO_PopCnt W8,)),-        ( "popcnt16", (MO_PopCnt W16,)),-        ( "popcnt32", (MO_PopCnt W32,)),-        ( "popcnt64", (MO_PopCnt W64,)),--        ( "pdep8",  (MO_Pdep W8,)),-        ( "pdep16", (MO_Pdep W16,)),-        ( "pdep32", (MO_Pdep W32,)),-        ( "pdep64", (MO_Pdep W64,)),--        ( "pext8",  (MO_Pext W8,)),-        ( "pext16", (MO_Pext W16,)),-        ( "pext32", (MO_Pext W32,)),-        ( "pext64", (MO_Pext W64,)),--        ( "cmpxchg8",  (MO_Cmpxchg W8,)),-        ( "cmpxchg16", (MO_Cmpxchg W16,)),-        ( "cmpxchg32", (MO_Cmpxchg W32,)),-        ( "cmpxchg64", (MO_Cmpxchg W64,)),--        ( "xchg8",  (MO_Xchg W8,)),-        ( "xchg16", (MO_Xchg W16,)),-        ( "xchg32", (MO_Xchg W32,)),-        ( "xchg64", (MO_Xchg W64,))-    ]-  where-    memcpyLikeTweakArgs :: (Int -> CallishMachOp) -> [CmmExpr] -> (CallishMachOp, [CmmExpr])-    memcpyLikeTweakArgs op [] = pgmError "memcpy-like function requires at least one argument"-    memcpyLikeTweakArgs op args@(_:_) =-        (op align, args')-      where-        args' = init args-        align = case last args of-          CmmLit (CmmInt alignInteger _) -> fromInteger alignInteger-          e -> pgmErrorDoc "Non-constant alignment in memcpy-like function:" (pdoc platform e)-        -- The alignment of memcpy-ish operations must be a-        -- compile-time constant. We verify this here, passing it around-        -- in the MO_* constructor. In order to do this, however, we-        -- must intercept the arguments in primCall.--parseSafety :: String -> PD Safety-parseSafety "safe"   = return PlaySafe-parseSafety "unsafe" = return PlayRisky-parseSafety "interruptible" = return PlayInterruptible-parseSafety str      = failMsgPD $ PsError (PsErrCmmParser (CmmUnrecognisedSafety str)) []--parseCmmHint :: String -> PD ForeignHint-parseCmmHint "ptr"    = return AddrHint-parseCmmHint "signed" = return SignedHint-parseCmmHint str      = failMsgPD $ PsError (PsErrCmmParser (CmmUnrecognisedHint str)) []---- labels are always pointers, so we might as well infer the hint-inferCmmHint :: CmmExpr -> ForeignHint-inferCmmHint (CmmLit (CmmLabel _)) = AddrHint-inferCmmHint (CmmReg (CmmGlobal g)) | isPtrGlobalReg g = AddrHint-inferCmmHint _ = NoHint--isPtrGlobalReg Sp                    = True-isPtrGlobalReg SpLim                 = True-isPtrGlobalReg Hp                    = True-isPtrGlobalReg HpLim                 = True-isPtrGlobalReg CCCS                  = True-isPtrGlobalReg CurrentTSO            = True-isPtrGlobalReg CurrentNursery        = True-isPtrGlobalReg (VanillaReg _ VGcPtr) = True-isPtrGlobalReg _                     = False--happyError :: PD a-happyError = PD $ \_ _ s -> unP srcParseFail s---- -------------------------------------------------------------------------------- Statement-level macros--stmtMacro :: FastString -> [CmmParse CmmExpr] -> PD (CmmParse ())-stmtMacro fun args_code = do-  case lookupUFM stmtMacros fun of-    Nothing -> failMsgPD $ PsError (PsErrCmmParser (CmmUnknownMacro fun)) []-    Just fcode -> return $ do-        args <- sequence args_code-        code (fcode args)--stmtMacros :: UniqFM FastString ([CmmExpr] -> FCode ())-stmtMacros = listToUFM [-  ( fsLit "CCS_ALLOC",             \[words,ccs]  -> profAlloc words ccs ),-  ( fsLit "ENTER_CCS_THUNK",       \[e] -> enterCostCentreThunk e ),--  ( fsLit "CLOSE_NURSERY",         \[]  -> emitCloseNursery ),-  ( fsLit "OPEN_NURSERY",          \[]  -> emitOpenNursery ),--  -- completely generic heap and stack checks, for use in high-level cmm.-  ( fsLit "HP_CHK_GEN",            \[bytes] ->-                                      heapStackCheckGen Nothing (Just bytes) ),-  ( fsLit "STK_CHK_GEN",           \[] ->-                                      heapStackCheckGen (Just (CmmLit CmmHighStackMark)) Nothing ),--  -- A stack check for a fixed amount of stack.  Sounds a bit strange, but-  -- we use the stack for a bit of temporary storage in a couple of primops-  ( fsLit "STK_CHK_GEN_N",         \[bytes] ->-                                      heapStackCheckGen (Just bytes) Nothing ),--  -- A stack check on entry to a thunk, where the argument is the thunk pointer.-  ( fsLit "STK_CHK_NP"   ,         \[node] -> entryHeapCheck' False node 0 [] (return ())),--  ( fsLit "LOAD_THREAD_STATE",     \[] -> emitLoadThreadState ),-  ( fsLit "SAVE_THREAD_STATE",     \[] -> emitSaveThreadState ),--  ( fsLit "SAVE_REGS",             \[] -> emitSaveRegs ),-  ( fsLit "RESTORE_REGS",          \[] -> emitRestoreRegs ),--  ( fsLit "PUSH_TUPLE_REGS",      \[live_regs] -> emitPushTupleRegs live_regs ),-  ( fsLit "POP_TUPLE_REGS",       \[live_regs] -> emitPopTupleRegs live_regs ),--  ( fsLit "LDV_ENTER",             \[e] -> ldvEnter e ),-  ( fsLit "LDV_RECORD_CREATE",     \[e] -> ldvRecordCreate e ),--  ( fsLit "PUSH_UPD_FRAME",        \[sp,e] -> emitPushUpdateFrame sp e ),-  ( fsLit "SET_HDR",               \[ptr,info,ccs] ->-                                        emitSetDynHdr ptr info ccs ),-  ( fsLit "TICK_ALLOC_PRIM",       \[hdr,goods,slop] ->-                                        tickyAllocPrim hdr goods slop ),-  ( fsLit "TICK_ALLOC_PAP",        \[goods,slop] ->-                                        tickyAllocPAP goods slop ),-  ( fsLit "TICK_ALLOC_UP_THK",     \[goods,slop] ->-                                        tickyAllocThunk goods slop ),-  ( fsLit "UPD_BH_UPDATABLE",      \[reg] -> emitBlackHoleCode reg )- ]--emitPushUpdateFrame :: CmmExpr -> CmmExpr -> FCode ()-emitPushUpdateFrame sp e = do-  emitUpdateFrame sp mkUpdInfoLabel e--pushStackFrame :: [CmmParse CmmExpr] -> CmmParse () -> CmmParse ()-pushStackFrame fields body = do-  profile <- getProfile-  exprs <- sequence fields-  updfr_off <- getUpdFrameOff-  let (new_updfr_off, _, g) = copyOutOflow profile NativeReturn Ret Old-                                           [] updfr_off exprs-  emit g-  withUpdFrameOff new_updfr_off body--reserveStackFrame-  :: CmmParse CmmExpr-  -> CmmParse CmmReg-  -> CmmParse ()-  -> CmmParse ()-reserveStackFrame psize preg body = do-  platform <- getPlatform-  old_updfr_off <- getUpdFrameOff-  reg <- preg-  esize <- psize-  let size = case constantFoldExpr platform esize of-               CmmLit (CmmInt n _) -> n-               _other -> pprPanic "CmmParse: not a compile-time integer: "-                            (pdoc platform esize)-  let frame = old_updfr_off + platformWordSizeInBytes platform * fromIntegral size-  emitAssign reg (CmmStackSlot Old frame)-  withUpdFrameOff frame body--profilingInfo profile desc_str ty_str-  = if not (profileIsProfiling profile)-    then NoProfilingInfo-    else ProfilingInfo (BS8.pack desc_str) (BS8.pack ty_str)--staticClosure :: UnitId -> FastString -> FastString -> [CmmLit] -> CmmParse ()-staticClosure pkg cl_label info payload-  = do profile <- getProfile-       let lits = mkStaticClosure profile (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] []-       code $ emitDataLits (mkCmmDataLabel pkg (NeedExternDecl True) cl_label) lits--foreignCall-        :: String-        -> [CmmParse (LocalReg, ForeignHint)]-        -> CmmParse CmmExpr-        -> [CmmParse (CmmExpr, ForeignHint)]-        -> Safety-        -> CmmReturnInfo-        -> PD (CmmParse ())-foreignCall conv_string results_code expr_code args_code safety ret-  = do  conv <- case conv_string of-          "C"       -> return CCallConv-          "stdcall" -> return StdCallConv-          _         -> failMsgPD $ PsError (PsErrCmmParser (CmmUnknownCConv conv_string)) []-        return $ do-          platform <- getPlatform-          results <- sequence results_code-          expr <- expr_code-          args <- sequence args_code-          let-                  expr' = adjCallTarget platform conv expr args-                  (arg_exprs, arg_hints) = unzip args-                  (res_regs,  res_hints) = unzip results-                  fc = ForeignConvention conv arg_hints res_hints ret-                  target = ForeignTarget expr' fc-          _ <- code $ emitForeignCall safety res_regs target arg_exprs-          return ()---doReturn :: [CmmParse CmmExpr] -> CmmParse ()-doReturn exprs_code = do-  profile <- getProfile-  exprs <- sequence exprs_code-  updfr_off <- getUpdFrameOff-  emit (mkReturnSimple profile exprs updfr_off)--mkReturnSimple  :: Profile -> [CmmActual] -> UpdFrameOffset -> CmmAGraph-mkReturnSimple profile actuals updfr_off =-  mkReturn profile e actuals updfr_off-  where e = entryCode platform (cmmLoadGCWord platform (CmmStackSlot Old updfr_off))-        platform = profilePlatform profile--doRawJump :: CmmParse CmmExpr -> [GlobalReg] -> CmmParse ()-doRawJump expr_code vols = do-  profile <- getProfile-  expr <- expr_code-  updfr_off <- getUpdFrameOff-  emit (mkRawJump profile expr updfr_off vols)--doJumpWithStack :: CmmParse CmmExpr -> [CmmParse CmmExpr]-                -> [CmmParse CmmExpr] -> CmmParse ()-doJumpWithStack expr_code stk_code args_code = do-  profile <- getProfile-  expr <- expr_code-  stk_args <- sequence stk_code-  args <- sequence args_code-  updfr_off <- getUpdFrameOff-  emit (mkJumpExtra profile NativeNodeCall expr args updfr_off stk_args)--doCall :: CmmParse CmmExpr -> [CmmParse LocalReg] -> [CmmParse CmmExpr]-       -> CmmParse ()-doCall expr_code res_code args_code = do-  expr <- expr_code-  args <- sequence args_code-  ress <- sequence res_code-  updfr_off <- getUpdFrameOff-  c <- code $ mkCall expr (NativeNodeCall,NativeReturn) ress args updfr_off []-  emit c--adjCallTarget :: Platform -> CCallConv -> CmmExpr -> [(CmmExpr, ForeignHint) ]-              -> CmmExpr--- On Windows, we have to add the '@N' suffix to the label when making--- a call with the stdcall calling convention.-adjCallTarget platform StdCallConv (CmmLit (CmmLabel lbl)) args- | platformOS platform == OSMinGW32-  = CmmLit (CmmLabel (addLabelSize lbl (sum (map size args))))-  where size (e, _) = max (platformWordSizeInBytes platform) (widthInBytes (typeWidth (cmmExprType platform e)))-                 -- c.f. CgForeignCall.emitForeignCall-adjCallTarget _ _ expr _-  = expr--primCall-        :: [CmmParse (CmmFormal, ForeignHint)]-        -> FastString-        -> [CmmParse CmmExpr]-        -> PD (CmmParse ())-primCall results_code name args_code-  = do-    platform <- PD.getPlatform-    case lookupUFM (callishMachOps platform) name of-        Nothing -> failMsgPD $ PsError (PsErrCmmParser (CmmUnknownPrimitive name)) []-        Just f  -> return $ do-                results <- sequence results_code-                args <- sequence args_code-                let (p, args') = f args-                code (emitPrimCall (map fst results) p args')--doStore :: CmmType -> CmmParse CmmExpr  -> CmmParse CmmExpr -> CmmParse ()-doStore rep addr_code val_code-  = do platform <- getPlatform-       addr <- addr_code-       val <- val_code-        -- if the specified store type does not match the type of the expr-        -- on the rhs, then we insert a coercion that will cause the type-        -- mismatch to be flagged by cmm-lint.  If we don't do this, then-        -- the store will happen at the wrong type, and the error will not-        -- be noticed.-       let val_width = typeWidth (cmmExprType platform val)-           rep_width = typeWidth rep-       let coerce_val-                | val_width /= rep_width = CmmMachOp (MO_UU_Conv val_width rep_width) [val]-                | otherwise              = val-       emitStore addr coerce_val---- -------------------------------------------------------------------------------- If-then-else and boolean expressions--data BoolExpr-  = BoolExpr `BoolAnd` BoolExpr-  | BoolExpr `BoolOr`  BoolExpr-  | BoolNot BoolExpr-  | BoolTest CmmExpr---- ToDo: smart constructors which simplify the boolean expression.--cmmIfThenElse cond then_part else_part likely = do-     then_id <- newBlockId-     join_id <- newBlockId-     c <- cond-     emitCond c then_id likely-     else_part-     emit (mkBranch join_id)-     emitLabel then_id-     then_part-     -- fall through to join-     emitLabel join_id--cmmRawIf cond then_id likely = do-    c <- cond-    emitCond c then_id likely---- 'emitCond cond true_id'  emits code to test whether the cond is true,--- branching to true_id if so, and falling through otherwise.-emitCond (BoolTest e) then_id likely = do-  else_id <- newBlockId-  emit (mkCbranch e then_id else_id likely)-  emitLabel else_id-emitCond (BoolNot (BoolTest (CmmMachOp op args))) then_id likely-  | Just op' <- maybeInvertComparison op-  = emitCond (BoolTest (CmmMachOp op' args)) then_id (not <$> likely)-emitCond (BoolNot e) then_id likely = do-  else_id <- newBlockId-  emitCond e else_id likely-  emit (mkBranch then_id)-  emitLabel else_id-emitCond (e1 `BoolOr` e2) then_id likely = do-  emitCond e1 then_id likely-  emitCond e2 then_id likely-emitCond (e1 `BoolAnd` e2) then_id likely = do-        -- we'd like to invert one of the conditionals here to avoid an-        -- extra branch instruction, but we can't use maybeInvertComparison-        -- here because we can't look too closely at the expression since-        -- we're in a loop.-  and_id <- newBlockId-  else_id <- newBlockId-  emitCond e1 and_id likely-  emit (mkBranch else_id)-  emitLabel and_id-  emitCond e2 then_id likely-  emitLabel else_id---- -------------------------------------------------------------------------------- Source code notes---- | Generate a source note spanning from "a" to "b" (inclusive), then--- proceed with parsing. This allows debugging tools to reason about--- locations in Cmm code.-withSourceNote :: Located a -> Located b -> CmmParse c -> CmmParse c-withSourceNote a b parse = do-  name <- getName-  case combineSrcSpans (getLoc a) (getLoc b) of-    RealSrcSpan span _ -> code (emitTick (SourceNote span name)) >> parse-    _other           -> parse---- -------------------------------------------------------------------------------- Table jumps---- We use a simplified form of C-- switch statements for now.  A--- switch statement always compiles to a table jump.  Each arm can--- specify a list of values (not ranges), and there can be a single--- default branch.  The range of the table is given either by the--- optional range on the switch (eg. switch [0..7] {...}), or by--- the minimum/maximum values from the branches.--doSwitch :: Maybe (Integer,Integer)-         -> CmmParse CmmExpr-         -> [([Integer],Either BlockId (CmmParse ()))]-         -> Maybe (CmmParse ()) -> CmmParse ()-doSwitch mb_range scrut arms deflt-   = do-        -- Compile code for the default branch-        dflt_entry <--                case deflt of-                  Nothing -> return Nothing-                  Just e  -> do b <- forkLabelledCode e; return (Just b)--        -- Compile each case branch-        table_entries <- mapM emitArm arms-        let table = M.fromList (concat table_entries)--        platform <- getPlatform-        let range = fromMaybe (0, platformMaxWord platform) mb_range--        expr <- scrut-        -- ToDo: check for out of range and jump to default if necessary-        emit $ mkSwitch expr (mkSwitchTargets False range dflt_entry table)-   where-        emitArm :: ([Integer],Either BlockId (CmmParse ())) -> CmmParse [(Integer,BlockId)]-        emitArm (ints,Left blockid) = return [ (i,blockid) | i <- ints ]-        emitArm (ints,Right code) = do-           blockid <- forkLabelledCode code-           return [ (i,blockid) | i <- ints ]--forkLabelledCode :: CmmParse () -> CmmParse BlockId-forkLabelledCode p = do-  (_,ag) <- getCodeScoped p-  l <- newBlockId-  emitOutOfLine l ag-  return l---- -------------------------------------------------------------------------------- Putting it all together---- The initial environment: we define some constants that the compiler--- knows about here.-initEnv :: Profile -> Env-initEnv profile = listToUFM [-  ( fsLit "SIZEOF_StgHeader",-    VarN (CmmLit (CmmInt (fromIntegral (fixedHdrSize profile)) (wordWidth platform)) )),-  ( fsLit "SIZEOF_StgInfoTable",-    VarN (CmmLit (CmmInt (fromIntegral (stdInfoTableSizeB profile)) (wordWidth platform)) ))-  ]-  where platform = profilePlatform profile---parseCmmFile :: DynFlags -> Module -> HomeUnit -> FilePath -> IO (Bag PsWarning, Bag PsError, Maybe (CmmGroup, [InfoProvEnt]))-parseCmmFile dflags this_mod home_unit filename = do-  buf <- hGetStringBuffer filename-  let-        init_loc = mkRealSrcLoc (mkFastString filename) 1 1-        opts       = initParserOpts dflags-        init_state = (initParserState opts buf init_loc) { lex_state = [0] }-                -- reset the lex_state: the Lexer monad leaves some stuff-                -- in there we don't want.-  case unPD cmmParse dflags home_unit init_state of-    PFailed pst -> do-        let (warnings,errors) = getMessages pst-        return (warnings, errors, Nothing)-    POk pst code -> do-        st <- initC-        let fcode = do-              ((), cmm) <- getCmm $ unEC code "global" (initEnv (targetProfile dflags)) [] >> return ()-              let used_info = map (cmmInfoTableToInfoProvEnt this_mod)-                                              (mapMaybe topInfoTable cmm)-              ((), cmm2) <- getCmm $ mapM_ emitInfoTableProv used_info-              return (cmm ++ cmm2, used_info)-            (cmm, _) = runC dflags no_module st fcode-            (warnings,errors) = getMessages pst-        if not (isEmptyBag errors)-         then return (warnings, errors, Nothing)-         else return (warnings, errors, Just cmm)-  where-        no_module = panic "parseCmmFile: no module"-}
GHC/Cmm/Parser/Monad.hs view
@@ -13,7 +13,6 @@   , failMsgPD   , getProfile   , getPlatform-  , getPtrOpts   , getHomeUnitId   ) where @@ -21,13 +20,13 @@  import GHC.Platform import GHC.Platform.Profile-import GHC.Cmm.Info  import Control.Monad  import GHC.Driver.Session import GHC.Parser.Lexer-import GHC.Parser.Errors+import GHC.Parser.Errors.Types+import GHC.Types.Error ( MsgEnvelope ) import GHC.Types.SrcLoc import GHC.Unit.Types import GHC.Unit.Home@@ -47,7 +46,7 @@ liftP :: P a -> PD a liftP (P f) = PD $ \_ _ s -> f s -failMsgPD :: (SrcSpan -> PsError) -> PD a+failMsgPD :: (SrcSpan -> MsgEnvelope PsMessage) -> PD a failMsgPD = liftP . failMsgP  returnPD :: a -> PD a@@ -67,15 +66,6 @@  getPlatform :: PD Platform getPlatform = profilePlatform <$> getProfile--getPtrOpts :: PD PtrOpts-getPtrOpts = do-   dflags <- getDynFlags-   profile <- getProfile-   pure $ PtrOpts-      { po_profile     = profile-      , po_align_check = gopt Opt_AlignmentSanitisation dflags-      }  -- | Return the UnitId of the home-unit. This is used to create labels. getHomeUnitId :: PD UnitId
GHC/Cmm/Pipeline.hs view
@@ -10,19 +10,20 @@ import GHC.Prelude  import GHC.Cmm-import GHC.Cmm.Lint-import GHC.Cmm.Info.Build-import GHC.Cmm.CommonBlockElim-import GHC.Cmm.Switch.Implement-import GHC.Cmm.ProcPoint+import GHC.Cmm.Config import GHC.Cmm.ContFlowOpt+import GHC.Cmm.CommonBlockElim+import GHC.Cmm.Dataflow.Collections+import GHC.Cmm.Info.Build+import GHC.Cmm.Lint import GHC.Cmm.LayoutStack+import GHC.Cmm.ProcPoint import GHC.Cmm.Sink-import GHC.Cmm.Dataflow.Collections+import GHC.Cmm.Switch.Implement  import GHC.Types.Unique.Supply import GHC.Driver.Session-import GHC.Driver.Backend+import GHC.Driver.Config.Cmm import GHC.Utils.Error import GHC.Utils.Logger import GHC.Driver.Env@@ -43,23 +44,31 @@  -> IO (ModuleSRTInfo, CmmGroupSRTs) -- Output CPS transformed C--  cmmPipeline hsc_env srtInfo prog = do-  let logger = hsc_logger hsc_env-  let dflags = hsc_dflags hsc_env-  let forceRes (info, group) = info `seq` foldr (\decl r -> decl `seq` r) () group-  withTimingSilent logger dflags (text "Cmm pipeline") forceRes $ do-     tops <- {-# SCC "tops" #-} mapM (cpsTop logger dflags) prog+  let logger    = hsc_logger hsc_env+  let cmmConfig = initCmmConfig (hsc_dflags hsc_env)+  let forceRes (info, group) = info `seq` foldr seq () group+  let platform = cmmPlatform cmmConfig+  withTimingSilent logger (text "Cmm pipeline") forceRes $ do+     tops <- {-# SCC "tops" #-} mapM (cpsTop logger platform cmmConfig) prog       let (procs, data_) = partitionEithers tops-     (srtInfo, cmms) <- {-# SCC "doSRTs" #-} doSRTs dflags srtInfo procs data_-     let platform = targetPlatform dflags-     dumpWith logger dflags Opt_D_dump_cmm_cps "Post CPS Cmm" FormatCMM (pdoc platform cmms)+     (srtInfo, cmms) <- {-# SCC "doSRTs" #-} doSRTs cmmConfig srtInfo procs data_+     dumpWith logger Opt_D_dump_cmm_cps "Post CPS Cmm" FormatCMM (pdoc platform cmms)       return (srtInfo, cmms)  -cpsTop :: Logger -> DynFlags -> CmmDecl -> IO (Either (CAFEnv, [CmmDecl]) (CAFSet, CmmDecl))-cpsTop _logger dflags p@(CmmData _ statics) = return (Right (cafAnalData (targetPlatform dflags) statics, p))-cpsTop logger dflags proc =+-- | The Cmm pipeline for a single 'CmmDecl'. Returns:+--+--   - in the case of a 'CmmProc': 'Left' of the resulting (possibly+--     proc-point-split) 'CmmDecl's and their 'CafEnv'. CAF analysis+--     necessarily happens *before* proc-point splitting, as described in Note+--     [SRTs].+--+--   - in the case of a `CmmData`, the unmodified 'CmmDecl' and a 'CAFSet' containing+cpsTop :: Logger -> Platform -> CmmConfig -> CmmDecl -> IO (Either (CAFEnv, [CmmDecl]) (CAFSet, CmmDecl))+cpsTop _logger platform _ p@(CmmData _ statics) = return (Right (cafAnalData platform statics, p))+cpsTop logger platform cfg proc =     do       ----------- Control-flow optimisations ---------------------------------- @@ -76,15 +85,17 @@        ----------- Eliminate common blocks -------------------------------------       g <- {-# SCC "elimCommonBlocks" #-}-           condPass Opt_CmmElimCommonBlocks elimCommonBlocks g+           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 <- {-# SCC "createSwitchPlans" #-}-           runUniqSM $ cmmImplementSwitchPlans (backend dflags) platform g+      g <- if cmmDoCmmSwitchPlans cfg+             then {-# SCC "createSwitchPlans" #-}+                  runUniqSM $ cmmImplementSwitchPlans platform g+             else pure g       dump Opt_D_dump_cmm_switch "Post switch plan" g        ----------- Proc points -------------------------------------------------@@ -96,7 +107,7 @@             then do               pp <- {-# SCC "minimalProcPointSet" #-} runUniqSM $                  minimalProcPointSet platform call_pps g-              dumpWith logger dflags Opt_D_dump_cmm_proc "Proc points"+              dumpWith logger Opt_D_dump_cmm_proc "Proc points"                     FormatCMM (pdoc platform l $$ ppr pp $$ pdoc platform g)               return pp             else@@ -106,25 +117,25 @@       (g, stackmaps) <-            {-# SCC "layoutStack" #-}            if do_layout-              then runUniqSM $ cmmLayoutStack dflags proc_points entry_off g+              then runUniqSM $ cmmLayoutStack cfg proc_points entry_off g               else return (g, mapEmpty)       dump Opt_D_dump_cmm_sp "Layout Stack" g        ----------- Sink and inline assignments  --------------------------------       g <- {-# SCC "sink" #-} -- See Note [Sinking after stack layout]-           condPass Opt_CmmSink (cmmSink platform) g+           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 dflags Opt_D_dump_cmm_caf "CAFEnv" FormatText (pdoc platform cafEnv)+      dumpWith logger Opt_D_dump_cmm_caf "CAFEnv" FormatText (pdoc platform cafEnv)        g <- if splitting_proc_points            then do              ------------- Split into separate procedures -----------------------              let pp_map = {-# SCC "procPointAnalysis" #-}                           procPointAnalysis proc_points g-             dumpWith logger dflags Opt_D_dump_cmm_procmap "procpoint map"+             dumpWith logger Opt_D_dump_cmm_procmap "procpoint map"                 FormatCMM (ppr pp_map)              g <- {-# SCC "splitAtProcPoints" #-} runUniqSM $                   splitAtProcPoints platform l call_pps proc_points pp_map@@ -142,7 +153,7 @@        ----------- Control-flow optimisations -----------------------------       g <- {-# SCC "cmmCfgOpts(2)" #-}-           return $ if optLevel dflags >= 1+           return $ if cmmOptControlFlow cfg                     then map (cmmCfgOptsProc splitting_proc_points) g                     else g       g <- return (map removeUnreachableBlocksProc g)@@ -151,14 +162,13 @@        return (Left (cafEnv, g)) -  where platform = targetPlatform dflags-        dump = dumpGraph logger dflags+  where dump = dumpGraph logger platform (cmmDoLinting cfg)          dumps flag name-           = mapM_ (dumpWith logger dflags flag name FormatCMM . pdoc platform)+           = mapM_ (dumpWith logger flag name FormatCMM . pdoc platform) -        condPass flag pass g dumpflag dumpname =-            if gopt flag dflags+        condPass do_opt pass g dumpflag dumpname =+            if do_opt                then do                     g <- return $ pass g                     dump dumpflag dumpname g@@ -169,18 +179,10 @@         -- 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 = backend dflags /= NCG-                             || not (platformTablesNextToCode platform)-                             || -- Note [inconsistent-pic-reg]-                                usingInconsistentPicReg-        usingInconsistentPicReg-           = case (platformArch platform, platformOS platform, positionIndependent dflags)-             of   (ArchX86, OSDarwin, pic) -> pic-                  _                        -> False+        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: --@@ -306,7 +308,7 @@ --  {- Note [inconsistent-pic-reg]-+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~ On x86/Darwin, PIC is implemented by inserting a sequence like      call 1f@@ -334,7 +336,7 @@ -}  {- 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@@ -348,24 +350,23 @@   return (initUs_ us m)  -dumpGraph :: Logger -> DynFlags -> DumpFlag -> String -> CmmGraph -> IO ()-dumpGraph logger dflags flag name g = do-  when (gopt Opt_DoCmmLinting dflags) $ do_lint g-  dumpWith logger dflags flag name FormatCMM (pdoc platform g)+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-  platform = targetPlatform dflags   do_lint g = case cmmLintGraph platform g of-                 Just err -> do { fatalErrorMsg logger dflags err-                                ; ghcExit logger dflags 1+                 Just err -> do { fatalErrorMsg logger err+                                ; ghcExit logger 1                                 }                  Nothing  -> return () -dumpWith :: Logger -> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()-dumpWith logger dflags flag txt fmt sdoc = do-  dumpIfSet_dyn logger dflags flag txt fmt sdoc-  when (not (dopt flag dflags)) $+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 (dopt Opt_D_dump_cmm_verbose dflags)-      $ putDumpMsg logger dflags (mkDumpStyle alwaysQualify) flag txt fmt sdoc-  dumpIfSet_dyn logger dflags Opt_D_dump_cmm_verbose_by_proc txt fmt sdoc+    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/Ppr.hs view
@@ -56,7 +56,7 @@ import GHC.Utils.Outputable import GHC.Cmm.Ppr.Decl import GHC.Cmm.Ppr.Expr-import GHC.Utils.Misc+import GHC.Utils.Constants (debugIsOn)  import GHC.Types.Basic import GHC.Cmm.Dataflow.Block@@ -64,6 +64,8 @@  ------------------------------------------------- -- Outputable instances+instance OutputableP Platform InfoProvEnt where+  pdoc platform (InfoProvEnt clabel _ _ _ _) = pdoc platform clabel  instance Outputable CmmStackInfo where     ppr = pprStackInfo
GHC/Cmm/Ppr/Decl.hs view
@@ -51,7 +51,6 @@ import GHC.Cmm  import GHC.Utils.Outputable-import GHC.Data.FastString  import Data.List (intersperse) @@ -160,15 +159,14 @@     section = text "section"  pprSectionType :: SectionType -> SDoc-pprSectionType s = doubleQuotes (ptext t)- where-  t = case s of-    Text              -> sLit "text"-    Data              -> sLit "data"-    ReadOnlyData      -> sLit "readonly"-    ReadOnlyData16    -> sLit "readonly16"-    RelocatableReadOnlyData-                      -> sLit "relreadonly"-    UninitialisedData -> sLit "uninitialised"-    CString           -> sLit "cstring"-    OtherSection s'   -> sLit s' -- Not actually a literal though.+pprSectionType s = doubleQuotes $ case s of+  Text                    -> text "text"+  Data                    -> text "data"+  ReadOnlyData            -> text "readonly"+  ReadOnlyData16          -> text "readonly16"+  RelocatableReadOnlyData -> text "relreadonly"+  UninitialisedData       -> text "uninitialised"+  InitArray               -> text "initarray"+  FiniArray               -> text "finiarray"+  CString                 -> text "cstring"+  OtherSection s'         -> text s'
GHC/Cmm/Ppr/Expr.hs view
@@ -44,12 +44,11 @@  import GHC.Prelude -import GHC.Driver.Ppr- import GHC.Platform import GHC.Cmm.Expr  import GHC.Utils.Outputable+import GHC.Utils.Trace  import Data.Maybe import Numeric ( fromRat )
GHC/Cmm/ProcPoint.hs view
@@ -213,7 +213,7 @@                                 ProcPoint -> 1                                 ReachedBy ps -> setSize ps                 block_procpoints = nreached (entryLabel b)-                -- | Looking for a successor of b that is reached by+                -- 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') &&@@ -428,7 +428,7 @@  {- 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. -}@@ -437,7 +437,7 @@  {- 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:
GHC/Cmm/Sink.hs view
@@ -318,21 +318,65 @@  where    go []               block as = (block, as)    go ((live,node):ns) block as+    -- discard nodes representing dead assignment     | shouldDiscard node live             = go ns block as-       -- discard dead assignment+    -- 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 no-sensical 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@@ -358,11 +402,20 @@ 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 @@ -379,7 +432,9 @@     go _ []             dropped kept = (dropped, kept)    go state (assig : rest) dropped kept-      | conflict  = go state' rest (toNode assig : 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@@ -388,13 +443,12 @@  -- ----------------------------------------------------------------------------- -- Try to inline assignments into a node.--- This also does constant folding for primpops, since+-- 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-  --  -> LocalRegSet               -- set of registers live after this                                 -- node.  We cannot inline anything                                 -- that is live after the node, unless                                 -- it is small enough to duplicate.@@ -418,7 +472,7 @@    go usages live node skipped (a@(l,rhs,_) : rest)    | cannot_inline            = dont_inline-   | occurs_none              = discard  -- Note [discard during inlining]+   | occurs_none              = discard  -- See Note [discard during inlining]    | occurs_once              = inline_and_discard    | isTrivial platform rhs   = inline_and_keep    | otherwise                = dont_inline@@ -442,7 +496,7 @@                 live' = inline foldLocalRegsUsed platform (\m r -> insertLRegSet r m)                                             live rhs -        cannot_inline = skipped `regsUsedIn` rhs -- Note [dependent assignments]+        cannot_inline = skipped `regsUsedIn` rhs -- See Note [dependent assignments]                         || l `elemLRegSet` skipped                         || not (okToInline platform rhs node) @@ -465,8 +519,7 @@         inl_exp other = other  {- Note [Keeping assignemnts mentioned in skipped RHSs]-    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~     If we have to assignments: [z = y, y = e1] and we skip     z we *must* retain the assignment y = e1. This is because     we might inline "z = y" into another node later on so we@@ -487,7 +540,7 @@ -}  {- Note [improveConditional]-+   ~~~~~~~~~~~~~~~~~~~~~~~~~ cmmMachOpFold tries to simplify conditionals to turn things like   (a == b) != 1 into@@ -525,7 +578,6 @@  -- Note [dependent assignments] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- -- If our assignment list looks like -- --    [ y = e,  x = ... y ... ]@@ -622,15 +674,20 @@   -- (5) foreign calls clobber heap: see Note [Foreign calls clobber heap]   | CmmUnsafeForeignCall{} <- node, memConflicts addr AnyMem      = True -  -- (6) native calls clobber any memory+  -- (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 -  -- (7) otherwise, no conflict+  -- (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. @@ -660,7 +717,6 @@  -- 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@@ -743,7 +799,6 @@  -- 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@@ -759,6 +814,10 @@ -- 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
GHC/Cmm/Switch.hs view
@@ -26,7 +26,6 @@  -- 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@@ -51,10 +50,9 @@ -- 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:@@ -83,7 +81,6 @@  -- 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. --@@ -175,7 +172,6 @@  -- 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@@ -239,7 +235,6 @@ -- -- Note [createSwitchPlan] -- ~~~~~~~~~~~~~~~~~~~~~~~--- -- A SwitchPlan describes how a Switch statement is to be broken down into -- smaller pieces suitable for code generation. --
GHC/Cmm/Switch/Implement.hs view
@@ -6,7 +6,6 @@  import GHC.Prelude -import GHC.Driver.Backend import GHC.Platform import GHC.Cmm.Dataflow.Block import GHC.Cmm.BlockId@@ -32,11 +31,10 @@  -- | Traverses the 'CmmGraph', making sure that 'CmmSwitch' are suitable for -- code generation.-cmmImplementSwitchPlans :: Backend -> Platform -> CmmGraph -> UniqSM CmmGraph-cmmImplementSwitchPlans backend platform g+cmmImplementSwitchPlans :: Platform -> CmmGraph -> UniqSM CmmGraph+cmmImplementSwitchPlans platform g =     -- Switch generation done by backend (LLVM/C)-    | backendSupportsSwitch backend = return g-    | otherwise = do+    do     blocks' <- concatMapM (visitSwitches platform) (toBlockList g)     return $ ofBlockList (g_entry g) blocks' @@ -59,16 +57,15 @@  -- 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]@@ -83,6 +80,8 @@ implementSwitchPlan :: Platform -> CmmTickScope -> CmmExpr -> SwitchPlan -> UniqSM (Block CmmNode O C, [CmmBlock]) implementSwitchPlan platform scope expr = go   where+    width = typeWidth $ cmmExprType platform expr+     go (Unconditionally l)       = return (emptyBlock `blockJoinTail` CmmBranch l, [])     go (JumpTable ids)@@ -92,9 +91,9 @@         (bid1, newBlocks1) <- go' ids1         (bid2, newBlocks2) <- go' ids2 -        let lt | signed    = cmmSLtWord-               | otherwise = cmmULtWord-            scrut = lt platform expr $ CmmLit $ mkWordCLit platform i+        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)@@ -102,7 +101,7 @@       = do         (bid2, newBlocks2) <- go' ids2 -        let scrut = cmmNeWord platform expr $ CmmLit $ mkWordCLit platform i+        let scrut = CmmMachOp (MO_Ne width) [expr, CmmLit $ CmmInt i width]             lastNode = CmmCondBranch scrut bid2 l Nothing             lastBlock = emptyBlock `blockJoinTail` lastNode         return (lastBlock, newBlocks2)
GHC/Cmm/Type.hs view
@@ -5,7 +5,8 @@     , cmmBits, cmmFloat     , typeWidth, cmmEqType, cmmEqType_ignoring_ptrhood     , isFloatType, isGcPtrType, isBitsType-    , isWord32, isWord64, isFloat64, isFloat32+    , isWordAny, isWord32, isWord64+    , isFloat64, isFloat32      , Width(..)     , widthInBits, widthInBytes, widthInLog, widthFromBytes@@ -25,6 +26,8 @@     , cmmVec     , vecLength, vecElemType     , isVecType++    , DoAlignSanitisation    ) where @@ -32,7 +35,6 @@ import GHC.Prelude  import GHC.Platform-import GHC.Data.FastString import GHC.Utils.Outputable import GHC.Utils.Panic @@ -145,10 +147,15 @@ isBitsType (CmmType BitsCat _) = True isBitsType _                   = False -isWord32, isWord64, isFloat32, isFloat64 :: CmmType -> Bool+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@@ -167,18 +174,18 @@ --              Width ----------------------------------------------------------------------------- -data Width   = W8 | W16 | W32 | W64-             | W128-             | W256-             | W512-             deriving (Eq, Ord, Show)+data Width+  = W8+  | W16+  | W32+  | W64+  | W128+  | W256+  | W512+  deriving (Eq, Ord, Show)  instance Outputable Width where-   ppr rep = ptext (mrStr rep)--mrStr :: Width -> PtrString-mrStr = sLit . show-+   ppr rep = text (show rep)  -------- Common Widths  ------------ @@ -466,3 +473,6 @@ this, the cons outweigh the pros.  -}++-- | is @-falignment-sanitisation@ enabled?+type DoAlignSanitisation = Bool
GHC/Cmm/Utils.hs view
@@ -48,7 +48,7 @@         currentTSOExpr, currentNurseryExpr, cccsExpr,          -- Tagging-        cmmTagMask, cmmPointerMask, cmmUntag, cmmIsTagged,+        cmmTagMask, cmmPointerMask, cmmUntag, cmmIsTagged, cmmIsNotTagged,         cmmConstrTag1, mAX_PTR_TAG, tAG_MASK,          -- Overlap and usage@@ -115,7 +115,7 @@    AddrRep          -> bWord platform    FloatRep         -> f32    DoubleRep        -> f64-   VecRep len rep   -> vec len (primElemRepCmmType rep)+   (VecRep len rep) -> vec len (primElemRepCmmType rep)  slotCmmType :: Platform -> SlotTy -> CmmType slotCmmType platform = \case@@ -125,7 +125,6 @@    Word64Slot      -> b64    FloatSlot       -> f32    DoubleSlot      -> f64-   VecSlot l e     -> vec l (primElemRepCmmType e)  primElemRepCmmType :: PrimElemRep -> CmmType primElemRepCmmType Int8ElemRep   = b8@@ -448,13 +447,14 @@  -- Used to untag a possibly tagged pointer -- A static label need not be untagged-cmmUntag, cmmIsTagged, cmmConstrTag1 :: Platform -> CmmExpr -> CmmExpr+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+-- 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)
GHC/CmmToAsm.hs view
@@ -6,7 +6,6 @@ -- -----------------------------------------------------------------------------  {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}@@ -76,17 +75,13 @@    -- cmmNativeGen emits    , cmmNativeGen    , NcgImpl(..)-   , initNCGConfig    ) where -#include "HsVersions.h"- import GHC.Prelude  import qualified GHC.CmmToAsm.X86   as X86 import qualified GHC.CmmToAsm.PPC   as PPC-import qualified GHC.CmmToAsm.SPARC as SPARC import qualified GHC.CmmToAsm.AArch64 as AArch64  import GHC.CmmToAsm.Reg.Liveness@@ -135,9 +130,12 @@ 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.Utils.Error import GHC.Unit import GHC.Data.Stream (Stream) import qualified GHC.Data.Stream as Stream@@ -145,27 +143,23 @@ import Data.List (sortBy, groupBy) import Data.Maybe import Data.Ord         ( comparing )-import Control.Exception import Control.Monad import System.IO  ---------------------nativeCodeGen :: forall a . Logger -> DynFlags -> Module -> ModLocation -> Handle -> UniqSupply+nativeCodeGen :: forall a . Logger -> NCGConfig -> ModLocation -> Handle -> UniqSupply               -> Stream IO RawCmmGroup a               -> IO a-nativeCodeGen logger dflags this_mod modLoc h us cmms- = let config   = initNCGConfig dflags this_mod-       platform = ncgPlatform config+nativeCodeGen logger config modLoc h us cmms+ = let platform = ncgPlatform config        nCG' :: ( OutputableP Platform statics, Outputable jumpDest, Instruction instr)             => NcgImpl statics instr jumpDest -> IO a-       nCG' ncgImpl = nativeCodeGen' logger dflags config modLoc ncgImpl h us cmms+       nCG' ncgImpl = nativeCodeGen' logger config modLoc ncgImpl h us cmms    in case platformArch platform of       ArchX86       -> nCG' (X86.ncgX86     config)       ArchX86_64    -> nCG' (X86.ncgX86_64  config)       ArchPPC       -> nCG' (PPC.ncgPPC     config)       ArchPPC_64 _  -> nCG' (PPC.ncgPPC     config)-      ArchSPARC     -> nCG' (SPARC.ncgSPARC config)-      ArchSPARC64   -> panic "nativeCodeGen: No NCG for SPARC64"       ArchS390X     -> panic "nativeCodeGen: No NCG for S390X"       ArchARM {}    -> panic "nativeCodeGen: No NCG for ARM"       ArchAArch64   -> nCG' (AArch64.ncgAArch64 config)@@ -198,7 +192,6 @@ {- 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@@ -222,7 +215,6 @@  nativeCodeGen' :: (OutputableP Platform statics, Outputable jumpDest, Instruction instr)                => Logger-               -> DynFlags                -> NCGConfig                -> ModLocation                -> NcgImpl statics instr jumpDest@@ -230,35 +222,34 @@                -> UniqSupply                -> Stream IO RawCmmGroup a                -> IO a-nativeCodeGen' logger dflags config modLoc ncgImpl h us cmms+nativeCodeGen' logger config modLoc ncgImpl h us cmms  = do         -- BufHandle is a performance hack.  We could hide it inside         -- Pretty if it weren't for the fact that we do lots of little         -- printDocs here (in order to do codegen in constant space).         bufh <- newBufHandle h         let ngs0 = NGS [] [] [] [] [] [] emptyUFM mapEmpty-        (ngs, us', a) <- cmmNativeGenStream logger dflags config modLoc ncgImpl bufh us+        (ngs, us', a) <- cmmNativeGenStream logger config modLoc ncgImpl bufh us                                          cmms ngs0-        _ <- finishNativeGen logger dflags config modLoc bufh us' ngs+        _ <- finishNativeGen logger config modLoc bufh us' ngs         return a  finishNativeGen :: Instruction instr                 => Logger-                -> DynFlags                 -> NCGConfig                 -> ModLocation                 -> BufHandle                 -> UniqSupply                 -> NativeGenAcc statics instr                 -> IO UniqSupply-finishNativeGen logger dflags config modLoc bufh@(BufHandle _ _ h) us ngs- = withTimingSilent logger dflags (text "NCG") (`seq` ()) $ do+finishNativeGen logger config modLoc bufh@(BufHandle _ _ h) us ngs+ = withTimingSilent logger (text "NCG") (`seq` ()) $ do         -- Write debug data and finish         us' <- if not (ncgDwarfEnabled config)                   then return us                   else do                      (dwarf, us') <- dwarfGen config modLoc us (ngs_debug ngs)-                     emitNativeCode logger dflags config bufh dwarf+                     emitNativeCode logger config bufh dwarf                      return us'         bFlush bufh @@ -275,7 +266,7 @@           dump_stats (Color.pprStats stats graphGlobal)            let platform = ncgPlatform config-          dumpIfSet_dyn logger dflags+          putDumpFileMaybe logger                   Opt_D_dump_asm_conflicts "Register conflict graph"                   FormatText                   $ Color.dotGraph@@ -297,13 +288,12 @@                 $ makeImportsDoc config (concat (ngs_imports ngs))         return us'   where-    dump_stats = putDumpMsg logger dflags (mkDumpStyle alwaysQualify)+    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-              -> DynFlags               -> NCGConfig               -> ModLocation               -> NcgImpl statics instr jumpDest@@ -313,7 +303,7 @@               -> NativeGenAcc statics instr               -> IO (NativeGenAcc statics instr, UniqSupply, a) -cmmNativeGenStream logger dflags config modLoc ncgImpl h us cmm_stream ngs+cmmNativeGenStream logger config modLoc ncgImpl h us cmm_stream ngs  = loop us (Stream.runStream cmm_stream) ngs   where     ncglabel = text "NCG"@@ -335,7 +325,6 @@         Stream.Yield cmms cmm_stream' -> do           (us', ngs'') <-             withTimingSilent logger-                dflags                 ncglabel (\(a, b) -> a `seq` b `seq` ()) $ do               -- Generate debug information               let !ndbgs | ncgDwarfEnabled config = cmmDebugGen modLoc cmms@@ -343,15 +332,15 @@                   dbgMap = debugToMap ndbgs                -- Generate native code-              (ngs',us') <- cmmNativeGens logger dflags config modLoc ncgImpl h+              (ngs',us') <- cmmNativeGens logger config modLoc ncgImpl h                                           dbgMap us cmms ngs 0                -- Link native code information into debug blocks               -- See Note [What is this unwinding business?] in "GHC.Cmm.DebugBlock".               let !ldbgs = cmmDebugLink (ngs_labels ngs') (ngs_unwinds ngs') ndbgs-                  platform = targetPlatform dflags+                  platform = ncgPlatform config               unless (null ldbgs) $-                dumpIfSet_dyn logger dflags Opt_D_dump_debug "Debug Infos" FormatText+                putDumpFileMaybe logger Opt_D_dump_debug "Debug Infos" FormatText                   (vcat $ map (pdoc platform) ldbgs)                -- Accumulate debug information for emission in finishNativeGen.@@ -366,7 +355,6 @@ cmmNativeGens :: forall statics instr jumpDest.                  (OutputableP Platform statics, Outputable jumpDest, Instruction instr)               => Logger-              -> DynFlags               -> NCGConfig               -> ModLocation               -> NcgImpl statics instr jumpDest@@ -378,7 +366,7 @@               -> Int               -> IO (NativeGenAcc statics instr, UniqSupply) -cmmNativeGens logger dflags config modLoc ncgImpl h dbgMap = go+cmmNativeGens logger config modLoc ncgImpl h dbgMap = go   where     go :: UniqSupply -> [RawCmmDecl]        -> NativeGenAcc statics instr -> Int@@ -391,7 +379,7 @@         let fileIds = ngs_dwarfFiles ngs         (us', fileIds', native, imports, colorStats, linearStats, unwinds)           <- {-# SCC "cmmNativeGen" #-}-             cmmNativeGen logger dflags modLoc ncgImpl us fileIds dbgMap+             cmmNativeGen logger modLoc ncgImpl us fileIds dbgMap                           cmm count          -- Generate .file directives for every new file that has been@@ -403,17 +391,17 @@             pprDecl (f,n) = text "\t.file " <> ppr n <+>                             pprFilePathString (unpackFS f) -        emitNativeCode logger dflags config h $ vcat $+        emitNativeCode logger config h $ vcat $           map pprDecl newFileIds ++           map (pprNatCmmDecl ncgImpl) native          -- force evaluation all this stuff to avoid space leaks-        let platform = targetPlatform dflags-        {-# SCC "seqString" #-} evaluate $ seqList (showSDoc dflags $ vcat $ map (pdoc platform) imports) ()+        let platform = ncgPlatform config+        {-# SCC "seqString" #-} evaluate $ seqList (showSDocUnsafe $ vcat $ map (pdoc platform) imports) ()          let !labels' = if ncgDwarfEnabled config                        then cmmDebugLabels isMetaInstr native else []-            !natives' = if dopt Opt_D_dump_asm_stats dflags+            !natives' = if logHasDumpFlag logger Opt_D_dump_asm_stats                         then native : ngs_natives ngs else []              mCon = maybe id (:)@@ -428,14 +416,14 @@         go us' cmms ngs' (count + 1)  -emitNativeCode :: Logger -> DynFlags -> NCGConfig -> BufHandle -> SDoc -> IO ()-emitNativeCode logger dflags config h sdoc = do+emitNativeCode :: Logger -> NCGConfig -> BufHandle -> SDoc -> IO ()+emitNativeCode logger config h sdoc = do          let ctx = ncgAsmContext config         {-# SCC "pprNativeCode" #-} bufLeftRenderSDoc ctx h sdoc          -- dump native code-        dumpIfSet_dyn logger dflags+        putDumpFileMaybe logger                 Opt_D_dump_asm "Asm code" FormatASM                 sdoc @@ -445,7 +433,6 @@ cmmNativeGen     :: forall statics instr jumpDest. (Instruction instr, OutputableP Platform statics, Outputable jumpDest)     => Logger-    -> DynFlags     -> ModLocation     -> NcgImpl statics instr jumpDest         -> UniqSupply@@ -462,7 +449,7 @@                 , LabelMap [UnwindPoint]                    -- unwinding information for blocks                 ) -cmmNativeGen logger dflags modLoc ncgImpl us fileIds dbgMap cmm count+cmmNativeGen logger modLoc ncgImpl us fileIds dbgMap cmm count  = do         let config   = ncgConfig ncgImpl         let platform = ncgPlatform config@@ -482,7 +469,7 @@                 {-# SCC "cmmToCmm" #-}                 cmmToCmm config fixed_cmm -        dumpIfSet_dyn logger dflags+        putDumpFileMaybe logger                 Opt_D_dump_opt_cmm "Optimised Cmm" FormatCMM                 (pprCmmGroup platform [opt_cmm]) @@ -496,16 +483,16 @@                                         (cmmTopCodeGen ncgImpl)                                         fileIds dbgMap opt_cmm cmmCfg -        dumpIfSet_dyn logger dflags+        putDumpFileMaybe logger                 Opt_D_dump_asm_native "Native code" FormatASM                 (vcat $ map (pprNatCmmDecl ncgImpl) native) -        maybeDumpCfg logger dflags (Just nativeCfgWeights) "CFG Weights - Native" proc_name+        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 backendMaintainsCfg platform+        let livenessCfg = if ncgEnableDeadCodeElimination config                                 then Just nativeCfgWeights                                 else Nothing         let (withLiveness, usLive) =@@ -513,15 +500,14 @@                 initUs usGen                         $ mapM (cmmTopLiveness livenessCfg platform) native -        dumpIfSet_dyn logger dflags+        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 ( gopt Opt_RegsGraph dflags-           || gopt Opt_RegsIterative dflags )+         if ( ncgRegsGraph config || ncgRegsIterative config )           then do                 -- the regs usable for allocation                 let (alloc_regs :: UniqFM RegClass (UniqSet RealReg))@@ -553,12 +539,12 @@                   -- dump out what happened during register allocation-                dumpIfSet_dyn logger dflags+                putDumpFileMaybe logger                         Opt_D_dump_asm_regalloc "Registers allocated"                         FormatCMM                         (vcat $ map (pprNatCmmDecl ncgImpl) alloced) -                dumpIfSet_dyn logger dflags+                putDumpFileMaybe logger                         Opt_D_dump_asm_regalloc_stages "Build/spill stages"                         FormatText                         (vcat   $ map (\(stage, stats)@@ -568,7 +554,7 @@                                 $ zip [0..] regAllocStats)                  let mPprStats =-                        if dopt Opt_D_dump_asm_stats dflags+                        if logHasDumpFlag logger Opt_D_dump_asm_stats                          then Just regAllocStats else Nothing                  -- force evaluation of the Maybe to avoid space leak@@ -597,13 +583,13 @@                           $ liftM unzip3                           $ mapM reg_alloc withLiveness -                dumpIfSet_dyn logger dflags+                putDumpFileMaybe logger                         Opt_D_dump_asm_regalloc "Registers allocated"                         FormatCMM                         (vcat $ map (pprNatCmmDecl ncgImpl) alloced)                  let mPprStats =-                        if dopt Opt_D_dump_asm_stats dflags+                        if logHasDumpFlag logger Opt_D_dump_asm_stats                          then Just (catMaybes regAllocStats) else Nothing                  -- force evaluation of the Maybe to avoid space leak@@ -632,7 +618,7 @@                 {-# SCC "generateJumpTables" #-}                 generateJumpTables ncgImpl alloced -        when (not $ null nativeCfgWeights) $ dumpIfSet_dyn logger dflags+        when (not $ null nativeCfgWeights) $ putDumpFileMaybe logger                 Opt_D_dump_cfg_weights "CFG Update information"                 FormatText                 ( text "stack:" <+> ppr stack_updt_blks $$@@ -641,20 +627,20 @@         ---- shortcut branches         let (shorted, postShortCFG)     =                 {-# SCC "shortcutBranches" #-}-                shortcutBranches dflags ncgImpl tabled postRegCFG+                shortcutBranches config ncgImpl tabled postRegCFG          let optimizedCFG :: Maybe CFG             optimizedCFG =-                optimizeCFG (gopt Opt_CmmStaticPred dflags) weights cmm <$!> postShortCFG+                optimizeCFG (ncgCmmStaticPred config) weights cmm <$!> postShortCFG -        maybeDumpCfg logger dflags optimizedCFG "CFG Weights - Final" proc_name+        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 ( backendMaintainsCfg platform &&-                (gopt Opt_DoAsmLinting dflags || debugIsOn )) $ do+        when ( ncgEnableDeadCodeElimination config &&+                (ncgAsmLinting config || debugIsOn )) $ do                 let blocks = concatMap getBlks shorted                 let labels = setFromList $ fmap blockId blocks :: LabelSet                 let cfg = fromJust optimizedCFG@@ -682,41 +668,30 @@                 invert (CmmProc info lbl live (ListGraph blocks)) =                     CmmProc info lbl live (ListGraph $ invertConds info blocks) -        ---- expansion of SPARC synthetic instrs-        let expanded =-                {-# SCC "sparc_expand" #-}-                ncgExpandTop ncgImpl branchOpt-                --ncgExpandTop ncgImpl sequenced--        dumpIfSet_dyn logger dflags-                Opt_D_dump_asm_expanded "Synthetic instructions expanded"-                FormatCMM-                (vcat $ map (pprNatCmmDecl ncgImpl) expanded)-         -- generate unwinding information from cmm         let unwinds :: BlockMap [UnwindPoint]             unwinds =                 {-# SCC "unwindingInfo" #-}-                foldl' addUnwind mapEmpty expanded+                foldl' addUnwind mapEmpty branchOpt               where                 addUnwind acc proc =-                    acc `mapUnion` computeUnwinding dflags ncgImpl proc+                    acc `mapUnion` computeUnwinding config ncgImpl proc          return  ( usAlloc                 , fileIds'-                , expanded+                , branchOpt                 , lastMinuteImports ++ imports                 , ppr_raStatsColor                 , ppr_raStatsLinear                 , unwinds ) -maybeDumpCfg :: Logger -> DynFlags -> Maybe CFG -> String -> SDoc -> IO ()-maybeDumpCfg _logger _dflags Nothing _ _ = return ()-maybeDumpCfg logger dflags (Just cfg) msg proc_name+maybeDumpCfg :: Logger -> Maybe CFG -> String -> SDoc -> IO ()+maybeDumpCfg _logger Nothing _ _ = return ()+maybeDumpCfg logger (Just cfg) msg proc_name         | null cfg = return ()         | otherwise-        = dumpIfSet_dyn logger-                dflags Opt_D_dump_cfg_weights msg+        = putDumpFileMaybe logger+                Opt_D_dump_cfg_weights msg                 FormatText                 (proc_name <> char ':' $$ pprEdgeWeights cfg) @@ -724,8 +699,7 @@ checkLayout :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr]             -> [NatCmmDecl statics instr] checkLayout procsUnsequenced procsSequenced =-        ASSERT2(setNull diff,-                ppr "Block sequencing dropped blocks:" <> ppr diff)+        assertPpr (setNull diff) (ppr "Block sequencing dropped blocks:" <> ppr diff)         procsSequenced   where         blocks1 = foldl' (setUnion) setEmpty $@@ -740,15 +714,16 @@  -- | Compute unwinding tables for the blocks of a procedure computeUnwinding :: Instruction instr-                 => DynFlags -> NcgImpl statics instr jumpDest+                 => 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 dflags _ _-  | debugLevel dflags == 0         = mapEmpty-computeUnwinding _ _ (CmmData _ _) = mapEmpty+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@@ -834,14 +809,15 @@ -- Shortcut branches  shortcutBranches-        :: forall statics instr jumpDest. (Outputable jumpDest) => DynFlags+        :: forall statics instr jumpDest. (Outputable jumpDest)+        => NCGConfig         -> NcgImpl statics instr jumpDest         -> [NatCmmDecl statics instr]         -> Maybe CFG         -> ([NatCmmDecl statics instr],Maybe CFG) -shortcutBranches dflags ncgImpl tops weights-  | gopt Opt_AsmShortcutting dflags+shortcutBranches config ncgImpl tops weights+  | ncgEnableShortcutting config   = ( map (apply_mapping ncgImpl mapping) tops'     , shortcutWeightMap mappingBid <$!> weights )   | otherwise@@ -1146,56 +1122,3 @@          other            -> return other---- | 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 AsmStyle)-   , 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-   , ncgAsmLinting            = gopt Opt_DoAsmLinting dflags-   , ncgCfgWeights            = cfgWeights dflags-   , ncgCfgBlockLayout        = gopt Opt_CfgBlocklayout dflags-   , ncgCfgWeightlessLayout   = gopt Opt_WeightlessBlocklayout dflags--     -- With -O1 and greater, the cmmSink pass does constant-folding, so-     -- we don't need to do it again in the native code generator.-   , ncgDoConstantFolding     = optLevel dflags < 1--   , ncgDumpRegAllocStages    = dopt Opt_D_dump_asm_regalloc_stages dflags-   , ncgDumpAsmStats          = dopt Opt_D_dump_asm_stats dflags-   , ncgDumpAsmConflicts      = dopt Opt_D_dump_asm_conflicts dflags-   , ncgBmiVersion            = case platformArch (targetPlatform dflags) of-                                 ArchX86_64 -> bmiVersion dflags-                                 ArchX86    -> bmiVersion dflags-                                 _          -> Nothing--     -- We assume  SSE1 and SSE2 operations are available on both-     -- x86 and x86_64. Historically we didn't default to SSE2 and-     -- SSE1 on x86, which results in defacto nondeterminism for how-     -- rounding behaves in the associated x87 floating point instructions-     -- because variations in the spill/fpu stack placement of arguments for-     -- operations would change the precision and final result of what-     -- would otherwise be the same expressions with respect to single or-     -- double precision IEEE floating point computations.-   , ncgSseVersion =-      let v | sseVersion dflags < Just SSE2 = Just SSE2-            | otherwise                     = sseVersion dflags-      in case platformArch (targetPlatform dflags) of-            ArchX86_64 -> v-            ArchX86    -> v-            _          -> Nothing--   , ncgDwarfEnabled        = osElfTarget (platformOS (targetPlatform dflags)) && debugLevel dflags > 0 && platformArch (targetPlatform dflags) /= ArchAArch64-   , ncgDwarfUnwindings     = osElfTarget (platformOS (targetPlatform dflags)) && debugLevel dflags > 0-   , ncgDwarfStripBlockInfo = osElfTarget (platformOS (targetPlatform dflags)) && debugLevel dflags < 2 -- We strip out block information when running with -g0 or -g1.-   , ncgDwarfSourceNotes    = osElfTarget (platformOS (targetPlatform dflags)) && debugLevel dflags > 2 -- We produce GHC-specific source-note DIEs only with -g3-   , ncgExposeInternalSymbols = gopt Opt_ExposeInternalSymbols dflags-   }
GHC/CmmToAsm/AArch64.hs view
@@ -32,7 +32,6 @@        ,maxSpillSlots             = AArch64.maxSpillSlots config        ,allocatableRegs           = AArch64.allocatableRegs platform        ,ncgAllocMoreStack         = AArch64.allocMoreStack platform-       ,ncgExpandTop              = id        ,ncgMakeFarBranches        = const id        ,extractUnwindPoints       = const []        ,invertCondBranches        = \_ _ -> id
GHC/CmmToAsm/AArch64/CodeGen.hs view
@@ -1,5 +1,4 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE GADTs #-}+{-# language GADTs #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE BinaryLiterals #-}@@ -12,8 +11,6 @@  where -#include "HsVersions.h"- -- NCG stuff: import GHC.Prelude hiding (EQ) @@ -65,6 +62,7 @@ import GHC.Utils.Panic  -- Note [General layout of an NCG]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- @cmmTopCodeGen@ will be our main entry point to code gen.  Here we'll get -- @RawCmmDecl@; see GHC.Cmm --@@ -173,7 +171,7 @@ -- ----------------------------------------------------------------------------- -- | Utilities ann :: SDoc -> Instr -> Instr-ann doc instr {- | debugIsOn -} = ANN doc instr+ann doc instr {- debugIsOn -} = ANN doc instr -- ann _ instr = instr {-# INLINE ann #-} @@ -201,8 +199,8 @@ -- 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 e instr {- debugIsOn -} = ANN (text . show $ e) instr+-- annExpr e instr {- debugIsOn -} = ANN (pprExpr genericPlatform e) instr -- annExpr _ instr = instr {-# INLINE annExpr #-} @@ -478,7 +476,7 @@ getRegister' :: NCGConfig -> Platform -> CmmExpr -> NatM Register -- OPTIMIZATION WARNING: CmmExpr rewrites -- 1. Rewrite: Reg + (-n) => Reg - n---    TODO: this expression souldn't even be generated to begin with.+--    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)]) @@ -664,11 +662,10 @@         -- 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`+                signExtendReg w w' reg `snocOL`+                NEG (OpReg w' dst) (OpReg w' reg) `appOL`                 truncateReg w' w dst          ss_conv from to reg code =@@ -797,7 +794,7 @@             -- <OP> x<n>, x<m>, x<o>             (reg_x, format_x, code_x) <- getSomeReg x             (reg_y, format_y, code_y) <- getSomeReg y-            MASSERT2(isIntFormat format_x == isIntFormat format_y, text "bitOp: incompatible")+            massertPpr (isIntFormat format_x == isIntFormat format_y) $ text "bitOp: incompatible"             return $ Any (intFormat w) (\dst ->                 code_x `appOL`                 code_y `appOL`@@ -813,35 +810,33 @@               -- <OP> x<n>, x<m>, x<o>               (reg_x, format_x, code_x) <- getSomeReg x               (reg_y, format_y, code_y) <- getSomeReg y-              MASSERT2(isIntFormat format_x && isIntFormat format_y, text "intOp: non-int")+              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)+                    | not is_signed  = 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`+                  signExt reg_x `appOL`+                  signExt reg_y `appOL`+                  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-            MASSERT2(isFloatFormat format_x && isFloatFormat format_y, text "floatOp: non-float")+            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-            MASSERT2(isFloatFormat format_x && isFloatFormat format_y, text "floatCond: non-float")+            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@@ -852,7 +847,7 @@         MO_Sub w -> intOp False w (\d x y -> unitOL $ annExpr expr (SUB d x y))          -- Note [CSET]-        --+        -- ~~~~~~~~~~~         -- Setting conditional flags: the architecture internally knows the         -- following flag bits.  And based on thsoe comparisons as in the         -- table below.@@ -1024,21 +1019,16 @@  -- | 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 :: Width -> Width -> Reg -> OrdList Instr signExtendReg w w' r =     case w of-      W64 -> noop+      W64 -> nilOL       W32-        | w' == W32 -> noop-        | otherwise -> extend SXTH-      W16           -> extend SXTH-      W8            -> extend SXTB+        | w' == W32 -> nilOL+        | otherwise -> unitOL $ SXTH (OpReg w' r) (OpReg w' r)+      W16           -> unitOL $ SXTH (OpReg w' r) (OpReg w' r)+      W8            -> unitOL $ SXTB (OpReg w' r) (OpReg w' r)       _             -> 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'@.@@ -1316,7 +1306,7 @@ -- -- 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>]--- instaed of the add instruction.+-- 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@@ -1524,6 +1514,9 @@         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)@@ -1546,11 +1539,11 @@     unsupported :: Show a => a -> b     unsupported mop = panic ("outOfLineCmmOp: " ++ show mop                           ++ " not supported here")-    mkCCall :: String -> NatM (InstrBlock, Maybe BlockId)+    mkCCall :: FastString -> NatM (InstrBlock, Maybe BlockId)     mkCCall name = do       config <- getConfig       target <- cmmMakeDynamicReference config CallReference $-          mkForeignLabel (fsLit name) Nothing ForeignLabelInThisPackage IsFunction+          mkForeignLabel name Nothing ForeignLabelInThisPackage IsFunction       let cconv = ForeignConvention CCallConv [NoHint] [NoHint] CmmMayReturn       genCCall (ForeignTarget target cconv) dest_regs arg_regs bid
GHC/CmmToAsm/AArch64/Instr.hs view
@@ -28,7 +28,6 @@  import GHC.Utils.Panic -import Control.Monad (replicateM) import Data.Maybe (fromMaybe)  import GHC.Stack@@ -73,12 +72,6 @@ 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)   CMN l r                  -> usage (regOp l ++ regOp r, [])@@ -143,7 +136,7 @@   FCVTZS dst src           -> usage (regOp src, regOp dst)   FABS dst src             -> usage (regOp src, regOp dst) -  _ -> panic $ "regUsageOfInstr: " ++ instrCon instr+  _ -> panic "regUsageOfInstr"    where         -- filtering the usage is necessary, otherwise the register@@ -173,8 +166,6 @@         interesting _        (RegVirtual _)                 = True         interesting _        (RegReal (RealRegSingle (-1))) = False         interesting platform (RegReal (RealRegSingle i))    = freeReg platform i-        interesting _        (RegReal (RealRegPair{}))-            = panic "AArch64.Instr.interesting: no reg pairs on this arch"  -- Save caller save registers -- This is x0-x18@@ -209,12 +200,7 @@ 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+    ANN d i        -> ANN d (patchRegsOfInstr i env)     -- 1. Arithmetic Instructions ----------------------------------------------     ADD o1 o2 o3   -> ADD (patchOp o1) (patchOp o2) (patchOp o3)     CMN o1 o2      -> CMN (patchOp o1) (patchOp o2)@@ -280,7 +266,8 @@     SCVTF o1 o2    -> SCVTF (patchOp o1) (patchOp o2)     FCVTZS o1 o2   -> FCVTZS (patchOp o1) (patchOp o2)     FABS o1 o2     -> FABS (patchOp o1) (patchOp o2)-    _              -> panic $ "patchRegsOfInstr: " ++ instrCon instr++    _ -> pprPanic "patchRegsOfInstr" (text $ show instr)     where         patchOp :: Operand -> Operand         patchOp (OpReg w r) = OpReg w (env r)@@ -336,7 +323,7 @@         B (TBlock bid) -> B (TBlock (patchF bid))         BL (TBlock bid) ps rs -> BL (TBlock (patchF bid)) ps rs         BCOND c (TBlock bid) -> BCOND c (TBlock (patchF bid))-        _ -> panic $ "patchJumpInstr: " ++ instrCon instr+        _ -> pprPanic "patchJumpInstr" (text $ show instr)  -- ----------------------------------------------------------------------------- -- Note [Spills and Reloads]@@ -463,7 +450,7 @@ mkStackDeallocInstr _platform n = pprPanic "mkStackDeallocInstr" (int n)  ----- See note [extra spill slots] in X86/Instr.hs+-- See Note [extra spill slots] in X86/Instr.hs -- allocMoreStack   :: Platform@@ -475,7 +462,7 @@ allocMoreStack platform slots proc@(CmmProc info lbl live (ListGraph code)) = do     let entries = entryBlocks proc -    uniqs <- replicateM (length entries) getUniqueM+    uniqs <- getUniquesM      let       delta = ((x + stackAlign - 1) `quot` stackAlign) * stackAlign -- round up@@ -648,69 +635,10 @@     -- Float ABSolute value     | FABS Operand Operand -instrCon :: Instr -> String-instrCon i =-    case i of-      COMMENT{} -> "COMMENT"-      MULTILINE_COMMENT{} -> "COMMENT"-      ANN{} -> "ANN"-      LOCATION{} -> "LOCATION"-      LDATA{} -> "LDATA"-      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"-      CMN{} -> "CMN"-      CMP{} -> "CMP"-      MSUB{} -> "MSUB"-      MUL{} -> "MUL"-      NEG{} -> "NEG"-      SDIV{} -> "SDIV"-      SMULH{} -> "SMULH"-      SMULL{} -> "SMULL"-      SUB{} -> "SUB"-      UDIV{} -> "UDIV"-      SBFM{} -> "SBFM"-      UBFM{} -> "UBFM"-      SBFX{} -> "SBFX"-      UBFX{} -> "UBFX"-      AND{} -> "AND"-      ANDS{} -> "ANDS"-      ASR{} -> "ASR"-      BIC{} -> "BIC"-      BICS{} -> "BICS"-      EON{} -> "EON"-      EOR{} -> "EOR"-      LSL{} -> "LSL"-      LSR{} -> "LSR"-      MOV{} -> "MOV"-      MOVK{} -> "MOVK"-      MVN{} -> "MVN"-      ORN{} -> "ORN"-      ORR{} -> "ORR"-      ROR{} -> "ROR"-      TST{} -> "TST"-      STR{} -> "STR"-      LDR{} -> "LDR"-      STP{} -> "STP"-      LDP{} -> "LDP"-      CSET{} -> "CSET"-      CBZ{} -> "CBZ"-      CBNZ{} -> "CBNZ"-      J{} -> "J"-      B{} -> "B"-      BL{} -> "BL"-      BCOND{} -> "BCOND"-      DMBSY{} -> "DMBSY"-      FCVT{} -> "FCVT"-      SCVTF{} -> "SCVTF"-      FCVTZS{} -> "FCVTZS"-      FABS{} -> "FABS"+instance Show Instr where+    show (LDR _f o1 o2) = "LDR " ++ show o1 ++ ", " ++ show o2+    show (MOV o1 o2) = "MOV " ++ show o1 ++ ", " ++ show o2+    show _ = "missing"  data Target     = TBlock BlockId@@ -838,11 +766,11 @@ 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)+opRegUExt w  _r = pprPanic "opRegUExt" (text $ show w)  opRegSExt :: Width -> Reg -> Operand opRegSExt W64 r = OpRegExt W64 r ESXTX 0 opRegSExt W32 r = OpRegExt W32 r ESXTW 0 opRegSExt W16 r = OpRegExt W16 r ESXTH 0 opRegSExt W8  r = OpRegExt W8  r ESXTB 0-opRegSExt w  _r = pprPanic "opRegSExt" (ppr w)+opRegSExt w  _r = pprPanic "opRegSExt" (text $ show w)
GHC/CmmToAsm/AArch64/Ppr.hs view
@@ -5,11 +5,6 @@  import GHC.Prelude hiding (EQ) -import Data.Word-import qualified Data.Array.Unsafe as U ( castSTUArray )-import Data.Array.ST-import Control.Monad.ST- import GHC.CmmToAsm.AArch64.Instr import GHC.CmmToAsm.AArch64.Regs import GHC.CmmToAsm.AArch64.Cond@@ -147,7 +142,7 @@              then ppr (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]+    -- coming right after it. See Note [Info Offset]     infoTableLoc = case instrs of       (l@LOCATION{} : _) -> pprInstr platform l       _other             -> empty@@ -187,11 +182,12 @@   | otherwise = text "\t.globl " <> pdoc 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 migth 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.+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- See discussion in X86.Ppr for why this is necessary.  Essentially we need to+-- ensure that we never pass function symbols when we migth 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.@@ -227,30 +223,14 @@          ppr_item FF32  (CmmFloat r _)            = let bs = floatToBytes (fromRational r)-             in  map (\b -> text "\t.byte\t" <> pprImm platform (ImmInt b)) bs+             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" <> pprImm platform (ImmInt b)) bs+             in  map (\b -> text "\t.byte\t" <> int (fromIntegral b)) bs          ppr_item _ _ = pprPanic "pprDataItem:ppr_item" (text $ show lit) -floatToBytes :: Float -> [Int]-floatToBytes f-   = runST (do-        arr <- newArray_ ((0::Int),3)-        writeArray arr 0 f-        arr <- castFloatToWord8Array arr-        i0 <- readArray arr 0-        i1 <- readArray arr 1-        i2 <- readArray arr 2-        i3 <- readArray arr 3-        return (map fromIntegral [i0,i1,i2,i3])-     )--castFloatToWord8Array :: STUArray s Int Float -> ST s (STUArray s Int Word8)-castFloatToWord8Array = U.castSTUArray- pprImm :: Platform -> Imm -> SDoc pprImm _ (ImmInt i)     = int i pprImm _ (ImmInteger i) = integer i@@ -339,7 +319,6 @@ pprReg :: Width -> Reg -> SDoc pprReg w r = case r of   RegReal    (RealRegSingle i) -> ppr_reg_no w i-  RegReal    (RealRegPair{})   -> panic "AArch64.pprReg: no reg pairs on this arch!"   -- 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
GHC/CmmToAsm/AArch64/Regs.hs view
@@ -129,16 +129,12 @@                         | regNo < 32    -> 1     -- first fp reg is 32                         | otherwise     -> 0 -                RealRegPair{}           -> 0-         RcDouble          -> case rr of                 RealRegSingle regNo                         | regNo < 32    -> 0                         | otherwise     -> 1 -                RealRegPair{}           -> 0-         _other -> 0  mkVirtualReg :: Unique -> Format -> VirtualReg@@ -155,9 +151,6 @@ classOfRealReg (RealRegSingle i)         | i < 32        = RcInteger         | otherwise     = RcDouble--classOfRealReg (RealRegPair{})-        = panic "regClass(ppr): no reg pairs on this architecture"  regDotColor :: RealReg -> SDoc regDotColor reg
GHC/CmmToAsm/BlockLayout.hs view
@@ -13,10 +13,9 @@     ( sequenceTop, backendMaintainsCfg) where -#include "HsVersions.h" import GHC.Prelude -import GHC.Driver.Ppr     (pprTrace)+import GHC.Platform  import GHC.CmmToAsm.Instr import GHC.CmmToAsm.Monad@@ -24,29 +23,26 @@ import GHC.CmmToAsm.Types import GHC.CmmToAsm.Config -import GHC.Cmm.BlockId import GHC.Cmm+import GHC.Cmm.BlockId import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Label -import GHC.Platform import GHC.Types.Unique.FM-import GHC.Utils.Misc  import GHC.Data.Graph.Directed-import GHC.Utils.Outputable-import GHC.Utils.Panic import GHC.Data.Maybe---- DEBUGGING ONLY---import GHC.Cmm.DebugBlock---import Debug.Trace import GHC.Data.List.SetOps (removeDups)- import GHC.Data.OrdList++import GHC.Utils.Trace+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Utils.Panic.Plain+import GHC.Utils.Misc+ import Data.List (sortOn, sortBy, nub) import Data.Foldable (toList)- import qualified Data.Set as Set import Data.STRef import Control.Monad.ST.Strict@@ -71,10 +67,9 @@   * 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]-  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +  Note [Chain based CFG serialization]+  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~   For additional information also look at   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/code-layout @@ -193,10 +188,9 @@   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]-  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +  Note [Triangle Control Flow]+  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~   Checking if an argument is already evaluated leads to a somewhat   special case  which looks like this: @@ -244,10 +238,9 @@   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]-  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +  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@@ -313,7 +306,7 @@ -- in the chain. instance Ord (BlockChain) where    (BlockChain lbls1) `compare` (BlockChain lbls2)-       = ASSERT(toList lbls1 /= toList lbls2 || lbls1 `strictlyEqOL` lbls2)+       = assert (toList lbls1 /= toList lbls2 || lbls1 `strictlyEqOL` lbls2) $          strictlyOrdOL lbls1 lbls2  instance Outputable (BlockChain) where@@ -377,9 +370,9 @@ 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. --@@ -709,7 +702,7 @@             directEdges          (neighbourChains, combined)-            = ASSERT(noDups $ mapElems builtChains)+            = assert (noDups $ mapElems builtChains) $               {-# SCC "groupNeighbourChains" #-}             --   pprTraceIt "NeighbourChains" $               combineNeighbourhood rankedEdges (mapElems builtChains)@@ -749,7 +742,7 @@ #endif          blockList-            = ASSERT(noDups [masterChain])+            = assert (noDups [masterChain])               (concatMap fromOL $ map chainBlocks prepedChains)          --chainPlaced = setFromList $ map blockId blockList :: LabelSet@@ -763,14 +756,14 @@             -- 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)+            assert (null unplaced) $             --pprTraceIt "placedBlocks" $             -- ++ [] is stil kinda expensive             if null unplaced then blockList else blockList ++ unplaced         getBlock bid = expectJust "Block placement" $ mapLookup bid blockMap     in         --Assert we placed all blocks given as input-        ASSERT(all (\bid -> mapMember bid blockMap) placedBlocks)+        assert (all (\bid -> mapMember bid blockMap) placedBlocks) $         dropJumps info $ map getBlock placedBlocks  {-# SCC dropJumps #-}
GHC/CmmToAsm/CFG.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP                        #-} {-# LANGUAGE DataKinds                  #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE Rank2Types                 #-}@@ -42,8 +41,6 @@      ) where -#include "HsVersions.h"- import GHC.Prelude import GHC.Platform @@ -76,6 +73,7 @@  import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain -- DEBUGGING ONLY --import GHC.Cmm.DebugBlock --import GHC.Data.OrdList@@ -152,7 +150,7 @@ -- 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 Conditional Branches]+-- See also Note [Inverting conditions] data TransitionSource   = CmmSource { trans_cmmNode :: (CmmNode O C)               , trans_info :: BranchInfo }@@ -215,7 +213,7 @@ 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))+  assert (found || not (any (mapMember node) m))   found     where       found = mapMember node m@@ -240,7 +238,7 @@       diff = (setUnion cfgNodes blockSet) `setDifference` (setIntersection cfgNodes blockSet) :: LabelSet  -- | Filter the CFG with a custom function f.---   Paramaeters are `f from to edgeInfo`+--   Parameters are `f from to edgeInfo` filterEdges :: (BlockId -> BlockId -> EdgeInfo -> Bool) -> CFG -> CFG filterEdges f cfg =     mapMapWithKey filterSources cfg@@ -250,7 +248,7 @@   {- 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. @@ -667,8 +665,8 @@         (CmmCall { cml_cont = Nothing })   -> []         other ->             panic "Foo" $-            ASSERT2(False, ppr "Unknown successor cause:" <>-              (pdoc platform branch <+> text "=>" <> pdoc platform (G.successors other)))+            assertPpr False (ppr "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@@ -714,7 +712,7 @@     increaseBackEdgeWeight (g_entry graph) $ cfg   where -    -- | Increase the weight of all backedges in the CFG+    -- 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 =@@ -727,7 +725,7 @@         in  foldl'  (\cfg edge -> updateEdgeWeight update edge cfg)                     cfg backedges -    -- | Since we cant fall through info tables we penalize these.+    -- Since we cant fall through info tables we penalize these.     penalizeInfoTables :: LabelMap a -> CFG -> CFG     penalizeInfoTables info cfg =         mapWeights fupdate cfg@@ -738,7 +736,7 @@           = weight - (fromIntegral $ infoTablePenalty weights)           | otherwise = weight -    -- | If a block has two successors, favour the one with fewer+    -- If a block has two successors, favour the one with fewer     -- predecessors and/or the one allowing fall through.     favourFewerPreds :: CFG -> CFG     favourFewerPreds cfg =@@ -1015,7 +1013,6 @@  {- 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.
GHC/CmmToAsm/CPrim.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE LambdaCase #-}+ -- | Generating C symbol names emitted by the compiler. module GHC.CmmToAsm.CPrim     ( atomicReadLabel@@ -15,130 +17,144 @@     , word2FloatLabel     ) where -import GHC.Prelude- import GHC.Cmm.Type import GHC.Cmm.MachOp+import GHC.Data.FastString import GHC.Utils.Outputable import GHC.Utils.Panic -popCntLabel :: Width -> String-popCntLabel w = "hs_popcnt" ++ pprWidth w-  where-    pprWidth W8  = "8"-    pprWidth W16 = "16"-    pprWidth W32 = "32"-    pprWidth W64 = "64"-    pprWidth w   = pprPanic "popCntLabel: Unsupported word width " (ppr w)+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 -> String-pdepLabel w = "hs_pdep" ++ pprWidth w-  where-    pprWidth W8  = "8"-    pprWidth W16 = "16"-    pprWidth W32 = "32"-    pprWidth W64 = "64"-    pprWidth w   = pprPanic "pdepLabel: Unsupported word width " (ppr w)+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 -> String-pextLabel w = "hs_pext" ++ pprWidth w-  where-    pprWidth W8  = "8"-    pprWidth W16 = "16"-    pprWidth W32 = "32"-    pprWidth W64 = "64"-    pprWidth w   = pprPanic "pextLabel: Unsupported word width " (ppr w)+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 -> String-bSwapLabel w = "hs_bswap" ++ pprWidth w-  where-    pprWidth W16 = "16"-    pprWidth W32 = "32"-    pprWidth W64 = "64"-    pprWidth w   = pprPanic "bSwapLabel: Unsupported word width " (ppr w)+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 -> String-bRevLabel w = "hs_bitrev" ++ pprWidth w-  where-    pprWidth W8  = "8"-    pprWidth W16 = "16"-    pprWidth W32 = "32"-    pprWidth W64 = "64"-    pprWidth w   = pprPanic "bRevLabel: Unsupported word width " (ppr w)+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 -> String-clzLabel w = "hs_clz" ++ pprWidth w-  where-    pprWidth W8  = "8"-    pprWidth W16 = "16"-    pprWidth W32 = "32"-    pprWidth W64 = "64"-    pprWidth w   = pprPanic "clzLabel: Unsupported word width " (ppr w)+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 -> String-ctzLabel w = "hs_ctz" ++ pprWidth w-  where-    pprWidth W8  = "8"-    pprWidth W16 = "16"-    pprWidth W32 = "32"-    pprWidth W64 = "64"-    pprWidth w   = pprPanic "ctzLabel: Unsupported word width " (ppr w)+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 -> String-word2FloatLabel w = "hs_word2float" ++ pprWidth w-  where-    pprWidth W32 = "32"-    pprWidth W64 = "64"-    pprWidth w   = pprPanic "word2FloatLabel: 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 -> String-atomicRMWLabel w amop = "hs_atomic_" ++ pprFunName amop ++ pprWidth w-  where-    pprWidth W8  = "8"-    pprWidth W16 = "16"-    pprWidth W32 = "32"-    pprWidth W64 = "64"-    pprWidth w   = pprPanic "atomicRMWLabel: Unsupported word width " (ppr w)+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 concatening 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) -    pprFunName AMO_Add  = "add"-    pprFunName AMO_Sub  = "sub"-    pprFunName AMO_And  = "and"-    pprFunName AMO_Nand = "nand"-    pprFunName AMO_Or   = "or"-    pprFunName AMO_Xor  = "xor" -xchgLabel :: Width -> String-xchgLabel w = "hs_xchg" ++ pprWidth w-  where-    pprWidth W8  = "8"-    pprWidth W16 = "16"-    pprWidth W32 = "32"-    pprWidth W64 = "64"-    pprWidth w   = pprPanic "xchgLabel: 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 -> String-cmpxchgLabel w = "hs_cmpxchg" ++ pprWidth w-  where-    pprWidth W8  = "8"-    pprWidth W16 = "16"-    pprWidth W32 = "32"-    pprWidth W64 = "64"-    pprWidth w   = pprPanic "cmpxchgLabel: Unsupported word width " (ppr w)+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 -> String-atomicReadLabel w = "hs_atomicread" ++ pprWidth w-  where-    pprWidth W8  = "8"-    pprWidth W16 = "16"-    pprWidth W32 = "32"-    pprWidth W64 = "64"-    pprWidth w   = pprPanic "atomicReadLabel: Unsupported word width " (ppr w)+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 -> String-atomicWriteLabel w = "hs_atomicwrite" ++ pprWidth w-  where-    pprWidth W8  = "8"-    pprWidth W16 = "16"-    pprWidth W32 = "32"-    pprWidth W64 = "64"-    pprWidth w   = pprPanic "atomicWriteLabel: Unsupported word width " (ppr w)+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
@@ -26,6 +26,7 @@    , 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@@ -41,6 +42,10 @@    , ncgDwarfStripBlockInfo   :: !Bool            -- ^ Strip out block information from generated Dwarf    , ncgExposeInternalSymbols :: !Bool            -- ^ Expose symbol table entries for internal symbols    , ncgDwarfSourceNotes      :: !Bool            -- ^ Enable GHC-specific source note DIEs+   , ncgCmmStaticPred         :: !Bool            -- ^ Enable static control-flow prediction+   , ncgEnableShortcutting    :: !Bool            -- ^ Enable shortcutting (don't jump to blocks only containing a jump)+   , ncgComputeUnwinding      :: !Bool            -- ^ Compute block unwinding tables+   , ncgEnableDeadCodeElimination :: !Bool        -- ^ Whether to enable the dead-code elimination    }  -- | Return Word size
GHC/CmmToAsm/Dwarf.hs view
@@ -51,8 +51,8 @@         , dwName = fromMaybe "" (ml_hs_file modLoc)         , dwCompDir = addTrailingPathSeparator compPath         , dwProducer = cProjectName ++ " " ++ cProjectVersion-        , dwLowLabel = lowLabel-        , dwHighLabel = highLabel+        , dwLowLabel = pdoc platform lowLabel+        , dwHighLabel = pdoc platform highLabel         , dwLineLabel = dwarfLineLabel         } @@ -69,7 +69,7 @@   -- .debug_info section: Information records on procedures and blocks   let -- unique to identify start and end compilation unit .debug_inf       (unitU, us') = takeUniqFromSupply us-      infoSct = vcat [ ptext dwarfInfoLabel <> colon+      infoSct = vcat [ dwarfInfoLabel <> colon                      , dwarfInfoSection platform                      , compileUnitHeader platform unitU                      , pprDwarfInfo platform haveSrc dwarfUnit@@ -79,12 +79,12 @@   -- .debug_line section: Generated mainly by the assembler, but we   -- need to label it   let lineSct = dwarfLineSection platform $$-                ptext dwarfLineLabel <> colon+                dwarfLineLabel <> colon    -- .debug_frame section: Information about the layout of the GHC stack   let (framesU, us'') = takeUniqFromSupply us'       frameSct = dwarfFrameSection platform $$-                 ptext dwarfFrameLabel <> colon $$+                 dwarfFrameLabel <> colon $$                  pprDwarfFrame platform (debugFrame framesU procs)    -- .aranges section: Information about the bounds of compilation units@@ -114,7 +114,7 @@   in vcat [ pdoc platform cuLabel <> colon           , text "\t.long " <> length  -- compilation unit size           , pprHalf 3                          -- DWARF version-          , sectionOffset platform (ptext dwarfAbbrevLabel) (ptext dwarfAbbrevLabel)+          , sectionOffset platform dwarfAbbrevLabel dwarfAbbrevLabel                                                -- abbrevs offset           , text "\t.byte " <> ppr (platformWordSizeInBytes platform) -- word size           ]@@ -148,7 +148,7 @@  {- 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,@@ -245,7 +245,7 @@           where uws'   = addDefaultUnwindings initUws uws                 nested = concatMap flatten blocks -        -- | If the current procedure has an info table, then we also say that+        -- 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".
GHC/CmmToAsm/Dwarf/Constants.hs view
@@ -6,7 +6,6 @@ import GHC.Prelude  import GHC.Utils.Asm-import GHC.Data.FastString import GHC.Platform import GHC.Utils.Outputable @@ -165,11 +164,11 @@        -> text "\t.section .debug_" <> text name <> text ",\"dr\""  -- * Dwarf section labels-dwarfInfoLabel, dwarfAbbrevLabel, dwarfLineLabel, dwarfFrameLabel :: PtrString-dwarfInfoLabel   = sLit ".Lsection_info"-dwarfAbbrevLabel = sLit ".Lsection_abbrev"-dwarfLineLabel   = sLit ".Lsection_line"-dwarfFrameLabel  = sLit ".Lsection_frame"+dwarfInfoLabel, dwarfAbbrevLabel, dwarfLineLabel, dwarfFrameLabel :: SDoc+dwarfInfoLabel   = text ".Lsection_info"+dwarfAbbrevLabel = text ".Lsection_abbrev"+dwarfLineLabel   = text ".Lsection_line"+dwarfFrameLabel  = text ".Lsection_frame"  -- | Mapping of registers to DWARF register numbers dwarfRegNo :: Platform -> Reg -> Word8
GHC/CmmToAsm/Dwarf/Types.hs view
@@ -44,7 +44,7 @@ import GHC.CmmToAsm.Dwarf.Constants  import qualified Data.ByteString as BS-import qualified Control.Monad.Trans.State.Strict as S+import qualified GHC.Utils.Monad.State.Strict as S import Control.Monad (zipWithM, join) import qualified Data.Map as Map import Data.Word@@ -59,9 +59,9 @@                      , dwName :: String                      , dwProducer :: String                      , dwCompDir :: String-                     , dwLowLabel :: CLabel-                     , dwHighLabel :: CLabel-                     , dwLineLabel :: PtrString }+                     , dwLowLabel :: SDoc+                     , dwHighLabel :: SDoc+                     , dwLineLabel :: SDoc }   | DwarfSubprogram { dwChildren :: [DwarfInfo]                     , dwName :: String                     , dwLabel :: CLabel@@ -111,7 +111,7 @@            , (dW_AT_frame_base, dW_FORM_block1)            ]   in dwarfAbbrevSection platform $$-     ptext dwarfAbbrevLabel <> colon $$+     dwarfAbbrevLabel <> colon $$      mkAbbrev DwAbbrCompileUnit dW_TAG_compile_unit dW_CHILDREN_yes        ([(dW_AT_name,     dW_FORM_string)        , (dW_AT_producer, dW_FORM_string)@@ -178,10 +178,10 @@   $$ pprData4 dW_LANG_Haskell   $$ pprString compDir      -- Offset due to Note [Info Offset]-  $$ pprWord platform (pdoc platform lowLabel <> text "-1")-  $$ pprWord platform (pdoc platform highLabel)+  $$ pprWord platform (lowLabel <> text "-1")+  $$ pprWord platform highLabel   $$ if haveSrc-     then sectionOffset platform (ptext lineLbl) (ptext dwarfLineLabel)+     then sectionOffset platform lineLbl dwarfLineLabel      else empty pprDwarfInfoOpen platform _ (DwarfSubprogram _ name label parent) =   pdoc platform (mkAsmTempDieLabel label) <> colon@@ -199,7 +199,7 @@     abbrev = case parent of Nothing -> DwAbbrSubprogram                             Just _  -> DwAbbrSubprogramWithParent     parentValue = maybe empty pprParentDie parent-    pprParentDie sym = sectionOffset platform (pdoc platform sym) (ptext dwarfInfoLabel)+    pprParentDie sym = sectionOffset platform (pdoc platform sym) dwarfInfoLabel pprDwarfInfoOpen platform _ (DwarfBlock _ label Nothing) =   pdoc platform (mkAsmTempDieLabel label) <> colon   $$ pprAbbrev DwAbbrBlockWithoutCode@@ -245,8 +245,7 @@       initialLength = 8 + paddingSize + (1 + length arngs) * 2 * wordSize   in pprDwWord (ppr initialLength)      $$ pprHalf 2-     $$ sectionOffset platform (pdoc platform $ mkAsmTempLabel $ unitU)-                               (ptext dwarfInfoLabel)+     $$ sectionOffset platform (pdoc platform $ mkAsmTempLabel $ unitU) dwarfInfoLabel      $$ pprByte (fromIntegral wordSize)      $$ pprByte 0      $$ pad paddingSize@@ -258,7 +257,7 @@  pprDwarfARange :: Platform -> DwarfARange -> SDoc pprDwarfARange platform arng =-    -- Offset due to Note [Info offset].+    -- Offset due to Note [Info Offset].     pprWord platform (pdoc platform (dwArngStartLabel arng) <> text "-1")     $$ pprWord platform length   where@@ -364,8 +363,7 @@     in vcat [ whenPprDebug $ text "# Unwinding for" <+> pdoc platform procLbl <> colon             , pprData4' (pdoc platform fdeEndLabel <> char '-' <> pdoc platform fdeLabel)             , pdoc platform fdeLabel <> colon-            , pprData4' (pdoc platform frameLbl <> char '-' <>-                         ptext dwarfFrameLabel)    -- Reference to CIE+            , pprData4' (pdoc platform frameLbl <> char '-' <> dwarfFrameLabel)    -- Reference to CIE             , pprWord platform (pdoc platform procLbl <> ifInfo "-1") -- Code pointer             , pprWord platform (pdoc platform procEnd <> char '-' <>                                  pdoc platform procLbl <> ifInfo "+1") -- Block byte length@@ -412,7 +410,6 @@  -- 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@@ -602,7 +599,7 @@   = pprString' $ hcat $ map escapeChar $     if str `lengthIs` utf8EncodedLength str     then str-    else map (chr . fromIntegral) $ BS.unpack $ bytesFS $ mkFastString str+    else map (chr . fromIntegral) $ BS.unpack $ utf8EncodeString str  -- | Escape a single non-unicode character escapeChar :: Char -> SDoc
GHC/CmmToAsm/Monad.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE BangPatterns #-} @@ -30,7 +29,6 @@         getBlockIdNat,         getNewLabelNat,         getNewRegNat,-        getNewRegPairNat,         getPicBaseMaybeNat,         getPicBaseNat,         getCfgWeights,@@ -38,13 +36,15 @@         getFileId,         getDebugBlock, -        DwarfFiles+        DwarfFiles,++        -- * 64-bit registers on 32-bit architectures+        Reg64(..), RegCode64(..),+        getNewReg64, localReg64 )  where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Platform@@ -59,6 +59,8 @@ import GHC.Cmm.Dataflow.Label import GHC.Cmm.CLabel           ( CLabel ) import GHC.Cmm.DebugBlock+import GHC.Cmm.Expr             (LocalReg (..), isWord64)+ import GHC.Data.FastString      ( FastString ) import GHC.Types.Unique.FM import GHC.Types.Unique.Supply@@ -69,6 +71,7 @@  import GHC.Utils.Outputable (SDoc, ppr) import GHC.Utils.Panic      (pprPanic)+import GHC.Utils.Misc import GHC.CmmToAsm.CFG import GHC.CmmToAsm.CFG.Weight @@ -85,7 +88,6 @@     pprNatCmmDecl             :: NatCmmDecl statics instr -> SDoc,     maxSpillSlots             :: Int,     allocatableRegs           :: [RealReg],-    ncgExpandTop              :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr],     ncgAllocMoreStack         :: Int -> NatCmmDecl statics instr                               -> UniqSM (NatCmmDecl statics instr, [(BlockId,BlockId)]),     -- ^ The list of block ids records the redirected jumps to allow us to update@@ -258,14 +260,38 @@       return (RegVirtual $ targetMkVirtualReg platform u rep)  -getNewRegPairNat :: Format -> NatM (Reg,Reg)-getNewRegPairNat rep- = do u <- getUniqueNat-      platform <- getPlatform-      let vLo = targetMkVirtualReg platform u rep-      let lo  = RegVirtual $ targetMkVirtualReg platform u rep-      let hi  = RegVirtual $ getHiVirtualRegFromLo vLo-      return (lo, hi)+-- | 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)
GHC/CmmToAsm/PIC.hs view
@@ -210,6 +210,13 @@ -- 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@@ -248,7 +255,7 @@          -- If the target symbol is in another PE we need to access it via the         --      appropriate __imp_SYMBOL pointer.-        | labelDynamic config lbl+        | ncgLabelDynamic config lbl         = AccessViaSymbolPtr          -- Target symbol is in the same PE as the caller, so just access it directly.@@ -263,7 +270,7 @@         | not (ncgExternalDynamicRefs config)         = AccessDirectly -        | labelDynamic config lbl+        | ncgLabelDynamic config lbl         = AccessViaSymbolPtr          | otherwise@@ -280,20 +287,17 @@ -- howToAccessLabel config arch OSDarwin DataReference lbl         -- data access to a dynamic library goes via a symbol pointer-        | labelDynamic config lbl+        | 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 t x86_64.-        -- Unfortunately, we don't know whether it's cross-module,-        -- so we do it for all externally visible labels.-        -- This is a slight waste of time and space, but otherwise-        -- we'd need to pass the current Module all the way in to-        -- this function.+        -- label is undefined. Doesn't apply to x86_64 (why?).         | arch /= ArchX86_64-        , ncgPIC config && externallyVisibleCLabel lbl+        , not (isLocalCLabel (ncgThisModule config) lbl)+        , ncgPIC config+        , externallyVisibleCLabel lbl         = AccessViaSymbolPtr          | otherwise@@ -304,7 +308,7 @@         -- stack alignment is only right for regular calls.         -- Therefore, we have to go via a symbol pointer:         | arch == ArchX86 || arch == ArchX86_64 || arch == ArchAArch64-        , labelDynamic config lbl+        , ncgLabelDynamic config lbl         = AccessViaSymbolPtr  @@ -314,7 +318,7 @@         -- them automatically, neither on Aarch64 (arm64).         | arch /= ArchX86_64         , arch /= ArchAArch64-        , labelDynamic config lbl+        , ncgLabelDynamic config lbl         = AccessViaStub          | otherwise@@ -366,7 +370,7 @@         | osElfTarget os         = case () of             -- A dynamic label needs to be accessed via a symbol pointer.-          _ | labelDynamic config lbl+          _ | ncgLabelDynamic config lbl             -> AccessViaSymbolPtr              -- For PowerPC32 -fPIC, we have to access even static data@@ -394,18 +398,19 @@  howToAccessLabel config arch os CallReference lbl         | osElfTarget os-        , labelDynamic config lbl && not (ncgPIC config)+        , ncgLabelDynamic config lbl+        , not (ncgPIC config)         = AccessDirectly          | osElfTarget os         , arch /= ArchX86-        , labelDynamic config lbl+        , ncgLabelDynamic config lbl         , ncgPIC config         = AccessViaStub  howToAccessLabel config _arch os _kind lbl         | osElfTarget os-        = if labelDynamic config lbl+        = if ncgLabelDynamic config lbl             then AccessViaSymbolPtr             else AccessDirectly @@ -598,7 +603,7 @@              then               vcat [                   text ".symbol_stub",-                  text "L" <> ppr_lbl lbl <> ptext (sLit "$stub:"),+                  text "L" <> ppr_lbl lbl <> text "$stub:",                       text "\t.indirect_symbol" <+> ppr_lbl lbl,                       text "\tjmp *L" <> ppr_lbl lbl                           <> text "$lazy_ptr",@@ -612,7 +617,7 @@               vcat [                   text ".section __TEXT,__picsymbolstub2,"                       <> text "symbol_stubs,pure_instructions,25",-                  text "L" <> ppr_lbl lbl <> ptext (sLit "$stub:"),+                  text "L" <> ppr_lbl lbl <> text "$stub:",                       text "\t.indirect_symbol" <+> ppr_lbl lbl,                       text "\tcall ___i686.get_pc_thunk.ax",                   text "1:",@@ -629,7 +634,7 @@            $+$ vcat [        text ".section __DATA, __la_sym_ptr"                     <> (if pic then int 2 else int 3)                     <> text ",lazy_symbol_pointers",-                text "L" <> ppr_lbl lbl <> ptext (sLit "$lazy_ptr:"),+                text "L" <> ppr_lbl lbl <> text "$lazy_ptr:",                     text "\t.indirect_symbol" <+> ppr_lbl lbl,                     text "\t.long L" <> ppr_lbl lbl                     <> text "$stub_binder"]@@ -709,14 +714,14 @@      -> case dynamicLinkerLabelInfo importedLbl of             Just (SymbolPtr, lbl)               -> let symbolSize = case ncgWordWidth config of-                         W32 -> sLit "\t.long"-                         W64 -> sLit "\t.quad"+                         W32 -> text "\t.long"+                         W64 -> text "\t.quad"                          _ -> panic "Unknown wordRep in pprImportedSymbol"                   in vcat [                       text ".section \".got2\", \"aw\"",                       text ".LC_" <> ppr_lbl lbl <> char ':',-                      ptext symbolSize <+> ppr_lbl lbl ]+                      symbolSize <+> ppr_lbl lbl ]              -- PLT code stubs are generated automatically by the dynamic linker.             _ -> empty
GHC/CmmToAsm/PPC.hs view
@@ -32,7 +32,6 @@    , maxSpillSlots             = PPC.maxSpillSlots config    , allocatableRegs           = PPC.allocatableRegs platform    , ncgAllocMoreStack         = PPC.allocMoreStack platform-   , ncgExpandTop              = id    , ncgMakeFarBranches        = PPC.makeFarBranches    , extractUnwindPoints       = const []    , invertCondBranches        = \_ _ -> id@@ -57,4 +56,4 @@    mkStackAllocInstr   = PPC.mkStackAllocInstr    mkStackDeallocInstr = PPC.mkStackDeallocInstr    pprInstr            = PPC.pprInstr-   mkComment           = const []+   mkComment           = pure . PPC.COMMENT
GHC/CmmToAsm/PPC/CodeGen.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-}  -----------------------------------------------------------------------------@@ -21,8 +20,6 @@  where -#include "HsVersions.h"- -- NCG stuff: import GHC.Prelude @@ -36,7 +33,8 @@    ( DebugBlock(..) ) import GHC.CmmToAsm.Monad    ( NatM, getNewRegNat, getNewLabelNat-   , getBlockIdNat, getPicBaseNat, getNewRegPairNat+   , getBlockIdNat, getPicBaseNat+   , Reg64(..), RegCode64(..), getNewReg64, localReg64    , getPicBaseMaybeNat, getPlatform, getConfig    , getDebugBlock, getFileId    )@@ -64,13 +62,13 @@ import GHC.Data.OrdList import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain  import Control.Monad    ( mapAndUnzipM, when ) import Data.Word  import GHC.Types.Basic import GHC.Data.FastString-import GHC.Utils.Misc  -- ----------------------------------------------------------------------------- -- Top-level of the instruction selector@@ -165,7 +163,7 @@   config <- getConfig   platform <- getPlatform   case stmt of-    CmmComment s   -> return (unitOL (COMMENT s))+    CmmComment s   -> return (unitOL (COMMENT $ ftext s))     CmmTick {}     -> return nilOL     CmmUnwind {}   -> return nilOL @@ -225,12 +223,15 @@ 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 (LocalReg u pk))-  = RegVirtual $ mkVirtualReg u (cmmTypeFormat pk)+getRegisterReg _ (CmmLocal local_reg)+  = getLocalRegReg local_reg  getRegisterReg platform (CmmGlobal mid)   = case globalRegMaybe platform mid of@@ -277,16 +278,6 @@ by applying getHiVRegFromLo to it. -} -data ChildCode64        -- a.k.a "Register64"-      = ChildCode64-           InstrBlock   -- code-           Reg          -- the lower 32-bit temporary which contains the-                        -- result; use getHiVRegFromLo to find the other-                        -- VRegUnique.  Rules of this simplified insn-                        -- selection game are therefore that the returned-                        -- Reg may be modified-- -- | Compute an expression into a register, but --      we don't mind which one it is. getSomeReg :: CmmExpr -> NatM (Reg, InstrBlock)@@ -313,10 +304,8 @@ assignMem_I64Code :: CmmExpr -> CmmExpr -> NatM InstrBlock assignMem_I64Code addrTree valueTree = do         (hi_addr, lo_addr, addr_code) <- getI64Amodes addrTree-        ChildCode64 vcode rlo <- iselExpr64 valueTree+        RegCode64 vcode rhi rlo <- iselExpr64 valueTree         let-                rhi = getHiVRegFromLo rlo-                 -- Big-endian store                 mov_hi = ST II32 rhi hi_addr                 mov_lo = ST II32 rlo lo_addr@@ -324,14 +313,11 @@   assignReg_I64Code :: CmmReg  -> CmmExpr -> NatM InstrBlock-assignReg_I64Code (CmmLocal (LocalReg u_dst _)) valueTree = do-   ChildCode64 vcode r_src_lo <- iselExpr64 valueTree-   let-         r_dst_lo = RegVirtual $ mkVirtualReg u_dst II32-         r_dst_hi = getHiVRegFromLo r_dst_lo-         r_src_hi = getHiVRegFromLo r_src_lo-         mov_lo = MR r_dst_lo r_src_lo-         mov_hi = MR r_dst_hi r_src_hi+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      )@@ -340,20 +326,21 @@    = panic "assignReg_I64Code(powerpc): invalid lvalue"  -iselExpr64        :: CmmExpr -> NatM ChildCode64+iselExpr64        :: CmmExpr -> NatM (RegCode64 InstrBlock) iselExpr64 (CmmLoad addrTree ty _) | isWord64 ty = do     (hi_addr, lo_addr, addr_code) <- getI64Amodes addrTree-    (rlo, rhi) <- getNewRegPairNat II32+    Reg64 rhi rlo <- getNewReg64     let mov_hi = LD II32 rhi hi_addr         mov_lo = LD II32 rlo lo_addr-    return $ ChildCode64 (addr_code `snocOL` mov_lo `snocOL` mov_hi)-                         rlo+    return $ RegCode64 (addr_code `snocOL` mov_lo `snocOL` mov_hi)+                         rhi rlo -iselExpr64 (CmmReg (CmmLocal (LocalReg vu ty))) | isWord64 ty-   = return (ChildCode64 nilOL (RegVirtual $ mkVirtualReg vu II32))+iselExpr64 (CmmReg (CmmLocal local_reg)) = do+  let Reg64 hi lo = localReg64 local_reg+  return (RegCode64 nilOL hi lo)  iselExpr64 (CmmLit (CmmInt i _)) = do-  (rlo,rhi) <- getNewRegPairNat II32+  Reg64 rhi rlo <- getNewReg64   let         half0 = fromIntegral (fromIntegral i :: Word16)         half1 = fromIntegral (fromIntegral (i `shiftR` 16) :: Word16)@@ -366,49 +353,45 @@                 LIS rhi (ImmInt half3),                 OR rhi rhi (RIImm $ ImmInt half2)                 ]-  return (ChildCode64 code rlo)+  return (RegCode64 code rhi rlo)  iselExpr64 (CmmMachOp (MO_Add _) [e1,e2]) = do-   ChildCode64 code1 r1lo <- iselExpr64 e1-   ChildCode64 code2 r2lo <- iselExpr64 e2-   (rlo,rhi) <- getNewRegPairNat II32+   RegCode64 code1 r1hi r1lo <- iselExpr64 e1+   RegCode64 code2 r2hi r2lo <- iselExpr64 e2+   Reg64 rhi rlo <- getNewReg64    let-        r1hi = getHiVRegFromLo r1lo-        r2hi = getHiVRegFromLo r2lo         code =  code1 `appOL`                 code2 `appOL`                 toOL [ ADDC rlo r1lo r2lo,                        ADDE rhi r1hi r2hi ]-   return (ChildCode64 code rlo)+   return (RegCode64 code rhi rlo)  iselExpr64 (CmmMachOp (MO_Sub _) [e1,e2]) = do-   ChildCode64 code1 r1lo <- iselExpr64 e1-   ChildCode64 code2 r2lo <- iselExpr64 e2-   (rlo,rhi) <- getNewRegPairNat II32+   RegCode64 code1 r1hi r1lo <- iselExpr64 e1+   RegCode64 code2 r2hi r2lo <- iselExpr64 e2+   Reg64 rhi rlo <- getNewReg64    let-        r1hi = getHiVRegFromLo r1lo-        r2hi = getHiVRegFromLo r2lo         code =  code1 `appOL`                 code2 `appOL`                 toOL [ SUBFC rlo r2lo (RIReg r1lo),                        SUBFE rhi r2hi r1hi ]-   return (ChildCode64 code rlo)+   return (RegCode64 code rhi rlo)  iselExpr64 (CmmMachOp (MO_UU_Conv W32 W64) [expr]) = do     (expr_reg,expr_code) <- getSomeReg expr-    (rlo, rhi) <- getNewRegPairNat II32+    Reg64 rhi rlo <- getNewReg64     let mov_hi = LI rhi (ImmInt 0)         mov_lo = MR rlo expr_reg-    return $ ChildCode64 (expr_code `snocOL` mov_lo `snocOL` mov_hi)-                         rlo+    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-    (rlo, rhi) <- getNewRegPairNat II32+    Reg64 rhi rlo <- getNewReg64     let mov_hi = SRA II32 rhi expr_reg (RIImm (ImmInt 31))         mov_lo = MR rlo expr_reg-    return $ ChildCode64 (expr_code `snocOL` mov_lo `snocOL` mov_hi)-                         rlo+    return $ RegCode64 (expr_code `snocOL` mov_lo `snocOL` mov_hi)+                       rhi rlo iselExpr64 expr    = do      platform <- getPlatform@@ -446,29 +429,29 @@ getRegister' _ platform (CmmMachOp (MO_UU_Conv W64 W32)                      [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]])  | target32Bit platform = do-  ChildCode64 code rlo <- iselExpr64 x+  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-  ChildCode64 code rlo <- iselExpr64 x+  RegCode64 code _rhi rlo <- iselExpr64 x   return $ Fixed II32 (getHiVRegFromLo rlo) code  getRegister' _ platform (CmmMachOp (MO_UU_Conv W64 W32) [x])  | target32Bit platform = do-  ChildCode64 code rlo <- iselExpr64 x+  RegCode64 code _rhi rlo <- iselExpr64 x   return $ Fixed II32 rlo code  getRegister' _ platform (CmmMachOp (MO_SS_Conv W64 W32) [x])  | target32Bit platform = do-  ChildCode64 code rlo <- iselExpr64 x+  RegCode64 code _rhi rlo <- iselExpr64 x   return $ Fixed II32 rlo code  getRegister' _ platform (CmmLoad mem pk _)  | not (isWord64 pk) = do         Amode addr addr_code <- getAmode D mem-        let code dst = ASSERT((targetClassOfReg platform dst == RcDouble) == isFloatType pk)+        let code dst = assert ((targetClassOfReg platform dst == RcDouble) == isFloatType pk) $                        addr_code `snocOL` LD format dst addr         return (Any format code)  | not (target32Bit platform) = do@@ -741,6 +724,7 @@ -}  {- 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@@ -929,10 +913,8 @@ condIntCode' True cond W64 x y   | condUnsigned cond   = do-      ChildCode64 code_x x_lo <- iselExpr64 x-      ChildCode64 code_y y_lo <- iselExpr64 y-      let x_hi = getHiVRegFromLo x_lo-          y_hi = getHiVRegFromLo y_lo+      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)@@ -945,10 +927,8 @@       return (CondCode False cond code)   | otherwise   = do-      ChildCode64 code_x x_lo <- iselExpr64 x-      ChildCode64 code_y y_lo <- iselExpr64 y-      let x_hi = getHiVRegFromLo x_lo-          y_hi = getHiVRegFromLo y_lo+      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@@ -1145,9 +1125,8 @@  = return $ nilOL  genCCall (PrimTarget (MO_AtomicRMW width amop)) [dst] [addr, n]- = do platform <- getPlatform-      let fmt      = intFormat width-          reg_dst  = getRegisterReg platform (CmmLocal dst)+ = 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@@ -1196,9 +1175,8 @@                           return  (op dst dst (RIReg n_reg), n_code)  genCCall (PrimTarget (MO_AtomicRead width)) [dst] [addr]- = do platform <- getPlatform-      let fmt      = intFormat width-          reg_dst  = getRegisterReg platform (CmmLocal dst)+ = 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@@ -1213,6 +1191,7 @@                                       ]  -- 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@@ -1224,19 +1203,48 @@  genCCall (PrimTarget (MO_AtomicWrite width)) [] [addr, val] = do     code <- assignMem_IntCode (intFormat width) addr val-    return $ unitOL(HWSYNC) `appOL` code+    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 = getRegisterReg platform (CmmLocal dst)+      let reg_dst = getLocalRegReg dst       if target32Bit platform && width == W64         then do-          ChildCode64 code vr_lo <- iselExpr64 src+          RegCode64 code vr_hi vr_lo <- iselExpr64 src           lbl1 <- getBlockIdNat           lbl2 <- getBlockIdNat           lbl3 <- getBlockIdNat-          let vr_hi = getHiVRegFromLo vr_lo-              cntlz = toOL [ CMPL II32 vr_hi (RIImm (ImmInt 0))+          let cntlz = toOL [ CMPL II32 vr_hi (RIImm (ImmInt 0))                            , BCC NE lbl2 Nothing                            , BCC ALWAYS lbl1 Nothing @@ -1279,11 +1287,11 @@  genCCall (PrimTarget (MO_Ctz width)) [dst] [src]  = do platform <- getPlatform-      let reg_dst = getRegisterReg platform (CmmLocal dst)+      let reg_dst = getLocalRegReg dst       if target32Bit platform && width == W64         then do           let format = II32-          ChildCode64 code vr_lo <- iselExpr64 src+          RegCode64 code vr_hi vr_lo <- iselExpr64 src           lbl1 <- getBlockIdNat           lbl2 <- getBlockIdNat           lbl3 <- getBlockIdNat@@ -1291,8 +1299,7 @@           x'' <- getNewRegNat format           r' <- getNewRegNat format           cnttzlo <- cnttz format reg_dst vr_lo-          let vr_hi = getHiVRegFromLo vr_lo-              cnttz64 = toOL [ CMPL format vr_lo (RIImm (ImmInt 0))+          let cnttz64 = toOL [ CMPL format vr_lo (RIImm (ImmInt 0))                              , BCC NE lbl2 Nothing                              , BCC ALWAYS lbl1 Nothing @@ -1345,38 +1352,38 @@ genCCall target dest_regs argsAndHints  = do platform <- getPlatform       case target of-        PrimTarget (MO_S_QuotRem  width) -> divOp1 platform True  width+        PrimTarget (MO_S_QuotRem  width) -> divOp1 True  width                                                    dest_regs argsAndHints-        PrimTarget (MO_U_QuotRem  width) -> divOp1 platform False width+        PrimTarget (MO_U_QuotRem  width) -> divOp1 False width                                                    dest_regs argsAndHints-        PrimTarget (MO_U_QuotRem2 width) -> divOp2 platform width dest_regs+        PrimTarget (MO_U_QuotRem2 width) -> divOp2 width dest_regs                                                    argsAndHints-        PrimTarget (MO_U_Mul2 width) -> multOp2 platform width dest_regs+        PrimTarget (MO_U_Mul2 width) -> multOp2 width dest_regs                                                 argsAndHints-        PrimTarget (MO_Add2 _) -> add2Op platform dest_regs argsAndHints-        PrimTarget (MO_AddWordC _) -> addcOp platform dest_regs argsAndHints-        PrimTarget (MO_SubWordC _) -> subcOp platform dest_regs argsAndHints-        PrimTarget (MO_AddIntC width) -> addSubCOp ADDO platform width+        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 platform width+        PrimTarget (MO_SubIntC width) -> addSubCOp SUBFO width                                                    dest_regs argsAndHints-        PrimTarget MO_F64_Fabs -> fabs platform dest_regs argsAndHints-        PrimTarget MO_F32_Fabs -> fabs platform 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 platform signed width [res_q, res_r] [arg_x, arg_y]-                = do let reg_q = getRegisterReg platform (CmmLocal res_q)-                         reg_r = getRegisterReg platform (CmmLocal res_r)+        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 _ _ _ _ _+              divOp1 _ _ _ _                 = panic "genCCall: Wrong number of arguments for divOp1"-              divOp2 platform width [res_q, res_r]+              divOp2 width [res_q, res_r]                                     [arg_x_high, arg_x_low, arg_y]-                = do let reg_q = getRegisterReg platform (CmmLocal res_q)-                         reg_r = getRegisterReg platform (CmmLocal res_r)+                = 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@@ -1513,11 +1520,11 @@                                    , SL fmt reg_q q1 (RIImm (ImmInt half))                                    , ADD reg_q reg_q (RIReg q0)                                    ]-              divOp2 _ _ _ _+              divOp2 _ _ _                 = panic "genCCall: Wrong number of arguments for divOp2"-              multOp2 platform width [res_h, res_l] [arg_x, arg_y]-                = do let reg_h = getRegisterReg platform (CmmLocal res_h)-                         reg_l = getRegisterReg platform (CmmLocal res_l)+              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@@ -1525,11 +1532,11 @@                             `appOL` toOL [ MULL fmt reg_l x_reg (RIReg y_reg)                                          , MULHU fmt reg_h x_reg y_reg                                          ]-              multOp2 _ _ _ _+              multOp2 _ _ _                 = panic "genCall: Wrong number of arguments for multOp2"-              add2Op platform [res_h, res_l] [arg_x, arg_y]-                = do let reg_h = getRegisterReg platform (CmmLocal res_h)-                         reg_l = getRegisterReg platform (CmmLocal res_l)+              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@@ -1537,20 +1544,20 @@                                          , ADDC reg_l x_reg y_reg                                          , ADDZE reg_h reg_h                                          ]-              add2Op _ _ _+              add2Op _ _                 = panic "genCCall: Wrong number of arguments/results for add2" -              addcOp platform [res_r, res_c] [arg_x, arg_y]-                = add2Op platform [res_c {-hi-}, res_r {-lo-}] [arg_x, arg_y]-              addcOp _ _ _+              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 platform [res_r, res_c] [arg_x, arg_y]-                = do let reg_r = getRegisterReg platform (CmmLocal res_r)-                         reg_c = getRegisterReg platform (CmmLocal res_c)+              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@@ -1559,11 +1566,11 @@                                          , ADDZE reg_c reg_c                                          , XOR reg_c reg_c (RIImm (ImmInt 1))                                          ]-              subcOp _ _ _+              subcOp _ _                 = panic "genCCall: Wrong number of arguments/results for subc"-              addSubCOp instr platform width [res_r, res_c] [arg_x, arg_y]-                = do let reg_r = getRegisterReg platform (CmmLocal res_r)-                         reg_c = getRegisterReg platform (CmmLocal res_c)+              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@@ -1571,13 +1578,13 @@                                            -- SUBFO argument order reversed!                                            MFOV (intFormat width) reg_c                                          ]-              addSubCOp _ _ _ _ _+              addSubCOp _ _ _ _                 = panic "genCall: Wrong number of arguments/results for addC"-              fabs platform [res] [arg]-                = do let res_r = getRegisterReg platform (CmmLocal res)+              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 _ _ _+              fabs _ _                 = panic "genCall: Wrong number of arguments/results for fabs"  -- TODO: replace 'Int' by an enum such as 'PPC_64ABI'@@ -1787,8 +1794,7 @@                accumCode accumUsed | isWord64 arg_ty                                      && target32Bit (ncgPlatform config) =             do-                ChildCode64 code vr_lo <- iselExpr64 arg-                let vr_hi = getHiVRegFromLo vr_lo+                RegCode64 code vr_hi vr_lo <- iselExpr64 arg                  case gcp of                     GCPAIX ->@@ -1948,7 +1954,7 @@                                 MR r_dest r4]                     | otherwise -> unitOL (MR r_dest r3)                     where rep = cmmRegType platform (CmmLocal dest)-                          r_dest = getRegisterReg platform (CmmLocal dest)+                          r_dest = getLocalRegReg dest                 _ -> panic "genCCall' moveResult: Bad dest_regs"          outOfLineMachOp mop =@@ -2042,23 +2048,26 @@                     MO_W64_Le    -> (fsLit "hs_leWord64", False)                     MO_W64_Lt    -> (fsLit "hs_ltWord64", False) -                    MO_UF_Conv w -> (fsLit $ word2FloatLabel w, 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_BSwap w   -> (fsLit $ bSwapLabel w, False)-                    MO_BRev w    -> (fsLit $ bRevLabel w, False)-                    MO_PopCnt w  -> (fsLit $ popCntLabel w, False)-                    MO_Pdep w    -> (fsLit $ pdepLabel w, False)-                    MO_Pext w    -> (fsLit $ pextLabel w, False)+                    MO_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 -> (fsLit $ cmpxchgLabel w, False)-                    MO_Xchg w    -> (fsLit $ xchgLabel w, False)+                    MO_Cmpxchg w -> (cmpxchgLabel w, False)+                    MO_Xchg w    -> (xchgLabel w, False)                     MO_AtomicRead _  -> unsupported                     MO_AtomicWrite _ -> unsupported @@ -2086,7 +2095,7 @@ genSwitch config expr targets   | OSAIX <- platformOS platform   = do-        (reg,e_code) <- getSomeReg (cmmOffset platform expr offset)+        (reg,e_code) <- getSomeReg indexExpr         let fmt = archWordFormat $ target32Bit platform             sha = if target32Bit platform then 2 else 3         tmp <- getNewRegNat fmt@@ -2103,7 +2112,7 @@    | (ncgPIC config) || (not $ target32Bit platform)   = do-        (reg,e_code) <- getSomeReg (cmmOffset platform expr offset)+        (reg,e_code) <- getSomeReg indexExpr         let fmt = archWordFormat $ target32Bit platform             sha = if target32Bit platform then 2 else 3         tmp <- getNewRegNat fmt@@ -2120,7 +2129,7 @@         return code   | otherwise   = do-        (reg,e_code) <- getSomeReg (cmmOffset platform expr offset)+        (reg,e_code) <- getSomeReg indexExpr         let fmt = archWordFormat $ target32Bit platform             sha = if target32Bit platform then 2 else 3         tmp <- getNewRegNat fmt@@ -2134,6 +2143,14 @@                     ]         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 santize 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 @@ -2498,12 +2515,14 @@ 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
GHC/CmmToAsm/PPC/Instr.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE CPP #-}- {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}  -----------------------------------------------------------------------------@@ -10,8 +8,6 @@ -- ----------------------------------------------------------------------------- -#include "HsVersions.h"- module GHC.CmmToAsm.PPC.Instr    ( Instr(..)    , RI(..)@@ -55,16 +51,16 @@ import GHC.Cmm.Dataflow.Label import GHC.Cmm import GHC.Cmm.Info-import GHC.Data.FastString import GHC.Cmm.CLabel+import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Platform import GHC.Types.Unique.FM (listToUFM, lookupUFM) import GHC.Types.Unique.Supply -import Control.Monad (replicateM) import Data.Maybe (fromMaybe) + -------------------------------------------------------------------------------- -- Format of a PPC memory address. --@@ -101,7 +97,7 @@     immAmount = ImmInt amount  ----- See note [extra spill slots] in X86/Instr.hs+-- See Note [extra spill slots] in X86/Instr.hs -- allocMoreStack   :: Platform@@ -119,7 +115,7 @@                         | entry `elem` infos -> infos                         | otherwise          -> entry : infos -    uniqs <- replicateM (length entries) getUniqueM+    uniqs <- getUniquesM      let         delta = ((x + stackAlign - 1) `quot` stackAlign) * stackAlign -- round up@@ -181,7 +177,7 @@  data Instr     -- comment pseudo-op-    = COMMENT FastString+    = COMMENT SDoc      -- location pseudo-op (file, line, col, name)     | LOCATION Int Int Int String@@ -395,9 +391,6 @@ interesting :: Platform -> Reg -> Bool interesting _        (RegVirtual _)              = True interesting platform (RegReal (RealRegSingle i)) = freeReg platform i-interesting _        (RegReal (RealRegPair{}))-    = panic "PPC.Instr.interesting: no reg pairs on this arch"-   -- | Apply a given mapping to all the register references in this
GHC/CmmToAsm/PPC/Ppr.hs view
@@ -38,7 +38,6 @@  import GHC.Types.Unique ( pprUniqueAlways, getUnique ) import GHC.Platform-import GHC.Data.FastString import GHC.Utils.Outputable import GHC.Utils.Panic @@ -155,7 +154,7 @@   pprDatas :: Platform -> RawCmmStatics -> SDoc--- See note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel".+-- 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@@ -200,7 +199,6 @@ pprReg r   = case r of       RegReal    (RealRegSingle i) -> ppr_reg_no i-      RegReal    (RealRegPair{})   -> panic "PPC.pprReg: no reg pairs on this arch"       RegVirtual (VirtualRegI  u)  -> text "%vI_"   <> pprUniqueAlways u       RegVirtual (VirtualRegHi u)  -> text "%vHi_"  <> pprUniqueAlways u       RegVirtual (VirtualRegF  u)  -> text "%vF_"   <> pprUniqueAlways u@@ -217,24 +215,24 @@  pprFormat :: Format -> SDoc pprFormat x- = ptext (case x of-                II8  -> sLit "b"-                II16 -> sLit "h"-                II32 -> sLit "w"-                II64 -> sLit "d"-                FF32 -> sLit "fs"-                FF64 -> sLit "fd")+ = case x of+                II8  -> text "b"+                II16 -> text "h"+                II32 -> text "w"+                II64 -> text "d"+                FF32 -> text "fs"+                FF64 -> text "fd"   pprCond :: Cond -> SDoc pprCond c- = ptext (case c of {-                ALWAYS  -> sLit "";-                EQQ     -> sLit "eq";  NE    -> sLit "ne";-                LTT     -> sLit "lt";  GE    -> sLit "ge";-                GTT     -> sLit "gt";  LE    -> sLit "le";-                LU      -> sLit "lt";  GEU   -> sLit "ge";-                GU      -> sLit "gt";  LEU   -> sLit "le"; })+ = 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 :: Platform -> Imm -> SDoc@@ -284,26 +282,28 @@ pprAlignForSection :: Platform -> SectionType -> SDoc pprAlignForSection platform seg =  let ppc64    = not $ target32Bit platform- in ptext $ case seg of-       Text              -> sLit ".align 2"+ in case seg of+       Text              -> text ".align 2"        Data-        | ppc64          -> sLit ".align 3"-        | otherwise      -> sLit ".align 2"+        | ppc64          -> text ".align 3"+        | otherwise      -> text ".align 2"        ReadOnlyData-        | ppc64          -> sLit ".align 3"-        | otherwise      -> sLit ".align 2"+        | ppc64          -> text ".align 3"+        | otherwise      -> text ".align 2"        RelocatableReadOnlyData-        | ppc64          -> sLit ".align 3"-        | otherwise      -> sLit ".align 2"+        | ppc64          -> text ".align 3"+        | otherwise      -> text ".align 2"        UninitialisedData-        | ppc64          -> sLit ".align 3"-        | otherwise      -> sLit ".align 2"-       ReadOnlyData16    -> sLit ".align 4"+        | ppc64          -> text ".align 3"+        | otherwise      -> text ".align 2"+       ReadOnlyData16    -> text ".align 4"        -- 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          -> sLit ".align 3"-        | otherwise      -> sLit ".align 2"+        | ppc64          -> text ".align 3"+        | otherwise      -> text ".align 2"        OtherSection _    -> panic "PprMach.pprSectionAlign: unknown section"  pprDataItem :: Platform -> CmmLit -> SDoc@@ -335,22 +335,21 @@                 = panic "PPC.Ppr.pprDataItem: no match"  +asmComment :: SDoc -> SDoc+asmComment c = whenPprDebug $ text "#" <+> c++ pprInstr :: Platform -> Instr -> SDoc pprInstr platform instr = case instr of -   COMMENT _-      -> empty -- nuke 'em--   -- COMMENT s-   --    -> if platformOS platform == OSLinux-   --          then text "# " <> ftext s-   --          else text "; " <> ftext s+   COMMENT s+      -> asmComment s     LOCATION file line col _name       -> text "\t.loc" <+> ppr file <+> ppr line <+> ppr col     DELTA d-      -> pprInstr platform (COMMENT (mkFastString ("\tdelta = " ++ show d)))+      -> asmComment $ text ("\tdelta = " ++ show d)     NEWBLOCK _       -> panic "PprMach.pprInstr: NEWBLOCK"@@ -380,13 +379,13 @@       -> hcat [            char '\t',            text "l",-           ptext (case fmt of-               II8  -> sLit "bz"-               II16 -> sLit "hz"-               II32 -> sLit "wz"-               II64 -> sLit "d"-               FF32 -> sLit "fs"-               FF64 -> sLit "fd"+           (case fmt of+               II8  -> text "bz"+               II16 -> text "hz"+               II32 -> text "wz"+               II64 -> text "d"+               FF32 -> text "fs"+               FF64 -> text "fd"                ),            case addr of AddrRegImm _ _ -> empty                         AddrRegReg _ _ -> char 'x',@@ -422,13 +421,13 @@       -> hcat [            char '\t',            text "l",-           ptext (case fmt of-               II8  -> sLit "ba"-               II16 -> sLit "ha"-               II32 -> sLit "wa"-               II64 -> sLit "d"-               FF32 -> sLit "fs"-               FF64 -> sLit "fd"+           (case fmt of+               II8  -> text "ba"+               II16 -> text "ha"+               II32 -> text "wa"+               II64 -> text "d"+               FF32 -> text "fs"+               FF64 -> text "fd"                ),            case addr of AddrRegImm _ _ -> empty                         AddrRegReg _ _ -> char 'x',@@ -643,7 +642,7 @@          ]     ADD reg1 reg2 ri-      -> pprLogic platform (sLit "add") reg1 reg2 ri+      -> pprLogic platform (text "add") reg1 reg2 ri     ADDIS reg1 reg2 imm       -> hcat [@@ -658,22 +657,22 @@            ]     ADDO reg1 reg2 reg3-      -> pprLogic platform (sLit "addo") reg1 reg2 (RIReg reg3)+      -> pprLogic platform (text "addo") reg1 reg2 (RIReg reg3)     ADDC reg1 reg2 reg3-      -> pprLogic platform (sLit "addc") reg1 reg2 (RIReg reg3)+      -> pprLogic platform (text "addc") reg1 reg2 (RIReg reg3)     ADDE reg1 reg2 reg3-      -> pprLogic platform (sLit "adde") reg1 reg2 (RIReg reg3)+      -> pprLogic platform (text "adde") reg1 reg2 (RIReg reg3)     ADDZE reg1 reg2-      -> pprUnary (sLit "addze") reg1 reg2+      -> pprUnary (text "addze") reg1 reg2     SUBF reg1 reg2 reg3-      -> pprLogic platform (sLit "subf") reg1 reg2 (RIReg reg3)+      -> pprLogic platform (text "subf") reg1 reg2 (RIReg reg3)     SUBFO reg1 reg2 reg3-      -> pprLogic platform (sLit "subfo") reg1 reg2 (RIReg reg3)+      -> pprLogic platform (text "subfo") reg1 reg2 (RIReg reg3)     SUBFC reg1 reg2 ri       -> hcat [@@ -691,7 +690,7 @@            ]     SUBFE reg1 reg2 reg3-      -> pprLogic platform (sLit "subfe") reg1 reg2 (RIReg reg3)+      -> pprLogic platform (text "subfe") reg1 reg2 (RIReg reg3)     MULL fmt reg1 reg2 ri       -> pprMul platform fmt reg1 reg2 ri@@ -773,19 +772,19 @@         ]     AND reg1 reg2 ri-      -> pprLogic platform (sLit "and") reg1 reg2 ri+      -> pprLogic platform (text "and") reg1 reg2 ri     ANDC reg1 reg2 reg3-      -> pprLogic platform (sLit "andc") reg1 reg2 (RIReg reg3)+      -> pprLogic platform (text "andc") reg1 reg2 (RIReg reg3)     NAND reg1 reg2 reg3-      -> pprLogic platform (sLit "nand") reg1 reg2 (RIReg reg3)+      -> pprLogic platform (text "nand") reg1 reg2 (RIReg reg3)     OR reg1 reg2 ri-      -> pprLogic platform (sLit "or") reg1 reg2 ri+      -> pprLogic platform (text "or") reg1 reg2 ri     XOR reg1 reg2 ri-      -> pprLogic platform (sLit "xor") reg1 reg2 ri+      -> pprLogic platform (text "xor") reg1 reg2 ri     ORIS reg1 reg2 imm       -> hcat [@@ -837,10 +836,10 @@          ]     NEG reg1 reg2-      -> pprUnary (sLit "neg") reg1 reg2+      -> pprUnary (text "neg") reg1 reg2     NOT reg1 reg2-      -> pprUnary (sLit "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@@ -864,24 +863,24 @@     SL fmt reg1 reg2 ri       -> let op = case fmt of-                       II32 -> "slw"-                       II64 -> "sld"+                       II32 -> text "slw"+                       II64 -> text "sld"                        _    -> panic "PPC.Ppr.pprInstr: shift illegal size"-         in pprLogic platform (sLit op) reg1 reg2 (limitShiftRI fmt ri)+         in pprLogic platform op reg1 reg2 (limitShiftRI fmt ri)     SR fmt reg1 reg2 ri       -> let op = case fmt of-                       II32 -> "srw"-                       II64 -> "srd"+                       II32 -> text "srw"+                       II64 -> text "srd"                        _    -> panic "PPC.Ppr.pprInstr: shift illegal size"-         in pprLogic platform (sLit op) reg1 reg2 (limitShiftRI fmt ri)+         in pprLogic platform op reg1 reg2 (limitShiftRI fmt ri)     SRA fmt reg1 reg2 ri       -> let op = case fmt of-                       II32 -> "sraw"-                       II64 -> "srad"+                       II32 -> text "sraw"+                       II64 -> text "srad"                        _    -> panic "PPC.Ppr.pprInstr: shift illegal size"-         in pprLogic platform (sLit op) reg1 reg2 (limitShiftRI fmt ri)+         in pprLogic platform op reg1 reg2 (limitShiftRI fmt ri)     RLWINM reg1 reg2 sh mb me       -> hcat [@@ -922,22 +921,22 @@         ]     FADD fmt reg1 reg2 reg3-      -> pprBinaryF (sLit "fadd") fmt reg1 reg2 reg3+      -> pprBinaryF (text "fadd") fmt reg1 reg2 reg3     FSUB fmt reg1 reg2 reg3-      -> pprBinaryF (sLit "fsub") fmt reg1 reg2 reg3+      -> pprBinaryF (text "fsub") fmt reg1 reg2 reg3     FMUL fmt reg1 reg2 reg3-      -> pprBinaryF (sLit "fmul") fmt reg1 reg2 reg3+      -> pprBinaryF (text "fmul") fmt reg1 reg2 reg3     FDIV fmt reg1 reg2 reg3-      -> pprBinaryF (sLit "fdiv") fmt reg1 reg2 reg3+      -> pprBinaryF (text "fdiv") fmt reg1 reg2 reg3     FABS reg1 reg2-      -> pprUnary (sLit "fabs") reg1 reg2+      -> pprUnary (text "fabs") reg1 reg2     FNEG reg1 reg2-      -> pprUnary (sLit "fneg") reg1 reg2+      -> pprUnary (text "fneg") reg1 reg2     FCMP reg1 reg2       -> hcat [@@ -956,16 +955,16 @@          ]     FCTIWZ reg1 reg2-      -> pprUnary (sLit "fctiwz") reg1 reg2+      -> pprUnary (text "fctiwz") reg1 reg2     FCTIDZ reg1 reg2-      -> pprUnary (sLit "fctidz") reg1 reg2+      -> pprUnary (text "fctidz") reg1 reg2     FCFID reg1 reg2-      -> pprUnary (sLit "fcfid") reg1 reg2+      -> pprUnary (text "fcfid") reg1 reg2     FRSP reg1 reg2-      -> pprUnary (sLit "frsp") reg1 reg2+      -> pprUnary (text "frsp") reg1 reg2     CRNOR dst src1 src2       -> hcat [@@ -1011,10 +1010,10 @@    NOP       -> text "\tnop" -pprLogic :: Platform -> PtrString -> Reg -> Reg -> RI -> SDoc+pprLogic :: Platform -> SDoc -> Reg -> Reg -> RI -> SDoc pprLogic platform op reg1 reg2 ri = hcat [         char '\t',-        ptext op,+        op,         case ri of             RIReg _ -> empty             RIImm _ -> char 'i',@@ -1064,10 +1063,10 @@     ]  -pprUnary :: PtrString -> Reg -> Reg -> SDoc+pprUnary :: SDoc -> Reg -> Reg -> SDoc pprUnary op reg1 reg2 = hcat [         char '\t',-        ptext op,+        op,         char '\t',         pprReg reg1,         text ", ",@@ -1075,10 +1074,10 @@     ]  -pprBinaryF :: PtrString -> Format -> Reg -> Reg -> Reg -> SDoc+pprBinaryF :: SDoc -> Format -> Reg -> Reg -> Reg -> SDoc pprBinaryF op fmt reg1 reg2 reg3 = hcat [         char '\t',-        ptext op,+        op,         pprFFormat fmt,         char '\t',         pprReg reg1,
GHC/CmmToAsm/PPC/RegInfo.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-}  ----------------------------------------------------------------------------- --@@ -16,8 +15,6 @@ )  where--#include "HsVersions.h"  import GHC.Prelude
GHC/CmmToAsm/PPC/Regs.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE CPP #-}- -- ----------------------------------------------------------------------------- -- -- (c) The University of Glasgow 1994-2004@@ -48,8 +46,6 @@  where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Platform.Reg@@ -104,7 +100,6 @@                         | regNo < 32    -> 1     -- first fp reg is 32                         | otherwise     -> 0 -                RealRegPair{}           -> 0          RcDouble          -> case rr of@@ -112,7 +107,6 @@                         | regNo < 32    -> 0                         | otherwise     -> 1 -                RealRegPair{}           -> 0          _other -> 0 @@ -242,9 +236,6 @@ classOfRealReg (RealRegSingle i)         | i < 32        = RcInteger         | otherwise     = RcDouble--classOfRealReg (RealRegPair{})-        = panic "regClass(ppr): no reg pairs on this architecture"  showReg :: RegNo -> String showReg n
GHC/CmmToAsm/Ppr.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE CPP, MagicHash #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}  ----------------------------------------------------------------------------- --@@ -10,6 +11,7 @@  module GHC.CmmToAsm.Ppr (         doubleToBytes,+        floatToBytes,         pprASCII,         pprString,         pprFileEmbed,@@ -24,8 +26,8 @@ import GHC.Cmm.CLabel import GHC.Cmm import GHC.CmmToAsm.Config-import GHC.Data.FastString-import GHC.Utils.Outputable+import GHC.Utils.Outputable as SDoc+import qualified GHC.Utils.Ppr as Pretty import GHC.Utils.Panic import GHC.Platform @@ -33,7 +35,6 @@ import Data.Array.ST  import Control.Monad.ST- import Data.Word import Data.ByteString (ByteString) import qualified Data.ByteString as BS@@ -49,39 +50,39 @@ -- ----------------------------------------------------------------------------- -- Converting floating-point literals to integrals for printing --- ToDo: this code is currently shared between SPARC and LLVM.---       Similar functions for (single precision) floats are---       present in the SPARC backend only. We need to fix both---       LLVM and SPARC.+-- | 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] -castDoubleToWord8Array :: STUArray s Int Double -> ST s (STUArray s Int Word8)-castDoubleToWord8Array = U.castSTUArray+-- | 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] --- floatToBytes and doubleToBytes convert to the host's byte--- order.  Providing that we're not cross-compiling for a--- target with the opposite endianness, this should work ok--- on all targets. --- ToDo: this stuff is very similar to the shenanigans in PprAbs,--- could they be merged?--doubleToBytes :: Double -> [Int]-doubleToBytes d-   = runST (do-        arr <- newArray_ ((0::Int),7)-        writeArray arr 0 d-        arr <- castDoubleToWord8Array arr-        i0 <- readArray arr 0-        i1 <- readArray arr 1-        i2 <- readArray arr 2-        i3 <- readArray arr 3-        i4 <- readArray arr 4-        i5 <- readArray arr 5-        i6 <- readArray arr 6-        i7 <- readArray arr 7-        return (map fromIntegral [i0,i1,i2,i3,i4,i5,i6,i7])-     )- -- --------------------------------------------------------------------------- -- Printing ASCII strings. --@@ -94,28 +95,34 @@   -- the literal SDoc directly.   -- See #14741   -- and Note [Pretty print ASCII when AsmCodeGen]-  = text $ BS.foldr (\w s -> do1 w ++ s) "" str+  --+  -- 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.+  = docToSDoc (BS.foldr f Pretty.empty str)     where-       do1 :: Word8 -> String-       do1 w | 0x09 == w = "\\t"-             | 0x0A == w = "\\n"-             | 0x22 == w = "\\\""-             | 0x5C == w = "\\\\"+       f :: Word8 -> Pretty.Doc -> Pretty.Doc+       f w s = do1 w Pretty.<> s++       do1 :: Word8 -> Pretty.Doc+       do1 w | 0x09 == w = Pretty.text "\\t"+             | 0x0A == w = Pretty.text "\\n"+             | 0x22 == w = Pretty.text "\\\""+             | 0x5C == w = Pretty.text "\\\\"                -- ASCII printable characters range-             | w >= 0x20 && w <= 0x7E = [chr' w]-             | otherwise = '\\' : octal w+             | w >= 0x20 && w <= 0x7E = Pretty.char (chr' w)+             | otherwise = Pretty.sizedText 4 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#))) -       octal :: Word8 -> String-       octal w = [ chr' (ord0 + (w `unsafeShiftR` 6) .&. 0x07)-                 , chr' (ord0 + (w `unsafeShiftR` 3) .&. 0x07)-                 , chr' (ord0 + w .&. 0x07)-                 ]-       ord0 = 0x30 -- = ord '0'  -- | Emit a ".string" directive pprString :: ByteString -> SDoc@@ -191,37 +198,47 @@  case platformOS (ncgPlatform config) of    OSAIX     -> pprXcoffSectionHeader t    OSDarwin  -> pprDarwinSectionHeader t-   OSMinGW32 -> pprGNUSectionHeader config (char '$') t suffix-   _         -> pprGNUSectionHeader config (char '.') t suffix+   _         -> pprGNUSectionHeader config t suffix -pprGNUSectionHeader :: NCGConfig -> SDoc -> SectionType -> CLabel -> SDoc-pprGNUSectionHeader config sep t suffix =-  text ".section " <> ptext header <> subsection <> flags+pprGNUSectionHeader :: NCGConfig -> SectionType -> CLabel -> SDoc+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 <> pdoc platform suffix       | otherwise     = empty     header = case t of-      Text -> sLit ".text"-      Data -> sLit ".data"+      Text -> text ".text"+      Data -> text ".data"       ReadOnlyData  | OSMinGW32 <- platformOS platform-                                -> sLit ".rdata"-                    | otherwise -> sLit ".rodata"+                                -> text ".rdata"+                    | otherwise -> text ".rodata"       RelocatableReadOnlyData | OSMinGW32 <- platformOS platform                                 -- Concept does not exist on Windows,                                 -- So map these to R/O data.-                                          -> sLit ".rdata$rel.ro"-                              | otherwise -> sLit ".data.rel.ro"-      UninitialisedData -> sLit ".bss"+                                          -> text ".rdata$rel.ro"+                              | otherwise -> text ".data.rel.ro"+      UninitialisedData -> text ".bss"       ReadOnlyData16 | OSMinGW32 <- platformOS platform-                                 -> sLit ".rdata$cst16"-                     | otherwise -> sLit ".rodata.cst16"+                                 -> text ".rdata$cst16"+                     | otherwise -> text ".rodata.cst16"+      InitArray+        | OSMinGW32 <- platformOS platform+                    -> text ".ctors"+        | otherwise -> text ".init_array"+      FiniArray+        | OSMinGW32 <- platformOS platform+                    -> text ".dtors"+        | otherwise -> text ".fini_array"       CString         | OSMinGW32 <- platformOS platform-                    -> sLit ".rdata"-        | otherwise -> sLit ".rodata.str"+                    -> text ".rdata"+        | otherwise -> text ".rodata.str"       OtherSection _ ->         panic "PprBase.pprGNUSectionHeader: unknown section type"     flags = case t of@@ -234,26 +251,25 @@ -- XCOFF doesn't support relocating label-differences, so we place all -- RO sections into .text[PR] sections pprXcoffSectionHeader :: SectionType -> SDoc-pprXcoffSectionHeader t = text $ case t of-     Text                    -> ".csect .text[PR]"-     Data                    -> ".csect .data[RW]"-     ReadOnlyData            -> ".csect .text[PR] # ReadOnlyData"-     RelocatableReadOnlyData -> ".csect .text[PR] # RelocatableReadOnlyData"-     ReadOnlyData16          -> ".csect .text[PR] # ReadOnlyData16"-     CString                 -> ".csect .text[PR] # CString"-     UninitialisedData       -> ".csect .data[BS]"-     OtherSection _          ->-       panic "PprBase.pprXcoffSectionHeader: unknown section type"+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"+  ReadOnlyData16          -> text ".csect .text[PR] # ReadOnlyData16"+  CString                 -> text ".csect .text[PR] # CString"+  UninitialisedData       -> text ".csect .data[BS]"+  _                       -> panic "pprXcoffSectionHeader: unknown section type"  pprDarwinSectionHeader :: SectionType -> SDoc-pprDarwinSectionHeader t =-  ptext $ case t of-     Text -> sLit ".text"-     Data -> sLit ".data"-     ReadOnlyData -> sLit ".const"-     RelocatableReadOnlyData -> sLit ".const_data"-     UninitialisedData -> sLit ".data"-     ReadOnlyData16 -> sLit ".const"-     CString -> sLit ".section\t__TEXT,__cstring,cstring_literals"-     OtherSection _ ->-       panic "PprBase.pprDarwinSectionHeader: unknown section type"+pprDarwinSectionHeader t = case t of+  Text                    -> text ".text"+  Data                    -> text ".data"+  ReadOnlyData            -> text ".const"+  RelocatableReadOnlyData -> text ".const_data"+  UninitialisedData       -> text ".data"+  ReadOnlyData16          -> text ".const"+  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"
GHC/CmmToAsm/Reg/Graph/Spill.hs view
@@ -18,7 +18,7 @@ import GHC.Cmm.Dataflow.Collections  import GHC.Utils.Monad-import GHC.Utils.Monad.State+import GHC.Utils.Monad.State.Strict import GHC.Types.Unique import GHC.Types.Unique.FM import GHC.Types.Unique.Set
GHC/CmmToAsm/Reg/Graph/SpillClean.hs view
@@ -45,7 +45,7 @@ import GHC.Types.Unique.FM import GHC.Types.Unique import GHC.Builtin.Uniques-import GHC.Utils.Monad.State+import GHC.Utils.Monad.State.Strict import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Platform@@ -515,9 +515,6 @@     getUnique (SReg  r)         | RegReal (RealRegSingle i)     <- r         = mkRegSingleUnique i--        | RegReal (RealRegPair r1 r2)   <- r-        = mkRegPairUnique (r1 * 65535 + r2)          | otherwise         = error $ "RegSpillClean.getUnique: found virtual reg during spill clean,"
GHC/CmmToAsm/Reg/Graph/SpillCost.hs view
@@ -33,7 +33,7 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Platform-import GHC.Utils.Monad.State+import GHC.Utils.Monad.State.Strict import GHC.CmmToAsm.CFG  import Data.List        (nub, minimumBy)
GHC/CmmToAsm/Reg/Graph/Stats.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE BangPatterns, CPP, DeriveFunctor #-}+{-# LANGUAGE BangPatterns, DeriveFunctor #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-}@@ -38,7 +38,7 @@ import GHC.Types.Unique.FM import GHC.Types.Unique.Set import GHC.Utils.Outputable-import GHC.Utils.Monad.State+import GHC.Utils.Monad.State.Strict  -- | Holds interesting statistics from the register allocator. data RegAllocStats statics instr
GHC/CmmToAsm/Reg/Graph/TrivColorable.hs view
@@ -1,13 +1,9 @@-{-# LANGUAGE CPP #-}- module GHC.CmmToAsm.Reg.Graph.TrivColorable (         trivColorable, )  where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Platform.Reg.Class@@ -44,7 +40,7 @@ --      TODO: Is that still true? Could we use allocatableRegsInClass --      without losing performance now? -----      Look at includes/stg/MachRegs.h to get the numbers.+--      Look at rts/include/stg/MachRegs.h to get the numbers. --  @@ -111,12 +107,12 @@                             ArchX86       -> 3                             ArchX86_64    -> 5                             ArchPPC       -> 16-                            ArchSPARC     -> 14-                            ArchSPARC64   -> panic "trivColorable ArchSPARC64"                             ArchPPC_64 _  -> 15                             ArchARM _ _ _ -> panic "trivColorable ArchARM"-                            -- N.B. x18 is reserved by the platform on AArch64/Darwin-                            ArchAArch64   -> 17+                            -- We should be able to allocate *a lot* more in princple.+                            -- essentially all 32 - SP, so 31, we'd trash the link reg+                            -- as well as the platform and all others though.+                            ArchAArch64   -> 18                             ArchAlpha     -> panic "trivColorable ArchAlpha"                             ArchMipseb    -> panic "trivColorable ArchMipseb"                             ArchMipsel    -> panic "trivColorable ArchMipsel"@@ -144,8 +140,6 @@                             ArchX86       -> 0                             ArchX86_64    -> 0                             ArchPPC       -> 0-                            ArchSPARC     -> 22-                            ArchSPARC64   -> panic "trivColorable ArchSPARC64"                             ArchPPC_64 _  -> 0                             ArchARM _ _ _ -> panic "trivColorable ArchARM"                             -- we can in princple address all the float regs as@@ -181,8 +175,6 @@                             -- "dont need to solve conflicts" count that                             -- was chosen at some point in the past.                             ArchPPC       -> 26-                            ArchSPARC     -> 11-                            ArchSPARC64   -> panic "trivColorable ArchSPARC64"                             ArchPPC_64 _  -> 20                             ArchARM _ _ _ -> panic "trivColorable ArchARM"                             ArchAArch64   -> 32
GHC/CmmToAsm/Reg/Linear.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE BangPatterns, CPP, ScopedTypeVariables #-}+{-# LANGUAGE BangPatterns, ScopedTypeVariables #-} {-# LANGUAGE ConstraintKinds #-}  {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}@@ -102,9 +102,6 @@         module  GHC.CmmToAsm.Reg.Linear.Stats   ) where -#include "HsVersions.h"-- import GHC.Prelude  import GHC.CmmToAsm.Reg.Linear.State@@ -114,7 +111,6 @@ 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.SPARC   as SPARC 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@@ -220,8 +216,6 @@       ArchX86        -> go $ (frInitFreeRegs platform :: X86.FreeRegs)       ArchX86_64     -> go $ (frInitFreeRegs platform :: X86_64.FreeRegs)       ArchS390X      -> panic "linearRegAlloc ArchS390X"-      ArchSPARC      -> go $ (frInitFreeRegs platform :: SPARC.FreeRegs)-      ArchSPARC64    -> panic "linearRegAlloc ArchSPARC64"       ArchPPC        -> go $ (frInitFreeRegs platform :: PPC.FreeRegs)       ArchARM _ _ _  -> panic "linearRegAlloc ArchARM"       ArchAArch64    -> go $ (frInitFreeRegs platform :: AArch64.FreeRegs)@@ -391,9 +385,9 @@                 , [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.+    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.@@ -679,29 +673,30 @@ saveClobberedTemps clobbered dying  = do         assig   <- getAssigR :: RegM freeRegs (UniqFM Reg Loc)-        -- Unique represents the VirtualReg-        let to_spill :: [(Unique, RealReg)]-            to_spill-                = [ (temp,reg)-                        | (temp, InReg reg) <- nonDetUFMToList assig-                        -- This is non-deterministic but we do not-                        -- currently support deterministic code-generation.-                        -- See Note [Unique Determinism and code generation]-                        , any (realRegsAlias reg) clobbered-                        , temp `notElem` map getUnique dying  ]--        (instrs,assig') <- clobber assig [] to_spill+        (assig',instrs) <- nonDetStrictFoldUFM_DirectlyM maybe_spill (assig,[]) assig         setAssigR assig'         return $ -- mkComment (text "<saveClobberedTemps>") ++                  instrs --              ++ mkComment (text "</saveClobberedTemps>")    where-     -- See Note [UniqFM and the register allocator]-     clobber :: RegMap Loc -> [instr] -> [(Unique,RealReg)] -> RegM freeRegs ([instr], RegMap Loc)-     clobber assig instrs []-            = return (instrs, assig)+     -- Unique represents the VirtualReg+     -- Here we separate the cases which we do want to spill from these we don't.+     maybe_spill :: Unique -> (RegMap Loc,[instr]) -> (Loc) -> RegM freeRegs (RegMap Loc,[instr])+     maybe_spill !temp !(assig,instrs) !loc =+        case loc of+                -- This is non-deterministic but we do not+                -- currently support deterministic code-generation.+                -- See Note [Unique Determinism and code generation]+                InReg reg+                    | any (realRegsAlias reg) clobbered+                    , temp `notElem` map getUnique dying+                    -> clobber temp (assig,instrs) (reg)+                _ -> return (assig,instrs) -     clobber assig instrs ((temp, reg) : rest)++     -- See Note [UniqFM and the register allocator]+     clobber :: Unique -> (RegMap Loc,[instr]) -> (RealReg) -> RegM freeRegs (RegMap Loc,[instr])+     clobber temp (assig,instrs) (reg)        = do platform <- getPlatform              freeRegs <- getFreeRegsR@@ -720,7 +715,7 @@                   let instr = mkRegRegMoveInstr platform                                   (RegReal reg) (RegReal my_reg) -                  clobber new_assign (instr : instrs) rest+                  return (new_assign,(instr : instrs))                -- (2) no free registers: spill the value               [] -> do@@ -731,7 +726,8 @@                    let new_assign  = addToUFM_Directly assig temp (InBoth reg slot) -                  clobber new_assign (spill ++ instrs) rest+                  return (new_assign, (spill ++ instrs))+
GHC/CmmToAsm/Reg/Linear/AArch64.hs view
@@ -71,7 +71,6 @@     | 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)-allocateReg _ _ = panic "Linear.AArch64.allocReg: bad reg"  -- we start from 28 downwards... the logic is similar to the ppc logic. -- 31 is Stack Pointer@@ -134,4 +133,3 @@   | 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-releaseReg _ _ = pprPanic "Linear.AArch64.releaseReg" (text "bad reg")
GHC/CmmToAsm/Reg/Linear/FreeRegs.hs view
@@ -1,12 +1,7 @@-{-# LANGUAGE CPP #-}- module GHC.CmmToAsm.Reg.Linear.FreeRegs (     FR(..),     maxSpillSlots )--#include "HsVersions.h"- where  import GHC.Prelude@@ -31,13 +26,11 @@ --      allocateReg f r = filter (/= r) f  import qualified GHC.CmmToAsm.Reg.Linear.PPC     as PPC-import qualified GHC.CmmToAsm.Reg.Linear.SPARC   as SPARC import qualified GHC.CmmToAsm.Reg.Linear.X86     as X86 import qualified GHC.CmmToAsm.Reg.Linear.X86_64  as X86_64 import qualified GHC.CmmToAsm.Reg.Linear.AArch64 as AArch64  import qualified GHC.CmmToAsm.PPC.Instr     as PPC.Instr-import qualified GHC.CmmToAsm.SPARC.Instr   as SPARC.Instr import qualified GHC.CmmToAsm.X86.Instr     as X86.Instr import qualified GHC.CmmToAsm.AArch64.Instr as AArch64.Instr @@ -71,20 +64,12 @@     frInitFreeRegs = AArch64.initFreeRegs     frReleaseReg = \_ -> AArch64.releaseReg -instance FR SPARC.FreeRegs where-    frAllocateReg  = SPARC.allocateReg-    frGetFreeRegs  = \_ -> SPARC.getFreeRegs-    frInitFreeRegs = SPARC.initFreeRegs-    frReleaseReg   = SPARC.releaseReg- maxSpillSlots :: NCGConfig -> Int maxSpillSlots config = case platformArch (ncgPlatform config) of    ArchX86       -> X86.Instr.maxSpillSlots config    ArchX86_64    -> X86.Instr.maxSpillSlots config    ArchPPC       -> PPC.Instr.maxSpillSlots config    ArchS390X     -> panic "maxSpillSlots ArchS390X"-   ArchSPARC     -> SPARC.Instr.maxSpillSlots config-   ArchSPARC64   -> panic "maxSpillSlots ArchSPARC64"    ArchARM _ _ _ -> panic "maxSpillSlots ArchARM"    ArchAArch64   -> AArch64.Instr.maxSpillSlots config    ArchPPC_64 _  -> PPC.Instr.maxSpillSlots config
GHC/CmmToAsm/Reg/Linear/PPC.hs view
@@ -8,7 +8,6 @@ import GHC.Platform.Reg  import GHC.Utils.Outputable-import GHC.Utils.Panic import GHC.Platform  import Data.Word@@ -38,9 +37,6 @@     | r > 31    = FreeRegs g (f .|. (1 `shiftL` (r - 32)))     | otherwise = FreeRegs (g .|. (1 `shiftL` r)) f -releaseReg _ _-        = panic "RegAlloc.Linear.PPC.releaseReg: bad reg"- initFreeRegs :: Platform -> FreeRegs initFreeRegs platform = foldl' (flip releaseReg) noFreeRegs (allocatableRegs platform) @@ -59,5 +55,3 @@     | r > 31    = FreeRegs g (f .&. complement (1 `shiftL` (r - 32)))     | otherwise = FreeRegs (g .&. complement (1 `shiftL` r)) f -allocateReg _ _-        = panic "RegAlloc.Linear.PPC.allocateReg: bad reg"
− GHC/CmmToAsm/Reg/Linear/SPARC.hs 
@@ -1,191 +0,0 @@-{-# LANGUAGE CPP #-}---- | Free regs map for SPARC-module GHC.CmmToAsm.Reg.Linear.SPARC where--import GHC.Prelude--import GHC.CmmToAsm.SPARC.Regs-import GHC.Platform.Reg.Class-import GHC.Platform.Reg--import GHC.Platform.Regs-import GHC.Utils.Outputable-import GHC.Utils.Panic-import GHC.Platform--import Data.Word-------------------------------------------------------------------------------------- SPARC is like PPC, except for twinning of floating point regs.---      When we allocate a double reg we must take an even numbered---      float reg, as well as the one after it.----- Holds bitmaps showing what registers are currently allocated.---      The float and double reg bitmaps overlap, but we only alloc---      float regs into the float map, and double regs into the double map.------      Free regs have a bit set in the corresponding bitmap.----data FreeRegs-        = FreeRegs-                !Word32         -- int    reg bitmap    regs  0..31-                !Word32         -- float  reg bitmap    regs 32..63-                !Word32         -- double reg bitmap    regs 32..63--instance Show FreeRegs where-        show = showFreeRegs--instance Outputable FreeRegs where-        ppr = text . showFreeRegs---- | A reg map where no regs are free to be allocated.-noFreeRegs :: FreeRegs-noFreeRegs = FreeRegs 0 0 0----- | The initial set of free regs.-initFreeRegs :: Platform -> FreeRegs-initFreeRegs platform- =      foldl' (flip $ releaseReg platform) noFreeRegs allocatableRegs----- | Get all the free registers of this class.-getFreeRegs :: RegClass -> FreeRegs -> [RealReg]        -- lazily-getFreeRegs cls (FreeRegs g f d)-        | RcInteger <- cls = map RealRegSingle                  $ go 1 g 1 0-        | RcFloat   <- cls = map RealRegSingle                  $ go 1 f 1 32-        | RcDouble  <- cls = map (\i -> RealRegPair i (i+1))    $ go 2 d 1 32-#if __GLASGOW_HASKELL__ <= 810-        | otherwise = pprPanic "RegAllocLinear.getFreeRegs: Bad register class " (ppr cls)-#endif-        where-                go _    _      0    _-                        = []--                go step bitmap mask ix-                        | bitmap .&. mask /= 0-                        = ix : (go step bitmap (mask `shiftL` step) $! ix + step)--                        | otherwise-                        = go step bitmap (mask `shiftL` step) $! ix + step----- | Grab a register.-allocateReg :: Platform -> RealReg -> FreeRegs -> FreeRegs-allocateReg platform-         reg@(RealRegSingle r)-             (FreeRegs g f d)--        -- can't allocate free regs-        | not $ freeReg platform r-        = pprPanic "SPARC.FreeRegs.allocateReg: not allocating pinned reg" (ppr reg)--        -- a general purpose reg-        | r <= 31-        = let   mask    = complement (bitMask r)-          in    FreeRegs-                        (g .&. mask)-                        f-                        d--        -- a float reg-        | r >= 32, r <= 63-        = let   mask    = complement (bitMask (r - 32))--                -- the mask of the double this FP reg aliases-                maskLow = if r `mod` 2 == 0-                                then complement (bitMask (r - 32))-                                else complement (bitMask (r - 32 - 1))-          in    FreeRegs-                        g-                        (f .&. mask)-                        (d .&. maskLow)--        | otherwise-        = pprPanic "SPARC.FreeRegs.releaseReg: not allocating bad reg" (ppr reg)--allocateReg _-         reg@(RealRegPair r1 r2)-             (FreeRegs g f d)--        | r1 >= 32, r1 <= 63, r1 `mod` 2 == 0-        , r2 >= 32, r2 <= 63-        = let   mask1   = complement (bitMask (r1 - 32))-                mask2   = complement (bitMask (r2 - 32))-          in-                FreeRegs-                        g-                        ((f .&. mask1) .&. mask2)-                        (d .&. mask1)--        | otherwise-        = pprPanic "SPARC.FreeRegs.releaseReg: not allocating bad reg" (ppr reg)------ | Release a register from allocation.---      The register liveness information says that most regs die after a C call,---      but we still don't want to allocate to some of them.----releaseReg :: Platform -> RealReg -> FreeRegs -> FreeRegs-releaseReg platform-         reg@(RealRegSingle r)-        regs@(FreeRegs g f d)--        -- don't release pinned reg-        | not $ freeReg platform r-        = regs--        -- a general purpose reg-        | r <= 31-        = let   mask    = bitMask r-          in    FreeRegs (g .|. mask) f d--        -- a float reg-        | r >= 32, r <= 63-        = let   mask    = bitMask (r - 32)--                -- the mask of the double this FP reg aliases-                maskLow = if r `mod` 2 == 0-                                then bitMask (r - 32)-                                else bitMask (r - 32 - 1)-          in    FreeRegs-                        g-                        (f .|. mask)-                        (d .|. maskLow)--        | otherwise-        = pprPanic "SPARC.FreeRegs.releaseReg: not releasing bad reg" (ppr reg)--releaseReg _-         reg@(RealRegPair r1 r2)-             (FreeRegs g f d)--        | r1 >= 32, r1 <= 63, r1 `mod` 2 == 0-        , r2 >= 32, r2 <= 63-        = let   mask1   = bitMask (r1 - 32)-                mask2   = bitMask (r2 - 32)-          in-                FreeRegs-                        g-                        ((f .|. mask1) .|. mask2)-                        (d .|. mask1)--        | otherwise-        = pprPanic "SPARC.FreeRegs.releaseReg: not releasing bad reg" (ppr reg)----bitMask :: Int -> Word32-bitMask n       = 1 `shiftL` n---showFreeRegs :: FreeRegs -> String-showFreeRegs regs-        =  "FreeRegs\n"-        ++ "    integer: " ++ (show $ getFreeRegs RcInteger regs)       ++ "\n"-        ++ "      float: " ++ (show $ getFreeRegs RcFloat   regs)       ++ "\n"-        ++ "     double: " ++ (show $ getFreeRegs RcDouble  regs)       ++ "\n"
GHC/CmmToAsm/Reg/Linear/State.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, PatternSynonyms, DeriveFunctor #-}+{-# LANGUAGE PatternSynonyms, DeriveFunctor #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UnboxedTuples #-} @@ -50,6 +50,7 @@ import GHC.Platform import GHC.Types.Unique import GHC.Types.Unique.Supply+import GHC.Exts (oneShot)  import Control.Monad (ap) @@ -64,16 +65,21 @@         = RegM { unReg :: RA_State freeRegs -> RA_Result freeRegs a }         deriving (Functor) +-- | Smart constructor for 'RegM', as described in Note [The one-shot state+-- monad trick] in GHC.Utils.Monad.+mkRegM :: (RA_State freeRegs -> RA_Result freeRegs a) -> RegM freeRegs a+mkRegM f = RegM (oneShot f)+ instance Applicative (RegM freeRegs) where-      pure a  =  RegM $ \s -> RA_Result s a+      pure a  =  mkRegM $ \s -> RA_Result s a       (<*>) = ap  instance Monad (RegM freeRegs) where-  m >>= k   =  RegM $ \s -> case unReg m s of { RA_Result s a -> unReg (k a) s }+  m >>= k   =  mkRegM $ \s -> case unReg m s of { RA_Result s a -> unReg (k a) s }  -- | Get native code generator configuration getConfig :: RegM a NCGConfig-getConfig = RegM $ \s -> RA_Result s (ra_config s)+getConfig = mkRegM $ \s -> RA_Result s (ra_config s)  -- | Get target platform from native code generator configuration getPlatform :: RegM a Platform@@ -117,7 +123,7 @@ spillR :: Instruction instr        => Reg -> Unique -> RegM freeRegs ([instr], Int) -spillR reg temp = RegM $ \s ->+spillR reg temp = mkRegM $ \s ->   let (stack1,slot) = getStackSlotFor (ra_stack s) temp       instr  = mkSpillInstr (ra_config s) reg (ra_delta s) slot   in@@ -127,42 +133,42 @@ loadR :: Instruction instr       => Reg -> Int -> RegM freeRegs [instr] -loadR reg slot = RegM $ \s ->+loadR reg slot = mkRegM $ \s ->   RA_Result s (mkLoadInstr (ra_config s) reg (ra_delta s) slot)  getFreeRegsR :: RegM freeRegs freeRegs-getFreeRegsR = RegM $ \ s@RA_State{ra_freeregs = freeregs} ->+getFreeRegsR = mkRegM $ \ s@RA_State{ra_freeregs = freeregs} ->   RA_Result s freeregs  setFreeRegsR :: freeRegs -> RegM freeRegs ()-setFreeRegsR regs = RegM $ \ s ->+setFreeRegsR regs = mkRegM $ \ s ->   RA_Result s{ra_freeregs = regs} ()  getAssigR :: RegM freeRegs (RegMap Loc)-getAssigR = RegM $ \ s@RA_State{ra_assig = assig} ->+getAssigR = mkRegM $ \ s@RA_State{ra_assig = assig} ->   RA_Result s assig  setAssigR :: RegMap Loc -> RegM freeRegs ()-setAssigR assig = RegM $ \ s ->+setAssigR assig = mkRegM $ \ s ->   RA_Result s{ra_assig=assig} ()  getBlockAssigR :: RegM freeRegs (BlockAssignment freeRegs)-getBlockAssigR = RegM $ \ s@RA_State{ra_blockassig = assig} ->+getBlockAssigR = mkRegM $ \ s@RA_State{ra_blockassig = assig} ->   RA_Result s assig  setBlockAssigR :: BlockAssignment freeRegs -> RegM freeRegs ()-setBlockAssigR assig = RegM $ \ s ->+setBlockAssigR assig = mkRegM $ \ s ->   RA_Result s{ra_blockassig = assig} ()  setDeltaR :: Int -> RegM freeRegs ()-setDeltaR n = RegM $ \ s ->+setDeltaR n = mkRegM $ \ s ->   RA_Result s{ra_delta = n} ()  getDeltaR :: RegM freeRegs Int-getDeltaR = RegM $ \s -> RA_Result s (ra_delta s)+getDeltaR = mkRegM $ \s -> RA_Result s (ra_delta s)  getUniqueR :: RegM freeRegs Unique-getUniqueR = RegM $ \s ->+getUniqueR = mkRegM $ \s ->   case takeUniqFromSupply (ra_us s) of     (uniq, us) -> RA_Result s{ra_us = us} uniq @@ -170,9 +176,9 @@ -- | Record that a spill instruction was inserted, for profiling. recordSpill :: SpillReason -> RegM freeRegs () recordSpill spill-    = RegM $ \s -> RA_Result (s { ra_spills = spill : ra_spills s }) ()+    = 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-    = RegM $ \s -> RA_Result (s { ra_fixups = (from,between,to) : ra_fixups s }) ()+    = mkRegM $ \s -> RA_Result (s { ra_fixups = (from,between,to) : ra_fixups s }) ()
GHC/CmmToAsm/Reg/Linear/Stats.hs view
@@ -17,7 +17,7 @@ import GHC.Types.Unique.FM  import GHC.Utils.Outputable-import GHC.Utils.Monad.State+import GHC.Utils.Monad.State.Strict  -- | Build a map of how many times each reg was alloced, clobbered, loaded etc. binSpillReasons
GHC/CmmToAsm/Reg/Linear/X86.hs view
@@ -8,7 +8,6 @@ import GHC.CmmToAsm.X86.Regs import GHC.Platform.Reg.Class import GHC.Platform.Reg-import GHC.Utils.Panic import GHC.Platform import GHC.Utils.Outputable @@ -24,9 +23,6 @@ releaseReg (RealRegSingle n) (FreeRegs f)         = FreeRegs (f .|. (1 `shiftL` n)) -releaseReg _ _-        = panic "RegAlloc.Linear.X86.FreeRegs.releaseReg: no reg"- initFreeRegs :: Platform -> FreeRegs initFreeRegs platform         = foldl' (flip releaseReg) noFreeRegs (allocatableRegs platform)@@ -47,7 +43,4 @@ allocateReg :: RealReg -> FreeRegs -> FreeRegs allocateReg (RealRegSingle r) (FreeRegs f)         = FreeRegs (f .&. complement (1 `shiftL` r))--allocateReg _ _-        = panic "RegAlloc.Linear.X86.FreeRegs.allocateReg: no reg"
GHC/CmmToAsm/Reg/Linear/X86_64.hs view
@@ -8,7 +8,6 @@ import GHC.CmmToAsm.X86.Regs import GHC.Platform.Reg.Class import GHC.Platform.Reg-import GHC.Utils.Panic import GHC.Platform import GHC.Utils.Outputable @@ -24,9 +23,6 @@ releaseReg (RealRegSingle n) (FreeRegs f)         = FreeRegs (f .|. (1 `shiftL` n)) -releaseReg _ _-        = panic "RegAlloc.Linear.X86_64.FreeRegs.releaseReg: no reg"- initFreeRegs :: Platform -> FreeRegs initFreeRegs platform         = foldl' (flip releaseReg) noFreeRegs (allocatableRegs platform)@@ -47,8 +43,4 @@ allocateReg :: RealReg -> FreeRegs -> FreeRegs allocateReg (RealRegSingle r) (FreeRegs f)         = FreeRegs (f .&. complement (1 `shiftL` r))--allocateReg _ _-        = panic "RegAlloc.Linear.X86_64.FreeRegs.allocateReg: no reg"-
GHC/CmmToAsm/Reg/Liveness.hs view
@@ -65,7 +65,7 @@ import GHC.Types.Unique.FM import GHC.Types.Unique.Supply import GHC.Data.Bag-import GHC.Utils.Monad.State+import GHC.Utils.Monad.State.Strict  import Data.List (mapAccumL, groupBy, partition) import Data.Maybe
GHC/CmmToAsm/Reg/Target.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ -- | Hard wired things related to registers. --      This is module is preventing the native code generator being able to --      emit code for non-host architectures.@@ -19,8 +19,6 @@  where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Platform.Reg@@ -35,7 +33,6 @@ 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.SPARC.Regs     as SPARC import qualified GHC.CmmToAsm.AArch64.Regs   as AArch64  @@ -46,8 +43,6 @@       ArchX86_64    -> X86.virtualRegSqueeze       ArchPPC       -> PPC.virtualRegSqueeze       ArchS390X     -> panic "targetVirtualRegSqueeze ArchS390X"-      ArchSPARC     -> SPARC.virtualRegSqueeze-      ArchSPARC64   -> panic "targetVirtualRegSqueeze ArchSPARC64"       ArchPPC_64 _  -> PPC.virtualRegSqueeze       ArchARM _ _ _ -> panic "targetVirtualRegSqueeze ArchARM"       ArchAArch64   -> AArch64.virtualRegSqueeze@@ -66,8 +61,6 @@       ArchX86_64    -> X86.realRegSqueeze       ArchPPC       -> PPC.realRegSqueeze       ArchS390X     -> panic "targetRealRegSqueeze ArchS390X"-      ArchSPARC     -> SPARC.realRegSqueeze-      ArchSPARC64   -> panic "targetRealRegSqueeze ArchSPARC64"       ArchPPC_64 _  -> PPC.realRegSqueeze       ArchARM _ _ _ -> panic "targetRealRegSqueeze ArchARM"       ArchAArch64   -> AArch64.realRegSqueeze@@ -85,8 +78,6 @@       ArchX86_64    -> X86.classOfRealReg platform       ArchPPC       -> PPC.classOfRealReg       ArchS390X     -> panic "targetClassOfRealReg ArchS390X"-      ArchSPARC     -> SPARC.classOfRealReg-      ArchSPARC64   -> panic "targetClassOfRealReg ArchSPARC64"       ArchPPC_64 _  -> PPC.classOfRealReg       ArchARM _ _ _ -> panic "targetClassOfRealReg ArchARM"       ArchAArch64   -> AArch64.classOfRealReg@@ -104,8 +95,6 @@       ArchX86_64    -> X86.mkVirtualReg       ArchPPC       -> PPC.mkVirtualReg       ArchS390X     -> panic "targetMkVirtualReg ArchS390X"-      ArchSPARC     -> SPARC.mkVirtualReg-      ArchSPARC64   -> panic "targetMkVirtualReg ArchSPARC64"       ArchPPC_64 _  -> PPC.mkVirtualReg       ArchARM _ _ _ -> panic "targetMkVirtualReg ArchARM"       ArchAArch64   -> AArch64.mkVirtualReg@@ -123,8 +112,6 @@       ArchX86_64    -> X86.regDotColor platform       ArchPPC       -> PPC.regDotColor       ArchS390X     -> panic "targetRegDotColor ArchS390X"-      ArchSPARC     -> SPARC.regDotColor-      ArchSPARC64   -> panic "targetRegDotColor ArchSPARC64"       ArchPPC_64 _  -> PPC.regDotColor       ArchARM _ _ _ -> panic "targetRegDotColor ArchARM"       ArchAArch64   -> AArch64.regDotColor
GHC/CmmToAsm/Reg/Utils.hs view
@@ -4,7 +4,6 @@  {- 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.
− GHC/CmmToAsm/SPARC.hs 
@@ -1,74 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}---- | Native code generator for SPARC architectures-module GHC.CmmToAsm.SPARC-   ( ncgSPARC-   )-where--import GHC.Prelude-import GHC.Utils.Panic--import GHC.CmmToAsm.Monad-import GHC.CmmToAsm.Config-import GHC.CmmToAsm.Types-import GHC.CmmToAsm.Instr--import qualified GHC.CmmToAsm.SPARC.Instr          as SPARC-import qualified GHC.CmmToAsm.SPARC.Ppr            as SPARC-import qualified GHC.CmmToAsm.SPARC.CodeGen        as SPARC-import qualified GHC.CmmToAsm.SPARC.CodeGen.Expand as SPARC-import qualified GHC.CmmToAsm.SPARC.Regs           as SPARC-import qualified GHC.CmmToAsm.SPARC.ShortcutJump   as SPARC---ncgSPARC :: NCGConfig -> NcgImpl RawCmmStatics SPARC.Instr SPARC.JumpDest-ncgSPARC config = NcgImpl-   { ncgConfig                 = config-   , cmmTopCodeGen             = SPARC.cmmTopCodeGen-   , generateJumpTableForInstr = SPARC.generateJumpTableForInstr platform-   , getJumpDestBlockId        = SPARC.getJumpDestBlockId-   , canShortcut               = SPARC.canShortcut-   , shortcutStatics           = SPARC.shortcutStatics-   , shortcutJump              = SPARC.shortcutJump-   , pprNatCmmDecl             = SPARC.pprNatCmmDecl config-   , maxSpillSlots             = SPARC.maxSpillSlots config-   , allocatableRegs           = SPARC.allocatableRegs-   , ncgExpandTop              = map SPARC.expandTop-   , ncgMakeFarBranches        = const id-   , extractUnwindPoints       = const []-   , invertCondBranches        = \_ _ -> id-   -- Allocating more stack space for spilling isn't currently supported for the-   -- linear register allocator on SPARC, hence the panic below.-   , ncgAllocMoreStack         = noAllocMoreStack-   }-    where-      platform = ncgPlatform config--      noAllocMoreStack amount _-        = panic $   "Register allocator: out of stack slots (need " ++ show amount ++ ")\n"-              ++  "   If you are trying to compile SHA1.hs from the crypto library then this\n"-              ++  "   is a known limitation in the linear allocator.\n"-              ++  "\n"-              ++  "   Try enabling the graph colouring allocator with -fregs-graph instead."-              ++  "   You can still file a bug report if you like.\n"----- | instance for sparc instruction set-instance Instruction SPARC.Instr where-   regUsageOfInstr         = SPARC.regUsageOfInstr-   patchRegsOfInstr        = SPARC.patchRegsOfInstr-   isJumpishInstr          = SPARC.isJumpishInstr-   jumpDestsOfInstr        = SPARC.jumpDestsOfInstr-   patchJumpInstr          = SPARC.patchJumpInstr-   mkSpillInstr            = SPARC.mkSpillInstr-   mkLoadInstr             = SPARC.mkLoadInstr-   takeDeltaInstr          = SPARC.takeDeltaInstr-   isMetaInstr             = SPARC.isMetaInstr-   mkRegRegMoveInstr       = SPARC.mkRegRegMoveInstr-   takeRegRegMoveInstr     = SPARC.takeRegRegMoveInstr-   mkJumpInstr             = SPARC.mkJumpInstr-   pprInstr                = SPARC.pprInstr-   mkComment               = const []-   mkStackAllocInstr       = panic "no sparc_mkStackAllocInstr"-   mkStackDeallocInstr     = panic "no sparc_mkStackDeallocInstr"
− GHC/CmmToAsm/SPARC/AddrMode.hs 
@@ -1,44 +0,0 @@--module GHC.CmmToAsm.SPARC.AddrMode (-        AddrMode(..),-        addrOffset-)--where--import GHC.Prelude--import GHC.CmmToAsm.SPARC.Imm-import GHC.CmmToAsm.SPARC.Base-import GHC.Platform.Reg---- addressing modes ---------------------------------------------------------------- | Represents a memory address in an instruction.---      Being a RISC machine, the SPARC addressing modes are very regular.----data AddrMode-        = AddrRegReg    Reg Reg         -- addr = r1 + r2-        | AddrRegImm    Reg Imm         -- addr = r1 + imm----- | Add an integer offset to the address in an AddrMode.----addrOffset :: AddrMode -> Int -> Maybe AddrMode-addrOffset addr off-  = case addr of-      AddrRegImm r (ImmInt n)-       | fits13Bits n2 -> Just (AddrRegImm r (ImmInt n2))-       | otherwise     -> Nothing-       where n2 = n + off--      AddrRegImm r (ImmInteger n)-       | fits13Bits n2 -> Just (AddrRegImm r (ImmInt (fromInteger n2)))-       | otherwise     -> Nothing-       where n2 = n + toInteger off--      AddrRegReg r (RegReal (RealRegSingle 0))-       | fits13Bits off -> Just (AddrRegImm r (ImmInt off))-       | otherwise     -> Nothing--      _ -> Nothing
− GHC/CmmToAsm/SPARC/Base.hs 
@@ -1,70 +0,0 @@---- | Bits and pieces on the bottom of the module dependency tree.---      Also import the required constants, so we know what we're using.------      In the interests of cross-compilation, we want to free ourselves---      from the autoconf generated modules like "GHC.Settings.Constants"--module GHC.CmmToAsm.SPARC.Base (-        wordLength,-        wordLengthInBits,-        spillSlotSize,-        extraStackArgsHere,-        fits13Bits,-        is32BitInteger,-        largeOffsetError-)--where--import GHC.Prelude--import GHC.Utils.Panic--import Data.Int----- On 32 bit SPARC, pointers are 32 bits.-wordLength :: Int-wordLength = 4--wordLengthInBits :: Int-wordLengthInBits-        = wordLength * 8---- | We need 8 bytes because our largest registers are 64 bit.-spillSlotSize :: Int-spillSlotSize = 8----- | We (allegedly) put the first six C-call arguments in registers;---      where do we start putting the rest of them?-extraStackArgsHere :: Int-extraStackArgsHere = 23---{-# SPECIALIZE fits13Bits :: Int -> Bool, Integer -> Bool #-}--- | Check whether an offset is representable with 13 bits.-fits13Bits :: Integral a => a -> Bool-fits13Bits x = x >= -4096 && x < 4096---- | Check whether an integer will fit in 32 bits.---      A CmmInt is intended to be truncated to the appropriate---      number of bits, so here we truncate it to Int64.  This is---      important because e.g. -1 as a CmmInt might be either---      -1 or 18446744073709551615.----is32BitInteger :: Integer -> Bool-is32BitInteger i-        = i64 <= 0x7fffffff && i64 >= -0x80000000-        where i64 = fromIntegral i :: Int64----- | Sadness.-largeOffsetError :: (Show a) => a -> b-largeOffsetError i-  = panic ("ERROR: SPARC native-code generator cannot handle large offset ("-                ++ show i ++ ");\nprobably because of large constant data structures;" ++-                "\nworkaround: use -fllvm on this module.\n")--
− GHC/CmmToAsm/SPARC/CodeGen.hs 
@@ -1,729 +0,0 @@-{-# LANGUAGE CPP #-}------------------------------------------------------------------------------------- Generating machine code (instruction selection)------ (c) The University of Glasgow 1996-2013-----------------------------------------------------------------------------------{-# LANGUAGE GADTs #-}-module GHC.CmmToAsm.SPARC.CodeGen (-        cmmTopCodeGen,-        generateJumpTableForInstr,-        InstrBlock-)--where--#include "HsVersions.h"---- NCG stuff:-import GHC.Prelude--import GHC.CmmToAsm.SPARC.Base-import GHC.CmmToAsm.SPARC.CodeGen.Sanity-import GHC.CmmToAsm.SPARC.CodeGen.Amode-import GHC.CmmToAsm.SPARC.CodeGen.CondCode-import GHC.CmmToAsm.SPARC.CodeGen.Gen64-import GHC.CmmToAsm.SPARC.CodeGen.Gen32-import GHC.CmmToAsm.SPARC.CodeGen.Base-import GHC.CmmToAsm.SPARC.Instr-import GHC.CmmToAsm.SPARC.Imm-import GHC.CmmToAsm.SPARC.AddrMode-import GHC.CmmToAsm.SPARC.Regs-import GHC.CmmToAsm.SPARC.Stack-import GHC.CmmToAsm.Types-import GHC.CmmToAsm.Format-import GHC.CmmToAsm.Monad   ( NatM, getNewRegNat, getNewLabelNat, getPlatform, getConfig )-import GHC.CmmToAsm.Config---- Our intermediate code:-import GHC.Cmm.BlockId-import GHC.Cmm-import GHC.Cmm.Utils-import GHC.Cmm.Switch-import GHC.Cmm.Dataflow.Block-import GHC.Cmm.Dataflow.Graph-import GHC.CmmToAsm.PIC-import GHC.Platform.Reg-import GHC.Cmm.CLabel-import GHC.CmmToAsm.CPrim---- The rest:-import GHC.Types.Basic-import GHC.Data.FastString-import GHC.Data.OrdList-import GHC.Utils.Panic-import GHC.Platform--import Control.Monad    ( mapAndUnzipM )---- | Top level code generation-cmmTopCodeGen :: RawCmmDecl-              -> NatM [NatCmmDecl RawCmmStatics Instr]--cmmTopCodeGen (CmmProc info lab live graph)- = do let blocks = toBlockListEntryFirst graph-      (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks--      let proc = CmmProc info lab live (ListGraph $ concat nat_blocks)-      let tops = proc : concat statics--      return tops--cmmTopCodeGen (CmmData sec dat) =-  return [CmmData sec dat]  -- no translation, we just use CmmStatic----- | Do code generation on a single block of CMM code.---      code generation may introduce new basic block boundaries, which---      are indicated by the NEWBLOCK instruction.  We must split up the---      instruction stream into basic blocks again.  Also, we extract---      LDATAs here too.-basicBlockCodeGen :: CmmBlock-                  -> NatM ( [NatBasicBlock Instr]-                          , [NatCmmDecl RawCmmStatics Instr])--basicBlockCodeGen block = do-  let (_, nodes, tail)  = blockSplit block-      id = entryLabel block-      stmts = blockToList nodes-  platform <- getPlatform-  mid_instrs <- stmtsToInstrs stmts-  tail_instrs <- stmtToInstrs tail-  let instrs = mid_instrs `appOL` tail_instrs-  let-        (top,other_blocks,statics)-                = foldrOL mkBlocks ([],[],[]) instrs--        mkBlocks (NEWBLOCK id) (instrs,blocks,statics)-          = ([], BasicBlock id instrs : blocks, statics)--        mkBlocks (LDATA sec dat) (instrs,blocks,statics)-          = (instrs, blocks, CmmData sec dat:statics)--        mkBlocks instr (instrs,blocks,statics)-          = (instr:instrs, blocks, statics)--        -- do intra-block sanity checking-        blocksChecked-                = map (checkBlock platform block)-                $ BasicBlock id top : other_blocks--  return (blocksChecked, statics)----- | Convert some Cmm statements to SPARC instructions.-stmtsToInstrs :: [CmmNode e x] -> NatM InstrBlock-stmtsToInstrs stmts-   = do instrss <- mapM stmtToInstrs stmts-        return (concatOL instrss)---stmtToInstrs :: CmmNode e x -> NatM InstrBlock-stmtToInstrs stmt = do-  platform <- getPlatform-  config <- getConfig-  case stmt of-    CmmComment s   -> return (unitOL (COMMENT s))-    CmmTick {}     -> return nilOL-    CmmUnwind {}   -> return nilOL--    CmmAssign reg src-      | isFloatType ty  -> assignReg_FltCode format reg src-      | isWord64 ty     -> assignReg_I64Code        reg src-      | otherwise       -> assignReg_IntCode format reg src-        where ty = cmmRegType platform reg-              format = cmmTypeFormat ty--    CmmStore addr src _-      | isFloatType ty  -> assignMem_FltCode format addr src-      | isWord64 ty     -> assignMem_I64Code      addr src-      | otherwise       -> assignMem_IntCode format addr src-        where ty = cmmExprType platform src-              format = cmmTypeFormat ty--    CmmUnsafeForeignCall target result_regs args-       -> genCCall target result_regs args--    CmmBranch   id              -> genBranch id-    CmmCondBranch arg true false _ -> do-      b1 <- genCondJump true arg-      b2 <- genBranch false-      return (b1 `appOL` b2)-    CmmSwitch arg ids   -> genSwitch config arg ids-    CmmCall { cml_target = arg } -> genJump arg--    _-     -> panic "stmtToInstrs: statement should have been cps'd away"---{--Now, given a tree (the argument to a CmmLoad) that references memory,-produce a suitable addressing mode.--A Rule of the Game (tm) for Amodes: use of the addr bit must-immediately follow use of the code part, since the code part puts-values in registers which the addr then refers to.  So you can't put-anything in between, lest it overwrite some of those registers.  If-you need to do some other computation between the code part and use of-the addr bit, first store the effective address from the amode in a-temporary, then do the other computation, and then use the temporary:--    code-    LEA amode, tmp-    ... other computation ...-    ... (tmp) ...--}------ | Convert a BlockId to some CmmStatic data-jumpTableEntry :: Platform -> Maybe BlockId -> CmmStatic-jumpTableEntry platform Nothing = CmmStaticLit (CmmInt 0 (wordWidth platform))-jumpTableEntry _ (Just blockid) = CmmStaticLit (CmmLabel blockLabel)-    where blockLabel = blockLbl blockid------ -------------------------------------------------------------------------------- Generating assignments---- Assignments are really at the heart of the whole code generation--- business.  Almost all top-level nodes of any real importance are--- assignments, which correspond to loads, stores, or register--- transfers.  If we're really lucky, some of the register transfers--- will go away, because we can use the destination register to--- complete the code generation for the right hand side.  This only--- fails when the right hand side is forced into a fixed register--- (e.g. the result of a call).--assignMem_IntCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock-assignMem_IntCode pk addr src = do-    (srcReg, code) <- getSomeReg src-    Amode dstAddr addr_code <- getAmode addr-    return $ code `appOL` addr_code `snocOL` ST pk srcReg dstAddr---assignReg_IntCode :: Format -> CmmReg  -> CmmExpr -> NatM InstrBlock-assignReg_IntCode _ reg src = do-    platform <- getPlatform-    r <- getRegister src-    let dst = getRegisterReg platform reg-    return $ case r of-        Any _ code         -> code dst-        Fixed _ freg fcode -> fcode `snocOL` OR False g0 (RIReg freg) dst------ Floating point assignment to memory-assignMem_FltCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock-assignMem_FltCode pk addr src = do-    platform <- getPlatform-    Amode dst__2 code1 <- getAmode addr-    (src__2, code2) <- getSomeReg src-    tmp1 <- getNewRegNat pk-    let-        pk__2   = cmmExprType platform src-        code__2 = code1 `appOL` code2 `appOL`-            if   formatToWidth pk == typeWidth pk__2-            then unitOL (ST pk src__2 dst__2)-            else toOL   [ FxTOy (cmmTypeFormat pk__2) pk src__2 tmp1-                        , ST    pk tmp1 dst__2]-    return code__2---- Floating point assignment to a register/temporary-assignReg_FltCode :: Format -> CmmReg  -> CmmExpr -> NatM InstrBlock-assignReg_FltCode pk dstCmmReg srcCmmExpr = do-    platform <- getPlatform-    srcRegister <- getRegister srcCmmExpr-    let dstReg  = getRegisterReg platform dstCmmReg--    return $ case srcRegister of-        Any _ code                  -> code dstReg-        Fixed _ srcFixedReg srcCode -> srcCode `snocOL` FMOV pk srcFixedReg dstReg-----genJump :: CmmExpr{-the branch target-} -> NatM InstrBlock--genJump (CmmLit (CmmLabel lbl))-  = return (toOL [CALL (Left target) 0 True, NOP])-  where-    target = ImmCLbl lbl--genJump tree-  = do-        (target, code) <- getSomeReg tree-        return (code `snocOL` JMP (AddrRegReg target g0)  `snocOL` NOP)---- --------------------------------------------------------------------------------  Unconditional branches--genBranch :: BlockId -> NatM InstrBlock-genBranch = return . toOL . mkJumpInstr----- --------------------------------------------------------------------------------  Conditional jumps--{--Conditional jumps are always to local labels, so we can use branch-instructions.  We peek at the arguments to decide what kind of-comparison to do.--SPARC: First, we have to ensure that the condition codes are set-according to the supplied comparison operation.  We generate slightly-different code for floating point comparisons, because a floating-point operation cannot directly precede a @BF@.  We assume the worst-and fill that slot with a @NOP@.--SPARC: Do not fill the delay slots here; you will confuse the register-allocator.--}---genCondJump-    :: BlockId      -- the branch target-    -> CmmExpr      -- the condition on which to branch-    -> NatM InstrBlock----genCondJump bid bool = do-  CondCode is_float cond code <- getCondCode bool-  return (-       code `appOL`-       toOL (-         if   is_float-         then [NOP, BF cond False bid, NOP]-         else [BI cond False bid, NOP]-       )-    )------ -------------------------------------------------------------------------------- Generating a table-branch--genSwitch :: NCGConfig -> CmmExpr -> SwitchTargets -> NatM InstrBlock-genSwitch config expr targets-        | ncgPIC config-        = error "MachCodeGen: sparc genSwitch PIC not finished\n"--        | otherwise-        = do    (e_reg, e_code) <- getSomeReg (cmmOffset (ncgPlatform config) expr offset)--                base_reg        <- getNewRegNat II32-                offset_reg      <- getNewRegNat II32-                dst             <- getNewRegNat II32--                label           <- getNewLabelNat--                return $ e_code `appOL`-                 toOL-                        [ -- load base of jump table-                          SETHI (HI (ImmCLbl label)) base_reg-                        , OR    False base_reg (RIImm $ LO $ ImmCLbl label) base_reg--                        -- the addrs in the table are 32 bits wide..-                        , SLL   e_reg (RIImm $ ImmInt 2) offset_reg--                        -- load and jump to the destination-                        , LD      II32 (AddrRegReg base_reg offset_reg) dst-                        , JMP_TBL (AddrRegImm dst (ImmInt 0)) ids label-                        , NOP ]-  where (offset, ids) = switchTargetsToTable targets--generateJumpTableForInstr :: Platform -> Instr-                          -> Maybe (NatCmmDecl RawCmmStatics Instr)-generateJumpTableForInstr platform (JMP_TBL _ ids label) =-  let jumpTable = map (jumpTableEntry platform) ids-  in Just (CmmData (Section ReadOnlyData label) (CmmStaticsRaw label jumpTable))-generateJumpTableForInstr _ _ = Nothing------ -------------------------------------------------------------------------------- Generating C calls--{--   Now the biggest nightmare---calls.  Most of the nastiness is buried in-   @get_arg@, which moves the arguments to the correct registers/stack-   locations.  Apart from that, the code is easy.--   The SPARC calling convention is an absolute-   nightmare.  The first 6x32 bits of arguments are mapped into-   %o0 through %o5, and the remaining arguments are dumped to the-   stack, beginning at [%sp+92].  (Note that %o6 == %sp.)--   If we have to put args on the stack, move %o6==%sp down by-   the number of words to go on the stack, to ensure there's enough space.--   According to Fraser and Hanson's lcc book, page 478, fig 17.2,-   16 words above the stack pointer is a word for the address of-   a structure return value.  I use this as a temporary location-   for moving values from float to int regs.  Certainly it isn't-   safe to put anything in the 16 words starting at %sp, since-   this area can get trashed at any time due to window overflows-   caused by signal handlers.--   A final complication (if the above isn't enough) is that-   we can't blithely calculate the arguments one by one into-   %o0 .. %o5.  Consider the following nested calls:--       fff a (fff b c)--   Naive code moves a into %o0, and (fff b c) into %o1.  Unfortunately-   the inner call will itself use %o0, which trashes the value put there-   in preparation for the outer call.  Upshot: we need to calculate the-   args into temporary regs, and move those to arg regs or onto the-   stack only immediately prior to the call proper.  Sigh.--}--genCCall-    :: ForeignTarget            -- function to call-    -> [CmmFormal]        -- where to put the result-    -> [CmmActual]        -- arguments (of mixed type)-    -> NatM InstrBlock------ On SPARC under TSO (Total Store Ordering), writes earlier in the instruction stream--- are guaranteed to take place before writes afterwards (unlike on PowerPC).--- Ref: Section 8.4 of the SPARC V9 Architecture manual.------ In the SPARC case we don't need a barrier.----genCCall (PrimTarget MO_ReadBarrier) _ _- = return $ nilOL-genCCall (PrimTarget MO_WriteBarrier) _ _- = return $ nilOL--genCCall (PrimTarget (MO_Prefetch_Data _)) _ _- = return $ nilOL--genCCall target dest_regs args- = do   -- work out the arguments, and assign them to integer regs-        argcode_and_vregs       <- mapM arg_to_int_vregs args-        let (argcodes, vregss)  = unzip argcode_and_vregs-        let vregs               = concat vregss--        let n_argRegs           = length allArgRegs-        let n_argRegs_used      = min (length vregs) n_argRegs---        -- deal with static vs dynamic call targets-        callinsns <- case target of-                ForeignTarget (CmmLit (CmmLabel lbl)) _ ->-                        return (unitOL (CALL (Left (litToImm (CmmLabel lbl))) n_argRegs_used False))--                ForeignTarget expr _-                 -> do  (dyn_c, dyn_rs) <- arg_to_int_vregs expr-                        let dyn_r = case dyn_rs of-                                      [dyn_r'] -> dyn_r'-                                      _ -> panic "SPARC.CodeGen.genCCall: arg_to_int"-                        return (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False)--                PrimTarget mop-                 -> do  res     <- outOfLineMachOp mop-                        case res of-                                Left lbl ->-                                        return (unitOL (CALL (Left (litToImm (CmmLabel lbl))) n_argRegs_used False))--                                Right mopExpr -> do-                                        (dyn_c, dyn_rs) <- arg_to_int_vregs mopExpr-                                        let dyn_r = case dyn_rs of-                                                      [dyn_r'] -> dyn_r'-                                                      _ -> panic "SPARC.CodeGen.genCCall: arg_to_int"-                                        return (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False)--        let argcode = concatOL argcodes--        let (move_sp_down, move_sp_up)-                   = let diff = length vregs - n_argRegs-                         nn   = if odd diff then diff + 1 else diff -- keep 8-byte alignment-                     in  if   nn <= 0-                         then (nilOL, nilOL)-                         else (unitOL (moveSp (-1*nn)), unitOL (moveSp (1*nn)))--        let transfer_code-                = toOL (move_final vregs allArgRegs extraStackArgsHere)--        platform <- getPlatform-        return-         $      argcode                 `appOL`-                move_sp_down            `appOL`-                transfer_code           `appOL`-                callinsns               `appOL`-                unitOL NOP              `appOL`-                move_sp_up              `appOL`-                assign_code platform dest_regs----- | Generate code to calculate an argument, and move it into one---      or two integer vregs.-arg_to_int_vregs :: CmmExpr -> NatM (OrdList Instr, [Reg])-arg_to_int_vregs arg = do platform <- getPlatform-                          arg_to_int_vregs' platform arg--arg_to_int_vregs' :: Platform -> CmmExpr -> NatM (OrdList Instr, [Reg])-arg_to_int_vregs' platform arg--        -- If the expr produces a 64 bit int, then we can just use iselExpr64-        | isWord64 (cmmExprType platform arg)-        = do    (ChildCode64 code r_lo) <- iselExpr64 arg-                let r_hi                = getHiVRegFromLo r_lo-                return (code, [r_hi, r_lo])--        | otherwise-        = do    (src, code)     <- getSomeReg arg-                let pk          = cmmExprType platform arg--                case cmmTypeFormat pk of--                 -- Load a 64 bit float return value into two integer regs.-                 FF64 -> do-                        v1 <- getNewRegNat II32-                        v2 <- getNewRegNat II32--                        let code2 =-                                code                            `snocOL`-                                FMOV FF64 src f0                `snocOL`-                                ST   FF32  f0 (spRel 16)        `snocOL`-                                LD   II32  (spRel 16) v1        `snocOL`-                                ST   FF32  f1 (spRel 16)        `snocOL`-                                LD   II32  (spRel 16) v2--                        return  (code2, [v1,v2])--                 -- Load a 32 bit float return value into an integer reg-                 FF32 -> do-                        v1 <- getNewRegNat II32--                        let code2 =-                                code                            `snocOL`-                                ST   FF32  src (spRel 16)       `snocOL`-                                LD   II32  (spRel 16) v1--                        return (code2, [v1])--                 -- Move an integer return value into its destination reg.-                 _ -> do-                        v1 <- getNewRegNat II32--                        let code2 =-                                code                            `snocOL`-                                OR False g0 (RIReg src) v1--                        return (code2, [v1])----- | Move args from the integer vregs into which they have been---      marshalled, into %o0 .. %o5, and the rest onto the stack.----move_final :: [Reg] -> [Reg] -> Int -> [Instr]---- all args done-move_final [] _ _-        = []---- out of aregs; move to stack-move_final (v:vs) [] offset-        = ST II32 v (spRel offset)-        : move_final vs [] (offset+1)---- move into an arg (%o[0..5]) reg-move_final (v:vs) (a:az) offset-        = OR False g0 (RIReg v) a-        : move_final vs az offset----- | Assign results returned from the call into their---      destination regs.----assign_code :: Platform -> [LocalReg] -> OrdList Instr--assign_code _ [] = nilOL--assign_code platform [dest]- = let  rep     = localRegType dest-        width   = typeWidth rep-        r_dest  = getRegisterReg platform (CmmLocal dest)--        result-                | isFloatType rep-                , W32   <- width-                = unitOL $ FMOV FF32 (regSingle $ fReg 0) r_dest--                | isFloatType rep-                , W64   <- width-                = unitOL $ FMOV FF64 (regSingle $ fReg 0) r_dest--                | not $ isFloatType rep-                , W32   <- width-                = unitOL $ mkRegRegMoveInstr platform (regSingle $ oReg 0) r_dest--                | not $ isFloatType rep-                , W64           <- width-                , r_dest_hi     <- getHiVRegFromLo r_dest-                = toOL  [ mkRegRegMoveInstr platform (regSingle $ oReg 0) r_dest_hi-                        , mkRegRegMoveInstr platform (regSingle $ oReg 1) r_dest]--                | otherwise-                = panic "SPARC.CodeGen.GenCCall: no match"--   in   result--assign_code _ _-        = panic "SPARC.CodeGen.GenCCall: no match"------ | Generate a call to implement an out-of-line floating point operation-outOfLineMachOp-        :: CallishMachOp-        -> NatM (Either CLabel CmmExpr)--outOfLineMachOp mop- = do   let functionName-                = outOfLineMachOp_table mop--        config  <- getConfig-        mopExpr <- cmmMakeDynamicReference config CallReference-                $  mkForeignLabel functionName Nothing ForeignLabelInExternalPackage IsFunction--        let mopLabelOrExpr-                = case mopExpr of-                        CmmLit (CmmLabel lbl)   -> Left lbl-                        _                       -> Right mopExpr--        return mopLabelOrExpr----- | Decide what C function to use to implement a CallishMachOp----outOfLineMachOp_table-        :: CallishMachOp-        -> FastString--outOfLineMachOp_table mop- = case mop of-        MO_F32_Exp    -> fsLit "expf"-        MO_F32_ExpM1  -> fsLit "expm1f"-        MO_F32_Log    -> fsLit "logf"-        MO_F32_Log1P  -> fsLit "log1pf"-        MO_F32_Sqrt   -> fsLit "sqrtf"-        MO_F32_Fabs   -> unsupported-        MO_F32_Pwr    -> fsLit "powf"--        MO_F32_Sin    -> fsLit "sinf"-        MO_F32_Cos    -> fsLit "cosf"-        MO_F32_Tan    -> fsLit "tanf"--        MO_F32_Asin   -> fsLit "asinf"-        MO_F32_Acos   -> fsLit "acosf"-        MO_F32_Atan   -> fsLit "atanf"--        MO_F32_Sinh   -> fsLit "sinhf"-        MO_F32_Cosh   -> fsLit "coshf"-        MO_F32_Tanh   -> fsLit "tanhf"--        MO_F32_Asinh  -> fsLit "asinhf"-        MO_F32_Acosh  -> fsLit "acoshf"-        MO_F32_Atanh  -> fsLit "atanhf"--        MO_F64_Exp    -> fsLit "exp"-        MO_F64_ExpM1  -> fsLit "expm1"-        MO_F64_Log    -> fsLit "log"-        MO_F64_Log1P  -> fsLit "log1p"-        MO_F64_Sqrt   -> fsLit "sqrt"-        MO_F64_Fabs   -> unsupported-        MO_F64_Pwr    -> fsLit "pow"--        MO_F64_Sin    -> fsLit "sin"-        MO_F64_Cos    -> fsLit "cos"-        MO_F64_Tan    -> fsLit "tan"--        MO_F64_Asin   -> fsLit "asin"-        MO_F64_Acos   -> fsLit "acos"-        MO_F64_Atan   -> fsLit "atan"--        MO_F64_Sinh   -> fsLit "sinh"-        MO_F64_Cosh   -> fsLit "cosh"-        MO_F64_Tanh   -> fsLit "tanh"--        MO_F64_Asinh  -> fsLit "asinh"-        MO_F64_Acosh  -> fsLit "acosh"-        MO_F64_Atanh  -> fsLit "atanh"--        MO_I64_ToI   -> fsLit "hs_int64ToInt"-        MO_I64_FromI -> fsLit "hs_intToInt64"-        MO_W64_ToW   -> fsLit "hs_word64ToWord"-        MO_W64_FromW -> fsLit "hs_wordToWord64"-        MO_x64_Neg   -> fsLit "hs_neg64"-        MO_x64_Add   -> fsLit "hs_add64"-        MO_x64_Sub   -> fsLit "hs_sub64"-        MO_x64_Mul   -> fsLit "hs_mul64"-        MO_I64_Quot  -> fsLit "hs_quotInt64"-        MO_I64_Rem   -> fsLit "hs_remInt64"-        MO_W64_Quot  -> fsLit "hs_quotWord64"-        MO_W64_Rem   -> fsLit "hs_remWord64"-        MO_x64_And   -> fsLit "hs_and64"-        MO_x64_Or    -> fsLit "hs_or64"-        MO_x64_Xor   -> fsLit "hs_xor64"-        MO_x64_Not   -> fsLit "hs_not64"-        MO_x64_Shl   -> fsLit "hs_uncheckedShiftL64"-        MO_I64_Shr   -> fsLit "hs_uncheckedIShiftRA64"-        MO_W64_Shr   -> fsLit "hs_uncheckedShiftRL64"-        MO_x64_Eq    -> fsLit "hs_eq64"-        MO_x64_Ne    -> fsLit "hs_ne64"-        MO_I64_Ge    -> fsLit "hs_geInt64"-        MO_I64_Gt    -> fsLit "hs_gtInt64"-        MO_I64_Le    -> fsLit "hs_leInt64"-        MO_I64_Lt    -> fsLit "hs_ltInt64"-        MO_W64_Ge    -> fsLit "hs_geWord64"-        MO_W64_Gt    -> fsLit "hs_gtWord64"-        MO_W64_Le    -> fsLit "hs_leWord64"-        MO_W64_Lt    -> fsLit "hs_ltWord64"--        MO_UF_Conv w -> fsLit $ word2FloatLabel w--        MO_Memcpy _  -> fsLit "memcpy"-        MO_Memset _  -> fsLit "memset"-        MO_Memmove _ -> fsLit "memmove"-        MO_Memcmp _  -> fsLit "memcmp"--        MO_BSwap w   -> fsLit $ bSwapLabel w-        MO_BRev w    -> fsLit $ bRevLabel w-        MO_PopCnt w  -> fsLit $ popCntLabel w-        MO_Pdep w    -> fsLit $ pdepLabel w-        MO_Pext w    -> fsLit $ pextLabel w-        MO_Clz w     -> fsLit $ clzLabel w-        MO_Ctz w     -> fsLit $ ctzLabel w-        MO_AtomicRMW w amop -> fsLit $ atomicRMWLabel w amop-        MO_Cmpxchg w -> fsLit $ cmpxchgLabel w-        MO_Xchg w -> fsLit $ xchgLabel w-        MO_AtomicRead w -> fsLit $ atomicReadLabel w-        MO_AtomicWrite w -> fsLit $ atomicWriteLabel 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_ReadBarrier   -> unsupported-        MO_WriteBarrier  -> unsupported-        MO_Touch         -> unsupported-        (MO_Prefetch_Data _) -> unsupported-    where unsupported = panic ("outOfLineCmmOp: " ++ show mop-                            ++ " not supported here")-
− GHC/CmmToAsm/SPARC/CodeGen/Amode.hs 
@@ -1,74 +0,0 @@-module GHC.CmmToAsm.SPARC.CodeGen.Amode (-        getAmode-)--where--import GHC.Prelude--import {-# SOURCE #-} GHC.CmmToAsm.SPARC.CodeGen.Gen32-import GHC.CmmToAsm.SPARC.CodeGen.Base-import GHC.CmmToAsm.SPARC.AddrMode-import GHC.CmmToAsm.SPARC.Imm-import GHC.CmmToAsm.SPARC.Instr-import GHC.CmmToAsm.SPARC.Regs-import GHC.CmmToAsm.SPARC.Base-import GHC.CmmToAsm.Monad-import GHC.CmmToAsm.Format--import GHC.Cmm--import GHC.Data.OrdList----- | Generate code to reference a memory address.-getAmode-        :: CmmExpr      -- ^ expr producing an address-        -> NatM Amode--getAmode tree@(CmmRegOff _ _)-    = do platform <- getPlatform-         getAmode (mangleIndexTree platform tree)--getAmode (CmmMachOp (MO_Sub _) [x, CmmLit (CmmInt i _)])-  | fits13Bits (-i)-  = do-       (reg, code) <- getSomeReg x-       let-         off  = ImmInt (-(fromInteger i))-       return (Amode (AddrRegImm reg off) code)---getAmode (CmmMachOp (MO_Add _) [x, CmmLit (CmmInt i _)])-  | fits13Bits i-  = do-       (reg, code) <- getSomeReg x-       let-         off  = ImmInt (fromInteger i)-       return (Amode (AddrRegImm reg off) code)--getAmode (CmmMachOp (MO_Add _) [x, y])-  = do-    (regX, codeX) <- getSomeReg x-    (regY, codeY) <- getSomeReg y-    let-        code = codeX `appOL` codeY-    return (Amode (AddrRegReg regX regY) code)--getAmode (CmmLit lit)-  = do-        let imm__2      = litToImm lit-        tmp1    <- getNewRegNat II32-        tmp2    <- getNewRegNat II32--        let code = toOL [ SETHI (HI imm__2) tmp1-                        , OR    False tmp1 (RIImm (LO imm__2)) tmp2]--        return (Amode (AddrRegReg tmp2 g0) code)--getAmode other-  = do-       (reg, code) <- getSomeReg other-       let-            off  = ImmInt 0-       return (Amode (AddrRegImm reg off) code)
− GHC/CmmToAsm/SPARC/CodeGen/Base.hs 
@@ -1,119 +0,0 @@-module GHC.CmmToAsm.SPARC.CodeGen.Base (-        InstrBlock,-        CondCode(..),-        ChildCode64(..),-        Amode(..),--        Register(..),-        setFormatOfRegister,--        getRegisterReg,-        mangleIndexTree-)--where--import GHC.Prelude--import GHC.CmmToAsm.SPARC.Instr-import GHC.CmmToAsm.SPARC.Cond-import GHC.CmmToAsm.SPARC.AddrMode-import GHC.CmmToAsm.SPARC.Regs-import GHC.CmmToAsm.Format-import GHC.Platform.Reg--import GHC.Platform.Regs-import GHC.Cmm-import GHC.Cmm.Ppr.Expr () -- For Outputable instances-import GHC.Platform--import GHC.Utils.Outputable-import GHC.Utils.Panic-import GHC.Data.OrdList------------------------------------------------------------------------------------- | 'InstrBlock's are the insn sequences generated by the insn selectors.---      They are really trees of insns to facilitate fast appending, where a---      left-to-right traversal yields the insns in the correct order.----type InstrBlock-        = OrdList Instr----- | Condition codes passed up the tree.----data CondCode-        = CondCode Bool Cond InstrBlock----- | a.k.a \"Register64\"---      Reg is the lower 32-bit temporary which contains the result.---      Use getHiVRegFromLo to find the other VRegUnique.------      Rules of this simplified insn selection game are therefore that---      the returned Reg may be modified----data ChildCode64-   = ChildCode64-        InstrBlock-        Reg----- | Holds code that references a memory address.-data Amode-        = Amode-                -- the AddrMode we can use in the instruction-                --      that does the real load\/store.-                AddrMode--                -- other setup code we have to run first before we can use the-                --      above AddrMode.-                InstrBlock--------------------------------------------------------------------------------------- | Code to produce a result into a register.---      If the result must go in a specific register, it comes out as Fixed.---      Otherwise, the parent can decide which register to put it in.----data Register-        = Fixed Format Reg InstrBlock-        | Any   Format (Reg -> InstrBlock)----- | Change the format field in a Register.-setFormatOfRegister-        :: Register -> Format -> Register--setFormatOfRegister reg format- = case reg of-        Fixed _ reg code        -> Fixed format reg code-        Any _ codefn            -> Any   format codefn-------------------------------------------------------------------------------------- | Grab the Reg for a CmmReg-getRegisterReg :: Platform -> CmmReg -> Reg--getRegisterReg _ (CmmLocal (LocalReg u pk))-        = RegVirtual $ mkVirtualReg u (cmmTypeFormat pk)--getRegisterReg platform (CmmGlobal mid)-  = case globalRegMaybe platform mid of-        Just reg -> RegReal reg-        Nothing  -> pprPanic-                        "SPARC.CodeGen.Base.getRegisterReg: global is in memory"-                        (ppr $ CmmGlobal mid)----- Expand CmmRegOff.  ToDo: should we do it this way around, or convert--- CmmExprs into CmmRegOff?-mangleIndexTree :: Platform -> CmmExpr -> CmmExpr--mangleIndexTree platform (CmmRegOff reg off)-        = CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)]-        where width = typeWidth (cmmRegType platform reg)--mangleIndexTree _ _-        = panic "SPARC.CodeGen.Base.mangleIndexTree: no match"
− GHC/CmmToAsm/SPARC/CodeGen/CondCode.hs 
@@ -1,115 +0,0 @@-module GHC.CmmToAsm.SPARC.CodeGen.CondCode (-        getCondCode,-        condIntCode,-        condFltCode-)--where--import GHC.Prelude--import {-# SOURCE #-} GHC.CmmToAsm.SPARC.CodeGen.Gen32-import GHC.CmmToAsm.SPARC.CodeGen.Base-import GHC.CmmToAsm.SPARC.Instr-import GHC.CmmToAsm.SPARC.Regs-import GHC.CmmToAsm.SPARC.Cond-import GHC.CmmToAsm.SPARC.Imm-import GHC.CmmToAsm.SPARC.Base-import GHC.CmmToAsm.Monad-import GHC.CmmToAsm.Format--import GHC.Cmm--import GHC.Data.OrdList-import GHC.Utils.Outputable-import GHC.Utils.Panic---getCondCode :: CmmExpr -> NatM CondCode-getCondCode (CmmMachOp mop [x, y])-  =-    case mop of-      MO_F_Eq W32 -> condFltCode EQQ x y-      MO_F_Ne W32 -> condFltCode NE  x y-      MO_F_Gt W32 -> condFltCode GTT x y-      MO_F_Ge W32 -> condFltCode GE  x y-      MO_F_Lt W32 -> condFltCode LTT x y-      MO_F_Le W32 -> condFltCode LE  x y--      MO_F_Eq W64 -> condFltCode EQQ x y-      MO_F_Ne W64 -> condFltCode NE  x y-      MO_F_Gt W64 -> condFltCode GTT x y-      MO_F_Ge W64 -> condFltCode GE  x y-      MO_F_Lt W64 -> condFltCode LTT x y-      MO_F_Le W64 -> condFltCode LE  x y--      MO_Eq   _   -> condIntCode EQQ  x y-      MO_Ne   _   -> condIntCode NE   x y--      MO_S_Gt _   -> condIntCode GTT  x y-      MO_S_Ge _   -> condIntCode GE   x y-      MO_S_Lt _   -> condIntCode LTT  x y-      MO_S_Le _   -> condIntCode LE   x y--      MO_U_Gt _   -> condIntCode GU   x y-      MO_U_Ge _   -> condIntCode GEU  x y-      MO_U_Lt _   -> condIntCode LU   x y-      MO_U_Le _   -> condIntCode LEU  x y--      _           -> do-                     platform <- getPlatform-                     pprPanic "SPARC.CodeGen.CondCode.getCondCode" (pdoc platform (CmmMachOp mop [x,y]))--getCondCode other = do-   platform <- getPlatform-   pprPanic "SPARC.CodeGen.CondCode.getCondCode" (pdoc platform other)-------- @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be--- passed back up the tree.--condIntCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode-condIntCode cond x (CmmLit (CmmInt y _))-  | fits13Bits y-  = do-       (src1, code) <- getSomeReg x-       let-           src2 = ImmInt (fromInteger y)-           code' = code `snocOL` SUB False True src1 (RIImm src2) g0-       return (CondCode False cond code')--condIntCode cond x y = do-    (src1, code1) <- getSomeReg x-    (src2, code2) <- getSomeReg y-    let-        code__2 = code1 `appOL` code2 `snocOL`-                  SUB False True src1 (RIReg src2) g0-    return (CondCode False cond code__2)---condFltCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode-condFltCode cond x y = do-    platform <- getPlatform-    (src1, code1) <- getSomeReg x-    (src2, code2) <- getSomeReg y-    tmp <- getNewRegNat FF64-    let-        promote x = FxTOy FF32 FF64 x tmp--        pk1   = cmmExprType platform x-        pk2   = cmmExprType platform y--        code__2 =-                if pk1 `cmmEqType` pk2 then-                    code1 `appOL` code2 `snocOL`-                    FCMP True (cmmTypeFormat pk1) src1 src2-                else if typeWidth pk1 == W32 then-                    code1 `snocOL` promote src1 `appOL` code2 `snocOL`-                    FCMP True FF64 tmp src2-                else-                    code1 `appOL` code2 `snocOL` promote src2 `snocOL`-                    FCMP True FF64 src1 tmp-    return (CondCode True cond code__2)
− GHC/CmmToAsm/SPARC/CodeGen/Expand.hs 
@@ -1,157 +0,0 @@-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}---- | Expand out synthetic instructions into single machine instrs.-module GHC.CmmToAsm.SPARC.CodeGen.Expand (-        expandTop-)--where--import GHC.Prelude--import GHC.CmmToAsm.SPARC.Instr-import GHC.CmmToAsm.SPARC.Imm-import GHC.CmmToAsm.SPARC.AddrMode-import GHC.CmmToAsm.SPARC.Regs-import GHC.CmmToAsm.Format-import GHC.CmmToAsm.Types-import GHC.Cmm--import GHC.Platform.Reg--import GHC.Utils.Outputable-import GHC.Utils.Panic-import GHC.Data.OrdList---- | Expand out synthetic instructions in this top level thing-expandTop :: NatCmmDecl RawCmmStatics Instr -> NatCmmDecl RawCmmStatics Instr-expandTop top@(CmmData{})-        = top--expandTop (CmmProc info lbl live (ListGraph blocks))-        = CmmProc info lbl live (ListGraph $ map expandBlock blocks)----- | Expand out synthetic instructions in this block-expandBlock :: NatBasicBlock Instr -> NatBasicBlock Instr--expandBlock (BasicBlock label instrs)- = let  instrs_ol       = expandBlockInstrs instrs-        instrs'         = fromOL instrs_ol-   in   BasicBlock label instrs'----- | Expand out some instructions-expandBlockInstrs :: [Instr] -> OrdList Instr-expandBlockInstrs []    = nilOL--expandBlockInstrs (ii:is)- = let  ii_doubleRegs   = remapRegPair ii-        is_misaligned   = expandMisalignedDoubles ii_doubleRegs--   in   is_misaligned `appOL` expandBlockInstrs is------ | In the SPARC instruction set the FP register pairs that are used---      to hold 64 bit floats are referred to by just the first reg---      of the pair. Remap our internal reg pairs to the appropriate reg.------      For example:---          ldd [%l1], (%f0 | %f1)------      gets mapped to---          ldd [$l1], %f0----remapRegPair :: Instr -> Instr-remapRegPair instr- = let  patchF reg-         = case reg of-                RegReal (RealRegSingle _)-                        -> reg--                RegReal (RealRegPair r1 r2)--                        -- sanity checking-                        | r1         >= 32-                        , r1         <= 63-                        , r1 `mod` 2 == 0-                        , r2         == r1 + 1-                        -> RegReal (RealRegSingle r1)--                        | otherwise-                        -> pprPanic "SPARC.CodeGen.Expand: not remapping dodgy looking reg pair " (ppr reg)--                RegVirtual _-                        -> pprPanic "SPARC.CodeGen.Expand: not remapping virtual reg " (ppr reg)--   in   patchRegsOfInstr instr patchF------- Expand out 64 bit load/stores into individual instructions to handle---      possible double alignment problems.------      TODO:   It'd be better to use a scratch reg instead of the add/sub thing.---              We might be able to do this faster if we use the UA2007 instr set---              instead of restricting ourselves to SPARC V9.----expandMisalignedDoubles :: Instr -> OrdList Instr-expandMisalignedDoubles instr--        -- Translate to:-        --    add g1,g2,g1-        --    ld  [g1],%fn-        --    ld  [g1+4],%f(n+1)-        --    sub g1,g2,g1           -- to restore g1-        | LD FF64 (AddrRegReg r1 r2) fReg       <- instr-        =       toOL    [ ADD False False r1 (RIReg r2) r1-                        , LD  FF32  (AddrRegReg r1 g0)          fReg-                        , LD  FF32  (AddrRegImm r1 (ImmInt 4))  (fRegHi fReg)-                        , SUB False False r1 (RIReg r2) r1 ]--        -- Translate to-        --    ld  [addr],%fn-        --    ld  [addr+4],%f(n+1)-        | LD FF64 addr fReg                     <- instr-        = let   Just addr'      = addrOffset addr 4-          in    toOL    [ LD  FF32  addr        fReg-                        , LD  FF32  addr'       (fRegHi fReg) ]--        -- Translate to:-        --    add g1,g2,g1-        --    st  %fn,[g1]-        --    st  %f(n+1),[g1+4]-        --    sub g1,g2,g1           -- to restore g1-        | ST FF64 fReg (AddrRegReg r1 r2)       <- instr-        =       toOL    [ ADD False False r1 (RIReg r2) r1-                        , ST  FF32  fReg           (AddrRegReg r1 g0)-                        , ST  FF32  (fRegHi fReg)  (AddrRegImm r1 (ImmInt 4))-                        , SUB False False r1 (RIReg r2) r1 ]--        -- Translate to-        --    ld  [addr],%fn-        --    ld  [addr+4],%f(n+1)-        | ST FF64 fReg addr                     <- instr-        = let   Just addr'      = addrOffset addr 4-          in    toOL    [ ST  FF32  fReg           addr-                        , ST  FF32  (fRegHi fReg)  addr'         ]--        -- some other instr-        | otherwise-        = unitOL instr------ | The high partner for this float reg.-fRegHi :: Reg -> Reg-fRegHi (RegReal (RealRegSingle r1))-        | r1            >= 32-        , r1            <= 63-        , r1 `mod` 2 == 0-        = (RegReal $ RealRegSingle (r1 + 1))---- Can't take high partner for non-low reg.-fRegHi reg-        = pprPanic "SPARC.CodeGen.Expand: can't take fRegHi from " (ppr reg)
− GHC/CmmToAsm/SPARC/CodeGen/Gen32.hs 
@@ -1,690 +0,0 @@--- | Evaluation of 32 bit values.-module GHC.CmmToAsm.SPARC.CodeGen.Gen32 (-        getSomeReg,-        getRegister-)--where--import GHC.Prelude--import GHC.CmmToAsm.SPARC.CodeGen.CondCode-import GHC.CmmToAsm.SPARC.CodeGen.Amode-import GHC.CmmToAsm.SPARC.CodeGen.Gen64-import GHC.CmmToAsm.SPARC.CodeGen.Base-import GHC.CmmToAsm.SPARC.Stack-import GHC.CmmToAsm.SPARC.Instr-import GHC.CmmToAsm.SPARC.Cond-import GHC.CmmToAsm.SPARC.AddrMode-import GHC.CmmToAsm.SPARC.Imm-import GHC.CmmToAsm.SPARC.Regs-import GHC.CmmToAsm.SPARC.Base-import GHC.CmmToAsm.Monad-import GHC.CmmToAsm.Format-import GHC.Platform.Reg--import GHC.Cmm--import Control.Monad (liftM)-import GHC.Data.OrdList-import GHC.Utils.Panic---- | The dual to getAnyReg: compute an expression into a register, but---      we don't mind which one it is.-getSomeReg :: CmmExpr -> NatM (Reg, InstrBlock)-getSomeReg expr = do-  r <- getRegister expr-  case r of-    Any rep code -> do-        tmp <- getNewRegNat rep-        return (tmp, code tmp)-    Fixed _ reg code ->-        return (reg, code)------ | Make code to evaluate a 32 bit expression.----getRegister :: CmmExpr -> NatM Register--getRegister (CmmReg reg)-  = do platform <- getPlatform-       return (Fixed (cmmTypeFormat (cmmRegType platform reg))-                     (getRegisterReg platform reg) nilOL)--getRegister tree@(CmmRegOff _ _)-  = do platform <- getPlatform-       getRegister (mangleIndexTree platform tree)--getRegister (CmmMachOp (MO_UU_Conv W64 W32)-             [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) = do-  ChildCode64 code rlo <- iselExpr64 x-  return $ Fixed II32 (getHiVRegFromLo rlo) code--getRegister (CmmMachOp (MO_SS_Conv W64 W32)-             [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) = do-  ChildCode64 code rlo <- iselExpr64 x-  return $ Fixed II32 (getHiVRegFromLo rlo) code--getRegister (CmmMachOp (MO_UU_Conv W64 W32) [x]) = do-  ChildCode64 code rlo <- iselExpr64 x-  return $ Fixed II32 rlo code--getRegister (CmmMachOp (MO_SS_Conv W64 W32) [x]) = do-  ChildCode64 code rlo <- iselExpr64 x-  return $ Fixed II32 rlo code----- Load a literal float into a float register.---      The actual literal is stored in a new data area, and we load it---      at runtime.-getRegister (CmmLit (CmmFloat f W32)) = do--    -- a label for the new data area-    lbl <- getNewLabelNat-    tmp <- getNewRegNat II32--    let code dst = toOL [-            -- the data area-            LDATA (Section ReadOnlyData lbl) $ CmmStaticsRaw lbl-                         [CmmStaticLit (CmmFloat f W32)],--            -- load the literal-            SETHI (HI (ImmCLbl lbl)) tmp,-            LD II32 (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]--    return (Any FF32 code)--getRegister (CmmLit (CmmFloat d W64)) = do-    lbl <- getNewLabelNat-    tmp <- getNewRegNat II32-    let code dst = toOL [-            LDATA (Section ReadOnlyData lbl) $ CmmStaticsRaw lbl-                         [CmmStaticLit (CmmFloat d W64)],-            SETHI (HI (ImmCLbl lbl)) tmp,-            LD II64 (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]-    return (Any FF64 code)----- Unary machine ops-getRegister (CmmMachOp mop [x])-  = case mop of-        -- Floating point negation --------------------------        MO_F_Neg W32            -> trivialUFCode FF32 (FNEG FF32) x-        MO_F_Neg W64            -> trivialUFCode FF64 (FNEG FF64) x---        -- Integer negation ---------------------------------        MO_S_Neg rep            -> trivialUCode (intFormat rep) (SUB False False g0) x-        MO_Not rep              -> trivialUCode (intFormat rep) (XNOR False g0) x---        -- Float word size conversion -----------------------        MO_FF_Conv W64 W32      -> coerceDbl2Flt x-        MO_FF_Conv W32 W64      -> coerceFlt2Dbl x---        -- Float <-> Signed Int conversion ------------------        MO_FS_Conv from to      -> coerceFP2Int from to x-        MO_SF_Conv from to      -> coerceInt2FP from to x---        -- Unsigned integer word size conversions ------------        -- If it's the same size, then nothing needs to be done.-        MO_UU_Conv from to-         | from == to           -> conversionNop (intFormat to)  x--        -- To narrow an unsigned word, mask out the high bits to simulate what would-        --      happen if we copied the value into a smaller register.-        MO_UU_Conv W16 W8       -> trivialCode W8  (AND False) x (CmmLit (CmmInt 255 W8))-        MO_UU_Conv W32 W8       -> trivialCode W8  (AND False) x (CmmLit (CmmInt 255 W8))--        -- for narrowing 32 bit to 16 bit, don't use a literal mask value like the W16->W8-        --      case because the only way we can load it is via SETHI, which needs 2 ops.-        --      Do some shifts to chop out the high bits instead.-        MO_UU_Conv W32 W16-         -> do  tmpReg          <- getNewRegNat II32-                (xReg, xCode)   <- getSomeReg x-                let code dst-                        =       xCode-                        `appOL` toOL-                                [ SLL xReg   (RIImm $ ImmInt 16) tmpReg-                                , SRL tmpReg (RIImm $ ImmInt 16) dst]--                return  $ Any II32 code--                --       trivialCode W16 (AND False) x (CmmLit (CmmInt 65535 W16))--        -- To widen an unsigned word we don't have to do anything.-        --      Just leave it in the same register and mark the result as the new size.-        MO_UU_Conv W8  W16      -> conversionNop (intFormat W16)  x-        MO_UU_Conv W8  W32      -> conversionNop (intFormat W32)  x-        MO_UU_Conv W16 W32      -> conversionNop (intFormat W32)  x---        -- Signed integer word size conversions --------------        -- Mask out high bits when narrowing them-        MO_SS_Conv W16 W8       -> trivialCode W8  (AND False) x (CmmLit (CmmInt 255 W8))-        MO_SS_Conv W32 W8       -> trivialCode W8  (AND False) x (CmmLit (CmmInt 255 W8))-        MO_SS_Conv W32 W16      -> trivialCode W16 (AND False) x (CmmLit (CmmInt 65535 W16))--        -- Sign extend signed words when widening them.-        MO_SS_Conv W8  W16      -> integerExtend W8  W16 x-        MO_SS_Conv W8  W32      -> integerExtend W8  W32 x-        MO_SS_Conv W16 W32      -> integerExtend W16 W32 x--        _                       -> panic ("Unknown unary mach op: " ++ show mop)----- Binary machine ops-getRegister (CmmMachOp mop [x, y])-  = case mop of-      MO_Eq _           -> condIntReg EQQ x y-      MO_Ne _           -> condIntReg NE x y--      MO_S_Gt _         -> condIntReg GTT x y-      MO_S_Ge _         -> condIntReg GE x y-      MO_S_Lt _         -> condIntReg LTT x y-      MO_S_Le _         -> condIntReg LE x y--      MO_U_Gt W32       -> condIntReg GU  x y-      MO_U_Ge W32       -> condIntReg GEU x y-      MO_U_Lt W32       -> condIntReg LU  x y-      MO_U_Le W32       -> condIntReg LEU x y--      MO_U_Gt W16       -> condIntReg GU  x y-      MO_U_Ge W16       -> condIntReg GEU x y-      MO_U_Lt W16       -> condIntReg LU  x y-      MO_U_Le W16       -> condIntReg LEU x y--      MO_Add W32        -> trivialCode W32 (ADD False False) x y-      MO_Sub W32        -> trivialCode W32 (SUB False False) x y--      MO_S_MulMayOflo rep -> imulMayOflo rep x y--      MO_S_Quot W32     -> idiv True  False x y-      MO_U_Quot W32     -> idiv False False x y--      MO_S_Rem  W32     -> irem True  x y-      MO_U_Rem  W32     -> irem False x y--      MO_F_Eq _         -> condFltReg EQQ x y-      MO_F_Ne _         -> condFltReg NE x y--      MO_F_Gt _         -> condFltReg GTT x y-      MO_F_Ge _         -> condFltReg GE x y-      MO_F_Lt _         -> condFltReg LTT x y-      MO_F_Le _         -> condFltReg LE x y--      MO_F_Add  w       -> trivialFCode w FADD x y-      MO_F_Sub  w       -> trivialFCode w FSUB x y-      MO_F_Mul  w       -> trivialFCode w FMUL x y-      MO_F_Quot w       -> trivialFCode w FDIV x y--      MO_And rep        -> trivialCode rep (AND False) x y-      MO_Or  rep        -> trivialCode rep (OR  False) x y-      MO_Xor rep        -> trivialCode rep (XOR False) x y--      MO_Mul rep        -> trivialCode rep (SMUL False) x y--      MO_Shl rep        -> trivialCode rep SLL  x y-      MO_U_Shr rep      -> trivialCode rep SRL x y-      MO_S_Shr rep      -> trivialCode rep SRA x y--      _                 -> pprPanic "getRegister(sparc) - binary CmmMachOp (1)" (pprMachOp mop)--getRegister (CmmLoad mem pk _) = do-    Amode src code <- getAmode mem-    let-        code__2 dst     = code `snocOL` LD (cmmTypeFormat pk) src dst-    return (Any (cmmTypeFormat pk) code__2)--getRegister (CmmLit (CmmInt i _))-  | fits13Bits i-  = let-        src = ImmInt (fromInteger i)-        code dst = unitOL (OR False g0 (RIImm src) dst)-    in-        return (Any II32 code)--getRegister (CmmLit lit)-  = let imm = litToImm lit-        code dst = toOL [-            SETHI (HI imm) dst,-            OR False dst (RIImm (LO imm)) dst]-    in return (Any II32 code)---getRegister _-        = panic "SPARC.CodeGen.Gen32.getRegister: no match"----- | sign extend and widen-integerExtend-        :: Width                -- ^ width of source expression-        -> Width                -- ^ width of result-        -> CmmExpr              -- ^ source expression-        -> NatM Register--integerExtend from to expr- = do   -- load the expr into some register-        (reg, e_code)   <- getSomeReg expr-        tmp             <- getNewRegNat II32-        let bitCount-                = case (from, to) of-                        (W8,  W32)      -> 24-                        (W16, W32)      -> 16-                        (W8,  W16)      -> 24-                        _               -> panic "SPARC.CodeGen.Gen32: no match"-        let code dst-                = e_code--                -- local shift word left to load the sign bit-                `snocOL`  SLL reg (RIImm (ImmInt bitCount)) tmp--                -- arithmetic shift right to sign extend-                `snocOL`  SRA tmp (RIImm (ImmInt bitCount)) dst--        return (Any (intFormat to) code)----- | For nop word format conversions we set the resulting value to have the---      required size, but don't need to generate any actual code.----conversionNop-        :: Format -> CmmExpr -> NatM Register--conversionNop new_rep expr- = do   e_code <- getRegister expr-        return (setFormatOfRegister e_code new_rep)------ | Generate an integer division instruction.-idiv :: Bool -> Bool -> CmmExpr -> CmmExpr -> NatM Register---- For unsigned division with a 32 bit numerator,---              we can just clear the Y register.-idiv False cc x y- = do-        (a_reg, a_code)         <- getSomeReg x-        (b_reg, b_code)         <- getSomeReg y--        let code dst-                =       a_code-                `appOL` b_code-                `appOL` toOL-                        [ WRY  g0 g0-                        , UDIV cc a_reg (RIReg b_reg) dst]--        return (Any II32 code)----- For _signed_ division with a 32 bit numerator,---              we have to sign extend the numerator into the Y register.-idiv True cc x y- = do-        (a_reg, a_code)         <- getSomeReg x-        (b_reg, b_code)         <- getSomeReg y--        tmp                     <- getNewRegNat II32--        let code dst-                =       a_code-                `appOL` b_code-                `appOL` toOL-                        [ SRA  a_reg (RIImm (ImmInt 16)) tmp            -- sign extend-                        , SRA  tmp   (RIImm (ImmInt 16)) tmp--                        , WRY  tmp g0-                        , SDIV cc a_reg (RIReg b_reg) dst]--        return (Any II32 code)----- | Do an integer remainder.------       NOTE:  The SPARC v8 architecture manual says that integer division---              instructions _may_ generate a remainder, depending on the implementation.---              If so it is _recommended_ that the remainder is placed in the Y register.------          The UltraSparc 2007 manual says Y is _undefined_ after division.------              The SPARC T2 doesn't store the remainder, not sure about the others.---              It's probably best not to worry about it, and just generate our own---              remainders.----irem :: Bool -> CmmExpr -> CmmExpr -> NatM Register---- For unsigned operands:---              Division is between a 64 bit numerator and a 32 bit denominator,---              so we still have to clear the Y register.-irem False x y- = do-        (a_reg, a_code) <- getSomeReg x-        (b_reg, b_code) <- getSomeReg y--        tmp_reg         <- getNewRegNat II32--        let code dst-                =       a_code-                `appOL` b_code-                `appOL` toOL-                        [ WRY   g0 g0-                        , UDIV  False         a_reg (RIReg b_reg) tmp_reg-                        , UMUL  False       tmp_reg (RIReg b_reg) tmp_reg-                        , SUB   False False   a_reg (RIReg tmp_reg) dst]--        return  (Any II32 code)------ For signed operands:---              Make sure to sign extend into the Y register, or the remainder---              will have the wrong sign when the numerator is negative.------      TODO:   When sign extending, GCC only shifts the a_reg right by 17 bits,---              not the full 32. Not sure why this is, something to do with overflow?---              If anyone cares enough about the speed of signed remainder they---              can work it out themselves (then tell me). -- BL 2009/01/20-irem True x y- = do-        (a_reg, a_code) <- getSomeReg x-        (b_reg, b_code) <- getSomeReg y--        tmp1_reg        <- getNewRegNat II32-        tmp2_reg        <- getNewRegNat II32--        let code dst-                =       a_code-                `appOL` b_code-                `appOL` toOL-                        [ SRA   a_reg      (RIImm (ImmInt 16)) tmp1_reg -- sign extend-                        , SRA   tmp1_reg   (RIImm (ImmInt 16)) tmp1_reg -- sign extend-                        , WRY   tmp1_reg g0--                        , SDIV  False          a_reg (RIReg b_reg)    tmp2_reg-                        , SMUL  False       tmp2_reg (RIReg b_reg)    tmp2_reg-                        , SUB   False False    a_reg (RIReg tmp2_reg) dst]--        return (Any II32 code)---imulMayOflo :: Width -> CmmExpr -> CmmExpr -> NatM Register-imulMayOflo rep a b- = do-        (a_reg, a_code) <- getSomeReg a-        (b_reg, b_code) <- getSomeReg b-        res_lo <- getNewRegNat II32-        res_hi <- getNewRegNat II32--        let shift_amt  = case rep of-                          W32 -> 31-                          W64 -> 63-                          _ -> panic "shift_amt"--        let code dst = a_code `appOL` b_code `appOL`-                       toOL [-                           SMUL False a_reg (RIReg b_reg) res_lo,-                           RDY res_hi,-                           SRA res_lo (RIImm (ImmInt shift_amt)) res_lo,-                           SUB False False res_lo (RIReg res_hi) dst-                        ]-        return (Any II32 code)----- -------------------------------------------------------------------------------- 'trivial*Code': deal with trivial instructions---- Trivial (dyadic: 'trivialCode', floating-point: 'trivialFCode',--- unary: 'trivialUCode', unary fl-pt:'trivialUFCode') instructions.--- Only look for constants on the right hand side, because that's--- where the generic optimizer will have put them.---- Similarly, for unary instructions, we don't have to worry about--- matching an StInt as the argument, because genericOpt will already--- have handled the constant-folding.--trivialCode-        :: Width-        -> (Reg -> RI -> Reg -> Instr)-        -> CmmExpr-        -> CmmExpr-        -> NatM Register--trivialCode _ instr x (CmmLit (CmmInt y _))-  | fits13Bits y-  = do-      (src1, code) <- getSomeReg x-      let-        src2 = ImmInt (fromInteger y)-        code__2 dst = code `snocOL` instr src1 (RIImm src2) dst-      return (Any II32 code__2)---trivialCode _ instr x y = do-    (src1, code1) <- getSomeReg x-    (src2, code2) <- getSomeReg y-    let-        code__2 dst = code1 `appOL` code2 `snocOL`-                      instr src1 (RIReg src2) dst-    return (Any II32 code__2)---trivialFCode-        :: Width-        -> (Format -> Reg -> Reg -> Reg -> Instr)-        -> CmmExpr-        -> CmmExpr-        -> NatM Register--trivialFCode pk instr x y = do-    platform <- getPlatform-    (src1, code1) <- getSomeReg x-    (src2, code2) <- getSomeReg y-    tmp <- getNewRegNat FF64-    let-        promote x = FxTOy FF32 FF64 x tmp--        pk1   = cmmExprType platform x-        pk2   = cmmExprType platform y--        code__2 dst =-                if pk1 `cmmEqType` pk2 then-                    code1 `appOL` code2 `snocOL`-                    instr (floatFormat pk) src1 src2 dst-                else if typeWidth pk1 == W32 then-                    code1 `snocOL` promote src1 `appOL` code2 `snocOL`-                    instr FF64 tmp src2 dst-                else-                    code1 `appOL` code2 `snocOL` promote src2 `snocOL`-                    instr FF64 src1 tmp dst-    return (Any (cmmTypeFormat $ if pk1 `cmmEqType` pk2 then pk1 else cmmFloat W64)-                code__2)----trivialUCode-        :: Format-        -> (RI -> Reg -> Instr)-        -> CmmExpr-        -> NatM Register--trivialUCode format instr x = do-    (src, code) <- getSomeReg x-    let-        code__2 dst = code `snocOL` instr (RIReg src) dst-    return (Any format code__2)---trivialUFCode-        :: Format-        -> (Reg -> Reg -> Instr)-        -> CmmExpr-        -> NatM Register--trivialUFCode pk instr x = do-    (src, code) <- getSomeReg x-    let-        code__2 dst = code `snocOL` instr src dst-    return (Any pk code__2)------- Coercions ----------------------------------------------------------------------- | Coerce a integer value to floating point-coerceInt2FP :: Width -> Width -> CmmExpr -> NatM Register-coerceInt2FP width1 width2 x = do-    (src, code) <- getSomeReg x-    let-        code__2 dst = code `appOL` toOL [-            ST (intFormat width1) src (spRel (-2)),-            LD (intFormat width1) (spRel (-2)) dst,-            FxTOy (intFormat width1) (floatFormat width2) dst dst]-    return (Any (floatFormat $ width2) code__2)------ | Coerce a floating point value to integer------   NOTE: On sparc v9 there are no instructions to move a value from an---         FP register directly to an int register, so we have to use a load/store.----coerceFP2Int :: Width -> Width -> CmmExpr -> NatM Register-coerceFP2Int width1 width2 x- = do   let fformat1      = floatFormat width1-            fformat2      = floatFormat width2--            iformat2      = intFormat   width2--        (fsrc, code)    <- getSomeReg x-        fdst            <- getNewRegNat fformat2--        let code2 dst-                =       code-                `appOL` toOL-                        -- convert float to int format, leaving it in a float reg.-                        [ FxTOy fformat1 iformat2 fsrc fdst--                        -- store the int into mem, then load it back to move-                        --      it into an actual int reg.-                        , ST    fformat2 fdst (spRel (-2))-                        , LD    iformat2 (spRel (-2)) dst]--        return (Any iformat2 code2)----- | Coerce a double precision floating point value to single precision.-coerceDbl2Flt :: CmmExpr -> NatM Register-coerceDbl2Flt x = do-    (src, code) <- getSomeReg x-    return (Any FF32 (\dst -> code `snocOL` FxTOy FF64 FF32 src dst))----- | Coerce a single precision floating point value to double precision-coerceFlt2Dbl :: CmmExpr -> NatM Register-coerceFlt2Dbl x = do-    (src, code) <- getSomeReg x-    return (Any FF64 (\dst -> code `snocOL` FxTOy FF32 FF64 src dst))------- Condition Codes ------------------------------------------------------------------- Evaluate a comparison, and get the result into a register.------ Do not fill the delay slots here. you will confuse the register allocator.----condIntReg :: Cond -> CmmExpr -> CmmExpr -> NatM Register-condIntReg EQQ x (CmmLit (CmmInt 0 _)) = do-    (src, code) <- getSomeReg x-    let-        code__2 dst = code `appOL` toOL [-            SUB False True g0 (RIReg src) g0,-            SUB True False g0 (RIImm (ImmInt (-1))) dst]-    return (Any II32 code__2)--condIntReg EQQ x y = do-    (src1, code1) <- getSomeReg x-    (src2, code2) <- getSomeReg y-    let-        code__2 dst = code1 `appOL` code2 `appOL` toOL [-            XOR False src1 (RIReg src2) dst,-            SUB False True g0 (RIReg dst) g0,-            SUB True False g0 (RIImm (ImmInt (-1))) dst]-    return (Any II32 code__2)--condIntReg NE x (CmmLit (CmmInt 0 _)) = do-    (src, code) <- getSomeReg x-    let-        code__2 dst = code `appOL` toOL [-            SUB False True g0 (RIReg src) g0,-            ADD True False g0 (RIImm (ImmInt 0)) dst]-    return (Any II32 code__2)--condIntReg NE x y = do-    (src1, code1) <- getSomeReg x-    (src2, code2) <- getSomeReg y-    let-        code__2 dst = code1 `appOL` code2 `appOL` toOL [-            XOR False src1 (RIReg src2) dst,-            SUB False True g0 (RIReg dst) g0,-            ADD True False g0 (RIImm (ImmInt 0)) dst]-    return (Any II32 code__2)--condIntReg cond x y = do-    bid1 <- liftM (\a -> seq a a) getBlockIdNat-    bid2 <- liftM (\a -> seq a a) getBlockIdNat-    CondCode _ cond cond_code <- condIntCode cond x y-    let-        code__2 dst-         =      cond_code-          `appOL` toOL-                [ BI cond False bid1-                , NOP--                , OR False g0 (RIImm (ImmInt 0)) dst-                , BI ALWAYS False bid2-                , NOP--                , NEWBLOCK bid1-                , OR False g0 (RIImm (ImmInt 1)) dst-                , BI ALWAYS False bid2-                , NOP--                , NEWBLOCK bid2]--    return (Any II32 code__2)---condFltReg :: Cond -> CmmExpr -> CmmExpr -> NatM Register-condFltReg cond x y = do-    bid1 <- liftM (\a -> seq a a) getBlockIdNat-    bid2 <- liftM (\a -> seq a a) getBlockIdNat--    CondCode _ cond cond_code <- condFltCode cond x y-    let-        code__2 dst-         =      cond_code-          `appOL` toOL-                [ NOP-                , BF cond False bid1-                , NOP--                , OR False g0 (RIImm (ImmInt 0)) dst-                , BI ALWAYS False bid2-                , NOP--                , NEWBLOCK bid1-                , OR False g0 (RIImm (ImmInt 1)) dst-                , BI ALWAYS False bid2-                , NOP--                , NEWBLOCK bid2 ]--    return (Any II32 code__2)
− GHC/CmmToAsm/SPARC/CodeGen/Gen32.hs-boot 
@@ -1,16 +0,0 @@--module GHC.CmmToAsm.SPARC.CodeGen.Gen32 (-        getSomeReg,-        getRegister-)--where--import GHC.CmmToAsm.SPARC.CodeGen.Base-import GHC.CmmToAsm.Monad-import GHC.Platform.Reg--import GHC.Cmm--getSomeReg  :: CmmExpr -> NatM (Reg, InstrBlock)-getRegister :: CmmExpr -> NatM Register
− GHC/CmmToAsm/SPARC/CodeGen/Gen64.hs 
@@ -1,215 +0,0 @@--- | Evaluation of 64 bit values on 32 bit platforms.-module GHC.CmmToAsm.SPARC.CodeGen.Gen64 (-        assignMem_I64Code,-        assignReg_I64Code,-        iselExpr64-)--where--import GHC.Prelude--import {-# SOURCE #-} GHC.CmmToAsm.SPARC.CodeGen.Gen32-import GHC.CmmToAsm.SPARC.CodeGen.Base-import GHC.CmmToAsm.SPARC.CodeGen.Amode-import GHC.CmmToAsm.SPARC.Regs-import GHC.CmmToAsm.SPARC.AddrMode-import GHC.CmmToAsm.SPARC.Imm-import GHC.CmmToAsm.SPARC.Instr-import GHC.CmmToAsm.Monad-import GHC.CmmToAsm.Format-import GHC.Platform.Reg--import GHC.Cmm--import GHC.Data.OrdList-import GHC.Utils.Outputable-import GHC.Utils.Panic---- | Code to assign a 64 bit value to memory.-assignMem_I64Code-        :: CmmExpr              -- ^ expr producing the destination address-        -> CmmExpr              -- ^ expr producing the source value.-        -> NatM InstrBlock--assignMem_I64Code addrTree valueTree- = do-     ChildCode64 vcode rlo      <- iselExpr64 valueTree--     (src, acode) <- getSomeReg addrTree-     let-         rhi = getHiVRegFromLo rlo--         -- Big-endian store-         mov_hi = ST II32 rhi (AddrRegImm src (ImmInt 0))-         mov_lo = ST II32 rlo (AddrRegImm src (ImmInt 4))--         code   = vcode `appOL` acode `snocOL` mov_hi `snocOL` mov_lo--{-     pprTrace "assignMem_I64Code"-        (vcat   [ text "addrTree:  " <+> ppr addrTree-                , text "valueTree: " <+> ppr valueTree-                , text "vcode:"-                , vcat $ map ppr $ fromOL vcode-                , text ""-                , text "acode:"-                , vcat $ map ppr $ fromOL acode ])-       $ -}-     return code----- | Code to assign a 64 bit value to a register.-assignReg_I64Code-        :: CmmReg               -- ^ the destination register-        -> CmmExpr              -- ^ expr producing the source value-        -> NatM InstrBlock--assignReg_I64Code (CmmLocal (LocalReg u_dst pk)) valueTree- = do-     ChildCode64 vcode r_src_lo <- iselExpr64 valueTree-     let-         r_dst_lo = RegVirtual $ mkVirtualReg u_dst (cmmTypeFormat pk)-         r_dst_hi = getHiVRegFromLo r_dst_lo-         r_src_hi = getHiVRegFromLo r_src_lo-         mov_lo = mkMOV r_src_lo r_dst_lo-         mov_hi = mkMOV r_src_hi r_dst_hi-         mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg--     return (vcode `snocOL` mov_hi `snocOL` mov_lo)--assignReg_I64Code _ _-   = panic "assignReg_I64Code(sparc): invalid lvalue"------- | Get the value of an expression into a 64 bit register.--iselExpr64 :: CmmExpr -> NatM ChildCode64---- Load a 64 bit word--- TODO: Check Ben-iselExpr64 (CmmLoad addrTree ty _)- | isWord64 ty- = do   Amode amode addr_code   <- getAmode addrTree-        let result--                | AddrRegReg r1 r2      <- amode-                = do    rlo     <- getNewRegNat II32-                        tmp     <- getNewRegNat II32-                        let rhi = getHiVRegFromLo rlo--                        return  $ ChildCode64-                                (        addr_code-                                `appOL`  toOL-                                         [ ADD False False r1 (RIReg r2) tmp-                                         , LD II32 (AddrRegImm tmp (ImmInt 0)) rhi-                                         , LD II32 (AddrRegImm tmp (ImmInt 4)) rlo ])-                                rlo--                | AddrRegImm r1 (ImmInt i) <- amode-                = do    rlo     <- getNewRegNat II32-                        let rhi = getHiVRegFromLo rlo--                        return  $ ChildCode64-                                (        addr_code-                                `appOL`  toOL-                                         [ LD II32 (AddrRegImm r1 (ImmInt $ 0 + i)) rhi-                                         , LD II32 (AddrRegImm r1 (ImmInt $ 4 + i)) rlo ])-                                rlo--                | otherwise-                = panic "SPARC.CodeGen.Gen64: no match"--        result----- Add a literal to a 64 bit integer-iselExpr64 (CmmMachOp (MO_Add _) [e1, CmmLit (CmmInt i _)])- = do   ChildCode64 code1 r1_lo <- iselExpr64 e1-        let r1_hi       = getHiVRegFromLo r1_lo--        r_dst_lo        <- getNewRegNat II32-        let r_dst_hi    =  getHiVRegFromLo r_dst_lo--        let code =      code1-                `appOL` toOL-                        [ ADD False True  r1_lo (RIImm (ImmInteger i)) r_dst_lo-                        , ADD True  False r1_hi (RIReg g0)         r_dst_hi ]--        return  $ ChildCode64 code r_dst_lo----- Addition of II64-iselExpr64 (CmmMachOp (MO_Add _) [e1, e2])- = do   ChildCode64 code1 r1_lo <- iselExpr64 e1-        let r1_hi       = getHiVRegFromLo r1_lo--        ChildCode64 code2 r2_lo <- iselExpr64 e2-        let r2_hi       = getHiVRegFromLo r2_lo--        r_dst_lo        <- getNewRegNat II32-        let r_dst_hi    = getHiVRegFromLo r_dst_lo--        let code =      code1-                `appOL` code2-                `appOL` toOL-                        [ ADD False True  r1_lo (RIReg r2_lo) r_dst_lo-                        , ADD True  False r1_hi (RIReg r2_hi) r_dst_hi ]--        return  $ ChildCode64 code r_dst_lo---iselExpr64 (CmmReg (CmmLocal (LocalReg uq ty)))- | isWord64 ty- = do-     r_dst_lo <-  getNewRegNat II32-     let r_dst_hi = getHiVRegFromLo r_dst_lo-         r_src_lo = RegVirtual $ mkVirtualReg uq II32-         r_src_hi = getHiVRegFromLo r_src_lo-         mov_lo = mkMOV r_src_lo r_dst_lo-         mov_hi = mkMOV r_src_hi r_dst_hi-         mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg-     return (-            ChildCode64 (toOL [mov_hi, mov_lo]) r_dst_lo-         )---- Convert something into II64-iselExpr64 (CmmMachOp (MO_UU_Conv _ W64) [expr])- = do-        r_dst_lo        <- getNewRegNat II32-        let r_dst_hi    = getHiVRegFromLo r_dst_lo--        -- compute expr and load it into r_dst_lo-        (a_reg, a_code) <- getSomeReg expr--        platform        <- getPlatform-        let code        = a_code-                `appOL` toOL-                        [ mkRegRegMoveInstr platform g0    r_dst_hi     -- clear high 32 bits-                        , mkRegRegMoveInstr platform a_reg r_dst_lo ]--        return  $ ChildCode64 code r_dst_lo---- only W32 supported for now-iselExpr64 (CmmMachOp (MO_SS_Conv W32 W64) [expr])- = do-        r_dst_lo        <- getNewRegNat II32-        let r_dst_hi    = getHiVRegFromLo r_dst_lo--        -- compute expr and load it into r_dst_lo-        (a_reg, a_code) <- getSomeReg expr--        platform        <- getPlatform-        let code        = a_code-                `appOL` toOL-                        [ SRA a_reg (RIImm (ImmInt 31)) r_dst_hi-                        , mkRegRegMoveInstr platform a_reg r_dst_lo ]--        return  $ ChildCode64 code r_dst_lo---iselExpr64 expr-   = do-      platform <- getPlatform-      pprPanic "iselExpr64(sparc)" (pdoc platform expr)
− GHC/CmmToAsm/SPARC/CodeGen/Sanity.hs 
@@ -1,72 +0,0 @@--- | One ounce of sanity checking is worth 10000000000000000 ounces--- of staring blindly at assembly code trying to find the problem..-module GHC.CmmToAsm.SPARC.CodeGen.Sanity (-        checkBlock-)--where--import GHC.Prelude-import GHC.Platform--import GHC.CmmToAsm.SPARC.Instr-import GHC.CmmToAsm.SPARC.Ppr        () -- For Outputable instances-import GHC.CmmToAsm.Types--import GHC.Cmm--import GHC.Utils.Outputable-import GHC.Utils.Panic----- | Enforce intra-block invariants.----checkBlock :: Platform-           -> CmmBlock-           -> NatBasicBlock Instr-           -> NatBasicBlock Instr--checkBlock platform cmm block@(BasicBlock _ instrs)-        | checkBlockInstrs instrs-        = block--        | otherwise-        = pprPanic-                ("SPARC.CodeGen: bad block\n")-                ( vcat  [ text " -- cmm -----------------\n"-                        , pdoc platform cmm-                        , text " -- native code ---------\n"-                        , pdoc platform block ])---checkBlockInstrs :: [Instr] -> Bool-checkBlockInstrs ii--        -- An unconditional jumps end the block.-        --      There must be an unconditional jump in the block, otherwise-        --      the register liveness determinator will get the liveness-        --      information wrong.-        ---        --      If the block ends with a cmm call that never returns-        --      then there can be unreachable instructions after the jump,-        --      but we don't mind here.-        ---        | instr : NOP : _       <- ii-        , isUnconditionalJump instr-        = True--        -- All jumps must have a NOP in their branch delay slot.-        --      The liveness determinator and register allocators aren't smart-        --      enough to handle branch delay slots.-        ---        | instr : NOP : is      <- ii-        , isJumpishInstr instr-        = checkBlockInstrs is--        -- keep checking-        | _:i2:is               <- ii-        = checkBlockInstrs (i2:is)--        -- this block is no good-        | otherwise-        = False
− GHC/CmmToAsm/SPARC/Cond.hs 
@@ -1,27 +0,0 @@-module GHC.CmmToAsm.SPARC.Cond (-        Cond(..),-)--where--import GHC.Prelude---- | Branch condition codes.-data Cond-        = ALWAYS-        | EQQ-        | GE-        | GEU-        | GTT-        | GU-        | LE-        | LEU-        | LTT-        | LU-        | NE-        | NEG-        | NEVER-        | POS-        | VC-        | VS-        deriving Eq
− GHC/CmmToAsm/SPARC/Imm.hs 
@@ -1,68 +0,0 @@-module GHC.CmmToAsm.SPARC.Imm (-        -- immediate values-        Imm(..),-        strImmLit,-        litToImm-)--where--import GHC.Prelude--import GHC.Cmm-import GHC.Cmm.CLabel--import GHC.Utils.Outputable-import GHC.Utils.Panic---- | An immediate value.---      Not all of these are directly representable by the machine.---      Things like ImmLit are slurped out and put in a data segment instead.----data Imm-        = ImmInt        Int--        -- Sigh.-        | ImmInteger    Integer--        -- AbstractC Label (with baggage)-        | ImmCLbl       CLabel--        -- Simple string-        | ImmLit        SDoc-        | ImmIndex      CLabel Int-        | ImmFloat      Rational-        | ImmDouble     Rational--        | ImmConstantSum  Imm Imm-        | ImmConstantDiff Imm Imm--        | LO    Imm-        | HI    Imm----- | Create a ImmLit containing this string.-strImmLit :: String -> Imm-strImmLit s = ImmLit (text s)----- | Convert a CmmLit to an Imm.---      Narrow to the width: a CmmInt might be out of---      range, but we assume that ImmInteger only contains---      in-range values.  A signed value should be fine here.----litToImm :: CmmLit -> Imm-litToImm lit- = case lit of-        CmmInt i w              -> ImmInteger (narrowS w i)-        CmmFloat f W32          -> ImmFloat f-        CmmFloat f W64          -> ImmDouble f-        CmmLabel l              -> ImmCLbl l-        CmmLabelOff l off       -> ImmIndex l off--        CmmLabelDiffOff l1 l2 off _-         -> ImmConstantSum-                (ImmConstantDiff (ImmCLbl l1) (ImmCLbl l2))-                (ImmInt off)--        _               -> panic "SPARC.Regs.litToImm: no match"
− GHC/CmmToAsm/SPARC/Instr.hs 
@@ -1,472 +0,0 @@-{-# LANGUAGE CPP #-}------------------------------------------------------------------------------------- Machine-dependent assembly language------ (c) The University of Glasgow 1993-2004----------------------------------------------------------------------------------#include "HsVersions.h"--module GHC.CmmToAsm.SPARC.Instr-   ( Instr(..)-   , RI(..)-   , riZero-   , fpRelEA-   , moveSp-   , isUnconditionalJump-   , maxSpillSlots-   , patchRegsOfInstr-   , patchJumpInstr-   , mkRegRegMoveInstr-   , mkLoadInstr-   , mkSpillInstr-   , mkJumpInstr-   , takeDeltaInstr-   , isMetaInstr-   , isJumpishInstr-   , jumpDestsOfInstr-   , takeRegRegMoveInstr-   , regUsageOfInstr-   )-where--import GHC.Prelude-import GHC.Platform--import GHC.CmmToAsm.SPARC.Stack-import GHC.CmmToAsm.SPARC.Imm-import GHC.CmmToAsm.SPARC.AddrMode-import GHC.CmmToAsm.SPARC.Cond-import GHC.CmmToAsm.SPARC.Regs-import GHC.CmmToAsm.SPARC.Base-import GHC.CmmToAsm.Reg.Target-import GHC.CmmToAsm.Format-import GHC.CmmToAsm.Config-import GHC.CmmToAsm.Instr (RegUsage(..), noUsage)--import GHC.Platform.Reg.Class-import GHC.Platform.Reg-import GHC.Platform.Regs--import GHC.Cmm.CLabel-import GHC.Cmm.BlockId-import GHC.Cmm-import GHC.Data.FastString-import GHC.Utils.Panic----- | Register or immediate-data RI-        = RIReg Reg-        | RIImm Imm---- | Check if a RI represents a zero value.---      - a literal zero---      - register %g0, which is always zero.----riZero :: RI -> Bool-riZero (RIImm (ImmInt 0))                       = True-riZero (RIImm (ImmInteger 0))                   = True-riZero (RIReg (RegReal (RealRegSingle 0)))      = True-riZero _                                        = False----- | Calculate the effective address which would be used by the---      corresponding fpRel sequence.-fpRelEA :: Int -> Reg -> Instr-fpRelEA n dst-   = ADD False False fp (RIImm (ImmInt (n * wordLength))) dst----- | Code to shift the stack pointer by n words.-moveSp :: Int -> Instr-moveSp n-   = ADD False False sp (RIImm (ImmInt (n * wordLength))) sp---- | An instruction that will cause the one after it never to be exectuted-isUnconditionalJump :: Instr -> Bool-isUnconditionalJump ii- = case ii of-        CALL{}          -> True-        JMP{}           -> True-        JMP_TBL{}       -> True-        BI ALWAYS _ _   -> True-        BF ALWAYS _ _   -> True-        _               -> False----- | SPARC instruction set.---      Not complete. This is only the ones we need.----data Instr--        -- meta ops ---------------------------------------------------        -- comment pseudo-op-        = COMMENT FastString--        -- some static data spat out during code generation.-        -- Will be extracted before pretty-printing.-        | LDATA   Section 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--        -- real instrs ------------------------------------------------        -- Loads and stores.-        | LD            Format AddrMode Reg             -- format, src, dst-        | ST            Format Reg AddrMode             -- format, src, dst--        -- Int Arithmetic.-        --      x:   add/sub with carry bit.-        --              In SPARC V9 addx and friends were renamed addc.-        ---        --      cc:  modify condition codes-        ---        | ADD           Bool Bool Reg RI Reg            -- x?, cc?, src1, src2, dst-        | SUB           Bool Bool Reg RI Reg            -- x?, cc?, src1, src2, dst--        | UMUL          Bool Reg RI Reg                 --     cc?, src1, src2, dst-        | SMUL          Bool Reg RI Reg                 --     cc?, src1, src2, dst---        -- The SPARC divide instructions perform 64bit by 32bit division-        --   The Y register is xored into the first operand.--        --   On _some implementations_ the Y register is overwritten by-        --   the remainder, so we have to make sure it is 0 each time.--        --   dst <- ((Y `shiftL` 32) `or` src1) `div` src2-        | UDIV          Bool Reg RI Reg                 --     cc?, src1, src2, dst-        | SDIV          Bool Reg RI Reg                 --     cc?, src1, src2, dst--        | RDY           Reg                             -- move contents of Y register to reg-        | WRY           Reg  Reg                        -- Y <- src1 `xor` src2--        -- Logic operations.-        | AND           Bool Reg RI Reg                 -- cc?, src1, src2, dst-        | ANDN          Bool Reg RI Reg                 -- cc?, src1, src2, dst-        | OR            Bool Reg RI Reg                 -- cc?, src1, src2, dst-        | ORN           Bool Reg RI Reg                 -- cc?, src1, src2, dst-        | XOR           Bool Reg RI Reg                 -- cc?, src1, src2, dst-        | XNOR          Bool Reg RI Reg                 -- cc?, src1, src2, dst-        | SLL           Reg RI Reg                      -- src1, src2, dst-        | SRL           Reg RI Reg                      -- src1, src2, dst-        | SRA           Reg RI Reg                      -- src1, src2, dst--        -- Load immediates.-        | SETHI         Imm Reg                         -- src, dst--        -- Do nothing.-        -- Implemented by the assembler as SETHI 0, %g0, but worth an alias-        | NOP--        -- Float Arithmetic.-        -- Note that we cheat by treating F{ABS,MOV,NEG} of doubles as single-        -- instructions right up until we spit them out.-        ---        | FABS          Format Reg Reg                  -- src dst-        | FADD          Format Reg Reg Reg              -- src1, src2, dst-        | FCMP          Bool Format Reg Reg             -- exception?, src1, src2, dst-        | FDIV          Format Reg Reg Reg              -- src1, src2, dst-        | FMOV          Format Reg Reg                  -- src, dst-        | FMUL          Format Reg Reg Reg              -- src1, src2, dst-        | FNEG          Format Reg Reg                  -- src, dst-        | FSQRT         Format Reg Reg                  -- src, dst-        | FSUB          Format Reg Reg Reg              -- src1, src2, dst-        | FxTOy         Format Format Reg Reg           -- src, dst--        -- Jumping around.-        | BI            Cond Bool BlockId               -- cond, annul?, target-        | BF            Cond Bool BlockId               -- cond, annul?, target--        | JMP           AddrMode                        -- target--        -- With a tabled jump we know all the possible destinations.-        -- We also need this info so we can work out what regs are live across the jump.-        ---        | JMP_TBL       AddrMode [Maybe BlockId] CLabel--        | CALL          (Either Imm Reg) Int Bool       -- target, args, terminal----- | regUsage returns the sets of src and destination registers used---      by a particular instruction.  Machine registers that are---      pre-allocated to stgRegs are filtered out, because they are---      uninteresting from a register allocation standpoint.  (We wouldn't---      want them to end up on the free list!)  As far as we are concerned,---      the fixed registers simply don't exist (for allocation purposes,---      anyway).----      regUsage doesn't need to do any trickery for jumps and such.  Just---      state precisely the regs read and written by that insn.  The---      consequences of control flow transfers, as far as register---      allocation goes, are taken care of by the register allocator.----regUsageOfInstr :: Platform -> Instr -> RegUsage-regUsageOfInstr platform instr- = case instr of-    LD    _ addr reg            -> usage (regAddr addr,         [reg])-    ST    _ reg addr            -> usage (reg : regAddr addr,   [])-    ADD   _ _ r1 ar r2          -> usage (r1 : regRI ar,        [r2])-    SUB   _ _ r1 ar r2          -> usage (r1 : regRI ar,        [r2])-    UMUL    _ r1 ar r2          -> usage (r1 : regRI ar,        [r2])-    SMUL    _ r1 ar r2          -> usage (r1 : regRI ar,        [r2])-    UDIV    _ r1 ar r2          -> usage (r1 : regRI ar,        [r2])-    SDIV    _ r1 ar r2          -> usage (r1 : regRI ar,        [r2])-    RDY       rd                -> usage ([],                   [rd])-    WRY       r1 r2             -> usage ([r1, r2],             [])-    AND     _ r1 ar r2          -> usage (r1 : regRI ar,        [r2])-    ANDN    _ r1 ar r2          -> usage (r1 : regRI ar,        [r2])-    OR      _ r1 ar r2          -> usage (r1 : regRI ar,        [r2])-    ORN     _ r1 ar r2          -> usage (r1 : regRI ar,        [r2])-    XOR     _ r1 ar r2          -> usage (r1 : regRI ar,        [r2])-    XNOR    _ r1 ar r2          -> usage (r1 : regRI ar,        [r2])-    SLL       r1 ar r2          -> usage (r1 : regRI ar,        [r2])-    SRL       r1 ar r2          -> usage (r1 : regRI ar,        [r2])-    SRA       r1 ar r2          -> usage (r1 : regRI ar,        [r2])-    SETHI   _ reg               -> usage ([],                   [reg])-    FABS    _ r1 r2             -> usage ([r1],                 [r2])-    FADD    _ r1 r2 r3          -> usage ([r1, r2],             [r3])-    FCMP    _ _  r1 r2          -> usage ([r1, r2],             [])-    FDIV    _ r1 r2 r3          -> usage ([r1, r2],             [r3])-    FMOV    _ r1 r2             -> usage ([r1],                 [r2])-    FMUL    _ r1 r2 r3          -> usage ([r1, r2],             [r3])-    FNEG    _ r1 r2             -> usage ([r1],                 [r2])-    FSQRT   _ r1 r2             -> usage ([r1],                 [r2])-    FSUB    _ r1 r2 r3          -> usage ([r1, r2],             [r3])-    FxTOy   _ _  r1 r2          -> usage ([r1],                 [r2])--    JMP     addr                -> usage (regAddr addr, [])-    JMP_TBL addr _ _            -> usage (regAddr addr, [])--    CALL  (Left _  )  _ True    -> noUsage-    CALL  (Left _  )  n False   -> usage (argRegs n, callClobberedRegs)-    CALL  (Right reg) _ True    -> usage ([reg], [])-    CALL  (Right reg) n False   -> usage (reg : (argRegs n), callClobberedRegs)-    _                           -> noUsage--  where-    usage (src, dst)-     = RU (filter (interesting platform) src)-          (filter (interesting platform) dst)--    regAddr (AddrRegReg r1 r2)  = [r1, r2]-    regAddr (AddrRegImm r1 _)   = [r1]--    regRI (RIReg r)             = [r]-    regRI  _                    = []----- | Interesting regs are virtuals, or ones that are allocatable---      by the register allocator.-interesting :: Platform -> Reg -> Bool-interesting platform reg- = case reg of-        RegVirtual _                    -> True-        RegReal (RealRegSingle r1)      -> freeReg platform r1-        RegReal (RealRegPair r1 _)      -> freeReg platform r1------ | Apply a given mapping to tall the register references in this instruction.-patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr-patchRegsOfInstr instr env = case instr of-    LD    fmt addr reg          -> LD fmt (fixAddr addr) (env reg)-    ST    fmt reg addr          -> ST fmt (env reg) (fixAddr addr)--    ADD   x cc r1 ar r2         -> ADD   x cc  (env r1) (fixRI ar) (env r2)-    SUB   x cc r1 ar r2         -> SUB   x cc  (env r1) (fixRI ar) (env r2)-    UMUL    cc r1 ar r2         -> UMUL    cc  (env r1) (fixRI ar) (env r2)-    SMUL    cc r1 ar r2         -> SMUL    cc  (env r1) (fixRI ar) (env r2)-    UDIV    cc r1 ar r2         -> UDIV    cc  (env r1) (fixRI ar) (env r2)-    SDIV    cc r1 ar r2         -> SDIV    cc  (env r1) (fixRI ar) (env r2)-    RDY   rd                    -> RDY         (env rd)-    WRY   r1 r2                 -> WRY         (env r1) (env r2)-    AND   b r1 ar r2            -> AND   b     (env r1) (fixRI ar) (env r2)-    ANDN  b r1 ar r2            -> ANDN  b     (env r1) (fixRI ar) (env r2)-    OR    b r1 ar r2            -> OR    b     (env r1) (fixRI ar) (env r2)-    ORN   b r1 ar r2            -> ORN   b     (env r1) (fixRI ar) (env r2)-    XOR   b r1 ar r2            -> XOR   b     (env r1) (fixRI ar) (env r2)-    XNOR  b r1 ar r2            -> XNOR  b     (env r1) (fixRI ar) (env r2)-    SLL   r1 ar r2              -> SLL         (env r1) (fixRI ar) (env r2)-    SRL   r1 ar r2              -> SRL         (env r1) (fixRI ar) (env r2)-    SRA   r1 ar r2              -> SRA         (env r1) (fixRI ar) (env r2)--    SETHI imm reg               -> SETHI imm (env reg)--    FABS  s r1 r2               -> FABS    s   (env r1) (env r2)-    FADD  s r1 r2 r3            -> FADD    s   (env r1) (env r2) (env r3)-    FCMP  e s r1 r2             -> FCMP e  s   (env r1) (env r2)-    FDIV  s r1 r2 r3            -> FDIV    s   (env r1) (env r2) (env r3)-    FMOV  s r1 r2               -> FMOV    s   (env r1) (env r2)-    FMUL  s r1 r2 r3            -> FMUL    s   (env r1) (env r2) (env r3)-    FNEG  s r1 r2               -> FNEG    s   (env r1) (env r2)-    FSQRT s r1 r2               -> FSQRT   s   (env r1) (env r2)-    FSUB  s r1 r2 r3            -> FSUB    s   (env r1) (env r2) (env r3)-    FxTOy s1 s2 r1 r2           -> FxTOy s1 s2 (env r1) (env r2)--    JMP     addr                -> JMP     (fixAddr addr)-    JMP_TBL addr ids l          -> JMP_TBL (fixAddr addr) ids l--    CALL  (Left i) n t          -> CALL (Left i) n t-    CALL  (Right r) n t         -> CALL (Right (env r)) n t-    _                           -> instr--  where-    fixAddr (AddrRegReg r1 r2)  = AddrRegReg   (env r1) (env r2)-    fixAddr (AddrRegImm r1 i)   = AddrRegImm   (env r1) i--    fixRI (RIReg r)             = RIReg (env r)-    fixRI other                 = other------------------------------------------------------------------------------------isJumpishInstr :: Instr -> Bool-isJumpishInstr instr- = case instr of-        BI{}            -> True-        BF{}            -> True-        JMP{}           -> True-        JMP_TBL{}       -> True-        CALL{}          -> True-        _               -> False--jumpDestsOfInstr :: Instr -> [BlockId]-jumpDestsOfInstr insn-  = case insn of-        BI   _ _ id     -> [id]-        BF   _ _ id     -> [id]-        JMP_TBL _ ids _ -> [id | Just id <- ids]-        _               -> []---patchJumpInstr :: Instr -> (BlockId -> BlockId) -> Instr-patchJumpInstr insn patchF-  = case insn of-        BI cc annul id  -> BI cc annul (patchF id)-        BF cc annul id  -> BF cc annul (patchF id)-        JMP_TBL n ids l -> JMP_TBL n (map (fmap patchF) ids) l-        _               -> insn-------------------------------------------------------------------------------------- | Make a spill instruction.---      On SPARC we spill below frame pointer leaving 2 words/spill-mkSpillInstr-    :: NCGConfig-    -> Reg      -- ^ register to spill-    -> Int      -- ^ current stack delta-    -> Int      -- ^ spill slot to use-    -> [Instr]--mkSpillInstr config reg _ slot- = let  platform = ncgPlatform config-        off      = spillSlotToOffset config slot-        off_w    = 1 + (off `div` 4)-        fmt      = case targetClassOfReg platform reg of-                        RcInteger -> II32-                        RcFloat   -> FF32-                        RcDouble  -> FF64--    in [ST fmt reg (fpRel (negate off_w))]----- | Make a spill reload instruction.-mkLoadInstr-    :: NCGConfig-    -> Reg      -- ^ register to load into-    -> Int      -- ^ current stack delta-    -> Int      -- ^ spill slot to use-    -> [Instr]--mkLoadInstr config reg _ slot-  = let platform = ncgPlatform config-        off      = spillSlotToOffset config slot-        off_w    = 1 + (off `div` 4)-        fmt      = case targetClassOfReg platform reg of-                        RcInteger -> II32-                        RcFloat   -> FF32-                        RcDouble  -> FF64--        in [LD fmt (fpRel (- off_w)) reg]-------------------------------------------------------------------------------------- | See if this instruction is telling us the current C stack delta-takeDeltaInstr-        :: Instr-        -> Maybe Int--takeDeltaInstr instr- = case instr of-        DELTA i         -> Just i-        _               -> Nothing---isMetaInstr-        :: Instr-        -> Bool--isMetaInstr instr- = case instr of-        COMMENT{}       -> True-        LDATA{}         -> True-        NEWBLOCK{}      -> True-        DELTA{}         -> True-        _               -> False----- | Make a reg-reg move instruction.---      On SPARC v8 there are no instructions to move directly between---      floating point and integer regs. If we need to do that then we---      have to go via memory.----mkRegRegMoveInstr-    :: Platform-    -> Reg-    -> Reg-    -> Instr--mkRegRegMoveInstr platform src dst-        | srcClass      <- targetClassOfReg platform src-        , dstClass      <- targetClassOfReg platform dst-        , srcClass == dstClass-        = case srcClass of-                RcInteger -> ADD  False False src (RIReg g0) dst-                RcDouble  -> FMOV FF64 src dst-                RcFloat   -> FMOV FF32 src dst--        | otherwise-        = panic "SPARC.Instr.mkRegRegMoveInstr: classes of src and dest not the same"----- | Check whether an instruction represents a reg-reg move.---      The register allocator attempts to eliminate reg->reg moves whenever it can,---      by assigning the src and dest temporaries to the same real register.----takeRegRegMoveInstr :: Instr -> Maybe (Reg,Reg)-takeRegRegMoveInstr instr- = case instr of-        ADD False False src (RIReg src2) dst-         | g0 == src2           -> Just (src, dst)--        FMOV FF64 src dst       -> Just (src, dst)-        FMOV FF32  src dst      -> Just (src, dst)-        _                       -> Nothing----- | Make an unconditional branch instruction.-mkJumpInstr-        :: BlockId-        -> [Instr]--mkJumpInstr id- =       [BI ALWAYS False id-        , NOP]                  -- fill the branch delay slot.
− GHC/CmmToAsm/SPARC/Ppr.hs 
@@ -1,667 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-------------------------------------------------------------------------------------- Pretty-printing assembly language------ (c) The University of Glasgow 1993-2005-----------------------------------------------------------------------------------{-# OPTIONS_GHC -fno-warn-orphans #-}-module GHC.CmmToAsm.SPARC.Ppr (-        pprNatCmmDecl,-        pprBasicBlock,-        pprData,-        pprInstr,-        pprFormat,-        pprImm,-        pprDataItem-)--where--#include "HsVersions.h"--import GHC.Prelude--import Data.Word-import qualified Data.Array.Unsafe as U ( castSTUArray )-import Data.Array.ST--import Control.Monad.ST--import GHC.CmmToAsm.SPARC.Regs-import GHC.CmmToAsm.SPARC.Instr-import GHC.CmmToAsm.SPARC.Cond-import GHC.CmmToAsm.SPARC.Imm-import GHC.CmmToAsm.SPARC.AddrMode-import GHC.CmmToAsm.SPARC.Base-import GHC.Platform.Reg-import GHC.CmmToAsm.Format-import GHC.CmmToAsm.Ppr-import GHC.CmmToAsm.Config-import GHC.CmmToAsm.Types-import GHC.CmmToAsm.Utils--import GHC.Cmm hiding (topInfoTable)-import GHC.Cmm.Ppr() -- For Outputable instances-import GHC.Cmm.BlockId-import GHC.Cmm.CLabel-import GHC.Cmm.Dataflow.Label-import GHC.Cmm.Dataflow.Collections--import GHC.Types.Unique ( pprUniqueAlways )-import GHC.Utils.Outputable-import GHC.Utils.Panic-import GHC.Platform-import GHC.Data.FastString---- -------------------------------------------------------------------------------- Printing this stuff out--pprNatCmmDecl :: NCGConfig -> NatCmmDecl RawCmmStatics Instr -> SDoc-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) $$-        pprLabel platform lbl $$ -- blocks guaranteed not null, so label needed-        vcat (map (pprBasicBlock platform top_info) blocks)--    Just (CmmStaticsRaw info_lbl _) ->-      (if platformHasSubsectionsViaSymbols platform-          then pprSectionAlign config dspSection $$-               pdoc platform (mkDeadStripPreventer info_lbl) <> char ':'-          else empty) $$-      vcat (map (pprBasicBlock platform top_info) blocks) $$-      -- above: Even the first block gets a label, because with branch-chain-      -- elimination, it might be the target of a goto.-      (if platformHasSubsectionsViaSymbols platform-       then-       -- See Note [Subsections Via Symbols] in X86/Ppr.hs-                text "\t.long "-            <+> pdoc platform info_lbl-            <+> char '-'-            <+> pdoc platform (mkDeadStripPreventer info_lbl)-       else empty)--dspSection :: Section-dspSection = Section Text $-    panic "subsections-via-symbols doesn't combine with split-sections"--pprBasicBlock :: Platform -> LabelMap RawCmmStatics -> NatBasicBlock Instr -> SDoc-pprBasicBlock platform info_env (BasicBlock blockid instrs)-  = maybe_infotable $$-    pprLabel platform (blockLbl blockid) $$-    vcat (map (pprInstr platform) instrs)-  where-    maybe_infotable = case mapLookup blockid info_env of-       Nothing   -> empty-       Just (CmmStaticsRaw info_lbl info) ->-           pprAlignForSection Text $$-           vcat (map (pprData platform) info) $$-           pprLabel platform info_lbl---pprDatas :: Platform -> RawCmmStatics -> SDoc--- 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-    $$ text ".equiv" <+> pdoc platform alias <> comma <> pdoc platform (CmmLabel ind')-pprDatas platform (CmmStaticsRaw lbl dats) = vcat (pprLabel platform lbl : map (pprData platform) dats)--pprData :: Platform -> CmmStatic -> SDoc-pprData platform d = case d of-   CmmString str          -> pprString str-   CmmFileEmbed path      -> pprFileEmbed path-   CmmUninitialised bytes -> text ".skip " <> int bytes-   CmmStaticLit lit       -> pprDataItem platform lit--pprGloblDecl :: Platform -> CLabel -> SDoc-pprGloblDecl platform lbl-  | not (externallyVisibleCLabel lbl) = empty-  | otherwise = text ".global " <> pdoc platform lbl--pprTypeAndSizeDecl :: Platform -> CLabel -> SDoc-pprTypeAndSizeDecl platform lbl-    = if platformOS platform == OSLinux && externallyVisibleCLabel lbl-      then text ".type " <> pdoc platform lbl <> ptext (sLit ", @object")-      else empty--pprLabel :: Platform -> CLabel -> SDoc-pprLabel platform lbl =-   pprGloblDecl platform lbl-   $$ pprTypeAndSizeDecl platform lbl-   $$ (pdoc platform lbl <> char ':')---- -------------------------------------------------------------------------------- pprInstr: print an 'Instr'--instance OutputableP Platform Instr where-    pdoc = pprInstr----- | Pretty print a register.-pprReg :: Reg -> SDoc-pprReg reg- = case reg of-        RegVirtual vr-         -> case vr of-                VirtualRegI   u -> text "%vI_"   <> pprUniqueAlways u-                VirtualRegHi  u -> text "%vHi_"  <> pprUniqueAlways u-                VirtualRegF   u -> text "%vF_"   <> pprUniqueAlways u-                VirtualRegD   u -> text "%vD_"   <> pprUniqueAlways u---        RegReal rr-         -> case rr of-                RealRegSingle r1-                 -> pprReg_ofRegNo r1--                RealRegPair r1 r2-                 -> text "(" <> pprReg_ofRegNo r1-                 <> vbar     <> pprReg_ofRegNo r2-                 <> text ")"------ | Pretty print a register name, based on this register number.---   The definition has been unfolded so we get a jump-table in the---   object code. This function is called quite a lot when emitting---   the asm file..----pprReg_ofRegNo :: Int -> SDoc-pprReg_ofRegNo i- = ptext-    (case i of {-         0 -> sLit "%g0";   1 -> sLit "%g1";-         2 -> sLit "%g2";   3 -> sLit "%g3";-         4 -> sLit "%g4";   5 -> sLit "%g5";-         6 -> sLit "%g6";   7 -> sLit "%g7";-         8 -> sLit "%o0";   9 -> sLit "%o1";-        10 -> sLit "%o2";  11 -> sLit "%o3";-        12 -> sLit "%o4";  13 -> sLit "%o5";-        14 -> sLit "%o6";  15 -> sLit "%o7";-        16 -> sLit "%l0";  17 -> sLit "%l1";-        18 -> sLit "%l2";  19 -> sLit "%l3";-        20 -> sLit "%l4";  21 -> sLit "%l5";-        22 -> sLit "%l6";  23 -> sLit "%l7";-        24 -> sLit "%i0";  25 -> sLit "%i1";-        26 -> sLit "%i2";  27 -> sLit "%i3";-        28 -> sLit "%i4";  29 -> sLit "%i5";-        30 -> sLit "%i6";  31 -> sLit "%i7";-        32 -> sLit "%f0";  33 -> sLit "%f1";-        34 -> sLit "%f2";  35 -> sLit "%f3";-        36 -> sLit "%f4";  37 -> sLit "%f5";-        38 -> sLit "%f6";  39 -> sLit "%f7";-        40 -> sLit "%f8";  41 -> sLit "%f9";-        42 -> sLit "%f10"; 43 -> sLit "%f11";-        44 -> sLit "%f12"; 45 -> sLit "%f13";-        46 -> sLit "%f14"; 47 -> sLit "%f15";-        48 -> sLit "%f16"; 49 -> sLit "%f17";-        50 -> sLit "%f18"; 51 -> sLit "%f19";-        52 -> sLit "%f20"; 53 -> sLit "%f21";-        54 -> sLit "%f22"; 55 -> sLit "%f23";-        56 -> sLit "%f24"; 57 -> sLit "%f25";-        58 -> sLit "%f26"; 59 -> sLit "%f27";-        60 -> sLit "%f28"; 61 -> sLit "%f29";-        62 -> sLit "%f30"; 63 -> sLit "%f31";-        _  -> sLit "very naughty sparc register" })----- | Pretty print a format for an instruction suffix.-pprFormat :: Format -> SDoc-pprFormat x- = ptext-    (case x of-        II8     -> sLit "ub"-        II16    -> sLit "uh"-        II32    -> sLit ""-        II64    -> sLit "d"-        FF32    -> sLit ""-        FF64    -> sLit "d")----- | Pretty print a format for an instruction suffix.---      eg LD is 32bit on sparc, but LDD is 64 bit.-pprStFormat :: Format -> SDoc-pprStFormat x- = ptext-    (case x of-        II8   -> sLit "b"-        II16  -> sLit "h"-        II32  -> sLit ""-        II64  -> sLit "x"-        FF32  -> sLit ""-        FF64  -> sLit "d")------ | Pretty print a condition code.-pprCond :: Cond -> SDoc-pprCond c- = ptext-    (case c of-        ALWAYS  -> sLit ""-        NEVER   -> sLit "n"-        GEU     -> sLit "geu"-        LU      -> sLit "lu"-        EQQ     -> sLit "e"-        GTT     -> sLit "g"-        GE      -> sLit "ge"-        GU      -> sLit "gu"-        LTT     -> sLit "l"-        LE      -> sLit "le"-        LEU     -> sLit "leu"-        NE      -> sLit "ne"-        NEG     -> sLit "neg"-        POS     -> sLit "pos"-        VC      -> sLit "vc"-        VS      -> sLit "vs")----- | Pretty print an address mode.-pprAddr :: Platform -> AddrMode -> SDoc-pprAddr platform am- = case am of-        AddrRegReg r1 (RegReal (RealRegSingle 0))-         -> pprReg r1--        AddrRegReg r1 r2-         -> hcat [ pprReg r1, char '+', pprReg r2 ]--        AddrRegImm r1 (ImmInt i)-         | i == 0               -> pprReg r1-         | not (fits13Bits i)   -> largeOffsetError i-         | otherwise            -> hcat [ pprReg r1, pp_sign, int i ]-         where-                pp_sign = if i > 0 then char '+' else empty--        AddrRegImm r1 (ImmInteger i)-         | i == 0               -> pprReg r1-         | not (fits13Bits i)   -> largeOffsetError i-         | otherwise            -> hcat [ pprReg r1, pp_sign, integer i ]-         where-                pp_sign = if i > 0 then char '+' else empty--        AddrRegImm r1 imm-         -> hcat [ pprReg r1, char '+', pprImm platform imm ]----- | Pretty print an immediate value.-pprImm :: Platform -> Imm -> SDoc-pprImm platform imm- = case imm of-        ImmInt i        -> int i-        ImmInteger i    -> integer i-        ImmCLbl l       -> pdoc platform l-        ImmIndex l i    -> pdoc platform l <> char '+' <> int i-        ImmLit s        -> s--        ImmConstantSum a b-         -> pprImm platform a <> char '+' <> pprImm platform b--        ImmConstantDiff a b-         -> pprImm platform a <> char '-' <> lparen <> pprImm platform b <> rparen--        LO i-         -> hcat [ text "%lo(", pprImm platform i, rparen ]--        HI i-         -> hcat [ text "%hi(", pprImm platform i, rparen ]--        -- these should have been converted to bytes and placed-        --      in the data section.-        ImmFloat _      -> text "naughty float immediate"-        ImmDouble _     -> text "naughty double immediate"----- | Pretty print a section \/ segment header.---      On SPARC all the data sections must be at least 8 byte aligned---      incase we store doubles in them.----pprSectionAlign :: NCGConfig -> Section -> SDoc-pprSectionAlign config sec@(Section seg _) =-    pprSectionHeader config sec $$-    pprAlignForSection seg---- | Print appropriate alignment for the given section type.-pprAlignForSection :: SectionType -> SDoc-pprAlignForSection seg =-    ptext (case seg of-      Text              -> sLit ".align 4"-      Data              -> sLit ".align 8"-      ReadOnlyData      -> sLit ".align 8"-      RelocatableReadOnlyData-                        -> sLit ".align 8"-      UninitialisedData -> sLit ".align 8"-      ReadOnlyData16    -> sLit ".align 16"-      -- TODO: This is copied from the ReadOnlyData case, but it can likely be-      -- made more efficient.-      CString           -> sLit ".align 8"-      OtherSection _    -> panic "PprMach.pprSectionHeader: unknown section")---- | Pretty print a data item.-pprDataItem :: Platform -> CmmLit -> SDoc-pprDataItem platform lit-  = vcat (ppr_item (cmmTypeFormat $ cmmLitType platform lit) lit)-    where-        imm = litToImm lit--        ppr_item II8   _        = [text "\t.byte\t" <> pprImm platform imm]-        ppr_item II32  _        = [text "\t.long\t" <> pprImm platform imm]--        ppr_item FF32  (CmmFloat r _)-         = let bs = floatToBytes (fromRational r)-           in  map (\b -> text "\t.byte\t" <> pprImm platform (ImmInt b)) bs--        ppr_item FF64 (CmmFloat r _)-         = let bs = doubleToBytes (fromRational r)-           in  map (\b -> text "\t.byte\t" <> pprImm platform (ImmInt b)) bs--        ppr_item II16  _        = [text "\t.short\t" <> pprImm platform imm]-        ppr_item II64  _        = [text "\t.quad\t"  <> pprImm platform imm]-        ppr_item _ _            = panic "SPARC.Ppr.pprDataItem: no match"--floatToBytes :: Float -> [Int]-floatToBytes f-   = runST (do-        arr <- newArray_ ((0::Int),3)-        writeArray arr 0 f-        arr <- castFloatToWord8Array arr-        i0 <- readArray arr 0-        i1 <- readArray arr 1-        i2 <- readArray arr 2-        i3 <- readArray arr 3-        return (map fromIntegral [i0,i1,i2,i3])-     )--castFloatToWord8Array :: STUArray s Int Float -> ST s (STUArray s Int Word8)-castFloatToWord8Array = U.castSTUArray----- | Pretty print an instruction.-pprInstr :: Platform -> Instr -> SDoc-pprInstr platform = \case-   COMMENT _ -> empty -- nuke comments.-   DELTA d   -> pprInstr platform (COMMENT (mkFastString ("\tdelta = " ++ show d)))--   -- Newblocks and LData should have been slurped out before producing the .s file.-   NEWBLOCK _ -> panic "X86.Ppr.pprInstr: NEWBLOCK"-   LDATA _ _  -> panic "PprMach.pprInstr: LDATA"--   -- 64 bit FP loads are expanded into individual instructions in CodeGen.Expand-   LD FF64 _ reg-        | RegReal (RealRegSingle{})     <- reg-        -> panic "SPARC.Ppr: not emitting potentially misaligned LD FF64 instr"--   LD format addr reg-        -> hcat [-               text "\tld",-               pprFormat format,-               char '\t',-               lbrack,-               pprAddr platform addr,-               pp_rbracket_comma,-               pprReg reg-            ]--   -- 64 bit FP stores are expanded into individual instructions in CodeGen.Expand-   ST FF64 reg _-        | RegReal (RealRegSingle{}) <- reg-        -> panic "SPARC.Ppr: not emitting potentially misaligned ST FF64 instr"--   -- no distinction is made between signed and unsigned bytes on stores for the-   -- Sparc opcodes (at least I cannot see any, and gas is nagging me --SOF),-   -- so we call a special-purpose pprFormat for ST..-   ST format reg addr-        -> hcat [-               text "\tst",-               pprStFormat format,-               char '\t',-               pprReg reg,-               pp_comma_lbracket,-               pprAddr platform addr,-               rbrack-            ]---   ADD x cc reg1 ri reg2-        | not x && not cc && riZero ri-        -> hcat [ text "\tmov\t", pprReg reg1, comma, pprReg reg2 ]--        | otherwise-        -> pprRegRIReg platform (if x then sLit "addx" else sLit "add") cc reg1 ri reg2---   SUB x cc reg1 ri reg2-        | not x && cc && reg2 == g0-        -> hcat [ text "\tcmp\t", pprReg reg1, comma, pprRI platform ri ]--        | not x && not cc && riZero ri-        -> hcat [ text "\tmov\t", pprReg reg1, comma, pprReg reg2 ]--        | otherwise-        -> pprRegRIReg platform (if x then sLit "subx" else sLit "sub") cc reg1 ri reg2--   AND  b reg1 ri reg2 -> pprRegRIReg platform (sLit "and")  b reg1 ri reg2--   ANDN b reg1 ri reg2 -> pprRegRIReg platform (sLit "andn") b reg1 ri reg2--   OR b reg1 ri reg2-        | not b && reg1 == g0-        -> let doit = hcat [ text "\tmov\t", pprRI platform ri, comma, pprReg reg2 ]-           in  case ri of-                   RIReg rrr | rrr == reg2 -> empty-                   _                       -> doit--        | otherwise-        -> pprRegRIReg platform (sLit "or") b reg1 ri reg2--   ORN b reg1 ri reg2 -> pprRegRIReg platform (sLit "orn") b reg1 ri reg2--   XOR  b reg1 ri reg2 -> pprRegRIReg platform (sLit "xor")  b reg1 ri reg2-   XNOR b reg1 ri reg2 -> pprRegRIReg platform (sLit "xnor") b reg1 ri reg2--   SLL reg1 ri reg2 -> pprRegRIReg platform (sLit "sll") False reg1 ri reg2-   SRL reg1 ri reg2 -> pprRegRIReg platform (sLit "srl") False reg1 ri reg2-   SRA reg1 ri reg2 -> pprRegRIReg platform (sLit "sra") False reg1 ri reg2--   RDY rd -> text "\trd\t%y," <> pprReg rd-   WRY reg1 reg2-        -> text "\twr\t"-                <> pprReg reg1-                <> char ','-                <> pprReg reg2-                <> char ','-                <> text "%y"--   SMUL b reg1 ri reg2 -> pprRegRIReg platform (sLit "smul")  b reg1 ri reg2-   UMUL b reg1 ri reg2 -> pprRegRIReg platform (sLit "umul")  b reg1 ri reg2-   SDIV b reg1 ri reg2 -> pprRegRIReg platform (sLit "sdiv")  b reg1 ri reg2-   UDIV b reg1 ri reg2 -> pprRegRIReg platform (sLit "udiv")  b reg1 ri reg2--   SETHI imm reg-      -> hcat [-            text "\tsethi\t",-            pprImm platform imm,-            comma,-            pprReg reg-         ]--   NOP -> text "\tnop"--   FABS format reg1 reg2-        -> pprFormatRegReg (sLit "fabs") format reg1 reg2--   FADD format reg1 reg2 reg3-        -> pprFormatRegRegReg (sLit "fadd") format reg1 reg2 reg3--   FCMP e format reg1 reg2-        -> pprFormatRegReg (if e then sLit "fcmpe" else sLit "fcmp")-                           format reg1 reg2--   FDIV format reg1 reg2 reg3-        -> pprFormatRegRegReg (sLit "fdiv") format reg1 reg2 reg3--   FMOV format reg1 reg2-        -> pprFormatRegReg (sLit "fmov") format reg1 reg2--   FMUL format reg1 reg2 reg3-        -> pprFormatRegRegReg (sLit "fmul") format reg1 reg2 reg3--   FNEG format reg1 reg2-        -> pprFormatRegReg (sLit "fneg") format reg1 reg2--   FSQRT format reg1 reg2-        -> pprFormatRegReg (sLit "fsqrt") format reg1 reg2--   FSUB format reg1 reg2 reg3-        -> pprFormatRegRegReg (sLit "fsub") format reg1 reg2 reg3--   FxTOy format1 format2 reg1 reg2-      -> hcat [-            text "\tf",-            ptext-            (case format1 of-                II32  -> sLit "ito"-                FF32  -> sLit "sto"-                FF64  -> sLit "dto"-                _     -> panic "SPARC.Ppr.pprInstr.FxToY: no match"),-            ptext-            (case format2 of-                II32  -> sLit "i\t"-                II64  -> sLit "x\t"-                FF32  -> sLit "s\t"-                FF64  -> sLit "d\t"-                _     -> panic "SPARC.Ppr.pprInstr.FxToY: no match"),-            pprReg reg1, comma, pprReg reg2-         ]---   BI cond b blockid-      -> hcat [-            text "\tb", pprCond cond,-            if b then pp_comma_a else empty,-            char '\t',-            pdoc platform (blockLbl blockid)-         ]--   BF cond b blockid-      -> hcat [-            text "\tfb", pprCond cond,-            if b then pp_comma_a else empty,-            char '\t',-            pdoc platform (blockLbl blockid)-         ]--   JMP addr -> text "\tjmp\t" <> pprAddr platform addr-   JMP_TBL op _ _ -> pprInstr platform (JMP op)--   CALL (Left imm) n _-      -> hcat [ text "\tcall\t", pprImm platform imm, comma, int n ]--   CALL (Right reg) n _-      -> hcat [ text "\tcall\t", pprReg reg, comma, int n ]----- | Pretty print a RI-pprRI :: Platform -> RI -> SDoc-pprRI platform = \case-   RIReg r -> pprReg r-   RIImm r -> pprImm platform r----- | Pretty print a two reg instruction.-pprFormatRegReg :: PtrString -> Format -> Reg -> Reg -> SDoc-pprFormatRegReg name format reg1 reg2-  = hcat [-        char '\t',-        ptext name,-        (case format of-            FF32 -> text "s\t"-            FF64 -> text "d\t"-            _    -> panic "SPARC.Ppr.pprFormatRegReg: no match"),--        pprReg reg1,-        comma,-        pprReg reg2-    ]----- | Pretty print a three reg instruction.-pprFormatRegRegReg :: PtrString -> Format -> Reg -> Reg -> Reg -> SDoc-pprFormatRegRegReg name format reg1 reg2 reg3-  = hcat [-        char '\t',-        ptext name,-        (case format of-            FF32  -> text "s\t"-            FF64  -> text "d\t"-            _    -> panic "SPARC.Ppr.pprFormatRegReg: no match"),-        pprReg reg1,-        comma,-        pprReg reg2,-        comma,-        pprReg reg3-    ]----- | Pretty print an instruction of two regs and a ri.-pprRegRIReg :: Platform -> PtrString -> Bool -> Reg -> RI -> Reg -> SDoc-pprRegRIReg platform name b reg1 ri reg2-  = hcat [-        char '\t',-        ptext name,-        if b then text "cc\t" else char '\t',-        pprReg reg1,-        comma,-        pprRI platform ri,-        comma,-        pprReg reg2-    ]--{--pprRIReg :: PtrString -> Bool -> RI -> Reg -> SDoc-pprRIReg name b ri reg1-  = hcat [-        char '\t',-        ptext name,-        if b then text "cc\t" else char '\t',-        pprRI ri,-        comma,-        pprReg reg1-    ]--}--{--pp_ld_lbracket :: SDoc-pp_ld_lbracket    = text "\tld\t["--}--pp_rbracket_comma :: SDoc-pp_rbracket_comma = text "],"---pp_comma_lbracket :: SDoc-pp_comma_lbracket = text ",["---pp_comma_a :: SDoc-pp_comma_a        = text ",a"
− GHC/CmmToAsm/SPARC/Regs.hs 
@@ -1,260 +0,0 @@--- ----------------------------------------------------------------------------------- (c) The University of Glasgow 1994-2004------ -------------------------------------------------------------------------------module GHC.CmmToAsm.SPARC.Regs (-        -- registers-        showReg,-        virtualRegSqueeze,-        realRegSqueeze,-        classOfRealReg,-        allRealRegs,--        -- machine specific info-        gReg, iReg, lReg, oReg, fReg,-        fp, sp, g0, g1, g2, o0, o1, f0, f1, f6, f8, f22, f26, f27,--        -- allocatable-        allocatableRegs,--        -- args-        argRegs,-        allArgRegs,-        callClobberedRegs,--        ---        mkVirtualReg,-        regDotColor-)--where---import GHC.Prelude--import GHC.Platform.SPARC-import GHC.Platform.Reg-import GHC.Platform.Reg.Class-import GHC.CmmToAsm.Format--import GHC.Types.Unique-import GHC.Utils.Outputable-import GHC.Utils.Panic--{--        The SPARC has 64 registers of interest; 32 integer registers and 32-        floating point registers.  The mapping of STG registers to SPARC-        machine registers is defined in StgRegs.h.  We are, of course,-        prepared for any eventuality.--        The whole fp-register pairing thing on sparcs is a huge nuisance.  See-        includes/stg/MachRegs.h for a description of what's going on-        here.--}----- | Get the standard name for the register with this number.-showReg :: RegNo -> String-showReg n-        | n >= 0  && n < 8   = "%g" ++ show n-        | n >= 8  && n < 16  = "%o" ++ show (n-8)-        | n >= 16 && n < 24  = "%l" ++ show (n-16)-        | n >= 24 && n < 32  = "%i" ++ show (n-24)-        | n >= 32 && n < 64  = "%f" ++ show (n-32)-        | otherwise          = panic "SPARC.Regs.showReg: unknown sparc register"----- Get the register class of a certain real reg-classOfRealReg :: RealReg -> RegClass-classOfRealReg reg- = case reg of-        RealRegSingle i-                | i < 32        -> RcInteger-                | otherwise     -> RcFloat--        RealRegPair{}           -> RcDouble----- | regSqueeze_class reg---      Calculate the maximum number of register colors that could be---      denied to a node of this class due to having this reg---      as a neighbour.----{-# INLINE virtualRegSqueeze #-}-virtualRegSqueeze :: RegClass -> VirtualReg -> Int--virtualRegSqueeze cls vr- = case cls of-        RcInteger-         -> case vr of-                VirtualRegI{}           -> 1-                VirtualRegHi{}          -> 1-                _other                  -> 0--        RcFloat-         -> case vr of-                VirtualRegF{}           -> 1-                VirtualRegD{}           -> 2-                _other                  -> 0--        RcDouble-         -> case vr of-                VirtualRegF{}           -> 1-                VirtualRegD{}           -> 1-                _other                  -> 0---{-# INLINE realRegSqueeze #-}-realRegSqueeze :: RegClass -> RealReg -> Int--realRegSqueeze cls rr- = case cls of-        RcInteger-         -> case rr of-                RealRegSingle regNo-                        | regNo < 32    -> 1-                        | otherwise     -> 0--                RealRegPair{}           -> 0--        RcFloat-         -> case rr of-                RealRegSingle regNo-                        | regNo < 32    -> 0-                        | otherwise     -> 1--                RealRegPair{}           -> 2--        RcDouble-         -> case rr of-                RealRegSingle regNo-                        | regNo < 32    -> 0-                        | otherwise     -> 1--                RealRegPair{}           -> 1----- | All the allocatable registers in the machine,---      including register pairs.-allRealRegs :: [RealReg]-allRealRegs-        =  [ (RealRegSingle i)          | i <- [0..63] ]-        ++ [ (RealRegPair   i (i+1))    | i <- [32, 34 .. 62 ] ]----- | Get the regno for this sort of reg-gReg, lReg, iReg, oReg, fReg :: Int -> RegNo--gReg x  = x             -- global regs-oReg x  = (8 + x)       -- output regs-lReg x  = (16 + x)      -- local regs-iReg x  = (24 + x)      -- input regs-fReg x  = (32 + x)      -- float regs----- | Some specific regs used by the code generator.-g0, g1, g2, fp, sp, o0, o1, f0, f1, f6, f8, f22, f26, f27 :: Reg--f6  = RegReal (RealRegSingle (fReg 6))-f8  = RegReal (RealRegSingle (fReg 8))-f22 = RegReal (RealRegSingle (fReg 22))-f26 = RegReal (RealRegSingle (fReg 26))-f27 = RegReal (RealRegSingle (fReg 27))---- g0 is always zero, and writes to it vanish.-g0  = RegReal (RealRegSingle (gReg 0))-g1  = RegReal (RealRegSingle (gReg 1))-g2  = RegReal (RealRegSingle (gReg 2))---- FP, SP, int and float return (from C) regs.-fp  = RegReal (RealRegSingle (iReg 6))-sp  = RegReal (RealRegSingle (oReg 6))-o0  = RegReal (RealRegSingle (oReg 0))-o1  = RegReal (RealRegSingle (oReg 1))-f0  = RegReal (RealRegSingle (fReg 0))-f1  = RegReal (RealRegSingle (fReg 1))---- | Produce the second-half-of-a-double register given the first half.-{--fPair :: Reg -> Maybe Reg-fPair (RealReg n)-        | n >= 32 && n `mod` 2 == 0  = Just (RealReg (n+1))--fPair (VirtualRegD u)-        = Just (VirtualRegHi u)--fPair reg-        = trace ("MachInstrs.fPair: can't get high half of supposed double reg " ++ showPpr reg)-                Nothing--}----- | All the regs that the register allocator can allocate to,---      with the fixed use regs removed.----allocatableRegs :: [RealReg]-allocatableRegs-   = let isFree rr-           = case rr of-                RealRegSingle r     -> freeReg r-                RealRegPair   r1 r2 -> freeReg r1 && freeReg r2-     in filter isFree allRealRegs----- | The registers to place arguments for function calls,---      for some number of arguments.----argRegs :: RegNo -> [Reg]-argRegs r- = case r of-        0       -> []-        1       -> map (RegReal . RealRegSingle . oReg) [0]-        2       -> map (RegReal . RealRegSingle . oReg) [0,1]-        3       -> map (RegReal . RealRegSingle . oReg) [0,1,2]-        4       -> map (RegReal . RealRegSingle . oReg) [0,1,2,3]-        5       -> map (RegReal . RealRegSingle . oReg) [0,1,2,3,4]-        6       -> map (RegReal . RealRegSingle . oReg) [0,1,2,3,4,5]-        _       -> panic "MachRegs.argRegs(sparc): don't know about >6 arguments!"----- | All the regs that could possibly be returned by argRegs----allArgRegs :: [Reg]-allArgRegs-        = map (RegReal . RealRegSingle) [oReg i | i <- [0..5]]----- These are the regs that we cannot assume stay alive over a C call.---      TODO: Why can we assume that o6 isn't clobbered? -- BL 2009/02----callClobberedRegs :: [Reg]-callClobberedRegs-        = map (RegReal . RealRegSingle)-                (  oReg 7 :-                  [oReg i | i <- [0..5]] ++-                  [gReg i | i <- [1..7]] ++-                  [fReg i | i <- [0..31]] )------ | Make a virtual reg with this format.-mkVirtualReg :: Unique -> Format -> VirtualReg-mkVirtualReg u format-        | not (isFloatFormat format)-        = VirtualRegI u--        | otherwise-        = case format of-                FF32    -> VirtualRegF u-                FF64    -> VirtualRegD u-                _       -> panic "mkVReg"---regDotColor :: RealReg -> SDoc-regDotColor reg- = case classOfRealReg reg of-        RcInteger       -> text "blue"-        RcFloat         -> text "red"-        _other          -> text "green"
− GHC/CmmToAsm/SPARC/ShortcutJump.hs 
@@ -1,74 +0,0 @@-module GHC.CmmToAsm.SPARC.ShortcutJump (-        JumpDest(..), getJumpDestBlockId,-        canShortcut,-        shortcutJump,-        shortcutStatics,-        shortBlockId-)--where--import GHC.Prelude--import GHC.CmmToAsm.SPARC.Instr-import GHC.CmmToAsm.SPARC.Imm--import GHC.Cmm.CLabel-import GHC.Cmm.BlockId-import GHC.Cmm--import GHC.Utils.Panic-import GHC.Utils.Outputable--data JumpDest-        = DestBlockId BlockId-        | DestImm Imm---- Debug Instance-instance Outputable JumpDest where-  ppr (DestBlockId bid) = text "blk:" <> ppr bid-  ppr (DestImm _bid)    = text "imm:?"--getJumpDestBlockId :: JumpDest -> Maybe BlockId-getJumpDestBlockId (DestBlockId bid) = Just bid-getJumpDestBlockId _                 = Nothing---canShortcut :: Instr -> Maybe JumpDest-canShortcut _ = Nothing---shortcutJump :: (BlockId -> Maybe JumpDest) -> Instr -> Instr-shortcutJump _ other = other----shortcutStatics :: (BlockId -> Maybe JumpDest) -> 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 -> blockLbl blockid-      Just (DestBlockId blockid')  -> shortBlockId fn blockid'-      Just (DestImm (ImmCLbl lbl)) -> lbl-      _other -> panic "shortBlockId"
− GHC/CmmToAsm/SPARC/Stack.hs 
@@ -1,60 +0,0 @@-module GHC.CmmToAsm.SPARC.Stack (-        spRel,-        fpRel,-        spillSlotToOffset,-        maxSpillSlots-)--where--import GHC.Prelude--import GHC.CmmToAsm.SPARC.AddrMode-import GHC.CmmToAsm.SPARC.Regs-import GHC.CmmToAsm.SPARC.Base-import GHC.CmmToAsm.SPARC.Imm-import GHC.CmmToAsm.Config--import GHC.Utils.Outputable-import GHC.Utils.Panic---- | Get an AddrMode relative to the address in sp.---      This gives us a stack relative addressing mode for volatile---      temporaries and for excess call arguments.----spRel :: Int            -- ^ stack offset in words, positive or negative-      -> AddrMode--spRel n = AddrRegImm sp (ImmInt (n * wordLength))----- | Get an address relative to the frame pointer.---      This doesn't work work for offsets greater than 13 bits; we just hope for the best----fpRel :: Int -> AddrMode-fpRel n-        = AddrRegImm fp (ImmInt (n * wordLength))----- | Convert a spill slot number to a *byte* offset, with no sign.----spillSlotToOffset :: NCGConfig -> Int -> Int-spillSlotToOffset config slot-        | slot >= 0 && slot < maxSpillSlots config-        = 64 + spillSlotSize * slot--        | otherwise-        = pprPanic "spillSlotToOffset:"-                      (   text "invalid spill location: " <> int slot-                      $$  text "maxSpillSlots:          " <> int (maxSpillSlots config))----- | The maximum number of spill slots available on the C stack.---      If we use up all of the slots, then we're screwed.------      Why do we reserve 64 bytes, instead of using the whole thing??---              -- BL 2009/02/15----maxSpillSlots :: NCGConfig -> Int-maxSpillSlots config-        = ((ncgSpillPreallocSize config - 64) `div` spillSlotSize) - 1
GHC/CmmToAsm/X86.hs view
@@ -37,7 +37,6 @@    , maxSpillSlots             = X86.maxSpillSlots config    , allocatableRegs           = X86.allocatableRegs platform    , ncgAllocMoreStack         = X86.allocMoreStack platform-   , ncgExpandTop              = id    , ncgMakeFarBranches        = const id    , extractUnwindPoints       = X86.extractUnwindPoints    , invertCondBranches        = X86.invertCondBranches@@ -62,4 +61,4 @@    mkStackAllocInstr       = X86.mkStackAllocInstr    mkStackDeallocInstr     = X86.mkStackDeallocInstr    pprInstr                = X86.pprInstr-   mkComment               = const []+   mkComment               = pure . X86.COMMENT
GHC/CmmToAsm/X86/CodeGen.hs view
@@ -1,3977 +1,4395 @@ {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE NondecreasingIndentation #-}-{-# LANGUAGE TupleSections #-}--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}------------------------------------------------------------------------------------- Generating machine code (instruction selection)------ (c) The University of Glasgow 1996-2004------------------------------------------------------------------------------------- This is a big module, but, if you pay attention to--- (a) the sectioning, and (b) the type signatures, the--- structure should not be too overwhelming.--module GHC.CmmToAsm.X86.CodeGen (-        cmmTopCodeGen,-        generateJumpTableForInstr,-        extractUnwindPoints,-        invertCondBranches,-        InstrBlock-)--where--#include "HsVersions.h"---- 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, getNewRegPairNat-   , getPicBaseMaybeNat, getDebugBlock, getFileId-   , addImmediateSuccessorNat, updateCfgNat, getConfig, getPlatform-   , getCfgWeights-   )-import GHC.CmmToAsm.CFG-import GHC.CmmToAsm.Format-import GHC.CmmToAsm.Config-import GHC.Platform.Reg-import GHC.Platform---- Our intermediate code:-import GHC.Types.Basic-import GHC.Cmm.BlockId-import GHC.Unit.Types ( primUnitId )-import GHC.Cmm.Utils-import GHC.Cmm.Switch-import GHC.Cmm-import GHC.Cmm.Dataflow.Block-import GHC.Cmm.Dataflow.Collections-import GHC.Cmm.Dataflow.Graph-import GHC.Cmm.Dataflow.Label-import GHC.Cmm.CLabel-import GHC.Types.Tickish ( GenTickish(..) )-import GHC.Types.SrcLoc  ( srcSpanFile, srcSpanStartLine, srcSpanStartCol )---- The rest:-import GHC.Types.ForeignCall ( CCallConv(..) )-import GHC.Data.OrdList-import GHC.Utils.Outputable-import GHC.Utils.Panic-import GHC.Data.FastString-import GHC.Driver.Session-import GHC.Utils.Misc-import GHC.Types.Unique.Supply ( getUniqueM )--import Control.Monad-import Data.Foldable (fold)-import Data.Int-import Data.Maybe-import Data.Word--import qualified Data.Map as M--is32BitPlatform :: NatM Bool-is32BitPlatform = do-    platform <- getPlatform-    return $ target32Bit platform--sse2Enabled :: NatM Bool-sse2Enabled = do-  config <- getConfig-  return (ncgSseVersion config >= Just SSE2)--sse4_2Enabled :: NatM Bool-sse4_2Enabled = do-  config <- getConfig-  return (ncgSseVersion config >= Just SSE42)--cmmTopCodeGen-        :: RawCmmDecl-        -> NatM [NatCmmDecl (Alignment, RawCmmStatics) Instr]--cmmTopCodeGen (CmmProc info lab live graph) = do-  let blocks = toBlockListEntryFirst graph-  (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks-  picBaseMb <- getPicBaseMaybeNat-  platform <- getPlatform-  let proc = CmmProc info lab live (ListGraph $ concat nat_blocks)-      tops = proc : concat statics-      os   = platformOS platform--  case picBaseMb of-      Just picBase -> initializePicBase_x86 ArchX86 os picBase tops-      Nothing -> return tops--cmmTopCodeGen (CmmData sec dat) =-  return [CmmData sec (mkAlignment 1, dat)]  -- no translation, we just use CmmStatic--{- Note [Verifying basic blocks]-   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--   We want to guarantee a few things about the results-   of instruction selection.--   Namely that each basic blocks consists of:-    * A (potentially empty) sequence of straight line instructions-  followed by-    * A (potentially empty) sequence of jump like instructions.--    We can verify this by going through the instructions and-    making sure that any non-jumpish instruction can't appear-    after a jumpish instruction.--    There are gotchas however:-    * CALLs are strictly speaking control flow but here we care-      not about them. Hence we treat them as regular instructions.--      It's safe for them to appear inside a basic block-      as (ignoring side effects inside the call) they will result in-      straight line code.--    * NEWBLOCK marks the start of a new basic block so can-      be followed by any instructions.--}---- Verifying basic blocks is cheap, but not cheap enough to enable it unconditionally.-verifyBasicBlock :: Platform -> [Instr] -> ()-verifyBasicBlock platform instrs-  | debugIsOn     = go False instrs-  | otherwise     = ()-  where-    go _     [] = ()-    go atEnd (i:instr)-        = case i of-            -- Start a new basic block-            NEWBLOCK {} -> go False instr-            -- Calls are not viable block terminators-            CALL {}     | atEnd -> faultyBlockWith i-                        | not atEnd -> go atEnd instr-            -- All instructions ok, check if we reached the end and continue.-            _ | not atEnd -> go (isJumpishInstr i) instr-              -- Only jumps allowed at the end of basic blocks.-              | otherwise -> if isJumpishInstr i-                                then go True instr-                                else faultyBlockWith i-    faultyBlockWith i-        = pprPanic "Non control flow instructions after end of basic block."-                   (pprInstr platform i <+> text "in:" $$ vcat (map (pprInstr platform) instrs))--basicBlockCodeGen-        :: CmmBlock-        -> NatM ( [NatBasicBlock Instr]-                , [NatCmmDecl (Alignment, RawCmmStatics) Instr])--basicBlockCodeGen block = do-  let (_, nodes, tail)  = blockSplit block-      id = entryLabel block-      stmts = blockToList nodes-  -- Generate location directive-  dbg <- getDebugBlock (entryLabel block)-  loc_instrs <- case dblSourceTick =<< dbg of-    Just (SourceNote span name)-      -> do fileId <- getFileId (srcSpanFile span)-            let line = srcSpanStartLine span; col = srcSpanStartCol span-            return $ unitOL $ LOCATION fileId line col name-    _ -> return nilOL-  (mid_instrs,mid_bid) <- stmtsToInstrs id stmts-  (!tail_instrs,_) <- stmtToInstrs mid_bid tail-  let instrs = loc_instrs `appOL` mid_instrs `appOL` tail_instrs-  platform <- getPlatform-  return $! verifyBasicBlock platform (fromOL instrs)-  instrs' <- fold <$> traverse addSpUnwindings instrs-  -- code generation may introduce new basic block boundaries, which-  -- are indicated by the NEWBLOCK instruction.  We must split up the-  -- instruction stream into basic blocks again.  Also, we extract-  -- LDATAs here too.-  let-        (top,other_blocks,statics) = foldrOL mkBlocks ([],[],[]) instrs'--        mkBlocks (NEWBLOCK id) (instrs,blocks,statics)-          = ([], BasicBlock id instrs : blocks, statics)-        mkBlocks (LDATA sec dat) (instrs,blocks,statics)-          = (instrs, blocks, CmmData sec dat:statics)-        mkBlocks instr (instrs,blocks,statics)-          = (instr:instrs, blocks, statics)-  return (BasicBlock id top : other_blocks, statics)---- | Convert 'DELTA' instructions into 'UNWIND' instructions to capture changes--- in the @sp@ register. See Note [What is this unwinding business?] in "GHC.Cmm.DebugBlock"--- for details.-addSpUnwindings :: Instr -> NatM (OrdList Instr)-addSpUnwindings instr@(DELTA d) = do-    config <- getConfig-    if ncgDwarfUnwindings config-        then do lbl <- mkAsmTempLabel <$> getUniqueM-                let unwind = M.singleton MachSp (Just $ UwReg MachSp $ negate d)-                return $ toOL [ instr, UNWIND lbl unwind ]-        else return (unitOL instr)-addSpUnwindings instr = return $ unitOL instr--{- Note [Keeping track of the current block]-   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--When generating instructions for Cmm we sometimes require-the current block for things like retry loops.--We also sometimes change the current block, if a MachOP-results in branching control flow.--Issues arise if we have two statements in the same block,-which both depend on the current block id *and* change the-basic block after them. This happens for atomic primops-in the X86 backend where we want to update the CFG data structure-when introducing new basic blocks.--For example in #17334 we got this Cmm code:--        c3Bf: // global-            (_s3t1::I64) = call MO_AtomicRMW W64 AMO_And(_s3sQ::P64 + 88, 18);-            (_s3t4::I64) = call MO_AtomicRMW W64 AMO_Or(_s3sQ::P64 + 88, 0);-            _s3sT::I64 = _s3sV::I64;-            goto c3B1;--This resulted in two new basic blocks being inserted:--        c3Bf:-                movl $18,%vI_n3Bo-                movq 88(%vI_s3sQ),%rax-                jmp _n3Bp-        n3Bp:-                ...-                cmpxchgq %vI_n3Bq,88(%vI_s3sQ)-                jne _n3Bp-                ...-                jmp _n3Bs-        n3Bs:-                ...-                cmpxchgq %vI_n3Bt,88(%vI_s3sQ)-                jne _n3Bs-                ...-                jmp _c3B1-        ...--Based on the Cmm we called stmtToInstrs we translated both atomic operations under-the assumption they would be placed into their Cmm basic block `c3Bf`.-However for the retry loop we introduce new labels, so this is not the case-for the second statement.-This resulted in a desync between the explicit control flow graph-we construct as a separate data type and the actual control flow graph in the code.--Instead we now return the new basic block if a statement causes a change-in the current block and use the block for all following statements.--For this reason genCCall 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-       -> genCCall is32Bit target result_regs args bid--    _ -> (,Nothing) <$> case stmt of-      CmmComment s   -> return (unitOL (COMMENT s))-      CmmTick {}     -> return nilOL--      CmmUnwind regs -> do-        let to_unwind_entry :: (GlobalReg, Maybe CmmExpr) -> UnwindTable-            to_unwind_entry (reg, expr) = M.singleton reg (fmap (toUnwindExpr platform) expr)-        case foldMap to_unwind_entry regs of-          tbl | M.null tbl -> return nilOL-              | otherwise  -> do-                  lbl <- mkAsmTempLabel <$> getUniqueM-                  return $ unitOL $ UNWIND lbl tbl--      CmmAssign reg src-        | isFloatType ty         -> assignReg_FltCode format reg src-        | is32Bit && isWord64 ty -> assignReg_I64Code      reg src-        | otherwise              -> assignReg_IntCode format reg src-          where ty = cmmRegType platform reg-                format = cmmTypeFormat ty--      CmmStore addr src _alignment-        | isFloatType ty         -> assignMem_FltCode format addr src-        | is32Bit && isWord64 ty -> assignMem_I64Code      addr src-        | otherwise              -> assignMem_IntCode format addr src-          where ty = cmmExprType platform src-                format = cmmTypeFormat ty--      CmmBranch id          -> return $ genBranch id--      --We try to arrange blocks such that the likely branch is the fallthrough-      --in GHC.Cmm.ContFlowOpt. So we can assume the condition is likely false here.-      CmmCondBranch arg true false _ -> genCondBranch bid true false arg-      CmmSwitch arg ids -> genSwitch arg ids-      CmmCall { cml_target = arg-              , cml_args_regs = gregs } -> genJump arg (jumpRegs platform gregs)-      _ ->-        panic "stmtToInstrs: statement should have been cps'd away"---jumpRegs :: Platform -> [GlobalReg] -> [Reg]-jumpRegs platform gregs = [ RegReal r | Just r <- map (globalRegMaybe platform) gregs ]------------------------------------------------------------------------------------- | 'InstrBlock's are the insn sequences generated by the insn selectors.---      They are really trees of insns to facilitate fast appending, where a---      left-to-right traversal yields the insns in the correct order.----type InstrBlock-        = OrdList Instr----- | Condition codes passed up the tree.----data CondCode-        = CondCode Bool Cond InstrBlock----- | a.k.a "Register64"---      Reg is the lower 32-bit temporary which contains the result.---      Use getHiVRegFromLo to find the other VRegUnique.------      Rules of this simplified insn selection game are therefore that---      the returned Reg may be modified----data ChildCode64-   = ChildCode64-        InstrBlock-        Reg----- | Register's passed up the tree.  If the stix code forces the register---      to live in a pre-decided machine register, it comes out as @Fixed@;---      otherwise, it comes out as @Any@, and the parent can decide which---      register to put it in.----data Register-        = Fixed Format Reg InstrBlock-        | Any   Format (Reg -> InstrBlock)---swizzleRegisterRep :: Register -> Format -> Register-swizzleRegisterRep (Fixed _ reg code) format = Fixed format reg code-swizzleRegisterRep (Any _ codefn)     format = Any   format codefn----- | Grab the Reg for a CmmReg-getRegisterReg :: Platform  -> CmmReg -> Reg--getRegisterReg _   (CmmLocal (LocalReg u pk))-  = -- by Assuming SSE2, Int,Word,Float,Double all can be register allocated-   let fmt = cmmTypeFormat pk in-        RegVirtual (mkVirtualReg u fmt)--getRegisterReg platform  (CmmGlobal mid)-  = case globalRegMaybe platform mid of-        Just reg -> RegReal $ reg-        Nothing  -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal mid)-        -- By this stage, the only MagicIds remaining should be the-        -- ones which map to a real machine register on this-        -- platform.  Hence ...----- | Memory addressing modes passed up the tree.-data Amode-        = Amode AddrMode InstrBlock--{--Now, given a tree (the argument to a CmmLoad) that references memory,-produce a suitable addressing mode.--A Rule of the Game (tm) for Amodes: use of the addr bit must-immediately follow use of the code part, since the code part puts-values in registers which the addr then refers to.  So you can't put-anything in between, lest it overwrite some of those registers.  If-you need to do some other computation between the code part and use of-the addr bit, first store the effective address from the amode in a-temporary, then do the other computation, and then use the temporary:--    code-    LEA amode, tmp-    ... other computation ...-    ... (tmp) ...--}----- | Check whether an integer will fit in 32 bits.---      A CmmInt is intended to be truncated to the appropriate---      number of bits, so here we truncate it to Int64.  This is---      important because e.g. -1 as a CmmInt might be either---      -1 or 18446744073709551615.----is32BitInteger :: Integer -> Bool-is32BitInteger i = i64 <= 0x7fffffff && i64 >= -0x80000000-  where i64 = fromIntegral i :: Int64----- | Convert a BlockId to some CmmStatic data-jumpTableEntry :: NCGConfig -> Maybe BlockId -> CmmStatic-jumpTableEntry config Nothing = CmmStaticLit (CmmInt 0 (ncgWordWidth config))-jumpTableEntry _ (Just blockid) = CmmStaticLit (CmmLabel blockLabel)-    where blockLabel = blockLbl blockid----- -------------------------------------------------------------------------------- General things for putting together code sequences---- Expand CmmRegOff.  ToDo: should we do it this way around, or convert--- CmmExprs into CmmRegOff?-mangleIndexTree :: Platform -> CmmReg -> Int -> CmmExpr-mangleIndexTree platform reg off-  = CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)]-  where width = typeWidth (cmmRegType platform reg)---- | The dual to getAnyReg: compute an expression into a register, but---      we don't mind which one it is.-getSomeReg :: CmmExpr -> NatM (Reg, InstrBlock)-getSomeReg expr = do-  r <- getRegister expr-  case r of-    Any rep code -> do-        tmp <- getNewRegNat rep-        return (tmp, code tmp)-    Fixed _ reg code ->-        return (reg, code)---assignMem_I64Code :: CmmExpr -> CmmExpr -> NatM InstrBlock-assignMem_I64Code addrTree valueTree = do-  Amode addr addr_code <- getAmode addrTree-  ChildCode64 vcode rlo <- iselExpr64 valueTree-  let-        rhi = getHiVRegFromLo rlo--        -- Little-endian store-        mov_lo = MOV II32 (OpReg rlo) (OpAddr addr)-        mov_hi = MOV II32 (OpReg rhi) (OpAddr (fromJust (addrOffset addr 4)))-  return (vcode `appOL` addr_code `snocOL` mov_lo `snocOL` mov_hi)---assignReg_I64Code :: CmmReg  -> CmmExpr -> NatM InstrBlock-assignReg_I64Code (CmmLocal (LocalReg u_dst _)) valueTree = do-   ChildCode64 vcode r_src_lo <- iselExpr64 valueTree-   let-         r_dst_lo = RegVirtual $ mkVirtualReg u_dst II32-         r_dst_hi = getHiVRegFromLo r_dst_lo-         r_src_hi = getHiVRegFromLo r_src_lo-         mov_lo = MOV II32 (OpReg r_src_lo) (OpReg r_dst_lo)-         mov_hi = MOV II32 (OpReg r_src_hi) (OpReg r_dst_hi)-   return (-        vcode `snocOL` mov_lo `snocOL` mov_hi-     )--assignReg_I64Code _ _-   = panic "assignReg_I64Code(i386): invalid lvalue"---iselExpr64        :: CmmExpr -> NatM ChildCode64-iselExpr64 (CmmLit (CmmInt i _)) = do-  (rlo,rhi) <- getNewRegPairNat II32-  let-        r = fromIntegral (fromIntegral i :: Word32)-        q = fromIntegral (fromIntegral (i `shiftR` 32) :: Word32)-        code = toOL [-                MOV II32 (OpImm (ImmInteger r)) (OpReg rlo),-                MOV II32 (OpImm (ImmInteger q)) (OpReg rhi)-                ]-  return (ChildCode64 code rlo)--iselExpr64 (CmmLoad addrTree ty _) | isWord64 ty = do-   Amode addr addr_code <- getAmode addrTree-   (rlo,rhi) <- getNewRegPairNat II32-   let-        mov_lo = MOV II32 (OpAddr addr) (OpReg rlo)-        mov_hi = MOV II32 (OpAddr (fromJust (addrOffset addr 4))) (OpReg rhi)-   return (-            ChildCode64 (addr_code `snocOL` mov_lo `snocOL` mov_hi)-                        rlo-     )--iselExpr64 (CmmReg (CmmLocal (LocalReg vu ty))) | isWord64 ty-   = return (ChildCode64 nilOL (RegVirtual $ mkVirtualReg vu II32))---- we handle addition, but rather badly-iselExpr64 (CmmMachOp (MO_Add _) [e1, CmmLit (CmmInt i _)]) = do-   ChildCode64 code1 r1lo <- iselExpr64 e1-   (rlo,rhi) <- getNewRegPairNat II32-   let-        r = fromIntegral (fromIntegral i :: Word32)-        q = fromIntegral (fromIntegral (i `shiftR` 32) :: Word32)-        r1hi = getHiVRegFromLo r1lo-        code =  code1 `appOL`-                toOL [ MOV II32 (OpReg r1lo) (OpReg rlo),-                       ADD II32 (OpImm (ImmInteger r)) (OpReg rlo),-                       MOV II32 (OpReg r1hi) (OpReg rhi),-                       ADC II32 (OpImm (ImmInteger q)) (OpReg rhi) ]-   return (ChildCode64 code rlo)--iselExpr64 (CmmMachOp (MO_Add _) [e1,e2]) = do-   ChildCode64 code1 r1lo <- iselExpr64 e1-   ChildCode64 code2 r2lo <- iselExpr64 e2-   (rlo,rhi) <- getNewRegPairNat II32-   let-        r1hi = getHiVRegFromLo r1lo-        r2hi = getHiVRegFromLo r2lo-        code =  code1 `appOL`-                code2 `appOL`-                toOL [ MOV II32 (OpReg r1lo) (OpReg rlo),-                       ADD II32 (OpReg r2lo) (OpReg rlo),-                       MOV II32 (OpReg r1hi) (OpReg rhi),-                       ADC II32 (OpReg r2hi) (OpReg rhi) ]-   return (ChildCode64 code rlo)--iselExpr64 (CmmMachOp (MO_Sub _) [e1,e2]) = do-   ChildCode64 code1 r1lo <- iselExpr64 e1-   ChildCode64 code2 r2lo <- iselExpr64 e2-   (rlo,rhi) <- getNewRegPairNat II32-   let-        r1hi = getHiVRegFromLo r1lo-        r2hi = getHiVRegFromLo r2lo-        code =  code1 `appOL`-                code2 `appOL`-                toOL [ MOV II32 (OpReg r1lo) (OpReg rlo),-                       SUB II32 (OpReg r2lo) (OpReg rlo),-                       MOV II32 (OpReg r1hi) (OpReg rhi),-                       SBB II32 (OpReg r2hi) (OpReg rhi) ]-   return (ChildCode64 code rlo)--iselExpr64 (CmmMachOp (MO_UU_Conv _ W64) [expr]) = do-     fn <- getAnyReg expr-     r_dst_lo <-  getNewRegNat II32-     let r_dst_hi = getHiVRegFromLo r_dst_lo-         code = fn r_dst_lo-     return (-             ChildCode64 (code `snocOL`-                          MOV II32 (OpImm (ImmInt 0)) (OpReg r_dst_hi))-                          r_dst_lo-            )--iselExpr64 (CmmMachOp (MO_SS_Conv W32 W64) [expr]) = do-     fn <- getAnyReg expr-     r_dst_lo <-  getNewRegNat II32-     let r_dst_hi = getHiVRegFromLo r_dst_lo-         code = fn r_dst_lo-     return (-             ChildCode64 (code `snocOL`-                          MOV II32 (OpReg r_dst_lo) (OpReg eax) `snocOL`-                          CLTD II32 `snocOL`-                          MOV II32 (OpReg eax) (OpReg r_dst_lo) `snocOL`-                          MOV II32 (OpReg edx) (OpReg r_dst_hi))-                          r_dst_lo-            )--iselExpr64 expr-   = do-      platform <- getPlatform-      pprPanic "iselExpr64(i386)" (pdoc platform expr)------------------------------------------------------------------------------------getRegister :: CmmExpr -> NatM Register-getRegister e = do platform <- getPlatform-                   is32Bit <- is32BitPlatform-                   getRegister' platform is32Bit e--getRegister' :: Platform -> Bool -> CmmExpr -> NatM Register--getRegister' platform is32Bit (CmmReg reg)-  = case reg of-        CmmGlobal PicBaseReg-         | is32Bit ->-            -- on x86_64, we have %rip for PicBaseReg, but it's not-            -- a full-featured register, it can only be used for-            -- rip-relative addressing.-            do reg' <- getPicBaseNat (archWordFormat is32Bit)-               return (Fixed (archWordFormat is32Bit) reg' nilOL)-        _ ->-            do-               let-                 fmt = cmmTypeFormat (cmmRegType platform reg)-                 format  = fmt-               ---               platform <- ncgPlatform <$> getConfig-               return (Fixed format-                             (getRegisterReg platform reg)-                             nilOL)---getRegister' platform is32Bit (CmmRegOff r n)-  = getRegister' platform is32Bit $ mangleIndexTree platform r n--getRegister' platform is32Bit (CmmMachOp (MO_AlignmentCheck align _) [e])-  = addAlignmentCheck align <$> getRegister' platform is32Bit e---- for 32-bit architectures, support some 64 -> 32 bit conversions:--- TO_W_(x), TO_W_(x >> 32)--getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W64 W32)-                     [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]])- | is32Bit = do-  ChildCode64 code rlo <- iselExpr64 x-  return $ Fixed II32 (getHiVRegFromLo rlo) code--getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W64 W32)-                     [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]])- | is32Bit = do-  ChildCode64 code rlo <- iselExpr64 x-  return $ Fixed II32 (getHiVRegFromLo rlo) code--getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W64 W32) [x])- | is32Bit = do-  ChildCode64 code rlo <- iselExpr64 x-  return $ Fixed II32 rlo code--getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W64 W32) [x])- | is32Bit = do-  ChildCode64 code rlo <- iselExpr64 x-  return $ Fixed II32 rlo code--getRegister' _ _ (CmmLit lit@(CmmFloat f w)) =-  float_const_sse2  where-  float_const_sse2-    | f == 0.0 = do-      let-          format = floatFormat w-          code dst = unitOL  (XOR format (OpReg dst) (OpReg dst))-        -- I don't know why there are xorpd, xorps, and pxor instructions.-        -- They all appear to do the same thing --SDM-      return (Any format code)--   | otherwise = do-      Amode addr code <- memConstant (mkAlignment $ widthInBytes w) lit-      loadFloatAmode w addr code---- catch simple cases of zero- or sign-extended load-getRegister' _ _ (CmmMachOp (MO_UU_Conv W8 W32) [CmmLoad addr _ _]) = do-  code <- intLoadCode (MOVZxL II8) addr-  return (Any II32 code)--getRegister' _ _ (CmmMachOp (MO_SS_Conv W8 W32) [CmmLoad addr _ _]) = do-  code <- intLoadCode (MOVSxL II8) addr-  return (Any II32 code)--getRegister' _ _ (CmmMachOp (MO_UU_Conv W16 W32) [CmmLoad addr _ _]) = do-  code <- intLoadCode (MOVZxL II16) addr-  return (Any II32 code)--getRegister' _ _ (CmmMachOp (MO_SS_Conv W16 W32) [CmmLoad addr _ _]) = do-  code <- intLoadCode (MOVSxL II16) addr-  return (Any II32 code)---- catch simple cases of zero- or sign-extended load-getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W8 W64) [CmmLoad addr _ _])- | not is32Bit = do-  code <- intLoadCode (MOVZxL II8) addr-  return (Any II64 code)--getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W8 W64) [CmmLoad addr _ _])- | not is32Bit = do-  code <- intLoadCode (MOVSxL II8) addr-  return (Any II64 code)--getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W16 W64) [CmmLoad addr _ _])- | not is32Bit = do-  code <- intLoadCode (MOVZxL II16) addr-  return (Any II64 code)--getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W16 W64) [CmmLoad addr _ _])- | not is32Bit = do-  code <- intLoadCode (MOVSxL II16) addr-  return (Any II64 code)--getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W32 W64) [CmmLoad addr _ _])- | not is32Bit = do-  code <- intLoadCode (MOV II32) addr -- 32-bit loads zero-extend-  return (Any II64 code)--getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W32 W64) [CmmLoad addr _ _])- | not is32Bit = do-  code <- intLoadCode (MOVSxL II32) addr-  return (Any II64 code)--getRegister' _ is32Bit (CmmMachOp (MO_Add W64) [CmmReg (CmmGlobal PicBaseReg),-                                     CmmLit displacement])- | not is32Bit =-      return $ Any II64 (\dst -> unitOL $-        LEA II64 (OpAddr (ripRel (litToImm displacement))) (OpReg dst))--getRegister' platform is32Bit (CmmMachOp mop [x]) = -- unary MachOps-    case mop of-      MO_F_Neg w  -> sse2NegCode w x---      MO_S_Neg w -> triv_ucode NEGI (intFormat w)-      MO_Not w   -> triv_ucode NOT  (intFormat w)--      -- Nop conversions-      MO_UU_Conv W32 W8  -> toI8Reg  W32 x-      MO_SS_Conv W32 W8  -> toI8Reg  W32 x-      MO_XX_Conv W32 W8  -> toI8Reg  W32 x-      MO_UU_Conv W16 W8  -> toI8Reg  W16 x-      MO_SS_Conv W16 W8  -> toI8Reg  W16 x-      MO_XX_Conv W16 W8  -> toI8Reg  W16 x-      MO_UU_Conv W32 W16 -> toI16Reg W32 x-      MO_SS_Conv W32 W16 -> toI16Reg W32 x-      MO_XX_Conv W32 W16 -> toI16Reg W32 x--      MO_UU_Conv W64 W32 | not is32Bit -> conversionNop II64 x-      MO_SS_Conv W64 W32 | not is32Bit -> conversionNop II64 x-      MO_XX_Conv W64 W32 | not is32Bit -> conversionNop II64 x-      MO_UU_Conv W64 W16 | not is32Bit -> toI16Reg W64 x-      MO_SS_Conv W64 W16 | not is32Bit -> toI16Reg W64 x-      MO_XX_Conv W64 W16 | not is32Bit -> toI16Reg W64 x-      MO_UU_Conv W64 W8  | not is32Bit -> toI8Reg  W64 x-      MO_SS_Conv W64 W8  | not is32Bit -> toI8Reg  W64 x-      MO_XX_Conv W64 W8  | not is32Bit -> toI8Reg  W64 x--      MO_UU_Conv rep1 rep2 | rep1 == rep2 -> conversionNop (intFormat rep1) x-      MO_SS_Conv rep1 rep2 | rep1 == rep2 -> conversionNop (intFormat rep1) x-      MO_XX_Conv rep1 rep2 | rep1 == rep2 -> conversionNop (intFormat rep1) x--      -- widenings-      MO_UU_Conv W8  W32 -> integerExtend W8  W32 MOVZxL x-      MO_UU_Conv W16 W32 -> integerExtend W16 W32 MOVZxL x-      MO_UU_Conv W8  W16 -> integerExtend W8  W16 MOVZxL x--      MO_SS_Conv W8  W32 -> integerExtend W8  W32 MOVSxL x-      MO_SS_Conv W16 W32 -> integerExtend W16 W32 MOVSxL x-      MO_SS_Conv W8  W16 -> integerExtend W8  W16 MOVSxL x--      -- We don't care about the upper bits for MO_XX_Conv, so MOV is enough. However, on 32-bit we-      -- have 8-bit registers only for a few registers (as opposed to x86-64 where every register-      -- has 8-bit version). So for 32-bit code, we'll just zero-extend.-      MO_XX_Conv W8  W32-          | is32Bit   -> integerExtend W8 W32 MOVZxL x-          | otherwise -> integerExtend W8 W32 MOV x-      MO_XX_Conv W8  W16-          | is32Bit   -> integerExtend W8 W16 MOVZxL x-          | otherwise -> integerExtend W8 W16 MOV x-      MO_XX_Conv W16 W32 -> integerExtend W16 W32 MOV x--      MO_UU_Conv W8  W64 | not is32Bit -> integerExtend W8  W64 MOVZxL x-      MO_UU_Conv W16 W64 | not is32Bit -> integerExtend W16 W64 MOVZxL x-      MO_UU_Conv W32 W64 | not is32Bit -> integerExtend W32 W64 MOVZxL x-      MO_SS_Conv W8  W64 | not is32Bit -> integerExtend W8  W64 MOVSxL x-      MO_SS_Conv W16 W64 | not is32Bit -> integerExtend W16 W64 MOVSxL x-      MO_SS_Conv W32 W64 | not is32Bit -> integerExtend W32 W64 MOVSxL x-      -- For 32-to-64 bit zero extension, amd64 uses an ordinary movl.-      -- However, we don't want the register allocator to throw it-      -- away as an unnecessary reg-to-reg move, so we keep it in-      -- the form of a movzl and print it as a movl later.-      -- This doesn't apply to MO_XX_Conv since in this case we don't care about-      -- the upper bits. So we can just use MOV.-      MO_XX_Conv W8  W64 | not is32Bit -> integerExtend W8  W64 MOV x-      MO_XX_Conv W16 W64 | not is32Bit -> integerExtend W16 W64 MOV x-      MO_XX_Conv W32 W64 | not is32Bit -> integerExtend W32 W64 MOV x--      MO_FF_Conv W32 W64 -> coerceFP2FP W64 x---      MO_FF_Conv W64 W32 -> coerceFP2FP W32 x--      MO_FS_Conv from to -> coerceFP2Int from to x-      MO_SF_Conv from to -> coerceInt2FP from to x--      MO_V_Insert {}   -> needLlvm-      MO_V_Extract {}  -> needLlvm-      MO_V_Add {}      -> needLlvm-      MO_V_Sub {}      -> needLlvm-      MO_V_Mul {}      -> needLlvm-      MO_VS_Quot {}    -> needLlvm-      MO_VS_Rem {}     -> needLlvm-      MO_VS_Neg {}     -> needLlvm-      MO_VU_Quot {}    -> needLlvm-      MO_VU_Rem {}     -> needLlvm-      MO_VF_Insert {}  -> needLlvm-      MO_VF_Extract {} -> needLlvm-      MO_VF_Add {}     -> needLlvm-      MO_VF_Sub {}     -> needLlvm-      MO_VF_Mul {}     -> needLlvm-      MO_VF_Quot {}    -> needLlvm-      MO_VF_Neg {}     -> needLlvm--      _other -> pprPanic "getRegister" (pprMachOp mop)-   where-        triv_ucode :: (Format -> Operand -> Instr) -> Format -> NatM Register-        triv_ucode instr format = trivialUCode format (instr format) x--        -- signed or unsigned extension.-        integerExtend :: Width -> Width-                      -> (Format -> Operand -> Operand -> Instr)-                      -> CmmExpr -> NatM Register-        integerExtend from to instr expr = do-            (reg,e_code) <- if from == W8 then getByteReg expr-                                          else getSomeReg expr-            let-                code dst =-                  e_code `snocOL`-                  instr (intFormat from) (OpReg reg) (OpReg dst)-            return (Any (intFormat to) code)--        toI8Reg :: Width -> CmmExpr -> NatM Register-        toI8Reg new_rep expr-            = do codefn <- getAnyReg expr-                 return (Any (intFormat new_rep) codefn)-                -- HACK: use getAnyReg to get a byte-addressable register.-                -- If the source was a Fixed register, this will add the-                -- mov instruction to put it into the desired destination.-                -- We're assuming that the destination won't be a fixed-                -- non-byte-addressable register; it won't be, because all-                -- fixed registers are word-sized.--        toI16Reg = toI8Reg -- for now--        conversionNop :: Format -> CmmExpr -> NatM Register-        conversionNop new_format expr-            = do e_code <- getRegister' platform is32Bit expr-                 return (swizzleRegisterRep e_code new_format)---getRegister' _ is32Bit (CmmMachOp mop [x, y]) = -- dyadic MachOps-  case mop of-      MO_F_Eq _ -> condFltReg is32Bit EQQ x y-      MO_F_Ne _ -> condFltReg is32Bit NE  x y-      MO_F_Gt _ -> condFltReg is32Bit GTT x y-      MO_F_Ge _ -> condFltReg is32Bit GE  x y-      -- Invert comparison condition and swap operands-      -- See Note [SSE Parity Checks]-      MO_F_Lt _ -> condFltReg is32Bit GTT  y x-      MO_F_Le _ -> condFltReg is32Bit GE   y x--      MO_Eq _   -> condIntReg EQQ x y-      MO_Ne _   -> condIntReg NE  x y--      MO_S_Gt _ -> condIntReg GTT x y-      MO_S_Ge _ -> condIntReg GE  x y-      MO_S_Lt _ -> condIntReg LTT x y-      MO_S_Le _ -> condIntReg LE  x y--      MO_U_Gt _ -> condIntReg GU  x y-      MO_U_Ge _ -> condIntReg GEU x y-      MO_U_Lt _ -> condIntReg LU  x y-      MO_U_Le _ -> condIntReg LEU x y--      MO_F_Add w   -> trivialFCode_sse2 w ADD  x y--      MO_F_Sub w   -> trivialFCode_sse2 w SUB  x y--      MO_F_Quot w  -> trivialFCode_sse2 w FDIV x y--      MO_F_Mul w   -> trivialFCode_sse2 w MUL x y---      MO_Add rep -> add_code rep x y-      MO_Sub rep -> sub_code rep x y--      MO_S_Quot rep -> div_code rep True  True  x y-      MO_S_Rem  rep -> div_code rep True  False x y-      MO_U_Quot rep -> div_code rep False True  x y-      MO_U_Rem  rep -> div_code rep False False x y--      MO_S_MulMayOflo rep -> imulMayOflo rep x y--      MO_Mul W8  -> imulW8 x y-      MO_Mul rep -> triv_op rep IMUL-      MO_And rep -> triv_op rep AND-      MO_Or  rep -> triv_op rep OR-      MO_Xor rep -> triv_op rep XOR--        {- Shift ops on x86s have constraints on their source, it-           either has to be Imm, CL or 1-            => trivialCode is not restrictive enough (sigh.)-        -}-      MO_Shl rep   -> shift_code rep SHL x y {-False-}-      MO_U_Shr rep -> shift_code rep SHR x y {-False-}-      MO_S_Shr rep -> shift_code rep SAR x y {-False-}--      MO_V_Insert {}   -> needLlvm-      MO_V_Extract {}  -> needLlvm-      MO_V_Add {}      -> needLlvm-      MO_V_Sub {}      -> needLlvm-      MO_V_Mul {}      -> needLlvm-      MO_VS_Quot {}    -> needLlvm-      MO_VS_Rem {}     -> needLlvm-      MO_VS_Neg {}     -> needLlvm-      MO_VF_Insert {}  -> needLlvm-      MO_VF_Extract {} -> needLlvm-      MO_VF_Add {}     -> needLlvm-      MO_VF_Sub {}     -> needLlvm-      MO_VF_Mul {}     -> needLlvm-      MO_VF_Quot {}    -> needLlvm-      MO_VF_Neg {}     -> needLlvm--      _other -> pprPanic "getRegister(x86) - binary CmmMachOp (1)" (pprMachOp mop)-  where-    ---------------------    triv_op width instr = trivialCode width op (Just op) x y-                        where op   = instr (intFormat width)--    -- Special case for IMUL for bytes, since the result of IMULB will be in-    -- %ax, the split to %dx/%edx/%rdx and %ax/%eax/%rax happens only for wider-    -- values.-    imulW8 :: CmmExpr -> CmmExpr -> NatM Register-    imulW8 arg_a arg_b = do-        (a_reg, a_code) <- getNonClobberedReg arg_a-        b_code <- getAnyReg arg_b--        let code = a_code `appOL` b_code eax `appOL`-                   toOL [ IMUL2 format (OpReg a_reg) ]-            format = intFormat W8--        return (Fixed format eax code)---    imulMayOflo :: Width -> CmmExpr -> CmmExpr -> NatM Register-    imulMayOflo rep a b = do-         (a_reg, a_code) <- getNonClobberedReg a-         b_code <- getAnyReg b-         let-             shift_amt  = case rep of-                           W32 -> 31-                           W64 -> 63-                           _ -> panic "shift_amt"--             format = intFormat rep-             code = a_code `appOL` b_code eax `appOL`-                        toOL [-                           IMUL2 format (OpReg a_reg),   -- result in %edx:%eax-                           SAR format (OpImm (ImmInt shift_amt)) (OpReg eax),-                                -- sign extend lower part-                           SUB format (OpReg edx) (OpReg eax)-                                -- compare against upper-                           -- eax==0 if high part == sign extended low part-                        ]-         return (Fixed format eax code)--    ---------------------    shift_code :: Width-               -> (Format -> Operand -> Operand -> Instr)-               -> CmmExpr-               -> CmmExpr-               -> NatM Register--    {- Case1: shift length as immediate -}-    shift_code width instr x (CmmLit lit)-      -- Handle the case of a shift larger than the width of the shifted value.-      -- This is necessary since x86 applies a mask of 0x1f to the shift-      -- amount, meaning that, e.g., `shr 47, $eax` will actually shift by-      -- `47 & 0x1f == 15`. See #20626.-      | CmmInt n _ <- lit-      , n >= fromIntegral (widthInBits width)-      = getRegister $ CmmLit $ CmmInt 0 width--      | otherwise = do-          x_code <- getAnyReg x-          let-               format = intFormat width-               code dst-                  = x_code dst `snocOL`-                    instr format (OpImm (litToImm lit)) (OpReg dst)-          return (Any format code)--    {- Case2: shift length is complex (non-immediate)-      * y must go in %ecx.-      * we cannot do y first *and* put its result in %ecx, because-        %ecx might be clobbered by x.-      * if we do y second, then x cannot be-        in a clobbered reg.  Also, we cannot clobber x's reg-        with the instruction itself.-      * so we can either:-        - do y first, put its result in a fresh tmp, then copy it to %ecx later-        - do y second and put its result into %ecx.  x gets placed in a fresh-          tmp.  This is likely to be better, because the reg alloc can-          eliminate this reg->reg move here (it won't eliminate the other one,-          because the move is into the fixed %ecx).-      * in the case of C calls the use of ecx here can interfere with arguments.-        We avoid this with the hack described in Note [Evaluate C-call-        arguments before placing in destination registers]-    -}-    shift_code width instr x y{-amount-} = do-        x_code <- getAnyReg x-        let format = intFormat width-        tmp <- getNewRegNat format-        y_code <- getAnyReg y-        let-           code = x_code tmp `appOL`-                  y_code ecx `snocOL`-                  instr format (OpReg ecx) (OpReg tmp)-        return (Fixed format tmp code)--    ---------------------    add_code :: Width -> CmmExpr -> CmmExpr -> NatM Register-    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)---getRegister' _ _ (CmmLoad mem pk _)-  | isFloatType pk-  = do-    Amode addr mem_code <- getAmode mem-    loadFloatAmode  (typeWidth pk) addr mem_code--getRegister' _ is32Bit (CmmLoad mem pk _)-  | is32Bit && not (isWord64 pk)-  = do-    code <- intLoadCode instr mem-    return (Any format code)-  where-    width = typeWidth pk-    format = intFormat width-    instr = case width of-                W8     -> MOVZxL II8-                _other -> MOV format-        -- We always zero-extend 8-bit loads, if we-        -- can't think of anything better.  This is because-        -- we can't guarantee access to an 8-bit variant of every register-        -- (esi and edi don't have 8-bit variants), so to make things-        -- simpler we do our 8-bit arithmetic with full 32-bit registers.---- Simpler memory load code on x86_64-getRegister' _ is32Bit (CmmLoad mem pk _)- | not is32Bit-  = do-    code <- intLoadCode (MOV format) mem-    return (Any format code)-  where format = intFormat $ typeWidth pk--getRegister' _ is32Bit (CmmLit (CmmInt 0 width))-  = let-        format = intFormat width--        -- x86_64: 32-bit xor is one byte shorter, and zero-extends to 64 bits-        format1 = if is32Bit then format-                           else case format of-                                II64 -> II32-                                _ -> format-        code dst-           = unitOL (XOR format1 (OpReg dst) (OpReg dst))-    in-        return (Any format code)--  -- optimisation for loading small literals on x86_64: take advantage-  -- of the automatic zero-extension from 32 to 64 bits, because the 32-bit-  -- instruction forms are shorter.-getRegister' platform is32Bit (CmmLit lit)-  | not is32Bit, isWord64 (cmmLitType platform lit), not (isBigLit lit)-  = let-        imm = litToImm lit-        code dst = unitOL (MOV II32 (OpImm imm) (OpReg dst))-    in-        return (Any II64 code)-  where-   isBigLit (CmmInt i _) = i < 0 || i > 0xffffffff-   isBigLit _ = False-        -- note1: not the same as (not.is32BitLit), because that checks for-        -- signed literals that fit in 32 bits, but we want unsigned-        -- literals here.-        -- note2: all labels are small, because we're assuming the-        -- small memory model (see gcc docs, -mcmodel=small).--getRegister' platform _ (CmmLit lit)-  = do let format = cmmTypeFormat (cmmLitType platform lit)-           imm = litToImm lit-           code dst = unitOL (MOV format (OpImm imm) (OpReg dst))-       return (Any format code)--getRegister' platform _ other-    | isVecExpr other  = needLlvm-    | otherwise        = pprPanic "getRegister(x86)" (pdoc platform other)---intLoadCode :: (Operand -> Operand -> Instr) -> CmmExpr-   -> NatM (Reg -> InstrBlock)-intLoadCode instr mem = do-  Amode src mem_code <- getAmode mem-  return (\dst -> mem_code `snocOL` instr (OpAddr src) (OpReg dst))---- Compute an expression into *any* register, adding the appropriate--- move instruction if necessary.-getAnyReg :: CmmExpr -> NatM (Reg -> InstrBlock)-getAnyReg expr = do-  r <- getRegister expr-  anyReg r--anyReg :: Register -> NatM (Reg -> InstrBlock)-anyReg (Any _ code)          = return code-anyReg (Fixed rep reg fcode) = return (\dst -> fcode `snocOL` reg2reg rep reg dst)---- A bit like getSomeReg, but we want a reg that can be byte-addressed.--- Fixed registers might not be byte-addressable, so we make sure we've--- got a temporary, inserting an extra reg copy if necessary.-getByteReg :: CmmExpr -> NatM (Reg, InstrBlock)-getByteReg expr = do-  is32Bit <- is32BitPlatform-  if is32Bit-      then do r <- getRegister expr-              case r of-                Any rep code -> do-                    tmp <- getNewRegNat rep-                    return (tmp, code tmp)-                Fixed rep reg code-                    | isVirtualReg reg -> return (reg,code)-                    | otherwise -> do-                        tmp <- getNewRegNat rep-                        return (tmp, code `snocOL` reg2reg rep reg tmp)-                    -- ToDo: could optimise slightly by checking for-                    -- byte-addressable real registers, but that will-                    -- happen very rarely if at all.-      else getSomeReg expr -- all regs are byte-addressable on x86_64---- Another variant: this time we want the result in a register that cannot--- be modified by code to evaluate an arbitrary expression.-getNonClobberedReg :: CmmExpr -> NatM (Reg, InstrBlock)-getNonClobberedReg expr = do-  r <- getRegister expr-  platform <- ncgPlatform <$> getConfig-  case r of-    Any rep code -> do-        tmp <- getNewRegNat rep-        return (tmp, code tmp)-    Fixed rep reg code-        -- only certain regs can be clobbered-        | reg `elem` instrClobberedRegs platform-        -> do-                tmp <- getNewRegNat rep-                return (tmp, code `snocOL` reg2reg rep reg tmp)-        | otherwise ->-                return (reg, code)--reg2reg :: Format -> Reg -> Reg -> Instr-reg2reg format src dst = MOV format (OpReg src) (OpReg dst)--------------------------------------------------------------------------------------- | Convert a 'CmmExpr' representing a memory address into an 'Amode'.------ An 'Amode' is a datatype representing a valid address form for the target--- (e.g. "Base + Index + disp" or immediate) and the code to compute it.-getAmode :: CmmExpr -> NatM Amode-getAmode e = do-   platform <- getPlatform-   let is32Bit = target32Bit platform--   case e of-      CmmRegOff r n-         -> getAmode $ mangleIndexTree platform r n--      CmmMachOp (MO_Add W64) [CmmReg (CmmGlobal PicBaseReg), CmmLit displacement]-         | not is32Bit-         -> return $ Amode (ripRel (litToImm displacement)) nilOL--      -- This is all just ridiculous, since it carefully undoes-      -- what mangleIndexTree has just done.-      CmmMachOp (MO_Sub _rep) [x, CmmLit lit@(CmmInt i _)]-         | is32BitLit is32Bit lit-         -- ASSERT(rep == II32)???-         -> do-            (x_reg, x_code) <- getSomeReg x-            let off = ImmInt (-(fromInteger i))-            return (Amode (AddrBaseIndex (EABaseReg x_reg) EAIndexNone off) x_code)--      CmmMachOp (MO_Add _rep) [x, CmmLit lit]-         | is32BitLit is32Bit lit-         -- ASSERT(rep == II32)???-         -> do-            (x_reg, x_code) <- getSomeReg x-            let off = litToImm lit-            return (Amode (AddrBaseIndex (EABaseReg x_reg) EAIndexNone off) x_code)--      -- Turn (lit1 << n  + lit2) into  (lit2 + lit1 << n) so it will be-      -- recognised by the next rule.-      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-         | is32BitLit is32Bit 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)------ | 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 :: Bool -> CmmExpr -> NatM Amode-getSimpleAmode is32Bit addr-    | is32Bit = 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)-    | otherwise = getAmode addr--x86_complex_amode :: CmmExpr -> CmmExpr -> Integer -> Integer -> NatM Amode-x86_complex_amode base index shift offset-  = do (x_reg, x_code) <- getNonClobberedReg base-        -- x must be in a temp, because it has to stay live over y_code-        -- we could compare x_reg and y_reg and do something better here...-       (y_reg, y_code) <- getSomeReg index-       let-           code = x_code `appOL` y_code-           base = case shift of 0 -> 1; 1 -> 2; 2 -> 4; 3 -> 8;-                                n -> panic $ "x86_complex_amode: unhandled shift! (" ++ show n ++ ")"-       return (Amode (AddrBaseIndex (EABaseReg x_reg) (EAIndex y_reg base) (ImmInt (fromIntegral offset)))-               code)------- -------------------------------------------------------------------------------- getOperand: sometimes any operand will do.---- getNonClobberedOperand: the value of the operand will remain valid across--- the computation of an arbitrary expression, unless the expression--- is computed directly into a register which the operand refers to--- (see trivialCode where this function is used for an example).--getNonClobberedOperand :: CmmExpr -> NatM (Operand, InstrBlock)-getNonClobberedOperand (CmmLit lit) =-  if isSuitableFloatingPointLit lit-  then do-    let CmmFloat _ w = lit-    Amode addr code <- memConstant (mkAlignment $ widthInBytes w) lit-    return (OpAddr addr, code)-  else do-    is32Bit <- is32BitPlatform-    platform <- getPlatform-    if is32BitLit is32Bit lit && not (isFloatType (cmmLitType platform lit))-    then return (OpImm (litToImm lit), nilOL)-    else getNonClobberedOperand_generic (CmmLit lit)--getNonClobberedOperand (CmmLoad mem pk _) = do-  is32Bit <- is32BitPlatform-  -- this logic could be simplified-  -- TODO FIXME-  if   (if is32Bit then not (isWord64 pk) else True)-      -- if 32bit and pk is at float/double/simd value-      -- or if 64bit-      --  this could use some eyeballs or i'll need to stare at it more later-    then do-      platform <- ncgPlatform <$> getConfig-      Amode src mem_code <- getAmode mem-      (src',save_code) <--        if (amodeCouldBeClobbered platform src)-                then do-                   tmp <- getNewRegNat (archWordFormat is32Bit)-                   return (AddrBaseIndex (EABaseReg tmp) EAIndexNone (ImmInt 0),-                           unitOL (LEA (archWordFormat is32Bit)-                                       (OpAddr src)-                                       (OpReg tmp)))-                else-                   return (src, nilOL)-      return (OpAddr src', mem_code `appOL` save_code)-    else-      -- if its a word or gcptr on 32bit?-      getNonClobberedOperand_generic (CmmLoad mem pk NaturallyAligned)--getNonClobberedOperand e = getNonClobberedOperand_generic e--getNonClobberedOperand_generic :: CmmExpr -> NatM (Operand, InstrBlock)-getNonClobberedOperand_generic e = do-  (reg, code) <- getNonClobberedReg e-  return (OpReg reg, code)--amodeCouldBeClobbered :: Platform -> AddrMode -> Bool-amodeCouldBeClobbered platform amode = any (regClobbered platform) (addrModeRegs amode)--regClobbered :: Platform -> Reg -> Bool-regClobbered platform (RegReal (RealRegSingle rr)) = freeReg platform rr-regClobbered _ _ = False---- getOperand: the operand is not required to remain valid across the--- computation of an arbitrary expression.-getOperand :: CmmExpr -> NatM (Operand, InstrBlock)--getOperand (CmmLit lit) = do-  use_sse2 <- sse2Enabled-  if (use_sse2 && isSuitableFloatingPointLit lit)-    then do-      let CmmFloat _ w = lit-      Amode addr code <- memConstant (mkAlignment $ widthInBytes w) lit-      return (OpAddr addr, code)-    else do--  is32Bit <- is32BitPlatform-  platform <- getPlatform-  if is32BitLit is32Bit lit && not (isFloatType (cmmLitType platform lit))-    then return (OpImm (litToImm lit), nilOL)-    else getOperand_generic (CmmLit lit)--getOperand (CmmLoad mem pk _) = do-  is32Bit <- is32BitPlatform-  use_sse2 <- sse2Enabled-  if (not (isFloatType pk) || use_sse2) && (if is32Bit then not (isWord64 pk) else True)-     then do-       Amode src mem_code <- getAmode mem-       return (OpAddr src, mem_code)-     else-       getOperand_generic (CmmLoad mem pk NaturallyAligned)--getOperand e = getOperand_generic e--getOperand_generic :: CmmExpr -> NatM (Operand, InstrBlock)-getOperand_generic e = do-    (reg, code) <- getSomeReg e-    return (OpReg reg, code)--isOperand :: Bool -> CmmExpr -> Bool-isOperand _ (CmmLoad _ _ _) = True-isOperand is32Bit (CmmLit lit)  = is32BitLit is32Bit lit-                          || isSuitableFloatingPointLit lit-isOperand _ _            = False---- | Given a 'Register', produce a new 'Register' with an instruction block--- which will check the value for alignment. Used for @-falignment-sanitisation@.-addAlignmentCheck :: Int -> Register -> Register-addAlignmentCheck align reg =-    case reg of-      Fixed fmt reg code -> Fixed fmt reg (code `appOL` check fmt reg)-      Any fmt f          -> Any fmt (\reg -> f reg `appOL` check fmt reg)-  where-    check :: Format -> Reg -> InstrBlock-    check fmt reg =-        ASSERT(not $ isFloatFormat fmt)-        toOL [ TEST fmt (OpImm $ ImmInt $ align-1) (OpReg reg)-             , JXX_GBL NE $ ImmCLbl mkBadAlignmentLabel-             ]--memConstant :: Alignment -> CmmLit -> NatM Amode-memConstant align lit = do-  lbl <- getNewLabelNat-  let rosection = Section ReadOnlyData lbl-  config <- getConfig-  platform <- getPlatform-  (addr, addr_code) <- if target32Bit platform-                       then do dynRef <- cmmMakeDynamicReference-                                             config-                                             DataReference-                                             lbl-                               Amode addr addr_code <- getAmode dynRef-                               return (addr, addr_code)-                       else return (ripRel (ImmCLbl lbl), nilOL)-  let code =-        LDATA rosection (align, CmmStaticsRaw lbl [CmmStaticLit lit])-        `consOL` addr_code-  return (Amode addr code)---loadFloatAmode :: Width -> AddrMode -> InstrBlock -> NatM Register-loadFloatAmode w addr addr_code = do-  let format = floatFormat w-      code dst = addr_code `snocOL`-                    MOV format (OpAddr addr) (OpReg dst)--  return (Any format code)----- if we want a floating-point literal as an operand, we can--- use it directly from memory.  However, if the literal is--- zero, we're better off generating it into a register using--- xor.-isSuitableFloatingPointLit :: CmmLit -> Bool-isSuitableFloatingPointLit (CmmFloat f _) = f /= 0.0-isSuitableFloatingPointLit _ = False--getRegOrMem :: CmmExpr -> NatM (Operand, InstrBlock)-getRegOrMem e@(CmmLoad mem pk _) = do-  is32Bit <- is32BitPlatform-  use_sse2 <- sse2Enabled-  if (not (isFloatType pk) || use_sse2) && (if is32Bit then not (isWord64 pk) else True)-     then do-       Amode src mem_code <- getAmode mem-       return (OpAddr src, mem_code)-     else do-       (reg, code) <- getNonClobberedReg e-       return (OpReg reg, code)-getRegOrMem e = do-    (reg, code) <- getNonClobberedReg e-    return (OpReg reg, code)--is32BitLit :: Bool -> CmmLit -> Bool-is32BitLit is32Bit lit-   | not is32Bit = case lit of-      CmmInt i W64              -> is32BitInteger i-      -- assume that labels are in the range 0-2^31-1: this assumes the-      -- small memory model (see gcc docs, -mcmodel=small).-      CmmLabel _                -> True-      -- however we can't assume that label offsets are in this range-      -- (see #15570)-      CmmLabelOff _ off         -> is32BitInteger (fromIntegral off)-      CmmLabelDiffOff _ _ off _ -> is32BitInteger (fromIntegral off)-      _                         -> True-is32BitLit _ _ = True------- Set up a condition code for a conditional branch.--getCondCode :: CmmExpr -> NatM CondCode---- yes, they really do seem to want exactly the same!--getCondCode (CmmMachOp mop [x, y])-  =-    case mop of-      MO_F_Eq W32 -> condFltCode EQQ x y-      MO_F_Ne W32 -> condFltCode NE  x y-      MO_F_Gt W32 -> condFltCode GTT x y-      MO_F_Ge W32 -> condFltCode GE  x y-      -- Invert comparison condition and swap operands-      -- See Note [SSE Parity Checks]-      MO_F_Lt W32 -> condFltCode GTT  y x-      MO_F_Le W32 -> condFltCode GE   y x--      MO_F_Eq W64 -> condFltCode EQQ x y-      MO_F_Ne W64 -> condFltCode NE  x y-      MO_F_Gt W64 -> condFltCode GTT x y-      MO_F_Ge W64 -> condFltCode GE  x y-      MO_F_Lt W64 -> condFltCode GTT y x-      MO_F_Le W64 -> condFltCode GE  y x--      _ -> condIntCode (machOpToCond mop) x y--getCondCode other = do-   platform <- getPlatform-   pprPanic "getCondCode(2)(x86,x86_64)" (pdoc platform other)--machOpToCond :: MachOp -> Cond-machOpToCond mo = case mo of-  MO_Eq _   -> EQQ-  MO_Ne _   -> NE-  MO_S_Gt _ -> GTT-  MO_S_Ge _ -> GE-  MO_S_Lt _ -> LTT-  MO_S_Le _ -> LE-  MO_U_Gt _ -> GU-  MO_U_Ge _ -> GEU-  MO_U_Lt _ -> LU-  MO_U_Le _ -> LEU-  _other -> pprPanic "machOpToCond" (pprMachOp mo)----- @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be--- passed back up the tree.--condIntCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode-condIntCode cond x y = do is32Bit <- is32BitPlatform-                          condIntCode' is32Bit cond x y--condIntCode' :: Bool -> Cond -> CmmExpr -> CmmExpr -> NatM CondCode---- memory vs immediate-condIntCode' is32Bit cond (CmmLoad x pk _) (CmmLit lit)- | is32BitLit is32Bit lit = do-    Amode x_addr x_code <- getAmode x-    let-        imm  = litToImm lit-        code = x_code `snocOL`-                  CMP (cmmTypeFormat pk) (OpImm imm) (OpAddr x_addr)-    ---    return (CondCode False cond code)---- anything vs zero, using a mask--- TODO: Add some sanity checking!!!!-condIntCode' is32Bit cond (CmmMachOp (MO_And _) [x,o2]) (CmmLit (CmmInt 0 pk))-    | (CmmLit lit@(CmmInt mask _)) <- o2, is32BitLit is32Bit lit-    = do-      (x_reg, x_code) <- getSomeReg x-      let-         code = x_code `snocOL`-                TEST (intFormat pk) (OpImm (ImmInteger mask)) (OpReg x_reg)-      ---      return (CondCode False cond code)---- anything vs zero-condIntCode' _ cond x (CmmLit (CmmInt 0 pk)) = do-    (x_reg, x_code) <- getSomeReg x-    let-        code = x_code `snocOL`-                  TEST (intFormat pk) (OpReg x_reg) (OpReg x_reg)-    ---    return (CondCode False cond code)---- anything vs operand-condIntCode' is32Bit cond x y- | isOperand is32Bit y = do-    platform <- getPlatform-    (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 is32Bit x- , Just revcond <- maybeFlipCond cond = do-    platform <- getPlatform-    (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' _ cond x y = do-  platform <- getPlatform-  (y_reg, y_code) <- getNonClobberedReg y-  (x_op, x_code) <- getRegOrMem x-  let-        code = y_code `appOL`-               x_code `snocOL`-                  CMP (cmmTypeFormat (cmmExprType platform x)) (OpReg y_reg) x_op-  return (CondCode False cond code)-------------------------------------------------------------------------------------condFltCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode--condFltCode cond x y-  =  condFltCode_sse2-  where---  -- in the SSE2 comparison ops (ucomiss, ucomisd) the left arg may be-  -- an operand, but the right must be a reg.  We can probably do better-  -- than this general case...-  condFltCode_sse2 = do-    platform <- getPlatform-    (x_reg, x_code) <- getNonClobberedReg x-    (y_op, y_code) <- getOperand y-    let-        code = x_code `appOL`-               y_code `snocOL`-                  CMP (floatFormat $ cmmExprWidth platform x) y_op (OpReg x_reg)-        -- NB(1): we need to use the unsigned comparison operators on the-        -- result of this comparison.-    return (CondCode True (condToUnsigned cond) code)---- -------------------------------------------------------------------------------- Generating assignments---- Assignments are really at the heart of the whole code generation--- business.  Almost all top-level nodes of any real importance are--- assignments, which correspond to loads, stores, or register--- transfers.  If we're really lucky, some of the register transfers--- will go away, because we can use the destination register to--- complete the code generation for the right hand side.  This only--- fails when the right hand side is forced into a fixed register--- (e.g. the result of a call).--assignMem_IntCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock-assignReg_IntCode :: Format -> CmmReg  -> CmmExpr -> NatM InstrBlock--assignMem_FltCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock-assignReg_FltCode :: Format -> CmmReg  -> CmmExpr -> NatM InstrBlock----- integer assignment to memory---- specific case of adding/subtracting an integer to a particular address.--- ToDo: catch other cases where we can use an operation directly on a memory--- address.-assignMem_IntCode pk addr (CmmMachOp op [CmmLoad addr2 _ _,-                                                 CmmLit (CmmInt i _)])-   | addr == addr2, pk /= II64 || is32BitInteger i,-     Just instr <- check op-   = do Amode amode code_addr <- getAmode addr-        let code = code_addr `snocOL`-                   instr pk (OpImm (ImmInt (fromIntegral i))) (OpAddr amode)-        return code-   where-        check (MO_Add _) = Just ADD-        check (MO_Sub _) = Just SUB-        check _ = Nothing-        -- ToDo: more?---- general case-assignMem_IntCode pk addr src = do-    is32Bit <- is32BitPlatform-    Amode addr code_addr <- getAmode addr-    (code_src, op_src)   <- get_op_RI is32Bit src-    let-        code = code_src `appOL`-               code_addr `snocOL`-                  MOV pk op_src (OpAddr addr)-        -- NOTE: op_src is stable, so it will still be valid-        -- after code_addr.  This may involve the introduction-        -- of an extra MOV to a temporary register, but we hope-        -- the register allocator will get rid of it.-    ---    return code-  where-    get_op_RI :: Bool -> CmmExpr -> NatM (InstrBlock,Operand)   -- code, operator-    get_op_RI is32Bit (CmmLit lit) | is32BitLit is32Bit lit-      = return (nilOL, OpImm (litToImm lit))-    get_op_RI _ op-      = do (reg,code) <- getNonClobberedReg op-           return (code, OpReg reg)----- Assign; dst is a reg, rhs is mem-assignReg_IntCode pk reg (CmmLoad src _ _) = do-  load_code <- intLoadCode (MOV pk) src-  platform <- ncgPlatform <$> getConfig-  return (load_code (getRegisterReg platform reg))---- dst is a reg, but src could be anything-assignReg_IntCode _ reg src = do-  platform <- ncgPlatform <$> getConfig-  code <- getAnyReg src-  return (code (getRegisterReg platform reg))----- Floating point assignment to memory-assignMem_FltCode pk addr src = do-  (src_reg, src_code) <- getNonClobberedReg src-  Amode addr addr_code <- getAmode addr-  let-        code = src_code `appOL`-               addr_code `snocOL`-               MOV pk (OpReg src_reg) (OpAddr addr)--  return code---- Floating point assignment to a register/temporary-assignReg_FltCode _ reg src = do-  src_code <- getAnyReg src-  platform <- ncgPlatform <$> getConfig-  return (src_code (getRegisterReg platform reg))---genJump :: CmmExpr{-the branch target-} -> [Reg] -> NatM InstrBlock--genJump (CmmLoad mem _ _) regs = do-  Amode target code <- getAmode mem-  return (code `snocOL` JMP (OpAddr target) regs)--genJump (CmmLit lit) regs =-  return (unitOL (JMP (OpImm (litToImm lit)) regs))--genJump expr regs = do-  (reg,code) <- getSomeReg expr-  return (code `snocOL` JMP (OpReg reg) regs)----- --------------------------------------------------------------------------------  Unconditional branches--genBranch :: BlockId -> InstrBlock-genBranch = toOL . mkJumpInstr------ --------------------------------------------------------------------------------  Conditional jumps/branches--{--Conditional jumps are always to local labels, so we can use branch-instructions.  We peek at the arguments to decide what kind of-comparison to do.--I386: First, we have to ensure that the condition-codes are set according to the supplied comparison operation.--}--{-  Note [64-bit integer comparisons on 32-bit]-    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--    When doing these comparisons there are 2 kinds of-    comparisons.--    * Comparison for equality (or lack thereof)--    We use xor to check if high/low bits are-    equal. Then combine the results using or and-    perform a single conditional jump based on the-    result.--    * Other comparisons:--    We map all other comparisons to the >= operation.-    Why? Because it's easy to encode it with a single-    conditional jump.--    We do this by first computing [r1_lo - r2_lo]-    and use the carry flag to compute-    [r1_high - r2_high - CF].--    At which point if r1 >= r2 then the result will be-    positive. Otherwise negative so we can branch on this-    condition.---}---genCondBranch-    :: BlockId      -- the source of the jump-    -> BlockId      -- the true branch target-    -> BlockId      -- the false branch target-    -> CmmExpr      -- the condition on which to branch-    -> NatM InstrBlock -- Instructions--genCondBranch bid id false expr = do-  is32Bit <- is32BitPlatform-  genCondBranch' is32Bit bid id false expr---- | We return the instructions generated.-genCondBranch' :: Bool -> BlockId -> BlockId -> BlockId -> CmmExpr-               -> NatM InstrBlock---- 64-bit integer comparisons on 32-bit--- See Note [64-bit integer comparisons on 32-bit]-genCondBranch' is32Bit _bid true false (CmmMachOp mop [e1,e2])-  | is32Bit, Just W64 <- maybeIntComparison mop = do--  -- The resulting registers here are both the lower part of-  -- the register as well as a way to get at the higher part.-  ChildCode64 code1 r1 <- iselExpr64 e1-  ChildCode64 code2 r2 <- iselExpr64 e2-  let cond = machOpToCond mop :: Cond--  let cmpCode = intComparison cond true false r1 r2-  return $ code1 `appOL` code2 `appOL` cmpCode--  where-    intComparison :: Cond -> BlockId -> BlockId -> Reg -> Reg -> InstrBlock-    intComparison cond true false r1_lo r2_lo =-      case cond of-        -- Impossible results of machOpToCond-        ALWAYS  -> panic "impossible"-        NEG     -> panic "impossible"-        POS     -> panic "impossible"-        CARRY   -> panic "impossible"-        OFLO    -> panic "impossible"-        PARITY  -> panic "impossible"-        NOTPARITY -> panic "impossible"-        -- Special case #1 x == y and x != y-        EQQ -> cmpExact-        NE  -> cmpExact-        -- [x >= y]-        GE  -> cmpGE-        GEU -> cmpGE-        -- [x >  y] <==> ![y >= x]-        GTT -> intComparison GE  false true r2_lo r1_lo-        GU  -> intComparison GEU false true r2_lo r1_lo-        -- [x <= y] <==> [y >= x]-        LE  -> intComparison GE  true false r2_lo r1_lo-        LEU -> intComparison GEU true false r2_lo r1_lo-        -- [x <  y] <==> ![x >= x]-        LTT -> intComparison GE  false true r1_lo r2_lo-        LU  -> intComparison GEU false true r1_lo r2_lo-      where-        r1_hi = getHiVRegFromLo r1_lo-        r2_hi = getHiVRegFromLo r2_lo-        cmpExact :: OrdList Instr-        cmpExact =-          toOL-            [ XOR II32 (OpReg r2_hi) (OpReg r1_hi)-            , XOR II32 (OpReg r2_lo) (OpReg r1_lo)-            , OR  II32 (OpReg r1_hi)  (OpReg r1_lo)-            , JXX cond true-            , JXX ALWAYS false-            ]-        cmpGE = toOL-            [ CMP II32 (OpReg r2_lo) (OpReg r1_lo)-            , SBB II32 (OpReg r2_hi) (OpReg r1_hi)-            , JXX cond true-            , JXX ALWAYS false ]--genCondBranch' _ bid id false bool = do-  CondCode is_float cond cond_code <- getCondCode bool-  use_sse2 <- sse2Enabled-  if not is_float || not use_sse2-    then-        return (cond_code `snocOL` JXX cond id `appOL` genBranch false)-    else do-        -- See Note [SSE Parity Checks]-        let jmpFalse = genBranch false-            code-                = case cond of-                  NE  -> or_unordered-                  GU  -> plain_test-                  GEU -> plain_test-                  -- Use ASSERT so we don't break releases if-                  -- LTT/LE creep in somehow.-                  LTT ->-                    ASSERT2(False, ppr "Should have been turned into >")-                    and_ordered-                  LE  ->-                    ASSERT2(False, ppr "Should have been turned into >=")-                    and_ordered-                  _   -> and_ordered--            plain_test = unitOL (-                  JXX cond id-                ) `appOL` jmpFalse-            or_unordered = toOL [-                  JXX cond id,-                  JXX PARITY id-                ] `appOL` jmpFalse-            and_ordered = toOL [-                  JXX PARITY false,-                  JXX cond id,-                  JXX ALWAYS false-                ]-        updateCfgNat (\cfg -> adjustEdgeWeight cfg (+3) bid false)-        return (cond_code `appOL` code)--{-  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.--genCCall-    :: Bool                     -- 32 bit platform?-    -> ForeignTarget            -- function to call-    -> [CmmFormal]        -- where to put the result-    -> [CmmActual]        -- arguments (of mixed type)-    -> BlockId      -- The block we are in-    -> NatM (InstrBlock, Maybe BlockId)---- First we deal with cases which might introduce new blocks in the stream.--genCCall is32Bit (PrimTarget (MO_AtomicRMW width amop))-                                           [dst] [addr, n] bid = do-    Amode amode addr_code <--        if amop `elem` [AMO_Add, AMO_Sub]-        then getAmode addr-        else getSimpleAmode is32Bit addr  -- See genCCall for MO_Cmpxchg-    arg <- getNewRegNat format-    arg_code <- getAnyReg n-    platform <- ncgPlatform <$> getConfig--    let dst_r    = getRegisterReg platform  (CmmLocal dst)-    (code, lbl) <- op_code dst_r arg amode-    return (addr_code `appOL` arg_code arg `appOL` code, Just lbl)-  where-    -- Code for the operation-    op_code :: Reg       -- Destination reg-            -> Reg       -- Register containing argument-            -> AddrMode  -- Address of location to mutate-            -> NatM (OrdList Instr,BlockId) -- TODO: Return Maybe BlockId-    op_code dst_r arg amode = case amop of-        -- In the common case where dst_r is a virtual register the-        -- final move should go away, because it's the last use of arg-        -- and the first use of dst_r.-        AMO_Add  -> return $ (toOL [ LOCK (XADD format (OpReg arg) (OpAddr amode))-                                   , MOV format (OpReg arg) (OpReg dst_r)-                                   ], bid)-        AMO_Sub  -> return $ (toOL [ NEGI format (OpReg arg)-                                   , LOCK (XADD format (OpReg arg) (OpAddr amode))-                                   , MOV format (OpReg arg) (OpReg dst_r)-                                   ], bid)-        -- In these cases we need a new block id, and have to return it so-        -- that later instruction selection can reference it.-        AMO_And  -> cmpxchg_code (\ src dst -> unitOL $ AND format src dst)-        AMO_Nand -> cmpxchg_code (\ src dst -> toOL [ AND format src dst-                                                    , NOT format dst-                                                    ])-        AMO_Or   -> cmpxchg_code (\ src dst -> unitOL $ OR format src dst)-        AMO_Xor  -> cmpxchg_code (\ src dst -> unitOL $ XOR format src dst)-      where-        -- Simulate operation that lacks a dedicated instruction using-        -- cmpxchg.-        cmpxchg_code :: (Operand -> Operand -> OrdList Instr)-                     -> NatM (OrdList Instr, BlockId)-        cmpxchg_code instrs = do-            lbl1 <- getBlockIdNat-            lbl2 <- getBlockIdNat-            tmp <- getNewRegNat format--            --Record inserted blocks-            --  We turn A -> B into A -> A' -> A'' -> B-            --  with a self loop on A'.-            addImmediateSuccessorNat bid lbl1-            addImmediateSuccessorNat lbl1 lbl2-            updateCfgNat (addWeightEdge lbl1 lbl1 0)--            return $ (toOL-                [ MOV format (OpAddr amode) (OpReg eax)-                , JXX ALWAYS lbl1-                , NEWBLOCK lbl1-                  -- Keep old value so we can return it:-                , MOV format (OpReg eax) (OpReg dst_r)-                , MOV format (OpReg eax) (OpReg tmp)-                ]-                `appOL` instrs (OpReg arg) (OpReg tmp) `appOL` toOL-                [ LOCK (CMPXCHG format (OpReg tmp) (OpAddr amode))-                , JXX NE lbl1-                -- See Note [Introducing cfg edges inside basic blocks]-                -- why this basic block is required.-                , JXX ALWAYS lbl2-                , NEWBLOCK lbl2-                ],-                lbl2)-    format = intFormat width--genCCall is32Bit (PrimTarget (MO_Ctz width)) [dst] [src] bid-  | is32Bit, width == W64 = do-      ChildCode64 vcode rlo <- iselExpr64 src-      platform <- ncgPlatform <$> getConfig-      let rhi     = getHiVRegFromLo rlo-          dst_r   = getRegisterReg platform  (CmmLocal dst)-      lbl1 <- getBlockIdNat-      lbl2 <- getBlockIdNat-      let format = if width == W8 then II16 else intFormat width-      tmp_r <- getNewRegNat format--      -- New CFG Edges:-      --  bid -> lbl2-      --  bid -> lbl1 -> lbl2-      --  We also changes edges originating at bid to start at lbl2 instead.-      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)--  | otherwise = do-    code_src <- getAnyReg src-    config <- getConfig-    let platform = ncgPlatform config-    let dst_r = getRegisterReg platform (CmmLocal 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, Nothing)-    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, Nothing)-  where-    bw = widthInBits width--genCCall bits mop dst args bid = do-  config <- getConfig-  instr <- genCCall' config bits mop dst args bid-  return (instr, Nothing)---- genCCall' handles cases not introducing new code blocks.-genCCall'-    :: NCGConfig-    -> Bool                     -- 32 bit platform?-    -> ForeignTarget            -- function to call-    -> [CmmFormal]        -- where to put the result-    -> [CmmActual]        -- arguments (of mixed type)-    -> BlockId      -- The block we are in-    -> NatM InstrBlock---- Unroll memcpy calls if the number of bytes to copy isn't too--- large.  Otherwise, call C's memcpy.-genCCall' config _ (PrimTarget (MO_Memcpy align)) _-         [dst, src, CmmLit (CmmInt n _)] _-    | fromInteger insns <= ncgInlineThresholdMemcpy config = do-        code_dst <- getAnyReg dst-        dst_r <- getNewRegNat format-        code_src <- getAnyReg src-        src_r <- getNewRegNat format-        tmp_r <- getNewRegNat format-        return $ code_dst dst_r `appOL` code_src src_r `appOL`-            go dst_r src_r tmp_r (fromInteger n)-  where-    platform = ncgPlatform config-    -- The number of instructions we will generate (approx). We need 2-    -- instructions per move.-    insns = 2 * ((n + sizeBytes - 1) `div` sizeBytes)--    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.-    sizeBytes :: Integer-    sizeBytes = fromIntegral (formatInBytes format)--    go :: Reg -> Reg -> Reg -> Integer -> OrdList Instr-    go dst src tmp i-        | i >= sizeBytes =-            unitOL (MOV format (OpAddr src_addr) (OpReg tmp)) `appOL`-            unitOL (MOV format (OpReg tmp) (OpAddr dst_addr)) `appOL`-            go dst src tmp (i - sizeBytes)-        -- Deal with remaining bytes.-        | i >= 4 =  -- Will never happen on 32-bit-            unitOL (MOV II32 (OpAddr src_addr) (OpReg tmp)) `appOL`-            unitOL (MOV II32 (OpReg tmp) (OpAddr dst_addr)) `appOL`-            go dst src tmp (i - 4)-        | i >= 2 =-            unitOL (MOVZxL II16 (OpAddr src_addr) (OpReg tmp)) `appOL`-            unitOL (MOV II16 (OpReg tmp) (OpAddr dst_addr)) `appOL`-            go dst src tmp (i - 2)-        | i >= 1 =-            unitOL (MOVZxL II8 (OpAddr src_addr) (OpReg tmp)) `appOL`-            unitOL (MOV II8 (OpReg tmp) (OpAddr dst_addr)) `appOL`-            go dst src tmp (i - 1)-        | otherwise = nilOL-      where-        src_addr = AddrBaseIndex (EABaseReg src) EAIndexNone-                   (ImmInteger (n - i))-        dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone-                   (ImmInteger (n - i))--genCCall' config _ (PrimTarget (MO_Memset align)) _-         [dst,-          CmmLit (CmmInt c _),-          CmmLit (CmmInt n _)]-         _-    | fromInteger insns <= ncgInlineThresholdMemset config = do-        code_dst <- getAnyReg dst-        dst_r <- getNewRegNat format-        if format == II64 && n >= 8 then do-          code_imm8byte <- getAnyReg (CmmLit (CmmInt c8 W64))-          imm8byte_r <- getNewRegNat II64-          return $ code_dst dst_r `appOL`-                   code_imm8byte imm8byte_r `appOL`-                   go8 dst_r imm8byte_r (fromInteger n)-        else-          return $ code_dst dst_r `appOL`-                   go4 dst_r (fromInteger n)-  where-    platform = ncgPlatform config-    maxAlignment = wordAlignment platform -- only machine word wide MOVs are supported-    effectiveAlignment = min (alignmentOf align) maxAlignment-    format = intFormat . widthFromBytes $ alignmentBytes effectiveAlignment-    c2 = c `shiftL` 8 .|. c-    c4 = c2 `shiftL` 16 .|. c2-    c8 = c4 `shiftL` 32 .|. c4--    -- The number of instructions we will generate (approx). We need 1-    -- instructions per move.-    insns = (n + sizeBytes - 1) `div` sizeBytes--    -- The size of each move, in bytes.-    sizeBytes :: Integer-    sizeBytes = fromIntegral (formatInBytes format)--    -- Depending on size returns the widest MOV instruction and its-    -- width.-    gen4 :: AddrMode -> Integer -> (InstrBlock, Integer)-    gen4 addr size-        | size >= 4 =-            (unitOL (MOV II32 (OpImm (ImmInteger c4)) (OpAddr addr)), 4)-        | size >= 2 =-            (unitOL (MOV II16 (OpImm (ImmInteger c2)) (OpAddr addr)), 2)-        | size >= 1 =-            (unitOL (MOV II8 (OpImm (ImmInteger c)) (OpAddr addr)), 1)-        | otherwise = (nilOL, 0)--    -- Generates a 64-bit wide MOV instruction from REG to MEM.-    gen8 :: AddrMode -> Reg -> InstrBlock-    gen8 addr reg8byte =-      unitOL (MOV format (OpReg reg8byte) (OpAddr addr))--    -- Unrolls memset when the widest MOV is <= 4 bytes.-    go4 :: Reg -> Integer -> InstrBlock-    go4 dst left =-      if left <= 0 then nilOL-      else curMov `appOL` go4 dst (left - curWidth)-      where-        possibleWidth = minimum [left, sizeBytes]-        dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone (ImmInteger (n - left))-        (curMov, curWidth) = gen4 dst_addr possibleWidth--    -- Unrolls memset when the widest MOV is 8 bytes (thus another Reg-    -- argument). Falls back to go4 when all 8 byte moves are-    -- exhausted.-    go8 :: Reg -> Reg -> Integer -> InstrBlock-    go8 dst reg8byte left =-      if possibleWidth >= 8 then-        let curMov = gen8 dst_addr reg8byte-        in  curMov `appOL` go8 dst reg8byte (left - 8)-      else go4 dst left-      where-        possibleWidth = minimum [left, sizeBytes]-        dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone (ImmInteger (n - left))--genCCall' _ _ (PrimTarget MO_ReadBarrier) _ _ _  = return nilOL-genCCall' _ _ (PrimTarget MO_WriteBarrier) _ _ _ = return nilOL-        -- barriers compile to no code on x86/x86-64;-        -- we keep it this long in order to prevent earlier optimisations.--genCCall' _ _ (PrimTarget MO_Touch) _ _ _ = return nilOL--genCCall' _ is32bit (PrimTarget (MO_Prefetch_Data n )) _  [src] _ =-        case n of-            0 -> genPrefetch src $ PREFETCH NTA  format-            1 -> genPrefetch src $ PREFETCH Lvl2 format-            2 -> genPrefetch src $ PREFETCH Lvl1 format-            3 -> genPrefetch src $ PREFETCH Lvl0 format-            l -> panic $ "unexpected prefetch level in genCCall MO_Prefetch_Data: " ++ (show l)-            -- the c / llvm prefetch convention is 0, 1, 2, and 3-            -- the x86 corresponding names are : NTA, 2 , 1, and 0-   where-        format = archWordFormat is32bit-        -- need to know what register width for pointers!-        genPrefetch inRegSrc prefetchCTor =-            do-                code_src <- getAnyReg inRegSrc-                src_r <- getNewRegNat format-                return $ code_src src_r `appOL`-                  (unitOL (prefetchCTor  (OpAddr-                              ((AddrBaseIndex (EABaseReg src_r )   EAIndexNone (ImmInt 0))))  ))-                  -- prefetch always takes an address--genCCall' _ is32Bit (PrimTarget (MO_BSwap width)) [dst] [src] _ = do-    platform <- ncgPlatform <$> getConfig-    let dst_r = getRegisterReg platform (CmmLocal dst)-    case width of-        W64 | is32Bit -> do-               ChildCode64 vcode rlo <- iselExpr64 src-               let dst_rhi = getHiVRegFromLo dst_r-                   rhi     = getHiVRegFromLo rlo-               return $ vcode `appOL`-                        toOL [ MOV II32 (OpReg rlo) (OpReg dst_rhi),-                               MOV II32 (OpReg rhi) (OpReg dst_r),-                               BSWAP II32 dst_rhi,-                               BSWAP II32 dst_r ]-        W16 -> do code_src <- getAnyReg src-                  return $ code_src dst_r `appOL`-                           unitOL (BSWAP II32 dst_r) `appOL`-                           unitOL (SHR II32 (OpImm $ ImmInt 16) (OpReg dst_r))-        _   -> do code_src <- getAnyReg src-                  return $ code_src dst_r `appOL` unitOL (BSWAP format dst_r)-  where-    format = intFormat width--genCCall' config is32Bit (PrimTarget (MO_PopCnt width)) dest_regs@[dst]-         args@[src] bid = do-    sse4_2 <- sse4_2Enabled-    let platform = ncgPlatform config-    if sse4_2-        then do code_src <- getAnyReg src-                src_r <- getNewRegNat format-                let dst_r = getRegisterReg platform  (CmmLocal dst)-                return $ code_src src_r `appOL`-                    (if width == W8 then-                         -- The POPCNT instruction doesn't take a r/m8-                         unitOL (MOVZxL II8 (OpReg src_r) (OpReg src_r)) `appOL`-                         unitOL (POPCNT II16 (OpReg src_r) dst_r)-                     else-                         unitOL (POPCNT format (OpReg src_r) dst_r)) `appOL`-                    (if width == W8 || width == W16 then-                         -- We used a 16-bit destination register above,-                         -- so zero-extend-                         unitOL (MOVZxL II16 (OpReg dst_r) (OpReg dst_r))-                     else nilOL)-        else do-            targetExpr <- cmmMakeDynamicReference config-                          CallReference lbl-            let target = ForeignTarget targetExpr (ForeignConvention CCallConv-                                                           [NoHint] [NoHint]-                                                           CmmMayReturn)-            genCCall' config is32Bit target dest_regs args bid-  where-    format = intFormat width-    lbl = mkCmmCodeLabel primUnitId (fsLit (popCntLabel width))--genCCall' config is32Bit (PrimTarget (MO_Pdep width)) dest_regs@[dst]-         args@[src, mask] bid = do-    let platform = ncgPlatform config-    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`-                    (if width == W8 then-                         -- The PDEP instruction doesn't take a r/m8-                         unitOL (MOVZxL II8  (OpReg src_r ) (OpReg src_r )) `appOL`-                         unitOL (MOVZxL II8  (OpReg mask_r) (OpReg mask_r)) `appOL`-                         unitOL (PDEP   II16 (OpReg mask_r) (OpReg src_r ) dst_r)-                     else-                         unitOL (PDEP format (OpReg mask_r) (OpReg src_r) dst_r)) `appOL`-                    (if width == W8 || width == W16 then-                         -- We used a 16-bit destination register above,-                         -- so zero-extend-                         unitOL (MOVZxL II16 (OpReg dst_r) (OpReg dst_r))-                     else nilOL)-        else do-            targetExpr <- cmmMakeDynamicReference config-                          CallReference lbl-            let target = ForeignTarget targetExpr (ForeignConvention CCallConv-                                                           [NoHint] [NoHint]-                                                           CmmMayReturn)-            genCCall' config is32Bit target dest_regs args bid-  where-    format = intFormat width-    lbl = mkCmmCodeLabel primUnitId (fsLit (pdepLabel width))--genCCall' config is32Bit (PrimTarget (MO_Pext width)) dest_regs@[dst]-         args@[src, mask] bid = do-    let platform = ncgPlatform config-    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`-                    (if width == W8 then-                         -- The PEXT instruction doesn't take a r/m8-                         unitOL (MOVZxL II8 (OpReg src_r ) (OpReg src_r )) `appOL`-                         unitOL (MOVZxL II8 (OpReg mask_r) (OpReg mask_r)) `appOL`-                         unitOL (PEXT II16 (OpReg mask_r) (OpReg src_r) dst_r)-                     else-                         unitOL (PEXT format (OpReg mask_r) (OpReg src_r) dst_r)) `appOL`-                    (if width == W8 || width == W16 then-                         -- We used a 16-bit destination register above,-                         -- so zero-extend-                         unitOL (MOVZxL II16 (OpReg dst_r) (OpReg dst_r))-                     else nilOL)-        else do-            targetExpr <- cmmMakeDynamicReference config-                          CallReference lbl-            let target = ForeignTarget targetExpr (ForeignConvention CCallConv-                                                           [NoHint] [NoHint]-                                                           CmmMayReturn)-            genCCall' config is32Bit target dest_regs args bid-  where-    format = intFormat width-    lbl = mkCmmCodeLabel primUnitId (fsLit (pextLabel width))--genCCall' config is32Bit (PrimTarget (MO_Clz width)) dest_regs@[dst] args@[src] bid-  | is32Bit && width == W64 = do-    -- Fallback to `hs_clz64` on i386-    targetExpr <- cmmMakeDynamicReference config CallReference lbl-    let target = ForeignTarget targetExpr (ForeignConvention CCallConv-                                           [NoHint] [NoHint]-                                           CmmMayReturn)-    genCCall' config is32Bit target dest_regs args bid--  | otherwise = do-    code_src <- getAnyReg src-    config <- getConfig-    let platform = ncgPlatform config-    let dst_r = getRegisterReg platform (CmmLocal 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-            src_r <- getNewRegNat format-            tmp_r <- getNewRegNat format-            return $ code_src src_r `appOL` toOL-                     ([ MOVZxL  II8    (OpReg src_r) (OpReg src_r) | width == W8 ] ++-                      [ BSR     format (OpReg src_r) tmp_r-                      , MOV     II32   (OpImm (ImmInt (2*bw-1))) (OpReg dst_r)-                      , CMOV NE format (OpReg tmp_r) dst_r-                      , XOR     format (OpImm (ImmInt (bw-1))) (OpReg dst_r)-                      ]) -- NB: We don't need to zero-extend the result for the-                         -- W8/W16 cases because the 'MOV' insn already-                         -- took care of implicitly clearing the upper bits-  where-    bw = widthInBits width-    lbl = mkCmmCodeLabel primUnitId (fsLit (clzLabel width))--genCCall' config is32Bit (PrimTarget (MO_UF_Conv width)) dest_regs args bid = do-    targetExpr <- cmmMakeDynamicReference config-                  CallReference lbl-    let target = ForeignTarget targetExpr (ForeignConvention CCallConv-                                           [NoHint] [NoHint]-                                           CmmMayReturn)-    genCCall' config is32Bit target dest_regs args bid-  where-    lbl = mkCmmCodeLabel primUnitId (fsLit (word2FloatLabel width))--genCCall' _ _ (PrimTarget (MO_AtomicRead width)) [dst] [addr] _ = do-  load_code <- intLoadCode (MOV (intFormat width)) addr-  platform <- ncgPlatform <$> getConfig--  return (load_code (getRegisterReg platform  (CmmLocal dst)))--genCCall' _ _ (PrimTarget (MO_AtomicWrite width)) [] [addr, val] _ = do-    code <- assignMem_IntCode (intFormat width) addr val-    return $ code `snocOL` MFENCE--genCCall' _ is32Bit (PrimTarget (MO_Cmpxchg width)) [dst] [addr, old, new] _ = do-    -- On x86 we don't have enough registers to use cmpxchg with a-    -- complicated addressing mode, so on that architecture we-    -- pre-compute the address first.-    Amode amode addr_code <- getSimpleAmode is32Bit 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-  where-    format = intFormat width--genCCall' config is32Bit (PrimTarget (MO_Xchg width)) [dst] [addr, value] _-  | (is32Bit && width == W64) = panic "gencCall: 64bit atomic exchange not supported on 32bit platforms"-  | otherwise = do-    let dst_r = getRegisterReg platform (CmmLocal dst)-    Amode amode addr_code <- getSimpleAmode is32Bit addr-    (newval, newval_code) <- getSomeReg value-    -- 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-  where-    format = intFormat width-    platform = ncgPlatform config--genCCall' _ is32Bit target dest_regs args bid = do-  platform <- ncgPlatform <$> getConfig-  case (target, dest_regs) of-    -- void return type prim op-    (PrimTarget op, []) ->-        outOfLineCmmOp bid op Nothing args-    -- we only cope with a single result for foreign calls-    (PrimTarget op, [r])  -> case op of-          MO_F32_Fabs -> case args of-            [x] -> sse2FabsCode W32 x-            _ -> panic "genCCall: Wrong number of arguments for fabs"-          MO_F64_Fabs -> case args of-            [x] -> sse2FabsCode W64 x-            _ -> panic "genCCall: Wrong number of arguments for fabs"--          MO_F32_Sqrt -> actuallyInlineSSE2Op (\fmt r -> SQRT fmt (OpReg r)) FF32 args-          MO_F64_Sqrt -> actuallyInlineSSE2Op (\fmt r -> SQRT fmt (OpReg r)) FF64 args-          _other_op -> outOfLineCmmOp bid op (Just r) args--       where-        actuallyInlineSSE2Op = actuallyInlineFloatOp'--        actuallyInlineFloatOp'  instr format [x]-              = do res <- trivialUFCode format (instr format) x-                   any <- anyReg res-                   return (any (getRegisterReg platform  (CmmLocal r)))--        actuallyInlineFloatOp' _ _ args-              = panic $ "genCCall.actuallyInlineFloatOp': bad number of arguments! ("-                      ++ show (length args) ++ ")"--        sse2FabsCode :: Width -> CmmExpr -> NatM InstrBlock-        sse2FabsCode w x = do-          let fmt = floatFormat w-          x_code <- getAnyReg x-          let-            const | FF32 <- fmt = CmmInt 0x7fffffff W32-                  | otherwise   = CmmInt 0x7fffffffffffffff W64-          Amode amode amode_code <- memConstant (mkAlignment $ widthInBytes w) const-          tmp <- getNewRegNat fmt-          let-            code dst = x_code dst `appOL` amode_code `appOL` toOL [-                MOV fmt (OpAddr amode) (OpReg tmp),-                AND fmt (OpReg tmp) (OpReg dst)-                ]--          return $ code (getRegisterReg platform (CmmLocal r))--    (PrimTarget (MO_S_QuotRem  width), _) -> divOp1 platform True  width dest_regs args-    (PrimTarget (MO_U_QuotRem  width), _) -> divOp1 platform False width dest_regs args-    (PrimTarget (MO_U_QuotRem2 width), _) -> divOp2 platform False width dest_regs args-    (PrimTarget (MO_Add2 width), [res_h, res_l]) ->-        case args of-        [arg_x, arg_y] ->-            do hCode <- getAnyReg (CmmLit (CmmInt 0 width))-               let format = intFormat width-               lCode <- anyReg =<< trivialCode width (ADD_CC format)-                                     (Just (ADD_CC format)) arg_x arg_y-               let reg_l = getRegisterReg platform (CmmLocal res_l)-                   reg_h = getRegisterReg platform (CmmLocal res_h)-                   code = hCode reg_h `appOL`-                          lCode reg_l `snocOL`-                          ADC format (OpImm (ImmInteger 0)) (OpReg reg_h)-               return code-        _ -> panic "genCCall: Wrong number of arguments/results for add2"-    (PrimTarget (MO_AddWordC width), [res_r, res_c]) ->-        addSubIntC platform ADD_CC (const Nothing) CARRY width res_r res_c args-    (PrimTarget (MO_SubWordC width), [res_r, res_c]) ->-        addSubIntC platform SUB_CC (const Nothing) CARRY width res_r res_c args-    (PrimTarget (MO_AddIntC width), [res_r, res_c]) ->-        addSubIntC platform ADD_CC (Just . ADD_CC) OFLO width res_r res_c args-    (PrimTarget (MO_SubIntC width), [res_r, res_c]) ->-        addSubIntC platform SUB_CC (const Nothing) OFLO width res_r res_c args-    (PrimTarget (MO_U_Mul2 width), [res_h, res_l]) ->-        case args of-        [arg_x, arg_y] ->-            do (y_reg, y_code) <- getRegOrMem arg_y-               x_code <- getAnyReg arg_x-               let format = intFormat width-                   reg_h = getRegisterReg platform (CmmLocal res_h)-                   reg_l = getRegisterReg platform (CmmLocal res_l)-                   code = y_code `appOL`-                          x_code rax `appOL`-                          toOL [MUL2 format y_reg,-                                MOV format (OpReg rdx) (OpReg reg_h),-                                MOV format (OpReg rax) (OpReg reg_l)]-               return code-        _ -> panic "genCCall: Wrong number of arguments/results for mul2"-    (PrimTarget (MO_S_Mul2 width), [res_c, res_h, res_l]) ->-        case args of-        [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 = getRegisterReg platform (CmmLocal res_h)-                   reg_l = getRegisterReg platform (CmmLocal res_l)-                   reg_c = getRegisterReg platform (CmmLocal 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-        _ -> panic "genCCall: Wrong number of arguments/results for imul2"--    _ -> do-        (instrs0, args') <- evalArgs bid args-        instrs1 <- if is32Bit-          then genCCall32' target dest_regs args'-          else genCCall64' target dest_regs args'-        return (instrs0 `appOL` instrs1)--  where divOp1 platform signed width results [arg_x, arg_y]-            = divOp platform signed width results Nothing arg_x arg_y-        divOp1 _ _ _ _ _-            = panic "genCCall: Wrong number of arguments for divOp1"-        divOp2 platform signed width results [arg_x_high, arg_x_low, arg_y]-            = divOp platform signed width results (Just arg_x_high) arg_x_low arg_y-        divOp2 _ _ _ _ _-            = panic "genCCall: Wrong number of arguments for divOp2"--        -- See Note [DIV/IDIV for bytes]-        divOp platform signed W8 [res_q, res_r] m_arg_x_high arg_x_low arg_y =-            let widen | signed = MO_SS_Conv W8 W16-                      | otherwise = MO_UU_Conv W8 W16-                arg_x_low_16 = CmmMachOp widen [arg_x_low]-                arg_y_16 = CmmMachOp widen [arg_y]-                m_arg_x_high_16 = (\p -> CmmMachOp widen [p]) <$> m_arg_x_high-            in divOp-                  platform signed W16 [res_q, res_r]-                  m_arg_x_high_16 arg_x_low_16 arg_y_16--        divOp platform signed width [res_q, res_r]-              m_arg_x_high arg_x_low arg_y-            = do let format = intFormat width-                     reg_q = getRegisterReg platform (CmmLocal res_q)-                     reg_r = getRegisterReg platform (CmmLocal res_r)-                     widen | signed    = CLTD format-                           | otherwise = XOR format (OpReg rdx) (OpReg rdx)-                     instr | signed    = IDIV-                           | otherwise = DIV-                 (y_reg, y_code) <- getRegOrMem arg_y-                 x_low_code <- getAnyReg arg_x_low-                 x_high_code <- case m_arg_x_high of-                                Just arg_x_high ->-                                    getAnyReg arg_x_high-                                Nothing ->-                                    return $ const $ unitOL widen-                 return $ y_code `appOL`-                          x_low_code rax `appOL`-                          x_high_code rdx `appOL`-                          toOL [instr format y_reg,-                                MOV format (OpReg rax) (OpReg reg_q),-                                MOV format (OpReg rdx) (OpReg reg_r)]-        divOp _ _ _ _ _ _ _-            = panic "genCCall: Wrong number of results for divOp"--        addSubIntC platform instr mrevinstr cond width-                   res_r res_c [arg_x, arg_y]-            = do let format = intFormat width-                 rCode <- anyReg =<< trivialCode width (instr format)-                                       (mrevinstr format) arg_x arg_y-                 reg_tmp <- getNewRegNat II8-                 let reg_c = getRegisterReg platform  (CmmLocal res_c)-                     reg_r = getRegisterReg platform  (CmmLocal res_r)-                     code = rCode reg_r `snocOL`-                            SETCC cond (OpReg reg_tmp) `snocOL`-                            MOVZxL II8 (OpReg reg_tmp) (OpReg reg_c)--                 return code-        addSubIntC _ _ _ _ _ _ _ _-            = panic "genCCall: Wrong number of arguments/results for addSubIntC"--{--Note [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) since outOfLineCmmOp produces the call via-(stmtToInstrs (CmmUnsafeForeignCall ...)), which will ultimately end up-back in genCCall{32,64}.--}---- | See Note [Evaluate C-call arguments before placing in destination registers]-evalArgs :: BlockId -> [CmmActual] -> NatM (InstrBlock, [CmmActual])-evalArgs bid actuals-  | any mightContainMachOp actuals = do-      regs_blks <- mapM evalArg actuals-      return (concatOL $ map fst regs_blks, map snd regs_blks)-  | otherwise = return (nilOL, actuals)-  where-    mightContainMachOp (CmmReg _)      = False-    mightContainMachOp (CmmRegOff _ _) = False-    mightContainMachOp (CmmLit _)      = False-    mightContainMachOp _               = True--    evalArg :: CmmActual -> NatM (InstrBlock, CmmExpr)-    evalArg actual = do-        platform <- getPlatform-        lreg <- newLocalReg $ cmmExprType platform actual-        (instrs, bid1) <- stmtToInstrs bid $ CmmAssign (CmmLocal lreg) actual-        -- The above assignment shouldn't change the current block-        MASSERT(isNothing bid1)-        return (instrs, CmmReg $ CmmLocal lreg)--    newLocalReg :: CmmType -> NatM LocalReg-    newLocalReg ty = LocalReg <$> getUniqueM <*> pure ty---- Note [DIV/IDIV for bytes]------ IDIV reminder:---   Size    Dividend   Divisor   Quotient    Remainder---   byte    %ax         r/m8      %al          %ah---   word    %dx:%ax     r/m16     %ax          %dx---   dword   %edx:%eax   r/m32     %eax         %edx---   qword   %rdx:%rax   r/m64     %rax         %rdx------ We do a special case for the byte division because the current--- codegen doesn't deal well with accessing %ah register (also,--- accessing %ah in 64-bit mode is complicated because it cannot be an--- operand of many instructions). So we just widen operands to 16 bits--- and get the results from %al, %dl. This is not optimal, but a few--- register moves are probably not a huge deal when doing division.--genCCall32' :: ForeignTarget            -- function to call-            -> [CmmFormal]        -- where to put the result-            -> [CmmActual]        -- arguments (of mixed type)-            -> NatM InstrBlock-genCCall32' target dest_regs args = do-        config <- getConfig-        let platform = ncgPlatform config-            prom_args = map (maybePromoteCArg platform W32) args--            -- If the size is smaller than the word, we widen things (see maybePromoteCArg)-            arg_size_bytes :: CmmType -> Int-            arg_size_bytes ty = max (widthInBytes (typeWidth ty)) (widthInBytes (wordWidth platform))--            roundTo a x | x `mod` a == 0 = x-                        | otherwise = x + a - (x `mod` a)--            push_arg :: CmmActual {-current argument-}-                            -> NatM InstrBlock  -- code--            push_arg  arg -- we don't need the hints on x86-              | isWord64 arg_ty = do-                ChildCode64 code r_lo <- iselExpr64 arg-                delta <- getDeltaNat-                setDeltaNat (delta - 8)-                let r_hi = getHiVRegFromLo r_lo-                return (       code `appOL`-                               toOL [PUSH II32 (OpReg r_hi), DELTA (delta - 4),-                                     PUSH II32 (OpReg r_lo), DELTA (delta - 8),-                                     DELTA (delta-8)]-                    )--              | isFloatType arg_ty = do-                (reg, code) <- getSomeReg arg-                delta <- getDeltaNat-                setDeltaNat (delta-size)-                return (code `appOL`-                                toOL [SUB II32 (OpImm (ImmInt size)) (OpReg esp),-                                      DELTA (delta-size),-                                      let addr = AddrBaseIndex (EABaseReg esp)-                                                                EAIndexNone-                                                                (ImmInt 0)-                                          format = floatFormat (typeWidth arg_ty)-                                      in--                                      -- assume SSE2-                                       MOV format (OpReg reg) (OpAddr addr)--                                     ]-                               )--              | otherwise = do-                -- Arguments can be smaller than 32-bit, but we still use @PUSH-                -- II32@ - the usual calling conventions expect integers to be-                -- 4-byte aligned.-                ASSERT((typeWidth arg_ty) <= W32) return ()-                (operand, code) <- getOperand arg-                delta <- getDeltaNat-                setDeltaNat (delta-size)-                return (code `snocOL`-                        PUSH II32 operand `snocOL`-                        DELTA (delta-size))--              where-                 arg_ty = cmmExprType platform arg-                 size = arg_size_bytes arg_ty -- Byte size--        let-            -- Align stack to 16n for calls, assuming a starting stack-            -- alignment of 16n - word_size on procedure entry. Which we-            -- maintiain. See Note [rts/StgCRun.c : Stack Alignment on X86]-            sizes               = map (arg_size_bytes . cmmExprType platform) (reverse args)-            raw_arg_size        = sum sizes + platformWordSizeInBytes platform-            arg_pad_size        = (roundTo 16 $ raw_arg_size) - raw_arg_size-            tot_arg_size        = raw_arg_size + arg_pad_size - platformWordSizeInBytes platform---        delta0 <- getDeltaNat-        setDeltaNat (delta0 - arg_pad_size)--        push_codes <- mapM push_arg (reverse prom_args)-        delta <- getDeltaNat-        MASSERT(delta == delta0 - tot_arg_size)--        -- deal with static vs dynamic call targets-        (callinsns,cconv) <--          case target of-            ForeignTarget (CmmLit (CmmLabel lbl)) conv-               -> -- ToDo: stdcall arg sizes-                  return (unitOL (CALL (Left fn_imm) []), conv)-               where fn_imm = ImmCLbl lbl-            ForeignTarget expr conv-               -> do { (dyn_r, dyn_c) <- getSomeReg expr-                     ; ASSERT( isWord32 (cmmExprType platform expr) )-                       return (dyn_c `snocOL` CALL (Right dyn_r) [], conv) }-            PrimTarget _-                -> panic $ "genCCall: Can't handle PrimTarget call type here, error "-                            ++ "probably because too many return values."--        let push_code-                | arg_pad_size /= 0-                = toOL [SUB II32 (OpImm (ImmInt arg_pad_size)) (OpReg esp),-                        DELTA (delta0 - arg_pad_size)]-                  `appOL` concatOL push_codes-                | otherwise-                = concatOL push_codes--              -- Deallocate parameters after call for ccall;-              -- but not for stdcall (callee does it)-              ---              -- We have to pop any stack padding we added-              -- even if we are doing stdcall, though (#5052)-            pop_size-               | ForeignConvention StdCallConv _ _ _ <- cconv = arg_pad_size-               | otherwise = tot_arg_size--            call = callinsns `appOL`-                   toOL (-                      (if pop_size==0 then [] else-                       [ADD II32 (OpImm (ImmInt pop_size)) (OpReg esp)])-                      ++-                      [DELTA delta0]-                   )-        setDeltaNat delta0--        let-            -- assign the results, if necessary-            assign_code []     = nilOL-            assign_code [dest]-              | isFloatType ty =-                  -- we assume SSE2-                  let tmp_amode = AddrBaseIndex (EABaseReg esp)-                                                       EAIndexNone-                                                       (ImmInt 0)-                      fmt = floatFormat w-                         in toOL [ SUB II32 (OpImm (ImmInt b)) (OpReg esp),-                                   DELTA (delta0 - b),-                                   X87Store fmt  tmp_amode,-                                   -- X87Store only supported for the CDECL ABI-                                   -- NB: This code will need to be-                                   -- revisited once GHC does more work around-                                   -- SIGFPE f-                                   MOV fmt (OpAddr tmp_amode) (OpReg r_dest),-                                   ADD II32 (OpImm (ImmInt b)) (OpReg esp),-                                   DELTA delta0]-              | isWord64 ty    = toOL [MOV II32 (OpReg eax) (OpReg r_dest),-                                        MOV II32 (OpReg edx) (OpReg r_dest_hi)]-              | otherwise      = unitOL (MOV (intFormat w)-                                             (OpReg eax)-                                             (OpReg r_dest))-              where-                    ty = localRegType dest-                    w  = typeWidth ty-                    b  = widthInBytes w-                    r_dest_hi = getHiVRegFromLo r_dest-                    r_dest    = getRegisterReg platform (CmmLocal dest)-            assign_code many = pprPanic "genCCall.assign_code - too many return values:" (ppr many)--        return (push_code `appOL`-                call `appOL`-                assign_code dest_regs)--genCCall64' :: ForeignTarget      -- function to call-            -> [CmmFormal]        -- where to put the result-            -> [CmmActual]        -- arguments (of mixed type)-            -> NatM InstrBlock-genCCall64' target dest_regs args = do-    platform <- getPlatform-    -- load up the register arguments-    let prom_args = map (maybePromoteCArg platform W32) args--    let load_args :: [CmmExpr]-                  -> [Reg]         -- int regs avail for args-                  -> [Reg]         -- FP regs avail for args-                  -> InstrBlock    -- code computing args-                  -> InstrBlock    -- code assigning args to ABI regs-                  -> NatM ([CmmExpr],[Reg],[Reg],InstrBlock,InstrBlock)-        -- no more regs to use-        load_args args [] [] code acode     =-            return (args, [], [], code, acode)--        -- no more args to push-        load_args [] aregs fregs code acode =-            return ([], aregs, fregs, code, acode)--        load_args (arg : rest) aregs fregs code acode-            | isFloatType arg_rep = case fregs of-                 []     -> push_this_arg-                 (r:rs) -> do-                    (code',acode') <- reg_this_arg r-                    load_args rest aregs rs code' acode'-            | otherwise           = case aregs of-                 []     -> push_this_arg-                 (r:rs) -> do-                    (code',acode') <- reg_this_arg r-                    load_args rest rs fregs code' acode'-            where--              -- put arg into the list of stack pushed args-              push_this_arg = do-                 (args',ars,frs,code',acode')-                     <- load_args rest aregs fregs code acode-                 return (arg:args', ars, frs, code', acode')--              -- pass the arg into the given register-              reg_this_arg r-                -- "operand" args can be directly assigned into r-                | isOperand False arg = do-                    arg_code <- getAnyReg arg-                    return (code, (acode `appOL` arg_code r))-                -- The last non-operand arg can be directly assigned after its-                -- computation without going into a temporary register-                | all (isOperand False) rest = do-                    arg_code   <- getAnyReg arg-                    return (code `appOL` arg_code r,acode)--                -- other args need to be computed beforehand to avoid clobbering-                -- previously assigned registers used to pass parameters (see-                -- #11792, #12614). They are assigned into temporary registers-                -- and get assigned to proper call ABI registers after they all-                -- have been computed.-                | otherwise     = do-                    arg_code <- getAnyReg arg-                    tmp      <- getNewRegNat arg_fmt-                    let-                      code'  = code `appOL` arg_code tmp-                      acode' = acode `snocOL` reg2reg arg_fmt tmp r-                    return (code',acode')--              arg_rep = cmmExprType platform arg-              arg_fmt = cmmTypeFormat arg_rep--        load_args_win :: [CmmExpr]-                      -> [Reg]        -- used int regs-                      -> [Reg]        -- used FP regs-                      -> [(Reg, Reg)] -- (int, FP) regs avail for args-                      -> InstrBlock-                      -> NatM ([CmmExpr],[Reg],[Reg],InstrBlock,InstrBlock)-        load_args_win args usedInt usedFP [] code-            = return (args, usedInt, usedFP, code, nilOL)-            -- no more regs to use-        load_args_win [] usedInt usedFP _ code-            = return ([], usedInt, usedFP, code, nilOL)-            -- no more args to push-        load_args_win (arg : rest) usedInt usedFP-                      ((ireg, freg) : regs) code-            | isFloatType arg_rep = do-                 arg_code <- getAnyReg arg-                 load_args_win rest (ireg : usedInt) (freg : usedFP) regs-                               (code `appOL`-                                arg_code freg `snocOL`-                                -- If we are calling a varargs function-                                -- then we need to define ireg as well-                                -- as freg-                                MOV II64 (OpReg freg) (OpReg ireg))-            | otherwise = do-                 arg_code <- getAnyReg arg-                 load_args_win rest (ireg : usedInt) usedFP regs-                               (code `appOL` arg_code ireg)-            where-              arg_rep = cmmExprType platform arg--        arg_size = 8 -- always, at the mo--        push_args [] code = return code-        push_args (arg:rest) code-           | isFloatType arg_rep = do-             (arg_reg, arg_code) <- getSomeReg arg-             delta <- getDeltaNat-             setDeltaNat (delta-arg_size)-             let code' = code `appOL` arg_code `appOL` toOL [-                            SUB (intFormat (wordWidth platform)) (OpImm (ImmInt arg_size)) (OpReg rsp),-                            DELTA (delta-arg_size),-                            MOV (floatFormat width) (OpReg arg_reg) (OpAddr (spRel platform 0))]-             push_args rest code'--           | otherwise = do-             -- Arguments can be smaller than 64-bit, but we still use @PUSH-             -- II64@ - the usual calling conventions expect integers to be-             -- 8-byte aligned.-             ASSERT(width <= W64) return ()-             (arg_op, arg_code) <- getOperand arg-             delta <- getDeltaNat-             setDeltaNat (delta-arg_size)-             let code' = code `appOL` arg_code `appOL` toOL [-                                    PUSH II64 arg_op,-                                    DELTA (delta-arg_size)]-             push_args rest code'-            where-              arg_rep = cmmExprType platform arg-              width = typeWidth arg_rep--        leaveStackSpace n = do-             delta <- getDeltaNat-             setDeltaNat (delta - n * arg_size)-             return $ toOL [-                         SUB II64 (OpImm (ImmInt (n * platformWordSizeInBytes platform))) (OpReg rsp),-                         DELTA (delta - n * arg_size)]--    (stack_args, int_regs_used, fp_regs_used, load_args_code, assign_args_code)-         <--        if platformOS platform == OSMinGW32-        then load_args_win prom_args [] [] (allArgRegs platform) nilOL-        else do-           (stack_args, aregs, fregs, load_args_code, assign_args_code)-               <- load_args prom_args (allIntArgRegs platform)-                                      (allFPArgRegs platform)-                                      nilOL nilOL-           let used_regs rs as = reverse (drop (length rs) (reverse as))-               fregs_used      = used_regs fregs (allFPArgRegs platform)-               aregs_used      = used_regs aregs (allIntArgRegs platform)-           return (stack_args, aregs_used, fregs_used, load_args_code-                                                      , assign_args_code)--    let-        arg_regs_used = int_regs_used ++ fp_regs_used-        arg_regs = [eax] ++ arg_regs_used-                -- for annotating the call instruction with-        sse_regs = length fp_regs_used-        arg_stack_slots = if platformOS platform == OSMinGW32-                          then length stack_args + length (allArgRegs platform)-                          else length stack_args-        tot_arg_size = arg_size * arg_stack_slots---    -- Align stack to 16n for calls, assuming a starting stack-    -- alignment of 16n - word_size on procedure entry. Which we-    -- maintain. See Note [rts/StgCRun.c : Stack Alignment on X86]-    let word_size = platformWordSizeInBytes platform-    (real_size, adjust_rsp) <--        if (tot_arg_size + word_size) `rem` 16 == 0-            then return (tot_arg_size, nilOL)-            else do -- we need to adjust...-                delta <- getDeltaNat-                setDeltaNat (delta - word_size)-                return (tot_arg_size + word_size, toOL [-                                SUB II64 (OpImm (ImmInt word_size)) (OpReg rsp),-                                DELTA (delta - word_size) ])--    -- push the stack args, right to left-    push_code <- push_args (reverse stack_args) nilOL-    -- On Win64, we also have to leave stack space for the arguments-    -- that we are passing in registers-    lss_code <- if platformOS platform == OSMinGW32-                then leaveStackSpace (length (allArgRegs platform))-                else return nilOL-    delta <- getDeltaNat--    -- deal with static vs dynamic call targets-    (callinsns,_cconv) <--      case target of-        ForeignTarget (CmmLit (CmmLabel lbl)) conv-           -> -- ToDo: stdcall arg sizes-              return (unitOL (CALL (Left fn_imm) arg_regs), conv)-           where fn_imm = ImmCLbl lbl-        ForeignTarget expr conv-           -> do (dyn_r, dyn_c) <- getSomeReg expr-                 return (dyn_c `snocOL` CALL (Right dyn_r) arg_regs, conv)-        PrimTarget _-            -> panic $ "genCCall: Can't handle PrimTarget call type here, error "-                        ++ "probably because too many return values."--    let-        -- The x86_64 ABI requires us to set %al to the number of SSE2-        -- registers that contain arguments, if the called routine-        -- is a varargs function.  We don't know whether it's a-        -- varargs function or not, so we have to assume it is.-        ---        -- It's not safe to omit this assignment, even if the number-        -- of SSE2 regs in use is zero.  If %al is larger than 8-        -- on entry to a varargs function, seg faults ensue.-        assign_eax n = unitOL (MOV II32 (OpImm (ImmInt n)) (OpReg eax))--    let call = callinsns `appOL`-               toOL (-                    -- Deallocate parameters after call for ccall;-                    -- stdcall has callee do it, but is not supported on-                    -- x86_64 target (see #3336)-                  (if real_size==0 then [] else-                   [ADD (intFormat (platformWordWidth platform)) (OpImm (ImmInt real_size)) (OpReg esp)])-                  ++-                  [DELTA (delta + real_size)]-               )-    setDeltaNat (delta + real_size)--    let-        -- assign the results, if necessary-        assign_code []     = nilOL-        assign_code [dest] =-          case typeWidth rep of-                W32 | isFloatType rep -> unitOL (MOV (floatFormat W32)-                                                     (OpReg xmm0)-                                                     (OpReg r_dest))-                W64 | isFloatType rep -> unitOL (MOV (floatFormat W64)-                                                     (OpReg xmm0)-                                                     (OpReg r_dest))-                _ -> unitOL (MOV (cmmTypeFormat rep) (OpReg rax) (OpReg r_dest))-          where-                rep = localRegType dest-                r_dest = getRegisterReg platform  (CmmLocal dest)-        assign_code _many = panic "genCCall.assign_code many"--    return (adjust_rsp          `appOL`-            push_code           `appOL`-            load_args_code      `appOL`-            assign_args_code    `appOL`-            lss_code            `appOL`-            assign_eax sse_regs `appOL`-            call                `appOL`-            assign_code dest_regs)---maybePromoteCArg :: Platform -> Width -> CmmExpr -> CmmExpr-maybePromoteCArg platform wto arg- | wfrom < wto = CmmMachOp (MO_UU_Conv wfrom wto) [arg]- | otherwise   = arg- where-   wfrom = cmmExprWidth platform arg--outOfLineCmmOp :: BlockId -> CallishMachOp -> Maybe CmmFormal -> [CmmActual]-               -> NatM InstrBlock-outOfLineCmmOp bid mop res args-  = do-      config <- getConfig-      targetExpr <- cmmMakeDynamicReference config CallReference lbl-      let target = ForeignTarget targetExpr-                           (ForeignConvention CCallConv [] [] CmmMayReturn)--      -- We know foreign calls results in no new basic blocks, so we can ignore-      -- the returned block id.-      (instrs, _) <- stmtToInstrs bid (CmmUnsafeForeignCall target (catMaybes [res]) args)-      return instrs-  where-        -- Assume we can call these functions directly, and that they're not in a dynamic library.-        -- TODO: Why is this ok? Under linux this code will be in libm.so-        --       Is it because they're really implemented as a primitive instruction by the assembler??  -- BL 2009/12/31-        lbl = mkForeignLabel fn Nothing ForeignLabelInThisPackage IsFunction--        fn = case mop of-              MO_F32_Sqrt  -> fsLit "sqrtf"-              MO_F32_Fabs  -> fsLit "fabsf"-              MO_F32_Sin   -> fsLit "sinf"-              MO_F32_Cos   -> fsLit "cosf"-              MO_F32_Tan   -> fsLit "tanf"-              MO_F32_Exp   -> fsLit "expf"-              MO_F32_ExpM1 -> fsLit "expm1f"-              MO_F32_Log   -> fsLit "logf"-              MO_F32_Log1P -> fsLit "log1pf"--              MO_F32_Asin  -> fsLit "asinf"-              MO_F32_Acos  -> fsLit "acosf"-              MO_F32_Atan  -> fsLit "atanf"--              MO_F32_Sinh  -> fsLit "sinhf"-              MO_F32_Cosh  -> fsLit "coshf"-              MO_F32_Tanh  -> fsLit "tanhf"-              MO_F32_Pwr   -> fsLit "powf"--              MO_F32_Asinh -> fsLit "asinhf"-              MO_F32_Acosh -> fsLit "acoshf"-              MO_F32_Atanh -> fsLit "atanhf"--              MO_F64_Sqrt  -> fsLit "sqrt"-              MO_F64_Fabs  -> fsLit "fabs"-              MO_F64_Sin   -> fsLit "sin"-              MO_F64_Cos   -> fsLit "cos"-              MO_F64_Tan   -> fsLit "tan"-              MO_F64_Exp   -> fsLit "exp"-              MO_F64_ExpM1 -> fsLit "expm1"-              MO_F64_Log   -> fsLit "log"-              MO_F64_Log1P -> fsLit "log1p"--              MO_F64_Asin  -> fsLit "asin"-              MO_F64_Acos  -> fsLit "acos"-              MO_F64_Atan  -> fsLit "atan"--              MO_F64_Sinh  -> fsLit "sinh"-              MO_F64_Cosh  -> fsLit "cosh"-              MO_F64_Tanh  -> fsLit "tanh"-              MO_F64_Pwr   -> fsLit "pow"--              MO_F64_Asinh  -> fsLit "asinh"-              MO_F64_Acosh  -> fsLit "acosh"-              MO_F64_Atanh  -> fsLit "atanh"--              MO_I64_ToI   -> fsLit "hs_int64ToInt"-              MO_I64_FromI -> fsLit "hs_intToInt64"-              MO_W64_ToW   -> fsLit "hs_word64ToWord"-              MO_W64_FromW -> fsLit "hs_wordToWord64"-              MO_x64_Neg   -> fsLit "hs_neg64"-              MO_x64_Add   -> fsLit "hs_add64"-              MO_x64_Sub   -> fsLit "hs_sub64"-              MO_x64_Mul   -> fsLit "hs_mul64"-              MO_I64_Quot  -> fsLit "hs_quotInt64"-              MO_I64_Rem   -> fsLit "hs_remInt64"-              MO_W64_Quot  -> fsLit "hs_quotWord64"-              MO_W64_Rem   -> fsLit "hs_remWord64"-              MO_x64_And   -> fsLit "hs_and64"-              MO_x64_Or    -> fsLit "hs_or64"-              MO_x64_Xor   -> fsLit "hs_xor64"-              MO_x64_Not   -> fsLit "hs_not64"-              MO_x64_Shl   -> fsLit "hs_uncheckedShiftL64"-              MO_I64_Shr   -> fsLit "hs_uncheckedIShiftRA64"-              MO_W64_Shr   -> fsLit "hs_uncheckedShiftRL64"-              MO_x64_Eq    -> fsLit "hs_eq64"-              MO_x64_Ne    -> fsLit "hs_ne64"-              MO_I64_Ge    -> fsLit "hs_geInt64"-              MO_I64_Gt    -> fsLit "hs_gtInt64"-              MO_I64_Le    -> fsLit "hs_leInt64"-              MO_I64_Lt    -> fsLit "hs_ltInt64"-              MO_W64_Ge    -> fsLit "hs_geWord64"-              MO_W64_Gt    -> fsLit "hs_gtWord64"-              MO_W64_Le    -> fsLit "hs_leWord64"-              MO_W64_Lt    -> fsLit "hs_ltWord64"--              MO_Memcpy _  -> fsLit "memcpy"-              MO_Memset _  -> fsLit "memset"-              MO_Memmove _ -> fsLit "memmove"-              MO_Memcmp _  -> fsLit "memcmp"--              MO_PopCnt _  -> fsLit "popcnt"-              MO_BSwap _   -> fsLit "bswap"-              {- Here the C implementation is used as there is no x86-              instruction to reverse a word's bit order.-              -}-              MO_BRev w    -> fsLit $ bRevLabel w-              MO_Clz w     -> fsLit $ clzLabel w-              MO_Ctz _     -> unsupported--              MO_Pdep w    -> fsLit $ pdepLabel w-              MO_Pext w    -> fsLit $ pextLabel w--              MO_AtomicRMW _ _ -> fsLit "atomicrmw"-              MO_AtomicRead _  -> fsLit "atomicread"-              MO_AtomicWrite _ -> fsLit "atomicwrite"-              MO_Cmpxchg _     -> fsLit "cmpxchg"-              MO_Xchg _        -> should_be_inline--              MO_UF_Conv _ -> unsupported--              MO_S_Mul2    {}  -> unsupported-              MO_S_QuotRem {}  -> unsupported-              MO_U_QuotRem {}  -> unsupported-              MO_U_QuotRem2 {} -> unsupported-              MO_Add2 {}       -> unsupported-              MO_AddIntC {}    -> unsupported-              MO_SubIntC {}    -> unsupported-              MO_AddWordC {}   -> unsupported-              MO_SubWordC {}   -> unsupported-              MO_U_Mul2 {}     -> unsupported-              MO_ReadBarrier   -> unsupported-              MO_WriteBarrier  -> unsupported-              MO_Touch         -> unsupported-              (MO_Prefetch_Data _ ) -> unsupported-        unsupported = panic ("outOfLineCmmOp: " ++ show mop-                          ++ " not supported here")-        -- If we generate a call for the given primop-        -- something went wrong.-        should_be_inline = panic ("outOfLineCmmOp: " ++ show mop-                          ++ " should be handled inline")----- -------------------------------------------------------------------------------- Generating a table-branch--genSwitch :: CmmExpr -> SwitchTargets -> NatM InstrBlock--genSwitch expr targets = do-  config <- getConfig-  let platform = ncgPlatform config-  if ncgPIC config-  then do-        (reg,e_code) <- getNonClobberedReg (cmmOffset platform expr offset)-           -- 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))--        offsetReg <- getNewRegNat (intFormat (platformWordWidth platform))-        return $ if is32bit || os == OSDarwin-                 then e_code `appOL` t_code `appOL` toOL [-                                ADD (intFormat (platformWordWidth platform)) op (OpReg tableReg),-                                JMP_TBL (OpReg tableReg) ids rosection lbl-                       ]-                 else -- HACK: On x86_64 binutils<2.17 is only able to generate-                      -- PC32 relocations, hence we only get 32-bit offsets in-                      -- the jump table. As these offsets are always negative-                      -- we need to properly sign extend them to 64-bit. This-                      -- hack should be removed in conjunction with the hack in-                      -- PprMach.hs/pprDataItem once binutils 2.17 is standard.-                      e_code `appOL` t_code `appOL` toOL [-                               MOVSxL II32 op (OpReg offsetReg),-                               ADD (intFormat (platformWordWidth platform))-                                   (OpReg offsetReg)-                                   (OpReg tableReg),-                               JMP_TBL (OpReg tableReg) ids rosection lbl-                       ]-  else do-        (reg,e_code) <- getSomeReg (cmmOffset platform expr offset)-        lbl <- getNewLabelNat-        let op = OpAddr (AddrBaseIndex EABaseNone (EAIndex reg (platformWordSizeInBytes platform)) (ImmCLbl lbl))-            code = e_code `appOL` toOL [-                    JMP_TBL op ids (Section ReadOnlyData lbl) lbl-                 ]-        return code-  where-    (offset, blockIds) = switchTargetsToTable targets-    ids = map (fmap DestBlockId) blockIds--generateJumpTableForInstr :: 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 predidiction system--- and plays better with the uOP cache.--condFltReg :: Bool -> Cond -> CmmExpr -> CmmExpr -> NatM Register-condFltReg is32Bit cond x y = condFltReg_sse2- where---  condFltReg_sse2 = do-    CondCode _ cond cond_code <- condFltCode cond x y-    tmp1 <- getNewRegNat (archWordFormat is32Bit)-    tmp2 <- getNewRegNat (archWordFormat is32Bit)-    let -- See Note [SSE Parity Checks]-        code dst =-           cond_code `appOL`-             (case cond of-                NE  -> or_unordered dst-                GU  -> plain_test   dst-                GEU -> plain_test   dst-                -- Use ASSERT so we don't break releases if these creep in.-                LTT -> ASSERT2(False, ppr "Should have been turned into >")-                       and_ordered  dst-                LE  -> ASSERT2(False, ppr "Should have been turned into >=")-                       and_ordered  dst-                _   -> and_ordered  dst)--        plain_test dst = toOL [-                    SETCC cond (OpReg tmp1),-                    MOVZxL II8 (OpReg tmp1) (OpReg dst)-                 ]-        or_unordered dst = toOL [-                    SETCC cond (OpReg tmp1),-                    SETCC PARITY (OpReg tmp2),-                    OR II8 (OpReg tmp1) (OpReg tmp2),-                    MOVZxL II8 (OpReg tmp2) (OpReg dst)-                  ]-        and_ordered dst = toOL [-                    SETCC cond (OpReg tmp1),-                    SETCC NOTPARITY (OpReg tmp2),-                    AND II8 (OpReg tmp1) (OpReg tmp2),-                    MOVZxL II8 (OpReg tmp2) (OpReg dst)-                  ]-    return (Any II32 code)----- -------------------------------------------------------------------------------- 'trivial*Code': deal with trivial instructions---- Trivial (dyadic: 'trivialCode', floating-point: 'trivialFCode',--- unary: 'trivialUCode', unary fl-pt:'trivialUFCode') instructions.--- Only look for constants on the right hand side, because that's--- where the generic optimizer will have put them.---- Similarly, for unary instructions, we don't have to worry about--- matching an StInt as the argument, because genericOpt will already--- have handled the constant-folding.---{--The Rules of the Game are:--* You cannot assume anything about the destination register dst;-  it may be anything, including a fixed reg.--* You may compute an operand into a fixed reg, but you may not-  subsequently change the contents of that fixed reg.  If you-  want to do so, first copy the value either to a temporary-  or into dst.  You are free to modify dst even if it happens-  to be a fixed reg -- that's not your problem.--* You cannot assume that a fixed reg will stay live over an-  arbitrary computation.  The same applies to the dst reg.--* Temporary regs obtained from getNewRegNat are distinct from-  each other and from all other regs, and stay live over-  arbitrary computations.------------------------SDM's version of The Rules:--* If getRegister returns Any, that means it can generate correct-  code which places the result in any register, period.  Even if that-  register happens to be read during the computation.--  Corollary #1: this means that if you are generating code for an-  operation with two arbitrary operands, you cannot assign the result-  of the first operand into the destination register before computing-  the second operand.  The second operand might require the old value-  of the destination register.--  Corollary #2: A function might be able to generate more efficient-  code if it knows the destination register is a new temporary (and-  therefore not read by any of the sub-computations).--* If getRegister returns Any, then the code it generates may modify only:-        (a) fresh temporaries-        (b) the destination register-        (c) known registers (eg. %ecx is used by shifts)-  In particular, it may *not* modify global registers, unless the global-  register happens to be the destination register.--}--trivialCode :: Width -> (Operand -> Operand -> Instr)-            -> Maybe (Operand -> Operand -> Instr)-            -> CmmExpr -> CmmExpr -> NatM Register-trivialCode width instr m a b-    = do is32Bit <- is32BitPlatform-         trivialCode' is32Bit width instr m a b--trivialCode' :: Bool -> Width -> (Operand -> Operand -> Instr)-             -> Maybe (Operand -> Operand -> Instr)-             -> CmmExpr -> CmmExpr -> NatM Register-trivialCode' is32Bit width _ (Just revinstr) (CmmLit lit_a) b-  | is32BitLit is32Bit lit_a = do-  b_code <- getAnyReg b-  let-       code dst-         = b_code dst `snocOL`-           revinstr (OpImm (litToImm lit_a)) (OpReg dst)-  return (Any (intFormat width) code)--trivialCode' _ width instr _ a b-  = genTrivialCode (intFormat width) instr a b---- This is re-used for floating pt instructions too.-genTrivialCode :: Format -> (Operand -> Operand -> Instr)-               -> CmmExpr -> CmmExpr -> NatM Register-genTrivialCode rep instr a b = do-  (b_op, b_code) <- getNonClobberedOperand b-  a_code <- getAnyReg a-  tmp <- getNewRegNat rep-  let-     -- We want the value of b to stay alive across the computation of a.-     -- But, we want to calculate a straight into the destination register,-     -- because the instruction only has two operands (dst := dst `op` src).-     -- The troublesome case is when the result of b is in the same register-     -- as the destination reg.  In this case, we have to save b in a-     -- new temporary across the computation of a.-     code dst-        | dst `regClashesWithOp` b_op =-                b_code `appOL`-                unitOL (MOV rep b_op (OpReg tmp)) `appOL`-                a_code dst `snocOL`-                instr (OpReg tmp) (OpReg dst)-        | otherwise =-                b_code `appOL`-                a_code dst `snocOL`-                instr b_op (OpReg dst)-  return (Any rep code)--regClashesWithOp :: Reg -> Operand -> Bool-reg `regClashesWithOp` OpReg reg2   = reg == reg2-reg `regClashesWithOp` OpAddr amode = any (==reg) (addrModeRegs amode)-_   `regClashesWithOp` _            = False---------------trivialUCode :: Format -> (Operand -> Instr)-             -> CmmExpr -> NatM Register-trivialUCode rep instr x = do-  x_code <- getAnyReg x-  let-     code dst =-        x_code dst `snocOL`-        instr (OpReg dst)-  return (Any rep code)----------------trivialFCode_sse2 :: Width -> (Format -> Operand -> Operand -> Instr)-                  -> CmmExpr -> CmmExpr -> NatM Register-trivialFCode_sse2 pk instr x y-    = genTrivialCode format (instr format) x y-    where format = floatFormat pk---trivialUFCode :: Format -> (Reg -> Reg -> Instr) -> CmmExpr -> NatM Register-trivialUFCode format instr x = do-  (x_reg, x_code) <- getSomeReg x-  let-     code dst =-        x_code `snocOL`-        instr x_reg dst-  return (Any format code)------------------------------------------------------------------------------------coerceInt2FP :: Width -> Width -> CmmExpr -> NatM Register-coerceInt2FP from to x =  coerce_sse2- where--   coerce_sse2 = do-     (x_op, x_code) <- getOperand x  -- ToDo: could be a safe operand-     let-           opc  = case to of W32 -> CVTSI2SS; W64 -> CVTSI2SD-                             n -> panic $ "coerceInt2FP.sse: unhandled width ("-                                         ++ show n ++ ")"-           code dst = x_code `snocOL` opc (intFormat from) x_op dst-     return (Any (floatFormat to) code)-        -- works even if the destination rep is <II32-----------------------------------------------------------------------------------coerceFP2Int :: Width -> Width -> CmmExpr -> NatM Register-coerceFP2Int from to x =  coerceFP2Int_sse2- where-   coerceFP2Int_sse2 = do-     (x_op, x_code) <- getOperand x  -- ToDo: could be a safe operand-     let-           opc  = case from of W32 -> CVTTSS2SIQ; W64 -> CVTTSD2SIQ;-                               n -> panic $ "coerceFP2Init.sse: unhandled width ("-                                           ++ show n ++ ")"-           code dst = x_code `snocOL` opc (intFormat to) x_op dst-     return (Any (intFormat to) code)-         -- works even if the destination rep is <II32------------------------------------------------------------------------------------coerceFP2FP :: Width -> CmmExpr -> NatM Register-coerceFP2FP to x = do-  (x_reg, x_code) <- getSomeReg x-  let-        opc  = case to of W32 -> CVTSD2SS; W64 -> CVTSS2SD;-                                     n -> panic $ "coerceFP2FP: unhandled width ("-                                                 ++ show n ++ ")"-        code dst = x_code `snocOL` opc x_reg dst-  return (Any ( floatFormat to) code)------------------------------------------------------------------------------------sse2NegCode :: Width -> CmmExpr -> NatM Register-sse2NegCode w x = do-  let fmt = floatFormat w-  x_code <- getAnyReg x-  -- This is how gcc does it, so it can't be that bad:-  let-    const = case fmt of-      FF32 -> CmmInt 0x80000000 W32-      FF64 -> CmmInt 0x8000000000000000 W64-      x@II8  -> wrongFmt x-      x@II16 -> wrongFmt x-      x@II32 -> wrongFmt x-      x@II64 -> wrongFmt x--      where-        wrongFmt x = panic $ "sse2NegCode: " ++ show x-  Amode amode amode_code <- memConstant (mkAlignment $ widthInBytes w) const-  tmp <- getNewRegNat fmt-  let-    code dst = x_code dst `appOL` amode_code `appOL` toOL [-        MOV fmt (OpAddr amode) (OpReg tmp),-        XOR fmt (OpReg tmp) (OpReg dst)-        ]-  ---  return (Any fmt code)--isVecExpr :: CmmExpr -> Bool-isVecExpr (CmmMachOp (MO_V_Insert {}) _)   = True-isVecExpr (CmmMachOp (MO_V_Extract {}) _)  = True-isVecExpr (CmmMachOp (MO_V_Add {}) _)      = True-isVecExpr (CmmMachOp (MO_V_Sub {}) _)      = True-isVecExpr (CmmMachOp (MO_V_Mul {}) _)      = True-isVecExpr (CmmMachOp (MO_VS_Quot {}) _)    = True-isVecExpr (CmmMachOp (MO_VS_Rem {}) _)     = True-isVecExpr (CmmMachOp (MO_VS_Neg {}) _)     = True-isVecExpr (CmmMachOp (MO_VF_Insert {}) _)  = True-isVecExpr (CmmMachOp (MO_VF_Extract {}) _) = True-isVecExpr (CmmMachOp (MO_VF_Add {}) _)     = True-isVecExpr (CmmMachOp (MO_VF_Sub {}) _)     = True-isVecExpr (CmmMachOp (MO_VF_Mul {}) _)     = True-isVecExpr (CmmMachOp (MO_VF_Quot {}) _)    = True-isVecExpr (CmmMachOp (MO_VF_Neg {}) _)     = True-isVecExpr (CmmMachOp _ [e])                = isVecExpr e-isVecExpr _                                = False--needLlvm :: NatM a-needLlvm =-    sorry $ unlines ["The native code generator does not support vector"-                    ,"instructions. Please use -fllvm."]---- | This works on the invariant that all jumps in the given blocks are required.---   Starting from there we try to make a few more jumps redundant by reordering---   them.---   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@(_:_:_xs)):b2@(BasicBlock lbl2 _):bs)-      | --pprTrace "Block" (ppr lbl1) True,-        (jmp1,jmp2) <- last2 ins-      , JXX cond1 target1 <- jmp1-      , target1 == lbl2-      --, pprTrace "CutChance" (ppr b1) True-      , JXX ALWAYS target2 <- jmp2-      -- We have enough information to check if we can perform the inversion-      -- TODO: We could also check for the last asm instruction which sets-      -- status flags instead. Which I suspect is worse in terms of compiler-      -- performance, but might be applicable to more cases-      , Just edgeInfo1 <- getEdgeInfo lbl1 target1 cfg-      , Just edgeInfo2 <- getEdgeInfo lbl1 target2 cfg-      -- Both jumps come from the same cmm statement-      , transitionSource edgeInfo1 == transitionSource edgeInfo2-      , CmmSource {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 [] = []+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE NondecreasingIndentation #-}+{-# LANGUAGE TupleSections #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++-----------------------------------------------------------------------------+--+-- Generating machine code (instruction selection)+--+-- (c) The University of Glasgow 1996-2004+--+-----------------------------------------------------------------------------++-- This is a big module, but, if you pay attention to+-- (a) the sectioning, and (b) the type signatures, the+-- structure should not be too overwhelming.++module GHC.CmmToAsm.X86.CodeGen (+        cmmTopCodeGen,+        generateJumpTableForInstr,+        extractUnwindPoints,+        invertCondBranches,+        InstrBlock+)++where++-- NCG stuff:+import GHC.Prelude++import GHC.CmmToAsm.X86.Instr+import GHC.CmmToAsm.X86.Cond+import GHC.CmmToAsm.X86.Regs+import GHC.CmmToAsm.X86.Ppr+import GHC.CmmToAsm.X86.RegInfo++import GHC.Platform.Regs+import GHC.CmmToAsm.CPrim+import GHC.CmmToAsm.Types+import GHC.Cmm.DebugBlock+   ( DebugBlock(..), UnwindPoint(..), UnwindTable+   , UnwindExpr(UwReg), toUnwindExpr+   )+import GHC.CmmToAsm.PIC+import GHC.CmmToAsm.Monad+   ( NatM, getNewRegNat, getNewLabelNat, setDeltaNat+   , getDeltaNat, getBlockIdNat, getPicBaseNat+   , Reg64(..), RegCode64(..), getNewReg64, localReg64+   , getPicBaseMaybeNat, getDebugBlock, getFileId+   , addImmediateSuccessorNat, updateCfgNat, getConfig, getPlatform+   , getCfgWeights+   )+import GHC.CmmToAsm.CFG+import GHC.CmmToAsm.Format+import GHC.CmmToAsm.Config+import GHC.Platform.Reg+import GHC.Platform++-- Our intermediate code:+import GHC.Types.Basic+import GHC.Cmm.BlockId+import GHC.Unit.Types ( primUnitId )+import GHC.Cmm.Utils+import GHC.Cmm.Switch+import GHC.Cmm+import GHC.Cmm.Dataflow.Block+import GHC.Cmm.Dataflow.Collections+import GHC.Cmm.Dataflow.Graph+import GHC.Cmm.Dataflow.Label+import GHC.Cmm.CLabel+import GHC.Types.Tickish ( GenTickish(..) )+import GHC.Types.SrcLoc  ( srcSpanFile, srcSpanStartLine, srcSpanStartCol )++-- The rest:+import GHC.Types.ForeignCall ( CCallConv(..) )+import GHC.Data.OrdList+import GHC.Utils.Outputable+import GHC.Utils.Constants (debugIsOn)+import GHC.Utils.Panic+import GHC.Utils.Panic.Plain+import GHC.Data.FastString+import GHC.Utils.Misc+import GHC.Types.Unique.Supply ( getUniqueM )++import Control.Monad+import Data.Foldable (fold)+import Data.Int+import Data.Maybe+import Data.Word++import qualified Data.Map as M++is32BitPlatform :: NatM Bool+is32BitPlatform = do+    platform <- getPlatform+    return $ target32Bit platform++expect32BitPlatform :: SDoc -> NatM ()+expect32BitPlatform doc = do+  is32Bit <- is32BitPlatform+  when (not is32Bit) $+    pprPanic "Expecting 32-bit platform" doc++sse2Enabled :: NatM Bool+sse2Enabled = do+  config <- getConfig+  return (ncgSseVersion config >= Just SSE2)++sse4_2Enabled :: NatM Bool+sse4_2Enabled = do+  config <- getConfig+  return (ncgSseVersion config >= Just SSE42)++cmmTopCodeGen+        :: RawCmmDecl+        -> NatM [NatCmmDecl (Alignment, RawCmmStatics) Instr]++cmmTopCodeGen (CmmProc info lab live graph) = do+  let blocks = toBlockListEntryFirst graph+  (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks+  picBaseMb <- getPicBaseMaybeNat+  platform <- getPlatform+  let proc = CmmProc info lab live (ListGraph $ concat nat_blocks)+      tops = proc : concat statics+      os   = platformOS platform++  case picBaseMb of+      Just picBase -> initializePicBase_x86 ArchX86 os picBase tops+      Nothing -> return tops++cmmTopCodeGen (CmmData sec dat) =+  return [CmmData sec (mkAlignment 1, dat)]  -- no translation, we just use CmmStatic++{- Note [Verifying basic blocks]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+   We want to guarantee a few things about the results+   of instruction selection.++   Namely that each basic blocks consists of:+    * A (potentially empty) sequence of straight line instructions+  followed by+    * A (potentially empty) sequence of jump like instructions.++    We can verify this by going through the instructions and+    making sure that any non-jumpish instruction can't appear+    after a jumpish instruction.++    There are gotchas however:+    * CALLs are strictly speaking control flow but here we care+      not about them. Hence we treat them as regular instructions.++      It's safe for them to appear inside a basic block+      as (ignoring side effects inside the call) they will result in+      straight line code.++    * NEWBLOCK marks the start of a new basic block so can+      be followed by any instructions.+-}++-- Verifying basic blocks is cheap, but not cheap enough to enable it unconditionally.+verifyBasicBlock :: Platform -> [Instr] -> ()+verifyBasicBlock platform instrs+  | debugIsOn     = go False instrs+  | otherwise     = ()+  where+    go _     [] = ()+    go atEnd (i:instr)+        = case i of+            -- Start a new basic block+            NEWBLOCK {} -> go False instr+            -- Calls are not viable block terminators+            CALL {}     | atEnd -> faultyBlockWith i+                        | not atEnd -> go atEnd instr+            -- All instructions ok, check if we reached the end and continue.+            _ | not atEnd -> go (isJumpishInstr i) instr+              -- Only jumps allowed at the end of basic blocks.+              | otherwise -> if isJumpishInstr i+                                then go True instr+                                else faultyBlockWith i+    faultyBlockWith i+        = pprPanic "Non control flow instructions after end of basic block."+                   (pprInstr platform i <+> text "in:" $$ vcat (map (pprInstr platform) instrs))++basicBlockCodeGen+        :: CmmBlock+        -> NatM ( [NatBasicBlock Instr]+                , [NatCmmDecl (Alignment, RawCmmStatics) Instr])++basicBlockCodeGen block = do+  let (_, nodes, tail)  = blockSplit block+      id = entryLabel block+      stmts = blockToList nodes+  -- Generate location directive+  dbg <- getDebugBlock (entryLabel block)+  loc_instrs <- case dblSourceTick =<< dbg of+    Just (SourceNote span name)+      -> do fileId <- getFileId (srcSpanFile span)+            let line = srcSpanStartLine span; col = srcSpanStartCol span+            return $ unitOL $ LOCATION fileId line col name+    _ -> return nilOL+  (mid_instrs,mid_bid) <- stmtsToInstrs id stmts+  (!tail_instrs,_) <- stmtToInstrs mid_bid tail+  let instrs = loc_instrs `appOL` mid_instrs `appOL` tail_instrs+  platform <- getPlatform+  return $! verifyBasicBlock platform (fromOL instrs)+  instrs' <- fold <$> traverse addSpUnwindings instrs+  -- code generation may introduce new basic block boundaries, which+  -- are indicated by the NEWBLOCK instruction.  We must split up the+  -- instruction stream into basic blocks again.  Also, we extract+  -- LDATAs here too.+  let+        (top,other_blocks,statics) = foldrOL mkBlocks ([],[],[]) instrs'++        mkBlocks (NEWBLOCK id) (instrs,blocks,statics)+          = ([], BasicBlock id instrs : blocks, statics)+        mkBlocks (LDATA sec dat) (instrs,blocks,statics)+          = (instrs, blocks, CmmData sec dat:statics)+        mkBlocks instr (instrs,blocks,statics)+          = (instr:instrs, blocks, statics)+  return (BasicBlock id top : other_blocks, statics)++-- | Convert 'DELTA' instructions into 'UNWIND' instructions to capture changes+-- in the @sp@ register. See Note [What is this unwinding business?] in "GHC.Cmm.DebugBlock"+-- for details.+addSpUnwindings :: Instr -> NatM (OrdList Instr)+addSpUnwindings instr@(DELTA d) = do+    config <- getConfig+    if ncgDwarfUnwindings config+        then do lbl <- mkAsmTempLabel <$> getUniqueM+                let unwind = M.singleton MachSp (Just $ UwReg MachSp $ negate d)+                return $ toOL [ instr, UNWIND lbl unwind ]+        else return (unitOL instr)+addSpUnwindings instr = return $ unitOL instr++{- Note [Keeping track of the current block]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When generating instructions for Cmm we sometimes require+the current block for things like retry loops.++We also sometimes change the current block, if a MachOP+results in branching control flow.++Issues arise if we have two statements in the same block,+which both depend on the current block id *and* change the+basic block after them. This happens for atomic primops+in the X86 backend where we want to update the CFG data structure+when introducing new basic blocks.++For example in #17334 we got this Cmm code:++        c3Bf: // global+            (_s3t1::I64) = call MO_AtomicRMW W64 AMO_And(_s3sQ::P64 + 88, 18);+            (_s3t4::I64) = call MO_AtomicRMW W64 AMO_Or(_s3sQ::P64 + 88, 0);+            _s3sT::I64 = _s3sV::I64;+            goto c3B1;++This resulted in two new basic blocks being inserted:++        c3Bf:+                movl $18,%vI_n3Bo+                movq 88(%vI_s3sQ),%rax+                jmp _n3Bp+        n3Bp:+                ...+                cmpxchgq %vI_n3Bq,88(%vI_s3sQ)+                jne _n3Bp+                ...+                jmp _n3Bs+        n3Bs:+                ...+                cmpxchgq %vI_n3Bt,88(%vI_s3sQ)+                jne _n3Bs+                ...+                jmp _c3B1+        ...++Based on the Cmm we called stmtToInstrs we translated both atomic operations under+the assumption they would be placed into their Cmm basic block `c3Bf`.+However for the retry loop we introduce new labels, so this is not the case+for the second statement.+This resulted in a desync between the explicit control flow graph+we construct as a separate data type and the actual control flow graph in the code.++Instead we now return the new basic block if a statement causes a change+in the current block and use the block for all following statements.++For this reason genForeignCall is also split into two parts.  One for calls which+*won't* change the basic blocks in which successive instructions will be+placed (since they only evaluate CmmExpr, which can only contain MachOps, which+cannot introduce basic blocks in their lowerings).  A different one for calls+which *are* known to change the basic block.++-}++-- See Note [Keeping track of the current block] for why+-- we pass the BlockId.+stmtsToInstrs :: BlockId -- ^ Basic block these statement will start to be placed in.+              -> [CmmNode O O] -- ^ Cmm Statement+              -> NatM (InstrBlock, BlockId) -- ^ Resulting instruction+stmtsToInstrs bid stmts =+    go bid stmts nilOL+  where+    go bid  []        instrs = return (instrs,bid)+    go bid (s:stmts)  instrs = do+      (instrs',bid') <- stmtToInstrs bid s+      -- If the statement introduced a new block, we use that one+      let !newBid = fromMaybe bid bid'+      go newBid stmts (instrs `appOL` instrs')++-- | `bid` refers to the current block and is used to update the CFG+--   if new blocks are inserted in the control flow.+-- See Note [Keeping track of the current block] for more details.+stmtToInstrs :: BlockId -- ^ Basic block this statement will start to be placed in.+             -> CmmNode e x+             -> NatM (InstrBlock, Maybe BlockId)+             -- ^ Instructions, and bid of new block if successive+             -- statements are placed in a different basic block.+stmtToInstrs bid stmt = do+  is32Bit <- is32BitPlatform+  platform <- getPlatform+  case stmt of+    CmmUnsafeForeignCall target result_regs args+       -> genForeignCall target result_regs args bid++    _ -> (,Nothing) <$> case stmt of+      CmmComment s   -> return (unitOL (COMMENT $ ftext s))+      CmmTick {}     -> return nilOL++      CmmUnwind regs -> do+        let to_unwind_entry :: (GlobalReg, Maybe CmmExpr) -> UnwindTable+            to_unwind_entry (reg, expr) = M.singleton reg (fmap (toUnwindExpr platform) expr)+        case foldMap to_unwind_entry regs of+          tbl | M.null tbl -> return nilOL+              | otherwise  -> do+                  lbl <- mkAsmTempLabel <$> getUniqueM+                  return $ unitOL $ UNWIND lbl tbl++      CmmAssign reg src+        | isFloatType ty         -> assignReg_FltCode format reg src+        | is32Bit && isWord64 ty -> assignReg_I64Code      reg src+        | otherwise              -> assignReg_IntCode format reg src+          where ty = cmmRegType platform reg+                format = cmmTypeFormat ty++      CmmStore addr src _alignment+        | isFloatType ty         -> assignMem_FltCode format addr src+        | is32Bit && isWord64 ty -> assignMem_I64Code      addr src+        | otherwise              -> assignMem_IntCode format addr src+          where ty = cmmExprType platform src+                format = cmmTypeFormat ty++      CmmBranch id          -> return $ genBranch id++      --We try to arrange blocks such that the likely branch is the fallthrough+      --in GHC.Cmm.ContFlowOpt. So we can assume the condition is likely false here.+      CmmCondBranch arg true false _ -> genCondBranch bid true false arg+      CmmSwitch arg ids -> genSwitch arg ids+      CmmCall { cml_target = arg+              , cml_args_regs = gregs } -> genJump arg (jumpRegs platform gregs)+      _ ->+        panic "stmtToInstrs: statement should have been cps'd away"+++jumpRegs :: Platform -> [GlobalReg] -> [Reg]+jumpRegs platform gregs = [ RegReal r | Just r <- map (globalRegMaybe platform) gregs ]++--------------------------------------------------------------------------------+-- | 'InstrBlock's are the insn sequences generated by the insn selectors.+--      They are really trees of insns to facilitate fast appending, where a+--      left-to-right traversal yields the insns in the correct order.+--+type InstrBlock+        = OrdList Instr+++-- | Condition codes passed up the tree.+--+data CondCode+        = CondCode Bool Cond InstrBlock+++-- | Register's passed up the tree.  If the stix code forces the register+--      to live in a pre-decided machine register, it comes out as @Fixed@;+--      otherwise, it comes out as @Any@, and the parent can decide which+--      register to put it in.+--+data Register+        = Fixed Format Reg InstrBlock+        | Any   Format (Reg -> InstrBlock)+++swizzleRegisterRep :: Register -> Format -> Register+swizzleRegisterRep (Fixed _ reg code) format = Fixed format reg code+swizzleRegisterRep (Any _ codefn)     format = Any   format codefn++getLocalRegReg :: LocalReg -> Reg+getLocalRegReg (LocalReg u pk)+  = -- by Assuming SSE2, Int,Word,Float,Double all can be register allocated+    RegVirtual (mkVirtualReg u (cmmTypeFormat pk))++-- | Grab the Reg for a CmmReg+getRegisterReg :: Platform  -> CmmReg -> Reg++getRegisterReg _   (CmmLocal lreg) = getLocalRegReg lreg++getRegisterReg platform  (CmmGlobal mid)+  = case globalRegMaybe platform mid of+        Just reg -> RegReal $ reg+        Nothing  -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal mid)+        -- By this stage, the only MagicIds remaining should be the+        -- ones which map to a real machine register on this+        -- platform.  Hence ...+++-- | Memory addressing modes passed up the tree.+data Amode+        = Amode AddrMode InstrBlock++{-+Now, given a tree (the argument to a CmmLoad) that references memory,+produce a suitable addressing mode.++A Rule of the Game (tm) for Amodes: use of the addr bit must+immediately follow use of the code part, since the code part puts+values in registers which the addr then refers to.  So you can't put+anything in between, lest it overwrite some of those registers.  If+you need to do some other computation between the code part and use of+the addr bit, first store the effective address from the amode in a+temporary, then do the other computation, and then use the temporary:++    code+    LEA amode, tmp+    ... other computation ...+    ... (tmp) ...+-}++{-+Note [%rip-relative addressing on x86-64]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+On x86-64 GHC produces code for use in the "small" or, when `-fPIC` is set,+"small PIC" code models defined by the x86-64 System V ABI (section 3.5.1 of+specification version 0.99).++In general the small code model would allow us to assume that code is located+between 0 and 2^31 - 1. However, this is not true on Windows which, due to+high-entropy ASLR, may place the executable image anywhere in 64-bit address+space. This is problematic since immediate operands in x86-64 are generally+32-bit sign-extended values (with the exception of the 64-bit MOVABS encoding).+Consequently, to avoid overflowing we use %rip-relative addressing universally.+Since %rip-relative addressing comes essentially for free and makes linking far+easier, we use it even on non-Windows platforms.++See also: the documentation for GCC's `-mcmodel=small` flag.+-}+++-- | Check whether an integer will fit in 32 bits.+--      A CmmInt is intended to be truncated to the appropriate+--      number of bits, so here we truncate it to Int64.  This is+--      important because e.g. -1 as a CmmInt might be either+--      -1 or 18446744073709551615.+--+is32BitInteger :: Integer -> Bool+is32BitInteger i = i64 <= 0x7fffffff && i64 >= -0x80000000+  where i64 = fromIntegral i :: Int64+++-- | Convert a BlockId to some CmmStatic data+jumpTableEntry :: NCGConfig -> Maybe BlockId -> CmmStatic+jumpTableEntry config Nothing = CmmStaticLit (CmmInt 0 (ncgWordWidth config))+jumpTableEntry _ (Just blockid) = CmmStaticLit (CmmLabel blockLabel)+    where blockLabel = blockLbl blockid+++-- -----------------------------------------------------------------------------+-- General things for putting together code sequences++-- Expand CmmRegOff.  ToDo: should we do it this way around, or convert+-- CmmExprs into CmmRegOff?+mangleIndexTree :: Platform -> CmmReg -> Int -> CmmExpr+mangleIndexTree platform reg off+  = CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)]+  where width = typeWidth (cmmRegType platform reg)++-- | The dual to getAnyReg: compute an expression into a register, but+--      we don't mind which one it is.+getSomeReg :: CmmExpr -> NatM (Reg, InstrBlock)+getSomeReg expr = do+  r <- getRegister expr+  case r of+    Any rep code -> do+        tmp <- getNewRegNat rep+        return (tmp, code tmp)+    Fixed _ reg code ->+        return (reg, code)+++assignMem_I64Code :: CmmExpr -> CmmExpr -> NatM InstrBlock+assignMem_I64Code addrTree valueTree = do+  Amode addr addr_code <- getAmode addrTree+  RegCode64 vcode rhi rlo <- iselExpr64 valueTree+  let+        -- Little-endian store+        mov_lo = MOV II32 (OpReg rlo) (OpAddr addr)+        mov_hi = MOV II32 (OpReg rhi) (OpAddr (fromJust (addrOffset addr 4)))+  return (vcode `appOL` addr_code `snocOL` mov_lo `snocOL` mov_hi)+++assignReg_I64Code :: CmmReg  -> CmmExpr -> NatM InstrBlock+assignReg_I64Code (CmmLocal dst) valueTree = do+   RegCode64 vcode r_src_hi r_src_lo <- iselExpr64 valueTree+   let+         Reg64 r_dst_hi r_dst_lo = localReg64 dst+         mov_lo = MOV II32 (OpReg r_src_lo) (OpReg r_dst_lo)+         mov_hi = MOV II32 (OpReg r_src_hi) (OpReg r_dst_hi)+   return (+        vcode `snocOL` mov_lo `snocOL` mov_hi+     )++assignReg_I64Code _ _+   = panic "assignReg_I64Code(i386): invalid lvalue"+++iselExpr64 :: HasDebugCallStack => CmmExpr -> NatM (RegCode64 InstrBlock)+iselExpr64 (CmmLit (CmmInt i _)) = do+  Reg64 rhi rlo <- getNewReg64+  let+        r = fromIntegral (fromIntegral i :: Word32)+        q = fromIntegral (fromIntegral (i `shiftR` 32) :: Word32)+        code = toOL [+                MOV II32 (OpImm (ImmInteger r)) (OpReg rlo),+                MOV II32 (OpImm (ImmInteger q)) (OpReg rhi)+                ]+  return (RegCode64 code rhi rlo)++iselExpr64 (CmmLoad addrTree ty _) | isWord64 ty = do+   Amode addr addr_code <- getAmode addrTree+   Reg64 rhi rlo <- getNewReg64+   let+        mov_lo = MOV II32 (OpAddr addr) (OpReg rlo)+        mov_hi = MOV II32 (OpAddr (fromJust (addrOffset addr 4))) (OpReg rhi)+   return (+            RegCode64 (addr_code `snocOL` mov_lo `snocOL` mov_hi) rhi rlo+     )++iselExpr64 (CmmReg (CmmLocal local_reg)) = do+  let Reg64 hi lo = localReg64 local_reg+  return (RegCode64 nilOL hi lo)++-- we handle addition, but rather badly+iselExpr64 (CmmMachOp (MO_Add _) [e1, CmmLit (CmmInt i _)]) = do+   RegCode64 code1 r1hi r1lo <- iselExpr64 e1+   Reg64 rhi rlo <- getNewReg64+   let+        r = fromIntegral (fromIntegral i :: Word32)+        q = fromIntegral (fromIntegral (i `shiftR` 32) :: Word32)+        code =  code1 `appOL`+                toOL [ MOV II32 (OpReg r1lo) (OpReg rlo),+                       ADD II32 (OpImm (ImmInteger r)) (OpReg rlo),+                       MOV II32 (OpReg r1hi) (OpReg rhi),+                       ADC II32 (OpImm (ImmInteger q)) (OpReg rhi) ]+   return (RegCode64 code rhi rlo)++iselExpr64 (CmmMachOp (MO_Add _) [e1,e2]) = do+   RegCode64 code1 r1hi r1lo <- iselExpr64 e1+   RegCode64 code2 r2hi r2lo <- iselExpr64 e2+   Reg64 rhi rlo <- getNewReg64+   let+        code =  code1 `appOL`+                code2 `appOL`+                toOL [ MOV II32 (OpReg r1lo) (OpReg rlo),+                       ADD II32 (OpReg r2lo) (OpReg rlo),+                       MOV II32 (OpReg r1hi) (OpReg rhi),+                       ADC II32 (OpReg r2hi) (OpReg rhi) ]+   return (RegCode64 code rhi rlo)++iselExpr64 (CmmMachOp (MO_Sub _) [e1,e2]) = do+   RegCode64 code1 r1hi r1lo <- iselExpr64 e1+   RegCode64 code2 r2hi r2lo <- iselExpr64 e2+   Reg64 rhi rlo <- getNewReg64+   let+        code =  code1 `appOL`+                code2 `appOL`+                toOL [ MOV II32 (OpReg r1lo) (OpReg rlo),+                       SUB II32 (OpReg r2lo) (OpReg rlo),+                       MOV II32 (OpReg r1hi) (OpReg rhi),+                       SBB II32 (OpReg r2hi) (OpReg rhi) ]+   return (RegCode64 code rhi rlo)++iselExpr64 (CmmMachOp (MO_UU_Conv _ W64) [expr]) = do+     code <- getAnyReg expr+     Reg64 r_dst_hi r_dst_lo <- getNewReg64+     return $ RegCode64 (code r_dst_lo `snocOL`+                          MOV II32 (OpImm (ImmInt 0)) (OpReg r_dst_hi))+                          r_dst_hi+                          r_dst_lo++iselExpr64 (CmmMachOp (MO_SS_Conv W32 W64) [expr]) = do+     code <- getAnyReg expr+     Reg64 r_dst_hi r_dst_lo <- getNewReg64+     return $ RegCode64 (code r_dst_lo `snocOL`+                          MOV II32 (OpReg r_dst_lo) (OpReg eax) `snocOL`+                          CLTD II32 `snocOL`+                          MOV II32 (OpReg eax) (OpReg r_dst_lo) `snocOL`+                          MOV II32 (OpReg edx) (OpReg r_dst_hi))+                          r_dst_hi+                          r_dst_lo++iselExpr64 expr+   = do+      platform <- getPlatform+      pprPanic "iselExpr64(i386)" (pdoc platform expr)+++--------------------------------------------------------------------------------+getRegister :: CmmExpr -> NatM Register+getRegister e = do platform <- getPlatform+                   is32Bit <- is32BitPlatform+                   getRegister' platform is32Bit e++getRegister' :: Platform -> Bool -> CmmExpr -> NatM Register++getRegister' platform is32Bit (CmmReg reg)+  = case reg of+        CmmGlobal PicBaseReg+         | is32Bit ->+            -- on x86_64, we have %rip for PicBaseReg, but it's not+            -- a full-featured register, it can only be used for+            -- rip-relative addressing.+            do reg' <- getPicBaseNat (archWordFormat is32Bit)+               return (Fixed (archWordFormat is32Bit) reg' nilOL)+        _ ->+            do+               let+                 fmt = cmmTypeFormat (cmmRegType platform reg)+                 format  = fmt+               --+               platform <- ncgPlatform <$> getConfig+               return (Fixed format+                             (getRegisterReg platform reg)+                             nilOL)+++getRegister' platform is32Bit (CmmRegOff r n)+  = getRegister' platform is32Bit $ mangleIndexTree platform r n++getRegister' platform is32Bit (CmmMachOp (MO_AlignmentCheck align _) [e])+  = addAlignmentCheck align <$> getRegister' platform is32Bit e++-- for 32-bit architectures, support some 64 -> 32 bit conversions:+-- TO_W_(x), TO_W_(x >> 32)++getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W64 W32)+                     [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]])+ | is32Bit = do+  RegCode64 code rhi _rlo <- iselExpr64 x+  return $ Fixed II32 rhi code++getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W64 W32)+                     [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]])+ | is32Bit = do+  RegCode64 code rhi _rlo <- iselExpr64 x+  return $ Fixed II32 rhi code++getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W64 W32) [x])+ | is32Bit = do+  RegCode64 code _rhi rlo <- iselExpr64 x+  return $ Fixed II32 rlo code++getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W64 W32) [x])+ | is32Bit = do+  RegCode64 code _rhi rlo <- iselExpr64 x+  return $ Fixed II32 rlo code++getRegister' _ _ (CmmLit lit@(CmmFloat f w)) =+  float_const_sse2  where+  float_const_sse2+    | f == 0.0 = do+      let+          format = floatFormat w+          code dst = unitOL  (XOR format (OpReg dst) (OpReg dst))+        -- I don't know why there are xorpd, xorps, and pxor instructions.+        -- They all appear to do the same thing --SDM+      return (Any format code)++   | otherwise = do+      Amode addr code <- memConstant (mkAlignment $ widthInBytes w) lit+      loadFloatAmode w addr code++-- catch simple cases of zero- or sign-extended load+getRegister' _ _ (CmmMachOp (MO_UU_Conv W8 W32) [CmmLoad addr _ _]) = do+  code <- intLoadCode (MOVZxL II8) addr+  return (Any II32 code)++getRegister' _ _ (CmmMachOp (MO_SS_Conv W8 W32) [CmmLoad addr _ _]) = do+  code <- intLoadCode (MOVSxL II8) addr+  return (Any II32 code)++getRegister' _ _ (CmmMachOp (MO_UU_Conv W16 W32) [CmmLoad addr _ _]) = do+  code <- intLoadCode (MOVZxL II16) addr+  return (Any II32 code)++getRegister' _ _ (CmmMachOp (MO_SS_Conv W16 W32) [CmmLoad addr _ _]) = do+  code <- intLoadCode (MOVSxL II16) addr+  return (Any II32 code)++-- catch simple cases of zero- or sign-extended load+getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W8 W64) [CmmLoad addr _ _])+ | not is32Bit = do+  code <- intLoadCode (MOVZxL II8) addr+  return (Any II64 code)++getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W8 W64) [CmmLoad addr _ _])+ | not is32Bit = do+  code <- intLoadCode (MOVSxL II8) addr+  return (Any II64 code)++getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W16 W64) [CmmLoad addr _ _])+ | not is32Bit = do+  code <- intLoadCode (MOVZxL II16) addr+  return (Any II64 code)++getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W16 W64) [CmmLoad addr _ _])+ | not is32Bit = do+  code <- intLoadCode (MOVSxL II16) addr+  return (Any II64 code)++getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W32 W64) [CmmLoad addr _ _])+ | not is32Bit = do+  code <- intLoadCode (MOV II32) addr -- 32-bit loads zero-extend+  return (Any II64 code)++getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W32 W64) [CmmLoad addr _ _])+ | not is32Bit = do+  code <- intLoadCode (MOVSxL II32) addr+  return (Any II64 code)++getRegister' _ is32Bit (CmmMachOp (MO_Add W64) [CmmReg (CmmGlobal PicBaseReg),+                                     CmmLit displacement])+ | not is32Bit =+      return $ Any II64 (\dst -> unitOL $+        LEA II64 (OpAddr (ripRel (litToImm displacement))) (OpReg dst))++getRegister' platform is32Bit (CmmMachOp mop [x]) = -- unary MachOps+    case mop of+      MO_F_Neg w  -> sse2NegCode w x+++      MO_S_Neg w -> triv_ucode NEGI (intFormat w)+      MO_Not w   -> triv_ucode NOT  (intFormat w)++      -- Nop conversions+      MO_UU_Conv W32 W8  -> toI8Reg  W32 x+      MO_SS_Conv W32 W8  -> toI8Reg  W32 x+      MO_XX_Conv W32 W8  -> toI8Reg  W32 x+      MO_UU_Conv W16 W8  -> toI8Reg  W16 x+      MO_SS_Conv W16 W8  -> toI8Reg  W16 x+      MO_XX_Conv W16 W8  -> toI8Reg  W16 x+      MO_UU_Conv W32 W16 -> toI16Reg W32 x+      MO_SS_Conv W32 W16 -> toI16Reg W32 x+      MO_XX_Conv W32 W16 -> toI16Reg W32 x++      MO_UU_Conv W64 W32 | not is32Bit -> conversionNop II64 x+      MO_SS_Conv W64 W32 | not is32Bit -> conversionNop II64 x+      MO_XX_Conv W64 W32 | not is32Bit -> conversionNop II64 x+      MO_UU_Conv W64 W16 | not is32Bit -> toI16Reg W64 x+      MO_SS_Conv W64 W16 | not is32Bit -> toI16Reg W64 x+      MO_XX_Conv W64 W16 | not is32Bit -> toI16Reg W64 x+      MO_UU_Conv W64 W8  | not is32Bit -> toI8Reg  W64 x+      MO_SS_Conv W64 W8  | not is32Bit -> toI8Reg  W64 x+      MO_XX_Conv W64 W8  | not is32Bit -> toI8Reg  W64 x++      MO_UU_Conv rep1 rep2 | rep1 == rep2 -> conversionNop (intFormat rep1) x+      MO_SS_Conv rep1 rep2 | rep1 == rep2 -> conversionNop (intFormat rep1) x+      MO_XX_Conv rep1 rep2 | rep1 == rep2 -> conversionNop (intFormat rep1) x++      -- widenings+      MO_UU_Conv W8  W32 -> integerExtend W8  W32 MOVZxL x+      MO_UU_Conv W16 W32 -> integerExtend W16 W32 MOVZxL x+      MO_UU_Conv W8  W16 -> integerExtend W8  W16 MOVZxL x++      MO_SS_Conv W8  W32 -> integerExtend W8  W32 MOVSxL x+      MO_SS_Conv W16 W32 -> integerExtend W16 W32 MOVSxL x+      MO_SS_Conv W8  W16 -> integerExtend W8  W16 MOVSxL x++      -- We don't care about the upper bits for MO_XX_Conv, so MOV is enough. However, on 32-bit we+      -- have 8-bit registers only for a few registers (as opposed to x86-64 where every register+      -- has 8-bit version). So for 32-bit code, we'll just zero-extend.+      MO_XX_Conv W8  W32+          | is32Bit   -> integerExtend W8 W32 MOVZxL x+          | otherwise -> integerExtend W8 W32 MOV x+      MO_XX_Conv W8  W16+          | is32Bit   -> integerExtend W8 W16 MOVZxL x+          | otherwise -> integerExtend W8 W16 MOV x+      MO_XX_Conv W16 W32 -> integerExtend W16 W32 MOV x++      MO_UU_Conv W8  W64 | not is32Bit -> integerExtend W8  W64 MOVZxL x+      MO_UU_Conv W16 W64 | not is32Bit -> integerExtend W16 W64 MOVZxL x+      MO_UU_Conv W32 W64 | not is32Bit -> integerExtend W32 W64 MOVZxL x+      MO_SS_Conv W8  W64 | not is32Bit -> integerExtend W8  W64 MOVSxL x+      MO_SS_Conv W16 W64 | not is32Bit -> integerExtend W16 W64 MOVSxL x+      MO_SS_Conv W32 W64 | not is32Bit -> integerExtend W32 W64 MOVSxL x+      -- For 32-to-64 bit zero extension, amd64 uses an ordinary movl.+      -- However, we don't want the register allocator to throw it+      -- away as an unnecessary reg-to-reg move, so we keep it in+      -- the form of a movzl and print it as a movl later.+      -- This doesn't apply to MO_XX_Conv since in this case we don't care about+      -- the upper bits. So we can just use MOV.+      MO_XX_Conv W8  W64 | not is32Bit -> integerExtend W8  W64 MOV x+      MO_XX_Conv W16 W64 | not is32Bit -> integerExtend W16 W64 MOV x+      MO_XX_Conv W32 W64 | not is32Bit -> integerExtend W32 W64 MOV x++      MO_FF_Conv W32 W64 -> coerceFP2FP W64 x+++      MO_FF_Conv W64 W32 -> coerceFP2FP W32 x++      MO_FS_Conv from to -> coerceFP2Int from to x+      MO_SF_Conv from to -> coerceInt2FP from to x++      MO_V_Insert {}   -> needLlvm+      MO_V_Extract {}  -> needLlvm+      MO_V_Add {}      -> needLlvm+      MO_V_Sub {}      -> needLlvm+      MO_V_Mul {}      -> needLlvm+      MO_VS_Quot {}    -> needLlvm+      MO_VS_Rem {}     -> needLlvm+      MO_VS_Neg {}     -> needLlvm+      MO_VU_Quot {}    -> needLlvm+      MO_VU_Rem {}     -> needLlvm+      MO_VF_Insert {}  -> needLlvm+      MO_VF_Extract {} -> needLlvm+      MO_VF_Add {}     -> needLlvm+      MO_VF_Sub {}     -> needLlvm+      MO_VF_Mul {}     -> needLlvm+      MO_VF_Quot {}    -> needLlvm+      MO_VF_Neg {}     -> needLlvm++      _other -> pprPanic "getRegister" (pprMachOp mop)+   where+        triv_ucode :: (Format -> Operand -> Instr) -> Format -> NatM Register+        triv_ucode instr format = trivialUCode format (instr format) x++        -- signed or unsigned extension.+        integerExtend :: Width -> Width+                      -> (Format -> Operand -> Operand -> Instr)+                      -> CmmExpr -> NatM Register+        integerExtend from to instr expr = do+            (reg,e_code) <- if from == W8 then getByteReg expr+                                          else getSomeReg expr+            let+                code dst =+                  e_code `snocOL`+                  instr (intFormat from) (OpReg reg) (OpReg dst)+            return (Any (intFormat to) code)++        toI8Reg :: Width -> CmmExpr -> NatM Register+        toI8Reg new_rep expr+            = do codefn <- getAnyReg expr+                 return (Any (intFormat new_rep) codefn)+                -- HACK: use getAnyReg to get a byte-addressable register.+                -- If the source was a Fixed register, this will add the+                -- mov instruction to put it into the desired destination.+                -- We're assuming that the destination won't be a fixed+                -- non-byte-addressable register; it won't be, because all+                -- fixed registers are word-sized.++        toI16Reg = toI8Reg -- for now++        conversionNop :: Format -> CmmExpr -> NatM Register+        conversionNop new_format expr+            = do e_code <- getRegister' platform is32Bit expr+                 return (swizzleRegisterRep e_code new_format)+++getRegister' _ is32Bit (CmmMachOp mop [x, y]) = -- dyadic MachOps+  case mop of+      MO_F_Eq _ -> condFltReg is32Bit EQQ x y+      MO_F_Ne _ -> condFltReg is32Bit NE  x y+      MO_F_Gt _ -> condFltReg is32Bit GTT x y+      MO_F_Ge _ -> condFltReg is32Bit GE  x y+      -- Invert comparison condition and swap operands+      -- See Note [SSE Parity Checks]+      MO_F_Lt _ -> condFltReg is32Bit GTT  y x+      MO_F_Le _ -> condFltReg is32Bit GE   y x++      MO_Eq _   -> condIntReg EQQ x y+      MO_Ne _   -> condIntReg NE  x y++      MO_S_Gt _ -> condIntReg GTT x y+      MO_S_Ge _ -> condIntReg GE  x y+      MO_S_Lt _ -> condIntReg LTT x y+      MO_S_Le _ -> condIntReg LE  x y++      MO_U_Gt _ -> condIntReg GU  x y+      MO_U_Ge _ -> condIntReg GEU x y+      MO_U_Lt _ -> condIntReg LU  x y+      MO_U_Le _ -> condIntReg LEU x y++      MO_F_Add w   -> trivialFCode_sse2 w ADD  x y++      MO_F_Sub w   -> trivialFCode_sse2 w SUB  x y++      MO_F_Quot w  -> trivialFCode_sse2 w FDIV x y++      MO_F_Mul w   -> trivialFCode_sse2 w MUL x y+++      MO_Add rep -> add_code rep x y+      MO_Sub rep -> sub_code rep x y++      MO_S_Quot rep -> div_code rep True  True  x y+      MO_S_Rem  rep -> div_code rep True  False x y+      MO_U_Quot rep -> div_code rep False True  x y+      MO_U_Rem  rep -> div_code rep False False x y++      MO_S_MulMayOflo rep -> imulMayOflo rep x y++      MO_Mul W8  -> imulW8 x y+      MO_Mul rep -> triv_op rep IMUL+      MO_And rep -> triv_op rep AND+      MO_Or  rep -> triv_op rep OR+      MO_Xor rep -> triv_op rep XOR++        {- Shift ops on x86s have constraints on their source, it+           either has to be Imm, CL or 1+            => trivialCode is not restrictive enough (sigh.)+        -}+      MO_Shl rep   -> shift_code rep SHL x y {-False-}+      MO_U_Shr rep -> shift_code rep SHR x y {-False-}+      MO_S_Shr rep -> shift_code rep SAR x y {-False-}++      MO_V_Insert {}   -> needLlvm+      MO_V_Extract {}  -> needLlvm+      MO_V_Add {}      -> needLlvm+      MO_V_Sub {}      -> needLlvm+      MO_V_Mul {}      -> needLlvm+      MO_VS_Quot {}    -> needLlvm+      MO_VS_Rem {}     -> needLlvm+      MO_VS_Neg {}     -> needLlvm+      MO_VF_Insert {}  -> needLlvm+      MO_VF_Extract {} -> needLlvm+      MO_VF_Add {}     -> needLlvm+      MO_VF_Sub {}     -> needLlvm+      MO_VF_Mul {}     -> needLlvm+      MO_VF_Quot {}    -> needLlvm+      MO_VF_Neg {}     -> needLlvm++      _other -> pprPanic "getRegister(x86) - binary CmmMachOp (1)" (pprMachOp mop)+  where+    --------------------+    triv_op width instr = trivialCode width op (Just op) x y+                        where op   = instr (intFormat width)++    -- Special case for IMUL for bytes, since the result of IMULB will be in+    -- %ax, the split to %dx/%edx/%rdx and %ax/%eax/%rax happens only for wider+    -- values.+    imulW8 :: CmmExpr -> CmmExpr -> NatM Register+    imulW8 arg_a arg_b = do+        (a_reg, a_code) <- getNonClobberedReg arg_a+        b_code <- getAnyReg arg_b++        let code = a_code `appOL` b_code eax `appOL`+                   toOL [ IMUL2 format (OpReg a_reg) ]+            format = intFormat W8++        return (Fixed format eax code)+++    imulMayOflo :: Width -> CmmExpr -> CmmExpr -> NatM Register+    imulMayOflo rep a b = do+         (a_reg, a_code) <- getNonClobberedReg a+         b_code <- getAnyReg b+         let+             shift_amt  = case rep of+                           W32 -> 31+                           W64 -> 63+                           _ -> panic "shift_amt"++             format = intFormat rep+             code = a_code `appOL` b_code eax `appOL`+                        toOL [+                           IMUL2 format (OpReg a_reg),   -- result in %edx:%eax+                           SAR format (OpImm (ImmInt shift_amt)) (OpReg eax),+                                -- sign extend lower part+                           SUB format (OpReg edx) (OpReg eax)+                                -- compare against upper+                           -- eax==0 if high part == sign extended low part+                        ]+         return (Fixed format eax code)++    --------------------+    shift_code :: Width+               -> (Format -> Operand -> Operand -> Instr)+               -> CmmExpr+               -> CmmExpr+               -> NatM Register++    {- Case1: shift length as immediate -}+    shift_code width instr x (CmmLit lit)+      -- Handle the case of a shift larger than the width of the shifted value.+      -- This is necessary since x86 applies a mask of 0x1f to the shift+      -- amount, meaning that, e.g., `shr 47, $eax` will actually shift by+      -- `47 & 0x1f == 15`. See #20626.+      | CmmInt n _ <- lit+      , n >= fromIntegral (widthInBits width)+      = getRegister $ CmmLit $ CmmInt 0 width++      | otherwise = do+          x_code <- getAnyReg x+          let+               format = intFormat width+               code dst+                  = x_code dst `snocOL`+                    instr format (OpImm (litToImm lit)) (OpReg dst)+          return (Any format code)++    {- Case2: shift length is complex (non-immediate)+      * y must go in %ecx.+      * we cannot do y first *and* put its result in %ecx, because+        %ecx might be clobbered by x.+      * if we do y second, then x cannot be+        in a clobbered reg.  Also, we cannot clobber x's reg+        with the instruction itself.+      * so we can either:+        - do y first, put its result in a fresh tmp, then copy it to %ecx later+        - do y second and put its result into %ecx.  x gets placed in a fresh+          tmp.  This is likely to be better, because the reg alloc can+          eliminate this reg->reg move here (it won't eliminate the other one,+          because the move is into the fixed %ecx).+      * in the case of C calls the use of ecx here can interfere with arguments.+        We avoid this with the hack described in Note [Evaluate C-call+        arguments before placing in destination registers]+    -}+    shift_code width instr x y{-amount-} = do+        x_code <- getAnyReg x+        let format = intFormat width+        tmp <- getNewRegNat format+        y_code <- getAnyReg y+        let+           code = x_code tmp `appOL`+                  y_code ecx `snocOL`+                  instr format (OpReg ecx) (OpReg tmp)+        return (Fixed format tmp code)++    --------------------+    add_code :: Width -> CmmExpr -> CmmExpr -> NatM Register+    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)+++getRegister' _ _ (CmmLoad mem pk _)+  | isFloatType pk+  = do+    Amode addr mem_code <- getAmode mem+    loadFloatAmode  (typeWidth pk) addr mem_code++getRegister' _ is32Bit (CmmLoad mem pk _)+  | is32Bit && not (isWord64 pk)+  = do+    code <- intLoadCode instr mem+    return (Any format code)+  where+    width = typeWidth pk+    format = intFormat width+    instr = case width of+                W8     -> MOVZxL II8+                _other -> MOV format+        -- We always zero-extend 8-bit loads, if we+        -- can't think of anything better.  This is because+        -- we can't guarantee access to an 8-bit variant of every register+        -- (esi and edi don't have 8-bit variants), so to make things+        -- simpler we do our 8-bit arithmetic with full 32-bit registers.++-- Simpler memory load code on x86_64+getRegister' _ is32Bit (CmmLoad mem pk _)+ | not is32Bit+  = do+    code <- intLoadCode (MOV format) mem+    return (Any format code)+  where format = intFormat $ typeWidth pk++getRegister' _ is32Bit (CmmLit (CmmInt 0 width))+  = let+        format = intFormat width++        -- x86_64: 32-bit xor is one byte shorter, and zero-extends to 64 bits+        format1 = if is32Bit then format+                           else case format of+                                II64 -> II32+                                _ -> format+        code dst+           = unitOL (XOR format1 (OpReg dst) (OpReg dst))+    in+        return (Any format code)++-- Handle symbol references with LEA and %rip-relative addressing.+-- See Note [%rip-relative addressing on x86-64].+getRegister' platform is32Bit (CmmLit lit)+  | is_label lit+  , not is32Bit+  = do let format = cmmTypeFormat (cmmLitType platform lit)+           imm = litToImm lit+           op = OpAddr (AddrBaseIndex EABaseRip EAIndexNone imm)+           code dst = unitOL (LEA format op (OpReg dst))+       return (Any format code)+  where+    is_label (CmmLabel {})        = True+    is_label (CmmLabelOff {})     = True+    is_label (CmmLabelDiffOff {}) = True+    is_label _                    = False++  -- optimisation for loading small literals on x86_64: take advantage+  -- of the automatic zero-extension from 32 to 64 bits, because the 32-bit+  -- instruction forms are shorter.+getRegister' platform is32Bit (CmmLit lit)+  | not is32Bit, isWord64 (cmmLitType platform lit), not (isBigLit lit)+  = let+        imm = litToImm lit+        code dst = unitOL (MOV II32 (OpImm imm) (OpReg dst))+    in+        return (Any II64 code)+  where+   isBigLit (CmmInt i _) = i < 0 || i > 0xffffffff+   isBigLit _ = False+        -- note1: not the same as (not.is32BitLit), because that checks for+        -- signed literals that fit in 32 bits, but we want unsigned+        -- literals here.+        -- note2: all labels are small, because we're assuming the+        -- small memory model. See Note [%rip-relative addressing on x86-64].++getRegister' platform _ (CmmLit lit)+  = do let format = cmmTypeFormat (cmmLitType platform lit)+           imm = litToImm lit+           code dst = unitOL (MOV format (OpImm imm) (OpReg dst))+       return (Any format code)++getRegister' platform _ other+    | isVecExpr other  = needLlvm+    | otherwise        = pprPanic "getRegister(x86)" (pdoc platform other)+++intLoadCode :: (Operand -> Operand -> Instr) -> CmmExpr+   -> NatM (Reg -> InstrBlock)+intLoadCode instr mem = do+  Amode src mem_code <- getAmode mem+  return (\dst -> mem_code `snocOL` instr (OpAddr src) (OpReg dst))++-- Compute an expression into *any* register, adding the appropriate+-- move instruction if necessary.+getAnyReg :: CmmExpr -> NatM (Reg -> InstrBlock)+getAnyReg expr = do+  r <- getRegister expr+  anyReg r++anyReg :: Register -> NatM (Reg -> InstrBlock)+anyReg (Any _ code)          = return code+anyReg (Fixed rep reg fcode) = return (\dst -> fcode `snocOL` reg2reg rep reg dst)++-- A bit like getSomeReg, but we want a reg that can be byte-addressed.+-- Fixed registers might not be byte-addressable, so we make sure we've+-- got a temporary, inserting an extra reg copy if necessary.+getByteReg :: CmmExpr -> NatM (Reg, InstrBlock)+getByteReg expr = do+  is32Bit <- is32BitPlatform+  if is32Bit+      then do r <- getRegister expr+              case r of+                Any rep code -> do+                    tmp <- getNewRegNat rep+                    return (tmp, code tmp)+                Fixed rep reg code+                    | isVirtualReg reg -> return (reg,code)+                    | otherwise -> do+                        tmp <- getNewRegNat rep+                        return (tmp, code `snocOL` reg2reg rep reg tmp)+                    -- ToDo: could optimise slightly by checking for+                    -- byte-addressable real registers, but that will+                    -- happen very rarely if at all.+      else getSomeReg expr -- all regs are byte-addressable on x86_64++-- Another variant: this time we want the result in a register that cannot+-- be modified by code to evaluate an arbitrary expression.+getNonClobberedReg :: CmmExpr -> NatM (Reg, InstrBlock)+getNonClobberedReg expr = do+  r <- getRegister expr+  platform <- ncgPlatform <$> getConfig+  case r of+    Any rep code -> do+        tmp <- getNewRegNat rep+        return (tmp, code tmp)+    Fixed rep reg code+        -- only certain regs can be clobbered+        | reg `elem` instrClobberedRegs platform+        -> do+                tmp <- getNewRegNat rep+                return (tmp, code `snocOL` reg2reg rep reg tmp)+        | otherwise ->+                return (reg, code)++reg2reg :: Format -> Reg -> Reg -> Instr+reg2reg format src dst = MOV format (OpReg src) (OpReg dst)+++--------------------------------------------------------------------------------++-- | Convert a 'CmmExpr' representing a memory address into an 'Amode'.+--+-- An 'Amode' is a datatype representing a valid address form for the target+-- (e.g. "Base + Index + disp" or immediate) and the code to compute it.+getAmode :: CmmExpr -> NatM Amode+getAmode e = do+   platform <- getPlatform+   let is32Bit = target32Bit platform++   case e of+      CmmRegOff r n+         -> getAmode $ mangleIndexTree platform r n++      CmmMachOp (MO_Add W64) [CmmReg (CmmGlobal PicBaseReg), CmmLit displacement]+         | not is32Bit+         -> return $ Amode (ripRel (litToImm displacement)) nilOL++      -- This is all just ridiculous, since it carefully undoes+      -- what mangleIndexTree has just done.+      CmmMachOp (MO_Sub _rep) [x, CmmLit lit@(CmmInt i _)]+         | is32BitLit platform lit+         -- assert (rep == II32)???+         -> do+            (x_reg, x_code) <- getSomeReg x+            let off = ImmInt (-(fromInteger i))+            return (Amode (AddrBaseIndex (EABaseReg x_reg) EAIndexNone off) x_code)++      CmmMachOp (MO_Add _rep) [x, CmmLit lit]+         | is32BitLit platform lit+         -- assert (rep == II32)???+         -> do+            (x_reg, x_code) <- getSomeReg x+            let off = litToImm lit+            return (Amode (AddrBaseIndex (EABaseReg x_reg) EAIndexNone off) x_code)++      -- Turn (lit1 << n  + lit2) into  (lit2 + lit1 << n) so it will be+      -- recognised by the next rule.+      CmmMachOp (MO_Add rep) [a@(CmmMachOp (MO_Shl _) _), b@(CmmLit _)]+         -> getAmode (CmmMachOp (MO_Add rep) [b,a])++      -- Matches: (x + offset) + (y << shift)+      CmmMachOp (MO_Add _) [CmmRegOff x offset, CmmMachOp (MO_Shl _) [y, CmmLit (CmmInt shift _)]]+         | shift == 0 || shift == 1 || shift == 2 || shift == 3+         -> x86_complex_amode (CmmReg x) y shift (fromIntegral offset)++      CmmMachOp (MO_Add _) [x, CmmMachOp (MO_Shl _) [y, CmmLit (CmmInt shift _)]]+         | shift == 0 || shift == 1 || shift == 2 || shift == 3+         -> x86_complex_amode x y shift 0++      CmmMachOp (MO_Add _) [x, CmmMachOp (MO_Add _) [CmmMachOp (MO_Shl _)+                                                    [y, CmmLit (CmmInt shift _)], CmmLit (CmmInt offset _)]]+         | shift == 0 || shift == 1 || shift == 2 || shift == 3+         && is32BitInteger offset+         -> x86_complex_amode x y shift offset++      CmmMachOp (MO_Add _) [x,y]+         | not (isLit y) -- we already handle valid literals above.+         -> x86_complex_amode x y 0 0++      -- Handle labels with %rip-relative addressing since in general the image+      -- may be loaded anywhere in the 64-bit address space (e.g. on Windows+      -- with high-entropy ASLR). See Note [%rip-relative addressing on x86-64].+      CmmLit lit+         | not is32Bit+         , is_label lit+         -> return (Amode (AddrBaseIndex EABaseRip EAIndexNone (litToImm lit)) nilOL)++      CmmLit lit+         | is32BitLit platform lit+         -> return (Amode (ImmAddr (litToImm lit) 0) nilOL)++      -- Literal with offsets too big (> 32 bits) fails during the linking phase+      -- (#15570). We already handled valid literals above so we don't have to+      -- test anything here.+      CmmLit (CmmLabelOff l off)+         -> getAmode (CmmMachOp (MO_Add W64) [ CmmLit (CmmLabel l)+                                             , CmmLit (CmmInt (fromIntegral off) W64)+                                             ])+      CmmLit (CmmLabelDiffOff l1 l2 off w)+         -> getAmode (CmmMachOp (MO_Add W64) [ CmmLit (CmmLabelDiffOff l1 l2 0 w)+                                             , CmmLit (CmmInt (fromIntegral off) W64)+                                             ])++      -- in case we can't do something better, we just compute the expression+      -- and put the result in a register+      _ -> do+        (reg,code) <- getSomeReg e+        return (Amode (AddrBaseIndex (EABaseReg reg) EAIndexNone (ImmInt 0)) code)+  where+    is_label (CmmLabel{}) = True+    is_label (CmmLabelOff{}) = True+    is_label (CmmLabelDiffOff{}) = True+    is_label _ = False+++-- | Like 'getAmode', but on 32-bit use simple register addressing+-- (i.e. no index register). This stops us from running out of+-- registers on x86 when using instructions such as cmpxchg, which can+-- use up to three virtual registers and one fixed register.+getSimpleAmode :: CmmExpr -> NatM Amode+getSimpleAmode addr = is32BitPlatform >>= \case+  False -> getAmode addr+  True  -> do+    addr_code <- getAnyReg addr+    config <- getConfig+    addr_r <- getNewRegNat (intFormat (ncgWordWidth config))+    let amode = AddrBaseIndex (EABaseReg addr_r) EAIndexNone (ImmInt 0)+    return $! Amode amode (addr_code addr_r)++x86_complex_amode :: CmmExpr -> CmmExpr -> Integer -> Integer -> NatM Amode+x86_complex_amode base index shift offset+  = do (x_reg, x_code) <- getNonClobberedReg base+        -- x must be in a temp, because it has to stay live over y_code+        -- we could compare x_reg and y_reg and do something better here...+       (y_reg, y_code) <- getSomeReg index+       let+           code = x_code `appOL` y_code+           base = case shift of 0 -> 1; 1 -> 2; 2 -> 4; 3 -> 8;+                                n -> panic $ "x86_complex_amode: unhandled shift! (" ++ show n ++ ")"+       return (Amode (AddrBaseIndex (EABaseReg x_reg) (EAIndex y_reg base) (ImmInt (fromIntegral offset)))+               code)+++++-- -----------------------------------------------------------------------------+-- getOperand: sometimes any operand will do.++-- getNonClobberedOperand: the value of the operand will remain valid across+-- the computation of an arbitrary expression, unless the expression+-- is computed directly into a register which the operand refers to+-- (see trivialCode where this function is used for an example).++getNonClobberedOperand :: CmmExpr -> NatM (Operand, InstrBlock)+getNonClobberedOperand (CmmLit lit) =+  if isSuitableFloatingPointLit lit+  then do+    let CmmFloat _ w = lit+    Amode addr code <- memConstant (mkAlignment $ widthInBytes w) lit+    return (OpAddr addr, code)+  else do+    platform <- getPlatform+    if is32BitLit platform lit && not (isFloatType (cmmLitType platform lit))+    then return (OpImm (litToImm lit), nilOL)+    else getNonClobberedOperand_generic (CmmLit lit)++getNonClobberedOperand (CmmLoad mem pk _) = do+  is32Bit <- is32BitPlatform+  -- this logic could be simplified+  -- TODO FIXME+  if   (if is32Bit then not (isWord64 pk) else True)+      -- if 32bit and pk is at float/double/simd value+      -- or if 64bit+      --  this could use some eyeballs or i'll need to stare at it more later+    then do+      platform <- ncgPlatform <$> getConfig+      Amode src mem_code <- getAmode mem+      (src',save_code) <-+        if (amodeCouldBeClobbered platform src)+                then do+                   tmp <- getNewRegNat (archWordFormat is32Bit)+                   return (AddrBaseIndex (EABaseReg tmp) EAIndexNone (ImmInt 0),+                           unitOL (LEA (archWordFormat is32Bit)+                                       (OpAddr src)+                                       (OpReg tmp)))+                else+                   return (src, nilOL)+      return (OpAddr src', mem_code `appOL` save_code)+    else+      -- if its a word or gcptr on 32bit?+      getNonClobberedOperand_generic (CmmLoad mem pk NaturallyAligned)++getNonClobberedOperand e = getNonClobberedOperand_generic e++getNonClobberedOperand_generic :: CmmExpr -> NatM (Operand, InstrBlock)+getNonClobberedOperand_generic e = do+  (reg, code) <- getNonClobberedReg e+  return (OpReg reg, code)++amodeCouldBeClobbered :: Platform -> AddrMode -> Bool+amodeCouldBeClobbered platform amode = any (regClobbered platform) (addrModeRegs amode)++regClobbered :: Platform -> Reg -> Bool+regClobbered platform (RegReal (RealRegSingle rr)) = freeReg platform rr+regClobbered _ _ = False++-- getOperand: the operand is not required to remain valid across the+-- computation of an arbitrary expression.+getOperand :: CmmExpr -> NatM (Operand, InstrBlock)++getOperand (CmmLit lit) = do+  use_sse2 <- sse2Enabled+  if (use_sse2 && isSuitableFloatingPointLit lit)+    then do+      let CmmFloat _ w = lit+      Amode addr code <- memConstant (mkAlignment $ widthInBytes w) lit+      return (OpAddr addr, code)+    else do++  platform <- getPlatform+  if is32BitLit platform lit && not (isFloatType (cmmLitType platform lit))+    then return (OpImm (litToImm lit), nilOL)+    else getOperand_generic (CmmLit lit)++getOperand (CmmLoad mem pk _) = do+  is32Bit <- is32BitPlatform+  use_sse2 <- sse2Enabled+  if (not (isFloatType pk) || use_sse2) && (if is32Bit then not (isWord64 pk) else True)+     then do+       Amode src mem_code <- getAmode mem+       return (OpAddr src, mem_code)+     else+       getOperand_generic (CmmLoad mem pk NaturallyAligned)++getOperand e = getOperand_generic e++getOperand_generic :: CmmExpr -> NatM (Operand, InstrBlock)+getOperand_generic e = do+    (reg, code) <- getSomeReg e+    return (OpReg reg, code)++isOperand :: Platform -> CmmExpr -> Bool+isOperand _ (CmmLoad _ _ _) = True+isOperand platform (CmmLit lit)+                          = is32BitLit platform lit+                          || isSuitableFloatingPointLit lit+isOperand _ _            = False++-- | Given a 'Register', produce a new 'Register' with an instruction block+-- which will check the value for alignment. Used for @-falignment-sanitisation@.+addAlignmentCheck :: Int -> Register -> Register+addAlignmentCheck align reg =+    case reg of+      Fixed fmt reg code -> Fixed fmt reg (code `appOL` check fmt reg)+      Any fmt f          -> Any fmt (\reg -> f reg `appOL` check fmt reg)+  where+    check :: Format -> Reg -> InstrBlock+    check fmt reg =+        assert (not $ isFloatFormat fmt) $+        toOL [ TEST fmt (OpImm $ ImmInt $ align-1) (OpReg reg)+             , JXX_GBL NE $ ImmCLbl mkBadAlignmentLabel+             ]++memConstant :: Alignment -> CmmLit -> NatM Amode+memConstant align lit = do+  lbl <- getNewLabelNat+  let rosection = Section ReadOnlyData lbl+  config <- getConfig+  platform <- getPlatform+  (addr, addr_code) <- if target32Bit platform+                       then do dynRef <- cmmMakeDynamicReference+                                             config+                                             DataReference+                                             lbl+                               Amode addr addr_code <- getAmode dynRef+                               return (addr, addr_code)+                       else return (ripRel (ImmCLbl lbl), nilOL)+  let code =+        LDATA rosection (align, CmmStaticsRaw lbl [CmmStaticLit lit])+        `consOL` addr_code+  return (Amode addr code)+++loadFloatAmode :: Width -> AddrMode -> InstrBlock -> NatM Register+loadFloatAmode w addr addr_code = do+  let format = floatFormat w+      code dst = addr_code `snocOL`+                    MOV format (OpAddr addr) (OpReg dst)++  return (Any format code)+++-- if we want a floating-point literal as an operand, we can+-- use it directly from memory.  However, if the literal is+-- zero, we're better off generating it into a register using+-- xor.+isSuitableFloatingPointLit :: CmmLit -> Bool+isSuitableFloatingPointLit (CmmFloat f _) = f /= 0.0+isSuitableFloatingPointLit _ = False++getRegOrMem :: CmmExpr -> NatM (Operand, InstrBlock)+getRegOrMem e@(CmmLoad mem pk _) = do+  is32Bit <- is32BitPlatform+  use_sse2 <- sse2Enabled+  if (not (isFloatType pk) || use_sse2) && (if is32Bit then not (isWord64 pk) else True)+     then do+       Amode src mem_code <- getAmode mem+       return (OpAddr src, mem_code)+     else do+       (reg, code) <- getNonClobberedReg e+       return (OpReg reg, code)+getRegOrMem e = do+    (reg, code) <- getNonClobberedReg e+    return (OpReg reg, code)++is32BitLit :: Platform -> CmmLit -> Bool+is32BitLit platform _lit+   | target32Bit platform = True+is32BitLit platform lit =+   case lit of+      CmmInt i W64              -> is32BitInteger i+      -- Except on Windows, assume that labels are in the range 0-2^31-1: this+      -- assumes the small memory model. Note [%rip-relative addressing on+      -- x86-64].+      CmmLabel _                -> low_image+      -- however we can't assume that label offsets are in this range+      -- (see #15570)+      CmmLabelOff _ off         -> low_image && is32BitInteger (fromIntegral off)+      CmmLabelDiffOff _ _ off _ -> low_image && is32BitInteger (fromIntegral off)+      _                         -> True+  where+    -- Is the executable image certain to be located below 4GB? As noted in+    -- Note [%rip-relative addressing on x86-64], this is not true on Windows.+    low_image =+      case platformOS platform of+        OSMinGW32 -> False   -- See Note [%rip-relative addressing on x86-64]+        _         -> True+++-- Set up a condition code for a conditional branch.++getCondCode :: CmmExpr -> NatM CondCode++-- yes, they really do seem to want exactly the same!++getCondCode (CmmMachOp mop [x, y])+  =+    case mop of+      MO_F_Eq W32 -> condFltCode EQQ x y+      MO_F_Ne W32 -> condFltCode NE  x y+      MO_F_Gt W32 -> condFltCode GTT x y+      MO_F_Ge W32 -> condFltCode GE  x y+      -- Invert comparison condition and swap operands+      -- See Note [SSE Parity Checks]+      MO_F_Lt W32 -> condFltCode GTT  y x+      MO_F_Le W32 -> condFltCode GE   y x++      MO_F_Eq W64 -> condFltCode EQQ x y+      MO_F_Ne W64 -> condFltCode NE  x y+      MO_F_Gt W64 -> condFltCode GTT x y+      MO_F_Ge W64 -> condFltCode GE  x y+      MO_F_Lt W64 -> condFltCode GTT y x+      MO_F_Le W64 -> condFltCode GE  y x++      _ -> condIntCode (machOpToCond mop) x y++getCondCode other = do+   platform <- getPlatform+   pprPanic "getCondCode(2)(x86,x86_64)" (pdoc platform other)++machOpToCond :: MachOp -> Cond+machOpToCond mo = case mo of+  MO_Eq _   -> EQQ+  MO_Ne _   -> NE+  MO_S_Gt _ -> GTT+  MO_S_Ge _ -> GE+  MO_S_Lt _ -> LTT+  MO_S_Le _ -> LE+  MO_U_Gt _ -> GU+  MO_U_Ge _ -> GEU+  MO_U_Lt _ -> LU+  MO_U_Le _ -> LEU+  _other -> pprPanic "machOpToCond" (pprMachOp mo)+++-- @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be+-- passed back up the tree.++condIntCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode+condIntCode cond x y = do platform <- getPlatform+                          condIntCode' platform cond x y++condIntCode' :: Platform -> Cond -> CmmExpr -> CmmExpr -> NatM CondCode++-- memory vs immediate+condIntCode' platform cond (CmmLoad x pk _) (CmmLit lit)+ | is32BitLit platform lit = do+    Amode x_addr x_code <- getAmode x+    let+        imm  = litToImm lit+        code = x_code `snocOL`+                  CMP (cmmTypeFormat pk) (OpImm imm) (OpAddr x_addr)+    --+    return (CondCode False cond code)++-- anything vs zero, using a mask+-- TODO: Add some sanity checking!!!!+condIntCode' platform cond (CmmMachOp (MO_And _) [x,o2]) (CmmLit (CmmInt 0 pk))+    | (CmmLit lit@(CmmInt mask _)) <- o2, is32BitLit platform lit+    = do+      (x_reg, x_code) <- getSomeReg x+      let+         code = x_code `snocOL`+                TEST (intFormat pk) (OpImm (ImmInteger mask)) (OpReg x_reg)+      --+      return (CondCode False cond code)++-- anything vs zero+condIntCode' _ cond x (CmmLit (CmmInt 0 pk)) = do+    (x_reg, x_code) <- getSomeReg x+    let+        code = x_code `snocOL`+                  TEST (intFormat pk) (OpReg x_reg) (OpReg x_reg)+    --+    return (CondCode False cond code)++-- anything vs operand+condIntCode' platform cond x y+ | isOperand platform y = do+    (x_reg, x_code) <- getNonClobberedReg x+    (y_op,  y_code) <- getOperand y+    let+        code = x_code `appOL` y_code `snocOL`+                  CMP (cmmTypeFormat (cmmExprType platform x)) y_op (OpReg x_reg)+    return (CondCode False cond code)+-- operand vs. anything: invert the comparison so that we can use a+-- single comparison instruction.+ | isOperand platform x+ , Just revcond <- maybeFlipCond cond = do+    (y_reg, y_code) <- getNonClobberedReg y+    (x_op,  x_code) <- getOperand x+    let+        code = y_code `appOL` x_code `snocOL`+                  CMP (cmmTypeFormat (cmmExprType platform x)) x_op (OpReg y_reg)+    return (CondCode False revcond code)++-- anything vs anything+condIntCode' platform cond x y = do+  (y_reg, y_code) <- getNonClobberedReg y+  (x_op, x_code) <- getRegOrMem x+  let+        code = y_code `appOL`+               x_code `snocOL`+                  CMP (cmmTypeFormat (cmmExprType platform x)) (OpReg y_reg) x_op+  return (CondCode False cond code)++++--------------------------------------------------------------------------------+condFltCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode++condFltCode cond x y+  =  condFltCode_sse2+  where+++  -- in the SSE2 comparison ops (ucomiss, ucomisd) the left arg may be+  -- an operand, but the right must be a reg.  We can probably do better+  -- than this general case...+  condFltCode_sse2 = do+    platform <- getPlatform+    (x_reg, x_code) <- getNonClobberedReg x+    (y_op, y_code) <- getOperand y+    let+        code = x_code `appOL`+               y_code `snocOL`+                  CMP (floatFormat $ cmmExprWidth platform x) y_op (OpReg x_reg)+        -- NB(1): we need to use the unsigned comparison operators on the+        -- result of this comparison.+    return (CondCode True (condToUnsigned cond) code)++-- -----------------------------------------------------------------------------+-- Generating assignments++-- Assignments are really at the heart of the whole code generation+-- business.  Almost all top-level nodes of any real importance are+-- assignments, which correspond to loads, stores, or register+-- transfers.  If we're really lucky, some of the register transfers+-- will go away, because we can use the destination register to+-- complete the code generation for the right hand side.  This only+-- fails when the right hand side is forced into a fixed register+-- (e.g. the result of a call).++assignMem_IntCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock+assignReg_IntCode :: Format -> CmmReg  -> CmmExpr -> NatM InstrBlock++assignMem_FltCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock+assignReg_FltCode :: Format -> CmmReg  -> CmmExpr -> NatM InstrBlock+++-- integer assignment to memory++-- specific case of adding/subtracting an integer to a particular address.+-- ToDo: catch other cases where we can use an operation directly on a memory+-- address.+assignMem_IntCode pk addr (CmmMachOp op [CmmLoad addr2 _ _,+                                                 CmmLit (CmmInt i _)])+   | addr == addr2, pk /= II64 || is32BitInteger i,+     Just instr <- check op+   = do Amode amode code_addr <- getAmode addr+        let code = code_addr `snocOL`+                   instr pk (OpImm (ImmInt (fromIntegral i))) (OpAddr amode)+        return code+   where+        check (MO_Add _) = Just ADD+        check (MO_Sub _) = Just SUB+        check _ = Nothing+        -- ToDo: more?++-- general case+assignMem_IntCode pk addr src = do+    platform <- getPlatform+    Amode addr code_addr <- getAmode addr+    (code_src, op_src)   <- get_op_RI platform src+    let+        code = code_src `appOL`+               code_addr `snocOL`+                  MOV pk op_src (OpAddr addr)+        -- NOTE: op_src is stable, so it will still be valid+        -- after code_addr.  This may involve the introduction+        -- of an extra MOV to a temporary register, but we hope+        -- the register allocator will get rid of it.+    --+    return code+  where+    get_op_RI :: Platform -> CmmExpr -> NatM (InstrBlock,Operand)   -- code, operator+    get_op_RI platform (CmmLit lit) | is32BitLit platform lit+      = return (nilOL, OpImm (litToImm lit))+    get_op_RI _ op+      = do (reg,code) <- getNonClobberedReg op+           return (code, OpReg reg)+++-- Assign; dst is a reg, rhs is mem+assignReg_IntCode pk reg (CmmLoad src _ _) = do+  load_code <- intLoadCode (MOV pk) src+  platform <- ncgPlatform <$> getConfig+  return (load_code (getRegisterReg platform reg))++-- dst is a reg, but src could be anything+assignReg_IntCode _ reg src = do+  platform <- ncgPlatform <$> getConfig+  code <- getAnyReg src+  return (code (getRegisterReg platform reg))+++-- Floating point assignment to memory+assignMem_FltCode pk addr src = do+  (src_reg, src_code) <- getNonClobberedReg src+  Amode addr addr_code <- getAmode addr+  let+        code = src_code `appOL`+               addr_code `snocOL`+               MOV pk (OpReg src_reg) (OpAddr addr)++  return code++-- Floating point assignment to a register/temporary+assignReg_FltCode _ reg src = do+  src_code <- getAnyReg src+  platform <- ncgPlatform <$> getConfig+  return (src_code (getRegisterReg platform reg))+++genJump :: CmmExpr{-the branch target-} -> [Reg] -> NatM InstrBlock++genJump (CmmLoad mem _ _) regs = do+  Amode target code <- getAmode mem+  return (code `snocOL` JMP (OpAddr target) regs)++genJump (CmmLit lit) regs =+  return (unitOL (JMP (OpImm (litToImm lit)) regs))++genJump expr regs = do+  (reg,code) <- getSomeReg expr+  return (code `snocOL` JMP (OpReg reg) regs)+++-- -----------------------------------------------------------------------------+--  Unconditional branches++genBranch :: BlockId -> InstrBlock+genBranch = toOL . mkJumpInstr++++-- -----------------------------------------------------------------------------+--  Conditional jumps/branches++{-+Conditional jumps are always to local labels, so we can use branch+instructions.  We peek at the arguments to decide what kind of+comparison to do.++I386: First, we have to ensure that the condition+codes are set according to the supplied comparison operation.+-}++{-  Note [64-bit integer comparisons on 32-bit]+    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++    When doing these comparisons there are 2 kinds of+    comparisons.++    * Comparison for equality (or lack thereof)++    We use xor to check if high/low bits are+    equal. Then combine the results using or and+    perform a single conditional jump based on the+    result.++    * Other comparisons:++    We map all other comparisons to the >= operation.+    Why? Because it's easy to encode it with a single+    conditional jump.++    We do this by first computing [r1_lo - r2_lo]+    and use the carry flag to compute+    [r1_high - r2_high - CF].++    At which point if r1 >= r2 then the result will be+    positive. Otherwise negative so we can branch on this+    condition.++-}+++genCondBranch+    :: BlockId      -- the source of the jump+    -> BlockId      -- the true branch target+    -> BlockId      -- the false branch target+    -> CmmExpr      -- the condition on which to branch+    -> NatM InstrBlock -- Instructions++genCondBranch bid id false expr = do+  is32Bit <- is32BitPlatform+  genCondBranch' is32Bit bid id false expr++-- | We return the instructions generated.+genCondBranch' :: Bool -> BlockId -> BlockId -> BlockId -> CmmExpr+               -> NatM InstrBlock++-- 64-bit integer comparisons on 32-bit+-- See Note [64-bit integer comparisons on 32-bit]+genCondBranch' is32Bit _bid true false (CmmMachOp mop [e1,e2])+  | is32Bit, Just W64 <- maybeIntComparison mop = do++  RegCode64 code1 r1hi r1lo <- iselExpr64 e1+  RegCode64 code2 r2hi r2lo <- iselExpr64 e2+  let cond = machOpToCond mop :: Cond++  -- we mustn't clobber r1/r2 so we use temporaries+  tmp1 <- getNewRegNat II32+  tmp2 <- getNewRegNat II32++  let cmpCode = intComparison cond true false r1hi r1lo r2hi r2lo tmp1 tmp2+  return $ code1 `appOL` code2 `appOL` cmpCode++  where+    intComparison cond true false r1_hi r1_lo r2_hi r2_lo tmp1 tmp2 =+      case cond of+        -- Impossible results of machOpToCond+        ALWAYS  -> panic "impossible"+        NEG     -> panic "impossible"+        POS     -> panic "impossible"+        CARRY   -> panic "impossible"+        OFLO    -> panic "impossible"+        PARITY  -> panic "impossible"+        NOTPARITY -> panic "impossible"+        -- Special case #1 x == y and x != y+        EQQ -> cmpExact+        NE  -> cmpExact+        -- [x >= y]+        GE  -> cmpGE+        GEU -> cmpGE+        -- [x >  y] <==> ![y >= x]+        GTT -> intComparison GE  false true r2_hi r2_lo r1_hi r1_lo tmp1 tmp2+        GU  -> intComparison GEU false true r2_hi r2_lo r1_hi r1_lo tmp1 tmp2+        -- [x <= y] <==> [y >= x]+        LE  -> intComparison GE  true false r2_hi r2_lo r1_hi r1_lo tmp1 tmp2+        LEU -> intComparison GEU true false r2_hi r2_lo r1_hi r1_lo tmp1 tmp2+        -- [x <  y] <==> ![x >= x]+        LTT -> intComparison GE  false true r1_hi r1_lo r2_hi r2_lo tmp1 tmp2+        LU  -> intComparison GEU false true r1_hi r1_lo r2_hi r2_lo tmp1 tmp2+      where+        cmpExact :: OrdList Instr+        cmpExact =+          toOL+            [ MOV II32 (OpReg r1_hi) (OpReg tmp1)+            , MOV II32 (OpReg r1_lo) (OpReg tmp2)+            , XOR II32 (OpReg r2_hi) (OpReg tmp1)+            , XOR II32 (OpReg r2_lo) (OpReg tmp2)+            , OR  II32 (OpReg tmp1)  (OpReg tmp2)+            , JXX cond true+            , JXX ALWAYS false+            ]+        cmpGE = toOL+            [ MOV II32 (OpReg r1_hi) (OpReg tmp1)+            , CMP II32 (OpReg r2_lo) (OpReg r1_lo)+            , SBB II32 (OpReg r2_hi) (OpReg tmp1)+            , JXX cond true+            , JXX ALWAYS false ]++genCondBranch' _ bid id false bool = do+  CondCode is_float cond cond_code <- getCondCode bool+  use_sse2 <- sse2Enabled+  if not is_float || not use_sse2+    then+        return (cond_code `snocOL` JXX cond id `appOL` genBranch false)+    else do+        -- See Note [SSE Parity Checks]+        let jmpFalse = genBranch false+            code+                = case cond of+                  NE  -> or_unordered+                  GU  -> plain_test+                  GEU -> plain_test+                  -- Use ASSERT so we don't break releases if+                  -- LTT/LE creep in somehow.+                  LTT ->+                    assertPpr False (ppr "Should have been turned into >")+                    and_ordered+                  LE  ->+                    assertPpr False (ppr "Should have been turned into >=")+                    and_ordered+                  _   -> and_ordered++            plain_test = unitOL (+                  JXX cond id+                ) `appOL` jmpFalse+            or_unordered = toOL [+                  JXX cond id,+                  JXX PARITY id+                ] `appOL` jmpFalse+            and_ordered = toOL [+                  JXX PARITY false,+                  JXX cond id,+                  JXX ALWAYS false+                ]+        updateCfgNat (\cfg -> adjustEdgeWeight cfg (+3) bid false)+        return (cond_code `appOL` code)++{-  Note [Introducing cfg edges inside basic blocks]+    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++    During instruction selection a statement `s`+    in a block B with control of the sort: B -> C+    will sometimes result in control+    flow of the sort:++            ┌ < ┐+            v   ^+      B ->  B1  ┴ -> C++    as is the case for some atomic operations.++    Now to keep the CFG in sync when introducing B1 we clearly+    want to insert it between B and C. However there is+    a catch when we have to deal with self loops.++    We might start with code and a CFG of these forms:++    loop:+        stmt1               ┌ < ┐+        ....                v   ^+        stmtX              loop ┘+        stmtY+        ....+        goto loop:++    Now we introduce B1:+                            ┌ ─ ─ ─ ─ ─┐+        loop:               │   ┌ <  ┐ │+        instrs              v   │    │ ^+        ....               loop ┴ B1 ┴ ┘+        instrsFromX+        stmtY+        goto loop:++    This is simple, all outgoing edges from loop now simply+    start from B1 instead and the code generator knows which+    new edges it introduced for the self loop of B1.++    Disaster strikes if the statement Y follows the same pattern.+    If we apply the same rule that all outgoing edges change then+    we end up with:++        loop ─> B1 ─> B2 ┬─┐+          │      │    └─<┤ │+          │      └───<───┘ │+          └───────<────────┘++    This is problematic. The edge B1->B1 is modified as expected.+    However the modification is wrong!++    The assembly in this case looked like this:++    _loop:+        <instrs>+    _B1:+        ...+        cmpxchgq ...+        jne _B1+        <instrs>+        <end _B1>+    _B2:+        ...+        cmpxchgq ...+        jne _B2+        <instrs>+        jmp loop++    There is no edge _B2 -> _B1 here. It's still a self loop onto _B1.++    The problem here is that really B1 should be two basic blocks.+    Otherwise we have control flow in the *middle* of a basic block.+    A contradiction!++    So to account for this we add yet another basic block marker:++    _B:+        <instrs>+    _B1:+        ...+        cmpxchgq ...+        jne _B1+        jmp _B1'+    _B1':+        <instrs>+        <end _B1>+    _B2:+        ...++    Now when inserting B2 we will only look at the outgoing edges of B1' and+    everything will work out nicely.++    You might also wonder why we don't insert jumps at the end of _B1'. There is+    no way another block ends up jumping to the labels _B1 or _B2 since they are+    essentially invisible to other blocks. View them as control flow labels local+    to the basic block if you'd like.++    Not doing this ultimately caused (part 2 of) #17334.+-}+++-- -----------------------------------------------------------------------------+--  Generating C calls++-- Now the biggest nightmare---calls.  Most of the nastiness is buried in+-- @get_arg@, which moves the arguments to the correct registers/stack+-- locations.  Apart from that, the code is easy.+--+-- (If applicable) Do not fill the delay slots here; you will confuse the+-- register allocator.+--+-- See Note [Keeping track of the current block] for information why we need+-- to take/return a block id.++genForeignCall+    :: ForeignTarget -- ^ function to call+    -> [CmmFormal]   -- ^ where to put the result+    -> [CmmActual]   -- ^ arguments (of mixed type)+    -> BlockId       -- ^ The block we are in+    -> NatM (InstrBlock, Maybe BlockId)++genForeignCall target dst args bid = do+  case target of+    PrimTarget prim         -> genPrim bid prim dst args+    ForeignTarget addr conv -> (,Nothing) <$> genCCall bid addr conv dst args++genPrim+    :: BlockId       -- ^ The block we are in+    -> CallishMachOp -- ^ MachOp+    -> [CmmFormal]   -- ^ where to put the result+    -> [CmmActual]   -- ^ arguments (of mixed type)+    -> NatM (InstrBlock, Maybe BlockId)++-- First we deal with cases which might introduce new blocks in the stream.+genPrim bid (MO_AtomicRMW width amop) [dst] [addr, n]+  = genAtomicRMW bid width amop dst addr n+genPrim bid (MO_Ctz width) [dst] [src]+  = genCtz bid width dst src++-- Then we deal with cases which not introducing new blocks in the stream.+genPrim bid prim dst args+  = (,Nothing) <$> genSimplePrim bid prim dst args++genSimplePrim+    :: BlockId       -- ^ the block we are in+    -> CallishMachOp -- ^ MachOp+    -> [CmmFormal]   -- ^ where to put the result+    -> [CmmActual]   -- ^ arguments (of mixed type)+    -> NatM InstrBlock+genSimplePrim bid (MO_Memcpy align)    []      [dst,src,n]    = genMemCpy  bid align dst src n+genSimplePrim bid (MO_Memmove align)   []      [dst,src,n]    = genMemMove bid align dst src n+genSimplePrim bid (MO_Memcmp align)    [res]   [dst,src,n]    = genMemCmp  bid align res dst src n+genSimplePrim bid (MO_Memset align)    []      [dst,c,n]      = genMemSet  bid align dst c n+genSimplePrim _   MO_ReadBarrier       []      []             = return nilOL -- barriers compile to no code on x86/x86-64;+genSimplePrim _   MO_WriteBarrier      []      []             = return nilOL -- we keep it this long in order to prevent earlier optimisations.+genSimplePrim _   MO_Touch             []      [_]            = return nilOL+genSimplePrim _   (MO_Prefetch_Data n) []      [src]          = genPrefetchData n src+genSimplePrim _   (MO_BSwap width)     [dst]   [src]          = genByteSwap width dst src+genSimplePrim bid (MO_BRev width)      [dst]   [src]          = genBitRev bid width dst src+genSimplePrim bid (MO_PopCnt width)    [dst]   [src]          = genPopCnt bid width dst src+genSimplePrim bid (MO_Pdep width)      [dst]   [src,mask]     = genPdep bid width dst src mask+genSimplePrim bid (MO_Pext width)      [dst]   [src,mask]     = genPext bid width dst src mask+genSimplePrim bid (MO_Clz width)       [dst]   [src]          = genClz bid width dst src+genSimplePrim bid (MO_UF_Conv width)   [dst]   [src]          = genWordToFloat bid width dst src+genSimplePrim _   (MO_AtomicRead w)    [dst]   [addr]         = genAtomicRead w dst addr+genSimplePrim _   (MO_AtomicWrite w)   []      [addr,val]     = genAtomicWrite w addr val+genSimplePrim bid (MO_Cmpxchg width)   [dst]   [addr,old,new] = genCmpXchg bid width dst addr old new+genSimplePrim _   (MO_Xchg width)      [dst]   [addr, value]  = genXchg width dst addr value+genSimplePrim _   (MO_AddWordC w)      [r,c]   [x,y]          = genAddSubRetCarry w ADD_CC (const Nothing) CARRY r c x y+genSimplePrim _   (MO_SubWordC w)      [r,c]   [x,y]          = genAddSubRetCarry w SUB_CC (const Nothing) CARRY r c x y+genSimplePrim _   (MO_AddIntC w)       [r,c]   [x,y]          = genAddSubRetCarry w ADD_CC (Just . ADD_CC) OFLO  r c x y+genSimplePrim _   (MO_SubIntC w)       [r,c]   [x,y]          = genAddSubRetCarry w SUB_CC (const Nothing) OFLO  r c x y+genSimplePrim _   (MO_Add2 w)          [h,l]   [x,y]          = genAddWithCarry w h l x y+genSimplePrim _   (MO_U_Mul2 w)        [h,l]   [x,y]          = genUnsignedLargeMul w h l x y+genSimplePrim _   (MO_S_Mul2 w)        [c,h,l] [x,y]          = genSignedLargeMul w c h l x y+genSimplePrim _   (MO_S_QuotRem w)     [q,r]   [x,y]          = genQuotRem w True  q r Nothing   x  y+genSimplePrim _   (MO_U_QuotRem w)     [q,r]   [x,y]          = genQuotRem w False q r Nothing   x  y+genSimplePrim _   (MO_U_QuotRem2 w)    [q,r]   [hx,lx,y]      = genQuotRem w False q r (Just hx) lx y+genSimplePrim _   MO_F32_Fabs          [dst]   [src]          = genFloatAbs W32 dst src+genSimplePrim _   MO_F64_Fabs          [dst]   [src]          = genFloatAbs W64 dst src+genSimplePrim _   MO_F32_Sqrt          [dst]   [src]          = genFloatSqrt FF32 dst src+genSimplePrim _   MO_F64_Sqrt          [dst]   [src]          = genFloatSqrt FF64 dst src+genSimplePrim bid MO_F32_Sin           [dst]   [src]          = genLibCCall bid (fsLit "sinf") [dst] [src]+genSimplePrim bid MO_F32_Cos           [dst]   [src]          = genLibCCall bid (fsLit "cosf") [dst] [src]+genSimplePrim bid MO_F32_Tan           [dst]   [src]          = genLibCCall bid (fsLit "tanf") [dst] [src]+genSimplePrim bid MO_F32_Exp           [dst]   [src]          = genLibCCall bid (fsLit "expf") [dst] [src]+genSimplePrim bid MO_F32_ExpM1         [dst]   [src]          = genLibCCall bid (fsLit "expm1f") [dst] [src]+genSimplePrim bid MO_F32_Log           [dst]   [src]          = genLibCCall bid (fsLit "logf") [dst] [src]+genSimplePrim bid MO_F32_Log1P         [dst]   [src]          = genLibCCall bid (fsLit "log1pf") [dst] [src]+genSimplePrim bid MO_F32_Asin          [dst]   [src]          = genLibCCall bid (fsLit "asinf") [dst] [src]+genSimplePrim bid MO_F32_Acos          [dst]   [src]          = genLibCCall bid (fsLit "acosf") [dst] [src]+genSimplePrim bid MO_F32_Atan          [dst]   [src]          = genLibCCall bid (fsLit "atanf") [dst] [src]+genSimplePrim bid MO_F32_Sinh          [dst]   [src]          = genLibCCall bid (fsLit "sinhf") [dst] [src]+genSimplePrim bid MO_F32_Cosh          [dst]   [src]          = genLibCCall bid (fsLit "coshf") [dst] [src]+genSimplePrim bid MO_F32_Tanh          [dst]   [src]          = genLibCCall bid (fsLit "tanhf") [dst] [src]+genSimplePrim bid MO_F32_Pwr           [dst]   [x,y]          = genLibCCall bid (fsLit "powf")  [dst] [x,y]+genSimplePrim bid MO_F32_Asinh         [dst]   [src]          = genLibCCall bid (fsLit "asinhf") [dst] [src]+genSimplePrim bid MO_F32_Acosh         [dst]   [src]          = genLibCCall bid (fsLit "acoshf") [dst] [src]+genSimplePrim bid MO_F32_Atanh         [dst]   [src]          = genLibCCall bid (fsLit "atanhf") [dst] [src]+genSimplePrim bid MO_F64_Sin           [dst]   [src]          = genLibCCall bid (fsLit "sin") [dst] [src]+genSimplePrim bid MO_F64_Cos           [dst]   [src]          = genLibCCall bid (fsLit "cos") [dst] [src]+genSimplePrim bid MO_F64_Tan           [dst]   [src]          = genLibCCall bid (fsLit "tan") [dst] [src]+genSimplePrim bid MO_F64_Exp           [dst]   [src]          = genLibCCall bid (fsLit "exp") [dst] [src]+genSimplePrim bid MO_F64_ExpM1         [dst]   [src]          = genLibCCall bid (fsLit "expm1") [dst] [src]+genSimplePrim bid MO_F64_Log           [dst]   [src]          = genLibCCall bid (fsLit "log") [dst] [src]+genSimplePrim bid MO_F64_Log1P         [dst]   [src]          = genLibCCall bid (fsLit "log1p") [dst] [src]+genSimplePrim bid MO_F64_Asin          [dst]   [src]          = genLibCCall bid (fsLit "asin") [dst] [src]+genSimplePrim bid MO_F64_Acos          [dst]   [src]          = genLibCCall bid (fsLit "acos") [dst] [src]+genSimplePrim bid MO_F64_Atan          [dst]   [src]          = genLibCCall bid (fsLit "atan") [dst] [src]+genSimplePrim bid MO_F64_Sinh          [dst]   [src]          = genLibCCall bid (fsLit "sinh") [dst] [src]+genSimplePrim bid MO_F64_Cosh          [dst]   [src]          = genLibCCall bid (fsLit "cosh") [dst] [src]+genSimplePrim bid MO_F64_Tanh          [dst]   [src]          = genLibCCall bid (fsLit "tanh") [dst] [src]+genSimplePrim bid MO_F64_Pwr           [dst]   [x,y]          = genLibCCall bid (fsLit "pow")  [dst] [x,y]+genSimplePrim bid MO_F64_Asinh         [dst]   [src]          = genLibCCall bid (fsLit "asinh") [dst] [src]+genSimplePrim bid MO_F64_Acosh         [dst]   [src]          = genLibCCall bid (fsLit "acosh") [dst] [src]+genSimplePrim bid MO_F64_Atanh         [dst]   [src]          = genLibCCall bid (fsLit "atanh") [dst] [src]+genSimplePrim bid MO_SuspendThread     [tok]   [rs,i]         = genRTSCCall bid (fsLit "suspendThread") [tok] [rs,i]+genSimplePrim bid MO_ResumeThread      [rs]    [tok]          = genRTSCCall bid (fsLit "resumeThread") [rs] [tok]+genSimplePrim _   MO_I64_ToI           [dst]   [src]          = genInt64ToInt dst src+genSimplePrim _   MO_I64_FromI         [dst]   [src]          = genIntToInt64 dst src+genSimplePrim _   MO_W64_ToW           [dst]   [src]          = genWord64ToWord dst src+genSimplePrim _   MO_W64_FromW         [dst]   [src]          = genWordToWord64 dst src+genSimplePrim _   MO_x64_Neg           [dst]   [src]          = genNeg64 dst src+genSimplePrim _   MO_x64_Add           [dst]   [x,y]          = genAdd64 dst x y+genSimplePrim _   MO_x64_Sub           [dst]   [x,y]          = genSub64 dst x y+genSimplePrim bid MO_x64_Mul           [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_mul64") [dst] [x,y]+genSimplePrim bid MO_I64_Quot          [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_quotInt64") [dst] [x,y]+genSimplePrim bid MO_I64_Rem           [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_remInt64") [dst] [x,y]+genSimplePrim bid MO_W64_Quot          [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_quotWord64") [dst] [x,y]+genSimplePrim bid MO_W64_Rem           [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_remWord64") [dst] [x,y]+genSimplePrim _   MO_x64_And           [dst]   [x,y]          = genAnd64 dst x y+genSimplePrim _   MO_x64_Or            [dst]   [x,y]          = genOr64  dst x y+genSimplePrim _   MO_x64_Xor           [dst]   [x,y]          = genXor64 dst x y+genSimplePrim _   MO_x64_Not           [dst]   [src]          = genNot64 dst src+genSimplePrim bid MO_x64_Shl           [dst]   [x,n]          = genPrimCCall bid (fsLit "hs_uncheckedShiftL64") [dst] [x,n]+genSimplePrim bid MO_I64_Shr           [dst]   [x,n]          = genPrimCCall bid (fsLit "hs_uncheckedIShiftRA64") [dst] [x,n]+genSimplePrim bid MO_W64_Shr           [dst]   [x,n]          = genPrimCCall bid (fsLit "hs_uncheckedShiftRL64") [dst] [x,n]+genSimplePrim _   MO_x64_Eq            [dst]   [x,y]          = genEq64 dst x y+genSimplePrim _   MO_x64_Ne            [dst]   [x,y]          = genNe64 dst x y+genSimplePrim _   MO_I64_Ge            [dst]   [x,y]          = genGeInt64 dst x y+genSimplePrim _   MO_I64_Gt            [dst]   [x,y]          = genGtInt64 dst x y+genSimplePrim _   MO_I64_Le            [dst]   [x,y]          = genLeInt64 dst x y+genSimplePrim _   MO_I64_Lt            [dst]   [x,y]          = genLtInt64 dst x y+genSimplePrim _   MO_W64_Ge            [dst]   [x,y]          = genGeWord64 dst x y+genSimplePrim _   MO_W64_Gt            [dst]   [x,y]          = genGtWord64 dst x y+genSimplePrim _   MO_W64_Le            [dst]   [x,y]          = genLeWord64 dst x y+genSimplePrim _   MO_W64_Lt            [dst]   [x,y]          = genLtWord64 dst x y+genSimplePrim _   op                   dst     args           = do+  platform <- ncgPlatform <$> getConfig+  pprPanic "genSimplePrim: unhandled primop" (ppr (pprCallishMachOp op, dst, fmap (pdoc platform) args))++{-+Note [Evaluate C-call arguments before placing in destination registers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++When producing code for C calls we must take care when placing arguments+in their final registers. Specifically, we must ensure that temporary register+usage due to evaluation of one argument does not clobber a register in which we+already placed a previous argument (e.g. as the code generation logic for+MO_Shl can clobber %rcx due to x86 instruction limitations).++This is precisely what happened in #18527. Consider this C--:++    (result::I64) = call "ccall" doSomething(_s2hp::I64, 2244, _s2hq::I64, _s2hw::I64 | (1 << _s2hz::I64));++Here we are calling the C function `doSomething` with three arguments, the last+involving a non-trivial expression involving MO_Shl. In this case the NCG could+naively generate the following assembly (where $tmp denotes some temporary+register and $argN denotes the register for argument N, as dictated by the+platform's calling convention):++    mov _s2hp, $arg1   # place first argument+    mov _s2hq, $arg2   # place second argument++    # Compute 1 << _s2hz+    mov _s2hz, %rcx+    shl %cl, $tmp++    # Compute (_s2hw | (1 << _s2hz))+    mov _s2hw, $arg3+    or $tmp, $arg3++    # Perform the call+    call func++This code is outright broken on Windows which assigns $arg1 to %rcx. This means+that the evaluation of the last argument clobbers the first argument.++To avoid this we use a rather awful hack: when producing code for a C call with+at least one non-trivial argument, we first evaluate all of the arguments into+local registers before moving them into their final calling-convention-defined+homes.  This is performed by 'evalArgs'. Here we define "non-trivial" to be an+expression which might contain a MachOp since these are the only cases which+might clobber registers. Furthermore, we use a conservative approximation of+this condition (only looking at the top-level of CmmExprs) to avoid spending+too much effort trying to decide whether we want to take the fast path.++Note that this hack *also* applies to calls to out-of-line PrimTargets (which+are lowered via a C call), which will ultimately end up in+genForeignCall{32,64}.+-}++-- | See Note [Evaluate C-call arguments before placing in destination registers]+evalArgs :: BlockId -> [CmmActual] -> NatM (InstrBlock, [CmmActual])+evalArgs bid actuals+  | any mightContainMachOp actuals = do+      regs_blks <- mapM evalArg actuals+      return (concatOL $ map fst regs_blks, map snd regs_blks)+  | otherwise = return (nilOL, actuals)+  where+    mightContainMachOp (CmmReg _)      = False+    mightContainMachOp (CmmRegOff _ _) = False+    mightContainMachOp (CmmLit _)      = False+    mightContainMachOp _               = True++    evalArg :: CmmActual -> NatM (InstrBlock, CmmExpr)+    evalArg actual = do+        platform <- getPlatform+        lreg <- newLocalReg $ cmmExprType platform actual+        (instrs, bid1) <- stmtToInstrs bid $ CmmAssign (CmmLocal lreg) actual+        -- The above assignment shouldn't change the current block+        massert (isNothing bid1)+        return (instrs, CmmReg $ CmmLocal lreg)++    newLocalReg :: CmmType -> NatM LocalReg+    newLocalReg ty = LocalReg <$> getUniqueM <*> pure ty++-- Note [DIV/IDIV for bytes]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~+-- IDIV reminder:+--   Size    Dividend   Divisor   Quotient    Remainder+--   byte    %ax         r/m8      %al          %ah+--   word    %dx:%ax     r/m16     %ax          %dx+--   dword   %edx:%eax   r/m32     %eax         %edx+--   qword   %rdx:%rax   r/m64     %rax         %rdx+--+-- We do a special case for the byte division because the current+-- codegen doesn't deal well with accessing %ah register (also,+-- accessing %ah in 64-bit mode is complicated because it cannot be an+-- operand of many instructions). So we just widen operands to 16 bits+-- and get the results from %al, %dl. This is not optimal, but a few+-- register moves are probably not a huge deal when doing division.+++-- | Generate C call to the given function in ghc-prim+genPrimCCall+  :: BlockId+  -> FastString+  -> [CmmFormal]+  -> [CmmActual]+  -> NatM InstrBlock+genPrimCCall bid lbl_txt dsts args = do+  config <- getConfig+  -- FIXME: we should use mkForeignLabel instead of mkCmmCodeLabel+  let lbl = mkCmmCodeLabel primUnitId lbl_txt+  addr <- cmmMakeDynamicReference config CallReference lbl+  let conv = ForeignConvention CCallConv [] [] CmmMayReturn+  genCCall bid addr conv dsts args++-- | Generate C call to the given function in libc+genLibCCall+  :: BlockId+  -> FastString+  -> [CmmFormal]+  -> [CmmActual]+  -> NatM InstrBlock+genLibCCall bid lbl_txt dsts args = do+  config <- getConfig+  -- Assume we can call these functions directly, and that they're not in a dynamic library.+  -- TODO: Why is this ok? Under linux this code will be in libm.so+  --       Is it because they're really implemented as a primitive instruction by the assembler??  -- BL 2009/12/31+  let lbl = mkForeignLabel lbl_txt Nothing ForeignLabelInThisPackage IsFunction+  addr <- cmmMakeDynamicReference config CallReference lbl+  let conv = ForeignConvention CCallConv [] [] CmmMayReturn+  genCCall bid addr conv dsts args++-- | Generate C call to the given function in the RTS+genRTSCCall+  :: BlockId+  -> FastString+  -> [CmmFormal]+  -> [CmmActual]+  -> NatM InstrBlock+genRTSCCall bid lbl_txt dsts args = do+  config <- getConfig+  -- Assume we can call these functions directly, and that they're not in a dynamic library.+  let lbl = mkForeignLabel lbl_txt Nothing ForeignLabelInThisPackage IsFunction+  addr <- cmmMakeDynamicReference config CallReference lbl+  let conv = ForeignConvention CCallConv [] [] CmmMayReturn+  genCCall bid addr conv dsts args++-- | Generate a real C call to the given address with the given convention+genCCall+  :: BlockId+  -> CmmExpr+  -> ForeignConvention+  -> [CmmFormal]+  -> [CmmActual]+  -> NatM InstrBlock+genCCall bid addr conv dest_regs args = do+  is32Bit <- is32BitPlatform+  (instrs0, args') <- evalArgs bid args+  instrs1 <- if is32Bit+    then genCCall32 addr conv dest_regs args'+    else genCCall64 addr conv dest_regs args'+  return (instrs0 `appOL` instrs1)++genCCall32 :: CmmExpr           -- ^ address of the function to call+           -> ForeignConvention -- ^ calling convention+           -> [CmmFormal]       -- ^ where to put the result+           -> [CmmActual]       -- ^ arguments (of mixed type)+           -> NatM InstrBlock+genCCall32 addr conv dest_regs args = do+        config <- getConfig+        let platform = ncgPlatform config+            prom_args = map (maybePromoteCArg platform W32) args++            -- If the size is smaller than the word, we widen things (see maybePromoteCArg)+            arg_size_bytes :: CmmType -> Int+            arg_size_bytes ty = max (widthInBytes (typeWidth ty)) (widthInBytes (wordWidth platform))++            roundTo a x | x `mod` a == 0 = x+                        | otherwise = x + a - (x `mod` a)++            push_arg :: CmmActual {-current argument-}+                            -> NatM InstrBlock  -- code++            push_arg  arg -- we don't need the hints on x86+              | isWord64 arg_ty = do+                RegCode64 code r_hi r_lo <- iselExpr64 arg+                delta <- getDeltaNat+                setDeltaNat (delta - 8)+                return (       code `appOL`+                               toOL [PUSH II32 (OpReg r_hi), DELTA (delta - 4),+                                     PUSH II32 (OpReg r_lo), DELTA (delta - 8),+                                     DELTA (delta-8)]+                    )++              | isFloatType arg_ty = do+                (reg, code) <- getSomeReg arg+                delta <- getDeltaNat+                setDeltaNat (delta-size)+                return (code `appOL`+                                toOL [SUB II32 (OpImm (ImmInt size)) (OpReg esp),+                                      DELTA (delta-size),+                                      let addr = AddrBaseIndex (EABaseReg esp)+                                                                EAIndexNone+                                                                (ImmInt 0)+                                          format = floatFormat (typeWidth arg_ty)+                                      in++                                      -- assume SSE2+                                       MOV format (OpReg reg) (OpAddr addr)++                                     ]+                               )++              | otherwise = do+                -- Arguments can be smaller than 32-bit, but we still use @PUSH+                -- II32@ - the usual calling conventions expect integers to be+                -- 4-byte aligned.+                massert ((typeWidth arg_ty) <= W32)+                (operand, code) <- getOperand arg+                delta <- getDeltaNat+                setDeltaNat (delta-size)+                return (code `snocOL`+                        PUSH II32 operand `snocOL`+                        DELTA (delta-size))++              where+                 arg_ty = cmmExprType platform arg+                 size = arg_size_bytes arg_ty -- Byte size++        let+            -- Align stack to 16n for calls, assuming a starting stack+            -- alignment of 16n - word_size on procedure entry. Which we+            -- maintiain. See Note [Stack Alignment on X86] in rts/StgCRun.c.+            sizes               = map (arg_size_bytes . cmmExprType platform) (reverse args)+            raw_arg_size        = sum sizes + platformWordSizeInBytes platform+            arg_pad_size        = (roundTo 16 $ raw_arg_size) - raw_arg_size+            tot_arg_size        = raw_arg_size + arg_pad_size - platformWordSizeInBytes platform+++        delta0 <- getDeltaNat+        setDeltaNat (delta0 - arg_pad_size)++        push_codes <- mapM push_arg (reverse prom_args)+        delta <- getDeltaNat+        massert (delta == delta0 - tot_arg_size)++        -- deal with static vs dynamic call targets+        (callinsns,cconv) <-+          case addr of+            CmmLit (CmmLabel lbl)+               -> -- ToDo: stdcall arg sizes+                  return (unitOL (CALL (Left fn_imm) []), conv)+               where fn_imm = ImmCLbl lbl+            _+               -> do { (dyn_r, dyn_c) <- getSomeReg addr+                     ; massert (isWord32 (cmmExprType platform addr))+                     ; return (dyn_c `snocOL` CALL (Right dyn_r) [], conv) }+        let push_code+                | arg_pad_size /= 0+                = toOL [SUB II32 (OpImm (ImmInt arg_pad_size)) (OpReg esp),+                        DELTA (delta0 - arg_pad_size)]+                  `appOL` concatOL push_codes+                | otherwise+                = concatOL push_codes++              -- Deallocate parameters after call for ccall;+              -- but not for stdcall (callee does it)+              --+              -- We have to pop any stack padding we added+              -- even if we are doing stdcall, though (#5052)+            pop_size+               | ForeignConvention StdCallConv _ _ _ <- cconv = arg_pad_size+               | otherwise = tot_arg_size++            call = callinsns `appOL`+                   toOL (+                      (if pop_size==0 then [] else+                       [ADD II32 (OpImm (ImmInt pop_size)) (OpReg esp)])+                      +++                      [DELTA delta0]+                   )+        setDeltaNat delta0++        let+            -- assign the results, if necessary+            assign_code []     = nilOL+            assign_code [dest]+              | isFloatType ty =+                  -- we assume SSE2+                  let tmp_amode = AddrBaseIndex (EABaseReg esp)+                                                       EAIndexNone+                                                       (ImmInt 0)+                      fmt = floatFormat w+                         in toOL [ SUB II32 (OpImm (ImmInt b)) (OpReg esp),+                                   DELTA (delta0 - b),+                                   X87Store fmt  tmp_amode,+                                   -- X87Store only supported for the CDECL ABI+                                   -- NB: This code will need to be+                                   -- revisited once GHC does more work around+                                   -- SIGFPE f+                                   MOV fmt (OpAddr tmp_amode) (OpReg r_dest),+                                   ADD II32 (OpImm (ImmInt b)) (OpReg esp),+                                   DELTA delta0]+              | isWord64 ty    = toOL [MOV II32 (OpReg eax) (OpReg r_dest),+                                        MOV II32 (OpReg edx) (OpReg r_dest_hi)]+              | otherwise      = unitOL (MOV (intFormat w)+                                             (OpReg eax)+                                             (OpReg r_dest))+              where+                    ty = localRegType dest+                    w  = typeWidth ty+                    b  = widthInBytes w+                    r_dest_hi = getHiVRegFromLo r_dest+                    r_dest    = getLocalRegReg dest+            assign_code many = pprPanic "genForeignCall.assign_code - too many return values:" (ppr many)++        return (push_code `appOL`+                call `appOL`+                assign_code dest_regs)++genCCall64 :: CmmExpr           -- ^ address of function to call+           -> ForeignConvention -- ^ calling convention+           -> [CmmFormal]       -- ^ where to put the result+           -> [CmmActual]       -- ^ arguments (of mixed type)+           -> NatM InstrBlock+genCCall64 addr conv dest_regs args = do+    platform <- getPlatform+    -- load up the register arguments+    let prom_args = map (maybePromoteCArg platform W32) args++    let load_args :: [CmmExpr]+                  -> [Reg]         -- int regs avail for args+                  -> [Reg]         -- FP regs avail for args+                  -> InstrBlock    -- code computing args+                  -> InstrBlock    -- code assigning args to ABI regs+                  -> NatM ([CmmExpr],[Reg],[Reg],InstrBlock,InstrBlock)+        -- no more regs to use+        load_args args [] [] code acode     =+            return (args, [], [], code, acode)++        -- no more args to push+        load_args [] aregs fregs code acode =+            return ([], aregs, fregs, code, acode)++        load_args (arg : rest) aregs fregs code acode+            | isFloatType arg_rep = case fregs of+                 []     -> push_this_arg+                 (r:rs) -> do+                    (code',acode') <- reg_this_arg r+                    load_args rest aregs rs code' acode'+            | otherwise           = case aregs of+                 []     -> push_this_arg+                 (r:rs) -> do+                    (code',acode') <- reg_this_arg r+                    load_args rest rs fregs code' acode'+            where++              -- put arg into the list of stack pushed args+              push_this_arg = do+                 (args',ars,frs,code',acode')+                     <- load_args rest aregs fregs code acode+                 return (arg:args', ars, frs, code', acode')++              -- pass the arg into the given register+              reg_this_arg r+                -- "operand" args can be directly assigned into r+                | isOperand platform arg = do+                    arg_code <- getAnyReg arg+                    return (code, (acode `appOL` arg_code r))+                -- The last non-operand arg can be directly assigned after its+                -- computation without going into a temporary register+                | all (isOperand platform) rest = do+                    arg_code   <- getAnyReg arg+                    return (code `appOL` arg_code r,acode)++                -- other args need to be computed beforehand to avoid clobbering+                -- previously assigned registers used to pass parameters (see+                -- #11792, #12614). They are assigned into temporary registers+                -- and get assigned to proper call ABI registers after they all+                -- have been computed.+                | otherwise     = do+                    arg_code <- getAnyReg arg+                    tmp      <- getNewRegNat arg_fmt+                    let+                      code'  = code `appOL` arg_code tmp+                      acode' = acode `snocOL` reg2reg arg_fmt tmp r+                    return (code',acode')++              arg_rep = cmmExprType platform arg+              arg_fmt = cmmTypeFormat arg_rep++        load_args_win :: [CmmExpr]+                      -> [Reg]        -- used int regs+                      -> [Reg]        -- used FP regs+                      -> [(Reg, Reg)] -- (int, FP) regs avail for args+                      -> InstrBlock+                      -> NatM ([CmmExpr],[Reg],[Reg],InstrBlock,InstrBlock)+        load_args_win args usedInt usedFP [] code+            = return (args, usedInt, usedFP, code, nilOL)+            -- no more regs to use+        load_args_win [] usedInt usedFP _ code+            = return ([], usedInt, usedFP, code, nilOL)+            -- no more args to push+        load_args_win (arg : rest) usedInt usedFP+                      ((ireg, freg) : regs) code+            | isFloatType arg_rep = do+                 arg_code <- getAnyReg arg+                 load_args_win rest (ireg : usedInt) (freg : usedFP) regs+                               (code `appOL`+                                arg_code freg `snocOL`+                                -- If we are calling a varargs function+                                -- then we need to define ireg as well+                                -- as freg+                                MOV II64 (OpReg freg) (OpReg ireg))+            | otherwise = do+                 arg_code <- getAnyReg arg+                 load_args_win rest (ireg : usedInt) usedFP regs+                               (code `appOL` arg_code ireg)+            where+              arg_rep = cmmExprType platform arg++        arg_size = 8 -- always, at the mo++        push_args [] code = return code+        push_args (arg:rest) code+           | isFloatType arg_rep = do+             (arg_reg, arg_code) <- getSomeReg arg+             delta <- getDeltaNat+             setDeltaNat (delta-arg_size)+             let code' = code `appOL` arg_code `appOL` toOL [+                            SUB (intFormat (wordWidth platform)) (OpImm (ImmInt arg_size)) (OpReg rsp),+                            DELTA (delta-arg_size),+                            MOV (floatFormat width) (OpReg arg_reg) (OpAddr (spRel platform 0))]+             push_args rest code'++           | otherwise = do+             -- Arguments can be smaller than 64-bit, but we still use @PUSH+             -- II64@ - the usual calling conventions expect integers to be+             -- 8-byte aligned.+             massert (width <= W64)+             (arg_op, arg_code) <- getOperand arg+             delta <- getDeltaNat+             setDeltaNat (delta-arg_size)+             let code' = code `appOL` arg_code `appOL` toOL [+                                    PUSH II64 arg_op,+                                    DELTA (delta-arg_size)]+             push_args rest code'+            where+              arg_rep = cmmExprType platform arg+              width = typeWidth arg_rep++        leaveStackSpace n = do+             delta <- getDeltaNat+             setDeltaNat (delta - n * arg_size)+             return $ toOL [+                         SUB II64 (OpImm (ImmInt (n * platformWordSizeInBytes platform))) (OpReg rsp),+                         DELTA (delta - n * arg_size)]++    (stack_args, int_regs_used, fp_regs_used, load_args_code, assign_args_code)+         <-+        if platformOS platform == OSMinGW32+        then load_args_win prom_args [] [] (allArgRegs platform) nilOL+        else do+           (stack_args, aregs, fregs, load_args_code, assign_args_code)+               <- load_args prom_args (allIntArgRegs platform)+                                      (allFPArgRegs platform)+                                      nilOL nilOL+           let used_regs rs as = reverse (drop (length rs) (reverse as))+               fregs_used      = used_regs fregs (allFPArgRegs platform)+               aregs_used      = used_regs aregs (allIntArgRegs platform)+           return (stack_args, aregs_used, fregs_used, load_args_code+                                                      , assign_args_code)++    let+        arg_regs_used = int_regs_used ++ fp_regs_used+        arg_regs = [eax] ++ arg_regs_used+                -- for annotating the call instruction with+        sse_regs = length fp_regs_used+        arg_stack_slots = if platformOS platform == OSMinGW32+                          then length stack_args + length (allArgRegs platform)+                          else length stack_args+        tot_arg_size = arg_size * arg_stack_slots+++    -- Align stack to 16n for calls, assuming a starting stack+    -- alignment of 16n - word_size on procedure entry. Which we+    -- maintain. See Note [Stack Alignment on X86] in rts/StgCRun.c+    let word_size = platformWordSizeInBytes platform+    (real_size, adjust_rsp) <-+        if (tot_arg_size + word_size) `rem` 16 == 0+            then return (tot_arg_size, nilOL)+            else do -- we need to adjust...+                delta <- getDeltaNat+                setDeltaNat (delta - word_size)+                return (tot_arg_size + word_size, toOL [+                                SUB II64 (OpImm (ImmInt word_size)) (OpReg rsp),+                                DELTA (delta - word_size) ])++    -- push the stack args, right to left+    push_code <- push_args (reverse stack_args) nilOL+    -- On Win64, we also have to leave stack space for the arguments+    -- that we are passing in registers+    lss_code <- if platformOS platform == OSMinGW32+                then leaveStackSpace (length (allArgRegs platform))+                else return nilOL+    delta <- getDeltaNat++    -- deal with static vs dynamic call targets+    (callinsns,_cconv) <- case addr of+      CmmLit (CmmLabel lbl) ->+        -- ToDo: stdcall arg sizes+        return (unitOL (CALL (Left (ImmCLbl lbl)) arg_regs), conv)+      _ -> do+        (dyn_r, dyn_c) <- getSomeReg addr+        return (dyn_c `snocOL` CALL (Right dyn_r) arg_regs, conv)++    let+        -- The x86_64 ABI requires us to set %al to the number of SSE2+        -- registers that contain arguments, if the called routine+        -- is a varargs function.  We don't know whether it's a+        -- varargs function or not, so we have to assume it is.+        --+        -- It's not safe to omit this assignment, even if the number+        -- of SSE2 regs in use is zero.  If %al is larger than 8+        -- on entry to a varargs function, seg faults ensue.+        assign_eax n = unitOL (MOV II32 (OpImm (ImmInt n)) (OpReg eax))++    let call = callinsns `appOL`+               toOL (+                    -- Deallocate parameters after call for ccall;+                    -- stdcall has callee do it, but is not supported on+                    -- x86_64 target (see #3336)+                  (if real_size==0 then [] else+                   [ADD (intFormat (platformWordWidth platform)) (OpImm (ImmInt real_size)) (OpReg esp)])+                  +++                  [DELTA (delta + real_size)]+               )+    setDeltaNat (delta + real_size)++    let+        -- assign the results, if necessary+        assign_code []     = nilOL+        assign_code [dest] =+          case typeWidth rep of+                W32 | isFloatType rep -> unitOL (MOV (floatFormat W32)+                                                     (OpReg xmm0)+                                                     (OpReg r_dest))+                W64 | isFloatType rep -> unitOL (MOV (floatFormat W64)+                                                     (OpReg xmm0)+                                                     (OpReg r_dest))+                _ -> unitOL (MOV (cmmTypeFormat rep) (OpReg rax) (OpReg r_dest))+          where+                rep = localRegType dest+                r_dest = getRegisterReg platform  (CmmLocal dest)+        assign_code _many = panic "genForeignCall.assign_code many"++    return (adjust_rsp          `appOL`+            push_code           `appOL`+            load_args_code      `appOL`+            assign_args_code    `appOL`+            lss_code            `appOL`+            assign_eax sse_regs `appOL`+            call                `appOL`+            assign_code dest_regs)+++maybePromoteCArg :: Platform -> Width -> CmmExpr -> CmmExpr+maybePromoteCArg platform wto arg+ | wfrom < wto = CmmMachOp (MO_UU_Conv wfrom wto) [arg]+ | otherwise   = arg+ where+   wfrom = cmmExprWidth platform arg++-- -----------------------------------------------------------------------------+-- Generating a table-branch++{-+Note [Sub-word subtlety during jump-table indexing]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Offset the index by the start index of the jump table.+It's important that we do this *before* the widening below. To see+why, consider a switch with a sub-word, signed discriminant such as:++    switch [-5...+2] x::I16 {+        case -5: ...+        ...+        case +2: ...+    }++Consider what happens if we offset *after* widening in the case that+x=-4:++                                         // x == -4 == 0xfffc::I16+    indexWidened = UU_Conv(x);           // == 0xfffc::I64+    indexExpr    = indexWidened - (-5);  // == 0x10000::I64++This index is clearly nonsense given that the jump table only has+eight entries.++By contrast, if we widen *after* we offset then we get the correct+index (1),++                                         // x == -4 == 0xfffc::I16+    indexOffset  = x - (-5);             // == 1::I16+    indexExpr    = UU_Conv(indexOffset); // == 1::I64++See #21186.+-}++genSwitch :: CmmExpr -> SwitchTargets -> NatM InstrBlock++genSwitch expr targets = do+  config <- getConfig+  let platform = ncgPlatform config+      expr_w = cmmExprWidth platform expr+      indexExpr0 = cmmOffset platform expr offset+      -- We widen to a native-width register because we cannot use arbitrary sizes+      -- in x86 addressing modes.+      -- See Note [Sub-word subtlety during jump-table indexing].+      indexExpr = CmmMachOp+        (MO_UU_Conv expr_w (platformWordWidth platform))+        [indexExpr0]+  if ncgPIC config+  then do+        (reg,e_code) <- getNonClobberedReg indexExpr+           -- getNonClobberedReg because it needs to survive across t_code+        lbl <- getNewLabelNat+        let is32bit = target32Bit platform+            os = platformOS platform+            -- Might want to use .rodata.<function we're in> instead, but as+            -- long as it's something unique it'll work out since the+            -- references to the jump table are in the appropriate section.+            rosection = case os of+              -- on Mac OS X/x86_64, put the jump table in the text section to+              -- work around a limitation of the linker.+              -- ld64 is unable to handle the relocations for+              --     .quad L1 - L0+              -- if L0 is not preceded by a non-anonymous label in its section.+              OSDarwin | not is32bit -> Section Text lbl+              _ -> Section ReadOnlyData lbl+        dynRef <- cmmMakeDynamicReference config DataReference lbl+        (tableReg,t_code) <- getSomeReg $ dynRef+        let op = OpAddr (AddrBaseIndex (EABaseReg tableReg)+                                       (EAIndex reg (platformWordSizeInBytes platform)) (ImmInt 0))++        offsetReg <- getNewRegNat (intFormat (platformWordWidth platform))+        return $ if is32bit || os == OSDarwin+                 then e_code `appOL` t_code `appOL` toOL [+                                ADD (intFormat (platformWordWidth platform)) op (OpReg tableReg),+                                JMP_TBL (OpReg tableReg) ids rosection lbl+                       ]+                 else -- HACK: On x86_64 binutils<2.17 is only able to generate+                      -- PC32 relocations, hence we only get 32-bit offsets in+                      -- the jump table. As these offsets are always negative+                      -- we need to properly sign extend them to 64-bit. This+                      -- hack should be removed in conjunction with the hack in+                      -- PprMach.hs/pprDataItem once binutils 2.17 is standard.+                      e_code `appOL` t_code `appOL` toOL [+                               MOVSxL II32 op (OpReg offsetReg),+                               ADD (intFormat (platformWordWidth platform))+                                   (OpReg offsetReg)+                                   (OpReg tableReg),+                               JMP_TBL (OpReg tableReg) ids rosection lbl+                       ]+  else do+        (reg,e_code) <- getSomeReg indexExpr+        lbl <- getNewLabelNat+        let is32bit = target32Bit platform+        if is32bit+          then let op = OpAddr (AddrBaseIndex EABaseNone (EAIndex reg (platformWordSizeInBytes platform)) (ImmCLbl lbl))+                   jmp_code = JMP_TBL op ids (Section ReadOnlyData lbl) lbl+               in return $ e_code `appOL` unitOL jmp_code+          else do+            -- See Note [%rip-relative addressing on x86-64].+            tableReg <- getNewRegNat (intFormat (platformWordWidth platform))+            targetReg <- getNewRegNat (intFormat (platformWordWidth platform))+            let op = OpAddr (AddrBaseIndex (EABaseReg tableReg) (EAIndex reg (platformWordSizeInBytes platform)) (ImmInt 0))+                code = e_code `appOL` toOL+                    [ LEA (archWordFormat is32bit) (OpAddr (AddrBaseIndex EABaseRip EAIndexNone (ImmCLbl lbl))) (OpReg tableReg)+                    , MOV (archWordFormat is32bit) op (OpReg targetReg)+                    , JMP_TBL (OpReg targetReg) ids (Section ReadOnlyData lbl) lbl+                    ]+            return code+  where+    (offset, blockIds) = switchTargetsToTable targets+    ids = map (fmap DestBlockId) blockIds++generateJumpTableForInstr :: NCGConfig -> Instr -> Maybe (NatCmmDecl (Alignment, RawCmmStatics) Instr)+generateJumpTableForInstr config (JMP_TBL _ ids section lbl)+    = let getBlockId (DestBlockId id) = id+          getBlockId _ = panic "Non-Label target in Jump Table"+          blockIds = map (fmap getBlockId) ids+      in Just (createJumpTable config blockIds section lbl)+generateJumpTableForInstr _ _ = Nothing++createJumpTable :: NCGConfig -> [Maybe BlockId] -> Section -> CLabel+                -> GenCmmDecl (Alignment, RawCmmStatics) h g+createJumpTable config ids section lbl+    = let jumpTable+            | ncgPIC config =+                  let ww = ncgWordWidth config+                      jumpTableEntryRel Nothing+                          = CmmStaticLit (CmmInt 0 ww)+                      jumpTableEntryRel (Just blockid)+                          = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0 ww)+                          where blockLabel = blockLbl blockid+                  in map jumpTableEntryRel ids+            | otherwise = map (jumpTableEntry config) ids+      in CmmData section (mkAlignment 1, CmmStaticsRaw lbl jumpTable)++extractUnwindPoints :: [Instr] -> [UnwindPoint]+extractUnwindPoints instrs =+    [ UnwindPoint lbl unwinds | UNWIND lbl unwinds <- instrs]++-- -----------------------------------------------------------------------------+-- 'condIntReg' and 'condFltReg': condition codes into registers++-- Turn those condition codes into integers now (when they appear on+-- the right hand side of an assignment).+--+-- (If applicable) Do not fill the delay slots here; you will confuse the+-- register allocator.++condIntReg :: Cond -> CmmExpr -> CmmExpr -> NatM Register++condIntReg cond x y = do+  CondCode _ cond cond_code <- condIntCode cond x y+  tmp <- getNewRegNat II8+  let+        code dst = cond_code `appOL` toOL [+                    SETCC cond (OpReg tmp),+                    MOVZxL II8 (OpReg tmp) (OpReg dst)+                  ]+  return (Any II32 code)+++-- Note [SSE Parity Checks]+-- ~~~~~~~~~~~~~~~~~~~~~~~~+-- We have to worry about unordered operands (eg. comparisons+-- against NaN).  If the operands are unordered, the comparison+-- sets the parity flag, carry flag and zero flag.+-- All comparisons are supposed to return false for unordered+-- operands except for !=, which returns true.+--+-- Optimisation: we don't have to test the parity flag if we+-- know the test has already excluded the unordered case: eg >+-- and >= test for a zero carry flag, which can only occur for+-- ordered operands.+--+-- By reversing comparisons we can avoid testing the parity+-- for < and <= as well. If any of the arguments is an NaN we+-- return false either way. If both arguments are valid then+-- x <= y  <->  y >= x  holds. So it's safe to swap these.+--+-- We invert the condition inside getRegister'and  getCondCode+-- which should cover all invertable cases.+-- All other functions translating FP comparisons to assembly+-- use these to two generate the comparison code.+--+-- As an example consider a simple check:+--+-- func :: Float -> Float -> Int+-- func x y = if x < y then 1 else 0+--+-- Which in Cmm gives the floating point comparison.+--+--  if (%MO_F_Lt_W32(F1, F2)) goto c2gg; else goto c2gf;+--+-- We used to compile this to an assembly code block like this:+-- _c2gh:+--  ucomiss %xmm2,%xmm1+--  jp _c2gf+--  jb _c2gg+--  jmp _c2gf+--+-- Where we have to introduce an explicit+-- check for unordered results (using jmp parity):+--+-- We can avoid this by exchanging the arguments and inverting the direction+-- of the comparison. This results in the sequence of:+--+--  ucomiss %xmm1,%xmm2+--  ja _c2g2+--  jmp _c2g1+--+-- Removing the jump reduces the pressure on the branch predidiction system+-- and plays better with the uOP cache.++condFltReg :: Bool -> Cond -> CmmExpr -> CmmExpr -> NatM Register+condFltReg is32Bit cond x y = condFltReg_sse2+ where+++  condFltReg_sse2 = do+    CondCode _ cond cond_code <- condFltCode cond x y+    tmp1 <- getNewRegNat (archWordFormat is32Bit)+    tmp2 <- getNewRegNat (archWordFormat is32Bit)+    let -- See Note [SSE Parity Checks]+        code dst =+           cond_code `appOL`+             (case cond of+                NE  -> or_unordered dst+                GU  -> plain_test   dst+                GEU -> plain_test   dst+                -- Use ASSERT so we don't break releases if these creep in.+                LTT -> assertPpr False (ppr "Should have been turned into >") $+                       and_ordered  dst+                LE  -> assertPpr False (ppr "Should have been turned into >=") $+                       and_ordered  dst+                _   -> and_ordered  dst)++        plain_test dst = toOL [+                    SETCC cond (OpReg tmp1),+                    MOVZxL II8 (OpReg tmp1) (OpReg dst)+                 ]+        or_unordered dst = toOL [+                    SETCC cond (OpReg tmp1),+                    SETCC PARITY (OpReg tmp2),+                    OR II8 (OpReg tmp1) (OpReg tmp2),+                    MOVZxL II8 (OpReg tmp2) (OpReg dst)+                  ]+        and_ordered dst = toOL [+                    SETCC cond (OpReg tmp1),+                    SETCC NOTPARITY (OpReg tmp2),+                    AND II8 (OpReg tmp1) (OpReg tmp2),+                    MOVZxL II8 (OpReg tmp2) (OpReg dst)+                  ]+    return (Any II32 code)+++-- -----------------------------------------------------------------------------+-- 'trivial*Code': deal with trivial instructions++-- Trivial (dyadic: 'trivialCode', floating-point: 'trivialFCode',+-- unary: 'trivialUCode', unary fl-pt:'trivialUFCode') instructions.+-- Only look for constants on the right hand side, because that's+-- where the generic optimizer will have put them.++-- Similarly, for unary instructions, we don't have to worry about+-- matching an StInt as the argument, because genericOpt will already+-- have handled the constant-folding.+++{-+The Rules of the Game are:++* You cannot assume anything about the destination register dst;+  it may be anything, including a fixed reg.++* You may compute an operand into a fixed reg, but you may not+  subsequently change the contents of that fixed reg.  If you+  want to do so, first copy the value either to a temporary+  or into dst.  You are free to modify dst even if it happens+  to be a fixed reg -- that's not your problem.++* You cannot assume that a fixed reg will stay live over an+  arbitrary computation.  The same applies to the dst reg.++* Temporary regs obtained from getNewRegNat are distinct from+  each other and from all other regs, and stay live over+  arbitrary computations.++--------------------++SDM's version of The Rules:++* If getRegister returns Any, that means it can generate correct+  code which places the result in any register, period.  Even if that+  register happens to be read during the computation.++  Corollary #1: this means that if you are generating code for an+  operation with two arbitrary operands, you cannot assign the result+  of the first operand into the destination register before computing+  the second operand.  The second operand might require the old value+  of the destination register.++  Corollary #2: A function might be able to generate more efficient+  code if it knows the destination register is a new temporary (and+  therefore not read by any of the sub-computations).++* If getRegister returns Any, then the code it generates may modify only:+        (a) fresh temporaries+        (b) the destination register+        (c) known registers (eg. %ecx is used by shifts)+  In particular, it may *not* modify global registers, unless the global+  register happens to be the destination register.+-}++trivialCode :: Width -> (Operand -> Operand -> Instr)+            -> Maybe (Operand -> Operand -> Instr)+            -> CmmExpr -> CmmExpr -> NatM Register+trivialCode width instr m a b+    = do platform <- getPlatform+         trivialCode' platform width instr m a b++trivialCode' :: Platform -> Width -> (Operand -> Operand -> Instr)+             -> Maybe (Operand -> Operand -> Instr)+             -> CmmExpr -> CmmExpr -> NatM Register+trivialCode' platform width _ (Just revinstr) (CmmLit lit_a) b+  | is32BitLit platform lit_a = do+  b_code <- getAnyReg b+  let+       code dst+         = b_code dst `snocOL`+           revinstr (OpImm (litToImm lit_a)) (OpReg dst)+  return (Any (intFormat width) code)++trivialCode' _ width instr _ a b+  = genTrivialCode (intFormat width) instr a b++-- This is re-used for floating pt instructions too.+genTrivialCode :: Format -> (Operand -> Operand -> Instr)+               -> CmmExpr -> CmmExpr -> NatM Register+genTrivialCode rep instr a b = do+  (b_op, b_code) <- getNonClobberedOperand b+  a_code <- getAnyReg a+  tmp <- getNewRegNat rep+  let+     -- We want the value of b to stay alive across the computation of a.+     -- But, we want to calculate a straight into the destination register,+     -- because the instruction only has two operands (dst := dst `op` src).+     -- The troublesome case is when the result of b is in the same register+     -- as the destination reg.  In this case, we have to save b in a+     -- new temporary across the computation of a.+     code dst+        | dst `regClashesWithOp` b_op =+                b_code `appOL`+                unitOL (MOV rep b_op (OpReg tmp)) `appOL`+                a_code dst `snocOL`+                instr (OpReg tmp) (OpReg dst)+        | otherwise =+                b_code `appOL`+                a_code dst `snocOL`+                instr b_op (OpReg dst)+  return (Any rep code)++regClashesWithOp :: Reg -> Operand -> Bool+reg `regClashesWithOp` OpReg reg2   = reg == reg2+reg `regClashesWithOp` OpAddr amode = any (==reg) (addrModeRegs amode)+_   `regClashesWithOp` _            = False++-----------++trivialUCode :: Format -> (Operand -> Instr)+             -> CmmExpr -> NatM Register+trivialUCode rep instr x = do+  x_code <- getAnyReg x+  let+     code dst =+        x_code dst `snocOL`+        instr (OpReg dst)+  return (Any rep code)++-----------+++trivialFCode_sse2 :: Width -> (Format -> Operand -> Operand -> Instr)+                  -> CmmExpr -> CmmExpr -> NatM Register+trivialFCode_sse2 pk instr x y+    = genTrivialCode format (instr format) x y+    where format = floatFormat pk+++--------------------------------------------------------------------------------+coerceInt2FP :: Width -> Width -> CmmExpr -> NatM Register+coerceInt2FP from to x =  coerce_sse2+ where++   coerce_sse2 = do+     (x_op, x_code) <- getOperand x  -- ToDo: could be a safe operand+     let+           opc  = case to of W32 -> CVTSI2SS; W64 -> CVTSI2SD+                             n -> panic $ "coerceInt2FP.sse: unhandled width ("+                                         ++ show n ++ ")"+           code dst = x_code `snocOL` opc (intFormat from) x_op dst+     return (Any (floatFormat to) code)+        -- works even if the destination rep is <II32++--------------------------------------------------------------------------------+coerceFP2Int :: Width -> Width -> CmmExpr -> NatM Register+coerceFP2Int from to x =  coerceFP2Int_sse2+ where+   coerceFP2Int_sse2 = do+     (x_op, x_code) <- getOperand x  -- ToDo: could be a safe operand+     let+           opc  = case from of W32 -> CVTTSS2SIQ; W64 -> CVTTSD2SIQ;+                               n -> panic $ "coerceFP2Init.sse: unhandled width ("+                                           ++ show n ++ ")"+           code dst = x_code `snocOL` opc (intFormat to) x_op dst+     return (Any (intFormat to) code)+         -- works even if the destination rep is <II32+++--------------------------------------------------------------------------------+coerceFP2FP :: Width -> CmmExpr -> NatM Register+coerceFP2FP to x = do+  (x_reg, x_code) <- getSomeReg x+  let+        opc  = case to of W32 -> CVTSD2SS; W64 -> CVTSS2SD;+                                     n -> panic $ "coerceFP2FP: unhandled width ("+                                                 ++ show n ++ ")"+        code dst = x_code `snocOL` opc x_reg dst+  return (Any ( floatFormat to) code)++--------------------------------------------------------------------------------++sse2NegCode :: Width -> CmmExpr -> NatM Register+sse2NegCode w x = do+  let fmt = floatFormat w+  x_code <- getAnyReg x+  -- This is how gcc does it, so it can't be that bad:+  let+    const = case fmt of+      FF32 -> CmmInt 0x80000000 W32+      FF64 -> CmmInt 0x8000000000000000 W64+      x@II8  -> wrongFmt x+      x@II16 -> wrongFmt x+      x@II32 -> wrongFmt x+      x@II64 -> wrongFmt x++      where+        wrongFmt x = panic $ "sse2NegCode: " ++ show x+  Amode amode amode_code <- memConstant (mkAlignment $ widthInBytes w) const+  tmp <- getNewRegNat fmt+  let+    code dst = x_code dst `appOL` amode_code `appOL` toOL [+        MOV fmt (OpAddr amode) (OpReg tmp),+        XOR fmt (OpReg tmp) (OpReg dst)+        ]+  --+  return (Any fmt code)++isVecExpr :: CmmExpr -> Bool+isVecExpr (CmmMachOp (MO_V_Insert {}) _)   = True+isVecExpr (CmmMachOp (MO_V_Extract {}) _)  = True+isVecExpr (CmmMachOp (MO_V_Add {}) _)      = True+isVecExpr (CmmMachOp (MO_V_Sub {}) _)      = True+isVecExpr (CmmMachOp (MO_V_Mul {}) _)      = True+isVecExpr (CmmMachOp (MO_VS_Quot {}) _)    = True+isVecExpr (CmmMachOp (MO_VS_Rem {}) _)     = True+isVecExpr (CmmMachOp (MO_VS_Neg {}) _)     = True+isVecExpr (CmmMachOp (MO_VF_Insert {}) _)  = True+isVecExpr (CmmMachOp (MO_VF_Extract {}) _) = True+isVecExpr (CmmMachOp (MO_VF_Add {}) _)     = True+isVecExpr (CmmMachOp (MO_VF_Sub {}) _)     = True+isVecExpr (CmmMachOp (MO_VF_Mul {}) _)     = True+isVecExpr (CmmMachOp (MO_VF_Quot {}) _)    = True+isVecExpr (CmmMachOp (MO_VF_Neg {}) _)     = True+isVecExpr (CmmMachOp _ [e])                = isVecExpr e+isVecExpr _                                = False++needLlvm :: NatM a+needLlvm =+    sorry $ unlines ["The native code generator does not support vector"+                    ,"instructions. Please use -fllvm."]++-- | This works on the invariant that all jumps in the given blocks are required.+--   Starting from there we try to make a few more jumps redundant by reordering+--   them.+--   We depend on the information in the CFG to do so so without a given CFG+--   we do nothing.+invertCondBranches :: Maybe CFG  -- ^ CFG if present+                   -> LabelMap a -- ^ Blocks with info tables+                   -> [NatBasicBlock Instr] -- ^ List of basic blocks+                   -> [NatBasicBlock Instr]+invertCondBranches Nothing _       bs = bs+invertCondBranches (Just cfg) keep bs =+    invert bs+  where+    invert :: [NatBasicBlock Instr] -> [NatBasicBlock Instr]+    invert ((BasicBlock lbl1 ins@(_:_:_xs)):b2@(BasicBlock lbl2 _):bs)+      | --pprTrace "Block" (ppr lbl1) True,+        (jmp1,jmp2) <- last2 ins+      , JXX cond1 target1 <- jmp1+      , target1 == lbl2+      --, pprTrace "CutChance" (ppr b1) True+      , JXX ALWAYS target2 <- jmp2+      -- We have enough information to check if we can perform the inversion+      -- TODO: We could also check for the last asm instruction which sets+      -- status flags instead. Which I suspect is worse in terms of compiler+      -- performance, but might be applicable to more cases+      , Just edgeInfo1 <- getEdgeInfo lbl1 target1 cfg+      , Just edgeInfo2 <- getEdgeInfo lbl1 target2 cfg+      -- Both jumps come from the same cmm statement+      , transitionSource edgeInfo1 == transitionSource edgeInfo2+      , CmmSource {trans_cmmNode = cmmCondBranch} <- transitionSource edgeInfo1++      --Int comparisons are invertable+      , CmmCondBranch (CmmMachOp op _args) _ _ _ <- cmmCondBranch+      , Just _ <- maybeIntComparison op+      , Just invCond <- maybeInvertCond cond1++      --Swap the last two jumps, invert the conditional jumps condition.+      = let jumps =+              case () of+                -- We are free the eliminate the jmp. So we do so.+                _ | not (mapMember target1 keep)+                    -> [JXX invCond target2]+                -- If the conditional target is unlikely we put the other+                -- target at the front.+                  | edgeWeight edgeInfo2 > edgeWeight edgeInfo1+                    -> [JXX invCond target2, JXX ALWAYS target1]+                -- Keep things as-is otherwise+                  | otherwise+                    -> [jmp1, jmp2]+        in --pprTrace "Cutable" (ppr [jmp1,jmp2] <+> text "=>" <+> ppr jumps) $+           (BasicBlock lbl1+            (dropTail 2 ins ++ jumps))+            : invert (b2:bs)+    invert (b:bs) = b : invert bs+    invert [] = []++genAtomicRMW+  :: BlockId+  -> Width+  -> AtomicMachOp+  -> LocalReg+  -> CmmExpr+  -> CmmExpr+  -> NatM (InstrBlock, Maybe BlockId)+genAtomicRMW bid width amop dst addr n = do+    Amode amode addr_code <-+        if amop `elem` [AMO_Add, AMO_Sub]+        then getAmode addr+        else getSimpleAmode addr  -- See genForeignCall for MO_Cmpxchg+    arg <- getNewRegNat format+    arg_code <- getAnyReg n+    platform <- ncgPlatform <$> getConfig++    let dst_r    = getRegisterReg platform  (CmmLocal dst)+    (code, lbl) <- op_code dst_r arg amode+    return (addr_code `appOL` arg_code arg `appOL` code, Just lbl)+  where+    -- Code for the operation+    op_code :: Reg       -- Destination reg+            -> Reg       -- Register containing argument+            -> AddrMode  -- Address of location to mutate+            -> NatM (OrdList Instr,BlockId) -- TODO: Return Maybe BlockId+    op_code dst_r arg amode = case amop of+        -- In the common case where dst_r is a virtual register the+        -- final move should go away, because it's the last use of arg+        -- and the first use of dst_r.+        AMO_Add  -> return $ (toOL [ LOCK (XADD format (OpReg arg) (OpAddr amode))+                                   , MOV format (OpReg arg) (OpReg dst_r)+                                   ], bid)+        AMO_Sub  -> return $ (toOL [ NEGI format (OpReg arg)+                                   , LOCK (XADD format (OpReg arg) (OpAddr amode))+                                   , MOV format (OpReg arg) (OpReg dst_r)+                                   ], bid)+        -- In these cases we need a new block id, and have to return it so+        -- that later instruction selection can reference it.+        AMO_And  -> cmpxchg_code (\ src dst -> unitOL $ AND format src dst)+        AMO_Nand -> cmpxchg_code (\ src dst -> toOL [ AND format src dst+                                                    , NOT format dst+                                                    ])+        AMO_Or   -> cmpxchg_code (\ src dst -> unitOL $ OR format src dst)+        AMO_Xor  -> cmpxchg_code (\ src dst -> unitOL $ XOR format src dst)+      where+        -- Simulate operation that lacks a dedicated instruction using+        -- cmpxchg.+        cmpxchg_code :: (Operand -> Operand -> OrdList Instr)+                     -> NatM (OrdList Instr, BlockId)+        cmpxchg_code instrs = do+            lbl1 <- getBlockIdNat+            lbl2 <- getBlockIdNat+            tmp <- getNewRegNat format++            --Record inserted blocks+            --  We turn A -> B into A -> A' -> A'' -> B+            --  with a self loop on A'.+            addImmediateSuccessorNat bid lbl1+            addImmediateSuccessorNat lbl1 lbl2+            updateCfgNat (addWeightEdge lbl1 lbl1 0)++            return $ (toOL+                [ MOV format (OpAddr amode) (OpReg eax)+                , JXX ALWAYS lbl1+                , NEWBLOCK lbl1+                  -- Keep old value so we can return it:+                , MOV format (OpReg eax) (OpReg dst_r)+                , MOV format (OpReg eax) (OpReg tmp)+                ]+                `appOL` instrs (OpReg arg) (OpReg tmp) `appOL` toOL+                [ LOCK (CMPXCHG format (OpReg tmp) (OpAddr amode))+                , JXX NE lbl1+                -- See Note [Introducing cfg edges inside basic blocks]+                -- why this basic block is required.+                , JXX ALWAYS lbl2+                , NEWBLOCK lbl2+                ],+                lbl2)+    format = intFormat width++-- | Count trailing zeroes+genCtz :: BlockId -> Width -> LocalReg -> CmmExpr -> NatM (InstrBlock, Maybe BlockId)+genCtz bid width dst src = do+  is32Bit <- is32BitPlatform+  if is32Bit && width == W64+    then genCtz64_32 bid dst src+    else (,Nothing) <$> genCtzGeneric width dst src++-- | Count trailing zeroes+--+-- 64-bit width on 32-bit architecture+genCtz64_32+  :: BlockId+  -> LocalReg+  -> CmmExpr+  -> NatM (InstrBlock, Maybe BlockId)+genCtz64_32 bid dst src = do+  RegCode64 vcode rhi rlo <- iselExpr64 src+  let dst_r = getLocalRegReg dst+  lbl1 <- getBlockIdNat+  lbl2 <- getBlockIdNat+  tmp_r <- getNewRegNat II64++  -- New CFG Edges:+  --  bid -> lbl2+  --  bid -> lbl1 -> lbl2+  --  We also changes edges originating at bid to start at lbl2 instead.+  weights <- getCfgWeights+  updateCfgNat (addWeightEdge bid lbl1 110 .+                addWeightEdge lbl1 lbl2 110 .+                addImmediateSuccessor weights bid lbl2)++  -- The following instruction sequence corresponds to the pseudo-code+  --+  --  if (src) {+  --    dst = src.lo32 ? BSF(src.lo32) : (BSF(src.hi32) + 32);+  --  } else {+  --    dst = 64;+  --  }+  let instrs = vcode `appOL` toOL+           ([ MOV      II32 (OpReg rhi)         (OpReg tmp_r)+            , OR       II32 (OpReg rlo)         (OpReg tmp_r)+            , MOV      II32 (OpImm (ImmInt 64)) (OpReg dst_r)+            , JXX EQQ    lbl2+            , JXX ALWAYS lbl1++            , NEWBLOCK   lbl1+            , BSF     II32 (OpReg rhi)         dst_r+            , ADD     II32 (OpImm (ImmInt 32)) (OpReg dst_r)+            , BSF     II32 (OpReg rlo)         tmp_r+            , CMOV NE II32 (OpReg tmp_r)       dst_r+            , JXX ALWAYS lbl2++            , NEWBLOCK   lbl2+            ])+  return (instrs, Just lbl2)++-- | Count trailing zeroes+--+-- Generic case (width <= word size)+genCtzGeneric :: Width -> LocalReg -> CmmExpr -> NatM InstrBlock+genCtzGeneric width dst src = do+  code_src <- getAnyReg src+  config <- getConfig+  let bw = widthInBits width+  let dst_r = getLocalRegReg dst+  if ncgBmiVersion config >= Just BMI2+  then do+      src_r <- getNewRegNat (intFormat width)+      let instrs = appOL (code_src src_r) $ case width of+              W8 -> toOL+                  [ OR    II32 (OpImm (ImmInteger 0xFFFFFF00)) (OpReg src_r)+                  , TZCNT II32 (OpReg src_r) dst_r+                  ]+              W16 -> toOL+                  [ TZCNT  II16 (OpReg src_r) dst_r+                  , MOVZxL II16 (OpReg dst_r) (OpReg dst_r)+                  ]+              _ -> unitOL $ TZCNT (intFormat width) (OpReg src_r) dst_r+      return instrs+  else do+      -- The following insn sequence makes sure 'ctz 0' has a defined value.+      -- starting with Haswell, one could use the TZCNT insn instead.+      let format = if width == W8 then II16 else intFormat width+      src_r <- getNewRegNat format+      tmp_r <- getNewRegNat format+      let instrs = code_src src_r `appOL` toOL+               ([ MOVZxL  II8    (OpReg src_r) (OpReg src_r) | width == W8 ] +++                [ BSF     format (OpReg src_r) tmp_r+                , MOV     II32   (OpImm (ImmInt bw)) (OpReg dst_r)+                , CMOV NE format (OpReg tmp_r) dst_r+                ]) -- NB: We don't need to zero-extend the result for the+                   -- W8/W16 cases because the 'MOV' insn already+                   -- took care of implicitly clearing the upper bits+      return instrs++++-- | Copy memory+--+-- Unroll memcpy calls if the number of bytes to copy isn't too large (cf+-- ncgInlineThresholdMemcpy).  Otherwise, call C's memcpy.+genMemCpy+  :: BlockId+  -> Int+  -> CmmExpr+  -> CmmExpr+  -> CmmExpr+  -> NatM InstrBlock+genMemCpy bid align dst src arg_n = do++  let libc_memcpy = genLibCCall bid (fsLit "memcpy") [] [dst,src,arg_n]++  case arg_n of+    CmmLit (CmmInt n _) -> do+      -- try to inline it+      mcode <- genMemCpyInlineMaybe align dst src n+      -- if it didn't inline, call the C function+      case mcode of+        Nothing -> libc_memcpy+        Just c  -> pure c++    -- not a literal size argument: call the C function+    _ -> libc_memcpy++++genMemCpyInlineMaybe+  :: Int+  -> CmmExpr+  -> CmmExpr+  -> Integer+  -> NatM (Maybe InstrBlock)+genMemCpyInlineMaybe align dst src n = do+  config <- getConfig+  let+    platform     = ncgPlatform config+    maxAlignment = wordAlignment platform+                   -- only machine word wide MOVs are supported+    effectiveAlignment = min (alignmentOf align) maxAlignment+    format = intFormat . widthFromBytes $ alignmentBytes effectiveAlignment+++  -- The size of each move, in bytes.+  let sizeBytes :: Integer+      sizeBytes = fromIntegral (formatInBytes format)++  -- The number of instructions we will generate (approx). We need 2+  -- instructions per move.+  let insns = 2 * ((n + sizeBytes - 1) `div` sizeBytes)++      go :: Reg -> Reg -> Reg -> Integer -> OrdList Instr+      go dst src tmp i+          | i >= sizeBytes =+              unitOL (MOV format (OpAddr src_addr) (OpReg tmp)) `appOL`+              unitOL (MOV format (OpReg tmp) (OpAddr dst_addr)) `appOL`+              go dst src tmp (i - sizeBytes)+          -- Deal with remaining bytes.+          | i >= 4 =  -- Will never happen on 32-bit+              unitOL (MOV II32 (OpAddr src_addr) (OpReg tmp)) `appOL`+              unitOL (MOV II32 (OpReg tmp) (OpAddr dst_addr)) `appOL`+              go dst src tmp (i - 4)+          | i >= 2 =+              unitOL (MOVZxL II16 (OpAddr src_addr) (OpReg tmp)) `appOL`+              unitOL (MOV II16 (OpReg tmp) (OpAddr dst_addr)) `appOL`+              go dst src tmp (i - 2)+          | i >= 1 =+              unitOL (MOVZxL II8 (OpAddr src_addr) (OpReg tmp)) `appOL`+              unitOL (MOV II8 (OpReg tmp) (OpAddr dst_addr)) `appOL`+              go dst src tmp (i - 1)+          | otherwise = nilOL+        where+          src_addr = AddrBaseIndex (EABaseReg src) EAIndexNone+                       (ImmInteger (n - i))++          dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone+                       (ImmInteger (n - i))++  if insns > fromIntegral (ncgInlineThresholdMemcpy config)+    then pure Nothing+    else do+      code_dst <- getAnyReg dst+      dst_r <- getNewRegNat format+      code_src <- getAnyReg src+      src_r <- getNewRegNat format+      tmp_r <- getNewRegNat format+      pure $ Just $ code_dst dst_r `appOL` code_src src_r `appOL`+                      go dst_r src_r tmp_r (fromInteger n)++-- | Set memory to the given byte+--+-- Unroll memset calls if the number of bytes to copy isn't too large (cf+-- ncgInlineThresholdMemset).  Otherwise, call C's memset.+genMemSet+  :: BlockId+  -> Int+  -> CmmExpr+  -> CmmExpr+  -> CmmExpr+  -> NatM InstrBlock+genMemSet bid align dst arg_c arg_n = do++  let libc_memset = genLibCCall bid (fsLit "memset") [] [dst,arg_c,arg_n]++  case (arg_c,arg_n) of+    (CmmLit (CmmInt c _), CmmLit (CmmInt n _)) -> do+      -- try to inline it+      mcode <- genMemSetInlineMaybe align dst c n+      -- if it didn't inline, call the C function+      case mcode of+        Nothing -> libc_memset+        Just c  -> pure c++    -- not literal size arguments: call the C function+    _ -> libc_memset++genMemSetInlineMaybe+  :: Int+  -> CmmExpr+  -> Integer+  -> Integer+  -> NatM (Maybe InstrBlock)+genMemSetInlineMaybe align dst c n = do+  config <- getConfig+  let+    platform = ncgPlatform config+    maxAlignment = wordAlignment platform -- only machine word wide MOVs are supported+    effectiveAlignment = min (alignmentOf align) maxAlignment+    format = intFormat . widthFromBytes $ alignmentBytes effectiveAlignment+    c2 = c `shiftL` 8 .|. c+    c4 = c2 `shiftL` 16 .|. c2+    c8 = c4 `shiftL` 32 .|. c4++    -- The number of instructions we will generate (approx). We need 1+    -- instructions per move.+    insns = (n + sizeBytes - 1) `div` sizeBytes++    -- The size of each move, in bytes.+    sizeBytes :: Integer+    sizeBytes = fromIntegral (formatInBytes format)++    -- Depending on size returns the widest MOV instruction and its+    -- width.+    gen4 :: AddrMode -> Integer -> (InstrBlock, Integer)+    gen4 addr size+        | size >= 4 =+            (unitOL (MOV II32 (OpImm (ImmInteger c4)) (OpAddr addr)), 4)+        | size >= 2 =+            (unitOL (MOV II16 (OpImm (ImmInteger c2)) (OpAddr addr)), 2)+        | size >= 1 =+            (unitOL (MOV II8 (OpImm (ImmInteger c)) (OpAddr addr)), 1)+        | otherwise = (nilOL, 0)++    -- Generates a 64-bit wide MOV instruction from REG to MEM.+    gen8 :: AddrMode -> Reg -> InstrBlock+    gen8 addr reg8byte =+      unitOL (MOV format (OpReg reg8byte) (OpAddr addr))++    -- Unrolls memset when the widest MOV is <= 4 bytes.+    go4 :: Reg -> Integer -> InstrBlock+    go4 dst left =+      if left <= 0 then nilOL+      else curMov `appOL` go4 dst (left - curWidth)+      where+        possibleWidth = minimum [left, sizeBytes]+        dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone (ImmInteger (n - left))+        (curMov, curWidth) = gen4 dst_addr possibleWidth++    -- Unrolls memset when the widest MOV is 8 bytes (thus another Reg+    -- argument). Falls back to go4 when all 8 byte moves are+    -- exhausted.+    go8 :: Reg -> Reg -> Integer -> InstrBlock+    go8 dst reg8byte left =+      if possibleWidth >= 8 then+        let curMov = gen8 dst_addr reg8byte+        in  curMov `appOL` go8 dst reg8byte (left - 8)+      else go4 dst left+      where+        possibleWidth = minimum [left, sizeBytes]+        dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone (ImmInteger (n - left))++  if fromInteger insns > ncgInlineThresholdMemset config+    then pure Nothing+    else do+        code_dst <- getAnyReg dst+        dst_r <- getNewRegNat format+        if format == II64 && n >= 8+          then do+            code_imm8byte <- getAnyReg (CmmLit (CmmInt c8 W64))+            imm8byte_r <- getNewRegNat II64+            return $ Just $ code_dst dst_r `appOL`+                              code_imm8byte imm8byte_r `appOL`+                              go8 dst_r imm8byte_r (fromInteger n)+          else+            return $ Just $ code_dst dst_r `appOL`+                              go4 dst_r (fromInteger n)+++genMemMove :: BlockId -> p -> CmmActual -> CmmActual -> CmmActual -> NatM InstrBlock+genMemMove bid _align dst src n = do+  -- TODO: generate inline assembly when under a given treshold (similarly to+  -- memcpy and memset)+  genLibCCall bid (fsLit "memmove") [] [dst,src,n]++genMemCmp :: BlockId -> p -> CmmFormal -> CmmActual -> CmmActual -> CmmActual -> NatM InstrBlock+genMemCmp bid _align res dst src n = do+  -- TODO: generate inline assembly when under a given treshold (similarly to+  -- memcpy and memset)+  genLibCCall bid (fsLit "memcmp") [res] [dst,src,n]++genPrefetchData :: Int -> CmmExpr -> NatM (OrdList Instr)+genPrefetchData n src = do+  is32Bit <- is32BitPlatform+  let+    format = archWordFormat is32Bit+    -- need to know what register width for pointers!+    genPrefetch inRegSrc prefetchCTor = do+      code_src <- getAnyReg inRegSrc+      src_r <- getNewRegNat format+      return $ code_src src_r `appOL`+        (unitOL (prefetchCTor  (OpAddr+                    ((AddrBaseIndex (EABaseReg src_r )   EAIndexNone (ImmInt 0))))  ))+        -- prefetch always takes an address++  -- the c / llvm prefetch convention is 0, 1, 2, and 3+  -- the x86 corresponding names are : NTA, 2 , 1, and 0+  case n of+      0 -> genPrefetch src $ PREFETCH NTA  format+      1 -> genPrefetch src $ PREFETCH Lvl2 format+      2 -> genPrefetch src $ PREFETCH Lvl1 format+      3 -> genPrefetch src $ PREFETCH Lvl0 format+      l -> pprPanic "genPrefetchData: unexpected prefetch level" (ppr l)++genByteSwap :: Width -> LocalReg -> CmmExpr -> NatM InstrBlock+genByteSwap width dst src = do+  is32Bit <- is32BitPlatform+  let format = intFormat width+  case width of+      W64 | is32Bit -> do+        let Reg64 dst_hi dst_lo = localReg64 dst+        RegCode64 vcode rhi rlo <- iselExpr64 src+        return $ vcode `appOL`+                 toOL [ MOV II32 (OpReg rlo) (OpReg dst_hi),+                        MOV II32 (OpReg rhi) (OpReg dst_lo),+                        BSWAP II32 dst_hi,+                        BSWAP II32 dst_lo ]+      W16 -> do+        let dst_r = getLocalRegReg dst+        code_src <- getAnyReg src+        return $ code_src dst_r `appOL`+                 unitOL (BSWAP II32 dst_r) `appOL`+                 unitOL (SHR II32 (OpImm $ ImmInt 16) (OpReg dst_r))+      _   -> do+        let dst_r = getLocalRegReg dst+        code_src <- getAnyReg src+        return $ code_src dst_r `appOL` unitOL (BSWAP format dst_r)++genBitRev :: BlockId -> Width -> CmmFormal -> CmmActual -> NatM InstrBlock+genBitRev bid width dst src = do+  -- Here the C implementation (hs_bitrevN) is used as there is no x86+  -- instruction to reverse a word's bit order.+  genPrimCCall bid (bRevLabel width) [dst] [src]++genPopCnt :: BlockId -> Width -> LocalReg -> CmmExpr -> NatM InstrBlock+genPopCnt bid width dst src = do+  config <- getConfig+  let+    platform = ncgPlatform config+    format = intFormat width++  sse4_2Enabled >>= \case++    True -> do+      code_src <- getAnyReg src+      src_r <- getNewRegNat format+      let dst_r = getRegisterReg platform  (CmmLocal dst)+      return $ code_src src_r `appOL`+          (if width == W8 then+               -- The POPCNT instruction doesn't take a r/m8+               unitOL (MOVZxL II8 (OpReg src_r) (OpReg src_r)) `appOL`+               unitOL (POPCNT II16 (OpReg src_r) dst_r)+           else+               unitOL (POPCNT format (OpReg src_r) dst_r)) `appOL`+          (if width == W8 || width == W16 then+               -- We used a 16-bit destination register above,+               -- so zero-extend+               unitOL (MOVZxL II16 (OpReg dst_r) (OpReg dst_r))+           else nilOL)++    False ->+      -- generate C call to hs_popcntN in ghc-prim+      -- TODO: we could directly generate the assembly to index popcount_tab+      -- here instead of doing it by calling a C function+      genPrimCCall bid (popCntLabel width) [dst] [src]+++genPdep :: BlockId -> Width -> LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock+genPdep bid width dst src mask = do+  config <- getConfig+  let+    platform = ncgPlatform config+    format = intFormat width++  if ncgBmiVersion config >= Just BMI2+    then do+      code_src  <- getAnyReg src+      code_mask <- getAnyReg mask+      src_r     <- getNewRegNat format+      mask_r    <- getNewRegNat format+      let dst_r = getRegisterReg platform  (CmmLocal dst)+      return $ code_src src_r `appOL` code_mask mask_r `appOL`+          -- PDEP only supports > 32 bit args+          ( if width == W8 || width == W16 then+              toOL+                [ MOVZxL format (OpReg src_r ) (OpReg src_r )+                , MOVZxL format (OpReg mask_r) (OpReg mask_r)+                , PDEP   II32 (OpReg mask_r) (OpReg src_r ) dst_r+                , MOVZxL format (OpReg dst_r) (OpReg dst_r) -- Truncate to op width+                ]+            else+              unitOL (PDEP format (OpReg mask_r) (OpReg src_r) dst_r)+          )+    else+      -- generate C call to hs_pdepN in ghc-prim+      genPrimCCall bid (pdepLabel width) [dst] [src,mask]+++genPext :: BlockId -> Width -> LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock+genPext bid width dst src mask = do+  config <- getConfig+  if ncgBmiVersion config >= Just BMI2+    then do+      let format   = intFormat width+      let dst_r    = getLocalRegReg dst+      code_src  <- getAnyReg src+      code_mask <- getAnyReg mask+      src_r     <- getNewRegNat format+      mask_r    <- getNewRegNat format+      return $ code_src src_r `appOL` code_mask mask_r `appOL`+          (if width == W8 || width == W16 then+               -- The PEXT instruction doesn't take a r/m8 or 16+              toOL+                [ MOVZxL format (OpReg src_r ) (OpReg src_r )+                , MOVZxL format (OpReg mask_r) (OpReg mask_r)+                , PEXT   II32 (OpReg mask_r) (OpReg src_r ) dst_r+                , MOVZxL format (OpReg dst_r) (OpReg dst_r) -- Truncate to op width+                ]+            else+              unitOL (PEXT format (OpReg mask_r) (OpReg src_r) dst_r)+          )+    else+      -- generate C call to hs_pextN in ghc-prim+      genPrimCCall bid (pextLabel width) [dst] [src,mask]++genClz :: BlockId -> Width -> CmmFormal -> CmmActual -> NatM InstrBlock+genClz bid width dst src = do+  is32Bit <- is32BitPlatform+  config <- getConfig+  if is32Bit && width == W64++    then+      -- Fallback to `hs_clz64` on i386+      genPrimCCall bid (clzLabel width) [dst] [src]++    else do+      code_src <- getAnyReg src+      let dst_r = getLocalRegReg dst+      if ncgBmiVersion config >= Just BMI2+        then do+          src_r <- getNewRegNat (intFormat width)+          return $ appOL (code_src src_r) $ case width of+            W8 -> toOL+                [ MOVZxL II8  (OpReg src_r)       (OpReg src_r) -- zero-extend to 32 bit+                , LZCNT  II32 (OpReg src_r)       dst_r         -- lzcnt with extra 24 zeros+                , SUB    II32 (OpImm (ImmInt 24)) (OpReg dst_r) -- compensate for extra zeros+                ]+            W16 -> toOL+                [ LZCNT  II16 (OpReg src_r) dst_r+                , MOVZxL II16 (OpReg dst_r) (OpReg dst_r) -- zero-extend from 16 bit+                ]+            _ -> unitOL (LZCNT (intFormat width) (OpReg src_r) dst_r)+        else do+          let format = if width == W8 then II16 else intFormat width+          let bw = widthInBits width+          src_r <- getNewRegNat format+          tmp_r <- getNewRegNat format+          return $ code_src src_r `appOL` toOL+                   ([ MOVZxL  II8    (OpReg src_r) (OpReg src_r) | width == W8 ] +++                    [ BSR     format (OpReg src_r) tmp_r+                    , MOV     II32   (OpImm (ImmInt (2*bw-1))) (OpReg dst_r)+                    , CMOV NE format (OpReg tmp_r) dst_r+                    , XOR     format (OpImm (ImmInt (bw-1))) (OpReg dst_r)+                    ]) -- NB: We don't need to zero-extend the result for the+                       -- W8/W16 cases because the 'MOV' insn already+                       -- took care of implicitly clearing the upper bits++genWordToFloat :: BlockId -> Width -> CmmFormal -> CmmActual -> NatM InstrBlock+genWordToFloat bid width dst src =+  -- TODO: generate assembly instead+  genPrimCCall bid (word2FloatLabel width) [dst] [src]++genAtomicRead :: Width -> LocalReg -> CmmExpr -> NatM InstrBlock+genAtomicRead width dst addr = do+  load_code <- intLoadCode (MOV (intFormat width)) addr+  return (load_code (getLocalRegReg dst))++genAtomicWrite :: Width -> CmmExpr -> CmmExpr -> NatM InstrBlock+genAtomicWrite width addr val = do+  code <- assignMem_IntCode (intFormat width) addr val+  return $ code `snocOL` MFENCE++genCmpXchg+  :: BlockId+  -> Width+  -> LocalReg+  -> CmmExpr+  -> CmmExpr+  -> CmmExpr+  -> NatM InstrBlock+genCmpXchg bid width dst addr old new = do+  is32Bit <- is32BitPlatform+  -- On x86 we don't have enough registers to use cmpxchg with a+  -- complicated addressing mode, so on that architecture we+  -- pre-compute the address first.+  if not (is32Bit && width == W64)+    then do+      let format = intFormat width+      Amode amode addr_code <- getSimpleAmode addr+      newval <- getNewRegNat format+      newval_code <- getAnyReg new+      oldval <- getNewRegNat format+      oldval_code <- getAnyReg old+      platform <- getPlatform+      let dst_r    = getRegisterReg platform  (CmmLocal dst)+          code     = toOL+                     [ MOV format (OpReg oldval) (OpReg eax)+                     , LOCK (CMPXCHG format (OpReg newval) (OpAddr amode))+                     , MOV format (OpReg eax) (OpReg dst_r)+                     ]+      return $ addr_code `appOL` newval_code newval `appOL` oldval_code oldval+          `appOL` code+    else+      -- generate C call to hs_cmpxchgN in ghc-prim+      genPrimCCall bid (cmpxchgLabel width) [dst] [addr,old,new]+      -- TODO: implement cmpxchg8b instruction++genXchg :: Width -> LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock+genXchg width dst addr value = do+  is32Bit <- is32BitPlatform++  when (is32Bit && width == W64) $+    panic "genXchg: 64bit atomic exchange not supported on 32bit platforms"++  Amode amode addr_code <- getSimpleAmode addr+  (newval, newval_code) <- getSomeReg value+  let format   = intFormat width+  let dst_r    = getLocalRegReg dst+  -- Copy the value into the target register, perform the exchange.+  let code     = toOL+                 [ MOV format (OpReg newval) (OpReg dst_r)+                  -- On X86 xchg implies a lock prefix if we use a memory argument.+                  -- so this is atomic.+                 , XCHG format (OpAddr amode) dst_r+                 ]+  return $ addr_code `appOL` newval_code `appOL` code+++genFloatAbs :: Width -> LocalReg -> CmmExpr -> NatM InstrBlock+genFloatAbs width dst src = do+  let+    format = floatFormat width+    const = case width of+      W32 -> CmmInt 0x7fffffff W32+      W64 -> CmmInt 0x7fffffffffffffff W64+      _   -> pprPanic "genFloatAbs: invalid width" (ppr width)+  src_code <- getAnyReg src+  Amode amode amode_code <- memConstant (mkAlignment $ widthInBytes width) const+  tmp <- getNewRegNat format+  let dst_r = getLocalRegReg dst+  pure $ src_code dst_r `appOL` amode_code `appOL` toOL+           [ MOV format (OpAddr amode) (OpReg tmp)+           , AND format (OpReg tmp) (OpReg dst_r)+           ]+++genFloatSqrt :: Format -> LocalReg -> CmmExpr -> NatM InstrBlock+genFloatSqrt format dst src = do+  let dst_r = getLocalRegReg dst+  src_code <- getAnyReg src+  pure $ src_code dst_r `snocOL` SQRT format (OpReg dst_r) dst_r+++genAddSubRetCarry+  :: Width+  -> (Format -> Operand -> Operand -> Instr)+  -> (Format -> Maybe (Operand -> Operand -> Instr))+  -> Cond+  -> LocalReg+  -> LocalReg+  -> CmmExpr+  -> CmmExpr+  -> NatM InstrBlock+genAddSubRetCarry width instr mrevinstr cond res_r res_c arg_x arg_y = do+  platform <- ncgPlatform <$> getConfig+  let format = intFormat width+  rCode <- anyReg =<< trivialCode width (instr format)+                        (mrevinstr format) arg_x arg_y+  reg_tmp <- getNewRegNat II8+  let reg_c = getRegisterReg platform  (CmmLocal res_c)+      reg_r = getRegisterReg platform  (CmmLocal res_r)+      code = rCode reg_r `snocOL`+             SETCC cond (OpReg reg_tmp) `snocOL`+             MOVZxL II8 (OpReg reg_tmp) (OpReg reg_c)+  return code+++genAddWithCarry+  :: Width+  -> LocalReg+  -> LocalReg+  -> CmmExpr+  -> CmmExpr+  -> NatM InstrBlock+genAddWithCarry width res_h res_l arg_x arg_y = do+  hCode <- getAnyReg (CmmLit (CmmInt 0 width))+  let format = intFormat width+  lCode <- anyReg =<< trivialCode width (ADD_CC format)+                        (Just (ADD_CC format)) arg_x arg_y+  let reg_l = getLocalRegReg res_l+      reg_h = getLocalRegReg res_h+      code = hCode reg_h `appOL`+             lCode reg_l `snocOL`+             ADC format (OpImm (ImmInteger 0)) (OpReg reg_h)+  return code+++genSignedLargeMul+  :: Width+  -> LocalReg+  -> LocalReg+  -> LocalReg+  -> CmmExpr+  -> CmmExpr+  -> NatM (OrdList Instr)+genSignedLargeMul width res_c res_h res_l arg_x arg_y = do+  (y_reg, y_code) <- getRegOrMem arg_y+  x_code <- getAnyReg arg_x+  reg_tmp <- getNewRegNat II8+  let format = intFormat width+      reg_h = getLocalRegReg res_h+      reg_l = getLocalRegReg res_l+      reg_c = getLocalRegReg res_c+      code = y_code `appOL`+             x_code rax `appOL`+             toOL [ IMUL2 format y_reg+                  , MOV format (OpReg rdx) (OpReg reg_h)+                  , MOV format (OpReg rax) (OpReg reg_l)+                  , SETCC CARRY (OpReg reg_tmp)+                  , MOVZxL II8 (OpReg reg_tmp) (OpReg reg_c)+                  ]+  return code++genUnsignedLargeMul+  :: Width+  -> LocalReg+  -> LocalReg+  -> CmmExpr+  -> CmmExpr+  -> NatM (OrdList Instr)+genUnsignedLargeMul width res_h res_l arg_x arg_y = do+  (y_reg, y_code) <- getRegOrMem arg_y+  x_code <- getAnyReg arg_x+  let format = intFormat width+      reg_h = getLocalRegReg res_h+      reg_l = getLocalRegReg res_l+      code = y_code `appOL`+             x_code rax `appOL`+             toOL [MUL2 format y_reg,+                   MOV format (OpReg rdx) (OpReg reg_h),+                   MOV format (OpReg rax) (OpReg reg_l)]+  return code+++genQuotRem+  :: Width+  -> Bool+  -> LocalReg+  -> LocalReg+  -> Maybe CmmExpr+  -> CmmExpr+  -> CmmExpr+  -> NatM InstrBlock+genQuotRem width signed res_q res_r m_arg_x_high arg_x_low arg_y = do+  case width of+    W8 -> do+      -- See Note [DIV/IDIV for bytes]+      let widen | signed = MO_SS_Conv W8 W16+                | otherwise = MO_UU_Conv W8 W16+          arg_x_low_16 = CmmMachOp widen [arg_x_low]+          arg_y_16 = CmmMachOp widen [arg_y]+          m_arg_x_high_16 = (\p -> CmmMachOp widen [p]) <$> m_arg_x_high+      genQuotRem W16 signed res_q res_r m_arg_x_high_16 arg_x_low_16 arg_y_16++    _ -> do+      let format = intFormat width+          reg_q = getLocalRegReg res_q+          reg_r = getLocalRegReg res_r+          widen | signed    = CLTD format+                | otherwise = XOR format (OpReg rdx) (OpReg rdx)+          instr | signed    = IDIV+                | otherwise = DIV+      (y_reg, y_code) <- getRegOrMem arg_y+      x_low_code <- getAnyReg arg_x_low+      x_high_code <- case m_arg_x_high of+                     Just arg_x_high ->+                         getAnyReg arg_x_high+                     Nothing ->+                         return $ const $ unitOL widen+      return $ y_code `appOL`+               x_low_code rax `appOL`+               x_high_code rdx `appOL`+               toOL [instr format y_reg,+                     MOV format (OpReg rax) (OpReg reg_q),+                     MOV format (OpReg rdx) (OpReg reg_r)]+++----------------------------------------------------------------------------+-- The following functions implement certain 64-bit MachOps inline for 32-bit+-- architectures. On 64-bit architectures, those MachOps aren't supported and+-- calling these functions for a 64-bit target platform is considered an error+-- (hence the use of `expect32BitPlatform`).+--+-- On 64-bit platforms, generic MachOps should be used instead of these 64-bit+-- specific ones (e.g. use MO_Add instead of MO_x64_Add). This MachOp selection+-- is done by StgToCmm.++genInt64ToInt :: LocalReg -> CmmExpr -> NatM InstrBlock+genInt64ToInt dst src = do+  expect32BitPlatform (text "genInt64ToInt")+  RegCode64 code _src_hi src_lo <- iselExpr64 src+  let dst_r = getLocalRegReg dst+  pure $ code `snocOL` MOV II32 (OpReg src_lo) (OpReg dst_r)++genWord64ToWord :: LocalReg -> CmmExpr -> NatM InstrBlock+genWord64ToWord dst src = do+  expect32BitPlatform (text "genWord64ToWord")+  RegCode64 code _src_hi src_lo <- iselExpr64 src+  let dst_r = getLocalRegReg dst+  pure $ code `snocOL` MOV II32 (OpReg src_lo) (OpReg dst_r)++genIntToInt64 :: LocalReg -> CmmExpr -> NatM InstrBlock+genIntToInt64 dst src = do+  expect32BitPlatform (text "genIntToInt64")+  let Reg64 dst_hi dst_lo = localReg64 dst+  src_code <- getAnyReg src+  pure $ src_code rax `appOL` toOL+          [ CLTD II32 -- sign extend EAX in EDX:EAX+          , MOV II32 (OpReg rax) (OpReg dst_lo)+          , MOV II32 (OpReg rdx) (OpReg dst_hi)+          ]++genWordToWord64 :: LocalReg -> CmmExpr -> NatM InstrBlock+genWordToWord64 dst src = do+  expect32BitPlatform (text "genWordToWord64")+  let Reg64 dst_hi dst_lo = localReg64 dst+  src_code <- getAnyReg src+  pure $ src_code dst_lo+          `snocOL` XOR II32 (OpReg dst_hi) (OpReg dst_hi)++genNeg64 :: LocalReg -> CmmExpr -> NatM InstrBlock+genNeg64 dst src = do+  expect32BitPlatform (text "genNeg64")+  let Reg64 dst_hi dst_lo = localReg64 dst+  RegCode64 code src_hi src_lo <- iselExpr64 src+  pure $ code `appOL` toOL+          [ MOV  II32 (OpReg src_lo) (OpReg dst_lo)+          , MOV  II32 (OpReg src_hi) (OpReg dst_hi)+          , NEGI II32 (OpReg dst_lo)+          , ADC  II32 (OpImm (ImmInt 0)) (OpReg dst_hi)+          , NEGI II32 (OpReg dst_hi)+          ]++genAdd64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock+genAdd64 dst x y = do+  expect32BitPlatform (text "genAdd64")+  let Reg64 dst_hi dst_lo = localReg64 dst+  RegCode64 x_code x_hi x_lo <- iselExpr64 x+  RegCode64 y_code y_hi y_lo <- iselExpr64 y+  pure $ x_code `appOL` y_code `appOL` toOL+          [ MOV  II32 (OpReg x_lo) (OpReg dst_lo)+          , MOV  II32 (OpReg x_hi) (OpReg dst_hi)+          , ADD  II32 (OpReg y_lo) (OpReg dst_lo)+          , ADC  II32 (OpReg y_hi) (OpReg dst_hi)+          ]++genSub64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock+genSub64 dst x y = do+  expect32BitPlatform (text "genSub64")+  let Reg64 dst_hi dst_lo = localReg64 dst+  RegCode64 x_code x_hi x_lo <- iselExpr64 x+  RegCode64 y_code y_hi y_lo <- iselExpr64 y+  pure $ x_code `appOL` y_code `appOL` toOL+          [ MOV  II32 (OpReg x_lo) (OpReg dst_lo)+          , MOV  II32 (OpReg x_hi) (OpReg dst_hi)+          , SUB  II32 (OpReg y_lo) (OpReg dst_lo)+          , SBB  II32 (OpReg y_hi) (OpReg dst_hi)+          ]++genAnd64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock+genAnd64 dst x y = do+  expect32BitPlatform (text "genAnd64")+  let Reg64 dst_hi dst_lo = localReg64 dst+  RegCode64 x_code x_hi x_lo <- iselExpr64 x+  RegCode64 y_code y_hi y_lo <- iselExpr64 y+  pure $ x_code `appOL` y_code `appOL` toOL+          [ MOV II32 (OpReg x_lo) (OpReg dst_lo)+          , MOV II32 (OpReg x_hi) (OpReg dst_hi)+          , AND II32 (OpReg y_lo) (OpReg dst_lo)+          , AND II32 (OpReg y_hi) (OpReg dst_hi)+          ]++genOr64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock+genOr64 dst x y = do+  expect32BitPlatform (text "genOr64")+  let Reg64 dst_hi dst_lo = localReg64 dst+  RegCode64 x_code x_hi x_lo <- iselExpr64 x+  RegCode64 y_code y_hi y_lo <- iselExpr64 y+  pure $ x_code `appOL` y_code `appOL` toOL+          [ MOV II32 (OpReg x_lo) (OpReg dst_lo)+          , MOV II32 (OpReg x_hi) (OpReg dst_hi)+          , OR  II32 (OpReg y_lo) (OpReg dst_lo)+          , OR  II32 (OpReg y_hi) (OpReg dst_hi)+          ]++genXor64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock+genXor64 dst x y = do+  expect32BitPlatform (text "genXor64")+  let Reg64 dst_hi dst_lo = localReg64 dst+  RegCode64 x_code x_hi x_lo <- iselExpr64 x+  RegCode64 y_code y_hi y_lo <- iselExpr64 y+  pure $ x_code `appOL` y_code `appOL` toOL+          [ MOV II32 (OpReg x_lo) (OpReg dst_lo)+          , MOV II32 (OpReg x_hi) (OpReg dst_hi)+          , XOR II32 (OpReg y_lo) (OpReg dst_lo)+          , XOR II32 (OpReg y_hi) (OpReg dst_hi)+          ]++genNot64 :: LocalReg -> CmmExpr -> NatM InstrBlock+genNot64 dst src = do+  expect32BitPlatform (text "genNot64")+  let Reg64 dst_hi dst_lo = localReg64 dst+  RegCode64 src_code src_hi src_lo <- iselExpr64 src+  pure $ src_code `appOL` toOL+          [ MOV II32 (OpReg src_lo) (OpReg dst_lo)+          , MOV II32 (OpReg src_hi) (OpReg dst_hi)+          , NOT II32 (OpReg dst_lo)+          , NOT II32 (OpReg dst_hi)+          ]++genEq64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock+genEq64 dst x y = do+  expect32BitPlatform (text "genEq64")+  let dst_r = getLocalRegReg dst+  RegCode64 x_code x_hi x_lo <- iselExpr64 x+  RegCode64 y_code y_hi y_lo <- iselExpr64 y+  Reg64 tmp_hi tmp_lo <- getNewReg64+  pure $ x_code `appOL` y_code `appOL` toOL+          [ MOV II32 (OpReg x_lo)   (OpReg tmp_lo)+          , MOV II32 (OpReg x_hi)   (OpReg tmp_hi)+          , XOR II32 (OpReg y_lo)   (OpReg tmp_lo)+          , XOR II32 (OpReg y_hi)   (OpReg tmp_hi)+          , OR  II32 (OpReg tmp_lo) (OpReg tmp_hi)+          , SETCC EQQ (OpReg dst_r)+          , MOVZxL II8 (OpReg dst_r) (OpReg dst_r)+          ]++genNe64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock+genNe64 dst x y = do+  expect32BitPlatform (text "genNe64")+  let dst_r = getLocalRegReg dst+  RegCode64 x_code x_hi x_lo <- iselExpr64 x+  RegCode64 y_code y_hi y_lo <- iselExpr64 y+  Reg64 tmp_hi tmp_lo <- getNewReg64+  pure $ x_code `appOL` y_code `appOL` toOL+          [ MOV II32 (OpReg x_lo)   (OpReg tmp_lo)+          , MOV II32 (OpReg x_hi)   (OpReg tmp_hi)+          , XOR II32 (OpReg y_lo)   (OpReg tmp_lo)+          , XOR II32 (OpReg y_hi)   (OpReg tmp_hi)+          , OR  II32 (OpReg tmp_lo) (OpReg tmp_hi)+          , SETCC NE (OpReg dst_r)+          , MOVZxL II8 (OpReg dst_r) (OpReg dst_r)+          ]++genGtWord64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock+genGtWord64 dst x y = do+  expect32BitPlatform (text "genGtWord64")+  genPred64 LU dst y x++genLtWord64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock+genLtWord64 dst x y = do+  expect32BitPlatform (text "genLtWord64")+  genPred64 LU dst x y++genGeWord64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock+genGeWord64 dst x y = do+  expect32BitPlatform (text "genGeWord64")+  genPred64 GEU dst x y++genLeWord64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock+genLeWord64 dst x y = do+  expect32BitPlatform (text "genLeWord64")+  genPred64 GEU dst y x++genGtInt64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock+genGtInt64 dst x y = do+  expect32BitPlatform (text "genGtInt64")+  genPred64 LTT dst y x++genLtInt64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock+genLtInt64 dst x y = do+  expect32BitPlatform (text "genLtInt64")+  genPred64 LTT dst x y++genGeInt64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock+genGeInt64 dst x y = do+  expect32BitPlatform (text "genGeInt64")+  genPred64 GE dst x y++genLeInt64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock+genLeInt64 dst x y = do+  expect32BitPlatform (text "genLeInt64")+  genPred64 GE dst y x++genPred64 :: Cond -> LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock+genPred64 cond dst x y = do+  -- we can only rely on CF/SF/OF flags!+  -- Not on ZF, which doesn't take into account the lower parts.+  massert (cond `elem` [LU,GEU,LTT,GE])++  let dst_r = getLocalRegReg dst+  RegCode64 x_code x_hi x_lo <- iselExpr64 x+  RegCode64 y_code y_hi y_lo <- iselExpr64 y+  -- Basically we perform a subtraction with borrow.+  -- As we don't need to result, we can use CMP instead of SUB for the low part+  -- (it sets the borrow flag just like SUB does)+  pure $ x_code `appOL` y_code `appOL` toOL+          [ MOV II32 (OpReg x_hi) (OpReg dst_r)+          , CMP II32 (OpReg y_lo) (OpReg x_lo)+          , SBB II32 (OpReg y_hi) (OpReg dst_r)+          , SETCC cond (OpReg dst_r)+          , MOVZxL II8 (OpReg dst_r) (OpReg dst_r)+          ]+
GHC/CmmToAsm/X86/Cond.hs view
@@ -11,22 +11,22 @@  data Cond         = ALWAYS        -- What's really used? ToDo-        | EQQ           -- je/jz -> zf = 1-        | GE            -- jge-        | GEU           -- ae-        | GTT           -- jg-        | GU            -- ja-        | LE            -- jle-        | LEU           -- jbe-        | LTT           -- jl-        | LU            -- jb-        | NE            -- jne-        | NEG           -- js-        | POS           -- jns-        | CARRY         -- jc-        | OFLO          -- jo-        | PARITY        -- jp-        | NOTPARITY     -- jnp+        | 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
GHC/CmmToAsm/X86/Instr.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, TypeFamilies #-}+{-# LANGUAGE TypeFamilies #-}  ----------------------------------------------------------------------------- --@@ -37,8 +37,6 @@    ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.CmmToAsm.X86.Cond@@ -57,7 +55,6 @@ import GHC.Cmm.Dataflow.Label import GHC.Platform.Regs import GHC.Cmm-import GHC.Data.FastString import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Platform@@ -69,7 +66,6 @@ import GHC.Types.Basic (Alignment) import GHC.Cmm.DebugBlock (UnwindTable) -import Control.Monad import Data.Maybe       (fromMaybe)  -- Format of an x86/x86_64 memory address, in bytes.@@ -124,7 +120,7 @@  {- Note [x86 Floating point precision]-+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Intel's internal floating point registers are by default 80 bit extended precision.  This means that all operations done on values in registers are done at 80 bits, and unless the intermediate values are@@ -174,7 +170,7 @@  data Instr         -- comment pseudo-op-        = COMMENT FastString+        = COMMENT SDoc          -- location pseudo-op (file, line, col, name)         | LOCATION Int Int Int String@@ -200,8 +196,16 @@          -- Moves.         | MOV         Format Operand Operand+             -- ^ N.B. when used with the 'II64' 'Format', the source+             -- operand is interpreted to be a 32-bit sign-extended value.+             -- True 64-bit operands need to be moved with @MOVABS@, which we+             -- currently don't use.         | CMOV   Cond Format Operand Reg-        | MOVZxL      Format Operand Operand -- format is the size of operand 1+        | 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@@ -513,7 +517,6 @@ interesting :: Platform -> Reg -> Bool interesting _        (RegVirtual _)              = True interesting platform (RegReal (RealRegSingle i)) = freeReg platform i-interesting _        (RegReal (RealRegPair{}))   = panic "X86.interesting: no reg pairs on this arch"   @@ -754,14 +757,7 @@         DELTA{}         -> True         _               -> False ------  TODO: why is there -- | Make a reg-reg move instruction.---      On SPARC v8 there are no instructions to move directly between---      floating point and integer regs. If we need to do that then we---      have to go via memory.--- mkRegRegMoveInstr     :: Platform     -> Reg@@ -803,6 +799,8 @@         = [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@@ -859,7 +857,7 @@         --    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].+        --    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.@@ -904,9 +902,8 @@       _ -> 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@@ -956,7 +953,7 @@ allocMoreStack platform slots proc@(CmmProc info lbl live (ListGraph code)) = do     let entries = entryBlocks proc -    uniqs <- replicateM (length entries) getUniqueM+    uniqs <- getUniquesM      let       delta = ((x + stackAlign - 1) `quot` stackAlign) * stackAlign -- round up
GHC/CmmToAsm/X86/Ppr.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE LambdaCase #-}  -----------------------------------------------------------------------------@@ -20,8 +20,6 @@  where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Platform@@ -45,18 +43,13 @@ import GHC.Types.Basic (Alignment, mkAlignment, alignmentBytes) import GHC.Types.Unique ( pprUniqueAlways ) -import GHC.Data.FastString import GHC.Utils.Outputable import GHC.Utils.Panic  import Data.Word --- -------------------------------------------------------------------------------- Printing this stuff out------ -- Note [Subsections Via Symbols]---+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- If we are using the .subsections_via_symbols directive -- (available on recent versions of Darwin), -- we have to make sure that there is some kind of reference@@ -100,7 +93,7 @@       pprProcAlignment config $$       pprProcLabel config lbl $$       (if platformHasSubsectionsViaSymbols platform-          then pdoc platform (mkDeadStripPreventer info_lbl) <> char ':'+          then pdoc platform (mkDeadStripPreventer info_lbl) <> colon           else empty) $$       vcat (map (pprBasicBlock config top_info) blocks) $$       ppWhen (ncgDwarfEnabled config) (pprProcEndLabel platform info_lbl) $$@@ -120,25 +113,25 @@ pprProcLabel config lbl   | ncgExposeInternalSymbols config   , Just lbl' <- ppInternalProcLabel (ncgThisModule config) lbl-  = lbl' <> char ':'+  = lbl' <> colon   | otherwise   = empty  pprProcEndLabel :: Platform -> CLabel -- ^ Procedure name                 -> SDoc pprProcEndLabel platform lbl =-    pdoc platform (mkAsmTempProcEndLabel lbl) <> char ':'+    pdoc platform (mkAsmTempProcEndLabel lbl) <> colon  pprBlockEndLabel :: Platform -> CLabel -- ^ Block name                  -> SDoc pprBlockEndLabel platform lbl =-    pdoc platform (mkAsmTempEndLabel lbl) <> char ':'+    pdoc platform (mkAsmTempEndLabel lbl) <> colon  -- | Output the ELF .size directive. pprSizeDecl :: Platform -> CLabel -> SDoc pprSizeDecl platform lbl  = if osElfTarget (platformOS platform)-   then text "\t.size" <+> pdoc platform lbl <> ptext (sLit ", .-") <> pdoc platform lbl+   then text "\t.size" <+> pdoc platform lbl <> text ", .-" <> pdoc platform lbl    else empty  pprBasicBlock :: NCGConfig -> LabelMap RawCmmStatics -> NatBasicBlock Instr -> SDoc@@ -163,17 +156,17 @@            vcat (map (pprData config) info) $$            pprLabel platform infoLbl $$            c $$-           ppWhen (ncgDwarfEnabled config) (pdoc platform (mkAsmTempEndLabel infoLbl) <> char ':')+           ppWhen (ncgDwarfEnabled config) (pdoc platform (mkAsmTempEndLabel infoLbl) <> colon)      -- Make sure the info table has the right .loc for the block-    -- coming right after it. See [Note: Info Offset]+    -- coming right after it. See Note [Info Offset]     infoTableLoc = case instrs of       (l@LOCATION{} : _) -> pprInstr platform l       _other             -> empty   pprDatas :: NCGConfig -> (Alignment, RawCmmStatics) -> SDoc--- See note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel".+-- 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@@ -267,14 +260,14 @@ pprTypeDecl :: Platform -> CLabel -> SDoc pprTypeDecl platform lbl     = if osElfTarget (platformOS platform) && externallyVisibleCLabel lbl-      then text ".type " <> pdoc platform lbl <> ptext (sLit  ", ") <> pprLabelType' platform lbl+      then text ".type " <> pdoc platform lbl <> text ", " <> pprLabelType' platform lbl       else empty  pprLabel :: Platform -> CLabel -> SDoc pprLabel platform lbl =    pprGloblDecl platform lbl    $$ pprTypeDecl platform lbl-   $$ (pdoc platform lbl <> char ':')+   $$ (pdoc platform lbl <> colon)  pprAlign :: Platform -> Alignment -> SDoc pprAlign platform alignment@@ -298,7 +291,6 @@       RegReal    (RealRegSingle i) ->           if target32Bit platform then ppr32_reg_no f i                                   else ppr64_reg_no f i-      RegReal    (RealRegPair _ _) -> panic "X86.Ppr: no reg pairs on this arch"       RegVirtual (VirtualRegI  u)  -> text "%vI_"   <> pprUniqueAlways u       RegVirtual (VirtualRegHi u)  -> text "%vHi_"  <> pprUniqueAlways u       RegVirtual (VirtualRegF  u)  -> text "%vF_"   <> pprUniqueAlways u@@ -310,30 +302,30 @@     ppr32_reg_no II16  = ppr32_reg_word     ppr32_reg_no _     = ppr32_reg_long -    ppr32_reg_byte i = ptext-      (case i of {-         0 -> sLit "%al";     1 -> sLit "%bl";-         2 -> sLit "%cl";     3 -> sLit "%dl";-        _  -> sLit $ "very naughty I386 byte register: " ++ show i-      })+    ppr32_reg_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 = ptext-      (case i of {-         0 -> sLit "%ax";     1 -> sLit "%bx";-         2 -> sLit "%cx";     3 -> sLit "%dx";-         4 -> sLit "%si";     5 -> sLit "%di";-         6 -> sLit "%bp";     7 -> sLit "%sp";-        _  -> sLit "very naughty I386 word register"-      })+    ppr32_reg_word i =+      case i of {+         0 -> text "%ax";     1 -> text "%bx";+         2 -> text "%cx";     3 -> text "%dx";+         4 -> text "%si";     5 -> text "%di";+         6 -> text "%bp";     7 -> text "%sp";+        _  -> text "very naughty I386 word register"+      } -    ppr32_reg_long i = ptext-      (case i of {-         0 -> sLit "%eax";    1 -> sLit "%ebx";-         2 -> sLit "%ecx";    3 -> sLit "%edx";-         4 -> sLit "%esi";    5 -> sLit "%edi";-         6 -> sLit "%ebp";    7 -> sLit "%esp";+    ppr32_reg_long i =+      case i of {+         0 -> text "%eax";    1 -> text "%ebx";+         2 -> text "%ecx";    3 -> text "%edx";+         4 -> text "%esi";    5 -> text "%edi";+         6 -> text "%ebp";    7 -> text "%esp";          _  -> ppr_reg_float i-      })+      }      ppr64_reg_no :: Format -> Int -> SDoc     ppr64_reg_no II8   = ppr64_reg_byte@@ -341,101 +333,97 @@     ppr64_reg_no II32  = ppr64_reg_long     ppr64_reg_no _     = ppr64_reg_quad -    ppr64_reg_byte i = ptext-      (case i of {-         0 -> sLit "%al";     1 -> sLit "%bl";-         2 -> sLit "%cl";     3 -> sLit "%dl";-         4 -> sLit "%sil";    5 -> sLit "%dil"; -- new 8-bit regs!-         6 -> sLit "%bpl";    7 -> sLit "%spl";-         8 -> sLit "%r8b";    9  -> sLit "%r9b";-        10 -> sLit "%r10b";   11 -> sLit "%r11b";-        12 -> sLit "%r12b";   13 -> sLit "%r13b";-        14 -> sLit "%r14b";   15 -> sLit "%r15b";-        _  -> sLit $ "very naughty x86_64 byte register: " ++ show i-      })+    ppr64_reg_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 = ptext-      (case i of {-         0 -> sLit "%ax";     1 -> sLit "%bx";-         2 -> sLit "%cx";     3 -> sLit "%dx";-         4 -> sLit "%si";     5 -> sLit "%di";-         6 -> sLit "%bp";     7 -> sLit "%sp";-         8 -> sLit "%r8w";    9  -> sLit "%r9w";-        10 -> sLit "%r10w";   11 -> sLit "%r11w";-        12 -> sLit "%r12w";   13 -> sLit "%r13w";-        14 -> sLit "%r14w";   15 -> sLit "%r15w";-        _  -> sLit "very naughty x86_64 word register"-      })+    ppr64_reg_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 = ptext-      (case i of {-         0 -> sLit "%eax";    1  -> sLit "%ebx";-         2 -> sLit "%ecx";    3  -> sLit "%edx";-         4 -> sLit "%esi";    5  -> sLit "%edi";-         6 -> sLit "%ebp";    7  -> sLit "%esp";-         8 -> sLit "%r8d";    9  -> sLit "%r9d";-        10 -> sLit "%r10d";   11 -> sLit "%r11d";-        12 -> sLit "%r12d";   13 -> sLit "%r13d";-        14 -> sLit "%r14d";   15 -> sLit "%r15d";-        _  -> sLit "very naughty x86_64 register"-      })+    ppr64_reg_long i =+      case i of {+         0 -> text "%eax";    1  -> text "%ebx";+         2 -> text "%ecx";    3  -> text "%edx";+         4 -> text "%esi";    5  -> text "%edi";+         6 -> text "%ebp";    7  -> text "%esp";+         8 -> text "%r8d";    9  -> text "%r9d";+        10 -> text "%r10d";   11 -> text "%r11d";+        12 -> text "%r12d";   13 -> text "%r13d";+        14 -> text "%r14d";   15 -> text "%r15d";+        _  -> text "very naughty x86_64 register"+      } -    ppr64_reg_quad i = ptext-      (case i of {-         0 -> sLit "%rax";      1 -> sLit "%rbx";-         2 -> sLit "%rcx";      3 -> sLit "%rdx";-         4 -> sLit "%rsi";      5 -> sLit "%rdi";-         6 -> sLit "%rbp";      7 -> sLit "%rsp";-         8 -> sLit "%r8";       9 -> sLit "%r9";-        10 -> sLit "%r10";    11 -> sLit "%r11";-        12 -> sLit "%r12";    13 -> sLit "%r13";-        14 -> sLit "%r14";    15 -> sLit "%r15";+    ppr64_reg_quad i =+      case i of {+         0 -> text "%rax";     1 -> text "%rbx";+         2 -> text "%rcx";     3 -> text "%rdx";+         4 -> text "%rsi";     5 -> text "%rdi";+         6 -> text "%rbp";     7 -> text "%rsp";+         8 -> text "%r8";      9 -> text "%r9";+        10 -> text "%r10";    11 -> text "%r11";+        12 -> text "%r12";    13 -> text "%r13";+        14 -> text "%r14";    15 -> text "%r15";         _  -> ppr_reg_float i-      })+      } -ppr_reg_float :: Int -> PtrString+ppr_reg_float :: Int -> SDoc ppr_reg_float i = case i of-        16 -> sLit "%xmm0" ;   17 -> sLit "%xmm1"-        18 -> sLit "%xmm2" ;   19 -> sLit "%xmm3"-        20 -> sLit "%xmm4" ;   21 -> sLit "%xmm5"-        22 -> sLit "%xmm6" ;   23 -> sLit "%xmm7"-        24 -> sLit "%xmm8" ;   25 -> sLit "%xmm9"-        26 -> sLit "%xmm10";   27 -> sLit "%xmm11"-        28 -> sLit "%xmm12";   29 -> sLit "%xmm13"-        30 -> sLit "%xmm14";   31 -> sLit "%xmm15"-        _  -> sLit "very naughty x86 register"+        16 -> text "%xmm0" ;   17 -> text "%xmm1"+        18 -> text "%xmm2" ;   19 -> text "%xmm3"+        20 -> text "%xmm4" ;   21 -> text "%xmm5"+        22 -> text "%xmm6" ;   23 -> text "%xmm7"+        24 -> text "%xmm8" ;   25 -> text "%xmm9"+        26 -> text "%xmm10";   27 -> text "%xmm11"+        28 -> text "%xmm12";   29 -> text "%xmm13"+        30 -> text "%xmm14";   31 -> text "%xmm15"+        _  -> text "very naughty x86 register"  pprFormat :: Format -> SDoc-pprFormat x- = ptext (case x of-                II8   -> sLit "b"-                II16  -> sLit "w"-                II32  -> sLit "l"-                II64  -> sLit "q"-                FF32  -> sLit "ss"      -- "scalar single-precision float" (SSE2)-                FF64  -> sLit "sd"      -- "scalar double-precision float" (SSE2)-                )+pprFormat x = case x of+  II8   -> text "b"+  II16  -> text "w"+  II32  -> text "l"+  II64  -> text "q"+  FF32  -> text "ss"      -- "scalar single-precision float" (SSE2)+  FF64  -> text "sd"      -- "scalar double-precision float" (SSE2)  pprFormat_x87 :: Format -> SDoc-pprFormat_x87 x-  = ptext $ case x of-                FF32  -> sLit "s"-                FF64  -> sLit "l"-                _     -> panic "X86.Ppr.pprFormat_x87"+pprFormat_x87 x = case x of+  FF32  -> text "s"+  FF64  -> text "l"+  _     -> panic "X86.Ppr.pprFormat_x87"   pprCond :: Cond -> SDoc-pprCond c- = ptext (case c of {-                GEU     -> sLit "ae";   LU    -> sLit "b";-                EQQ     -> sLit "e";    GTT   -> sLit "g";-                GE      -> sLit "ge";   GU    -> sLit "a";-                LTT     -> sLit "l";    LE    -> sLit "le";-                LEU     -> sLit "be";   NE    -> sLit "ne";-                NEG     -> sLit "s";    POS   -> sLit "ns";-                CARRY   -> sLit "c";   OFLO  -> sLit "o";-                PARITY  -> sLit "p";   NOTPARITY -> sLit "np";-                ALWAYS  -> sLit "mp"})+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 :: Platform -> Imm -> SDoc@@ -562,7 +550,7 @@                   -- to 32-bit offset fields and modify the RTS                   -- appropriately                   ---                  -- See Note [x86-64-relative] in includes/rts/storage/InfoTables.h+                  -- See Note [x86-64-relative] in rts/include/rts/storage/InfoTables.h                   --                   case lit of                   -- A relative relocation:@@ -579,7 +567,7 @@ pprInstr :: Platform -> Instr -> SDoc pprInstr platform i = case i of    COMMENT s-      -> asmComment (ftext s)+      -> asmComment s     LOCATION file line col _name       -> text "\t.loc " <> ppr file <+> ppr line <+> ppr col@@ -624,70 +612,70 @@                 _    -> format     MOV format src dst-     -> pprFormatOpOp (sLit "mov") format src dst+     -> pprFormatOpOp (text "mov") format src dst     CMOV cc format src dst-     -> pprCondOpReg (sLit "cmov") format cc src dst+     -> pprCondOpReg (text "cmov") format cc src dst     MOVZxL II32 src dst-      -> pprFormatOpOp (sLit "mov") 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 (sLit "movz") formats II32 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 (sLit "movs") formats (archWordFormat (target32Bit platform)) 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 (sLit "add") format (OpReg reg2) dst+      -> pprFormatOpOp (text "add") format (OpReg reg2) dst     LEA format (OpAddr (AddrBaseIndex (EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3)       | reg2 == reg3-      -> pprFormatOpOp (sLit "add") format (OpReg reg1) dst+      -> 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 (sLit "lea") format src dst+      -> pprFormatOpOp (text "lea") format src dst     ADD format (OpImm (ImmInt (-1))) dst-      -> pprFormatOp (sLit "dec") format dst+      -> pprFormatOp (text "dec") format dst     ADD format (OpImm (ImmInt 1)) dst-      -> pprFormatOp (sLit "inc") format dst+      -> pprFormatOp (text "inc") format dst     ADD format src dst-      -> pprFormatOpOp (sLit "add") format src dst+      -> pprFormatOpOp (text "add") format src dst     ADC format src dst-      -> pprFormatOpOp (sLit "adc") format src dst+      -> pprFormatOpOp (text "adc") format src dst     SUB format src dst-      -> pprFormatOpOp (sLit "sub") format src dst+      -> pprFormatOpOp (text "sub") format src dst     SBB format src dst-      -> pprFormatOpOp (sLit "sbb") format src dst+      -> pprFormatOpOp (text "sbb") format src dst     IMUL format op1 op2-      -> pprFormatOpOp (sLit "imul") format op1 op2+      -> pprFormatOpOp (text "imul") format op1 op2     ADD_CC format src dst-      -> pprFormatOpOp (sLit "add") format src dst+      -> pprFormatOpOp (text "add") format src dst     SUB_CC format src dst-      -> pprFormatOpOp (sLit "sub") 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.@@ -698,86 +686,86 @@       -> pprInstr platform (AND II32 src dst)     AND FF32 src dst-      -> pprOpOp (sLit "andps") FF32 src dst+      -> pprOpOp (text "andps") FF32 src dst     AND FF64 src dst-      -> pprOpOp (sLit "andpd") FF64 src dst+      -> pprOpOp (text "andpd") FF64 src dst     AND format src dst-      -> pprFormatOpOp (sLit "and") format src dst+      -> pprFormatOpOp (text "and") format src dst     OR  format src dst-      -> pprFormatOpOp (sLit "or")  format src dst+      -> pprFormatOpOp (text "or")  format src dst     XOR FF32 src dst-      -> pprOpOp (sLit "xorps") FF32 src dst+      -> pprOpOp (text "xorps") FF32 src dst     XOR FF64 src dst-      ->  pprOpOp (sLit "xorpd") FF64 src dst+      ->  pprOpOp (text "xorpd") FF64 src dst     XOR format src dst-      -> pprFormatOpOp (sLit "xor") format src dst+      -> pprFormatOpOp (text "xor") format src dst     POPCNT format src dst-      -> pprOpOp (sLit "popcnt") format src (OpReg dst)+      -> pprOpOp (text "popcnt") format src (OpReg dst)     LZCNT format src dst-      ->  pprOpOp (sLit "lzcnt") format src (OpReg dst)+      ->  pprOpOp (text "lzcnt") format src (OpReg dst)     TZCNT format src dst-      -> pprOpOp (sLit "tzcnt") format src (OpReg dst)+      -> pprOpOp (text "tzcnt") format src (OpReg dst)     BSF format src dst-      -> pprOpOp (sLit "bsf") format src (OpReg dst)+      -> pprOpOp (text "bsf") format src (OpReg dst)     BSR format src dst-      -> pprOpOp (sLit "bsr") format src (OpReg dst)+      -> pprOpOp (text "bsr") format src (OpReg dst)     PDEP format src mask dst-      -> pprFormatOpOpReg (sLit "pdep") format src mask dst+      -> pprFormatOpOpReg (text "pdep") format src mask dst     PEXT format src mask dst-      -> pprFormatOpOpReg (sLit "pext") format src mask dst+      -> pprFormatOpOpReg (text "pext") format src mask dst     PREFETCH NTA format src-      -> pprFormatOp_ (sLit "prefetchnta") format src+      -> pprFormatOp_ (text "prefetchnta") format src     PREFETCH Lvl0 format src-      -> pprFormatOp_ (sLit "prefetcht0") format src+      -> pprFormatOp_ (text "prefetcht0") format src     PREFETCH Lvl1 format src-      -> pprFormatOp_ (sLit "prefetcht1") format src+      -> pprFormatOp_ (text "prefetcht1") format src     PREFETCH Lvl2 format src-      -> pprFormatOp_ (sLit "prefetcht2") format src+      -> pprFormatOp_ (text "prefetcht2") format src     NOT format op-      -> pprFormatOp (sLit "not") format op+      -> pprFormatOp (text "not") format op     BSWAP format op-      -> pprFormatOp (sLit "bswap") format (OpReg op)+      -> pprFormatOp (text "bswap") format (OpReg op)     NEGI format op-      -> pprFormatOp (sLit "neg") format op+      -> pprFormatOp (text "neg") format op     SHL format src dst-      -> pprShift (sLit "shl") format src dst+      -> pprShift (text "shl") format src dst     SAR format src dst-      -> pprShift (sLit "sar") format src dst+      -> pprShift (text "sar") format src dst     SHR format src dst-      -> pprShift (sLit "shr") format src dst+      -> pprShift (text "shr") format src dst     BT format imm src-      -> pprFormatImmOp (sLit "bt") format imm src+      -> pprFormatImmOp (text "bt") format imm src     CMP format src dst-     | isFloatFormat format -> pprFormatOpOp (sLit "ucomi") format src dst -- SSE2-     | otherwise            -> pprFormatOpOp (sLit "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 (sLit "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@@ -800,10 +788,10 @@           minSizeOfReg _ _ = format                 -- other     PUSH format op-      -> pprFormatOp (sLit "push") format op+      -> pprFormatOp (text "push") format op     POP format op-      -> pprFormatOp (sLit "pop") format op+      -> pprFormatOp (text "pop") format op  -- both unused (SDM): -- PUSHA -> text "\tpushal"@@ -828,17 +816,17 @@       -> panic $ "pprInstr: CLTD " ++ show x     SETCC cond op-      -> pprCondInstr (sLit "set") cond (pprOperand platform II8 op)+      -> pprCondInstr (text "set") cond (pprOperand platform II8 op)     XCHG format src val-      -> pprFormatOpReg (sLit "xchg") format src val+      -> pprFormatOpReg (text "xchg") format src val     JXX cond blockid-      -> pprCondInstr (sLit "j") cond (pdoc platform lab)+      -> pprCondInstr (text "j") cond (pdoc platform lab)          where lab = blockLbl blockid     JXX_GBL cond imm-      -> pprCondInstr (sLit "j") cond (pprImm platform imm)+      -> pprCondInstr (text "j") cond (pprImm platform imm)     JMP (OpImm imm) _       -> text "\tjmp " <> pprImm platform imm@@ -856,44 +844,44 @@       -> text "\tcall *" <> pprReg platform (archWordFormat (target32Bit platform)) reg     IDIV fmt op-      -> pprFormatOp (sLit "idiv") fmt op+      -> pprFormatOp (text "idiv") fmt op     DIV fmt op-      -> pprFormatOp (sLit "div")  fmt op+      -> pprFormatOp (text "div")  fmt op     IMUL2 fmt op-      -> pprFormatOp (sLit "imul") fmt op+      -> pprFormatOp (text "imul") fmt op     -- x86_64 only    MUL format op1 op2-      -> pprFormatOpOp (sLit "mul") format op1 op2+      -> pprFormatOpOp (text "mul") format op1 op2     MUL2 format op-      -> pprFormatOp (sLit "mul") format op+      -> pprFormatOp (text "mul") format op     FDIV format op1 op2-      -> pprFormatOpOp (sLit "div") format op1 op2+      -> pprFormatOpOp (text "div") format op1 op2     SQRT format op1 op2-      -> pprFormatOpReg (sLit "sqrt") format op1 op2+      -> pprFormatOpReg (text "sqrt") format op1 op2     CVTSS2SD from to-      -> pprRegReg (sLit "cvtss2sd") from to+      -> pprRegReg (text "cvtss2sd") from to     CVTSD2SS from to-      -> pprRegReg (sLit "cvtsd2ss") from to+      -> pprRegReg (text "cvtsd2ss") from to     CVTTSS2SIQ fmt from to-      -> pprFormatFormatOpReg (sLit "cvttss2si") FF32 fmt from to+      -> pprFormatFormatOpReg (text "cvttss2si") FF32 fmt from to     CVTTSD2SIQ fmt from to-      -> pprFormatFormatOpReg (sLit "cvttsd2si") FF64 fmt from to+      -> pprFormatFormatOpReg (text "cvttsd2si") FF64 fmt from to     CVTSI2SS fmt from to-      -> pprFormatOpReg (sLit "cvtsi2ss") fmt from to+      -> pprFormatOpReg (text "cvtsi2ss") fmt from to     CVTSI2SD fmt from to-      -> pprFormatOpReg (sLit "cvtsi2sd") fmt from to+      -> pprFormatOpReg (text "cvtsi2sd") fmt from to         -- FETCHGOT for PIC on ELF platforms    FETCHGOT reg@@ -925,10 +913,10 @@       -> text "\tmfence"     XADD format src dst-      -> pprFormatOpOp (sLit "xadd") format src dst+      -> pprFormatOpOp (text "xadd") format src dst     CMPXCHG format src dst-      -> pprFormatOpOp (sLit "cmpxchg") format src dst+      -> pprFormatOpOp (text "cmpxchg") format src dst     where@@ -945,7 +933,7 @@       = (char '#' <> pprX87Instr fake) $$ actual     pprX87Instr :: Instr -> SDoc-   pprX87Instr (X87Store fmt dst) = pprFormatAddr (sLit "gst") fmt dst+   pprX87Instr (X87Store fmt dst) = pprFormatAddr (text "gst") fmt dst    pprX87Instr _ = panic "X86.Ppr.pprX87Instr: no match"     pprDollImm :: Imm -> SDoc@@ -959,17 +947,17 @@       OpAddr ea -> pprAddr platform ea  -   pprMnemonic_  :: PtrString -> SDoc+   pprMnemonic_  :: SDoc -> SDoc    pprMnemonic_ name =-      char '\t' <> ptext name <> space+      char '\t' <> name <> space  -   pprMnemonic  :: PtrString -> Format -> SDoc+   pprMnemonic  :: SDoc -> Format -> SDoc    pprMnemonic name format =-      char '\t' <> ptext name <> pprFormat format <> space+      char '\t' <> name <> pprFormat format <> space  -   pprFormatImmOp :: PtrString -> Format -> Imm -> Operand -> SDoc+   pprFormatImmOp :: SDoc -> Format -> Imm -> Operand -> SDoc    pprFormatImmOp name format imm op1      = hcat [            pprMnemonic name format,@@ -980,14 +968,14 @@        ]  -   pprFormatOp_ :: PtrString -> Format -> Operand -> SDoc+   pprFormatOp_ :: SDoc -> Format -> Operand -> SDoc    pprFormatOp_ name format op1      = hcat [            pprMnemonic_ name ,            pprOperand platform format op1        ] -   pprFormatOp :: PtrString -> Format -> Operand -> SDoc+   pprFormatOp :: SDoc -> Format -> Operand -> SDoc    pprFormatOp name format op1      = hcat [            pprMnemonic name format,@@ -995,7 +983,7 @@        ]  -   pprFormatOpOp :: PtrString -> Format -> Operand -> Operand -> SDoc+   pprFormatOpOp :: SDoc -> Format -> Operand -> Operand -> SDoc    pprFormatOpOp name format op1 op2      = hcat [            pprMnemonic name format,@@ -1005,7 +993,7 @@        ]  -   pprOpOp :: PtrString -> Format -> Operand -> Operand -> SDoc+   pprOpOp :: SDoc -> Format -> Operand -> Operand -> SDoc    pprOpOp name format op1 op2      = hcat [            pprMnemonic_ name,@@ -1014,7 +1002,7 @@            pprOperand platform format op2        ] -   pprRegReg :: PtrString -> Reg -> Reg -> SDoc+   pprRegReg :: SDoc -> Reg -> Reg -> SDoc    pprRegReg name reg1 reg2      = hcat [            pprMnemonic_ name,@@ -1024,7 +1012,7 @@        ]  -   pprFormatOpReg :: PtrString -> Format -> Operand -> Reg -> SDoc+   pprFormatOpReg :: SDoc -> Format -> Operand -> Reg -> SDoc    pprFormatOpReg name format op1 reg2      = hcat [            pprMnemonic name format,@@ -1033,11 +1021,11 @@            pprReg platform (archWordFormat (target32Bit platform)) reg2        ] -   pprCondOpReg :: PtrString -> Format -> Cond -> Operand -> Reg -> SDoc+   pprCondOpReg :: SDoc -> Format -> Cond -> Operand -> Reg -> SDoc    pprCondOpReg name format cond op1 reg2      = hcat [            char '\t',-           ptext name,+           name,            pprCond cond,            space,            pprOperand platform format op1,@@ -1045,7 +1033,7 @@            pprReg platform format reg2        ] -   pprFormatFormatOpReg :: PtrString -> Format -> Format -> Operand -> Reg -> SDoc+   pprFormatFormatOpReg :: SDoc -> Format -> Format -> Operand -> Reg -> SDoc    pprFormatFormatOpReg name format1 format2 op1 reg2      = hcat [            pprMnemonic name format2,@@ -1054,7 +1042,7 @@            pprReg platform format2 reg2        ] -   pprFormatOpOpReg :: PtrString -> Format -> Operand -> Operand -> Reg -> SDoc+   pprFormatOpOpReg :: SDoc -> Format -> Operand -> Operand -> Reg -> SDoc    pprFormatOpOpReg name format op1 op2 reg3      = hcat [            pprMnemonic name format,@@ -1067,7 +1055,7 @@   -   pprFormatAddr :: PtrString -> Format -> AddrMode -> SDoc+   pprFormatAddr :: SDoc -> Format -> AddrMode -> SDoc    pprFormatAddr name format  op      = hcat [            pprMnemonic name format,@@ -1075,7 +1063,7 @@            pprAddr platform op        ] -   pprShift :: PtrString -> Format -> Operand -> Operand -> SDoc+   pprShift :: SDoc -> Format -> Operand -> Operand -> SDoc    pprShift name format src dest      = hcat [            pprMnemonic name format,@@ -1085,15 +1073,15 @@        ]  -   pprFormatOpOpCoerce :: PtrString -> Format -> Format -> Operand -> Operand -> SDoc+   pprFormatOpOpCoerce :: SDoc -> Format -> Format -> Operand -> Operand -> SDoc    pprFormatOpOpCoerce name format1 format2 op1 op2-     = hcat [ char '\t', ptext name, pprFormat format1, pprFormat format2, space,+     = hcat [ char '\t', name, pprFormat format1, pprFormat format2, space,            pprOperand platform format1 op1,            comma,            pprOperand platform format2 op2        ]  -   pprCondInstr :: PtrString -> Cond -> SDoc -> SDoc+   pprCondInstr :: SDoc -> Cond -> SDoc -> SDoc    pprCondInstr name cond arg-     = hcat [ char '\t', ptext name, pprCond cond, space, arg]+     = hcat [ char '\t', name, pprCond cond, space, arg]
GHC/CmmToAsm/X86/RegInfo.hs view
@@ -1,12 +1,10 @@-{-# LANGUAGE CPP #-}+ module GHC.CmmToAsm.X86.RegInfo (         mkVirtualReg,         regDotColor )  where--#include "HsVersions.h"  import GHC.Prelude
GHC/CmmToAsm/X86/Regs.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE CPP #-} + module GHC.CmmToAsm.X86.Regs (         -- squeese functions for the graph allocator         virtualRegSqueeze,@@ -47,8 +47,6 @@  where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Platform.Regs@@ -98,17 +96,12 @@                         | regNo < firstxmm -> 1                         | otherwise     -> 0 -                RealRegPair{}           -> 0-         RcDouble          -> case rr of                 RealRegSingle regNo                         | regNo >= firstxmm  -> 1                         | otherwise     -> 0 -                RealRegPair{}           -> 0--         _other -> 0  -- -----------------------------------------------------------------------------@@ -251,7 +244,6 @@             | i <= lastint platform -> RcInteger             | i <= lastxmm platform -> RcDouble             | otherwise             -> panic "X86.Reg.classOfRealReg registerSingle too high"-        _   -> panic "X86.Regs.classOfRealReg: RegPairs on this arch"  -- | Get the name of the register with this number. -- NOTE: fixme, we dont track which "way" the XMM registers are used
GHC/CmmToC.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP           #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE GADTs         #-} {-# LANGUAGE LambdaCase    #-}@@ -26,14 +25,14 @@    ) where -#include "HsVersions.h"---- Cmm stuff import GHC.Prelude +import GHC.Platform++import GHC.CmmToAsm.CPrim+ import GHC.Cmm.BlockId import GHC.Cmm.CLabel-import GHC.Types.ForeignCall import GHC.Cmm hiding (pprBBlock) import GHC.Cmm.Ppr () -- For Outputable instances import GHC.Cmm.Dataflow.Block@@ -41,32 +40,26 @@ import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Utils import GHC.Cmm.Switch+import GHC.Cmm.InitFini --- Utils-import GHC.CmmToAsm.CPrim-import GHC.Driver.Session-import GHC.Driver.Ppr-import GHC.Data.FastString-import GHC.Utils.Outputable-import GHC.Utils.Panic-import GHC.Platform+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.Misc+import GHC.Utils.Trace --- The rest import Data.ByteString (ByteString) import qualified Data.ByteString as BS-import Control.Monad.ST import Data.Char import Data.List (intersperse) import Data.Map (Map)-import Data.Word import qualified Data.Map as Map import Control.Monad (ap)-import qualified Data.Array.Unsafe as U ( castSTUArray )-import Data.Array.ST+import GHC.Float  -- -------------------------------------------------------------------------- -- Now do some real work@@ -108,6 +101,9 @@    -- 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 [@@ -172,6 +168,7 @@      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:@@ -207,7 +204,7 @@ pprStmt platform stmt =     case stmt of     CmmEntry{}   -> empty-    CmmComment _ -> empty -- (hang (text "/*") 3 (ftext s)) $$ ptext (sLit "*/")+    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@@ -221,7 +218,7 @@     CmmStore  dest src align         | typeWidth rep == W64 && wordWidth platform /= W64         -> (if isFloatType rep then text "ASSIGN_DBL"-                               else ptext (sLit ("ASSIGN_Word64"))) <>+                               else text "ASSIGN_Word64") <>            parens (mkP_ <> pprExpr1 platform dest <> comma <> pprExpr platform src) <> semi          | otherwise@@ -272,12 +269,17 @@         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).-          | Just _align <- machOpMemcpyishAlign op+          | need_cdecl           = (text ";EFF_(" <> fn <> char ')' <> semi) $$             pprForeignCall platform fn cconv hresults hargs           | otherwise@@ -340,21 +342,23 @@   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 (wordWidth platform) <> colon ,+                 hsep [ text "case" , pprHexVal platform ix rep <> colon ,                         text "/* fall through */" ]          final_branch ix =-                hsep [ text "case" , pprHexVal platform ix (wordWidth platform) <> colon ,+                hsep [ text "case" , pprHexVal platform ix rep <> colon ,                        text "goto" , (pprBlockId ident) <> semi ]      caseify (_     , _    ) = panic "pprSwitch: switch with no cases!"      def | Just l <- mbdef = text "default: goto" <+> pprBlockId l <> semi-        | otherwise       = empty+        | otherwise       = text "default: __builtin_unreachable();"  -- --------------------------------------------------------------------- -- Expressions.@@ -493,7 +497,7 @@     -- resultRepOfMachOp says).   | isComparisonMachOp mop = Just mkW_ -    -- See Note [Zero-extended sub-word signed results]+    -- 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@@ -634,14 +638,15 @@     -- single-word (or smaller) literals.     decomposeMultiWord :: CmmLit -> [CmmLit]     decomposeMultiWord (CmmFloat n W64)-      -- This will produce a W64 integer, which will then be broken up further-      -- on the next iteration on 32-bit platforms.-      = [doubleToWord64 n]+      | W32 <- wordWidth platform = decomposeMultiWord (doubleToWord64 n)+      | otherwise = [doubleToWord64 n]     decomposeMultiWord (CmmFloat n W32)       = [floatToWord32 n]     decomposeMultiWord (CmmInt n W64)       | W32 <- wordWidth platform-      = [CmmInt hi W32, CmmInt lo W32]+      = 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@@ -926,24 +931,28 @@         MO_F32_Fabs     -> text "fabsf"         MO_ReadBarrier  -> text "load_load_barrier"         MO_WriteBarrier -> text "write_barrier"-        MO_Memcpy _     -> text "memcpy"-        MO_Memset _     -> text "memset"-        MO_Memmove _    -> text "memmove"-        MO_Memcmp _     -> text "memcmp"-        (MO_BSwap w)    -> ptext (sLit $ bSwapLabel w)-        (MO_BRev w)     -> ptext (sLit $ bRevLabel w)-        (MO_PopCnt w)   -> ptext (sLit $ popCntLabel w)-        (MO_Pext w)     -> ptext (sLit $ pextLabel w)-        (MO_Pdep w)     -> ptext (sLit $ pdepLabel w)-        (MO_Clz w)      -> ptext (sLit $ clzLabel w)-        (MO_Ctz w)      -> ptext (sLit $ ctzLabel w)-        (MO_AtomicRMW w amop) -> ptext (sLit $ atomicRMWLabel w amop)-        (MO_Cmpxchg w)  -> ptext (sLit $ cmpxchgLabel w)-        (MO_Xchg w)     -> ptext (sLit $ xchgLabel w)-        (MO_AtomicRead w)  -> ptext (sLit $ atomicReadLabel w)-        (MO_AtomicWrite w) -> ptext (sLit $ atomicWriteLabel w)-        (MO_UF_Conv w)  -> ptext (sLit $ word2FloatLabel w)+        MO_Memcpy _     -> text "__builtin_memcpy"+        MO_Memset _     -> text "__builtin_memset"+        MO_Memmove _    -> text "__builtin_memmove"+        MO_Memcmp _     -> text "__builtin_memcmp" +        MO_SuspendThread -> text "suspendThread"+        MO_ResumeThread  -> text "resumeThread"++        MO_BSwap w          -> ftext (bSwapLabel w)+        MO_BRev w           -> ftext (bRevLabel w)+        MO_PopCnt w         -> ftext (popCntLabel w)+        MO_Pext w           -> ftext (pextLabel w)+        MO_Pdep w           -> ftext (pdepLabel w)+        MO_Clz w            -> ftext (clzLabel w)+        MO_Ctz w            -> ftext (ctzLabel w)+        MO_AtomicRMW w amop -> ftext (atomicRMWLabel w amop)+        MO_Cmpxchg w        -> ftext (cmpxchgLabel w)+        MO_Xchg w           -> ftext (xchgLabel w)+        MO_AtomicRead w     -> ftext (atomicReadLabel w)+        MO_AtomicWrite w    -> ftext (atomicWriteLabel w)+        MO_UF_Conv w        -> ftext (word2FloatLabel w)+         MO_S_Mul2     {} -> unsupported         MO_S_QuotRem  {} -> unsupported         MO_U_QuotRem  {} -> unsupported@@ -1003,7 +1012,7 @@ mkFN_  i = text "FN_"  <> parens i -- externally visible function mkIF_  i = text "IF_"  <> parens i -- locally visible --- from includes/Stg.h+-- from rts/include/Stg.h -- mkC_,mkW_,mkP_ :: SDoc @@ -1107,7 +1116,7 @@  pprAsPtrReg :: CmmReg -> SDoc pprAsPtrReg (CmmGlobal (VanillaReg n gcp))-  = WARN( gcp /= VGcPtr, ppr n ) char 'R' <> int n <> text ".p"+  = warnPprTrace (gcp /= VGcPtr) "pprAsPtrReg" (ppr n) $ char 'R' <> int n <> text ".p" pprAsPtrReg other_reg = pprReg other_reg  pprGlobalReg :: GlobalReg -> SDoc@@ -1310,8 +1319,6 @@           bewareLoadStoreAlignment ArchMipsel   = True           bewareLoadStoreAlignment (ArchARM {}) = True           bewareLoadStoreAlignment ArchAArch64  = True-          bewareLoadStoreAlignment ArchSPARC    = True-          bewareLoadStoreAlignment ArchSPARC64  = True           -- Pessimistically assume that they will also cause problems           -- on unknown arches           bewareLoadStoreAlignment ArchUnknown  = True@@ -1404,28 +1411,10 @@ -- can safely initialise to static locations.  floatToWord32 :: Rational -> CmmLit-floatToWord32 r-  = runST $ do-        arr <- newArray_ ((0::Int),0)-        writeArray arr 0 (fromRational r)-        arr' <- castFloatToWord32Array arr-        w32 <- readArray arr' 0-        return (CmmInt (toInteger w32) W32)-  where-    castFloatToWord32Array :: STUArray s Int Float -> ST s (STUArray s Int Word32)-    castFloatToWord32Array = U.castSTUArray+floatToWord32 r = CmmInt (toInteger (castFloatToWord32 (fromRational r))) W32  doubleToWord64 :: Rational -> CmmLit-doubleToWord64 r-  = runST $ do-        arr <- newArray_ ((0::Int),1)-        writeArray arr 0 (fromRational r)-        arr' <- castDoubleToWord64Array arr-        w64 <- readArray arr' 0-        return $ CmmInt (toInteger w64) W64-  where-    castDoubleToWord64Array :: STUArray s Int Double -> ST s (STUArray s Int Word64)-    castDoubleToWord64Array = U.castSTUArray+doubleToWord64 r = CmmInt (toInteger (castDoubleToWord64 (fromRational r))) W64   -- ---------------------------------------------------------------------------@@ -1502,3 +1491,19 @@              (q,r) = w' `quotRem` 16              dig | r < 10    = char (chr (fromInteger r + ord '0'))                  | otherwise = char (chr (fromInteger r - 10 + ord 'a'))++-- | Construct a constructor/finalizer function. Instead of emitting a+-- initializer/finalizer array we rather just emit a single function, annotated+-- with the appropriate C attribute, which then calls each of the initializers.+pprCtorArray :: Platform -> InitOrFini -> [CLabel] -> SDoc+pprCtorArray platform initOrFini lbls =+       decls+    <> text "static __attribute__((" <> attribute <> text "))"+    <> text "void _hs_" <> attribute <> text "()"+    <> braces body+  where+    body = vcat [ pprCLabel platform CStyle lbl <> text " ();" | lbl <- lbls ]+    decls = vcat [ text "void" <+> pprCLabel platform CStyle lbl <> text " (void);" | lbl <- lbls ]+    attribute = case initOrFini of+                  IsInitArray -> text "constructor"+                  IsFiniArray -> text "destructor"
GHC/CmmToLlvm.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, TypeFamilies, ViewPatterns, OverloadedStrings #-}+{-# LANGUAGE TypeFamilies, ViewPatterns, OverloadedStrings #-}  -- ----------------------------------------------------------------------------- -- | This is the top-level module in the LLVM code generator.@@ -11,13 +11,12 @@    ) where -#include "HsVersions.h"- 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@@ -36,7 +35,6 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Logger-import GHC.SysTools ( figureLlvmVersion ) import qualified GHC.Data.Stream as Stream  import Control.Monad ( when, forM_ )@@ -46,33 +44,33 @@ -- ----------------------------------------------------------------------------- -- | Top-level of the LLVM Code generator ---llvmCodeGen :: Logger -> DynFlags -> Handle+llvmCodeGen :: Logger -> LlvmCgConfig -> Handle                -> Stream.Stream IO RawCmmGroup a                -> IO a-llvmCodeGen logger dflags h cmm_stream-  = withTiming logger dflags (text "LLVM CodeGen") (const ()) $ do+llvmCodeGen logger cfg h cmm_stream+  = withTiming logger (text "LLVM CodeGen") (const ()) $ do        bufh <- newBufHandle h         -- Pass header-       showPass logger dflags "LLVM CodeGen"+       showPass logger "LLVM CodeGen"         -- get llvm version, cache for later use-       mb_ver <- figureLlvmVersion logger dflags+       let mb_ver = llvmCgLlvmVersion cfg         -- warn if unsupported        forM_ mb_ver $ \ver -> do-         debugTraceMsg logger dflags 2+         debugTraceMsg logger 2               (text "Using LLVM version:" <+> text (llvmVersionStr ver))-         let doWarn = wopt Opt_WarnUnsupportedLlvmVersion dflags-         when (not (llvmVersionSupported ver) && doWarn) $ putMsg logger dflags $+         let doWarn = llvmCgDoWarn cfg+         when (not (llvmVersionSupported ver) && doWarn) $ putMsg logger $            "You are using an unsupported version of LLVM!" $$            "Currently only" <+> text (llvmVersionStr supportedLlvmVersionLowerBound) <+>-           "to" <+> text (llvmVersionStr supportedLlvmVersionUpperBound) <+> "is supported." <+>+           "up to" <+> text (llvmVersionStr supportedLlvmVersionUpperBound) <+> "(non inclusive) is supported." <+>            "System LLVM version: " <> text (llvmVersionStr ver) $$            "We will try though..."-         let isS390X = platformArch (targetPlatform dflags) == ArchS390X+         let isS390X = platformArch (llvmCgPlatform cfg)  == ArchS390X          let major_ver = head . llvmVersionList $ ver-         when (isS390X && major_ver < 10 && doWarn) $ putMsg logger dflags $+         when (isS390X && major_ver < 10 && doWarn) $ putMsg logger $            "Warning: For s390x the GHC calling convention is only supported since LLVM version 10." <+>            "You are using LLVM version: " <> text (llvmVersionStr ver) @@ -83,15 +81,15 @@            llvm_ver = fromMaybe supportedLlvmVersionLowerBound mb_ver         -- run code generation-       a <- runLlvm logger dflags llvm_ver bufh $-         llvmCodeGen' dflags cmm_stream+       a <- runLlvm logger cfg llvm_ver bufh $+         llvmCodeGen' cfg cmm_stream         bFlush bufh         return a -llvmCodeGen' :: DynFlags -> Stream.Stream IO RawCmmGroup a -> LlvmM a-llvmCodeGen' dflags cmm_stream+llvmCodeGen' :: LlvmCgConfig -> Stream.Stream IO RawCmmGroup a -> LlvmM a+llvmCodeGen' cfg cmm_stream   = do  -- Preamble         renderLlvm header         ghcInternalFunctions@@ -101,8 +99,7 @@         a <- Stream.consume cmm_stream liftIO llvmGroupLlvmGens          -- Declare aliases for forward references-        opts <- getLlvmOpts-        renderLlvm . pprLlvmData opts =<< generateExternDecls+        renderLlvm . pprLlvmData cfg =<< generateExternDecls          -- Postamble         cmmUsedLlvmGens@@ -111,8 +108,9 @@   where     header :: SDoc     header =-      let target = platformMisc_llvmTarget $ platformMisc dflags-      in     text ("target datalayout = \"" ++ getDataLayout (llvmConfig dflags) target ++ "\"")+      let target  = llvmCgLlvmTarget cfg+          llvmCfg = llvmCgLlvmConfig cfg+      in     text ("target datalayout = \"" ++ getDataLayout llvmCfg target ++ "\"")          $+$ text ("target triple = \"" ++ target ++ "\"")      getDataLayout :: LlvmConfig -> String -> String@@ -160,8 +158,8 @@        mapM_ regGlobal gs        gss' <- mapM aliasify $ gs -       opts <- getLlvmOpts-       renderLlvm $ pprLlvmData opts (concat gss', concat tss)+       cfg <- getConfig+       renderLlvm $ pprLlvmData cfg (concat gss', concat tss)  -- | Complete LLVM code generation phase for a single top-level chunk of Cmm. cmmLlvmGen ::RawCmmDecl -> LlvmM ()@@ -205,8 +203,8 @@               -- just a name on its own. Previously `null` was accepted as the               -- name.               Nothing -> [ MetaStr name ]-  opts <- getLlvmOpts-  renderLlvm $ ppLlvmMetas opts metas+  cfg <- getConfig+  renderLlvm $ ppLlvmMetas cfg metas  -- ----------------------------------------------------------------------------- -- | Marks variables as used where necessary@@ -224,12 +222,11 @@   -- 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)+      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)-  opts <- getLlvmOpts   if null ivars      then return ()-     else renderLlvm $ pprLlvmData opts ([lmUsed], [])+     else getConfig >>= renderLlvm . flip pprLlvmData ([lmUsed], [])
GHC/CmmToLlvm/Base.hs view
@@ -22,9 +22,9 @@         LlvmM,         runLlvm, withClearVars, varLookup, varInsert,         markStackReg, checkStackReg,-        funLookup, funInsert, getLlvmVer, getDynFlags,+        funLookup, funInsert, getLlvmVer,         dumpIfSetLlvm, renderLlvm, markUsedVar, getUsedVars,-        ghcInternalFunctions, getPlatform, getLlvmOpts,+        ghcInternalFunctions, getPlatform, getConfig,          getMetaUniqueId,         setUniqMeta, getUniqMeta, liftIO,@@ -39,14 +39,14 @@         aliasify, llvmDefLabel     ) where -#include "HsVersions.h"-#include "ghcautoconf.h"+#include "ghc-llvm-version.h"  import GHC.Prelude import GHC.Utils.Panic  import GHC.Llvm import GHC.CmmToLlvm.Regs+import GHC.CmmToLlvm.Config  import GHC.Cmm.CLabel import GHC.Cmm.Ppr.Expr ()@@ -150,10 +150,10 @@ llvmInfAlign platform = Just (platformWordSizeInBytes platform)  -- | Section to use for a function-llvmFunSection :: LlvmOpts -> LMString -> LMSection+llvmFunSection :: LlvmCgConfig -> LMString -> LMSection llvmFunSection opts lbl-    | llvmOptsSplitSections opts = Just (concatFS [fsLit ".text.", lbl])-    | otherwise                  = Nothing+    | llvmCgSplitSection opts = Just (concatFS [fsLit ".text.", lbl])+    | otherwise               = Nothing  -- | A Function's arguments llvmFunArgs :: Platform -> LiveGlobalRegs -> [LlvmVar]@@ -264,9 +264,6 @@ -- * Llvm Version -- -newtype LlvmVersion = LlvmVersion { llvmVersionNE :: NE.NonEmpty Int }-  deriving (Eq, Ord)- parseLlvmVersion :: String -> Maybe LlvmVersion parseLlvmVersion =     fmap LlvmVersion . NE.nonEmpty . go [] . dropWhile (not . isDigit)@@ -304,21 +301,20 @@ --  data LlvmEnv = LlvmEnv-  { envVersion :: LlvmVersion      -- ^ LLVM version-  , envOpts    :: LlvmOpts         -- ^ LLVM backend options-  , envDynFlags :: DynFlags        -- ^ Dynamic flags-  , envLogger :: !Logger           -- ^ Logger-  , envOutput :: BufHandle         -- ^ Output buffer-  , envMask :: !Char               -- ^ Mask for creating unique values-  , envFreshMeta :: MetaId         -- ^ Supply of fresh metadata IDs-  , envUniqMeta :: UniqFM Unique MetaId   -- ^ Global metadata nodes-  , envFunMap :: LlvmEnvMap        -- ^ Global functions so far, with type-  , envAliases :: UniqSet LMString -- ^ Globals that we had to alias, see [Llvm Forward References]-  , envUsedVars :: [LlvmVar]       -- ^ Pointers to be added to llvm.used (see @cmmUsedLlvmGens@)+  { envVersion   :: LlvmVersion      -- ^ LLVM version+  , envConfig    :: !LlvmCgConfig    -- ^ Configuration for LLVM code gen+  , envLogger    :: !Logger          -- ^ Logger+  , envOutput    :: BufHandle        -- ^ Output buffer+  , envMask      :: !Char            -- ^ Mask for creating unique values+  , envFreshMeta :: MetaId           -- ^ Supply of fresh metadata IDs+  , envUniqMeta  :: UniqFM Unique MetaId   -- ^ Global metadata nodes+  , envFunMap    :: LlvmEnvMap       -- ^ Global functions so far, with type+  , envAliases   :: UniqSet LMString -- ^ Globals that we had to alias, see [Llvm Forward References]+  , envUsedVars  :: [LlvmVar]        -- ^ Pointers to be added to llvm.used (see @cmmUsedLlvmGens@)      -- the following get cleared for every function (see @withClearVars@)-  , envVarMap :: LlvmEnvMap        -- ^ Local variables so far, with type-  , envStackRegs :: [GlobalReg]    -- ^ Non-constant registers (alloca'd in the function prelude)+  , envVarMap    :: LlvmEnvMap       -- ^ Local variables so far, with type+  , envStackRegs :: [GlobalReg]      -- ^ Non-constant registers (alloca'd in the function prelude)   }  type LlvmEnvMap = UniqFM Unique LlvmType@@ -335,20 +331,16 @@     m >>= f  = LlvmM $ \env -> do (x, env') <- runLlvmM m env                                   runLlvmM (f x) env' -instance HasDynFlags LlvmM where-    getDynFlags = LlvmM $ \env -> return (envDynFlags env, env)- instance HasLogger LlvmM where     getLogger = LlvmM $ \env -> return (envLogger env, env)   -- | Get target platform getPlatform :: LlvmM Platform-getPlatform = llvmOptsPlatform <$> getLlvmOpts+getPlatform = llvmCgPlatform <$> getConfig --- | Get LLVM options-getLlvmOpts :: LlvmM LlvmOpts-getLlvmOpts = LlvmM $ \env -> return (envOpts env, env)+getConfig :: LlvmM LlvmCgConfig+getConfig = LlvmM $ \env -> return (envConfig env, env)  instance MonadUnique LlvmM where     getUniqueSupplyM = do@@ -365,23 +357,22 @@                               return (x, env)  -- | Get initial Llvm environment.-runLlvm :: Logger -> DynFlags -> LlvmVersion -> BufHandle -> LlvmM a -> IO a-runLlvm logger dflags ver out m = do+runLlvm :: Logger -> LlvmCgConfig -> LlvmVersion -> BufHandle -> LlvmM a -> IO a+runLlvm logger cfg ver out m = do     (a, _) <- runLlvmM m env     return a-  where env = LlvmEnv { envFunMap = emptyUFM-                      , envVarMap = emptyUFM+  where env = LlvmEnv { envFunMap    = emptyUFM+                      , envVarMap    = emptyUFM                       , envStackRegs = []-                      , envUsedVars = []-                      , envAliases = emptyUniqSet-                      , envVersion = ver-                      , envOpts = initLlvmOpts dflags-                      , envDynFlags = dflags-                      , envLogger = logger-                      , envOutput = out-                      , envMask = 'n'+                      , envUsedVars  = []+                      , envAliases   = emptyUniqSet+                      , envVersion   = ver+                      , envConfig    = cfg+                      , envLogger    = logger+                      , envOutput    = out+                      , envMask      = 'n'                       , envFreshMeta = MetaId 0-                      , envUniqMeta = emptyUFM+                      , envUniqMeta  = emptyUFM                       }  -- | Get environment (internal)@@ -428,18 +419,16 @@ -- | 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-  dflags <- getDynFlags   logger <- getLogger-  liftIO $ dumpIfSet_dyn logger dflags flag hdr fmt doc+  liftIO $ putDumpFileMaybe logger flag hdr fmt doc  -- | Prints the given contents to the output handle renderLlvm :: Outp.SDoc -> LlvmM () renderLlvm sdoc = do      -- Write to output-    dflags <- getDynFlags+    ctx <- llvmCgContext <$> getConfig     out <- getEnv envOutput-    let ctx = initSDocContext dflags (Outp.PprCode Outp.CStyle)     liftIO $ Outp.bufLeftRenderSDoc ctx out sdoc      -- Dump, if requested@@ -501,12 +490,10 @@ -- | Pretty print a 'CLabel'. strCLabel_llvm :: CLabel -> LlvmM LMString strCLabel_llvm lbl = do-    dflags <- getDynFlags+    ctx <- llvmCgContext <$> getConfig     platform <- getPlatform     let sdoc = pprCLabel platform CStyle lbl-        str = Outp.renderWithContext-                  (initSDocContext dflags (Outp.PprCode Outp.CStyle))-                  sdoc+        str = Outp.renderWithContext ctx sdoc     return (fsLit str)  -- ----------------------------------------------------------------------------@@ -566,7 +553,7 @@ -- | 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".+-- 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.@@ -604,7 +591,7 @@            ]  -- 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
GHC/CmmToLlvm/CodeGen.hs view
@@ -1,24 +1,22 @@-{-# LANGUAGE CPP, GADTs, MultiWayIf #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs, MultiWayIf #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}--- ----------------------------------------------------------------------------+ -- | Handle conversion of CmmProc to LLVM code.--- module GHC.CmmToLlvm.CodeGen ( genLlvmProc ) where -#include "HsVersions.h"- import GHC.Prelude -import GHC.Driver.Session-import GHC.Driver.Ppr+import GHC.Platform+import GHC.Platform.Regs ( activeStgRegs )  import GHC.Llvm import GHC.CmmToLlvm.Base+import GHC.CmmToLlvm.Config import GHC.CmmToLlvm.Regs  import GHC.Cmm.BlockId-import GHC.Platform.Regs ( activeStgRegs ) import GHC.Cmm.CLabel import GHC.Cmm import GHC.Cmm.Ppr as PprCmm@@ -29,14 +27,15 @@ import GHC.Cmm.Dataflow.Collections  import GHC.Data.FastString-import GHC.Types.ForeignCall-import GHC.Utils.Outputable-import GHC.Utils.Panic (assertPanic)-import qualified GHC.Utils.Panic as Panic-import GHC.Platform import GHC.Data.OrdList++import GHC.Types.ForeignCall import GHC.Types.Unique.Supply import GHC.Types.Unique++import GHC.Utils.Outputable+import GHC.Utils.Panic.Plain (massert)+import qualified GHC.Utils.Panic as Panic import GHC.Utils.Misc  import Control.Monad.Trans.Class@@ -194,10 +193,10 @@ -- Barriers need to be handled specially as they are implemented as LLVM -- intrinsic functions. genCall (PrimTarget MO_ReadBarrier) _ _ =-    barrierUnless [ArchX86, ArchX86_64, ArchSPARC]+    barrierUnless [ArchX86, ArchX86_64]  genCall (PrimTarget MO_WriteBarrier) _ _ =-    barrierUnless [ArchX86, ArchX86_64, ArchSPARC]+    barrierUnless [ArchX86, ArchX86_64]  genCall (PrimTarget MO_Touch) _ _ =     return (nilOL, [])@@ -560,7 +559,7 @@                             , MO_AddWordC w                             , MO_SubWordC w                             ]-    MASSERT(valid)+    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.@@ -692,14 +691,13 @@      ForeignTarget expr _ -> do         (v1, stmts, top) <- exprToVar expr-        dflags <- getDynFlags         let fty = funTy $ fsLit "dynamic"             cast = case getVarType v1 of                 ty | isPointer ty -> LM_Bitcast                 ty | isInt ty     -> LM_Inttoptr -                ty -> panic $ "genCall: Expr is of bad type for function"-                              ++ " call! (" ++ showSDoc dflags (ppr ty) ++ ")"+                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)@@ -728,13 +726,12 @@  arg_vars ((e, AddrHint):rest) (vars, stmts, tops)   = do (v1, stmts', top') <- exprToVar e-       dflags <- getDynFlags        let op = case getVarType v1 of                ty | isPointer ty -> LM_Bitcast                ty | isInt ty     -> LM_Inttoptr -               a  -> panic $ "genCall: Can't cast llvmType to i8*! ("-                           ++ showSDoc dflags (ppr a) ++ ")"+               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,@@ -768,8 +765,7 @@             = return (v, Nop)              | otherwise-            = do dflags <- getDynFlags-                 platform <- getPlatform+            = do platform <- getPlatform                  let op = case (getVarType v, t) of                       (LMInt n, LMInt m)                           -> if n < m then extend else LM_Trunc@@ -783,8 +779,11 @@                       (vt, _) | isPointer vt && isPointer t -> LM_Bitcast                       (vt, _) | isVector vt && isVector t   -> LM_Bitcast -                      (vt, _) -> panic $ "castVars: Can't cast this type ("-                                  ++ showSDoc dflags (ppr vt) ++ ") to (" ++ showSDoc dflags (ppr t) ++ ")"+                      (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@@ -800,11 +799,10 @@ -- | Decide what C function to use to implement a CallishMachOp cmmPrimOpFunctions :: CallishMachOp -> LlvmM LMString cmmPrimOpFunctions mop = do--  dflags <- getDynFlags+  cfg      <- getConfig   platform <- getPlatform-  let intrinTy1 = "p0i8.p0i8." ++ showSDoc dflags (ppr $ llvmWord platform)-      intrinTy2 = "p0i8." ++ showSDoc dflags (ppr $ llvmWord platform)+  let !isBmi2Enabled = llvmCgBmiVersion cfg >= Just BMI2+      !is32bit       = platformWordSize platform == PW4       unsupported = panic ("cmmPrimOpFunctions: " ++ show mop                         ++ " not supported here")       dontReach64 = panic ("cmmPrimOpFunctions: " ++ show mop@@ -859,39 +857,150 @@     MO_F64_Acosh  -> fsLit "acosh"     MO_F64_Atanh  -> fsLit "atanh" -    MO_Memcpy _   -> fsLit $ "llvm.memcpy."  ++ intrinTy1-    MO_Memmove _  -> fsLit $ "llvm.memmove." ++ intrinTy1-    MO_Memset _   -> fsLit $ "llvm.memset."  ++ intrinTy2-    MO_Memcmp _   -> fsLit $ "memcmp"+    -- 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_PopCnt w) -> fsLit $ "llvm.ctpop."      ++ showSDoc dflags (ppr $ widthToLlvmInt w)-    (MO_BSwap w)  -> fsLit $ "llvm.bswap."      ++ showSDoc dflags (ppr $ widthToLlvmInt w)-    (MO_BRev w)   -> fsLit $ "llvm.bitreverse." ++ showSDoc dflags (ppr $ widthToLlvmInt w)-    (MO_Clz w)    -> fsLit $ "llvm.ctlz."       ++ showSDoc dflags (ppr $ widthToLlvmInt w)-    (MO_Ctz w)    -> fsLit $ "llvm.cttz."       ++ showSDoc dflags (ppr $ widthToLlvmInt w)+    MO_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_Pdep w)   ->  let w' = showSDoc dflags (ppr $ widthInBits w)-                      in  if isBmi2Enabled dflags-                            then fsLit $ "llvm.x86.bmi.pdep."   ++ w'-                            else fsLit $ "hs_pdep"              ++ w'-    (MO_Pext w)   ->  let w' = showSDoc dflags (ppr $ widthInBits w)-                      in  if isBmi2Enabled dflags-                            then fsLit $ "llvm.x86.bmi.pext."   ++ w'-                            else fsLit $ "hs_pext"              ++ w'+    MO_SuspendThread -> fsLit "suspendThread"+    MO_ResumeThread  -> fsLit "resumeThread" -    (MO_Prefetch_Data _ )-> fsLit "llvm.prefetch"+    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    -> fsLit $ "llvm.sadd.with.overflow."-                             ++ showSDoc dflags (ppr $ widthToLlvmInt w)-    MO_SubIntC w    -> fsLit $ "llvm.ssub.with.overflow."-                             ++ showSDoc dflags (ppr $ widthToLlvmInt w)-    MO_Add2 w       -> fsLit $ "llvm.uadd.with.overflow."-                             ++ showSDoc dflags (ppr $ widthToLlvmInt w)-    MO_AddWordC w   -> fsLit $ "llvm.uadd.with.overflow."-                             ++ showSDoc dflags (ppr $ widthToLlvmInt w)-    MO_SubWordC w   -> fsLit $ "llvm.usub.with.overflow."-                             ++ showSDoc dflags (ppr $ widthToLlvmInt w)+    MO_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@@ -957,14 +1066,13 @@ genJump expr live = do     fty <- llvmFunTy live     (vf, stmts, top) <- exprToVar expr-    dflags <- getDynFlags      let cast = case getVarType vf of          ty | isPointer ty -> LM_Bitcast          ty | isInt ty     -> LM_Inttoptr -         ty -> panic $ "genJump: Expr is of bad type for function call! ("-                     ++ showSDoc dflags (ppr ty) ++ ")"+         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@@ -1075,9 +1183,8 @@     (vval,  stmts2, top2) <- exprToVar val      let stmts = stmts1 `appOL` stmts2-    dflags <- getDynFlags     platform <- getPlatform-    opts <- getLlvmOpts+    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@@ -1098,9 +1205,9 @@         other ->             pprPanic "genStore: ptr not right type!"                     (PprCmm.pprExpr platform addr <+> text (-                        "Size of Ptr: " ++ show (llvmPtrBits platform) +++                        "Size of Ptr: "   ++ show (llvmPtrBits platform) ++                         ", Size of var: " ++ show (llvmWidthInBits platform other) ++-                        ", Var: " ++ showSDoc dflags (ppVar opts vaddr)))+                        ", Var: "         ++ renderWithContext (llvmCgContext cfg) (ppVar cfg vaddr)))  mkStore :: LlvmVar -> LlvmVar -> AlignmentSpec -> LlvmStatement mkStore vval vptr alignment =@@ -1135,22 +1242,22 @@             let s1 = BranchIf vc' labelT labelF             return (stmts1 `appOL` stmts2 `snocOL` s1, top1 ++ top2)         else do-            dflags <- getDynFlags-            opts <- getLlvmOpts-            panic $ "genCondBranch: Cond expr not bool! (" ++ showSDoc dflags (ppVar opts vc) ++ ")"+            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-  dflags <- getDynFlags+  cfg <- getConfig    let     lit = LMLitVar $ LMIntLit expLit expTy      llvmExpectName-      | isInt expTy = fsLit $ "llvm.expect." ++ showSDoc dflags (ppr expTy)-      | otherwise   = panic $ "genExpectedLit: Type not an int!"+      | isInt expTy = fsLit $ "llvm.expect." ++ renderWithContext (llvmCgContext cfg) (ppr expTy)+      | otherwise   = panic "genExpectedLit: Type not an int!"    (llvmExpect, stmts, top) <-     getInstrinct llvmExpectName expTy [expTy, expTy]@@ -1159,7 +1266,6 @@  {- 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@@ -1600,6 +1706,7 @@      where         binLlvmOp ty binOp allow_y_cast = do+          cfg      <- getConfig           platform <- getPlatform           runExprData $ do             vx <- exprToVarW x@@ -1617,10 +1724,8 @@                | otherwise                -> do                     -- Error. Continue anyway so we can debug the generated ll file.-                    dflags <- getDynFlags-                    let style = PprCode CStyle-                        toString doc = renderWithContext (initSDocContext dflags style) doc-                        cmmToStr = (lines . toString . PprCmm.pprExpr platform)+                    let render   = renderWithContext (llvmCgContext cfg)+                        cmmToStr = (lines . render . PprCmm.pprExpr platform)                     statement $ Comment $ map fsLit $ cmmToStr x                     statement $ Comment $ map fsLit $ cmmToStr y                     doExprW (ty vx) $ binOp vx vy@@ -1633,12 +1738,11 @@               [vx',vy'] -> doExprW ty $ binOp vx' vy'               _         -> panic "genMachOp_slow: binCastLlvmOp" -        -- | Need to use EOption here as Cmm expects word size results from+        -- Need to use EOption here as Cmm expects word size results from         -- comparisons while LLVM return i1. Need to extend to llvmWord type         -- if expected. See Note [Literals and branch conditions].         genBinComp opt cmp = do-            ed@(v1, stmts, top) <- binLlvmOp (\_ -> i1) (Compare cmp) False-            dflags <- getDynFlags+            ed@(v1, stmts, top) <- binLlvmOp (const i1) (Compare cmp) False             platform <- getPlatform             if getVarType v1 == i1                 then case i1Expected opt of@@ -1648,8 +1752,8 @@                         (v2, s1) <- doExpr w_ $ Cast LM_Zext v1 w_                         return (v2, stmts `snocOL` s1, top)                 else-                    panic $ "genBinComp: Compare returned type other then i1! "-                        ++ (showSDoc dflags $ ppr $ getVarType v1)+                    pprPanic "genBinComp: Compare returned type other then i1! "+                               (ppr $ getVarType v1)          genBinMach op = binLlvmOp getVarType (LlvmOp op) False @@ -1657,20 +1761,19 @@          genCastBinMach ty op = binCastLlvmOp ty (LlvmOp op) -        -- | Detect if overflow will occur in signed multiply of the two+        -- 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-          dflags <- getDynFlags           runExprData $ do             vx <- exprToVarW x             vy <- exprToVarW y              let word  = getVarType vx-            let word2 = LMInt $ 2 * (llvmWidthInBits platform $ 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@@ -1687,7 +1790,8 @@                     doExprW word $ LlvmOp LM_MO_Sub rlow2 rhigh2                  else-                    panic $ "isSMulOK: Not bit type! (" ++ showSDoc dflags (ppr word) ++ ")"+                    pprPanic "isSMulOK: Not bit type! " $+                        lparen <> ppr word <> rparen          panicOp = panic $ "LLVM.CodeGen.genMachOp_slow: unary op encountered"                        ++ "with two arguments! (" ++ show op ++ ")"@@ -1765,8 +1869,7 @@              -> LlvmM ExprData genLoad_slow atomic e ty align meta = do   platform <- getPlatform-  dflags <- getDynFlags-  opts <- getLlvmOpts+  cfg      <- getConfig   runExprData $ do     iptr <- exprToVarW e     case getVarType iptr of@@ -1780,9 +1883,9 @@          other -> pprPanic "exprToVar: CmmLoad expression is not right type!"                      (PprCmm.pprExpr platform e <+> text (-                         "Size of Ptr: " ++ show (llvmPtrBits platform) +++                         "Size of Ptr: "   ++ show (llvmPtrBits platform) ++                          ", Size of var: " ++ show (llvmWidthInBits platform other) ++-                         ", Var: " ++ showSDoc dflags (ppVar opts iptr)))+                         ", Var: " ++ renderWithContext (llvmCgContext cfg) (ppVar cfg iptr)))  {- Note [Alignment of vector-typed values]@@ -1814,21 +1917,21 @@ getCmmReg :: CmmReg -> LlvmM LlvmVar getCmmReg (CmmLocal (LocalReg un _))   = do exists <- varLookup un-       dflags <- getDynFlags        case exists of          Just ety -> return (LMLocalVar un $ pLift ety)-         Nothing  -> panic $ "getCmmReg: Cmm register " ++ showSDoc dflags (ppr un) ++ " was not allocated!"+         Nothing  -> pprPanic "getCmmReg: Cmm register " $+                        ppr un <> text " was not allocated!"            -- This should never happen, as every local variable should            -- have been assigned a value at some point, triggering            -- "funPrologue" to allocate it on the stack.  getCmmReg (CmmGlobal g)-  = do onStack <- checkStackReg g-       dflags <- getDynFlags+  = do onStack  <- checkStackReg g        platform <- getPlatform        if onStack          then return (lmGlobalRegVar platform g)-         else panic $ "getCmmReg: Cmm register " ++ showSDoc dflags (ppr g) ++ " not stack-allocated!"+         else pprPanic "getCmmReg: Cmm register " $+                ppr g <> text " not stack-allocated!"  -- | Return the value of a given register, as well as its type. Might -- need to be load from stack.
+ GHC/CmmToLlvm/Config.hs view
@@ -0,0 +1,31 @@+-- | Llvm code generator configuration+module GHC.CmmToLlvm.Config+  ( LlvmCgConfig(..)+  , LlvmVersion(..)+  )+where++import GHC.Prelude+import GHC.Platform++import GHC.Utils.Outputable+import GHC.Driver.Session++import qualified Data.List.NonEmpty as NE++newtype LlvmVersion = LlvmVersion { llvmVersionNE :: NE.NonEmpty Int }+  deriving (Eq, Ord)++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+  , 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   -- ^ mirror DynFlags LlvmConfig.+    -- see Note [LLVM configuration] in "GHC.SysTools". This can be strict since+    -- GHC.Driver.Config.CmmToLlvm.initLlvmCgConfig verifies the files are present.+  }
GHC/CmmToLlvm/Data.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ -- ---------------------------------------------------------------------------- -- | Handle conversion of CmmData to LLVM code. --@@ -7,15 +7,15 @@         genLlvmData, genData     ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Llvm import GHC.CmmToLlvm.Base+import GHC.CmmToLlvm.Config  import GHC.Cmm.BlockId import GHC.Cmm.CLabel+import GHC.Cmm.InitFini import GHC.Cmm import GHC.Platform @@ -42,7 +42,7 @@  -- | 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".+-- 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@@ -66,6 +66,14 @@      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@@ -89,6 +97,37 @@      return ([globDef], [tyAlias]) +-- | Produce an initializer or finalizer array declaration.+-- See Note [Initializers and finalizers in Cmm] in GHC.Cmm.InitFini for+-- details.+genGlobalLabelArray :: FastString -> [CLabel] -> LlvmM LlvmData+genGlobalLabelArray var_nm clbls = do+    lbls <- mapM strCLabel_llvm clbls+    decls <- mapM mkFunDecl lbls+    let entries = map toArrayEntry lbls+        static = LMStaticArray entries arr_ty+        arr = LMGlobal arr_var (Just static)+    return ([arr], decls)+  where+    mkFunDecl :: LMString -> LlvmM LlvmType+    mkFunDecl fn_lbl = do+        let fn_ty = mkFunTy fn_lbl+        funInsert fn_lbl fn_ty+        return (fn_ty)++    toArrayEntry :: LMString -> LlvmStatic+    toArrayEntry fn_lbl =+        let fn_var = LMGlobalVar fn_lbl (LMPointer $ mkFunTy fn_lbl) Internal Nothing Nothing Global+            fn = LMStaticPointer fn_var+            null = LMStaticLit (LMNullLit i8Ptr)+            prio = LMStaticLit $ LMIntLit 0xffff i32+        in LMStaticStrucU [prio, fn, null] entry_ty++    arr_var = LMGlobalVar var_nm arr_ty Internal Nothing Nothing Global+    mkFunTy lbl = LMFunction $ LlvmFunctionDecl lbl ExternallyVisible CC_Ccc LMVoid FixedArgs [] Nothing+    entry_ty = LMStructU [i32, LMPointer $ mkFunTy $ fsLit "placeholder", LMPointer i8]+    arr_ty = LMArray (length clbls) entry_ty+ -- | Format the section type part of a Cmm Section llvmSectionType :: Platform -> SectionType -> FastString llvmSectionType p t = case t of@@ -107,14 +146,17 @@     CString                 -> case platformOS p of                                  OSMinGW32 -> fsLit ".rdata$str"                                  _         -> fsLit ".rodata.str"-    (OtherSection _)        -> panic "llvmSectionType: unknown section type" +    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 <- getLlvmOpts-  let splitSect = llvmOptsSplitSections opts-      platform  = llvmOptsPlatform opts+  opts <- getConfig+  let splitSect = llvmCgSplitSection opts+      platform  = llvmCgPlatform     opts   if not splitSect   then return Nothing   else do
GHC/CmmToLlvm/Mangler.hs view
@@ -13,44 +13,39 @@  import GHC.Prelude -import GHC.Driver.Session ( DynFlags, targetPlatform )-import GHC.Platform ( platformArch, Arch(..) )-import GHC.Utils.Error ( withTiming )-import GHC.Utils.Outputable ( text )-import GHC.Utils.Logger+import GHC.Platform ( Platform, platformArch, Arch(..) )+import GHC.Utils.Exception (try) -import Control.Exception import qualified Data.ByteString.Char8 as B import System.IO  -- | Read in assembly file and process-llvmFixupAsm :: Logger -> DynFlags -> FilePath -> FilePath -> IO ()-llvmFixupAsm logger dflags f1 f2 = {-# SCC "llvm_mangler" #-}-    withTiming logger dflags (text "LLVM Mangler") id $-    withBinaryFile f1 ReadMode $ \r -> withBinaryFile f2 WriteMode $ \w -> do-        go r w-        hClose r-        hClose w-        return ()+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 dflags rewrites a) >> go r w+      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]+rewrites = [rewriteSymType, rewriteAVX, rewriteCall] -type Rewrite = DynFlags -> B.ByteString -> Maybe B.ByteString+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 :: DynFlags -> [Rewrite] -> B.ByteString -> B.ByteString-rewriteLine dflags rewrites l+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@@ -58,7 +53,7 @@   | isSubsectionsViaSymbols l =     (B.pack "## no .subsection_via_symbols for ghc. We need our info tables!")   | otherwise =-    case firstJust $ map (\rewrite -> rewrite dflags rest) rewrites of+    case firstJust $ map (\rewrite -> rewrite platform rest) rewrites of       Nothing        -> l       Just rewritten -> B.concat $ [symbol, B.pack "\t", rewritten]   where@@ -97,15 +92,36 @@ -- tells LLVM that the stack is 32-byte aligned (even though it isn't) and then -- rewrites the instructions in the mangler. rewriteAVX :: Rewrite-rewriteAVX dflags s+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 (targetPlatform dflags) == ArchX86_64+    isX86_64 = platformArch platform == ArchX86_64     isVmovdqa = B.isPrefixOf (B.pack "vmovdqa")     isVmovap = B.isPrefixOf (B.pack "vmovap")++-- | This rewrites (tail) calls to avoid creating PLT entries for+-- functions on riscv64. The replacement will load the address from the+-- GOT, which is resolved to point to the real address of the function.+rewriteCall :: Rewrite+rewriteCall platform l+  | not isRISCV64 = Nothing+  | isCall l      = Just $ replaceCall "call" "jalr" "ra" l+  | isTail l      = Just $ replaceCall "tail" "jr" "t1" l+  | otherwise     = Nothing+  where+    isRISCV64 = platformArch platform == ArchRISCV64+    isCall = B.isPrefixOf (B.pack "call\t")+    isTail = B.isPrefixOf (B.pack "tail\t")++    replaceCall call jump reg l =+        appendInsn (jump ++ "\t" ++ reg) $ removePlt $+        replaceOnce (B.pack call) (B.pack ("la\t" ++ reg ++ ",")) l+      where+        removePlt = replaceOnce (B.pack "@plt") (B.pack "")+        appendInsn i = (`B.append` B.pack ("\n\t" ++ i))  -- | @replaceOnce match replace bs@ replaces the first occurrence of the -- substring @match@ in @bs@ with @replace@.
GHC/CmmToLlvm/Ppr.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE CPP #-} + -- ---------------------------------------------------------------------------- -- | Pretty print helpers for the LLVM Code generator. --@@ -7,15 +7,12 @@         pprLlvmCmmDecl, pprLlvmData, infoSection     ) where -#include "HsVersions.h"- import GHC.Prelude -import GHC.Driver.Ppr- import GHC.Llvm import GHC.CmmToLlvm.Base import GHC.CmmToLlvm.Data+import GHC.CmmToLlvm.Config  import GHC.Cmm.CLabel import GHC.Cmm@@ -29,21 +26,21 @@ --  -- | Pretty print LLVM data code-pprLlvmData :: LlvmOpts -> LlvmData -> SDoc-pprLlvmData opts (globals, types) =+pprLlvmData :: LlvmCgConfig -> LlvmData -> SDoc+pprLlvmData cfg (globals, types) =     let ppLlvmTys (LMAlias    a) = ppLlvmAlias a         ppLlvmTys (LMFunction f) = ppLlvmFunctionDecl f         ppLlvmTys _other         = empty          types'   = vcat $ map ppLlvmTys types-        globals' = ppLlvmGlobals opts globals+        globals' = ppLlvmGlobals cfg globals     in types' $+$ globals'   -- | Pretty print LLVM code pprLlvmCmmDecl :: LlvmCmmDecl -> LlvmM (SDoc, [LlvmVar]) pprLlvmCmmDecl (CmmData _ lmdata) = do-  opts <- getLlvmOpts+  opts <- getConfig   return (vcat $ map (pprLlvmData opts) lmdata, [])  pprLlvmCmmDecl (CmmProc mb_info entry_lbl live (ListGraph blks))@@ -56,13 +53,12 @@            lmblocks = map (\(BasicBlock id stmts) ->                                 LlvmBlock (getUnique id) stmts) blks -       funDec <- llvmFunSig live lbl link-       dflags <- getDynFlags-       opts <- getLlvmOpts+       funDec   <- llvmFunSig live lbl link+       cfg      <- getConfig        platform <- getPlatform-       let buildArg = fsLit . showSDoc dflags . ppPlainName opts+       let buildArg = fsLit . renderWithContext (llvmCgContext cfg). ppPlainName cfg            funArgs = map buildArg (llvmFunArgs platform live)-           funSect = llvmFunSection opts (decName funDec)+           funSect = llvmFunSection cfg (decName funDec)         -- generate the info table        prefix <- case mb_info of@@ -96,7 +92,7 @@                             (Just $ LMBitc (LMStaticPointer defVar)                                            i8Ptr) -       return (ppLlvmGlobal opts alias $+$ ppLlvmFunction opts fun', [])+       return (ppLlvmGlobal cfg alias $+$ ppLlvmFunction cfg fun', [])   -- | The section we are putting info tables and their entry code into, should
GHC/CmmToLlvm/Regs.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE CPP #-} + -------------------------------------------------------------------------------- -- | Deal with Cmm registers --@@ -8,8 +8,6 @@         lmGlobalRegArg, lmGlobalRegVar, alwaysLive,         stgTBAA, baseN, stackN, heapN, rxN, topN, tbaa, getTBAA     ) where--#include "HsVersions.h"  import GHC.Prelude
GHC/Core.hs view
@@ -3,7 +3,7 @@ (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -} -{-# LANGUAGE CPP, DeriveDataTypeable, FlexibleContexts #-}+{-# LANGUAGE DeriveDataTypeable, FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE BangPatterns #-} @@ -46,8 +46,8 @@         collectNBinders,         collectArgs, stripNArgs, collectArgsTicks, flattenBinds, -        exprToType, exprToCoercion_maybe,-        applyTypeToArg,+        exprToType,+        wrapLamBody,          isValArg, isTypeArg, isCoArg, isTyCoArg, valArgCount, valBndrCount,         isRuntimeArg, isRuntimeVar,@@ -64,8 +64,8 @@         maybeUnfoldingTemplate, otherCons,         isValueUnfolding, isEvaldUnfolding, isCheapUnfolding,         isExpandableUnfolding, isConLikeUnfolding, isCompulsoryUnfolding,-        isStableUnfolding, hasCoreUnfolding, hasSomeUnfolding,-        isBootUnfolding,+        isStableUnfolding, isInlineUnfolding, isBootUnfolding,+        hasCoreUnfolding, hasSomeUnfolding,         canUnfold, neverUnfoldGuidance, isStableSource,          -- * Annotated expression data types@@ -92,8 +92,6 @@         isBuiltinRule, isLocalRule, isAutoRule,     ) where -#include "HsVersions.h"- import GHC.Prelude import GHC.Platform @@ -103,7 +101,7 @@ import GHC.Core.Coercion import GHC.Types.Name import GHC.Types.Name.Set-import GHC.Types.Name.Env( NameEnv, emptyNameEnv )+import GHC.Types.Name.Env( NameEnv ) import GHC.Types.Literal import GHC.Types.Tickish import GHC.Core.DataCon@@ -115,8 +113,7 @@ import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic--import GHC.Driver.Ppr+import GHC.Utils.Panic.Plain  import Data.Data hiding (TyCon) import Data.Int@@ -179,10 +176,10 @@ -- -- *  Applications: note that the argument may be a 'Type'. --    See Note [Core let/app invariant]---    See Note [Levity polymorphism invariants]+--    See Note [Representation polymorphism invariants] -- -- *  Lambda abstraction---    See Note [Levity polymorphism invariants]+--    See Note [Representation polymorphism invariants] -- -- *  Recursive and non recursive @let@s. Operationally --    this corresponds to allocating a thunk for the things@@ -190,7 +187,7 @@ -- --    See Note [Core letrec invariant] --    See Note [Core let/app invariant]---    See Note [Levity polymorphism invariants]+--    See Note [Representation polymorphism invariants] --    See Note [Core type and coercion invariant] -- -- *  Case expression. Operationally this corresponds to evaluating@@ -300,7 +297,7 @@ -- The instance adheres to the order described in [Core case invariants] instance Ord AltCon where   compare (DataAlt con1) (DataAlt con2) =-    ASSERT( dataConTyCon con1 == dataConTyCon con2 )+    assert (dataConTyCon con1 == dataConTyCon con2) $     compare (dataConTag con1) (dataConTag con2)   compare (DataAlt _) _ = GT   compare _ (DataAlt _) = LT@@ -510,7 +507,7 @@ 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 isFloatingTy.+   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.@@ -548,26 +545,73 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~ See Note [Case expression invariants] -Note [Levity polymorphism invariants]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The levity-polymorphism invariants are these (as per "Levity Polymorphism",-PLDI '17):+Note [Representation polymorphism invariants]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+GHC allows us to abstract over calling conventions using **representation polymorphism**.+For example, we have: -* The type of a term-binder must not be levity-polymorphic,-  unless it is a let(rec)-bound join point-     (see Note [Invariants on join points])+  ($) :: forall (r :: RuntimeRep) (a :: Type) (b :: TYPE r). a -> b -> b -* The type of the argument of an App must not be levity-polymorphic.+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`. -A type (t::TYPE r) is "levity polymorphic" if 'r' has any free variables.+To ensure that programs containing representation-polymorphism remain compilable,+we enforce the following representation-polymorphism invariants: -For example+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.++On top of these two invariants, GHC's internal eta-expansion mechanism also requires:++  I3. In any partial application `f e_1 .. e_n`, where `f` is `hasNoBinding`,+      it must be the case that the application can be eta-expanded to match+      the arity of `f`.+      See Note [checkCanEtaExpand] in GHC.Core.Lint for more details.++Example of I1:+   \(r::RuntimeRep). \(a::TYPE r). \(x::a). e-is illegal because x's type has kind (TYPE r), which has 'r' free. -See Note [Levity polymorphism checking] in GHC.HsToCore.Monad to see where these-invariants are established for user-written code.+    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.++Examples of I3:++  myUnsafeCoerce# :: forall {r1} (a :: TYPE r1) {r2} (b :: TYPE r2). a -> b+  myUnsafeCoerce# = unsafeCoerce#++    This contravenes I3: we are instantiating `unsafeCoerce#` without any+    value arguments, and with a remaining argument type, `a`, which does not+    have a fixed runtime representation.+    But `unsafeCorce#` has no binding (see Note [Wiring in unsafeCoerce#]+    in GHC.HsToCore).  So before code-generation we must saturate it+    by eta-expansion (see GHC.CoreToStg.Prep.maybeSaturate), thus+       myUnsafeCoerce# = \x. unsafeCoerce# x+    But we can't do that because now the \x binding would violate I1.++  bar :: forall (a :: TYPE) r (b :: TYPE r). a -> b+  bar = unsafeCoerce#++    OK: eta expand to `\ (x :: Type) -> unsafeCoerce# x`,+    and `x` has a fixed RuntimeRep.++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 [Core let goal] ~~~~~~~~~~~~~~~~~~~~ * The simplifier tries to ensure that if the RHS of a let is a constructor@@ -695,7 +739,6 @@           The arity of a join point isn't very important; but short of setting          it to zero, it is helpful to have an invariant.  E.g. #17294.-         See also Note [Do not eta-expand join points] in GHC.Core.Opt.Simplify.Utils.    3. If the binding is recursive, then all other bindings in the recursive group      must also be join points.@@ -709,7 +752,7 @@      ok-for-speculation (i.e. drop the let/app invariant)      e.g.  let j :: Int# = factorial x in ... -  6. A join point can have a levity-polymorphic RHS+  6. The RHS of join point is not required to have a fixed runtime representation,      e.g.  let j :: r :: TYPE l = fail void# in ...      This happened in an intermediate program #13394 @@ -939,7 +982,7 @@ -- See Note [Orphans] data IsOrphan   = IsOrphan-  | NotOrphan OccName -- The OccName 'n' witnesses the instance's non-orphanhood+  | 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@@ -1041,16 +1084,41 @@ -- 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...) data RuleEnv-    = RuleEnv { re_base          :: RuleBase+    = RuleEnv { re_base          :: [RuleBase] -- See Note [Why re_base is a list]               , re_visible_orphs :: ModuleSet               }  mkRuleEnv :: RuleBase -> [Module] -> RuleEnv-mkRuleEnv rules vis_orphs = RuleEnv rules (mkModuleSet vis_orphs)+mkRuleEnv rules vis_orphs = RuleEnv [rules] (mkModuleSet vis_orphs)  emptyRuleEnv :: RuleEnv-emptyRuleEnv = RuleEnv emptyNameEnv emptyModuleSet+emptyRuleEnv = RuleEnv [] emptyModuleSet +{-+Note [Why re_base is a list]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~++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.+-}+ -- | A 'CoreRule' is: -- -- * \"Local\" if the function it is a rule for is defined in the@@ -1114,7 +1182,7 @@                 -- 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 rule matching] in GHC.Core.Rules+                -- See Note [Extra args in the target] in GHC.Core.Rules  -- | Rule options data RuleOpts = RuleOpts@@ -1124,6 +1192,8 @@    , roBignumRules             :: !Bool     -- ^ Enable rules for bignums    } +-- | The 'InScopeSet' in the 'InScopeEnv' is a /superset/ of variables that are+-- currently in scope. See Note [The InScopeSet invariant]. type RuleFun = RuleOpts -> InScopeEnv -> Id -> [CoreExpr] -> Maybe CoreExpr type InScopeEnv = (InScopeSet, IdUnfoldingFun) @@ -1176,6 +1246,17 @@ ************************************************************************  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@@ -1458,6 +1539,22 @@ isStableUnfolding (DFunUnfolding {})               = True isStableUnfolding _                                = 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@@ -1576,9 +1673,7 @@ cmpAltCon (LitAlt  l1) (LitAlt  l2) = l1 `compare` l2 cmpAltCon (LitAlt _)   DEFAULT      = GT -cmpAltCon con1 con2 = WARN( True, text "Comparing incomparable AltCons" <+>-                                  ppr con1 <+> ppr con2 )-                      LT+cmpAltCon con1 con2 = pprPanic "cmpAltCon" (ppr con1 $$ ppr con2)  {- ************************************************************************@@ -1804,7 +1899,7 @@ varToCoreExpr :: CoreBndr -> Expr b varToCoreExpr v | isTyVar v = Type (mkTyVarTy v)                 | isCoVar v = Coercion (mkCoVarCo v)-                | otherwise = ASSERT( isId v ) Var v+                | otherwise = assert (isId v) $ Var v  varsToCoreExprs :: [CoreBndr] -> [Expr b] varsToCoreExprs vs = map varToCoreExpr vs@@ -1820,22 +1915,12 @@  -} -applyTypeToArg :: Type -> CoreExpr -> Type--- ^ Determines the type resulting from applying an expression with given type--- to a given argument expression-applyTypeToArg fun_ty arg = piResultTy fun_ty (exprToType arg)- -- | 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 --- | If the expression is a 'Coercion', converts.-exprToCoercion_maybe :: CoreExpr -> Maybe Coercion-exprToCoercion_maybe (Coercion co) = Just co-exprToCoercion_maybe _             = Nothing- {- ************************************************************************ *                                                                      *@@ -1919,6 +2004,14 @@   where     go (App f a) as = go f (a:as)     go e         as = (e, as)++-- | 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
GHC/Core/Class.hs view
@@ -3,8 +3,8 @@ -- -- The @Class@ datatype -{-# LANGUAGE CPP #-} + module GHC.Core.Class (         Class,         ClassOpItem,@@ -21,8 +21,6 @@         isAbstractClass,     ) where -#include "HsVersions.h"- import GHC.Prelude  import {-# SOURCE #-} GHC.Core.TyCon    ( TyCon )@@ -34,6 +32,7 @@ import GHC.Types.Unique import GHC.Utils.Misc import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Types.SrcLoc import GHC.Utils.Outputable import GHC.Data.BooleanFormula (BooleanFormula, mkTrue)@@ -80,7 +79,7 @@ -- --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnRarrow'', --- For details on above see note [exact print annotations] in GHC.Parser.Annotation+-- For details on above see Note [exact print annotations] in GHC.Parser.Annotation type FunDep a = ([a],[a])  type ClassOpItem = (Id, DefMethInfo)@@ -254,20 +253,20 @@ -- 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) ) []+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) ) []+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 )+  = assert (n >= 0 && lengthExceeds sc_sels n )     sc_sels !! n classSCSelId c n = pprPanic "classSCSelId" (ppr c <+> ppr n)
GHC/Core/Coercion.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP                 #-} {-# LANGUAGE FlexibleContexts    #-} {-# LANGUAGE RankNTypes          #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -21,7 +20,8 @@         Role(..), ltRole,          -- ** Functions over coercions-        coVarTypes, coVarKind, coVarKindsTypesRole, coVarRole,+        coVarRType, coVarLType, coVarTypes,+        coVarKind, coVarKindsTypesRole, coVarRole,         coercionType, mkCoercionType,         coercionKind, coercionLKind, coercionRKind,coercionKinds,         coercionRole, coercionKindRole,@@ -73,8 +73,8 @@         mkCoherenceRightMCo,          coToMCo, mkTransMCo, mkTransMCoL, mkTransMCoR, mkCastTyMCo, mkSymMCo,-        mkHomoForAllMCo, mkFunResMCo, mkPiMCos, checkReflexiveMCo,-        isReflMCo,+        mkHomoForAllMCo, mkFunResMCo, mkPiMCos,+        isReflMCo, checkReflexiveMCo,          -- ** Coercion variables         mkCoVar, isCoVar, coVarName, setCoVarName, setCoVarUnique,@@ -123,14 +123,11 @@          multToCo, -        simplifyArgsWorker,+        hasCoercionHoleTy, hasCoercionHoleCo, hasThisCoercionHoleTy, -        hasCoercionHoleTy, hasCoercionHoleCo,-        HoleSet, coercionHolesOfType, coercionHolesOfCo+        setCoHoleType        ) where -#include "HsVersions.h"- import {-# SOURCE #-} GHC.CoreToIface (toIfaceTyCon, tidyToIfaceTcArgs)  import GHC.Prelude@@ -159,11 +156,11 @@ import GHC.Data.List.SetOps import GHC.Data.Maybe import GHC.Types.Unique.FM-import GHC.Types.Unique.Set  import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain  import Control.Monad (foldM, zipWithM) import Data.Function ( on )@@ -310,6 +307,7 @@ 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 dicussion on this point coToMCo co | isReflCo co = MRefl            | otherwise   = MCo co @@ -427,7 +425,11 @@ -- Expects co :: (s1 -> t1) ~ (s2 -> t2) -- Returns (co1 :: s1~s2, co2 :: t1~t2) -- See Note [Function coercions] for the "3" and "4"-decomposeFunCo r co = ASSERT2( all_ok, ppr co )++decomposeFunCo _ (FunCo _ w co1 co2) = (w, co1, co2)+   -- Short-circuits the calls to mkNthCo++decomposeFunCo r co = assertPpr all_ok (ppr co)                       (mkNthCo Nominal 0 co, mkNthCo r 3 co, mkNthCo r 4 co)   where     Pair s1t1 s2t2 = coercionKind co@@ -607,7 +609,7 @@  coVarKind :: CoVar -> Type coVarKind cv-  = ASSERT( isCoVar cv )+  = assert (isCoVar cv )     varType cv  coVarRole :: CoVar -> Role@@ -840,7 +842,7 @@ mkAppCos co1 cos = foldl' mkAppCo co1 cos  {- Note [Unused coercion variable in ForAllCo]-+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ See Note [Unused coercion variable in ForAllTy] in GHC.Core.TyCo.Rep for the motivation for checking coercion variable in types. To lift the design choice to (ForAllCo cv kind_co body_co), we have two options:@@ -883,8 +885,8 @@ -- See Note [Unused coercion variable in ForAllCo] mkForAllCo :: TyCoVar -> CoercionN -> Coercion -> Coercion mkForAllCo v kind_co co-  | ASSERT( varType v `eqType` (pFst $ coercionKind kind_co)) True-  , ASSERT( isTyVar v || almostDevoidCoVarOfCo v co) True+  | assert (varType v `eqType` (pFst $ coercionKind kind_co)) True+  , assert (isTyVar v || almostDevoidCoVarOfCo v co) True   , Just (ty, r) <- isReflCo_maybe co   , isGReflCo kind_co   = mkReflCo r (mkTyCoInvForAllTy v ty)@@ -896,9 +898,9 @@ -- The kind of the tycovar should be the left-hand kind of the kind coercion. mkForAllCo_NoRefl :: TyCoVar -> CoercionN -> Coercion -> Coercion mkForAllCo_NoRefl v kind_co co-  | ASSERT( varType v `eqType` (pFst $ coercionKind kind_co)) True-  , ASSERT( isTyVar v || almostDevoidCoVarOfCo v co) True-  , ASSERT( not (isReflCo co)) True+  | assert (varType v `eqType` (pFst $ coercionKind kind_co)) True+  , assert (isTyVar v || almostDevoidCoVarOfCo v co) True+  , assert (not (isReflCo co)) True   , isCoVar v   , not (v `elemVarSet` tyCoVarsOfCo co)   = FunCo (coercionRole co) (multToCo Many) kind_co co@@ -930,7 +932,7 @@ -- reflexive coercion. For example, it is guaranteed in 'mkHomoForAllCos'. mkHomoForAllCos_NoRefl :: [TyCoVar] -> Coercion -> Coercion mkHomoForAllCos_NoRefl vs orig_co-  = ASSERT( not (isReflCo orig_co))+  = assert (not (isReflCo orig_co))     foldr go orig_co vs   where     go v co = mkForAllCo_NoRefl v (mkNomReflCo (varType v)) co@@ -965,7 +967,7 @@ mkAxInstCo role ax index tys cos   | arity == n_tys = downgradeRole role ax_role $                      mkAxiomInstCo ax_br index (rtys `chkAppend` cos)-  | otherwise      = ASSERT( arity < n_tys )+  | otherwise      = assert (arity < n_tys) $                      downgradeRole role ax_role $                      mkAppCos (mkAxiomInstCo ax_br index                                              (ax_args `chkAppend` cos))@@ -985,7 +987,7 @@ -- worker function mkAxiomInstCo :: CoAxiom Branched -> BranchIndex -> [Coercion] -> Coercion mkAxiomInstCo ax index args-  = ASSERT( args `lengthIs` coAxiomArity ax index )+  = assert (args `lengthIs` coAxiomArity ax index) $     AxiomInstCo ax index args  -- to be used only with unbranched axioms@@ -1000,7 +1002,7 @@ -- A companion to mkAxInstCo: --    mkAxInstRhs ax index tys = snd (coercionKind (mkAxInstCo ax index tys)) mkAxInstRHS ax index tys cos-  = ASSERT( tvs `equalLength` tys1 )+  = assert (tvs `equalLength` tys1) $     mkAppTys rhs' tys2   where     branch       = coAxiomNthBranch ax index@@ -1018,7 +1020,7 @@ -- at the types given. mkAxInstLHS :: CoAxiom br -> BranchIndex -> [Type] -> [Coercion] -> Type mkAxInstLHS ax index tys cos-  = ASSERT( tvs `equalLength` tys1 )+  = assert (tvs `equalLength` tys1) $     mkTyConApp fam_tc (lhs_tys `chkAppend` tys2)   where     branch       = coAxiomNthBranch ax index@@ -1067,7 +1069,7 @@                   | isReflCo co2 = co1 mkTransCo (GRefl r t1 (MCo co1)) (GRefl _ _ (MCo co2))   = GRefl r t1 (MCo $ mkTransCo co1 co2)-mkTransCo co1 co2                 = TransCo co1 co2+mkTransCo co1 co2                = TransCo co1 co2  mkNthCo :: HasDebugCallStack         => Role  -- The role of the coercion you're creating@@ -1075,7 +1077,7 @@         -> Coercion         -> Coercion mkNthCo r n co-  = ASSERT2( good_call, bad_call_msg )+  = assertPpr good_call bad_call_msg $     go n co   where     Pair ty1 ty2 = coercionKind co@@ -1084,14 +1086,14 @@       | Just (ty, _) <- isReflCo_maybe co       , Just (tv, _) <- splitForAllTyCoVar_maybe ty       = -- works for both tyvar and covar-        ASSERT( r == Nominal )+        assert (r == Nominal) $         mkNomReflCo (varType tv)      go n co       | Just (ty, r0) <- isReflCo_maybe co       , let tc = tyConAppTyCon ty-      = ASSERT2( ok_tc_app ty n, ppr n $$ ppr ty )-        ASSERT( nthRole r0 tc n == r )+      = assertPpr (ok_tc_app ty n) (ppr n $$ ppr ty) $+        assert (nthRole r0 tc n == r) $         mkReflCo r (tyConAppArgN n ty)       where ok_tc_app :: Type -> Int -> Bool             ok_tc_app ty n@@ -1103,7 +1105,7 @@               = False      go 0 (ForAllCo _ kind_co _)-      = ASSERT( r == Nominal )+      = assert (r == Nominal)         kind_co       -- If co :: (forall a1:k1. t1) ~ (forall a2:k2. t2)       -- then (nth 0 co :: k1 ~N k2)@@ -1113,12 +1115,12 @@     go n (FunCo _ w arg res)       = mkNthCoFunCo n w arg res -    go n (TyConAppCo r0 tc arg_cos) = ASSERT2( r == nthRole r0 tc n-                                                    , (vcat [ ppr tc-                                                            , ppr arg_cos-                                                            , ppr r0-                                                            , ppr n-                                                            , ppr r ]) )+    go n (TyConAppCo r0 tc arg_cos) = assertPpr (r == nthRole r0 tc n)+                                                  (vcat [ ppr tc+                                                        , ppr arg_cos+                                                        , ppr r0+                                                        , ppr n+                                                        , ppr r ]) $                                              arg_cos `getNth` n      go n (SymCo co)  -- Recurse, hoping to get to a TyConAppCo or FunCo@@ -1286,7 +1288,7 @@   = FunCo Representational w           (downgradeRole Representational Nominal arg)           (downgradeRole Representational Nominal res)-mkSubCo co = ASSERT2( coercionRole co == Nominal, ppr co <+> ppr (coercionRole co) )+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]@@ -1321,7 +1323,7 @@  -- | Make a "coercion between coercions". mkProofIrrelCo :: Role       -- ^ role of the created coercion, "r"-               -> Coercion   -- ^ :: phi1 ~N phi2+               -> CoercionN  -- ^ :: phi1 ~N phi2                -> Coercion   -- ^ g1 :: phi1                -> Coercion   -- ^ g2 :: phi2                -> Coercion   -- ^ :: g1 ~r g2@@ -1440,13 +1442,13 @@     _ | ki1 `eqType` ki2       -> mkNomReflCo (typeKind ty1)      -- no later branch should return refl-     --    The ASSERT( False )s throughout+     --    The assert (False )s throughout      -- are these cases explicitly, but they should never fire. -    Refl _ -> ASSERT( False )+    Refl _ -> assert False $               mkNomReflCo ki1 -    GRefl _ _ MRefl -> ASSERT( False )+    GRefl _ _ MRefl -> assert False $                        mkNomReflCo ki1      GRefl _ _ (MCo co) -> co@@ -1469,12 +1471,12 @@       -> promoteCoercion g      ForAllCo _ _ _-      -> ASSERT( False )+      -> assert False $          mkNomReflCo liftedTypeKind       -- See Note [Weird typing rule for ForAllTy] in GHC.Core.TyCo.Rep      FunCo _ _ _ _-      -> ASSERT( False )+      -> assert False $          mkNomReflCo liftedTypeKind      CoVarCo {}     -> mkKindCo co@@ -1500,7 +1502,7 @@        | Just _ <- splitForAllCo_maybe co       , n == 0-      -> ASSERT( False ) mkNomReflCo liftedTypeKind+      -> assert False $ mkNomReflCo liftedTypeKind        | otherwise       -> mkKindCo co@@ -1516,15 +1518,15 @@      InstCo g _       | isForAllTy_ty ty1-      -> ASSERT( isForAllTy_ty ty2 )+      -> assert (isForAllTy_ty ty2) $          promoteCoercion g       | otherwise-      -> ASSERT( False)+      -> assert False $          mkNomReflCo liftedTypeKind            -- See Note [Weird typing rule for ForAllTy] in GHC.Core.TyCo.Rep      KindCo _-      -> ASSERT( False )+      -> assert False $          mkNomReflCo liftedTypeKind      SubCo g@@ -1591,7 +1593,7 @@                   -> CoercionN -> Coercion castCoercionKind1 g r t1 t2 h   = case g of-      Refl {} -> ASSERT( r == Nominal ) -- Refl is always Nominal+      Refl {} -> assert (r == Nominal) $ -- Refl is always Nominal                  mkNomReflCo (mkCastTy t2 h)       GRefl _ _ mco -> case mco of            MRefl       -> mkReflCo r (mkCastTy t2 h)@@ -1626,13 +1628,13 @@ mkFamilyTyConAppCo tc cos   | Just (fam_tc, fam_tys) <- tyConFamInst_maybe tc   , let tvs = tyConTyVars tc-        fam_cos = ASSERT2( tvs `equalLength` cos, ppr tc <+> ppr cos )+        fam_cos = assertPpr (tvs `equalLength` cos) (ppr tc <+> ppr cos) $                   map (liftCoSubstWith Nominal tvs cos) fam_tys   = mkTyConAppCo Nominal fam_tc fam_cos   | otherwise   = mkTyConAppCo Nominal tc cos --- See note [Newtype coercions] in GHC.Core.TyCon+-- See Note [Newtype coercions] in GHC.Core.TyCon  mkPiCos :: Role -> [Var] -> Coercion -> Coercion mkPiCos r vs co = foldr (mkPiCo r) co vs@@ -1641,7 +1643,7 @@ -- are quantified over the same variable. mkPiCo  :: Role -> Var -> Coercion -> Coercion mkPiCo r v co | isTyVar v = mkHomoForAllCos [v] co-              | isCoVar v = ASSERT( not (v `elemVarSet` tyCoVarsOfCo co) )+              | isCoVar v = assert (not (v `elemVarSet` tyCoVarsOfCo co)) $                   -- We didn't call mkForAllCo here because if v does not appear                   -- in co, the argement coercion will be nominal. But here we                   -- want it to be r. It is only called in 'mkPiCos', which is@@ -1705,9 +1707,8 @@ %************************************************************************ -} --- | If @co :: T ts ~ rep_ty@ then:------ > instNewTyCon_maybe T ts = Just (rep_ty, co)+-- | 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)@@ -1769,7 +1770,8 @@ unwrapNewTypeStepper :: NormaliseStepper Coercion unwrapNewTypeStepper rec_nts tc tys   | Just (ty', co) <- instNewTyCon_maybe tc tys-  = case checkRecTc rec_nts tc of+  = -- 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 @@ -1788,10 +1790,13 @@ -- 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)+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@@ -2014,7 +2019,7 @@     -- lift_s1 :: s1 ~r s1'     -- lift_s2 :: s2 ~r s2'     -- kco     :: (s1 ~r s2) ~N (s1' ~r s2')-    ASSERT( isCoVar v )+    assert (isCoVar v) $     let (_, _, s1, s2, r) = coVarKindsTypesRole v         lift_s1 = ty_co_subst lc r s1         lift_s2 = ty_co_subst lc r s2@@ -2051,7 +2056,9 @@ 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+    -- 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@@ -2075,7 +2082,7 @@            -- fall into it.          then mkForAllCo v' h body_co          else pprPanic "ty_co_subst: covar is not almost devoid" (ppr t)-    go r ty@(LitTy {})     = ASSERT( r == Nominal )+    go r ty@(LitTy {})     = assert (r == Nominal) $                              mkNomReflCo ty     go r (CastTy ty co)    = castCoercionKind (go r ty) (substLeftCo lc co)                                                         (substRightCo lc co)@@ -2110,14 +2117,23 @@   = Just $ mkReflCo r (substTyVar subst v)  {- Note [liftCoSubstVarBndr]-+   ~~~~~~~~~~~~~~~~~~~~~~~~~ callback:-  We want 'liftCoSubstVarBndrUsing' to be general enough to be reused in-  FamInstEnv, therefore the input arg 'fun' returns a pair with polymorphic type-  in snd.-  However in 'liftCoSubstVarBndr', we don't need the snd, so we use unit and-  ignore the fourth component of the return value.+  '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@@ -2150,52 +2166,56 @@ liftCoSubstVarBndr :: LiftingContext -> TyCoVar                    -> (LiftingContext, TyCoVar, Coercion) liftCoSubstVarBndr lc tv-  = let (lc', tv', h, _) = liftCoSubstVarBndrUsing callback lc tv in-    (lc', tv', h)+  = liftCoSubstVarBndrUsing id callback lc tv   where-    callback lc' ty' = (ty_co_subst lc' Nominal ty', ())+    callback lc' ty' = ty_co_subst lc' Nominal ty'  -- the callback must produce a nominal coercion-liftCoSubstVarBndrUsing :: (LiftingContext -> Type -> (CoercionN, a))-                           -> LiftingContext -> TyCoVar-                           -> (LiftingContext, TyCoVar, CoercionN, a)-liftCoSubstVarBndrUsing fun lc old_var+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 fun lc old_var+  = liftCoSubstTyVarBndrUsing view_co fun lc old_var   | otherwise-  = liftCoSubstCoVarBndrUsing fun lc old_var+  = liftCoSubstCoVarBndrUsing view_co fun lc old_var  -- Works for tyvar binder-liftCoSubstTyVarBndrUsing :: (LiftingContext -> Type -> (CoercionN, a))-                           -> LiftingContext -> TyVar-                           -> (LiftingContext, TyVar, CoercionN, a)-liftCoSubstTyVarBndrUsing fun lc@(LC subst cenv) old_var-  = ASSERT( isTyVar old_var )+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 `extendTCvInScope` new_var) new_cenv-    , new_var, eta, stuff )+    , new_var, stuff )   where-    old_kind     = tyVarKind old_var-    (eta, stuff) = fun lc old_kind-    k1           = coercionLKind eta-    new_var      = uniqAway (getTCvInScope subst) (setVarType old_var k1)+    old_kind = tyVarKind old_var+    stuff    = fun lc old_kind+    eta      = view_co stuff+    k1       = coercionLKind eta+    new_var  = uniqAway (getTCvInScope 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 :: (LiftingContext -> Type -> (CoercionN, a))-                           -> LiftingContext -> CoVar-                           -> (LiftingContext, CoVar, CoercionN, a)-liftCoSubstCoVarBndrUsing fun lc@(LC subst cenv) old_var-  = ASSERT( isCoVar old_var )+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 `extendTCvInScope` new_var) new_cenv-    , new_var, kind_co, stuff )+    , new_var, stuff )   where-    old_kind     = coVarKind old_var-    (eta, stuff) = fun lc old_kind-    k1           = coercionLKind eta-    new_var      = uniqAway (getTCvInScope subst) (setVarType old_var k1)+    old_kind = coVarKind old_var+    stuff    = fun lc old_kind+    eta      = view_co stuff+    k1       = coercionLKind eta+    new_var  = uniqAway (getTCvInScope subst) (setVarType old_var k1)      -- old_var :: s1  ~r s2     -- eta     :: (s1' ~r s2') ~N (t1 ~r t2)@@ -2203,7 +2223,6 @@     -- eta2    :: s2' ~r t2     -- co1     :: s1' ~r s2'     -- co2     :: t1  ~r t2-    -- kind_co :: (s1' ~r s2') ~N (t1 ~r t2)     -- lifted  :: co1 ~N co2      role   = coVarRole old_var@@ -2213,10 +2232,7 @@      co1     = mkCoVarCo new_var     co2     = mkSymCo eta1 `mkTransCo` co1 `mkTransCo` eta2-    kind_co = mkTyConAppCo Nominal (equalityTyCon role)-                           [ mkKindCo co1, mkKindCo co2-                           , co1         , co2          ]-    lifted  = mkProofIrrelCo Nominal kind_co co1 co2+    lifted  = mkProofIrrelCo Nominal eta co1 co2      new_cenv = extendVarEnv cenv old_var lifted @@ -2383,7 +2399,7 @@                    , cab_lhs = lhs } <- coAxiomNthBranch ax ind       , let (tys1, cotys1) = splitAtList tvs tys             cos1           = map stripCoercionTy cotys1-      = ASSERT( tys `equalLength` (tvs ++ cvs) )+      = assert (tys `equalLength` (tvs ++ cvs)) $                   -- Invariant of AxiomInstCo: cos should                   -- exactly saturate the axiom branch         substTyWith tvs tys1       $@@ -2399,7 +2415,7 @@ go_nth :: Int -> Type -> Type go_nth d ty   | Just args <- tyConAppArgs_maybe ty-  = ASSERT( args `lengthExceeds` d )+  = assert (args `lengthExceeds` d) $     args `getNth` d    | d == 0@@ -2445,7 +2461,7 @@                    , cab_rhs = rhs } <- coAxiomNthBranch ax ind       , let (tys2, cotys2) = splitAtList tvs tys             cos2           = map stripCoercionTy cotys2-      = ASSERT( tys `equalLength` (tvs ++ cvs) )+      = assert (tys `equalLength` (tvs ++ cvs)) $                   -- Invariant of AxiomInstCo: cos should                   -- exactly saturate the axiom branch         substTyWith tvs tys2 $@@ -2624,9 +2640,9 @@         in  mkCoherenceRightCo r ty2 co co'      go ty1@(TyVarTy tv1) _tyvarty-      = ASSERT( case _tyvarty of+      = assert (case _tyvarty of                   { TyVarTy tv2 -> tv1 == tv2-                  ; _           -> False      } )+                  ; _           -> False      }) $         mkNomReflCo ty1      go (FunTy { ft_mult = w1, ft_arg = arg1, ft_res = res1 })@@ -2634,7 +2650,7 @@       = mkFunCo Nominal (go w1 w2) (go arg1 arg2) (go res1 res2)      go (TyConApp tc1 args1) (TyConApp tc2 args2)-      = ASSERT( tc1 == tc2 )+      = assert (tc1 == tc2) $         mkTyConAppCo Nominal tc1 (zipWith go args1 args2)      go (AppTy ty1a ty1b) ty2@@ -2647,7 +2663,7 @@      go (ForAllTy (Bndr tv1 _flag1) ty1) (ForAllTy (Bndr tv2 _flag2) ty2)       | isTyVar tv1-      = ASSERT( isTyVar tv2 )+      = assert (isTyVar tv2) $         mkForAllCo tv1 kind_co (go ty1 ty2')       where kind_co  = go (tyVarKind tv1) (tyVarKind tv2)             in_scope = mkInScopeSet $ tyCoVarsOfType ty2 `unionVarSet` tyCoVarsOfCo kind_co@@ -2656,7 +2672,7 @@                          ty2      go (ForAllTy (Bndr cv1 _flag1) ty1) (ForAllTy (Bndr cv2 _flag2) ty2)-      = ASSERT( isCoVar cv1 && isCoVar cv2 )+      = assert (isCoVar cv1 && isCoVar cv2) $         mkForAllCo cv1 kind_co (go ty1 ty2')       where s1 = varType cv1             s2 = varType cv2@@ -2681,9 +2697,9 @@                             ty2      go ty1@(LitTy lit1) _lit2-      = ASSERT( case _lit2 of+      = assert (case _lit2 of                   { LitTy lit2 -> lit1 == lit2-                  ; _          -> False        } )+                  ; _          -> False        }) $         mkNomReflCo ty1      go (CoercionTy co1) (CoercionTy co2)@@ -2695,402 +2711,7 @@       = pprPanic "buildKindCoercion" (vcat [ ppr orig_ty1, ppr orig_ty2                                            , ppr ty1, ppr ty2 ]) -{--%************************************************************************-%*                                                                      *-       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 :: k--  [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--  (fa,                             co1 :: fa ~ a)-  (fb,                             co2 :: fb ~ b)-  (Just fa (fc |> aco) |> co6,     co3 :: (Just fa (fc |> aco) |> co6) ~ (Just a c))-  (Right fa fb (fd |> bco) |> co7, co4 :: (Right fa fb (fd |> bco) |> co7) ~ (Right a b d))-  (False,                          co5 :: False ~ False)--where-  co6 :: Maybe fa ~ Maybe a-  co7 :: 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-(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 (sym co1)), thus building-(f3 |> Maybe (sym 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 fa ~ Maybe a. Use (f3 |> sym co8) as the argument to-     F.--  4. Lifting the kind (Either j k) with our LC-     yields co9 :: Either fa fb ~ Either a b. Use (f4 |> sym 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 |> sym co8) (f4 > sym 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 returned as the third return value from 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-  type family Star-  Proxy :: forall j. j -> Type-  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:--    (forall j. j -> Type, co1 :: (forall j. j -> Type) ~-                                 (forall (j :: Star). (j |> axStar) -> Star))  -- 1-    (Proxy |> co,         co2 :: (Proxy |> co) ~ (Proxy |> co))                -- 2-    (Bool |> sym axStar,  co3 :: (Bool |> sym axStar) ~ (bo |> sym axStar))    -- 3-    (False |> sym bc,     co4 :: (False |> sym bc) ~ (NoWay |> 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 |> sym 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 *right-hand* 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 taking the right-hand types is correct-at its other call sites, which 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. j -> Type) (forall (j :: Star). (j |> axStar) -> Star))-                 [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.---}----- This is shared between the rewriter and the normaliser in GHC.Core.FamInstEnv.--- See Note [simplifyArgsWorker]-{-# INLINE simplifyArgsWorker #-}-simplifyArgsWorker :: [TyCoBinder] -> 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-                   -> [Role]   -- list of roles, r-                   -> [(Type, Coercion)] -- rewritten type arguments, arg-                                         -- each comes with the coercion used to rewrite it,-                                         -- with co :: rewritten_type ~ original_type-                   -> ([Type], [Coercion], MCoercionN)--- Returns (xis, cos, res_co), where each co :: xi ~ arg,--- and res_co :: kind (f xis) ~ kind (f tys), where f is the function applied to the args--- Precondition: if f :: forall bndrs. inner_ki (where bndrs and inner_ki are passed in),--- then (f orig_tys) is well kinded. Note that (f rewritten_tys) might *not* be well-kinded.--- Massaging the rewritten_tys in order to make (f rewritten_tys) well-kinded is what this--- function is all about. That is, (f xis), where xis 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 :: [Type]      -- Xis accumulator, in reverse order-       -> [Coercion]  -- Coercions accumulator, in reverse order-                      -- These are in 1-to-1 correspondence-       -> LiftingContext  -- mapping from tyvars to rewriting coercions-       -> [TyCoBinder]    -- Unsubsted binders of function's kind-       -> Kind        -- Unsubsted result kind of function (not a Pi-type)-       -> [Role]      -- Roles at which to rewrite these ...-       -> [(Type, Coercion)]  -- rewritten arguments, with their rewriting coercions-       -> ([Type], [Coercion], MCoercionN)-    go acc_xis acc_cos !lc binders inner_ki _ []-        -- The !lc makes the function strict in the lifting context-        -- which means GHC can unbox that pair.  A modest win.-      = (reverse acc_xis, reverse acc_cos, kind_co)-      where-        final_kind = mkPiTys binders inner_ki-        kind_co | noFreeVarsOfType final_kind = MRefl-                | otherwise                   = MCo $ liftCoSubst Nominal lc final_kind--    go acc_xis acc_cos lc (binder:binders) inner_ki (role:roles) ((xi,co):args)-      = -- By Note [Rewriting] in GHC.Tc.Solver.Rewrite invariant (F2),-         -- tcTypeKind(xi) = tcTypeKind(ty). But, it's possible that xi will be-         -- used as an argument to a function whose kind is different, if-         -- earlier arguments have been rewritten to new types. We thus-         -- need a coercion (kind_co :: old_kind ~ new_kind).-         ---         -- The bangs here have been observed to improve performance-         -- significantly in optimized builds; see #18502-         let !kind_co = mkSymCo $-                        liftCoSubst Nominal lc (tyCoBinderType binder)-             !casted_xi = xi `mkCastTy` kind_co-             casted_co =  mkCoherenceLeftCo role xi kind_co co--         -- now, extend the lifting context with the new binding-             !new_lc | Just tv <- tyCoBinderVar_maybe binder-                     = extendLiftingContextAndInScope lc tv casted_co-                     | otherwise-                     = lc-         in-         go (casted_xi : acc_xis)-            (casted_co : acc_cos)-            new_lc-            binders-            inner_ki-            roles-            args---      -- See Note [Last case in simplifyArgsWorker]-    go acc_xis acc_cos lc [] inner_ki roles args-      = let co1 = liftCoSubst Nominal lc inner_ki-            co1_kind              = coercionKind co1-            unrewritten_tys       = map (coercionRKind . snd) args-            (arg_cos, res_co)     = decomposePiCos co1 co1_kind unrewritten_tys-            casted_args           = ASSERT2( equalLength args arg_cos-                                           , ppr args $$ ppr arg_cos )-                                    [ (casted_xi, casted_co)-                                    | ((xi, co), arg_co, role) <- zip3 args arg_cos roles-                                    , let casted_xi = xi `mkCastTy` arg_co-                                          casted_co = mkCoherenceLeftCo role xi arg_co co ]-               -- 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--            (xis_out, cos_out, res_co_out)-              = go acc_xis acc_cos zapped_lc bndrs new_inner roles casted_args-        in-        (xis_out, cos_out, res_co_out `mkTransMCoL` res_co)--    go _ _ _ _ _ _ _ = panic-        "simplifyArgsWorker wandered into deeper water than usual"-           -- This debug information is commented out because leaving it in-           -- causes a ~2% increase in allocations in T9872d.-           -- That's independent of the analogous case in rewrite_args_fast-           -- in GHC.Tc.Solver.Rewrite:-           -- each of these causes a 2% increase on its own, so commenting them-           -- both out gives a 4% decrease in T9872d.-           {---             (vcat [ppr orig_binders,-                    ppr orig_inner_ki,-                    ppr (take 10 orig_roles), -- often infinite!-                    ppr orig_tys])-           -}- {- %************************************************************************ %*                                                                      *@@ -3104,16 +2725,13 @@ (has_co_hole_ty, _, has_co_hole_co, _)   = foldTyCo folder ()   where-    folder = TyCoFolder { tcf_view  = const Nothing+    folder = TyCoFolder { tcf_view  = noView                         , tcf_tyvar = const2 (Monoid.Any False)                         , tcf_covar = const2 (Monoid.Any False)                         , tcf_hole  = const2 (Monoid.Any True)                         , tcf_tycobinder = const2                         } -    const2 :: a -> b -> c -> a-    const2 x _ _ = x- -- | Is there a coercion hole in this type? hasCoercionHoleTy :: Type -> Bool hasCoercionHoleTy = Monoid.getAny . has_co_hole_ty@@ -3122,17 +2740,18 @@ hasCoercionHoleCo :: Coercion -> Bool hasCoercionHoleCo = Monoid.getAny . has_co_hole_co --- | A set of 'CoercionHole's-type HoleSet = UniqSet CoercionHole---- | Extract out all the coercion holes from a given type-coercionHolesOfType :: Type -> UniqSet CoercionHole-coercionHolesOfCo   :: Coercion -> UniqSet CoercionHole-(coercionHolesOfType, _, coercionHolesOfCo, _) = foldTyCo folder ()+hasThisCoercionHoleTy :: Type -> CoercionHole -> Bool+hasThisCoercionHoleTy ty hole = Monoid.getAny (f ty)   where-    folder = TyCoFolder { tcf_view  = const Nothing  -- don't look through synonyms-                        , tcf_tyvar = \ _ _ -> mempty-                        , tcf_covar = \ _ _ -> mempty-                        , tcf_hole  = const unitUniqSet-                        , tcf_tycobinder = \ _ _ _ -> ()+    (f, _, _, _) = foldTyCo folder ()++    folder = TyCoFolder { tcf_view  = noView+                        , tcf_tyvar = const2 (Monoid.Any False)+                        , tcf_covar = const2 (Monoid.Any False)+                        , tcf_hole  = \ _ h -> Monoid.Any (getUnique h == getUnique hole)+                        , tcf_tycobinder = const2                         }++-- | 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
@@ -51,3 +51,7 @@ coercionLKind :: Coercion -> Type coercionRKind :: 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
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP                 #-} {-# LANGUAGE DataKinds           #-} {-# LANGUAGE DeriveDataTypeable  #-} {-# LANGUAGE GADTs               #-}@@ -47,6 +46,7 @@ import GHC.Utils.Misc import GHC.Utils.Binary import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Data.Pair import GHC.Types.Basic import Data.Typeable ( Typeable )@@ -55,8 +55,6 @@ import Data.Array import Data.List ( mapAccumL ) -#include "HsVersions.h"- {- Note [Coercion axiom branches] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -143,7 +141,7 @@ type role Branches nominal  manyBranches :: [CoAxBranch] -> Branches Branched-manyBranches brs = ASSERT( snd bnds >= fst bnds )+manyBranches brs = assert (snd bnds >= fst bnds )                    MkBranches (listArray bnds brs)   where     bnds = (0, length brs - 1)@@ -155,7 +153,7 @@ toBranched = MkBranches . unMkBranches  toUnbranched :: Branches br -> Branches Unbranched-toUnbranched (MkBranches arr) = ASSERT( bounds arr == (0,0) )+toUnbranched (MkBranches arr) = assert (bounds arr == (0,0) )                                 MkBranches arr  fromBranches :: Branches br -> [CoAxBranch]@@ -325,7 +323,7 @@ coAxBranchIncomps :: CoAxBranch -> [CoAxBranch] coAxBranchIncomps = cab_incomps --- See Note [Compatibility checking] in GHC.Core.FamInstEnv+-- See Note [Compatibility] in GHC.Core.FamInstEnv placeHolderIncomps :: [CoAxBranch] placeHolderIncomps = panic "placeHolderIncomps" @@ -457,6 +455,7 @@   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. -}  instance Eq (CoAxiom br) where
GHC/Core/Coercion/Opt.hs view
@@ -9,30 +9,33 @@    ) where -#include "HsVersions.h"- import GHC.Prelude -import GHC.Driver.Ppr+import GHC.Tc.Utils.TcType   ( exactTyCoVarsOfType )  import GHC.Core.TyCo.Rep import GHC.Core.TyCo.Subst import GHC.Core.Coercion import GHC.Core.Type as Type hiding( substTyVarBndr, substTy )-import GHC.Tc.Utils.TcType   ( exactTyCoVarsOfType ) import GHC.Core.TyCon import GHC.Core.Coercion.Axiom+import GHC.Core.Unify+ import GHC.Types.Var.Set import GHC.Types.Var.Env+ import GHC.Data.Pair import GHC.Data.List.SetOps ( getNth )-import GHC.Core.Unify-import Control.Monad   ( zipWithM )  import GHC.Utils.Outputable+import GHC.Utils.Constants (debugIsOn) import GHC.Utils.Misc import GHC.Utils.Panic+import GHC.Utils.Panic.Plain+import GHC.Utils.Trace +import Control.Monad   ( zipWithM )+ {- %************************************************************************ %*                                                                      *@@ -130,23 +133,24 @@         (Pair in_ty1  in_ty2,  in_role)  = coercionKindRole co         (Pair out_ty1 out_ty2, out_role) = coercionKindRole out_co     in-    ASSERT2( substTyUnchecked env in_ty1 `eqType` out_ty1 &&-             substTyUnchecked env in_ty2 `eqType` out_ty2 &&-             in_role == out_role-           , text "optCoercion changed types!"-             $$ hang (text "in_co:") 2 (ppr co)-             $$ hang (text "in_ty1:") 2 (ppr in_ty1)-             $$ hang (text "in_ty2:") 2 (ppr in_ty2)-             $$ hang (text "out_co:") 2 (ppr out_co)-             $$ hang (text "out_ty1:") 2 (ppr out_ty1)-             $$ hang (text "out_ty2:") 2 (ppr out_ty2)-             $$ hang (text "subst:") 2 (ppr env) )-    out_co+    assertPpr (substTyUnchecked env in_ty1 `eqType` out_ty1 &&+               substTyUnchecked env in_ty2 `eqType` out_ty2 &&+               in_role == out_role)+              ( text "optCoercion changed types!"+                 $$ hang (text "in_co:") 2 (ppr co)+                 $$ hang (text "in_ty1:") 2 (ppr in_ty1)+                 $$ hang (text "in_ty2:") 2 (ppr in_ty2)+                 $$ hang (text "out_co:") 2 (ppr out_co)+                 $$ hang (text "out_ty1:") 2 (ppr out_ty1)+                 $$ hang (text "out_ty2:") 2 (ppr out_ty2)+                 $$ hang (text "subst:") 2 (ppr env))+              out_co    | otherwise         = opt_co1 lc False co   where     lc = mkSubstLiftingContext env + type NormalCo    = Coercion   -- Invariants:   --  * The substitution has been fully applied@@ -197,28 +201,31 @@            , text "Rep:" <+> ppr rep            , text "Role:" <+> ppr r            , text "Co:" <+> ppr co ]) $-    ASSERT( r == coercionRole co )+    assert (r == coercionRole co )     let result = opt_co4 env sym rep r co in     pprTrace "opt_co4_wrap }" (ppr co $$ text "---" $$ ppr result) $     result -}  opt_co4 env _   rep r (Refl ty)-  = ASSERT2( r == Nominal, text "Expected role:" <+> ppr r    $$-                           text "Found role:" <+> ppr Nominal $$-                           text "Type:" <+> ppr ty )+  = assertPpr (r == Nominal)+              (text "Expected role:" <+> ppr r    $$+               text "Found role:" <+> ppr Nominal $$+               text "Type:" <+> ppr ty) $     liftCoSubst (chooseRole rep r) env ty  opt_co4 env _   rep r (GRefl _r ty MRefl)-  = ASSERT2( r == _r, text "Expected role:" <+> ppr r $$-                      text "Found role:" <+> ppr _r   $$-                      text "Type:" <+> ppr ty )+  = assertPpr (r == _r)+              (text "Expected role:" <+> ppr r $$+               text "Found role:" <+> ppr _r   $$+               text "Type:" <+> ppr ty) $     liftCoSubst (chooseRole rep r) env ty  opt_co4 env sym  rep r (GRefl _r ty (MCo co))-  = ASSERT2( r == _r, text "Expected role:" <+> ppr r $$-                      text "Found role:" <+> ppr _r   $$-                      text "Type:" <+> ppr ty )+  = assertPpr (r == _r)+              (text "Expected role:" <+> ppr r $$+               text "Found role:" <+> ppr _r   $$+               text "Type:" <+> ppr ty) $     if isGReflCo co || isGReflCo co'     then liftCoSubst r' env ty     else wrapSym sym $ mkCoherenceRightCo r' ty' co' (liftCoSubst r' env ty)@@ -234,7 +241,7 @@   -- exchange them.  opt_co4 env sym rep r g@(TyConAppCo _r tc cos)-  = ASSERT( r == _r )+  = assert (r == _r) $     case (rep, r) of       (True, Nominal) ->         mkTyConAppCo Representational tc@@ -263,7 +270,7 @@      -- Use the "mk" functions to check for nested Refls  opt_co4 env sym rep r (FunCo _r cow co1 co2)-  = ASSERT( r == _r )+  = assert (r == _r) $     if rep     then mkFunCo Representational cow' co1' co2'     else mkFunCo r cow' co1' co2'@@ -280,7 +287,7 @@   = mkReflCo (chooseRole rep r) ty1    | otherwise-  = ASSERT( isCoVar cv1 )+  = assert (isCoVar cv1 )     wrapRole rep r $ wrapSym sym $     CoVarCo cv1 @@ -289,9 +296,10 @@      cv1 = case lookupInScope (lcInScopeSet env) cv of              Just cv1 -> cv1-             Nothing  -> WARN( True, text "opt_co: not in scope:"-                                     <+> ppr cv $$ ppr env)-                         cv+             Nothing  -> warnPprTrace True+                          "opt_co: not in scope"+                          (ppr cv $$ ppr env)+                          cv           -- cv1 might have a substituted kind!  opt_co4 _ _ _ _ (HoleCo h)@@ -302,7 +310,7 @@     -- e.g. if g is a top-level axiom     --   g a : f a ~ a     -- then (sym (g ty)) /= g (sym ty) !!-  = ASSERT( r == coAxiomRole con )+  = assert (r == coAxiomRole con )     wrapRole rep (coAxiomRole con) $     wrapSym sym $                        -- some sub-cos might be P: use opt_co2@@ -313,7 +321,7 @@       -- Note that the_co does *not* have sym pushed into it  opt_co4 env sym rep r (UnivCo prov _r t1 t2)-  = ASSERT( r == _r )+  = assert (r == _r )     opt_univ env sym prov (chooseRole rep r) t1 t2  opt_co4 env sym rep r (TransCo co1 co2)@@ -327,7 +335,7 @@  opt_co4 env _sym rep r (NthCo _r n co)   | Just (ty, _) <- isReflCo_maybe co-  , Just (_tc, args) <- ASSERT( r == _r )+  , Just (_tc, args) <- assert (r == _r )                         splitTyConApp_maybe ty   = liftCoSubst (chooseRole rep r) env (args `getNth` n) @@ -338,18 +346,18 @@   = liftCoSubst (chooseRole rep r) env (varType tv)  opt_co4 env sym rep r (NthCo r1 n (TyConAppCo _ _ cos))-  = ASSERT( r == r1 )+  = assert (r == r1 )     opt_co4_wrap env sym rep r (cos `getNth` n)  -- see the definition of GHC.Builtin.Types.Prim.funTyCon opt_co4 env sym rep r (NthCo r1 n (FunCo _r2 w co1 co2))-  = ASSERT( r == r1 )+  = assert (r == r1 )     opt_co4_wrap env sym rep r (mkNthCoFunCo n w co1 co2)  opt_co4 env sym rep r (NthCo _r n (ForAllCo _ eta _))       -- works for both tyvar and covar-  = ASSERT( r == _r )-    ASSERT( n == 0 )+  = assert (r == _r )+    assert (n == 0 )     opt_co4_wrap env sym rep Nominal eta  opt_co4 env sym rep r (NthCo _r n co)@@ -370,10 +378,10 @@  opt_co4 env sym rep r (LRCo lr co)   | Just pr_co <- splitAppCo_maybe co-  = ASSERT( r == Nominal )+  = assert (r == Nominal )     opt_co4_wrap env sym rep Nominal (pick_lr lr pr_co)   | Just pr_co <- splitAppCo_maybe co'-  = ASSERT( r == Nominal )+  = assert (r == Nominal) $     if rep     then opt_co4_wrap (zapLiftingContext env) False True Nominal (pick_lr lr pr_co)     else pick_lr lr pr_co@@ -453,7 +461,7 @@                            (n1 `mkTransCo` h2 `mkTransCo` (mkSymCo n2))  opt_co4 env sym _rep r (KindCo co)-  = ASSERT( r == Nominal )+  = assert (r == Nominal) $     let kco' = promoteCoercion co in     case kco' of       KindCo co' -> promoteCoercion (opt_co1 env sym co')@@ -462,12 +470,12 @@   -- and substitution/optimization at the same time  opt_co4 env sym _ r (SubCo co)-  = ASSERT( r == Representational )+  = assert (r == Representational) $     opt_co4_wrap env sym True Nominal co  -- This could perhaps be optimized more. opt_co4 env sym rep r (AxiomRuleCo co cs)-  = ASSERT( r == coaxrRole co )+  = assert (r == coaxrRole co) $     wrapRole rep r $     wrapSym sym $     AxiomRuleCo co (zipWith (opt_co2 env False) (coaxrAsmpRoles co) cs)@@ -502,6 +510,23 @@   Any (*->*) Maybe Int  :: *  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 -> SymFlag -> UnivCoProvenance -> Role@@ -518,6 +543,7 @@   | 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@@ -620,7 +646,7 @@ opt_trans_rule :: InScopeSet -> NormalNonIdCo -> NormalNonIdCo -> Maybe NormalCo  opt_trans_rule is in_co1@(GRefl r1 t1 (MCo co1)) in_co2@(GRefl r2 _ (MCo co2))-  = ASSERT( r1 == r2 )+  = assert (r1 == r2) $     fireTransRule "GRefl" in_co1 in_co2 $     mkGReflRightCo r1 t1 (opt_trans is co1 co2) @@ -629,7 +655,7 @@   | d1 == d2   , coercionRole co1 == coercionRole co2   , co1 `compatible_co` co2-  = ASSERT( r1 == r2 )+  = assert (r1 == r2) $     fireTransRule "PushNth" in_co1 in_co2 $     mkNthCo r1 d1 (opt_trans is co1 co2) @@ -649,7 +675,7 @@ opt_trans_rule is in_co1@(UnivCo p1 r1 tyl1 _tyr1)                   in_co2@(UnivCo p2 r2 _tyl2 tyr2)   | Just prov' <- opt_trans_prov p1 p2-  = ASSERT( r1 == r2 )+  = assert (r1 == r2) $     fireTransRule "UnivCo" in_co1 in_co2 $     mkUnivCo prov' r1 tyl1 tyr2   where@@ -664,12 +690,12 @@ -- 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 )+  = 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 w1 co1a co1b) in_co2@(FunCo r2 w2 co2a co2b)-  = ASSERT( r1 == r2)   -- Just like the TyConAppCo/TyConAppCo case+  = assert (r1 == r2) $   -- Just like the TyConAppCo/TyConAppCo case     fireTransRule "PushFun" in_co1 in_co2 $     mkFunCo r1 (opt_trans is w1 w2) (opt_trans is co1a co2a) (opt_trans is co1b co2b) @@ -840,7 +866,7 @@   = opt_trans_rule_app is orig_co1 orig_co2 co1aa (co1ab:co1bs) co2aa (co2ab:co2bs)    | otherwise-  = ASSERT( co1bs `equalLength` co2bs )+  = assert (co1bs `equalLength` co2bs) $     fireTransRule ("EtaApps:" ++ show (length co1bs)) orig_co1 orig_co2 $     let rt1a = coercionRKind co1a @@ -1173,7 +1199,7 @@ --       g :: T s1 .. sn ~ T t1 .. tn -- into [ Nth 0 g :: s1~t1, ..., Nth (n-1) g :: sn~tn ] etaTyConAppCo_maybe tc (TyConAppCo _ tc2 cos2)-  = ASSERT( tc == tc2 ) Just cos2+  = assert (tc == tc2) $ Just cos2  etaTyConAppCo_maybe tc co   | not (mustBeSaturated tc)@@ -1186,7 +1212,7 @@   , tys2 `lengthIs` n      -- This can fail in an erroneous program                            -- E.g. T a ~# T a b                            -- #14607-  = ASSERT( tc == tc1 )+  = assert (tc == tc1) $     Just (decomposeCo n co (tyConRolesX r tc1))     -- NB: n might be <> tyConArity tc     -- e.g.   data family T a :: * -> *
GHC/Core/ConLike.hs view
@@ -5,8 +5,8 @@ \section[ConLike]{@ConLike@: Constructor-like things} -} -{-# LANGUAGE CPP #-} + module GHC.Core.ConLike (           ConLike(..)         , isVanillaConLike@@ -26,8 +26,6 @@         , conLikeHasBuilder     ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Core.DataCon@@ -148,6 +146,7 @@ -- -- > 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 {})         = []
GHC/Core/DataCon.hs view
@@ -5,7 +5,7 @@ \section[DataCon]{@DataCon@: Data Constructors} -} -{-# LANGUAGE CPP, DeriveDataTypeable #-}+{-# LANGUAGE DeriveDataTypeable #-}  module GHC.Core.DataCon (         -- * Main data types@@ -14,6 +14,7 @@         HsSrcBang(..), HsImplBang(..),         StrictnessMark(..),         ConTag,+        DataConEnv,          -- ** Equality specs         EqSpec, mkEqSpec, eqSpecTyVar, eqSpecType,@@ -40,6 +41,7 @@         dataConOtherTheta,         dataConInstArgTys, dataConOrigArgTys, dataConOrigResTy,         dataConInstOrigArgTys, dataConRepArgTys,+        dataConInstUnivs,         dataConFieldLabels, dataConFieldType, dataConFieldType_maybe,         dataConSrcBangs,         dataConSourceArity, dataConRepArity,@@ -56,15 +58,13 @@         isUnboxedSumDataCon,         isVanillaDataCon, isNewDataCon, classDataCon, dataConCannotMatch,         dataConUserTyVarsArePermuted,-        isBanged, isMarkedStrict, eqHsBang, isSrcStrict, isSrcUnpacked,+        isBanged, isMarkedStrict, cbvFromStrictMark, eqHsBang, isSrcStrict, isSrcUnpacked,         specialPromotedDc,          -- ** Promotion related functions         promoteDataCon     ) where -#include "HsVersions.h"- import GHC.Prelude  import {-# SOURCE #-} GHC.Types.Id.Make ( DataConBoxer )@@ -72,6 +72,7 @@ import GHC.Core.Coercion import GHC.Core.Unify import GHC.Core.TyCon+import GHC.Core.TyCo.Subst import GHC.Core.Multiplicity import {-# SOURCE #-} GHC.Types.TyThing import GHC.Types.FieldLabel@@ -81,17 +82,21 @@ 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.Unit.Module.Name import GHC.Utils.Binary+import GHC.Types.Unique.FM ( UniqFM ) import GHC.Types.Unique.Set import GHC.Builtin.Uniques( mkAlphaTyVarUnique ) + import GHC.Utils.Outputable import GHC.Utils.Misc import GHC.Utils.Panic+import GHC.Utils.Panic.Plain  import Data.ByteString (ByteString) import qualified Data.ByteString.Builder as BSB@@ -196,6 +201,9 @@ * INVARIANT: the dictionary constructor for a class              never has a wrapper. +* See Note [Data Constructor Naming] for how the worker and wrapper+  are named+ * Neither_ the worker _nor_ the wrapper take the dcStupidTheta dicts as arguments  * The wrapper (if it exists) takes dcOrigArgTys as its arguments.@@ -249,12 +257,21 @@          data (Eq a, Ord b) => T a b = T1 a b | T2 a -and that makes the constructors have a context too-(notice that T2's context is "thinned"):+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):@@ -265,37 +282,50 @@  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] in GHC.Tc.Gen.Head.) It's a flaw in the language. -        Up to now [March 2002] I have put this stupid context into the-        type of the "wrapper" constructors functions, T1 and T2, but-        that turned out to be jolly inconvenient for generics, and-        record update, and other functions that build values of type T-        (because they don't have suitable dictionaries available).+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. -        So now I've taken the stupid context out.  I simply deal with-        it separately in the type checker on occurrences of a-        constructor, either in an expression or in a pattern.+Some other notes about stupid contexts: -        [May 2003: actually I think this decision could easily be-        reversed now, and probably should be.  Generics could be-        disabled for types with a stupid context; record updates now-        (H98) needs the context too; etc.  It's an unforced change, so-        I'm leaving it for now --- but it does seem odd that the-        wrapper doesn't include the stupid context.]+* Stupid contexts can interact badly with `deriving`. For instance, it's+  unclear how to make this derived Functor instance typecheck: -[July 04] With the advent of generalised data types, it's less obvious-what the "stupid context" is.  Consider-        C :: forall a. Ord a => a -> a -> T (Foo a)-Does the C constructor in Core contain the Ord dictionary?  Yes, it must:+    data Eq a => T a = MkT a+      deriving Functor -        f :: T b -> Ordering-        f = /\b. \x:T b.-            case x of-                C a (d:Ord a) (p:a) (q:a) -> compare d p q+  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.) -Note that (Foo a) might not be an instance of Ord.+  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.+ ************************************************************************ *                                                                      * \subsection{Data constructors}@@ -308,7 +338,7 @@ -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen', --             'GHC.Parser.Annotation.AnnClose','GHC.Parser.Annotation.AnnComma' --- For details on above see note [exact print annotations] in GHC.Parser.Annotation+-- For details on above see Note [exact print annotations] in GHC.Parser.Annotation data DataCon   = MkData {         dcName    :: Name,      -- This is the name of the *source data con*@@ -412,7 +442,8 @@                                         -- 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+                -- 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@@ -664,6 +695,8 @@      } +type DataConEnv a = UniqFM DataCon a     -- Keyed by DataCon+ -------------------------  -- | Haskell Source Bang@@ -712,9 +745,10 @@   ---------------------------- StrictnessMark is internal only, used to indicate strictness+-- 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@@ -822,16 +856,42 @@          b) the constructor may store an unboxed version of a strict field. -Here's an example illustrating both:-        data Ord a => T a = MkT Int! a+So whenever this module talks about the representation of a data constructor+what it means is the DataCon with all Unpacking having been applied.+We can think of this as the Core representation.++Here's an example illustrating the Core representation:+        data Ord a => T a = MkT Int! a Void# Here-        T :: Ord a => Int -> a -> T a+        T :: Ord a => Int -> a -> Void# -> T a but the rep type is-        Trep :: Int# -> a -> T a+        Trep :: Int# -> a -> Void# -> T a Actually, the unboxed part isn't implemented yet! +Not that this representation is still *different* from runtime+representation. (Which is what STG uses afer unarise). +This is how T would end up being used in STG post-unarise: +  let x = T 1# y+  in ...+      case x of+        T int a -> ...++The Void# argument is dropped and the boxed int is replaced by an unboxed+one. In essence we only generate binders for runtime relevant values.++We also flatten out unboxed tuples in this process. See the unarise+pass for details on how this is done. But as an example consider+`data S = MkS Bool (# Bool | Char #)` which when matched on would+result in an alternative with three binders like this++    MkS bool tag tpl_field ->++See Note [Translating unboxed sums to unboxed tuples] and Note [Unarisation]+for the details of this transformation.++ ************************************************************************ *                                                                      * \subsection{Instances}@@ -885,6 +945,16 @@     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@@ -935,6 +1005,11 @@ isMarkedStrict NotMarkedStrict = False isMarkedStrict _               = True   -- All others are strict +cbvFromStrictMark :: StrictnessMark -> CbvMark+cbvFromStrictMark NotMarkedStrict = NotMarkedCbv+cbvFromStrictMark MarkedStrict = MarkedCbv++ {- ********************************************************************* *                                                                      * \subsection{Construction}@@ -1318,6 +1393,8 @@ -- | 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 @@ -1329,7 +1406,7 @@ or MkT :: a  -> T a (with -XNoLinearTypes) -There are two different methods to retrieve a type of a datacon.+There are three different methods to retrieve a type of a datacon. They differ in how linear fields are handled.  1. dataConWrapperType:@@ -1341,7 +1418,7 @@ Used when we don't want to introduce linear types to user (in holes and in types in hie used by haddock). -3. dataConDisplayType (take a boolean indicating if -XLinearTypes is enabled):+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@@ -1406,9 +1483,9 @@                   -> [Scaled Type] dataConInstArgTys dc@(MkData {dcUnivTyVars = univ_tvs,                               dcExTyCoVars = ex_tvs}) inst_tys- = ASSERT2( univ_tvs `equalLength` inst_tys-          , text "dataConInstArgTys" <+> ppr dc $$ ppr univ_tvs $$ ppr inst_tys)-   ASSERT2( null ex_tvs, ppr dc )+ = 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',@@ -1424,13 +1501,66 @@ dataConInstOrigArgTys dc@(MkData {dcOrigArgTys = arg_tys,                                   dcUnivTyVars = univ_tvs,                                   dcExTyCoVars = ex_tvs}) inst_tys-  = ASSERT2( tyvars `equalLength` inst_tys-           , text "dataConInstOrigArgTys" <+> ppr dc $$ ppr tyvars $$ ppr 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)) $+                          splitAt (length 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]@@ -1449,7 +1579,7 @@                          , dcOtherTheta = theta                          , dcOrigArgTys = orig_arg_tys })   = case rep of-      NoDataConRep -> ASSERT( null eq_spec ) (map unrestricted theta) ++ orig_arg_tys+      NoDataConRep -> assert (null eq_spec) $ (map unrestricted theta) ++ orig_arg_tys       DCR { dcr_arg_tys = arg_tys } -> arg_tys  -- | The string @package:module.name@ identifying a constructor, which is attached@@ -1467,7 +1597,7 @@        occNameFS $ nameOccName name    ]   where name = dataConName dc-        mod  = ASSERT( isExternalName name ) nameModule name+        mod  = assert (isExternalName name) $ nameModule name  isTupleDataCon :: DataCon -> Bool isTupleDataCon (MkData {dcRepTyCon = tc}) = isTupleTyCon tc@@ -1496,7 +1626,7 @@  classDataCon :: Class -> DataCon classDataCon clas = case tyConDataCons (classTyCon clas) of-                      (dict_constr:no_more) -> ASSERT( null no_more ) dict_constr+                      (dict_constr:no_more) -> assert (null no_more) dict_constr                       [] -> panic "classDataCon"  dataConCannotMatch :: [Type] -> DataCon -> Bool
GHC/Core/FVs.hs view
@@ -5,7 +5,6 @@ Taken quite directly from the Peyton Jones/Lester paper. -} -{-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-}  -- | A module concerned with finding the free variables of an expression.@@ -56,8 +55,6 @@         freeVarsOfAnn     ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Core@@ -80,7 +77,7 @@  import GHC.Utils.FV as FV import GHC.Utils.Misc-import GHC.Utils.Panic+import GHC.Utils.Panic.Plain  {- ************************************************************************@@ -635,14 +632,14 @@                  Nothing   -> emptyFV  idFreeVars :: Id -> VarSet-idFreeVars id = ASSERT( isId id) fvVarSet $ idFVs id+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)+idFVs id = assert (isId id) $            varTypeTyCoFVs id `unionFV`            bndrRuleAndUnfoldingFVs id @@ -661,7 +658,7 @@ idRuleVars id = fvVarSet $ idRuleFVs id  idRuleFVs :: Id -> FV-idRuleFVs id = ASSERT( isId id)+idRuleFVs id = assert (isId id) $   FV.mkFVs (dVarSetElems $ ruleInfoFreeVars (idSpecialisation id))  idUnfoldingVars :: Id -> VarSet
GHC/Core/FamInstEnv.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP                 #-} {-# LANGUAGE DeriveFunctor       #-} {-# LANGUAGE GADTs               #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -16,8 +15,8 @@         mkImportedFamInst,          FamInstEnvs, FamInstEnv, emptyFamInstEnv, emptyFamInstEnvs,-        extendFamInstEnv, extendFamInstEnvList,-        famInstEnvElts, famInstEnvSize, familyInstances,+        unionFamInstEnv, extendFamInstEnv, extendFamInstEnvList,+        famInstEnvElts, famInstEnvSize, familyInstances, familyNameInstances,          -- * CoAxioms         mkCoAxBranch, mkBranchedCoAxiom, mkUnbranchedCoAxiom, mkSingleCoAxiom,@@ -38,8 +37,6 @@         topReduceTyFamApp_maybe, reduceTyFamApp_maybe     ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Core.Unify@@ -48,10 +45,11 @@ import GHC.Core.TyCon import GHC.Core.Coercion import GHC.Core.Coercion.Axiom+import GHC.Core.Reduction+import GHC.Core.RoughMap import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Types.Name-import GHC.Types.Unique.DFM import GHC.Data.Maybe import GHC.Types.Var import GHC.Types.SrcLoc@@ -62,6 +60,8 @@ import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain+import GHC.Data.Bag  {- ************************************************************************@@ -303,8 +303,18 @@  Note [FamInstEnv] ~~~~~~~~~~~~~~~~~-A FamInstEnv maps a family name to the list of known instances for that family.+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@@ -351,30 +361,24 @@ See Note [Deterministic UniqFM]. -} --- Internally we sometimes index by Name instead of TyCon despite--- of what the type says. This is safe since--- getUnique (tyCon) == getUniqe (tcName tyCon)-type FamInstEnv = UniqDFM TyCon FamilyInstEnv  -- Maps a family to its instances-     -- See Note [FamInstEnv]-     -- See Note [FamInstEnv determinism]- type FamInstEnvs = (FamInstEnv, FamInstEnv)      -- External package inst-env, Home-package inst-env -newtype FamilyInstEnv-  = FamIE [FamInst]     -- The instances for a particular family, in any order+data FamInstEnv+  = FamIE !Int -- The number of instances, used to choose the smaller environment+               -- when checking type family consistnecy of home modules.+          !(RoughMap FamInst)+     -- See Note [FamInstEnv]+     -- See Note [FamInstEnv determinism] -instance Outputable FamilyInstEnv where-  ppr (FamIE fs) = text "FamIE" <+> vcat (map ppr fs) --- | Index a FamInstEnv by the tyCons name.-toNameInstEnv :: FamInstEnv -> UniqDFM Name FamilyInstEnv-toNameInstEnv = unsafeCastUDFMKey+instance Outputable FamInstEnv where+  ppr (FamIE _ fs) = text "FamIE" <+> vcat (map ppr $ elemsRM fs) --- | Create a FamInstEnv from Name indices.-fromNameInstEnv :: UniqDFM Name FamilyInstEnv -> FamInstEnv-fromNameInstEnv = unsafeCastUDFMKey+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)@@ -383,34 +387,40 @@ emptyFamInstEnvs = (emptyFamInstEnv, emptyFamInstEnv)  emptyFamInstEnv :: FamInstEnv-emptyFamInstEnv = emptyUDFM+emptyFamInstEnv = FamIE 0 emptyRM  famInstEnvElts :: FamInstEnv -> [FamInst]-famInstEnvElts fi = [elt | FamIE elts <- eltsUDFM fi, elt <- elts]+famInstEnvElts (FamIE _ rm) = elemsRM rm   -- See Note [FamInstEnv determinism] -famInstEnvSize :: FamInstEnv -> Int-famInstEnvSize = nonDetStrictFoldUDFM (\(FamIE elt) sum -> sum + length elt) 0   -- It's OK to use nonDetStrictFoldUDFM here since we're just computing the   -- size.  familyInstances :: (FamInstEnv, FamInstEnv) -> TyCon -> [FamInst]-familyInstances (pkg_fie, home_fie) fam+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 env = case lookupUDFM env fam of-                Just (FamIE insts) -> insts-                Nothing                      -> []+    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 inst_env+extendFamInstEnv (FamIE s inst_env)                  ins_item@(FamInst {fi_fam = cls_nm})-  = fromNameInstEnv $ addToUDFM_C add (toNameInstEnv inst_env) cls_nm (FamIE [ins_item])+  = FamIE (s+1) $ insertRM rough_tmpl ins_item inst_env   where-    add (FamIE items) _ = FamIE (ins_item:items)+    rough_tmpl = RM_KnownTc cls_nm : fi_tcs ins_item  {- ************************************************************************@@ -775,9 +785,7 @@ lookupFamInstEnvByTyCon (pkg_ie, home_ie) fam_tc   = get pkg_ie ++ get home_ie   where-    get ie = case lookupUDFM ie fam_tc of-               Nothing          -> []-               Just (FamIE fis) -> fis+    get (FamIE _ rm) = lookupRM [RML_KnownTc (tyConName fam_tc)] rm  lookupFamInstEnv     :: FamInstEnvs@@ -786,14 +794,12 @@ -- Precondition: the tycon is saturated (or over-saturated)  lookupFamInstEnv-   = lookup_fam_inst_env match-   where-     match _ _ tpl_tys tys = tcMatchTys tpl_tys tys+   = lookup_fam_inst_env WantMatches  lookupFamInstEnvConflicts     :: FamInstEnvs     -> FamInst          -- Putative new instance-    -> [FamInstMatch]   -- Conflicting matches (don't look at the fim_tys field)+    -> [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])@@ -801,33 +807,17 @@ -- -- Precondition: the tycon is saturated (or over-saturated) -lookupFamInstEnvConflicts envs fam_inst@(FamInst { fi_axiom = new_axiom })-  = lookup_fam_inst_env my_unify envs fam tys+lookupFamInstEnvConflicts envs fam_inst+  = lookup_fam_inst_env (WantConflicts fam_inst) envs fam tys   where     (fam, tys) = famInstSplitLHS fam_inst-        -- In example above,   fam tys' = F [b] -    my_unify (FamInst { fi_axiom = old_axiom }) tpl_tvs tpl_tys _-       = ASSERT2( tyCoVarsOfTypes tys `disjointVarSet` 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 noSubst-      -- Note [Family instance overlap conflicts]--    noSubst = panic "lookupFamInstEnvConflicts noSubst"-    new_branch = coAxiomSingleBranch new_axiom- -------------------------------------------------------------------------------- --                 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@@ -929,11 +919,17 @@     ->  FamInstEnvs   -- all type instances seens so far     ->  FamInst       -- new type instance that we're checking     -> [CoAxBranch]   -- conflicting instance declarations-lookupFamInstEnvInjectivityConflicts injList (pkg_ie, home_ie)+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.-  = lookup_inj_fam_conflicts home_ie ++ lookup_inj_fam_conflicts pkg_ie+  = map (coAxiomSingleBranch . fi_axiom) $+    filter isInjConflict $+    familyInstances fam_inst_envs fam     where       fam        = famInstTyCon fam_inst       new_branch = coAxiomSingleBranch new_axiom@@ -946,13 +942,7 @@           = False -- no conflict           | otherwise = True -      lookup_inj_fam_conflicts ie-          | isOpenFamilyTyCon fam, Just (FamIE insts) <- lookupUDFM ie fam-          = map (coAxiomSingleBranch . fi_axiom) $-            filter isInjConflict insts-          | otherwise = [] - -------------------------------------------------------------------------------- --                    Type family overlap checking bits                       -- --------------------------------------------------------------------------------@@ -975,47 +965,62 @@  ------------------------------------------------------------ -- Might be a one-way match or a unifier-type MatchFun =  FamInst                -- The FamInst template-              -> TyVarSet -> [Type]     --   fi_tvs, fi_tys of that FamInst-              -> [Type]                 -- Target to match against-              -> Maybe TCvSubst+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-    :: MatchFun+    :: forall a . FamInstLookupMode a     -> FamInstEnv     -> TyCon -> [Type]        -- What we are looking for-    -> [FamInstMatch]-lookup_fam_inst_env' match_fun ie fam match_tys+    -> [a]+lookup_fam_inst_env' lookup_mode (FamIE _ ie) fam match_tys   | isOpenFamilyTyCon fam-  , Just (FamIE insts) <- lookupUDFM ie fam-  = find insts    -- The common case+  , 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 -    find [] = []-    find (item@(FamInst { fi_tcs = mb_tcs, fi_tvs = tpl_tvs, fi_cvs = tpl_cvs-                        , fi_tys = tpl_tys }) : rest)-        -- Fast check for no match, uses the "rough match" fields-      | instanceCantMatch rough_tcs mb_tcs-      = find rest+    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) -        -- Proper check-      | Just subst <- match_fun item (mkVarSet tpl_tvs) tpl_tys match_tys1-      = (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-                      })-        : find rest+    -- Function used for finding unifiers+    unify_fun orig_fam_inst item@(FamInst { fi_axiom = old_axiom, fi_tys = tpl_tys, fi_tvs = tpl_tvs }) -        -- No match => try next-      | otherwise-      = find rest+       = 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-        (rough_tcs, match_tys1, match_tys2) = split_tys tpl_tys+        new_branch = coAxiomSingleBranch (famInstAxiom orig_fam_inst)+        (fam, tys) = famInstSplitLHS orig_fam_inst -      -- Precondition: the tycon is saturated (or over-saturated)+    -- 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@@ -1024,18 +1029,17 @@        | otherwise       = let (match_tys1, match_tys2) = splitAtList tpl_tys match_tys-            rough_tcs = roughMatchTcs match_tys1-        in (rough_tcs, match_tys1, match_tys2)+        in (match_tys1, match_tys2)      (pre_match_tys1, pre_match_tys2) = splitAt (tyConArity fam) match_tys     pre_rough_split_tys-      = (roughMatchTcs pre_match_tys1, pre_match_tys1, pre_match_tys2)+      = (pre_match_tys1, pre_match_tys2)  lookup_fam_inst_env           -- The worker, local to this module-    :: MatchFun+    :: FamInstLookupMode a     -> FamInstEnvs     -> TyCon -> [Type]        -- What we are looking for-    -> [FamInstMatch]         -- Successful matches+    -> [a]         -- Successful matches  -- Precondition: the tycon is saturated (or over-saturated) @@ -1101,7 +1105,7 @@ reduceTyFamApp_maybe :: FamInstEnvs                      -> Role              -- Desired role of result coercion                      -> TyCon -> [Type]-                     -> Maybe (Coercion, 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@@ -1132,20 +1136,18 @@       -- NB: Allow multiple matches because of compatible overlap    = let co = mkUnbranchedAxInstCo role ax inst_tys inst_cos-        ty = coercionRKind co-    in Just (co, ty)+    in Just $ coercionRedn co    | Just ax <- isClosedSynFamilyTyConWithAxiom_maybe tc   , Just (ind, inst_tys, inst_cos) <- chooseBranch ax tys   = let co = mkAxInstCo role ax ind inst_tys inst_cos-        ty = coercionRKind co-    in Just (co, ty)+    in Just $ coercionRedn co    | Just ax           <- isBuiltInSynFamTyCon_maybe tc   , Just (coax,ts,ty) <- sfMatchFam ax tys   , role == coaxrRole coax   = let co = mkAxiomRuleCo coax (zipWith mkReflCo (coaxrAsmpRoles coax) ts)-    in Just (co, ty)+    in Just $ mkReduction co ty    | otherwise   = Nothing@@ -1186,7 +1188,7 @@           |  apartnessCheck flattened_target branch           -> -- matching worked & we're apart from all incompatible branches.              -- success-             ASSERT( all (isJust . lookupCoVar subst) tpl_cvs )+             assert (all (isJust . lookupCoVar subst) tpl_cvs) $              Just (index, substTyVars subst tpl_tvs, substCoVars subst tpl_cvs)          -- failure. keep looking@@ -1276,11 +1278,12 @@ -}  topNormaliseType :: FamInstEnvs -> Type -> Type-topNormaliseType env ty = case topNormaliseType_maybe env ty of-                            Just (_co, ty') -> ty'-                            Nothing         -> ty+topNormaliseType env ty+  = case topNormaliseType_maybe env ty of+      Just redn -> reductionReducedType redn+      Nothing   -> ty -topNormaliseType_maybe :: FamInstEnvs -> Type -> Maybe (Coercion, Type)+topNormaliseType_maybe :: FamInstEnvs -> Type -> Maybe Reduction  -- ^ Get rid of *outermost* (or toplevel) --      * type function redex@@ -1299,12 +1302,8 @@ -- original type, and the returned coercion is always homogeneous. topNormaliseType_maybe env ty   = do { ((co, mkind_co), nty) <- topNormaliseTypeX stepper combine ty-       ; return $ case mkind_co of-           MRefl       -> (co, nty)-           MCo kind_co -> let nty_casted = nty `mkCastTy` mkSymCo kind_co-                              final_co   = mkCoherenceRightCo Representational nty-                                                              (mkSymCo kind_co) co-                          in (final_co, nty_casted) }+       ; let hredn = mkHetReduction (mkReduction co nty) mkind_co+       ; return $ homogeniseHetRedn Representational hredn }   where     stepper = unwrapNewTypeStepper' `composeSteppers` tyFamStepper @@ -1319,18 +1318,19 @@     tyFamStepper :: NormaliseStepper (Coercion, MCoercionN)     tyFamStepper rec_nts tc tys  -- Try to step a type/data family       = case topReduceTyFamApp_maybe env tc tys of-          Just (co, rhs, res_co) -> NS_Step rec_nts rhs (co, res_co)-          _                      -> NS_Done+          Just (HetReduction (Reduction co rhs) res_co)+            -> NS_Step rec_nts rhs (co, res_co)+          _ -> NS_Done  ----------------normaliseTcApp :: FamInstEnvs -> Role -> TyCon -> [Type] -> (Coercion, Type)+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  -- See Note [Normalising types] about the LiftingContext-normalise_tc_app :: TyCon -> [Type] -> NormM (Coercion, Type)+normalise_tc_app :: TyCon -> [Type] -> NormM Reduction normalise_tc_app tc tys   | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys   , not (isFamFreeTyCon tc)  -- Expand and try again@@ -1343,76 +1343,70 @@   = -- A type-family application     do { env <- getEnv        ; role <- getRole-       ; (args_co, ntys, res_co) <- normalise_tc_args tc tys+       ; ArgsReductions redns@(Reductions args_cos ntys) res_co <- normalise_tc_args tc tys        ; case reduceTyFamApp_maybe env role tc ntys of-           Just (first_co, ty')-             -> do { (rest_co,nty) <- normalise_type ty'-                   ; return (assemble_result role nty-                                             (args_co `mkTransCo` first_co `mkTransCo` rest_co)-                                             res_co) }+           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 (mkTyConApp tc ntys) args_co res_co) }+                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 { (args_co, ntys, res_co) <- normalise_tc_args tc tys+    do { ArgsReductions redns res_co <- normalise_tc_args tc tys        ; role <- getRole-       ; return (assemble_result role (mkTyConApp tc ntys) args_co res_co) }+       ; return $+            assemble_result role (mkTyConAppRedn role tc redns) res_co }    where     assemble_result :: Role       -- r, ambient role in NormM monad-                    -> Type       -- nty, result type, possibly of changed kind-                    -> Coercion   -- orig_ty ~r nty, possibly heterogeneous+                    -> Reduction  -- orig_ty ~r nty, possibly heterogeneous (nty possibly of changed kind)                     -> MCoercionN -- typeKind(orig_ty) ~N typeKind(nty)-                    -> (Coercion, Type)   -- (co :: orig_ty ~r nty_casted, nty_casted)-                                          -- where nty_casted has same kind as orig_ty-    assemble_result r nty orig_to_nty kind_co-      = ( final_co, nty_old_kind )-      where-        nty_old_kind = nty `mkCastTyMCo` mkSymMCo kind_co-        final_co     = mkCoherenceRightMCo r nty (mkSymMCo kind_co) orig_to_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)  --------------- -- | Try to simplify a type-family application, by *one* step--- If topReduceTyFamApp_maybe env r F tys = Just (co, rhs, res_co)+-- 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 (Coercion, Type, MCoercion)+                        -> Maybe HetReduction topReduceTyFamApp_maybe envs fam_tc arg_tys   | isFamilyTyCon fam_tc   -- type families and data families-  , Just (co, rhs) <- reduceTyFamApp_maybe envs role fam_tc ntys-  = Just (args_co `mkTransCo` co, rhs, res_co)+  , 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-    (args_co, ntys, res_co) = initNormM envs role (tyCoVarsOfTypes arg_tys) $-                              normalise_tc_args fam_tc arg_tys+    ArgsReductions (Reductions args_cos ntys) res_co+      = initNormM envs role (tyCoVarsOfTypes arg_tys)+      $ normalise_tc_args fam_tc arg_tys -normalise_tc_args :: TyCon -> [Type]             -- tc tys-                  -> NormM (Coercion, [Type], MCoercionN)-                  -- (co, new_tys), where-                  -- co :: tc tys ~ tc new_tys; might not be homogeneous-                  -- res_co :: typeKind(tc tys) ~N typeKind(tc new_tys)+normalise_tc_args :: TyCon -> [Type] -> NormM ArgsReductions normalise_tc_args tc tys   = do { role <- getRole-       ; (args_cos, nargs, res_co) <- normalise_args (tyConKind tc) (tyConRolesX role tc) tys-       ; return (mkTyConAppCo role tc args_cos, nargs, res_co) }+       ; normalise_args (tyConKind tc) (tyConRolesX role tc) tys }  --------------- normaliseType :: FamInstEnvs               -> Role  -- desired role of coercion-              -> Type -> (Coercion, Type)+              -> Type -> Reduction normaliseType env role ty   = initNormM env role (tyCoVarsOfType ty) $ normalise_type ty -normalise_type :: Type                     -- old type-               -> NormM (Coercion, Type)   -- (coercion, new type), where-                                           -- co :: old-type ~ new_type+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@@ -1424,106 +1418,105 @@ 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 (mkReflCo r ty, ty) }+    go ty@(LitTy {})+      = do { r <- getRole+           ; return $ mkReflRedn r ty }     go (AppTy ty1 ty2) = go_app_tys ty1 [ty2] -    go ty@(FunTy { ft_mult = w, ft_arg = ty1, ft_res = ty2 })-      = do { (co1, nty1) <- go ty1-           ; (co2, nty2) <- go ty2-           ; (wco, wty) <- withRole Nominal $ go w+    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 (mkFunCo r wco co1 co2, ty { ft_mult = wty, ft_arg = nty1, ft_res = nty2 }) }+           ; return $ mkFunRedn r vis w_redn arg_redn res_redn }     go (ForAllTy (Bndr tcvar vis) ty)-      = do { (lc', tv', h, ki') <- normalise_var_bndr tcvar-           ; (co, nty)          <- withLC lc' $ normalise_type ty-           ; let tv2 = setTyVarKind tv' ki'-           ; return (mkForAllCo tv' h co, ForAllTy (Bndr tv2 vis) nty) }+      = 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 { (nco, nty) <- go ty+      = do { redn <- go ty            ; lc <- getLC            ; let co' = substRightCo lc co-           ; return (castCoercionKind2 nco Nominal ty nty co co'-                    , mkCastTy nty co') }+           ; return $ mkCastRedn2 Nominal ty co redn co'+             --       ^^^^^^^^^^^ uses castCoercionKind2+           }     go (CoercionTy co)       = do { lc <- getLC            ; r <- getRole-           ; let right_co = substRightCo lc co-           ; return ( mkProofIrrelCo r-                         (liftCoSubst Nominal lc (coercionType co))-                         co right_co-                    , mkCoercionTy right_co ) }+           ; 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 (Coercion, Type)+               -> 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_co, nfun) <- go fun_ty+      = do { fun_redn@(Reduction fun_co nfun) <- go fun_ty            ; case tcSplitTyConApp_maybe nfun of                Just (tc, xis) ->-                 do { (second_co, nty) <- go (mkTyConApp tc (xis ++ arg_tys))+                 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) `mkTransCo` second_co, nty) }+                    ; return $+                        mkAppCos fun_co (map mkNomReflCo arg_tys) `mkTransRedn` redn }                Nothing ->-                 do { (args_cos, nargs, res_co) <- normalise_args (typeKind nfun)-                                                                  (repeat Nominal)-                                                                  arg_tys+                 do { ArgsReductions redns res_co+                        <- normalise_args (typeKind nfun)+                                          (repeat Nominal)+                                          arg_tys                     ; role <- getRole-                    ; let nty = mkAppTys nfun nargs-                          nco = mkAppCos fun_co args_cos-                          nty_casted = nty `mkCastTyMCo` mkSymMCo res_co-                          final_co = mkCoherenceRightMCo role nty (mkSymMCo res_co) nco-                    ; return (final_co, nty_casted) } }+                    ; return $+                        mkCoherenceRightMRedn role+                          (mkAppRedns fun_redn redns)+                          (mkSymMCo res_co) } }  normalise_args :: Kind    -- of the function                -> [Role]  -- roles at which to normalise args                -> [Type]  -- args-               -> NormM ([Coercion], [Type], MCoercion)--- returns (cos, xis, res_co), where each xi is the normalised--- version of the corresponding type, each co is orig_arg ~ xi,--- and the res_co :: kind(f orig_args) ~ kind(f xis)+               -> 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 roles args-       ; let (xis, cos, res_co) = simplifyArgsWorker ki_binders inner_ki fvs roles normed_args-       ; return (map mkSymCo cos, xis, mkSymMCo res_co) }+       ; return $ simplifyArgsWorker ki_binders inner_ki fvs roles normed_args }   where     (ki_binders, inner_ki) = splitPiTys fun_ki     fvs = tyCoVarsOfTypes args -    -- rewriter conventions are different from ours-    impedance_match :: NormM (Coercion, Type) -> NormM (Type, Coercion)-    impedance_match action = do { (co, ty) <- action-                                ; return (ty, mkSymCo co) }-     normalise1 role ty-      = impedance_match $ withRole role $ normalise_type ty+      = withRole role $ normalise_type ty -normalise_tyvar :: TyVar -> NormM (Coercion, Type)+normalise_tyvar :: TyVar -> NormM Reduction normalise_tyvar tv-  = ASSERT( isTyVar tv )+  = assert (isTyVar tv) $     do { lc <- getLC        ; r  <- getRole        ; return $ case liftCoSubstTyVar lc r tv of-           Just co -> (co, coercionRKind co)-           Nothing -> (mkReflCo r ty, ty) }-  where ty = mkTyVarTy tv+           Just co -> coercionRedn co+           Nothing -> mkReflRedn r (mkTyVarTy tv) } -normalise_var_bndr :: TyCoVar -> NormM (LiftingContext, TyCoVar, Coercion, Kind)+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 callback lc1 tcvar }+       ; return $ liftCoSubstVarBndrUsing reductionCoercion callback lc1 tcvar }  -- | a monad for the normalisation functions, reading 'FamInstEnvs', -- a 'LiftingContext', and a 'Role'.
GHC/Core/InstEnv.hs view
@@ -7,53 +7,55 @@ The bits common to GHC.Tc.TyCl.Instance and GHC.Tc.Deriv. -} -{-# LANGUAGE CPP, DeriveDataTypeable #-}+{-# LANGUAGE DeriveDataTypeable #-}  module GHC.Core.InstEnv (         DFunId, InstMatch, ClsInstLookupResult,+        PotentialUnifiers(..), getPotentialUnifiers, nullUnifiers,         OverlapFlag(..), OverlapMode(..), setOverlapModeMaybe,         ClsInst(..), DFunInstType, pprInstance, pprInstanceHdr, pprInstances,         instanceHead, instanceSig, mkLocalInstance, mkImportedInstance,-        instanceDFunId, updateClsInstDFun, instanceRoughTcs,+        instanceDFunId, updateClsInstDFuns, updateClsInstDFun,         fuzzyClsInstCmp, orphNamesOfClsInst,          InstEnvs(..), VisibleOrphanModules, InstEnv,-        emptyInstEnv, extendInstEnv,-        deleteFromInstEnv, deleteDFunFromInstEnv,+        mkInstEnv, emptyInstEnv, unionInstEnv, extendInstEnv,+        filterInstEnv, deleteFromInstEnv, deleteDFunFromInstEnv,+        anyInstEnv,         identicalClsInstHead,-        extendInstEnvList, lookupUniqueInstEnv, lookupInstEnv, instEnvElts, instEnvClasses,+        extendInstEnvList, lookupUniqueInstEnv, lookupInstEnv, instEnvElts, instEnvClasses, mapInstEnv,         memberInstEnv,         instIsVisible,         classInstances, instanceBindFun,+        classNameInstances,         instanceCantMatch, roughMatchTcs,         isOverlappable, isOverlapping, isIncoherent     ) where -#include "HsVersions.h"- import GHC.Prelude  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.Unit.Module.Env import GHC.Unit.Types import GHC.Core.Class 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.Unique (getUnique) import GHC.Core.Unify import GHC.Types.Basic-import GHC.Types.Unique.DFM import GHC.Types.Id import Data.Data        ( Data ) import Data.Maybe       ( isJust ) -import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain+import Data.Semigroup  {- ************************************************************************@@ -69,9 +71,12 @@ data ClsInst   = ClsInst {   -- Used for "rough matching"; see                 -- Note [ClsInst laziness and the rough-match fields]-                -- INVARIANT: is_tcs = roughMatchTcs is_tys+                -- 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@.                --@@ -104,13 +109,12 @@ -- instances before displaying them to the user. fuzzyClsInstCmp :: ClsInst -> ClsInst -> Ordering fuzzyClsInstCmp x y =-    stableNameCmp (is_cls_nm x) (is_cls_nm y) `mappend`-    mconcat (map cmp (zip (is_tcs x) (is_tcs y)))+    foldMap cmp (zip (is_tcs x) (is_tcs y))   where-    cmp (OtherTc,   OtherTc)   = EQ-    cmp (OtherTc,   KnownTc _) = LT-    cmp (KnownTc _, OtherTc)   = GT-    cmp (KnownTc x, KnownTc y) = stableNameCmp x y+    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 :: ClsInst -> Bool isOverlappable i = hasOverlappableFlag (overlapMode (is_flag i))@@ -197,8 +201,9 @@ updateClsInstDFun tidy_dfun ispec   = ispec { is_dfun = tidy_dfun (is_dfun ispec) } -instanceRoughTcs :: ClsInst -> [RoughMatchTc]-instanceRoughTcs = is_tcs+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)@@ -260,13 +265,13 @@             , is_tvs = tvs             , is_dfun_name = dfun_name             , is_cls = cls, is_cls_nm = cls_name-            , is_tys = tys, is_tcs = roughMatchTcs tys+            , is_tys = tys, is_tcs = RM_KnownTc cls_name : roughMatchTcs tys             , is_orphan = orph             }   where     cls_name = className cls     dfun_name = idName dfun-    this_mod = ASSERT( isExternalName dfun_name ) nameModule dfun_name+    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@@ -274,9 +279,9 @@     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  = ASSERT( not (null mb_ns) ) head mb_ns-         | otherwise         = IsOrphan+    orph | is_local cls_name   = NotOrphan (nameOccName cls_name)+         | all notOrphan mb_ns = assert (not (null mb_ns)) $ head mb_ns+         | otherwise           = IsOrphan      notOrphan NotOrphan{} = True     notOrphan _ = False@@ -291,7 +296,7 @@     choose_one nss = chooseOrphanAnchor (unionNameSets nss)  mkImportedInstance :: Name           -- ^ the name of the class-                   -> [RoughMatchTc] -- ^ the types which the class was applied to+                   -> [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?@@ -305,7 +310,8 @@   = 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 = mb_tcs+            , is_cls_nm = cls_nm, is_cls = cls+            , is_tcs = RM_KnownTc cls_nm : mb_tcs             , is_orphan = orphan }   where     (tvs, _, cls, tys) = tcSplitDFunTy (idType dfun)@@ -387,9 +393,12 @@ -- 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.-type InstEnv = UniqDFM Class ClsInstEnv      -- Maps Class to instances for that class+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@@ -407,31 +416,33 @@ -- transitively reachable orphan modules (modules that define orphan instances). type VisibleOrphanModules = ModuleSet -newtype ClsInstEnv-  = ClsIE [ClsInst]    -- The instances for a particular class, in any order -instance Outputable ClsInstEnv where-  ppr (ClsIE is) = pprInstances is- -- INVARIANTS: --  * The is_tvs are distinct in each ClsInst --      of a ClsInstEnv (so we can safely unify them) --- Thus, the @ClassInstEnv@ for @Eq@ might contain the following entry:+-- 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 = emptyUDFM+emptyInstEnv = InstEnv emptyRM +mkInstEnv :: [ClsInst] -> InstEnv+mkInstEnv = extendInstEnvList emptyInstEnv+ instEnvElts :: InstEnv -> [ClsInst]-instEnvElts ie = [elt | ClsIE elts <- eltsUDFM ie, elt <- elts]+instEnvElts (InstEnv rm) = elemsRM rm   -- See Note [InstEnv determinism] -instEnvClasses :: InstEnv -> [Class]-instEnvClasses ie = [is_cls e | ClsIE (e : _) <- eltsUDFM ie]+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]@@ -447,45 +458,56 @@                | otherwise                   -> True  classInstances :: InstEnvs -> Class -> [ClsInst]-classInstances (InstEnvs { ie_global = pkg_ie, ie_local = home_ie, ie_visible = vis_mods }) cls+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 env = case lookupUDFM env cls of-                Just (ClsIE insts) -> filter (instIsVisible vis_mods) insts-                Nothing            -> []+    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 inst_env ins_item@(ClsInst { is_cls_nm = cls_nm } ) =-    maybe False (\(ClsIE items) -> any (identicalDFunType ins_item) items)-          (lookupUDFM_Directly inst_env (getUnique cls_nm))+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 inst_env ins_item@(ClsInst { is_cls_nm = cls_nm })-  = addToUDFM_C_Directly add inst_env (getUnique cls_nm) (ClsIE [ins_item])-  where-    add (ClsIE cur_insts) _ = ClsIE (ins_item : cur_insts)+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 inst_env ins_item@(ClsInst { is_cls_nm = cls_nm })-  = adjustUDFM_Directly adjust inst_env (getUnique cls_nm)-  where-    adjust (ClsIE items) = ClsIE (filterOut (identicalClsInstHead ins_item) items)+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 inst_env dfun-  = adjustUDFM adjust inst_env cls+deleteDFunFromInstEnv (InstEnv rm) dfun+  = InstEnv $ filterMatchingRM (not . same_dfun) [RM_KnownTc (className cls)] rm   where     (_, _, cls, _) = tcSplitDFunTy (idType dfun)-    adjust (ClsIE items) = ClsIE (filterOut same_dfun items)     same_dfun (ClsInst { is_dfun = dfun' }) = dfun == dfun'  identicalClsInstHead :: ClsInst -> ClsInst -> Bool@@ -493,10 +515,10 @@ -- e.g.  both are   Eq [(a,b)] -- Used for overriding in GHCi -- Obviously should be insensitive to alpha-renaming-identicalClsInstHead (ClsInst { is_cls_nm = cls_nm1, is_tcs = rough1, is_tys = tys1 })-                     (ClsInst { is_cls_nm = cls_nm2, is_tcs = rough2, is_tys = tys2 })-  =  cls_nm1 == cls_nm2-  && not (instanceCantMatch rough1 rough2)  -- Fast check for no match, uses the "rough match" fields+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) @@ -731,7 +753,7 @@  type ClsInstLookupResult      = ( [InstMatch]     -- Successful matches-       , [ClsInst]       -- These don't match but do unify+       , 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).@@ -812,11 +834,38 @@       _other -> Left $ text "instance not found" <+>                        (ppr $ mkTyConApp (classTyCon cls) tys) +data PotentialUnifiers = NoUnifiers+                       | OneOrMoreUnifiers [ClsInst]+                       -- 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.++instance Outputable PotentialUnifiers where+  ppr NoUnifiers = text "NoUnifiers"+  ppr xs = ppr (getPotentialUnifiers xs)++instance Semigroup PotentialUnifiers where+  NoUnifiers <> u = u+  u <> NoUnifiers = u+  u1 <> u2 = OneOrMoreUnifiers (getPotentialUnifiers u1 ++ getPotentialUnifiers u2)++instance Monoid PotentialUnifiers where+  mempty = NoUnifiers++getPotentialUnifiers :: PotentialUnifiers -> [ClsInst]+getPotentialUnifiers NoUnifiers = []+getPotentialUnifiers (OneOrMoreUnifiers cls) = cls++nullUnifiers :: PotentialUnifiers -> Bool+nullUnifiers NoUnifiers = True+nullUnifiers _ = False+ lookupInstEnv' :: InstEnv          -- InstEnv to look in                -> VisibleOrphanModules   -- But filter against this                -> Class -> [Type]  -- What we are looking for                -> ([InstMatch],    -- Successful matches-                   [ClsInst])      -- These don't match but do unify+                   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]@@ -828,41 +877,40 @@ -- but Foo [Int] is a unifier.  This gives the caller a better chance of -- giving a suitable error message -lookupInstEnv' ie vis_mods cls tys-  = lookup ie+lookupInstEnv' (InstEnv rm) vis_mods cls tys+  = (foldr check_match [] rough_matches, check_unifier rough_unifiers)   where-    rough_tcs  = roughMatchTcs tys--    ---------------    lookup env = case lookupUDFM env cls of-                   Nothing -> ([],[])   -- No instances for this class-                   Just (ClsIE insts) -> find [] [] insts+    (rough_matches, rough_unifiers) = lookupRM' rough_tcs rm+    rough_tcs  = RML_KnownTc (className cls) : roughMatchTcsLookup tys      ---------------    find ms us [] = (ms, us)-    find ms us (item@(ClsInst { is_tcs = mb_tcs, is_tvs = tpl_tvs-                              , is_tys = tpl_tys }) : rest)+    check_match :: ClsInst -> [InstMatch] -> [InstMatch]+    check_match item@(ClsInst { is_tvs = tpl_tvs, is_tys = tpl_tys }) acc       | not (instIsVisible vis_mods item)-      = find ms us rest  -- See Note [Instance lookup and orphan instances]--        -- Fast check for no match, uses the "rough match" fields-      | instanceCantMatch rough_tcs mb_tcs-      = find ms us rest+      = acc  -- See Note [Instance lookup and orphan instances]        | Just subst <- tcMatchTys tpl_tys tys-      = find ((item, map (lookupTyVar subst) tpl_tvs) : ms) us rest+      = ((item, map (lookupTyVar subst) tpl_tvs) : acc)+      | otherwise+      = acc ++    check_unifier :: [ClsInst] -> PotentialUnifiers+    check_unifier [] = NoUnifiers+    check_unifier (item@ClsInst { is_tvs = tpl_tvs, is_tys = tpl_tys }:items)+      | not (instIsVisible vis_mods item)+      = check_unifier items  -- See Note [Instance lookup and orphan instances]+      | Just {} <- tcMatchTys tpl_tys tys = check_unifier items         -- Does not match, so next check whether the things unify         -- See Note [Overlapping instances]         -- Ignore ones that are incoherent: Note [Incoherent instances]       | isIncoherent item-      = find ms us rest+      = check_unifier items        | otherwise-      = ASSERT2( tys_tv_set `disjointVarSet` tpl_tv_set,-                 (ppr cls <+> ppr tys) $$-                 (ppr tpl_tvs <+> ppr tpl_tys)-                )+      = 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]@@ -870,10 +918,12 @@           -- 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.-            SurelyApart              -> find ms us        rest-              -- Note [Infinitary substitution in lookup]-            MaybeApart MARInfinite _ -> find ms us        rest-            _                        -> find ms (item:us) rest+            SurelyApart              -> check_unifier items+              -- See Note [Infinitary substitution in lookup]+            MaybeApart MARInfinite _ -> check_unifier items+            _                        ->+              OneOrMoreUnifiers (item: getPotentialUnifiers (check_unifier items))+       where         tpl_tv_set = mkVarSet tpl_tvs         tys_tv_set = tyCoVarsOfTypes tys@@ -893,14 +943,13 @@                         , ie_visible = vis_mods })               cls               tys-  = -- pprTrace "lookupInstEnv" (ppr cls <+> ppr tys $$ ppr home_ie) $-    (final_matches, final_unifs, unsafe_overlapped)+  = (final_matches, final_unifs, unsafe_overlapped)   where     (home_matches, home_unifs) = lookupInstEnv' home_ie vis_mods cls tys     (pkg_matches,  pkg_unifs)  = lookupInstEnv' pkg_ie  vis_mods cls tys     all_matches = home_matches ++ pkg_matches-    all_unifs   = home_unifs   ++ pkg_unifs-    final_matches = foldr insert_overlapping [] all_matches+    all_unifs   = home_unifs   `mappend` pkg_unifs+    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@@ -913,7 +962,7 @@      -- If the selected match is incoherent, discard all unifiers     final_unifs = case final_matches of-                    (m:_) | isIncoherent (fst m) -> []+                    (m:_) | isIncoherent (fst m) -> NoUnifiers                     _                            -> all_unifs      -- NOTE [Safe Haskell isSafeOverlap]@@ -953,48 +1002,253 @@         (isOrphan (is_orphan inst) || classArity (is_cls inst) > 1)  ----------------insert_overlapping :: InstMatch -> [InstMatch] -> [InstMatch]--- ^ Add a new solution, knocking out strictly less specific ones--- See Note [Rules for instance lookup]-insert_overlapping new_item [] = [new_item]-insert_overlapping new_item@(new_inst,_) (old_item@(old_inst,_) : old_items)-  | new_beats_old        -- New strictly overrides old-  , not old_beats_new-  , new_inst `can_override` old_inst-  = insert_overlapping new_item old_items -  | old_beats_new        -- Old strictly overrides new-  , not new_beats_old-  , old_inst `can_override` new_inst-  = old_item : old_items -  -- 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-  = old_item : old_items+{- 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: -  -- Equal or incomparable, and neither is incoherent; keep both-  | otherwise-  = old_item : insert_overlapping new_item old_items-  where+(A)   instance                      C [a] where ...+(B)   instance {-# OVERLAPPING #-} C [[a] where ...+(C)   instance C (Maybe a) where -    new_beats_old = new_inst `more_specific_than` old_inst-    old_beats_new = old_inst `more_specific_than` new_inst+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). -    -- `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))+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]. -    instA `can_override` instB-       = isOverlapping instA || isOverlappable instB+  - 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 overriden 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 overriden 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 overriden 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 overriden 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 Nove [Rules for instance lookup]+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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1015,7 +1269,7 @@ 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]):+it was only about the unify-check (Note [Overlapping instances]):  Example:         class C a b c where foo :: (a,b,c)
+ GHC/Core/LateCC.hs view
@@ -0,0 +1,167 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE TupleSections #-}++-- | Adds cost-centers after the core piple has run.+module GHC.Core.LateCC+    ( addLateCostCentresMG+    , addLateCostCentresPgm+    , addLateCostCentres -- Might be useful for API users+    , Env(..)+    ) where++import Control.Applicative+import GHC.Utils.Monad.State.Strict+import Control.Monad++import GHC.Prelude+import GHC.Driver.Session+import GHC.Types.CostCentre+import GHC.Types.CostCentre.State+import GHC.Types.Name hiding (varName)+import GHC.Types.Tickish+import GHC.Unit.Module.ModGuts+import GHC.Types.Var+import GHC.Unit.Types+import GHC.Data.FastString+import GHC.Core+import GHC.Core.Opt.Monad+import GHC.Types.Id+import GHC.Core.Utils (mkTick)++import qualified Data.Set as S+import GHC.Utils.Logger+import GHC.Utils.Outputable+import GHC.Utils.Misc+import GHC.Utils.Error (withTiming)+++{- Note [Collecting late cost centres]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Usually cost centres defined by a module are collected+during tidy by collectCostCentres. However with `-fprof-late`+we insert cost centres after inlining. So we keep a list of+all the cost centres we inserted and combine that with the list+of cost centres found during tidy.++To avoid overhead when using -fprof-inline there is a flag to stop+us from collecting them here when we run this pass before tidy.++Note [Adding late cost centres]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The basic idea is very simple. For every top level binder+`f = rhs` we compile it as if the user had written+`f = {-# SCC f #-} rhs`.++If we do this after unfoldings for `f` have been created this+doesn't impact core-level optimizations at all. If we do it+before the cost centre will be included in the unfolding and+might inhibit optimizations at the call site. For this reason+we provide flags for both approaches as they have different+tradeoffs.++We also don't add a cost centre for any binder that is a constructor+worker or wrapper. These will never meaningfully enrich the resulting+profile so we improve efficiency by omitting those.++-}++addLateCostCentresMG :: ModGuts -> CoreM ModGuts+addLateCostCentresMG guts = do+  dflags <- getDynFlags+  let env :: Env+      env = Env+        { thisModule = mg_module guts+        , ccState = newCostCentreState+        , countEntries = gopt Opt_ProfCountEntries dflags+        , collectCCs = False -- See Note [Collecting late cost centres]+        }+  let guts' = guts { mg_binds = fst (addLateCostCentres env (mg_binds guts))+                   }+  return guts'++addLateCostCentresPgm :: DynFlags -> Logger -> Module -> CoreProgram -> IO (CoreProgram, S.Set CostCentre)+addLateCostCentresPgm dflags logger mod binds =+  withTiming logger+               (text "LateCC"<+>brackets (ppr mod))+               (\(a,b) -> a `seqList` (b `seq` ())) $ do+  let env = Env+        { thisModule = mod+        , ccState = newCostCentreState+        , countEntries = gopt Opt_ProfCountEntries dflags+        , collectCCs = True -- See Note [Collecting late cost centres]+        }+      (binds', ccs) = addLateCostCentres env binds+  when (dopt Opt_D_dump_late_cc dflags || dopt Opt_D_verbose_core2core dflags) $+    putDumpFileMaybe logger Opt_D_dump_late_cc "LateCC" FormatCore (vcat (map ppr binds'))+  return (binds', ccs)++addLateCostCentres :: Env -> CoreProgram -> (CoreProgram,S.Set CostCentre)+addLateCostCentres env binds =+  let (binds', state) = runState (mapM (doBind env) binds) initLateCCState+  in (binds',lcs_ccs state)+++doBind :: Env -> CoreBind -> M CoreBind+doBind env (NonRec b rhs) = NonRec b <$> doBndr env b rhs+doBind env (Rec bs) = Rec <$> mapM doPair bs+  where+    doPair :: ((Id, CoreExpr) -> M (Id, CoreExpr))+    doPair (b,rhs) = (b,) <$> doBndr env b rhs++doBndr :: Env -> Id -> CoreExpr -> M CoreExpr+doBndr env bndr rhs+  -- Cost centres on constructor workers are pretty much useless+  -- so we don't emit them if we are looking at the rhs of a constructor+  -- binding.+  | Just _ <- isDataConId_maybe bndr = pure rhs+  | otherwise = doBndr' env bndr rhs+++-- We want to put the cost centra below the lambda as we only care about executions of the RHS.+doBndr' :: Env -> Id -> CoreExpr -> State LateCCState CoreExpr+doBndr' env bndr (Lam b rhs) = Lam b <$> doBndr' env bndr rhs+doBndr' env bndr rhs = do+    let name = idName bndr+        name_loc = nameSrcSpan name+        cc_name = getOccFS name+        count = countEntries env+    cc_flavour <- getCCFlavour cc_name+    let cc_mod = thisModule env+        bndrCC = NormalCC cc_flavour cc_name cc_mod name_loc+        note = ProfNote bndrCC count True+    addCC env bndrCC+    return $ mkTick note rhs++data LateCCState = LateCCState+    { lcs_state :: !CostCentreState+    , lcs_ccs   :: S.Set CostCentre+    }+type M = State LateCCState++initLateCCState :: LateCCState+initLateCCState = LateCCState newCostCentreState mempty++getCCFlavour :: FastString -> M CCFlavour+getCCFlavour name = LateCC <$> getCCIndex' name++getCCIndex' :: FastString -> M CostCentreIndex+getCCIndex' name = do+  state <- get+  let (index,cc_state') = getCCIndex name (lcs_state state)+  put (state { lcs_state = cc_state'})+  return index++addCC :: Env -> CostCentre -> M ()+addCC !env cc = do+    state <- get+    when (collectCCs env) $ do+        let ccs' = S.insert cc (lcs_ccs state)+        put (state { lcs_ccs = ccs'})++data Env = Env+  { thisModule  :: !Module+  , countEntries:: !Bool+  , ccState     :: !CostCentreState+  , collectCCs  :: !Bool+  }+
GHC/Core/Lint.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP                 #-} {-# LANGUAGE DeriveFunctor       #-} {-# LANGUAGE MultiWayIf          #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -21,45 +20,31 @@      -- ** Debug output     endPass, endPassIO,-    displayLintResults, dumpPassResult,-    dumpIfSet,+    displayLintResults, dumpPassResult  ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Driver.Session import GHC.Driver.Ppr import GHC.Driver.Env+import GHC.Driver.Config.Diagnostic +import GHC.Tc.Utils.TcType ( isFloatingPrimTy, isTyFamFree )+import GHC.Unit.Module.ModGuts+import GHC.Runtime.Context+ import GHC.Core import GHC.Core.FVs import GHC.Core.Utils import GHC.Core.Stats ( coreBindsStats ) import GHC.Core.Opt.Monad-import GHC.Data.Bag-import GHC.Types.Literal import GHC.Core.DataCon-import GHC.Builtin.Types.Prim-import GHC.Builtin.Types ( multiplicityTy )-import GHC.Tc.Utils.TcType ( isFloatingTy, isTyFamFree )-import GHC.Types.Var as Var-import GHC.Types.Var.Env-import GHC.Types.Var.Set-import GHC.Types.Unique.Set( nonDetEltsUniqSet )-import GHC.Types.Name-import GHC.Types.Name.Env-import GHC.Types.Id-import GHC.Types.Id.Info import GHC.Core.Ppr import GHC.Core.Coercion-import GHC.Types.SrcLoc-import GHC.Types.Tickish import GHC.Core.Type as Type import GHC.Core.Multiplicity import GHC.Core.UsageEnv-import GHC.Types.RepType import GHC.Core.TyCo.Rep   -- checks validity of types/coercions import GHC.Core.TyCo.Subst import GHC.Core.TyCo.FVs@@ -67,27 +52,44 @@ import GHC.Core.TyCon as TyCon import GHC.Core.Coercion.Axiom import GHC.Core.Unify+import GHC.Core.InstEnv      ( instanceDFunId, instEnvElts )+import GHC.Core.Coercion.Opt ( checkAxInstCo )+import GHC.Core.Opt.Arity    ( typeArity )++import GHC.Types.Literal+import GHC.Types.Var as Var+import GHC.Types.Var.Env+import GHC.Types.Var.Set+import GHC.Types.Unique.Set( nonDetEltsUniqSet )+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.RepType import GHC.Types.Basic-import GHC.Utils.Error-import qualified GHC.Utils.Error as Err-import GHC.Utils.Logger (Logger, putLogMsg, putDumpMsg, DumpFormat (..), getLogger)-import qualified GHC.Utils.Logger as Logger-import GHC.Data.List.SetOps+import GHC.Types.Demand      ( splitDmdSig, isDeadEndDiv )+import GHC.Types.TypeEnv+ import GHC.Builtin.Names+import GHC.Builtin.Types.Prim+import GHC.Builtin.Types ( multiplicityTy )++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.Data.FastString+import GHC.Utils.Constants (debugIsOn) import GHC.Utils.Misc-import GHC.Core.InstEnv      ( instanceDFunId )-import GHC.Core.Coercion.Opt ( checkAxInstCo )-import GHC.Core.Opt.Arity    ( typeArity )-import GHC.Types.Demand      ( splitStrictSig, isDeadEndDiv )-import GHC.Types.TypeEnv-import GHC.Unit.Module.ModGuts-import GHC.Runtime.Context+import GHC.Utils.Trace+import GHC.Utils.Error+import qualified GHC.Utils.Error as Err+import GHC.Utils.Logger  import Control.Monad-import GHC.Utils.Monad import Data.Foldable      ( toList ) import Data.List.NonEmpty ( NonEmpty(..), groupWith ) import Data.List          ( partition )@@ -160,16 +162,6 @@ If we have done specialisation the we check that there are         (a) No top-level bindings of primitive (unboxed type) -Outstanding issues:--    -- Things are *not* OK if:-    ---    --  * Unsaturated type app before specialisation has been done;-    ---    --  * Oversaturated type app after specialisation (eta reduction-    --   may well be happening...);-- Note [Linting function types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ As described in Note [Representation of function types], all saturated@@ -182,7 +174,7 @@         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 mkWwArgs; see Note [Join points and beta-redexes]+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@@ -293,49 +285,46 @@           -> CoreToDo -> CoreProgram -> [CoreRule] -> IO () -- Used by the IO-is CorePrep too endPassIO hsc_env print_unqual pass binds rules-  = do { dumpPassResult logger dflags print_unqual mb_flag-                        (ppr pass) (pprPassDetails pass) binds rules+  = do { dumpPassResult logger dump_core_sizes print_unqual mb_flag+                        (showSDoc dflags (ppr pass)) (pprPassDetails pass) binds rules        ; lintPassResult hsc_env pass binds }   where+    dump_core_sizes = not (gopt Opt_SuppressCoreSizes dflags)     logger  = hsc_logger hsc_env     dflags  = hsc_dflags hsc_env     mb_flag = case coreDumpFlag pass of-                Just flag | dopt flag dflags                    -> Just flag-                          | dopt Opt_D_verbose_core2core dflags -> Just flag+                Just flag | logHasDumpFlag logger flag                    -> Just flag+                          | logHasDumpFlag logger Opt_D_verbose_core2core -> Just flag                 _ -> Nothing -dumpIfSet :: Logger -> DynFlags -> Bool -> CoreToDo -> SDoc -> SDoc -> IO ()-dumpIfSet logger dflags dump_me pass extra_info doc-  = Logger.dumpIfSet logger dflags dump_me (showSDoc dflags (ppr pass <+> extra_info)) doc- dumpPassResult :: Logger-               -> DynFlags+               -> Bool                  -- dump core sizes?                -> PrintUnqualified                -> Maybe DumpFlag        -- Just df => show details in a file whose                                         --            name is specified by df-               -> SDoc                  -- Header+               -> String                -- Header                -> SDoc                  -- Extra info to appear after header                -> CoreProgram -> [CoreRule]                -> IO ()-dumpPassResult logger dflags unqual mb_flag hdr extra_info binds rules+dumpPassResult logger dump_core_sizes unqual mb_flag hdr extra_info binds rules   = do { forM_ mb_flag $ \flag -> do-           let sty = mkDumpStyle unqual-           putDumpMsg logger dflags sty flag-              (showSDoc dflags hdr) FormatCore dump_doc+           logDumpFile logger (mkDumpStyle unqual) 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 dflags 2 size_doc+       ; Err.debugTraceMsg logger 2 size_doc        }    where-    size_doc = sep [text "Result size of" <+> hdr, nest 2 (equals <+> ppr (coreBindsStats binds))]+    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-                     , pprCoreBindingsWithSize binds+                     , 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 --------"@@ -360,9 +349,10 @@ coreDumpFlag CoreDesugarOpt           = Just Opt_D_dump_ds coreDumpFlag CoreTidy                 = Just Opt_D_dump_simpl coreDumpFlag CorePrep                 = Just Opt_D_dump_prep-coreDumpFlag CoreOccurAnal            = Just Opt_D_dump_occur_anal+coreDumpFlag CoreAddLateCcs           = Just Opt_D_dump_late_cc  coreDumpFlag CoreAddCallerCcs         = Nothing+coreDumpFlag CoreOccurAnal            = Nothing coreDumpFlag CoreDoPrintCore          = Nothing coreDumpFlag (CoreDoRuleCheck {})     = Nothing coreDumpFlag CoreDoNothing            = Nothing@@ -382,37 +372,36 @@   = return ()   | otherwise   = do { let warns_and_errs = lintCoreBindings dflags pass (interactiveInScope $ hsc_IC hsc_env) binds-       ; Err.showPass logger dflags ("Core Linted result of " ++ showPpr dflags pass)-       ; displayLintResults logger dflags (showLintWarnings pass) (ppr pass)+       ; Err.showPass logger ("Core Linted result of " ++ showPpr dflags pass)+       ; displayLintResults logger (showLintWarnings pass) (ppr pass)                             (pprCoreBindings binds) warns_and_errs }   where     dflags = hsc_dflags hsc_env     logger = hsc_logger hsc_env  displayLintResults :: Logger-                   -> DynFlags                    -> 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 dflags display_warnings pp_what pp_pgm (warns, errs)+displayLintResults logger display_warnings pp_what pp_pgm (warns, errs)   | not (isEmptyBag errs)-  = do { putLogMsg logger dflags NoReason Err.SevDump noSrcSpan+  = do { logMsg logger Err.MCDump noSrcSpan            $ withPprStyle defaultDumpStyle            (vcat [ lint_banner "errors" pp_what, Err.pprMessageBag errs                  , text "*** Offending Program ***"                  , pp_pgm                  , text "*** End of Offense ***" ])-       ; Err.ghcExit logger dflags 1 }+       ; Err.ghcExit logger 1 }    | not (isEmptyBag warns)-  , not (hasNoDebugOutput dflags)+  , log_enable_debug (logFlags logger)   , display_warnings   -- If the Core linter encounters an error, output to stderr instead of   -- stdout (#13342)-  = putLogMsg logger dflags NoReason Err.SevInfo noSrcSpan+  = logMsg logger Err.MCInfo noSrcSpan       $ withPprStyle defaultDumpStyle         (lint_banner "warnings" pp_what $$ Err.pprMessageBag (mapBag ($$ blankLine) warns)) @@ -435,7 +424,7 @@   | not (gopt Opt_DoCoreLinting dflags)   = return ()   | Just err <- lintExpr dflags (interactiveInScope $ hsc_IC hsc_env) expr-  = displayLintResults logger dflags False what (pprCoreExpr expr) (emptyBag, err)+  = displayLintResults logger False what (pprCoreExpr expr) (emptyBag, err)   | otherwise   = return ()   where@@ -460,7 +449,7 @@     -- 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 cls_insts)+    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?@@ -491,8 +480,19 @@                { 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_linearity = check_linearity+               , lf_check_fixed_rep = check_fixed_rep } +    -- 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 [Checking for representation-polymorphic built-ins]+    -- in GHC.HsToCore.Expr.+    check_fixed_rep = case pass of+                        CoreDesugar -> False+                        _           -> True+     -- See Note [Checking for global Ids]     check_globals = case pass of                       CoreTidy -> False@@ -542,7 +542,6 @@  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). @@ -552,10 +551,10 @@  -} -lintUnfolding :: Bool               -- True <=> is a compulsory unfolding+lintUnfolding :: Bool             -- ^ True <=> is a compulsory unfolding               -> DynFlags               -> SrcLoc-              -> VarSet             -- Treat these as in scope+              -> VarSet           -- ^ Treat these as in scope               -> CoreExpr               -> Maybe (Bag SDoc) -- Nothing => OK @@ -566,8 +565,8 @@     vars = nonDetEltsUniqSet var_set     (_warns, errs) = initL dflags (defaultLintFlags dflags) vars $                      if is_compulsory-                       -- See Note [Checking for levity polymorphism]-                     then noLPChecks linter+                       -- See Note [Checking for representation polymorphism]+                     then noFixedRuntimeRepChecks linter                      else linter     linter = addLoc (ImportedUnfolding locn) $              lintCoreExpr expr@@ -635,15 +634,15 @@         -- Check the let/app invariant         -- See Note [Core let/app invariant] in GHC.Core        ; checkL ( isJoinId binder-               || not (isUnliftedType binder_ty)+               || 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].+        -- 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)@@ -677,12 +676,12 @@            ppr (length (typeArity (idType binder))) <> colon <+>            ppr binder) -       ; case splitStrictSig (idStrictness binder) of+       ; case splitDmdSig (idDmdSig binder) of            (demands, result_info) | isDeadEndDiv result_info ->              checkL (demands `lengthAtLeast` idArity binder)                (text "idArity" <+> ppr (idArity binder) <+>                text "exceeds arity imposed by the strictness signature" <+>-               ppr (idStrictness binder) <> colon <+>+               ppr (idDmdSig binder) <> colon <+>                ppr binder)            _ -> return () @@ -751,8 +750,9 @@   | isStableUnfolding uf   , Just rhs <- maybeUnfoldingTemplate uf   = do { ty <- fst <$> (if isCompulsoryUnfolding uf-                        then noLPChecks $ lintRhs bndr rhs-                              -- See Note [Checking for levity polymorphism]+                        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  _ _ _@@ -769,18 +769,18 @@ simplification are they unravelled.  So we suppress the test for the desugarer. -Note [Checking for levity polymorphism]+Note [Checking for representation polymorphism] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We ordinarily want to check for bad levity polymorphism. See-Note [Levity polymorphism invariants] in GHC.Core. However, we do *not*+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 levity-polymorphic;-indeed levity-polyorphic unfoldings are a primary reason for the+(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, levity-poly, binding).+the original, representation-polymorphic, binding). -It is vitally important that we do levity-polymorphism checks *after*+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@@ -847,7 +847,10 @@ -- See Note [GHC Formalism]  lintCoreExpr (Var var)-  = lintIdOcc var 0+  = do+      var_pair@(var_ty, _) <- lintIdOcc var 0+      checkCanEtaExpand (Var var) [] var_ty+      return var_pair  lintCoreExpr (Lit lit)   = return (literalType lit, zeroUE)@@ -923,9 +926,9 @@   , fun `hasKey` runRWKey     -- N.B. we may have an over-saturated application of the form:     --   runRW (\s -> \x -> ...) y-  , arg_ty1 : arg_ty2 : arg3 : rest <- args-  = do { fun_pair1 <- lintCoreArg (idType fun, zeroUE) arg_ty1-       ; (fun_ty2, ue2) <- lintCoreArg fun_pair1      arg_ty2+  , ty_arg1 : ty_arg2 : arg3 : rest <- args+  = do { fun_pair1 <- lintCoreArg (idType fun, zeroUE) ty_arg1+       ; (fun_ty2, ue2) <- lintCoreArg fun_pair1       ty_arg2          -- See Note [Linting of runRW#]        ; let lintRunRWCont :: CoreArg -> LintM (LintedType, UsageEnv)              lintRunRWCont expr@(Lam _ _) =@@ -937,10 +940,22 @@        ; lintCoreArgs app_ty rest }    | otherwise-  = do { pair <- lintCoreFun fun (length args)-       ; lintCoreArgs pair args }+  = do { fun_pair <- lintCoreFun fun (length args)+       ; app_pair@(app_ty, _) <- lintCoreArgs fun_pair args+       ; checkCanEtaExpand fun args app_ty+       ; return app_pair}   where-    (fun, args) = collectArgs e+    (fun, args, _source_ticks) = collectArgsTicks tickishFloatable 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.  lintCoreExpr (Lam var expr)   = markAllJoinsBad $@@ -1006,8 +1021,8 @@   = lintIdOcc var nargs  lintCoreFun (Lam var body) nargs-  -- Act like lintCoreExpr of Lam, but *don't* call markAllJoinsBad; see-  -- Note [Beta redexes]+  -- Act like lintCoreExpr of Lam, but *don't* call markAllJoinsBad;+  -- See Note [Beta redexes]   | nargs /= 0   = lintLambda var $ lintCoreFun body (nargs - 1) @@ -1080,6 +1095,78 @@   | otherwise   = return () +-- | This function checks that we are able to perform eta expansion for+-- functions with no binding, in order to satisfy invariant I3+-- from Note [Representation polymorphism invariants] in GHC.Core.+checkCanEtaExpand :: CoreExpr   -- ^ the function (head of the application) we are checking+                  -> [CoreArg]  -- ^ the arguments to the application+                  -> LintedType -- ^ the instantiated type of the overall application+                  -> LintM ()+checkCanEtaExpand (Var fun_id) args app_ty+  | hasNoBinding fun_id+  = checkL (null bad_arg_tys) err_msg+    where+      arity :: Arity+      arity = idArity fun_id++      nb_val_args :: Int+      nb_val_args = count isValArg args++      -- Check the remaining argument types, past the+      -- given arguments and up to the arity of the 'Id'.+      -- Returns the types that couldn't be determined to have+      -- a fixed RuntimeRep.+      check_args :: [Type] -> [Type]+      check_args = go (nb_val_args + 1)+        where+          go :: Int    -- index of the argument (starting from 1)+             -> [Type] -- arguments+             -> [Type] -- value argument types that could not be+                       -- determined to have a fixed runtime representation+          go i _+            | i > arity+            = []+          go _ []+            -- The Arity of an Id should never exceed the number of value arguments+            -- that can be read off from the Id's type.+            -- See Note [Arity and function types] in GHC.Types.Id.Info.+            = pprPanic "checkCanEtaExpand: arity larger than number of value arguments apparent in type"+                $ vcat+                  [ text "fun_id =" <+> ppr fun_id+                  , text "arity =" <+> ppr arity+                  , text "app_ty =" <+> ppr app_ty+                  , text "args = " <+> ppr args+                  , text "nb_val_args =" <+> ppr nb_val_args ]+          go i (ty : bndrs)+            | typeHasFixedRuntimeRep ty+            = go (i+1) bndrs+            | otherwise+            = ty : go (i+1) bndrs++      bad_arg_tys :: [Type]+      bad_arg_tys = check_args . map fst $ getRuntimeArgTys app_ty+        -- We use 'getRuntimeArgTys' to find all the argument types,+        -- including those hidden under newtypes. For example,+        -- if `FunNT a b` is a newtype around `a -> b`, then+        -- when checking+        --+        -- foo :: forall r (a :: TYPE r) (b :: TYPE r) c. a -> FunNT b c+        --+        -- we should check that the instantiations of BOTH `a` AND `b`+        -- have a fixed runtime representation.++      err_msg :: SDoc+      err_msg+        = vcat [ text "Cannot eta expand" <+> quotes (ppr fun_id)+               , text "The following type" <> plural bad_arg_tys+                 <+> doOrDoes bad_arg_tys <+> text "not have a fixed runtime representation:"+               , nest 2 $ vcat $ map ppr_ty_ki bad_arg_tys ]++      ppr_ty_ki :: Type -> SDoc+      ppr_ty_ki ty = bullet <+> ppr ty <+> dcolon <+> ppr (typeKind ty)+checkCanEtaExpand _ _ _+  = return ()+ -- 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 -> Var -> LintM UsageEnv@@ -1189,16 +1276,20 @@  lintCoreArg (fun_ty, fun_ue) arg   = do { (arg_ty, arg_ue) <- markAllJoinsBad $ lintCoreExpr arg-           -- See Note [Levity polymorphism invariants] in GHC.Core+           -- See Note [Representation polymorphism invariants] in GHC.Core        ; flags <- getLintFlags-       ; lintL (not (lf_check_levity_poly flags) || not (isTypeLevPoly arg_ty))-           (text "Levity-polymorphic argument:" <+>-             (ppr arg <+> dcolon <+> parens (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))))-          -- check for levity polymorphism first, because otherwise isUnliftedType panics -       ; checkL (not (isUnliftedType arg_ty) || exprOkForSpeculation arg)-                (mkLetAppMsg arg)+       ; 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))) +            ; checkL (mightBeLiftedType arg_ty || exprOkForSpeculation arg)+                     (mkLetAppMsg arg) }+        ; lintValApp arg fun_ty arg_ty fun_ue arg_ue }  -----------------@@ -1269,13 +1360,12 @@ lintValApp :: CoreExpr -> LintedType -> LintedType -> UsageEnv -> UsageEnv -> LintM (LintedType, 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 err1+  = 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-    err1 = mkAppMsg       fun_ty arg_ty arg     err2 = mkNonFunAppMsg fun_ty arg_ty arg  lintTyKind :: OutTyVar -> LintedType -> LintM ()@@ -1323,10 +1413,8 @@      -- See Note [Rules for floating-point comparisons] in GHC.Core.Opt.ConstantFold      ; let isLitPat (Alt (LitAlt _) _  _) = True            isLitPat _                     = False-     ; checkL (not $ isFloatingTy scrut_ty && any isLitPat alts)-         (ptext (sLit $ "Lint warning: Scrutinising floating-point " ++-                        "expression with literal pattern in case " ++-                        "analysis (see #9238).")+     ; checkL (not $ isFloatingPrimTy scrut_ty && any isLitPat alts)+         (text "Lint warning: Scrutinising floating-point expression with literal pattern in case analysis (see #9238)."           $$ text "scrut" <+> ppr scrut)       ; case tyConAppTyCon_maybe (idType var) of@@ -1534,7 +1622,7 @@ -- new type to the in-scope set of the second argument -- ToDo: lint its rules lintIdBndr top_lvl bind_site id thing_inside-  = ASSERT2( isId id, ppr id )+  = assertPpr (isId id) (ppr id) $     do { flags <- getLintFlags        ; checkL (not (lf_check_global_ids flags) || isLocalId id)                 (text "Non-local Id binder" <+> ppr id)@@ -1548,10 +1636,10 @@        ; checkL (not (isExternalName (Var.varName id)) || is_top_lvl)            (mkNonTopExternalNameMsg id) -          -- See Note [Levity polymorphism invariants] in GHC.Core-       ; lintL (isJoinId id || not (lf_check_levity_poly flags)-                || not (isTypeLevPoly id_ty)) $-         text "Levity-polymorphic binder:" <+> ppr id <+> dcolon <+>+          -- 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@@ -1564,6 +1652,11 @@        ; 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.")+        ; linted_ty <- addLoc (IdTy id) (lintValueType id_ty)         ; addInScopeId id linted_ty $@@ -1746,11 +1839,11 @@        ; return (TyConApp tc tys') }  -------------------- Confirms that a type is really *, #, Constraint etc+-- Confirms that a type is really TYPE r or Constraint checkValueType :: LintedType -> SDoc -> LintM () checkValueType ty doc   = lintL (classifiesTypeWithValues kind)-          (text "Non-*-like kind when *-like expected:" <+> ppr kind $$+          (text "Non-Type-like kind when Type-like expected:" <+> ppr kind $$            text "when checking" <+> doc)   where     kind = typeKind ty@@ -1920,7 +2013,7 @@ "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 [Rules and join points] in "GHC.Core.Opt.OccurAnal" for further discussion.+Note [Join points and unfoldings/rules] in "GHC.Core.Opt.OccurAnal" for further discussion. -}  {-@@ -2120,17 +2213,17 @@        | allow_ill_kinded_univ_co prov        = return ()  -- Skip kind checks        | otherwise-       = do { checkWarnL (not lev_poly1)-                         (report "left-hand type is levity-polymorphic")-            ; checkWarnL (not lev_poly2)-                         (report "right-hand type is levity-polymorphic")-            ; when (not (lev_poly1 || lev_poly2)) $+       = do { checkWarnL 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-         lev_poly1 = isTypeLevPoly t1-         lev_poly2 = isTypeLevPoly t2+         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@@ -2354,7 +2447,7 @@            -> [CoAxiom Branched]            -> IO () lintAxioms logger dflags what axioms =-  displayLintResults logger dflags True what (vcat $ map pprCoAxiom axioms) $+  displayLintResults logger True what (vcat $ map pprCoAxiom axioms) $   initL dflags (defaultLintFlags dflags) [] $   do { mapM_ lint_axiom axioms      ; let axiom_groups = groupWith coAxiomTyCon axioms@@ -2558,7 +2651,7 @@        , 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_levity_poly :: Bool -- See Note [Checking for levity polymorphism]+       , lf_check_fixed_rep :: Bool -- See Note [Checking for representation polymorphism]     }  -- See Note [Checking StaticPtrs]@@ -2577,7 +2670,7 @@                              , lf_check_static_ptrs = AllowAnywhere                              , lf_check_linearity = gopt Opt_DoLinearCoreLinting dflags                              , lf_report_unsat_syns = True-                             , lf_check_levity_poly = True+                             , lf_check_fixed_rep = True                              }  newtype LintM a =@@ -2657,11 +2750,9 @@  Note [Linting linearity] ~~~~~~~~~~~~~~~~~~~~~~~~-There are two known optimisations that have not yet been updated+There is one known optimisations that have not yet been updated to work with Linear Lint: -* Lambda-bound variables with unfoldings-  (see Note [Case binders and join points] and ticket #17530) * Optimisations can create a letrec which uses a variable linearly, e.g.     letrec f True = f False            f False = x@@ -2670,10 +2761,48 @@   Plan: make let-bound variables remember the usage environment.   See ticket #18694. -We plan to fix both of the issues in the very near future.+We plan to fix this issue in the very near future. For now, -dcore-lint enables only linting output of the desugarer, and full Linear Lint has to be enabled separately with -dlinear-core-lint. Ticket #19165 concerns enabling Linear Lint with -dcore-lint.++Note [checkCanEtaExpand]+~~~~~~~~~~~~~~~~~~~~~~~~+The checkCanEtaExpand function is responsible for enforcing invariant I3+from Note [Representation polymorphism invariants] in GHC.Core: in any+partial application `f e_1 .. e_n`, if `f` has no binding, we must be able to+eta expand `f` to match the declared arity of `f`.++Wrinkle 1: eta-expansion and newtypes++  Most of the time, when we have a partial application `f e_1 .. e_n`+  in which `f` is `hasNoBinding`, we eta-expand it up to its arity+  as follows:++    \ x_{n+1} ... x_arity -> f e_1 .. e_n x_{n+1} ... x_arity++  However, we might need to insert casts if some of the arguments+  that `f` takes are under a newtype.+  For example, suppose `f` `hasNoBinding`, has arity 1 and type++    f :: forall r (a :: TYPE r). Identity (a -> a)++  then we eta-expand the nullary application `f` to++    ( \ x -> f x ) |> co++  where++    co :: ( forall r (a :: TYPE r). a -> a ) ~# ( forall r (a :: TYPE r). Identity (a -> a) )++  In this case we would have to perform a representation-polymorphism check on the instantiation+  of `a`.++Wrinkle 2: 'hasNoBinding' and laziness++  It's important that we able to compute 'hasNoBinding' for an 'Id' without ever forcing+  the unfolding of the 'Id'. Otherwise, we could end up with a loop, as outlined in+    Note [Lazily checking Unfoldings] in GHC.IfaceToCore. -}  instance Applicative LintM where@@ -2712,8 +2841,11 @@   | InCo   Coercion     -- Inside a coercion   | InAxiom (CoAxiom Branched)   -- Inside a CoAxiom -initL :: DynFlags -> LintFlags -> [Var]-       -> LintM a -> WarnsAndErrs    -- Warnings and errors+initL :: DynFlags+      -> LintFlags+      -> [Var]              -- ^ 'Id's that should be treated as being in scope+      -> LintM a            -- ^ Action to run+      -> WarnsAndErrs initL dflags flags vars m   = case unLintM m env (emptyBag, emptyBag) of       (Just _, errs) -> errs@@ -2737,11 +2869,11 @@     let env' = env { le_flags = (le_flags env) { lf_report_unsat_syns = ru } }     in unLintM thing_inside env' errs --- See Note [Checking for levity polymorphism]-noLPChecks :: LintM a -> LintM a-noLPChecks thing_inside+-- 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_levity_poly = False } }+    let env' = env { le_flags = (le_flags env) { lf_check_fixed_rep = False } }     in unLintM thing_inside env' errs  getLintFlags :: LintM LintFlags@@ -2773,7 +2905,7 @@  addMsg :: Bool -> LintEnv ->  Bag SDoc -> SDoc -> Bag SDoc addMsg is_error env msgs msg-  = ASSERT2( notNull loc_msgs, msg )+  = assertPpr (notNull loc_msgs) msg $     msgs `snocBag` mk_msg msg   where    loc_msgs :: [(SrcLoc, SDoc)]  -- Innermost first@@ -2791,7 +2923,8 @@                           , isGoodSrcSpan span ] of                []    -> noSrcSpan                (s:_) -> s-   mk_msg msg = mkLocMessage SevWarning msg_span+   !diag_opts = initDiagOpts (le_dynflags env)+   mk_msg msg = mkLocMessage (mkMCDiagnostic diag_opts WarningWithoutFlag) msg_span                              (msg $$ context)  addLoc :: LintLocInfo -> LintM a -> LintM a@@ -3099,10 +3232,10 @@ --      Other error messages  mkAppMsg :: Type -> Type -> CoreExpr -> SDoc-mkAppMsg fun_ty arg_ty arg+mkAppMsg expected_arg_ty actual_arg_ty arg   = vcat [text "Argument value doesn't match argument type:",-              hang (text "Fun type:") 4 (ppr fun_ty),-              hang (text "Arg type:") 4 (ppr arg_ty),+              hang (text "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@@ -3298,20 +3431,20 @@ -- consistency checks: We check this by running the given task twice, -- noting all differences between the results. lintAnnots :: SDoc -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts-lintAnnots pname pass guts = do+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 dflags "Annotation linting - first run"+    liftIO $ Err.showPass logger "Annotation linting - first run"   nguts <- pass guts   -- If appropriate re-run it without debug annotations to make sure   -- that they made no difference.   when (gopt Opt_DoAnnotationLinting dflags) $ do-    liftIO $ Err.showPass logger dflags "Annotation linting - second run"+    liftIO $ Err.showPass logger "Annotation linting - second run"     nguts' <- withoutAnnots pass guts     -- Finally compare the resulting bindings-    liftIO $ Err.showPass logger dflags "Annotation linting - comparison"+    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'@@ -3330,7 +3463,7 @@ withoutAnnots pass guts = do   -- Remove debug flag from environment.   dflags <- getDynFlags-  let removeFlag env = env{ hsc_dflags = dflags{ debugLevel = 0} }+  let removeFlag env = hscSetFlags (dflags { debugLevel = 0}) env       withoutFlag corem =           -- TODO: supply tag here as well ?         liftIO =<< runCoreM <$> fmap removeFlag getHscEnv <*> getRuleBase <*>
GHC/Core/Make.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE CPP #-} + {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}  -- | Handy functions for creating much Core syntax@@ -19,6 +19,7 @@         mkIntegerExpr, mkNaturalExpr,         mkFloatExpr, mkDoubleExpr,         mkCharExpr, mkStringExpr, mkStringExprFS, mkStringExprFSWith,+        MkStringIds (..), getMkStringIds,          -- * Floats         FloatBind(..), wrapFloat, wrapFloats, floatBindings,@@ -56,8 +57,6 @@         tYPE_ERROR_ID, aBSENT_SUM_FIELD_ERROR_ID     ) where -#include "HsVersions.h"- import GHC.Prelude import GHC.Platform @@ -65,12 +64,11 @@ import GHC.Types.Var  ( EvVar, setTyVarUnique ) import GHC.Types.TyThing import GHC.Types.Id.Info-import GHC.Types.Demand import GHC.Types.Cpr+import GHC.Types.Demand import GHC.Types.Name      hiding ( varName ) import GHC.Types.Literal import GHC.Types.Unique.Supply-import GHC.Types.Basic  import GHC.Core import GHC.Core.Utils ( exprType, needsCaseBinding, mkSingleAltCase, bindNonRec )@@ -88,6 +86,7 @@ import GHC.Utils.Outputable import GHC.Utils.Misc import GHC.Utils.Panic+import GHC.Utils.Panic.Plain  import GHC.Data.FastString @@ -103,12 +102,13 @@ *                                                                      * ************************************************************************ -}-sortQuantVars :: [Var] -> [Var]--- Sort the variables, putting type and covars first, in scoped order,+-- | Sort the variables, putting type and covars first, in scoped order, -- and then other Ids+-- -- It is a deterministic sort, meaining 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@@ -141,9 +141,12 @@  -- | Construct an expression which represents the application of a number of -- expressions to another. The leftmost expression in the list is applied first+-- -- Respects the let/app invariant by building a case expression where necessary --   See Note [Core let/app invariant] in "GHC.Core"-mkCoreApps :: CoreExpr -> [CoreExpr] -> CoreExpr+mkCoreApps :: CoreExpr -- ^ function+           -> [CoreExpr] -- ^ arguments+           -> CoreExpr mkCoreApps fun args   = fst $     foldl' (mkCoreAppTyped doc_string) (fun, fun_ty) args@@ -153,9 +156,13 @@  -- | Construct an expression which represents the application of one expression -- to the other+-- -- Respects the let/app invariant by building a case expression where necessary --   See Note [Core let/app invariant] in "GHC.Core"-mkCoreApp :: SDoc -> CoreExpr -> CoreExpr -> CoreExpr+mkCoreApp :: SDoc+          -> CoreExpr -- ^ function+          -> CoreExpr -- ^ argument+          -> CoreExpr mkCoreApp s fun arg   = fst $ mkCoreAppTyped s (fun, exprType fun) arg @@ -163,6 +170,7 @@ -- 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'.+-- -- Respects the let/app invariant by building a case expression where necessary --   See Note [Core let/app invariant] in "GHC.Core" mkCoreAppTyped :: SDoc -> (CoreExpr, Type) -> CoreExpr -> (CoreExpr, Type)@@ -171,16 +179,16 @@ mkCoreAppTyped _ (fun, fun_ty) (Coercion co)   = (App fun (Coercion co), funResultTy fun_ty) mkCoreAppTyped d (fun, fun_ty) arg-  = ASSERT2( isFunTy fun_ty, ppr fun $$ ppr arg $$ d )+  = assertPpr (isFunTy fun_ty) (ppr fun $$ ppr arg $$ d)     (mkValApp fun arg (Scaled mult arg_ty) res_ty, res_ty)   where     (mult, arg_ty, res_ty) = splitFunTy fun_ty -mkValApp :: CoreExpr -> CoreExpr -> Scaled Type -> Type -> CoreExpr--- Build an application (e1 e2),+-- | Build an application (e1 e2), -- or a strict binding  (case e2 of x -> e1 x) -- using the latter when necessary to respect the let/app invariant --   See Note [Core let/app invariant] in GHC.Core+mkValApp :: CoreExpr -> CoreExpr -> Scaled Type -> Type -> CoreExpr mkValApp fun arg (Scaled w arg_ty) res_ty   | not (needsCaseBinding arg_ty arg)   = App fun arg                -- The vastly common case@@ -200,20 +208,25 @@ -- 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. -mkWildCase :: CoreExpr -> Scaled Type -> Type -> [CoreAlt] -> CoreExpr--- Make a case expression whose case binder is unused+-- | 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 +-- | Build a strict application (case e2 of x -> e1 x) mkStrictApp :: CoreExpr -> CoreExpr -> Scaled Type -> Type -> CoreExpr--- Build a strict application (case e2 of x -> e1 x) mkStrictApp fun arg (Scaled w arg_ty) res_ty   = Case arg arg_id res_ty [Alt DEFAULT [] (App fun (Var arg_id))]        -- mkDefaultCase looks attractive here, and would be sound.@@ -231,7 +244,10 @@         -- expression that uses mkWildValBinder, of which there are not         -- many), and pass a fragment of it as the fun part of a 'mkStrictApp'. -mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr+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)@@ -291,12 +307,17 @@ mkWordExpr platform w = mkCoreConApps wordDataCon [mkWordLit platform w]  -- | Create a 'CoreExpr' which will evaluate to the given @Integer@-mkIntegerExpr  :: Integer -> CoreExpr  -- Result :: Integer-mkIntegerExpr i = Lit (mkLitInteger i)+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  :: Integer -> CoreExpr-mkNaturalExpr i = Lit (mkLitNatural i)+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@@ -313,26 +334,37 @@  -- | 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 -mkStringExpr str = mkStringExprFS (mkFastString str)+mkStringExprFSLookup :: Monad m => (Name -> m Id) -> FastString -> m CoreExpr+mkStringExprFSLookup lookupM str = do+  mk <- getMkStringIds lookupM+  pure (mkStringExprFSWith mk str) -mkStringExprFS = mkStringExprFSWith lookupId+getMkStringIds :: Applicative m => (Name -> m Id) -> m MkStringIds+getMkStringIds lookupM = MkStringIds <$> lookupM unpackCStringName <*> lookupM unpackCStringUtf8Name -mkStringExprFSWith :: Monad m => (Name -> m Id) -> FastString -> m CoreExpr-mkStringExprFSWith lookupM str+data MkStringIds = MkStringIds+  { unpackCStringId     :: !Id+  , unpackCStringUtf8Id :: !Id+  }++mkStringExprFSWith :: MkStringIds -> FastString -> CoreExpr+mkStringExprFSWith ids str   | nullFS str-  = return (mkNilExpr charTy)+  = mkNilExpr charTy    | all safeChar chars-  = do unpack_id <- lookupM unpackCStringName-       return (App (Var unpack_id) lit)+  = let !unpack_id = unpackCStringId ids+    in App (Var unpack_id) lit    | otherwise-  = do unpack_utf8_id <- lookupM unpackCStringUtf8Name-       return (App (Var unpack_utf8_id) lit)+  = let !unpack_utf8_id = unpackCStringUtf8Id ids+    in App (Var unpack_utf8_id) lit    where     chars = unpackFS str@@ -414,7 +446,7 @@ -- Does /not/ flatten one-tuples; see Note [Flattening one-tuples] mkCoreUbxTup :: [Type] -> [CoreExpr] -> CoreExpr mkCoreUbxTup tys exps-  = ASSERT( tys `equalLength` exps)+  = assert (tys `equalLength` exps) $     mkCoreConApps (tupleDataCon Unboxed (length tys))              (map (Type . getRuntimeRep) tys ++ map Type tys ++ exps) @@ -428,8 +460,8 @@ -- Alternative number ("alt") starts from 1. mkCoreUbxSum :: Int -> Int -> [Type] -> CoreExpr -> CoreExpr mkCoreUbxSum arity alt tys exp-  = ASSERT( length tys == arity )-    ASSERT( alt <= arity )+  = assert (length tys == arity) $+    assert (alt <= arity) $     mkCoreConApps (sumDataCon alt arity)                   (map (Type . getRuntimeRep) tys                    ++ map Type tys@@ -537,7 +569,7 @@           -> CoreExpr    -- Scrutinee           -> CoreExpr mkSmallTupleSelector [var] should_be_the_same_var _ scrut-  = ASSERT(var == should_be_the_same_var)+  = 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@@ -545,7 +577,7 @@ -- ^ '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 )+  = assert (notNull vars) $     Case scrut scrut_var (idType the_var)          [Alt (DataAlt (tupleDataCon Boxed (length vars))) vars (Var the_var)] @@ -619,7 +651,7 @@  instance Outputable FloatBind where   ppr (FloatLet b) = text "LET" <+> ppr b-  ppr (FloatCase e b c bs) = hang (text "CASE" <+> ppr e <+> ptext (sLit "of") <+> 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@@ -763,10 +795,6 @@ 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).--@parError@ is a special version of @error@ which the compiler does-not know to be a bottoming Id.  It is used in the @_par_@ and @_seq_@-templates, but we don't ever expect to generate code for it. -}  errorIds :: [Id]@@ -820,73 +848,90 @@  -- 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. It's easy to--- come up with rubbish literal values: we use 0 (ints/words) and 0.0--- (floats/doubles). Coming up with a rubbish pointer value is more delicate:+-- and fields that can't be reached are filled with rubbish values.+-- For instance, consider the case of the program: -----    1. it needs to be a valid closure pointer for the GC (not a NULL pointer)+--     f :: (# Int | Float# #) -> Int+--     f = ... -----    2. it is never used in Core, only in STG; and even then only for filling a---       GC-ptr slot in an unboxed sum (see GHC.Stg.Unarise.ubxSumRubbishArg).---       So all we need is a pointer, and its levity doesn't matter. Hence we---       can safely give it the (lifted) type:+--     x = f (# | 2.0## #) -----             absentSumFieldError :: forall a. a+-- 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: -----       despite the fact that Unarise might instantiate it at non-lifted---       types.+--     x = f (# 2#, ???, 2.0## #) -----    3. it can't take arguments because it's used in unarise and applying an---       argument would require allocating a thunk.+-- 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#. -----    4. it can't be CAFFY because that would mean making some non-CAFFY---       definitions that use unboxed sums CAFFY in unarise. We work around---       this by declaring the absentSumFieldError as non-CAFfy, as described---       in Note [Wired-in exceptions are not CAFfy].+-- However, coming up with a rubbish pointer value is more delicate as the+-- value must satisfy the following requirements: -----       Getting this wrong causes hard-to-debug runtime issues, see #15038.+--    1. it needs to be a valid closure pointer for the GC (not a NULL pointer) -----    5. it can't be defined in `base` package.+--    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. -----       Defining `absentSumFieldError` in `base` package introduces a---       dependency on `base` for any code using unboxed sums. It became an---       issue when we wanted to use unboxed sums in boot libraries used by+--    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: ----- * Most runtime-error functions throw a proper Haskell exception, which can be---   caught in the usual way. But these functions are defined in---   `base:Control.Exception.Base`, hence, they cannot be directly invoked in---   any library compiled before `base`.  Only exceptions that have been wired---   in the RTS can be thrown (indirectly, via a call into the RTS) by libraries---   compiled before `base`.+--    absentSumFieldError :: forall a. a -----   However wiring exceptions in the RTS is a bit annoying because we need to---   explicitly import exception closures via their mangled symbol name (e.g.---   `import CLOSURE base_GHCziIOziException_heapOverflow_closure`) in Cmm files---   and every imported symbol must be indicated to the linker in a few files---   (`package.conf`, `rts.cabal`, `win32/libHSbase.def`, `Prelude.h`...). It---   explains why exceptions are only wired in the RTS when necessary.+-- 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.. ----- * `absentSumFieldError` is defined in ghc-prim:GHC.Prim.Panic, hence, it can---   be invoked in libraries compiled before `base`. It does not throw a Haskell---   exception; instead, it calls `stg_panic#`, which immediately halts---   execution.  A runtime invocation of `absentSumFieldError` indicates a GHC---   bug. Unlike (say) pattern-match errors, it cannot be caused by a user---   error. That's why it is OK for it to be un-catchable.+-- 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] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- mkExceptionId claims that all exceptions are not CAFfy, despite the fact--- that their closures' code may in fact contain CAF references. We get away--- with this lie because the RTS ensures that all exception closures are--- considered live by the GC by creating StablePtrs during initialization.--- The lie is necessary to avoid unduly growing SRTs as these exceptions are--- sufficiently common to warrant special treatment.+-- 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.@@ -941,11 +986,8 @@ mkExceptionId name   = mkVanillaGlobalWithInfo name       (mkSpecForAllTys [alphaTyVar] (mkTyVarTy alphaTyVar)) -- forall a . a-      (vanillaIdInfo `setStrictnessInfo` mkClosedStrictSig [] botDiv-                     `setCprInfo` mkCprSig 0 botCpr-                     `setArityInfo` 0-                     `setCafInfo` NoCafRefs)-                        -- See Note [Wired-in exceptions are not CAFfy]+      (divergingIdInfo [] `setCafInfo` NoCafRefs)+         -- See Note [Wired-in exceptions are not CAFfy]  mkRuntimeErrorId :: Name -> Id -- Error function@@ -955,23 +997,15 @@ -- The Addr# is expected to be the address of --   a UTF8-encoded error string mkRuntimeErrorId name- = mkVanillaGlobalWithInfo name runtimeErrorTy bottoming_info- where-    bottoming_info = vanillaIdInfo `setStrictnessInfo`    strict_sig-                                   `setCprInfo`           mkCprSig 1 botCpr-                                   `setArityInfo`         1-                        -- Make arity and strictness agree--        -- 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.--    strict_sig = mkClosedStrictSig [evalDmd] botDiv+ = mkVanillaGlobalWithInfo name runtimeErrorTy (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.  runtimeErrorTy :: Type -- forall (rr :: RuntimeRep) (a :: rr). Addr# -> a@@ -979,6 +1013,23 @@ runtimeErrorTy = mkSpecForAllTys [runtimeRep1TyVar, openAlphaTyVar]                                  (mkVisFunTyMany addrPrimTy openAlphaTy) +-- | An 'IdInfo' for an Id, such as 'aBSENT_ERROR_ID' or 'raiseOverflow', 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@@ -997,7 +1048,7 @@  Note [aBSENT_ERROR_ID] ~~~~~~~~~~~~~~~~~~~~~~-We use aBSENT_ERROR_ID to build dummy values in workers.  E.g.+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 @@ -1010,9 +1061,16 @@                x = (a,b)            in <the original RHS of f> -After some simplification, the (absentError "blah") thunk goes away.+After some simplification, the (absentError "blah") thunk normally goes away.+See also Note [Absent fillers] in GHC.Core.Opt.WorkWrap.Utils. ------- Tricky wrinkle -------+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@@ -1023,8 +1081,8 @@ 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 INLINEABLE functions] in GHC.Core.Opt.WorkWrap) so the template ends up like+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)@@ -1064,15 +1122,13 @@ be relying on anything from it. -} -aBSENT_ERROR_ID- = mkVanillaGlobalWithInfo absentErrorName absent_ty arity_info+aBSENT_ERROR_ID -- See Note [aBSENT_ERROR_ID]+ = mkVanillaGlobalWithInfo absentErrorName absent_ty id_info  where    absent_ty = mkSpecForAllTys [alphaTyVar] (mkVisFunTyMany addrPrimTy alphaTy)    -- Not runtime-rep polymorphic. aBSENT_ERROR_ID is only used for    -- lifted-type things; see Note [Absent fillers] in GHC.Core.Opt.WorkWrap.Utils-   arity_info = vanillaIdInfo `setArityInfo` 1-   -- NB: no bottoming strictness info, unlike other error-ids.-   -- See Note [aBSENT_ERROR_ID]+   id_info = divergingIdInfo [evalDmd] -- NB: CAFFY!  mkAbsentErrorApp :: Type         -- The type to instantiate 'a'                  -> String       -- The string to print
GHC/Core/Map/Expr.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RankNTypes #-}@@ -17,6 +16,8 @@ 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,@@ -24,8 +25,6 @@    (>.>), (|>), (|>>),  ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Data.TrieMap@@ -143,33 +142,42 @@      }  instance Eq (DeBruijn CoreExpr) where-  D env1 e1 == D env2 e2 = go e1 e2 where-    go (Var v1) (Var v2)-      = case (lookupCME env1 v1, lookupCME env2 v2) of-                            (Just b1, Just b2) -> b1 == b2-                            (Nothing, Nothing) -> v1 == v2-                            _ -> False+    (==) = 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)        = D env1 t1 == D env2 t2-    go (Coercion co1) (Coercion co2) = D env1 co1 == D env2 co2+    -- See Note [Using tcView inside eqDeBruijnType] in GHC.Core.Map.Type+    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-    -- This seems a bit dodgy, see 'eqTickish'-    go (Tick n1 e1)  (Tick n2 e2)  = n1 == n2 && go e1 e2+    go (Tick n1 e1) (Tick n2 e2)+      =  eqDeBruijnTickish (D env1 n1) (D env2 n2)+      && go e1 e2      go (Lam b1 e1)  (Lam b2 e2)-      =  D env1 (varType b1) == D env2 (varType b2)+          -- See Note [Using tcView inside eqDeBruijnType] in GHC.Core.Map.Type+      =  eqDeBruijnType (D env1 (varType b1)) (D env2 (varType b2))       && D env1 (varMultMaybe b1) == D env2 (varMultMaybe b2)-      && D (extendCME env1 b1) e1 == D (extendCME env2 b2) e2+      && 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-      && D (extendCME env1 v1) e1 == D (extendCME env2 v2) 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 -> -- See Note [Using tcView inside eqDeBruijnType] in+                         -- GHC.Core.Map.Type+                         eqDeBruijnType (D env1 (varType b1))+                                        (D env2 (varType b2)))+              bs1 bs2       && D env1' rs1 == D env2' rs2-      && D env1' e1  == D env2' e2+      && eqDeBruijnExpr (D env1' e1) (D env2' e2)       where         (bs1,rs1) = unzip ps1         (bs2,rs2) = unzip ps2@@ -180,9 +188,57 @@       | 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 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
GHC/Core/Map/Type.hs view
@@ -21,7 +21,7 @@    -- * Utilities for use by friends only    TypeMapG, CoercionMapG, -   DeBruijn(..), deBruijnize,+   DeBruijn(..), deBruijnize, eqDeBruijnType, eqDeBruijnVar,     BndrMap, xtBndr, lkBndr,    VarMap, xtVar, lkVar, lkDFreeVar, xtDFreeVar,@@ -182,38 +182,122 @@    filterTM = filterT  instance Eq (DeBruijn Type) where-  env_t@(D env t) == env_t'@(D env' t')-    | Just new_t  <- tcView t  = D env new_t == env_t'-    | Just new_t' <- tcView t' = env_t       == D env' new_t'-    | otherwise-    = case (t, t') of-        (CastTy t1 _, _)  -> D env t1 == D env t'-        (_, CastTy t1' _) -> D env t  == D env t1'+  (==) = eqDeBruijnType -        (TyVarTy v, TyVarTy v')-            -> case (lookupCME env v, lookupCME env' v') of-                (Just bv, Just bv') -> bv == bv'-                (Nothing, Nothing)  -> v == v'-                _ -> False-                -- See Note [Equality on AppTys] in GHC.Core.Type-        (AppTy t1 t2, s) | Just (t1', t2') <- repSplitAppTy_maybe s-            -> D env t1 == D env' t1' && D env t2 == D env' t2'-        (s, AppTy t1' t2') | Just (t1, t2) <- repSplitAppTy_maybe s-            -> D env t1 == D env' t1' && D env t2 == D env' t2'-        (FunTy v1 w1 t1 t2, FunTy v1' w1' t1' t2')-            -> v1 == v1' &&-               D env w1 == D env w1' &&-               D env t1 == D env' t1' &&-               D env t2 == D env' t2'-        (TyConApp tc tys, TyConApp tc' tys')-            -> tc == tc' && D env tys == D env' tys'-        (LitTy l, LitTy l')-            -> l == l'-        (ForAllTy (Bndr tv _) ty, ForAllTy (Bndr tv' _) ty')-            -> D env (varType tv)      == D env' (varType tv') &&-               D (extendCME env tv) ty == D (extendCME env' tv') ty'-        (CoercionTy {}, CoercionTy {})-            -> True+{- Note [Using tcView inside eqDeBruijnType]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+`eqDeBruijnType` uses `tcView` and thus treats Type and Constraint as+distinct -- see Note [coreView vs tcView] in GHC.Core.Type. We do that because+`eqDeBruijnType` is used in TrieMaps, which are used for instance for instance+selection in the type checker. [Or at least will be soon.]++However, the odds that we have two expressions that are identical save for the+'Type'/'Constraint' distinction are low. (Not impossible to do. But doubtful+anyone has ever done so in the history of Haskell.)++And it's actually all OK: 'eqExpr' is conservative: if `eqExpr e1 e2` returns+'True', thne it must be that `e1` behaves identically to `e2` in all contexts.+But if `eqExpr e1 e2` returns 'False', then we learn nothing. The use of+'tcView' where we expect 'coreView' means 'eqExpr' returns 'False' bit more+often that it should. This might, say, stop a `RULE` from firing or CSE from+optimizing an expression. Stopping `RULE` firing is good actually: `RULES` are+written in Haskell, where `Type /= Constraint`. Stopping CSE is unfortunate,+but tolerable.+-}++-- | 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 nullary type synonyms] in GHC.Core.Type+    go (D _ (TyConApp tc1 [])) (D _ (TyConApp tc2 []))+      | tc1 == tc2+      = TEQ+    go env_t@(D env t) env_t'@(D env' t')+      -- See Note [Using tcView inside eqDeBruijnType]+      | Just new_t  <- tcView t  = go (D env new_t) env_t'+      | Just new_t' <- tcView 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') <- repSplitAppTy_maybe s+              -> go (D env t1) (D env' t1') `andEq` go (D env t2) (D env' t2')+          (s, AppTy t1' t2') | Just (t1, t2) <- repSplitAppTy_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 typechecker equality] in+                 -- GHC.Tc.Solver.Canonical for why we use `sameVis` here+                 liftEquality (vis `sameVis` 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++    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 #-}
GHC/Core/Multiplicity.hs view
@@ -145,7 +145,7 @@ 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+    \(x % Many) -> 0  However, we cannot replace absence with Many when computing usages compositionally: in@@ -219,7 +219,7 @@  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]).+[Linear types]).  Note [Polymorphisation of linear fields] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -237,9 +237,7 @@ 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:+polymorphism. Instead, we generalise the type of Just, when used as term:     Just :: forall {p}. a %p-> Just a @@ -254,7 +252,8 @@ other multiplicity expressions are exclusive to -XLinearTypes, hence don't have backward compatibility implications. -The implementation is described in Note [Linear fields generalization].+The implementation is described in Note [Typechecking data constructors]+in GHC.Tc.Gen.Head.  More details in the proposal. -}@@ -290,7 +289,7 @@ 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 sumands and factors are ordered somehow, to have more equalities.+that the summands and factors are ordered somehow, to have more equalities. -}  -- With only two multiplicities One and Many, we can always replace
GHC/Core/Opt/Arity.hs view
@@ -7,7 +7,6 @@ -}  {-# LANGUAGE CPP #-}- {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}  -- | Arity and eta expansion@@ -18,7 +17,7 @@    , exprBotStrictness_maybe     -- ** ArityType-   , ArityType(..), mkBotArityType, mkManifestArityType, expandableArityType+   , ArityType(..), mkBotArityType, mkTopArityType, expandableArityType    , arityTypeArity, maxWithArity, idArityType     -- ** Join points@@ -30,19 +29,18 @@    ) where -#include "HsVersions.h"- import GHC.Prelude -import GHC.Driver.Ppr+import GHC.Driver.Session ( DynFlags, GeneralFlag(..), gopt )  import GHC.Core import GHC.Core.FVs import GHC.Core.Utils-import GHC.Types.Demand-import GHC.Types.Var-import GHC.Types.Var.Env-import GHC.Types.Id+import GHC.Core.DataCon+import GHC.Core.TyCon     ( tyConArity )+import GHC.Core.TyCon.RecWalk     ( initRecTc, checkRecTc )+import GHC.Core.Predicate ( isDictTy, isCallStackPredTy )+import GHC.Core.Multiplicity  -- We have two sorts of substitution: --   GHC.Core.Subst.Subst, and GHC.Core.TyCo.TCvSubst@@ -51,19 +49,23 @@ import GHC.Core.Type     as Type import GHC.Core.Coercion as Type -import GHC.Core.DataCon-import GHC.Core.TyCon     ( tyConArity )-import GHC.Core.TyCon.RecWalk     ( initRecTc, checkRecTc )-import GHC.Core.Predicate ( isDictTy )-import GHC.Core.Multiplicity+import GHC.Types.Demand+import GHC.Types.Var+import GHC.Types.Var.Env+import GHC.Types.Id+import GHC.Types.Var.Set import GHC.Types.Basic import GHC.Types.Tickish+ import GHC.Builtin.Uniques-import GHC.Driver.Session ( DynFlags, GeneralFlag(..), gopt )-import GHC.Utils.Outputable-import GHC.Utils.Panic import GHC.Data.FastString import GHC.Data.Pair++import GHC.Utils.Constants (debugIsOn)+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Utils.Panic.Plain+import GHC.Utils.Trace import GHC.Utils.Misc  {-@@ -125,7 +127,7 @@                  | otherwise       = go e     go (Tick t e) | not (tickishIsCode t) = go e     go (Cast e co)                 = trim_arity (go e) (coercionRKind co)-                                        -- Note [exprArity invariant]+                                        -- See Note [exprArity invariant]     go (App e (Type _))            = go e     go (App f a) | exprIsTrivial a = (go f - 1) `max` 0         -- See Note [exprArity for applications]@@ -153,7 +155,7 @@        | Just (tc,tys) <- splitTyConApp_maybe ty       , Just (ty', _) <- instNewTyCon_maybe tc tys-      , Just rec_nts' <- checkRecTc rec_nts tc  -- See Note [Expanding newtypes]+      , 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]@@ -170,7 +172,7 @@       = []  ----------------exprBotStrictness_maybe :: CoreExpr -> Maybe (Arity, StrictSig)+exprBotStrictness_maybe :: CoreExpr -> Maybe (Arity, DmdSig) -- A cheap and cheerful function that identifies bottoming functions -- and gives them a suitable strictness signatures.  It's used during -- float-out@@ -179,7 +181,7 @@         Nothing -> Nothing         Just ar -> Just (ar, sig ar)   where-    sig ar = mkClosedStrictSig (replicate ar topDmd) botDiv+    sig ar = mkClosedDmdSig (replicate ar topDmd) botDiv  {- Note [exprArity invariant]@@ -531,8 +533,7 @@ -- 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]+-- Why the strange Top element? See Note [Combining case branches]. -- -- We rely on this lattice structure for fixed-point iteration in -- 'findRhsArity'. For the semantics of 'ArityType', see Note [ArityType].@@ -579,16 +580,11 @@ botArityType :: ArityType botArityType = mkBotArityType [] -mkManifestArityType :: [Var] -> CoreExpr -> ArityType-mkManifestArityType bndrs body-  = AT oss div-  where-    oss = [idOneShotInfo bndr | bndr <- bndrs, isId bndr]-    div | exprIsDeadEnd body = botDiv-        | otherwise          = topDiv+mkTopArityType :: [OneShotInfo] -> ArityType+mkTopArityType oss = AT oss topDiv  topArityType :: ArityType-topArityType = AT [] topDiv+topArityType = mkTopArityType []  -- | The number of value args for the arity type arityTypeArity :: ArityType -> Arity@@ -596,7 +592,7 @@  -- | True <=> eta-expansion will add at least one lambda expandableArityType :: ArityType -> Bool-expandableArityType at = arityTypeArity at /= 0+expandableArityType at = arityTypeArity at > 0  -- | See Note [Dead ends] in "GHC.Types.Demand". -- Bottom implies a dead end.@@ -628,7 +624,7 @@ exprEtaExpandArity :: DynFlags -> CoreExpr -> ArityType -- exprEtaExpandArity is used when eta expanding --      e  ==>  \xy -> e x y-exprEtaExpandArity dflags e = arityType (findRhsArityEnv dflags) e+exprEtaExpandArity dflags e = arityType (etaExpandArityEnv dflags) e  getBotArity :: ArityType -> Maybe Arity -- Arity of a divergent function@@ -658,11 +654,10 @@       | next_at == cur_at       = cur_at       | otherwise               =          -- Warn if more than 2 iterations. Why 2? See Note [Exciting arity]-         WARN( debugIsOn && n > 2, text "Exciting arity"-                                   $$ nest 2 (-                                        ppr bndr <+> ppr cur_at <+> ppr next_at-                                        $$ ppr rhs) )-         go (n+1) next_at+         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 cur_at @@ -672,6 +667,7 @@       where         env = extendSigEnv (findRhsArityEnv dflags) bndr at + {- Note [Arity analysis] ~~~~~~~~~~~~~~~~~~~~~@@ -712,7 +708,7 @@   by the 'am_sigs' field in 'FindRhsArity', and 'lookupSigEnv' in the Var case   of 'arityType'. -Note [Exciting Arity]+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,@@ -768,7 +764,6 @@   | otherwise                      = takeWhileOneShot at  arityApp :: ArityType -> Bool -> ArityType- -- Processing (fun arg) where at is the ArityType of fun, -- Knock off an argument and behave like 'let' arityApp (AT (_:oss) div) cheap = floatIn cheap (AT oss div)@@ -778,30 +773,16 @@ -- 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-    (os1) `and_lam` (os2)-      = ( 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-  | isDeadEndDiv div1     -- case x of { T -> error; F -> \y.e }-  = at2        -- Note [ABot branches: max arity wins]--  | pedanticBottoms env  -- Note [Combining case branches: andWithTail]-  = AT [] topDiv--  | otherwise  -- case x of { T -> plusInt <expensive>; F -> \y.e }-  = takeWhileOneShot at2    -- We know div1 = topDiv-    -- See Note [Combining case branches: andWithTail]-+andArityType :: ArityType -> ArityType -> ArityType+andArityType (AT (os1:oss1) div1) (AT (os2:oss2) div2)+  | AT oss' div' <- andArityType (AT oss1 div1) (AT oss2 div2)+  = AT ((os1 `bestOneShot` os2) : oss') div' -- See Note [Combining case branches]+andArityType at1@(AT []         div1) at2+  | isDeadEndDiv div1 = at2                  -- Note [ABot branches: max arity wins]+  | otherwise         = at1                  -- See Note [Combining case branches]+andArityType at1                  at2@(AT []         div2)+  | isDeadEndDiv div2 = at1                  -- Note [ABot branches: max arity wins]+  | otherwise         = at2                  -- See Note [Combining case branches]  {- Note [ABot branches: max arity wins] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -812,66 +793,16 @@ 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. -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+Note [Combining case branches]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -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.+Unless we can conclude that **all** branches are safe to eta-expand then we+must pessimisticaly conclude that we can't eta-expand. See #21694 for where this+went wrong.+We can do better in the long run, but for the 9.4/9.2 branches we choose to simply+ignore oneshot annotations for the time being. -Hence the call to `bestOneShot` in `andArityType`. -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; see Note [ABot branches: max arity wins]--* 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.--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.-When combining the branches of the case we have-     T `andAT` \1.T-and we want to get \1.T.-But if the inner lambda wasn't one-shot (\?.T) we don't want to do this.-(We need a usage analysis to justify that.)--So 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.- Note [Arity trimming] ~~~~~~~~~~~~~~~~~~~~~ Consider ((\x y. blah) |> co), where co :: (Int->Int->Int) ~ (Int -> F a) , and@@ -894,6 +825,17 @@  Historical note: long ago, we unconditionally switched to topDiv when we encountered a cast, but that is far too conservative: see #5475++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. -}  ---------------------------@@ -931,21 +873,22 @@   = AE   { ae_mode   :: !AnalysisMode   -- ^ The analysis mode. See 'AnalysisMode'.+  , ae_joins  :: !IdSet+  -- ^ In-scope join points. See Note [Eta-expansion and join points]+  --   INVARIANT: Disjoint with the domain of 'am_sigs' (if present).   }  -- | The @ArityEnv@ used by 'exprBotStrictness_maybe'. Pedantic about bottoms -- and no application is ever considered cheap. botStrictnessArityEnv :: ArityEnv-botStrictnessArityEnv = AE { ae_mode = BotStrictness }+botStrictnessArityEnv = AE { ae_mode = BotStrictness, ae_joins = emptyVarSet } -{- -- | The @ArityEnv@ used by 'exprEtaExpandArity'. etaExpandArityEnv :: DynFlags -> ArityEnv etaExpandArityEnv dflags   = AE { ae_mode  = EtaExpandArity { am_ped_bot = gopt Opt_PedanticBottoms dflags                                    , am_dicts_cheap = gopt Opt_DictsCheap dflags }        , ae_joins = emptyVarSet }--}  -- | The @ArityEnv@ used by 'findRhsArity'. findRhsArityEnv :: DynFlags -> ArityEnv@@ -953,11 +896,7 @@   = AE { ae_mode  = FindRhsArity { am_ped_bot = gopt Opt_PedanticBottoms dflags                                  , am_dicts_cheap = gopt Opt_DictsCheap dflags                                  , am_sigs = emptyVarEnv }-       }--isFindRhsArity :: ArityEnv -> Bool-isFindRhsArity (AE { ae_mode = FindRhsArity {} }) = True-isFindRhsArity _                                  = False+       , ae_joins = emptyVarSet }  -- First some internal functions in snake_case for deleting in certain VarEnvs -- of the ArityType. Don't call these; call delInScope* instead!@@ -976,17 +915,32 @@ del_sig_env_list ids = modifySigEnv (\sigs -> delVarEnvList sigs ids) {-# INLINE del_sig_env_list #-} +del_join_env :: JoinId -> ArityEnv -> ArityEnv -- internal!+del_join_env id env@(AE { ae_joins = joins })+  = env { ae_joins = delVarSet joins id }+{-# INLINE del_join_env #-}++del_join_env_list :: [JoinId] -> ArityEnv -> ArityEnv -- internal!+del_join_env_list ids env@(AE { ae_joins = joins })+  = env { ae_joins = delVarSetList joins ids }+{-# INLINE del_join_env_list #-}+ -- end of internal deletion functions +extendJoinEnv :: ArityEnv -> [JoinId] -> ArityEnv+extendJoinEnv env@(AE { ae_joins = joins }) join_ids+  = del_sig_env_list join_ids+  $ env { ae_joins = joins `extendVarSetList` join_ids }+ extendSigEnv :: ArityEnv -> Id -> ArityType -> ArityEnv extendSigEnv env id ar_ty-  = modifySigEnv (\sigs -> extendVarEnv sigs id ar_ty) env+  = del_join_env id (modifySigEnv (\sigs -> extendVarEnv sigs id ar_ty) env)  delInScope :: ArityEnv -> Id -> ArityEnv-delInScope env id = del_sig_env id env+delInScope env id = del_join_env id $ del_sig_env id env  delInScopeList :: ArityEnv -> [Id] -> ArityEnv-delInScopeList env ids = del_sig_env_list ids env+delInScopeList env ids = del_join_env_list ids $ del_sig_env_list ids env  lookupSigEnv :: ArityEnv -> Id -> Maybe ArityType lookupSigEnv AE{ ae_mode = mode } id = case mode of@@ -1010,7 +964,13 @@   BotStrictness -> False   _             -> cheap_dict || cheap_fun e     where-      cheap_dict = am_dicts_cheap mode && fmap isDictTy mb_ty == Just True+      cheap_dict = case mb_ty of+                     Nothing -> False+                     Just ty -> (am_dicts_cheap mode && isDictTy ty)+                                || isCallStackPredTy ty+        -- See Note [Eta expanding through dictionaries]+        -- See Note [Eta expanding through CallStacks]+       cheap_fun e = case mode of #if __GLASGOW_HASKELL__ <= 900         BotStrictness                -> panic "impossible"@@ -1025,11 +985,8 @@ 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+  Nothing         -> isCheapApp fn n_val_args+  -- @Just at@ means local function with @at@ as current ArityType.   -- Roughly approximate what 'isCheapApp' is doing.   Just (AT oss div)     | isDeadEndDiv div -> True -- See Note [isCheapApp: bottoming functions] in GHC.Core.Utils@@ -1037,10 +994,7 @@     | 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]+arityType :: ArityEnv -> CoreExpr -> ArityType  arityType env (Cast e co)   = minWithArity (arityType env e) co_arity -- See Note [Arity trimming]@@ -1052,13 +1006,12 @@     -- #5441 is a nice demo  arityType env (Var v)+  | v `elemVarSet` ae_joins env+  = botArityType  -- See Note [Eta-expansion and join points]   | Just at <- lookupSigEnv env v -- Local binding   = at   | otherwise-  = ASSERT2( (not (isFindRhsArity env && isJoinId v)) , (ppr v) )-    -- All join-point should be in the ae_sigs-    -- See Note [No free join points in arityType]-    idArityType v+  = idArityType v          -- Lambdas; increase arity arityType env (Lam x e)@@ -1083,8 +1036,8 @@         -- arityType env (Case scrut bndr _ alts)   | exprIsDeadEnd scrut || null alts-  = botArityType    -- Do not eta expand. See Note [Dealing with bottom (1)]-  | not (pedanticBottoms env)  -- See Note [Dealing with bottom (2)]+  = botArityType    -- Do not eta expand. See (1) in Note [Dealing with bottom]+  | not (pedanticBottoms env)  -- See (2) in Note [Dealing with bottom]   , myExprIsCheap env scrut (Just (idType bndr))   = alts_type   | exprOkForSpeculation scrut@@ -1095,11 +1048,32 @@   where     env' = delInScope env bndr     arity_type_alt (Alt _con bndrs rhs) = arityType (delInScopeList env' bndrs) rhs-    alts_type = foldr1 (andArityType env) (map arity_type_alt alts)+    alts_type = foldr1 andArityType (map arity_type_alt alts) +arityType env (Let (NonRec j rhs) body)+  | Just join_arity <- isJoinId_maybe j+  , (_, rhs_body)   <- collectNBinders join_arity rhs+  = -- See Note [Eta-expansion and join points]+    andArityType (arityType env rhs_body)+                 (arityType env' body)+  where+     env' = extendJoinEnv env [j]++arityType env (Let (Rec pairs) body)+  | ((j,_):_) <- pairs+  , isJoinId j+  = -- See Note [Eta-expansion and join points]+    foldr (andArityType . do_one) (arityType env' body) pairs+  where+    env' = extendJoinEnv env (map fst pairs)+    do_one (j,rhs)+      | Just arity <- isJoinId_maybe j+      = arityType env' $ snd $ collectNBinders arity rhs+      | otherwise+      = pprPanic "arityType:joinrec" (ppr pairs)+ arityType env (Let (NonRec b r) e)-  = -- See Note [arityType for let-bindings]-    floatIn cheap_rhs (arityType env' e)+  = floatIn cheap_rhs (arityType env' e)   where     cheap_rhs = myExprIsCheap env r (Just (idType b))     env'      = extendSigEnv env b (arityType env r)@@ -1107,76 +1081,17 @@ arityType env (Let (Rec prs) e)   = floatIn (all is_cheap prs) (arityType env' e)   where+    env'           = delInScopeList env (map fst prs)     is_cheap (b,e) = myExprIsCheap env' e (Just (idType b))-    env'            = foldl extend_rec env prs-    extend_rec :: ArityEnv -> (Id,CoreExpr) -> ArityEnv-    extend_rec env (b,e) = extendSigEnv env b  $-                           mkManifestArityType bndrs body-                         where-                           (bndrs, body) = collectBinders e-      -- We can't call arityType on the RHS, because it might mention-      -- join points bound in this very letrec, and we don't want to-      -- do a fixpoint calculation here.  So we make do with the-      -- manifest arity  arityType env (Tick t e)   | not (tickishIsCode t)     = arityType env e  arityType _ _ = topArityType --{- 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 assesrt in the Var case of arityType.)--BUT the invariant 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 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)+{- Note [Eta-expansion and join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this (#18328)    f x = join j y = case y of                       True -> \a. blah@@ -1189,71 +1104,49 @@ 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.--For /recursive/ bindings it's more difficult, to call arityType,-because we don't have an ArityType to put in the envt for the-recursively bound Ids.  So for non-join-point bindings we satisfy-ourselves with mkManifestArityType.  Typically we'll have eta-expanded-the binding (based on an earlier fixpoint calculation in-findRhsArity), so the manifest arity is good.--But for /recursive join points/ things are not so good.-See Note [Arity type for recursive join bindings]--See Note [Arity type for recursive join bindings]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-  f x = joinrec j 0 = \ a b c -> (a,x,b)-                j n = j (n-1)-        in j 20+lambda.  But currently the join point totally messes all that up,+because (thought of as a vanilla let-binding) the arity pinned on 'j'+is just 1. -Obviously `f` should get arity 4.  But the manifest arity of `j`-is 1.  Remember, we don't eta-expand join points; see-GHC.Core.Opt.Simplify.Utils Note [Do not eta-expand join points].-And the ArityInfo on `j` will be just 1 too; see GHC.Core-Note [Invariants on join points], item (2b).  So using-Note [ArityType for let-bindings] won't work well.+Why don't we eta-expand j?  Because of+Note [Do not eta-expand join points] in GHC.Core.Opt.Simplify.Utils -We could do a fixpoint iteration, but that's a heavy hammer-to use in arityType.  So we take advantage of it being a join-point:+Even if we don't eta-expand j, why is its arity only 1?+See invariant 2b in Note [Invariants on join points] in GHC.Core. -* Extend the ArityEnv to bind each of the recursive binders-  (all join points) to `botArityType`.  This means that any-  jump to the join point will return botArityType, which is-  unit for `andArityType`:-      botAritType `andArityType` at = at-  So it's almost as if those "jump" branches didn't exist.+So we do this: -* In this extended env, find the ArityType of each of the RHS, after-  stripping off the join-point binders.+* Treat the RHS of a join-point binding, /after/ stripping off+  join-arity lambda-binders, as very like the body of the let.+  More precisely, do andArityType with the arityType from the+  body of the let. -* Use andArityType to combine all these RHS ArityTypes.+* Dually, when we come to a /call/ of a join point, just no-op+  by returning ABot, the bottom element of ArityType,+  which so that: bot `andArityType` x = x -* Find the ArityType of the body, also in this strange extended-  environment+* This works if the join point is bound in the expression we are+  taking the arityType of.  But if it's bound further out, it makes+  no sense to say that (say) the arityType of (j False) is ABot.+  Bad things happen.  So we keep track of the in-scope join-point Ids+  in ae_join. -* And combine that into the result with andArityType.+This will make f, above, have arity 2. Then, we'll eta-expand it thus: -In our example, the jump (j 20) will yield Bot, as will the jump-(j (n-1)). We'll 'and' those the ArityType of (\abc. blah).  Good!+  f x eta = (join j y = ... in case x of ...) eta -In effect we are treating the RHSs as alternative bodies (like-in a case), and ignoring all jumps.  In this way we don't need-to take a fixpoint.  Tricky!+and the Simplify will automatically push that application of eta into+the join points. -NB: we treat /non-recursive/ join points in the same way, but-actually it works fine to treat them uniformly with normal-let-bindings, and that takes less code.+An alternative (roughly equivalent) idea would be to carry an+environment mapping let-bound Ids to their ArityType. -}  idArityType :: Id -> ArityType idArityType v-  | strict_sig <- idStrictness v+  | strict_sig <- idDmdSig v   , not $ isTopSig strict_sig-  , (ds, div) <- splitStrictSig strict_sig+  , (ds, div) <- splitDmdSig strict_sig   , let arity = length ds   -- Every strictness signature admits an arity signature!   = AT (take arity one_shots) div@@ -1390,13 +1283,23 @@ -- We should have that: -- -- > ty = exprType e = exprType e'-etaExpand   :: Arity     -> CoreExpr -> CoreExpr-etaExpandAT :: ArityType -> CoreExpr -> CoreExpr -etaExpand   n          orig_expr = eta_expand (replicate n NoOneShotInfo) orig_expr-etaExpandAT (AT oss _) orig_expr = eta_expand oss                         orig_expr-                           -- See Note [Eta expansion with ArityType]+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 -> ArityType -> 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 oss _) orig_expr+  = eta_expand in_scope oss orig_expr+ -- etaExpand arity e = res -- Then 'res' has at least 'arity' lambdas at the top --    possibly with a cast wrapped around the outside@@ -1408,12 +1311,12 @@ -- would return --      (/\b. \y::a -> E b y) -eta_expand :: [OneShotInfo] -> CoreExpr -> CoreExpr-eta_expand one_shots (Cast expr co)-  = mkCast (eta_expand one_shots expr) co+eta_expand :: InScopeSet -> [OneShotInfo] -> CoreExpr -> CoreExpr+eta_expand in_scope one_shots (Cast expr co)+  = Cast (eta_expand in_scope one_shots expr) co -eta_expand one_shots orig_expr-  = go one_shots [] orig_expr+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@@ -1421,20 +1324,20 @@       -- 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 _ [] _ _ = orig_expr  -- Already has the specified arity; no-op -    go oss@(_:oss1) vs (Lam v body)-      | isTyVar v = go oss  (v:vs) body-      | otherwise = go oss1 (v:vs) body+    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 oss rev_vs expr-      = -- pprTrace "ee" (vcat [ppr orig_expr, ppr expr, pprEtaInfos etas]) $-        retick $ etaInfoAbs top_eis $-                 etaInfoApp in_scope' sexpr eis+    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 = mkInScopeSet (exprFreeVars expr)           (in_scope', eis@(EI eta_bndrs mco))-              = mkEtaWW oss (ppr orig_expr) in_scope (exprType expr)+                    = 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) @@ -1477,23 +1380,29 @@ 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-   ty = N (N Int)-then the eta-expansion must look like-        (\x (\y. ((e |> co1) x) |> co2) y)-           |> sym co2)-        |> sym co1+   e :: N (N Int)+then the eta-expansion should look like+   (\(x::S) (y::S) -> e |> co x y) |> sym co where-  co1 :: N (N Int) ~ S -> N Int-  co2 :: N Int     ~ S -> Int+  co :: N (N Int) ~ S -> S -> Int+  co = axN @(N Int) ; (S -> axN @Int) -Blimey!  Look at all those casts.  Moreover, if the type-is very deeply nested (as happens in #18223), the repetition+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++Note [Check for reflexive casts in eta expansion]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It turns out that the casts created by teh 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 a lot in etaEInfoApp, where we+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@@ -1510,23 +1419,56 @@ #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 --- EI bs co--- Abstraction:  (\b1 b2 .. bn. []) |> sym co--- Application:  ([] |> co) b1 b2 .. bn+-- (EI bs co) describes a particular eta-expansion, as follows:+--  Abstraction:  (\b1 b2 .. bn. []) |> sym co+--  Application:  ([] |> co) b1 b2 .. bn -- --    e :: T    co :: T ~ (t1 -> t2 -> .. -> tn -> tr) --    e = (\b1 b2 ... bn. (e |> co) b1 b2 .. bn) |> sym co +instance Outputable EtaInfo where+  ppr (EI vs mco) = text "EI" <+> ppr vs <+> parens (ppr mco) + etaInfoApp :: InScopeSet -> CoreExpr -> EtaInfo -> CoreExpr--- (etaInfoApp s e eis) returns something equivalent to---             (substExpr s e `appliedto` eis)+-- (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@@ -1539,7 +1481,10 @@       = Tick (substTickish subst t) (go subst e eis)      go subst (Cast e co) (EI bs mco)-      = go subst e (EI bs (Core.substCo subst co `mkTransMCoR` 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'@@ -1558,14 +1503,15 @@         (subst', b') = Core.substBindSC subst b      -- Beta-reduction if possible, pushing any intervening casts past-    -- the argument. See Note [The EtaInfo mechansim]+    -- 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` mco+                             `mkCastMCo` checkReflexiveMCo mco                              `mkVarApps` bs  --------------@@ -1634,7 +1580,7 @@         ----------- Function types  (t1 -> t2)        | Just (mult, arg_ty, res_ty) <- splitFunTy_maybe ty-       , not (isTypeLevPoly arg_ty)+       , typeHasFixedRuntimeRep arg_ty           -- See Note [Representation polymorphism invariants] in GHC.Core           -- See also test case typecheck/should_run/EtaExpandLevPoly @@ -1664,8 +1610,8 @@         | otherwise       -- We have an expression of arity > 0,                          -- but its type isn't a function, or a binder-                         -- is representation-polymorphic-       = WARN( True, (ppr orig_oss <+> ppr orig_ty) $$ ppr_orig_expr )+                         -- does not have a fixed runtime representation+       = warnPprTrace True "mkEtaWW" ((ppr orig_oss <+> ppr orig_ty) $$ ppr_orig_expr)          (getTCvInScope subst, EI [] MRefl)         -- This *can* legitimately happen:         -- e.g.  coerce Int (\x. x) Essentially the programmer is@@ -1714,10 +1660,17 @@ -- 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 (Type ty) = do { (ty', m_co') <- pushCoTyArg co ty-                            ; return (Type ty', m_co') }-pushCoArg co val_arg   = do { (arg_co, m_co') <- pushCoValArg co-                            ; return (val_arg `mkCastMCo` arg_co, m_co') }+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@@ -1736,7 +1689,7 @@   = Just (ty, MRefl)    | isForAllTy_ty tyL-  = ASSERT2( isForAllTy_ty tyR, ppr co $$ ppr ty )+  = assertPpr (isForAllTy_ty tyR) (ppr co $$ ppr ty) $     Just (ty `mkCastTy` co1, MCo co2)    | otherwise@@ -1785,7 +1738,7 @@               -- If   co  :: (tyL1 -> tyL2) ~ (tyR1 -> tyR2)               -- then co1 :: tyL1 ~ tyR1               --      co2 :: tyL2 ~ tyR2-  = ASSERT2( isFunTy tyR, ppr co $$ ppr arg )+  = assertPpr (isFunTy tyR) (ppr co $$ ppr arg) $     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@@ -1805,7 +1758,7 @@ -- ===> --    (\x'. e |> co') pushCoercionIntoLambda in_scope x e co-    | ASSERT(not (isTyVar x) && not (isCoVar x)) True+    | assert (not (isTyVar x) && not (isCoVar x)) True     , Pair s1s2 t1t2 <- coercionKind co     , Just (_, _s1,_s2) <- splitFunTy_maybe s1s2     , Just (w1, t1,_t2) <- splitFunTy_maybe t1t2@@ -1820,7 +1773,11 @@           in_scope' = in_scope `extendInScopeSet` x'           subst = extendIdSubst (mkEmptySubst in_scope')                                 x-                                (mkCast (Var x') co1)+                                (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       -- See #21555 / #21577 for a case where this trace fired but the cause was benign@@ -1879,8 +1836,8 @@                          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) ]     in-    ASSERT2( eqType from_ty (mkTyConApp to_tc (map exprToType $ takeList dc_univ_tyvars dc_args)), dump_doc )-    ASSERT2( equalLength val_args arg_tys, dump_doc )+    assertPpr (eqType from_ty (mkTyConApp to_tc (map exprToType $ takeList dc_univ_tyvars dc_args))) dump_doc $+    assertPpr (equalLength val_args arg_tys) dump_doc $     Just (dc, to_tc_arg_tys, to_ex_args ++ new_val_args)    | otherwise@@ -1921,14 +1878,14 @@     go_lam bs b e co       | isTyVar b       , let Pair tyL tyR = coercionKind co-      , ASSERT( isForAllTy_ty tyL )+      , assert (isForAllTy_ty tyL) $         isForAllTy_ty tyR       , isReflCo (mkNthCo Nominal 0 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 )+      , assert (isForAllTy_co tyL) $         isForAllTy_co tyR       , isReflCo (mkNthCo Nominal 0 co)  -- See Note [collectBindersPushingCo]       , let cov = mkCoVarCo b@@ -1936,7 +1893,7 @@        | isId b       , let Pair tyL tyR = coercionKind co-      , ASSERT( isFunTy tyL) isFunTy tyR+      , assert (isFunTy tyL) $ isFunTy tyR       , (co_mult, co_arg, co_res) <- decomposeFunCo Representational co       , isReflCo co_mult -- See Note [collectBindersPushingCo]       , isReflCo co_arg  -- See Note [collectBindersPushingCo]@@ -1949,7 +1906,7 @@ Note [collectBindersPushingCo] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We just look for coercions of form-   <type> # w -> blah+   <type> % w -> blah (and similarly for foralls) to keep this function simple.  We could do more elaborate stuff, but it'd involve substitution etc. @@ -1975,7 +1932,7 @@  etaExpandToJoinPointRule :: JoinArity -> CoreRule -> CoreRule etaExpandToJoinPointRule _ rule@(BuiltinRule {})-  = WARN(True, (sep [text "Can't eta-expand built-in rule:", ppr rule]))+  = 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@@ -2004,11 +1961,8 @@       , let (subst', tv') = substVarBndr subst tv       = go (n-1) res_ty subst' (tv' : rev_bs) (e `App` varToCoreExpr tv')       | Just (mult, arg_ty, res_ty) <- splitFunTy_maybe ty-        -- The varToCoreExpr is important: `tv` might be a coercion variable       , 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-+      = go (n-1) res_ty subst' (b : rev_bs) (e `App` Var b)       | otherwise       = pprPanic "etaBodyForJoinPoint" $ int need_args $$                                          ppr body $$ ppr (exprType body)
GHC/Core/Opt/CSE.hs view
@@ -4,15 +4,13 @@ \section{Common subexpression} -} -{-# LANGUAGE CPP #-} + {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}  module GHC.Core.Opt.CSE (cseProgram, cseOneExpr) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Core.Subst@@ -22,7 +20,7 @@                         , idInlineActivation, setInlineActivation                         , zapIdOccInfo, zapIdUsageInfo, idInlinePragma                         , isJoinId, isJoinId_maybe )-import GHC.Core.Utils   ( mkAltExpr, eqExpr+import GHC.Core.Utils   ( mkAltExpr                         , exprIsTickedString                         , stripTicksE, stripTicksT, mkTicks ) import GHC.Core.FVs     ( exprFreeVars )@@ -32,7 +30,7 @@ import GHC.Types.Basic import GHC.Types.Tickish import GHC.Core.Map.Expr-import GHC.Utils.Misc   ( filterOut, equalLength, debugIsOn )+import GHC.Utils.Misc   ( filterOut, equalLength ) import GHC.Utils.Panic import Data.List        ( mapAccumL ) @@ -714,7 +712,7 @@ cseCase :: CSEnv -> InExpr -> InId -> InType -> [InAlt] -> OutExpr cseCase env scrut bndr ty alts   = Case scrut1 bndr3 ty' $-    combineAlts alt_env (map cse_alt alts)+    combineAlts (map cse_alt alts)   where     ty' = substTy (csEnvSubst env) ty     (cse_done, scrut1) = try_for_cse env scrut@@ -746,20 +744,19 @@         where           (env', args') = addBinders alt_env args -combineAlts :: CSEnv -> [OutAlt] -> [OutAlt]+combineAlts :: [OutAlt] -> [OutAlt] -- See Note [Combine case alternatives]-combineAlts env alts+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)-  = ASSERT2( null bndrs1, ppr alts )+  = assertPpr (null bndrs1) (ppr alts) $     Alt DEFAULT [] rhs1 : filtered_alts    | otherwise   = alts   where-    in_scope = substInScope (csEnvSubst env)      find_bndr_free_alt :: [CoreAlt] -> (Maybe CoreAlt, [CoreAlt])        -- The (Just alt) is a binder-free alt@@ -771,7 +768,7 @@       | otherwise  = case find_bndr_free_alt alts of                        (mb_bf, alts) -> (mb_bf, alt:alts) -    identical_alt rhs1 (Alt _ _ rhs) = eqExpr in_scope rhs1 rhs+    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
GHC/Core/Opt/CallArity.hs view
@@ -13,7 +13,6 @@  import GHC.Types.Var.Set import GHC.Types.Var.Env-import GHC.Driver.Session ( DynFlags )  import GHC.Types.Basic import GHC.Core@@ -100,7 +99,7 @@ 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@@ -116,7 +115,7 @@   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@@ -171,7 +170,7 @@    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].+   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@@ -434,12 +433,12 @@  -- Main entry point -callArityAnalProgram :: DynFlags -> CoreProgram -> CoreProgram-callArityAnalProgram _dflags binds = binds'+callArityAnalProgram :: CoreProgram -> CoreProgram+callArityAnalProgram binds = binds'   where     (_, binds') = callArityTopLvl [] emptyVarSet binds --- See Note [Analysing top-level-binds]+-- See Note [Analysing top-level binds] callArityTopLvl :: [Var] -> VarSet -> [CoreBind] -> (CallArityRes, [CoreBind]) callArityTopLvl exported _ []     = ( calledMultipleTimes $ (emptyUnVarGraph, mkVarEnv $ [(v, 0) | v <- exported])@@ -526,7 +525,7 @@       (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 e+    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@@ -568,7 +567,7 @@     --          (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]+    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 @@ -638,7 +637,7 @@              | 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]+            = 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@@ -706,7 +705,7 @@         | isDeadEndDiv result_info = length demands         | otherwise = a -    (demands, result_info) = splitStrictSig (idStrictness v)+    (demands, result_info) = splitDmdSig (idDmdSig v)  --------------------------------------- -- Functions related to CallArityRes --
GHC/Core/Opt/CallerCC.hs view
@@ -19,7 +19,7 @@ import Data.Maybe  import Control.Applicative-import Control.Monad.Trans.State.Strict+import GHC.Utils.Monad.State.Strict import Data.Either import Control.Monad import qualified Text.ParserCombinators.ReadP as P@@ -80,12 +80,13 @@         ccName :: CcName         ccName = mkFastString $ showSDoc (dflags env) nameDoc     ccIdx <- getCCIndex' ccName-    let span = case revParents env of+    let count = gopt Opt_ProfCountEntries (dflags env)+        span = case revParents env of           top:_ -> nameSrcSpan $ varName top           _     -> noSrcSpan         cc = NormalCC (ExprCC ccIdx) ccName (thisModule env) span         tick :: CoreTickish-        tick = ProfNote cc True True+        tick = ProfNote cc count True     pure $ Tick tick e   | otherwise = pure e doExpr _env e@(Lit _)       = pure e
GHC/Core/Opt/ConstantFold.hs view
@@ -11,3313 +11,3332 @@ -}  {-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE ViewPatterns #-}--{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE -Wno-incomplete-uni-patterns #-}---- | Constant Folder-module GHC.Core.Opt.ConstantFold-   ( primOpRules-   , builtinRules-   , caseRules-   )-where--#include "HsVersions.h"-#include "MachDeps.h"--import GHC.Prelude--import GHC.Driver.Ppr--import {-# SOURCE #-} GHC.Types.Id.Make ( mkPrimOpId, magicDictId, voidPrimId )--import GHC.Core-import GHC.Core.Make-import GHC.Types.Id-import GHC.Types.Literal-import GHC.Core.SimpleOpt (  exprIsConApp_maybe, exprIsLiteral_maybe )-import GHC.Builtin.PrimOps ( PrimOp(..), tagToEnumKey )-import GHC.Builtin.Types-import GHC.Builtin.Types.Prim-import GHC.Core.TyCon-   ( tyConDataCons_maybe, isAlgTyCon, isEnumerationTyCon-   , isNewTyCon, unwrapNewTyCon_maybe, tyConDataCons-   , tyConFamilySize )-import GHC.Core.DataCon ( dataConTagZ, dataConTyCon, dataConWrapId, dataConWorkId )-import GHC.Core.Utils  ( eqExpr, cheapEqExpr, exprIsHNF, exprType-                       , stripTicksTop, stripTicksTopT, mkTicks, stripTicksE )-import GHC.Core.Multiplicity-import GHC.Core.FVs-import GHC.Core.Type-import GHC.Types.Var.Set-import GHC.Types.Var.Env-import GHC.Types.Name.Occurrence ( occNameFS )-import GHC.Types.Tickish-import GHC.Builtin.Names-import GHC.Data.Maybe      ( orElse )-import GHC.Types.Name ( Name, nameOccName )-import GHC.Utils.Outputable-import GHC.Data.FastString-import GHC.Types.Basic-import GHC.Platform-import GHC.Utils.Misc-import GHC.Utils.Panic-import GHC.Core.Coercion   (mkUnbranchedAxInstCo,mkSymCo,Role(..))--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)--{--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 ]-   DataToTagOp -> mkPrimOpRule nm 2 [ 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 ]-   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 ]-   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-                                    , sameArgIdempotentCommut Word8AndOp-                                    ]-   Word8OrOp   -> mkPrimOpRule nm 2 [ binaryLit (word8Op2 (.|.))-                                    , idempotent-                                    , identity zeroW8-                                    , sameArgIdempotentCommut Word8OrOp-                                    ]-   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 LitNumWord (const shiftL) ]-   Word8SrlOp  -> mkPrimOpRule nm 2 [ shiftRule LitNumWord $ 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 ]-   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 ]-   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-                                    , sameArgIdempotentCommut Word16AndOp-                                    ]-   Word16OrOp  -> mkPrimOpRule nm 2 [ binaryLit (word16Op2 (.|.))-                                    , idempotent-                                    , identity zeroW16-                                    , sameArgIdempotentCommut Word16OrOp-                                    ]-   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 LitNumWord (const shiftL) ]-   Word16SrlOp -> mkPrimOpRule nm 2 [ shiftRule LitNumWord $ 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 ]-   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 ]-   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-                                    , sameArgIdempotentCommut Word32AndOp-                                    ]-   Word32OrOp  -> mkPrimOpRule nm 2 [ binaryLit (word32Op2 (.|.))-                                    , idempotent-                                    , identity zeroW32-                                    , sameArgIdempotentCommut Word32OrOp-                                    ]-   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 LitNumWord (const shiftL) ]-   Word32SrlOp -> mkPrimOpRule nm 2 [ shiftRule LitNumWord $ const $ shiftRightLogical @Word32 ]--#if WORD_SIZE_IN_BITS < 64-   -- 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 ]-   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 ]-   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-                                    , sameArgIdempotentCommut Word64AndOp-                                    ]-   Word64OrOp  -> mkPrimOpRule nm 2 [ binaryLit (word64Op2 (.|.))-                                    , idempotent-                                    , identity zeroW64-                                    , sameArgIdempotentCommut Word64OrOp-                                    ]-   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 ]-#endif--   -- 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-                                    ]-   IntQuotOp   -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (intOp2 quot)-                                    , leftZero-                                    , rightIdentityPlatform onei-                                    , equalArgs >> retLit onei ]-   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-                                    , sameArgIdempotentCommut IntAndOp-                                    ]-   IntOrOp     -> mkPrimOpRule nm 2 [ binaryLit (intOp2 (.|.))-                                    , idempotent-                                    , identityPlatform zeroi-                                    , sameArgIdempotentCommut IntOrOp-                                    ]-   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 ]-   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-                                    , sameArgIdempotentCommut WordAndOp-                                    ]-   WordOrOp    -> mkPrimOpRule nm 2 [ binaryLit (wordOp2 (.|.))-                                    , idempotent-                                    , identityPlatform zerow-                                    , sameArgIdempotentCommut WordOrOp-                                    ]-   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 ]--   -- coercions--   Int8ToIntOp    -> mkPrimOpRule nm 1 [ liftLitPlatform convertToIntLit ]-   Int16ToIntOp   -> mkPrimOpRule nm 1 [ liftLitPlatform convertToIntLit ]-   Int32ToIntOp   -> mkPrimOpRule nm 1 [ liftLitPlatform convertToIntLit ]-#if WORD_SIZE_IN_BITS < 64-   Int64ToIntOp   -> mkPrimOpRule nm 1 [ liftLitPlatform convertToIntLit ]-#endif-   IntToInt8Op    -> mkPrimOpRule nm 1 [ liftLit narrowInt8Lit-                                       , semiInversePrimOp Int8ToIntOp-                                       , narrowSubsumesAnd IntAndOp IntToInt8Op 8 ]-   IntToInt16Op   -> mkPrimOpRule nm 1 [ liftLit narrowInt16Lit-                                       , semiInversePrimOp Int16ToIntOp-                                       , narrowSubsumesAnd IntAndOp IntToInt16Op 16 ]-   IntToInt32Op   -> mkPrimOpRule nm 1 [ liftLit narrowInt32Lit-                                       , semiInversePrimOp Int32ToIntOp-                                       , narrowSubsumesAnd IntAndOp IntToInt32Op 32 ]-#if WORD_SIZE_IN_BITS < 64-   IntToInt64Op   -> mkPrimOpRule nm 1 [ liftLit narrowInt64Lit ]-#endif--   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-                                       ]-#if WORD_SIZE_IN_BITS < 64-   Word64ToWordOp -> mkPrimOpRule nm 1 [ liftLitPlatform convertToWordLit ]-#endif--   WordToWord8Op  -> mkPrimOpRule nm 1 [ liftLit narrowWord8Lit-                                       , semiInversePrimOp Word8ToWordOp-                                       , narrowSubsumesAnd WordAndOp WordToWord8Op 8 ]-   WordToWord16Op -> mkPrimOpRule nm 1 [ liftLit narrowWord16Lit-                                       , semiInversePrimOp Word16ToWordOp-                                       , narrowSubsumesAnd WordAndOp WordToWord16Op 16 ]-   WordToWord32Op -> mkPrimOpRule nm 1 [ liftLit narrowWord32Lit-                                       , semiInversePrimOp Word32ToWordOp-                                       , narrowSubsumesAnd WordAndOp WordToWord32Op 32 ]-#if WORD_SIZE_IN_BITS < 64-   WordToWord64Op -> mkPrimOpRule nm 1 [ liftLit narrowWord64Lit ]-#endif--   Word8ToInt8Op  -> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumInt8)-                                       , semiInversePrimOp Int8ToWord8Op ]-   Int8ToWord8Op  -> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumWord8)-                                       , semiInversePrimOp Word8ToInt8Op ]-   Word16ToInt16Op-> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumInt16)-                                       , semiInversePrimOp Int16ToWord16Op ]-   Int16ToWord16Op-> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumWord16)-                                       , semiInversePrimOp Word16ToInt16Op ]-   Word32ToInt32Op-> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumInt32)-                                       , semiInversePrimOp Int32ToWord32Op ]-   Int32ToWord32Op-> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumWord32)-                                       , semiInversePrimOp Word32ToInt32Op ]-#if WORD_SIZE_IN_BITS < 64-   Word64ToInt64Op-> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumInt64)-                                       , semiInversePrimOp Int64ToWord64Op ]-   Int64ToWord64Op-> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumWord64)-                                       , semiInversePrimOp Word64ToInt64Op ]-#endif--   WordToIntOp    -> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumInt)-                                       , semiInversePrimOp IntToWordOp ]-   IntToWordOp    -> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumWord)-                                       , semiInversePrimOp WordToIntOp ]--   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 ]--   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  ]-             -- 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  ]-              -- 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--   IntEqOp    -> mkRelOpRule nm (==) [ litEq True ]-   IntNeOp    -> mkRelOpRule nm (/=) [ litEq False ]-   CharEqOp   -> mkRelOpRule nm (==) [ litEq True ]-   CharNeOp   -> mkRelOpRule nm (/=) [ litEq False ]--   IntGtOp    -> mkRelOpRule nm (>)  [ boundsCmp Gt ]-   IntGeOp    -> mkRelOpRule nm (>=) [ boundsCmp Ge ]-   IntLeOp    -> mkRelOpRule nm (<=) [ boundsCmp Le ]-   IntLtOp    -> 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 (<)-   FloatEqOp  -> mkFloatingRelOpRule nm (==)-   FloatNeOp  -> mkFloatingRelOpRule nm (/=)--   DoubleGtOp -> mkFloatingRelOpRule nm (>)-   DoubleGeOp -> mkFloatingRelOpRule nm (>=)-   DoubleLeOp -> mkFloatingRelOpRule nm (<=)-   DoubleLtOp -> mkFloatingRelOpRule nm (<)-   DoubleEqOp -> mkFloatingRelOpRule nm (==)-   DoubleNeOp -> mkFloatingRelOpRule nm (/=)--   WordGtOp   -> mkRelOpRule nm (>)  [ boundsCmp Gt ]-   WordGeOp   -> mkRelOpRule nm (>=) [ boundsCmp Ge ]-   WordLeOp   -> mkRelOpRule nm (<=) [ boundsCmp Le ]-   WordLtOp   -> mkRelOpRule nm (<)  [ boundsCmp Lt ]-   WordEqOp   -> mkRelOpRule nm (==) [ litEq True ]-   WordNeOp   -> mkRelOpRule nm (/=) [ litEq False ]--   AddrAddOp  -> mkPrimOpRule nm 2 [ rightIdentityPlatform zeroi ]--   SeqOp      -> mkPrimOpRule nm 4 [ seqRule ]-   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--#if WORD_SIZE_IN_BITS < 64-zeroI64, oneI64, zeroW64, oneW64 :: Literal-zeroI64 = mkLitInt64  0-oneI64  = mkLitInt64  1-zeroW64 = mkLitWord64 0-oneW64  = mkLitWord64 1-#endif--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--#if WORD_SIZE_IN_BITS < 64-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-#endif--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-                 let ty = literalType lit-                 return $ mkCoreUbxTup [ty, ty] [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--#if WORD_SIZE_IN_BITS < 64-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-#endif--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 $ mkCoreUbxTup [intPrimTy, intPrimTy]-                        [ 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 $ mkCoreUbxTup [iNT64Ty, intPrimTy]-                        [ Lit (mkLitINT64 (toInteger m))-                        , mkIntVal platform (toInteger e) ]-  where-    platform = roPlatform env-    (iNT64Ty, mkLitINT64)-      | platformWordSizeInBits platform < 64-      = (int64PrimTy, mkLitInt64Wrap)-      | otherwise-      = (intPrimTy  , mkLitIntWrap platform)-doubleDecodeOp _   _-  = Nothing-----------------------------{- 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 (mkPair [Lit lit, Lit c])-  where-    mkPair = mkCoreUbxTup [intPrimTy, intPrimTy]-    (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 (mkPair [Lit lit, Lit c])-  where-    mkPair = mkCoreUbxTup [wordPrimTy, intPrimTy]-    (lit, b) = mkLitWordWrapC platform result-    c = if b then onei platform else zeroi platform--#if WORD_SIZE_IN_BITS < 64-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)-#endif----- | 'ambiant (primop x) = x', but not nececesarily '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 (mkPrimOpId 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 (mkPrimOpId 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 (mkPrimOpId 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-  let is_op = \case-        BinOpApp v op' e | op == op' -> Just (v,e)-        _                            -> Nothing-  [a,b] <- getArgs-  case (a,b) of-    (is_op -> Just (e1,e2), e3)-      | cheapEqExpr e2 e3 -> return a-      | cheapEqExpr e1 e3 -> return a-    (e3, is_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/app-invariant (see Note [Core let/app invariant] in GHC.Core) as noted in #16742.-For the reasons discussed in Note [Checking versus non-checking primops] (in-the PrimOp module) there is no safe way rewrite the argument of I# such that-it bottoms.--Consequently we instead take advantage of the fact that large shifts are-undefined behavior (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--getRuleOpts :: RuleM RuleOpts-getRuleOpts = RuleM $ \rule_opts _ _ _ -> Just rule_opts--getEnv :: RuleM InScopeEnv-getEnv = RuleM $ \_ env _ _ -> Just env--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--exprIsVarApp_maybe :: InScopeEnv -> CoreExpr -> Maybe (Id,CoreArg)-exprIsVarApp_maybe env@(_, id_unf) e = case e of-  App (Var f) a -> Just (f, a)-  Var v-    | Just rhs <- expandUnfolding_maybe (id_unf v)-    -> exprIsVarApp_maybe env rhs-  _ -> Nothing---- | Looks into the expression or its unfolding to find "App (Var f) x"-isVarApp :: InScopeEnv -> CoreExpr -> RuleM (Id,CoreArg)-isVarApp env e = case exprIsVarApp_maybe env e of-  Nothing -> mzero-  Just r  -> pure r--isLiteral :: CoreExpr -> RuleM Literal-isLiteral e = do-    env <- getInScopeEnv-    case exprIsLiteral_maybe env e of-        Nothing -> mzero-        Just l  -> pure l--isNumberLiteral :: CoreExpr -> RuleM Integer-isNumberLiteral e = isLiteral e >>= \case-  LitNumber _ x -> pure x-  _             -> mzero--isIntegerLiteral :: CoreExpr -> RuleM Integer-isIntegerLiteral e = isLiteral e >>= \case-  LitNumber LitNumInteger x -> pure x-  _                         -> mzero--isNaturalLiteral :: CoreExpr -> RuleM Integer-isNaturalLiteral e = isLiteral e >>= \case-  LitNumber LitNumNatural x -> pure x-  _                         -> mzero--isWordLiteral :: CoreExpr -> RuleM Integer-isWordLiteral e = isLiteral e >>= \case-  LitNumber LitNumWord x -> pure x-  _                      -> mzero--isIntLiteral :: CoreExpr -> RuleM Integer-isIntLiteral e = isLiteral e >>= \case-  LitNumber LitNumInt x -> pure x-  _                     -> 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 (mkCoreUbxTup [exprType e2, intPrimTy] [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 (mkCoreUbxTup [exprType e1, intPrimTy] [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---- 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 (mkPrimOpId 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.--}--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-      (dc:rest) <- return $ filter correct_tag (tyConDataCons_maybe tycon `orElse` [])-      ASSERT(null rest) return ()-      return $ mkTyApps (Var (dataConWorkId dc)) tc_args--    -- See Note [tagToEnum#]-    _ -> WARN( True, text "tagToEnum# on non-enumeration type" <+> ppr ty )-         return $ mkRuntimeErrorApp rUNTIME_ERROR_ID ty "tagToEnum# on non-enumeration type"---------------------------------dataToTagRule :: RuleM CoreExpr--- See Note [dataToTag#] in primops.txt.pp-dataToTagRule = a `mplus` b-  where-    -- dataToTag (tagToEnum x)   ==>   x-    a = do-      [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-      dflags <- getPlatform-      [_, val_arg] <- getArgs-      in_scope <- getInScopeEnv-      (_,floats, dc,_,_) <- liftMaybe $ exprIsConApp_maybe in_scope val_arg-      ASSERT( not (isNewTyCon (dataConTyCon dc)) ) return ()-      return $ wrapFloats floats (mkIntVal dflags (toInteger (dataConTagZ dc)))--{- Note [dataToTag# magic]-~~~~~~~~~~~~~~~~~~~~~~~~~~-The primop dataToTag# is unusual because it evaluates its argument.-Only `SeqOp` shares that property.  (Other primops do not do anything-as fancy as argument evaluation.)  The special handling for dataToTag#-is:--* GHC.Core.Utils.exprOkForSpeculation has a special case for DataToTagOp,-  (actually in app_ok).  Most primops with lifted arguments do not-  evaluate those arguments, but DataToTagOp and SeqOp are two-  exceptions.  We say that they are /never/ ok-for-speculation,-  regardless of the evaluated-ness of their argument.-  See GHC.Core.Utils Note [exprOkForSpeculation and SeqOp/DataToTagOp]--* There is a special case for DataToTagOp in GHC.StgToCmm.Expr.cgExpr,-  that evaluates its argument and then extracts the tag from-  the returned value.--* An application like (dataToTag# (Just x)) is optimised by-  dataToTagRule in GHC.Core.Opt.ConstantFold.--* A case expression like-     case (dataToTag# e) of <alts>-  gets transformed t-     case e of <transformed alts>-  by GHC.Core.Opt.ConstantFold.caseRules; see Note [caseRules for dataToTag]--See #15696 for a long saga.--}--{- *********************************************************************-*                                                                      *-             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:_)  = tyConDataCons tc  -- data con: UnsafeRefl-             -- UnsafeRefl :: forall (r :: RuntimeRep) (a :: TYPE r).-             --               UnsafeEquality r a a-       ; return (mkTyApps (Var (dataConWrapId dc)) [rep, t1]) }---{- *********************************************************************-*                                                                      *-             Rules for seq# and spark#-*                                                                      *-********************************************************************* -}--{- Note [seq# magic]-~~~~~~~~~~~~~~~~~~~~-The primop-   seq# :: forall a s . a -> State# s -> (# State# s, a #)--is /not/ the same as the Prelude function seq :: a -> b -> b-as you can see from its type.  In fact, seq# is the implementation-mechanism for 'evaluate'--   evaluate :: a -> IO a-   evaluate a = IO $ \s -> seq# a s--The semantics of seq# is-  * evaluate its first argument-  * and return it--Things to note--* Why do we need a primop at all?  That is, instead of-      case seq# x s of (# x, s #) -> blah-  why not instead say this?-      case x of { DEFAULT -> blah)--  Reason (see #5129): if we saw-    catch# (\s -> case x of { DEFAULT -> raiseIO# exn s }) handler--  then we'd drop the 'case x' because the body of the case is bottom-  anyway. But we don't want to do that; the whole /point/ of-  seq#/evaluate is to evaluate 'x' first in the IO monad.--  In short, we /always/ evaluate the first argument and never-  just discard it.--* Why return the value?  So that we can control sharing of seq'd-  values: in-     let x = e in x `seq` ... x ...-  We don't want to inline x, so better to represent it as-       let x = e in case seq# x RW of (# _, x' #) -> ... x' ...-  also it matches the type of rseq in the Eval monad.--Implementing seq#.  The compiler has magic for SeqOp in--- GHC.Core.Opt.ConstantFold.seqRule: eliminate (seq# <whnf> s)--- GHC.StgToCmm.Expr.cgExpr, and cgCase: special case for seq#--- GHC.Core.Utils.exprOkForSpeculation;-  see Note [exprOkForSpeculation and SeqOp/DataToTagOp] in GHC.Core.Utils--- Simplify.addEvals records evaluated-ness for the result; see-  Note [Adding evaluatedness info to pattern-bound variables]-  in GHC.Core.Opt.Simplify--}--seqRule :: RuleM CoreExpr-seqRule = do-  [Type ty_a, Type _ty_s, a, s] <- getArgs-  guard $ exprIsHNF a-  return $ mkCoreUbxTup [exprType s, ty_a] [s, a]---- spark# :: forall a s . a -> State# s -> (# State# s, a #)-sparkRule :: RuleM CoreExpr-sparkRule = seqRule -- reduce on HNF, just the same-  -- 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 "AppendLitString",-                   ru_fn = unpackCStringFoldrName,-                   ru_nargs = 4, ru_try = match_append_lit_C },-     BuiltinRule { ru_name = fsLit "AppendLitStringUtf8",-                   ru_fn = unpackCStringFoldrUtf8Name,-                   ru_nargs = 4, ru_try = match_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 },-     BuiltinRule { ru_name = fsLit "MagicDict", ru_fn = idName magicDictId,-                   ru_nargs = 4, ru_try = \_ _ _ -> match_magicDict },--     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 (mkPrimOpId 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 (mkPrimOpId 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--  , lit_to_natural  "Word# -> Natural"         naturalNSName-  , natural_to_word "Natural -> Word# (wrap)"  naturalToWordName      False-  , natural_to_word "Natural -> Word# (clamp)" naturalToWordClampName True--    -- comparisons (return an unlifted Int#)-  , integer_cmp "integerEq#" integerEqName (==)-  , integer_cmp "integerNe#" integerNeName (/=)-  , integer_cmp "integerLe#" integerLeName (<=)-  , integer_cmp "integerGt#" integerGtName (>)-  , integer_cmp "integerLt#" integerLtName (<)-  , integer_cmp "integerGe#" integerGeName (>=)--  , natural_cmp "naturalEq#" naturalEqName (==)-  , natural_cmp "naturalNe#" naturalNeName (/=)-  , natural_cmp "naturalLe#" naturalLeName (<=)-  , natural_cmp "naturalGt#" naturalGtName (>)-  , natural_cmp "naturalLt#" naturalLtName (<)-  , natural_cmp "naturalGe#" naturalGeName (>=)--    -- comparisons (return an Ordering)-  , bignum_compare "integerCompare" integerCompareName-  , bignum_compare "naturalCompare" naturalCompareName--    -- 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 $ mkCoreUbxSum 2 n [unboxedUnitTy,naturalTy] v-        if x < y-            then ret 1 $ Var voidPrimId-            else ret 2 $ Lit (mkLitNatural (x - y))--    -- unary operations-  , bignum_unop "integerNegate"     integerNegateName     mkLitInteger negate-  , bignum_unop "integerAbs"        integerAbsName        mkLitInteger abs-  , bignum_unop "integerSignum"     integerSignumName     mkLitInteger signum-  , bignum_unop "integerComplement" integerComplementName mkLitInteger complement--  , bignum_unop "naturalSignum"     naturalSignumName     mkLitNatural signum--  , mkRule "naturalNegate" naturalNegateName 1 $ do-        [a0] <- getArgs-        x <- isNaturalLiteral a0-        guard (x == 0) -- negate is only valid for (0 :: Natural)-        pure a0--  , bignum_popcount "integerPopCount" integerPopCountName mkLitIntWrap-  , bignum_popcount "naturalPopCount" naturalPopCountName mkLitWordWrap--  -------------------------------------------------------------  -- The following `small_passthough_*` rules are used to optimise conversions-  -- between numeric types by avoiding passing through "small" constructors of-  -- Integer and Natural.-  ---  -- See Note [Optimising conversions between numeric types]-  ----  , small_passthrough_id "Word# -> Natural -> Word#"-      naturalNSName naturalToWordName-  , small_passthrough_id "Word# -> Natural -> Word# (clamp)"-      naturalNSName naturalToWordClampName--  , small_passthrough_id "Int# -> Integer -> Int#"-      integerISName integerToIntName-  , small_passthrough_id "Word# -> Integer -> Word#"-      integerFromWordName integerToWordName-  , small_passthrough_id "Int64# -> Integer -> Int64#"-      integerFromInt64Name integerToInt64Name-  , small_passthrough_id "Word64# -> Integer -> Word64#"-      integerFromWord64Name integerToWord64Name-  , small_passthrough_id "Natural -> Integer -> Natural (wrap)"-      integerFromNaturalName integerToNaturalName-  , small_passthrough_id "Natural -> Integer -> Natural (throw)"-      integerFromNaturalName integerToNaturalThrowName-  , small_passthrough_id "Natural -> Integer -> Natural (clamp)"-      integerFromNaturalName integerToNaturalClampName--  , small_passthrough_app "Int# -> Integer -> Word#"-        integerISName integerToWordName   (mkPrimOpId IntToWordOp)-  , small_passthrough_app "Int# -> Integer -> Float#"-        integerISName integerToFloatName  (mkPrimOpId IntToFloatOp)-  , small_passthrough_app "Int# -> Integer -> Double#"-        integerISName integerToDoubleName (mkPrimOpId IntToDoubleOp)--  , small_passthrough_app "Word# -> Integer -> Int#"-        integerFromWordName integerToIntName (mkPrimOpId WordToIntOp)-  , small_passthrough_app "Word# -> Integer -> Float#"-        integerFromWordName integerToFloatName (mkPrimOpId WordToFloatOp)-  , small_passthrough_app "Word# -> Integer -> Double#"-        integerFromWordName integerToDoubleName (mkPrimOpId WordToDoubleOp)-  , small_passthrough_app "Word# -> Integer -> Natural (wrap)"-        integerFromWordName integerToNaturalName naturalNSId-  , small_passthrough_app "Word# -> Integer -> Natural (throw)"-        integerFromWordName integerToNaturalThrowName naturalNSId-  , small_passthrough_app "Word# -> Integer -> Natural (clamp)"-        integerFromWordName integerToNaturalClampName naturalNSId--  , small_passthrough_app "Word# -> Natural -> Float#"-        naturalNSName naturalToFloatName  (mkPrimOpId WordToFloatOp)-  , small_passthrough_app "Word# -> Natural -> Double#"-        naturalNSName naturalToDoubleName (mkPrimOpId WordToDoubleOp)--#if WORD_SIZE_IN_BITS < 64-  , small_passthrough_id "Int64# -> Integer -> Int64#"-      integerFromInt64Name integerToInt64Name-  , small_passthrough_id "Word64# -> Integer -> Word64#"-      integerFromWord64Name integerToWord64Name--  , small_passthrough_app "Int64# -> Integer -> Word64#"-        integerFromInt64Name integerToWord64Name   (mkPrimOpId Int64ToWord64Op)-  , small_passthrough_app "Word64# -> Integer -> Int64#"-        integerFromWord64Name integerToInt64Name   (mkPrimOpId Word64ToInt64Op)--  , small_passthrough_app "Word# -> Integer -> Word64#"-        integerFromWordName integerToWord64Name (mkPrimOpId WordToWord64Op)-  , small_passthrough_app "Word64# -> Integer -> Word#"-        integerFromWord64Name integerToWordName (mkPrimOpId Word64ToWordOp)-  , small_passthrough_app "Int# -> Integer -> Int64#"-        integerISName integerToInt64Name (mkPrimOpId IntToInt64Op)-  , small_passthrough_app "Int64# -> Integer -> Int#"-        integerFromInt64Name integerToIntName (mkPrimOpId Int64ToIntOp)--  , small_passthrough_custom "Int# -> Integer -> Word64#"-        integerISName integerToWord64Name-          (\x -> Var (mkPrimOpId Int64ToWord64Op) `App` (Var (mkPrimOpId IntToInt64Op) `App` x))-  , small_passthrough_custom "Word64# -> Integer -> Int#"-        integerFromWord64Name integerToIntName-          (\x -> Var (mkPrimOpId WordToIntOp) `App` (Var (mkPrimOpId Word64ToWordOp) `App` x))-  , small_passthrough_custom "Word# -> Integer -> Int64#"-        integerFromWordName integerToInt64Name-          (\x -> Var (mkPrimOpId Word64ToInt64Op) `App` (Var (mkPrimOpId WordToWord64Op) `App` x))-  , small_passthrough_custom "Int64# -> Integer -> Word#"-        integerFromInt64Name integerToWordName-          (\x -> Var (mkPrimOpId IntToWordOp) `App` (Var (mkPrimOpId Int64ToIntOp) `App` x))-#endif--    -- Bits.bit-  , bignum_bit "integerBit" integerBitName mkLitInteger-  , bignum_bit "naturalBit" naturalBitName mkLitNatural--    -- Bits.testBit-  , bignum_testbit "integerTestBit" integerTestBitName-  , bignum_testbit "naturalTestBit" naturalTestBitName--    -- Bits.shift-  , bignum_shift "integerShiftL" integerShiftLName shiftL mkLitInteger-  , bignum_shift "integerShiftR" integerShiftRName shiftR mkLitInteger-  , bignum_shift "naturalShiftL" naturalShiftLName shiftL mkLitNatural-  , bignum_shift "naturalShiftR" naturalShiftRName shiftR mkLitNatural--    -- division-  , divop_one  "integerQuot"    integerQuotName    quot    mkLitInteger-  , divop_one  "integerRem"     integerRemName     rem     mkLitInteger-  , divop_one  "integerDiv"     integerDivName     div     mkLitInteger-  , divop_one  "integerMod"     integerModName     mod     mkLitInteger-  , divop_both "integerDivMod"  integerDivModName  divMod  mkLitInteger integerTy-  , divop_both "integerQuotRem" integerQuotRemName quotRem mkLitInteger integerTy--  , divop_one  "naturalQuot"    naturalQuotName    quot    mkLitNatural-  , divop_one  "naturalRem"     naturalRemName     rem     mkLitNatural-  , divop_both "naturalQuotRem" naturalQuotRemName quotRem mkLitNatural naturalTy--    -- 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-    -- The rule is matching against an occurrence of a data constructor in a-    -- Core expression. It must match either its worker name or its wrapper-    -- name, /not/ the DataCon name itself, which is different.-    -- See Note [Data Constructor Naming] in GHC.Core.DataCon and #19892-    ---    -- But data constructor wrappers deliberately inline late; See Note-    -- [Activation for data constructor wrappers] in GHC.Types.Id.Make.-    -- Suppose there is a wrapper and the rule matches on the worker: the-    -- wrapper won't be inlined until rules have finished firing and the rule-    -- will never fire.-    ---    -- Hence the rule must match on the wrapper, if there is one, otherwise on-    -- the worker. That is exactly the dataConWrapId for the data constructor.-    -- The data constructor may or may not have a wrapper, but if not-    -- dataConWrapId will return the worker-    ---    integerISId   = dataConWrapId integerISDataCon-    naturalNSId   = dataConWrapId naturalNSDataCon-    integerISName = idName integerISId-    naturalNSName = idName naturalNSId--    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-      x <- isIntegerLiteral a0-      pure (convert platform x)--    natural_to_word str name clamp = mkRule str name 1 $ do-      [a0] <- getArgs-      n <- isNaturalLiteral a0-      platform <- getPlatform-      if clamp && not (platformInWordRange platform n)-          then pure (Lit (mkLitWord platform (platformMaxWord platform)))-          else pure (Lit (mkLitWordWrap platform n))--    integer_to_natural str name thrw clamp = mkRule str name 1 $ do-      [a0] <- getArgs-      x <- isIntegerLiteral a0-      if | x >= 0    -> pure $ Lit $ mkLitNatural x-         | thrw      -> mzero-         | clamp     -> pure $ Lit $ mkLitNatural 0       -- clamp to 0-         | otherwise -> pure $ Lit $ mkLitNatural (abs x) -- negate/wrap--    lit_to_integer str name = mkRule str name 1 $ do-      [a0] <- getArgs-      isLiteral a0 >>= \case-        -- convert any numeric literal into an Integer literal-        LitNumber _ i -> pure (Lit (mkLitInteger i))-        _             -> mzero--    lit_to_natural str name = mkRule str name 1 $ do-      [a0] <- getArgs-      isLiteral a0 >>= \case-        -- convert any *positive* numeric literal into a Natural literal-        LitNumber _ i | i >= 0 -> pure (Lit (mkLitNatural i))-        _                      -> mzero--    integer_binop str name op = mkRule str name 2 $ do-      [a0,a1] <- getArgs-      x <- isIntegerLiteral a0-      y <- isIntegerLiteral a1-      pure (Lit (mkLitInteger (x `op` y)))--    natural_binop str name op = mkRule str name 2 $ do-      [a0,a1] <- getArgs-      x <- isNaturalLiteral a0-      y <- isNaturalLiteral a1-      pure (Lit (mkLitNatural (x `op` y)))--    natural_sub str name = mkRule str name 2 $ do-      [a0,a1] <- getArgs-      x <- isNaturalLiteral a0-      y <- isNaturalLiteral a1-      guard (x >= y)-      pure (Lit (mkLitNatural (x - y)))--    integer_cmp str name op = mkRule str name 2 $ do-      platform <- getPlatform-      [a0,a1] <- getArgs-      x <- isIntegerLiteral a0-      y <- isIntegerLiteral a1-      pure $ if x `op` y-              then trueValInt platform-              else falseValInt platform--    natural_cmp str name op = mkRule str name 2 $ do-      platform <- getPlatform-      [a0,a1] <- getArgs-      x <- isNaturalLiteral a0-      y <- isNaturalLiteral 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 <- isNumberLiteral a0-      y <- isNumberLiteral 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 <- isNumberLiteral a0-      pure $ Lit (mk_lit (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 <- isNumberLiteral a0-      pure $ Lit (mk_lit platform (fromIntegral (popCount x)))--    small_passthrough_id str from_x to_x =-      small_passthrough_custom str from_x to_x id--    small_passthrough_app str from_x to_y x_to_y =-      small_passthrough_custom str from_x to_y (App (Var x_to_y))--    small_passthrough_custom str from_x to_y x_to_y = mkRule str to_y 1 $ do-      [a0] <- getArgs-      env <- getEnv-      (f,x) <- isVarApp env a0-      guard (idName f == from_x)-      pure $ x_to_y 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 $ Lit (mk_lit (bit (fromIntegral n)))--    bignum_testbit str name = mkRule str name 2 $ do-      [a0,a1] <- getArgs-      platform <- getPlatform-      x <- isNumberLiteral 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 <- isNumberLiteral a0-      n <- isWordLiteral 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)-      pure $ Lit (mk_lit (x `shift_op` fromIntegral n))--    divop_one str name divop mk_lit = mkRule str name 2 $ do-      [a0,a1] <- getArgs-      n <- isNumberLiteral a0-      d <- isNumberLiteral a1-      guard (d /= 0)-      pure $ Lit (mk_lit (n `divop` d))--    divop_both str name divop mk_lit ty = mkRule str name 2 $ do-      [a0,a1] <- getArgs-      n <- isNumberLiteral a0-      d <- isNumberLiteral a1-      guard (d /= 0)-      let (r,s) = n `divop` d-      pure $ mkCoreUbxTup [ty,ty] [Lit (mk_lit r), Lit (mk_lit 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 <- isIntLiteral 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 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_append_lit_C :: RuleFun-match_append_lit_C = match_append_lit unpackCStringFoldrIdKey---- CStringUTF8 version-match_append_lit_utf8 :: RuleFun-match_append_lit_utf8 = match_append_lit unpackCStringFoldrUtf8IdKey--{-# INLINE match_append_lit #-}-match_append_lit :: Unique -> RuleFun-match_append_lit foldVariant _ id_unf _-        [ Type ty1-        , lit1-        , c1-        , e2-        ]-  -- N.B. Ensure that we strip off any ticks (e.g. source notes) from the-  -- `lit` and `c` arguments, lest this may fail to fire when building with-  -- -g3. See #16740.-  | (strTicks, Var unpk `App` Type ty2-                        `App` lit2-                        `App` c2-                        `App` n) <- stripTicksTop tickishFloatable e2-  , unpk `hasKey` foldVariant-  , Just (LitString s1) <- exprIsLiteral_maybe id_unf lit1-  , Just (LitString s2) <- exprIsLiteral_maybe id_unf lit2-  , let freeVars = (mkInScopeSet (exprFreeVars c1 `unionVarSet` exprFreeVars c2))-    in eqExpr freeVars c1 c2-  , (c1Ticks, c1') <- stripTicksTop tickishFloatable c1-  , c2Ticks <- stripTicksTopT tickishFloatable 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_append_lit _ _ _ _ _ = Nothing-------------------------------------------------------- The rule is this:---      eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2)) = s1==s2--- Also  matches unpackCStringUtf8#--match_eq_string :: RuleFun-match_eq_string _ id_unf _-        [Var unpk1 `App` lit1, Var unpk2 `App` lit2]-  | 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 id_unf lit1-  , Just (LitString s2) <- exprIsLiteral_maybe id_unf lit2-  = Just (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 env id_unf _ [lit1]-  | Just (LitString str) <- exprIsLiteral_maybe id_unf 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 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)--  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 : _)-  | (Var f, args1) <- collectArgs e,-    Just unf <- maybeUnfoldingTemplate (realIdUnfolding f)-             -- Ignore the IdUnfoldingFun here!-  = Just (mkApps unf args1)--match_inline _ = Nothing-------------------------------------------------------- See Note [magicDictId magic] in "GHC.Types.Id.Make"--- for a description of what is going on here.-match_magicDict :: [Expr CoreBndr] -> Maybe (Expr CoreBndr)-match_magicDict [Type _, (stripTicksE (const True) -> (Var wrap `App` Type a `App` Type _ `App` f)), x, y ]-  | Just (_, fieldTy, _)  <- splitFunTy_maybe $ dropForAlls $ idType wrap-  , Just (_, dictTy, _)   <- splitFunTy_maybe fieldTy-  , Just dictTc           <- tyConAppTyCon_maybe dictTy-  , Just (_,_,co)         <- unwrapNewTyCon_maybe dictTc-  = Just-  $ f `App` Cast x (mkSymCo (mkUnbranchedAxInstCo Representational co [a] []))-      `App` y--match_magicDict _ = Nothing------------------------------------------------------------- Note [Constant folding through nested expressions]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~------ 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) * simplification---    ops = *, 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-   ASSERT(op == numAdd num_ops) return ()-   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-   ASSERT(op == numSub num_ops) return ()-   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-   ASSERT(op == numMul num_ops) return ()-   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)---addFoldingRules' :: Platform -> CoreExpr -> CoreExpr -> NumOps -> Maybe CoreExpr-addFoldingRules' platform arg1 arg2 num_ops = case (arg1, arg2) of-      -- 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-      -- 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-   -- 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--is_op :: PrimOp -> CoreExpr -> Maybe (Arg CoreBndr, Arg CoreBndr)-is_op op e = case e of- BinOpApp x op' y | op == op' -> Just (x,y)- _                            -> Nothing--is_add, is_sub, is_mul :: NumOps -> CoreExpr -> Maybe (Arg CoreBndr, Arg CoreBndr)-is_add num_ops = is_op (numAdd num_ops)-is_sub num_ops = is_op (numSub num_ops)-is_mul num_ops = is_op (numMul num_ops)---- match addition with a literal (handles commutativity)-is_lit_add :: NumOps -> CoreExpr -> Maybe (Integer, Arg CoreBndr)-is_lit_add num_ops e = case is_add num_ops e of-   Just (L l, x  ) -> Just (l,x)-   Just (x  , L l) -> Just (l,x)-   _               -> Nothing---- match multiplication with a literal (handles commutativity)-is_lit_mul :: NumOps -> CoreExpr -> Maybe (Integer, Arg CoreBndr)-is_lit_mul num_ops e = case is_mul 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 (mkPrimOpId 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-   , numLitType :: !LitNumType -- ^ Literal type-   }---- | Create a numeric literal-mkNumLiteral :: Platform -> NumOps -> Integer -> Literal-mkNumLiteral platform ops i = mkLitNumberWrap platform (numLitType ops) i--int8Ops :: NumOps-int8Ops = NumOps-   { numAdd     = Int8AddOp-   , numSub     = Int8SubOp-   , numMul     = Int8MulOp-   , numLitType = LitNumInt8-   }--word8Ops :: NumOps-word8Ops = NumOps-   { numAdd     = Word8AddOp-   , numSub     = Word8SubOp-   , numMul     = Word8MulOp-   , numLitType = LitNumWord8-   }--int16Ops :: NumOps-int16Ops = NumOps-   { numAdd     = Int16AddOp-   , numSub     = Int16SubOp-   , numMul     = Int16MulOp-   , numLitType = LitNumInt16-   }--word16Ops :: NumOps-word16Ops = NumOps-   { numAdd     = Word16AddOp-   , numSub     = Word16SubOp-   , numMul     = Word16MulOp-   , numLitType = LitNumWord16-   }--int32Ops :: NumOps-int32Ops = NumOps-   { numAdd     = Int32AddOp-   , numSub     = Int32SubOp-   , numMul     = Int32MulOp-   , numLitType = LitNumInt32-   }--word32Ops :: NumOps-word32Ops = NumOps-   { numAdd     = Word32AddOp-   , numSub     = Word32SubOp-   , numMul     = Word32MulOp-   , numLitType = LitNumWord32-   }--#if WORD_SIZE_IN_BITS < 64-int64Ops :: NumOps-int64Ops = NumOps-   { numAdd     = Int64AddOp-   , numSub     = Int64SubOp-   , numMul     = Int64MulOp-   , numLitType = LitNumInt64-   }--word64Ops :: NumOps-word64Ops = NumOps-   { numAdd     = Word64AddOp-   , numSub     = Word64SubOp-   , numMul     = Word64MulOp-   , numLitType = LitNumWord64-   }-#endif--intOps :: NumOps-intOps = NumOps-   { numAdd     = IntAddOp-   , numSub     = IntSubOp-   , numMul     = IntMulOp-   , numLitType = LitNumInt-   }--wordOps :: NumOps-wordOps = NumOps-   { numAdd     = WordAddOp-   , numSub     = WordSubOp-   , numMul     = WordMulOp-   , 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 _ (App (App (Var f) (Type ty)) v)       -- dataToTag x-  | Just DataToTagOp <- isPrimOpId_maybe f-  , Just (tc, _) <- tcSplitTyConApp_maybe ty-  , isAlgTyCon tc-  = Just (v, tx_con_dtt ty-           , \v -> App (App (Var f) (Type ty)) (Var v))--caseRules _ _ = 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 :: Type -> AltCon -> Maybe AltCon-tx_con_dtt _  DEFAULT = Just DEFAULT-tx_con_dtt ty (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-     tc          = tyConAppTyCon ty-     n_data_cons = tyConFamilySize tc-     data_cons   = tyConDataCons tc--tx_con_dtt _ alt = pprPanic "caseRules" (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--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, we deal with turning one branch into DEFAULT in GHC.Core.Opt.Simplify.Utils-(add_default in mkCase3).--Note [caseRules for dataToTag]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-See also Note [dataToTag#] in primpops.txt.pp--We want to transform-  case dataToTag x of-    DEFAULT -> e1-    1# -> e2-into-  case x of-    DEFAULT -> e1-    (:) _ _ -> e2--Note the need for some wildcard binders in-the 'cons' case.--For the time, we only apply this transformation when the type of `x` is a type-headed by a normal tycon. In particular, we do not apply this in the case of a-data family tycon, since that would require carefully applying coercion(s)-between the data family and the data family instance's representation type,-which caseRules isn't currently engineered to handle (#14680).--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.---Note [Optimising conversions between numeric types]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Converting between numeric types is very common in Haskell codes.  Suppose that-we have N inter-convertible numeric types (Word, Word8, Int, Integer, etc.).--- We don't want to have to use one conversion function per pair of types as that-would require N^2 functions: wordToWord8, wordToInt, wordToInteger...--- The following kind of class would allow us to have a single conversion-function at the price of N^2 instances and of the use of MultiParamTypeClasses-extension.--    class Convert a b where-      convert :: a -> b--What we do instead is that we use the Integer type (signed, unbounded) as a-passthrough type to perform every conversion. Hence we only need to define two-functions per numeric type:--  class Integral a where-    toInteger :: a -> Integer--  class Num a where-    fromInteger :: Integer -> a--These classes have a single parameter and can be derived automatically (e.g. for-newtypes). So we don't even have to define 2*N instances.--fromIntegral---------------We can now define a generic conversion function:--  -- in the Prelude-  fromIntegral :: (Integral a, Num b) => a -> b-  fromIntegral = fromInteger . toInteger--The trouble with this approach is that performance might be terrible. E.g.-converting an Int into a Word, which is a no-op at the machine level, becomes-costly when performed via `fromIntegral` because an Integer has to be allocated.--To alleviate this:--- first `fromIntegral` was specialized (SPECIALIZE pragma). However it would-need N^2 pragmas to cover every case and it wouldn't cover user defined numeric-types which don't belong to base.--- while writing this note I discovered that we have a `-fwarn-identities` warning-to detect useless conversions (since 0656c72a8f):--  > fromIntegral (1 :: Int) :: Int--  <interactive>:3:21: warning: [-Widentities]-      Call of fromIntegral :: Int -> Int-        can probably be omitted--- but more importantly, many rules were added (e.g. in e0c787c10f):--    "fromIntegral/Int8->Int8" fromIntegral = id :: Int8 -> Int8-    "fromIntegral/a->Int8"    fromIntegral = \x -> case fromIntegral x of I# x# -> I8# (intToInt8# x#)-    "fromIntegral/Int8->a"    fromIntegral = \(I8# x#) -> fromIntegral (I# x#)--  The idea was to ensure that only cheap conversions ended up being used. E.g.:--      foo :: Int8 --> {- Integer -> -} -> Word8-      foo = fromIntegral--    ====> {Some fromIntegral rule for Int8}--      foo :: Int8 -> {- Int -> Integer -} -> Word8-      foo = fromIntegral . int8ToInt--    ====> {Some fromIntegral rule for Word8}--      foo :: Int8 -> {- Int -> Integer -> Word -} -> Word8-      foo = wordToWord8 . fromIntegral . int8ToInt--    ====> {Some fromIntegral rule for Int/Word}--      foo :: Int8 -> {- Int -> Word -} -> Word8-      foo = wordToWord8 . intToWord . int8ToInt-      -- not passing through Integer anymore!---It worked but there were still some issues with this approach:--1. These rules only work for `fromIntegral`. If we wanted to define our own-   similar function (e.g. using other type-classes), we would also have to redefine-   all the rules to get similar performance.--2. `fromIntegral` had to be marked `NOINLINE [1]`:-    - NOINLINE to allow rules to match-    - [1] to allow inlining in later phases to avoid incurring a function call-      overhead for such a trivial operation--   Users of the function had to be careful because a simple helper without an-   INLINE pragma like:--      toInt :: Integral a => a -> Int-      toInt = fromIntegral--   has the following unfolding:--      toInt = integerToInt . toInteger--   which doesn't mention `fromIntegral` anymore. Hence `fromIntegral` rules-   wouldn't be triggered for any user of `toInt`. For this reason, we also have-   a bunch of rules for bignum primitives such as `integerToInt`.--3. These rewrite rules are tedious to write and error-prone (cf #19345).---For these reasons, it is simpler to only rely on built-in rewrite rules for-bignum primitives. There aren't so many conversion primitives:-  - Natural <-> Word-  - Integer <-> Int/Word/Natural (+ Int64/Word64 on 32-bit arch)--All the built-in "small_passthrough_*" rules are used to avoid passing through-Integer/Natural. We now always inline `fromIntegral`.-+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ViewPatterns #-}++{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE -Wno-incomplete-uni-patterns #-}++-- | Constant Folder+module GHC.Core.Opt.ConstantFold+   ( primOpRules+   , builtinRules+   , caseRules+   )+where++import GHC.Prelude++import GHC.Platform++import GHC.Types.Id.Make ( voidPrimId )+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, exprType+                       , stripTicksTop, stripTicksTopT, mkTicks )+import GHC.Core.Multiplicity+import GHC.Core.Type+import GHC.Core.TyCon+   ( tyConDataCons_maybe, isAlgTyCon, isEnumerationTyCon+   , isNewTyCon, tyConDataCons+   , tyConFamilySize )+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.Data.FastString+import GHC.Data.Maybe      ( orElse )++import GHC.Utils.Outputable+import GHC.Utils.Misc+import GHC.Utils.Panic+import GHC.Utils.Panic.Plain+import GHC.Utils.Trace++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 ]+   DataToTagOp -> mkPrimOpRule nm 2 [ 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 ]+   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 ]+   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 ]+   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 ]+   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 ]+   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 ]+   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 ]+   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 ]+   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 $ mkCoreUbxTup [intPrimTy,intPrimTy,intPrimTy]+                                          [ Lit (if platformInIntRange platform r then zeroi platform else onei platform)+                                          , mkIntLitWrap platform (r `shiftR` platformWordSizeInBits platform)+                                          , mkIntLitWrap platform r+                                          ]++                                    , zeroElem >>= \z ->+                                        pure (mkCoreUbxTup [intPrimTy,intPrimTy,intPrimTy]+                                                           [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 $ mkCoreUbxTup [intPrimTy,intPrimTy,intPrimTy]+                                          [ 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 ]+   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 ]+   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 ]++   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  ]+             -- 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  ]+              -- 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 ]++   SeqOp      -> mkPrimOpRule nm 4 [ seqRule ]+   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+                 let ty = literalType lit+                 return $ mkCoreUbxTup [ty, ty] [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 $ mkCoreUbxTup [intPrimTy, intPrimTy]+                        [ 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 $ mkCoreUbxTup [iNT64Ty, intPrimTy]+                        [ Lit (mkLitINT64 (toInteger m))+                        , mkIntVal platform (toInteger e) ]+  where+    platform = roPlatform env+    (iNT64Ty, mkLitINT64)+      | platformWordSizeInBits platform < 64+      = (int64PrimTy, mkLitInt64Wrap)+      | otherwise+      = (intPrimTy  , mkLitIntWrap platform)+doubleDecodeOp _   _+  = Nothing++--------------------------+{- 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 (mkPair [Lit lit, Lit c])+  where+    mkPair = mkCoreUbxTup [intPrimTy, intPrimTy]+    (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 (mkPair [Lit lit, Lit c])+  where+    mkPair = mkCoreUbxTup [wordPrimTy, intPrimTy]+    (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)+++-- | 'ambiant (primop x) = x', but not nececesarily '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/app+invariant (see Note [Core let/app invariant] in GHC.Core) as noted in #16742.+For the reasons discussed in Note [Checking versus non-checking primops] (in+the PrimOp module) there is no safe way rewrite the argument of I# such that+it bottoms.++Consequently we instead take advantage of the fact that large shifts are+undefined behavior (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 (mkCoreUbxTup [exprType e2, intPrimTy] [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 (mkCoreUbxTup [exprType e1, intPrimTy] [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.+-}++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+      (dc:rest) <- return $ filter correct_tag (tyConDataCons_maybe tycon `orElse` [])+      massert (null rest)+      return $ mkTyApps (Var (dataConWorkId dc)) tc_args++    -- See Note [tagToEnum#]+    _ -> warnPprTrace True "tagToEnum# on non-enumeration type" (ppr ty) $+         return $ mkRuntimeErrorApp rUNTIME_ERROR_ID ty "tagToEnum# on non-enumeration type"++------------------------------+dataToTagRule :: RuleM CoreExpr+-- See Note [dataToTag# magic].+dataToTagRule = a `mplus` b+  where+    -- dataToTag (tagToEnum x)   ==>   x+    a = do+      [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+      dflags <- getPlatform+      [_, val_arg] <- getArgs+      in_scope <- getInScopeEnv+      (_,floats, dc,_,_) <- liftMaybe $ exprIsConApp_maybe in_scope val_arg+      massert (not (isNewTyCon (dataConTyCon dc)))+      return $ wrapFloats floats (mkIntVal dflags (toInteger (dataConTagZ dc)))++{- Note [dataToTag# magic]+~~~~~~~~~~~~~~~~~~~~~~~~~~+The primop dataToTag# is unusual because it evaluates its argument.+Only `SeqOp` shares that property.  (Other primops do not do anything+as fancy as argument evaluation.)  The special handling for dataToTag#+is:++* GHC.Core.Utils.exprOkForSpeculation has a special case for DataToTagOp,+  (actually in app_ok).  Most primops with lifted arguments do not+  evaluate those arguments, but DataToTagOp and SeqOp are two+  exceptions.  We say that they are /never/ ok-for-speculation,+  regardless of the evaluated-ness of their argument.+  See GHC.Core.Utils Note [exprOkForSpeculation and SeqOp/DataToTagOp]++* There is a special case for DataToTagOp in GHC.StgToCmm.Expr.cgExpr,+  that evaluates its argument and then extracts the tag from+  the returned value.++* An application like (dataToTag# (Just x)) is optimised by+  dataToTagRule in GHC.Core.Opt.ConstantFold.++* A case expression like+     case (dataToTag# e) of <alts>+  gets transformed t+     case e of <transformed alts>+  by GHC.Core.Opt.ConstantFold.caseRules; see Note [caseRules for dataToTag]++See #15696 for a long saga.+-}++{- *********************************************************************+*                                                                      *+             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:_)  = tyConDataCons tc  -- data con: UnsafeRefl+             -- UnsafeRefl :: forall (r :: RuntimeRep) (a :: TYPE r).+             --               UnsafeEquality r a a+       ; return (mkTyApps (Var (dataConWrapId dc)) [rep, t1]) }+++{- *********************************************************************+*                                                                      *+             Rules for seq# and spark#+*                                                                      *+********************************************************************* -}++{- Note [seq# magic]+~~~~~~~~~~~~~~~~~~~~+The primop+   seq# :: forall a s . a -> State# s -> (# State# s, a #)++is /not/ the same as the Prelude function seq :: a -> b -> b+as you can see from its type.  In fact, seq# is the implementation+mechanism for 'evaluate'++   evaluate :: a -> IO a+   evaluate a = IO $ \s -> seq# a s++The semantics of seq# is+  * evaluate its first argument+  * and return it++Things to note++* Why do we need a primop at all?  That is, instead of+      case seq# x s of (# x, s #) -> blah+  why not instead say this?+      case x of { DEFAULT -> blah)++  Reason (see #5129): if we saw+    catch# (\s -> case x of { DEFAULT -> raiseIO# exn s }) handler++  then we'd drop the 'case x' because the body of the case is bottom+  anyway. But we don't want to do that; the whole /point/ of+  seq#/evaluate is to evaluate 'x' first in the IO monad.++  In short, we /always/ evaluate the first argument and never+  just discard it.++* Why return the value?  So that we can control sharing of seq'd+  values: in+     let x = e in x `seq` ... x ...+  We don't want to inline x, so better to represent it as+       let x = e in case seq# x RW of (# _, x' #) -> ... x' ...+  also it matches the type of rseq in the Eval monad.++Implementing seq#.  The compiler has magic for SeqOp in++- GHC.Core.Opt.ConstantFold.seqRule: eliminate (seq# <whnf> s)++- GHC.StgToCmm.Expr.cgExpr, and cgCase: special case for seq#++- GHC.Core.Utils.exprOkForSpeculation;+  see Note [exprOkForSpeculation and SeqOp/DataToTagOp] in GHC.Core.Utils++- Simplify.addEvals records evaluated-ness for the result; see+  Note [Adding evaluatedness info to pattern-bound variables]+  in GHC.Core.Opt.Simplify+-}++seqRule :: RuleM CoreExpr+seqRule = do+  [Type ty_a, Type _ty_s, a, s] <- getArgs+  guard $ exprIsHNF a+  return $ mkCoreUbxTup [exprType s, ty_a] [s, a]++-- spark# :: forall a s . a -> State# s -> (# State# s, a #)+sparkRule :: RuleM CoreExpr+sparkRule = seqRule -- reduce on HNF, just the same+  -- 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 $ mkCoreUbxSum 2 n [unboxedUnitTy,naturalTy] v+        platform <- getPlatform+        if x < y+            then ret 1 $ Var voidPrimId+            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 integerTy+  , divop_both "integerQuotRem" integerQuotRemName quotRem mkIntegerExpr integerTy++  , divop_one  "naturalQuot"    naturalQuotName    quot    mkNaturalExpr+  , divop_one  "naturalRem"     naturalRemName     rem     mkNaturalExpr+  , divop_both "naturalQuotRem" naturalQuotRemName quotRem mkNaturalExpr naturalTy++    -- 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 ty = 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 $ mkCoreUbxTup [ty,ty] [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 (_,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)++  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 : _)+  | (Var f, args1) <- collectArgs e,+    Just unf <- maybeUnfoldingTemplate (realIdUnfolding f)+             -- Ignore the IdUnfoldingFun here!+  = Just (mkApps unf args1)++match_inline _ = Nothing++--------------------------------------------------------+-- Note [Constant folding through nested expressions]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- 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)++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` simplications+    -- 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++    _ -> 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` simplications+    -- 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++    _ -> Nothing+    where+      mkL = Lit . mkNumLiteral platform num_ops+      or x y = BinOpApp x (fromJust (numOr 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 :: NumOps -> CoreExpr -> Maybe (Arg CoreBndr, Arg CoreBndr)+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_neg :: NumOps -> CoreExpr -> Maybe (Arg CoreBndr)+is_neg num_ops e = numNeg num_ops >>= \op -> is_op op e++-- 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+   , 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++int8Ops :: NumOps+int8Ops = NumOps+   { numAdd     = Int8AddOp+   , numSub     = Int8SubOp+   , numMul     = Int8MulOp+   , numLitType = LitNumInt8+   , numAnd     = Nothing+   , numOr      = Nothing+   , numNeg     = Just Int8NegOp+   }++word8Ops :: NumOps+word8Ops = NumOps+   { numAdd     = Word8AddOp+   , numSub     = Word8SubOp+   , numMul     = Word8MulOp+   , numAnd     = Just Word8AndOp+   , numOr      = Just Word8OrOp+   , numNeg     = Nothing+   , numLitType = LitNumWord8+   }++int16Ops :: NumOps+int16Ops = NumOps+   { numAdd     = Int16AddOp+   , numSub     = Int16SubOp+   , numMul     = Int16MulOp+   , numLitType = LitNumInt16+   , numAnd     = Nothing+   , numOr      = Nothing+   , numNeg     = Just Int16NegOp+   }++word16Ops :: NumOps+word16Ops = NumOps+   { numAdd     = Word16AddOp+   , numSub     = Word16SubOp+   , numMul     = Word16MulOp+   , numAnd     = Just Word16AndOp+   , numOr      = Just Word16OrOp+   , numNeg     = Nothing+   , numLitType = LitNumWord16+   }++int32Ops :: NumOps+int32Ops = NumOps+   { numAdd     = Int32AddOp+   , numSub     = Int32SubOp+   , numMul     = Int32MulOp+   , numLitType = LitNumInt32+   , numAnd     = Nothing+   , numOr      = Nothing+   , numNeg     = Just Int32NegOp+   }++word32Ops :: NumOps+word32Ops = NumOps+   { numAdd     = Word32AddOp+   , numSub     = Word32SubOp+   , numMul     = Word32MulOp+   , numAnd     = Just Word32AndOp+   , numOr      = Just Word32OrOp+   , numNeg     = Nothing+   , numLitType = LitNumWord32+   }++int64Ops :: NumOps+int64Ops = NumOps+   { numAdd     = Int64AddOp+   , numSub     = Int64SubOp+   , numMul     = Int64MulOp+   , numLitType = LitNumInt64+   , numAnd     = Nothing+   , numOr      = Nothing+   , numNeg     = Just Int64NegOp+   }++word64Ops :: NumOps+word64Ops = NumOps+   { numAdd     = Word64AddOp+   , numSub     = Word64SubOp+   , numMul     = Word64MulOp+   , numAnd     = Just Word64AndOp+   , numOr      = Just Word64OrOp+   , numNeg     = Nothing+   , numLitType = LitNumWord64+   }++intOps :: NumOps+intOps = NumOps+   { numAdd     = IntAddOp+   , numSub     = IntSubOp+   , numMul     = IntMulOp+   , numAnd     = Just IntAndOp+   , numOr      = Just IntOrOp+   , numNeg     = Just IntNegOp+   , numLitType = LitNumInt+   }++wordOps :: NumOps+wordOps = NumOps+   { numAdd     = WordAddOp+   , numSub     = WordSubOp+   , numMul     = WordMulOp+   , 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 _ (App (App (Var f) (Type ty)) v)       -- dataToTag x+  | Just DataToTagOp <- isPrimOpId_maybe f+  , Just (tc, _) <- tcSplitTyConApp_maybe ty+  , isAlgTyCon tc+  = Just (v, tx_con_dtt ty+           , \v -> App (App (Var f) (Type ty)) (Var v))++caseRules _ _ = 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 :: Type -> AltCon -> Maybe AltCon+tx_con_dtt _  DEFAULT = Just DEFAULT+tx_con_dtt ty (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+     tc          = tyConAppTyCon ty+     n_data_cons = tyConFamilySize tc+     data_cons   = tyConDataCons tc++tx_con_dtt _ alt = pprPanic "caseRules" (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++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, we deal with turning one branch into DEFAULT in GHC.Core.Opt.Simplify.Utils+(add_default in mkCase3).++Note [caseRules for dataToTag]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+See also Note [dataToTag# magic].++We want to transform+  case dataToTag x of+    DEFAULT -> e1+    1# -> e2+into+  case x of+    DEFAULT -> e1+    (:) _ _ -> e2++Note the need for some wildcard binders in+the 'cons' case.++For the time, we only apply this transformation when the type of `x` is a type+headed by a normal tycon. In particular, we do not apply this in the case of a+data family tycon, since that would require carefully applying coercion(s)+between the data family and the data family instance's representation type,+which caseRules isn't currently engineered to handle (#14680).++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
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-}  -- | Constructed Product Result analysis. Identifies functions that surely -- return heap-allocated records on every code path, so that we can eliminate@@ -9,81 +8,148 @@ -- See Note [Phase ordering]. module GHC.Core.Opt.CprAnal ( cprAnalProgram ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Driver.Session-import GHC.Types.Demand-import GHC.Types.Cpr-import GHC.Core-import GHC.Core.Seq-import GHC.Utils.Outputable+ import GHC.Builtin.Names ( runRWKey )+ import GHC.Types.Var.Env import GHC.Types.Basic import GHC.Types.Id import GHC.Types.Id.Info+import GHC.Types.Demand+import GHC.Types.Cpr+import GHC.Types.Unique.MemoFun++import GHC.Core.FamInstEnv import GHC.Core.DataCon-import GHC.Core.Multiplicity-import GHC.Core.Utils   ( exprIsHNF, dumpIdInfoOfProgram ) import GHC.Core.Type-import GHC.Core.FamInstEnv+import GHC.Core.Utils+import GHC.Core+import GHC.Core.Seq import GHC.Core.Opt.WorkWrap.Utils++import GHC.Data.Graph.UnVar -- for UnVarSet++import GHC.Utils.Outputable import GHC.Utils.Misc import GHC.Utils.Panic-import GHC.Utils.Logger  ( Logger, dumpIfSet_dyn, DumpFormat (..) )-import GHC.Data.Graph.UnVar -- for UnVarSet-import GHC.Data.Maybe   ( isNothing )+import GHC.Utils.Panic.Plain+import GHC.Utils.Logger  ( Logger, putDumpFileMaybe, DumpFormat (..) ) -import Control.Monad ( guard ) import Data.List ( mapAccumL ) -import GHC.Driver.Ppr-_ = pprTrace -- Tired of commenting out the import all the time- {- 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.--@swap@ below is such a function:+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.+```+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@+```+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:-+```+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+```+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@@ -96,8 +162,7 @@ 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]-and Note [Optimistic field binder CPR].+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 @@ -110,12 +175,12 @@ -- * Analysing programs -- -cprAnalProgram :: Logger -> DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram-cprAnalProgram logger dflags fam_envs binds = do+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-  dumpIfSet_dyn logger dflags Opt_D_dump_cpr_signatures "Cpr signatures" FormatText $-    dumpIdInfoOfProgram (ppr . cprInfo) binds_plus_cpr+  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 @@ -126,12 +191,12 @@ cprAnalTopBind env (NonRec id rhs)   = (env', NonRec id' rhs')   where-    (id', rhs', env') = cprAnalBind TopLevel env id rhs+    (id', rhs', env') = cprAnalBind env id rhs  cprAnalTopBind env (Rec pairs)   = (env', Rec pairs')   where-    (env', pairs') = cprFix TopLevel env pairs+    (env', pairs') = cprFix env pairs  -- -- * Analysing expressions@@ -162,9 +227,9 @@     (cpr_ty, e') = cprAnal env e  cprAnal' env e@(Var{})-  = cprAnalApp env e [] []+  = cprAnalApp env e [] cprAnal' env e@(App{})-  = cprAnalApp env e [] []+  = cprAnalApp env e []  cprAnal' env (Lam var body)   | isTyVar var@@ -189,13 +254,13 @@ cprAnal' env (Let (NonRec id rhs) body)   = (body_ty, Let (NonRec id' rhs') body')   where-    (id', rhs', env') = cprAnalBind NotTopLevel env id rhs+    (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 NotTopLevel env pairs+    (env', pairs')   = cprFix env pairs     (body_ty, body') = cprAnal env' body  cprAnalAlt@@ -210,7 +275,7 @@       | DataAlt dc <- con       , let ids = filter isId bndrs       , CprType arity cpr <- scrut_ty-      , ASSERT( arity == 0 ) True+      , assert (arity == 0 ) True       = case unpackConFieldsCpr dc cpr of           AllFieldsSame field_cpr             | let sig = mkCprSig 0 field_cpr@@ -226,79 +291,122 @@ -- * CPR transformer -- -cprAnalApp :: AnalEnv -> CoreExpr -> [CoreArg] -> [CprType] -> (CprType, CoreExpr)-cprAnalApp env e args' arg_tys-  -- Collect CprTypes for (value) args (inlined collectArgs):-  | App fn arg <- e, isTypeArg arg -- Don't analyse Type args-  = cprAnalApp env fn (arg:args') arg_tys-  | App fn arg <- e-  , (arg_ty, arg') <- cprAnal env arg-  = cprAnalApp env fn (arg':args') (arg_ty:arg_tys)+data TermFlag -- Better than using a Bool+  = Terminates+  | MightDiverge -  | Var fn <- e-  = (cprTransform env fn arg_tys, mkApps e args')+-- See Note [Nested CPR]+exprTerminates :: CoreExpr -> TermFlag+exprTerminates e+  | exprIsHNF e = Terminates -- A /very/ simple termination analysis.+  | otherwise   = MightDiverge -  | otherwise -- e is not an App and not a Var-  , (e_ty, e') <- cprAnal env e-  = (applyCprTy e_ty (length arg_tys), mkApps e' args')+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') -cprTransform :: AnalEnv   -- ^ The analysis environment-             -> Id        -- ^ The function-             -> [CprType] -- ^ info about incoming /value/ arguments-             -> CprType   -- ^ The demand type of the application+      | 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-  = -- pprTrace "cprTransform" (vcat [ppr id, ppr args, ppr sig])-    sig-  where-    sig-      -- Top-level binding, local let-binding, lambda arg or case binder-      | Just sig <- lookupSigEnv env id-      = applyCprTy (getCprSig sig) (length args)-      -- CPR transformers for special Ids-      | Just cpr_ty <- cprTransformSpecial id args-      = cpr_ty-      -- See Note [CPR for data structures]-      | Just rhs <- cprDataStructureUnfolding_maybe id-      = fst $ cprAnal env rhs-      -- Imported function or data con worker-      | isGlobalId id-      = applyCprTy (getCprSig (idCprInfo id)) (length args)-      | otherwise-      = topCprType+  -- Any local binding, except for data structure bindings+  -- See Note [Efficient Top sigs in SigEnv]+  | Just sig <- lookupSigEnv env id+  = applyCprTy (getCprSig sig) (length args)+  -- See Note [CPR for data structures]+  | Just rhs <- cprDataStructureUnfolding_maybe id+  = fst $ cprAnal env rhs+  -- Some (mostly global, known-key) Ids have bespoke CPR transformers+  | Just cpr_ty <- cprTransformBespoke id args+  = cpr_ty+  -- Other local Ids that respond True to 'isDataStructure' but don't have an+  -- expandable unfolding, such as NOINLINE bindings. They all get a top sig+  | isLocalId id+  = assertPpr (isDataStructure id) (ppr id) topCprType+  -- See Note [CPR for DataCon wrappers]+  | isDataConWrapId id, let rhs = uf_tmpl (realIdUnfolding id)+  = fst $ cprAnalApp env rhs args+  -- DataCon worker+  | Just con <- isDataConWorkId_maybe id+  = cprTransformDataConWork env con args+  -- Imported function+  | otherwise+  = applyCprTy (getCprSig (idCprSig id)) (length args) --- | CPR transformers for special Ids-cprTransformSpecial :: Id -> [CprType] -> Maybe CprType-cprTransformSpecial id 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] <- args           -- `\s -> e` has CPR type `arg` (e.g. `. -> 2`)-  = Just $ applyCprTy arg 1 -- `e` has CPR type `2`+  | idUnique id == runRWKey    -- `runRW (\s -> e)`+  , [(arg_ty, _arg)] <- args   -- `\s -> e` has CPR type `arg` (e.g. `. -> 2`)+  = Just $ applyCprTy arg_ty 1 -- `e` has CPR type `2`   | otherwise   = Nothing +-- | Get a (possibly nested) 'CprType' for an application of a 'DataCon' worker,+-- given a saturated number of 'CprType's for its field expressions.+-- Implements the Nested part of Note [Nested CPR].+cprTransformDataConWork :: AnalEnv -> DataCon -> [(CprType, CoreArg)] -> CprType+cprTransformDataConWork env con args+  | null (dataConExTyCoVars con)  -- No existentials+  , wkr_arity <= mAX_CPR_SIZE -- See Note [Trimming to mAX_CPR_SIZE]+  , args `lengthIs` wkr_arity+  , ae_rec_dc env con /= DefinitelyRecursive -- See Note [CPR for recursive data constructors]+  -- , pprTrace "cprTransformDataConWork" (ppr con <+> ppr wkr_arity <+> ppr args) True+  = CprType 0 (ConCpr (dataConTag con) (strictZipWith extract_nested_cpr args wkr_str_marks))+  | otherwise+  = topCprType+  where+    wkr_arity = dataConRepArity con+    wkr_str_marks = dataConRepStrictness con+    -- See Note [Nested CPR]+    extract_nested_cpr (CprType 0 cpr, arg) str+      | MarkedStrict <- str              = cpr+      | Terminates <- exprTerminates arg = cpr+    extract_nested_cpr _ _               = topCpr -- intervening lambda or doesn't terminate++-- | See Note [Trimming to mAX_CPR_SIZE].+mAX_CPR_SIZE :: Arity+mAX_CPR_SIZE = 10+ -- -- * Bindings --  -- Recursive bindings-cprFix :: TopLevelFlag-       -> AnalEnv                    -- Does not include bindings for this binding+cprFix :: AnalEnv                    -- Does not include bindings for this binding        -> [(Id,CoreExpr)]        -> (AnalEnv, [(Id,CoreExpr)]) -- Binders annotated with CPR info-cprFix top_lvl orig_env orig_pairs+cprFix orig_env orig_pairs   = loop 1 init_env init_pairs   where-    init_sig id rhs+    init_sig id       -- See Note [CPR for data structures]-      | isDataStructure id rhs = topCprSig-      | otherwise              = mkCprSig 0 botCpr+      | isDataStructure 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  = [(setIdCprInfo id (init_sig id rhs), rhs) | (id, rhs) <- orig_pairs ]+    init_pairs | orig_virgin  = [(setIdCprSig id (init_sig id), rhs) | (id, rhs) <- orig_pairs ]                | otherwise    = orig_pairs     init_env = extendSigEnvFromIds orig_env (map fst init_pairs) -    -- The fixed-point varies the idCprInfo field of the binders and and their+    -- 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)])@@ -311,27 +419,53 @@         (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 (idCprInfo . fst) pairs' == map (idCprInfo . fst) pairs+        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 top_lvl env id rhs+            (id', rhs', env') = cprAnalBind env id rhs +{-+Note [The OPAQUE pragma and avoiding the reboxing of results]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider:++  {-# OPAQUE f #-}+  f x = (x,y)++  g True  = f 2 x+  g False = (0,0)++Where if we didn't strip the CPR info from 'f' we would end up with the+following W/W pair for 'g':++  $wg True  = case f 2 of (x, y) -> (# x, y #)+  $wg False = (# 0, 0 #)++  g b = case wg$ b of (# x, y #) -> (x, y)++Where the worker unboxes the result of 'f', only for wrapper to box it again.+That's because the non-stripped CPR signature of 'f' is saying to W/W-transform+'f'. However, OPAQUE-annotated binders aren't W/W transformed (see+Note [OPAQUE pragma]), so we should strip 'f's CPR signature.+-}+ -- | Process the RHS of the binding for a sensible arity, add the CPR signature -- to the Id, and augment the environment with the signature as well. cprAnalBind-  :: TopLevelFlag-  -> AnalEnv+  :: AnalEnv   -> Id   -> CoreExpr   -> (Id, CoreExpr, AnalEnv)-cprAnalBind top_lvl env id rhs+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 rhs-  = (id,  rhs,  env) -- Data structure => no code => need to analyse rhs+  | isDataStructure id+  = (id,  rhs,  env) -- Data structure => no code => no need to analyse rhs   | otherwise   = (id', rhs', env')   where@@ -340,38 +474,37 @@     rhs_ty'       -- See Note [CPR for thunks]       | stays_thunk = trimCprTy rhs_ty-      -- See Note [CPR for sum types]-      | returns_sum = trimCprTy rhs_ty       | otherwise   = rhs_ty     -- See Note [Arity trimming for CPR signatures]     sig  = mkCprSigForArity (idArity id) rhs_ty'-    id'  = setIdCprInfo id sig-    env' = extendSigEnv env id sig+    -- See Note [OPAQUE pragma]+    -- See Note [The OPAQUE pragma and avoiding the reboxing of results]+    sig' | isOpaquePragma (idInlinePragma id) = topCprSig+         | otherwise                          = sig+    id'  = setIdCprSig id 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))-    -- See Note [CPR for sum types]-    (_, ret_ty) = splitPiTys (idType id)-    not_a_prod  = isNothing (splitArgType_maybe (ae_fam_envs env) ret_ty)-    returns_sum = not (isTopLevel top_lvl) && not_a_prod -isDataStructure :: Id -> CoreExpr -> Bool+isDataStructure :: Id -> Bool -- See Note [CPR for data structures]-isDataStructure id rhs =-  idArity id == 0 && exprIsHNF rhs+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 = do+cprDataStructureUnfolding_maybe id   -- There are only FinalPhase Simplifier runs after CPR analysis-  guard (activeInFinalPhase (idInlineActivation id))-  unf <- expandUnfolding_maybe (idUnfolding id)-  guard (isDataStructure id unf)-  return unf+  | activeInFinalPhase (idInlineActivation id)+  , isDataStructure id+  = expandUnfolding_maybe (idUnfolding id)+  | otherwise+  = Nothing  {- Note [Arity trimming for CPR signatures] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -403,6 +536,49 @@  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 DmdAnal.+  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'!++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@@ -414,6 +590,8 @@   -- iteration. See Note [Initialising strictness] in "GHC.Core.Opt.DmdAnal"   , ae_fam_envs :: FamInstEnvs   -- ^ Needed when expanding type families and synonyms of product types.+  , ae_rec_dc :: DataCon -> IsRecDataConResult+  -- ^ Memoised result of 'GHC.Core.Opt.WorkWrap.Utils.isRecDataCon'   }  instance Outputable AnalEnv where@@ -445,7 +623,11 @@   { 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) }@@ -472,7 +654,7 @@ -- | Extend an environment with the CPR sigs attached to the ids extendSigEnvFromIds :: AnalEnv -> [Id] -> AnalEnv extendSigEnvFromIds env ids-  = foldl' (\env id -> extendSigEnv env id (idCprInfo id)) 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@@ -489,35 +671,23 @@ -- See Note [CPR for binders that will be unboxed]. extendSigEnvForArg :: AnalEnv -> Id -> AnalEnv extendSigEnvForArg env id-  = extendSigEnv env id (CprSig (argCprType env (idType id) (idDemandInfo 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 @1L@ on @Int@ would translate to @1@---   * A product demand @1P(1L,L)@ on @(Int, Bool)@ would translate to @1(1,)@---   * A product demand @1P(1L,L)@ on @(a , Bool)@ would translate to @1(,)@,---     because the unboxing strategy would not unbox the @a@.-argCprType :: AnalEnv -> Type -> Demand -> CprType-argCprType env arg_ty dmd = CprType 0 (go arg_ty dmd)+--   * 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 ty dmd-      | Unbox (DataConPatContext { dcpc_dc = dc, dcpc_tc_args = tc_args }) ds-          <- wantToUnbox (ae_fam_envs env) no_inlineable_prag ty dmd-      -- No existentials; see Note [Which types are unboxed?])-      -- Otherwise we'd need to call dataConRepInstPat here and thread a-      -- UniqSupply. So argCprType is a bit less aggressive than it could-      -- be, for the sake of coding convenience.-      , null (dataConExTyCoVars dc)-      , let arg_tys = map scaledThing (dataConInstArgTys dc tc_args)-      = ConCpr (dataConTag dc) (zipWith go arg_tys ds)-      | otherwise-      = topCpr-    -- Rather than maintaining in AnalEnv whether we are in an INLINEABLE-    -- function, we just assume that we aren't. That flag is only relevant-    -- to Note [Do not unpack class dictionaries], the few unboxing-    -- opportunities on dicts it prohibits are probably irrelevant to CPR.-    no_inlineable_prag = False+    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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -570,7 +740,7 @@  Note that -  * Whether or not something unboxes is decided by 'wantToUnbox', else we may+  * Whether or not something unboxes is decided by 'wantToUnboxArg', 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@@ -592,110 +762,6 @@    * See Note [CPR examples] -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, 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 Historical Note [Optimistic case binder CPR].--Historical 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.--Note [CPR for sum types]-~~~~~~~~~~~~~~~~~~~~~~~~-At the moment we do not do CPR for let-bindings that-   * non-top level-   * bind a sum type-Reason: I found that in some benchmarks we were losing let-no-escapes,-which messed it all up.  Example-   let j = \x. ....-   in case y of-        True  -> j False-        False -> j True-If we w/w this we get-   let j' = \x. ....-   in case y of-        True  -> case j' False of { (# a #) -> Just a }-        False -> case j' True of { (# a #) -> Just a }-Notice that j' is not a let-no-escape any more.--However this means in turn that the *enclosing* function-may be CPR'd (via the returned Justs).  But in the case of-sums, there may be Nothing alternatives; and that messes-up the sum-type CPR.--Conclusion: only do this for products.  It's still not-guaranteed OK for products, but sums definitely lose sometimes.- Note [CPR for thunks] ~~~~~~~~~~~~~~~~~~~~~ If the rhs is a thunk, we usually forget the CPR info, because@@ -765,65 +831,282 @@   xs1 = x2 : xs2   xs2 = x3 : xs3 -should not get CPR signatures (#18154), because they+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-  * Recording CPR on them blows up interface file sizes and is redundant with+  * 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 we don't analyse or annotate data structures in 'cprAnalBind'. To-implement this, the isDataStructure guard is triggered for bindings that satisfy+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) exprIsHNF rhs   (otherwise it's a thunk, Note [CPR for thunks] applies)+  (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 we can't just stop giving DataCon application bindings the CPR *property*,-for example+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 -  fac 0 = I# 1#+  lvl = I# 1#+  fac 0 = lvl   fac n = n * fac (n-1) -fac certainly has the CPR property and should be WW'd! But FloatOut will-transform the first clause to+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. -  lvl = I# 1#-  fac 0 = lvl+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. -If lvl doesn't have the CPR property, fac won't either. But lvl is a data-structure, and hence (see above) will not have a CPR signature. So instead, when-'cprAnal' meets a variable lacking a CPR signature to extrapolate into a CPR-transformer, 'cprTransform' instead 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. -In practice, GHC generates a lot of (nested) TyCon and KindRep bindings, one-for each data declaration. They should not have CPR signatures (blow up!).+There is one exception to (R1): -There is a perhaps surprising special case: KindRep bindings satisfy-'isDataStructure' (so no CPR signature), but are marked NOINLINE at the same-time (see the noinline wrinkle in Note [Grand plan for Typeable]). So there is-no unfolding for 'cprDataStructureUnfolding_maybe' to look through and we'll-return topCprType. And that is fine! We should refrain to look through NOINLINE-data structures in general, as a constructed product could never be exposed-after WW.+  x   = (y, z); {-# NOINLINE x #-}+  f p = (y, z); {-# NOINLINE f #-} -It's also worth pointing out how ad-hoc this is: If we instead had+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 every deepening CPR signature. But it's very+we still give every function an ever deepening CPR signature. But it's very uncommon to find code like this, whereas the long static data structures from the beginning of this Note are very common because of GHC's strategy of ANF'ing data structure RHSs. +Note [CPR for data structures can destroy sharing]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In Note [CPR for data structures], we argued that giving data structure bindings+the CPR property is useful to give functions like fac the CPR property:++  lvl = I# 1#+  fac 0 = lvl+  fac n = n * fac (n-1)++Worker/wrappering fac for its CPR property means we get a very fast worker+function with type Int# -> Int#, without any heap allocation at all.++But consider what happens if we call `map fac (replicate n 0)`, where the+wrapper doesn't cancel away: Then we rebox the result of $wfac *on each call*,+n times, instead of reusing the static thunk for 1, e.g. an asymptotic increase+in allocations. If you twist it just right, you can actually write programs that+that take O(n) space if you do CPR and O(1) if you don't:++  fac :: Int -> Int+  fac 0 = 1 -- this clause will trigger CPR and destroy sharing for O(n) space+  -- fac 0 = lazy 1 -- this clause will prevent CPR and run in O(1) space+  fac n = n * fac (n-1)++  const0 :: Int -> Int+  const0 n = signum n - 1 -- will return 0 for [1..n]+  {-# NOINLINE const0 #-}++  main = print $ foldl' (\acc n -> acc + lazy n) 0 $ map (fac . const0) [1..100000000]++Generally, this kind of asymptotic increase in allocation can happen whenever we+give a data structure the CPR property that is bound outside of a recursive+function. So far we don't have a convincing remedy; giving fac the CPR property+is just too attractive. #19309 documents a futile idea. #13331 tracks the+general issue of WW destroying sharing and also contains above reproducer.+#19326 is about CPR destroying sharing in particular.++With Nested CPR, sharing can also be lost within the same "lambda level", for+example:++  f (I# x) = let y = I# (x*#x) in (y, y)++Nestedly unboxing would destroy the box shared through 'y'. (Perhaps we can call+this "internal sharing", in contrast to "external sharing" beyond lambda or even+loop levels above.) But duplicate occurrences like that are pretty rare and may+never lead to an asymptotic difference in allocations of 'f'.++Note [CPR for recursive data constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Note [CPR for data structures can destroy sharing] gives good reasons not to+give shared data structure bindings the CPR property. But we shouldn't even+give *functions* that return *recursive* data constructor applications the CPR+property. Here's an example for why:++  c = C# 'a'+  replicateC :: Int -> [Int]+  replicateC 1 = [c]+  replicateC n = c : replicateC (n-1)++What happens if we give `replicateC` the (nested) CPR property? We get a WW+split for 'replicateC', the wrapper of which is certain to inline, like this:++  replicateC (I# n) = case $wreplicateC n of (# x, xs #) -> C# x : xs+  $wreplicateC 1# = (# 'a', [] #)+  $wreplicateC n  = (# 'a', replicateC (I# (n -# 1#)) #)++Eliminating the shared 'c' binding in the process. And then++  * We *might* save allocation of the topmost (of most likely several) (:)+    constructor if it cancels away at the call site. Similarly for the 'C#'+    constructor.+  * But we will now re-allocate the C# box on every iteration of the loop,+    because we separated the character literal from the C# application.+    That means n times as many C# allocations as before. Yikes!!+  * We make all other call sites where the wrapper inlines a bit larger, most of+    them for no gain. But this shouldn't matter much.+  * The inlined wrapper may inhibit eta-expansion in some cases. Here's how:+    If the wrapper is inlined in a strict arg position, the Simplifier will+    transform as follows++      f (replicateC n)+      ==> { inline }+      f (case $wreplicateC n of (# x, xs #) -> (C# x, xs))+      ==> { strict arg }+      case $wreplicateC n of (# x, xs #) -> f (C# x, xs)++    Now we can't float out the case anymore. In fact, we can't even float out+    `$wreplicateC n`, because it returns an unboxed tuple.+    This can inhibit eta-expansion if we later find out that `f` has arity > 1+    (such as when we define `foldl` in terms of `foldr`). #19970 shows how+    abstaining from worker/wrappering made a difference of -20% in reptile. So+    while WW'ing for CPR didn't make the program slower directly, the resulting+    program got much harder to optimise because of the returned unboxed tuple+    (which can't easily float because unlifted).++`replicateC` comes up in T5536, which regresses significantly if CPR'd nestedly.++What can we do about it?++ A. Don't CPR functions that return a *recursive data type* (the list in this+    case). This is the solution we adopt. Rationale: the benefit of CPR on+    recursive data structures is slight, because it only affects the outer layer+    of a potentially massive data structure.+ B. Don't CPR any *recursive function*. That would be quite conservative, as it+    would also affect e.g. the factorial function.+ C. Flat CPR only for recursive functions. This prevents the asymptotic+    worsening part arising through unsharing the C# box, but it's still quite+    conservative.+ D. No CPR at occurrences of shared data structure in hot paths (e.g. the use of+    `c` in the second eqn of `replicateC`). But we'd need to know which paths+    were hot. We want such static branch frequency estimates in #20378.++We adopt solution (A) It is ad-hoc, but appears to work reasonably well.+Deciding what a "recursive data constructor" is is quite tricky and ad-hoc, too:+See Note [Detecting recursive data constructors]. We don't have to be perfect+and can simply keep on unboxing if unsure.++Note [Detecting recursive data constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+What qualifies as a "recursive data constructor" as per+Note [CPR for recursive data constructors]? That is up to+'GHC.Core.Opt.WorkWrapW.Utils.isRecDataCon' to decide. It does a DFS search over+the field types of the DataCon and looks for term-level recursion into the data+constructor's type constructor. Assuming infinite fuel (point (4) below), it+looks inside the following class of types, represented by `ty` (and responds+`NonRecursiveOrUnsure` in all other cases):++ A. If `ty = forall v. ty'`, then look into `ty'`+ B. If `ty = Tc tc_args` and `Tc` is an `AlgTyCon`, look into the arg+    types of its data constructors and check `tc_args` for recursion.+ C. If `ty = F tc_args`, `F` is a `FamTyCon` and we can reduce `F tc_args` to+    `rhs`, look into the `rhs` type.++A few perhaps surprising points:++  1. It deems any function type as non-recursive, because it's unlikely that+     a recursion through a function type builds up a recursive data structure.+  2. It doesn't look into kinds or coercion types because there's nothing to unbox.+     Same for promoted data constructors.+  3. We don't care whether an AlgTyCon app `T tc_args` is fully saturated or not;+     we simply look at its definition/DataCons and its field tys and look for+     recursive occs in the `tc_args` we are given. This is so that we expand+     the `ST` in `StateT Int (ST s) a`.+  4. We don't recurse deeper than 3 (at the moment of this writing) TyCons and+     assume the DataCon is non-recursive after that. One reason for this "fuel"+     approach is guaranteed constant-time efficiency; the other is that it's+     fair to say that a recursion over 3 or more TyCons doesn't really count as+     a list-like data structure anymore and a bit of unboxing doesn't hurt much.+  5. It checks AlgTyCon apps like `T tc_args` by eagerly checking the `tc_args`+     *before* it looks into the expanded DataCons/NewTyCon, so that it+     terminates before doing a deep nest of expansions only to discover that the+     first level already contained a recursion.+  6. As a result of keeping the implementation simple, it says "recursive"+     for `data T = MkT [T]`, even though we could argue that the inner recursion+     (through the `[]` TyCon) by way of which `T` is recursive will already be+     "broken" and thus never unboxed. Consequently, it might be OK to CPR a+     function returning `T`. Lacking arguments for or against the current simple+     behavior, we stick to it.+  7. When the search hits an abstract TyCon (algebraic, but without visible+     DataCons, e.g., from an .hs-boot file), it returns 'NonRecursiveOrUnsure',+     the same as when we run out of fuel. If there is ever a recursion through+     an abstract TyCon, then it's not part of the same function we are looking+     at in CPR, so we can treat it as if it wasn't recursive.+     We handle stuck type and data families much the same.++Here are a few examples of data constructors or data types with a single data+con and the answers of our function:++  data T = T (Int, (Bool, Char))               NonRec+  (:)                                          Rec+  []                                           NonRec+  data U = U [Int]                             NonRec+  data U2 = U2 [U2]                            Rec     (see point (6))+  data T1 = T1 T2; data T2 = T2 T1             Rec+  newtype Fix f = Fix (f (Fix f))              Rec+  data N = N (Fix (Either Int))                NonRec+  data M = M (Fix (Either M))                  Rec+  data F = F (F -> Int)                        NonRec  (see point (1))+  data G = G (Int -> G)                        NonRec  (see point (1))+  newtype MyM s a = MyM (StateT Int (ST s) a   NonRec+  type S = (Int, Bool)                         NonRec++  { type family E a where+      E Int = Char+      E (a,b) = (E a, E b)+      E Char = Blub+    data Blah = Blah (E (Int, (Int, Int)))     NonRec+    data Blub = Blub (E (Char, Int))           Rec+    data Blub2 = Blub2 (E (Bool, Int))     }   Unsure, because stuck (see point (7))++  { data T1 = T1 T2; data T2 = T2 T3;+    ... data T5 = T5 T1                    }   Unsure (out of fuel)  (see point (4))++  { module A where -- A.hs-boot+      data T+    module B where+      import {-# SOURCE #-} A+      data U = MkU T+      f :: T -> U+      f t = MkU t                              Unsure (T is abstract)  (see point (7))+    module A where -- A.hs+      import B+      data T = MkT U }++These examples are tested by the testcase RecDataConCPR.++I've played with the idea to make points (1) through (3) of 'isRecDataCon'+configurable like (4) to enable more re-use throughout the compiler, but haven't+found a killer app for that yet, so ultimately didn't do that.+ Note [CPR examples]-~~~~~~~~~~~~~~~~~~~~+~~~~~~~~~~~~~~~~~~~ Here are some examples (stranal/should_compile/T10482a) of the usefulness of Note [Optimistic field binder CPR].  The main point: all of these functions can have the CPR property.@@ -846,4 +1129,84 @@     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
@@ -7,7 +7,6 @@                         ----------------- -} -{-# LANGUAGE CPP #-}  module GHC.Core.Opt.DmdAnal    ( DmdAnalOpts(..)@@ -15,8 +14,6 @@    ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Core.Opt.WorkWrap.Utils@@ -34,18 +31,23 @@ import GHC.Core.Utils import GHC.Core.TyCon import GHC.Core.Type+import GHC.Core.Predicate ( isClassPred ) import GHC.Core.FVs      ( rulesRhsFreeIds, bndrRuleAndUnfoldingIds )-import GHC.Core.Coercion ( Coercion, coVarsOfCo )+import GHC.Core.Coercion ( Coercion )+import GHC.Core.TyCo.FVs ( coVarsOfCos ) import GHC.Core.FamInstEnv import GHC.Core.Opt.Arity ( typeArity ) import GHC.Utils.Misc import GHC.Utils.Panic-import GHC.Data.Maybe         ( isJust )+import GHC.Utils.Panic.Plain+import GHC.Data.Maybe import GHC.Builtin.PrimOps import GHC.Builtin.Types.Prim ( realWorldStatePrimTy ) import GHC.Types.Unique.Set+import GHC.Types.Unique.MemoFun --- import GHC.Driver.Ppr+import GHC.Utils.Trace+_ = pprTrace -- Tired of commenting out the import all the time  {- ************************************************************************@@ -56,8 +58,10 @@ -}  -- | Options for the demand analysis-newtype DmdAnalOpts = DmdAnalOpts-   { dmd_strict_dicts :: Bool -- ^ Use strict dictionaries+data DmdAnalOpts = DmdAnalOpts+   { dmd_strict_dicts    :: !Bool -- ^ Use strict dictionaries+   , dmd_unbox_width     :: !Int  -- ^ Use strict dictionaries+   , dmd_max_worker_args :: !Int    }  -- This is a strict alternative to (,)@@ -93,7 +97,7 @@     add_exported_uses :: AnalEnv -> DmdType -> [Id] -> DmdType     add_exported_uses env = foldl' (add_exported_use env) -    -- | If @e@ is denoted by @dmd_ty@, then @add_exported_use _ dmd_ty id@+    -- If @e@ is denoted by @dmd_ty@, then @add_exported_use _ dmd_ty id@     -- corresponds to the demand type of @(id, e)@, but is a lot more direct.     -- See Note [Analysing top-level bindings].     add_exported_use :: AnalEnv -> DmdType -> Id -> DmdType@@ -229,7 +233,7 @@ -- -- It calls a function that knows how to analyse this \"body\" given -- an 'AnalEnv' with updated demand signatures for the binding group--- (reflecting their 'idStrictnessInfo') and expects to receive a+-- (reflecting their 'idDmdSigInfo') and expects to receive a -- 'DmdType' in return, which it uses to annotate the binding group with their -- 'idDemandInfo'. dmdAnalBind@@ -275,11 +279,14 @@                  -> 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)-    WithDmdType body_ty' id_dmd = findBndrDmd env notArgOfDfun body_ty id-    !id'                = setBindIdDemandInfo top_lvl id id_dmd-    (rhs_ty, rhs')     = dmdAnalStar env (dmdTransformThunkDmd rhs id_dmd) rhs+    WithDmdType body_ty body'   = anal_body env+    WithDmdType body_ty' id_dmd = findBndrDmd env body_ty id+    -- See Note [Finalising boxity for demand signatures] +    id_dmd'            = finaliseLetBoxity (ae_fam_envs env) (idType id) id_dmd+    !id'               = setBindIdDemandInfo top_lvl id id_dmd'+    (rhs_ty, rhs')     = dmdAnalStar env (dmdTransformThunkDmd rhs id_dmd') rhs+     -- See Note [Absence analysis for stable unfoldings and RULES]     rule_fvs           = bndrRuleAndUnfoldingIds id     final_ty           = body_ty' `plusDmdType` rhs_ty `keepAliveDmdType` rule_fvs@@ -342,11 +349,12 @@             -> Demand   -- This one takes a *Demand*             -> CoreExpr -- Should obey the let/app invariant             -> (PlusDmdArg, CoreExpr)-dmdAnalStar env (n :* cd) e-  | WithDmdType dmd_ty e'    <- dmdAnal env cd e-  = ASSERT2( not (isUnliftedType (exprType e)) || exprOkForSpeculation e, ppr e )+dmdAnalStar env (n :* sd) e+  -- NB: (:*) expands AbsDmd and BotDmd as needed+  -- See Note [Analysing with absent demand]+  | WithDmdType dmd_ty e' <- dmdAnal env sd e+  = assertPpr (mightBeLiftedType (exprType e) || exprOkForSpeculation e) (ppr e)     -- The argument 'e' should satisfy the let/app invariant-    -- See Note [Analysing with absent demand] in GHC.Types.Demand     (toPlusDmdArg $ multDmdType n dmd_ty, e')  -- Main Demand Analsysis machinery@@ -405,8 +413,7 @@ 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]+        WithDmdType body_ty body' = dmdAnal env dmd body     in     WithDmdType body_ty (Lam var body') @@ -414,52 +421,50 @@   = 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 notArgOfDfun body_ty var+        WithDmdType body_ty body' = dmdAnal env body_dmd body+        WithDmdType lam_ty var'   = annotateLamIdBndr env body_ty var         new_dmd_type = multDmdType n lam_ty     in     WithDmdType new_dmd_type (Lam var' body')  dmdAnal' env dmd (Case scrut case_bndr ty [Alt alt bndrs rhs])   -- Only one alternative.-  -- If it's a DataAlt, it should be the only constructor of the type.-  | is_single_data_alt alt+  -- 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   = 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 dmds          = findBndrsDmds env rhs_ty bndrs-        WithDmdType alt_ty2 case_bndr_dmd = findBndrDmd env False alt_ty1 case_bndr+        WithDmdType rhs_ty rhs'           = dmdAnal env dmd rhs+        WithDmdType alt_ty1 fld_dmds      = findBndrsDmds env rhs_ty bndrs+        WithDmdType alt_ty2 case_bndr_dmd = findBndrDmd env alt_ty1 case_bndr+        !case_bndr'                       = setIdDemandInfo case_bndr case_bndr_dmd         -- Evaluation cardinality on the case binder is irrelevant and a no-op.         -- What matters is its nested sub-demand!-        (_ :* case_bndr_sd)      = case_bndr_dmd+        -- 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) = 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           -- See Note [Demand on the scrutinee of a product case]-          , let !scrut_sd = scrutSubDmd case_bndr_sd dmds-          , let !fld_dmds' = fieldBndrDmds scrut_sd (length dmds)-          = let !new_info = setBndrsDemandInfo bndrs fld_dmds'-                !new_prod = mkProd fld_dmds'-            in (new_info, new_prod)+          -- See Note [Demand on case-alternative binders]+          , (!scrut_sd, fld_dmds') <- addCaseBndrDmd case_bndr_sd fld_dmds+          , let !bndrs' = setBndrsDemandInfo bndrs fld_dmds'+          = (bndrs', scrut_sd)           | otherwise           -- __DEFAULT and literal alts. Simply add demands and discard the           -- evaluation cardinality, as we evaluate the scrutinee exactly once.-          = ASSERT( null bndrs ) (bndrs, case_bndr_sd)-        fam_envs                 = ae_fam_envs env+          = assert (null bndrs) (bndrs, case_bndr_sd)         alt_ty3           -- See Note [Precise exceptions and strictness analysis] in "GHC.Types.Demand"-          | exprMayThrowPreciseException fam_envs scrut+          | exprMayThrowPreciseException (ae_fam_envs env) scrut           = deferAfterPreciseException alt_ty2           | otherwise           = alt_ty2          WithDmdType scrut_ty scrut' = dmdAnal env scrut_sd scrut         res_ty             = alt_ty3 `plusDmdType` toPlusDmdArg scrut_ty-        !case_bndr'        = setIdDemandInfo case_bndr case_bndr_dmd     in --    pprTrace "dmdAnal:Case1" (vcat [ text "scrut" <+> ppr scrut --                                   , text "dmd" <+> ppr dmd@@ -470,8 +475,12 @@ --                                   , text "res_ty" <+> ppr res_ty ]) $     WithDmdType res_ty (Case scrut' case_bndr' ty [Alt alt bndrs' rhs'])     where-      is_single_data_alt (DataAlt dc) = isJust $ tyConSingleAlgDataCon_maybe $ dataConTyCon dc-      is_single_data_alt _            = True+      want_precise_field_dmds alt = case alt of+        (DataAlt dc)+          | Nothing <- tyConSingleAlgDataCon_maybe $ dataConTyCon dc -> False+          | DefinitelyRecursive <- ae_rec_dc env dc                  -> False+              -- See Note [Demand analysis for recursive data constructors]+        _                                                            -> True   @@ -487,8 +496,9 @@             WithDmdType rest_ty as' = combineAltDmds as           in WithDmdType (lubDmdType cur_ty rest_ty) (a':as') -        WithDmdType scrut_ty scrut'   = dmdAnal env topSubDmd scrut-        WithDmdType alt_ty1 case_bndr' = annotateBndr env alt_ty case_bndr+        WithDmdType alt_ty1 case_bndr_dmd = findBndrDmd env alt_ty case_bndr+        !case_bndr'                       = setIdDemandInfo case_bndr case_bndr_dmd+        WithDmdType scrut_ty scrut'       = dmdAnal env topSubDmd scrut                                -- NB: Base case is botDmdType, for empty case alternatives                                --     This is a unit for lubDmdType, and the right result                                --     when there really are no alternatives@@ -542,53 +552,47 @@ forcesRealWorld fam_envs ty   | ty `eqType` realWorldStatePrimTy   = True-  | Just DataConPatContext{ dcpc_dc = dc, dcpc_tc_args = tc_args }-      <- splitArgType_maybe fam_envs ty-  , isUnboxedTupleDataCon dc-  , let field_tys = dataConInstArgTys dc tc_args+  | 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  dmdAnalSumAlt :: AnalEnv -> SubDemand -> Id -> Alt Var -> WithDmdType (Alt Var) 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 rhs_ty rhs' <- dmdAnal env dmd rhs   , WithDmdType alt_ty dmds <- findBndrsDmds env rhs_ty bndrs   , let (_ :* case_bndr_sd) = findIdDemand alt_ty case_bndr         -- See Note [Demand on case-alternative binders]         -- we can't use the scrut_sd, because it says 'Prod' and we'll use         -- topSubDmd anyway for scrutinees of sum types.-        scrut_sd = scrutSubDmd case_bndr_sd dmds-        id_dmds = fieldBndrDmds scrut_sd (length dmds)+        (!_scrut_sd, dmds') = addCaseBndrDmd case_bndr_sd dmds         -- Do not put a thunk into the Alt-        !new_ids            = setBndrsDemandInfo bndrs id_dmds-  = -- pprTrace "dmdAnalSumAlt" (ppr con $$ ppr case_bndr $$ ppr dmd $$ ppr alt_ty) $-    WithDmdType alt_ty (Alt con new_ids rhs')+        !new_ids            = setBndrsDemandInfo bndrs dmds'+  = WithDmdType alt_ty (Alt con new_ids rhs') +-- Precondition: The SubDemand is not a Call -- 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 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]+-- and Note [Demand on case-alternative binders]+addCaseBndrDmd :: SubDemand -- On the case binder+               -> [Demand]  -- On the fields of the constructor+               -> (SubDemand, [Demand])+                            -- SubDemand on the case binder incl. field demands+                            -- and final demands for the components of the constructor+addCaseBndrDmd case_sd fld_dmds+  | Just (_, ds) <- viewProd (length fld_dmds) scrut_sd+  = (scrut_sd, ds)+  | otherwise+  = pprPanic "was a call demand" (ppr case_sd $$ ppr fld_dmds) -- See the Precondition+  where+    scrut_sd = case_sd `plusSubDmd` mkProd Unboxed fld_dmds  {- 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?+"absent", so this expression will never be needed. What should happen? There are several wrinkles:  * We *do* want to analyse the expression regardless.@@ -597,6 +601,15 @@   But we can post-process the results to ignore all the usage   demands coming back. This is done by multDmdType. +* 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.+ * In a previous incarnation of GHC we needed to be extra careful in the   case of an *unlifted type*, because unlifted values are evaluated   even if they are not used.  Example (see #9254):@@ -681,12 +694,29 @@ from 'topDiv' to 'conDiv', leading to bugs, performance regressions and complexity that didn't justify the single fixed testcase T13380c. +Note [Demand analysis for recursive data constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+T11545 features a single-product, recursive data type+  data A = A A A ... A+    deriving Eq+Naturally, `(==)` is deeply strict in `A` and in fact will never terminate. That+leads to very large (exponential in the depth) demand signatures and fruitless+churn in boxity analysis, demand analysis and worker/wrapper.+So we detect `A` as a recursive data constructor+(see Note [Detecting recursive data constructors]) analysing `case x of A ...`+and simply assume L for the demand on field binders, which is the same code+path as we take for sum types.+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] in GHC.Types.Demand.+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@@ -739,44 +769,6 @@ 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@@ -828,43 +820,42 @@ ************************************************************************ -} -dmdTransform :: AnalEnv         -- ^ The strictness environment-             -> Id              -- ^ The function-             -> SubDemand       -- ^ The demand on the function-             -> DmdType         -- ^ The demand type of the function in this context-                                -- Returned DmdEnv includes the demand on-                                -- this function plus demand on its free variables-+dmdTransform :: AnalEnv   -- ^ The analysis environment+             -> Id        -- ^ The variable+             -> SubDemand -- ^ The evaluation context of the var+             -> DmdType   -- ^ The demand type unleashed by the variable in this+                          -- context. The returned DmdEnv includes the demand on+                          -- this function plus demand on its free variables -- See Note [What are demand signatures?] in "GHC.Types.Demand"-dmdTransform env var dmd+dmdTransform env var sd   -- Data constructors   | isDataConWorkId var-  = dmdTransformDataConSig (idArity var) dmd+  = dmdTransformDataConSig (idArity var) sd   -- 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 dmd) $-    dmdTransformDictSelSig (idStrictness var) dmd+  = -- pprTrace "dmdTransform:DictSel" (ppr var $$ ppr (idDmdSig var) $$ ppr sd) $+    dmdTransformDictSelSig (idDmdSig var) sd   -- Imported functions   | isGlobalId var-  , let res = dmdTransformSig (idStrictness var) dmd-  = -- pprTrace "dmdTransform:import" (vcat [ppr var, ppr (idStrictness var), ppr dmd, ppr res])+  , 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 dmd-  = -- pprTrace "dmdTransform:LetDown" (vcat [ppr var, ppr sig, ppr dmd, ppr fn_ty]) $+  , 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 :* dmd)+      NotTopLevel -> addVarDmd fn_ty var (C_11 :* sd)       TopLevel         | isInterestingTopLevelFn var         -- Top-level things will be used multiple times or not at         -- all anyway, hence the multDmd below: It means we don't         -- have to track whether @var@ is used strictly or at most         -- once, because ultimately it never will.-        -> addVarDmd fn_ty var (C_0N `multDmd` (C_11 :* dmd)) -- discard strictness+        -> addVarDmd fn_ty var (C_0N `multDmd` (C_11 :* sd)) -- discard strictness         | otherwise         -> fn_ty -- don't bother tracking; just annotate with 'topDmd' later   -- Everything else:@@ -872,8 +863,8 @@   --   * Lambda binders   --   * Case and constructor field binders   | otherwise-  = -- pprTrace "dmdTransform:other" (vcat [ppr var, ppr sig, ppr dmd, ppr res]) $-    unitDmdType (unitVarEnv var (C_11 :* dmd))+  = -- pprTrace "dmdTransform:other" (vcat [ppr var, ppr boxity, ppr sd]) $+    unitDmdType (unitVarEnv var (C_11 :* sd))  {- ********************************************************************* *                                                                      *@@ -900,26 +891,36 @@ -- to the Id, and augment the environment with the signature as well. -- See Note [NOINLINE and strictness] dmdAnalRhsSig top_lvl rec_flag env let_dmd id rhs-  = -- pprTrace "dmdAnalRhsSig" (ppr id $$ ppr let_dmd $$ ppr sig $$ ppr lazy_fv) $-    (env', lazy_fv, id', rhs')+  = -- pprTrace "dmdAnalRhsSig" (ppr id $$ ppr let_dmd $$ ppr rhs_dmds $$ ppr sig $$ ppr lazy_fv) $+    (final_env, lazy_fv, final_id, final_rhs)   where     rhs_arity = idArity id     -- See Note [Demand signatures are computed for a threshold demand based on idArity]-    rhs_dmd -- See Note [Demand analysis for join points]-            -- See Note [Invariants on join points] invariant 2b, in GHC.Core-            --     rhs_arity matches the join arity of the join point-            | isJoinId id-            = mkCalledOnceDmds rhs_arity let_dmd-            | otherwise-            = mkCalledOnceDmds rhs_arity topSubDmd +    rhs_dmd = mkCalledOnceDmds rhs_arity body_dmd++    body_dmd+      | isJoinId id+      -- See Note [Demand analysis for join points]+      -- See Note [Invariants on join points] invariant 2b, in GHC.Core+      --     rhs_arity matches the join arity of the join point+      -- See Note [Unboxed demand on function bodies returning small products]+      = unboxedWhenSmall env rec_flag (resultType_maybe id) let_dmd+      | otherwise+      -- See Note [Unboxed demand on function bodies returning small products]+      = unboxedWhenSmall env rec_flag (resultType_maybe id) topSubDmd+     WithDmdType rhs_dmd_ty rhs' = dmdAnal env rhs_dmd rhs     DmdType rhs_fv rhs_dmds rhs_div = rhs_dmd_ty+    -- See Note [Do not unbox class dictionaries]+    -- See Note [Boxity for bottoming functions]+    (final_rhs_dmds, final_rhs) = finaliseArgBoxities env id rhs_arity rhs' rhs_div+                                  `orElse` (rhs_dmds, rhs') -    sig = mkStrictSigForArity rhs_arity (DmdType sig_fv rhs_dmds rhs_div)+    sig = mkDmdSigForArity rhs_arity (DmdType sig_fv final_rhs_dmds rhs_div) -    id' = id `setIdStrictness` sig-    !env' = extendAnalEnv top_lvl env id' sig+    final_id   = id `setIdDmdSig` 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@@ -932,6 +933,7 @@     --        might turn into used-many even if the signature was stable and     --        we'd have to do an additional iteration. reuseEnv makes sure that     --        we never get used-once info for FVs of recursive functions.+    --        See #14816 where we try to get rid of reuseEnv.     rhs_fv1 = case rec_flag of                 Recursive    -> reuseEnv rhs_fv                 NonRecursive -> rhs_fv@@ -942,6 +944,45 @@     -- See Note [Lazy and unleashable free variables]     !(!lazy_fv, !sig_fv) = partitionVarEnv isWeakDmd rhs_fv2 +-- | 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 (not . isNamedBinder) pis == idArity id+  = Just $! ret_ty+  | otherwise+  = Nothing++unboxedWhenSmall :: AnalEnv -> RecFlag -> Maybe Type -> SubDemand -> SubDemand+-- See Note [Unboxed demand on function bodies returning small products]+unboxedWhenSmall _   _        Nothing       sd = sd+unboxedWhenSmall env rec_flag (Just ret_ty) sd = go 1 ret_ty sd+  where+    -- Magic constant, bounding the depth of optimistic 'Unboxed' flags. We+    -- might want to minmax in the future.+    max_depth | isRec rec_flag = 3 -- So we get at most something as deep as !P(L!P(L!L))+              | otherwise      = 1 -- Otherwise be unbox too deep in T18109, T18174 and others and get a bunch of stack overflows+    go :: Int -> Type -> SubDemand -> SubDemand+    go depth ty sd+      | depth <= max_depth+      , Just (tc, tc_args, _co) <- normSplitTyConApp_maybe (ae_fam_envs env) ty+      , Just dc <- tyConSingleAlgDataCon_maybe tc+      , null (dataConExTyCoVars dc) -- Can't unbox results with existentials+      , dataConRepArity dc <= dmd_unbox_width (ae_opts env)+      , Just (_, ds) <- viewProd (dataConRepArity dc) sd+      , arg_tys <- map scaledThing $ dataConInstArgTys dc tc_args+      , equalLength ds arg_tys+      = mkProd Unboxed $! strictZipWith (go_dmd (depth+1)) arg_tys ds+      | otherwise+      = sd++    go_dmd :: Int -> Type -> Demand -> Demand+    go_dmd depth ty dmd = case dmd of+      AbsDmd  -> AbsDmd+      BotDmd  -> BotDmd+      n :* sd -> n :* go depth ty sd+ -- | If given the (local, non-recursive) let-bound 'Id', 'useLetUp' determines -- whether we should process the binding up (body before rhs) or down (rhs -- before body).@@ -1045,7 +1086,7 @@ Because idArity of a function varies independently of its cardinality properties (cf. Note [idArity varies independently of dmdTypeDepth]), we implicitly encode the arity for when a demand signature is sound to unleash-in its 'dmdTypeDepth' (cf. Note [Understanding DmdType and StrictSig] in+in its 'dmdTypeDepth' (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 Note [What are demand signatures?] in GHC.Types.Demand for more details@@ -1094,7 +1135,7 @@   * idArity is analysis information itself, thus volatile   * We already *have* dmdTypeDepth, wo why not just use it to encode the     threshold for when to unleash the signature-    (cf. Note [Understanding DmdType and StrictSig] in GHC.Types.Demand)+    (cf. Note [Understanding DmdType and DmdSig] in GHC.Types.Demand)  Consider the following expression, for example: @@ -1160,35 +1201,466 @@ disaster.  But regardless, #18638 was a more complicated version of this, that actually happened in practice. -Historical Note [Product demands for function body]+Note [Boxity for bottoming functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+```hs+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` and `u` boxed (although the+wrapper for `indexError` *will* unbox `p`). This pattern often occurs in+performance sensitive code that does bounds-checking.++It would be a shame to let `Boxed` win for the fields! So here's what we do:+While to summarising `indexError`'s boxity signature in `finaliseArgBoxities`,+we `unboxDeeplyDmd` all its argument demands and are careful not to discard+excess boxity in the `StopUnboxing` case, to get the signature+`<1!P(!S,!S)><1!S><S!S>b`.++Then worker/wrapper will not only unbox the pair passed to `indexError` (as it+would do anyway), demand analysis will also pretend that `indexError` needs `l`+and `u` unboxed (and the two other args). Which is a lie, because `indexError`'s+type abstracts over their types and could never unbox them.++The important change is at the *call sites* of `$windexError`: Boxity analysis+will conclude to unbox `l` and `u`, which *will* incur reboxing of crud that+should better float to the call site of `$windexError`. There we don't care+much, because it's in the slow, diverging code path! And that floating often+happens, but not always. See Note [Reboxed crud for bottoming calls].++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.+-}++{- *********************************************************************+*                                                                      *+             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 decicions+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)`+  * Implement fixes for corner cases Note [Do not unbox class dictionaries]+    and Note [mkWWstr and unsafeCoerce]++Then, in worker/wrapper blindly trusts the boxity info in the demand signature+and will not look at strictness info *at all*, in 'wantToUnboxArg'.++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 becuase+worker/wrapper ignores stricness 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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In 2013 I spotted this example, in shootout/binary_trees:+Consider T19407: -    Main.check' = \ b z ds. case z of z' { I# ip ->-                                case ds_d13s of-                                  Main.Nil -> z'-                                  Main.Node s14k s14l s14m ->-                                    Main.check' (not b)-                                      (Main.check' b-                                         (case b {-                                            False -> I# (-# s14h s14k);-                                            True  -> I# (+# s14h s14k)-                                          })-                                         s14l)-                                     s14m   }   }   }+  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 -Here we *really* want to unbox z, even though it appears to be used boxed in-the Nil case.  Partly the Nil case is not a hot path.  But more specifically,-the whole function gets the CPR property if we do.+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].) -That motivated using a demand of C1(C1(C1(P(L,L)))) for the RHS, where-(solely because the result was a product) we used a product demand-(albeit with lazy components) for the body. But that gives very silly-behaviour -- see #17932.   Happily it turns out now to be entirely-unnecessary: we get good results with C1(C1(C1(L))).   So I simply-deleted the special case.+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 'wantToUnboxArg' for its unboxing decision. It will+  /not/ look at the strictness bits of the demand, only at Boxity flags. As such,+  it will happily unbox 'a' despite the lazy demand on it.++The net effect is that boxity analysis and the w/w transformation are more+aggressive about unboxing the strict arguments of a data constructor than when+looking at strictness info exclusively. It is very much like (Nested) CPR, which+needs its nested fields to be evaluated in order for it to unbox nestedly.++There is the usual danger of reboxing, which as usual we ignore. But+if X is monomorphic, and has an UNPACK pragma, then this optimisation+is even more important.  We don't want the wrapper to rebox an unboxed+argument, and pass an Int to $wfoo!++This works in nested situations like T10482++    data family Bar a+    data instance Bar (a, b) = BarPair !(Bar a) !(Bar b)+    newtype instance Bar Int = Bar Int++    foo :: Bar ((Int, Int), Int) -> Int -> Int+    foo f k = case f of BarPair x y ->+              case burble of+                 True -> case x of+                           BarPair p q -> ...+                 False -> ...++The extra eagerness lets us produce a worker of type:+     $wfoo :: Int# -> Int# -> Int# -> Int -> Int+     $wfoo p# q# y# = ...++even though the `case x` is only lazily evaluated.++--------- Historical note ------------+We used to add data-con strictness demands when demand analysing case+expression. However, it was noticed in #15696 that this misses some cases. For+instance, consider the program (from T10482)++    data family Bar a+    data instance Bar (a, b) = BarPair !(Bar a) !(Bar b)+    newtype instance Bar Int = Bar Int++    foo :: Bar ((Int, Int), Int) -> Int -> Int+    foo f k =+      case f of+        BarPair x y -> case burble of+                          True -> case x of+                                    BarPair p q -> ...+                          False -> ...++We really should be able to assume that `p` is already evaluated since it came+from a strict field of BarPair. This strictness would allow us to produce a+worker of type:++    $wfoo :: Int# -> Int# -> Int# -> Int -> Int+    $wfoo p# q# y# = ...++even though the `case x` is only lazily evaluated++Indeed before we fixed #15696 this would happen since we would float the inner+`case x` through the `case burble` to get:++    foo f k =+      case f of+        BarPair x y -> case x of+                          BarPair p q -> case burble of+                                          True -> ...+                                          False -> ...++However, after fixing #15696 this could no longer happen (for the reasons+discussed in ticket:15696#comment:76). This means that the demand placed on `f`+would then be significantly weaker (since the False branch of the case on+`burble` is not strict in `p` or `q`).++Consequently, we now instead account for data-con strictness in mkWWstr_one,+applying the strictness demands to the final result of DmdAnal. The result is+that we get the strict demand signature we wanted even if we can't float+the case on `x` up through the case on `burble`.++Note [Do not unbox class dictionaries]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+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.++But in any other situation, a dictionary is just an ordinary value,+and can be unpacked.  So we track the INLINABLE pragma, and discard the boxity+flag in finaliseArgBoxities (see the isClassPred test).++Historical note: #14955 describes how I got this fix wrong the first time.++Note that the simplicity of this fix implies that INLINE functions (such as+wrapper functions after the WW run) will never say that they unbox class+dictionaries. That's not ideal, but not worth losing sleep over, as INLINE+functions will have been inlined by the time we run demand analysis so we'll+see the unboxing around the worker in client modules. I got aware of the issue+in T5075 by the change in boxity of loop between demand analysis runs.++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 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.++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.++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. -} +data Budgets = MkB Arity Budgets   -- An infinite list of arity budgets++incTopBudget :: Budgets -> Budgets+incTopBudget (MkB n bg) = MkB (n+1) bg++positiveTopBudget :: Budgets -> Bool+positiveTopBudget (MkB n _) = n >= 0++finaliseArgBoxities :: AnalEnv -> Id -> Arity -> CoreExpr -> Divergence+                    -> Maybe ([Demand], CoreExpr)+finaliseArgBoxities env fn arity rhs div+  | arity > count isId bndrs  -- Can't find enough binders+  = Nothing  -- This happens if we have   f = g+             -- Then there are no binders; we don't worker/wrapper; and we+             -- simply want to give f the same demand signature as g++  | otherwise+  = Just (arg_dmds', add_demands arg_dmds' rhs)+    -- add_demands: we must attach the final boxities to the lambda-binders+    -- of the function, both because that's kosher, and because CPR analysis+    -- uses the info on the binders directly.+  where+    opts            = ae_opts env+    fam_envs        = ae_fam_envs env+    is_inlinable_fn = isStableUnfolding (realIdUnfolding fn)+    (bndrs, _body)  = collectBinders rhs+    max_wkr_args    = dmd_max_worker_args opts `max` arity+                      -- See Note [Worker argument budget]++    -- This is the key line, which uses almost-circular programming+    -- The remaining budget from one layer becomes the initial+    -- budget for the next layer down.  See Note [Worker argument budget]+    (remaining_budget, arg_dmds') = go_args (MkB max_wkr_args remaining_budget) arg_triples++    arg_triples :: [(Type, StrictnessMark, Demand)]+    arg_triples = take arity $+                  map mk_triple $+                  filter isRuntimeVar bndrs++    mk_triple :: Id -> (Type,StrictnessMark,Demand)+    mk_triple bndr | is_cls_arg ty = (ty, NotMarkedStrict, trimBoxity dmd)+                   | is_bot_fn     = (ty, NotMarkedStrict, unboxDeeplyDmd dmd)+                   -- See Note [OPAQUE pragma]+                   -- See Note [The OPAQUE pragma and avoiding the reboxing of arguments]+                   | is_opaque     = (ty, NotMarkedStrict, trimBoxity dmd)+                   | otherwise     = (ty, NotMarkedStrict, dmd)+                   where+                     ty        = idType bndr+                     dmd       = idDemandInfo bndr+                     is_opaque = isOpaquePragma (idInlinePragma fn)++    -- is_cls_arg: see Note [Do not unbox class dictionaries]+    is_cls_arg arg_ty = is_inlinable_fn && isClassPred arg_ty+    -- 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 False fam_envs ty dmd of+          StopUnboxing+            | not is_bot_fn+                -- If bot: Keep deep boxity even though WW won't unbox+                -- See Note [Boxity for bottoming functions]+            -> (MkB (bg_top-1) bg_inner, trimBoxity dmd)++          Unbox DataConPatContext{dcpc_dc=dc, dcpc_tc_args=tc_args} dmds+            -> (MkB (bg_top-1) final_bg_inner, final_dmd)+            where+              dc_arity = dataConRepArity dc+              arg_tys  = dubiousDataConInstArgTys dc tc_args+              (bg_inner', dmds') = go_args (incTopBudget bg_inner) $+                                   zip3 arg_tys (dataConRepStrictness dc) dmds+              dmd' = n :* (mkProd Unboxed $! dmds')+              (final_bg_inner, final_dmd)+                  | dmds `lengthIs` dc_arity+                  , isStrict n || isMarkedStrict str_mark+                     -- isStrict: see Note [No lazy, Unboxed demands in demand signature]+                     -- isMarkedStrict: see Note [Unboxing evaluated arguments]+                  , positiveTopBudget bg_inner'+                  , NonRecursiveOrUnsure <- ae_rec_dc env dc+                     -- See Note [Which types are unboxed?]+                     -- and Note [Demand analysis for recursive data constructors]+                  = (bg_inner', dmd')+                  | otherwise+                  = (bg_inner, trimBoxity dmd)+          _ -> (bg, dmd)++    add_demands :: [Demand] -> CoreExpr -> CoreExpr+    -- Attach the demands to the outer lambdas of this expression+    add_demands [] e = e+    add_demands (dmd:dmds) (Lam v e)+      | isTyVar v = Lam v (add_demands (dmd:dmds) e)+      | otherwise = Lam (v `setIdDemandInfo` dmd) (add_demands dmds e)+    add_demands dmds e = pprPanic "add_demands" (ppr dmds $$ ppr e)++finaliseLetBoxity+  :: FamInstEnvs+  -> 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 ty mark dmd@(n :* _) =+      case wantToUnboxArg False env ty dmd of+        DropAbsent   -> dmd+        StopUnboxing -> trimBoxity dmd+        Unbox DataConPatContext{dcpc_dc=dc, dcpc_tc_args=tc_args} dmds+          | isStrict n || isMarkedStrict mark+          , dmds `lengthIs` dataConRepArity dc+          , let arg_tys = dubiousDataConInstArgTys dc tc_args+                dmds'   = strictZipWith3 go arg_tys (dataConRepStrictness dc) dmds+          -> n :* (mkProd Unboxed $! dmds')+          | otherwise+          -> trimBoxity dmd+        Unlift -> panic "No unlifting in DmdAnal"++ {- ********************************************************************* *                                                                      *                       Fixpoints@@ -1206,23 +1678,23 @@   = loop 1 initial_pairs   where     -- See Note [Initialising strictness]-    initial_pairs | ae_virgin env = [(setIdStrictness id botSig, rhs) | (id, rhs) <- orig_pairs ]+    initial_pairs | ae_virgin env = [(setIdDmdSig id botSig, rhs) | (id, rhs) <- orig_pairs ]                   | otherwise     = orig_pairs      -- If fixed-point iteration does not yield a result we use this instead     -- See Note [Safe abortion in the fixed-point iteration]     abort :: (AnalEnv, DmdEnv, [(Id,CoreExpr)])     abort = (env, lazy_fv', zapped_pairs)-      where (lazy_fv, pairs') = step True (zapIdStrictness orig_pairs)+      where (lazy_fv, pairs') = step True (zapIdDmdSig orig_pairs)             -- Note [Lazy and unleashable free variables]-            non_lazy_fvs = plusVarEnvList $ map (strictSigDmdEnv . idStrictness . fst) pairs'+            non_lazy_fvs = plusVarEnvList $ map (dmdSigDmdEnv . idDmdSig . fst) pairs'             lazy_fv'     = lazy_fv `plusVarEnv` mapVarEnv (const topDmd) non_lazy_fvs-            zapped_pairs = zapIdStrictness pairs'+            zapped_pairs = zapIdDmdSig pairs' -    -- The fixed-point varies the idStrictness field of the binders, and terminates if that+    -- The fixed-point varies the idDmdSig field of the binders, and terminates if that     -- annotation does not change any more.     loop :: Int -> [(Id,CoreExpr)] -> (AnalEnv, DmdEnv, [(Id,CoreExpr)])-    loop n pairs = -- pprTrace "dmdFix" (ppr n <+> vcat [ ppr id <+> ppr (idStrictness id)+    loop n pairs = -- pprTrace "dmdFix" (ppr n <+> vcat [ ppr id <+> ppr (idDmdSig id)                    --                                     | (id,_)<- pairs]) $                    loop' n pairs @@ -1231,7 +1703,7 @@       | n == 10        = abort       | otherwise      = loop (n+1) pairs'       where-        found_fixpoint    = map (idStrictness . fst) pairs' == map (idStrictness . fst) pairs+        found_fixpoint    = map (idDmdSig . fst) pairs' == map (idDmdSig . fst) pairs         first_round       = n == 1         (lazy_fv, pairs') = step first_round pairs         final_anal_env    = extendAnalEnvs top_lvl env (map fst pairs')@@ -1251,18 +1723,17 @@                 -- so this can significantly reduce the number of iterations needed          my_downRhs (env, lazy_fv) (id,rhs)-          = -- pprTrace "my_downRhs" (ppr id $$ ppr (idStrictness id) $$ ppr sig) $+          = -- pprTrace "my_downRhs" (ppr id $$ ppr (idDmdSig id) $$ ppr sig) $             ((env', lazy_fv'), (id', rhs'))           where             !(!env', !lazy_fv1, !id', !rhs') = dmdAnalRhsSig top_lvl Recursive env let_dmd id rhs             !lazy_fv'                    = plusVarEnv_C plusDmd lazy_fv lazy_fv1 -    zapIdStrictness :: [(Id, CoreExpr)] -> [(Id, CoreExpr)]-    zapIdStrictness pairs = [(setIdStrictness id nopSig, rhs) | (id, rhs) <- pairs ]+    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:@@ -1334,9 +1805,12 @@ unitDmdType dmd_env = DmdType dmd_env [] topDiv  coercionDmdEnv :: Coercion -> DmdEnv-coercionDmdEnv co = mapVarEnv (const topDmd) (getUniqSet $ coVarsOfCo co)-                    -- The VarSet from coVarsOfCo is really a VarEnv Var+coercionDmdEnv co = coercionsDmdEnv [co] +coercionsDmdEnv :: [Coercion] -> DmdEnv+coercionsDmdEnv cos = mapVarEnv (const topDmd) (getUniqSet $ coVarsOfCos cos)+                      -- The VarSet from coVarsOfCos is really a VarEnv Var+ addVarDmd :: DmdType -> Var -> Demand -> DmdType addVarDmd (DmdType fv ds res) var dmd   = DmdType (extendVarEnv_C plusDmd fv var dmd) ds res@@ -1376,52 +1850,32 @@ dictionaries. -} -setBndrsDemandInfo :: [Var] -> [Demand] -> [Var]+setBndrsDemandInfo :: HasCallStack => [Var] -> [Demand] -> [Var] setBndrsDemandInfo (b:bs) ds   | isTyVar b = b : setBndrsDemandInfo bs ds setBndrsDemandInfo (b:bs) (d:ds) =     let !new_info = setIdDemandInfo b d         !vars = setBndrsDemandInfo bs ds     in new_info : vars-setBndrsDemandInfo [] ds = ASSERT( null ds ) []+setBndrsDemandInfo [] ds = assert (null ds) [] setBndrsDemandInfo bs _  = pprPanic "setBndrsDemandInfo" (ppr bs) -annotateBndr :: AnalEnv -> DmdType -> Var -> WithDmdType Var--- The returned env has the var deleted--- The returned var is annotated with demand info--- according to the result demand of the provided demand type--- No effect on the argument demands-annotateBndr env dmd_ty var-  | isId var  = WithDmdType dmd_ty' new_id-  | otherwise = WithDmdType dmd_ty  var-  where-    new_id = setIdDemandInfo var dmd-    WithDmdType dmd_ty' dmd = findBndrDmd env False dmd_ty var- annotateLamIdBndr :: AnalEnv-                  -> DFunFlag   -- is this lambda at the top of the RHS of a dfun?                   -> DmdType    -- Demand type of body                   -> Id         -- Lambda binder                   -> WithDmdType Id  -- Demand type of lambda                                      -- and binder annotated with demand -annotateLamIdBndr env arg_of_dfun dmd_ty id+annotateLamIdBndr env dmd_ty id -- For lambdas we add the demand to the argument demands -- Only called for Ids-  = ASSERT( isId id )+  = assert (isId id) $     -- pprTrace "annLamBndr" (vcat [ppr id, ppr dmd_ty, ppr final_ty]) $-    WithDmdType final_ty new_id+    WithDmdType main_ty new_id   where-    new_id = setIdDemandInfo id dmd-      -- Watch out!  See note [Lambda-bound unfoldings]-    final_ty = case maybeUnfoldingTemplate (idUnfolding id) of-                 Nothing  -> main_ty-                 Just unf -> main_ty `plusDmdType` unf_ty-                          where-                             (unf_ty, _) = dmdAnalStar env dmd unf-+    new_id  = setIdDemandInfo id dmd     main_ty = addDemand dmd dmd_ty'-    WithDmdType dmd_ty' dmd = findBndrDmd env arg_of_dfun dmd_ty id+    WithDmdType dmd_ty' dmd = findBndrDmd env dmd_ty id  {- Note [NOINLINE and strictness] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1431,7 +1885,7 @@ 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 [Worker/wrapper for NOINLINE functions] in GHC.Core.Opt.WorkWrap.   Note [Lazy and unleashable free variables]@@ -1491,16 +1945,6 @@ demand put on them (topDmd), and add that to the "lazy_fv" returned by "dmdFix".  -Note [Lambda-bound unfoldings]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We allow a lambda-bound variable to carry an unfolding, a facility that is used-exclusively for join points; see Note [Case binders and join points].  If so,-we must be careful to demand-analyse the RHS of the unfolding!  Example-   \x. \y{=Just x}. <body>-Then if <body> uses 'y', then transitively it uses 'x', and we must not-forget that fact, otherwise we might make 'x' absent when it isn't.-- ************************************************************************ *                                                                      * \subsection{Strictness signatures}@@ -1508,18 +1952,17 @@ ************************************************************************ -} -type DFunFlag = Bool  -- indicates if the lambda being considered is in the-                      -- sequence of lambdas at the top of the RHS of a dfun-notArgOfDfun :: DFunFlag-notArgOfDfun = False  data AnalEnv = AE-   { ae_strict_dicts :: !Bool -- ^ Enable strict dict-   , ae_sigs         :: !SigEnv-   , ae_virgin       :: !Bool -- ^ True on first iteration only-                              -- See Note [Initialising strictness]-   , ae_fam_envs     :: !FamInstEnvs-   }+  { 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@@ -1528,51 +1971,45 @@         -- The DmdEnv gives the demand on the free vars of the function         -- when it is given enough args to satisfy the strictness signature -type SigEnv = VarEnv (StrictSig, TopLevelFlag)+type SigEnv = VarEnv (DmdSig, TopLevelFlag)  instance Outputable AnalEnv where   ppr env = text "AE" <+> braces (vcat          [ text "ae_virgin =" <+> ppr (ae_virgin env)-         , text "ae_strict_dicts =" <+> ppr (ae_strict_dicts env)          , text "ae_sigs =" <+> ppr (ae_sigs env)          ])  emptyAnalEnv :: DmdAnalOpts -> FamInstEnvs -> AnalEnv emptyAnalEnv opts fam_envs-    = AE { ae_strict_dicts = dmd_strict_dicts opts+    = AE { ae_opts         = opts          , ae_sigs         = emptySigEnv          , ae_virgin       = True          , ae_fam_envs     = fam_envs+         , ae_rec_dc       = memoiseUniqueFun (isRecDataCon fam_envs 3)          }  emptySigEnv :: SigEnv emptySigEnv = emptyVarEnv --- | Extend an environment with the strictness sigs attached to the Ids+-- | Extend an environment with the strictness IDs attached to the id extendAnalEnvs :: TopLevelFlag -> AnalEnv -> [Id] -> AnalEnv extendAnalEnvs top_lvl env vars   = env { ae_sigs = extendSigEnvs top_lvl (ae_sigs env) vars }  extendSigEnvs :: TopLevelFlag -> SigEnv -> [Id] -> SigEnv extendSigEnvs top_lvl sigs vars-  = extendVarEnvList sigs [ (var, (idStrictness var, top_lvl)) | var <- vars]+  = extendVarEnvList sigs [ (var, (idDmdSig var, top_lvl)) | var <- vars] -extendAnalEnv :: TopLevelFlag -> AnalEnv -> Id -> StrictSig -> AnalEnv+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 -> StrictSig -> SigEnv+extendSigEnv :: TopLevelFlag -> SigEnv -> Id -> DmdSig -> SigEnv extendSigEnv top_lvl sigs var sig = extendVarEnv sigs var (sig, top_lvl) -lookupSigEnv :: AnalEnv -> Id -> Maybe (StrictSig, TopLevelFlag)+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 } @@ -1584,13 +2021,13 @@     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 False dmd_ty1 b+                        WithDmdType dmd_ty2 dmd  = findBndrDmd env dmd_ty1 b                     in WithDmdType dmd_ty2  (dmd : dmds)       | otherwise = go dmd_ty bs -findBndrDmd :: AnalEnv -> Bool -> DmdType -> Id -> WithDmdType Demand+findBndrDmd :: AnalEnv -> DmdType -> Id -> WithDmdType Demand -- See Note [Trimming a demand to a type]-findBndrDmd env arg_of_dfun dmd_ty id+findBndrDmd env dmd_ty id   = -- pprTrace "findBndrDmd" (ppr id $$ ppr dmd_ty $$ ppr starting_dmd $$ ppr dmd') $     WithDmdType dmd_ty' dmd'   where@@ -1602,31 +2039,61 @@     id_ty = idType id      strictify dmd-      | ae_strict_dicts env+      -- See Note [Making dictionaries strict]+      | dmd_strict_dicts (ae_opts env)              -- We never want to strictify a recursive let. At the moment-             -- annotateBndr is only call for non-recursive lets; if that+             -- findBndrDmd is never called for recursive lets; if that              -- changes, we need a RecFlag parameter and another guard here.-      , not arg_of_dfun -- See Note [Do not strictify the argument dictionaries of a dfun]       = strictifyDictDmd id_ty dmd       | otherwise       = dmd      fam_envs = ae_fam_envs env -{- Note [Bringing a new variable into scope]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-   f x = blah-   g = ...(\f. ...f...)...+{- Note [Making dictionaries strict]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The Opt_DictsStrict flag makes GHC use call-by-value for dictionaries.  Why? -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).+* Generally CBV is more efficient. -Note [Initialising strictness]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+* Dictionaries are always non-bottom; and never take much work to+  compute.  E.g. a dfun from an instance decl always returns a dicionary+  record immediately.  See DFunUnfolding in CoreSyn.+  See also Note [Recursive superclasses] in TcInstDcls. +* The strictness analyser will then unbox dictionaries and pass the+  methods individually, rather than in a bundle.  If there are a lot of+  methods that might be bad; but worker/wrapper already does throttling.++* A newtype dictionary is *not* always non-bottom.  E.g.+      class C a where op :: a -> a+      instance C Int where op = error "urk"+  Now a value of type (C Int) is just a newtype wrapper (a cast) around+  the error thunk.  Don't strictify these!++See #17758 for more background and perf numbers.++The implementation is extremly simple: just make the strictness+analyser strictify the demand on a dictionary binder in+'findBndrDmd'.++However there is one case where this can make performance worse.+For the principle consider some function at the core level:+    myEq :: Eq a => a -> a -> Bool+    myEq eqDict x y = ((==) eqDict) x y+If we make the dictionary strict then WW can fire turning this into:+    $wmyEq :: (a -> a -> Bool) -> a -> a -> Bool+    $wmyEq eq x y = eq x y+Which *usually* performs better. However if the dictionary is known we+are far more likely to inline a function applied to the dictionary than+to inline one applied to a function. Sometimes this makes just enough+of a difference to stop a function from inlining. This is documented in #18421.++It's somewhat similar to Note [Do not unbox class dictionaries] although+here our problem is with the inliner, not the specializer.++Note [Initialising strictness]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ See section 9.2 (Finding fixpoints) of the paper.  Our basic plan is to initialise the strictness of each Id in a
GHC/Core/Opt/Exitify.hs view
@@ -41,7 +41,7 @@ import GHC.Types.Id.Info import GHC.Core import GHC.Core.Utils-import GHC.Utils.Monad.State+import GHC.Utils.Monad.State.Strict import GHC.Builtin.Uniques import GHC.Types.Var.Set import GHC.Types.Var.Env@@ -131,11 +131,11 @@     -- 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+    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+       -> CoreExprWithFVs -- Current expression in tail position        -> ExitifyM CoreExpr      -- We first look at the expression (no matter what it shape is)@@ -310,7 +310,7 @@  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])+ * 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
GHC/Core/Opt/FloatIn.hs view
@@ -12,51 +12,38 @@ then discover that they aren't needed in the chosen branch. -} -{-# LANGUAGE CPP #-}+ {-# OPTIONS_GHC -fprof-auto #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}  module GHC.Core.Opt.FloatIn ( floatInwards ) where -#include "HsVersions.h"- import GHC.Prelude import GHC.Platform -import GHC.Driver.Session- import GHC.Core import GHC.Core.Make hiding ( wrapFloats ) import GHC.Core.Utils import GHC.Core.FVs-import GHC.Core.Opt.Monad   ( CoreM ) import GHC.Core.Type -import GHC.Types.Basic      ( RecFlag(..), isRec )+import GHC.Types.Basic      ( RecFlag(..), isRec, Levity(Unlifted) ) import GHC.Types.Id         ( isOneShotBndr, idType, isJoinId, isJoinId_maybe ) import GHC.Types.Tickish import GHC.Types.Var import GHC.Types.Var.Set -import GHC.Unit.Module.ModGuts- import GHC.Utils.Misc import GHC.Utils.Panic--import GHC.Utils.Outputable--import Data.List        ( mapAccumL )+import GHC.Utils.Panic.Plain  {- Top-level interface function, @floatInwards@.  Note that we do not actually float any bindings downwards from the top-level. -} -floatInwards :: ModGuts -> CoreM ModGuts-floatInwards pgm@(ModGuts { mg_binds = binds })-  = do { dflags <- getDynFlags-       ; let platform = targetPlatform dflags-       ; return (pgm { mg_binds = map (fi_top_bind platform) binds }) }+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))@@ -136,7 +123,7 @@ ************************************************************************ -} -type FreeVarSet  = DVarSet+type FreeVarSet  = DIdSet type BoundVarSet = DIdSet  data FloatInBind = FB BoundVarSet FreeVarSet FloatBind@@ -144,33 +131,28 @@         -- 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 ])+type FloatInBinds = [FloatInBind]+        -- In reverse dependency order (innermost binder first)  fiExpr :: Platform-       -> RevFloatInBinds   -- Binds we're trying to drop+       -> FloatInBinds      -- Binds we're trying to drop                             -- as far "inwards" as possible        -> CoreExprWithFVs   -- Input expr        -> CoreExpr          -- Result  fiExpr _ to_drop (_, AnnLit lit)     = wrapFloats to_drop (Lit lit)                                        -- See Note [Dead bindings]-fiExpr _ to_drop (_, AnnType ty)     = ASSERT( null to_drop ) Type ty+fiExpr _ to_drop (_, 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 $+  = wrapFloats (drop_here ++ co_drop) $     Cast (fiExpr platform e_drop expr) co   where-    (drop_here, [e_drop])-      = sepBindsByDropPoint platform False to_drop-          (freeVarsOfAnn co_ann) [freeVarsOf expr]+    [drop_here, e_drop, co_drop]+      = sepBindsByDropPoint platform False+          [freeVarsOf expr, freeVarsOfAnn co_ann]+          to_drop  {- Applications: we do float inside applications, mainly because we@@ -179,7 +161,7 @@ -}  fiExpr platform to_drop ann_expr@(_,AnnApp {})-  = wrapFloats drop_here $+  = wrapFloats drop_here $ wrapFloats extra_drop $     mkTicks ticks $     mkApps (fiExpr platform fun_drop ann_fun)            (zipWithEqual "fiExpr" (fiExpr platform) arg_drops ann_args)@@ -189,18 +171,19 @@     (ann_fun, ann_args, ticks) = collectAnnArgsTicks tickishFloatable ann_expr     fun_ty  = exprType (deAnnotate ann_fun)     fun_fvs = freeVarsOf ann_fun--    (drop_here, fun_drop : arg_drops)-       = sepBindsByDropPoint platform False to_drop-                             here_fvs (fun_fvs : arg_fvs)+    arg_fvs = map freeVarsOf ann_args +    (drop_here : extra_drop : fun_drop : arg_drops)+       = sepBindsByDropPoint platform False+                             (extra_fvs : fun_fvs : arg_fvs)+                             to_drop          -- Shortcut behaviour: if to_drop is empty,          -- sepBindsByDropPoint returns a suitable bunch of empty          -- lists without evaluating extra_fvs, and hence without          -- peering into each argument -    ((_,here_fvs), arg_fvs) = mapAccumL add_arg (fun_ty,here_fvs0) ann_args-    here_fvs0 = case ann_fun of+    (_, extra_fvs) = foldl' add_arg (fun_ty, extra_fvs0) ann_args+    extra_fvs0 = case ann_fun of                    (_, AnnVar _) -> fun_fvs                    _             -> emptyDVarSet           -- Don't float the binding for f into f x y z; see Note [Join points]@@ -208,13 +191,15 @@           -- join point, floating it in isn't especially harmful but it's           -- useless since the simplifier will immediately float it back out.) -    add_arg :: (Type,FreeVarSet) -> CoreExprWithFVs -> ((Type,FreeVarSet),FreeVarSet)-    add_arg (fun_ty, here_fvs) (arg_fvs, AnnType ty)-      = ((piResultTy fun_ty ty, here_fvs), arg_fvs)-    -- We can't float into some arguments, so put them into the here_fvs-    add_arg (fun_ty, here_fvs) (arg_fvs, arg)-      | noFloatIntoArg arg arg_ty = ((res_ty,here_fvs `unionDVarSet` arg_fvs), emptyDVarSet)-      | otherwise          = ((res_ty,here_fvs), arg_fvs)+    add_arg :: (Type,FreeVarSet) -> CoreExprWithFVs -> (Type,FreeVarSet)+    add_arg (fun_ty, extra_fvs) (_, AnnType ty)+      = (piResultTy fun_ty ty, extra_fvs)++    add_arg (fun_ty, extra_fvs) (arg_fvs, arg)+      | noFloatIntoArg arg arg_ty+      = (res_ty, extra_fvs `unionDVarSet` arg_fvs)+      | otherwise+      = (res_ty, extra_fvs)       where        (_, arg_ty, res_ty) = splitFunTy fun_ty @@ -298,6 +283,7 @@ 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@@ -317,36 +303,6 @@ 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, 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, beause any bindings mentioning them will be dropped-  here unconditionally. -}  fiExpr platform to_drop lam@(_, AnnLam _ _)@@ -355,18 +311,11 @@   = wrapFloats to_drop (mkLams bndrs (fiExpr platform [] body))    | otherwise           -- Float inside-  = wrapFloats drop_here $-    mkLams bndrs (fiExpr platform body_drop body)+  = mkLams bndrs (fiExpr platform to_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@@ -404,7 +353,7 @@ things to drop in the outer let's body, and let nature take its course. -Note [extra_fvs (1): avoid floating into RHS]+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@@ -422,7 +371,7 @@ 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]+Note [extra_fvs (2)]: free variables of rules ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider   let x{rule mentioning y} = rhs in body@@ -499,21 +448,22 @@  fiExpr platform to_drop (_, AnnCase scrut case_bndr _ [AnnAlt con alt_bndrs rhs])   | isUnliftedType (idType case_bndr)+     -- binders have a fixed RuntimeRep so it's OK to call isUnliftedType   , exprOkForSideEffects (deAnnotate scrut)       -- See Note [Floating primops]   = wrapFloats shared_binds $     fiExpr platform (case_float : rhs_binds) rhs   where-    case_float = FB all_bndrs scrut_fvs+    case_float = FB (mkDVarSet (case_bndr : alt_bndrs)) scrut_fvs                     (FloatCase scrut' case_bndr con alt_bndrs)     scrut'     = fiExpr platform scrut_binds scrut-    rhs_fvs    = freeVarsOf rhs    -- No need to delete alt_bndrs-    scrut_fvs  = freeVarsOf scrut  -- See Note [Shadowing and name capture]-    all_bndrs  = mkDVarSet alt_bndrs `extendDVarSet` case_bndr+    rhs_fvs    = freeVarsOf rhs `delDVarSetList` (case_bndr : alt_bndrs)+    scrut_fvs  = freeVarsOf scrut -    (shared_binds, [scrut_binds, rhs_binds])-       = sepBindsByDropPoint platform False to_drop-                     all_bndrs [scrut_fvs, rhs_fvs]+    [shared_binds, scrut_binds, rhs_binds]+       = sepBindsByDropPoint platform False+           [scrut_fvs, rhs_fvs]+           to_drop  fiExpr platform to_drop (_, AnnCase scrut case_bndr ty alts)   = wrapFloats drop_here1 $@@ -523,43 +473,39 @@          -- 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]+    [drop_here1, scrut_drops, alts_drops]+       = sepBindsByDropPoint platform False+           [scrut_fvs, all_alts_fvs]+           to_drop          -- Float into the alts with the is_case flag set-    (drop_here2, alts_drops_s)-       = 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]+    (drop_here2 : alts_drops_s)+      | [ _ ] <- alts = [] : [alts_drops]+      | otherwise     = sepBindsByDropPoint platform True alts_fvs alts_drops -    all_alt_fvs :: DVarSet-    all_alt_fvs = foldr unionDVarSet (unitDVarSet case_bndr) alts_fvs+    scrut_fvs    = freeVarsOf scrut+    alts_fvs     = map alt_fvs alts+    all_alts_fvs = unionDVarSets alts_fvs+    alt_fvs (AnnAlt _con args rhs)+      = foldl' delDVarSet (freeVarsOf rhs) (case_bndr:args)+           -- Delete case_bndr and args from free vars of rhs+           -- to get free vars of alt      fi_alt to_drop (AnnAlt con args rhs) = Alt con args (fiExpr platform to_drop rhs)  ------------------ fiBind :: Platform-       -> 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+       -> FloatInBinds      -- Binds we're trying to drop+                            -- as far "inwards" as possible+       -> CoreBindWithFVs   -- Input binding+       -> DVarSet           -- Free in scope of binding+       -> ( FloatInBinds    -- Land these before+          , FloatInBind     -- The binding itself+          , FloatInBinds)   -- Land these after  fiBind platform to_drop (AnnNonRec id ann_rhs@(rhs_fvs, rhs)) body_fvs-  = ( shared_binds          -- Land these before-                                           -- See Note [extra_fvs (1,2)]+  = ( extra_binds ++ shared_binds          -- Land these before+                                           -- See Note [extra_fvs (1)] and Note [extra_fvs (2)]     , FB (unitDVarSet id) rhs_fvs'         -- The new binding itself           (FloatLet (NonRec id rhs'))     , body_binds )                         -- Land these after@@ -567,19 +513,20 @@   where     body_fvs2 = body_fvs `delDVarSet` id -    rule_fvs = bndrRuleAndUnfoldingVarsDSet id        -- See Note [extra_fvs (2): free variables of rules]+    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): avoid floating into RHS]+        -- 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]+    [shared_binds, extra_binds, rhs_binds, body_binds]+        = sepBindsByDropPoint platform False+            [extra_fvs, rhs_fvs, body_fvs2]+            to_drop          -- Push rhs_binds into the right hand side of the binding     rhs'     = fiRhs platform rhs_binds id ann_rhs@@ -587,7 +534,7 @@                         -- Don't forget the rule_fvs; the binding mentions them!  fiBind platform to_drop (AnnRec bindings) body_fvs-  = ( shared_binds+  = ( extra_binds ++ shared_binds     , FB (mkDVarSet ids) rhs_fvs'          (FloatLet (Rec (fi_bind rhss_binds bindings)))     , body_binds )@@ -595,22 +542,23 @@     (ids, rhss) = unzip bindings     rhss_fvs = map freeVarsOf rhss -        -- See Note [extra_fvs (1,2)]+        -- 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)+    (shared_binds:extra_binds:body_binds:rhss_binds)+        = sepBindsByDropPoint platform False+            (extra_fvs:body_fvs:rhss_fvs)+            to_drop      rhs_fvs' = unionDVarSets rhss_fvs `unionDVarSet`                unionDVarSets (map floatedBindsFVs rhss_binds) `unionDVarSet`                rule_fvs         -- Don't forget the rule variables!      -- Push rhs_binds into the right hand side of the binding-    fi_bind :: [RevFloatInBinds]   -- One per "drop pt" conjured w/ fvs_of_rhss+    fi_bind :: [FloatInBinds]       -- one per "drop pt" conjured w/ fvs_of_rhss             -> [(Id, CoreExprWithFVs)]             -> [(Id, CoreExpr)] @@ -619,7 +567,7 @@         | ((binder, rhs), to_drop) <- zipEqual "fi_bind" pairs to_drops ]  -------------------fiRhs :: Platform -> RevFloatInBinds -> CoreBndr -> CoreExprWithFVs -> CoreExpr+fiRhs :: Platform -> FloatInBinds -> CoreBndr -> CoreExprWithFVs -> CoreExpr fiRhs platform to_drop bndr rhs   | Just join_arity <- isJoinId_maybe bndr   , let (bndrs, body) = collectNAnnBndrs join_arity rhs@@ -645,7 +593,7 @@  noFloatIntoArg :: CoreExprWithFVs' -> Type -> Bool noFloatIntoArg expr expr_ty-  | isUnliftedType expr_ty+  | Just Unlifted <- typeLevity_maybe expr_ty   = True  -- See Note [Do not destroy the let/app invariant]     | AnnLam bndr e <- expr@@ -654,7 +602,7 @@    || all isTyVar (bndr:bndrs)     -- Wrinkle 1 (b)       -- See Note [noFloatInto considerations] wrinkle 2 -  | otherwise  -- Note [noFloatInto considerations] wrinkle 2+  | otherwise  -- See Note [noFloatInto considerations] wrinkle 2   = exprIsTrivial deann_expr || exprIsHNF deann_expr   where     deann_expr = deAnnotate' expr@@ -719,84 +667,68 @@ We have to maintain the order on these drop-point-related lists. -} --- pprFIB :: RevFloatInBinds -> SDoc+-- pprFIB :: FloatInBinds -> 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+    -> Bool                -- True <=> is case expression+    -> [FreeVarSet]        -- One set of FVs per drop point+                           -- Always at least two long!+    -> FloatInBinds        -- Candidate floaters+    -> [FloatInBinds]      -- FIRST one is bindings which must not be floated+                           -- inside any drop point; the rest correspond+                           -- one-to-one with the input list of FV sets  -- Every input floater is returned somewhere in the result; -- none are dropped, not even ones which don't seem to be -- free in *any* of the drop-point fvs.  Why?  Because, for example, -- a binding (let x = E in B) might have a specialised version of -- x (say x') stored inside x, but x' isn't free in E or B.------ 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+sepBindsByDropPoint platform is_case drop_pts floaters   | null floaters  -- Shortcut common case-  = ([], [[] | _ <- fork_fvs])+  = [] : [[] | _ <- drop_pts]    | otherwise-  = go floaters (initDropBox here_fvs) (map initDropBox fork_fvs)+  = assert (drop_pts `lengthAtLeast` 2) $+    go floaters (map (\fvs -> (fvs, [])) (emptyDVarSet : drop_pts))   where-    n_alts = length fork_fvs+    n_alts = length drop_pts -    go :: RevFloatInBinds -> DropBox -> [DropBox]-       -> (RevFloatInBinds, [RevFloatInBinds])-        -- The *first* one in the pair is the drop_here set+    go :: FloatInBinds -> [DropBox] -> [FloatInBinds]+        -- The *first* one in the argument list is the drop_here set+        -- The FloatInBinds in the lists are in the reverse of+        -- the normal FloatInBinds order; that is, they are the right way round! -    go [] here_box fork_boxes-        = (dropBoxFloats here_box, map dropBoxFloats fork_boxes)+    go [] drop_boxes = map (reverse . snd) drop_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+    go (bind_w_fvs@(FB bndrs bind_fvs bind) : binds) drop_boxes@(here_box : fork_boxes)+        = go binds new_boxes         where           -- "here" means the group of bindings dropped at the top of the fork -          used_here     = 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+          (used_here : used_in_flags) = [ fvs `intersectsDVarSet` bndrs+                                        | (fvs, _) <- drop_boxes]            drop_here = used_here || cant_push            n_used_alts = count id used_in_flags -- returns number of Trues in list.            cant_push-            | is_case   = (n_alts > 1 && n_used_alts == n_alts)-                             -- Used in all, muliple branches, don't push+            | is_case   = n_used_alts == n_alts   -- Used in all, don't push+                                                  -- Remember n_alts > 1                           || (n_used_alts > 1 && not (floatIsDupable platform bind))                              -- floatIsDupable: see Note [Duplicating floats]              | otherwise = floatIsCase bind || n_used_alts > 1                              -- floatIsCase: see Note [Floating primops] +          new_boxes | drop_here = (insert here_box : fork_boxes)+                    | otherwise = (here_box : new_fork_boxes)+           new_fork_boxes = zipWithEqual "FloatIn.sepBinds" insert_maybe                                         fork_boxes used_in_flags @@ -806,10 +738,11 @@           insert_maybe box True  = insert box           insert_maybe box False = box +    go _ _ = panic "sepBindsByDropPoint/go" + {- Note [Duplicating floats] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~- For case expressions we duplicate the binding if it is reasonably small, and if it is not used in all the RHSs This is good for situations like@@ -823,14 +756,14 @@ so we don't duplicate then. -} -floatedBindsFVs :: RevFloatInBinds -> FreeVarSet+floatedBindsFVs :: FloatInBinds -> 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 :: FloatInBinds -> CoreExpr -> CoreExpr+-- Remember FloatInBinds is in *reverse* dependency order wrapFloats []               e = e wrapFloats (FB _ _ fl : bs) e = wrapFloats bs (wrapFloat fl e)
GHC/Core/Opt/FloatOut.hs view
@@ -6,8 +6,8 @@ ``Long-distance'' floating of bindings towards the top level. -} -{-# LANGUAGE CPP #-} + module GHC.Core.Opt.FloatOut ( floatOutwards ) where  import GHC.Prelude@@ -19,7 +19,7 @@ import GHC.Core.Opt.Monad ( FloatOutSwitches(..) )  import GHC.Driver.Session-import GHC.Utils.Logger  ( dumpIfSet_dyn, DumpFormat (..), Logger )+import GHC.Utils.Logger import GHC.Types.Id      ( Id, idArity, idType, isDeadEndId,                            isJoinId, isJoinId_maybe ) import GHC.Types.Tickish@@ -35,8 +35,6 @@  import Data.List        ( partition ) -#include "HsVersions.h"- {-         -----------------         Overall game plan@@ -166,23 +164,22 @@  floatOutwards :: Logger               -> FloatOutSwitches-              -> DynFlags               -> UniqSupply               -> CoreProgram -> IO CoreProgram -floatOutwards logger float_sws dflags us pgm+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)             } ; -        dumpIfSet_dyn logger dflags Opt_D_verbose_core2core "Levels added:"+        putDumpFileMaybe logger Opt_D_verbose_core2core "Levels added:"                   FormatCore                   (vcat (map ppr annotated_w_levels));          let { (tlets, ntlets, lams) = get_stats (sum_stats fss) }; -        dumpIfSet_dyn logger dflags Opt_D_dump_simpl_stats "FloatOut stats:"+        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 ",@@ -272,6 +269,8 @@   = 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@@ -283,7 +282,7 @@                                                    -- non-rec  installUnderLambdas :: Bag FloatBind -> CoreExpr -> CoreExpr--- Note [Floating out of Rec rhss]+-- See Note [Floating out of Rec rhss] installUnderLambdas floats e   | isEmptyBag floats = e   | otherwise         = go e@@ -377,7 +376,6 @@  {- Note [Floating past breakpoints] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~- We used to disallow floating out of breakpoint ticks (see #10052). However, I think this is too restrictive. @@ -431,7 +429,7 @@     in     (fs, annotated_defns, Tick tickish expr') } -  -- Note [Floating past breakpoints]+  -- See Note [Floating past breakpoints]   | Breakpoint{} <- tickish   = case (floatExpr expr)    of { (fs, floating_defns, expr') ->     (fs, floating_defns, Tick tickish expr') }@@ -629,8 +627,8 @@  flattenTopFloats :: FloatBinds -> Bag CoreBind flattenTopFloats (FB tops ceils defs)-  = ASSERT2( isEmptyBag (flattenMajor defs), ppr defs )-    ASSERT2( isEmptyBag ceils, ppr ceils )+  = assertPpr (isEmptyBag (flattenMajor defs)) (ppr defs) $+    assertPpr (isEmptyBag ceils) (ppr ceils)     tops  addTopFloatPairs :: Bag CoreBind -> [(Id,CoreExpr)] -> [(Id,CoreExpr)]
GHC/Core/Opt/LiberateCase.hs view
@@ -4,10 +4,8 @@ \section[LiberateCase]{Unroll recursion to allow evals to be lifted from a loop} -} -{-# LANGUAGE CPP #-}-module GHC.Core.Opt.LiberateCase ( liberateCase ) where -#include "HsVersions.h"+module GHC.Core.Opt.LiberateCase ( liberateCase ) where  import GHC.Prelude @@ -170,7 +168,7 @@      ok_pair (id,_)         =  idArity id > 0       -- Note [Only functions!]-        && not (isDeadEndId id) -- Note [Not bottoming ids]+        && not (isDeadEndId id) -- Note [Not bottoming Ids]  {- Note [Not bottoming Ids] ~~~~~~~~~~~~~~~~~~~~~~~~~~~
GHC/Core/Opt/Monad.hs view
@@ -3,7 +3,7 @@  -} -{-# LANGUAGE CPP #-}+ {-# LANGUAGE DeriveFunctor #-}  {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}@@ -42,10 +42,9 @@     getAnnotations, getFirstAnnotations,      -- ** Screen output-    putMsg, putMsgS, errorMsg, errorMsgS, warnMsg,+    putMsg, putMsgS, errorMsg, errorMsgS, msg,     fatalErrorMsg, fatalErrorMsgS,     debugTraceMsg, debugTraceMsgS,-    dumpIfSet_dyn   ) where  import GHC.Prelude hiding ( read )@@ -62,10 +61,11 @@ 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 ( HasLogger (..), DumpFormat (..), putLogMsg, putDumpMsg, Logger )-import GHC.Utils.Error ( Severity(..) )+import GHC.Utils.Logger import GHC.Utils.Monad  import GHC.Data.FastString@@ -130,6 +130,7 @@   | CoreTidy   | CorePrep   | CoreAddCallerCcs+  | CoreAddLateCcs   | CoreOccurAnal  instance Outputable CoreToDo where@@ -151,6 +152,7 @@   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 CoreOccurAnal            = text "Occurrence analysis"   ppr CoreDoPrintCore          = text "Print core"@@ -182,7 +184,6 @@             --    - target platform (for `exprIsDupable` and `mkDupableAlt`)             --    - Opt_DictsCheap and Opt_PedanticBottoms general flags             --    - rules options (initRuleOpts)-            --    - verbose_core2core, dump_inlinings, dump_rule_rewrites/firings             --    - inlineCheck         } @@ -194,13 +195,13 @@        = text "SimplMode" <+> braces (          sep [ text "Phase =" <+> ppr p <+>                brackets (text (concat $ intersperse "," ss)) <> comma-             , pp_flag i   (sLit "inline") <> comma-             , pp_flag r   (sLit "rules") <> comma-             , pp_flag eta (sLit "eta-expand") <> comma-             , pp_flag cs  (sLit "cast-swizzle") <> comma-             , pp_flag cc  (sLit "case-of-case") ])+             , 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") <+> ptext s+           pp_flag f s = ppUnless f (text "no") <+> s  data FloatOutSwitches = FloatOutSwitches {   floatOutLambdas   :: Maybe Int,  -- ^ Just n <=> float lambdas to top level, if@@ -794,21 +795,19 @@ ************************************************************************ -} -msg :: Severity -> WarnReason -> SDoc -> CoreM ()-msg sev reason doc = do-    dflags <- getDynFlags+msg :: MessageClass -> SDoc -> CoreM ()+msg msg_class doc = do     logger <- getLogger     loc    <- getSrcSpanM     unqual <- getPrintUnqualified-    let sty = case sev of-                SevError   -> err_sty-                SevWarning -> err_sty-                SevDump    -> dump_sty-                _          -> user_sty+    let sty = case msg_class of+                MCDiagnostic _ _ -> err_sty+                MCDump           -> dump_sty+                _                -> user_sty         err_sty  = mkErrStyle unqual         user_sty = mkUserStyle unqual AllTheWay         dump_sty = mkDumpStyle unqual-    liftIO $ putLogMsg logger dflags reason sev loc (withPprStyle sty doc)+    liftIO $ logMsg logger msg_class loc (withPprStyle sty doc)  -- | Output a String message to the screen putMsgS :: String -> CoreM ()@@ -816,7 +815,7 @@  -- | Output a message to the screen putMsg :: SDoc -> CoreM ()-putMsg = msg SevInfo NoReason+putMsg = msg MCInfo  -- | Output an error to the screen. Does not cause the compiler to die. errorMsgS :: String -> CoreM ()@@ -824,10 +823,7 @@  -- | Output an error to the screen. Does not cause the compiler to die. errorMsg :: SDoc -> CoreM ()-errorMsg = msg SevError NoReason--warnMsg :: WarnReason -> SDoc -> CoreM ()-warnMsg = msg SevWarning+errorMsg doc = msg errorDiagnostic doc  -- | Output a fatal error to the screen. Does not cause the compiler to die. fatalErrorMsgS :: String -> CoreM ()@@ -835,7 +831,7 @@  -- | Output a fatal error to the screen. Does not cause the compiler to die. fatalErrorMsg :: SDoc -> CoreM ()-fatalErrorMsg = msg SevFatal NoReason+fatalErrorMsg = msg MCFatal  -- | Output a string debugging message at verbosity level of @-v@ or higher debugTraceMsgS :: String -> CoreM ()@@ -843,14 +839,4 @@  -- | Outputs a debugging message at verbosity level of @-v@ or higher debugTraceMsg :: SDoc -> CoreM ()-debugTraceMsg = msg SevDump NoReason---- | Show some labelled 'SDoc' if a particular flag is set or at a verbosity level of @-v -ddump-most@ or higher-dumpIfSet_dyn :: DumpFlag -> String -> DumpFormat -> SDoc -> CoreM ()-dumpIfSet_dyn flag str fmt doc = do-    dflags <- getDynFlags-    logger <- getLogger-    unqual <- getPrintUnqualified-    when (dopt flag dflags) $ liftIO $ do-        let sty = mkDumpStyle unqual-        putDumpMsg logger dflags sty flag str fmt doc+debugTraceMsg = msg MCDump
GHC/Core/Opt/OccurAnal.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP          #-} {-# LANGUAGE ViewPatterns #-}  {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}@@ -17,43 +16,48 @@ core expression with (hopefully) improved usage information. -} -module GHC.Core.Opt.OccurAnal ( occurAnalysePgm, occurAnalyseExpr ) where--#include "HsVersions.h"+module GHC.Core.Opt.OccurAnal (+    occurAnalysePgm,+    occurAnalyseExpr,+    zapLambdaBndrs+  ) where  import GHC.Prelude -import GHC.Driver.Ppr- import GHC.Core import GHC.Core.FVs import GHC.Core.Utils   ( exprIsTrivial, isDefaultAlt, isExpandableApp,                           stripTicksTopE, mkTicks ) import GHC.Core.Opt.Arity   ( joinRhsArity )-import GHC.Types.Id-import GHC.Types.Id.Info-import GHC.Types.Basic-import GHC.Types.Tickish-import GHC.Unit.Module( Module ) import GHC.Core.Coercion import GHC.Core.Type import GHC.Core.TyCo.FVs( tyCoVarsOfMCo ) -import GHC.Types.Var.Set-import GHC.Types.Var.Env-import GHC.Types.Var-import GHC.Types.Demand ( argOneShots, argsOneShots )+import GHC.Data.Maybe( isJust, orElse ) import GHC.Data.Graph.Directed ( SCC(..), Node(..)                                , stronglyConnCompFromEdgedVerticesUniq                                , stronglyConnCompFromEdgedVerticesUniqR )-import GHC.Builtin.Names( runRWKey ) import GHC.Types.Unique import GHC.Types.Unique.FM import GHC.Types.Unique.Set-import GHC.Utils.Misc-import GHC.Data.Maybe( isJust )+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 )+ import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain+import GHC.Utils.Misc+import GHC.Utils.Trace++import GHC.Builtin.Names( runRWKey )+import GHC.Unit.Module( Module )+ import Data.List (mapAccumL, mapAccumR)  {-@@ -66,10 +70,11 @@ Here's the externally-callable interface: -} +-- | Do occurrence analysis, and discard occurrence info returned occurAnalyseExpr :: CoreExpr -> CoreExpr--- Do occurrence analysis, and discard occurrence info returned-occurAnalyseExpr expr-  = snd (occAnal initOccEnv expr)+occurAnalyseExpr expr = expr'+  where+    (WithUsageDetails _ expr') = occAnal initOccEnv expr  occurAnalysePgm :: Module         -- Used only in debug output                 -> (Id -> Bool)         -- Active unfoldings@@ -81,15 +86,14 @@   = occ_anald_binds    | otherwise   -- See Note [Glomming]-  = WARN( True, hang (text "Glomming in" <+> ppr this_mod <> colon)-                   2 (ppr final_usage ) )+  = 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 } -    (final_usage, occ_anald_binds) = go init_env binds-    (_, occ_anald_glommed_binds)   = occAnalRecBind init_env TopLevel+    (WithUsageDetails final_usage occ_anald_binds) = go init_env binds+    (WithUsageDetails _ occ_anald_glommed_binds) = occAnalRecBind init_env TopLevel                                                     imp_rule_edges                                                     (flattenBinds binds)                                                     initial_uds@@ -121,15 +125,14 @@                                    -- Not BuiltinRules; see Note [Plugin rules]                            , let rhs_fvs = exprFreeIds rhs `delVarSetList` bndrs ] -    go :: OccEnv -> [CoreBind] -> (UsageDetails, [CoreBind])-    go _ []-        = (initial_uds, [])+    go :: OccEnv -> [CoreBind] -> WithUsageDetails [CoreBind]+    go !_ []+        = WithUsageDetails initial_uds []     go env (bind:binds)-        = (final_usage, bind' ++ binds')+        = WithUsageDetails final_usage (bind' ++ binds')         where-           (bs_usage, binds')   = go env binds-           (final_usage, bind') = occAnalBind env TopLevel imp_rule_edges bind-                                              bs_usage+           (WithUsageDetails bs_usage binds')   = go env binds+           (WithUsageDetails final_usage bind') = occAnalBind env TopLevel imp_rule_edges bind bs_usage  {- ********************************************************************* *                                                                      *@@ -338,7 +341,7 @@         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 [Rules for imported functions], the+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.) @@ -570,13 +573,13 @@ 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 [Self-recursive rules] in GHC.Core.Opt.Simplify+  - 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 [Rules and loop breakers].  ------------------------------------------------------------ Note [Finding join points]@@ -673,7 +676,13 @@    a) call 'markAllInsideLam' *unless* the binding is for a thunk, a one-shot      lambda, or a non-recursive join point; and-  b) call 'markAllNonTail' *unless* the binding is for a join point.+  b) call 'markAllNonTail' *unless* the binding is for a join point, and+     the RHS has the right 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  Some examples, with how the free occurrences in e (assumed not to be a value lambda) get marked:@@ -707,6 +716,9 @@ 'occAnalRec'.) -} ++data WithUsageDetails a = WithUsageDetails !UsageDetails !a+ ------------------------------------------------------------------ --                 occAnalBind ------------------------------------------------------------------@@ -716,26 +728,25 @@             -> ImpRuleEdges             -> CoreBind             -> UsageDetails             -- Usage details of scope-            -> (UsageDetails,           -- Of the whole let(rec)-                [CoreBind])+            -> WithUsageDetails [CoreBind] -- Of the whole let(rec) -occAnalBind env lvl top_env (NonRec binder rhs) body_usage+occAnalBind !env lvl top_env (NonRec binder rhs) body_usage   = occAnalNonRecBind env lvl top_env binder rhs body_usage occAnalBind env lvl top_env (Rec pairs) body_usage   = occAnalRecBind env lvl top_env pairs body_usage  ----------------- occAnalNonRecBind :: OccEnv -> TopLevelFlag -> ImpRuleEdges -> Var -> CoreExpr-                  -> UsageDetails -> (UsageDetails, [CoreBind])-occAnalNonRecBind env lvl imp_rule_edges bndr rhs body_usage+                  -> UsageDetails -> WithUsageDetails [CoreBind]+occAnalNonRecBind !env lvl imp_rule_edges bndr rhs body_usage   | isTyVar bndr      -- A type let; we don't gather usage info-  = (body_usage, [NonRec bndr rhs])+  = WithUsageDetails body_usage [NonRec bndr rhs]    | not (bndr `usedIn` body_usage)    -- It's not mentioned-  = (body_usage, [])+  = WithUsageDetails body_usage []    | otherwise                   -- It's mentioned in the body-  = (body_usage' `andUDs` rhs_usage, [NonRec final_bndr rhs'])+  = WithUsageDetails (body_usage' `andUDs` rhs_usage) [NonRec final_bndr rhs']   where     (body_usage', tagged_bndr) = tagNonRecBinder lvl body_usage bndr     final_bndr = tagged_bndr `setIdUnfolding` unf'@@ -754,12 +765,13 @@      -- See Note [Sources of one-shot information]     rhs_env = env1 { occ_one_shots = argOneShots dmd }-    (rhs_uds, rhs') = occAnalRhs rhs_env NonRecursive mb_join_arity rhs+    (WithUsageDetails rhs_uds rhs') = occAnalRhs rhs_env NonRecursive mb_join_arity rhs      --------- Unfolding ---------     -- See Note [Unfoldings and join points]-    unf = idUnfolding bndr-    (unf_uds, unf') = occAnalUnfolding rhs_env NonRecursive mb_join_arity unf+    unf | isId bndr = idUnfolding bndr+        | otherwise = NoUnfolding+    (WithUsageDetails unf_uds unf') = occAnalUnfolding rhs_env NonRecursive mb_join_arity unf      --------- Rules ---------     -- See Note [Rules are extra RHSs] and Note [Rule dependency info]@@ -791,14 +803,14 @@  ----------------- occAnalRecBind :: OccEnv -> TopLevelFlag -> ImpRuleEdges -> [(Var,CoreExpr)]-               -> UsageDetails -> (UsageDetails, [CoreBind])+               -> 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 env lvl imp_rule_edges pairs body_usage-  = foldr (occAnalRec rhs_env lvl) (body_usage, []) sccs+occAnalRecBind !env lvl imp_rule_edges pairs body_usage+  = foldr (occAnalRec rhs_env lvl) (WithUsageDetails body_usage []) sccs   where     sccs :: [SCC Details]     sccs = {-# SCC "occAnalBind.scc" #-}@@ -816,34 +828,34 @@ ----------------------------- occAnalRec :: OccEnv -> TopLevelFlag            -> SCC Details-           -> (UsageDetails, [CoreBind])-           -> (UsageDetails, [CoreBind])+           -> WithUsageDetails [CoreBind]+           -> WithUsageDetails [CoreBind]          -- The NonRec case is just like a Let (NonRec ...) above-occAnalRec _ lvl (AcyclicSCC (ND { nd_bndr = bndr, nd_rhs = rhs-                                 , nd_uds = rhs_uds, nd_rhs_bndrs = rhs_bndrs }))-           (body_uds, binds)+occAnalRec !_ lvl (AcyclicSCC (ND { nd_bndr = bndr, nd_rhs = rhs+                                  , nd_uds = rhs_uds }))+           (WithUsageDetails body_uds binds)   | not (bndr `usedIn` body_uds)-  = (body_uds, binds)           -- See Note [Dead code]+  = WithUsageDetails body_uds binds -- See Note [Dead code]    | otherwise                   -- It's mentioned in the body-  = (body_uds' `andUDs` rhs_uds',-     NonRec tagged_bndr rhs : binds)+  = WithUsageDetails (body_uds' `andUDs` rhs_uds')+                     (NonRec tagged_bndr rhs : binds)   where     (body_uds', tagged_bndr) = tagNonRecBinder lvl body_uds bndr-    rhs_uds'   = adjustRhsUsage NonRecursive (willBeJoinId_maybe tagged_bndr)-                                rhs_bndrs rhs_uds+    rhs_uds'      = adjustRhsUsage mb_join_arity rhs rhs_uds+    mb_join_arity = willBeJoinId_maybe tagged_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) (body_uds, binds)+occAnalRec env lvl (CyclicSCC details_s) (WithUsageDetails body_uds binds)   | not (any (`usedIn` body_uds) bndrs) -- NB: look at body_uds, not total_uds-  = (body_uds, binds)                   -- See Note [Dead code]+  = WithUsageDetails body_uds binds     -- See Note [Dead code]    | otherwise   -- At this point we always build a single Rec   = -- pprTrace "occAnalRec" (ppr loop_breaker_nodes)-    (final_uds, Rec pairs : binds)+    WithUsageDetails final_uds (Rec pairs : binds)    where     bndrs      = map nd_bndr details_s@@ -854,7 +866,7 @@     -- See Note [Choosing loop breakers] for loop_breaker_nodes     final_uds :: UsageDetails     loop_breaker_nodes :: [LetrecNode]-    (final_uds, loop_breaker_nodes) = mkLoopBreakerNodes env lvl body_uds details_s+    (WithUsageDetails final_uds loop_breaker_nodes) = mkLoopBreakerNodes env lvl body_uds details_s      ------------------------------     weak_fvs :: VarSet@@ -1309,10 +1321,6 @@         , nd_rhs  :: CoreExpr    -- RHS, already occ-analysed -       , nd_rhs_bndrs :: [CoreBndr] -- Outer lambdas of RHS-                                    -- INVARIANT: (nd_rhs_bndrs nd, _) ==-                                    --              collectBinders (nd_rhs nd)-        , nd_uds  :: UsageDetails  -- Usage from RHS, and RULES, and stable unfoldings                                   -- ignoring phase (ie assuming all are active)                                   -- See Note [Forming Rec groups]@@ -1362,7 +1370,7 @@ makeNode :: OccEnv -> ImpRuleEdges -> VarSet          -> (Var, CoreExpr) -> LetrecNode -- See Note [Recursive bindings: the grand plan]-makeNode env imp_rule_edges bndr_set (bndr, rhs)+makeNode !env imp_rule_edges bndr_set (bndr, rhs)   = DigraphNode { node_payload      = details                 , node_key          = varUnique bndr                 , node_dependencies = nonDetKeysUniqSet scope_fvs }@@ -1372,7 +1380,6 @@   where     details = ND { nd_bndr            = bndr'                  , nd_rhs             = rhs'-                 , nd_rhs_bndrs       = bndrs'                  , nd_uds             = scope_uds                  , nd_inl             = inl_fvs                  , nd_simple          = null rules_w_uds && null imp_rule_info@@ -1407,18 +1414,17 @@     --------- Right hand side ---------     -- Constructing the edges for the main Rec computation     -- See Note [Forming Rec groups]-    -- Do not use occAnalRhs because we don't yet know-    -- the final answer for mb_join_arity-    (bndrs, body)            = collectBinders rhs-    rhs_env                  = rhsCtxt env-    (rhs_uds, bndrs', body') = occAnalLamOrRhs rhs_env bndrs body-    rhs'                     = mkLams bndrs' body'+    -- Do not use occAnalRhs because we don't yet know the final+    -- answer for mb_join_arity; instead, do the occAnalLam call from+    -- occAnalRhs, and postpone adjustRhsUsage until occAnalRec+    rhs_env                         = rhsCtxt env+    (WithUsageDetails rhs_uds rhs') = occAnalLam rhs_env rhs      --------- Unfolding ---------     -- See Note [Unfoldings and join points]     unf = realIdUnfolding bndr -- realIdUnfolding: Ignore loop-breaker-ness                                -- here because that is what we are setting!-    (unf_uds, unf') = occAnalUnfolding rhs_env Recursive mb_join_arity unf+    (WithUsageDetails unf_uds unf') = occAnalUnfolding rhs_env Recursive mb_join_arity unf      --------- IMP-RULES --------     is_active     = occ_rule_act env :: Activation -> Bool@@ -1450,8 +1456,7 @@ mkLoopBreakerNodes :: OccEnv -> TopLevelFlag                    -> UsageDetails   -- for BODY of let                    -> [Details]-                   -> (UsageDetails, -- adjusted-                       [LetrecNode])+                   -> WithUsageDetails [LetrecNode] -- adjusted -- See Note [Choosing loop breakers] -- This function primarily creates the Nodes for the -- loop-breaker SCC analysis.  More specifically:@@ -1461,14 +1466,10 @@ --      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-  = (final_uds, zipWithEqual "mkLoopBreakerNodes" mk_lb_node details_s bndrs')+mkLoopBreakerNodes !env lvl body_uds details_s+  = WithUsageDetails final_uds (zipWithEqual "mkLoopBreakerNodes" mk_lb_node details_s bndrs')   where-    (final_uds, bndrs')-       = tagRecBinders lvl body_uds-            [ (bndr, uds, rhs_bndrs)-            | ND { nd_bndr = bndr, nd_uds = uds, nd_rhs_bndrs = rhs_bndrs }-                 <- details_s ]+    (final_uds, bndrs') = tagRecBinders lvl body_uds details_s      mk_lb_node nd@(ND { nd_bndr = old_bndr, nd_inl = inl_fvs }) new_bndr       = DigraphNode { node_payload      = new_nd@@ -1517,7 +1518,7 @@           -> VarSet    -- Loop-breaker dependencies           -> Details           -> NodeScore-nodeScore env new_bndr lb_deps+nodeScore !env new_bndr lb_deps           (ND { nd_bndr = old_bndr, nd_rhs = bind_rhs })    | not (isId old_bndr)     -- A type or coercion variable is never a loop breaker@@ -1599,7 +1600,9 @@     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 _          = False+    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@@ -1713,65 +1716,246 @@    was a loop breaker last time round  Hence the is_lb field of NodeScore+-} -************************************************************************+{- ********************************************************************* *                                                                      *-                   Right hand sides+                  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 occAnalLam.++* 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 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++occAnalLam :: OccEnv -> CoreExpr -> (WithUsageDetails 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+-- This function does /not/ do+--   markAllInsideLam or+--   markAllNonTail+-- The caller does that, either in occAnal (Lam {}), or in adjustRhsUsage+-- See Note [Adjusting right-hand sides]++occAnalLam env (Lam bndr expr)+  | isTyVar bndr+  = let (WithUsageDetails usage expr') = occAnalLam env expr+    in WithUsageDetails usage (Lam bndr expr')+       -- Important: Keep the 'env' unchanged 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  -- So 'bndr' is an Id+  = let (env_one_shots', bndr1)+           = 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 [The oneShot function]++        env1 = env { occ_encl = OccVanilla, occ_one_shots = env_one_shots' }+        env2 = addOneInScope env1 bndr+        (WithUsageDetails usage expr') = occAnalLam env2 expr+        (usage', bndr2) = tagLamBinder usage bndr1+    in WithUsageDetails usage' (Lam bndr2 expr')++-- For casts, keep going in the same lambda-group+-- See Note [Occurrence analysis for lambda binders]+occAnalLam env (Cast expr co)+  = let  (WithUsageDetails usage expr') = occAnalLam 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 adjustRhsUsage; but not so!  For a+         -- join point, adjustRhsUsage doesn't do this; yet if there is+         -- a cast, we must!+         usage3 = markAllNonTail usage2++    in WithUsageDetails usage3 (Cast expr' co)++occAnalLam env expr = 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 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 occAnalLam, not occAnal, because the top leve+of a right hand side is handled by occAnalLam.+-}+++{- *********************************************************************+*                                                                      *+                   Right hand sides+*                                                                      *+********************************************************************* -}+ occAnalRhs :: OccEnv -> RecFlag -> Maybe JoinArity            -> CoreExpr   -- RHS-           -> (UsageDetails, CoreExpr)-occAnalRhs env is_rec mb_join_arity rhs-  = case occAnalLamOrRhs env1 bndrs body of { (body_usage, bndrs', body') ->-    let final_bndrs | isRec is_rec = bndrs'-                    | otherwise    = markJoinOneShots mb_join_arity bndrs'-               -- 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+           -> WithUsageDetails CoreExpr+occAnalRhs !env is_rec mb_join_arity rhs+  = let (WithUsageDetails usage rhs1) = occAnalLam env rhs+           -- We call occAnalLam here, not occAnalExpr, so that it doesn't+           -- do the markAllInsideLam and markNonTailCall stuff before+           -- we've had a chance to help with join points; that comes next+        rhs2      = markJoinOneShots is_rec mb_join_arity rhs1+        rhs_usage = adjustRhsUsage mb_join_arity rhs2 usage+    in WithUsageDetails rhs_usage rhs2 -        -- Final adjustment-        rhs_usage = adjustRhsUsage is_rec mb_join_arity final_bndrs body_usage -    in (rhs_usage, mkLams final_bndrs body') }++markJoinOneShots :: RecFlag -> Maybe JoinArity -> CoreExpr -> CoreExpr+-- 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+markJoinOneShots NonRecursive (Just join_arity) rhs+  = go join_arity rhs   where-    (bndrs, body) = collectBinders rhs-    env1          = addInScope env bndrs+    go 0 rhs         = rhs+    go n (Lam b rhs) = Lam (if isId b then setOneShotLambda b else b)+                           (go (n-1) rhs)+    go _ rhs         = rhs  -- 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.)+markJoinOneShots _ _ rhs+  = rhs  occAnalUnfolding :: OccEnv                  -> RecFlag                  -> Maybe JoinArity   -- See Note [Join points and unfoldings/rules]                  -> Unfolding-                 -> (UsageDetails, Unfolding)+                 -> WithUsageDetails Unfolding -- Occurrence-analyse a stable unfolding; -- discard a non-stable one altogether.-occAnalUnfolding env is_rec mb_join_arity unf+occAnalUnfolding !env is_rec mb_join_arity unf   = case unf of       unf@(CoreUnfolding { uf_tmpl = rhs, uf_src = src })-        | isStableSource src -> (markAllMany usage, unf')+        | isStableSource src ->+            let+              (WithUsageDetails usage rhs') = occAnalRhs env is_rec mb_join_arity rhs++              unf' | noBinderSwaps env = unf -- Note [Unfoldings and rules]+                   | otherwise         = unf { uf_tmpl = rhs' }+            in WithUsageDetails (markAllMany usage) unf'               -- markAllMany: see Note [Occurrences in stable unfoldings]-        | otherwise          -> (emptyDetails,      unf)+        | otherwise          -> WithUsageDetails 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.-        where-          (usage, rhs') = occAnalRhs env is_rec mb_join_arity rhs -          unf' | noBinderSwaps env = unf -- Note [Unfoldings and rules]-               | otherwise         = unf { uf_tmpl = rhs' }-       unf@(DFunUnfolding { df_bndrs = bndrs, df_args = args })-        -> ( final_usage, unf { df_args = args' } )+        -> WithUsageDetails final_usage (unf { df_args = args' })         where           env'            = env `addInScope` bndrs-          (usage, args')  = occAnalList env' args+          (WithUsageDetails usage args') = occAnalList env' args           final_usage     = markAllManyNonTail (delDetailsList usage bndrs)+                            `addLamCoVarOccs` bndrs+                            `delDetailsList` bndrs+              -- delDetailsList; no need to use tagLamBinders because we+              -- never inline DFuns so the occ-info on binders doesn't matter -      unf -> (emptyDetails, unf)+      unf -> WithUsageDetails emptyDetails unf  occAnalRules :: OccEnv              -> Maybe JoinArity  -- See Note [Join points and unfoldings/rules]@@ -1779,7 +1963,7 @@              -> [(CoreRule,      -- Each (non-built-in) rule                   UsageDetails,  -- Usage details for LHS                   UsageDetails)] -- Usage details for RHS-occAnalRules env mb_join_arity bndr+occAnalRules !env mb_join_arity bndr   = map occ_anal_rule (idCoreRules bndr)   where     occ_anal_rule rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs })@@ -1789,11 +1973,11 @@         rule' | noBinderSwaps env = rule  -- Note [Unfoldings and rules]               | otherwise         = rule { ru_args = args', ru_rhs = rhs' } -        (lhs_uds, args') = occAnalList env' args-        lhs_uds'         = markAllManyNonTail $-                           lhs_uds `delDetailsList` bndrs+        (WithUsageDetails lhs_uds args') = occAnalList env' args+        lhs_uds'         = markAllManyNonTail (lhs_uds `delDetailsList` bndrs)+                           `addLamCoVarOccs` bndrs -        (rhs_uds, rhs') = occAnal env' rhs+        (WithUsageDetails rhs_uds rhs') = occAnal env' rhs                             -- Note [Rules are extra RHSs]                             -- Note [Rule dependency info]         rhs_uds' = markAllNonTailIf (not exact_join) $@@ -1904,20 +2088,20 @@ ************************************************************************ -} -occAnalList :: OccEnv -> [CoreExpr] -> (UsageDetails, [CoreExpr])-occAnalList _   []     = (emptyDetails, [])-occAnalList env (e:es) = case occAnal env e      of { (uds1, e')  ->-                         case occAnalList env es of { (uds2, es') ->-                         (uds1 `andUDs` uds2, e' : es') } }+occAnalList :: OccEnv -> [CoreExpr] -> WithUsageDetails [CoreExpr]+occAnalList !_   []    = WithUsageDetails emptyDetails []+occAnalList env (e:es) = let+                          (WithUsageDetails uds1 e') = occAnal env e+                          (WithUsageDetails uds2 es') = occAnalList env es+                         in WithUsageDetails (uds1 `andUDs` uds2) (e' : es')  occAnal :: OccEnv         -> CoreExpr-        -> (UsageDetails,       -- Gives info only about the "interesting" Ids-            CoreExpr)+        -> WithUsageDetails CoreExpr       -- Gives info only about the "interesting" Ids -occAnal _   expr@(Type _) = (emptyDetails,         expr)-occAnal _   expr@(Lit _)  = (emptyDetails,         expr)-occAnal env expr@(Var _)  = occAnalApp env (expr, [], [])+occAnal !_   expr@(Lit _)  = WithUsageDetails 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@@ -1925,35 +2109,74 @@     -- rules in them, so the *specialised* versions looked as if they     -- weren't used at all. -occAnal _ (Coercion co)-  = (addManyOccs emptyDetails (coVarsOfCo co), Coercion co)+occAnal _ expr@(Type ty)+  = WithUsageDetails (addManyOccs emptyDetails (coVarsOfType ty)) expr+occAnal _ expr@(Coercion co)+  = WithUsageDetails (addManyOccs emptyDetails (coVarsOfCo co)) expr         -- See Note [Gather occurrences of coercion variables] -{--Note [Gather occurrences of coercion variables]+{- Note [Gather occurrences of coercion variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We need to gather info about what coercion variables appear, so that-we can sort them into the right place when doing dependency analysis.+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 addLamCoVarOccs++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)   | SourceNote{} <- tickish-  = (usage, Tick tickish body')+  = WithUsageDetails usage (Tick tickish body')                   -- SourceNotes are best-effort; so we just proceed as usual.                   -- If we drop a tick due to the issues described below it's                   -- not the end of the world.    | tickish `tickishScopesLike` SoftScope-  = (markAllNonTail usage, Tick tickish body')+  = WithUsageDetails (markAllNonTail usage) (Tick tickish body')    | Breakpoint _ _ ids <- tickish-  = (usage_lam `andUDs` foldr addManyOcc emptyDetails ids, Tick tickish body')+  = WithUsageDetails (usage_lam `andUDs` foldr addManyOcc emptyDetails ids) (Tick tickish body')     -- never substitute for any of the Ids in a Breakpoint    | otherwise-  = (usage_lam, Tick tickish body')+  = WithUsageDetails usage_lam (Tick tickish body')   where-    !(usage,body') = occAnal env body+    (WithUsageDetails usage body') = occAnal env body     -- for a non-soft tick scope, we can inline lambdas only     usage_lam = markAllNonTail (markAllInsideLam usage)                   -- TODO There may be ways to make ticks and join points play@@ -1965,95 +2188,62 @@                   -- See #14242.  occAnal env (Cast expr co)-  = case occAnal env expr of { (usage, expr') ->-    let usage1 = markAllManyNonTailIf (isRhsEnv env) usage-          -- usage1: if we see let x = y `cast` co-          -- then mark y as 'Many' so that we don't-          -- immediately inline y again.-        usage2 = addManyOccs usage1 (coVarsOfCo co)-          -- usage2: see Note [Gather occurrences of coercion variables]-    in (markAllNonTail usage2, Cast expr' co)-    }+  = let  (WithUsageDetails 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 WithUsageDetails usage2 (Cast expr' co)  occAnal env app@(App _ _)   = occAnalApp env (collectArgsTicks tickishFloatable app) --- Ignore type variables altogether---   (a) occurrences inside type lambdas only not marked as InsideLam---   (b) type variables not in environment--occAnal env (Lam x body)-  | isTyVar x-  = case occAnal env body of { (body_usage, body') ->-    (markAllNonTail body_usage, Lam x body')-    }--{- 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 instead, we just mark each binder with its occurrence info in the-*body* of the multiple lambda.  Then, the simplifier is careful when-partially applying lambdas. See the calls to zapLamBndrs in-  GHC.Core.Opt.Simplify.simplExprF1-  GHC.Core.SimpleOpt.simple_app--}--occAnal env expr@(Lam _ _)-  = -- See Note [Occurrence analysis for lambda binders]-    case occAnalLamOrRhs env1 bndrs body of { (usage, tagged_bndrs, body') ->-    let-        expr'       = mkLams tagged_bndrs body'-        usage1      = markAllNonTail usage-        one_shot_gp = all isOneShotBndr tagged_bndrs-        final_usage = markAllInsideLamIf (not one_shot_gp) usage1-    in-    (final_usage, expr') }-  where-    (bndrs, body) = collectBinders expr-    env1          = addInScope env bndrs+occAnal env expr@(Lam {})+  = let (WithUsageDetails usage expr') = occAnalLam env expr+        final_usage = markAllInsideLamIf (not (isOneShotFun expr')) $+                      markAllNonTail usage+    in WithUsageDetails final_usage expr'  occAnal env (Case scrut bndr ty alts)-  = case occAnal (scrutCtxt env alts) scrut of { (scrut_usage, scrut') ->-    let alt_env = addBndrSwap scrut' bndr $-                  env { occ_encl = OccVanilla } `addInScope` [bndr]-    in-    case mapAndUnzip (occAnalAlt alt_env) alts of { (alts_usage_s, alts')   ->-    let-        alts_usage  = foldr orUDs emptyDetails alts_usage_s-        (alts_usage1, tagged_bndr) = tagLamBinder alts_usage bndr-        total_usage = markAllNonTail scrut_usage `andUDs` alts_usage1-                        -- Alts can have tail calls, but the scrutinee can't-    in-    total_usage `seq` (total_usage, Case scrut' tagged_bndr ty alts') }}+  = let+      (WithUsageDetails scrut_usage scrut') = occAnal (scrutCtxt env alts) scrut+      alt_env = addBndrSwap scrut' bndr $ env { occ_encl = OccVanilla } `addOneInScope` bndr+      (alts_usage_s, alts') = mapAndUnzip (do_alt alt_env) alts+      alts_usage  = foldr orUDs emptyDetails alts_usage_s+      (alts_usage1, tagged_bndr) = tagLamBinder alts_usage bndr+      total_usage = markAllNonTail scrut_usage `andUDs` alts_usage1+                    -- Alts can have tail calls, but the scrutinee can't+    in WithUsageDetails total_usage (Case scrut' tagged_bndr ty alts')+  where+    do_alt !env (Alt con bndrs rhs)+      = let+          (WithUsageDetails rhs_usage1 rhs1) = occAnal (env `addInScope` bndrs) rhs+          (alt_usg, tagged_bndrs) = tagLamBinders rhs_usage1 bndrs+        in                          -- See Note [Binders in case alternatives]+        (alt_usg, Alt con tagged_bndrs rhs1)  occAnal env (Let bind body)-  = case occAnal (env `addInScope` bindersOf bind)-                 body                    of { (body_usage, body') ->-    case occAnalBind env NotTopLevel-                     noImpRuleEdges bind-                     body_usage          of { (final_usage, new_binds) ->-       (final_usage, mkLets new_binds body') }}--occAnalArgs :: OccEnv -> [CoreExpr] -> [OneShots] -> (UsageDetails, [CoreExpr])-occAnalArgs _ [] _-  = (emptyDetails, [])--occAnalArgs env (arg:args) one_shots-  | isTypeArg arg-  = case occAnalArgs env args one_shots of { (uds, args') ->-    (uds, arg:args') }+  = let+      body_env = env { occ_encl = OccVanilla } `addInScope` bindersOf bind+      (WithUsageDetails body_usage  body')  = occAnal body_env body+      (WithUsageDetails final_usage binds') = occAnalBind env NotTopLevel+                                                    noImpRuleEdges bind body_usage+    in WithUsageDetails final_usage (mkLets binds' body') -  | otherwise-  = case argCtxt env one_shots           of { (arg_env, one_shots') ->-    case occAnal arg_env arg             of { (uds1, arg') ->-    case occAnalArgs env args one_shots' of { (uds2, args') ->-    (uds1 `andUDs` uds2, arg':args') }}}+occAnalArgs :: OccEnv -> CoreExpr -> [CoreExpr] -> [OneShots] -> 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+    go uds fun [] _ = WithUsageDetails uds fun+    go uds fun (arg:args) one_shots+      = go (uds `andUDs` arg_uds) (fun `App` arg') args one_shots'+      where+        !(WithUsageDetails arg_uds arg') = occAnal arg_env arg+        !(arg_env, one_shots')+            | isTypeArg arg = (env, one_shots)+            | otherwise     = valArgCtxt env one_shots  {- Applications are dealt with specially because we want@@ -2074,9 +2264,9 @@  occAnalApp :: OccEnv            -> (Expr CoreBndr, [Arg CoreBndr], [CoreTickish])-           -> (UsageDetails, Expr CoreBndr)+           -> WithUsageDetails (Expr CoreBndr) -- Naked variables (not applied) end up here too-occAnalApp env (Var fun, args, ticks)+occAnalApp !env (Var fun, args, ticks)   -- Account for join arity of runRW# continuation   -- See Note [Simplification of runRW#]   --@@ -2087,13 +2277,17 @@   --     This caused #18296   | fun `hasKey` runRWKey   , [t1, t2, arg]  <- args-  , let (usage, arg') = occAnalRhs env NonRecursive (Just 1) arg-  = (usage, mkTicks ticks $ mkApps (Var fun) [t1, t2, arg'])+  , let (WithUsageDetails usage arg') = occAnalRhs env NonRecursive (Just 1) arg+  = WithUsageDetails usage (mkTicks ticks $ mkApps (Var fun) [t1, t2, arg'])  occAnalApp env (Var fun_id, args, ticks)-  = (all_uds, mkTicks ticks $ mkApps fun' args')+  = WithUsageDetails all_uds (mkTicks ticks app')   where-    (fun', fun_id') = lookupBndrSwap env fun_id+    -- 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+    !(WithUsageDetails args_uds app') = occAnalArgs env fun' args one_shots      fun_uds = mkOneOcc fun_id' int_cxt n_args        -- NB: fun_uds is computed for fun_id', not fun_id@@ -2101,8 +2295,7 @@      all_uds = fun_uds `andUDs` final_args_uds -    !(args_uds, args') = occAnalArgs env args one_shots-    !final_args_uds = markAllNonTail                        $+    !final_args_uds = markAllNonTail                              $                       markAllInsideLamIf (isRhsEnv env && is_exp) $                       args_uds        -- We mark the free vars of the argument of a constructor or PAP@@ -2115,36 +2308,48 @@        -- 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+    !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+    !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 (idStrictness fun_id) guaranteed_val_args+    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)-  = (markAllNonTail (fun_uds `andUDs` args_uds),-     mkTicks ticks $ mkApps fun' args')+  = WithUsageDetails (markAllNonTail (fun_uds `andUDs` args_uds))+                     (mkTicks ticks app')   where-    !(fun_uds, fun') = occAnal (addAppCtxt env args) fun+    !(WithUsageDetails args_uds app') = occAnalArgs env fun' args []+    !(WithUsageDetails fun_uds fun')  = occAnal (addAppCtxt env args) fun         -- The addAppCtxt is a bit cunning.  One iteration of the simplifier         -- often leaves behind beta redexs 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 True items+        -- thing much like a let.  We do this by pushing some OneShotLam items         -- onto the context stack.-    !(args_uds, args') = occAnalArgs env args [] +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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -2233,42 +2438,6 @@ scrutinised y). -} -occAnalLamOrRhs :: OccEnv -> [CoreBndr] -> CoreExpr-                -> (UsageDetails, [CoreBndr], CoreExpr)--- Tags the returned binders with their OccInfo, but does--- not do any markInsideLam to the returned usage details-occAnalLamOrRhs env [] body-  = case occAnal env body of (body_usage, body') -> (body_usage, [], body')-      -- RHS of thunk or nullary join point--occAnalLamOrRhs env (bndr:bndrs) body-  | isTyVar bndr-  = -- Important: Keep the environment so that we don't inline into an RHS like-    --   \(@ x) -> C @x (f @x)-    -- (see the beginning of Note [Cascading inlines]).-    case occAnalLamOrRhs env bndrs body of-      (body_usage, bndrs', body') -> (body_usage, bndr:bndrs', body')--occAnalLamOrRhs env binders body-  = case occAnal env_body body of { (body_usage, body') ->-    let-        (final_usage, tagged_binders) = tagLamBinders body_usage binders'-                      -- Use binders' to put one-shot info on the lambdas-    in-    (final_usage, tagged_binders, body') }-  where-    env1 = env `addInScope` binders-    (env_body, binders') = oneShotGroup env1 binders--occAnalAlt :: OccEnv-           -> CoreAlt -> (UsageDetails, Alt IdWithOccInfo)-occAnalAlt env (Alt con bndrs rhs)-  = case occAnal (env `addInScope` bndrs) rhs of { (rhs_usage1, rhs1) ->-    let-      (alt_usg, tagged_bndrs) = tagLamBinders rhs_usage1 bndrs-    in                          -- See Note [Binders in case alternatives]-    (alt_usg, Alt con tagged_bndrs rhs1) }- {- ************************************************************************ *                                                                      *@@ -2286,13 +2455,12 @@             -- 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))+           -- then please replace x by (y |> sym mco)+           -- Invariant of course: idType x = exprType (y |> sym mco)+           , occ_bs_env  :: !(VarEnv (OutId, MCoercion))+           , occ_bs_rng  :: !VarSet   -- Vars free in the range of occ_bs_env                    -- 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     }  @@ -2322,7 +2490,7 @@   ppr OccScrut   = text "occScrut"   ppr OccVanilla = text "occVanilla" --- See note [OneShots]+-- See Note [OneShots] type OneShots = [OneShotInfo]  initOccEnv :: OccEnv@@ -2342,7 +2510,7 @@ noBinderSwaps (OccEnv { occ_bs_env = bs_env }) = isEmptyVarEnv bs_env  scrutCtxt :: OccEnv -> [CoreAlt] -> OccEnv-scrutCtxt env alts+scrutCtxt !env alts   | interesting_alts =  env { occ_encl = OccScrut,   occ_one_shots = [] }   | otherwise        =  env { occ_encl = OccVanilla, occ_one_shots = [] }   where@@ -2355,12 +2523,12 @@      -- pre/postInlineUnconditionally.  Grep for "occ_int_cxt"!  rhsCtxt :: OccEnv -> OccEnv-rhsCtxt env = env { occ_encl = OccRhs, occ_one_shots = [] }+rhsCtxt !env = env { occ_encl = OccRhs, occ_one_shots = [] } -argCtxt :: OccEnv -> [OneShots] -> (OccEnv, [OneShots])-argCtxt env []+valArgCtxt :: OccEnv -> [OneShots] -> (OccEnv, [OneShots])+valArgCtxt !env []   = (env { occ_encl = OccVanilla, occ_one_shots = [] }, [])-argCtxt env (one_shots:one_shots_s)+valArgCtxt env (one_shots:one_shots_s)   = (env { occ_encl = OccVanilla, occ_one_shots = one_shots }, one_shots_s)  isRhsEnv :: OccEnv -> Bool@@ -2368,66 +2536,20 @@                                           OccRhs -> True                                           _      -> False +addOneInScope :: OccEnv -> CoreBndr -> OccEnv+addOneInScope env@(OccEnv { occ_bs_env = swap_env, occ_bs_rng = rng_vars }) bndr+  | bndr `elemVarSet` rng_vars = env { occ_bs_env = emptyVarEnv, occ_bs_rng = emptyVarSet }+  | otherwise                  = env { occ_bs_env = swap_env `delVarEnv` bndr }+ addInScope :: OccEnv -> [Var] -> OccEnv -- See Note [The binder-swap substitution]+-- It's only neccessary to call this on in-scope Ids,+-- but harmless to include TyVars too addInScope env@(OccEnv { occ_bs_env = swap_env, occ_bs_rng = rng_vars }) bndrs   | any (`elemVarSet` rng_vars) bndrs = env { occ_bs_env = emptyVarEnv, occ_bs_rng = emptyVarSet }   | otherwise                         = env { occ_bs_env = swap_env `delVarEnvList` bndrs } -oneShotGroup :: OccEnv -> [CoreBndr]-             -> ( OccEnv-                , [CoreBndr] )-        -- The result binders have one-shot-ness set that they might not have had originally.-        -- This happens in (build (\c n -> e)).  Here the occurrence analyser-        -- linearity context knows that c,n are one-shot, and it records that fact in-        -- the binder. This is useful to guide subsequent float-in/float-out transformations -oneShotGroup env@(OccEnv { occ_one_shots = ctxt }) bndrs-  = go ctxt bndrs []-  where-    go ctxt [] rev_bndrs-      = ( env { occ_one_shots = ctxt, occ_encl = OccVanilla }-        , reverse rev_bndrs )--    go [] bndrs rev_bndrs-      = ( env { occ_one_shots = [], occ_encl = OccVanilla }-        , reverse rev_bndrs ++ bndrs )--    go ctxt@(one_shot : ctxt') (bndr : bndrs) rev_bndrs-      | isId bndr = go ctxt' bndrs (bndr': rev_bndrs)-      | otherwise = go ctxt  bndrs (bndr : rev_bndrs)-      where-        bndr' = updOneShotInfo bndr one_shot-               -- 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 [The oneShot function]---markJoinOneShots :: Maybe JoinArity -> [Var] -> [Var]--- Mark the lambdas of a non-recursive join point as one-shot.--- This is good to prevent gratuitous float-out etc-markJoinOneShots mb_join_arity bndrs-  = case mb_join_arity of-      Nothing -> bndrs-      Just n  -> go n bndrs- where-   go 0 bndrs  = bndrs-   go _ []     = [] -- 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.)-   go n (b:bs) = b' : go (n-1) bs-     where-       b' | isId b    = setOneShotLambda b-          | otherwise = b--addAppCtxt :: OccEnv -> [Arg CoreBndr] -> OccEnv-addAppCtxt env@(OccEnv { occ_one_shots = ctxt }) args-  = env { occ_one_shots = replicate (valArgCount args) OneShotLam ++ ctxt }- -------------------- transClosureFV :: VarEnv VarSet -> VarEnv VarSet -- If (f,g), (g,h) are in the input, then (f,h) is in the output@@ -2581,29 +2703,25 @@  (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+         - \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.+         - \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.+      The occurrence analyser itself does /not/ do cloning. It could, in+      principle, 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 }@@ -2659,7 +2777,7 @@ 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. -Historical note [no-case-of-case]+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:@@ -2674,7 +2792,7 @@ 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]+Historical Note [Suppressing the case binder-swap] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ This old note describes a problem that is also fixed by doing the binder-swap in OccAnal:@@ -2796,9 +2914,9 @@  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_no_tail :: ZappedSet } -- apply 'markNonTail' to these+       , ud_z_many    :: !ZappedSet   -- apply 'markMany' to these+       , ud_z_in_lam  :: !ZappedSet   -- apply 'markInsideLam' to these+       , ud_z_no_tail :: !ZappedSet } -- apply 'markNonTail' to these   -- INVARIANT: All three zapped sets are subsets of the OccInfoEnv  instance Outputable UsageDetails where@@ -2812,7 +2930,7 @@ andUDs = combineUsageDetailsWith addOccInfo orUDs  = combineUsageDetailsWith orOccInfo -mkOneOcc ::Id -> InterestingCxt -> JoinArity -> UsageDetails+mkOneOcc :: Id -> InterestingCxt -> JoinArity -> UsageDetails mkOneOcc id int_cxt arity   | isLocalId id   = emptyDetails { ud_env = unitVarEnv id occ_info }@@ -2842,6 +2960,12 @@ addManyOccs usage id_set = nonDetStrictFoldUniqSet addManyOcc usage id_set   -- It's OK to use nonDetStrictFoldUniqSet here because addManyOcc 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+  = uds `addManyOccs` coVarsOfTypes (map varType bndrs)+ delDetails :: UsageDetails -> Id -> UsageDetails delDetails ud bndr   = ud `alterUsageDetails` (`delVarEnv` bndr)@@ -2876,18 +3000,8 @@  markAllManyNonTail = markAllMany . markAllNonTail -- effectively sets to noOccInfo -markAllManyNonTailIf :: Bool              -- If this is true-             -> UsageDetails      -- Then do markAllManyNonTail on this-             -> UsageDetails-markAllManyNonTailIf True  uds = markAllManyNonTail uds-markAllManyNonTailIf False uds = uds- lookupDetails :: UsageDetails -> Id -> OccInfo lookupDetails ud id-  | isCoVar id  -- We do not currently gather occurrence info (from types)-  = noOccInfo   -- for CoVars, so we must conservatively mark them as used-                -- See Note [DoO not mark CoVars as dead]-  | otherwise   = case lookupVarEnv (ud_env ud) id of       Just occ -> doZapping ud id occ       Nothing  -> IAmDead@@ -2902,25 +3016,6 @@ restrictFreeVars :: VarSet -> OccInfoEnv -> VarSet restrictFreeVars bndrs fvs = restrictUniqSetToUFM bndrs fvs -{- Note [Do not mark CoVars as dead]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-It's obviously wrong to mark CoVars as dead if they are used.-Currently we don't traverse types to gather usase info for CoVars,-so we had better treat them as having noOccInfo.--This showed up in #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 co -> ...(typeError @(...co...) "urk")...--But then the "drop the case altogether" equation of rebuildCase-thought that 'co' was dead, and discarded the entire case. Urk!--I have no idea how we managed to avoid this pitfall for so long!--}- ------------------- -- Auxiliary functions for UsageDetails implementation @@ -2952,39 +3047,35 @@     occ2 | uniq `elemVarEnvByKey` no_tail = markNonTail occ1          | otherwise                      = occ1 -alterZappedSets :: UsageDetails -> (ZappedSet -> ZappedSet) -> UsageDetails-alterZappedSets ud f-  = ud { ud_z_many    = f (ud_z_many    ud)+alterUsageDetails :: UsageDetails -> (OccInfoEnv -> OccInfoEnv) -> UsageDetails+alterUsageDetails !ud f+  = UD { ud_env       = f (ud_env       ud)+       , ud_z_many    = f (ud_z_many    ud)        , ud_z_in_lam  = f (ud_z_in_lam  ud)        , ud_z_no_tail = f (ud_z_no_tail ud) } -alterUsageDetails :: UsageDetails -> (OccInfoEnv -> OccInfoEnv) -> UsageDetails-alterUsageDetails ud f-  = ud { ud_env = f (ud_env ud) } `alterZappedSets` f- flattenUsageDetails :: UsageDetails -> UsageDetails-flattenUsageDetails ud-  = ud { ud_env = mapUFM_Directly (doZappingByUnique ud) (ud_env ud) }-      `alterZappedSets` const emptyVarEnv+flattenUsageDetails ud@(UD { ud_env = env })+  = UD { ud_env       = mapUFM_Directly (doZappingByUnique ud) env+       , ud_z_many    = emptyVarEnv+       , ud_z_in_lam  = emptyVarEnv+       , ud_z_no_tail = emptyVarEnv }  ------------------- -- See Note [Adjusting right-hand sides]-adjustRhsUsage :: RecFlag -> Maybe JoinArity-               -> [CoreBndr]     -- Outer lambdas, AFTER occ anal+adjustRhsUsage :: Maybe JoinArity+               -> CoreExpr       -- Rhs, AFTER occ anal                -> UsageDetails   -- From body of lambda                -> UsageDetails-adjustRhsUsage is_rec mb_join_arity bndrs usage-  = markAllInsideLamIf (not one_shot) $+adjustRhsUsage mb_join_arity rhs usage+  = -- c.f. occAnal (Lam {})+    markAllInsideLamIf (not one_shot) $     markAllNonTailIf (not exact_join) $     usage   where-    one_shot = case mb_join_arity of-                 Just join_arity-                   | isRec is_rec -> False-                   | otherwise    -> all isOneShotBndr (drop join_arity bndrs)-                 Nothing          -> all isOneShotBndr bndrs-+    one_shot   = isOneShotFun rhs     exact_join = exactJoin mb_join_arity bndrs+    (bndrs,_)  = collectBinders rhs  exactJoin :: Maybe JoinArity -> [a] -> Bool exactJoin Nothing           _    = False@@ -3033,7 +3124,7 @@      occ     = lookupDetails usage binder      will_be_join = decideJoinPointHood lvl usage [binder]      occ'    | will_be_join = -- must already be marked AlwaysTailCalled-                              ASSERT(isAlwaysTailCalled occ) occ+                              assert (isAlwaysTailCalled occ) occ              | otherwise    = markNonTail occ      binder' = setBinderOcc occ' binder      usage'  = usage `delDetails` binder@@ -3042,17 +3133,16 @@  tagRecBinders :: TopLevelFlag           -- At top level?               -> UsageDetails           -- Of body of let ONLY-              -> [(CoreBndr,            -- Binder-                   UsageDetails,        -- RHS usage details-                   [CoreBndr])]         -- Lambdas in new RHS+              -> [Details]               -> (UsageDetails,         -- 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 triples+tagRecBinders lvl body_uds details_s  = let-     (bndrs, rhs_udss, _) = unzip3 triples+     bndrs    = map nd_bndr details_s+     rhs_udss = map nd_uds  details_s       -- 1. Determine join-point-hood of whole group, as determined by      --    the *unadjusted* usage details@@ -3061,21 +3151,22 @@       -- 2. Adjust usage details of each RHS, taking into account the      --    join-point-hood decision-     rhs_udss' = map adjust triples-     adjust (bndr, rhs_uds, rhs_bndrs)-       = adjustRhsUsage Recursive mb_join_arity rhs_bndrs rhs_uds-       where-         -- Can't use willBeJoinId_maybe here because we haven't tagged the-         -- binder yet (the tag depends on these adjustments!)-         mb_join_arity-           | will_be_joins-           , let occ = lookupDetails unadj_uds bndr-           , AlwaysTailCalled arity <- tailCallInfo occ-           = Just arity-           | otherwise-           = ASSERT(not will_be_joins) -- Should be AlwaysTailCalled if-             Nothing                   -- we are making join points!+     rhs_udss' = [ adjustRhsUsage (mb_join_arity bndr) rhs rhs_uds+                 | ND { nd_bndr = bndr, nd_uds = rhs_uds+                      , nd_rhs = rhs } <- details_s ] +     mb_join_arity :: Id -> Maybe JoinArity+     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+       , let occ = lookupDetails unadj_uds bndr+       , AlwaysTailCalled arity <- tailCallInfo occ+       = Just arity+       | otherwise+       = assert (not will_be_joins) -- Should be AlwaysTailCalled if+         Nothing                   -- we are making join points!+      -- 3. Compute final usage details from adjusted RHS details      adj_uds   = foldr andUDs body_uds rhs_udss' @@ -3118,9 +3209,9 @@   = False decideJoinPointHood NotTopLevel usage bndrs   | isJoinId (head bndrs)-  = WARN(not all_ok, text "OccurAnal failed to rediscover join point(s):" <+>-                       ppr bndrs)-    all_ok+  = warnPprTrace (not all_ok)+                 "OccurAnal failed to rediscover join point(s)" (ppr bndrs)+                 all_ok   | otherwise   = all_ok   where@@ -3163,9 +3254,11 @@  willBeJoinId_maybe :: CoreBndr -> Maybe JoinArity willBeJoinId_maybe bndr-  = case tailCallInfo (idOccInfo bndr) of-      AlwaysTailCalled arity -> Just arity-      _                      -> isJoinId_maybe bndr+  | isId bndr+  , AlwaysTailCalled arity <- tailCallInfo (idOccInfo bndr)+  = Just arity+  | otherwise+  = isJoinId_maybe bndr   {- Note [Join points and INLINE pragmas]@@ -3218,7 +3311,7 @@  addOccInfo, orOccInfo :: OccInfo -> OccInfo -> OccInfo -addOccInfo a1 a2  = ASSERT( not (isDeadOcc a1 || isDeadOcc a2) )+addOccInfo a1 a2  = assert (not (isDeadOcc a1 || isDeadOcc a2)) $                     ManyOccs { occ_tail = tailCallInfo a1 `andTailCallInfo`                                           tailCallInfo a2 }                                 -- Both branches are at least One@@ -3240,7 +3333,7 @@            , occ_int_cxt = int_cxt1 `mappend` int_cxt2            , occ_tail    = tail1 `andTailCallInfo` tail2 } -orOccInfo a1 a2 = ASSERT( not (isDeadOcc a1 || isDeadOcc a2) )+orOccInfo a1 a2 = assert (not (isDeadOcc a1 || isDeadOcc a2)) $                   ManyOccs { occ_tail = tailCallInfo a1 `andTailCallInfo`                                         tailCallInfo a2 }
GHC/Core/Opt/Pipeline.hs view
@@ -8,19 +8,16 @@  module GHC.Core.Opt.Pipeline ( core2core, simplifyExpr ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Driver.Session-import GHC.Driver.Ppr import GHC.Driver.Plugins ( withPlugins, installCoreToDos ) import GHC.Driver.Env import GHC.Platform.Ways  ( hasWay, Way(WayProf) )  import GHC.Core import GHC.Core.Opt.CSE  ( cseProgram )-import GHC.Core.Rules   ( mkRuleBase, unionRuleBase,+import GHC.Core.Rules   ( mkRuleBase,                           extendRuleBaseList, ruleCheckProgram, addRuleInfo,                           getRules, initRuleOpts ) import GHC.Core.Ppr     ( pprCoreBindings, pprCoreExpr )@@ -29,7 +26,7 @@ import GHC.Core.Utils   ( mkTicks, stripTicksTop, dumpIdInfoOfProgram ) import GHC.Core.Lint    ( endPass, lintPassResult, dumpPassResult,                           lintAnnots )-import GHC.Core.Opt.Simplify       ( simplTopBinds, simplExpr, simplRules )+import GHC.Core.Opt.Simplify       ( simplTopBinds, simplExpr, simplImpRules ) import GHC.Core.Opt.Simplify.Utils ( simplEnvForGHCi, activeRule, activeUnfolding ) import GHC.Core.Opt.Simplify.Env import GHC.Core.Opt.Simplify.Monad@@ -46,15 +43,16 @@ import GHC.Core.Opt.Exitify      ( exitifyProgram ) import GHC.Core.Opt.WorkWrap     ( wwTopBinds ) import GHC.Core.Opt.CallerCC     ( addCallerCostCentres )+import GHC.Core.LateCC           (addLateCostCentresMG) import GHC.Core.Seq (seqBinds) import GHC.Core.FamInstEnv -import qualified GHC.Utils.Error as Err import GHC.Utils.Error  ( withTiming ) import GHC.Utils.Logger as Logger-import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Constants (debugIsOn)+import GHC.Utils.Trace  import GHC.Unit.External import GHC.Unit.Module.Env@@ -63,7 +61,6 @@  import GHC.Runtime.Context -import GHC.Types.SrcLoc import GHC.Types.Id import GHC.Types.Id.Info import GHC.Types.Basic@@ -71,12 +68,12 @@ import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Types.Tickish-import GHC.Types.Unique.Supply ( UniqSupply ) import GHC.Types.Unique.FM import GHC.Types.Name.Ppr  import Control.Monad import qualified GHC.LanguageExtensions as LangExt+import GHC.Unit.Module {- ************************************************************************ *                                                                      *@@ -97,12 +94,12 @@        ; (guts2, stats) <- runCoreM hsc_env hpt_rule_base uniq_mask mod                                     orph_mods print_unqual loc $                            do { hsc_env' <- getHscEnv-                              ; all_passes <- withPlugins hsc_env'+                              ; all_passes <- withPlugins (hsc_plugins hsc_env')                                                 installCoreToDos                                                 builtin_passes                               ; runCorePasses all_passes guts } -       ; Logger.dumpIfSet_dyn logger dflags Opt_D_dump_simpl_stats+       ; Logger.putDumpFileMaybe logger Opt_D_dump_simpl_stats              "Grand total simplifier statistics"              FormatText              (pprSimplCount stats)@@ -111,7 +108,8 @@   where     logger         = hsc_logger hsc_env     dflags         = hsc_dflags hsc_env-    home_pkg_rules = hptRules hsc_env (dep_mods deps)+    home_pkg_rules = hptRules hsc_env (moduleUnitId mod) (GWIB { gwib_mod = moduleName mod+                                                               , gwib_isBoot = NotBoot })     hpt_rule_base  = mkRuleBase home_pkg_rules     print_unqual   = mkPrintUnqualified (hsc_unit_env hsc_env) rdr_env     -- mod: get the module out of the current HscEnv so we can retrieve it from the monad.@@ -132,10 +130,10 @@ getCoreToDo logger dflags   = flatten_todos core_todo   where-    opt_level     = optLevel           dflags     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@@ -155,6 +153,9 @@     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)@@ -225,17 +226,11 @@     add_caller_ccs =         runWhen (profiling && not (null $ callerCcFilters dflags)) CoreAddCallerCcs -    core_todo =-     if opt_level == 0 then-       [ static_ptrs_float_outwards,-         CoreDoSimplify max_iter-             (base_mode { sm_phase = FinalPhase-                        , sm_names = ["Non-opt simplification"] })-       , add_caller_ccs-       ]--     else {- opt_level >= 1 -} [+    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@@ -243,7 +238,7 @@         runWhen static_args (CoreDoPasses [ simpl_gently, CoreDoStaticArgs ]),          -- initial simplify: mk specialiser happy: minimum effort please-        simpl_gently,+        runWhen do_presimplify simpl_gently,          -- Specialisation is best done before full laziness         -- so that overloaded functions have all their dictionary lambdas manifest@@ -279,9 +274,10 @@            static_ptrs_float_outwards,          -- Run the simplier phases 2,1,0 to allow rewrite rules to fire-        CoreDoPasses [ simpl_phase (Phase phase) "main" max_iter-                     | phase <- [phases, phases-1 .. 1] ],-        simpl_phase (Phase 0) "main" (max max_iter 3),+        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 @@ -309,7 +305,7 @@         runWhen strictness demand_analyser,          runWhen exitification CoreDoExitify,-            -- See note [Placement of the exitification pass]+            -- See Note [Placement of the exitification pass]          runWhen full_laziness $            CoreDoFloatOutwards FloatOutSwitches {@@ -377,7 +373,8 @@          maybe_rule_check FinalPhase, -        add_caller_ccs+        add_caller_ccs,+        add_late_ccs      ]      -- Remove 'CoreDoNothing' and flatten 'CoreDoPasses' for clarity.@@ -468,9 +465,8 @@     do_pass guts CoreDoNothing = return guts     do_pass guts (CoreDoPasses ps) = runCorePasses ps guts     do_pass guts pass = do-      dflags <- getDynFlags       logger <- getLogger-      withTiming logger dflags (ppr pass <+> brackets (ppr mod))+      withTiming logger (ppr pass <+> brackets (ppr mod))                    (const ()) $ do             guts' <- lintAnnots (ppr pass) (doCorePass pass) guts             endPass pass (mg_binds guts') (mg_rules guts')@@ -480,40 +476,48 @@  doCorePass :: CoreToDo -> ModGuts -> CoreM ModGuts doCorePass pass guts = do-  logger <- getLogger+  logger    <- getLogger+  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' }+   case pass of     CoreDoSimplify {}         -> {-# SCC "Simplify" #-}                                  simplifyPgm pass guts      CoreCSE                   -> {-# SCC "CommonSubExpr" #-}-                                 doPass cseProgram guts+                                 updateBinds cseProgram      CoreLiberateCase          -> {-# SCC "LiberateCase" #-}-                                 doPassD liberateCase guts+                                 updateBinds (liberateCase dflags)      CoreDoFloatInwards        -> {-# SCC "FloatInwards" #-}-                                 floatInwards guts+                                 updateBinds (floatInwards platform)      CoreDoFloatOutwards f     -> {-# SCC "FloatOutwards" #-}-                                 doPassDUM (floatOutwards logger f) guts+                                 updateBindsM (liftIO . floatOutwards logger f us)      CoreDoStaticArgs          -> {-# SCC "StaticArgs" #-}-                                 doPassU doStaticArgs guts+                                 updateBinds (doStaticArgs us)      CoreDoCallArity           -> {-# SCC "CallArity" #-}-                                 doPassD callArityAnalProgram guts+                                 updateBinds callArityAnalProgram      CoreDoExitify             -> {-# SCC "Exitify" #-}-                                 doPass exitifyProgram guts+                                 updateBinds exitifyProgram      CoreDoDemand              -> {-# SCC "DmdAnal" #-}-                                 doPassDFRM (dmdAnal logger) guts+                                 updateBindsM (liftIO . dmdAnal logger dflags fam_envs (mg_rules guts))      CoreDoCpr                 -> {-# SCC "CprAnal" #-}-                                 doPassDFM (cprAnalProgram logger) guts+                                 updateBindsM (liftIO . cprAnalProgram logger fam_envs)      CoreDoWorkerWrapper       -> {-# SCC "WorkWrap" #-}-                                 doPassDFU wwTopBinds guts+                                 updateBinds (wwTopBinds (mg_module guts) dflags fam_envs us)      CoreDoSpecialising        -> {-# SCC "Specialise" #-}                                  specProgram guts@@ -524,9 +528,14 @@     CoreAddCallerCcs          -> {-# SCC "AddCallerCcs" #-}                                  addCallerCostCentres guts -    CoreDoPrintCore           -> observe (printCore logger) guts+    CoreAddLateCcs            -> {-# SCC "AddLateCcs" #-}+                                 addLateCostCentresMG guts -    CoreDoRuleCheck phase pat -> ruleCheckPass phase pat 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 @@ -546,84 +555,26 @@ ************************************************************************ -} -printCore :: Logger -> DynFlags -> CoreProgram -> IO ()-printCore logger dflags binds-    = Logger.dumpIfSet logger dflags True "Print Core" (pprCoreBindings binds)+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 dflags (text "RuleCheck"<+>brackets (ppr $ mg_module guts))+    withTiming logger (text "RuleCheck"<+>brackets (ppr $ mg_module guts))                 (const ()) $ do         rb <- getRuleBase         vis_orphs <- getVisibleOrphanMods-        let rule_fn fn = getRules (RuleEnv rb vis_orphs) fn+        let rule_fn fn = getRules (RuleEnv [rb] vis_orphs) fn                           ++ (mg_rules guts)         let ropts = initRuleOpts dflags-        liftIO $ putLogMsg logger dflags NoReason Err.SevDump noSrcSpan-                     $ withPprStyle defaultDumpStyle+        liftIO $ logDumpMsg logger "Rule check"                      (ruleCheckProgram ropts current_phase pat                         rule_fn (mg_binds guts))         return guts -doPassDUM :: (DynFlags -> UniqSupply -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts-doPassDUM do_pass = doPassM $ \binds -> do-    dflags <- getDynFlags-    us     <- getUniqueSupplyM-    liftIO $ do_pass dflags us binds--doPassDM :: (DynFlags -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts-doPassDM do_pass = doPassDUM (\dflags -> const (do_pass dflags))--doPassD :: (DynFlags -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts-doPassD do_pass = doPassDM (\dflags -> return . do_pass dflags)--doPassDU :: (DynFlags -> UniqSupply -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts-doPassDU do_pass = doPassDUM (\dflags us -> return . do_pass dflags us)--doPassU :: (UniqSupply -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts-doPassU do_pass = doPassDU (const do_pass)--doPassDFM :: (DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts-doPassDFM do_pass guts = do-    dflags <- getDynFlags-    p_fam_env <- getPackageFamInstEnv-    let fam_envs = (p_fam_env, mg_fam_inst_env guts)-    doPassM (liftIO . do_pass dflags fam_envs) guts--doPassDFRM :: (DynFlags -> FamInstEnvs -> [CoreRule] -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts-doPassDFRM do_pass guts = do-    dflags <- getDynFlags-    p_fam_env <- getPackageFamInstEnv-    let fam_envs = (p_fam_env, mg_fam_inst_env guts)-    doPassM (liftIO . do_pass dflags fam_envs (mg_rules guts)) guts--doPassDFU :: (DynFlags -> FamInstEnvs -> UniqSupply -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts-doPassDFU do_pass guts = do-    dflags <- getDynFlags-    us     <- getUniqueSupplyM-    p_fam_env <- getPackageFamInstEnv-    let fam_envs = (p_fam_env, mg_fam_inst_env guts)-    doPass (do_pass dflags fam_envs us) guts---- Most passes return no stats and don't change rules: these combinators--- let us lift them to the full blown ModGuts+CoreM world-doPassM :: Monad m => (CoreProgram -> m CoreProgram) -> ModGuts -> m ModGuts-doPassM bind_f guts = do-    binds' <- bind_f (mg_binds guts)-    return (guts { mg_binds = binds' })--doPass :: (CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts-doPass bind_f guts = return $ guts { mg_binds = bind_f (mg_binds guts) }---- Observer passes just peek; don't modify the bindings at all-observe :: (DynFlags -> CoreProgram -> IO a) -> ModGuts -> CoreM ModGuts-observe do_pass = doPassM $ \binds -> do-    dflags <- getDynFlags-    _ <- liftIO $ do_pass dflags binds-    return binds- {- ************************************************************************ *                                                                      *@@ -638,23 +589,22 @@ -- simplifyExpr is called by the driver to simplify an -- expression typed in at the interactive prompt simplifyExpr hsc_env expr-  = withTiming logger dflags (text "Simplify [expr]") (const ()) $+  = withTiming logger (text "Simplify [expr]") (const ()) $     do  { eps <- hscEPS hsc_env ;-        ; let rule_env  = mkRuleEnv (eps_rule_base eps) []-              fi_env    = ( eps_fam_inst_env eps+        ; let fi_env    = ( eps_fam_inst_env eps                           , extendFamInstEnvList emptyFamInstEnv $                             snd $ ic_instances $ hsc_IC hsc_env )               simpl_env = simplEnvForGHCi logger dflags          ; let sz = exprSize expr -        ; (expr', counts) <- initSmpl logger dflags rule_env fi_env sz $+        ; (expr', counts) <- initSmpl logger dflags (eps_rule_base <$> hscEPS hsc_env) emptyRuleEnv fi_env sz $                              simplExprGently simpl_env expr -        ; Logger.dumpIfSet logger dflags (dopt Opt_D_dump_simpl_stats dflags)-                  "Simplifier statistics" (pprSimplCount counts)+        ; Logger.putDumpFileMaybe logger Opt_D_dump_simpl_stats+                  "Simplifier statistics" FormatText (pprSimplCount counts) -        ; Logger.dumpIfSet_dyn logger dflags Opt_D_dump_simpl "Simplified expression"+        ; Logger.putDumpFileMaybe logger Opt_D_dump_simpl "Simplified expression"                         FormatCore                         (pprCoreExpr expr') @@ -678,7 +628,7 @@ -- enforce that; it just simplifies the expression twice  -- It's important that simplExprGently does eta reduction; see--- Note [Simplifying the left-hand side of a RULE] above.  The+-- 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. @@ -717,8 +667,9 @@   = do { (termination_msg, it_count, counts_out, guts')            <- do_iteration 1 [] binds rules -        ; Logger.dumpIfSet logger dflags (dopt Opt_D_verbose_core2core dflags &&-                                dopt Opt_D_dump_simpl_stats  dflags)+        ; 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",@@ -746,12 +697,13 @@         -- iteration_no is the number of the iteration we are         -- about to begin, with '1' for the first       | iteration_no > max_iterations   -- Stop if we've run out of iterations-      = WARN( debugIsOn && (max_iterations > 2)-            , hang (text "Simplifier bailing out after" <+> int max_iterations-                    <+> text "iterations"+      = 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)))+                 2 (text "Size =" <+> ppr (coreBindsStats binds))) $                  -- Subtract 1 from iteration_no to get the                 -- number of iterations we actually completed@@ -769,25 +721,27 @@                      occurAnalysePgm this_mod active_unf active_rule rules                                      binds                } ;-           Logger.dumpIfSet_dyn logger dflags Opt_D_dump_occur_anal "Occurrence analysis"+           Logger.putDumpFileMaybe logger Opt_D_dump_occur_anal "Occurrence analysis"                      FormatCore                      (pprCoreBindings tagged_binds); -                -- Get any new rules, and extend the rule base-                -- See Note [Overall plumbing for rules] in GHC.Core.Rules-                -- We need to do this regularly, because simplification can+                -- 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 rules we read on the EPS+                -- value and then combine it when the existing rule base.+                -- See `GHC.Core.Opt.Simplify.Monad.getSimplRules`.            eps <- hscEPS hsc_env ;-           let  { rule_base1 = unionRuleBase hpt_rule_base (eps_rule_base eps)-                ; rule_base2 = extendRuleBaseList rule_base1 rules+           let  { read_eps_rules = eps_rule_base <$> hscEPS hsc_env+                ; rule_base = extendRuleBaseList hpt_rule_base rules                 ; fam_envs = (eps_fam_inst_env eps, fam_inst_env)                 ; vis_orphs = this_mod : dep_orphs deps } ;                  -- Simplify the program            ((binds1, rules1), counts1) <--             initSmpl logger dflags (mkRuleEnv rule_base2 vis_orphs) fam_envs sz $+             initSmpl logger dflags read_eps_rules (mkRuleEnv rule_base vis_orphs) fam_envs sz $                do { (floats, env1) <- {-# SCC "SimplTopBinds" #-}                                       simplTopBinds simpl_env tagged_binds @@ -795,7 +749,7 @@                       -- for imported Ids.  Eg  RULE map my_f = blah                       -- If we have a substitution my_f :-> other_f, we'd better                       -- apply it to the rule to, or it'll never match-                  ; rules1 <- simplRules env1 Nothing rules Nothing+                  ; rules1 <- simplImpRules env1 rules                    ; return (getTopFloatBinds floats, rules1) } ; @@ -817,7 +771,8 @@            let { binds2 = {-# SCC "ZapInd" #-} shortOutIndirections binds1 } ;                  -- Dump the result of this iteration-           dump_end_iteration logger dflags print_unqual iteration_no counts1 binds2 rules1 ;+           let { dump_core_sizes = not (gopt Opt_SuppressCoreSizes dflags) } ;+           dump_end_iteration logger dump_core_sizes print_unqual iteration_no counts1 binds2 rules1 ;            lintPassResult hsc_env pass binds2 ;                  -- Loop@@ -835,19 +790,19 @@ simplifyPgmIO _ _ _ _ = panic "simplifyPgmIO"  --------------------dump_end_iteration :: Logger -> DynFlags -> PrintUnqualified -> Int+dump_end_iteration :: Logger -> Bool -> PrintUnqualified -> Int                    -> SimplCount -> CoreProgram -> [CoreRule] -> IO ()-dump_end_iteration logger dflags print_unqual iteration_no counts binds rules-  = dumpPassResult logger dflags print_unqual mb_flag hdr pp_counts binds rules+dump_end_iteration logger dump_core_sizes print_unqual iteration_no counts binds rules+  = dumpPassResult logger dump_core_sizes print_unqual mb_flag hdr pp_counts binds rules   where-    mb_flag | dopt Opt_D_dump_simpl_iterations dflags = Just Opt_D_dump_simpl_iterations-            | otherwise                               = Nothing+    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 = text "Simplifier iteration=" <> int iteration_no-    pp_counts = vcat [ text "---- Simplifier counts for" <+> hdr+    hdr = "Simplifier iteration=" ++ show iteration_no+    pp_counts = vcat [ text "---- Simplifier counts for" <+> text hdr                      , pprSimplCount counts-                     , text "---- End of simplifier counts for" <+> hdr ]+                     , text "---- End of simplifier counts for" <+> text hdr ]  {- ************************************************************************@@ -988,7 +943,7 @@ shortOutIndirections :: CoreProgram -> CoreProgram shortOutIndirections binds   | isEmptyVarEnv ind_env = binds-  | no_need_to_flatten    = binds'                      -- See Note [Rules and indirect-zapping]+  | 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@@ -1050,9 +1005,8 @@        not (local_id `elemVarEnv` ind_env)      -- Only if not already substituted for     then         if hasShortableIdInfo exported_id-        then True       -- See Note [Messing up the exported Id's IdInfo]-        else WARN( True, text "Not shorting out:" <+> ppr exported_id )-             False+        then True       -- See Note [Messing up the exported Id's RULES]+        else warnPprTrace True "Not shorting out" (ppr exported_id) False     else         False @@ -1060,11 +1014,11 @@ hasShortableIdInfo :: Id -> Bool -- True if there is no user-attached IdInfo on exported_id, -- so we can safely discard it--- See Note [Messing up the exported Id's IdInfo]+-- See Note [Messing up the exported Id's RULES] hasShortableIdInfo id   =  isEmptyRuleInfo (ruleInfo info)   && isDefaultInlinePragma (inlinePragInfo info)-  && not (isStableUnfolding (unfoldingInfo info))+  && not (isStableUnfolding (realUnfoldingInfo info))   where      info = idInfo id @@ -1085,37 +1039,47 @@  Overwriting, rather than merging, seems to work ok. -We also zap the InlinePragma on the lcl_id. It might originally-have had a NOINLINE, which we have now transferred; and we really-want the lcl_id to inline now that its RHS is trivial!+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-    , local_id `setInlinePragma` defaultInlinePragma )+    , modifyIdInfo zap_info local_id )   where     local_info = idInfo local_id-    transfer exp_info = exp_info `setStrictnessInfo`    strictnessInfo local_info-                                 `setCprInfo`           cprInfo local_info-                                 `setUnfoldingInfo`     unfoldingInfo local_info-                                 `setInlinePragInfo`    inlinePragInfo local_info-                                 `setRuleInfo`          addRuleInfo (ruleInfo exp_info) new_info+    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   dmdAnal :: Logger -> DynFlags -> FamInstEnvs -> [CoreRule] -> CoreProgram -> IO CoreProgram dmdAnal logger dflags fam_envs rules binds = do   let !opts = DmdAnalOpts-               { dmd_strict_dicts = gopt Opt_DictsStrict dflags+               { dmd_strict_dicts    = gopt Opt_DictsStrict dflags+               , dmd_unbox_width     = dmdUnboxWidth dflags+               , dmd_max_worker_args = maxWorkerArgs dflags                }       binds_plus_dmds = dmdAnalProgram opts fam_envs rules binds-  Logger.dumpIfSet_dyn logger dflags Opt_D_dump_str_signatures "Strictness signatures" FormatText $-    dumpIdInfoOfProgram (ppr . zapDmdEnvSig . strictnessInfo) binds_plus_dmds+  Logger.putDumpFileMaybe logger Opt_D_dump_str_signatures "Strictness signatures" FormatText $+    dumpIdInfoOfProgram (hasPprDebug dflags) (ppr . zapDmdEnvSig . dmdSigInfo) binds_plus_dmds   -- See Note [Stamp out space leaks in demand analysis] in GHC.Core.Opt.DmdAnal   seqBinds binds_plus_dmds `seq` return binds_plus_dmds
GHC/Core/Opt/SetLevels.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP             #-}+ {-# LANGUAGE PatternSynonyms #-}  {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}@@ -55,9 +55,9 @@    This can only work if @wild@ is an unrestricted binder. Indeed, even with the   extended typing rule (in the linter) for case expressions, if-       case x of wild # 1 { p -> e}+       case x of wild % 1 { p -> e}   is well-typed, then-       case x of wild # 1 { p -> e[wild\x] }+       case x of wild % 1 { p -> e[wild\x] }   is only well-typed if @e[wild\x] = e@ (that is, if @wild@ is not used in @e@   at all). In which case, it is, of course, pointless to do the substitution   anyway. So for a linear binder (and really anything which isn't unrestricted),@@ -75,18 +75,13 @@         incMinorLvl, ltMajLvl, ltLvl, isTopLvl     ) where -#include "HsVersions.h"- import GHC.Prelude -import GHC.Driver.Ppr- import GHC.Core import GHC.Core.Opt.Monad ( FloatOutSwitches(..) ) import GHC.Core.Utils   ( exprType, exprIsHNF                         , exprOkForSpeculation                         , exprIsTopLevelBindable-                        , isExprLevPoly                         , collectMakeStaticArgs                         , mkLamTypes                         )@@ -94,6 +89,12 @@ import GHC.Core.FVs     -- all of it import GHC.Core.Subst import GHC.Core.Make    ( sortQuantVars )+import GHC.Core.Type    ( Type, splitTyConApp_maybe, tyCoVarsOfType+                        , mightBeUnliftedType, closeOverKindsDSet+                        , typeHasFixedRuntimeRep+                        )+import GHC.Core.Multiplicity     ( pattern Many )+import GHC.Core.DataCon ( dataConOrigResTy )  import GHC.Types.Id import GHC.Types.Id.Info@@ -103,28 +104,30 @@ import GHC.Types.Unique.DSet  ( getUniqDSet ) import GHC.Types.Var.Env import GHC.Types.Literal      ( litIsTrivial )-import GHC.Types.Demand       ( StrictSig, Demand, isStrUsedDmd, splitStrictSig, prependArgsStrictSig )+import GHC.Types.Demand       ( DmdSig, Demand, isStrUsedDmd, splitDmdSig, prependArgsDmdSig ) import GHC.Types.Cpr          ( mkCprSig, botCpr ) import GHC.Types.Name         ( getOccName, mkSystemVarName ) import GHC.Types.Name.Occurrence ( occNameString ) import GHC.Types.Unique       ( hasKey ) import GHC.Types.Tickish      ( tickishIsCode )-import GHC.Core.Type    ( Type, splitTyConApp_maybe, tyCoVarsOfType-                        , mightBeUnliftedType, closeOverKindsDSet )-import GHC.Core.Multiplicity     ( pattern Many )+import GHC.Types.Unique.Supply+import GHC.Types.Unique.DFM import GHC.Types.Basic  ( Arity, RecFlag(..), isRec )-import GHC.Core.DataCon ( dataConOrigResTy )+ import GHC.Builtin.Types import GHC.Builtin.Names      ( runRWKey )-import GHC.Types.Unique.Supply++import GHC.Data.FastString++import GHC.Utils.FV+import GHC.Utils.Monad  ( mapAccumLM ) import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Data.FastString-import GHC.Types.Unique.DFM-import GHC.Utils.FV+import GHC.Utils.Panic.Plain+import GHC.Utils.Trace+ import Data.Maybe-import GHC.Utils.Monad  ( mapAccumLM )  {- ************************************************************************@@ -288,35 +291,35 @@           -> [LevelledBind]  setLevels float_lams binds us-  = initLvl us (do_them init_env binds)+  = initLvl us (do_them binds)   where-    init_env = initialEnv float_lams+    env = initialEnv float_lams binds -    do_them :: LevelEnv -> [CoreBind] -> LvlM [LevelledBind]-    do_them _ [] = return []-    do_them env (b:bs)-      = do { (lvld_bind, env') <- lvlTopBind env b-           ; lvld_binds <- do_them env' bs+    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, LevelEnv)+lvlTopBind :: LevelEnv -> Bind Id -> LvlM LevelledBind lvlTopBind env (NonRec bndr rhs)-  = do { rhs' <- lvl_top env NonRecursive bndr rhs-       ; let (env', [bndr']) = substAndLvlBndrs NonRecursive env tOP_LEVEL [bndr]-       ; return (NonRec bndr' rhs', env') }+  = do { (bndr', rhs') <- lvl_top env NonRecursive bndr rhs+       ; return (NonRec bndr' rhs') }  lvlTopBind env (Rec pairs)-  = do { let (env', bndrs') = substAndLvlBndrs Recursive env tOP_LEVEL-                                               (map fst pairs)-       ; rhss' <- mapM (\(b,r) -> lvl_top env' Recursive b r) pairs-       ; return (Rec (bndrs' `zip` rhss'), env') }+  = do { prs' <- mapM (\(b,r) -> lvl_top env Recursive b r) pairs+       ; return (Rec prs') } -lvl_top :: LevelEnv -> RecFlag -> Id -> CoreExpr -> LvlM LevelledExpr+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-  = lvlRhs env is_rec-           (isDeadEndId bndr)-           Nothing  -- Not a join point-           (freeVars rhs)+  = do { rhs' <- lvlRhs env is_rec (isDeadEndId bndr)+                                   Nothing  -- Not a join point+                                   (freeVars rhs)+       ; return (stayPut tOP_LEVEL bndr, rhs') }  {- ************************************************************************@@ -446,7 +449,7 @@     arity      = idArity fn      stricts :: [Demand]   -- True for strict /value/ arguments-    stricts = case splitStrictSig (idStrictness fn) of+    stricts = case splitDmdSig (idDmdSig fn) of                 (arg_ds, _) | arg_ds `lengthExceeds` n_val_args                             -> []                             | otherwise@@ -666,9 +669,10 @@          -- 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]-  || isExprLevPoly expr-         -- We can't let-bind levity polymorphic expressions-         -- See Note [Levity polymorphism invariants] in GHC.Core+  || not (typeHasFixedRuntimeRep (exprType expr))+         -- We can't let-bind an expression if we don't know+         -- how it will be represented at runtime.+         -- See Note [Representation polymorphism invariants] in GHC.Core   || notWorthFloating expr abs_vars   || not float_me   =     -- Don't float it out@@ -822,7 +826,7 @@      t = f (g True)   If f is lazy, we /do/ float (g True) because then we can allocate   the thunk statically rather than dynamically.  But if f is strict-  we don't (see the use of idStrictness in lvlApp).  It's not clear+  we don't (see the use of idDmdSig in lvlApp).  It's not clear   if this test is worth the bother: it's only about CAFs!  It's controlled by a flag (floatConsts), because doing this too@@ -1024,7 +1028,7 @@  -} -annotateBotStr :: Id -> Arity -> Maybe (Arity, StrictSig) -> Id+annotateBotStr :: Id -> Arity -> Maybe (Arity, DmdSig) -> Id -- See Note [Bottoming floats] for why we want to add -- bottoming information right now --@@ -1033,8 +1037,8 @@   = case mb_str of       Nothing           -> id       Just (arity, sig) -> id `setIdArity`      (arity + n_extra)-                              `setIdStrictness` (prependArgsStrictSig n_extra sig)-                              `setIdCprInfo`    mkCprSig (arity + n_extra) botCpr+                              `setIdDmdSig` (prependArgsDmdSig n_extra sig)+                              `setIdCprSig`    mkCprSig (arity + n_extra) botCpr  notWorthFloating :: CoreExpr -> [Var] -> Bool -- Returns True if the expression would be replaced by@@ -1052,7 +1056,7 @@   = go e (count isId abs_vars)   where     go (Var {}) n    = n >= 0-    go (Lit lit) n   = ASSERT( n==0 )+    go (Lit lit) n   = assert (n==0) $                        litIsTrivial lit   -- Note [Floating literals]     go (Tick t e) n  = not (tickishIsCode t) && go e n     go (Cast e _)  n = go e n@@ -1551,9 +1555,9 @@  {- Note [le_subst and le_env] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We clone let- and case-bound variables so that they are still distinct-when floated out; hence the le_subst/le_env.  (see point 3 of the-module overview comment).  We also use these envs when making a+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. @@ -1580,14 +1584,21 @@ The domain of the le_lvl_env is the *post-cloned* Ids -} -initialEnv :: FloatOutSwitches -> LevelEnv-initialEnv float_lams-  = LE { le_switches = float_lams-       , le_ctxt_lvl = tOP_LEVEL+initialEnv :: FloatOutSwitches -> CoreProgram -> LevelEnv+initialEnv float_lams binds+  = LE { le_switches  = float_lams+       , le_ctxt_lvl  = tOP_LEVEL        , le_join_ceil = panic "initialEnv"-       , le_lvl_env = emptyVarEnv-       , le_subst = emptySubst-       , le_env = emptyVarEnv }+       , le_lvl_env   = emptyVarEnv+       , le_subst     = mkEmptySubst in_scope_toplvl+       , le_env       = emptyVarEnv }+  where+    in_scope_toplvl = emptyInScopeSet `extendInScopeSetList` bindersOfBinds 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@@ -1690,9 +1701,9 @@          -- We are going to lambda-abstract, so nuke any IdInfo,         -- and add the tyvars of the Id (if necessary)-    zap v | isId v = WARN( isStableUnfolding (idUnfolding v) ||-                           not (isEmptyRuleInfo (idSpecialisation v)),-                           text "absVarsOf: discarding info on" <+> ppr v )+    zap v | isId v = warnPprTrace (isStableUnfolding (idUnfolding v) ||+                           not (isEmptyRuleInfo (idSpecialisation v)))+                           "absVarsOf: discarding info on" (ppr v) $                      setIdInfo v vanillaIdInfo           | otherwise = v @@ -1708,7 +1719,7 @@ 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.+ = 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@@ -1807,7 +1818,7 @@ 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)+  | otherwise = extendVarEnv id_env v ([v1], assert (not (isCoVar v1)) $ Var v1)  {- Note [Zapping the demand info]
GHC/Core/Opt/Simplify.hs view
@@ -4,4202 +4,4281 @@ \section[Simplify]{The main module of the simplifier} -} -{-# LANGUAGE CPP #-}-{-# LANGUAGE TypeFamilies #-}--{-# OPTIONS_GHC -Wno-incomplete-record-updates -Wno-incomplete-uni-patterns #-}-module GHC.Core.Opt.Simplify ( simplTopBinds, simplExpr, simplRules ) where--#include "HsVersions.h"--import GHC.Prelude--import GHC.Platform-import GHC.Driver.Session-import GHC.Driver.Ppr-import GHC.Driver.Config-import GHC.Core.Opt.Simplify.Monad-import GHC.Core.Type hiding ( substTy, substTyVar, extendTvSubst, extendCvSubst )-import GHC.Core.Opt.Simplify.Env-import GHC.Core.Opt.Simplify.Utils-import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr )-import GHC.Types.Literal   ( litIsLifted ) --, mkLitInt ) -- temporalily commented out. See #8326-import GHC.Types.SourceText-import GHC.Types.Id-import GHC.Types.Id.Make   ( seqId )-import GHC.Core.Make       ( FloatBind, mkImpossibleExpr, castBottomExpr )-import qualified GHC.Core.Make-import GHC.Types.Id.Info-import GHC.Types.Name           ( mkSystemVarName, isExternalName, getOccFS )-import GHC.Core.Coercion hiding ( substCo, substCoVar )-import GHC.Core.Coercion.Opt    ( optCoercion )-import GHC.Core.FamInstEnv      ( FamInstEnv, topNormaliseType_maybe )-import GHC.Core.DataCon-   ( DataCon, dataConWorkId, dataConRepStrictness-   , dataConRepArgTys, isUnboxedTupleDataCon-   , StrictnessMark (..) )-import GHC.Core.Opt.Monad ( Tick(..), SimplMode(..) )-import GHC.Core-import GHC.Builtin.Types.Prim( realWorldStatePrimTy )-import GHC.Builtin.Names( runRWKey )-import GHC.Types.Demand ( StrictSig(..), Demand, dmdTypeDepth, isStrUsedDmd-                        , mkClosedStrictSig, topDmd, seqDmd, isDeadEndDiv )-import GHC.Types.Cpr    ( mkCprSig, botCpr )-import GHC.Core.Ppr     ( pprCoreExpr )-import GHC.Types.Unique ( hasKey )-import GHC.Core.Unfold-import GHC.Core.Unfold.Make-import GHC.Core.Utils-import GHC.Core.Opt.Arity ( ArityType(..)-                          , pushCoTyArg, pushCoValArg-                          , idArityType, etaExpandAT )-import GHC.Core.SimpleOpt ( exprIsConApp_maybe, joinPointBinding_maybe, joinPointBindings_maybe )-import GHC.Core.FVs     ( mkRuleInfo )-import GHC.Core.Rules   ( lookupRule, getRules, initRuleOpts )-import GHC.Types.Basic-import GHC.Utils.Monad  ( mapAccumLM, liftIO )-import GHC.Utils.Logger-import GHC.Types.Tickish-import GHC.Types.Var    ( isTyCoVar )-import GHC.Data.Maybe   ( isNothing, orElse )-import Control.Monad-import GHC.Utils.Outputable-import GHC.Utils.Panic-import GHC.Data.FastString-import GHC.Utils.Misc-import GHC.Unit.Module ( moduleName, pprModuleName )-import GHC.Core.Multiplicity-import GHC.Builtin.PrimOps ( PrimOp (SeqOp) )---{--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 (which includes DynFlags for convenience)-     - Ambient substitution-     - InScopeSet-- * SimplFloats contains-     - Let-floats (which includes ok-for-spec case-floats)-     - Join floats-     - InScopeSet (including all the floats)-- * Expressions-      simplExpr :: SimplEnv -> InExpr -> SimplCont-                -> SimplM (SimplFloats, OutExpr)-   The result of simplifying an /expression/ is (floats, expr)-      - A bunch of floats (let bindings, join bindings)-      - A simplified expression.-   The overall result is effectively (let floats in expr)-- * Bindings-      simplBind :: SimplEnv -> InBind -> SimplM (SimplFloats, SimplEnv)-   The result of simplifying a binding is-     - A bunch of floats, the last of which is the simplified binding-       There may be auxiliary bindings too; see prepareRhs-     - An environment suitable for simplifying the scope of the binding--   The floats may also be empty, if the binding is inlined unconditionally;-   in that case the returned SimplEnv will have an augmented substitution.--   The returned floats and env both have an in-scope set, and they are-   guaranteed to be the same.---Note [Shadowing]-~~~~~~~~~~~~~~~~-The simplifier used to guarantee that the output had no shadowing, but-it does not do so any more.   (Actually, it never did!)  The reason is-documented with simplifyArgs.---Eta expansion-~~~~~~~~~~~~~~-For eta expansion, we want to catch things like--        case e of (a,b) -> \x -> case a of (p,q) -> \y -> r--If the \x was on the RHS of a let, we'd eta expand to bring the two-lambdas together.  And in general that's a good thing to do.  Perhaps-we should eta expand wherever we find a (value) lambda?  Then the eta-expansion at a let RHS can concentrate solely on the PAP case.--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 TopLevel Nothing pairs-    simpl_bind env (NonRec b r)-      = do { (env', b') <- addBndrRules env b (lookupRecBndr env b) Nothing-           ; simplRecOrTopPair env' TopLevel NonRecursive Nothing b b' r }--{--************************************************************************-*                                                                      *-        Lazy bindings-*                                                                      *-************************************************************************--simplRecBind is used for-        * recursive bindings only--}--simplRecBind :: SimplEnv -> TopLevelFlag -> MaybeJoinCont-             -> [(InId, InExpr)]-             -> SimplM (SimplFloats, SimplEnv)-simplRecBind env0 top_lvl mb_cont pairs0-  = do  { (env_with_info, triples) <- mapAccumLM add_rules env0 pairs0-        ; (rec_floats, env1) <- go env_with_info triples-        ; return (mkRecFloats rec_floats, env1) }-  where-    add_rules :: SimplEnv -> (InBndr,InExpr) -> SimplM (SimplEnv, (InBndr, OutBndr, InExpr))-        -- Add the (substituted) rules to the binder-    add_rules env (bndr, rhs)-        = do { (env', bndr') <- addBndrRules env bndr (lookupRecBndr env bndr) mb_cont-             ; return (env', (bndr, bndr', rhs)) }--    go env [] = return (emptyFloats env, env)--    go env ((old_bndr, new_bndr, rhs) : pairs)-        = do { (float, env1) <- simplRecOrTopPair env top_lvl Recursive mb_cont-                                                  old_bndr new_bndr rhs-             ; (floats, env2) <- go env1 pairs-             ; return (float `addFloats` floats, env2) }--{--simplOrTopPair is used for-        * recursive bindings (whether top level or not)-        * top-level non-recursive bindings--It assumes the binder has already been simplified, but not its IdInfo.--}--simplRecOrTopPair :: SimplEnv-                  -> TopLevelFlag -> RecFlag -> MaybeJoinCont-                  -> InId -> OutBndr -> InExpr  -- Binder and rhs-                  -> SimplM (SimplFloats, SimplEnv)--simplRecOrTopPair env top_lvl is_rec mb_cont old_bndr new_bndr rhs-  | Just env' <- preInlineUnconditionally env top_lvl old_bndr rhs env-  = {-#SCC "simplRecOrTopPair-pre-inline-uncond" #-}-    trace_bind "pre-inline-uncond" $-    do { tick (PreInlineUnconditionally old_bndr)-       ; return ( emptyFloats env, env' ) }--  | Just cont <- mb_cont-  = {-#SCC "simplRecOrTopPair-join" #-}-    ASSERT( isNotTopLevel top_lvl && isJoinId new_bndr )-    trace_bind "join" $-    simplJoinBind env cont old_bndr new_bndr rhs env--  | otherwise-  = {-#SCC "simplRecOrTopPair-normal" #-}-    trace_bind "normal" $-    simplLazyBind env top_lvl is_rec old_bndr new_bndr rhs env--  where-    dflags = seDynFlags env-    logger = seLogger env--    -- trace_bind emits a trace for each top-level binding, which-    -- helps to locate the tracing for inlining and rule firing-    trace_bind what thing_inside-      | not (dopt Opt_D_verbose_core2core dflags)-      = thing_inside-      | otherwise-      = putTraceMsg logger dflags ("SimplBind " ++ what)-         (ppr old_bndr) thing_inside-----------------------------simplLazyBind :: SimplEnv-              -> TopLevelFlag -> RecFlag-              -> InId -> OutId          -- Binder, both pre-and post simpl-                                        -- Not a JoinId-                                        -- The OutId has IdInfo, except arity, unfolding-                                        -- Ids only, no TyVars-              -> InExpr -> SimplEnv     -- The RHS and its environment-              -> SimplM (SimplFloats, SimplEnv)--- Precondition: not a JoinId--- Precondition: rhs obeys the let/app invariant--- NOT used for JoinIds-simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se-  = ASSERT( isId bndr )-    ASSERT2( not (isJoinId bndr), ppr bndr )-    -- pprTrace "simplLazyBind" ((ppr bndr <+> ppr bndr1) $$ ppr rhs $$ ppr (seIdSubst rhs_se)) $-    do  { let   !rhs_env     = rhs_se `setInScopeFromE` env -- 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))-        ; (body_floats0, body0) <- {-#SCC "simplExprF" #-} simplExprF body_env body rhs_cont--              -- 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: body_floats1 consists only of let-floats-        ; let (body_floats1, body1) = wrapJoinFloatsX body_floats0 body0--        -- ANF-ise a constructor or PAP rhs-        -- We get at most one float per argument here-        ; let body_env1 = body_env `setInScopeFromF` body_floats1-              -- body_env1: add to in-scope set the binders from body_floats1-              -- so that prepareBinding knows what is in scope in body1-        ; (let_floats, bndr2, body2) <- {-#SCC "prepareBinding" #-}-                                        prepareBinding body_env1 top_lvl bndr bndr1 body1-        ; let body_floats2 = body_floats1 `addLetFloats` let_floats--        ; (rhs_floats, body3)-            <-  if not (doFloatFromRhs top_lvl is_rec False body_floats2 body2)-                then                    -- No floating, revert to body1-                     return (emptyFloats env, wrapFloats body_floats2 body1)--                else if null tvs then   -- Simple floating-                     {-#SCC "simplLazyBind-simple-floating" #-}-                     do { tick LetFloatFromLet-                        ; return (body_floats2, body2) }--                else                    -- Do type-abstraction first-                     {-#SCC "simplLazyBind-type-abstraction-first" #-}-                     do { tick LetFloatFromLet-                        ; (poly_binds, body3) <- abstractFloats (seUnfoldingOpts env) top_lvl-                                                                tvs' body_floats2 body2-                        ; let floats = foldl' extendFloats (emptyFloats env) poly_binds-                        ; return (floats, body3) }--        ; let env' = env `setInScopeFromF` rhs_floats-        ; rhs' <- mkLam env' tvs' body3 rhs_cont-        ; (bind_float, env2) <- completeBind env' top_lvl Nothing bndr bndr2 rhs'-        ; return (rhs_floats `addFloats` bind_float, env2) }-----------------------------simplJoinBind :: SimplEnv-              -> SimplCont-              -> InId -> OutId          -- Binder, both pre-and post simpl-                                        -- The OutId has IdInfo, except arity,-                                        --   unfolding-              -> InExpr -> SimplEnv     -- The right hand side and its env-              -> SimplM (SimplFloats, SimplEnv)-simplJoinBind env cont old_bndr new_bndr rhs rhs_se-  = do  { let rhs_env = rhs_se `setInScopeFromE` env-        ; rhs' <- simplJoinRhs rhs_env old_bndr rhs cont-        ; completeBind env NotTopLevel (Just cont) old_bndr new_bndr rhs' }-----------------------------simplNonRecX :: SimplEnv-             -> InId            -- Old binder; not a JoinId-             -> OutExpr         -- Simplified RHS-             -> SimplM (SimplFloats, SimplEnv)--- A specialised variant of simplNonRec used when the RHS is already--- simplified, notably in knownCon.  It uses case-binding where necessary.------ Precondition: rhs satisfies the let/app invariant--simplNonRecX env bndr new_rhs-  | ASSERT2( not (isJoinId bndr), ppr bndr )-    isDeadBinder bndr   -- Not uncommon; e.g. case (a,b) of c { (p,q) -> p }-  = return (emptyFloats env, env)    --  Here c is dead, and we avoid-                                         --  creating the binding c = (a,b)--  | Coercion co <- new_rhs-  = return (emptyFloats env, extendCvSubst env bndr co)--  | otherwise-  = do  { (env', bndr') <- simplBinder env bndr-        ; completeNonRecX NotTopLevel env' (isStrictId bndr') bndr bndr' new_rhs }-          -- NotTopLevel: simplNonRecX is only used for NotTopLevel things-          ---          -- isStrictId: use bndr' because in a levity-polymorphic setting-          -- the InId bndr might have a levity-polymorphic type, which-          -- which isStrictId doesn't expect-          -- c.f. Note [Dark corner with levity polymorphism]-----------------------------completeNonRecX :: TopLevelFlag -> SimplEnv-                -> Bool-                -> InId                 -- Old binder; not a JoinId-                -> OutId                -- New binder-                -> OutExpr              -- Simplified RHS-                -> SimplM (SimplFloats, SimplEnv)    -- The new binding is in the floats--- Precondition: rhs satisfies the let/app invariant---               See Note [Core let/app invariant] in GHC.Core--completeNonRecX top_lvl env is_strict old_bndr new_bndr new_rhs-  = ASSERT2( not (isJoinId new_bndr), ppr new_bndr )-    do  { (prepd_floats, new_bndr, new_rhs)-              <- prepareBinding env top_lvl old_bndr new_bndr new_rhs-        ; let floats = emptyFloats env `addLetFloats` prepd_floats-        ; (rhs_floats, rhs2) <--                if doFloatFromRhs NotTopLevel NonRecursive is_strict floats new_rhs-                then    -- Add the floats to the main env-                     do { tick LetFloatFromLet-                        ; return (floats, new_rhs) }-                else    -- Do not float; wrap the floats around the RHS-                     return (emptyFloats env, wrapFloats floats new_rhs)--        ; (bind_float, env2) <- completeBind (env `setInScopeFromF` rhs_floats)-                                             NotTopLevel Nothing-                                             old_bndr new_bndr rhs2-        ; return (rhs_floats `addFloats` bind_float, env2) }---{- *********************************************************************-*                                                                      *-           prepareBinding, prepareRhs, makeTrivial-*                                                                      *-************************************************************************--Note [Cast worker/wrappers]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-When we have a binding-   x = e |> co-we want to do something very similar to worker/wrapper:-   $wx = e-   x = $wx |> co--So now 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--We call this making a cast worker/wrapper, and it's done by prepareBinding.--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... }-It's 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 NOINLINE functions] in-GHC.Core.Opt.WorkWrap.--See #17673, #18093, #18078.--Note [Preserve strictness in cast w/w]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In the Note [Cast worker/wrappers] 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 [Cast w/w: unlifted]-~~~~~~~~~~~~~~~~~~~~~~~~~-BUT don't do cast worker/wrapper if 'e' has an unlifted type.-This *can* happen:--     foo :: Int = (error (# Int,Int #) "urk")-                  `cast` CoUnsafe (# Int,Int #) Int--If do the makeTrivial thing to the error call, we'll get-    foo = case error (# Int,Int #) "urk" of v -> v `cast` ...-But 'v' isn't in scope!--These strange casts can happen as a result of case-of-case-        bar = case (case x of { T -> (# 2,3 #); F -> error "urk" }) of-                (# p,q #) -> p+q--NOTE: Nowadays we don't use casts for these error functions;-instead, we use (case erorr ... of {}). So I'm not sure-this Note makes much sense any more.--}--prepareBinding :: SimplEnv -> TopLevelFlag-               -> InId -> OutId -> OutExpr-               -> SimplM (LetFloats, OutId, OutExpr)--prepareBinding env top_lvl old_bndr bndr rhs-  | Cast rhs1 co <- rhs-    -- Try for cast worker/wrapper-    -- See Note [Cast worker/wrappers]-  , not (isStableUnfolding (realIdUnfolding old_bndr))-        -- Don't make a cast w/w if the thing is going to be inlined anyway-  , not (exprIsTrivial rhs1)-        -- Nor if the RHS is trivial; then again it'll be inlined-  , let ty1 = coercionLKind co-  , not (isUnliftedType ty1)-        -- Not if rhs has an unlifted type; see Note [Cast w/w: unlifted]-  = do { (floats, new_id) <- makeTrivialBinding (getMode env) top_lvl-                                   (getOccFS bndr) worker_info rhs1 ty1-       ; let bndr' = bndr `setInlinePragma` mkCastWrapperInlinePrag (idInlinePragma bndr)-       ; return (floats, bndr', Cast (Var new_id) co) }--  | otherwise-  = do { (floats, rhs') <- prepareRhs (getMode env) top_lvl (getOccFS bndr) rhs-       ; return (floats, bndr, rhs') }- where-   info = idInfo bndr-   worker_info = vanillaIdInfo `setStrictnessInfo` strictnessInfo info-                               `setCprInfo`        cprInfo info-                               `setDemandInfo`     demandInfo info-                               `setInlinePragInfo` inlinePragInfo info-                               `setArityInfo`      arityInfo info-          -- We do /not/ want to transfer OccInfo, Rules, Unfolding-          -- Note [Preserve strictness in cast w/w]--mkCastWrapperInlinePrag :: InlinePragma -> InlinePragma--- See Note [Cast wrappers]-mkCastWrapperInlinePrag (InlinePragma { inl_act = act, inl_rule = rule_info })-  = InlinePragma { inl_src    = SourceText "{-# INLINE"-                 , inl_inline = NoUserInlinePrag -- See Note [Wrapper NoUserInline]-                 , 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 act = activateDuringFinal-             | otherwise         = act--{- Note [prepareRhs]-~~~~~~~~~~~~~~~~~~~~-prepareRhs takes a putative RHS, checks whether it's a PAP or-constructor application and, if so, converts it to ANF, so that the-resulting thing can be inlined more easily.  Thus-        x = (f a, g b)-becomes-        t1 = f a-        t2 = g b-        x = (t1,t2)--We also want to deal well cases like this-        v = (f e1 `cast` co) e2-Here we want to make e1,e2 trivial and get-        x1 = e1; x2 = e2; v = (f x1 `cast` co) v2-That's what the 'go' loop in prepareRhs does--}--prepareRhs :: SimplMode -> TopLevelFlag-           -> FastString    -- Base for any new variables-           -> 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 mode top_lvl occ rhs0-  = do  { (_is_exp, floats, rhs1) <- go 0 rhs0-        ; return (floats, rhs1) }-  where-    go :: Int -> OutExpr -> SimplM (Bool, LetFloats, OutExpr)-    go n_val_args (Cast rhs co)-        = do { (is_exp, floats, rhs') <- go n_val_args rhs-             ; return (is_exp, floats, Cast rhs' co) }-    go n_val_args (App fun (Type ty))-        = do { (is_exp, floats, rhs') <- go n_val_args fun-             ; return (is_exp, floats, App rhs' (Type ty)) }-    go n_val_args (App fun arg)-        = do { (is_exp, floats1, fun') <- go (n_val_args+1) fun-             ; case is_exp of-                False -> return (False, emptyLetFloats, App fun arg)-                True  -> do { (floats2, arg') <- makeTrivial mode top_lvl topDmd occ arg-                            ; return (True, floats1 `addLetFlts` floats2, App fun' arg') } }-    go n_val_args (Var fun)-        = return (is_exp, emptyLetFloats, Var fun)-        where-          is_exp = isExpandableApp fun n_val_args   -- The fun a constructor or PAP-                        -- See Note [CONLIKE pragma] in GHC.Types.Basic-                        -- The definition of is_exp should match that in-                        -- 'GHC.Core.Opt.OccurAnal.occAnalApp'--    go n_val_args (Tick t rhs)-        -- We want to be able to float bindings past this-        -- tick. Non-scoping ticks don't care.-        | tickishScoped t == NoScope-        = do { (is_exp, floats, rhs') <- go n_val_args rhs-             ; return (is_exp, floats, Tick t rhs') }--        -- On the other hand, for scoping ticks we need to be able to-        -- copy them on the floats, which in turn is only allowed if-        -- we can obtain non-counting ticks.-        | (not (tickishCounts t) || tickishCanSplit t)-        = do { (is_exp, floats, rhs') <- go n_val_args rhs-             ; let tickIt (id, expr) = (id, mkTick (mkNoCount t) expr)-                   floats' = mapLetFloats floats tickIt-             ; return (is_exp, floats', Tick t rhs') }--    go _ other-        = return (False, emptyLetFloats, other)--makeTrivialArg :: SimplMode -> ArgSpec -> SimplM (LetFloats, ArgSpec)-makeTrivialArg mode arg@(ValArg { as_arg = e, as_dmd = dmd })-  = do { (floats, e') <- makeTrivial mode NotTopLevel dmd (fsLit "arg") e-       ; return (floats, arg { as_arg = e' }) }-makeTrivialArg _ arg-  = return (emptyLetFloats, arg)  -- CastBy, TyArg--makeTrivial :: SimplMode -> TopLevelFlag -> Demand-            -> FastString  -- ^ A "friendly name" to build the new binder from-            -> OutExpr     -- ^ This expression satisfies the let/app invariant-            -> SimplM (LetFloats, OutExpr)--- Binds the expression to a variable, if it's not trivial, returning the variable--- For the Demand argument, see Note [Keeping demand info in StrictArg Plan A]-makeTrivial mode 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 mode top_lvl dmd occ_fs expr'-       ; return (floats, Cast triv_expr co) }--  | otherwise-  = do { (floats, new_id) <- makeTrivialBinding mode top_lvl occ_fs-                                                id_info expr expr_ty-       ; return (floats, Var new_id) }-  where-    id_info = vanillaIdInfo `setDemandInfo` dmd-    expr_ty = exprType expr--makeTrivialBinding :: SimplMode -> TopLevelFlag-                   -> FastString  -- ^ a "friendly name" to build the new binder from-                   -> IdInfo-                   -> OutExpr     -- ^ This expression satisfies the let/app invariant-                   -> OutType     -- Type of the expression-                   -> SimplM (LetFloats, OutId)-makeTrivialBinding mode top_lvl occ_fs info expr expr_ty-  = do  { (floats, expr1) <- prepareRhs mode top_lvl occ_fs expr-        ; uniq <- getUniqueM-        ; let name = mkSystemVarName uniq occ_fs-              var  = mkLocalIdWithInfo name Many expr_ty info--        -- Now something very like completeBind,-        -- but without the postInlineUnconditionally part-        ; (arity_type, expr2) <- tryEtaExpandRhs mode 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 shadowig in eta expansion--        ; unf <- mkLetUnfolding (sm_uf_opts mode) top_lvl InlineRhs var expr2--        ; let final_id = addLetBndrInfo var arity_type unf-              bind     = NonRec final_id expr2--        ; return ( floats `addLetFlts` unitLetFloat bind, final_id ) }--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--It does *not* attempt to do let-to-case.  Why?  Because it is used for-  - top-level bindings (when let-to-case is impossible)-  - many situations where the "rhs" is known to be a WHNF-                (so let-to-case is inappropriate).--Nor does it do the atomic-argument thing--}--completeBind :: SimplEnv-             -> TopLevelFlag            -- Flag stuck into unfolding-             -> MaybeJoinCont           -- Required only for join point-             -> InId                    -- Old binder-             -> OutId -> OutExpr        -- New binder and RHS-             -> SimplM (SimplFloats, SimplEnv)--- completeBind may choose to do its work---      * by extending the substitution (e.g. let x = y in ...)---      * or by adding to the floats in the envt------ Binder /can/ be a JoinId--- Precondition: rhs obeys the let/app invariant-completeBind env top_lvl mb_cont old_bndr new_bndr new_rhs- | isCoVar old_bndr- = case new_rhs of-     Coercion co -> return (emptyFloats env, extendCvSubst env old_bndr co)-     _           -> return (mkFloatBind env (NonRec new_bndr new_rhs))-- | otherwise- = ASSERT( isId new_bndr )-   do { let old_info = idInfo old_bndr-            old_unf  = unfoldingInfo old_info-            occ_info = occInfo old_info--         -- Do eta-expansion on the RHS of the binding-         -- See Note [Eta-expanding at let bindings] in GHC.Core.Opt.Simplify.Utils-      ; (new_arity, final_rhs) <- tryEtaExpandRhs (getMode env) new_bndr new_rhs--        -- Simplify the unfolding-      ; new_unfolding <- simplLetUnfolding env top_lvl mb_cont old_bndr-                          final_rhs (idType new_bndr) new_arity old_unf--      ; let final_bndr = addLetBndrInfo new_bndr new_arity new_unfolding-        -- See Note [In-scope set as a substitution]--      ; if postInlineUnconditionally env top_lvl final_bndr occ_info final_rhs--        then -- Inline and discard the binding-             do  { tick (PostInlineUnconditionally old_bndr)-                 ; return ( emptyFloats env-                          , extendIdSubst env old_bndr $-                            DoneEx final_rhs (isJoinId_maybe new_bndr)) }-                -- Use the substitution to make quite, quite sure that the-                -- substitution will happen, since we are going to discard the binding--        else -- Keep the binding-             -- pprTrace "Binding" (ppr final_bndr <+> ppr new_unfolding) $-             return (mkFloatBind env (NonRec final_bndr final_rhs)) }--addLetBndrInfo :: OutId -> ArityType -> Unfolding -> OutId-addLetBndrInfo new_bndr new_arity_type new_unf-  = new_bndr `setIdInfo` info5-  where-    AT oss div = new_arity_type-    new_arity  = length oss--    info1 = idInfo new_bndr `setArityInfo` new_arity--    -- Unfolding info: Note [Setting the new unfolding]-    info2 = info1 `setUnfoldingInfo` new_unf--    -- Demand info: Note [Setting the demand info]-    -- We also have to nuke demand info if for some reason-    -- eta-expansion *reduces* the arity of the binding to less-    -- than that of the strictness sig. This can happen: see Note [Arity decrease].-    info3 | isEvaldUnfolding new_unf-            || (case strictnessInfo info2 of-                  StrictSig dmd_ty -> new_arity < dmdTypeDepth dmd_ty)-          = zapDemandInfo info2 `orElse` info2-          | otherwise-          = info2--    -- Bottoming bindings: see Note [Bottoming bindings]-    info4 | isDeadEndDiv div = info3 `setStrictnessInfo` bot_sig-                                     `setCprInfo`        bot_cpr-          | otherwise        = info3--    bot_sig = mkClosedStrictSig (replicate new_arity topDmd) div-    bot_cpr = mkCprSig new_arity botCpr--     -- Zap call arity info. We have used it by now (via-     -- `tryEtaExpandRhs`), and the simplifier can invalidate this-     -- information, leading to broken code later (e.g. #13479)-    info5 = zapCallArityInfo info4---{- Note [Arity decrease]-~~~~~~~~~~~~~~~~~~~~~~~~-Generally speaking the arity of a binding should not decrease.  But it *can*-legitimately happen because of RULES.  Eg-        f = g @Int-where g has arity 2, will have arity 2.  But if there's a rewrite rule-        g @Int --> h-where h has arity 1, then f's arity will decrease.  Here's a real-life example,-which is in the output of Specialise:--     Rec {-        $dm {Arity 2} = \d.\x. op d-        {-# RULES forall d. $dm Int d = $s$dm #-}--        dInt = MkD .... opInt ...-        opInt {Arity 1} = $dm dInt--        $s$dm {Arity 0} = \x. op dInt }--Here opInt has arity 1; but when we apply the rule its arity drops to 0.-That's why Specialise goes to a little trouble to pin the right arity-on specialised functions too.--Note [Bottoming bindings]-~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we have-   let x = error "urk"-   in ...(case x of <alts>)...-or-   let f = \x. error (x ++ "urk")-   in ...(case f "foo" of <alts>)...--Then we'd like to drop the dead <alts> immediately.  So it's good to-propagate the info that x's RHS is bottom to x's IdInfo as rapidly as-possible.--We use tryEtaExpandRhs on every binding, and it turns 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.--Note [Setting the demand info]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If the unfolding is a value, the demand info may-go pear-shaped, so we nuke it.  Example:-     let x = (a,b) in-     case x of (p,q) -> h p q x-Here x is certainly demanded. But after we've nuked-the case, we'll get just-     let x = (a,b) in h a b x-and now x is not demanded (I'm assuming h is lazy)-This really happens.  Similarly-     let f = \x -> e in ...f..f...-After inlining f at some of its call sites the original binding may-(for example) be no longer strictly demanded.-The solution here is a bit ad hoc...---************************************************************************-*                                                                      *-\subsection[Simplify-simplExpr]{The main function: simplExpr}-*                                                                      *-************************************************************************--The reason for this OutExprStuff stuff is that we want to float *after*-simplifying a RHS, not before.  If we do so naively we get quadratic-behaviour as things float out.--To see why it's important to do it after, consider this (real) example:--        let t = f x-        in fst t-==>-        let t = let a = e1-                    b = e2-                in (a,b)-        in fst t-==>-        let a = e1-            b = e2-            t = (a,b)-        in-        a       -- Can't inline a this round, cos it appears twice-==>-        e1--Each of the ==> steps is a round of simplification.  We'd save a-whole round if we float first.  This can cascade.  Consider--        let f = g d-        in \x -> ...f...-==>-        let f = let d1 = ..d.. in \y -> e-        in \x -> ...f...-==>-        let d1 = ..d..-        in \x -> ...(\y ->e)...--Only in this second round can the \y be applied, and it-might do the same again.--}--simplExpr :: SimplEnv -> CoreExpr -> SimplM CoreExpr-simplExpr !env (Type ty) -- 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 {- $$ ppr (seIdSubst env) -} $$ ppr (seLetFloats env) ) $-    do  { (floats, expr') <- simplExprF env expr cont-        ; -- pprTrace "simplExprC ret" (ppr expr $$ ppr expr') $-          -- pprTrace "simplExprC ret3" (ppr (seInScope env')) $-          -- pprTrace "simplExprC ret4" (ppr (seLetFloats env')) $-          return $! wrapFloats floats expr' }-----------------------------------------------------simplExprF :: SimplEnv-           -> InExpr     -- A term-valued expression, never (Type ty)-           -> SimplCont-           -> SimplM (SimplFloats, OutExpr)--simplExprF !env e !cont -- 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 :: 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 "simplIdF" #-} simplIdF env v cont-simplExprF1 env (Lit lit)      cont = {-#SCC "rebuild" #-} rebuild env (Lit lit) cont-simplExprF1 env (Tick t expr)  cont = {-#SCC "simplTick" #-} simplTick env t expr cont-simplExprF1 env (Cast body co) cont = {-#SCC "simplCast" #-} simplCast env body co cont-simplExprF1 env (Coercion co)  cont = {-#SCC "simplCoercionF" #-} simplCoercionF env co cont--simplExprF1 env (App fun arg) cont-  = {-#SCC "simplExprF1-App" #-} case arg of-      Type ty -> do { -- The argument type will (almost) certainly be used-                      -- in the output program, so just force it now.-                      -- See Note [Avoiding space leaks in OutType]-                      arg' <- simplType env ty--                      -- But use substTy, not simplType, to avoid forcing-                      -- the hole type; it will likely not be needed.-                      -- See Note [The hole type in ApplyToTy]-                    ; let hole' = substTy env (exprType fun)--                    ; simplExprF env fun $-                      ApplyToTy { sc_arg_ty  = arg'-                                , sc_hole_ty = hole'-                                , sc_cont    = cont } }-      _       ->-          -- 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 zapped_bndrs body cont-        -- The main issue here is under-saturated lambdas-        --   (\x1. \x2. e) arg1-        -- Here x1 might have "occurs-once" occ-info, because occ-info-        -- is computed assuming that a group of lambdas is applied-        -- all at once.  If there are too few args, we must zap the-        -- occ-info, UNLESS the remaining binders are one-shot-  where-    (bndrs, body) = collectBinders expr-    zapped_bndrs = zapLamBndrs n_args bndrs-    n_args = countArgs cont-        -- NB: countArgs counts all the args (incl type args)-        -- and likewise drop counts all binders (incl type lambdas)--simplExprF1 env (Case scrut bndr _ alts) cont-  = {-#SCC "simplExprF1-Case" #-}-    simplExprF env scrut (Select { sc_dup = NoDup, sc_bndr = bndr-                                 , sc_alts = alts-                                 , sc_env = env, sc_cont = cont })--simplExprF1 env (Let (Rec pairs) body) cont-  | Just pairs' <- joinPointBindings_maybe pairs-  = {-#SCC "simplRecJoinPoin" #-} simplRecJoinPoint env pairs' body cont--  | otherwise-  = {-#SCC "simplRecE" #-} simplRecE env pairs body cont--simplExprF1 env (Let (NonRec bndr rhs) body) cont-  | Type ty <- rhs    -- First deal with type lets (let a = Type ty in e)-  = {-#SCC "simplExprF1-NonRecLet-Type" #-}-    ASSERT( isTyVar bndr )-    do { ty' <- simplType env ty-       ; simplExprF (extendTvSubst env bndr ty') body cont }--  | Just (bndr', rhs') <- joinPointBinding_maybe bndr rhs-  = {-#SCC "simplNonRecJoinPoint" #-} simplNonRecJoinPoint env bndr' rhs' body cont--  | otherwise-  = {-#SCC "simplNonRecE" #-} simplNonRecE env bndr (rhs, env) ([], body) cont--{- Note [Avoiding space leaks in OutType]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Since the simplifier is run for multiple iterations, we need to ensure-that any thunks in the output of one simplifier iteration are forced-by the evaluation of the next simplifier iteration. Otherwise we may-retain multiple copies of the Core program and leak a terrible amount-of memory (as in #13426).--The simplifier is naturally strict in the entire "Expr part" of the-input Core program, because any expression may contain binders, which-we must find in order to extend the SimplEnv accordingly. But types-do not contain binders and so it is tempting to write things like--    simplExpr env (Type ty) = return (Type (substTy env ty))   -- Bad!--This is Bad because the result includes a thunk (substTy env ty) which-retains a reference to the whole simplifier environment; and the next-simplifier iteration will not force this thunk either, because the-line above is not strict in ty.--So instead our strategy is for the simplifier to fully evaluate-OutTypes when it emits them into the output Core program, for example--    simplExpr env (Type ty) = do { ty' <- simplType env ty     -- Good-                                 ; return (Type ty') }--where the only difference from above is that simplType calls seqType-on the result of substTy.--However, SimplCont can also contain OutTypes and it's not necessarily-a good idea to force types on the way in to SimplCont, because they-may end up not being used and forcing them could be a lot of wasted-work. T5631 is a good example of this.--- For ApplyToTy's sc_arg_ty, we force the type on the way in because-  the type will almost certainly appear as a type argument in the-  output program.--- For the hole types in Stop and ApplyToTy, we force the type when we-  emit it into the output program, after obtaining it from-  contResultType. (The hole type in ApplyToTy is only directly used-  to form the result type in a new Stop continuation.)--}-------------------------------------- Simplify a join point, adding the context.--- Context goes *inside* the lambdas. IOW, if the join point has arity n, we do:---   \x1 .. xn -> e => \x1 .. xn -> E[e]--- Note that we need the arity of the join point, since e may be a lambda--- (though this is unlikely). See Note [Join points and case-of-case].-simplJoinRhs :: SimplEnv -> InId -> InExpr -> SimplCont-             -> SimplM OutExpr-simplJoinRhs env bndr expr cont-  | Just arity <- isJoinId_maybe bndr-  =  do { let (join_bndrs, join_body) = collectNBinders arity expr-              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 { opts <- getOptCoercionOpts-       ; let opt_co = optCoercion opts (getTCvSubst env) co-       ; seqCo opt_co `seq` return opt_co }---------------------------------------- | Push a TickIt context outwards past applications and cases, as--- long as this is a non-scoping tick, to let case and application--- optimisations apply.--simplTick :: SimplEnv -> 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.---- XXX: we cannot do this, because the simplifier assumes that--- the context can be pushed into a case with a single branch. e.g.---    scc<f>  case expensive of p -> e--- becomes---    case expensive of p -> scc<f> e------ So I'm disabling this for now.  It just means we will do more--- simplifier iterations that necessary in some cases.----  | tickishScoped tickish && not (tickishCounts tickish)---  = simplExprF env expr (TickIt tickish cont)--  -- For unscoped or soft-scoped ticks, we are allowed to float in new-  -- cost, so we simply push the continuation inside the tick.  This-  -- has the effect of moving the tick to the outside of a case or-  -- application context, allowing the normal case and application-  -- optimisations to fire.-  | tickish `tickishScopesLike` SoftScope-  = do { (floats, expr') <- simplExprF env expr cont-       ; return (floats, mkTick tickish expr')-       }--  -- Push tick inside if the context looks like this will allow us to-  -- do a case-of-case - see Note [case-of-scc-of-case]-  | Select {} <- cont, Just expr' <- push_tick_inside-  = simplExprF env expr' cont--  -- We don't want to move the tick, but we might still want to allow-  -- floats to pass through with appropriate wrapping (or not, see-  -- wrap_floats below)-  --- | not (tickishCounts tickish) || tickishCanSplit tickish-  -- = wrap_floats--  | otherwise-  = no_floating_past_tick-- where--  -- Try to push tick inside a case, see Note [case-of-scc-of-case].-  push_tick_inside =-    case expr0 of-      Case scrut bndr ty alts-             -> Just $ Case (tickScrut scrut) bndr ty (map tickAlt alts)-      _other -> Nothing-   where (ticks, expr0) = stripTicksTop movable (Tick tickish expr)-         movable t      = not (tickishCounts t) ||-                          t `tickishScopesLike` NoScope ||-                          tickishCanSplit t-         tickScrut e    = foldr mkTick e ticks-         -- Alternatives get annotated with all ticks that scope in some way,-         -- but we don't want to count entries.-         tickAlt (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) = (zapIdStrictness (setIdArity b 0),---                                   mkTick (mkNoCount tickish') rhs)---              -- when wrapping a float with mkTick, we better zap the Id's---              -- strictness info and arity, because it might be wrong now.---       ; let env'' = addFloats env (mapFloats env' wrap_float)---       ; rebuild env'' expr' (TickIt tickish' outc)---       }---  simplTickish env tickish-    | Breakpoint ext n ids <- tickish-          = Breakpoint ext n (map (getDoneId . substId env) ids)-    | otherwise = tickish--  -- Push type application and coercion inside a tick-  splitCont :: SimplCont -> (SimplCont, SimplCont)-  splitCont cont@(ApplyToTy { sc_cont = tail }) = (cont { sc_cont = inc }, outc)-    where (inc,outc) = splitCont tail-  splitCont (CastIt co c) = (CastIt co inc, outc)-    where (inc,outc) = splitCont c-  splitCont other = (mkBoringStop (contHoleType other), other)--  getDoneId (DoneId id)  = id-  getDoneId (DoneEx e _) = getIdFromTrivialExpr e -- Note [substTickish] in 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)--- At this point the substitution in the SimplEnv should be irrelevant;--- only the in-scope set matters-rebuild env expr cont-  = case cont of-      Stop {}          -> return (emptyFloats env, expr)-      TickIt t cont    -> rebuild env (mkTick t expr) cont-      CastIt co cont   -> rebuild env (mkCast expr co) cont-                       -- NB: mkCast implements the (Coercion co |> g) optimisation--      Select { sc_bndr = bndr, sc_alts = alts, sc_env = se, sc_cont = cont }-        -> rebuildCase (se `setInScopeFromE` env) expr bndr alts cont--      StrictArg { sc_fun = fun, sc_cont = cont, sc_fun_ty = fun_ty }-        -> rebuildCall env (addValArgTo fun expr fun_ty ) cont-      StrictBind { sc_bndr = b, sc_bndrs = bs, sc_body = body-                 , sc_env = se, sc_cont = cont }-        -> do { (floats1, env') <- simplNonRecX (se `setInScopeFromE` env) b expr-                                  -- expr satisfies let/app since it started life-                                  -- in a call to simplNonRecE-              ; (floats2, expr') <- simplLam env' bs body cont-              ; return (floats1 `addFloats` floats2, expr') }--      ApplyToTy  { sc_arg_ty = ty, sc_cont = cont}-        -> rebuild env (App expr (Type ty)) cont--      ApplyToVal { sc_arg = arg, sc_env = se, sc_dup = dup_flag, sc_cont = cont}-        -- See Note [Avoid redundant simplification]-        -> do { (_, _, arg') <- simplArg env dup_flag se arg-              ; rebuild env (App expr arg') cont }--{--************************************************************************-*                                                                      *-\subsection{Lambdas}-*                                                                      *-************************************************************************--}--{- Note [Optimising reflexivity]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-It's important (for compiler performance) to get rid of reflexivity as soon-as it appears.  See #11735, #14737, and #15019.--In particular, we want to behave well on-- *  e |> co1 |> co2-    where the two happen to cancel out entirely. That is quite common;-    e.g. a newtype wrapping and unwrapping cancel.--- * (f |> co) @t1 @t2 ... @tn x1 .. xm-   Here we will use pushCoTyArg and pushCoValArg successively, which-   build up NthCo stacks.  Silly to do that if co is reflexive.--However, we don't want to call isReflexiveCo too much, because it uses-type equality which is expensive on big types (#14737 comment:7).--A good compromise (determined experimentally) seems to be to call-isReflexiveCo- * when composing casts, and- * at the end--In investigating this I saw missed opportunities for on-the-fly-coercion shrinkage. See #15090.--}---simplCast :: SimplEnv -> InExpr -> Coercion -> SimplCont-          -> SimplM (SimplFloats, OutExpr)-simplCast env body co0 cont0-  = do  { co1   <- {-#SCC "simplCast-simplCoercion" #-} simplCoercion env co0-        ; cont1 <- {-#SCC "simplCast-addCoerce" #-}-                   if isReflCo co1-                   then return cont0  -- See Note [Optimising reflexivity]-                   else addCoerce co1 cont0-        ; {-#SCC "simplCast-simplExprF" #-} simplExprF env body cont1 }-  where-        -- If the first parameter is MRefl, then simplifying revealed a-        -- reflexive coercion. Omit.-        addCoerceM :: MOutCoercion -> SimplCont -> SimplM SimplCont-        addCoerceM MRefl   cont = return cont-        addCoerceM (MCo co) cont = addCoerce co cont--        addCoerce :: OutCoercion -> SimplCont -> SimplM SimplCont-        addCoerce co1 (CastIt co2 cont)  -- See Note [Optimising reflexivity]-          | isReflexiveCo co' = return cont-          | otherwise         = addCoerce co' cont-          where-            co' = mkTransCo co1 co2--        addCoerce co (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = tail })-          | Just (arg_ty', m_co') <- pushCoTyArg co arg_ty-          = {-#SCC "addCoerce-pushCoTyArg" #-}-            do { tail' <- addCoerceM m_co' tail-               ; return (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 cont@(ApplyToVal { sc_arg = arg, sc_env = arg_se-                                      , sc_dup = dup, sc_cont = tail })-          | Just (m_co1, m_co2) <- pushCoValArg co-          , levity_ok m_co1-          = {-#SCC "addCoerce-pushCoValArg" #-}-            do { tail' <- addCoerceM m_co2 tail-               ; case m_co1 of {-                   MRefl -> return (cont { sc_cont = tail'-                                         , sc_hole_ty = coercionLKind co }) ;-                      -- Avoid simplifying if possible;-                      -- See Note [Avoiding exponential behaviour]--                   MCo co1 ->-            do { (dup', arg_se', arg') <- simplArg env dup arg_se arg-                    -- When we build the ApplyTo we can't mix the OutCoercion-                    -- 'co' with the InExpr 'arg', so we simplify-                    -- to make it all consistent.  It's a bit messy.-                    -- But it isn't a common case.-                    -- Example of use: #995-               ; return (ApplyToVal { sc_arg  = mkCast arg' co1-                                    , sc_env  = arg_se'-                                    , sc_dup  = dup'-                                    , sc_cont = tail'-                                    , sc_hole_ty = coercionLKind co }) } } }--        addCoerce co cont-          | isReflexiveCo co = return cont  -- Having this at the end makes a huge-                                            -- difference in T12227, for some reason-                                            -- See Note [Optimising reflexivity]-          | otherwise        = return (CastIt co cont)--        levity_ok :: MCoercionR -> Bool-        levity_ok MRefl = True-        levity_ok (MCo co) = not $ isTypeLevPoly $ coercionRKind co-          -- Without this check, we get a lev-poly arg-          -- See Note [Levity polymorphism invariants] in GHC.Core-          -- test: typecheck/should_run/EtaExpandLevPoly--simplArg :: SimplEnv -> DupFlag -> StaticEnv -> CoreExpr-         -> SimplM (DupFlag, StaticEnv, OutExpr)-simplArg env dup_flag arg_env arg-  | isSimplified dup_flag-  = return (dup_flag, arg_env, arg)-  | otherwise-  = do { let arg_env' = arg_env `setInScopeFromE` env-       ; arg' <- simplExpr arg_env'  arg-       ; 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}-*                                                                      *-************************************************************************--}--simplLam :: SimplEnv -> [InId] -> InExpr -> SimplCont-         -> SimplM (SimplFloats, OutExpr)--simplLam env [] body cont-  = simplExprF env body cont--simplLam env (bndr:bndrs) body (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = cont })-  = do { tick (BetaReduction bndr)-       ; simplLam (extendTvSubst env bndr arg_ty) bndrs body cont }--simplLam env (bndr:bndrs) body (ApplyToVal { sc_arg = arg, sc_env = arg_se-                                           , sc_cont = cont, sc_dup = dup })-  | isSimplified dup  -- Don't re-simplify if we've simplified it once-                      -- See Note [Avoiding exponential behaviour]-  = do  { tick (BetaReduction bndr)-        ; (floats1, env') <- simplNonRecX env zapped_bndr arg-        ; (floats2, expr') <- simplLam env' bndrs body cont-        ; return (floats1 `addFloats` floats2, expr') }--  | otherwise-  = do  { tick (BetaReduction bndr)-        ; simplNonRecE env zapped_bndr (arg, arg_se) (bndrs, body) cont }-  where-    zapped_bndr  -- See Note [Zap unfolding when beta-reducing]-      | isId bndr = zapStableUnfolding bndr-      | otherwise = bndr--      -- Discard a non-counting tick on a lambda.  This may change the-      -- cost attribution slightly (moving the allocation of the-      -- lambda elsewhere), but we don't care: optimisation changes-      -- cost attribution all the time.-simplLam env bndrs body (TickIt tickish cont)-  | not (tickishCounts tickish)-  = simplLam env bndrs body cont--        -- Not enough args, so there are real lambdas left to put in the result-simplLam env bndrs body cont-  = do  { (env', bndrs') <- simplLamBndrs env bndrs-        ; body' <- simplExpr env' body-        ; new_lam <- mkLam env bndrs' body' cont-        ; rebuild env' new_lam cont }----------------simplLamBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)--- Used for lambda binders.  These sometimes have unfoldings added by--- the worker/wrapper pass that must be preserved, because they can't--- be reconstructed from context.  For example:---      f x = case x of (a,b) -> fw a b x---      fw a b x{=(a,b)} = ...--- The "{=(a,b)}" is an unfolding we can't reconstruct otherwise.-simplLamBndr env bndr-  | isId bndr && hasCoreUnfolding old_unf   -- Special case-  = do { (env1, bndr1) <- simplBinder env bndr-       ; unf'          <- simplStableUnfolding env1 NotTopLevel Nothing bndr-                                      (idType bndr1) (idArityType bndr1) old_unf-       ; let bndr2 = bndr1 `setIdUnfolding` unf'-       ; return (modifyInScope env1 bndr2, bndr2) }--  | otherwise-  = simplBinder env bndr                -- Normal case-  where-    old_unf = idUnfolding bndr--simplLamBndrs :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr])-simplLamBndrs env bndrs = mapAccumLM simplLamBndr env bndrs---------------------simplNonRecE :: SimplEnv-             -> InId                    -- The binder, always an Id-                                        -- Never a join point-             -> (InExpr, SimplEnv)      -- Rhs of binding (or arg of lambda)-             -> ([InBndr], InExpr)      -- Body of the let/lambda-                                        --      \xs.e-             -> SimplCont-             -> SimplM (SimplFloats, OutExpr)---- simplNonRecE is used for---  * non-top-level non-recursive non-join-point lets in expressions---  * beta reduction------ simplNonRec env b (rhs, rhs_se) (bs, body) k---   = let env in---     cont< let b = rhs_se(rhs) in \bs.body >------ It deals with strict bindings, via the StrictBind continuation,--- which may abort the whole process------ Precondition: rhs satisfies the let/app invariant---               Note [Core let/app invariant] in GHC.Core------ The "body" of the binding comes as a pair of ([InId],InExpr)--- representing a lambda; so we recurse back to simplLam--- Why?  Because of the binder-occ-info-zapping done before---       the call to simplLam in simplExprF (Lam ...)--simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont-  | ASSERT( isId bndr && not (isJoinId bndr) ) True-  , Just env' <- preInlineUnconditionally env NotTopLevel bndr rhs rhs_se-  = do { tick (PreInlineUnconditionally bndr)-       ; -- pprTrace "preInlineUncond" (ppr bndr <+> ppr rhs) $-         simplLam env' bndrs body cont }--  | otherwise-  = do { (env1, bndr1) <- simplNonRecBndr env bndr--       -- Deal with strict bindings-       -- See Note [Dark corner with levity polymorphism]-       ; if isStrictId bndr1 && sm_case_case (getMode env)-         then simplExprF (rhs_se `setInScopeFromE` env) rhs-                   (StrictBind { sc_bndr = bndr, sc_bndrs = bndrs, sc_body = body-                               , sc_env = env, sc_cont = cont, sc_dup = NoDup })--       -- Deal with lazy bindings-         else do-       { (env2, bndr2) <- addBndrRules env1 bndr bndr1 Nothing-       ; (floats1, env3) <- simplLazyBind env2 NotTopLevel NonRecursive bndr bndr2 rhs rhs_se-       ; (floats2, expr') <- simplLam env3 bndrs body cont-       ; return (floats1 `addFloats` floats2, expr') } }---------------------simplRecE :: SimplEnv-          -> [(InId, InExpr)]-          -> InExpr-          -> SimplCont-          -> SimplM (SimplFloats, OutExpr)---- simplRecE is used for---  * non-top-level recursive lets in expressions-simplRecE env pairs body cont-  = do  { let bndrs = map fst pairs-        ; MASSERT(all (not . isJoinId) bndrs)-        ; env1 <- simplRecBndrs env bndrs-                -- NB: bndrs' don't have unfoldings or rules-                -- We add them as we go down-        ; (floats1, env2) <- simplRecBind env1 NotTopLevel Nothing pairs-        ; (floats2, expr') <- simplExprF env2 body cont-        ; return (floats1 `addFloats` floats2, expr') }--{- Note [Dark corner with levity polymorphism]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In `simplNonRecE`, the call to `isStrictId` will fail if the binder-has a levity-polymorphic type, 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,-levity-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 exponential behaviour]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-One way in which we can get exponential behaviour is if we simplify a-big expression, and the re-simplify it -- and then this happens in a-deeply-nested way.  So we must be jolly careful about re-simplifying-an expression.  That is why completeNonRecX does not try-preInlineUnconditionally.--Example:-  f BIG, where f has a RULE-Then- * We simplify BIG before trying the rule; but the rule does not fire- * We inline f = \x. x True- * So if we did preInlineUnconditionally we'd re-simplify (BIG True)--However, if BIG has /not/ already been simplified, we'd /like/ to-simplify BIG True; maybe good things happen.  That is why--* simplLam has-    - a case for (isSimplified dup), which goes via simplNonRecX, and-    - a case for the un-simplified case, which goes via simplNonRecE--* We go to some efforts to avoid unnecessarily simplifying ApplyToVal,-  in at least two places-    - In simplCast/addCoerce, where we check for isReflCo-    - In rebuildCall we avoid simplifying arguments before we have to-      (see Note [Trying rewrite rules])---Note [Zap unfolding when beta-reducing]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Lambda-bound variables can have stable unfoldings, such as-   $j = \x. \b{Unf=Just x}. e-See Note [Case binders and join points] below; the unfolding for lets-us optimise e better.  However when we beta-reduce it we want to-revert to using the actual value, otherwise we can end up in the-stupid situation of-          let x = blah in-          let b{Unf=Just x} = y-          in ...b...-Here it'd be far better to drop the unfolding and use the actual RHS.--************************************************************************-*                                                                      *-                     Join points-*                                                                      *-********************************************************************* -}--{- Note [Rules and unfolding for join points]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we have--   simplExpr (join j x = rhs                         ) cont-             (      {- RULE j (p:ps) = blah -}       )-             (      {- StableUnfolding j = blah -}   )-             (in blah                                )--Then we will push 'cont' into the rhs of 'j'.  But we should *also* push-'cont' into the RHS of-  * Any RULEs for j, e.g. generated by SpecConstr-  * Any stable unfolding for j, e.g. the result of an INLINE pragma--Simplifying rules and stable-unfoldings happens a bit after-simplifying the right-hand side, so we remember whether or not it-is a join point, and what 'cont' is, in a value of type MaybeJoinCont--#13900 was caused by forgetting to push 'cont' into the RHS-of a SpecConstr-generated RULE for a join point.--}--type MaybeJoinCont = Maybe SimplCont-  -- Nothing => Not a join point-  -- Just k  => This is a join binding with continuation k-  -- See Note [Rules and unfolding for join points]--simplNonRecJoinPoint :: SimplEnv -> InId -> InExpr-                     -> InExpr -> SimplCont-                     -> SimplM (SimplFloats, OutExpr)-simplNonRecJoinPoint env bndr rhs body cont-  | ASSERT( isJoinId bndr ) True-  , Just env' <- preInlineUnconditionally env NotTopLevel bndr rhs env-  = do { tick (PreInlineUnconditionally bndr)-       ; simplExprF env' body cont }--   | otherwise-   = wrapJoinCont env cont $ \ env cont ->-     do { -- We push join_cont into the join RHS and the body;-          -- and wrap wrap_cont around the whole thing-        ; let mult   = contHoleScaling cont-              res_ty = contResultType cont-        ; (env1, bndr1)    <- simplNonRecJoinBndr env bndr mult res_ty-        ; (env2, bndr2)    <- addBndrRules env1 bndr bndr1 (Just cont)-        ; (floats1, env3)  <- simplJoinBind env2 cont bndr bndr2 rhs env-        ; (floats2, body') <- simplExprF env3 body cont-        ; return (floats1 `addFloats` floats2, body') }----------------------simplRecJoinPoint :: SimplEnv -> [(InId, InExpr)]-                  -> InExpr -> SimplCont-                  -> SimplM (SimplFloats, OutExpr)-simplRecJoinPoint env pairs body cont-  = wrapJoinCont env cont $ \ env cont ->-    do { let bndrs  = map fst pairs-             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 NotTopLevel (Just cont) pairs-       ; (floats2, body') <- simplExprF env2 body cont-       ; return (floats1 `addFloats` floats2, body') }-----------------------wrapJoinCont :: SimplEnv -> SimplCont-             -> (SimplEnv -> SimplCont -> SimplM (SimplFloats, OutExpr))-             -> SimplM (SimplFloats, OutExpr)--- Deal with making the continuation duplicable if necessary,--- and with the no-case-of-case situation.-wrapJoinCont env cont thing_inside-  | contIsStop cont        -- Common case; no need for fancy footwork-  = thing_inside env cont--  | not (sm_case_case (getMode env))-    -- See Note [Join points 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 -> Maybe JoinArity -> SimplCont -> SimplCont--- Drop outer context from join point invocation (jump)--- See Note [Join points and case-of-case]--trimJoinCont _ Nothing cont-  = cont -- Not a jump-trimJoinCont var (Just arity) cont-  = trim arity cont-  where-    trim 0 cont@(Stop {})-      = cont-    trim 0 cont-      = mkBoringStop (contResultType cont)-    trim n cont@(ApplyToVal { sc_cont = k })-      = cont { sc_cont = trim (n-1) k }-    trim n cont@(ApplyToTy { sc_cont = k })-      = cont { sc_cont = trim (n-1) k } -- join arity counts types!-    trim _ cont-      = pprPanic "completeCall" $ ppr var $$ ppr cont---{- Note [Join points and case-of-case]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When we perform the case-of-case transform (or otherwise push continuations-inward), we want to treat join points specially. Since they're always-tail-called and we want to maintain this invariant, we can do this (for any-evaluation context E):--  E[join j = e-    in case ... of-         A -> jump j 1-         B -> jump j 2-         C -> f 3]--    -->--  join j = E[e]-  in case ... of-       A -> jump j 1-       B -> jump j 2-       C -> E[f 3]--As is evident from the example, there are two components to this behavior:--  1. When entering the RHS of a join point, copy the context inside.-  2. When a join point is invoked, discard the outer context.--We need to be very careful here to remain consistent---neither part is-optional!--We need do make the continuation E duplicable (since we are duplicating it)-with 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-*                                                                      *-************************************************************************--}--simplVar :: SimplEnv -> InVar -> SimplM OutExpr--- Look up an InVar in the environment-simplVar 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--simplIdF :: SimplEnv -> InId -> SimplCont -> SimplM (SimplFloats, OutExpr)-simplIdF env var cont-  = case substId env var of-      ContEx tvs cvs ids e ->-          let env' = setSubstEnv env tvs cvs ids-          in simplExprF env' e cont-          -- Don't trim; haven't already simplified e,-          -- so the cont is not embodied in e--      DoneId var1 ->-          let cont' = trimJoinCont var (isJoinId_maybe var1) cont-          in completeCall env var1 cont'--      DoneEx e mb_join ->-          let env' = zapSubstEnv env-              cont' = trimJoinCont var mb_join cont-          in simplExprF env' e cont'-              -- Note [zapSubstEnv]-              -- The template is already simplified, so don't re-substitute.-              -- This is VITAL.  Consider-              --      let x = e in-              --      let y = \z -> ...x... in-              --      \ x -> ...y...-              -- We'll clone the inner \x, adding x->x' in the id_subst-              -- Then when we inline y, we must *not* replace x by x' in-              -- the inlined copy!!--------------------------------------------------------------      Dealing with a call site--completeCall :: SimplEnv -> OutId -> SimplCont -> SimplM (SimplFloats, OutExpr)-completeCall env var cont-  | Just expr <- callSiteInline logger dflags case_depth var active_unf-                                lone_variable arg_infos interesting_cont-  -- Inline the variable's RHS-  = do { checkedTick (UnfoldingDone var)-       ; dump_inline expr cont-       ; let env1 = zapSubstEnv env-       ; simplExprF env1 expr cont }--  | otherwise-  -- Don't inline; instead rebuild the call-  = do { rule_base <- getSimplRules-       ; let rules = getRules rule_base var-             info = mkArgInfo env var rules-                              n_val_args call_cont-       ; rebuildCall env info cont }--  where-    dflags     = seDynFlags env-    case_depth = seCaseDepth env-    logger     = seLogger env-    (lone_variable, arg_infos, call_cont) = contArgs cont-    n_val_args       = length arg_infos-    interesting_cont = interestingCallContext env call_cont-    active_unf       = activeUnfolding (getMode env) var--    log_inlining doc-      = liftIO $ putDumpMsg logger dflags-           (mkDumpStyle alwaysQualify)-           Opt_D_dump_inlinings-           "" FormatText doc--    dump_inline unfolding cont-      | not (dopt Opt_D_dump_inlinings dflags) = return ()-      | not (dopt Opt_D_verbose_core2core dflags)-      = 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])]--rebuildCall :: SimplEnv-            -> ArgInfo-            -> SimplCont-            -> SimplM (SimplFloats, OutExpr)--- We decided not to inline, so---    - simplify the arguments---    - try rewrite rules---    - and rebuild------------ Bottoming applications ---------------rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_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------------ Try rewrite RULES ----------------- See Note [Trying rewrite rules]-rebuildCall env info@(ArgInfo { ai_fun = fun, ai_args = rev_args-                              , ai_rules = Just (nr_wanted, rules) }) cont-  | nr_wanted == 0 || no_more_args-  , let info' = info { ai_rules = Nothing }-  = -- We've accumulated a simplified call in <fun,rev_args>-    -- so try rewrite rules; see Note [RULEs apply to simplified arguments]-    -- See also Note [Rules for recursive functions]-    do { mb_match <- tryRules env rules fun (reverse rev_args) cont-       ; case mb_match of-             Just (env', rhs, cont') -> simplExprF env' rhs cont'-             Nothing                 -> rebuildCall env info' cont }-  where-    no_more_args = case cont of-                      ApplyToTy  {} -> False-                      ApplyToVal {} -> False-                      _             -> True------------- Simplify applications and casts ---------------rebuildCall env info (CastIt co cont)-  = rebuildCall env (addCastTo info co) cont--rebuildCall env info (ApplyToTy { sc_arg_ty = arg_ty, sc_hole_ty = hole_ty, sc_cont = cont })-  = rebuildCall env (addTyArgTo info arg_ty hole_ty) cont------------ The runRW# rule. Do this after absorbing all arguments --------- See Note [Simplification of runRW#] in GHC.CoreToSTG.Prep.------ runRW# :: forall (r :: RuntimeRep) (o :: TYPE r). (State# RealWorld -> o) -> o--- K[ runRW# rr ty body ]   -->   runRW rr' ty' (\s. K[ body s ])-rebuildCall env (ArgInfo { ai_fun = fun_id, ai_args = rev_args })-            (ApplyToVal { sc_arg = arg, sc_env = arg_se-                        , sc_cont = cont, sc_hole_ty = fun_ty })-  | fun_id `hasKey` runRWKey-  , [ TyArg {}, TyArg {} ] <- rev_args-  -- Do this even if (contIsStop cont)-  -- See Note [No eta-expansion in runRW#]-  = do { let arg_env = arg_se `setInScopeFromE` env-             ty'   = contResultType cont--       -- 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.-       ; arg' <- case arg of-           Lam s body -> do { (env', s') <- simplBinder arg_env s-                            ; body' <- simplExprC env' body 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") Many 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 = cont-                                            , sc_hole_ty = mkVisFunTy m realWorldStatePrimTy ty' }-                                -- cont' applies to s', then K-                   ; body' <- simplExprC env' arg cont'-                   ; return (Lam s' body') }--       ; let rr'   = getRuntimeRep ty'-             call' = mkApps (Var fun_id) [mkTyArg rr', mkTyArg ty', arg']-       ; return (emptyFloats env, call') }--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-  , sm_case_case (getMode env)-  = -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $-    simplExprF (arg_se `setInScopeFromE` env) arg-               (StrictArg { sc_fun = fun_info, sc_fun_ty = fun_ty-                          , sc_dup = Simplified-                          , sc_cont = cont })-                -- Note [Shadowing]--  -- 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' <- simplExprC (arg_se `setInScopeFromE` env) arg-                             (mkLazyArgStop arg_ty (lazyArgContext fun_info))-        ; rebuildCall env (addValArgTo fun_info  arg' fun_ty) cont }-  where-    arg_ty = funArgTy fun_ty------------- No further useful info, revert to generic rebuild -------------rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args }) cont-  = rebuild env (argInfoExpr fun rev_args) cont--{- Note [Trying rewrite rules]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider an application (f e1 e2 e3) where the e1,e2,e3 are not yet-simplified.  We want to simplify enough arguments to allow the rules-to apply, but it's more efficient to avoid simplifying e2,e3 if e1 alone-is sufficient.  Example: class ops-   (+) dNumInt e2 e3-If we rewrite ((+) dNumInt) to plusInt, we can take advantage of the-latter's strictness when simplifying e2, e3.  Moreover, suppose we have-  RULE  f Int = \x. x True--Then given (f Int e1) we rewrite to-   (\x. x True) e1-without simplifying e1.  Now we can inline x into its unique call site,-and absorb the True into it all in the same pass.  If we simplified-e1 first, we couldn't do that; see Note [Avoiding exponential behaviour].--So we try to apply rules if either-  (a) no_more_args: we've run out of argument that the rules can "see"-  (b) nr_wanted: none of the rules wants any more arguments---Note [RULES apply to simplified arguments]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-It's very desirable to try RULES once the arguments have been simplified, because-doing so ensures that rule cascades work in one pass.  Consider-   {-# RULES g (h x) = k x-             f (k x) = x #-}-   ...f (g (h x))...-Then we want to rewrite (g (h x)) to (k x) and only then try f's rules. If-we match f's rules against the un-simplified RHS, it won't match.  This-makes a particularly big difference when superclass selectors are involved:-        op ($p1 ($p2 (df d)))-We want all this to unravel in one sweep.--Note [Avoid redundant simplification]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Because RULES apply to simplified arguments, there's a danger of repeatedly-simplifying already-simplified arguments.  An important example is that of-        (>>=) d e1 e2-Here e1, e2 are simplified before the rule is applied, but don't really-participate in the rule firing. So we mark them as Simplified to avoid-re-simplifying them.--Note [Shadowing]-~~~~~~~~~~~~~~~~-This part of the simplifier may break the no-shadowing invariant-Consider-        f (...(\a -> e)...) (case y of (a,b) -> e')-where f is strict in its second arg-If we simplify the innermost one first we get (...(\a -> e)...)-Simplifying the second arg makes us float the case out, so we end up with-        case y of (a,b) -> f (...(\a -> e)...) e'-So the output does not have the no-shadowing invariant.  However, there is-no danger of getting name-capture, because when the first arg was simplified-we used an in-scope set that at least mentioned all the variables free in its-static environment, and that is enough.--We can't just do innermost first, or we'd end up with a dual problem:-        case x of (a,b) -> f e (...(\a -> e')...)--I spent hours trying to recover the no-shadowing invariant, but I just could-not think of an elegant way to do it.  The simplifier is already knee-deep in-continuations.  We have to keep the right in-scope set around; AND we have-to get the effect that finding (error "foo") in a strict arg position will-discard the entire application and replace it with (error "foo").  Getting-all this at once is TOO HARD!--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]-         -> Id -> [ArgSpec]-         -> SimplCont-         -> SimplM (Maybe (SimplEnv, CoreExpr, SimplCont))--tryRules env rules fn args call_cont-  | null rules-  = return Nothing--{- Disabled until we fix #8326-  | fn `hasKey` tagToEnumKey   -- See Note [Optimising tagToEnum#]-  , [_type_arg, val_arg] <- args-  , Select dup bndr ((_,[],rhs1) : rest_alts) se cont <- call_cont-  , isDeadBinder bndr-  = do { let enum_to_tag :: CoreAlt -> CoreAlt-                -- Takes   K -> e  into   tagK# -> e-                -- where tagK# is the tag of constructor K-             enum_to_tag (DataAlt con, [], rhs)-               = ASSERT( isEnumerationTyCon (dataConTyCon con) )-                (LitAlt tag, [], rhs)-              where-                tag = mkLitInt dflags (toInteger (dataConTag con - fIRST_TAG))-             enum_to_tag alt = pprPanic "tryRules: tagToEnum" (ppr alt)--             new_alts = (DEFAULT, [], rhs1) : map enum_to_tag rest_alts-             new_bndr = setIdType bndr intPrimTy-                 -- The binder is dead, but should have the right type-      ; return (Just (val_arg, Select dup new_bndr new_alts se cont)) }--}--  | Just (rule, rule_rhs) <- lookupRule ropts (getUnfoldingInRuleMatch env)-                                        (activeRule (getMode env)) fn-                                        (argInfoAppArgs args) rules-  -- Fire a rule for the function-  = do { checkedTick (RuleFired (ruleName rule))-       ; let cont' = pushSimplifiedArgs zapped_env-                                        (drop (ruleArity rule) args)-                                        call_cont-                     -- (ruleArity rule) says how-                     -- many args the rule consumed--             occ_anald_rhs = occurAnalyseExpr rule_rhs-                 -- See Note [Occurrence-analyse after rule firing]-       ; dump rule rule_rhs-       ; return (Just (zapped_env, occ_anald_rhs, cont')) }-            -- The occ_anald_rhs and cont' are all Out things-            -- hence zapping the environment--  | otherwise  -- No rule fires-  = do { nodump  -- This ensures that an empty file is written-       ; return Nothing }--  where-    -- Force this to avoid retaining DynFlags and hence SimplEnv-    !ropts     = initRuleOpts dflags-    dflags     = seDynFlags env-    logger     = seLogger env-    zapped_env = zapSubstEnv env  -- See Note [zapSubstEnv]--    printRuleModule rule-      = parens (maybe (text "BUILTIN")-                      (pprModuleName . moduleName)-                      (ruleModule rule))--    dump rule rule_rhs-      | dopt Opt_D_dump_rule_rewrites dflags-      = log_rule dflags Opt_D_dump_rule_rewrites "Rule fired" $ vcat-          [ text "Rule:" <+> ftext (ruleName rule)-          , text "Module:" <+>  printRuleModule rule-          , text "Before:" <+> hang (ppr fn) 2 (sep (map ppr args))-          , text "After: " <+> hang (pprCoreExpr rule_rhs) 2-                               (sep $ map ppr $ drop (ruleArity rule) args)-          , text "Cont:  " <+> ppr call_cont ]--      | dopt Opt_D_dump_rule_firings dflags-      = log_rule dflags Opt_D_dump_rule_firings "Rule fired:" $-          ftext (ruleName rule)-            <+> printRuleModule rule--      | otherwise-      = return ()--    nodump-      | dopt Opt_D_dump_rule_rewrites dflags-      = liftIO $-          touchDumpFile logger dflags Opt_D_dump_rule_rewrites--      | dopt Opt_D_dump_rule_firings dflags-      = liftIO $-          touchDumpFile logger dflags Opt_D_dump_rule_firings--      | otherwise-      = return ()--    log_rule dflags flag hdr details-      = liftIO $ do-          let sty = mkDumpStyle alwaysQualify-          putDumpMsg logger dflags sty flag "" FormatText $-              sep [text hdr, nest 4 details]--trySeqRules :: SimplEnv-            -> OutExpr -> InExpr   -- Scrutinee and RHS-            -> SimplCont-            -> SimplM (Maybe (SimplEnv, CoreExpr, SimplCont))--- See Note [User-defined RULES for seq]-trySeqRules in_env scrut rhs cont-  = do { rule_base <- getSimplRules-       ; tryRules in_env (getRules rule_base seqId) seqId out_args rule_cont }-  where-    no_cast_scrut = drop_casts scrut-    scrut_ty  = exprType no_cast_scrut-    seq_id_ty = idType seqId                    -- 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  = [ 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.--Possible improvement: occ-anal the rules when putting them in the-database; and in the simplifier just occ-anal the OutExpr arguments.-But that's more complicated and the rule RHS is usually tiny; so I'm-just doing the simple thing.--Historical note: previously we did occ-anal the rules in Rule.hs,-but failed to occ-anal the OutExpr arguments, which led to the-nasty performance problem described above.---Note [Optimising tagToEnum#]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If we have an enumeration data type:--  data Foo = A | B | C--Then we want to transform--   case tagToEnum# x of   ==>    case x of-     A -> e1                       DEFAULT -> e1-     B -> e2                       1#      -> e2-     C -> e3                       2#      -> e3--thereby getting rid of the tagToEnum# altogether.  If there was a DEFAULT-alternative we retain it (remember it comes first).  If not the case must-be exhaustive, and we reflect that in the transformed version by adding-a DEFAULT.  Otherwise Lint complains that the new case is not exhaustive.-See #8317.--Note [Rules for recursive functions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-You might think that we shouldn't apply rules for a loop breaker:-doing so might give rise to an infinite loop, because a RULE is-rather like an extra equation for the function:-     RULE:           f (g x) y = x+y-     Eqn:            f a     y = a-y--But it's too drastic to disable rules for loop breakers.-Even the foldr/build rule would be disabled, because foldr-is recursive, and hence a loop breaker:-     foldr k z (build g) = g k z-So it's up to the programmer: rules can cause divergence---************************************************************************-*                                                                      *-                Rebuilding a case expression-*                                                                      *-************************************************************************--Note [Case elimination]-~~~~~~~~~~~~~~~~~~~~~~~-The case-elimination transformation discards redundant case expressions.-Start with a simple situation:--        case x# of      ===>   let y# = x# in e-          y# -> e--(when x#, y# are of primitive type, of course).  We can't (in general)-do this for algebraic cases, because we might turn bottom into-non-bottom!--The code in 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/app invariant).-  This turns     case a +# b of r -> ...r...-  into           let r = a +# b in ...r...-  and thence     .....(a +# b)....--  However, if we have-      case indexArray# a i of r -> ...r...-  we might like to do the same, and inline the (indexArray# a i).-  But indexArray# is not okForSpeculation, so we don't build a let-  in rebuildCase (lest it get floated *out*), so the inlining doesn't-  happen either.  Annoying.--* Lifted case: we need to be sure that the expression is already-  evaluated (exprIsHNF).  If it's not already evaluated-      - we risk losing exceptions, divergence or-        user-specified thunk-forcing-      - even if 'e' is guaranteed to converge, we don't want to-        create a thunk (call by need) instead of evaluating it-        right away (call by value)--  However, we can turn the case into a /strict/ let if the 'r' is-  used strictly in the body.  Then we won't lose divergence; and-  we won't build a thunk because the let is strict.-  See also Note [Case-to-let for strictly-used binders]--  NB: absentError satisfies exprIsHNF: see Note [aBSENT_ERROR_ID] in GHC.Core.Make.-  We want to turn-     case (absentError "foo") of r -> ...MkT r...-  into-     let r = absentError "foo" in ...MkT r...---Note [Case-to-let for strictly-used binders]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If we have this:-   case <scrut> of r { _ -> ..r.. }--where 'r' is used strictly in (..r..), we can safely transform to-   let r = <scrut> in ...r...--This is a Good Thing, because 'r' might be dead (if the body just-calls error), or might be used just once (in which case it can be-inlined); or we might be able to float the let-binding up or down.-E.g. #15631 has an example.--Note that this can change the error behaviour.  For example, we might-transform-    case x of { _ -> error "bad" }-    --> error "bad"-which is might be puzzling if 'x' currently lambda-bound, but later gets-let-bound to (error "good").--Nevertheless, the paper "A semantics for imprecise exceptions" allows-this transformation. If you want to fix the evaluation order, use-'pseq'.  See #8900 for an example where the loss of this-transformation bit us in practice.--See also Note [Empty case alternatives] in 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 of an eval'd function] 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.--}--------------------------------------------------------------      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 findAlt (DataAlt con) alts of-            Nothing  -> missingAlt env0 case_bndr alts cont-            Just (Alt DEFAULT bs rhs) -> let con_app = Var (dataConWorkId con)-                                                 `mkTyApps` ty_args-                                                 `mkApps`   other_args-                                         in simple_rhs env0 scaled_wfloats con_app 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 scrut' bs rhs =-      ASSERT( null bs )-      do { (floats1, env') <- simplNonRecX env case_bndr scrut'-             -- scrut is a constructor application,-             -- hence satisfies let/app invariant-         ; (floats2, expr') <- simplExprF env' rhs cont-         ; case wfloats of-             [] -> return (floats1 `addFloats` floats2, expr')-             _ -> return-               -- See Note [FloatBinds from constructor wrappers]-                   ( emptyFloats env,-                     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-  , exprOkForSideEffects scrut-          -- The entire case is dead, so we can drop it-          -- if the scrutinee converges without having imperative-          -- side effects or raising a Haskell exception-          -- See Note [PrimOp can_fail and has_side_effects] in GHC.Builtin.PrimOps-   = simplExprF env rhs cont--  -- 2b.  Turn the case into a let, if-  --      a) it binds only the case-binder-  --      b) unlifted case: the scrutinee is ok-for-speculation-  --           lifted case: the scrutinee is in HNF (or will later be demanded)-  -- See Note [Case to let transformation]-  | all_dead_bndrs-  , doCaseToLet scrut case_bndr-  = do { tick (CaseElim case_bndr)-       ; (floats1, env') <- simplNonRecX env case_bndr scrut-       ; (floats2, expr') <- simplExprF env' rhs cont-       ; return (floats1 `addFloats` floats2, expr') }--  -- 2c. Try the seq rules if-  --     a) it binds only the case binder-  --     b) a rule for seq applies-  -- See Note [User-defined RULES for seq] in GHC.Types.Id.Make-  | is_plain_seq-  = do { mb_rule <- trySeqRules env scrut rhs cont-       ; case mb_rule of-           Just (env', rule_rhs, cont') -> simplExprF env' rule_rhs cont'-           Nothing                      -> reallyRebuildCase env scrut case_bndr alts cont }-  where-    all_dead_bndrs = all isDeadBinder bndrs       -- bndrs are [InId]-    is_plain_seq   = all_dead_bndrs && isDeadBinder case_bndr -- Evaluation *only* for effect--rebuildCase env scrut case_bndr alts cont-  = reallyRebuildCase env scrut case_bndr alts cont---doCaseToLet :: OutExpr          -- Scrutinee-            -> InId             -- Case binder-            -> Bool--- The situation is         case scrut of b { DEFAULT -> body }--- Can we transform thus?   let { b = scrut } in body-doCaseToLet scrut case_bndr-  | isTyCoVar case_bndr    -- Respect GHC.Core-  = isTyCoArg scrut        -- Note [Core type and coercion invariant]--  | isUnliftedType (idType case_bndr)-  = exprOkForSpeculation scrut--  | otherwise  -- Scrut has a lifted type-  = exprIsHNF scrut-    || isStrUsedDmd (idDemandInfo case_bndr)-    -- See Note [Case-to-let for strictly-used binders]-------------------------------------------------------      3. Catch-all case-----------------------------------------------------reallyRebuildCase env scrut case_bndr alts cont-  | not (sm_case_case (getMode env))-  = do { case_expr <- simplAlts env scrut case_bndr alts-                                (mkBoringStop (contHoleType cont))-       ; rebuild env case_expr cont }--  | otherwise-  = do { (floats, 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 [Case alternative occ info]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When we are simply reconstructing a case (the common case), we always-zap the occurrence info on the binders in the alternatives.  Even-if the case binder is dead, the scrutinee is usually a variable, and *that*-can bring the case-alternative binders back to life.-See Note [Add unfolding for scrutinee]--Note [Improving seq]-~~~~~~~~~~~~~~~~~~~-Consider-        type family F :: * -> *-        type instance F Int = Int--We'd like to transform-        case e of (x :: F Int) { DEFAULT -> rhs }-===>-        case e `cast` co of (x'::Int)-           I# x# -> let x = x' `cast` sym co-                    in rhs--so that 'rhs' can take advantage of the form of x'.  Notice that Note-[Case of cast] (in OccurAnal) may then apply to the result.--We'd also like to eliminate empty types (#13468). So if--    data Void-    type instance F Bool = Void--then we'd like to transform-        case (x :: F Bool) of { _ -> error "urk" }-===>-        case (x |> co) of (x' :: Void) of {}--Nota Bene: we used to have a built-in rule for 'seq' that dropped-casts, so that-    case (x |> co) of { _ -> blah }-dropped the cast; in order to improve the chances of trySeqRules-firing.  But that works in the /opposite/ direction to Note [Improving-seq] so there's a danger of flip/flopping.  Better to make trySeqRules-insensitive to the cast, which is now is.--The need for [Improving seq] showed up in Roman's experiments.  Example:-  foo :: F Int -> Int -> Int-  foo t n = t `seq` bar n-     where-       bar 0 = 0-       bar n = bar (n - case t of TI i -> i)-Here we'd like to avoid repeated evaluating t inside the loop, by-taking advantage of the `seq`.--At one point I did transformation in LiberateCase, but it's more-robust here.  (Otherwise, there's a danger that we'll simply drop the-'seq' altogether, before LiberateCase gets to see it.)--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 <- getFamEnvs-        ; (alt_env', scrut', case_bndr') <- improveSeq fam_envs env2 scrut-                                                       case_bndr case_bndr2 alts--        ; (imposs_deflt_cons, in_alts) <- prepareAlts scrut' case_bndr' alts-          -- NB: it's possible that the returned in_alts is empty: this is handled-          -- by the caller (rebuildCase) in the missingAlt function--        ; alts' <- mapM (simplAlt alt_env' (Just scrut') imposs_deflt_cons case_bndr' cont') in_alts-        ; -- pprTrace "simplAlts" (ppr case_bndr $$ ppr alts_ty $$ ppr alts_ty' $$ ppr alts $$ ppr cont') $--        ; let alts_ty' = contResultType cont'-        -- See Note [Avoiding space leaks in OutType]-        ; seqType alts_ty' `seq`-          mkCase (seDynFlags env0) scrut' case_bndr' alts_ty' alts' }----------------------------------------improveSeq :: (FamInstEnv, FamInstEnv) -> SimplEnv-           -> OutExpr -> InId -> OutId -> [InAlt]-           -> SimplM (SimplEnv, OutExpr, OutId)--- Note [Improving seq]-improveSeq fam_envs env scrut case_bndr case_bndr1 [Alt DEFAULT _ _]-  | Just (co, ty2) <- topNormaliseType_maybe fam_envs (idType case_bndr1)-  = do { case_bndr2 <- newId (fsLit "nt") Many ty2-        ; let rhs  = DoneEx (Var case_bndr2 `Cast` mkSymCo co) Nothing-              env2 = extendIdSubst env case_bndr rhs-        ; return (env2, scrut `Cast` co, case_bndr2) }--improveSeq _ env scrut _ case_bndr1 _-  = return (env, scrut, case_bndr1)----------------------------------------simplAlt :: SimplEnv-         -> Maybe OutExpr  -- The scrutinee-         -> [AltCon]       -- These constructors can't be present when-                           -- matching the DEFAULT alternative-         -> OutId          -- The case binder-         -> SimplCont-         -> InAlt-         -> SimplM OutAlt--simplAlt env _ !imposs_deflt_cons case_bndr' cont' (Alt DEFAULT bndrs rhs)-  = ASSERT( null bndrs )-    do  { let env' = addBinderUnfolding env case_bndr'-                                        (mkOtherCon imposs_deflt_cons)-                -- Record the constructors that the case-binder *can't* be.-        ; rhs' <- simplExprC env' rhs cont'-        ; return (Alt DEFAULT [] rhs') }--simplAlt env scrut' _ case_bndr' cont' (Alt (LitAlt lit) bndrs rhs)-  = ASSERT( null bndrs )-    do  { env' <- addAltUnfoldings env scrut' case_bndr' (Lit lit)-        ; rhs' <- simplExprC env' rhs cont'-        ; return (Alt (LitAlt lit) [] rhs') }--simplAlt env scrut' _ case_bndr' cont' (Alt (DataAlt con) vs rhs)-  = do  { -- See Note [Adding evaluatedness info to pattern-bound variables]-          let vs_with_evals = addEvals scrut' con vs-        ; (env', vs') <- simplLamBndrs env vs_with_evals--                -- Bind the case-binder to (con args)-        ; let inst_tys' = tyConAppArgs (idType case_bndr')-              con_app :: OutExpr-              con_app   = mkConApp2 con inst_tys' vs'--        ; env'' <- addAltUnfoldings env' scrut' case_bndr' con_app-        -- Forced so that simplExprC forces wrapFloats which means we don't-        -- retain the InScopeSet in SimplFloats-        ; !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 [Data-con worker strictness] in GHC.Core.DataCon--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.Core.Opt.ConstantFold.  Example (#15226):--  case seq# v s of-    (# s', v' #) -> E--we want the compiler to be aware that v' is in WHNF in E.--Open problem: we don't record that v itself is in WHNF (and we can't-do it here).  The right thing is to do some kind of binder-swap;-see #15226 for discussion.--}--addEvals :: Maybe OutExpr -> DataCon -> [Id] -> [Id]--- See Note [Adding evaluatedness info to pattern-bound variables]-addEvals scrut con vs-  -- Deal with seq# applications-  | Just scr <- scrut-  , 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-  , Just SeqOp <- isPrimOpId_maybe f-  , let x' = zapIdOccInfoAndSetEvald MarkedStrict x-  = [s, x']--  -- Deal with banged datacon fields-addEvals _scrut con vs = go vs the_strs-    where-      the_strs = dataConRepStrictness con--      go [] [] = []-      go (v:vs') strs | isTyVar v = v : go vs' strs-      go (v:vs') (str:strs) = zapIdOccInfoAndSetEvald str v : go vs' strs-      go _ _ = pprPanic "Simplify.addEvals"-                (ppr con $$-                 ppr vs  $$-                 ppr_with_length (map strdisp the_strs) $$-                 ppr_with_length (dataConRepArgTys con) $$-                 ppr_with_length (dataConRepStrictness con))-        where-          ppr_with_length list-            = ppr list <+> parens (text "length =" <+> ppr (length list))-          strdisp MarkedStrict = text "MarkedStrict"-          strdisp NotMarkedStrict = text "NotMarkedStrict"--zapIdOccInfoAndSetEvald :: StrictnessMark -> Id -> Id-zapIdOccInfoAndSetEvald str v =-  setCaseBndrEvald str $ -- Add eval'dness info-  zapIdOccInfo v         -- And kill occ info;-                         -- see Note [Case alternative occ info]--addAltUnfoldings :: SimplEnv -> Maybe OutExpr -> OutId -> OutExpr -> SimplM SimplEnv-addAltUnfoldings env scrut case_bndr con_app-  = do { let con_app_unf = mk_simple_unf con_app-             env1 = addBinderUnfolding env case_bndr con_app_unf--             -- See Note [Add unfolding for scrutinee]-             env2 | Many <- idMult case_bndr = case scrut of-                      Just (Var v)           -> addBinderUnfolding env1 v con_app_unf-                      Just (Cast (Var v) co) -> addBinderUnfolding env1 v $-                                                mk_simple_unf (Cast con_app (mkSymCo co))-                      _                      -> env1-                  | otherwise = env1--       ; traceSmpl "addAltUnf" (vcat [ppr case_bndr <+> ppr scrut, ppr con_app])-       ; return env2 }-  where-    -- 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-  = WARN( not (eqType (idType bndr) (exprType tmpl)),-          ppr bndr $$ ppr (idType bndr) $$ ppr tmpl $$ ppr (exprType tmpl) )-    modifyInScope env (bndr `setIdUnfolding` unf)--  | otherwise-  = modifyInScope env (bndr `setIdUnfolding` unf)--zapBndrOccInfo :: Bool -> Id -> Id--- Consider  case e of b { (a,b) -> ... }--- Then if we bind b to (a,b) in "...", and b is not dead,--- then we must zap the deadness info on a,b-zapBndrOccInfo keep_occ_info pat_id-  | keep_occ_info = pat_id-  | otherwise     = zapIdOccInfo pat_id--{- Note [Case binder evaluated-ness]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We pin on a (OtherCon []) unfolding to the case-binder of a Case,-even though it'll be over-ridden in every case alternative with a more-informative unfolding.  Why?  Because suppose a later, less clever, pass-simply replaces all occurrences of the case binder with the binder itself;-then Lint may complain about the let/app invariant.  Example-    case e of b { DEFAULT -> let v = reallyUnsafePtrEq# b y in ....-                ; K       -> blah }--The let/app invariant requires that y is evaluated in the call to-reallyUnsafePtrEq#, which it is.  But we still want that to be true if we-propagate binders to occurrences.--This showed up in #13027.--Note [Add unfolding for scrutinee]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In general it's unlikely that a variable scrutinee will appear-in the case alternatives   case x of { ...x unlikely to appear... }-because the binder-swap in 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.--Exactly the same issue arises in GHC.Core.Opt.SpecConstr;-see Note [Add scrutinee to ValueEnv too] in GHC.Core.Opt.SpecConstr--HOWEVER, given-  case x of y { Just a -> r1; Nothing -> r2 }-we do not want to add the unfolding x -> y to 'x', which might seem cool,-since 'y' itself has different unfoldings in r1 and r2.  Reason: if we-did that, we'd have to zap y's deadness info and that is a very useful-piece of information.--So instead we add the unfolding x -> Just a, and x -> Nothing in the-respective RHSs.--Since this transformation is tantamount to a binder swap, the same caveat as in-Note [Suppressing binder-swaps on linear case] in OccurAnal apply.---************************************************************************-*                                                                      *-\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-             -- Note that the binder might be "dead", because it doesn't-             -- occur in the RHS; and simplNonRecX may therefore discard-             -- it via postInlineUnconditionally.-             -- Nevertheless we must keep it if the case-binder is alive,-             -- because it may be used in the con_app.  See Note [knownCon occ info]-           ; (floats1, env2) <- simplNonRecX env' b' arg  -- arg satisfies let/app invariant-           ; (floats2, env3)  <- bind_args env2 bs' args-           ; return (floats1 `addFloats` floats2, env3) }--    bind_args _ _ _ =-      pprPanic "bind_args" $ ppr dc $$ ppr bs $$ ppr dc_args $$-                             text "scrut:" <+> ppr scrut--       -- It's useful to bind bndr to scrut, rather than to a fresh-       -- binding      x = Con arg1 .. argn-       -- because very often the scrut is a variable, so we avoid-       -- creating, and then subsequently eliminating, a let-binding-       -- BUT, if scrut is a not a variable, we must be careful-       -- about duplicating the arg redexes; in that case, make-       -- a new con-app from the args-    bind_case_bndr env-      | isDeadBinder bndr   = return (emptyFloats env, env)-      | exprIsTrivial scrut = return (emptyFloats env-                                     , extendIdSubst env bndr (DoneEx scrut Nothing))-      | otherwise           = do { dc_args <- mapM (simplVar env) bs-                                         -- dc_ty_args are already OutTypes,-                                         -- but bs are InBndrs-                                 ; let con_app = Var (dataConWorkId dc)-                                                 `mkTyApps` dc_ty_args-                                                 `mkApps`   dc_args-                                 ; simplNonRecX env bndr con_app }----------------------missingAlt :: SimplEnv -> Id -> [InAlt] -> SimplCont-           -> SimplM (SimplFloats, OutExpr)-                -- This isn't strictly an error, although it is unusual.-                -- It's possible that the simplifier might "see" that-                -- an inner case has no accessible alternatives before-                -- it "sees" that the entire branch of an outer case is-                -- inaccessible.  So we simply put an error case here instead.-missingAlt env case_bndr _ cont-  = WARN( True, text "missingAlt" <+> ppr case_bndr )-    -- See Note [Avoiding space leaks in OutType]-    let cont_ty = contResultType cont-    in seqType cont_ty `seq`-       return (emptyFloats env, mkImpossibleExpr cont_ty)--{--************************************************************************-*                                                                      *-\subsection{Duplicating continuations}-*                                                                      *-************************************************************************--Consider-  let x* = case e of { True -> e1; False -> e2 }-  in b-where x* is a strict binding.  Then mkDupableCont will be given-the continuation-   case [] of { True -> e1; False -> e2 } ; let x* = [] in b ; stop-and will split it into-   dupable:      case [] of { True -> $j1; False -> $j2 } ; stop-   join floats:  $j1 = e1, $j2 = e2-   non_dupable:  let x* = [] in b; stop--Putting this back together would give-   let x* = let { $j1 = e1; $j2 = e2 } in-            case e of { True -> $j1; False -> $j2 }-   in b-(Of course we only do this if 'e' wants to duplicate that continuation.)-Note how important it is that the new join points wrap around the-inner expression, and not around the whole thing.--In contrast, any let-bindings introduced by mkDupableCont can wrap-around the entire thing.--Note [Bottom alternatives]-~~~~~~~~~~~~~~~~~~~~~~~~~~-When we have-     case (case x of { A -> error .. ; B -> e; C -> error ..)-       of alts-then we can just duplicate those alts because the A and C cases-will disappear immediately.  This is more direct than creating-join points and inlining them away.  See #4930.--}-----------------------mkDupableCaseCont :: SimplEnv -> [InAlt] -> SimplCont-                  -> SimplM ( SimplFloats  -- 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 env (repeat topDmd) cont--mkDupableContWithDmds-   :: SimplEnv  -> [Demand]  -- Demands on arguments; always infinite-   -> SimplCont -> SimplM ( SimplFloats, SimplCont)--mkDupableContWithDmds env _ cont-  | contIsDupable cont-  = return (emptyFloats env, cont)--mkDupableContWithDmds _ _ (Stop {}) = panic "mkDupableCont"     -- Handled by previous eqn--mkDupableContWithDmds env dmds (CastIt ty cont)-  = do  { (floats, cont') <- mkDupableContWithDmds env dmds cont-        ; return (floats, CastIt ty cont') }---- 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_bndrs = bndrs-                 , sc_body = body, 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) <- simplLam sb_env1 bndrs body cont-          -- No need to use mkDupableCont before simplLam; we-          -- use cont once here, and then share the result if necessary--       ; let join_body = wrapFloats floats1 join_inner-             res_ty    = contResultType cont--       ; 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))-  , thumbsUpPlanA cont  -- See point (3) of Note [Duplicating join points]-  = -- Use Plan A of Note [Duplicating StrictArg]-    do { let (_ : dmds) = 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 (getMode 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 (CastIt _ k)                 = thumbsUpPlanA k-    thumbsUpPlanA (TickIt _ k)                 = thumbsUpPlanA k-    thumbsUpPlanA (ApplyToVal { sc_cont = k }) = thumbsUpPlanA k-    thumbsUpPlanA (ApplyToTy  { sc_cont = k }) = thumbsUpPlanA k-    thumbsUpPlanA (Select {})                  = True-    thumbsUpPlanA (StrictBind {})              = True-    thumbsUpPlanA (Stop {})                    = True--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:_) = dmds   -- Never fails-        ; (floats1, cont') <- mkDupableContWithDmds env dmds cont-        ; let env' = env `setInScopeFromF` floats1-        ; (_, se', arg') <- simplArg env' dup se arg-        ; (let_floats2, arg'') <- makeTrivial (getMode 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' <- mapM (simplAlt alt_env' Nothing [] case_bndr' alt_cont) (scaleAltsBy cont_scaling alts)-        -- Safe to say that there are no handled-cons for the DEFAULT case-                -- NB: simplBinder does not zap deadness occ-info, so-                -- a dead case_bndr' will still advertise its deadness-                -- This is really important because in-                --      case e of b { (# p,q #) -> ... }-                -- b is always dead, and indeed we are not allowed to bind b to (# p,q #),-                -- which might happen if e was an explicit unboxed pair and b wasn't marked dead.-                -- In the new alts we build, we have the new case binder, so it must retain-                -- its deadness.-        -- NB: we don't use alt_env further; it has the substEnv for-        --     the alternatives, and we don't want that--        ; (join_floats, alts'') <- mapAccumLM (mkDupableAlt (targetPlatform (seDynFlags env)) case_bndr')-                                              emptyJoinFloats alts'--        ; let all_floats = floats `addJoinFloats` join_floats-                           -- Note [Duplicated env]-        ; return (all_floats-                 , Select { sc_dup  = OkToDup-                          , sc_bndr = case_bndr'-                          , sc_alts = alts''-                          , sc_env  = zapSubstEnv se `setInScopeFromF` all_floats-                                      -- See Note [StaticEnv invariant] in 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-  | exprIsTrivial join_rhs   -- See point (2) of Note [Duplicating join points]-  = return (emptyFloats env-           , StrictBind { sc_bndr = arg_bndr, sc_bndrs = []-                        , sc_body = join_rhs-                        , sc_env  = zapSubstEnv env-                          -- 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 = Nothing, 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 :: Platform -> OutId-             -> JoinFloats -> OutAlt-             -> SimplM (JoinFloats, OutAlt)-mkDupableAlt _platform case_bndr jfloats (Alt con bndrs' rhs')-  | exprIsTrivial rhs'   -- See point (2) of Note [Duplicating join points]-  = return (jfloats, Alt con bndrs' rhs')--  | otherwise-  = do  { simpl_opts <- initSimpleOpts <$> getDynFlags-        ; let rhs_ty'  = exprType rhs'-              scrut_ty = idType case_bndr-              case_bndr_w_unf-                = case con of-                      DEFAULT    -> case_bndr-                      DataAlt dc -> setIdUnfolding case_bndr unf-                          where-                                 -- See Note [Case binders and join points]-                             unf = mkInlineUnfolding simpl_opts rhs-                             rhs = mkConApp2 dc (tyConAppArgs scrut_ty) bndrs'--                      LitAlt {} -> WARN( True, text "mkDupableAlt"-                                                <+> ppr case_bndr <+> ppr con )-                                   case_bndr-                           -- The case binder is alive but trivial, so why has-                           -- it not been substituted away?--              final_bndrs'-                | isDeadBinder case_bndr = filter abstract_over bndrs'-                | otherwise              = bndrs' ++ [case_bndr_w_unf]--              abstract_over bndr-                  | isTyVar bndr = True -- Abstract over all type variables just in case-                  | otherwise    = not (isDeadBinder bndr)-                        -- The deadness info on the new Ids is preserved by simplBinders-              final_args = varsToCoreExprs final_bndrs'-                           -- Note [Join point abstraction]--                -- We make the lambdas into one-shot-lambdas.  The-                -- join point is sure to be applied at most once, and doing so-                -- prevents the body of the join point being floated out by-                -- the full laziness pass-              really_final_bndrs     = map one_shot final_bndrs'-              one_shot v | isId v    = setOneShotLambda v-                         | otherwise = v-              join_rhs   = mkLams really_final_bndrs rhs'--        ; join_bndr <- newJoinId final_bndrs' rhs_ty'--        ; let join_call = mkApps (Var join_bndr) final_args-              alt'      = Alt con bndrs' join_call--        ; return ( jfloats `addJoinFlts` unitJoinFloat (NonRec join_bndr join_rhs)-                 , alt') }-                -- See Note [Duplicated env]--{--Note [Fusing case continuations]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-It's important to fuse two successive case continuations when the-first has one alternative.  That's why we call prepareCaseCont here.-Consider this, which arises from thunk splitting (see Note [Thunk-splitting] in 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 x y).  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`.   In contrast, if we /don't/ inline $j we-don't need a 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.--To achieve this:--1. Do not postInlineUnconditionally a join point, until the Final-   phase.  (The Final phase is still quite early, so we might consider-   delaying still more.)--2. In mkDupableAlt and mkDupableStrictBind, generate an alterative for-   all alternatives, except for exprIsTrival RHSs. Previously we used-   exprIsDupable.  This generates a lot more join points, but makes-   them much more case-of-case friendly.--   It is definitely worth checking for exprIsTrivial, otherwise we get-   an extra Simplifier iteration, because it is inlined in the next-   round.--3. 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.  That same Note explains why we-   want Plan A when the RHS of the new join point would be a-   non-data-constructor application--4. You might worry that $j will be inlined by the call-site inliner,-   but it won't because the call-site context for a join is usually-   extremely boring (the arguments come from the pattern match).-   And if not, then perhaps inlining it would be a good idea.--   You might also wonder if we get UnfWhen, because the RHS of the-   join point is no bigger than the call. But in the cases we care-   about it will be a little bigger, because of that free `f` in-       $j x = K f x-   So for now we don't do anything special in callSiteInline--There is a bit of tension between (2) and (3).  Do we want to retain-the join point only when the RHS is-* a constructor application? or-* just non-trivial?-Currently, a bit ad-hoc, but we definitely want to retain the join-point for data constructors in mkDupalbleALt (point 2); that is the-whole point of #19996 described above.--Note [Case binders and join points]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this-   case (case .. ) of c {-     I# c# -> ....c....--If we make a join point with c but not c# we get-  $j = \c -> ....c....--But if later inlining scrutinises the c, thus--  $j = \c -> ... case c of { I# y -> ... } ...--we won't see that 'c' has already been scrutinised.  This actually-happens in the 'tabulate' function in wave4main, and makes a significant-difference to allocation.--An alternative plan is this:--   $j = \c# -> let c = I# c# in ...c....--but that is bad if 'c' is *not* later scrutinised.--So instead we do both: we pass 'c' and 'c#' , and record in c's inlining-(a stable unfolding) that it's really I# c#, thus--   $j = \c# -> \c[=I# c#] -> ...c....--Absence analysis may later discard 'c'.--NB: take great care when doing strictness analysis;-    see Note [Lambda-bound unfoldings] in 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. 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.--Here is another example.-        && E (case x of { T -> F; F -> T })--Pushing the call inward (being careful not to duplicate E)-        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.--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-> TopLevelFlag-                  -> MaybeJoinCont-                  -> InId-                  -> OutExpr -> OutType -> ArityType-                  -> Unfolding -> SimplM Unfolding-simplLetUnfolding env top_lvl cont_mb id new_rhs rhs_ty arity unf-  | isStableUnfolding unf-  = simplStableUnfolding env top_lvl cont_mb id rhs_ty arity unf-  | isExitJoinId id-  = return noUnfolding -- See Note [Do not inline exit join points] in GHC.Core.Opt.Exitify-  | otherwise-  = -- Otherwise, we end up retaining all the SimpleEnv-    let !opts = seUnfoldingOpts env-    in mkLetUnfolding opts top_lvl InlineRhs id new_rhs----------------------mkLetUnfolding :: UnfoldingOpts -> TopLevelFlag -> UnfoldingSource-               -> InId -> OutExpr -> SimplM Unfolding-mkLetUnfolding !uf_opts top_lvl src id new_rhs-  = return (mkUnfolding uf_opts src is_top_lvl is_bottoming new_rhs)-            -- We make an  unfolding *even for loop-breakers*.-            -- Reason: (a) It might be useful to know that they are WHNF-            --         (b) In 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-    -- 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 -> TopLevelFlag-                     -> MaybeJoinCont  -- Just k => a join point with continuation k-                     -> InId-                     -> OutType-                     -> ArityType      -- Used to eta expand, but only for non-join-points-                     -> Unfolding-                     ->SimplM Unfolding--- Note [Setting the new unfolding]-simplStableUnfolding env top_lvl mb_cont 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 mb_cont of-                           Just cont -> -- Binder is a join point-                                        -- See Note [Rules and unfolding for join points]-                                        simplJoinRhs unf_env id expr cont-                           Nothing   -> -- Binder is not a join point-                                        do { expr' <- simplExprC unf_env expr (mkBoringStop rhs_ty)-                                           ; return (eta_expand expr') }-              ; case guide of-                  UnfWhen { ug_arity = arity-                          , ug_unsat_ok = sat_ok-                          , ug_boring_ok = boring_ok-                          }-                          -- Happens for INLINE things-                        -- Really important to force new_boring_ok as otherwise-                        -- `ug_boring_ok` is a thunk chain of-                        -- inlineBoringExprOk expr0-                        --  || inlineBoringExprOk expr1 || ...-                        --  See #20134-                     -> let !new_boring_ok = boring_ok || inlineBoringOk expr'-                            guide' =-                              UnfWhen { ug_arity = arity-                                      , ug_unsat_ok = sat_ok-                                      , 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' guide')-                            -- See Note [Top-level flag on inline rules] in GHC.Core.Unfold--                  _other              -- Happens for INLINABLE things-                     -> mkLetUnfolding uf_opts top_lvl src id expr' }-                -- If the guidance is UnfIfGoodArgs, this is an INLINABLE-                -- unfolding, and we need to make sure the guidance is kept up-                -- to date with respect to any changes in the unfolding.--        | otherwise -> return noUnfolding   -- Discard unstable unfoldings-  where-    uf_opts    = seUnfoldingOpts env-    -- 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.-    !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]-    eta_expand expr-      | not eta_on         = expr-      | exprIsTrivial expr = expr-      | otherwise          = etaExpandAT id_arity expr-    eta_on = sm_eta_expand (getMode env)--{- 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 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 [Do not eta-expand trivial expressions]-  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 (mb_cont = Just _) 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-             -> MaybeJoinCont   -- Just k for a join point binder-                                -- Nothing otherwise-             -> SimplM (SimplEnv, OutBndr)--- Rules are added back into the bin-addBndrRules env in_id out_id mb_cont-  | null old_rules-  = return (env, out_id)-  | otherwise-  = do { new_rules <- simplRules env (Just out_id) old_rules mb_cont-       ; let final_id  = out_id `setIdSpecialisation` mkRuleInfo new_rules-       ; return (modifyInScope env final_id, final_id) }-  where-    old_rules = ruleInfoRules (idSpecialisation in_id)--simplRules :: SimplEnv -> Maybe OutId -> [CoreRule]-           -> MaybeJoinCont -> SimplM [CoreRule]-simplRules env mb_new_id rules mb_cont-  = mapM simpl_rule rules-  where-    simpl_rule rule@(BuiltinRule {})-      = return rule--    simpl_rule rule@(Rule { ru_bndrs = bndrs, ru_args = args-                          , ru_fn = fn_name, ru_rhs = rhs-                          , ru_act = act })-      = do { (env', bndrs') <- simplBinders env bndrs-           ; let rhs_ty = substTy env' (exprType rhs)-                 rhs_cont = case mb_cont of  -- See Note [Rules and unfolding for join points]-                                Nothing   -> mkBoringStop rhs_ty-                                Just cont -> ASSERT2( join_ok, bad_join_msg )-                                             cont-                 lhs_env = updMode updModeForRules env'-                 rhs_env = updMode (updModeForStableUnfoldings act) env'-                           -- See Note [Simplifying the RHS of a RULE]-                 fn_name' = case mb_new_id of-                              Just id -> idName id-                              Nothing -> fn_name--                 -- join_ok is an assertion check that the join-arity of the-                 -- binder matches that of the rule, so that pushing the-                 -- continuation into the RHS makes sense-                 join_ok = case mb_new_id of-                             Just id | Just join_arity <- isJoinId_maybe id-                                     -> length args == join_arity-                             _ -> False-                 bad_join_msg = vcat [ ppr mb_new_id, ppr rule-                                     , ppr (fmap isJoinId_maybe mb_new_id) ]--           ; args' <- mapM (simplExpr lhs_env) args-           ; rhs'  <- simplExprC rhs_env rhs rhs_cont-           ; return (rule { ru_bndrs = bndrs'-                          , ru_fn    = fn_name'-                          , ru_args  = args'-                          , ru_rhs   = rhs' }) }--{- 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.--}++{-# LANGUAGE TypeFamilies #-}++{-# OPTIONS_GHC -Wno-incomplete-record-updates -Wno-incomplete-uni-patterns #-}+module GHC.Core.Opt.Simplify ( simplTopBinds, simplExpr, simplImpRules ) where++import GHC.Prelude++import GHC.Platform++import GHC.Driver.Session++import GHC.Core+import GHC.Core.Opt.Simplify.Monad+import GHC.Core.Type hiding ( substTy, substTyVar, extendTvSubst, extendCvSubst )+import GHC.Core.Opt.Simplify.Env+import GHC.Core.Opt.Simplify.Utils+import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr, zapLambdaBndrs )+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+   ( DataCon, dataConWorkId, dataConRepStrictness+   , dataConRepArgTys, isUnboxedTupleDataCon+   , StrictnessMark (..) )+import GHC.Core.Opt.Monad ( Tick(..), SimplMode(..) )+import GHC.Core.Ppr     ( pprCoreExpr )+import GHC.Core.Unfold+import GHC.Core.Unfold.Make+import GHC.Core.Utils+import GHC.Core.Opt.Arity ( ArityType(..)+                          , pushCoTyArg, pushCoValArg+                          , etaExpandAT )+import GHC.Core.SimpleOpt ( exprIsConApp_maybe, joinPointBinding_maybe, joinPointBindings_maybe )+import GHC.Core.FVs     ( mkRuleInfo )+import GHC.Core.Rules   ( lookupRule, getRules, initRuleOpts )+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.Cpr    ( mkCprSig, botCpr )+import GHC.Types.Unique ( hasKey )+import GHC.Types.Basic+import GHC.Types.Tickish+import GHC.Types.Var    ( isTyCoVar )+import GHC.Builtin.PrimOps ( PrimOp (SeqOp) )+import GHC.Builtin.Types.Prim( realWorldStatePrimTy )+import GHC.Builtin.Names( runRWKey )++import GHC.Data.Maybe   ( isNothing, orElse )+import GHC.Data.FastString+import GHC.Unit.Module ( moduleName, pprModuleName )+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Utils.Panic.Plain+import GHC.Utils.Constants (debugIsOn)+import GHC.Utils.Trace+import GHC.Utils.Monad  ( mapAccumLM, liftIO )+import GHC.Utils.Logger++import Control.Monad++{-+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 (which includes DynFlags for convenience)+     - Ambient substitution+     - InScopeSet++ * SimplFloats contains+     - Let-floats (which includes ok-for-spec case-floats)+     - Join floats+     - InScopeSet (including all the floats)++ * Expressions+      simplExpr :: SimplEnv -> InExpr -> SimplCont+                -> SimplM (SimplFloats, OutExpr)+   The result of simplifying an /expression/ is (floats, expr)+      - A bunch of floats (let bindings, join bindings)+      - A simplified expression.+   The overall result is effectively (let floats in expr)++ * Bindings+      simplBind :: SimplEnv -> InBind -> SimplM (SimplFloats, SimplEnv)+   The result of simplifying a binding is+     - A bunch of floats, the last of which is the simplified binding+       There may be auxiliary bindings too; see prepareRhs+     - An environment suitable for simplifying the scope of the binding++   The floats may also be empty, if the binding is inlined unconditionally;+   in that case the returned SimplEnv will have an augmented substitution.++   The returned floats and env both have an in-scope set, and they are+   guaranteed to be the same.+++Note [Shadowing]+~~~~~~~~~~~~~~~~+The simplifier used to guarantee that the output had no shadowing, but+it does not do so any more.   (Actually, it never did!)  The reason is+documented with simplifyArgs.+++Eta expansion+~~~~~~~~~~~~~~+For eta expansion, we want to catch things like++        case e of (a,b) -> \x -> case a of (p,q) -> \y -> r++If the \x was on the RHS of a let, we'd eta expand to bring the two+lambdas together.  And in general that's a good thing to do.  Perhaps+we should eta expand wherever we find a (value) lambda?  Then the eta+expansion at a let RHS can concentrate solely on the PAP case.++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  { (env_with_info, triples) <- mapAccumLM add_rules env0 pairs0+        ; (rec_floats, env1) <- go env_with_info triples+        ; return (mkRecFloats rec_floats, env1) }+  where+    add_rules :: SimplEnv -> (InBndr,InExpr) -> SimplM (SimplEnv, (InBndr, OutBndr, InExpr))+        -- Add the (substituted) rules to the binder+    add_rules env (bndr, rhs)+        = do { (env', bndr') <- addBndrRules env bndr (lookupRecBndr env bndr) 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 env "SimplBindr:inline-uncond" (ppr old_bndr) $+    do { tick (PreInlineUnconditionally old_bndr)+       ; return ( emptyFloats env, env' ) }++  | otherwise+  = case bind_cxt of+      BC_Join cont  -> simplTrace env "SimplBind:join" (ppr old_bndr) $+                       simplJoinBind env cont old_bndr new_bndr rhs env++      BC_Let top_lvl is_rec -> simplTrace env "SimplBind:normal" (ppr old_bndr) $+                               simplLazyBind env top_lvl is_rec old_bndr new_bndr rhs env++simplTrace :: SimplEnv -> String -> SDoc -> a -> a+simplTrace env herald doc thing_inside+  | not (logHasDumpFlag logger Opt_D_verbose_core2core)+  = thing_inside+  | otherwise+  = logTraceMsg logger herald doc thing_inside+  where+    logger = seLogger env++--------------------------+simplLazyBind :: SimplEnv+              -> TopLevelFlag -> RecFlag+              -> InId -> OutId          -- Binder, both pre-and post simpl+                                        -- Not a JoinId+                                        -- The OutId has IdInfo, except arity, unfolding+                                        -- Ids only, no TyVars+              -> InExpr -> SimplEnv     -- The RHS and its environment+              -> SimplM (SimplFloats, SimplEnv)+-- Precondition: the OutId is already in the InScopeSet of the incoming 'env'+-- Precondition: not a JoinId+-- Precondition: rhs obeys the let/app invariant+-- NOT used for JoinIds+simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se+  = assert (isId bndr )+    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))+        ; (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 floats = foldl' extendFloats (emptyFloats env) poly_binds+                        ; return (floats, body3) }++        ; let env' = env `setInScopeFromF` rhs_floats+        ; rhs' <- mkLam env' tvs' body3 rhs_cont+        ; (bind_float, env2) <- completeBind env' (BC_Let top_lvl is_rec) bndr bndr1 rhs'+        ; return (rhs_floats `addFloats` bind_float, env2) }++--------------------------+simplJoinBind :: SimplEnv+              -> SimplCont+              -> InId -> OutId          -- Binder, both pre-and post simpl+                                        -- The OutId has IdInfo, except arity,+                                        --   unfolding+              -> InExpr -> SimplEnv     -- The right hand side and its env+              -> SimplM (SimplFloats, SimplEnv)+simplJoinBind env cont old_bndr new_bndr rhs rhs_se+  = do  { let rhs_env = rhs_se `setInScopeFromE` env+        ; rhs' <- simplJoinRhs rhs_env old_bndr rhs cont+        ; completeBind env (BC_Join cont) old_bndr new_bndr rhs' }++--------------------------+simplNonRecX :: SimplEnv+             -> InId            -- Old binder; not a JoinId+             -> OutExpr         -- Simplified RHS+             -> SimplM (SimplFloats, SimplEnv)+-- A specialised variant of simplNonRec used when the RHS is already+-- simplified, notably in knownCon.  It uses case-binding where necessary.+--+-- Precondition: rhs satisfies the let/app invariant++simplNonRecX env bndr new_rhs+  | assertPpr (not (isJoinId bndr)) (ppr bndr) $+    isDeadBinder bndr   -- Not uncommon; e.g. case (a,b) of c { (p,q) -> p }+  = return (emptyFloats env, env)    --  Here c is dead, and we avoid+                                         --  creating the binding c = (a,b)++  | Coercion co <- new_rhs+  = return (emptyFloats env, extendCvSubst env bndr co)++  | exprIsTrivial new_rhs  -- Short-cut for let x = y in ...+    -- This case would ultimately land in postInlineUnconditionally+    -- but it seems not uncommon, and avoids a lot of faff to do it here+  = return (emptyFloats env+           , extendIdSubst env bndr (DoneEx new_rhs Nothing))++  | otherwise+  = do  { (env1, new_bndr)   <- simplBinder env bndr+        ; let is_strict = isStrictId new_bndr+              -- isStrictId: use new_bndr 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+                                               new_bndr (emptyFloats env) new_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 simplNonRecX, so bndr is not in scope in the RHS.++        ; (bind_float, env2) <- completeBind (env1 `setInScopeFromF` rhs_floats)+                                             (BC_Let NotTopLevel NonRecursive)+                                             bndr new_bndr rhs1+              -- Must pass env1 to completeBind in case simplBinder had to clone,+              -- and extended the substitution with [bndr :-> new_bndr]++        ; 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 -> OccInfo+                     -> OutId -> OutExpr+                     -> SimplM (SimplFloats, SimplEnv)+-- See Note [Cast worker/wrapper]+tryCastWorkerWrapper env bind_cxt old_bndr occ_info 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+  , isConcrete (typeKind rhs_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 Many rhs_ty worker_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 bndr occ_info 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 Nothing ) }++          else do { wrap_unf <- mkLetUnfolding (sm_uf_opts mode) top_lvl InlineRhs bndr 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+    mode   = getMode env+    occ_fs = getOccFS bndr+    rhs_ty = coercionLKind co+    info   = idInfo bndr++    worker_info = vanillaIdInfo `setDmdSigInfo`     dmdSigInfo info+                                `setCprSigInfo`     cprSigInfo info+                                `setDemandInfo`     demandInfo info+                                `setInlinePragInfo` inlinePragInfo info+                                `setArityInfo`      arityInfo info+           -- 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 (sm_uf_opts mode) top_lvl InlineRhs work_id work_rhs++tryCastWorkerWrapper env _ _ _ bndr rhs  -- All other bindings+  = return (mkFloatBind env (NonRec bndr rhs))++mkCastWrapperInlinePrag :: InlinePragma -> InlinePragma+-- See Note [Cast worker/wrapper]+mkCastWrapperInlinePrag (InlinePragma { inl_act = act, inl_rule = rule_info })+  = InlinePragma { inl_src    = SourceText "{-# INLINE"+                 , inl_inline = NoUserInlinePrag -- See Note [Wrapper NoUserInlinePrag]+                 , 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 act = activateDuringFinal+             | otherwise         = 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+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++       -- Now ANF-ise the remaining rhs+       ; (anf_floats, rhs2) <- prepareRhs rhs_env top_lvl (getOccFS bndr) rhs1++       -- Finally, decide whether or not to float+       ; let all_floats = rhs_floats1 `addLetFloats` anf_floats+       ; if doFloatFromRhs 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 :: 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+  = do  { (_is_exp, floats, rhs1) <- go 0 rhs0+        ; return (floats, rhs1) }+  where+    go :: Int -> OutExpr -> SimplM (Bool, LetFloats, OutExpr)+    go n_val_args (Cast rhs co)+        = do { (is_exp, floats, rhs') <- go n_val_args rhs+             ; return (is_exp, floats, Cast rhs' co) }+    go n_val_args (App fun (Type ty))+        = do { (is_exp, floats, rhs') <- go n_val_args fun+             ; return (is_exp, floats, App rhs' (Type ty)) }+    go n_val_args (App fun arg)+        = do { (is_exp, floats1, fun') <- go (n_val_args+1) fun+             ; case is_exp of+                False -> return (False, emptyLetFloats, App fun arg)+                True  -> do { (floats2, arg') <- makeTrivial env top_lvl topDmd occ arg+                            ; return (True, floats1 `addLetFlts` floats2, App fun' arg') } }+    go n_val_args (Var fun)+        = return (is_exp, emptyLetFloats, Var fun)+        where+          is_exp = isExpandableApp fun n_val_args   -- The fun a constructor or PAP+                        -- See Note [CONLIKE pragma] in GHC.Types.Basic+                        -- The definition of is_exp should match that in+                        -- 'GHC.Core.Opt.OccurAnal.occAnalApp'++    go n_val_args (Tick t rhs)+        -- We want to be able to float bindings past this+        -- tick. Non-scoping ticks don't care.+        | tickishScoped t == NoScope+        = do { (is_exp, floats, rhs') <- go n_val_args rhs+             ; return (is_exp, floats, Tick t rhs') }++        -- On the other hand, for scoping ticks we need to be able to+        -- copy them on the floats, which in turn is only allowed if+        -- we can obtain non-counting ticks.+        | (not (tickishCounts t) || tickishCanSplit t)+        = do { (is_exp, floats, rhs') <- go n_val_args rhs+             ; let tickIt (id, expr) = (id, mkTick (mkNoCount t) expr)+                   floats' = mapLetFloats floats tickIt+             ; return (is_exp, floats', Tick t rhs') }++    go _ other+        = return (False, emptyLetFloats, other)++makeTrivialArg :: 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+  = return (emptyLetFloats, arg)  -- CastBy, TyArg++makeTrivial :: SimplEnv -> TopLevelFlag -> Demand+            -> FastString  -- ^ A "friendly name" to build the new binder from+            -> OutExpr     -- ^ This expression satisfies the let/app invariant+            -> SimplM (LetFloats, OutExpr)+-- Binds the expression to a variable, if it's not trivial, returning the variable+-- 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+  = do { (floats, new_id) <- makeTrivialBinding env top_lvl occ_fs+                                                id_info expr expr_ty+       ; return (floats, Var new_id) }+  where+    id_info = vanillaIdInfo `setDemandInfo` dmd+    expr_ty = exprType expr++makeTrivialBinding :: SimplEnv -> TopLevelFlag+                   -> FastString  -- ^ a "friendly name" to build the new binder from+                   -> IdInfo+                   -> OutExpr     -- ^ This expression satisfies the let/app invariant+                   -> OutType     -- Type of the expression+                   -> SimplM (LetFloats, OutId)+makeTrivialBinding env top_lvl occ_fs info expr expr_ty+  = do  { (floats, expr1) <- prepareRhs env top_lvl occ_fs expr+        ; uniq <- getUniqueM+        ; let name = mkSystemVarName uniq occ_fs+              var  = mkLocalIdWithInfo name Many expr_ty info++        -- Now something very like completeBind,+        -- but without the postInlineUnconditionally part+        ; (arity_type, expr2) <- tryEtaExpandRhs env 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 shadowig in eta expansion++        ; unf <- mkLetUnfolding (sm_uf_opts mode) top_lvl InlineRhs var expr2++        ; let final_id = addLetBndrInfo var arity_type unf+              bind     = NonRec final_id expr2++        ; return ( floats `addLetFlts` unitLetFloat bind, final_id ) }+  where+    mode = getMode env++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 :: SimplEnv+             -> BindContext+             -> InId           -- Old binder+             -> OutId          -- New binder; can be a JoinId+             -> OutExpr        -- New RHS+             -> SimplM (SimplFloats, SimplEnv)+-- completeBind may choose to do its work+--      * by extending the substitution (e.g. let x = y in ...)+--      * or by adding to the floats in the envt+--+-- Binder /can/ be a JoinId+-- Precondition: rhs obeys the let/app invariant+completeBind env bind_cxt old_bndr new_bndr new_rhs+ | isCoVar old_bndr+ = case new_rhs of+     Coercion co -> return (emptyFloats env, extendCvSubst env old_bndr co)+     _           -> return (mkFloatBind env (NonRec new_bndr new_rhs))++ | otherwise+ = assert (isId new_bndr) $+   do { let old_info = idInfo old_bndr+            old_unf  = realUnfoldingInfo old_info+            occ_info = occInfo 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 new_bndr new_rhs++        -- Simplify the unfolding+      ; new_unfolding <- simplLetUnfolding 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 new_bndr_w_info occ_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 env "PostInlineUnconditionally" (ppr new_bndr <+> ppr unf_rhs) $+                   return ( emptyFloats env+                          , extendIdSubst env old_bndr $+                            DoneEx unf_rhs (isJoinId_maybe new_bndr)) }+                -- Use the substitution to make quite, quite sure that the+                -- substitution will happen, since we are going to discard the binding++        else -- Keep the binding; do cast worker/wrapper+             -- pprTrace "Binding" (ppr new_bndr <+> ppr new_unfolding) $+             tryCastWorkerWrapper env bind_cxt old_bndr occ_info new_bndr_w_info eta_rhs }++addLetBndrInfo :: OutId -> ArityType -> Unfolding -> OutId+addLetBndrInfo new_bndr new_arity_type new_unf+  = new_bndr `setIdInfo` info5+  where+    AT oss div = new_arity_type+    new_arity  = length oss++    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+          = zapDemandInfo info2 `orElse` info2+          | otherwise+          = info2++    -- Bottoming bindings: see Note [Bottoming bindings]+    info4 | isDeadEndDiv div = info3 `setDmdSigInfo` bot_sig+                                     `setCprSigInfo`        bot_cpr+          | otherwise        = info3++    bot_sig = mkClosedDmdSig (replicate new_arity topDmd) div+    bot_cpr = mkCprSig new_arity botCpr++     -- 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 = \x. error (x ++ "urk")+   in ...(case f "foo" of <alts>)...++Then we'd like to drop the dead <alts> immediately.  So it's good to+propagate the info that x's RHS is bottom to x's IdInfo as rapidly as+possible.++We use tryEtaExpandRhs on every binding, and it turns 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.++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.+++************************************************************************+*                                                                      *+\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 :: 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 "simplIdF" #-} simplIdF env v cont+simplExprF1 env (Lit lit)      cont = {-#SCC "rebuild" #-} rebuild env (Lit lit) cont+simplExprF1 env (Tick t expr)  cont = {-#SCC "simplTick" #-} simplTick env t expr cont+simplExprF1 env (Cast body co) cont = {-#SCC "simplCast" #-} simplCast env body co cont+simplExprF1 env (Coercion co)  cont = {-#SCC "simplCoercionF" #-} simplCoercionF env co cont++simplExprF1 env (App fun arg) cont+  = {-#SCC "simplExprF1-App" #-} case arg of+      Type ty -> do { -- The argument type will (almost) certainly be used+                      -- in the output program, so just force it now.+                      -- See Note [Avoiding space leaks in OutType]+                      arg' <- simplType env ty++                      -- But use substTy, not simplType, to avoid forcing+                      -- the hole type; it will likely not be needed.+                      -- See Note [The hole type in ApplyToTy]+                    ; let hole' = substTy env (exprType fun)++                    ; simplExprF env fun $+                      ApplyToTy { sc_arg_ty  = arg'+                                , sc_hole_ty = hole'+                                , sc_cont    = cont } }+      _       ->+          -- 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 (bndr', rhs') <- joinPointBinding_maybe bndr rhs+  = {-#SCC "simplNonRecJoinPoint" #-} simplNonRecJoinPoint env bndr' rhs' body cont++  | otherwise+  = {-#SCC "simplNonRecE" #-} simplNonRecE env bndr (rhs, env) body cont++{- Note [Avoiding space leaks in OutType]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Since the simplifier is run for multiple iterations, we need to ensure+that any thunks in the output of one simplifier iteration are forced+by the evaluation of the next simplifier iteration. Otherwise we may+retain multiple copies of the Core program and leak a terrible amount+of memory (as in #13426).++The simplifier is naturally strict in the entire "Expr part" of the+input Core program, because any expression may contain binders, which+we must find in order to extend the SimplEnv accordingly. But types+do not contain binders and so it is tempting to write things like++    simplExpr env (Type ty) = return (Type (substTy env ty))   -- Bad!++This is Bad because the result includes a thunk (substTy env ty) which+retains a reference to the whole simplifier environment; and the next+simplifier iteration will not force this thunk either, because the+line above is not strict in ty.++So instead our strategy is for the simplifier to fully evaluate+OutTypes when it emits them into the output Core program, for example++    simplExpr env (Type ty) = do { ty' <- simplType env ty     -- Good+                                 ; return (Type ty') }++where the only difference from above is that simplType calls seqType+on the result of substTy.++However, SimplCont can also contain OutTypes and it's not necessarily+a good idea to force types on the way in to SimplCont, because they+may end up not being used and forcing them could be a lot of wasted+work. T5631 is a good example of this.++- For ApplyToTy's sc_arg_ty, we force the type on the way in because+  the type will almost certainly appear as a type argument in the+  output program.++- For the hole types in Stop and ApplyToTy, we force the type when we+  emit it into the output program, after obtaining it from+  contResultType. (The hole type in ApplyToTy is only directly used+  to form the result type in a new Stop continuation.)+-}++---------------------------------+-- Simplify a join point, adding the context.+-- Context goes *inside* the lambdas. IOW, if the join point has arity n, we do:+--   \x1 .. xn -> e => \x1 .. xn -> E[e]+-- Note that we need the arity of the join point, since e may be a lambda+-- (though this is unlikely). See Note [Join points and case-of-case].+simplJoinRhs :: SimplEnv -> InId -> InExpr -> SimplCont+             -> SimplM OutExpr+simplJoinRhs env bndr expr cont+  | Just arity <- isJoinId_maybe bndr+  =  do { let (join_bndrs, join_body) = collectNBinders arity expr+              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 { opts <- getOptCoercionOpts+       ; let opt_co = optCoercion opts (getTCvSubst env) co+       ; seqCo opt_co `seq` return opt_co }++-----------------------------------+-- | Push a TickIt context outwards past applications and cases, as+-- long as this is a non-scoping tick, to let case and application+-- optimisations apply.++simplTick :: SimplEnv -> 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.++-- XXX: we cannot do this, because the simplifier assumes that+-- the context can be pushed into a case with a single branch. e.g.+--    scc<f>  case expensive of p -> e+-- becomes+--    case expensive of p -> scc<f> e+--+-- So I'm disabling this for now.  It just means we will do more+-- simplifier iterations that necessary in some cases.++--  | tickishScoped tickish && not (tickishCounts tickish)+--  = simplExprF env expr (TickIt tickish cont)++  -- For unscoped or soft-scoped ticks, we are allowed to float in new+  -- cost, so we simply push the continuation inside the tick.  This+  -- has the effect of moving the tick to the outside of a case or+  -- application context, allowing the normal case and application+  -- optimisations to fire.+  | tickish `tickishScopesLike` SoftScope+  = do { (floats, expr') <- simplExprF env expr cont+       ; return (floats, mkTick tickish expr')+       }++  -- Push tick inside if the context looks like this will allow us to+  -- do a case-of-case - see Note [case-of-scc-of-case]+  | Select {} <- cont, Just expr' <- push_tick_inside+  = simplExprF env expr' cont++  -- We don't want to move the tick, but we might still want to allow+  -- floats to pass through with appropriate wrapping (or not, see+  -- wrap_floats below)+  --- | not (tickishCounts tickish) || tickishCanSplit tickish+  -- = wrap_floats++  | otherwise+  = no_floating_past_tick++ where++  -- Try to push tick inside a case, see Note [case-of-scc-of-case].+  push_tick_inside =+    case expr0 of+      Case scrut bndr ty alts+             -> Just $ Case (tickScrut scrut) bndr ty (map tickAlt alts)+      _other -> Nothing+   where (ticks, expr0) = stripTicksTop movable (Tick tickish expr)+         movable t      = not (tickishCounts t) ||+                          t `tickishScopesLike` NoScope ||+                          tickishCanSplit t+         tickScrut e    = foldr mkTick e ticks+         -- Alternatives get annotated with all ticks that scope in some way,+         -- but we don't want to count entries.+         tickAlt (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 n ids <- tickish+          = Breakpoint ext n (map (getDoneId . substId env) ids)+    | otherwise = tickish++  -- Push type application and coercion inside a tick+  splitCont :: SimplCont -> (SimplCont, SimplCont)+  splitCont cont@(ApplyToTy { sc_cont = tail }) = (cont { sc_cont = inc }, outc)+    where (inc,outc) = splitCont tail+  splitCont (CastIt co c) = (CastIt co inc, outc)+    where (inc,outc) = splitCont c+  splitCont other = (mkBoringStop (contHoleType other), other)++  getDoneId (DoneId id)  = id+  getDoneId (DoneEx e _) = getIdFromTrivialExpr e -- Note [substTickish] in 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)+-- At this point the substitution in the SimplEnv should be irrelevant;+-- only the in-scope set matters+rebuild env expr cont+  = case cont of+      Stop {}          -> return (emptyFloats env, expr)+      TickIt t cont    -> rebuild env (mkTick t expr) cont+      CastIt co cont   -> rebuild env (mkCast expr co) cont+                       -- NB: mkCast implements the (Coercion co |> g) optimisation++      Select { sc_bndr = bndr, sc_alts = alts, sc_env = se, sc_cont = cont }+        -> rebuildCase (se `setInScopeFromE` env) expr bndr alts cont++      StrictArg { sc_fun = fun, sc_cont = cont, 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 }+        -> do { (floats1, env') <- simplNonRecX (se `setInScopeFromE` env) b expr+                                  -- expr satisfies let/app since it started life+                                  -- in a call to simplNonRecE+              ; (floats2, expr') <- simplLam env' body cont+              ; return (floats1 `addFloats` floats2, expr') }++      ApplyToTy  { sc_arg_ty = ty, sc_cont = cont}+        -> rebuild env (App expr (Type ty)) cont++      ApplyToVal { sc_arg = arg, sc_env = se, sc_dup = dup_flag, sc_cont = cont}+        -- See Note [Avoid redundant simplification]+        -> do { (_, _, arg') <- simplArg env dup_flag se arg+              ; rebuild env (App expr arg') cont }++{-+************************************************************************+*                                                                      *+\subsection{Lambdas}+*                                                                      *+************************************************************************+-}++{- Note [Optimising reflexivity]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's important (for compiler performance) to get rid of reflexivity as soon+as it appears.  See #11735, #14737, and #15019.++In particular, we want to behave well on++ *  e |> co1 |> co2+    where the two happen to cancel out entirely. That is quite common;+    e.g. a newtype wrapping and unwrapping cancel.+++ * (f |> co) @t1 @t2 ... @tn x1 .. xm+   Here we will use pushCoTyArg and pushCoValArg successively, which+   build up NthCo stacks.  Silly to do that if co is reflexive.++However, we don't want to call isReflexiveCo too much, because it uses+type equality which is expensive on big types (#14737 comment:7).++A good compromise (determined experimentally) seems to be to call+isReflexiveCo+ * when composing casts, and+ * at the end++In investigating this I saw missed opportunities for on-the-fly+coercion shrinkage. See #15090.+-}+++simplCast :: SimplEnv -> InExpr -> Coercion -> SimplCont+          -> SimplM (SimplFloats, OutExpr)+simplCast env body co0 cont0+  = do  { co1   <- {-#SCC "simplCast-simplCoercion" #-} simplCoercion env co0+        ; cont1 <- {-#SCC "simplCast-addCoerce" #-}+                   if isReflCo co1+                   then return cont0  -- See Note [Optimising reflexivity]+                   else addCoerce co1 cont0+        ; {-#SCC "simplCast-simplExprF" #-} simplExprF env body cont1 }+  where+        -- If the first parameter is MRefl, then simplifying revealed a+        -- reflexive coercion. Omit.+        addCoerceM :: MOutCoercion -> SimplCont -> SimplM SimplCont+        addCoerceM MRefl   cont = return cont+        addCoerceM (MCo co) cont = addCoerce co cont++        addCoerce :: OutCoercion -> SimplCont -> SimplM SimplCont+        addCoerce co1 (CastIt co2 cont)  -- See Note [Optimising reflexivity]+          | isReflexiveCo co' = return cont+          | otherwise         = addCoerce co' cont+          where+            co' = mkTransCo co1 co2++        addCoerce co (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = tail })+          | Just (arg_ty', m_co') <- pushCoTyArg co arg_ty+          = {-#SCC "addCoerce-pushCoTyArg" #-}+            do { tail' <- addCoerceM m_co' tail+               ; return (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 cont@(ApplyToVal { sc_arg = arg, sc_env = arg_se+                                      , sc_dup = dup, sc_cont = tail })+          | Just (m_co1, m_co2) <- pushCoValArg co+          , fixed_rep m_co1+          = {-#SCC "addCoerce-pushCoValArg" #-}+            do { tail' <- addCoerceM m_co2 tail+               ; case m_co1 of {+                   MRefl -> return (cont { sc_cont = tail'+                                         , sc_hole_ty = coercionLKind co }) ;+                      -- Avoid simplifying if possible;+                      -- See Note [Avoiding exponential behaviour]++                   MCo co1 ->+            do { (dup', arg_se', arg') <- simplArg env dup arg_se arg+                    -- When we build the ApplyTo we can't mix the OutCoercion+                    -- 'co' with the InExpr 'arg', so we simplify+                    -- to make it all consistent.  It's a bit messy.+                    -- But it isn't a common case.+                    -- Example of use: #995+               ; return (ApplyToVal { sc_arg  = mkCast arg' co1+                                    , sc_env  = arg_se'+                                    , sc_dup  = dup'+                                    , sc_cont = tail'+                                    , sc_hole_ty = coercionLKind co }) } } }++        addCoerce co cont+          | isReflexiveCo co = return cont  -- Having this at the end makes a huge+                                            -- difference in T12227, for some reason+                                            -- See Note [Optimising reflexivity]+          | otherwise        = return (CastIt co cont)++        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++simplArg :: SimplEnv -> DupFlag -> StaticEnv -> CoreExpr+         -> SimplM (DupFlag, StaticEnv, OutExpr)+simplArg env dup_flag arg_env arg+  | isSimplified dup_flag+  = return (dup_flag, arg_env, arg)+  | otherwise+  = do { let arg_env' = arg_env `setInScopeFromE` env+       ; arg' <- simplExpr arg_env'  arg+       ; 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}+*                                                                      *+************************************************************************+-}++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 :: 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 }++-- Value beta-reduction+simpl_lam env bndr body (ApplyToVal { sc_arg = arg, sc_env = arg_se+                                    , sc_cont = cont, sc_dup = dup })+  | isSimplified dup  -- Don't re-simplify if we've simplified it once+                      -- See Note [Avoiding exponential behaviour]+  = do  { tick (BetaReduction bndr)+        ; (floats1, env') <- simplNonRecX env bndr arg+        ; (floats2, expr') <- simplLam env' body cont+        ; return (floats1 `addFloats` floats2, expr') }++  | otherwise+  = do  { tick (BetaReduction bndr)+        ; simplNonRecE env 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 <- mkLam 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 :: SimplEnv+             -> InId                    -- The binder, always an Id+                                        -- Never a join point+             -> (InExpr, SimplEnv)      -- Rhs of binding (or arg of lambda)+             -> InExpr                  -- Body of the let/lambda+             -> SimplCont+             -> SimplM (SimplFloats, OutExpr)++-- simplNonRecE is used for+--  * non-top-level non-recursive non-join-point lets in expressions+--  * beta reduction+--+-- simplNonRec env b (rhs, rhs_se) 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+--+-- Precondition: rhs satisfies the let/app invariant+--               Note [Core let/app invariant] in GHC.Core++simplNonRecE env bndr (rhs, rhs_se) body cont+  | assert (isId bndr && not (isJoinId bndr) ) True+  , Just env' <- preInlineUnconditionally env NotTopLevel bndr rhs rhs_se+  = do { tick (PreInlineUnconditionally bndr)+       ; -- pprTrace "preInlineUncond" (ppr bndr <+> ppr rhs) $+         simplLam env' body cont }++  | otherwise+  = do { (env1, bndr1) <- simplNonRecBndr env bndr++       -- Deal with strict bindings+       -- See Note [Dark corner with representation polymorphism]+       ; if isStrictId bndr1 && sm_case_case (getMode env)+         then simplExprF (rhs_se `setInScopeFromE` env) rhs+                   (StrictBind { sc_bndr = bndr, sc_body = body+                               , sc_env = env, sc_cont = cont, sc_dup = NoDup })++       -- Deal with lazy bindings+         else do+       { (env2, bndr2)    <- addBndrRules env1 bndr bndr1 (BC_Let NotTopLevel NonRecursive)+       ; (floats1, env3)  <- simplLazyBind env2 NotTopLevel NonRecursive bndr bndr2 rhs rhs_se+       ; (floats2, expr') <- simplLam env3 body cont+       ; return (floats1 `addFloats` floats2, expr') } }++------------------+simplRecE :: SimplEnv+          -> [(InId, InExpr)]+          -> InExpr+          -> SimplCont+          -> SimplM (SimplFloats, OutExpr)++-- simplRecE is used for+--  * non-top-level recursive lets in expressions+-- 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 `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 exponential behaviour]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+One way in which we can get exponential behaviour is if we simplify a+big expression, and the re-simplify it -- and then this happens in a+deeply-nested way.  So we must be jolly careful about re-simplifying+an expression.  That is why simplNonRecX does not try+preInlineUnconditionally (unlike simplNonRecE).++Example:+  f BIG, where f has a RULE+Then+ * We simplify BIG before trying the rule; but the rule does not fire+ * We inline f = \x. x True+ * So if we did preInlineUnconditionally we'd re-simplify (BIG True)++However, if BIG has /not/ already been simplified, we'd /like/ to+simplify BIG True; maybe good things happen.  That is why++* simplLam has+    - a case for (isSimplified dup), which goes via simplNonRecX, and+    - a case for the un-simplified case, which goes via simplNonRecE++* We go to some efforts to avoid unnecessarily simplifying ApplyToVal,+  in at least two places+    - In simplCast/addCoerce, where we check for isReflCo+    - In rebuildCall we avoid simplifying arguments before we have to+      (see Note [Trying rewrite rules])+++************************************************************************+*                                                                      *+                     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 ) True+  , Just env' <- preInlineUnconditionally env NotTopLevel bndr rhs env+  = do { tick (PreInlineUnconditionally bndr)+       ; simplExprF env' body cont }++   | otherwise+   = wrapJoinCont env cont $ \ env cont ->+     do { -- We push join_cont into the join RHS and the body;+          -- and wrap wrap_cont around the whole thing+        ; let mult   = contHoleScaling cont+              res_ty = contResultType cont+        ; (env1, bndr1)    <- simplNonRecJoinBndr env bndr mult res_ty+        ; (env2, bndr2)    <- addBndrRules env1 bndr bndr1 (BC_Join cont)+        ; (floats1, env3)  <- simplJoinBind env2 cont bndr bndr2 rhs env+        ; (floats2, body') <- simplExprF env3 body cont+        ; return (floats1 `addFloats` floats2, body') }+++------------------+simplRecJoinPoint :: SimplEnv -> [(InId, InExpr)]+                  -> InExpr -> SimplCont+                  -> SimplM (SimplFloats, OutExpr)+simplRecJoinPoint env pairs body cont+  = wrapJoinCont env cont $ \ env cont ->+    do { let bndrs  = map fst pairs+             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 cont) pairs+       ; (floats2, body') <- simplExprF env2 body cont+       ; return (floats1 `addFloats` floats2, body') }++--------------------+wrapJoinCont :: SimplEnv -> SimplCont+             -> (SimplEnv -> SimplCont -> SimplM (SimplFloats, OutExpr))+             -> SimplM (SimplFloats, OutExpr)+-- Deal with making the continuation duplicable if necessary,+-- and with the no-case-of-case situation.+wrapJoinCont env cont thing_inside+  | contIsStop cont        -- Common case; no need for fancy footwork+  = thing_inside env cont++  | not (sm_case_case (getMode env))+    -- See Note [Join points 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 -> Maybe JoinArity -> SimplCont -> SimplCont+-- Drop outer context from join point invocation (jump)+-- See Note [Join points and case-of-case]++trimJoinCont _ Nothing cont+  = cont -- Not a jump+trimJoinCont var (Just arity) cont+  = trim arity cont+  where+    trim 0 cont@(Stop {})+      = cont+    trim 0 cont+      = mkBoringStop (contResultType cont)+    trim n cont@(ApplyToVal { sc_cont = k })+      = cont { sc_cont = trim (n-1) k }+    trim n cont@(ApplyToTy { sc_cont = k })+      = cont { sc_cont = trim (n-1) k } -- join arity counts types!+    trim _ cont+      = pprPanic "completeCall" $ ppr var $$ ppr cont+++{- Note [Join points and case-of-case]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we perform the case-of-case transform (or otherwise push continuations+inward), we want to treat join points specially. Since they're always+tail-called and we want to maintain this invariant, we can do this (for any+evaluation context E):++  E[join j = e+    in case ... of+         A -> jump j 1+         B -> jump j 2+         C -> f 3]++    -->++  join j = E[e]+  in case ... of+       A -> jump j 1+       B -> jump j 2+       C -> E[f 3]++As is evident from the example, there are two components to this behavior:++  1. When entering the RHS of a join point, copy the context inside.+  2. When a join point is invoked, discard the outer context.++We need to be very careful here to remain consistent---neither part is+optional!++We need do make the continuation E duplicable (since we are duplicating it)+with 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+*                                                                      *+************************************************************************+-}++simplVar :: SimplEnv -> InVar -> SimplM OutExpr+-- Look up an InVar in the environment+simplVar 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++simplIdF :: SimplEnv -> InId -> SimplCont -> SimplM (SimplFloats, OutExpr)+simplIdF env var cont+  = case substId env var of+      ContEx tvs cvs ids e ->+          let env' = setSubstEnv env tvs cvs ids+          in simplExprF env' e cont+          -- Don't trim; haven't already simplified e,+          -- so the cont is not embodied in e++      DoneId var1 ->+          let cont' = trimJoinCont var (isJoinId_maybe var1) cont+          in completeCall env var1 cont'++      DoneEx e mb_join ->+          let env' = zapSubstEnv env+              cont' = trimJoinCont var mb_join cont+          in simplExprF env' e cont'+              -- Note [zapSubstEnv]+              -- ~~~~~~~~~~~~~~~~~~+              -- The template is already simplified, so don't re-substitute.+              -- This is VITAL.  Consider+              --      let x = e in+              --      let y = \z -> ...x... in+              --      \ x -> ...y...+              -- We'll clone the inner \x, adding x->x' in the id_subst+              -- Then when we inline y, we must *not* replace x by x' in+              -- the inlined copy!!++---------------------------------------------------------+--      Dealing with a call site++completeCall :: SimplEnv -> OutId -> SimplCont -> SimplM (SimplFloats, OutExpr)+completeCall env var cont+  | Just expr <- callSiteInline logger uf_opts case_depth var active_unf+                                lone_variable arg_infos interesting_cont+  -- Inline the variable's RHS+  = do { checkedTick (UnfoldingDone var)+       ; dump_inline expr cont+       ; let env1 = zapSubstEnv env+       ; simplExprF env1 expr cont }++  | otherwise+  -- Don't inline; instead rebuild the call+  = do { rule_base <- getSimplRules+       ; let rules = getRules rule_base var+             info = mkArgInfo env var rules+                              n_val_args call_cont+       ; rebuildCall env info cont }++  where+    uf_opts    = seUnfoldingOpts env+    case_depth = seCaseDepth env+    logger     = seLogger env+    (lone_variable, arg_infos, call_cont) = contArgs cont+    n_val_args       = length arg_infos+    interesting_cont = interestingCallContext env call_cont+    active_unf       = activeUnfolding (getMode env) var++    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])]++rebuildCall :: SimplEnv+            -> ArgInfo+            -> SimplCont+            -> SimplM (SimplFloats, OutExpr)+-- We decided not to inline, so+--    - simplify the arguments+--    - try rewrite rules+--    - and rebuild++---------- Bottoming applications --------------+rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_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++---------- Try rewrite RULES --------------+-- See Note [Trying rewrite rules]+rebuildCall env info@(ArgInfo { ai_fun = fun, ai_args = rev_args+                              , ai_rules = Just (nr_wanted, rules) }) cont+  | nr_wanted == 0 || no_more_args+  , let info' = info { ai_rules = Nothing }+  = -- We've accumulated a simplified call in <fun,rev_args>+    -- so try rewrite rules; see Note [RULES apply to simplified arguments]+    -- See also Note [Rules for recursive functions]+    do { mb_match <- tryRules env rules fun (reverse rev_args) cont+       ; case mb_match of+             Just (env', rhs, cont') -> simplExprF env' rhs cont'+             Nothing                 -> rebuildCall env info' cont }+  where+    no_more_args = case cont of+                      ApplyToTy  {} -> False+                      ApplyToVal {} -> False+                      _             -> True+++---------- Simplify applications and casts --------------+rebuildCall env info (CastIt co cont)+  = rebuildCall env (addCastTo info co) cont++rebuildCall env info (ApplyToTy { sc_arg_ty = arg_ty, sc_hole_ty = hole_ty, sc_cont = cont })+  = rebuildCall env (addTyArgTo info arg_ty hole_ty) cont++---------- The runRW# rule. Do this after absorbing all arguments ------+-- See Note [Simplification of runRW#] in GHC.CoreToSTG.Prep.+--+-- runRW# :: forall (r :: RuntimeRep) (o :: TYPE r). (State# RealWorld -> o) -> o+-- K[ runRW# rr ty body ]   -->   runRW rr' ty' (\s. K[ body s ])+rebuildCall env (ArgInfo { ai_fun = fun_id, ai_args = rev_args })+            (ApplyToVal { sc_arg = arg, sc_env = arg_se+                        , sc_cont = cont, sc_hole_ty = fun_ty })+  | fun_id `hasKey` runRWKey+  , not (contIsStop cont)  -- Don't fiddle around if the continuation is boring+  , [ TyArg {}, TyArg {} ] <- rev_args+  = do { s <- newId (fsLit "s") Many realWorldStatePrimTy+       ; let (m,_,_) = splitFunTy fun_ty+             env'  = (arg_se `setInScopeFromE` env) `addNewInScopeIds` [s]+             ty'   = contResultType cont+             cont' = ApplyToVal { sc_dup = Simplified, sc_arg = Var s+                                , sc_env = env', sc_cont = cont+                                , sc_hole_ty = mkVisFunTy m realWorldStatePrimTy ty' }+                     -- cont' applies to s, then K+       ; body' <- simplExprC env' arg cont'+       ; let arg'  = Lam s body'+             rr'   = getRuntimeRep ty'+             call' = mkApps (Var fun_id) [mkTyArg rr', mkTyArg ty', arg']+       ; return (emptyFloats env, call') }++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+  , sm_case_case (getMode env)+  = -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $+    simplExprF (arg_se `setInScopeFromE` env) arg+               (StrictArg { sc_fun = fun_info, sc_fun_ty = fun_ty+                          , sc_dup = Simplified+                          , sc_cont = cont })+                -- Note [Shadowing]++  -- 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' <- simplExprC (arg_se `setInScopeFromE` env) arg+                             (mkLazyArgStop arg_ty (lazyArgContext fun_info))+        ; rebuildCall env (addValArgTo fun_info  arg' fun_ty) cont }+  where+    arg_ty = funArgTy fun_ty+++---------- No further useful info, revert to generic rebuild ------------+rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args }) cont+  = rebuild env (argInfoExpr fun rev_args) cont++{- Note [Trying rewrite rules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider an application (f e1 e2 e3) where the e1,e2,e3 are not yet+simplified.  We want to simplify enough arguments to allow the rules+to apply, but it's more efficient to avoid simplifying e2,e3 if e1 alone+is sufficient.  Example: class ops+   (+) dNumInt e2 e3+If we rewrite ((+) dNumInt) to plusInt, we can take advantage of the+latter's strictness when simplifying e2, e3.  Moreover, suppose we have+  RULE  f Int = \x. x True++Then given (f Int e1) we rewrite to+   (\x. x True) e1+without simplifying e1.  Now we can inline x into its unique call site,+and absorb the True into it all in the same pass.  If we simplified+e1 first, we couldn't do that; see Note [Avoiding exponential behaviour].++So we try to apply rules if either+  (a) no_more_args: we've run out of argument that the rules can "see"+  (b) nr_wanted: none of the rules wants any more arguments+++Note [RULES apply to simplified arguments]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's very desirable to try RULES once the arguments have been simplified, because+doing so ensures that rule cascades work in one pass.  Consider+   {-# RULES g (h x) = k x+             f (k x) = x #-}+   ...f (g (h x))...+Then we want to rewrite (g (h x)) to (k x) and only then try f's rules. If+we match f's rules against the un-simplified RHS, it won't match.  This+makes a particularly big difference when superclass selectors are involved:+        op ($p1 ($p2 (df d)))+We want all this to unravel in one sweep.++Note [Avoid redundant simplification]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Because RULES apply to simplified arguments, there's a danger of repeatedly+simplifying already-simplified arguments.  An important example is that of+        (>>=) d e1 e2+Here e1, e2 are simplified before the rule is applied, but don't really+participate in the rule firing. So we mark them as Simplified to avoid+re-simplifying them.++Note [Shadowing]+~~~~~~~~~~~~~~~~+This part of the simplifier may break the no-shadowing invariant+Consider+        f (...(\a -> e)...) (case y of (a,b) -> e')+where f is strict in its second arg+If we simplify the innermost one first we get (...(\a -> e)...)+Simplifying the second arg makes us float the case out, so we end up with+        case y of (a,b) -> f (...(\a -> e)...) e'+So the output does not have the no-shadowing invariant.  However, there is+no danger of getting name-capture, because when the first arg was simplified+we used an in-scope set that at least mentioned all the variables free in its+static environment, and that is enough.++We can't just do innermost first, or we'd end up with a dual problem:+        case x of (a,b) -> f e (...(\a -> e')...)++I spent hours trying to recover the no-shadowing invariant, but I just could+not think of an elegant way to do it.  The simplifier is already knee-deep in+continuations.  We have to keep the right in-scope set around; AND we have+to get the effect that finding (error "foo") in a strict arg position will+discard the entire application and replace it with (error "foo").  Getting+all this at once is TOO HARD!+++************************************************************************+*                                                                      *+                Rewrite rules+*                                                                      *+************************************************************************+-}++tryRules :: SimplEnv -> [CoreRule]+         -> Id -> [ArgSpec]+         -> SimplCont+         -> SimplM (Maybe (SimplEnv, CoreExpr, SimplCont))++tryRules env rules fn args call_cont+  | null rules+  = return Nothing++{- Disabled until we fix #8326+  | fn `hasKey` tagToEnumKey   -- See Note [Optimising tagToEnum#]+  , [_type_arg, val_arg] <- args+  , Select dup bndr ((_,[],rhs1) : rest_alts) se cont <- call_cont+  , isDeadBinder bndr+  = do { let enum_to_tag :: CoreAlt -> CoreAlt+                -- Takes   K -> e  into   tagK# -> e+                -- where tagK# is the tag of constructor K+             enum_to_tag (DataAlt con, [], rhs)+               = assert (isEnumerationTyCon (dataConTyCon con) )+                (LitAlt tag, [], rhs)+              where+                tag = mkLitInt dflags (toInteger (dataConTag con - fIRST_TAG))+             enum_to_tag alt = pprPanic "tryRules: tagToEnum" (ppr alt)++             new_alts = (DEFAULT, [], rhs1) : map enum_to_tag rest_alts+             new_bndr = setIdType bndr intPrimTy+                 -- The binder is dead, but should have the right type+      ; return (Just (val_arg, Select dup new_bndr new_alts se cont)) }+-}++  | Just (rule, rule_rhs) <- lookupRule ropts (getUnfoldingInRuleMatch env)+                                        (activeRule (getMode env)) fn+                                        (argInfoAppArgs args) rules+  -- Fire a rule for the function+  = do { checkedTick (RuleFired (ruleName rule))+       ; let cont' = pushSimplifiedArgs zapped_env+                                        (drop (ruleArity rule) args)+                                        call_cont+                     -- (ruleArity rule) says how+                     -- many args the rule consumed++             occ_anald_rhs = occurAnalyseExpr rule_rhs+                 -- See Note [Occurrence-analyse after rule firing]+       ; dump rule rule_rhs+       ; return (Just (zapped_env, occ_anald_rhs, cont')) }+            -- The occ_anald_rhs and cont' are all Out things+            -- hence zapping the environment++  | otherwise  -- No rule fires+  = do { nodump  -- This ensures that an empty file is written+       ; return Nothing }++  where+    ropts      = initRuleOpts dflags+    dflags     = seDynFlags env+    logger     = seLogger env+    zapped_env = zapSubstEnv env  -- See Note [zapSubstEnv]++    printRuleModule rule+      = parens (maybe (text "BUILTIN")+                      (pprModuleName . moduleName)+                      (ruleModule rule))++    dump 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 "Before:" <+> hang (ppr fn) 2 (sep (map ppr args))+          , text "After: " <+> hang (pprCoreExpr rule_rhs) 2+                               (sep $ map ppr $ drop (ruleArity rule) args)+          , text "Cont:  " <+> ppr call_cont ]++      | logHasDumpFlag logger Opt_D_dump_rule_firings+      = log_rule Opt_D_dump_rule_firings "Rule fired:" $+          ftext (ruleName rule)+            <+> printRuleModule rule++      | otherwise+      = return ()++    nodump+      | 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+      = liftIO $ logDumpFile logger (mkDumpStyle alwaysQualify) flag "" FormatText+               $ sep [text hdr, nest 4 details]++trySeqRules :: SimplEnv+            -> OutExpr -> InExpr   -- Scrutinee and RHS+            -> SimplCont+            -> SimplM (Maybe (SimplEnv, CoreExpr, SimplCont))+-- See Note [User-defined RULES for seq]+trySeqRules in_env scrut rhs cont+  = do { rule_base <- getSimplRules+       ; tryRules in_env (getRules rule_base seqId) seqId out_args rule_cont }+  where+    no_cast_scrut = drop_casts scrut+    scrut_ty  = exprType no_cast_scrut+    seq_id_ty = idType seqId                    -- 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  = [ 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.++Possible improvement: occ-anal the rules when putting them in the+database; and in the simplifier just occ-anal the OutExpr arguments.+But that's more complicated and the rule RHS is usually tiny; so I'm+just doing the simple thing.++Historical note: previously we did occ-anal the rules in Rule.hs,+but failed to occ-anal the OutExpr arguments, which led to the+nasty performance problem described above.+++Note [Optimising tagToEnum#]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we have an enumeration data type:++  data Foo = A | B | C++Then we want to transform++   case tagToEnum# x of   ==>    case x of+     A -> e1                       DEFAULT -> e1+     B -> e2                       1#      -> e2+     C -> e3                       2#      -> e3++thereby getting rid of the tagToEnum# altogether.  If there was a DEFAULT+alternative we retain it (remember it comes first).  If not the case must+be exhaustive, and we reflect that in the transformed version by adding+a DEFAULT.  Otherwise Lint complains that the new case is not exhaustive.+See #8317.++Note [Rules for recursive functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+You might think that we shouldn't apply rules for a loop breaker:+doing so might give rise to an infinite loop, because a RULE is+rather like an extra equation for the function:+     RULE:           f (g x) y = x+y+     Eqn:            f a     y = a-y++But it's too drastic to disable rules for loop breakers.+Even the foldr/build rule would be disabled, because foldr+is recursive, and hence a loop breaker:+     foldr k z (build g) = g k z+So it's up to the programmer: rules can cause divergence+++************************************************************************+*                                                                      *+                Rebuilding a case expression+*                                                                      *+************************************************************************++Note [Case elimination]+~~~~~~~~~~~~~~~~~~~~~~~+The case-elimination transformation discards redundant case expressions.+Start with a simple situation:++        case x# of      ===>   let y# = x# in e+          y# -> e++(when x#, y# are of primitive type, of course).  We can't (in general)+do this for algebraic cases, because we might turn bottom into+non-bottom!++The code in 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/app invariant).+  This turns     case a +# b of r -> ...r...+  into           let r = a +# b in ...r...+  and thence     .....(a +# b)....++  However, if we have+      case indexArray# a i of r -> ...r...+  we might like to do the same, and inline the (indexArray# a i).+  But indexArray# is not okForSpeculation, so we don't build a let+  in rebuildCase (lest it get floated *out*), so the inlining doesn't+  happen either.  Annoying.++* Lifted case: we need to be sure that the expression is already+  evaluated (exprIsHNF).  If it's not already evaluated+      - we risk losing exceptions, divergence or+        user-specified thunk-forcing+      - even if 'e' is guaranteed to converge, we don't want to+        create a thunk (call by need) instead of evaluating it+        right away (call by value)++  However, we can turn the case into a /strict/ let if the 'r' is+  used strictly in the body.  Then we won't lose divergence; and+  we won't build a thunk because the let is strict.+  See also Note [Case-to-let for strictly-used binders]++Note [Case-to-let for strictly-used binders]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we have this:+   case <scrut> of r { _ -> ..r.. }++where 'r' is used strictly in (..r..), we can safely transform to+   let r = <scrut> in ...r...++This is a Good Thing, because 'r' might be dead (if the body just+calls error), or might be used just once (in which case it can be+inlined); or we might be able to float the let-binding up or down.+E.g. #15631 has an example.++Note that this can change the error behaviour.  For example, we might+transform+    case x of { _ -> error "bad" }+    --> error "bad"+which is might be puzzling if 'x' currently lambda-bound, but later gets+let-bound to (error "good").++Nevertheless, the paper "A semantics for imprecise exceptions" allows+this transformation. If you want to fix the evaluation order, use+'pseq'.  See #8900 for an example where the loss of this+transformation bit us in practice.++See also Note [Empty case alternatives] in 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 of an eval'd function] 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') <- simplNonRecX env case_bndr case_bndr_rhs+             -- scrut is a constructor application,+             -- hence satisfies let/app invariant+         ; (floats2, expr') <- simplExprF env' rhs cont+         ; case wfloats of+             [] -> return (floats1 `addFloats` floats2, expr')+             _ -> return+               -- See Note [FloatBinds from constructor wrappers]+                   ( emptyFloats env,+                     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+  , exprOkForSideEffects scrut+          -- The entire case is dead, so we can drop it+          -- if the scrutinee converges without having imperative+          -- side effects or raising a Haskell exception+          -- See Note [PrimOp can_fail and has_side_effects] in GHC.Builtin.PrimOps+   = simplExprF env rhs cont++  -- 2b.  Turn the case into a let, if+  --      a) it binds only the case-binder+  --      b) unlifted case: the scrutinee is ok-for-speculation+  --           lifted case: the scrutinee is in HNF (or will later be demanded)+  -- See Note [Case to let transformation]+  | all_dead_bndrs+  , doCaseToLet scrut case_bndr+  = do { tick (CaseElim case_bndr)+       ; (floats1, env') <- simplNonRecX env case_bndr scrut+       ; (floats2, expr') <- simplExprF env' rhs cont+       ; return (floats1 `addFloats` floats2, expr') }++  -- 2c. Try the seq rules if+  --     a) it binds only the case binder+  --     b) a rule for seq applies+  -- See Note [User-defined RULES for seq] in GHC.Types.Id.Make+  | is_plain_seq+  = do { mb_rule <- trySeqRules env scrut rhs cont+       ; case mb_rule of+           Just (env', rule_rhs, cont') -> simplExprF env' rule_rhs cont'+           Nothing                      -> reallyRebuildCase env scrut case_bndr alts cont }+  where+    all_dead_bndrs = all isDeadBinder bndrs       -- bndrs are [InId]+    is_plain_seq   = all_dead_bndrs && isDeadBinder case_bndr -- Evaluation *only* for effect++rebuildCase env scrut case_bndr alts cont+  = reallyRebuildCase env scrut case_bndr alts cont+++doCaseToLet :: OutExpr          -- Scrutinee+            -> InId             -- Case binder+            -> Bool+-- The situation is         case scrut of b { DEFAULT -> body }+-- Can we transform thus?   let { b = scrut } in body+doCaseToLet scrut case_bndr+  | isTyCoVar case_bndr    -- Respect GHC.Core+  = isTyCoArg scrut        -- Note [Core type and coercion invariant]++  | isUnliftedType (idType case_bndr)+    -- OK to call isUnliftedType: scrutinees always have a fixed RuntimeRep (see FRRCase)+  = exprOkForSpeculation scrut++  | otherwise  -- Scrut has a lifted type+  = exprIsHNF scrut+    || isStrUsedDmd (idDemandInfo case_bndr)+    -- See Note [Case-to-let for strictly-used binders]++--------------------------------------------------+--      3. Catch-all case+--------------------------------------------------++reallyRebuildCase env scrut case_bndr alts cont+  | not (sm_case_case (getMode env))+  = do { case_expr <- simplAlts env scrut case_bndr alts+                                (mkBoringStop (contHoleType cont))+       ; rebuild env case_expr cont }++  | otherwise+  = do { (floats, 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 [Case alternative occ info]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we are simply reconstructing a case (the common case), we always+zap the occurrence info on the binders in the alternatives.  Even+if the case binder is dead, the scrutinee is usually a variable, and *that*+can bring the case-alternative binders back to life.+See Note [Add unfolding for scrutinee]++Note [Improving seq]+~~~~~~~~~~~~~~~~~~~+Consider+        type family F :: * -> *+        type instance F Int = Int++We'd like to transform+        case e of (x :: F Int) { DEFAULT -> rhs }+===>+        case e `cast` co of (x'::Int)+           I# x# -> let x = x' `cast` sym co+                    in rhs++so that 'rhs' can take advantage of the form of x'.  Notice that Note+[Case of cast] (in OccurAnal) may then apply to the result.++We'd also like to eliminate empty types (#13468). So if++    data Void+    type instance F Bool = Void++then we'd like to transform+        case (x :: F Bool) of { _ -> error "urk" }+===>+        case (x |> co) of (x' :: Void) of {}++Nota Bene: we used to have a built-in rule for 'seq' that dropped+casts, so that+    case (x |> co) of { _ -> blah }+dropped the cast; in order to improve the chances of trySeqRules+firing.  But that works in the /opposite/ direction to Note [Improving+seq] so there's a danger of flip/flopping.  Better to make trySeqRules+insensitive to the cast, which is now is.++The need for [Improving seq] showed up in Roman's experiments.  Example:+  foo :: F Int -> Int -> Int+  foo t n = t `seq` bar n+     where+       bar 0 = 0+       bar n = bar (n - case t of TI i -> i)+Here we'd like to avoid repeated evaluating t inside the loop, by+taking advantage of the `seq`.++At one point I did transformation in LiberateCase, but it's more+robust here.  (Otherwise, there's a danger that we'll simply drop the+'seq' altogether, before LiberateCase gets to see it.)++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 <- getFamEnvs+        ; (alt_env', scrut', case_bndr') <- improveSeq fam_envs env2 scrut+                                                       case_bndr case_bndr2 alts++        ; (imposs_deflt_cons, in_alts) <- prepareAlts scrut' case_bndr' alts+          -- NB: it's possible that the returned in_alts is empty: this is handled+          -- by the caller (rebuildCase) in the missingAlt function++        ; alts' <- mapM (simplAlt alt_env' (Just scrut') imposs_deflt_cons case_bndr' cont') in_alts+--      ; pprTrace "simplAlts" (ppr case_bndr $$ ppr alts $$ ppr cont') $ return ()++        ; let alts_ty' = contResultType cont'+        -- See Note [Avoiding space leaks in OutType]+        ; seqType alts_ty' `seq`+          mkCase (seDynFlags env0) scrut' case_bndr' alts_ty' alts' }+++------------------------------------+improveSeq :: (FamInstEnv, FamInstEnv) -> SimplEnv+           -> OutExpr -> InId -> OutId -> [InAlt]+           -> SimplM (SimplEnv, OutExpr, OutId)+-- Note [Improving seq]+improveSeq fam_envs env scrut case_bndr case_bndr1 [Alt DEFAULT _ _]+  | Just (Reduction co ty2) <- topNormaliseType_maybe fam_envs (idType case_bndr1)+  = do { case_bndr2 <- newId (fsLit "nt") Many ty2+        ; let rhs  = DoneEx (Var case_bndr2 `Cast` mkSymCo co) Nothing+              env2 = extendIdSubst env case_bndr rhs+        ; return (env2, scrut `Cast` co, case_bndr2) }++improveSeq _ env scrut _ case_bndr1 _+  = return (env, scrut, case_bndr1)+++------------------------------------+simplAlt :: SimplEnv+         -> Maybe OutExpr  -- The scrutinee+         -> [AltCon]       -- These constructors can't be present when+                           -- matching the DEFAULT alternative+         -> OutId          -- The case binder+         -> SimplCont+         -> InAlt+         -> SimplM OutAlt++simplAlt env _ imposs_deflt_cons case_bndr' cont' (Alt DEFAULT bndrs rhs)+  = assert (null bndrs) $+    do  { let env' = addBinderUnfolding env case_bndr'+                                        (mkOtherCon imposs_deflt_cons)+                -- Record the constructors that the case-binder *can't* be.+        ; rhs' <- simplExprC env' rhs cont'+        ; return (Alt DEFAULT [] rhs') }++simplAlt env scrut' _ case_bndr' cont' (Alt (LitAlt lit) bndrs rhs)+  = assert (null bndrs) $+    do  { env' <- addAltUnfoldings env scrut' case_bndr' (Lit lit)+        ; rhs' <- simplExprC env' rhs cont'+        ; return (Alt (LitAlt lit) [] rhs') }++simplAlt env scrut' _ case_bndr' cont' (Alt (DataAlt con) vs rhs)+  = do  { -- See Note [Adding evaluatedness info to pattern-bound variables]+          let vs_with_evals = addEvals scrut' con vs+        ; (env', vs') <- simplBinders env vs_with_evals++                -- Bind the case-binder to (con args)+        ; let inst_tys' = tyConAppArgs (idType case_bndr')+              con_app :: OutExpr+              con_app   = mkConApp2 con inst_tys' vs'++        ; env'' <- addAltUnfoldings env' scrut' case_bndr' con_app+        ; rhs' <- simplExprC env'' rhs cont'+        ; return (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 [Data-con worker strictness] in GHC.Core.DataCon++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.Core.Opt.ConstantFold.  Example (#15226):++  case seq# v s of+    (# s', v' #) -> E++we want the compiler to be aware that v' is in WHNF in E.++Open problem: we don't record that v itself is in WHNF (and we can't+do it here).  The right thing is to do some kind of binder-swap;+see #15226 for discussion.+-}++addEvals :: Maybe OutExpr -> DataCon -> [Id] -> [Id]+-- See Note [Adding evaluatedness info to pattern-bound variables]+addEvals scrut con vs+  -- Deal with seq# applications+  | Just scr <- scrut+  , 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+  , Just SeqOp <- isPrimOpId_maybe f+  , let x' = zapIdOccInfoAndSetEvald MarkedStrict x+  = [s, x']++  -- Deal with banged datacon fields+addEvals _scrut con vs = go vs the_strs+    where+      the_strs = dataConRepStrictness con++      go [] [] = []+      go (v:vs') strs | isTyVar v = v : go vs' strs+      go (v:vs') (str:strs) = zapIdOccInfoAndSetEvald str v : go vs' strs+      go _ _ = pprPanic "Simplify.addEvals"+                (ppr con $$+                 ppr vs  $$+                 ppr_with_length (map strdisp the_strs) $$+                 ppr_with_length (dataConRepArgTys con) $$+                 ppr_with_length (dataConRepStrictness con))+        where+          ppr_with_length list+            = ppr list <+> parens (text "length =" <+> ppr (length list))+          strdisp MarkedStrict = text "MarkedStrict"+          strdisp NotMarkedStrict = text "NotMarkedStrict"++zapIdOccInfoAndSetEvald :: StrictnessMark -> Id -> Id+zapIdOccInfoAndSetEvald str v =+  setCaseBndrEvald str $ -- Add eval'dness info+  zapIdOccInfo v         -- And kill occ info;+                         -- see Note [Case alternative occ info]++addAltUnfoldings :: SimplEnv -> Maybe OutExpr -> OutId -> OutExpr -> SimplM SimplEnv+addAltUnfoldings env scrut case_bndr con_app+  = do { let con_app_unf = mk_simple_unf con_app+             env1 = addBinderUnfolding env case_bndr con_app_unf++             -- See Note [Add unfolding for scrutinee]+             env2 | Many <- idMult case_bndr = case scrut of+                      Just (Var v)           -> addBinderUnfolding env1 v con_app_unf+                      Just (Cast (Var v) co) -> addBinderUnfolding env1 v $+                                                mk_simple_unf (Cast con_app (mkSymCo co))+                      _                      -> env1+                  | otherwise = env1++       ; traceSmpl "addAltUnf" (vcat [ppr case_bndr <+> ppr scrut, ppr con_app])+       ; return env2 }+  where+    -- 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/app invariant.  Example+    case e of b { DEFAULT -> let v = reallyUnsafePtrEquality# b y in ....+                ; K       -> blah }++The let/app 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.++Exactly the same issue arises in GHC.Core.Opt.SpecConstr;+see Note [Add scrutinee to ValueEnv too] in GHC.Core.Opt.SpecConstr++HOWEVER, given+  case x of y { Just a -> r1; Nothing -> r2 }+we do not want to add the unfolding x -> y to 'x', which might seem cool,+since 'y' itself has different unfoldings in r1 and r2.  Reason: if we+did that, we'd have to zap y's deadness info and that is a very useful+piece of information.++So instead we add the unfolding x -> Just a, and x -> Nothing in the+respective RHSs.++Since this transformation is tantamount to a binder swap, the same caveat as in+Note [Suppressing binder-swaps on linear case] in OccurAnal apply.+++************************************************************************+*                                                                      *+\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+             -- Note that the binder might be "dead", because it doesn't+             -- occur in the RHS; and simplNonRecX may therefore discard+             -- it via postInlineUnconditionally.+             -- Nevertheless we must keep it if the case-binder is alive,+             -- because it may be used in the con_app.  See Note [knownCon occ info]+           ; (floats1, env2) <- simplNonRecX env' b' arg  -- arg satisfies let/app invariant+           ; (floats2, env3)  <- bind_args env2 bs' args+           ; return (floats1 `addFloats` floats2, env3) }++    bind_args _ _ _ =+      pprPanic "bind_args" $ ppr dc $$ ppr bs $$ ppr dc_args $$+                             text "scrut:" <+> ppr scrut++       -- It's useful to bind bndr to scrut, rather than to a fresh+       -- binding      x = Con arg1 .. argn+       -- because very often the scrut is a variable, so we avoid+       -- creating, and then subsequently eliminating, a let-binding+       -- BUT, if scrut is a not a variable, we must be careful+       -- about duplicating the arg redexes; in that case, make+       -- a new con-app from the args+    bind_case_bndr env+      | isDeadBinder bndr   = return (emptyFloats env, env)+      | exprIsTrivial scrut = return (emptyFloats env+                                     , extendIdSubst env bndr (DoneEx scrut Nothing))+                              -- See Note [Do not duplicate constructor applications]+      | otherwise           = do { dc_args <- mapM (simplVar 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+                                 ; simplNonRecX env bndr con_app }++-------------------+missingAlt :: SimplEnv -> Id -> [InAlt] -> SimplCont+           -> SimplM (SimplFloats, OutExpr)+                -- This isn't strictly an error, although it is unusual.+                -- It's possible that the simplifier might "see" that+                -- an inner case has no accessible alternatives before+                -- it "sees" that the entire branch of an outer case is+                -- inaccessible.  So we simply put an error case here instead.+missingAlt env case_bndr _ cont+  = 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)++{-+************************************************************************+*                                                                      *+\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 env (repeat topDmd) cont++mkDupableContWithDmds+   :: SimplEnv  -> [Demand]  -- Demands on arguments; always infinite+   -> SimplCont -> SimplM ( SimplFloats, SimplCont)++mkDupableContWithDmds env _ cont+  | contIsDupable cont+  = return (emptyFloats env, cont)++mkDupableContWithDmds _ _ (Stop {}) = panic "mkDupableCont"     -- Handled by previous eqn++mkDupableContWithDmds env dmds (CastIt ty cont)+  = do  { (floats, cont') <- mkDupableContWithDmds env dmds cont+        ; return (floats, CastIt ty cont') }++-- 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_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) <- simplLam sb_env1 body cont+          -- No need to use mkDupableCont before simplLam; we+          -- use cont once here, and then share the result if necessary++       ; let join_body = wrapFloats floats1 join_inner+             res_ty    = contResultType cont++       ; 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))+  , thumbsUpPlanA cont  -- See point (3) of Note [Duplicating join points]+  = -- Use Plan A of Note [Duplicating StrictArg]+    do { let (_ : dmds) = 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 (CastIt _ k)                 = thumbsUpPlanA k+    thumbsUpPlanA (TickIt _ k)                 = thumbsUpPlanA k+    thumbsUpPlanA (ApplyToVal { sc_cont = k }) = thumbsUpPlanA k+    thumbsUpPlanA (ApplyToTy  { sc_cont = k }) = thumbsUpPlanA k+    thumbsUpPlanA (Select {})                  = True+    thumbsUpPlanA (StrictBind {})              = True+    thumbsUpPlanA (Stop {})                    = True++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:_) = dmds   -- Never fails+        ; (floats1, cont') <- mkDupableContWithDmds env dmds cont+        ; let env' = env `setInScopeFromF` floats1+        ; (_, se', arg') <- simplArg env' dup 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' <- mapM (simplAlt alt_env' Nothing [] case_bndr' alt_cont) (scaleAltsBy cont_scaling alts)+        -- Safe to say that there are no handled-cons for the DEFAULT case+                -- NB: simplBinder does not zap deadness occ-info, so+                -- a dead case_bndr' will still advertise its deadness+                -- This is really important because in+                --      case e of b { (# p,q #) -> ... }+                -- b is always dead, and indeed we are not allowed to bind b to (# p,q #),+                -- which might happen if e was an explicit unboxed pair and b wasn't marked dead.+                -- In the new alts we build, we have the new case binder, so it must retain+                -- its deadness.+        -- NB: we don't use alt_env further; it has the substEnv for+        --     the alternatives, and we don't want that++        ; (join_floats, alts'') <- mapAccumLM (mkDupableAlt (targetPlatform (seDynFlags env)) case_bndr')+                                              emptyJoinFloats alts'++        ; let all_floats = floats `addJoinFloats` join_floats+                           -- Note [Duplicated env]+        ; return (all_floats+                 , Select { sc_dup  = OkToDup+                          , sc_bndr = case_bndr'+                          , sc_alts = alts''+                          , sc_env  = zapSubstEnv se `setInScopeFromF` all_floats+                                      -- See Note [StaticEnv invariant] in 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+  | exprIsTrivial join_rhs   -- See point (2) of Note [Duplicating join points]+  = return (emptyFloats env+           , StrictBind { sc_bndr = arg_bndr+                        , sc_body = join_rhs+                        , sc_env  = zapSubstEnv env+                          -- 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 = Nothing, 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 :: Platform -> OutId+             -> JoinFloats -> OutAlt+             -> SimplM (JoinFloats, OutAlt)+mkDupableAlt _platform case_bndr jfloats (Alt con alt_bndrs alt_rhs_in)+  | exprIsTrivial alt_rhs_in   -- See point (2) 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_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 [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 x y).  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`.   In contrast, if we /don't/ inline $j we+don't need a 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.++To achieve this:++1. Do not postInlineUnconditionally a join point, until the Final+   phase.  (The Final phase is still quite early, so we might consider+   delaying still more.)++2. In mkDupableAlt and mkDupableStrictBind, generate an alterative for+   all alternatives, except for exprIsTrival RHSs. Previously we used+   exprIsDupable.  This generates a lot more join points, but makes+   them much more case-of-case friendly.++   It is definitely worth checking for exprIsTrivial, otherwise we get+   an extra Simplifier iteration, because it is inlined in the next+   round.++3. 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.  That same Note explains why we+   want Plan A when the RHS of the new join point would be a+   non-data-constructor application++4. You might worry that $j will be inlined by the call-site inliner,+   but it won't because the call-site context for a join is usually+   extremely boring (the arguments come from the pattern match).+   And if not, then perhaps inlining it would be a good idea.++   You might also wonder if we get UnfWhen, because the RHS of the+   join point is no bigger than the call. But in the cases we care+   about it will be a little bigger, because of that free `f` in+       $j x = K f x+   So for now we don't do anything special in callSiteInline++There is a bit of tension between (2) and (3).  Do we want to retain+the join point only when the RHS is+* a constructor application? or+* just non-trivial?+Currently, a bit ad-hoc, but we definitely want to retain the join+point for data constructors in mkDupalbleALt (point 2); that is the+whole point of #19996 described above.++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. 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.++Here is another example.+        && E (case x of { T -> F; F -> T })++Pushing the call inward (being careful not to duplicate E)+        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.++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+  | isExitJoinId id+  = return noUnfolding -- See Note [Do not inline exit join points] in GHC.Core.Opt.Exitify+  | otherwise+  = -- Otherwise, we end up retaining all the SimpleEnv+    let !opts = seUnfoldingOpts env+    in mkLetUnfolding opts (bindContextLevel bind_cxt) InlineRhs id new_rhs++-------------------+mkLetUnfolding :: UnfoldingOpts -> TopLevelFlag -> UnfoldingSource+               -> InId -> OutExpr -> SimplM Unfolding+mkLetUnfolding !uf_opts top_lvl src id new_rhs+  = return (mkUnfolding uf_opts src is_top_lvl is_bottoming new_rhs)+            -- We make an  unfolding *even for loop-breakers*.+            -- Reason: (a) It might be useful to know that they are WHNF+            --         (b) In 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+    -- 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 {} -> -- Binder is not a join point+                                        do { expr' <- simplExprC unf_env expr (mkBoringStop rhs_ty)+                                           ; return (eta_expand expr') }+              ; case guide of+                  UnfWhen { ug_arity = arity+                          , ug_unsat_ok = sat_ok+                          , ug_boring_ok = boring_ok+                          }+                          -- Happens for INLINE things+                        -- Really important to force new_boring_ok as otherwise+                        -- `ug_boring_ok` is a thunk chain of+                        -- inlineBoringExprOk expr0+                        --  || inlineBoringExprOk expr1 || ...+                        --  See #20134+                     -> let !new_boring_ok = boring_ok || inlineBoringOk expr'+                            guide' =+                              UnfWhen { ug_arity = arity+                                      , ug_unsat_ok = sat_ok+                                      , 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' guide')+                            -- See Note [Top-level flag on inline rules] in GHC.Core.Unfold++                  _other              -- Happens for INLINABLE things+                     -> mkLetUnfolding uf_opts top_lvl src id expr' }+                -- If the guidance is UnfIfGoodArgs, this is an INLINABLE+                -- unfolding, and we need to make sure the guidance is kept up+                -- to date with respect to any changes in the unfolding.++        | otherwise -> return noUnfolding   -- Discard unstable unfoldings+  where+    uf_opts    = seUnfoldingOpts env+    -- 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]+    eta_expand expr+      | not eta_on         = expr+      | exprIsTrivial expr = expr+      | otherwise          = etaExpandAT (getInScope env) id_arity expr+    eta_on = sm_eta_expand (getMode env)++{- 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 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 [Do not eta-expand trivial expressions]+  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]+                 fn_name' = case mb_new_id of+                              Just id -> idName id+                              Nothing -> fn_name++                 -- join_ok is an assertion check that the join-arity of the+                 -- binder matches that of the rule, so that pushing the+                 -- continuation into the RHS makes sense+                 join_ok = case mb_new_id of+                             Just id | Just join_arity <- isJoinId_maybe id+                                     -> length args == join_arity+                             _ -> False+                 bad_join_msg = vcat [ ppr mb_new_id, ppr rule+                                     , ppr (fmap isJoinId_maybe mb_new_id) ]++           ; args' <- mapM (simplExpr lhs_env) args+           ; rhs'  <- simplExprC rhs_env rhs rhs_cont+           ; return (rule { ru_bndrs = bndrs'+                          , ru_fn    = fn_name'+                          , ru_args  = args'+                          , ru_rhs   = rhs' }) }++{- 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/Env.hs view
@@ -4,8 +4,8 @@ \section[GHC.Core.Opt.Simplify.Monad]{The simplifier Monad} -} -{-# LANGUAGE CPP #-} + module GHC.Core.Opt.Simplify.Env (         -- * The simplifier mode         setMode, getMode, updMode, seDynFlags, seUnfoldingOpts, seLogger,@@ -29,7 +29,7 @@         substCo, substCoVar,          -- * Floats-        SimplFloats(..), emptyFloats, mkRecFloats,+        SimplFloats(..), emptyFloats, isEmptyFloats, mkRecFloats,         mkFloatBind, addLetFloats, addJoinFloats, addFloats,         extendFloats, wrapFloats,         doFloatFromRhs, getTopFloatBinds,@@ -43,8 +43,6 @@         wrapJoinFloats, wrapJoinFloatsX, unitJoinFloat, addJoinFlts     ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Core.Opt.Simplify.Monad@@ -70,6 +68,7 @@ import GHC.Utils.Monad import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Utils.Misc import GHC.Utils.Logger import GHC.Types.Unique.FM      ( pprUniqFM )@@ -140,6 +139,13 @@                 , 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@@ -336,17 +342,17 @@ --------------------- extendIdSubst :: SimplEnv -> Id -> SimplSR -> SimplEnv extendIdSubst env@(SimplEnv {seIdSubst = subst}) var res-  = ASSERT2( isId var && not (isCoVar var), ppr var )+  = 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-  = ASSERT2( isTyVar var, ppr var $$ ppr 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 )+  = assert (isCoVar var) $     env {seCvSubst = extendVarEnv csubst var co}  ---------------------@@ -486,7 +492,7 @@  doFloatFromRhs :: TopLevelFlag -> RecFlag -> Bool -> SimplFloats -> OutExpr -> Bool -- If you change this function look also at FloatIn.noFloatFromRhs-doFloatFromRhs lvl rec str (SimplFloats { sfLetFloats = LetFloats fs ff }) rhs+doFloatFromRhs lvl rec strict_bind (SimplFloats { sfLetFloats = LetFloats fs ff }) rhs   =  not (isNilOL fs) && want_to_float && can_float   where      want_to_float = isTopLevel lvl || exprIsCheap rhs || exprIsExpandable rhs@@ -494,7 +500,7 @@      can_float = case ff of                    FltLifted  -> True                    FltOkSpec  -> isNotTopLevel lvl && isNonRec rec-                   FltCareful -> isNotTopLevel lvl && isNonRec rec && str+                   FltCareful -> isNotTopLevel lvl && isNonRec rec && strict_bind  {- Note [Float when cheap or expandable]@@ -516,7 +522,7 @@  unitLetFloat :: OutBind -> LetFloats -- This key function constructs a singleton float with the right form-unitLetFloat bind = ASSERT(all (not . isJoinId) (bindersOf bind))+unitLetFloat bind = assert (all (not . isJoinId) (bindersOf bind)) $                     LetFloats (unitOL bind) (flag bind)   where     flag (Rec {})                = FltLifted@@ -526,12 +532,14 @@           -- 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                = ASSERT2( not (isUnliftedType (idType bndr)), ppr bndr )+      | otherwise                = assertPpr (not (isUnliftedType (idType bndr))) (ppr bndr)+                                   -- NB: binders always have a fixed RuntimeRep, so calling+                                   -- isUnliftedType is OK here                                    FltCareful       -- Unlifted binders can only be let-bound if exprOkForSpeculation holds  unitJoinFloat :: OutBind -> JoinFloats-unitJoinFloat bind = ASSERT(all isJoinId (bindersOf bind))+unitJoinFloat bind = assert (all isJoinId (bindersOf bind)) $                      unitOL bind  mkFloatBind :: SimplEnv -> OutBind -> (SimplFloats, SimplEnv)@@ -577,11 +585,14 @@ -- Add the let-floats for env2 to env1; -- *plus* the in-scope set for env2, which is bigger -- than that for env1-addLetFloats floats let_floats@(LetFloats binds _)+addLetFloats floats let_floats   = floats { sfLetFloats = sfLetFloats floats `addLetFlts` let_floats-           , sfInScope   = foldlOL extendInScopeSetBind-                                   (sfInScope floats) binds }+           , 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@@ -618,7 +629,7 @@ mkRecFloats floats@(SimplFloats { sfLetFloats  = LetFloats bs _ff                                 , sfJoinFloats = jbs                                 , sfInScope    = in_scope })-  = ASSERT2( isNilOL bs || isNilOL jbs, ppr floats )+  = assertPpr (isNilOL bs || isNilOL jbs) (ppr floats) $     SimplFloats { sfLetFloats  = floats'                 , sfJoinFloats = jfloats'                 , sfInScope    = in_scope }@@ -654,7 +665,7 @@ getTopFloatBinds :: SimplFloats -> [CoreBind] getTopFloatBinds (SimplFloats { sfLetFloats  = lbs                               , sfJoinFloats = jbs})-  = ASSERT( isNilOL jbs )  -- Can't be any top-level join bindings+  = assert (isNilOL jbs) $  -- Can't be any top-level join bindings     letFloatBinds lbs  {-# INLINE mapLetFloats #-}@@ -786,7 +797,7 @@ -- Recursive let binders simplRecBndrs env@(SimplEnv {}) ids   -- See Note [Bangs in the Simplifier]-  = ASSERT(all (not . isJoinId) ids)+  = assert (all (not . isJoinId) ids) $     do  { let (!env1, ids1) = mapAccumL substIdBndr env ids         ; seqIds ids1 `seq` return env1 } @@ -832,7 +843,7 @@               -> (SimplEnv, OutBndr) subst_id_bndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst })               old_id adjust_type-  = ASSERT2( not (isCoVar old_id), ppr old_id )+  = 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@@ -933,7 +944,7 @@ -- 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)+  = assert (all isJoinId ids) $     do  { let (env1, ids1) = mapAccumL (simplJoinBndr mult res_ty) env ids         ; seqIds ids1 `seq` return env1 } @@ -960,7 +971,7 @@ -- 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 )+  = assert (isJoinId join_id) $     setIdType join_id new_join_ty   where     orig_ar = idJoinArity join_id
GHC/Core/Opt/Simplify/Monad.hs view
@@ -28,7 +28,8 @@ import GHC.Types.Id.Info   ( IdDetails(..), vanillaIdInfo, setArityInfo ) import GHC.Core.Type       ( Type, Mult ) import GHC.Core.FamInstEnv ( FamInstEnv )-import GHC.Core            ( RuleEnv(..) )+import GHC.Core            ( RuleEnv(..), RuleBase)+import GHC.Core.Rules import GHC.Core.Utils      ( mkLamTypes ) import GHC.Core.Coercion.Opt import GHC.Types.Unique.Supply@@ -79,20 +80,23 @@   = STE { st_flags     :: DynFlags         , st_logger    :: !Logger         , st_max_ticks :: IntWithInf  -- ^ Max #ticks in this simplifier run-        , st_rules     :: RuleEnv+        , st_query_rulebase :: IO RuleBase+          -- ^ The action to retrieve an up-to-date EPS RuleBase+          -- See Note [Overall plumbing for rules]+        , st_mod_rules :: RuleEnv         , st_fams      :: (FamInstEnv, FamInstEnv)          , st_co_opt_opts :: !OptCoercionOpts             -- ^ Coercion optimiser options         } -initSmpl :: Logger -> DynFlags -> RuleEnv -> (FamInstEnv, FamInstEnv)+initSmpl :: Logger -> DynFlags -> IO RuleBase -> RuleEnv -> (FamInstEnv, FamInstEnv)          -> Int                 -- Size of the bindings, used to limit                                 -- the number of ticks we allow          -> SimplM a          -> IO (a, SimplCount) -initSmpl logger dflags rules fam_envs size m+initSmpl logger dflags qrb rules fam_envs size m   = do -- No init count; set to 0        let simplCount = zeroSimplCount dflags        (result, count) <- unSM m env simplCount@@ -100,7 +104,8 @@   where     env = STE { st_flags = dflags               , st_logger = logger-              , st_rules = rules+              , st_query_rulebase = qrb+              , st_mod_rules = rules               , st_max_ticks = computeMaxTicks dflags size               , st_fams = fam_envs               , st_co_opt_opts = initOptCoercionOpts dflags@@ -169,9 +174,8 @@  traceSmpl :: String -> SDoc -> SimplM () traceSmpl herald doc-  = do dflags <- getDynFlags-       logger <- getLogger-       liftIO $ Logger.dumpIfSet_dyn logger dflags Opt_D_dump_simpl_trace "Simpl Trace"+  = 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]@@ -204,7 +208,9 @@       return (x, sc)  getSimplRules :: SimplM RuleEnv-getSimplRules = SM (\st_env sc -> return (st_rules st_env, sc))+getSimplRules = SM (\st_env sc -> do+    eps_rules <- st_query_rulebase st_env+    return (extendRuleEnv (st_mod_rules st_env) eps_rules, sc))  getFamEnvs :: SimplM (FamInstEnv, FamInstEnv) getFamEnvs = SM (\st_env sc -> return (st_fams st_env, sc))@@ -216,6 +222,7 @@ newId fs w ty = do uniq <- getUniqueM                    return (mkSysLocalOrCoVar fs uniq 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@@ -224,7 +231,7 @@              arity      = count isId bndrs              -- arity: See Note [Invariants on join points] invariant 2b, in GHC.Core              join_arity = length bndrs-             details    = JoinId join_arity+             details    = JoinId join_arity Nothing              id_info    = vanillaIdInfo `setArityInfo` arity --                                        `setOccInfo` strongLoopBreaker
GHC/Core/Opt/Simplify/Utils.hs view
@@ -4,8 +4,8 @@ The simplifier utilities -} -{-# LANGUAGE CPP #-} + module GHC.Core.Opt.Simplify.Utils (         -- Rebuilding         mkLam, mkCase, prepareAlts, tryEtaExpandRhs,@@ -16,6 +16,9 @@         getUnfoldingInRuleMatch,         simplEnvForGHCi, updModeForStableUnfoldings, updModeForRules, +        -- The BindContext type+        BindContext(..), bindContextLevel,+         -- The continuation type         SimplCont(..), DupFlag(..), StaticEnv,         isSimplified, contIsStop,@@ -37,15 +40,14 @@         isExitJoinId     ) where -#include "HsVersions.h"- import GHC.Prelude -import GHC.Core.Opt.Simplify.Env-import GHC.Core.Opt.Monad        ( SimplMode(..), Tick(..) ) import GHC.Driver.Session-import GHC.Driver.Ppr+ import GHC.Core+import GHC.Types.Literal ( isLitRubbish )+import GHC.Core.Opt.Simplify.Env+import GHC.Core.Opt.Monad        ( SimplMode(..), Tick(..) ) import qualified GHC.Core.Subst import GHC.Core.Ppr import GHC.Core.TyCo.Ppr ( pprParendType )@@ -54,34 +56,57 @@ 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.Var import GHC.Types.Demand import GHC.Types.Var.Set import GHC.Types.Basic-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.Utils.Misc+ 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.Logger import GHC.Utils.Panic-import GHC.Core.Opt.ConstantFold-import GHC.Data.FastString ( fsLit )+import GHC.Utils.Panic.Plain+import GHC.Utils.Trace  import Control.Monad    ( when ) import Data.List        ( sortBy ) -{--************************************************************************+{- ********************************************************************* *                                                                      *+                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+      SimplCont            -- See Note [Rules and unfolding for join points]+                           -- in GHC.Core.Opt.Simplify++bindContextLevel :: BindContext -> TopLevelFlag+bindContextLevel (BC_Let top_lvl _) = top_lvl+bindContextLevel (BC_Join {})       = NotTopLevel+++{- *********************************************************************+*                                                                      *                 The SimplCont and DupFlag types *                                                                      * ************************************************************************@@ -127,7 +152,7 @@   | 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/Val]+                                -- See Note [The hole type in ApplyToTy]       , sc_arg  :: InExpr       -- The argument,       , sc_env  :: StaticEnv    -- see Note [StaticEnv invariant]       , sc_cont :: SimplCont }@@ -135,7 +160,7 @@   | 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/Val]+                                  -- See Note [The hole type in ApplyToTy]       , sc_cont    :: SimplCont }    | Select             -- (Select alts K)[e] = K[ case e of alts ]@@ -146,11 +171,10 @@       , sc_cont :: SimplCont }    -- The two strict forms have no DupFlag, because we never duplicate them-  | StrictBind          -- (StrictBind x xs b K)[e] = let x = e in K[\xs.b]-                        --       or, equivalently,  = K[ (\x xs.b) e ]+  | 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_bndr  :: InId-      , sc_bndrs :: [InBndr]       , sc_body  :: InExpr       , sc_env   :: StaticEnv      -- See Note [StaticEnv invariant]       , sc_cont  :: SimplCont }@@ -406,6 +430,7 @@  contIsRhs :: SimplCont -> Bool contIsRhs (Stop _ RhsCtxt) = True+contIsRhs (CastIt _ k)     = contIsRhs k   -- For f = e |> co, treat e as Rhs context contIsRhs _                = False  -------------------@@ -426,7 +451,8 @@ contIsTrivial :: SimplCont -> Bool contIsTrivial (Stop {})                                         = True contIsTrivial (ApplyToTy { sc_cont = k })                       = contIsTrivial k-contIsTrivial (ApplyToVal { sc_arg = Coercion _, 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 _ k)                                      = contIsTrivial k contIsTrivial _                                                 = False @@ -449,7 +475,7 @@   = 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/Val]+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) @@ -478,9 +504,11 @@ contHoleScaling (TickIt _ k) = contHoleScaling k ------------------- countArgs :: SimplCont -> Int--- Count all arguments, including types, coercions, and other values+-- 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 _ cont)                 = countArgs cont countArgs _                               = 0  contArgs :: SimplCont -> (Bool, [ArgSummary], SimplCont)@@ -547,7 +575,7 @@       = vanilla_dmds -- See Note [Do not expose strictness if sm_inline=False]       | otherwise       = -- add_type_str fun_ty $-        case splitStrictSig (idStrictness fun) of+        case splitDmdSig (idDmdSig fun) of           (demands, result_info)                 | not (demands `lengthExceeds` n_val_args)                 ->      -- Enough args, use the strictness given.@@ -563,8 +591,8 @@                    else                         demands ++ vanilla_dmds                | otherwise-               -> WARN( True, text "More demands than arity" <+> ppr fun <+> ppr (idArity fun)-                                <+> ppr n_val_args <+> ppr demands )+               -> 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]@@ -583,13 +611,15 @@        | Just (_, arg_ty, fun_ty') <- splitFunTy_maybe fun_ty        -- Add strict-type info       , dmd : rest_dmds <- dmds-      , let dmd' = case isLiftedType_maybe arg_ty of-                       Just False -> strictifyDmd dmd-                       _          -> dmd+      , let dmd'+             | Just Unlifted <- typeLevity_maybe 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-          -- If the type is levity-polymorphic, we can't know whether it's-          -- strict. isLiftedType_maybe will return Just False only when-          -- we're sure the type is unlifted.        | otherwise       = dmds@@ -816,7 +846,9 @@            DoneEx e _           -> go (zapSubstEnv env)             n e            ContEx tvs cvs ids e -> go (setSubstEnv env tvs cvs ids) n e -    go _   _ (Lit {})          = ValueArg+    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@@ -1113,13 +1145,9 @@     mode = getMode env     id_unf id | unf_is_active id = idUnfolding id               | otherwise        = NoUnfolding-    unf_is_active id-     | not (sm_rules mode) = -- active_unfolding_minimal id-                             isStableUnfolding (realIdUnfolding id)-        -- Do we even need to test this?  I think this InScopeEnv-        -- is only consulted if activeRule returns True, which-        -- never happens if sm_rules is False-     | otherwise           = isActive (sm_phase mode) (idInlineActivation id)+    unf_is_active id = isActive (sm_phase mode) (idInlineActivation id)+       -- When sm_rules was off we used to test for a /stable/ unfolding,+       -- but that seems wrong (#20941)  ---------------------- activeRule :: SimplMode -> Activation -> Bool@@ -1276,7 +1304,7 @@   | not (one_occ (idOccInfo bndr))           = Nothing   | not (isStableUnfolding unf)              = Just $! (extend_subst_with rhs) -  -- Note [Stable unfoldings and preInlineUnconditionally]+  -- See Note [Stable unfoldings and preInlineUnconditionally]   | not (isInlinePragma inline_prag)   , Just inl <- maybeUnfoldingTemplate unf   = Just $! (extend_subst_with inl)   | otherwise                                = Nothing@@ -1378,12 +1406,12 @@ 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 [Simplfying+may seem surprising; for instance, the LHS of rules. See Note [Simplifying rules] for details. -}  postInlineUnconditionally-    :: SimplEnv -> TopLevelFlag+    :: SimplEnv -> BindContext     -> OutId            -- The binder (*not* a CoVar), including its unfolding     -> OccInfo          -- From the InId     -> OutExpr@@ -1392,14 +1420,15 @@ -- See Note [Core let/app 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 top_lvl bndr occ_info rhs+postInlineUnconditionally env bind_cxt bndr occ_info rhs   | not active                  = False   | isWeakLoopBreaker occ_info  = False -- If it's a loop-breaker of any kind, don't inline                                         -- because it might be referred to "earlier"   | isStableUnfolding unfolding = False -- Note [Stable unfoldings and postInlineUnconditionally]-  | isTopLevel top_lvl          = False -- Note [Top level and postInlineUnconditionally]+  | isTopLevel (bindContextLevel bind_cxt)+                                = False -- Note [Top level and postInlineUnconditionally]   | exprIsTrivial rhs           = True-  | isJoinId bndr                       -- See point (1) of Note [Duplicating join points]+  | BC_Join {} <- bind_cxt              -- See point (1) of Note [Duplicating join points]   , not (phase == FinalPhase)   = False -- in Simplify.hs   | otherwise   = case occ_info of@@ -1570,11 +1599,14 @@ -- mkLam tries three things --      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 mkLam _env [] body _cont   = return body mkLam env bndrs body cont-  = do { dflags <- getDynFlags+  = {-#SCC "mkLam" #-}+--    pprTrace "mkLam" (ppr bndrs $$ ppr body $$ ppr cont) $+    do { dflags <- getDynFlags        ; mkLam' dflags bndrs body }   where     mode = getMode env@@ -1605,7 +1637,7 @@       = do { tick (EtaReduction (head bndrs))            ; return etad_lam } -      | not (contIsRhs cont)   -- See Note [Eta-expanding lambdas]+      | not (contIsRhs cont)   -- See Note [Eta expanding lambdas]       , sm_eta_expand mode       , any isRuntimeVar bndrs       , let body_arity = {-# SCC "eta" #-} exprEtaExpandArity dflags body@@ -1613,13 +1645,15 @@       = do { tick (EtaExpansion (head bndrs))            ; let res = {-# SCC "eta3" #-}                        mkLams bndrs $-                       etaExpandAT body_arity body+                       etaExpandAT in_scope body_arity body            ; traceSmpl "eta expand" (vcat [text "before" <+> ppr (mkLams bndrs body)                                           , text "after" <+> ppr res])            ; return res }        | otherwise       = return (mkLams bndrs body)+      where+        in_scope = getInScope env  -- Includes 'bndrs'  {- Note [Eta expanding lambdas]@@ -1688,16 +1722,18 @@ ************************************************************************ -} -tryEtaExpandRhs :: SimplMode -> OutId -> OutExpr+tryEtaExpandRhs :: SimplEnv -> OutId -> OutExpr                 -> SimplM (ArityType, OutExpr) -- See Note [Eta-expanding at let bindings] -- If tryEtaExpandRhs rhs = (n, is_bot, rhs') then --   (a) rhs' has manifest arity n --   (b) if is_bot is True then rhs' applied to n args is guaranteed bottom-tryEtaExpandRhs mode bndr rhs+tryEtaExpandRhs env bndr rhs   | Just join_arity <- isJoinId_maybe bndr   = do { let (join_bndrs, join_body) = collectNBinders join_arity rhs-             arity_type = mkManifestArityType join_bndrs join_body+             oss   = [idOneShotInfo id | id <- join_bndrs, isId id]+             arity_type | exprIsDeadEnd join_body = mkBotArityType oss+                        | otherwise               = mkTopArityType oss        ; return (arity_type, rhs) }          -- Note [Do not eta-expand join points]          -- But do return the correct arity and bottom-ness, because@@ -1708,12 +1744,14 @@   , new_arity > old_arity   -- And the current manifest arity isn't enough   , want_eta rhs   = do { tick (EtaExpansion bndr)-       ; return (arity_type, etaExpandAT arity_type rhs) }+       ; return (arity_type, etaExpandAT in_scope arity_type rhs) }    | otherwise   = return (arity_type, rhs)    where+    mode      = getMode env+    in_scope  = getInScope env     dflags    = sm_dflags mode     old_arity = exprArity rhs @@ -1788,7 +1826,7 @@ Suppose we have a PAP     foo :: IO ()     foo = returnIO ()-Then we can eta-expand do+Then we can eta-expand to     foo = (\eta. (returnIO () |> sym g) eta) |> g where     g :: IO () ~ State# RealWorld -> (# State# RealWorld, () #)@@ -1954,18 +1992,25 @@     otherwise we get        t = /\ (f:k->*) (a:k). AccFailure @ (f a)     which is obviously bogus.++  * 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 gratuitiously change order, which may help (in a tiny+      way) with CSE and/or the compiler-debugging experience -}  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) )+  = assert (notNull body_floats) $+    assert (isNilOL (sfJoinFloats floats)) $     do  { (subst, float_binds) <- mapAccumLM abstract empty_subst body_floats         ; return (float_binds, GHC.Core.Subst.substExpr subst body) }   where     is_top_lvl  = isTopLevel top_lvl-    main_tv_set = mkVarSet main_tvs     body_floats = letFloatBinds (sfLetFloats floats)     empty_subst = GHC.Core.Subst.mkEmptySubst (sfInScope floats) @@ -1979,10 +2024,9 @@         rhs' = GHC.Core.Subst.substExpr subst rhs          -- tvs_here: see Note [Which type variables to abstract over]-        tvs_here = scopedSort $-                   filter (`elemVarSet` main_tv_set) $-                   closeOverKindsList $-                   exprSomeFreeVarsList isTyVar rhs'+        tvs_here = filter (`elemVarSet` free_tvs) main_tvs+        free_tvs = closeOverKinds $+                   exprSomeFreeVars isTyVar rhs'      abstract subst (Rec prs)        = do { (poly_ids, poly_apps) <- mapAndUnzipM (mk_poly1 tvs_here) ids@@ -2164,9 +2208,9 @@  mkCase tries these things -* Note [Nerge nested cases]-* Note [Eliminate identity case]-* Note [Scrutinee constant folding]+* Note [Merge Nested Cases]+* Note [Eliminate Identity Case]+* Note [Scrutinee Constant Folding]  Note [Merge Nested Cases] ~~~~~~~~~~~~~~~~~~~~~~~~~@@ -2283,7 +2327,7 @@   , inner_scrut_var == outer_bndr   = do  { tick (CaseMerge outer_bndr) -        ; let wrap_alt (Alt con args rhs) = ASSERT( outer_bndr `notElem` args )+        ; let wrap_alt (Alt con args rhs) = assert (outer_bndr `notElem` args)                                             (Alt con args (wrap_rhs rhs))                 -- Simplifier's no-shadowing invariant should ensure                 -- that outer_bndr is not shadowed by the inner patterns
GHC/Core/Opt/SpecConstr.hs view
@@ -10,8 +10,8 @@ \section[SpecConstr]{Specialise over constructors} -} -{-# LANGUAGE CPP #-} + {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}  module GHC.Core.Opt.SpecConstr(@@ -19,53 +19,61 @@         SpecConstrAnnotation(..)     ) where -#include "HsVersions.h"- import GHC.Prelude +import GHC.Driver.Session ( DynFlags(..), GeneralFlag( Opt_SpecConstrKeen )+                          , gopt, hasPprDebug )+ import GHC.Core import GHC.Core.Subst import GHC.Core.Utils import GHC.Core.Unfold import GHC.Core.FVs     ( exprsFreeVarsList ) import GHC.Core.Opt.Monad-import GHC.Types.Literal ( litIsLifted )-import GHC.Unit.Module.ModGuts-import GHC.Core.Opt.WorkWrap.Utils ( isWorkerSmallEnough, mkWorkerArgs )+import GHC.Core.Opt.WorkWrap.Utils import GHC.Core.DataCon import GHC.Core.Coercion hiding( substCo ) import GHC.Core.Rules import GHC.Core.Type     hiding ( substTy ) import GHC.Core.TyCon   (TyCon, tyConUnique, tyConName ) import GHC.Core.Multiplicity-import GHC.Types.Id import GHC.Core.Ppr     ( pprParendExpr ) import GHC.Core.Make    ( mkImpossibleExpr )++import GHC.Unit.Module+import GHC.Unit.Module.ModGuts++import GHC.Types.Literal ( litIsLifted )+import GHC.Types.Id import GHC.Types.Var.Env import GHC.Types.Var.Set import GHC.Types.Name import GHC.Types.Tickish import GHC.Types.Basic-import GHC.Driver.Session ( DynFlags(..), GeneralFlag( Opt_SpecConstrKeen )-                          , gopt, hasPprDebug )-import GHC.Driver.Ppr-import GHC.Data.Maybe     ( orElse, catMaybes, isJust, isNothing ) import GHC.Types.Demand import GHC.Types.Cpr-import GHC.Serialized   ( deserializeWithData )-import GHC.Utils.Misc-import GHC.Data.Pair import GHC.Types.Unique.Supply+import GHC.Types.Unique.FM++import GHC.Data.Maybe     ( orElse, catMaybes, isJust, isNothing )+import GHC.Data.Pair+import GHC.Data.FastString++import GHC.Utils.Misc import GHC.Utils.Outputable+import GHC.Utils.Panic.Plain import GHC.Utils.Panic-import GHC.Data.FastString-import GHC.Types.Unique.FM+import GHC.Utils.Constants (debugIsOn) import GHC.Utils.Monad-import Control.Monad    ( zipWithM )-import Data.List (nubBy, sortBy, partition)+import GHC.Utils.Trace+ import GHC.Builtin.Names ( specTyConKey )-import GHC.Unit.Module+ import GHC.Exts( SpecConstrAnnotation(..) )+import GHC.Serialized   ( deserializeWithData )++import Control.Monad    ( zipWithM )+import Data.List (nubBy, sortBy, partition, dropWhileEnd, mapAccumL ) import Data.Ord( comparing )  {-@@ -618,6 +626,13 @@ 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.+ -----------------------------------------------------                 Stuff not yet handled -----------------------------------------------------@@ -707,6 +722,7 @@       us     <- getUniqueSupplyM       (_, annos) <- getFirstAnnotations deserializeWithData guts       this_mod <- getModule+      -- pprTraceM "specConstrInput" (ppr $ mg_binds guts)       let binds' = reverse $ fst $ initUs us $ do                     -- Note [Top-level recursive groups]                     (env, binds) <- goEnv (initScEnv dflags this_mod annos)@@ -946,10 +962,13 @@                       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+extendBndr env bndr  = (env { sc_subst = subst' }, bndr')+                     where+                       (subst', bndr') = substBndr (sc_subst env) bndr  extendValEnv :: ScEnv -> Id -> Maybe Value -> ScEnv extendValEnv env _  Nothing   = env@@ -1102,11 +1121,14 @@         -- 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 [ ptext (sLit "calls =") <+> ppr calls-                                         , text "occs =" <+> ppr 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)@@ -1136,10 +1158,8 @@             | ScrutOcc  -- See Note [ScrutOcc]                  (DataConEnv [ArgOcc])   -- How the sub-components are used -type DataConEnv a = UniqFM DataCon a     -- Keyed by DataCon--{- Note  [ScrutOcc]-~~~~~~~~~~~~~~~~~~~+{- Note [ScrutOcc]+~~~~~~~~~~~~~~~~~~ An occurrence of ScrutOcc indicates that the thing, or a `cast` version of the thing, is *only* taken apart or applied. @@ -1273,7 +1293,7 @@         ; rhs_info  <- scRecRhs env (bndr',rhs)          ; let body_env2 = extendHowBound body_env [bndr'] RecFun-                           -- Note [Local let bindings]+                           -- See Note [Local let bindings]               rhs'      = ri_new_rhs rhs_info               body_env3 = extendValEnv body_env2 bndr' (isValue (sc_vals env) rhs') @@ -1283,9 +1303,14 @@           -- the parent function (see Note [Forcing specialisation])         ; (spec_usg, specs) <- specNonRec env body_usg rhs_info +        -- Specialized + original binding+        ; let spec_bnds = mkLets [NonRec b r | (b,r) <- ruleInfoBinds rhs_info specs] body'+        -- ; pprTraceM "spec_bnds" $ (ppr spec_bnds)+         ; return (body_usg { scu_calls = scu_calls body_usg `delVarEnv` bndr' }                     `combineUsage` spec_usg,  -- Note [spec_usg includes rhs_usg]-                  mkLets [NonRec b r | (b,r) <- ruleInfoBinds rhs_info specs] body')+                  spec_bnds+                  )         }  @@ -1336,7 +1361,7 @@ scApp :: ScEnv -> (InExpr, [InExpr]) -> UniqSM (ScUsage, CoreExpr)  scApp env (Var fn, args)        -- Function is a variable-  = ASSERT( not (null args) )+  = assert (not (null args)) $     do  { args_w_usgs <- mapM (scExpr env) args         ; let (arg_usgs, args') = unzip args_w_usgs               arg_usg = combineUsages arg_usgs@@ -1399,12 +1424,6 @@ ---------------------- scTopBind :: ScEnv -> ScUsage -> CoreBind -> UniqSM (ScUsage, CoreBind) -{--scTopBind _ usage _-  | pprTrace "scTopBind_usage" (ppr (scu_calls usage)) False-  = error "false"--}- scTopBind env body_usage (Rec prs)   | Just threshold <- sc_size env   , not force_spec@@ -1603,15 +1622,16 @@   = -- pprTrace "specialise bot" (ppr fn) $     return (nullUsage, spec_info) -  | isNeverActive (idInlineActivation fn) -- See Note [Transfer activation]-    || null arg_bndrs                     -- Only specialise functions-  = -- pprTrace "specialise inactive" (ppr fn) $-    case mb_unspec of    -- Behave as if there was a single, boring call-      Just rhs_usg -> return (rhs_usg, spec_info { si_mb_unspec = Nothing })-                         -- See Note [spec_usg includes rhs_usg]-      Nothing      -> return (nullUsage, spec_info)--  | Just all_calls <- lookupVarEnv bind_calls fn+  | 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, new_pats) <- callsToNewPats env fn spec_info arg_occs all_calls @@ -1650,10 +1670,13 @@                                 , si_n_specs = spec_count + n_pats                                 , si_mb_unspec = mb_unspec' }) } -  | otherwise  -- No new seeds, so return nullUsage-  = return (nullUsage, spec_info)--+  | 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)   ---------------------@@ -1686,58 +1709,78 @@             f (b,c) ((:) (a,(b,c)) (x,v) hw) = f_spec b c v hw -} -spec_one env fn arg_bndrs body (call_pat@(qvars, pats), rule_number)+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  { spec_uniq <- getUniqueM-        ; let spec_env   = extendScSubstList (extendScInScope env qvars)-                                             (arg_bndrs `zip` pats)-              fn_name    = idName fn-              fn_loc     = nameSrcSpan fn_name-              fn_occ     = nameOccName fn_name-              spec_occ   = mkSpecOcc fn_occ+        ; 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---      ; pprTrace "{spec_one" (ppr (sc_count env) <+> ppr fn---                              <+> ppr pats <+> text "-->" <+> ppr spec_name) $+--      ; pprTrace "spec_one {" (vcat [ text "function:" <+> ppr fn <+> ppr (idUnique fn)+--                                    , text "sc_count:" <+> ppr (sc_count env)+--                                    , text "pats:" <+> ppr pats+--                                    , text "-->" <+> ppr spec_name+--                                    , text "bndrs" <+> ppr arg_bndrs+--                                    , text "body" <+> ppr body+--                                    , text "how_bound" <+> ppr (sc_how_bound env) ]) $ --        return ()          -- Specialise the body-        ; (spec_usg, spec_body) <- scExpr spec_env body+        -- ; pprTraceM "body_subst_for" $ ppr (spec_occ) $$ ppr (sc_subst body_env)+        ; (spec_usg, spec_body) <- scExpr body_env body ---      ; pprTrace "done spec_one}" (ppr fn) $+--      ; pprTrace "done spec_one }" (ppr fn $$ ppr (scu_calls spec_usg)) $ --        return ()                  -- And build the results-        ; let (spec_lam_args, spec_call_args) = mkWorkerArgs (sc_dflags env)-                                                             qvars body_ty-                -- Usual w/w hack to avoid generating-                -- a spec_rhs of unlifted type and no args+        ; let spec_body_ty   = exprType spec_body+              (spec_lam_args1, spec_sig, spec_arity1, spec_join_arity1)+                  = calcSpecInfo fn call_pat extra_bndrs+                  -- Annotate the variables with the strictness information from+                  -- the function (see Note [Strictness information in worker binders]) -              spec_lam_args_str = handOutStrictnessInformation (fst (splitStrictSig spec_str)) spec_lam_args-                -- Annotate the variables with the strictness information from-                -- the function (see Note [Strictness information in worker binders])+              (spec_lam_args, spec_call_args, spec_arity, spec_join_arity)+                  | needsVoidWorkerArg fn arg_bndrs spec_lam_args1+                  , (spec_lam_args, spec_call_args, _) <- addVoidWorkerArg spec_lam_args1 []+                      -- needsVoidWorkerArg: usual w/w hack to avoid generating+                      -- a spec_rhs of unlifted type and no args.+                  , !spec_arity      <- spec_arity1 + 1+                  , !spec_join_arity <- fmap (+ 1) spec_join_arity1+                  = (spec_lam_args,  spec_call_args, spec_arity,  spec_join_arity)+                  | otherwise+                  = (spec_lam_args1, spec_lam_args1, spec_arity1, spec_join_arity1) -              spec_join_arity | isJoinId fn = Just (length spec_lam_args)-                              | otherwise   = Nothing-              spec_id    = mkLocalId spec_name Many-                                     (mkLamTypes spec_lam_args body_ty)+              spec_id    = asWorkerLikeId $+                           mkLocalId spec_name Many+                                     (mkLamTypes spec_lam_args spec_body_ty)                              -- See Note [Transfer strictness]-                             `setIdStrictness` spec_str-                             `setIdCprInfo` topCprSig-                             `setIdArity` count isId spec_lam_args+                             `setIdDmdSig`    spec_sig+                             `setIdCprSig`    topCprSig+                             `setIdArity`     spec_arity                              `asJoinId_maybe` spec_join_arity-              spec_str   = calcSpecStrictness fn spec_lam_args pats -                 -- Conditionally use result of new worker-wrapper transform-              spec_rhs   = mkLams spec_lam_args_str spec_body-              body_ty    = exprType spec_body-              rule_rhs   = mkVarApps (Var spec_id) spec_call_args+              spec_rhs   = mkLams spec_lam_args (mkSeqs cbv_args spec_body_ty spec_body)+              rule_rhs   = mkVarApps (Var spec_id) $+                           dropTail (length extra_bndrs) spec_call_args               inline_act = idInlineActivation fn-              this_mod   = sc_module spec_env+              this_mod   = sc_module env               rule       = mkRule this_mod True {- Auto -} True {- Local -}                                   rule_name inline_act fn_name qvars pats rule_rhs                            -- See Note [Transfer activation]@@ -1745,31 +1788,89 @@                                , os_id = spec_id                                , os_rhs = spec_rhs }) } +-- See Note [SpecConstr and strict fields]+mkSeqs :: [Var] -> Type -> CoreExpr -> CoreExpr+mkSeqs seqees res_ty rhs =+  foldr addEval rhs seqees+    where+      addEval :: Var -> CoreExpr -> CoreExpr+      addEval arg_id rhs+        -- Argument representing strict field and it's worth passing via cbv+        | shouldStrictifyIdForCbv arg_id+        = Case (Var arg_id) arg_id res_ty ([Alt DEFAULT [] rhs])+        | otherwise+        = rhs --- See Note [Strictness information in worker binders]-handOutStrictnessInformation :: [Demand] -> [Var] -> [Var]-handOutStrictnessInformation = go-  where-    go _ [] = []-    go [] vs = vs-    go (d:dmds) (v:vs) | isId v = setIdDemandInfo v d : go dmds vs-    go dmds (v:vs) = v : go dmds vs -calcSpecStrictness :: Id                     -- The original function-                   -> [Var] -> [CoreExpr]    -- Call pattern-                   -> StrictSig              -- Strictness of specialised thing+{- Note [SpecConst needs to add void args first]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider a function+    f start @t = e+We want to specialize for a partially applied call `f True`.+See also Note [SpecConstr call patterns], second Wrinkle.+Naively we would expect to get+    $sf @t = $se+    RULE: f True = $sf+The specialized function only takes a single type argument+so we add a void argument to prevent it from turning into+a thunk. See Note [Protecting the last value argument] for details+why. Normally we would add the void argument after the+type argument giving us:+    $sf :: forall t. Void# -> bla+    $sf @t void = $se+    RULE: f True = $sf void# (wrong)+But if you look closely this wouldn't typecheck!+If we substitute `f True` with `$sf void#` we expect the type argument to be applied first+but we apply void# first.+The easist 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!+-}++calcSpecInfo :: Id                     -- The original function+             -> CallPat                -- Call pattern+             -> [Var]                  -- Extra bndrs+             -> ( [Var]                     -- Demand-decorated binders+                , DmdSig                    -- Strictness of specialised thing+                , Arity, Maybe JoinArity )  -- Arities of specialised thing+-- Calcuate bits of IdInfo for the specialised function -- See Note [Transfer strictness]-calcSpecStrictness fn qvars pats-  = mkClosedStrictSig spec_dmds div+-- See Note [Strictness information in worker binders]+calcSpecInfo fn (CP { cp_qvars = qvars, cp_args = pats }) extra_bndrs+  | isJoinId fn    -- Join points have strictness and arity for LHS only+  = ( bndrs_w_dmds+    , mkClosedDmdSig qvar_dmds div+    , count isId qvars+    , Just (length qvars) )+  | otherwise+  = ( bndrs_w_dmds+    , mkClosedDmdSig (qvar_dmds ++ extra_dmds) div+    , count isId qvars + count isId extra_bndrs+    , Nothing )   where-    spec_dmds = [ lookupVarEnv dmd_env qv `orElse` topDmd | qv <- qvars, isId qv ]-    StrictSig (DmdType _ dmds div) = idStrictness fn+    DmdSig (DmdType _ fn_dmds div) = idDmdSig fn -    dmd_env = go emptyVarEnv dmds pats+    val_pats   = filterOut isTypeArg pats -- value args at call sites, used to determine how many demands to drop+                                          -- from the original functions demand and for setting up dmd_env.+    qvar_dmds  = [ lookupVarEnv dmd_env qv `orElse` topDmd | qv <- qvars, isId qv ]+    extra_dmds = dropList val_pats fn_dmds +    bndrs_w_dmds =  set_dmds qvars       qvar_dmds+                 ++ set_dmds extra_bndrs extra_dmds++    set_dmds :: [Var] -> [Demand] -> [Var]+    set_dmds [] _   = []+    set_dmds vs  [] = vs  -- Run out of demands+    set_dmds (v:vs) ds@(d:ds') | isTyVar v = v                   : set_dmds vs ds+                               | otherwise = setIdDemandInfo v d : set_dmds vs ds'++    dmd_env = go emptyVarEnv fn_dmds val_pats+     go :: DmdEnv -> [Demand] -> [CoreExpr] -> DmdEnv-    go env ds (Type {} : pats)     = go env ds pats-    go env ds (Coercion {} : pats) = go env ds pats+    -- 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 @@ -1777,10 +1878,11 @@     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 ds <- viewProd (length args) cd+      , 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+    go_one env _  _ = env + {- Note [spec_usg includes rhs_usg] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1837,13 +1939,13 @@  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}@@ -1871,19 +1973,39 @@ Note [SpecConstr call patterns] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ A "call patterns" that we collect is going to become the LHS of a RULE.-It's important that it doesn't have++Wrinkles:++* The list of argument patterns, cp_args, is no longer than the+  visible lambdas of the binding, ri_arg_occs.  This is done via+  the zipWithM in callToPats.++* The list of argument patterns can certainly be shorter than the+  lambdas in the function definition (under-saturated).  For example+      f x y = case x of { True -> e1; False -> e2 }+      ....map (f True) e...+  We want to specialise `f` for `f True`.++* In fact we deliberately shrink the list of argument patterns,+  cp_args, by trimming off all the boring ones at the end (see+  `dropWhileEnd is_boring` in callToPats).  Since the RULE only+  applies when it is saturated, this shrinking makes the RULE more+  applicable.  But it does mean that the argument patterns do not+  necessarily saturate the lambdas of the function.++* It's important that the pattern arguments do not look like      e |> Refl-or+  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).+  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!+  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] ~~~~~~~~~~~~~~~~~~~~~~~~@@ -1912,7 +2034,7 @@     in ... f (K @(a |> co)) ...  where 'co' is a coercion variable not in scope at f's definition site.-If we aren't caereful we'll get+If we aren't careful we'll get      let $sf a co = e (K @(a |> co))         RULE "SC:f" forall a co.  f (K @(a |> co)) = $sf a co@@ -1968,9 +2090,17 @@ only in kind-casts, but I'm doing the simple thing for now. -} -type CallPat = ([Var], [CoreExpr])      -- Quantified variables and arguments-                                        -- See Note [SpecConstr call patterns]+data CallPat = CP { cp_qvars :: [Var]           -- Quantified variables+                  , cp_args  :: [CoreExpr]      -- Arguments+                  , cp_strict_args :: [Var] }   -- Arguments we want to pass unlifted even if they are boxed+     -- See Note [SpecConstr call patterns] +instance Outputable CallPat where+  ppr (CP { cp_qvars = qvars, cp_args = args, cp_strict_args =  strict })+    = text "CP" <> braces (sep [ text "cp_qvars =" <+> ppr qvars <> comma+                               , text "cp_args =" <+> ppr args+                               , text "cp_strict_args = " <> ppr strict ])+ callsToNewPats :: ScEnv -> Id                -> SpecInfo                -> [ArgOcc] -> [Call]@@ -1995,34 +2125,40 @@                -- Remove ones that have too many worker variables               small_pats = filterOut too_big non_dups-              too_big (vars,args) = not (isWorkerSmallEnough (sc_dflags env) (valArgCount args) vars)+              max_args = maxWorkerArgs (sc_dflags env)+              too_big (CP { cp_qvars = vars, cp_args = args })+                = not (isWorkerSmallEnough max_args (valArgCount args) vars)                   -- We are about to construct w/w pair in 'spec_one'.                   -- Omit specialisation leading to high arity workers.                   -- See Note [Limit w/w arity] in GHC.Core.Opt.WorkWrap.Utils                  -- Discard specialisations if there are too many of them-              trimmed_pats = trim_pats env fn spec_info small_pats+              (pats_were_discarded, trimmed_pats) = trim_pats env fn spec_info small_pats  --        ; pprTrace "callsToPats" (vcat [ text "calls to" <+> ppr fn <> colon <+> ppr calls --                                       , text "done_specs:" <+> ppr (map os_pat done_specs) --                                       , text "good_pats:" <+> ppr good_pats ]) $ --          return () -        ; return (have_boring_call, trimmed_pats) }+        ; return (have_boring_call || pats_were_discarded, trimmed_pats) }+          -- If any of the calls does not give rise to a specialisation, either+          -- because it is boring, or because there are too many specialisations,+          -- return a flag to say so, so that we know to keep the original function.  -trim_pats :: ScEnv -> Id -> SpecInfo -> [CallPat] -> [CallPat]+trim_pats :: ScEnv -> Id -> SpecInfo -> [CallPat] -> (Bool, [CallPat])+-- True <=> some patterns were discarded -- See Note [Choosing patterns] trim_pats env fn (SI { si_n_specs = done_spec_count }) pats   | sc_force env     || isNothing mb_scc     || n_remaining >= n_pats   = -- pprTrace "trim_pats: no-trim" (ppr (sc_force env) $$ ppr mb_scc $$ ppr n_remaining $$ ppr n_pats)-    pats          -- No need to trim+    (False, pats)          -- No need to trim    | otherwise   = emit_trace $  -- Need to trim, so keep the best ones-    take n_remaining sorted_pats+    (True, take n_remaining sorted_pats)    where     n_pats         = length pats@@ -2041,7 +2177,8 @@     pat_cons :: CallPat -> Int     -- How many data constructors of literals are in     -- the pattern.  More data-cons => less general-    pat_cons (qs, ps) = foldr ((+) . n_cons) 0 ps+    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@@ -2072,12 +2209,21 @@         --      Type variables come first, since they may scope         --      over the following term variables         -- The [CoreExpr] are the argument patterns for the rule-callToPats env bndr_occs call@(Call _ args con_env)-  | args `ltLength` bndr_occs      -- Check saturated-  = return Nothing-  | otherwise+callToPats env bndr_occs call@(Call fn args con_env)   = do  { let in_scope = substInScope (sc_subst env)-        ; (interesting, pats) <- argsToPats env in_scope con_env args bndr_occs++        ; arg_tripples <- zipWith3M (argToPat env in_scope con_env) args bndr_occs (map (const NotMarkedStrict) args)+                   -- This zip trims the args to be no longer than+                   -- the lambdas in the function definition (bndr_occs)++          -- Drop boring patterns from the end+          -- See Note [SpecConstr call patterns]+        ; let arg_tripples' | isJoinId fn = arg_tripples+                            | otherwise   = dropWhileEnd is_boring arg_tripples+              is_boring (interesting, _,_) = not interesting+              (interesting_s, pats, cbv_ids) = unzip3 arg_tripples'+              interesting           = or interesting_s+         ; let pat_fvs = exprsFreeVarsList pats                 -- To get determinism we need the list of free variables in                 -- deterministic order. Otherwise we end up creating@@ -2107,18 +2253,20 @@               bad_covars :: CoVarSet               bad_covars = mapUnionVarSet get_bad_covars pats               get_bad_covars :: CoreArg -> CoVarSet-              get_bad_covars (Type ty)-                = filterVarSet (\v -> isId v && not (is_in_scope v)) $-                  tyCoVarsOfType ty-              get_bad_covars _-                = emptyVarSet+              get_bad_covars (Type ty) = filterVarSet bad_covar (tyCoVarsOfType ty)+              get_bad_covars _         = emptyVarSet+              bad_covar v = isId v && not (is_in_scope v)          ; -- pprTrace "callToPats"  (ppr args $$ ppr bndr_occs) $-          WARN( not (isEmptyVarSet bad_covars)-              , text "SpecConstr: bad covars:" <+> ppr bad_covars-                $$ ppr call )+          warnPprTrace (not (isEmptyVarSet bad_covars))+              "SpecConstr: bad covars"+              (ppr bad_covars $$ ppr call) $           if interesting && isEmptyVarSet bad_covars-          then return (Just (qvars', pats))+          then+              -- pprTraceM "callToPatsOut" (+              --   text "fun" <> ppr fn $$+              --   ppr (CP { cp_qvars = qvars', cp_args = pats })) >>+              return (Just (CP { cp_qvars = qvars', cp_args = pats, cp_strict_args = concat cbv_ids }))           else return Nothing }      -- argToPat takes an actual argument, and returns an abstracted@@ -2132,7 +2280,9 @@          -> ValueEnv                    -- ValueEnv at the call site          -> CoreArg                     -- A call arg (or component thereof)          -> ArgOcc-         -> UniqSM (Bool, CoreArg)+         -> 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@@ -2144,11 +2294,25 @@ --              lvl7         --> (True, lvl7)      if lvl7 is bound --                                                 somewhere further out -argToPat _env _in_scope _val_env arg@(Type {}) _arg_occ-  = return (False, arg)+argToPat env in_scope val_env 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 -argToPat env in_scope val_env (Tick _ arg) arg_occ-  = argToPat env in_scope val_env arg arg_occ+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@@ -2156,8 +2320,8 @@         -- ride roughshod over them all for now.         --- See Note [Tick annotations in RULE matching] in GHC.Core.Rules -argToPat env in_scope val_env (Let _ arg) arg_occ-  = argToPat env in_scope val_env arg arg_occ+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))@@ -2170,17 +2334,17 @@   = argToPat env in_scope val_env rhs arg_occ -} -argToPat env in_scope val_env (Cast arg co) arg_occ+argToPat1 env in_scope val_env (Cast arg co) arg_occ arg_str   | not (ignoreType env ty2)-  = do  { (interesting, arg') <- argToPat env in_scope val_env arg arg_occ+  = do  { (interesting, arg', strict_args) <- argToPat env in_scope val_env arg arg_occ arg_str         ; if not interesting then-                wildCardPat ty2+                wildCardPat ty2 arg_str           else do         { -- Make a wild-card pattern for the coercion           uniq <- getUniqueM         ; let co_name = mkSysTvName uniq (fsLit "sg")               co_var  = mkCoVar co_name (mkCoercionType Representational ty1 ty2)-        ; return (interesting, Cast arg' (mkCoVarCo co_var)) } }+        ; return (interesting, Cast arg' (mkCoVarCo co_var), strict_args) } }   where     Pair ty1 ty2 = coercionKind co @@ -2200,35 +2364,66 @@    -- Check for a constructor application   -- NB: this *precedes* the Var case, so that we catch nullary constrs-argToPat env in_scope val_env arg arg_occ+argToPat1 env in_scope val_env arg arg_occ _arg_str   | Just (ConVal (DataAlt dc) args) <- isValue val_env arg   , not (ignoreDataCon env dc)        -- See Note [NoSpecConstr]   , Just arg_occs <- mb_scrut dc-  = do  { let (ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) args-        ; (_, args') <- argsToPats env in_scope val_env rest_args arg_occs-        ; return (True,-                  mkConApp dc (ty_args ++ args')) }+  = do { let (ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) args+             con_str, matched_str :: [StrictnessMark]+             -- con_str corrresponds 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 env-                                -> Just (repeat UnkOcc)-                                | otherwise-                                -> Nothing+                ScrutOcc bs | Just occs <- lookupUFM bs dc+                            -> Just (occs)  -- See Note [Reboxing]+                _other      | sc_force env || sc_keen 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"-argToPat env in_scope val_env (Var v) arg_occ-  | sc_force env || case arg_occ of { UnkOcc -> False; _other -> True }, -- (a)-    is_value,                                                            -- (b)+argToPat1 env in_scope val_env (Var v) arg_occ arg_str+  | sc_force env || case arg_occ of { ScrutOcc {} -> True+                                    ; UnkOcc      -> False+                                    ; NoOcc       -> False } -- (a)+  , is_value                                                 -- (b)        -- Ignoring sc_keen here to avoid gratuitously incurring Note [Reboxing]        -- So sc_keen focused just on f (I# x), where we have freshly-allocated        -- box that we can eliminate in the caller-    not (ignoreType env (varType v))-  = return (True, Var v)+  , 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@@ -2257,22 +2452,15 @@    -- The default case: make a wild-card   -- We use this for coercions too-argToPat _env _in_scope _val_env arg _arg_occ-  = wildCardPat (exprType arg)--wildCardPat :: Type -> UniqSM (Bool, CoreArg)-wildCardPat ty-  = do { uniq <- getUniqueM-       ; let id = mkSysLocalOrCoVar (fsLit "sc") uniq Many ty-       ; return (False, varToCoreExpr id) }+argToPat1 _env _in_scope _val_env arg _arg_occ arg_str+  = wildCardPat (exprType arg) arg_str -argsToPats :: ScEnv -> InScopeSet -> ValueEnv-           -> [CoreArg] -> [ArgOcc]  -- Should be same length-           -> UniqSM (Bool, [CoreArg])-argsToPats env in_scope val_env args occs-  = do { stuff <- zipWithM (argToPat env in_scope val_env) args occs-       ; let (interesting_s, args') = unzip stuff-       ; return (or interesting_s, args') }+-- | wildCardPats are always boring+wildCardPat :: Type -> StrictnessMark -> UniqSM (Bool, CoreArg, [Id])+wildCardPat ty str+  = do { id <- mkSysLocalOrCoVarM (fsLit "sc") Many 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)@@ -2324,9 +2512,11 @@ valueIsWorkFree (ConVal _ args) = all exprIsWorkFree args  samePat :: CallPat -> CallPat -> Bool-samePat (vs1, as1) (vs2, as2)+samePat (CP { cp_qvars = vs1, cp_args = as1 })+        (CP { cp_qvars = vs2, cp_args = as2 })   = all2 same as1 as2   where+    -- If the args are the same, their strictness marks will be too so we don't compare those.     same (Var v1) (Var v2)         | v1 `elem` vs1 = v2 `elem` vs2         | v2 `elem` vs2 = False@@ -2342,7 +2532,7 @@     same e1 (Tick _ e2) = same e1 e2     same e1 (Cast e2 _) = same e1 e2 -    same e1 e2 = WARN( bad e1 || bad e2, ppr e1 $$ ppr e2)+    same e1 e2 = warnPprTrace (bad e1 || bad e2) "samePat" (ppr e1 $$ ppr e2) $                  False  -- Let, lambda, case should not occur     bad (Case {}) = True     bad (Let {})  = True
GHC/Core/Opt/Specialise.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE CPP #-} + {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}  {-@@ -10,13 +10,12 @@  module GHC.Core.Opt.Specialise ( specProgram, specUnfolding ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Driver.Session import GHC.Driver.Ppr import GHC.Driver.Config+import GHC.Driver.Config.Diagnostic import GHC.Driver.Env  import GHC.Tc.Utils.TcType hiding( substTy )@@ -29,7 +28,6 @@ import qualified GHC.Core.Subst as Core import GHC.Core.Unfold.Make import GHC.Core-import GHC.Core.Make      ( mkLitRubbish ) import GHC.Core.Rules import GHC.Core.Utils     ( exprIsTrivial, getIdFromTrivialExpr_maybe                           , mkCast, exprType )@@ -43,6 +41,7 @@ import GHC.Data.Maybe     ( mapMaybe, maybeToList, isJust ) import GHC.Data.Bag import GHC.Data.FastString+import GHC.Data.List.SetOps  import GHC.Types.Basic import GHC.Types.Unique.Supply@@ -54,11 +53,14 @@ import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Types.Id+import GHC.Types.Error +import GHC.Utils.Error ( mkMCDiagnostic ) import GHC.Utils.Monad    ( foldlM ) import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Trace  import GHC.Unit.Module( Module ) import GHC.Unit.Module.ModGuts@@ -735,8 +737,7 @@        ; hsc_env <- getHscEnv        ; eps <- liftIO $ hscEPS hsc_env        ; vis_orphs <- getVisibleOrphanMods-       ; let full_rb = unionRuleBase rb (eps_rule_base eps)-             rules_for_fn = getRules (RuleEnv full_rb vis_orphs) fn+       ; let rules_for_fn = getRules (RuleEnv [rb, eps_rule_base eps] vis_orphs) fn         ; (rules1, spec_pairs, MkUD { ud_binds = dict_binds1, ud_calls = new_calls })             <- -- debugTraceMsg (text "specImport1" <+> vcat [ppr fn, ppr good_calls, ppr rhs]) >>@@ -801,16 +802,17 @@ 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 specialization for ClassOps]+  | isClassOpId fn = return () -- See Note [Missed specialisation for ClassOps]   | wopt Opt_WarnMissedSpecs dflags     && not (null callers)-    && allCallersInlined                  = doWarn $ Reason Opt_WarnMissedSpecs-  | wopt Opt_WarnAllMissedSpecs dflags    = doWarn $ Reason Opt_WarnAllMissedSpecs+    && 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 =-      warnMsg reason+      msg (mkMCDiagnostic diag_opts reason)         (vcat [ hang (text ("Could not specialise imported function") <+> quotes (ppr fn))                 2 (vcat [ text "when specialising" <+> quotes (ppr caller)                         | caller <- callers])@@ -892,14 +894,14 @@ Note [Avoiding loops in specImports] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We must take great care when specialising instance declarations-(functions like $fOrdList) lest we accidentally build a recursive-dictionary. See Note [Avoiding loops].+(DFuns like $fOrdList) lest we accidentally build a recursive+dictionary. See Note [Avoiding loops (DFuns)]. -The basic strategy of Note [Avoiding loops] is to use filterCalls+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_imorpts in spec_import, we must include the dict-binds+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.@@ -991,7 +993,7 @@ and similarly specialising 'g' might expose a new call to 'h'.  We track the stack of enclosing functions. So when specialising 'h' we-haev a specImport call stack of [g,f]. We do this for two reasons:+have a specImport call stack of [g,f]. We do this for two reasons: * Note [Warning about missed specialisations] * Note [Avoiding recursive specialisation] @@ -1423,18 +1425,22 @@   && 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 specialisation] for why we do not+--      See Note [Inline specialisations] for why we do not --      switch off specialisation for inline functions    = -- pprTrace "specDefn: some" (ppr fn $$ ppr calls_for_me $$ ppr existing_rules) $     foldlM spec_call ([], [], emptyUDs) calls_for_me    | otherwise   -- No calls or RHS doesn't fit our preconceptions-  = WARN( not (exprIsTrivial rhs) && notNull calls_for_me,-          text "Missed specialisation opportunity for"-                                 <+> ppr fn $$ _trace_doc )+  = warnPprTrace (not (exprIsTrivial rhs) && notNull calls_for_me)+          "Missed specialisation opportunity" (ppr fn $$ _trace_doc) $           -- Note [Specialisation shape]     -- pprTrace "specDefn: none" (ppr fn <+> ppr calls_for_me) $     return ([], [], emptyUDs)@@ -1504,7 +1510,7 @@                  -- 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.mkWorkerArgs+                 -- C.f. GHC.Core.Opt.WorkWrap.Utils.needsVoidWorkerArg                  add_void_arg = isUnliftedType spec_fn_ty1 && not (isJoinId fn)                  (spec_bndrs, spec_rhs, spec_fn_ty)                    | add_void_arg = ( voidPrimId : spec_bndrs1@@ -1566,7 +1572,7 @@                   = (neverInlinePragma, noUnfolding)                         -- See Note [Specialising imported functions] in "GHC.Core.Opt.OccurAnal" -                  | InlinePragma { inl_inline = Inlinable } <- inl_prag+                  | isInlinablePragma inl_prag                   = (inl_prag { inl_inline = NoUserInlinePrag }, noUnfolding)                    | otherwise@@ -1737,11 +1743,8 @@   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.+  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 [Zap occ info in rule binders] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1853,8 +1856,8 @@   - there are some specialisations (spec_binds non-empty)   - there are some dict_binds that depend on f (dump_dbs non-empty) -Note [Avoiding loops]-~~~~~~~~~~~~~~~~~~~~~+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.@@ -1895,8 +1898,10 @@   (directly or indirectly) on the dfun we are specialising.   This is done by 'filterCalls' ----------------Here's yet another example+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] } @@ -1917,8 +1922,8 @@ 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: +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 @@ -1930,8 +1935,24 @@  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@@ -2296,28 +2317,16 @@          let (env', bndr') = substBndr env (zapIdOccInfo bndr)        ; (useful, env'', leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args)              <- specHeader env' bndrs args--       ; let bndr_ty = idType bndr'--             -- See Note [Drop dead args from specialisations]-             -- C.f. GHC.Core.Opt.WorkWrap.Utils.mk_absent_let-             (mb_spec_bndr, spec_arg)-                | isDeadBinder bndr-                , Just lit_expr <- mkLitRubbish bndr_ty-                = (Nothing, lit_expr)-                | otherwise-                = (Just bndr', varToCoreExpr bndr')-        ; pure ( useful               , env''               , leftover_bndrs               , bndr' : rule_bs               , varToCoreExpr bndr' : rule_es-              , case mb_spec_bndr of-                  Nothing -> bs' -- see Note [Drop dead args from specialisations]-                  Just b' -> b' : bs'+              , if isDeadBinder bndr+                  then bs' -- see Note [Drop dead args from specialisations]+                  else bndr' : bs'               , dx-              , spec_arg : spec_args+              , varToCoreExpr bndr' : spec_args               )        } @@ -2494,9 +2503,9 @@  data CallInfo   = CI { ci_key  :: [SpecArg]   -- All arguments-       , ci_fvs  :: VarSet      -- Free vars of the ci_key-                                -- call (including tyvars)-                                -- [*not* include the main id itself, of course]+       , ci_fvs  :: IdSet       -- Free Ids of the ci_key call+                                -- _not_ including the main id itself, of course+                                -- NB: excluding tyvars:     }  type DictExpr = CoreExpr@@ -2724,11 +2733,10 @@     interesting :: InterestingVarFun     interesting v = isLocalVar v || (isId v && isDFunId v)         -- Very important: include DFunIds /even/ if it is imported-        -- Reason: See Note [Avoiding loops], the second 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-        --         #13429 illustrates+        -- 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.@@ -2818,14 +2826,20 @@                         Nothing -> []                         Just cis -> filterCalls cis orig_dbs          -- filterCalls: drop calls that (directly or indirectly)-         -- refer to fn.  See Note [Avoiding loops]+         -- refer to fn.  See Note [Avoiding loops (DFuns)]  ---------------------- filterCalls :: CallInfoSet -> Bag DictBind -> [CallInfo]--- See Note [Avoiding loops]+-- Remove dominated calls+-- and loopy DFuns (Note [Avoiding loops (DFuns)]) filterCalls (CIS fn call_bag) dbs-  = filter ok_call (bagToList call_bag)+  | isDFunId fn  -- Note [Avoiding loops (DFuns)] applies only to DFuns+  = filter ok_call unfiltered_calls+  | otherwise         -- Do not apply it to non-DFuns+  = unfiltered_calls  -- See Note [Avoiding loops (non-DFuns)]   where+    unfiltered_calls = bagToList call_bag+     dump_set = foldl' go (unitVarSet fn) dbs       -- This dump-set could also be computed by splitDictBinds       --   (_,_,dump_set) = splitDictBinds dbs {fn}
GHC/Core/Opt/StaticArgs.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE CPP #-} + {- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 @@ -73,8 +73,6 @@  import Data.List (mapAccumL) import GHC.Data.FastString--#include "HsVersions.h"  doStaticArgs :: UniqSupply -> CoreProgram -> CoreProgram doStaticArgs us binds = snd $ mapAccumL sat_bind_threaded_us us binds
GHC/Core/Opt/WorkWrap.hs view
@@ -4,38 +4,39 @@ \section[WorkWrap]{Worker/wrapper-generating back-end of strictness analyser} -} -{-# LANGUAGE CPP #-}+ module GHC.Core.Opt.WorkWrap ( wwTopBinds ) where  import GHC.Prelude -import GHC.Core.Opt.Arity  ( manifestArity )+import GHC.Driver.Session+ import GHC.Core-import GHC.Core.Unfold import GHC.Core.Unfold.Make import GHC.Core.Utils  ( exprType, exprIsHNF )-import GHC.Core.FVs    ( exprFreeVars )+import GHC.Core.Type+import GHC.Core.Opt.WorkWrap.Utils+import GHC.Core.FamInstEnv+import GHC.Core.SimpleOpt+ import GHC.Types.Var import GHC.Types.Id import GHC.Types.Id.Info-import GHC.Core.Type import GHC.Types.Unique.Supply import GHC.Types.Basic-import GHC.Driver.Session-import GHC.Driver.Ppr-import GHC.Driver.Config import GHC.Types.Demand import GHC.Types.Cpr import GHC.Types.SourceText-import GHC.Core.Opt.WorkWrap.Utils+import GHC.Types.Unique+ import GHC.Utils.Misc import GHC.Utils.Outputable-import GHC.Types.Unique import GHC.Utils.Panic-import GHC.Core.FamInstEnv+import GHC.Utils.Panic.Plain import GHC.Utils.Monad--#include "HsVersions.h"+import GHC.Utils.Trace+import GHC.Unit.Types+import GHC.Core.DataCon  {- We take Core bindings whose binders have:@@ -65,12 +66,14 @@ \end{enumerate} -} -wwTopBinds :: DynFlags -> FamInstEnvs -> UniqSupply -> CoreProgram -> CoreProgram+wwTopBinds :: Module -> DynFlags -> FamInstEnvs -> UniqSupply -> CoreProgram -> CoreProgram -wwTopBinds dflags fam_envs us top_binds+wwTopBinds this_mod dflags fam_envs us top_binds   = initUs_ us $ do-    top_binds' <- mapM (wwBind dflags fam_envs) top_binds+    top_binds' <- mapM (wwBind ww_opts) top_binds     return (concat top_binds')+  where+    ww_opts = initWwOpts this_mod dflags fam_envs  {- ************************************************************************@@ -83,25 +86,24 @@ turn.  Non-recursive case first, then recursive... -} -wwBind  :: DynFlags-        -> FamInstEnvs+wwBind  :: WwOpts         -> CoreBind         -> UniqSM [CoreBind]    -- returns a WwBinding intermediate form;                                 -- the caller will convert to Expr/Binding,                                 -- as appropriate. -wwBind dflags fam_envs (NonRec binder rhs) = do-    new_rhs <- wwExpr dflags fam_envs rhs-    new_pairs <- tryWW dflags fam_envs NonRecursive binder new_rhs+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 dflags fam_envs (Rec pairs)+wwBind ww_opts (Rec pairs)   = return . Rec <$> concatMapM do_one pairs   where-    do_one (binder, rhs) = do new_rhs <- wwExpr dflags fam_envs rhs-                              tryWW dflags fam_envs Recursive binder new_rhs+    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@@ -110,41 +112,41 @@ @wwExpr@ is a version that just returns the ``Plain'' Tree. -} -wwExpr :: DynFlags -> FamInstEnvs -> CoreExpr -> UniqSM CoreExpr+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 _ e@(Type {}) = return e+wwExpr _ e@(Coercion {}) = return e+wwExpr _ e@(Lit  {}) = return e+wwExpr _ e@(Var  {}) = return e -wwExpr dflags fam_envs (Lam binder expr)-  = Lam new_binder <$> wwExpr dflags fam_envs expr+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 dflags fam_envs (App f a)-  = App <$> wwExpr dflags fam_envs f <*> wwExpr dflags fam_envs a+wwExpr ww_opts (App f a)+  = App <$> wwExpr ww_opts f <*> wwExpr ww_opts a -wwExpr dflags fam_envs (Tick note expr)-  = Tick note <$> wwExpr dflags fam_envs expr+wwExpr ww_opts (Tick note expr)+  = Tick note <$> wwExpr ww_opts expr -wwExpr dflags fam_envs (Cast expr co) = do-    new_expr <- wwExpr dflags fam_envs expr+wwExpr ww_opts (Cast expr co) = do+    new_expr <- wwExpr ww_opts expr     return (Cast new_expr co) -wwExpr dflags fam_envs (Let bind expr)-  = mkLets <$> wwBind dflags fam_envs bind <*> wwExpr dflags fam_envs expr+wwExpr ww_opts (Let bind expr)+  = mkLets <$> wwBind ww_opts bind <*> wwExpr ww_opts expr -wwExpr dflags fam_envs (Case expr binder ty alts) = do-    new_expr <- wwExpr dflags fam_envs 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 dflags fam_envs rhs+        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]@@ -181,7 +183,7 @@ 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]+Note [Worker/wrapper for INLINABLE functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If we have   {-# INLINABLE f #-}@@ -190,26 +192,26 @@  where f is strict in y, we might get a more efficient loop by w/w'ing f.  But that would make a new unfolding which would overwrite the old-one! So the function would no longer be INLNABLE, and in particular+one! So the function would no longer be INLINABLE, and in particular will not be specialised at call sites in other modules. -This comes in practice (#6056).+This comes up in practice (#6056).  Solution: do the w/w for strictness analysis, but transfer the Stable unfolding to the *worker*.  So we will get something like this: -  {-# INLINE[0] f #-}+  {-# INLINE[2] f #-}   f :: Ord a => [a] -> Int -> a   f d x y = case y of I# y' -> fw d x y' -  {-# INLINABLE[0] fw #-}+  {-# INLINABLE[2] fw #-}   fw :: Ord a => [a] -> Int# -> a   fw d x y' = let y = I# y' in ...f...  How do we "transfer the unfolding"? Easy: by using the old one, wrapped-in work_fn! See GHC.Core.Unfold.mkWorkerUnfolding.+in work_fn! See GHC.Core.Unfold.Make.mkWorkerUnfolding. -Note [No worker-wrapper for record selectors]+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,@@ -225,8 +227,10 @@ 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]+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@@ -300,7 +304,7 @@  Note [Worker activation] ~~~~~~~~~~~~~~~~~~~~~~~~-Follows on from Note [Worker-wrapper for INLINABLE functions]+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@@ -308,7 +312,7 @@ 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 work inherit the+If the original is NOINLINE, it's important that the worker inherits the original activation. Consider    {-# NOINLINE expensive #-}@@ -320,9 +324,9 @@ we'll get this (because of the compromise in point (2) of Note [Wrapper activation]) -  {-# NOINLINE[0] $wexpensive #-}+  {-# NOINLINE[Final] $wexpensive #-}   $wexpensive x = x + 1-  {-# INLINE[0] expensive #-}+  {-# INLINE[Final] expensive #-}   expensive x = $wexpensive x    f y = let z = expensive y in ...@@ -421,17 +425,20 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~ When should the wrapper inlining be active? -1. It must not be active earlier than the current Activation of the-   Id+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]+   Note [Worker/wrapper for NOINLINE functions]  3. For ordinary functions with no pragmas we want to inline the    wrapper as early as possible (#15056).  Suppose another module-   defines    f x = g x x-   and suppose there is some RULE for (g True True).  Then if we have-   a call (f True), we'd expect to inline 'f' and the RULE will fire.+   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. @@ -456,32 +463,46 @@    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+   (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.+   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. -Conclusion:-  - If the user said NOINLINE[n], respect that -  - If the user said NOINLINE, inline the wrapper only after-    phase 0, the last user-visible phase.  That means that all-    rules will have had a chance to fire.--    What phase is after phase 0?  Answer: FinalPhase, that's the reason it-    exists. NB: Similar to InitialPhase, users can't write INLINE[Final] f;-    it's syntactically illegal.+What if `foo` has no specialiations, is worker/wrappered (with the+wrapper inlining very early), and exported; and then in an importing+module we have {-# SPECIALISE foo : ... #-}? -  - Otherwise inline wrapper in phase 2.  That allows the-    'gentle' simplification pass to apply specialisation rules+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 [Wrapper NoUserInlinePrag]-~~~~~~~~~~~~~~~~~~~~~~~~~~~+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We use NoUserInlinePrag on the wrapper, to say that there is no user-specified inline pragma. (The worker inherits that; see Note-[Worker-wrapper for INLINABLE functions].)  The wrapper has no pragma+[Worker/wrapper for INLINABLE functions].)  The wrapper has no pragma given by the user.  (Historical note: we used to give the wrapper an INLINE pragma, but@@ -490,10 +511,20 @@ everything we needs is expressed by (a) the stable unfolding and (b) the inl_act activation.) +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   :: DynFlags-        -> FamInstEnvs+tryWW   :: WwOpts         -> RecFlag         -> Id                           -- The fn binder         -> CoreExpr                     -- The bound rhs; its innards@@ -503,49 +534,75 @@                                         -- the orig "wrapper" lives on);                                         -- if two, then a worker and a                                         -- wrapper.-tryWW dflags fam_envs is_rec fn_id rhs-  -- See Note [Worker-wrapper for NOINLINE functions]+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)] -  | Just stable_unf <- certainlyWillInline uf_opts fn_info-  = return [ (fn_id `setIdUnfolding` stable_unf, rhs) ]-        -- See Note [Don't w/w INLINE things]-        -- See Note [Don't w/w inline small non-loop-breaker things]+  -- See Note [Don't w/w INLINE things]+  | hasInlineUnfolding fn_info+  = return [(new_fn_id, rhs)] -  | is_fun && is_eta_exp-  = splitFun dflags fam_envs new_fn_id fn_info wrap_dmds div cpr rhs+  -- See Note [No worker/wrapper for record selectors]+  | isRecordSelector fn_id+  = return [ (new_fn_id, rhs ) ] -  | isNonRec is_rec, is_thunk                        -- See Note [Thunk splitting]-  = splitThunk dflags fam_envs is_rec 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-    uf_opts      = unfoldingOpts dflags-    fn_info      = idInfo new_fn_id-    (wrap_dmds, div) = splitStrictSig (strictnessInfo fn_info)--    cpr_ty       = getCprSig (cprInfo 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          = ASSERT2( 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-+    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 WorkWrap]+        -- See Note [Zapping Used Once info in WorkWrap]      zap_join_cpr id-      | isJoinId id = id `setIdCprInfo` topCprSig+      | 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-    -- See Note [Don't eta expand in w/w]-    is_eta_exp = length wrap_dmds == manifestArity rhs     is_thunk   = not is_fun && not (exprIsHNF rhs) && not (isJoinId fn_id)                             && not (isUnliftedType (idType fn_id)) @@ -572,22 +629,57 @@  Note [Zapping Used Once info in WorkWrap] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In the worker-wrapper pass we zap the used once info in demands and in-strictness signatures.+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. -So as the data is useless and possibly wrong, we want to remove it. The most-convenient place to do that is the worker wrapper phase, as it runs after every-run of the demand analyser besides the very last one (which is the one where we-want to _keep_ the info for the code generator).+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) -We do not do it in the demand analyser for the same reasons outlined in-Note [Zapping DmdEnv after Demand Analyzer] above.+I think we'll give `f` the strictness signature `<SP(M,A)>`, where the+`M` sayd 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@@ -595,7 +687,13 @@ for a reason (see Note [exprArity invariant] in GHC.Core.Opt.Arity) and we probably have a PAP, cast or trivial expression as RHS. -Performing the worker/wrapper split will implicitly eta-expand the binding to+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: @@ -603,7 +701,7 @@     where       co :: (Int -> Int -> Char) ~ T -Then idArity is 2 (despite the type T), and it can have a StrictSig based on a+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@@ -617,67 +715,106 @@ 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 :: DynFlags -> FamInstEnvs -> Id -> IdInfo -> [Demand] -> Divergence -> Cpr -> CoreExpr-         -> UniqSM [(Id, CoreExpr)]-splitFun dflags fam_envs fn_id fn_info wrap_dmds div cpr rhs-  | isRecordSelector fn_id  -- See Note [No worker/wrapper for record selectors]-  = return [ (fn_id, rhs ) ]+splitFun :: WwOpts -> Id -> CoreExpr -> UniqSM [(Id, CoreExpr)]+splitFun ww_opts fn_id rhs+  | not (wrap_dmds `lengthIs` count isId arg_vars)+    -- See Note [Don't eta expand in w/w]+  = return [(fn_id, rhs)]    | otherwise-  = WARN( not (wrap_dmds `lengthIs` arity), ppr fn_id <+> (ppr arity $$ ppr wrap_dmds $$ ppr cpr) )-          -- The arity should match the signature-    do { mb_stuff <- mkWwBodies dflags fam_envs rhs_fvs fn_id wrap_dmds use_cpr_info+  = warnPprTrace (not (wrap_dmds `lengthIs` (arityInfo fn_info)))+                 "splitFun"+                 (ppr fn_id <+> (ppr wrap_dmds $$ ppr cpr)) $+    do { mb_stuff <- mkWwBodies ww_opts fn_id arg_vars (exprType body) wrap_dmds cpr        ; case mb_stuff of-            Nothing -> return [(fn_id, rhs)]+            Nothing -> -- No useful wrapper; leave the binding alone+                       return [(fn_id, rhs)]              Just stuff-              | Just stable_unf <- certainlyWillInline (unfoldingOpts dflags) fn_info-              ->  return [ (fn_id `setIdUnfolding` stable_unf, rhs) ]-                  -- See Note [Don't w/w INLINE things]-                  -- See Note [Don't w/w inline small non-loop-breaker things]+              | let opt_wwd_rhs = simpleOptExpr (wo_simple_opts ww_opts) rhs+                  -- We need to stabilise the WW'd (and optimised) RHS below+              , Just stable_unf <- certainlyWillInline uf_opts fn_info opt_wwd_rhs+                -- We could make a w/w split, but in fact the RHS is small+                -- See Note [Don't w/w inline small non-loop-breaker things]+              , let id_w_unf = fn_id `setIdUnfolding` stable_unf+                -- See Note [Inline pragma for certainlyWillInline]+              ->  return [ (id_w_unf, rhs) ]                | otherwise               -> do { work_uniq <- getUniqueM-                    ; return (mkWWBindPair dflags fn_id fn_info arity rhs+                    ; return (mkWWBindPair ww_opts fn_id fn_info arg_vars body                                            work_uniq div stuff) } }   where-    rhs_fvs = exprFreeVars rhs-    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+    uf_opts = so_uf_opts (wo_simple_opts ww_opts)+    fn_info = idInfo fn_id+    (arg_vars, body) = collectBinders rhs -    -- use_cpr_info is the CPR we w/w for. Note that we kill it for join points,-    -- see Note [Don't w/w join points for CPR].-    use_cpr_info  | isJoinId fn_id = topCpr-                  | otherwise      = cpr+    (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 :: DynFlags -> Id -> IdInfo -> Arity-             -> CoreExpr -> Unique -> Divergence-             -> ([Demand], JoinArity, Id -> CoreExpr, Expr CoreBndr -> CoreExpr)+mkWWBindPair :: WwOpts -> Id -> IdInfo+             -> [Var] -> CoreExpr -> Unique -> Divergence+             -> ([Demand],JoinArity, Id -> CoreExpr, Expr CoreBndr -> CoreExpr)              -> [(Id, CoreExpr)]-mkWWBindPair dflags fn_id fn_info arity rhs work_uniq div+mkWWBindPair ww_opts fn_id fn_info fn_args fn_body work_uniq div              (work_demands, join_arity, wrap_fn, work_fn)-  = [(work_id, work_rhs), (wrap_id, wrap_rhs)]+  = -- 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-    simpl_opts = initSimpleOpts dflags+    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 -    work_rhs = work_fn rhs+    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+                   NoInline _  -> inl_act fn_inl_prag+                   _           -> inl_act wrap_prag      work_prag = InlinePragma { inl_src = SourceText "{-# INLINE"                              , inl_inline = fn_inline_spec                              , inl_sat    = Nothing                              , inl_act    = work_act                              , inl_rule   = FunLike }-      -- inl_inline: copy from fn_id; see Note [Worker-wrapper for INLINABLE functions]+      -- inl_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. @@ -686,7 +823,8 @@       -- worker is join point iff wrapper is join point       -- (see Note [Don't w/w join points for CPR]) -    work_id  = mkWorkerId work_uniq fn_id (exprType work_rhs)+    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@@ -696,13 +834,13 @@                 `setInlinePragma` work_prag                  `setIdUnfolding` mkWorkerUnfolding simpl_opts work_fn fn_unfolding-                        -- See Note [Worker-wrapper for INLINABLE functions]+                        -- See Note [Worker/wrapper for INLINABLE functions] -                `setIdStrictness` mkClosedStrictSig work_demands div+                `setIdDmdSig` mkClosedDmdSig work_demands div                         -- Even though we may not be at top level,                         -- it's ok to give it an empty DmdEnv -                `setIdCprInfo` topCprSig+                `setIdCprSig` topCprSig                  `setIdDemandInfo` worker_demand @@ -710,19 +848,21 @@                         -- 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+    work_arity = length work_demands :: Int -    -- See Note [Demand on the Worker]+    -- 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+    wrap_prag = mkStrWrapperInlinePrag fn_inl_prag fn_rules+    wrap_unf  = mkWrapperUnfolding simpl_opts wrap_rhs arity -    wrap_id   = fn_id `setIdUnfolding`  mkWwInlineRule 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@@ -730,27 +870,30 @@      fn_inl_prag     = inlinePragInfo fn_info     fn_inline_spec  = inl_inline fn_inl_prag-    fn_unfolding    = unfoldingInfo fn_info+    fn_unfolding    = realUnfoldingInfo fn_info+    fn_rules        = ruleInfoRules (ruleInfo fn_info) -mkStrWrapperInlinePrag :: InlinePragma -> InlinePragma-mkStrWrapperInlinePrag (InlinePragma { inl_act = act, inl_rule = rule_info })+mkStrWrapperInlinePrag :: InlinePragma -> [CoreRule] -> InlinePragma+-- See Note [Wrapper activation]+mkStrWrapperInlinePrag (InlinePragma { inl_act = act, inl_rule = rule_info }) rules   = InlinePragma { inl_src    = SourceText "{-# INLINE"-                 , inl_inline = NoUserInlinePrag -- See Note [Wrapper NoUserInline]+                 , inl_inline = NoUserInlinePrag -- See Note [Wrapper NoUserInlinePrag]                  , inl_sat    = Nothing-                 , inl_act    = wrap_act+                 , inl_act    = activeAfter wrapper_phase                  , inl_rule   = rule_info }  -- RuleMatchInfo is (and must be) unaffected   where-    wrap_act  = case act of  -- See Note [Wrapper activation]-                   NeverActive     -> activateDuringFinal-                   FinalActive     -> act-                   ActiveAfter {}  -> act-                   ActiveBefore {} -> activateAfterInitial-                   AlwaysActive    -> activateAfterInitial-      -- For the last two cases, see (4) in Note [Wrapper activation]-      -- NB: the (ActiveBefore n) isn't quite right. We really want-      -- it to be active *after* Initial but *before* n.  We don't have-      -- a way to say that, alas.+    -- See Note [Wrapper activation]+    wrapper_phase = foldr (laterPhase . get_rule_phase) earliest_inline_phase rules+    earliest_inline_phase = beginPhase 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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -782,55 +925,62 @@ The demand on the worker is then calculated using mkWorkerDemand, and always of the form [Demand=<L,1*(C1(...(C1(U))))>] --Note [Do not split void functions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this rather common form of binding:-        $j = \x:Void# -> ...no use of x...--Since x is not used it'll be marked as absent.  But there is no point-in w/w-ing because we'll simply add (\y:Void#), see GHC.Core.Opt.WorkWrap.Utils.mkWorerArgs.--If x has a more interesting type (eg Int, or Int#), there *is* a point-in w/w so that we don't pass the argument at all.- Note [Thunk splitting] ~~~~~~~~~~~~~~~~~~~~~~-Suppose x is used strictly (never mind whether it has the CPR-property).+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* = case x-rhs of { I# a -> I# a }+        x* = let x = x-rhs in+             case x of { I# a -> I# a }       in body -Now simplifier will transform to-+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 -which is what we want. Now suppose x-rhs is itself a case:--        x-rhs = case e of { T -> I# a; F -> I# b }+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 -The join point will abstract over a, rather than over (which is-what would have happened before) which is fine.+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. -Notice that x certainly has the CPR property now!+* 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, so that if x's demand is deeper (say U(U(L,L),L))-then the splitting will go deeper too.+* 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. -NB: 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.+* 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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -878,12 +1028,13 @@ -- -- How can we do thunk-splitting on a top-level binder?  See -- Note [Thunk splitting for top-level binders].-splitThunk :: DynFlags -> FamInstEnvs -> RecFlag -> Var -> Expr Var -> UniqSM [(Var, Expr Var)]-splitThunk dflags fam_envs is_rec x rhs-  = ASSERT(not (isJoinId x))+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,_, wrap_fn, work_fn) <- mkWWstr dflags fam_envs False [x']-       ; let res = [ (x, Let (NonRec x' rhs) (wrap_fn (work_fn (Var x')))) ]-       ; if useful then ASSERT2( isNonRec is_rec, ppr x ) -- The thunk must be non-recursive+       ; (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
@@ -4,1424 +4,1615 @@ A library for the ``worker\/wrapper'' back-end to the strictness analyser -} -{-# LANGUAGE CPP #-}--module GHC.Core.Opt.WorkWrap.Utils-   ( mkWwBodies, mkWWstr, mkWorkerArgs-   , DataConPatContext(..), UnboxingDecision(..), splitArgType_maybe, wantToUnbox-   , findTypeShape-   , isWorkerSmallEnough-   )-where--#include "HsVersions.h"--import GHC.Prelude--import GHC.Core-import GHC.Core.Utils   ( exprType, mkCast, mkDefaultCase, mkSingleAltCase-                        , bindNonRec, dataConRepFSInstPat )-import GHC.Types.Id-import GHC.Types.Id.Info ( JoinArity )-import GHC.Core.DataCon-import GHC.Types.Demand-import GHC.Types.Cpr-import GHC.Core.Make    ( mkAbsentErrorApp, mkCoreUbxTup-                        , mkCoreApp, mkCoreLet )-import GHC.Types.Id.Make ( voidArgId, voidPrimId )-import GHC.Builtin.Types      ( tupleDataCon )-import GHC.Core.Make ( mkLitRubbish )-import GHC.Types.Var.Env ( mkInScopeSet )-import GHC.Types.Var.Set ( VarSet )-import GHC.Core.Type-import GHC.Core.Multiplicity-import GHC.Core.Predicate ( isClassPred )-import GHC.Core.Coercion-import GHC.Core.FamInstEnv-import GHC.Types.Basic       ( Boxity(..) )-import GHC.Core.TyCon-import GHC.Core.TyCon.RecWalk-import GHC.Types.Unique.Supply-import GHC.Types.Unique-import GHC.Types.Name ( getOccFS )-import GHC.Data.Maybe-import GHC.Utils.Misc-import GHC.Utils.Outputable-import GHC.Utils.Panic-import GHC.Driver.Session-import GHC.Driver.Ppr-import GHC.Data.FastString-import GHC.Data.List.SetOps--import GHC.Types.RepType--{--************************************************************************-*                                                                      *-\subsection[mkWrapperAndWorker]{@mkWrapperAndWorker@}-*                                                                      *-************************************************************************--Here's an example.  The original function is:--\begin{verbatim}-g :: forall a . Int -> [a] -> a--g = \/\ a -> \ x ys ->-        case x of-          0 -> head ys-          _ -> head (tail ys)-\end{verbatim}--From this, we want to produce:-\begin{verbatim}--- wrapper (an unfolding)-g :: forall a . Int -> [a] -> a--g = \/\ a -> \ x ys ->-        case x of-          I# x# -> $wg a x# ys-            -- call the worker; don't forget the type args!---- worker-$wg :: forall a . Int# -> [a] -> a--$wg = \/\ a -> \ x# ys ->-        let-            x = I# x#-        in-            case x of               -- note: body of g moved intact-              0 -> head ys-              _ -> head (tail ys)-\end{verbatim}--Something we have to be careful about:  Here's an example:--\begin{verbatim}--- "f" strictness: U(P)U(P)-f (I# a) (I# b) = a +# b--g = f   -- "g" strictness same as "f"-\end{verbatim}--\tr{f} will get a worker all nice and friendly-like; that's good.-{\em But we don't want a worker for \tr{g}}, even though it has the-same strictness as \tr{f}.  Doing so could break laziness, at best.--Consequently, we insist that the number of strictness-info items is-exactly the same as the number of lambda-bound arguments.  (This is-probably slightly paranoid, but OK in practice.)  If it isn't the-same, we ``revise'' the strictness info, so that we won't propagate-the unusable strictness-info into the interfaces.---************************************************************************-*                                                                      *-\subsection{The worker wrapper core}-*                                                                      *-************************************************************************--@mkWwBodies@ is called when doing the worker\/wrapper split inside a module.--}--type WwResult-  = ([Demand],              -- Demands for worker (value) args-     JoinArity,             -- Number of worker (type OR value) args-     Id -> CoreExpr,        -- Wrapper body, lacking only the worker Id-     CoreExpr -> CoreExpr)  -- Worker body, lacking the original function rhs--mkWwBodies :: DynFlags-           -> FamInstEnvs-           -> VarSet         -- Free vars of RHS-                             -- See Note [Freshen WW arguments]-           -> Id             -- The original function-           -> [Demand]       -- Strictness of original function-           -> Cpr            -- Info about function result-           -> UniqSM (Maybe WwResult)---- wrap_fn_args E       = \x y -> E--- work_fn_args E       = E x y---- wrap_fn_str E        = case x of { (a,b) ->---                        case a of { (a1,a2) ->---                        E a1 a2 b y }}--- work_fn_str E        = \a1 a2 b y ->---                        let a = (a1,a2) in---                        let x = (a,b) in---                        E--mkWwBodies dflags fam_envs rhs_fvs fun_id demands cpr_info-  = do  { let empty_subst = mkEmptyTCvSubst (mkInScopeSet rhs_fvs)-                -- See Note [Freshen WW arguments]--        ; (wrap_args, wrap_fn_args, work_fn_args, res_ty)-             <- mkWWargs empty_subst fun_ty demands-        ; (useful1, work_args, wrap_fn_str, work_fn_str)-             <- mkWWstr dflags fam_envs has_inlineable_prag wrap_args--        -- Do CPR w/w.  See Note [Always do CPR w/w]-        ; (useful2, wrap_fn_cpr, work_fn_cpr, cpr_res_ty)-              <- mkWWcpr (gopt Opt_CprAnal dflags) fam_envs res_ty cpr_info--        ; let (work_lam_args, work_call_args) = mkWorkerArgs dflags work_args cpr_res_ty-              worker_args_dmds = [idDemandInfo v | v <- work_call_args, isId v]-              wrapper_body = wrap_fn_args . wrap_fn_cpr . wrap_fn_str . applyToVars work_call_args . Var-              worker_body = mkLams work_lam_args. work_fn_str . work_fn_cpr . work_fn_args--        ; if isWorkerSmallEnough dflags (length demands) work_args-             && not (too_many_args_for_join_point wrap_args)-             && ((useful1 && not only_one_void_argument) || useful2)-          then return (Just (worker_args_dmds, length work_call_args,-                       wrapper_body, worker_body))-          else return Nothing-        }-        -- We use an INLINE unconditionally, even if the wrapper turns out to be-        -- something trivial like-        --      fw = ...-        --      f = __inline__ (coerce T fw)-        -- The point is to propagate the coerce to f's call sites, so even though-        -- f's RHS is now trivial (size 1) we still want the __inline__ to prevent-        -- fw from being inlined into f's RHS-  where-    fun_ty        = idType fun_id-    mb_join_arity = isJoinId_maybe fun_id-    has_inlineable_prag = isStableUnfolding (realIdUnfolding fun_id)-                          -- See Note [Do not unpack class dictionaries]--    -- Note [Do not split void functions]-    only_one_void_argument-      | [d] <- demands-      , Just (_, arg_ty1, _) <- splitFunTy_maybe fun_ty-      , isAbsDmd d && isVoidTy arg_ty1-      = True-      | otherwise-      = False--    -- Note [Join points returning functions]-    too_many_args_for_join_point wrap_args-      | Just join_arity <- mb_join_arity-      , wrap_args `lengthExceeds` join_arity-      = WARN(True, text "Unable to worker/wrapper join point with arity " <+>-                     int join_arity <+> text "but" <+>-                     int (length wrap_args) <+> text "args")-        True-      | otherwise-      = False---- See Note [Limit w/w arity]-isWorkerSmallEnough :: DynFlags -> Int -> [Var] -> Bool-isWorkerSmallEnough dflags old_n_args vars-  = count isId vars <= max old_n_args (maxWorkerArgs dflags)-    -- We count only Free variables (isId) to skip Type, Kind-    -- variables which have no runtime representation.-    -- Also if the function took 82 arguments before (old_n_args), it's fine if-    -- it takes <= 82 arguments afterwards.--{--Note [Always do CPR w/w]-~~~~~~~~~~~~~~~~~~~~~~~~-At one time we refrained from doing CPR w/w for thunks, on the grounds that-we might duplicate work.  But that is already handled by the demand analyser,-which doesn't give the CPR property if w/w might waste work: see-Note [CPR for thunks] in GHC.Core.Opt.DmdAnal.--And if something *has* been given the CPR property and we don't w/w, it's-a disaster, because then the enclosing function might say it has the CPR-property, but now doesn't and there a cascade of disaster.  A good example-is #5920.--Note [Limit w/w arity]-~~~~~~~~~~~~~~~~~~~~~~~~-Guard against high worker arity as it generates a lot of stack traffic.-A simplified example is #11565#comment:6--Current strategy is very simple: don't perform w/w transformation at all-if the result produces a wrapper with arity higher than -fmax-worker-args-and the number arguments before w/w (see #18122).--It is a bit all or nothing, consider--        f (x,y) (a,b,c,d,e ... , z) = rhs--Currently we will remove all w/w ness entirely. But actually we could-w/w on the (x,y) pair... it's the huge product that is the problem.--Could we instead refrain from w/w on an arg-by-arg basis? Yes, that'd-solve f. But we can get a lot of args from deeply-nested products:--        g (a, (b, (c, (d, ...)))) = rhs--This is harder to spot on an arg-by-arg basis. Previously mkWwStr was-given some "fuel" saying how many arguments it could add; when we ran-out of fuel it would stop w/wing.--Still not very clever because it had a left-right bias.--************************************************************************-*                                                                      *-\subsection{Making wrapper args}-*                                                                      *-************************************************************************--During worker-wrapper stuff we may end up with an unlifted thing-which we want to let-bind without losing laziness.  So we-add a void argument.  E.g.--        f = /\a -> \x y z -> E::Int#    -- E does not mention x,y,z-==>-        fw = /\ a -> \void -> E-        f  = /\ a -> \x y z -> fw realworld--We use the state-token type which generates no code.--}--mkWorkerArgs :: DynFlags -> [Var]-             -> Type    -- Type of body-             -> ([Var], -- Lambda bound args-                 [Var]) -- Args at call site-mkWorkerArgs dflags args res_ty-    | any isId args || not needsAValueLambda-    = (args, args)-    | otherwise-    = (args ++ [voidArgId], args ++ [voidPrimId])-    where-      -- See "Making wrapper args" section above-      needsAValueLambda =-        lifted-        -- We may encounter a levity-polymorphic result, in which case we-        -- conservatively assume that we have laziness that needs preservation.-        -- See #15186.-        || not (gopt Opt_FunToThunk dflags)-           -- see Note [Protecting the last value argument]--      -- Might the result be lifted?-      lifted =-        case isLiftedType_maybe res_ty of-          Just lifted -> lifted-          Nothing     -> True--{--Note [Protecting the last value argument]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If the user writes (\_ -> E), they might be intentionally disallowing-the sharing of E. Since absence analysis and worker-wrapper are keen-to remove such unused arguments, we add in a void argument to prevent-the function from becoming a thunk.--The user can avoid adding the void argument with the -ffun-to-thunk-flag. However, this can create sharing, which may be bad in two ways. 1) It can-create a space leak. 2) It can prevent inlining *under a lambda*. If w/w-removes the last argument from a function f, then f now looks like a thunk, and-so f can't be inlined *under a lambda*.--Note [Join points and beta-redexes]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--Originally, the worker would invoke the original function by calling it with-arguments, thus producing a beta-redex for the simplifier to munch away:--  \x y z -> e => (\x y z -> e) wx wy wz--Now that we have special rules about join points, however, this is Not Good if-the original function is itself a join point, as then it may contain invocations-of other join points:--  join j1 x = ...-  join j2 y = if y == 0 then 0 else j1 y--  =>--  join j1 x = ...-  join $wj2 y# = let wy = I# y# in (\y -> if y == 0 then 0 else jump j1 y) wy-  join j2 y = case y of I# y# -> jump $wj2 y#--There can't be an intervening lambda between a join point's declaration and its-occurrences, so $wj2 here is wrong. But of course, this is easy enough to fix:--  ...-  let join $wj2 y# = let wy = I# y# in let y = wy in if y == 0 then 0 else j1 y-  ...--Hence we simply do the beta-reduction here. (This would be harder if we had to-worry about hygiene, but luckily wy is freshly generated.)--Note [Join points returning functions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--It is crucial that the arity of a join point depends on its *callers,* not its-own syntax. What this means is that a join point can have "extra lambdas":--f :: Int -> Int -> (Int, Int) -> Int-f x y = join j (z, w) = \(u, v) -> ...-        in jump j (x, y)--Typically this happens with functions that are seen as computing functions,-rather than being curried. (The real-life example was GHC.Data.Graph.Ops.addConflicts.)--When we create the wrapper, it *must* be in "eta-contracted" form so that the-jump has the right number of arguments:--f x y = join $wj z' w' = \u' v' -> let {z = z'; w = w'; u = u'; v = v'} in ...-             j (z, w)  = jump $wj z w--(See Note [Join points and beta-redexes] for where the lets come from.) If j-were a function, we would instead say--f x y = let $wj = \z' w' u' v' -> let {z = z'; w = w'; u = u'; v = v'} in ...-            j (z, w) (u, v) = $wj z w u v--Notice that the worker ends up with the same lambdas; it's only the wrapper we-have to be concerned about.--FIXME Currently the functionality to produce "eta-contracted" wrappers is-unimplemented; we simply give up.--************************************************************************-*                                                                      *-\subsection{Coercion stuff}-*                                                                      *-************************************************************************--We really want to "look through" coerces.-Reason: I've seen this situation:--        let f = coerce T (\s -> E)-        in \x -> case x of-                    p -> coerce T' f-                    q -> \s -> E2-                    r -> coerce T' f--If only we w/w'd f, we'd get-        let f = coerce T (\s -> fw s)-            fw = \s -> E-        in ...--Now we'll inline f to get--        let fw = \s -> E-        in \x -> case x of-                    p -> fw-                    q -> \s -> E2-                    r -> fw--Now we'll see that fw has arity 1, and will arity expand-the \x to get what we want.--}---- mkWWargs just does eta expansion--- is driven off the function type and arity.--- It chomps bites off foralls, arrows, newtypes--- and keeps repeating that until it's satisfied the supplied arity--mkWWargs :: TCvSubst            -- Freshening substitution to apply to the type-                                --   See Note [Freshen WW arguments]-         -> Type                -- The type of the function-         -> [Demand]     -- Demands and one-shot info for value arguments-         -> UniqSM  ([Var],            -- Wrapper args-                     CoreExpr -> CoreExpr,      -- Wrapper fn-                     CoreExpr -> CoreExpr,      -- Worker fn-                     Type)                      -- Type of wrapper body--mkWWargs subst fun_ty demands-  | null demands-  = return ([], id, id, substTyUnchecked subst fun_ty)-    -- I got an ASSERT failure here with `substTy`, and I was-    -- disinclined to pursue it since this code is about to be-    -- deleted by Sebastian--  | (dmd:demands') <- demands-  , Just (mult, arg_ty, fun_ty') <- splitFunTy_maybe fun_ty-  = do  { uniq <- getUniqueM-        ; let arg_ty' = substScaledTy subst (Scaled mult arg_ty)-              id = mk_wrap_arg uniq arg_ty' dmd-        ; (wrap_args, wrap_fn_args, work_fn_args, res_ty)-              <- mkWWargs subst fun_ty' demands'-        ; return (id : wrap_args,-                  Lam id . wrap_fn_args,-                  apply_or_bind_then work_fn_args (varToCoreExpr id),-                  res_ty) }--  | Just (tv, fun_ty') <- splitForAllTyCoVar_maybe fun_ty-  = do  { uniq <- getUniqueM-        ; let (subst', tv') = cloneTyVarBndr subst tv uniq-                -- See Note [Freshen WW arguments]-        ; (wrap_args, wrap_fn_args, work_fn_args, res_ty)-             <- mkWWargs subst' fun_ty' demands-        ; return (tv' : wrap_args,-                  Lam tv' . wrap_fn_args,-                  apply_or_bind_then work_fn_args (mkTyArg (mkTyVarTy tv')),-                  res_ty) }--  | Just (co, rep_ty) <- topNormaliseNewType_maybe fun_ty-        -- The newtype case is for when the function has-        -- a newtype after the arrow (rare)-        ---        -- It's also important when we have a function returning (say) a pair-        -- wrapped in a  newtype, at least if CPR analysis can look-        -- through such newtypes, which it probably can since they are-        -- simply coerces.--  = do { (wrap_args, wrap_fn_args, work_fn_args, res_ty)-            <-  mkWWargs subst rep_ty demands-       ; let co' = substCo subst co-       ; return (wrap_args,-                  \e -> Cast (wrap_fn_args e) (mkSymCo co'),-                  \e -> work_fn_args (Cast e co'),-                  res_ty) }--  | otherwise-  = WARN( True, ppr fun_ty )                    -- Should not happen: if there is a demand-    return ([], id, id, substTy subst fun_ty)   -- then there should be a function arrow-  where-    -- See Note [Join points and beta-redexes]-    apply_or_bind_then k arg (Lam bndr body)-      = mkCoreLet (NonRec bndr arg) (k body)    -- Important that arg is fresh!-    apply_or_bind_then k arg fun-      = k $ mkCoreApp (text "mkWWargs") fun arg-applyToVars :: [Var] -> CoreExpr -> CoreExpr-applyToVars vars fn = mkVarApps fn vars--mk_wrap_arg :: Unique -> Scaled Type -> Demand -> Id-mk_wrap_arg uniq (Scaled w ty) dmd-  = mkSysLocalOrCoVar (fsLit "w") uniq w ty-       `setIdDemandInfo` dmd--{- Note [Freshen WW arguments]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Wen we do a worker/wrapper split, we must not in-scope names as the arguments-of the worker, else we'll get name capture.  E.g.--   -- y1 is in scope from further out-   f x = ..y1..--If we accidentally choose y1 as a worker argument disaster results:--   fww y1 y2 = let x = (y1,y2) in ...y1...--To avoid this:--  * We use a fresh unique for both type-variable and term-variable binders-    Originally we lacked this freshness for type variables, and that led-    to the very obscure #12562.  (A type variable in the worker shadowed-    an outer term-variable binding.)--  * Because of this cloning we have to substitute in the type/kind of the-    new binders.  That's why we carry the TCvSubst through mkWWargs.--    So we need a decent in-scope set, just in case that type/kind-    itself has foralls.  We get this from the free vars of the RHS of the-    function since those are the only variables that might be captured.-    It's a lazy thunk, which will only be poked if the type/kind has a forall.--    Another tricky case was when f :: forall a. a -> forall a. a->a-    (i.e. with shadowing), and then the worker used the same 'a' twice.--}--{--************************************************************************-*                                                                      *-\subsection{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@-data DataConPatContext-  = DataConPatContext-  { dcpc_dc      :: !DataCon-  , dcpc_tc_args :: ![Type]-  , dcpc_co      :: !Coercion-  }---- | If @splitArgType_maybe ty = Just (dc, tys, co)@--- then @dc \@tys \@_ex_tys (_args::_arg_tys) :: tc tys@--- and  @co :: ty ~ tc tys@--- where underscore prefixes are holes, e.g. yet unspecified.------ See Note [Which types are unboxed?].-splitArgType_maybe :: FamInstEnvs -> Type -> Maybe DataConPatContext-splitArgType_maybe fam_envs ty-  | let (co, ty1) = topNormaliseType_maybe fam_envs ty-                    `orElse` (mkRepReflCo ty, ty)-  , Just (tc, tc_args) <- splitTyConApp_maybe ty1-  , Just con <- tyConSingleAlgDataCon_maybe tc-  = Just DataConPatContext { dcpc_dc      = con-                           , dcpc_tc_args = tc_args-                           , dcpc_co      = co }-splitArgType_maybe _ _ = Nothing---- | If @splitResultType_maybe n ty = Just (dc, tys, co)@--- then @dc \@tys \@_ex_tys (_args::_arg_tys) :: tc tys@--- and  @co :: ty ~ tc tys@--- where underscore prefixes are holes, e.g. yet unspecified.--- @dc@ is the @n@th data constructor of @tc@.------ See Note [Which types are unboxed?].-splitResultType_maybe :: FamInstEnvs -> ConTag -> Type -> Maybe DataConPatContext-splitResultType_maybe fam_envs con_tag ty-  | let (co, ty1) = topNormaliseType_maybe fam_envs ty-                    `orElse` (mkRepReflCo ty, ty)-  , Just (tc, tc_args) <- splitTyConApp_maybe ty1-  , isDataTyCon tc -- NB: rules out unboxed sums and pairs!-  , let cons = tyConDataCons tc-  , cons `lengthAtLeast` con_tag -- This might not be true if we import the-                                 -- type constructor via a .hs-boot file (#8743)-  , let con = cons `getNth` (con_tag - fIRST_TAG)-  , null (dataConExTyCoVars con) -- no existentials;-                                 -- See Note [Which types are unboxed?]-                                 -- and GHC.Core.Opt.CprAnal.extendEnvForDataAlt-                                 -- where we also check this.-  , all isLinear (dataConInstArgTys con tc_args)-  -- Deactivates CPR worker/wrapper splits on constructors with non-linear-  -- arguments, for the moment, because they require unboxed tuple with variable-  -- multiplicity fields.-  = Just DataConPatContext { dcpc_dc = con-                           , dcpc_tc_args = tc_args-                           , dcpc_co = co }-splitResultType_maybe _ _ _ = Nothing--isLinear :: Scaled a -> Bool-isLinear (Scaled w _ ) =-  case w of-    One -> True-    _ -> False---- | Describes the outer shape of an argument to be unboxed or left as-is--- Depending on how @s@ is instantiated (e.g., 'Demand').-data UnboxingDecision s-  = StopUnboxing-  -- ^ We ran out of strictness info. Leave untouched.-  | Unbox !DataConPatContext [s]-  -- ^ The argument is used strictly or the returned product was constructed, so-  -- unbox it.-  -- The 'DataConPatContext' carries the bits necessary for-  -- instantiation with 'dataConRepInstPat'.-  -- The @[s]@ carries the bits of information with which we can continue-  -- unboxing, e.g. @s@ will be 'Demand'.--wantToUnbox :: FamInstEnvs -> Bool -> Type -> Demand -> UnboxingDecision Demand--- See Note [Which types are unboxed?]-wantToUnbox fam_envs has_inlineable_prag ty dmd =-  case splitArgType_maybe fam_envs ty of-    Just dcpc@DataConPatContext{ dcpc_dc = dc }-      | isStrUsedDmd dmd || isUnliftedType ty-      , let arity = dataConRepArity dc-      -- See Note [Unpacking arguments with product and polymorphic demands]-      , Just cs <- split_prod_dmd_arity dmd arity-      -- See Note [Do not unpack class dictionaries]-      , not (has_inlineable_prag && isClassPred ty)-      -- See Note [mkWWstr and unsafeCoerce]-      , cs `lengthIs` arity-      -- See Note [Add demands for strict constructors]-      , let cs' = addDataConStrictness dc cs-      -> Unbox dcpc cs'-    _ -> StopUnboxing-  where-    split_prod_dmd_arity dmd arity-      -- For seqDmd, it should behave like <S(AAAA)>, for some-      -- suitable arity-      | isSeqDmd dmd        = Just (replicate arity absDmd)-      | _ :* Prod ds <- dmd = Just ds-      | otherwise           = Nothing--{- Note [Which types are unboxed?]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Worker/wrapper will unbox--  1. A strict data type argument, that-       * is an algebraic data type (not a newtype)-       * has a single constructor (thus is a "product")-       * that may bind existentials-     We can transform-     > 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)-       * (might have multiple constructors, in contrast to (1))-       * the applied data constructor *does not* bind existentials-     We can transform-     > f x y = let ... in D a b-     to-     > $wf x y = let ... in (# a, b #)-     via 'mkWWcpr'.--     NB: We don't allow existentials for CPR W/W, because we don't have unboxed-     dependent tuples (yet?). Otherwise, we could transform-     > f x y = let ... in D @ex (a :: ..ex..) (b :: ..ex..)-     to-     > $wf x y = let ... in (# @ex, (a :: ..ex..), (b :: ..ex..) #)--The respective tests are in 'splitArgType_maybe' and-'splitResultType_maybe', respectively.--Note that the data constructor /can/ have evidence arguments: equality-constraints, type classes etc.  So it can be GADT.  These evidence-arguments are simply value arguments, and should not get in the way.--Note [Unpacking arguments with product and polymorphic demands]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The argument is unpacked in a case if it has a product type and has a-strict *and* used demand put on it. I.e., arguments, with demands such-as the following ones:--   <S,U(U, L)>-   <S(L,S),U>--will be unpacked, but--   <S,U> or <B,U>--will not, because the pieces aren't used. This is quite important otherwise-we end up unpacking massive tuples passed to the bottoming function. Example:--        f :: ((Int,Int) -> String) -> (Int,Int) -> a-        f g pr = error (g pr)--        main = print (f fst (1, error "no"))--Does 'main' print "error 1" or "error no"?  We don't really want 'f'-to unbox its second argument.  This actually happened in GHC's onwn-source code, in Packages.applyPackageFlag, which ended up un-boxing-the enormous DynFlags tuple, and being strict in the-as-yet-un-filled-in unitState files.--Note [Do not unpack class dictionaries]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If we have-   f :: Ord a => [a] -> Int -> a-   {-# INLINABLE f #-}-and we worker/wrapper f, we'll get a worker with an INLINABLE pragma-(see Note [Worker-wrapper for INLINABLE functions] in 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.--But in any other situation a dictionary is just an ordinary value,-and can be unpacked.  So we track the INLINABLE pragma, and switch-off the unpacking in mkWWstr_one (see the isClassPred test).--Historical note: #14955 describes how I got this fix wrong the first time.--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 [Add demands for strict constructors]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this program (due to Roman):--    data X a = X !a--    foo :: X Int -> Int -> Int-    foo (X a) n = go 0-     where-       go i | i < n     = a + go (i+1)-            | otherwise = 0--We want the worker for 'foo' too look like this:--    $wfoo :: Int# -> Int# -> Int#--with the first argument unboxed, so that it is not eval'd each time-around the 'go' loop (which would otherwise happen, since 'foo' is not-strict in 'a').  It is sound for the wrapper to pass an unboxed arg-because X is strict, so its argument must be evaluated.  And if we-*don't* pass an unboxed argument, we can't even repair it by adding a-`seq` thus:--    foo (X a) n = a `seq` go 0--because the seq is discarded (very early) since X is strict!--So here's what we do--* We leave the demand-analysis alone.  The demand on 'a' in the-  definition of 'foo' is <L, U(U)>; the strictness info is Lazy-  because foo's body may or may not evaluate 'a'; but the usage info-  says that 'a' is unpacked and its content is used.--* During worker/wrapper, if we unpack a strict constructor (as we do-  for 'foo'), we use 'addDataConStrictness' to bump up the strictness on-  the strict arguments of the data constructor.--* That in turn means that, if the usage info supports doing so-  (i.e. splitProdDmd_maybe returns Just), we will unpack that argument-  -- even though the original demand (e.g. on 'a') was lazy.--* What does "bump up the strictness" mean?  Just add a head-strict-  demand to the strictness!  Even for a demand like <L,A> we can-  safely turn it into <S,A>; remember case (1) of-  Note [How to do the worker/wrapper split].--The net effect is that the w/w transformation is more aggressive about-unpacking the strict arguments of a data constructor, when that-eagerness is supported by the usage info.--There is the usual danger of reboxing, which as usual we ignore. But-if X is monomorphic, and has an UNPACK pragma, then this optimisation-is even more important.  We don't want the wrapper to rebox an unboxed-argument, and pass an Int to $wfoo!--This works in nested situations like--    data family Bar a-    data instance Bar (a, b) = BarPair !(Bar a) !(Bar b)-    newtype instance Bar Int = Bar Int--    foo :: Bar ((Int, Int), Int) -> Int -> Int-    foo f k = case f of BarPair x y ->-              case burble of-                 True -> case x of-                           BarPair p q -> ...-                 False -> ...--The extra eagerness lets us produce a worker of type:-     $wfoo :: Int# -> Int# -> Int# -> Int -> Int-     $wfoo p# q# y# = ...--even though the `case x` is only lazily evaluated.----------- Historical note -------------We used to add data-con strictness demands when demand analysing case-expression. However, it was noticed in #15696 that this misses some cases. For-instance, consider the program (from T10482)--    data family Bar a-    data instance Bar (a, b) = BarPair !(Bar a) !(Bar b)-    newtype instance Bar Int = Bar Int--    foo :: Bar ((Int, Int), Int) -> Int -> Int-    foo f k =-      case f of-        BarPair x y -> case burble of-                          True -> case x of-                                    BarPair p q -> ...-                          False -> ...--We really should be able to assume that `p` is already evaluated since it came-from a strict field of BarPair. This strictness would allow us to produce a-worker of type:--    $wfoo :: Int# -> Int# -> Int# -> Int -> Int-    $wfoo p# q# y# = ...--even though the `case x` is only lazily evaluated--Indeed before we fixed #15696 this would happen since we would float the inner-`case x` through the `case burble` to get:--    foo f k =-      case f of-        BarPair x y -> case x of-                          BarPair p q -> case burble of-                                          True -> ...-                                          False -> ...--However, after fixing #15696 this could no longer happen (for the reasons-discussed in ticket:15696#comment:76). This means that the demand placed on `f`-would then be significantly weaker (since the False branch of the case on-`burble` is not strict in `p` or `q`).--Consequently, we now instead account for data-con strictness in mkWWstr_one,-applying the strictness demands to the final result of DmdAnal. The result is-that we get the strict demand signature we wanted even if we can't float-the case on `x` up through the case on `burble`.--}--{--************************************************************************-*                                                                      *-\subsection{Strictness stuff}-*                                                                      *-************************************************************************--}--mkWWstr :: DynFlags-        -> FamInstEnvs-        -> Bool    -- True <=> INLINEABLE pragma on this function defn-                   -- See Note [Do not unpack class dictionaries]-        -> [Var]                                -- Wrapper args; have their demand info on them-                                                --  *Includes type variables*-        -> UniqSM (Bool,                        -- Is this useful-                   [Var],                       -- Worker args-                   CoreExpr -> CoreExpr,        -- Wrapper body, lacking the worker call-                                                -- and without its lambdas-                                                -- This fn adds the unboxing--                   CoreExpr -> CoreExpr)        -- Worker body, lacking the original body of the function,-                                                -- and lacking its lambdas.-                                                -- This fn does the reboxing-mkWWstr dflags fam_envs has_inlineable_prag args-  = go args-  where-    go_one arg = mkWWstr_one dflags fam_envs has_inlineable_prag arg--    go []           = return (False, [], nop_fn, nop_fn)-    go (arg : args) = do { (useful1, args1, wrap_fn1, work_fn1) <- go_one arg-                         ; (useful2, args2, wrap_fn2, work_fn2) <- go args-                         ; return ( useful1 || useful2-                                  , args1 ++ args2-                                  , wrap_fn1 . wrap_fn2-                                  , work_fn1 . work_fn2) }--------------------------- mkWWstr_one wrap_arg = (useful, work_args, wrap_fn, work_fn)---   *  wrap_fn assumes wrap_arg is in scope,---        brings into scope work_args (via cases)---   * work_fn assumes work_args are in scope, a---        brings into scope wrap_arg (via lets)--- See Note [How to do the worker/wrapper split]-mkWWstr_one :: DynFlags -> FamInstEnvs-            -> Bool    -- True <=> INLINEABLE pragma on this function defn-                       -- See Note [Do not unpack class dictionaries]-            -> Var-            -> UniqSM (Bool, [Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)-mkWWstr_one dflags fam_envs has_inlineable_prag arg-  | isTyVar arg-  = return (False, [arg],  nop_fn, nop_fn)--  | isAbsDmd dmd-  , Just work_fn <- mk_absent_let dflags arg dmd-     -- Absent case.  We can't always handle absence for rep-polymorphic-     -- types, so we need to choose just the cases we can-     -- (that's what mk_absent_let does)-  = return (True, [], nop_fn, work_fn)--  | Unbox dcpc cs <- wantToUnbox fam_envs has_inlineable_prag arg_ty dmd-  = unbox_one dflags fam_envs arg cs dcpc--  | otherwise   -- Other cases-  = return (False, [arg], nop_fn, nop_fn)--  where-    arg_ty = idType arg-    dmd    = idDemandInfo arg--unbox_one :: DynFlags -> FamInstEnvs -> Var-          -> [Demand]-          -> DataConPatContext-          -> UniqSM (Bool, [Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)-unbox_one dflags fam_envs arg cs-          DataConPatContext { dcpc_dc = dc, dcpc_tc_args = tc_args-                            , dcpc_co = co }-  = do { (case_bndr_uniq:pat_bndrs_uniqs) <- getUniquesM-       ; let ex_name_fss     = map getOccFS $ dataConExTyCoVars dc-             (ex_tvs', arg_ids) =-               dataConRepFSInstPat (ex_name_fss ++ repeat ww_prefix) pat_bndrs_uniqs (idMult arg) dc tc_args-             arg_ids'  = zipWithEqual "unbox_one" setIdDemandInfo arg_ids cs-             unbox_fn  = mkUnpackCase (Var arg) co (idMult arg) case_bndr_uniq-                                      dc (ex_tvs' ++ arg_ids')-             arg_no_unf = zapStableUnfolding arg-                          -- See Note [Zap unfolding when beta-reducing]-                          -- in GHC.Core.Opt.Simplify; and see #13890-             rebox_fn   = Let (NonRec arg_no_unf con_app)-             con_app    = mkConApp2 dc tc_args (ex_tvs' ++ arg_ids') `mkCast` mkSymCo co-       ; (_, worker_args, wrap_fn, work_fn) <- mkWWstr dflags fam_envs False (ex_tvs' ++ arg_ids')-       ; return (True, worker_args, unbox_fn . wrap_fn, work_fn . rebox_fn) }-                          -- Don't pass the arg, rebox instead--nop_fn :: CoreExpr -> CoreExpr-nop_fn body = body--addDataConStrictness :: DataCon -> [Demand] -> [Demand]--- See Note [Add demands for strict constructors]-addDataConStrictness con ds-  | Nothing <- dataConWrapId_maybe con-  -- DataCon worker=wrapper. Implies no strict fields, so nothing to do-  = ds-addDataConStrictness con ds-  = zipWithEqual "addDataConStrictness" add ds strs-  where-    strs = dataConRepStrictness con-    add dmd str | isMarkedStrict str = strictifyDmd dmd-                | otherwise          = dmd--{- Note [How to do the worker/wrapper split]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The worker-wrapper transformation, mkWWstr_one, takes into account-several possibilities to decide if the function is worthy for-splitting:--1. If an argument is absent, it would be silly to pass it to-   the worker.  Hence the isAbsDmd case.  This case must come-   first because a demand like <S,A> or <B,A> is possible.-   E.g. <B,A> comes from a function like-       f x = error "urk"-   and <S,A> can come from Note [Add demands for strict constructors]--2. If the argument is evaluated strictly, and we can split the-   product demand (splitProdDmd_maybe), then unbox it and w/w its-   pieces.  For example--    f :: (Int, Int) -> Int-    f p = (case p of (a,b) -> a) + 1-  is split to-    f :: (Int, Int) -> Int-    f p = case p of (a,b) -> $wf a--    $wf :: Int -> Int-    $wf a = a + 1--  and-    g :: Bool -> (Int, Int) -> Int-    g c p = case p of (a,b) ->-               if c then a else b-  is split to-   g c p = case p of (a,b) -> $gw c a b-   $gw c a b = if c then a else b--2a But do /not/ split if the components are not used; that is, the-   usage is just 'Used' rather than 'UProd'. In this case-   splitProdDmd_maybe returns Nothing.  Otherwise we risk decomposing-   a massive tuple which is barely used.  Example:--        f :: ((Int,Int) -> String) -> (Int,Int) -> a-        f g pr = error (g pr)--        main = print (f fst (1, error "no"))--   Here, f does not take 'pr' apart, and it's stupid to do so.-   Imagine that it had millions of fields. This actually happened-   in GHC itself where the tuple was DynFlags--3. A plain 'seqDmd', which is head-strict with usage UHead, can't-   be split by splitProdDmd_maybe.  But we want it to behave just-   like U(AAAA) for suitable number of absent demands. So we have-   a special case for it, with arity coming from the data constructor.--Note [Worker-wrapper for bottoming functions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We used not to split if the result is bottom.-[Justification:  there's no efficiency to be gained.]--But it's sometimes bad not to make a wrapper.  Consider-        fw = \x# -> let x = I# x# in case e of-                                        p1 -> error_fn x-                                        p2 -> error_fn x-                                        p3 -> the real stuff-The re-boxing code won't go away unless error_fn gets a wrapper too.-[We don't do reboxing now, but in general it's better to pass an-unboxed thing to f, and have it reboxed in the error cases....]--Note [Record evaluated-ness in worker/wrapper]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we have--   data T = MkT !Int Int--   f :: T -> T-   f x = e--and f's is strict, and has the CPR property.  The we are going to generate-this w/w split--   f x = case x of-           MkT x1 x2 -> case $wf x1 x2 of-                           (# r1, r2 #) -> MkT r1 r2--   $wfw x1 x2 = let x = MkT x1 x2 in-                case e of-                  MkT r1 r2 -> (# r1, r2 #)--Note that--* In the worker $wf, inside 'e' we can be sure that x1 will be-  evaluated (it came from unpacking the argument MkT.  But that's no-  immediately apparent in $wf--* In the wrapper 'f', which we'll inline at call sites, we can be sure-  that 'r1' has been evaluated (because it came from unpacking the result-  MkT.  But that is not immediately apparent from the wrapper code.--Missing these facts isn't unsound, but it loses possible future-opportunities for optimisation.--Solution: use setCaseBndrEvald when creating- (A) The arg binders x1,x2 in mkWstr_one-         See #13077, test T13077- (B) The result binders r1,r2 in mkWWcpr_help-         See Trace #13077, test T13077a-         And #13027 comment:20, item (4)-to record that the relevant binder is evaluated.---************************************************************************-*                                                                      *-         Type scrutiny that is specific to demand analysis-*                                                                      *-************************************************************************--}--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 (_, rhs, _) <- topReduceTyFamApp_maybe fam_envs tc tc_args-       = go rec_tc rhs--       | Just con <- tyConSingleAlgDataCon_maybe tc-       , Just rec_tc <- if isTupleTyCon tc-                        then Just rec_tc-                        else checkRecTc rec_tc tc-         -- We treat tuples specially because they can't cause loops.-         -- Maybe we should do so in checkRecTc.-         -- The use of 'dubiousDataConInstArgTys' is OK, since this-         -- function performs no substitution at all, hence the uniques-         -- don't matter.-       = 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---- | Exactly 'dataConInstArgTys', but lacks the (ASSERT'ed) precondition that--- the 'DataCon' may not have existentials. The lack of cloning the existentials--- compared to 'dataConInstExAndArgVars' makes this function \"dubious\";--- only use it where type variables aren't substituted for!-dubiousDataConInstArgTys :: DataCon -> [Type] -> [Type]-dubiousDataConInstArgTys dc tc_args = arg_tys-  where-    univ_tvs = dataConUnivTyVars dc-    ex_tvs   = dataConExTyCoVars dc-    subst    = extendTCvInScopeList (zipTvSubst univ_tvs tc_args) ex_tvs-    arg_tys  = map (substTy subst . scaledThing) (dataConRepArgTys dc)--{--************************************************************************-*                                                                      *-\subsection{CPR stuff}-*                                                                      *-************************************************************************---@mkWWcpr@ takes the worker/wrapper pair produced from the strictness-info and adds in the CPR transformation.  The worker returns an-unboxed tuple containing non-CPR components.  The wrapper takes this-tuple and re-produces the correct structured output.--The non-CPR results appear ordered in the unboxed tuple as if by a-left-to-right traversal of the result structure.--}--mkWWcpr :: Bool-        -> FamInstEnvs-        -> Type                              -- function body type-        -> Cpr                               -- CPR analysis results-        -> UniqSM (Bool,                     -- Is w/w'ing useful?-                   CoreExpr -> CoreExpr,     -- New wrapper-                   CoreExpr -> CoreExpr,     -- New worker-                   Type)                     -- Type of worker's body--mkWWcpr opt_CprAnal fam_envs body_ty cpr-    -- CPR explicitly turned off (or in -O0)-  | not opt_CprAnal = return (False, id, id, body_ty)-    -- CPR is turned on by default for -O and O2-  | otherwise-  = case asConCpr cpr of-       Nothing      -> return (False, id, id, body_ty)  -- No CPR info-       Just (con_tag, _cprs)-         | Just dcpc <- splitResultType_maybe fam_envs con_tag body_ty-         -> mkWWcpr_help dcpc-         |  otherwise-         -- See Note [non-algebraic or open body type warning]-         -> WARN( True, text "mkWWcpr: non-algebraic or open body type" <+> ppr body_ty )-            return (False, id, id, body_ty)--mkWWcpr_help :: DataConPatContext-             -> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type)--mkWWcpr_help (DataConPatContext { dcpc_dc = dc, dcpc_tc_args = tc_args-                                , dcpc_co = co })-  | [arg_ty]   <- dataConInstArgTys dc tc_args -- NB: No existentials!-  , [str_mark] <- dataConRepStrictness dc-  , isUnliftedType (scaledThing arg_ty)-  , isLinear arg_ty-        -- Special case when there is a single result of unlifted, linear, type-        ---        -- Wrapper:     case (..call worker..) of x -> C x-        -- Worker:      case (   ..body..    ) of C x -> x-  = do { (work_uniq : arg_uniq : _) <- getUniquesM-       ; let arg_id    = mk_ww_local arg_uniq str_mark arg_ty-             con_app   = mkConApp2 dc tc_args [arg_id] `mkCast` mkSymCo co--       ; return ( True-                , \ wkr_call -> mkDefaultCase wkr_call arg_id con_app-                , \ body     -> mkUnpackCase body co One work_uniq dc [arg_id] (varToCoreExpr arg_id)-                                -- varToCoreExpr important here: arg can be a coercion-                                -- Lacking this caused #10658-                , scaledThing arg_ty ) }--  | otherwise   -- The general case-        -- Wrapper: case (..call worker..) of (# a, b #) -> C a b-        -- Worker:  case (   ...body...  ) of C a b -> (# a, b #)-        ---        -- Remark on linearity: in both the case of the wrapper and the worker,-        -- we build a linear case. All the multiplicity information is kept in-        -- the constructors (both C and (#, #)). In particular (#,#) is-        -- parametrised 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.-  = do { (work_uniq : wild_uniq : pat_bndrs_uniqs) <- getUniquesM-       ; let case_mult       = One -- see above-             (_exs, arg_ids) =-               dataConRepFSInstPat (repeat ww_prefix) pat_bndrs_uniqs case_mult dc tc_args-             wrap_wild       = mk_ww_local wild_uniq MarkedStrict (Scaled case_mult ubx_tup_ty)-             ubx_tup_ty      = exprType ubx_tup_app-             ubx_tup_app     = mkCoreUbxTup (map idType arg_ids) (map varToCoreExpr arg_ids)-             con_app         = mkConApp2 dc tc_args arg_ids `mkCast` mkSymCo co-             tup_con         = tupleDataCon Unboxed (length arg_ids)--       ; MASSERT( null _exs ) -- Should have been caught by splitResultType_maybe--       ; return (True-                , \ wkr_call -> mkSingleAltCase wkr_call wrap_wild-                                                (DataAlt tup_con) arg_ids con_app-                , \ body     -> mkUnpackCase body co case_mult work_uniq dc arg_ids ubx_tup_app-                , ubx_tup_ty ) }--mkUnpackCase ::  CoreExpr -> Coercion -> Mult -> Unique -> DataCon -> [Id] -> CoreExpr -> CoreExpr--- (mkUnpackCase e co uniq Con args body)---      returns--- case e |> co of bndr { Con args -> body }--mkUnpackCase (Tick tickish e) co mult uniq con args body   -- See Note [Profiling and unpacking]-  = Tick tickish (mkUnpackCase e co mult uniq con args body)-mkUnpackCase scrut co mult uniq boxing_con unpk_args body-  = mkSingleAltCase casted_scrut bndr-                    (DataAlt boxing_con) unpk_args body-  where-    casted_scrut = scrut `mkCast` co-    bndr = mk_ww_local uniq MarkedStrict (Scaled mult (exprType casted_scrut))-      -- An unpacking case can always be chosen linear, because the variables-      -- are always passed to a constructor. This limits the-{--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'easily W/W constructed results like `Stream` because we have no simple-way to express existential types in the worker's type signature.--Note [Profiling and unpacking]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If the original function looked like-        f = \ x -> {-# SCC "foo" #-} E--then we want the CPR'd worker to look like-        \ x -> {-# SCC "foo" #-} (case E of I# x -> x)-and definitely not-        \ x -> case ({-# SCC "foo" #-} E) of I# x -> x)--This transform doesn't move work or allocation-from one cost centre to another.--Later [SDM]: presumably this is because we want the simplifier to-eliminate the case, and the scc would get in the way?  I'm ok with-including the case itself in the cost centre, since it is morally-part of the function (post transformation) anyway.---************************************************************************-*                                                                      *-\subsection{Utilities}-*                                                                      *-************************************************************************--Note [Absent fillers]-~~~~~~~~~~~~~~~~~~~~~-Consider--  data T = MkT [Int] [Int] ![Int]  -- NB: last field is strict-  f :: T -> Int# -> blah-  f ps w = case ps of MkT xs ys zs -> <body mentioning xs>--Then f gets a strictness sig of <S(L,A,A)><A>. We make a worker $wf thus:--  $wf :: [Int] -> blah-  $wf xs = case ps of MkT xs _ _ -> <body mentioning xs>-    where-      ys = absentError "ys :: [Int]"-      zs = RUBBISH[LiftedRep] @[Int]-      ps = MkT xs ys zs-      w  = RUBBISH[IntRep] @Int#--The absent arguments 'ys', 'zs' and 'w' aren't even passed to the worker.-And neither should they! They are never used, their value is irrelevant (hence-they are *dead code*) and they are probably discarded after the next run of the-Simplifier (when they are in fact *unreachable code*). Yet, we have to come up-with "filler" values that we bind the absent arg Ids to.--That is exactly what Note [Rubbish literals] are for: A convenient way to-conjure filler values at any type (and any representation or levity!).--Needless to say, there are some wrinkles:--  1. In case we have a absent, /lazy/, and /lifted/ arg, we use an error-thunk-     instead. If absence analysis was wrong (e.g., #11126) and the binding-     in fact is used, then we get a nice panic message instead of undefined-     runtime behavior (See Modes of failure from Note [Rubbish literals]).--     Obviously, we can't use an error-thunk if the value is of unlifted rep-     (like 'Int#' or 'MutVar#'), because we'd immediately evaluate the panic.--  2. We also mustn't put an error-thunk (that fills in for an absent value of-     lifted rep) in a strict field, because #16970 establishes the invariant-     that strict fields are always evaluated, by (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, but-     it's quite nasty to thread the marks though 'mkWWstr' and 'mkWWstr_one'.-     So we rather look out for a necessary condition for strict fields:-     Note [Add demands for strict constructors] 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 guarantees-     we 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, but that's a small price to pay for simplicity.--  3. We can only emit a RubbishLit 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.-     'typeMonoPrimRep_maybe' returns 'Nothing' in this case and we simply fall-     back to passing the original parameter to the worker.--     Note that currently this case should not occur, because binders always-     have to be representation monomorphic. But in the future, we might allow-     levity polymorphism, e.g. a polymorphic levity variable in 'BoxedRep'.--While (1) and (2) are simply an optimisation in terms of compiler debugging-experience, (3) should be irrelevant in most programs, if not all.--Historical note: I did try the experiment of using an error thunk for unlifted-things too, relying on the simplifier to drop it as dead code.  But this is-fragile-- - It fails when profiling is on, which disables various optimisations-- - It fails when reboxing happens. E.g.-      data T = MkT Int Int#-      f p@(MkT a _) = ...g p....-   where g is /lazy/ in 'p', but only uses the first component.  Then-   'f' is /strict/ in 'p', and only uses the first component.  So we only-   pass that component to the worker for 'f', which reconstructs 'p' to-   pass it to 'g'.  Alas we can't say-       ...f (MkT a (absentError Int# "blah"))...-   because `MkT` is strict in its Int# argument, so we get an absentError-   exception when we shouldn't.  Very annoying!--}---- | Tries to find a suitable dummy RHS to bind the given absent identifier to.------ If @mk_absent_let _ id == Just wrap@, then @wrap e@ will wrap a let binding--- for @id@ with that RHS around @e@. Otherwise, there could no suitable RHS be--- found.-mk_absent_let :: DynFlags -> Id -> Demand -> Maybe (CoreExpr -> CoreExpr)-mk_absent_let dflags arg dmd-  -- The lifted case: Bind 'absentError' for a nice panic message if we are-  -- wrong (like we were in #11126). See (1) in Note [Absent fillers]-  | not (isUnliftedType arg_ty)-  , not (isStrictDmd dmd) -- See (2) in Note [Absent fillers]-  = Just (Let (NonRec arg panic_rhs))--  -- The default case for mono rep: Bind `RUBBISH[rr] \@arg_ty`-  -- See Note [Absent fillers], the main part-  | Just lit_expr <- mkLitRubbish arg_ty-  = Just (bindNonRec arg lit_expr)--  -- Catch all: Either @arg_ty@ wasn't of form @TYPE rep@ or @rep@ wasn't mono rep.-  -- See (3) in Note [Absent fillers]-  | otherwise-  = WARN( True, text "No absent value for" <+> ppr arg_ty )-    Nothing-  where-    arg_ty            = idType arg--    panic_rhs = mkAbsentErrorApp arg_ty msg--    msg       = showSDoc (gopt_set dflags Opt_SuppressUniques)-                         (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  = case outputFile dflags of-                  Nothing -> empty-                  Just f  -> text "In output file " <+> quotes (text f)--ww_prefix :: FastString-ww_prefix = fsLit "ww"--mk_ww_local :: Unique -> StrictnessMark -> Scaled Type -> Id--- The StrictnessMark comes form the data constructor and says--- whether this field is strict--- See Note [Record evaluated-ness in worker/wrapper]-mk_ww_local uniq str (Scaled w ty)-  = setCaseBndrEvald str $-    mkSysLocalOrCoVar ww_prefix uniq w ty++{-# LANGUAGE ViewPatterns #-}++module GHC.Core.Opt.WorkWrap.Utils+   ( WwOpts(..), initWwOpts, mkWwBodies, mkWWstr, mkWWstr_one+   , needsVoidWorkerArg, addVoidWorkerArg+   , DataConPatContext(..)+   , UnboxingDecision(..), wantToUnboxArg+   , findTypeShape, IsRecDataConResult(..), isRecDataCon+   , mkAbsentFiller+   , isWorkerSmallEnough, dubiousDataConInstArgTys+   , isGoodWorker, badWorker , goodWorker+   )+where++import GHC.Prelude++import GHC.Driver.Session+import GHC.Driver.Config (initSimpleOpts)++import GHC.Core+import GHC.Core.Utils+import GHC.Core.DataCon+import GHC.Core.Make+import GHC.Core.Subst+import GHC.Core.Type+import GHC.Core.Multiplicity+import GHC.Core.Coercion+import GHC.Core.Reduction+import GHC.Core.FamInstEnv+import GHC.Core.TyCon+import GHC.Core.TyCon.Set+import GHC.Core.TyCon.RecWalk+import GHC.Core.SimpleOpt( SimpleOpts )++import GHC.Types.Id+import GHC.Types.Id.Info+import GHC.Types.Demand+import GHC.Types.Cpr+import GHC.Types.Id.Make ( voidArgId, voidPrimId )+import GHC.Types.Var.Env+import GHC.Types.Basic+import GHC.Types.Unique.Supply+import GHC.Types.Name ( getOccFS )++import GHC.Data.FastString+import GHC.Data.OrdList+import GHC.Data.List.SetOps++import GHC.Builtin.Types ( tupleDataCon )++import GHC.Utils.Misc+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Utils.Panic.Plain+import GHC.Utils.Trace++import Control.Applicative ( (<|>) )+import Control.Monad ( zipWithM )+import Data.List ( unzip4 )++import GHC.Types.RepType+import GHC.Unit.Types++{-+************************************************************************+*                                                                      *+\subsection[mkWrapperAndWorker]{@mkWrapperAndWorker@}+*                                                                      *+************************************************************************++Here's an example.  The original function is:++\begin{verbatim}+g :: forall a . Int -> [a] -> a++g = \/\ a -> \ x ys ->+        case x of+          0 -> head ys+          _ -> head (tail ys)+\end{verbatim}++From this, we want to produce:+\begin{verbatim}+-- wrapper (an unfolding)+g :: forall a . Int -> [a] -> a++g = \/\ a -> \ x ys ->+        case x of+          I# x# -> $wg a x# ys+            -- call the worker; don't forget the type args!++-- worker+$wg :: forall a . Int# -> [a] -> a++$wg = \/\ a -> \ x# ys ->+        let+            x = I# x#+        in+            case x of               -- note: body of g moved intact+              0 -> head ys+              _ -> head (tail ys)+\end{verbatim}++Something we have to be careful about:  Here's an example:++\begin{verbatim}+-- "f" strictness: U(P)U(P)+f (I# a) (I# b) = a +# b++g = f   -- "g" strictness same as "f"+\end{verbatim}++\tr{f} will get a worker all nice and friendly-like; that's good.+{\em But we don't want a worker for \tr{g}}, even though it has the+same strictness as \tr{f}.  Doing so could break laziness, at best.++Consequently, we insist that the number of strictness-info items is+exactly the same as the number of lambda-bound arguments.  (This is+probably slightly paranoid, but OK in practice.)  If it isn't the+same, we ``revise'' the strictness info, so that we won't propagate+the unusable strictness-info into the interfaces.+++************************************************************************+*                                                                      *+\subsection{The worker wrapper core}+*                                                                      *+************************************************************************++@mkWwBodies@ is called when doing the worker\/wrapper split inside a module.+-}++data WwOpts+  = MkWwOpts+  { wo_fam_envs          :: !FamInstEnvs+  , wo_simple_opts       :: !SimpleOpts+  , wo_cpr_anal          :: !Bool++  -- Used for absent argument error message+  , wo_module            :: !Module+  , wo_unlift_strict     :: !Bool -- Generate workers even if the only effect is some args+                                  -- get passed unlifted.+                                  -- See Note [WW for calling convention]+  }++initWwOpts :: Module -> DynFlags -> FamInstEnvs -> WwOpts+initWwOpts 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+  }++type WwResult+  = ([Demand],              -- Demands for worker (value) args+     JoinArity,             -- Number of worker (type OR value) args+     Id -> CoreExpr,        -- Wrapper body, lacking only the worker Id+     CoreExpr -> CoreExpr)  -- Worker body, lacking the original function rhs++nop_fn :: CoreExpr -> CoreExpr+nop_fn body = body+++mkWwBodies :: WwOpts+           -> Id             -- ^ The original function+           -> [Var]          -- ^ Manifest args of original function+           -> Type           -- ^ Result type of the original function,+                             --   after being stripped of args+           -> [Demand]       -- ^ Strictness of original function+           -> Cpr            -- ^ Info about function result+           -> UniqSM (Maybe WwResult)+-- ^ Given a function definition+--+-- > data T = MkT Int Bool Char+-- > f :: (a, b) -> Int -> T+-- > f = \x y -> E+--+-- @mkWwBodies _ 'f' ['x::(a,b)','y::Int'] '(a,b)' ['1P(L,L)', '1P(L)'] '1'@+-- returns+--+--   * The wrapper body context for the call to the worker function, lacking+--     only the 'Id' for the worker function:+--+--     > W[_] :: Id -> CoreExpr+--     > W[work_fn] = \x y ->          -- args of the wrapper    (cloned_arg_vars)+--     >   case x of (a, b) ->         -- unbox wrapper args     (wrap_fn_str)+--     >   case y of I# n ->           --+--     >   case <work_fn> a b n of     -- call to the worker fun (call_work)+--     >   (# i, b, c #) -> MkT i b c  -- rebox result           (wrap_fn_cpr)+--+--   * The worker body context that wraps around its hole reboxing defns for x+--     and y, as well as returning CPR transit variables of the unboxed MkT+--     result in an unboxed tuple:+--+--     > w[_] :: CoreExpr -> CoreExpr+--     > w[fn_rhs] = \a b n ->              -- args of the worker       (work_lam_args)+--     >   let { y = I# n; x = (a, b) } in  -- reboxing wrapper args    (work_fn_str)+--     >   case <fn_rhs> x y of             -- call to the original RHS (call_rhs)+--     >   MkT i b c -> (# i, b, c #)       -- return CPR transit vars  (work_fn_cpr)+--+--     NB: The wrap_rhs hole is to be filled with the original wrapper RHS+--     @\x y -> E@. This is so that we can also use @w@ to transform stable+--     unfoldings, the lambda args of which may be different than x and y.+--+--   * Id details for the worker function like demands on arguments and its join+--     arity.+--+-- All without looking at E (except for beta reduction, see Note [Join points+-- and beta-redexes]), which allows us to apply the same split to function body+-- and its unfolding(s) alike.+--+mkWwBodies opts fun_id arg_vars res_ty demands res_cpr+  = do  { massertPpr (filter isId arg_vars `equalLength` demands)+                     (text "wrong wrapper arity" $$ ppr fun_id $$ ppr arg_vars $$ ppr res_ty $$ ppr demands)++        -- Clone and prepare arg_vars of the original fun RHS+        -- See Note [Freshen WW arguments]+        -- and Note [Zap IdInfo on worker args]+        ; uniq_supply <- getUniqueSupplyM+        ; let args_free_tcvs = tyCoVarsOfTypes (res_ty : map varType arg_vars)+              empty_subst = mkEmptySubst (mkInScopeSet args_free_tcvs)+              zapped_arg_vars = map zap_var arg_vars+              (subst, cloned_arg_vars) = cloneBndrs empty_subst uniq_supply zapped_arg_vars+              res_ty' = GHC.Core.Subst.substTy subst res_ty+              init_cbv_marks = map (const NotMarkedStrict) cloned_arg_vars++        ; (useful1, work_args_cbv, wrap_fn_str, fn_args)+             <- mkWWstr opts cloned_arg_vars init_cbv_marks++        ; let (work_args, work_marks) = unzip work_args_cbv++        -- 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_cbv)+                | 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_cbv)+              worker_body = mkLams work_lam_args . work_seq_str_flds . work_fn_cpr . call_rhs+              worker_args_dmds= [(idDemandInfo v) | v <- work_call_args, isId v]++        ; if ((useful1 && not only_one_void_argument) || useful2)+          then return (Just (worker_args_dmds, length work_call_args,+                       wrapper_body, worker_body))+          else return Nothing+        }+        -- We use an INLINE unconditionally, even if the wrapper turns out to be+        -- something trivial like+        --      fw = ...+        --      f = __inline__ (coerce T fw)+        -- The point is to propagate the coerce to f's call sites, so even though+        -- f's RHS is now trivial (size 1) we still want the __inline__ to prevent+        -- fw from being inlined into f's RHS+  where+    zap_var v | isTyVar v = v+              | otherwise = modifyIdInfo zap_info v+    zap_info info -- See Note [Zap IdInfo on worker args]+      = info `setOccInfo`       noOccInfo++    -- Note [Do not split void functions]+    only_one_void_argument+      | [d] <- demands+      , [v] <- filter isId arg_vars+      , isAbsDmd d && isZeroBitTy (idType v)+      = True+      | otherwise+      = False++-- | Version of 'GHC.Core.mkApps' that does beta reduction on-the-fly.+-- PRECONDITION: The arg expressions are not free in any of the lambdas binders.+mkAppsBeta :: CoreExpr -> [CoreArg] -> CoreExpr+-- The precondition holds for our call site in mkWwBodies, because all the FVs+-- of as are either cloned_arg_vars (and thus fresh) or fresh worker args.+mkAppsBeta (Lam b body) (a:as) = bindNonRec b a $! mkAppsBeta body as+mkAppsBeta f            as     = mkApps f as++-- See Note [Limit w/w arity]+isWorkerSmallEnough :: Int -> Int -> [Var] -> Bool+isWorkerSmallEnough max_worker_args old_n_args vars+  = count isId vars <= max old_n_args max_worker_args+    -- We count only Free variables (isId) to skip Type, Kind+    -- variables which have no runtime representation.+    -- Also if the function took 82 arguments before (old_n_args), it's fine if+    -- it takes <= 82 arguments afterwards.++{-+Note [Always do CPR w/w]+~~~~~~~~~~~~~~~~~~~~~~~~+At one time we refrained from doing CPR w/w for thunks, on the grounds that+we might duplicate work.  But that is already handled by the demand analyser,+which doesn't give the CPR property if w/w might waste work: see+Note [CPR for thunks] in GHC.Core.Opt.DmdAnal.++And if something *has* been given the CPR property and we don't w/w, it's+a disaster, because then the enclosing function might say it has the CPR+property, but now doesn't and there a cascade of disaster.  A good example+is #5920.++Note [Limit w/w arity]+~~~~~~~~~~~~~~~~~~~~~~~~+Guard against high worker arity as it generates a lot of stack traffic.+A simplified example is #11565#comment:6++Current strategy is very simple: don't perform w/w transformation at all+if the result produces a wrapper with arity higher than -fmax-worker-args+and the number arguments before w/w (see #18122).++It is a bit all or nothing, consider++        f (x,y) (a,b,c,d,e ... , z) = rhs++Currently we will remove all w/w ness entirely. But actually we could+w/w on the (x,y) pair... it's the huge product that is the problem.++Could we instead refrain from w/w on an arg-by-arg basis? Yes, that'd+solve f. But we can get a lot of args from deeply-nested products:++        g (a, (b, (c, (d, ...)))) = rhs++This is harder to spot on an arg-by-arg basis. Previously mkWwStr was+given some "fuel" saying how many arguments it could add; when we ran+out of fuel it would stop w/wing.++Still not very clever because it had a left-right bias.++Note [Zap IdInfo on worker args]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We have to zap the following IdInfo when re-using arg variables of the original+function for the worker:++  * OccInfo: Dead wrapper args now occur in Apps of the worker's call to the+    original fun body. Those occurrences will quickly cancel away with the lambdas+    of the fun body in the next run of the Simplifier, but CoreLint will complain+    in the meantime, so zap it.++We zap in mkWwBodies because we need the zapped variables when binding them in+mkWWstr (mkAbsentFiller, specifically).++Note [Do not split void functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this rather common form of binding:+        $j = \x:Void# -> ...no use of x...++Since x is not used it'll be marked as absent.  But there is no point+in w/w-ing because we'll simply add (\y:Void#), see addVoidWorkerArg.++If x has a more interesting type (eg Int, or Int#), there *is* a point+in w/w so that we don't pass the argument at all.++************************************************************************+*                                                                      *+\subsection{Making wrapper args}+*                                                                      *+************************************************************************++During worker-wrapper stuff we may end up with an unlifted thing+which we want to let-bind without losing laziness.  So we+add a void argument.  E.g.++        f = /\a -> \x y z -> E::Int#    -- E does not mention x,y,z+==>+        fw = /\ a -> \void -> E+        f  = /\ a -> \x y z -> fw realworld++We use the state-token type which generates no code.+-}++-- | Whether the worker needs an additional `Void#` arg as per+-- Note [Protecting the last value argument] or+-- Note [Preserving float barriers].+needsVoidWorkerArg :: Id -> [Var] -> [Var] -> Bool+needsVoidWorkerArg fn_id wrap_args work_args+  =  not (isJoinId fn_id) && no_value_arg -- See Note [Protecting the last value argument]+  || needs_float_barrier                  -- See Note [Preserving float barriers]+  where+    no_value_arg        = all (not . isId) work_args+    is_float_barrier v  = isId v && hasNoOneShotInfo (idOneShotInfo v)+    wrap_had_barrier    = any is_float_barrier wrap_args+    work_has_barrier    = any is_float_barrier work_args+    needs_float_barrier = wrap_had_barrier && not work_has_barrier++-- | Inserts a `Void#` arg before the first argument.+--+-- Why as the first argument? See Note [SpecConst needs to add void args first]+-- in SpecConstr.+addVoidWorkerArg :: [Var] -> [StrictnessMark]+                 -> ([Var],     -- Lambda bound args+                     [Var],     -- Args at call site+                     [StrictnessMark]) -- cbv semantics for the worker args.+addVoidWorkerArg work_args cbv_marks+  = (voidArgId : work_args, voidPrimId:work_args, NotMarkedStrict:cbv_marks)++{-+Note [Protecting the last value argument]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If the user writes (\_ -> E), they might be intentionally disallowing+the sharing of E. Since absence analysis and worker-wrapper are keen+to remove such unused arguments, we add in a void argument to prevent+the function from becoming a thunk.  Three reasons why turning a function+into a thunk might be bad:++1) It can create a space leak. e.g.+      f x = let y () = [1..x]+            in (sum (y ()) + length (y ()))+   As written it'll calculate [1..x] twice, and avoid keeping a big+   list around.  (Of course let-floating may introduce the leak; but+   at least w/w doesn't.)++2) It can prevent inlining *under a lambda*. e.g.+       g = \y. [1..100]+       f = \t. g ()+   Here we can inline g under the \t.  But we won't if we remove the \y.++3) It can create an unlifted binding.  E.g.+       g :: Int -> Int#+       g = \x. 30#+   Removing the \x would leave an unlifted binding.++NB: none of these apply to a join point.++Note [Preserving float barriers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+```+let+  t = sum [0..x]+  f a{os} b[Dmd=A] c{os} = ... t ...+in f 1 2 3 + f 4 5 6+```+Here, we would like to drop the argument `b` because it's absent. But doing so+leaves behind only one-shot lambdas, `$wf a{os} c{os} = ...`, and then the+Simplifier will inline `t` into `$wf`, because `$wf` says "I'm only called+once". That's bad, because we lost sharing of `t`! Similarly, FloatIn would+happily float `t` into `$wf`, see Note [Floating in past a lambda group].++Why does floating happen after dropping `b` but not before? Because `b` was the+only non-one-shot value lambda left, acting as our "float barrier".++Definition:  A float barrier is a non-one-shot value lambda.+Key insight: If `f` had a float barrier, `$wf` has to have one, too.++To this end, in `needsVoidWorkerArg`, we check whether the wrapper had a float+barrier and if the worker has none so far. If that is the case, we add a `Void#`+argument at the end as an artificial float barrier.++The issue is tracked in #21150. It came up when compiling GHC itself, in+GHC.Tc.Gen.Bind.mkEdges. There the key_map thunk was inlined after WW dropped a+leading absent non-one-shot arg. Here are some example wrapper arguments of+which some are absent or one-shot and the resulting worker arguments:++  * \a{Abs}.\b{os}.\c{os}... ==> \b{os}.\c{os}.\(_::Void#)...+    Wrapper arg `a` was the only float barrier and had been dropped. Hence Void#+  * \a{Abs,os}.\b{os}.\c... ==> \b{os}.\c...+    Worker arg `c` is a float barrier.+  * \a.\b{Abs}.\c{os}... ==> \a.\c{os}...+    Worker arg `a` is a float barrier.+  * \a{os}.\b{Abs,os}.\c{os}... ==> \a{os}.\c{os}...+    Wrapper didn't have a float barrier, no need for Void#.+  * \a{Abs,os}.... ==> ... (no value lambda left)+    This examples simply demonstrates that preserving float barriers is not+    enough to subsume Note [Protecting the last value argument].++Executable examples in T21150.++Note [Join points and beta-redexes]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Originally, the worker would invoke the original function by calling it with+arguments, thus producing a beta-redex for the simplifier to munch away:++  \x y z -> e => (\x y z -> e) wx wy wz++Now that we have special rules about join points, however, this is Not Good if+the original function is itself a join point, as then it may contain invocations+of other join points:++  join j1 x = ...+  join j2 y = if y == 0 then 0 else j1 y++  =>++  join j1 x = ...+  join $wj2 y# = let wy = I# y# in (\y -> if y == 0 then 0 else jump j1 y) wy+  join j2 y = case y of I# y# -> jump $wj2 y#++There can't be an intervening lambda between a join point's declaration and its+occurrences, so $wj2 here is wrong. But of course, this is easy enough to fix:++  ...+  let join $wj2 y# = let wy = I# y# in let y = wy in if y == 0 then 0 else j1 y+  ...++Hence we simply do the beta-reduction here. (This would be harder if we had to+worry about hygiene, but luckily wy is freshly generated.)++Note [Freshen WW arguments]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we do a worker/wrapper split, we must freshen the arg vars of the original+fun RHS because they might shadow each other. E.g.++  f :: forall a. Maybe a -> forall a. Maybe a -> Int -> Int+  f @a x @a y z = case x <|> y of+    Nothing -> z+    Just _  -> z + 1++  ==> {WW split unboxing the Int}++  $wf :: forall a. Maybe a -> forall a. Maybe a -> Int# -> Int+  $wf @a x @a y wz = (\@a x @a y z -> case x <|> y of ...) ??? x @a y (I# wz)++(Notice that the code we actually emit will sort-of ANF-ise the lambda args,+leading to even more shadowing issues. The above demonstrates that even if we+try harder we'll still get shadowing issues.)++What should we put in place for ??? ? Certainly not @a, because that would+reference the wrong, inner a. A similar situation occurred in #12562, we even+saw a type variable in the worker shadowing an outer term-variable binding.++We avoid the issue by freshening the argument variables from the original fun+RHS through 'cloneBndrs', which will also take care of subsitution 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@+data DataConPatContext+  = DataConPatContext+  { dcpc_dc      :: !DataCon+  , dcpc_tc_args :: ![Type]+  , dcpc_co      :: !Coercion+  }++-- | 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 s+  = StopUnboxing+  -- ^ We ran out of strictness info. Leave untouched.+  | DropAbsent+  -- ^ The argument/field was absent. Drop it.+  | Unbox !DataConPatContext [s]+  -- ^ The argument is used strictly or the returned product was constructed, so+  -- unbox it.+  -- The 'DataConPatContext' carries the bits necessary for+  -- instantiation with 'dataConRepInstPat'.+  -- The @[s]@ carries the bits of information with which we can continue+  -- unboxing, e.g. @s@ will be 'Demand' or 'Cpr'.+  | Unlift+  -- ^ The argument can't be unboxed, but we want it to be passed evaluated to the worker.++-- Do we want to create workers just for unlifting?+wwForUnlifting :: WwOpts -> Bool+wwForUnlifting !opts+    -- Always unlift if possible+    | wo_unlift_strict opts = goodWorker+    -- Don't unlift  it would cause additional W/W splits.+    | otherwise = badWorker++badWorker :: Bool+badWorker = False++goodWorker :: Bool+goodWorker = True++isGoodWorker :: Bool -> Bool+isGoodWorker = id+++-- | 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.+wantToUnboxArg+  :: Bool                -- ^ Consider unlifting+  -> FamInstEnvs+  -> Type                -- ^ Type of the argument+  -> Demand              -- ^ How the arg was used+  -> UnboxingDecision Demand+-- See Note [Which types are unboxed?]+wantToUnboxArg do_unlifting fam_envs ty dmd@(n :* sd)+  | isAbs n+  = DropAbsent++  | Just (tc, tc_args, co) <- normSplitTyConApp_maybe fam_envs ty+  , Just dc <- tyConSingleAlgDataCon_maybe tc+  , let arity = dataConRepArity dc+  , Just (Unboxed, ds) <- viewProd arity sd -- See Note [Boxity analysis]+  -- NB: No strictness or evaluatedness checks for unboxing here.+  -- That is done by 'finaliseArgBoxities'!+  = Unbox (DataConPatContext dc tc_args co) ds++  -- See Note [CBV Function Ids]+  | do_unlifting+  , isStrUsedDmd dmd+  , not (isFunTy ty)+  , not (isUnliftedType ty) -- Already unlifted!+    -- NB: function arguments have a fixed RuntimeRep, so it's OK to call isUnliftedType here+  = Unlift++  | otherwise+  = StopUnboxing+++-- | Unboxing strategy for constructed results.+wantToUnboxResult :: FamInstEnvs -> Type -> Cpr -> UnboxingDecision Cpr+-- See Note [Which types are unboxed?]+wantToUnboxResult fam_envs ty cpr+  | Just (con_tag, arg_cprs) <- asConCpr cpr+  , Just (tc, tc_args, co) <- normSplitTyConApp_maybe fam_envs ty+  , Just dcs <- tyConAlgDataCons_maybe tc <|> open_body_ty_warning+  , dcs `lengthAtLeast` con_tag -- This might not be true if we import the+                                -- type constructor via a .hs-boot file (#8743)+  , let dc = dcs `getNth` (con_tag - fIRST_TAG)+  , null (dataConExTyCoVars dc) -- no existentials;+                                -- See Note [Which types are unboxed?]+                                -- and GHC.Core.Opt.CprAnal.argCprType+                                -- where we also check this.+  , all isLinear (dataConInstArgTys dc tc_args)+  -- Deactivates CPR worker/wrapper splits on constructors with non-linear+  -- arguments, for the moment, because they require unboxed tuple with variable+  -- multiplicity fields.+  = Unbox (DataConPatContext dc tc_args co) arg_cprs++  | otherwise+  = StopUnboxing++  where+    -- See Note [non-algebraic or open body type warning]+    open_body_ty_warning = warnPprTrace True "wantToUnboxResult: non-algebraic or open body type" (ppr ty) Nothing++isLinear :: Scaled a -> Bool+isLinear (Scaled w _ ) =+  case w of+    One -> True+    _ -> False+++{- Note [Which types are unboxed?]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Worker/wrapper will unbox++  1. A strict data type argument, that+       * is an algebraic data type (not a newtype)+       * is not recursive (as per 'isRecDataCon')+       * has a single constructor (thus is a "product")+       * that may bind existentials+     We can transform+     > data D a = forall b. D a b+     > f (D @ex a b) = e+     to+     > $wf @ex a b = e+     via 'mkWWstr'.++  2. The constructed result of a function, if+       * its type is an algebraic data type (not a newtype)+       * is not recursive (as per 'isRecDataCon')+       * (might have multiple constructors, in contrast to (1))+       * the applied data constructor *does not* bind existentials+     We can transform+     > f x y = let ... in D a b+     to+     > $wf x y = let ... in (# a, b #)+     via 'mkWWcpr'.++     NB: We don't allow existentials for CPR W/W, because we don't have unboxed+     dependent tuples (yet?). Otherwise, we could transform+     > f x y = let ... in D @ex (a :: ..ex..) (b :: ..ex..)+     to+     > $wf x y = let ... in (# @ex, (a :: ..ex..), (b :: ..ex..) #)++The respective tests are in 'wantToUnboxArg' and+'wantToUnboxResult', respectively.++Note that the data constructor /can/ have evidence arguments: equality+constraints, type classes etc.  So it can be GADT.  These evidence+arguments are simply value arguments, and should not get in the way.++Note [mkWWstr and unsafeCoerce]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+By using unsafeCoerce, it is possible to make the number of demands fail to+match the number of constructor arguments; this happened in #8037.+If so, the worker/wrapper split doesn't work right and we get a Core Lint+bug.  The fix here is simply to decline to do w/w if that happens.++Note [non-algebraic or open body type warning]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There are a few cases where the W/W transformation is told that something+returns a constructor, but the type at hand doesn't really match this. One+real-world example involves unsafeCoerce:+  foo = IO a+  foo = unsafeCoerce c_exit+  foreign import ccall "c_exit" c_exit :: IO ()+Here CPR will tell you that `foo` returns a () constructor for sure, but trying+to create a worker/wrapper for type `a` obviously fails.+(This was a real example until ee8e792  in libraries/base.)++It does not seem feasible to avoid all such cases already in the analyser (and+after all, the analysis is not really wrong), so we simply do nothing here in+mkWWcpr. But we still want to emit warning with -DDEBUG, to hopefully catch+other cases where something went avoidably wrong.++This warning also triggers for the stream fusion library within `text`.+We can'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 explaination.++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 oppertunity 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 imprompto wrapper function+      wherever we wouldn't inline the wrapper with a W/W approach.+    ~ There is the option of achieving this without eta-expansion if we instead expand+      the partial application code to check for demands on the calling convention and+      for it to evaluate the arguments. The main downsides there would be the complexity+      of the implementation and that it carries a certain overhead even for functions who+      don't take advantage of this functionality. I haven't tried this approach because it's+      not trivial to implement and doing W/W splits seems to work well enough.++Currently we use the first approach A) by default, with a flag that allows users to fall back to the+more aggressive approach B).+I also tried the third approach C) using eta-expansion at call sites to avoid modifying the PAP-handling+code which wasn't fruitful. See https://gitlab.haskell.org/ghc/ghc/-/merge_requests/5614#note_389903.+We could still try to do C) in the future by having PAP calls which will evaluate the required arguments+before calling the partially applied function. But this would be neither a small nor simple change so we+stick with A) and a flag for B) for now.+See also Note [Tag Inference] and Note [CBV Function Ids]+-}++{-+************************************************************************+*                                                                      *+\subsection{Worker/wrapper for Strictness and Absence}+*                                                                      *+************************************************************************+-}++mkWWstr :: WwOpts+        -> [Var]                         -- Wrapper args; have their demand info on them+                                         --  *Includes type variables*+        -> [StrictnessMark]                     -- cbv info for arguments+        -> UniqSM (Bool,                 -- 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 cbv_info+  = go args cbv_info+  where+    go_one arg cbv = mkWWstr_one opts arg cbv++    go []           _ = return (badWorker, [], nop_fn, [])+    go (arg : args) (cbv:cbvs)+      =               do { (useful1, args1, wrap_fn1, wrap_arg)  <- go_one arg cbv+                         ; (useful2, args2, wrap_fn2, wrap_args) <- go args cbvs+                         ; return ( useful1 || useful2+                                  , args1 ++ args2+                                  , wrap_fn1 . wrap_fn2+                                  , wrap_arg:wrap_args ) }+    go _ _ = panic "mkWWstr: Impossible - cbv/arg length missmatch"++----------------------+-- 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 (Bool, [(Var,StrictnessMark)], CoreExpr -> CoreExpr, CoreExpr)+mkWWstr_one opts arg banged =+  case wantToUnboxArg True fam_envs arg_ty arg_dmd of+    _ | isTyVar arg -> do_nothing++    DropAbsent+      | Just absent_filler <- mkAbsentFiller opts arg banged+         -- Absent case.  Dropt 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 (goodWorker, [], nop_fn, absent_filler)++    Unbox dcpc ds -> unbox_one_arg opts arg ds dcpc banged++    Unlift -> return  ( wwForUnlifting opts+                      , [(arg, MarkedStrict)]+                      , nop_fn+                      , varToCoreExpr arg)++    _ -> do_nothing -- Other cases, like StopUnboxing++  where+    fam_envs   = wo_fam_envs opts+    arg_ty     = idType arg+    arg_dmd    = idDemandInfo arg+    -- Type args don't get cbv marks+    arg_cbv    = if isTyVar arg then NotMarkedStrict else banged++    do_nothing = return (badWorker, [(arg,arg_cbv)], nop_fn, varToCoreExpr arg)++unbox_one_arg :: WwOpts+          -> Var+          -> [Demand]+          -> DataConPatContext+          -> StrictnessMark+          -> UniqSM (Bool, [(Var,StrictnessMark)], CoreExpr -> CoreExpr, CoreExpr)+unbox_one_arg opts arg_var ds+          DataConPatContext { dcpc_dc = dc, dcpc_tc_args = tc_args+                            , dcpc_co = co }+          _marked_cbv+  = do { pat_bndrs_uniqs <- getUniquesM+       ; let ex_name_fss = map getOccFS $ dataConExTyCoVars dc+             -- Create new arguments we get when unboxing dc+             (ex_tvs', arg_ids) =+               dataConRepFSInstPat (ex_name_fss ++ repeat ww_prefix) pat_bndrs_uniqs (idMult arg_var) dc tc_args+             con_str_marks = dataConRepStrictness dc+             -- Apply str info to new args. Also remove OtherCon unfoldings so they don't end up in lambda binders+             -- of the worker. See Note [Never put `OtherCon` unfoldings on lambda binders]+             arg_ids' = map zapIdUnfolding $ zipWithEqual "unbox_one_arg" setIdDemandInfo arg_ids ds+             unbox_fn = mkUnpackCase (Var arg_var) co (idMult arg_var)+                                     dc (ex_tvs' ++ arg_ids')+             -- Mark arguments coming out of strict fields so we can make the worker strict on those+             -- argumnets later. seq them later. See Note [Call-by-value for worker args]+             strict_marks = (map (const NotMarkedStrict) ex_tvs') ++ con_str_marks+       ; (_sub_args_quality, worker_args, wrap_fn, wrap_args) <- mkWWstr opts (ex_tvs' ++ arg_ids') strict_marks+       ; let wrap_arg = mkConApp dc (map Type tc_args ++ wrap_args) `mkCast` mkSymCo co+       ; return (goodWorker, worker_args, unbox_fn . wrap_fn, wrap_arg) }+                          -- Don't pass the arg, rebox instead++-- | Tries to find a suitable absent filler to bind the given absent identifier+-- to. See Note [Absent fillers].+--+-- If @mkAbsentFiller _ id == Just e@, then @e@ is an absent filler with the+-- same type as @id@. Otherwise, no suitable filler could be found.+mkAbsentFiller :: WwOpts -> Id -> StrictnessMark -> Maybe CoreExpr+mkAbsentFiller opts arg str+  -- The lifted case: Bind 'absentError' for a nice panic message if we are+  -- wrong (like we were in #11126). See (1) in Note [Absent fillers]+  | mightBeLiftedType arg_ty+  , not is_strict+  , not (isMarkedStrict str) -- See (2) in Note [Absent fillers]+  = Just (mkAbsentErrorApp arg_ty msg)++  -- The default case for mono rep: Bind `RUBBISH[rr] arg_ty`+  -- See Note [Absent fillers], the main part+  | otherwise+  = mkLitRubbish arg_ty++  where+    arg_ty    = idType arg+    is_strict = isStrictDmd (idDemandInfo arg)++    msg = renderWithContext+            (defaultSDocContext { sdocSuppressUniques = True })+            (vcat+              [ text "Arg:" <+> ppr arg+              , text "Type:" <+> ppr arg_ty+              , file_msg ])+              -- We need to suppress uniques here because otherwise they'd+              -- end up in the generated code as strings. This is bad for+              -- determinism, because with different uniques the strings+              -- will have different lengths and hence different costs for+              -- the inliner leading to different inlining.+              -- See also Note [Unique Determinism] in GHC.Types.Unique+    file_msg = text "In module" <+> quotes (ppr $ wo_module opts)++{- Note [Worker/wrapper for Strictness and Absence]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The worker/wrapper transformation, mkWWstr_one, takes concrete action+based on the 'UnboxingDescision' returned by 'wantToUnboxArg'.+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], 'wantToUnboxArg' will say 'Unbox'.+   '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, 'wantToUnboxArg' returns 'StopUnboxing'.+   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 'wantToUnboxArg' returns 'StopUnboxing' so that 'mkWWstr_one'+   stops unboxing.++Note [Worker/wrapper for bottoming functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We used not to split if the result is bottom.+[Justification:  there's no efficiency to be gained.]++But it's sometimes bad not to make a wrapper.  Consider+        fw = \x# -> let x = I# x# in case e of+                                        p1 -> error_fn x+                                        p2 -> error_fn x+                                        p3 -> the real stuff+The re-boxing code won't go away unless error_fn gets a wrapper too.+[We don't do reboxing now, but in general it's better to pass an+unboxed thing to f, and have it reboxed in the error cases....]++Note [Record evaluated-ness in worker/wrapper]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have++   data T = MkT !Int Int++   f :: T -> T+   f x = e++and f's is strict, and has the CPR property.  The we are going to generate+this w/w split++   f x = case x of+           MkT x1 x2 -> case $wf x1 x2 of+                           (# r1, r2 #) -> MkT r1 r2++   $wfw x1 x2 = let x = MkT x1 x2 in+                case e of+                  MkT r1 r2 -> (# r1, r2 #)++Note that++* In the worker $wf, inside 'e' we can be sure that x1 will be+  evaluated (it came from unpacking the argument MkT.  But that's no+  immediately apparent in $wf++* In the wrapper 'f', which we'll inline at call sites, we can be sure+  that 'r1' has been evaluated (because it came from unpacking the result+  MkT.  But that is not immediately apparent from the wrapper code.++Missing these facts isn't unsound, but it loses possible future+opportunities for optimisation.++Solution: use setCaseBndrEvald when creating+ (A) The arg binders x1,x2 in mkWstr_one via mkUnpackCase+         See #13077, test T13077+ (B) The result binders r1,r2 in mkWWcpr_entry+         See Trace #13077, test T13077a+         And #13027 comment:20, item (4)+to record that the relevant binder is evaluated.++Note [Absent fillers]+~~~~~~~~~~~~~~~~~~~~~+Consider++  data T = MkT [Int] [Int] ![Int]  -- NB: last field is strict+  f :: T -> Int# -> blah+  f ps w = case ps of MkT xs ys zs -> <body mentioning xs>++Then f gets a strictness sig of <S(L,A,A)><A>. We make a worker $wf thus:++  $wf :: [Int] -> blah+  $wf xs = case ps of MkT xs _ _ -> <body mentioning xs>+    where+      ys = absentError "ys :: [Int]"+      zs = RUBBISH[LiftedRep] @[Int]+      ps = MkT xs ys zs+      w  = RUBBISH[IntRep] @Int#++The absent arguments 'ys', 'zs' and 'w' aren't even passed to the worker.+And neither should they! They are never used, their value is irrelevant (hence+they are *dead code*) and they are probably discarded after the next run of the+Simplifier (when they are in fact *unreachable code*). Yet, we have to come up+with "filler" values that we bind the absent arg Ids to.++That is exactly what Note [Rubbish literals] are for: A convenient way to+conjure filler values at any type (and any representation or levity!).++Needless to say, there are some wrinkles:++  1. In case we have a absent, /lazy/, and /lifted/ arg, we use an error-thunk+     instead. If absence analysis was wrong (e.g., #11126) and the binding+     in fact is used, then we get a nice panic message instead of undefined+     runtime behavior (See Modes of failure from Note [Rubbish literals]).++     Obviously, we can't use an error-thunk if the value is of unlifted rep+     (like 'Int#' or 'MutVar#'), because we'd immediately evaluate the panic.++  2. We also mustn't put an error-thunk (that fills in for an absent value of+     lifted rep) in a strict field, because #16970 establishes the invariant+     that strict fields are always evaluated, by possibly (re-)evaluating what is put in+     a strict field. That's the reason why 'zs' binds a rubbish literal instead+     of an error-thunk, see #19133.++     How do we detect when we are about to put an error-thunk in a strict field?+     Ideally, we'd just look at the 'StrictnessMark' of the DataCon's field. So that's+     what we do!++     There are other necessary conditions for strict fields:+     Note [Unboxing evaluated arguments] in DmdAnal makes it so that the demand on+     'zs' is absent and /strict/: It will get cardinality 'C_10', the empty+     interval, rather than 'C_00'. Hence the 'isStrictDmd' check: It further+     guarantees e never fill in an error-thunk for an absent strict field.+     But that also means we emit a rubbish lit for other args that have+     cardinality 'C_10' (say, the arg to a bottoming function) where we could've+     used an error-thunk.+     NB from Andreas: But I think using an error thunk there would be dodgy no matter what+     for example if we decide to pass the argument to the bottoming function cbv.+     As we might do if the function in question is a worker.+     See Note [CBV Function Ids] in GHC.CoreToStg.Prep. So I just left the strictness check+     in place on top of threading through the marks from the constructor. It's a *really* cheap+     and easy check to make anyway.++  3. We can only emit a LitRubbish if the arg's type @arg_ty@ is mono-rep, e.g.+     of the form @TYPE rep@ where @rep@ is not (and doesn't contain) a variable.+     Why? Because if we don't know its representation (e.g. size in memory,+     register class), we don't know what or how much rubbish to emit in codegen.+     'mkLitRubbish' returns 'Nothing' in this case and we simply fall+     back to passing the original parameter to the worker.++     Note that currently this case should not occur, because binders always+     have to be representation monomorphic. But in the future, we might allow+     levity polymorphism, e.g. a polymorphic levity variable in 'BoxedRep'.++While (1) and (2) are simply an optimisation in terms of compiler debugging+experience, (3) should be irrelevant in most programs, if not all.++Historical note: I did try the experiment of using an error thunk for unlifted+things too, relying on the simplifier to drop it as dead code.  But this is+fragile++ - It fails when profiling is on, which disables various optimisations++ - It fails when reboxing happens. E.g.+      data T = MkT Int Int#+      f p@(MkT a _) = ...g p....+   where g is /lazy/ in 'p', but only uses the first component.  Then+   'f' is /strict/ in 'p', and only uses the first component.  So we only+   pass that component to the worker for 'f', which reconstructs 'p' to+   pass it to 'g'.  Alas we can't say+       ...f (MkT a (absentError Int# "blah"))...+   because `MkT` is strict in its Int# argument, so we get an absentError+   exception when we shouldn't.  Very annoying!++************************************************************************+*                                                                      *+         Type scrutiny that is specific to demand analysis+*                                                                      *+************************************************************************+-}++-- | Exactly 'dataConInstArgTys', but lacks the (ASSERT'ed) precondition that+-- the 'DataCon' may not have existentials. The lack of cloning the existentials+-- compared to 'dataConInstExAndArgVars' makes this function \"dubious\";+-- only use it where type variables aren't substituted for!+dubiousDataConInstArgTys :: DataCon -> [Type] -> [Type]+dubiousDataConInstArgTys dc tc_args = arg_tys+  where+    univ_tvs = dataConUnivTyVars dc+    ex_tvs   = dataConExTyCoVars dc+    subst    = extendTCvInScopeList (zipTvSubst univ_tvs tc_args) ex_tvs+    arg_tys  = map (GHC.Core.Type.substTy subst . scaledThing) (dataConRepArgTys dc)++findTypeShape :: FamInstEnvs -> Type -> TypeShape+-- Uncover the arrow and product shape of a type+-- The data type TypeShape is defined in GHC.Types.Demand+-- See Note [Trimming a demand to a type] in GHC.Core.Opt.DmdAnal+findTypeShape fam_envs ty+  = go (setRecTcMaxBound 2 initRecTc) ty+       -- You might think this bound of 2 is low, but actually+       -- I think even 1 would be fine.  This only bites for recursive+       -- product types, which are rare, and we really don't want+       -- to look deep into such products -- see #18034+  where+    go rec_tc ty+       | Just (_, _, res) <- splitFunTy_maybe ty+       = TsFun (go rec_tc res)++       | Just (tc, tc_args)  <- splitTyConApp_maybe ty+       = go_tc rec_tc tc tc_args++       | Just (_, ty') <- splitForAllTyCoVar_maybe ty+       = go rec_tc ty'++       | otherwise+       = TsUnk++    go_tc rec_tc tc tc_args+       | Just (HetReduction (Reduction _ rhs) _) <- topReduceTyFamApp_maybe fam_envs tc tc_args+       = go rec_tc rhs++       | Just con <- tyConSingleAlgDataCon_maybe tc+       , Just rec_tc <- if isTupleTyCon tc+                        then Just rec_tc+                        else checkRecTc rec_tc tc+         -- We treat tuples specially because they can't cause loops.+         -- Maybe we should do so in checkRecTc.+         -- The use of 'dubiousDataConInstArgTys' is OK, since this+         -- function performs no substitution at all, hence the uniques+         -- don't matter.+         -- We really do encounter existentials here, see+         -- Note [Which types are unboxed?] for an example.+       = TsProd (map (go rec_tc) (dubiousDataConInstArgTys con tc_args))++       | Just (ty', _) <- instNewTyCon_maybe tc tc_args+       , Just rec_tc <- checkRecTc rec_tc tc+       = go rec_tc ty'++       | otherwise+       = TsUnk++-- | Returned by 'isRecDataCon'.+-- See also Note [Detecting recursive data constructors].+data IsRecDataConResult+  = DefinitelyRecursive  -- ^ The algorithm detected a loop+  | NonRecursiveOrUnsure -- ^ The algorithm detected no loop, went out of fuel+                         -- or hit an .hs-boot file+  deriving (Eq, Show)++instance Outputable IsRecDataConResult where+  ppr = text . show++combineIRDCR :: IsRecDataConResult -> IsRecDataConResult -> IsRecDataConResult+combineIRDCR DefinitelyRecursive _                   = DefinitelyRecursive+combineIRDCR _                   DefinitelyRecursive = DefinitelyRecursive+combineIRDCR _                   _                   = NonRecursiveOrUnsure++combineIRDCRs :: [IsRecDataConResult] -> IsRecDataConResult+combineIRDCRs = foldl' combineIRDCR NonRecursiveOrUnsure+{-# INLINE combineIRDCRs #-}++-- | @isRecDataCon _ fuel dc@, where @tc = dataConTyCon dc@ returns+--+--   * @DefinitelyRecursive@ if the analysis found that @tc@ is reachable+--     through one of @dc@'s @arg_tys@.+--   * @NonRecursiveOrUnsure@ if the analysis found that @tc@ is not reachable+--     through one of @dc@'s fields (so surely non-recursive).+--   * @NonRecursiveOrUnsure@ when @fuel /= Infinity@+--     and @fuel@ expansions of nested data TyCons were not enough to prove+--     non-recursivenss, nor arrive at an occurrence of @tc@ thus proving+--     recursiveness. (So not sure if non-recursive.)+--   * @NonRecursiveOrUnsure@ when we hit an abstract TyCon (one without+--     visible DataCons), such as those imported from .hs-boot files.+--     Similarly for stuck type and data families.+--+-- If @fuel = 'Infinity'@ and there are no boot files involved, then the result+-- is never @Nothing@ and the analysis is a depth-first search. If @fuel = 'Int'+-- f@, then the analysis behaves like a depth-limited DFS and returns @Nothing@+-- if the search was inconclusive.+--+-- See Note [Detecting recursive data constructors] for which recursive DataCons+-- we want to flag.+isRecDataCon :: FamInstEnvs -> IntWithInf -> DataCon -> IsRecDataConResult+isRecDataCon fam_envs fuel orig_dc+  | isTupleDataCon orig_dc || isUnboxedSumDataCon orig_dc+  = NonRecursiveOrUnsure+  | otherwise+  = -- pprTraceWith "isRecDataCon" (\answer -> ppr dc <+> dcolon <+> ppr (dataConRepType dc) $$ ppr fuel $$ ppr answer) $+    go_dc fuel emptyTyConSet orig_dc+  where+    go_dc :: IntWithInf -> TyConSet -> DataCon -> IsRecDataConResult+    go_dc fuel visited_tcs dc =+      combineIRDCRs [ go_arg_ty fuel visited_tcs arg_ty+                    | arg_ty <- map scaledThing (dataConRepArgTys dc) ]++    go_arg_ty :: IntWithInf -> TyConSet -> Type -> IsRecDataConResult+    go_arg_ty fuel visited_tcs ty+      --- | pprTrace "arg_ty" (ppr ty) False = undefined++      | Just (_tcv, ty') <- splitForAllTyCoVar_maybe ty+      = go_arg_ty fuel visited_tcs ty'+          -- See Note [Detecting recursive data constructors], point (A)++      | Just (tc, tc_args) <- splitTyConApp_maybe ty+      = go_tc_app fuel visited_tcs tc tc_args++      | otherwise+      = NonRecursiveOrUnsure++    go_tc_app :: IntWithInf -> TyConSet -> TyCon -> [Type] -> IsRecDataConResult+    go_tc_app fuel visited_tcs tc tc_args =+      case tyConDataCons_maybe tc of+      --- | pprTrace "tc_app" (vcat [ppr tc, ppr tc_args]) False = undefined+        _ | Just (HetReduction (Reduction _ rhs) _) <- topReduceTyFamApp_maybe fam_envs tc tc_args+          -- This is the only place where we look at tc_args, which might have+          -- See Note [Detecting recursive data constructors], point (C) and (5)+          -> go_arg_ty fuel visited_tcs rhs++        _ | tc == dataConTyCon orig_dc+          -> DefinitelyRecursive -- loop found!++        Just dcs+          | DefinitelyRecursive <- combineIRDCRs [ go_arg_ty fuel visited_tcs' ty | ty <- tc_args ]+              -- Check tc_args, See Note [Detecting recursive data constructors], point (5)+              -- The new visited_tcs', so that we don't recursively check tc,+              -- promising that we will check it below.+              -- Do the tc_args check *before* the dcs check below, otherwise+              -- we might miss an obvious rec occ in tc_args when we run out of+              -- fuel and respond NonRecursiveOrUnsure instead+          -> DefinitelyRecursive++          | fuel >= 0+              -- See Note [Detecting recursive data constructors], point (4)+          , not (tc `elemTyConSet` visited_tcs)+              -- only need to check tc if we haven't visited it already. NB: original visited_tcs+          -> combineIRDCRs [ go_dc (subWithInf fuel 1) visited_tcs' dc | dc <- dcs ]+              -- Finally: check ds++        _ -> NonRecursiveOrUnsure+        where+          visited_tcs' = extendTyConSet visited_tcs tc++{-+************************************************************************+*                                                                      *+\subsection{Worker/wrapper for CPR}+*                                                                      *+************************************************************************+See Note [Worker/wrapper for CPR] for an overview.+-}++mkWWcpr_entry+  :: WwOpts+  -> Type                              -- function body+  -> Cpr                               -- CPR analysis results+  -> UniqSM (Bool,            -- 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 (badWorker, 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 (badWorker, nop_fn, nop_fn)+                else (goodWorker, 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 Bool capturing whether the transformation did 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  = (Bool, OrdList Var,  CoreExpr , CoreExpr -> CoreExpr)+type CprWwResultMany = (Bool, 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 (badWorker, toOL vars, map varToCoreExpr vars, nop_fn)+mkWWcpr opts  vars cprs = do+  -- No existentials in 'vars'. 'wantToUnboxResult' 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+  , Unbox dcpc arg_cprs <- wantToUnboxResult (wo_fam_envs opts) (idType res_bndr) cpr+  = unbox_one_result opts res_bndr arg_cprs dcpc+  | otherwise+  = return (badWorker, unitOL res_bndr, varToCoreExpr res_bndr, nop_fn)++unbox_one_result+  :: WwOpts -> Id -> [Cpr] -> DataConPatContext -> UniqSM CprWwResultOne+-- ^ Implements the main bits of part (2) of Note [Worker/wrapper for CPR]+unbox_one_result opts res_bndr arg_cprs+                 DataConPatContext { dcpc_dc = dc, dcpc_tc_args = tc_args+                                   , dcpc_co = co } = 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 wantToUnboxResult++  (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++  -- Don't try to WW an unboxed tuple return type when there's nothing inside+  -- to unbox further.+  return $ if isUnboxedTupleDataCon dc && not nested_useful+              then ( badWorker, unitOL res_bndr, Var res_bndr, nop_fn )+              else ( goodWorker+                   , 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 = mkCoreUbxTup (map idType vars) (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 satsify '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 parametrised 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 = One++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
@@ -5,8 +5,8 @@ \section[PatSyn]{@PatSyn@: Pattern synonyms} -} -{-# LANGUAGE CPP #-} + module GHC.Core.PatSyn (         -- * Main data types         PatSyn, PatSynMatcher, PatSynBuilder, mkPatSyn,@@ -24,8 +24,6 @@         pprPatSynType     ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Core.Type@@ -61,7 +59,7 @@         psName        :: Name,         psUnique      :: Unique,       -- Cached from Name -        psArgs        :: [Type],+        psArgs        :: [FRRType],    -- ^ Argument types         psArity       :: Arity,        -- == length psArgs         psInfix       :: Bool,         -- True <=> declared infix         psFieldLabels :: [FieldLabel], -- List of fields for a@@ -382,7 +380,7 @@                                          -- variables and required dicts          -> ([InvisTVBinder], ThetaType) -- ^ Existentially-quantified type                                          -- variables and provided dicts-         -> [Type]               -- ^ Original arguments+         -> [FRRType]            -- ^ Original arguments          -> Type                 -- ^ Original result type          -> PatSynMatcher        -- ^ Matcher          -> PatSynBuilder        -- ^ Builder@@ -478,8 +476,8 @@ patSynInstArgTys (MkPatSyn { psName = name, psUnivTyVars = univ_tvs                            , psExTyVars = ex_tvs, psArgs = arg_tys })                  inst_tys-  = ASSERT2( tyvars `equalLength` inst_tys-          , text "patSynInstArgTys" <+> ppr name $$ ppr tyvars $$ ppr 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)@@ -493,8 +491,8 @@ patSynInstResTy (MkPatSyn { psName = name, psUnivTyVars = univ_tvs                           , psResultTy = res_ty })                 inst_tys-  = ASSERT2( univ_tvs `equalLength` inst_tys-           , text "patSynInstResTy" <+> ppr name $$ ppr univ_tvs $$ ppr 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
GHC/Core/Ppr.hs view
@@ -23,13 +23,15 @@         pprCoreBinding, pprCoreBindings, pprCoreAlt,         pprCoreBindingWithSize, pprCoreBindingsWithSize,         pprCoreBinder, pprCoreBinders,-        pprRules, pprOptCo+        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@@ -45,7 +47,6 @@ import GHC.Data.Maybe import GHC.Utils.Misc import GHC.Utils.Outputable-import GHC.Data.FastString import GHC.Types.SrcLoc ( pprUserRealSpan ) import GHC.Types.Tickish @@ -171,7 +172,7 @@ pprOptCo :: Coercion -> SDoc -- Print a coercion optionally; i.e. honouring -dsuppress-coercions pprOptCo co = sdocOption sdocSuppressCoercions $ \case-              True  -> angleBrackets (text "Co:" <> int (coercionSize co))+              True  -> angleBrackets (text "Co:" <> int (coercionSize co)) <+> dcolon <+> ppr (coercionType co)               False -> parens $ sep [ppr co, dcolon <+> ppr (coercionType co)]  ppr_id_occ :: (SDoc -> SDoc) -> Id -> SDoc@@ -383,6 +384,17 @@   pprPrefixOcc b = ppr b   bndrIsJoin_maybe (TB b _) = isJoinId_maybe 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@@ -431,7 +443,7 @@                                    2 (vcat [ dcolon <+> pprType (idType var)                                            , pp_unf]))   where-    unf_info = unfoldingInfo (idInfo var)+    unf_info = realUnfoldingInfo (idInfo var)     pp_unf | hasSomeUnfolding unf_info = text "Unf=" <> ppr unf_info            | otherwise                 = empty @@ -512,10 +524,10 @@       caf_info = cafInfo info       has_caf_info = not (mayHaveCafRefs caf_info) -      str_info = strictnessInfo info+      str_info = dmdSigInfo info       has_str_info = not (isTopSig str_info) -      unf_info = unfoldingInfo info+      unf_info = realUnfoldingInfo info       has_unf = hasSomeUnfolding unf_info        rules = ruleInfoRules (ruleInfo info)@@ -556,13 +568,13 @@     caf_info = cafInfo info     has_caf_info = not (mayHaveCafRefs caf_info) -    str_info = strictnessInfo info+    str_info = dmdSigInfo info     has_str_info = not (isTopSig str_info) -    cpr_info = cprInfo info+    cpr_info = cprSigInfo info     has_cpr_info = cpr_info /= topCprSig -    unf_info = unfoldingInfo info+    unf_info = realUnfoldingInfo info     has_unf = hasSomeUnfolding unf_info      rules = ruleInfoRules (ruleInfo info)@@ -603,7 +615,7 @@   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:" <+> ptext (sLit "\\")+       = hang (text "DFun:" <+> char '\\'                 <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow)             2 (ppr con <+> sep (map ppr args))   ppr (CoreUnfolding { uf_src = src
GHC/Core/Predicate.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE DerivingStrategies #-}+ {-  Describes predicates as they are considered by the solver.@@ -24,9 +26,12 @@    -- Implicit parameters   isIPLikePred, hasIPSuperClasses, isIPTyCon, isIPClass,+  isCallStackTy, isCallStackPred, isCallStackPredTy,+  isIPPred_maybe,    -- Evidence variables   DictId, isEvVar, isDictId+   ) where  import GHC.Prelude@@ -44,16 +49,28 @@ import GHC.Utils.Outputable import GHC.Utils.Misc import GHC.Utils.Panic+import GHC.Data.FastString +import Control.Monad ( guard )  -- | 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.   | EqPred EqRel Type Type++  -- | An irreducible predicate.   | IrredPred PredType++  -- | A quantified predicate.+  --+  -- See Note [Quantified constraints] in GHC.Tc.Solver.Canonical   | ForAllPred [TyVar] [PredType] PredType-     -- ForAllPred: see Note [Quantified constraints] in GHC.Tc.Solver.Canonical+   -- 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@@ -257,6 +274,48 @@ initIPRecTc :: RecTcChecker initIPRecTc = setRecTcMaxBound 1 initRecTc +-- --------------------- 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+++-- | Decomposes a predicate if it is an implicit parameter. Does not look in+-- superclasses. See also [Local implicit parameters].+isIPPred_maybe :: Type -> Maybe (FastString, Type)+isIPPred_maybe ty =+  do (tc,[t1,t2]) <- splitTyConApp_maybe ty+     guard (isIPTyCon tc)+     x <- isStrLitTy t1+     return (x,t2)+ {- Note [Local implicit parameters] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The function isIPLikePred tells if this predicate, or any of its@@ -286,7 +345,7 @@   instantiate and check each superclass, one by one, in   hasIPSuperClasses. -* With -XRecursiveSuperClasses, the superclass hunt can go on forever,+* 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
+ GHC/Core/Reduction.hs view
@@ -0,0 +1,892 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}++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.Types.Var       ( 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, panic )++{-+%************************************************************************+%*                                                                      *+      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+          -> AnonArgFlag+          -> ReductionN -- ^ multiplicity reduction+          -> Reduction  -- ^ argument reduction+          -> Reduction  -- ^ result reduction+          -> Reduction+mkFunRedn r vis+  (Reduction w_co w_ty)+  (Reduction arg_co arg_ty)+  (Reduction res_co res_ty)+    = mkReduction+        (mkFunCo r w_co arg_co res_co)+        (mkFunTy vis 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 :: ArgFlag+             -> TyVar+             -> ReductionN -- ^ kind reduction+             -> Reduction  -- ^ body reduction+             -> Reduction+mkForAllRedn vis tv1 (Reduction h ki') (Reduction co ty)+  = mkReduction+      (mkForAllCo tv1 h co)+      (mkForAllTy 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 (binderVars 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+                   => [TyCoBinder] -> 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+                   -> [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+       -> [TyCoBinder]    -- Unsubsted binders of function's kind+       -> Kind        -- Unsubsted result kind of function (not a Pi-type)+       -> [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 (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),+         -- tcTypeKind(ty) = tcTypeKind(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 (tyCoBinderType 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 <- tyCoBinderVar_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 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)++    go _ _ _ _ _ = panic+        "simplifyArgsWorker wandered into deeper water than usual"+           -- This debug information is commented out because leaving it in+           -- causes a ~2% increase in allocations in T9872d.+           -- That's independent of the analogous case in rewrite_args_fast+           -- in GHC.Tc.Solver.Rewrite:+           -- each of these causes a 2% increase on its own, so commenting them+           -- both out gives a 4% decrease in T9872d.+           {-++             (vcat [ppr orig_binders,+                    ppr orig_inner_ki,+                    ppr (take 10 orig_roles), -- often infinite!+                    ppr orig_tys])+           -}
+ GHC/Core/RoughMap.hs view
@@ -0,0 +1,451 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE BangPatterns #-}++-- | '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++    -- * 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 Control.Monad (join)+import Data.Data (Data)+import GHC.Utils.Misc+import Data.Bifunctor+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 the lookup key runs out, the remaining instances might match.++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 substituion 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 [RoughMatch 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.++-}++-- 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 "_"++roughMatchTcToLookup :: RoughMatchTc -> RoughMatchLookupTc+roughMatchTcToLookup (RM_KnownTc n) = RML_KnownTc n+roughMatchTcToLookup RM_WildCard = RML_WildCard++instance Outputable RoughMatchTc where+    ppr (RM_KnownTc nm) = text "KnownTc" <+> ppr nm+    ppr RM_WildCard = text "OtherTc"++isRoughWildcard :: RoughMatchTc -> Bool+isRoughWildcard RM_WildCard  = True+isRoughWildcard (RM_KnownTc {}) = False++typeToRoughMatchLookupTc :: Type -> RoughMatchLookupTc+typeToRoughMatchLookupTc ty+  | Just (ty', _) <- splitCastTy_maybe 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 $! tyConName 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)              = assertPpr (isGenerativeTyCon tc Nominal) (ppr tc)+                                              RM_KnownTc $! tyConName tc+    -- See Note [Rough matching in class and family instances]+  | otherwise                               = RM_WildCard++-- | Trie of @[RoughMatchTc]@+--+-- *Examples*+-- @+-- insert [OtherTc] 1+-- insert [OtherTc] 2+-- lookup [OtherTc] == [1,2]+-- @+data RoughMap a = RM { rm_empty   :: Bag a+                     , rm_known   :: DNameEnv (RoughMap a)+                        -- See Note [InstEnv determinism] in GHC.Core.InstEnv+                     , rm_unknown :: RoughMap a }+                | RMEmpty -- an optimised (finite) form of emptyRM+                          -- invariant: Empty RoughMaps are always represented with RMEmpty++                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 becuase 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 = (emptyBag, [])+-- See Note [Simple Matching Semantics] about why we return everything when the lookup+-- key runs out.+lookupRM' []                 rm      = let m = elemsRM rm+                                       in (listToBag m, m)+lookupRM' (RML_KnownTc tc : tcs) rm  =+  let (common_m, common_u) = lookupRM' tcs (rm_unknown 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_unknown 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  =+  let (m, u) = bimap unionManyBags concat (mapAndUnzip (lookupRM' tcs) (eltsDNameEnv $ rm_known rm))+      (u_m, u_u) = lookupRM' tcs (rm_unknown rm)+  in (rm_empty rm `unionBags` u_m `unionBags` m+     , bagToList (rm_empty rm) ++ u_u ++ u)++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_unknown = rm_unknown a `unionRM` rm_unknown b+     }+++insertRM :: [RoughMatchTc] -> a -> RoughMap a -> RoughMap a+insertRM k v RMEmpty =+    insertRM k v $ RM { rm_empty = emptyBag+                      , rm_known = emptyDNameEnv+                      , rm_unknown = 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_unknown = insertRM ks v (rm_unknown 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_unknown = filterRM pred (rm_unknown 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_unknown = filterMatchingRM pred tcs (rm_unknown 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_unknown = filterMatchingRM pred tcs (rm_unknown 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_unknown = 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_unknown rm))+           (rm_known rm)+        )+        (rm_empty rm)++sizeRM :: RoughMap a -> Int+sizeRM = nonDetStrictFoldRM (\acc _ -> acc + 1) 0
GHC/Core/Rules.hs view
@@ -4,14 +4,13 @@ \section[CoreRules]{Rewrite rules} -} -{-# LANGUAGE CPP #-}  -- | Functions for collecting together and applying rewrite rules to a module. -- The 'CoreRule' datatype itself is declared elsewhere. module GHC.Core.Rules (         -- ** Constructing         emptyRuleBase, mkRuleBase, extendRuleBaseList,-        unionRuleBase, pprRuleBase,+        pprRuleBase, extendRuleEnv,          -- ** Checking rule applications         ruleCheckProgram,@@ -26,29 +25,35 @@         lookupRule, mkRule, roughTopNames, initRuleOpts     ) where -#include "HsVersions.h"- import GHC.Prelude -import GHC.Core         -- All of it+import GHC.Driver.Session      ( DynFlags, gopt, targetPlatform, homeUnitId_ )+import GHC.Driver.Flags+ import GHC.Unit.Types    ( primUnitId, bignumUnitId ) import GHC.Unit.Module   ( Module ) import GHC.Unit.Module.Env++import GHC.Core         -- All of it import GHC.Core.Subst import GHC.Core.SimpleOpt ( exprIsLambda_maybe ) import GHC.Core.FVs       ( exprFreeVars, exprsFreeVars, bindFreeVars                           , rulesFreeVarsDSet, exprsOrphNames, exprFreeVarsList )-import GHC.Core.Utils     ( exprType, eqExpr, mkTick, mkTicks+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, TCvSubst, extendTvSubst, extendCvSubst-   , mkEmptyTCvSubst, getTyVar_maybe, substTy )-import GHC.Tc.Utils.TcType  ( tcSplitTyConApp_maybe )-import GHC.Builtin.Types    ( anyTypeOfKind )+   , mkEmptyTCvSubst, substTy, getTyVar_maybe ) import GHC.Core.Coercion as Coercion import GHC.Core.Tidy     ( tidyRules )+import GHC.Core.Map.Expr ( eqCoreExpr )++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@@ -59,17 +64,18 @@ import GHC.Types.Name.Env import GHC.Types.Unique.FM import GHC.Types.Tickish-import GHC.Core.Unify as Unify ( ruleMatchTyKiX ) import GHC.Types.Basic-import GHC.Driver.Session      ( DynFlags, gopt, targetPlatform, homeUnitId_ )-import GHC.Driver.Ppr-import GHC.Driver.Flags-import GHC.Utils.Outputable-import GHC.Utils.Panic+ import GHC.Data.FastString import GHC.Data.Maybe import GHC.Data.Bag+ import GHC.Utils.Misc as Utils+import GHC.Utils.Trace+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 )@@ -130,16 +136,20 @@   [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, we combine (b-d) into a single+* 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-  [Of course this means that we won't see new EPS rules that come in-  during a single simplifier iteration, but that probably does not-  matter.]+  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 seee+  see T19790 and !6735. + ************************************************************************ *                                                                      * \subsection[specialisation-IdInfo]{Specialisation info about an @Id@}@@ -307,9 +317,9 @@ getRules :: RuleEnv -> Id -> [CoreRule] -- See Note [Where rules are found] getRules (RuleEnv { re_base = rule_base, re_visible_orphs = orphs }) fn-  = idCoreRules fn ++ filter (ruleIsVisible orphs) imp_rules+  = idCoreRules fn ++ concatMap imp_rules rule_base   where-    imp_rules = lookupNameEnv rule_base (idName fn) `orElse` []+    imp_rules rb = filter (ruleIsVisible orphs) (lookupNameEnv rb (idName fn) `orElse` [])  ruleIsVisible :: ModuleSet -> CoreRule -> Bool ruleIsVisible _ BuiltinRule{} = True@@ -355,13 +365,13 @@ extendRuleBaseList rule_base new_guys   = foldl' extendRuleBase rule_base new_guys -unionRuleBase :: RuleBase -> RuleBase -> RuleBase-unionRuleBase rb1 rb2 = plusNameEnv_C (++) rb1 rb2- extendRuleBase :: RuleBase -> CoreRule -> RuleBase extendRuleBase rule_base rule   = extendNameEnv_Acc (:) Utils.singleton rule_base (ruleIdName rule) rule +extendRuleEnv :: RuleEnv -> RuleBase -> RuleEnv+extendRuleEnv (RuleEnv rules orphs) rb = (RuleEnv (rb:rules) orphs)+ pprRuleBase :: RuleBase -> SDoc pprRuleBase rules = pprUFM rules $ \rss ->   vcat [ pprRules (tidyRules emptyTidyEnv rs)@@ -381,8 +391,10 @@ -- successful. lookupRule :: RuleOpts -> InScopeEnv            -> (Activation -> Bool)      -- When rule is active-           -> Id -> [CoreExpr]-           -> [CoreRule] -> Maybe (CoreRule, CoreExpr)+           -> Id -- Function head+           -> [CoreExpr] -- Args+           -> [CoreRule] -- Rules+           -> Maybe (CoreRule, CoreExpr)  -- See Note [Extra args in the target] -- See comments on matchRule@@ -394,7 +406,7 @@   where     rough_args = map roughTopName args -    -- Strip ticks from arguments, see note [Tick annotations in RULE+    -- 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@@ -765,10 +777,6 @@        ; match_exprs renv subst' es1 es2 } match_exprs _ _ _ _ = Nothing ---      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  {- Note [Casts in the target] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -882,7 +890,7 @@   = match_ty renv subst ty1 ty2  ------------------------ Coercions ------------------------ See Note [Coercion argument] for why this isn't really right+-- 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)@@ -912,7 +920,7 @@ ------------------------ Literals --------------------- match _ subst (Lit lit1) (Lit lit2) mco   | lit1 == lit2-  = ASSERT2(isReflMCo mco, ppr mco)+  = assertPpr (isReflMCo mco) (ppr mco) $     Just subst  ------------------------ Variables ---------------------@@ -1233,7 +1241,7 @@                 -- e.g. match forall a. (\x-> a x) against (\y. y y)    | Just e1' <- lookupVarEnv id_subst v1'-  = if eqExpr (rnInScopeSet rn_env) e1' e2'+  = if eqCoreExpr e1' e2'     then Just subst     else Nothing
GHC/Core/Seq.hs view
@@ -14,7 +14,7 @@  import GHC.Core import GHC.Types.Id.Info-import GHC.Types.Demand( seqDemand, seqStrictSig )+import GHC.Types.Demand( seqDemand, seqDmdSig ) import GHC.Types.Cpr( seqCprSig ) import GHC.Types.Basic( seqOccInfo ) import GHC.Types.Tickish@@ -32,11 +32,11 @@  -- Omitting this improves runtimes a little, presumably because -- some unfoldings are not calculated at all---    seqUnfolding (unfoldingInfo info)         `seq`+--    seqUnfolding (realUnfoldingInfo info)         `seq`      seqDemand (demandInfo info)                 `seq`-    seqStrictSig (strictnessInfo info)          `seq`-    seqCprSig (cprInfo info)                    `seq`+    seqDmdSig (dmdSigInfo info)          `seq`+    seqCprSig (cprSigInfo info)                    `seq`     seqCaf (cafInfo info)                       `seq`     seqOneShot (oneShotInfo info)               `seq`     seqOccInfo (occInfo info)
GHC/Core/SimpleOpt.hs view
@@ -3,8 +3,6 @@ (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -} -{-# LANGUAGE CPP #-}-{-# LANGUAGE MultiWayIf #-}  module GHC.Core.SimpleOpt (         SimpleOpts (..), defaultSimpleOpts,@@ -20,8 +18,6 @@      ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Core@@ -32,15 +28,15 @@ import GHC.Core.Unfold import GHC.Core.Unfold.Make import GHC.Core.Make ( FloatBind(..) )-import GHC.Core.Opt.OccurAnal( occurAnalyseExpr, occurAnalysePgm )+import GHC.Core.Opt.OccurAnal( occurAnalyseExpr, occurAnalysePgm, zapLambdaBndrs ) import GHC.Types.Literal import GHC.Types.Id-import GHC.Types.Id.Info  ( unfoldingInfo, setUnfoldingInfo, setRuleInfo, IdInfo (..) )+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.Core.DataCon-import GHC.Types.Demand( etaConvertStrictSig )+import GHC.Types.Demand( etaConvertDmdSig ) import GHC.Types.Tickish import GHC.Core.Coercion.Opt ( optCoercion, OptCoercionOpts (..) ) import GHC.Core.Type hiding ( substTy, extendTvSubst, extendCvSubst, extendTvSubstList@@ -53,6 +49,7 @@ import GHC.Utils.Encoding import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Utils.Misc import GHC.Data.Maybe       ( orElse ) import Data.List (mapAccumL)@@ -335,20 +332,21 @@   = simple_app env e1 ((env, e2) : as)  simple_app env e@(Lam {}) as@(_:_)-  | (bndrs, body) <- collectBinders e-  , let zapped_bndrs = zapLamBndrs (length as) bndrs+  = do_beta env (zapLambdaBndrs e n_args) as     -- Be careful to zap the lambda binders if necessary-    -- c.f. the Lam caes of simplExprF1 in GHC.Core.Opt.Simplify+    -- 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 [Linear fields generalization] in GHC.Tc.Gen.Head-  = do_beta env zapped_bndrs body as+    -- Note [Typechecking data constructors] in GHC.Tc.Gen.Head   where-    do_beta env (b:bs) body (a:as)+    n_args = length as++    do_beta env (Lam b body) (a:as)       | (env', mb_pr) <- simple_bind_pair env b Nothing a NotTopLevel-      = wrapLet mb_pr $ do_beta env' bs body as-    do_beta env bs body as = simple_app env (mkLams bs body) as+      = wrapLet mb_pr $ do_beta env' body as+    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)"?@@ -419,15 +417,15 @@                  top_level   | Type ty <- in_rhs        -- let a::* = TYPE ty in <body>   , let out_ty = substTy (soe_subst rhs_env) ty-  = ASSERT2( isTyVar in_bndr, ppr in_bndr $$ ppr in_rhs )+  = 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 (soe_co_opt_opts env) (getTCvSubst (soe_subst rhs_env)) co-  = ASSERT( isCoVar in_bndr )+  = assert (isCoVar in_bndr)     (env { soe_subst = extendCvSubst subst in_bndr out_co }, Nothing) -  | ASSERT2( isNonCoVarId in_bndr, ppr in_bndr )+  | 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@@ -477,11 +475,11 @@                 -> (SimpleOptEnv, Maybe (OutVar, OutExpr)) simple_out_bind top_level env@(SOE { soe_subst = subst }) (in_bndr, out_rhs)   | Type out_ty <- out_rhs-  = ASSERT2( isTyVar in_bndr, ppr in_bndr $$ ppr out_ty $$ ppr 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 )+  = assert (isCoVar in_bndr)     (env { soe_subst = extendCvSubst subst in_bndr out_co }, Nothing)    | otherwise@@ -495,7 +493,7 @@                      -> (SimpleOptEnv, Maybe (OutVar, OutExpr)) simple_out_bind_pair env in_bndr mb_out_bndr out_rhs                      occ_info active stable_unf top_level-  | ASSERT2( isNonCoVarId in_bndr, ppr in_bndr )+  | assertPpr (isNonCoVarId in_bndr) (ppr in_bndr)     -- Type and coercion bindings are caught earlier     -- See Note [Core type and coercion invariant]     post_inline_unconditionally@@ -668,7 +666,7 @@    old_rules = ruleInfo old_info    new_rules = substRuleInfo subst new_bndr old_rules -   old_unfolding = unfoldingInfo old_info+   old_unfolding = realUnfoldingInfo old_info    new_unfolding | isStableUnfolding old_unfolding                  = substUnfolding subst old_unfolding                  | otherwise@@ -828,10 +826,10 @@    | AlwaysTailCalled join_arity <- tailCallInfo (idOccInfo bndr)   , (bndrs, body) <- etaExpandToJoinPoint join_arity rhs-  , let str_sig   = idStrictness bndr+  , let str_sig   = idDmdSig bndr         str_arity = count isId bndrs  -- Strictness demands are for Ids only         join_bndr = bndr `asJoinId`        join_arity-                         `setIdStrictness` etaConvertStrictSig str_arity str_sig+                         `setIdDmdSig` etaConvertDmdSig str_arity str_sig   = Just (join_bndr, mkLams bndrs body)    | otherwise@@ -1285,36 +1283,15 @@ exprIsLiteral_maybe :: InScopeEnv -> CoreExpr -> Maybe Literal -- Same deal as exprIsConApp_maybe, but much simpler -- Nevertheless we do need to look through unfoldings for--- Integer and string literals, which are vigorously hoisted to top level+-- string literals, which are vigorously hoisted to top level -- and not subsequently inlined exprIsLiteral_maybe env@(_, id_unf) e   = case e of       Lit l     -> Just l       Tick _ e' -> exprIsLiteral_maybe env e' -- dubious?-      Var v-         | Just rhs <- expandUnfolding_maybe (id_unf v)-         , Just l   <- exprIsLiteral_maybe env rhs-         -> Just l-      Var v-         | Just rhs <- expandUnfolding_maybe (id_unf v)-         , Just b <- matchBignum env rhs-         -> Just b-      e-         | Just b <- matchBignum env e-         -> Just b--         | otherwise-         -> Nothing-  where-    matchBignum env e-         | Just (_env,_fb,dc,_tys,[arg]) <- exprIsConApp_maybe env e-         , Just (LitNumber _ i) <- exprIsLiteral_maybe env arg-         = if-            | dc == naturalNSDataCon -> Just (mkLitNatural i)-            | dc == integerISDataCon -> Just (mkLitInteger i)-            | otherwise              -> Nothing-         | otherwise-         = Nothing+      Var v     -> expandUnfolding_maybe (id_unf v)+                    >>= exprIsLiteral_maybe env+      _         -> Nothing  {- Note [exprIsLambda_maybe]@@ -1349,7 +1326,7 @@     -- 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+    , 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)])
GHC/Core/Subst.hs view
@@ -6,7 +6,7 @@ Utility functions on @Core@ syntax -} -{-# LANGUAGE CPP #-}+ {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} module GHC.Core.Subst (         -- * Main data types@@ -17,7 +17,7 @@         deShadowBinds, substRuleInfo, substRulesForImportedIds,         substTy, substCo, substExpr, substExprSC, substBind, substBindSC,         substUnfolding, substUnfoldingSC,-        lookupIdSubst, lookupTCvSubst, substIdType, substIdOcc,+        lookupIdSubst, substIdType, substIdOcc,         substTickish, substDVarSet, substIdInfo,          -- ** Operations on substitutions@@ -34,9 +34,6 @@      ) where -#include "HsVersions.h"-- import GHC.Prelude  import GHC.Core@@ -52,7 +49,6 @@    , isInScope, substTyVarBndr, cloneTyVarBndr ) import GHC.Core.Coercion hiding ( substCo, substCoVarBndr ) -import GHC.Builtin.Names import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Types.Id@@ -61,12 +57,16 @@ 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 GHC.Utils.Panic.Plain+ import Data.List (mapAccumL)-import GHC.Driver.Ppr   @@ -190,13 +190,13 @@ 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-  = ASSERT2( isNonCoVarId v, ppr v $$ ppr r )+  = assertPpr (isNonCoVarId v) (ppr v $$ ppr r) $     Subst in_scope (extendVarEnv ids v r) tvs cvs  -- | 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 )+  = assert (all (isNonCoVarId . fst) prs) $     Subst in_scope (extendVarEnvList ids prs) tvs cvs  -- | Add a substitution for a 'TyVar' to the 'Subst'@@ -206,7 +206,7 @@ -- after extending the substitution like this. extendTvSubst :: Subst -> TyVar -> Type -> Subst extendTvSubst (Subst in_scope ids tvs cvs) tv ty-  = ASSERT( isTyVar tv )+  = assert (isTyVar tv) $     Subst in_scope ids (extendVarEnv tvs tv ty) cvs  -- | Adds multiple 'TyVar' substitutions to the 'Subst': see also 'extendTvSubst'@@ -222,7 +222,7 @@ -- after extending the substitution like this extendCvSubst :: Subst -> CoVar -> Coercion -> Subst extendCvSubst (Subst in_scope ids tvs cvs) v r-  = ASSERT( isCoVar v )+  = assert (isCoVar v) $     Subst in_scope ids tvs (extendVarEnv cvs v r)  -- | Add a substitution appropriate to the thing being substituted@@ -231,15 +231,15 @@ extendSubst :: Subst -> Var -> CoreArg -> Subst extendSubst subst var arg   = case arg of-      Type ty     -> ASSERT( isTyVar var ) extendTvSubst subst var ty-      Coercion co -> ASSERT( isCoVar var ) extendCvSubst subst var co-      _           -> ASSERT( isId    var ) extendIdSubst subst var arg+      Type ty     -> assert (isTyVar var) $ extendTvSubst subst var ty+      Coercion co -> assert (isCoVar var) $ extendCvSubst subst var co+      _           -> assert (isId    var) $ extendIdSubst subst var 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)+  | 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@@ -254,18 +254,10 @@   | not (isLocalId v) = Var v   | Just e  <- lookupVarEnv ids       v = e   | Just v' <- lookupInScope in_scope v = Var v'--  | otherwise = WARN( True, text "GHC.Core.Subst.lookupIdSubst" <+> ppr v-                             $$ ppr in_scope)-                Var v---- | Find the substitution for a 'TyVar' in the 'Subst'-lookupTCvSubst :: Subst -> TyVar -> Type-lookupTCvSubst (Subst _ _ tvs cvs) v-  | isTyVar v-  = lookupVarEnv tvs v `orElse` Type.mkTyVarTy v-  | otherwise-  = mkCoercionTy $ lookupVarEnv cvs v `orElse` mkCoVarCo v+        -- Vital! See Note [Extending the Subst]+        -- If v isn't in the InScopeSet, we panic, because+        -- it's a bad bug and we reallly want to know+  | otherwise = pprPanic "lookupIdSubst" (ppr v $$ ppr in_scope)  delBndr :: Subst -> Var -> Subst delBndr (Subst in_scope ids tvs cvs) v@@ -619,7 +611,7 @@                                `setUnfoldingInfo` substUnfolding subst old_unf)   where     old_rules     = ruleInfo info-    old_unf       = unfoldingInfo info+    old_unf       = realUnfoldingInfo info     nothing_to_do = isEmptyRuleInfo old_rules && not (hasCoreUnfolding old_unf)  ------------------@@ -701,13 +693,21 @@     (subst', bndrs') = substBndrs subst bndrs  -------------------substDVarSet :: Subst -> DVarSet -> DVarSet-substDVarSet subst fvs-  = mkDVarSet $ fst $ foldr (subst_fv subst) ([], emptyVarSet) $ dVarSetElems fvs+substDVarSet :: HasDebugCallStack => Subst -> DVarSet -> DVarSet+substDVarSet subst@(Subst _ _ tv_env cv_env) fvs+  = mkDVarSet $ fst $ foldr subst_fv ([], emptyVarSet) $ dVarSetElems fvs   where-  subst_fv subst fv acc-     | isId fv = expr_fvs (lookupIdSubst subst fv) isLocalVar emptyVarSet $! acc-     | otherwise = tyCoFVsOfType (lookupTCvSubst subst fv) (const True) emptyVarSet $! acc+  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+     = expr_fvs fv_expr isLocalVar emptyVarSet $! acc  ------------------ substTickish :: Subst -> CoreTickish -> CoreTickish@@ -748,8 +748,7 @@ and the rule was  {-# RULES-"transpose/overlays1" forall xs. transpose (overlays1 xs) = overlays1 (fmap transpose xs)-#-}+"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.
GHC/Core/Tidy.hs view
@@ -7,32 +7,39 @@ The code for *top-level* bindings is in GHC.Iface.Tidy. -} -{-# LANGUAGE CPP #-}+ {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} module GHC.Core.Tidy (-        tidyExpr, tidyRules, tidyUnfolding+        tidyExpr, tidyRules, tidyUnfolding, tidyCbvInfoTop     ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Core+import GHC.Core.Type+ import GHC.Core.Seq ( seqUnfolding ) import GHC.Types.Id import GHC.Types.Id.Info-import GHC.Types.Demand ( zapDmdEnvSig )-import GHC.Core.Type     ( tidyType, tidyVarBndr )+import GHC.Types.Demand ( zapDmdEnvSig, isStrUsedDmd ) import GHC.Core.Coercion ( tidyCo ) 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.Trace+import GHC.Utils.Outputable+import GHC.Types.RepType (typePrimRep)+import GHC.Utils.Panic+import GHC.Types.Basic (isMarkedCbv, CbvMark (..))+import GHC.Core.Utils (shouldUseCbvForId)  {- ************************************************************************@@ -47,18 +54,142 @@          ->  (TidyEnv, CoreBind)  tidyBind env (NonRec bndr rhs)-  = tidyLetBndr env env bndr =: \ (env', bndr') ->-    (env', NonRec bndr' (tidyExpr env' 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)-  = let-       (bndrs, rhss)  = unzip prs-       (env', bndrs') = mapAccumL (tidyLetBndr env') env bndrs+  = -- 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 tidyCbvInfo 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+  | otherwise = 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+  | (isWorkerLike || isJoinId fun_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+    val_args = filter isId . fst $ collectBinders rhs+    cbv_marks =+      -- 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+        | valid_unlifted_worker val_args+        , any isMarkedCbv cbv_marks+        -- seqList to avoid retaining the original rhs+        = cbv_marks `seqList` setIdCbvMarks fun_id cbv_marks+        | otherwise =+          -- pprTraceDebug "tidyCbvInfo: 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++    isWorkerLike = isWorkerLikeId fun_id+ ------------  Expressions  -------------- tidyExpr :: TidyEnv -> CoreExpr -> CoreExpr tidyExpr env (Var v)       = Var (tidyVarOcc env v)@@ -163,8 +294,8 @@                                   -- see Note [Preserve OneShotInfo]                                  `setOneShotInfo` oneShotInfo old_info         old_info = idInfo id-        old_unf  = unfoldingInfo old_info-        new_unf  = zapUnfolding old_unf  -- See Note [Preserve evaluatedness]+        old_unf  = realUnfoldingInfo old_info+        new_unf  = trimUnfolding old_unf  -- See Note [Preserve evaluatedness]     in     ((tidy_env', var_env'), id')    }@@ -208,14 +339,14 @@         new_info = vanillaIdInfo                     `setOccInfo`        occInfo old_info                     `setArityInfo`      arityInfo old_info-                    `setStrictnessInfo` zapDmdEnvSig (strictnessInfo old_info)+                    `setDmdSigInfo` zapDmdEnvSig (dmdSigInfo old_info)                     `setDemandInfo`     demandInfo old_info                     `setInlinePragInfo` inlinePragInfo old_info                     `setUnfoldingInfo`  new_unf -        old_unf = unfoldingInfo old_info+        old_unf = realUnfoldingInfo old_info         new_unf | isStableUnfolding old_unf = tidyUnfolding rec_tidy_env old_unf old_unf-                | otherwise                 = zapUnfolding old_unf+                | otherwise                 = trimUnfolding old_unf                                               -- See Note [Preserve evaluatedness]      in
GHC/Core/TyCo/FVs.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE CPP #-} + module GHC.Core.TyCo.FVs   (     shallowTyCoVarsOfType, shallowTyCoVarsOfTypes,         tyCoVarsOfType,        tyCoVarsOfTypes,@@ -42,8 +42,6 @@         Endo(..), runTyCoVars   ) where -#include "HsVersions.h"- import GHC.Prelude  import {-# SOURCE #-} GHC.Core.Type (coreView, partitionInvisibleTypes)@@ -267,9 +265,6 @@ {-# INLINE runTyCoVars #-} runTyCoVars f = appEndo f emptyVarSet -noView :: Type -> Maybe Type-noView _ = Nothing- {- ********************************************************************* *                                                                      *           Deep free variables@@ -384,8 +379,8 @@ ********************************************************************* -}  -{- Note [Finding free coercion varibles]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+{- 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. @@ -394,6 +389,7 @@ See #14880. -} +-- See Note [Finding free coercion variables] coVarsOfType  :: Type       -> CoVarSet coVarsOfTypes :: [Type]     -> CoVarSet coVarsOfCo    :: Coercion   -> CoVarSet@@ -433,7 +429,6 @@     do_hole is hole  = do_covar is (coHoleCoVar hole)                        -- See Note [CoercionHoles and coercion free variables]                        -- in GHC.Core.TyCo.Rep-  {- ********************************************************************* *                                                                      *
GHC/Core/TyCo/Rep.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP                #-}+ {-# LANGUAGE DeriveDataTypeable #-}  {-# OPTIONS_HADDOCK not-home #-}@@ -30,8 +30,9 @@          TyLit(..),         KindOrType, Kind,+        RuntimeRepType,         KnotTied,-        PredType, ThetaType,      -- Synonyms+        PredType, ThetaType, FRRType,     -- Synonyms         ArgFlag(..), AnonArgFlag(..),          -- * Coercions@@ -42,7 +43,7 @@         MCoercion(..), MCoercionR, MCoercionN,          -- * Functions over types-        mkTyConTy_, mkTyVarTy, mkTyVarTys,+        mkNakedTyConTy, mkTyVarTy, mkTyVarTys,         mkTyCoVarTy, mkTyCoVarTys,         mkFunTy, mkVisFunTy, mkInvisFunTy, mkVisFunTys,         mkForAllTy, mkForAllTys, mkInvisForAllTys,@@ -65,7 +66,7 @@         pickLR,          -- ** Analyzing types-        TyCoFolder(..), foldTyCo,+        TyCoFolder(..), foldTyCo, noView,          -- * Sizes         typeSize, coercionSize, provSize,@@ -74,8 +75,6 @@         Scaled(..), scaledMult, scaledThing, mapScaledType, Mult     ) where -#include "HsVersions.h"- import GHC.Prelude  import {-# SOURCE #-} GHC.Core.TyCo.Ppr ( pprType, pprCo, pprTyLit )@@ -83,7 +82,6 @@    -- Transitively pulls in a LOT of stuff, better to break the loop  -- friends:-import GHC.Iface.Type import GHC.Types.Var import GHC.Types.Var.Set import GHC.Core.TyCon@@ -115,6 +113,13 @@ -- | The key type representing kinds in the compiler. type Kind = Type +-- | Type synonym used for types of kind RuntimeRep.+type RuntimeRepType = 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@@ -152,6 +157,7 @@   | ForAllTy         {-# UNPACK #-} !TyCoVarBinder         Type            -- ^ A Π type.+             -- Note [When we quantify over a coercion variable]              -- INVARIANT: If the binder is a coercion variable, it must              -- be mentioned in the Type. See              -- Note [Unused coercion variable in ForAllTy]@@ -217,21 +223,38 @@  {- Note [Function types] ~~~~~~~~~~~~~~~~~~~~~~~~-FFunTy is the constructor for a function type.  Lots of things to say-about it!--* FFunTy is the data constructor, meaning "full function type".+FunTy is the constructor for a function type.  Here are the details: -* The function type constructor (->) has kind-     (->) :: forall {r1} {r2}. TYPE r1 -> TYPE r2 -> Type LiftedRep-  mkTyConApp ensure that we convert a saturated application-    TyConApp (->) [r1,r2,t1,t2] into FunTy t1 t2+* 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 VisArg m t1 t2   dropping the 'r1' and 'r2' arguments; they are easily recovered-  from 't1' and 't2'.+  from 't1' and 't2'. The visibility is always VisArg, 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.+ * The ft_af field says whether or not this is an invisible argument      VisArg:   t1 -> t2    Ordinary function type      InvisArg: t1 => t2    t1 is guaranteed to be a predicate type,@@ -241,33 +264,8 @@   This visibility info makes no difference in Core; it matters   only when we regard the type as a Haskell source type. -* FunTy is a (unidirectional) pattern synonym that allows-  positional pattern matching (FunTy arg res), ignoring the-  ArgFlag.--}--{- ------------------------      Commented out until the pattern match-      checker can handle it; see #16185--      For now we use the CPP macro #define FunTy FFunTy _-      (see HsVersions.h) to allow pattern matching on a-      (positional) FunTy constructor.--{-# COMPLETE FunTy, TyVarTy, AppTy, TyConApp-           , ForAllTy, LitTy, CastTy, CoercionTy :: Type #-}---- | 'FunTy' is a (uni-directional) pattern synonym for the common--- case where we want to match on the argument/result type, but--- ignoring the AnonArgFlag-pattern FunTy :: Type -> Type -> Type-pattern FunTy arg res <- FFunTy { ft_arg = arg, ft_res = res }--       End of commented out block----------------------------------- -}--{- Note [Types for coercions, predicates, and evidence]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Note [Types for coercions, predicates, and evidence]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We treat differently:    (a) Predicate types@@ -634,6 +632,35 @@ expand into TyConApps, we must check the kinds of the arg and the res. +Note [When we quantify over a coercion variable]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The TyCoVarBinder 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@@ -723,10 +750,8 @@ instance Outputable TyCoBinder where   ppr (Anon af ty) = ppr af <+> ppr ty   ppr (Named (Bndr v Required))  = ppr v-  -- See Note [Explicit Case Statement for Specificity]-  ppr (Named (Bndr v (Invisible spec))) = case spec of-    SpecifiedSpec -> char '@' <> ppr v-    InferredSpec  -> braces (ppr v)+  ppr (Named (Bndr v Specified)) = char '@' <> ppr v+  ppr (Named (Bndr v Inferred))  = braces (ppr v)   -- | 'TyBinder' is like 'TyCoBinder', but there can only be 'TyVarBinder'@@ -1000,7 +1025,7 @@ -}  mkTyVarTy  :: TyVar   -> Type-mkTyVarTy v = ASSERT2( isTyVar v, ppr v <+> dcolon <+> ppr (tyVarKind v) )+mkTyVarTy v = assertPpr (isTyVar v) (ppr v <+> dcolon <+> ppr (tyVarKind v)) $               TyVarTy v  mkTyVarTys :: [TyVar] -> [Type]@@ -1063,7 +1088,7 @@  -- | Wraps foralls over the type using the provided 'InvisTVBinder's from left to right mkInvisForAllTys :: [InvisTVBinder] -> Type -> Type-mkInvisForAllTys tyvars ty = foldr ForAllTy ty $ tyVarSpecToBinders tyvars+mkInvisForAllTys tyvars = mkForAllTys (tyVarSpecToBinders tyvars)  mkPiTy :: TyCoBinder -> Type -> Type mkPiTy (Anon af ty1) ty2        = mkScaledFunTy af ty1 ty2@@ -1072,11 +1097,13 @@ mkPiTys :: [TyCoBinder] -> Type -> Type mkPiTys tbs ty = foldr mkPiTy ty tbs --- | Create a nullary 'TyConApp'. In general you should rather use--- 'GHC.Core.Type.mkTyConTy'. This merely exists to break the import cycle--- between 'GHC.Core.TyCon' and this module.-mkTyConTy_ :: TyCon -> Type-mkTyConTy_ tycon = TyConApp tycon []+-- | '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 []  {- %************************************************************************@@ -1844,7 +1871,7 @@                                      `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 makr+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. -}@@ -1853,8 +1880,8 @@   = TyCoFolder       { tcf_view  :: Type -> Maybe Type   -- Optional "view" function                                           -- E.g. expand synonyms-      , tcf_tyvar :: env -> TyVar -> a-      , tcf_covar :: env -> CoVar -> a+      , 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".@@ -1925,6 +1952,10 @@     go_prov env (ProofIrrelProv co) = go_co env co     go_prov _   (PluginProv _)      = mempty     go_prov _   (CorePrepProv _)    = mempty++-- | A view function that looks through nothing.+noView :: Type -> Maybe Type+noView _ = Nothing  {- ********************************************************************* *                                                                      *
GHC/Core/TyCo/Rep.hs-boot view
@@ -1,3 +1,4 @@+{-# LANGUAGE NoPolyKinds #-} module GHC.Core.TyCo.Rep where  import GHC.Utils.Outputable ( Outputable )@@ -23,7 +24,7 @@  mkFunTyMany :: AnonArgFlag -> Type -> Type -> Type mkForAllTy :: Var -> ArgFlag -> Type -> Type-mkTyConTy_ :: TyCon -> Type+mkNakedTyConTy :: TyCon -> Type  instance Data Type  -- To support Data instances in GHC.Core.Coercion.Axiom instance Outputable Type
GHC/Core/TyCo/Subst.hs view
@@ -4,7 +4,7 @@ Type and Coercion - friends' interface -} -{-# LANGUAGE CPP #-}+ {-# LANGUAGE BangPatterns #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -52,8 +52,6 @@         checkValidSubst, isValidTCvSubst,   ) where -#include "HsVersions.h"- import GHC.Prelude  import {-# SOURCE #-} GHC.Core.Type@@ -76,6 +74,7 @@ import GHC.Types.Var.Env  import GHC.Data.Pair+import GHC.Utils.Constants (debugIsOn) import GHC.Utils.Misc import GHC.Types.Unique.Supply import GHC.Types.Unique@@ -83,6 +82,7 @@ import GHC.Types.Unique.Set import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain  import Data.List (mapAccumL) @@ -113,7 +113,7 @@              TvSubstEnv -- Substitutes both type and kind variables              CvSubstEnv -- Substitutes coercion variables         -- See Note [Substitutions apply only once]-        -- and Note [Extending the TvSubstEnv]+        -- and Note [Extending the TCvSubstEnv]         -- and Note [Substituting types and coercions]         -- and Note [The substitution invariant] @@ -179,8 +179,8 @@ 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]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Note [Extending the TCvSubstEnv]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ See #tcvsubst_invariant# for the invariants that must hold.  This invariant allows a short-cut when the subst envs are empty:@@ -258,7 +258,7 @@ mkEmptyTCvSubst is = TCvSubst is emptyTvSubstEnv emptyCvSubstEnv  isEmptyTCvSubst :: TCvSubst -> Bool-         -- See Note [Extending the TvSubstEnv]+         -- See Note [Extending the TCvSubstEnv] isEmptyTCvSubst (TCvSubst _ tenv cenv) = isEmptyVarEnv tenv && isEmptyVarEnv cenv  mkTCvSubst :: InScopeSet -> (TvSubstEnv, CvSubstEnv) -> TCvSubst@@ -344,7 +344,7 @@  extendTvSubstBinderAndInScope :: TCvSubst -> TyCoBinder -> Type -> TCvSubst extendTvSubstBinderAndInScope subst (Named (Bndr v _)) ty-  = ASSERT( isTyVar v )+  = assert (isTyVar v )     extendTvSubstAndInScope subst v ty extendTvSubstBinderAndInScope subst (Anon {}) _   = subst@@ -388,7 +388,7 @@ unionTCvSubst :: TCvSubst -> TCvSubst -> TCvSubst -- Works when the ranges are disjoint unionTCvSubst (TCvSubst in_scope1 tenv1 cenv1) (TCvSubst in_scope2 tenv2 cenv2)-  = ASSERT( tenv1 `disjointVarEnv` tenv2+  = assert (tenv1 `disjointVarEnv` tenv2          && cenv1 `disjointVarEnv` cenv2 )     TCvSubst (in_scope1 `unionInScope` in_scope2)              (tenv1     `plusVarEnv`   tenv2)@@ -430,7 +430,7 @@ mkTvSubstPrs :: [(TyVar, Type)] -> TCvSubst mkTvSubstPrs []  = emptyTCvSubst mkTvSubstPrs prs =-    ASSERT2( onlyTyVarsAndNoCoercionTy, text "prs" <+> ppr prs )+    assertPpr onlyTyVarsAndNoCoercionTy (text "prs" <+> ppr prs) $     mkTvSubst in_scope tenv   where tenv = mkVarEnv prs         in_scope = mkInScopeSet $ shallowTyCoVarsOfTypes $ map snd prs@@ -444,7 +444,7 @@   , not (all isTyVar tyvars && (tyvars `equalLength` tys))   = pprPanic "zipTyEnv" (ppr tyvars $$ ppr tys)   | otherwise-  = ASSERT( all (not . isCoercionTy) tys )+  = assert (all (not . isCoercionTy) tys )     zipToUFM tyvars tys         -- There used to be a special case for when         --      ty == TyVarTy tv@@ -552,11 +552,11 @@ -}  -- | Type substitution, see 'zipTvSubst'-substTyWith :: HasCallStack => [TyVar] -> [Type] -> Type -> Type+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 )+                      assert (tvs `equalLength` tys )                       substTy (zipTvSubst tvs tys)  -- | Type substitution, see 'zipTvSubst'. Disables sanity checks.@@ -566,7 +566,7 @@ -- substTy and remove this function. Please don't use in new code. substTyWithUnchecked :: [TyVar] -> [Type] -> Type -> Type substTyWithUnchecked tvs tys-  = ASSERT( tvs `equalLength` tys )+  = assert (tvs `equalLength` tys )     substTyUnchecked (zipTvSubst tvs tys)  -- | Substitute tyvars within a type using a known 'InScopeSet'.@@ -575,13 +575,13 @@ -- and of 'ty' minus the domain of the subst. substTyWithInScope :: InScopeSet -> [TyVar] -> [Type] -> Type -> Type substTyWithInScope in_scope tvs tys ty =-  ASSERT( tvs `equalLength` tys )+  assert (tvs `equalLength` tys )   substTy (mkTvSubst in_scope tenv) ty   where tenv = zipTyEnv tvs tys  -- | Coercion substitution, see 'zipTvSubst'-substCoWith :: HasCallStack => [TyVar] -> [Type] -> Coercion -> Coercion-substCoWith tvs tys = ASSERT( tvs `equalLength` tys )+substCoWith :: HasDebugCallStack => [TyVar] -> [Type] -> Coercion -> Coercion+substCoWith tvs tys = assert (tvs `equalLength` tys )                       substCo (zipTvSubst tvs tys)  -- | Coercion substitution, see 'zipTvSubst'. Disables sanity checks.@@ -591,7 +591,7 @@ -- substCo and remove this function. Please don't use in new code. substCoWithUnchecked :: [TyVar] -> [Type] -> Coercion -> Coercion substCoWithUnchecked tvs tys-  = ASSERT( tvs `equalLength` tys )+  = assert (tvs `equalLength` tys )     substCoUnchecked (zipTvSubst tvs tys)  @@ -602,12 +602,12 @@  -- | Type substitution, see 'zipTvSubst' substTysWith :: [TyVar] -> [Type] -> [Type] -> [Type]-substTysWith tvs tys = ASSERT( tvs `equalLength` tys )+substTysWith tvs tys = assert (tvs `equalLength` tys )                        substTys (zipTvSubst tvs tys)  -- | Type substitution, see 'zipTvSubst' substTysWithCoVars :: [CoVar] -> [Coercion] -> [Type] -> [Type]-substTysWithCoVars cvs cos = ASSERT( cvs `equalLength` cos )+substTysWithCoVars cvs cos = assert (cvs `equalLength` cos )                              substTys (zipCvSubst cvs cos)  -- | Substitute within a 'Type' after adding the free variables of the type@@ -632,23 +632,23 @@  -- | This checks if the substitution satisfies the invariant from -- Note [The substitution invariant].-checkValidSubst :: HasCallStack => TCvSubst -> [Type] -> [Coercion] -> a -> a+checkValidSubst :: HasDebugCallStack => TCvSubst -> [Type] -> [Coercion] -> a -> a checkValidSubst subst@(TCvSubst in_scope tenv cenv) tys cos a-  = ASSERT2( 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 )-    ASSERT2( 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 )+  = 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@@ -663,7 +663,7 @@ -- | Substitute within a 'Type' -- The substitution has to satisfy the invariants described in -- Note [The substitution invariant].-substTy :: HasCallStack => TCvSubst -> Type  -> Type+substTy :: HasDebugCallStack => TCvSubst -> Type  -> Type substTy subst ty   | isEmptyTCvSubst subst = ty   | otherwise             = checkValidSubst subst [ty] [] $@@ -679,21 +679,21 @@                  | isEmptyTCvSubst subst = ty                  | otherwise             = subst_ty subst ty -substScaledTy :: HasCallStack => TCvSubst -> Scaled Type -> Scaled Type+substScaledTy :: HasDebugCallStack => TCvSubst -> Scaled Type -> Scaled Type substScaledTy subst scaled_ty = mapScaledType (substTy subst) scaled_ty -substScaledTyUnchecked :: HasCallStack => TCvSubst -> Scaled Type -> Scaled Type+substScaledTyUnchecked :: HasDebugCallStack => TCvSubst -> 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 :: HasCallStack => TCvSubst -> [Type] -> [Type]+substTys :: HasDebugCallStack => TCvSubst -> [Type] -> [Type] substTys subst tys   | isEmptyTCvSubst subst = tys   | otherwise = checkValidSubst subst tys [] $ map (subst_ty subst) tys -substScaledTys :: HasCallStack => TCvSubst -> [Scaled Type] -> [Scaled Type]+substScaledTys :: HasDebugCallStack => TCvSubst -> [Scaled Type] -> [Scaled Type] substScaledTys subst scaled_tys   | isEmptyTCvSubst subst = scaled_tys   | otherwise = checkValidSubst subst (map scaledMult scaled_tys ++ map scaledThing scaled_tys) [] $@@ -717,7 +717,7 @@ -- | Substitute within a 'ThetaType' -- The substitution has to satisfy the invariants described in -- Note [The substitution invariant].-substTheta :: HasCallStack => TCvSubst -> ThetaType -> ThetaType+substTheta :: HasDebugCallStack => TCvSubst -> ThetaType -> ThetaType substTheta = substTys  -- | Substitute within a 'ThetaType' disabling the sanity checks.@@ -746,8 +746,8 @@     go (TyConApp tc tys) = (mkTyConApp $! tc) $! strictMap go tys                                -- NB: mkTyConApp, not TyConApp.                                -- mkTyConApp has optimizations.-                               -- See Note [Prefer Type over TYPE 'LiftedRep]-                               -- in GHC.Core.TyCo.Rep+                               -- 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@@ -764,7 +764,7 @@  substTyVar :: TCvSubst -> TyVar -> Type substTyVar (TCvSubst _ tenv _) tv-  = ASSERT( isTyVar tv )+  = assert (isTyVar tv) $     case lookupVarEnv tenv tv of       Just ty -> ty       Nothing -> TyVarTy tv@@ -783,13 +783,13 @@ lookupTyVar :: TCvSubst -> TyVar  -> Maybe Type         -- See Note [Extending the TCvSubst] lookupTyVar (TCvSubst _ tenv _) tv-  = ASSERT( isTyVar 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 :: HasCallStack => TCvSubst -> Coercion -> Coercion+substCo :: HasDebugCallStack => TCvSubst -> Coercion -> Coercion substCo subst co   | isEmptyTCvSubst subst = co   | otherwise = checkValidSubst subst [] [co] $ subst_co subst co@@ -807,7 +807,7 @@ -- | Substitute within several 'Coercion's -- The substitution has to satisfy the invariants described in -- Note [The substitution invariant].-substCos :: HasCallStack => TCvSubst -> [Coercion] -> [Coercion]+substCos :: HasDebugCallStack => TCvSubst -> [Coercion] -> [Coercion] substCos subst cos   | isEmptyTCvSubst subst = cos   | otherwise = checkValidSubst subst [] cos $ map (subst_co subst) cos@@ -887,7 +887,7 @@                             -> TCvSubst -> TyVar -> KindCoercion                             -> (TCvSubst, TyVar, KindCoercion) substForAllCoTyVarBndrUsing sym sco (TCvSubst in_scope tenv cenv) old_var old_kind_co-  = ASSERT( isTyVar old_var )+  = assert (isTyVar old_var )     ( TCvSubst (in_scope `extendInScopeSet` new_var) new_env cenv     , new_var, new_kind_co )   where@@ -916,7 +916,7 @@                             -> (TCvSubst, CoVar, KindCoercion) substForAllCoCoVarBndrUsing sym sco (TCvSubst in_scope tenv cenv)                             old_var old_kind_co-  = ASSERT( isCoVar old_var )+  = assert (isCoVar old_var )     ( TCvSubst (in_scope `extendInScopeSet` new_var) tenv new_cenv     , new_var, new_kind_co )   where@@ -947,19 +947,19 @@ lookupCoVar :: TCvSubst -> Var -> Maybe Coercion lookupCoVar (TCvSubst _ _ cenv) v = lookupVarEnv cenv v -substTyVarBndr :: HasCallStack => TCvSubst -> TyVar -> (TCvSubst, TyVar)+substTyVarBndr :: HasDebugCallStack => TCvSubst -> TyVar -> (TCvSubst, TyVar) substTyVarBndr = substTyVarBndrUsing substTy -substTyVarBndrs :: HasCallStack => TCvSubst -> [TyVar] -> (TCvSubst, [TyVar])+substTyVarBndrs :: HasDebugCallStack => TCvSubst -> [TyVar] -> (TCvSubst, [TyVar]) substTyVarBndrs = mapAccumL substTyVarBndr -substVarBndr :: HasCallStack => TCvSubst -> TyCoVar -> (TCvSubst, TyCoVar)+substVarBndr :: HasDebugCallStack => TCvSubst -> TyCoVar -> (TCvSubst, TyCoVar) substVarBndr = substVarBndrUsing substTy -substVarBndrs :: HasCallStack => TCvSubst -> [TyCoVar] -> (TCvSubst, [TyCoVar])+substVarBndrs :: HasDebugCallStack => TCvSubst -> [TyCoVar] -> (TCvSubst, [TyCoVar]) substVarBndrs = mapAccumL substVarBndr -substCoVarBndr :: HasCallStack => TCvSubst -> CoVar -> (TCvSubst, CoVar)+substCoVarBndr :: HasDebugCallStack => TCvSubst -> CoVar -> (TCvSubst, CoVar) substCoVarBndr = substCoVarBndrUsing substTy  -- | Like 'substVarBndr', but disables sanity checks.@@ -983,8 +983,8 @@   :: (TCvSubst -> Type -> Type)  -- ^ Use this to substitute in the kind   -> TCvSubst -> TyVar -> (TCvSubst, TyVar) substTyVarBndrUsing subst_fn subst@(TCvSubst in_scope tenv cenv) old_var-  = ASSERT2( _no_capture, pprTyVar old_var $$ pprTyVar new_var $$ ppr subst )-    ASSERT( isTyVar old_var )+  = assertPpr _no_capture (pprTyVar old_var $$ pprTyVar new_var $$ ppr subst) $+    assert (isTyVar old_var )     (TCvSubst (in_scope `extendInScopeSet` new_var) new_env cenv, new_var)   where     new_env | no_change = delVarEnv tenv old_var@@ -1018,7 +1018,7 @@   :: (TCvSubst -> Type -> Type)   -> TCvSubst -> CoVar -> (TCvSubst, CoVar) substCoVarBndrUsing subst_fn subst@(TCvSubst in_scope tenv cenv) old_var-  = ASSERT( isCoVar old_var )+  = assert (isCoVar old_var)     (TCvSubst (in_scope `extendInScopeSet` new_var) tenv new_cenv, new_var)   where     new_co         = mkCoVarCo new_var@@ -1040,7 +1040,7 @@  cloneTyVarBndr :: TCvSubst -> TyVar -> Unique -> (TCvSubst, TyVar) cloneTyVarBndr subst@(TCvSubst in_scope tv_env cv_env) tv uniq-  = ASSERT2( isTyVar tv, ppr tv )   -- I think it's only called on TyVars+  = assertPpr (isTyVar tv) (ppr tv)   -- I think it's only called on TyVars     (TCvSubst (extendInScopeSet in_scope tv')               (extendVarEnv tv_env tv (mkTyVarTy tv')) cv_env, tv')   where
GHC/Core/TyCo/Tidy.hs view
@@ -8,12 +8,10 @@         -- * Tidying type related things up for printing         tidyType,      tidyTypes,         tidyOpenType,  tidyOpenTypes,-        tidyOpenKind,         tidyVarBndr, tidyVarBndrs, tidyFreeTyCoVars, avoidNameClashes,         tidyOpenTyCoVar, tidyOpenTyCoVars,         tidyTyCoVarOcc,         tidyTopType,-        tidyKind,         tidyCo, tidyCos,         tidyTyCoVarBinder, tidyTyCoVarBinders   ) where@@ -58,7 +56,7 @@  avoidNameClashes :: [TyCoVar] -> TidyEnv -> TidyEnv -- Seed the occ_env with clashes among the names, see--- Note [Tidying multiple names at once] in GHC.Types.Names.OccName+-- Note [Tidying multiple names at once] in GHC.Types.Name.Occurrence avoidNameClashes tvs (occ_env, subst)   = (avoidClashesOccEnv occ_env occs, subst)   where@@ -127,12 +125,22 @@ {- Note [Strictness in tidyType and friends] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Perhaps surprisingly, making `tidyType` strict has a rather large effect on-performance: see #14738.  So you will see lots of strict applications ($!)-and uses of `strictMap` in `tidyType`, `tidyTypes` and `tidyCo`. -See #14738 for the performance impact -- sometimes as much as a 5%-reduction in allocation.+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@@ -148,8 +156,9 @@ -- -- See Note [Strictness in tidyType and friends] tidyType :: TidyEnv -> Type -> Type-tidyType _   (LitTy n)             = LitTy n+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 ty@(FunTy _ w arg res)  = let { !w'   = tidyType env w@@ -204,13 +213,6 @@ tidyTopType ty = tidyType emptyTidyEnv ty  ----------------tidyOpenKind :: TidyEnv -> Kind -> (TidyEnv, Kind)-tidyOpenKind = tidyOpenType--tidyKind :: TidyEnv -> Kind -> Kind-tidyKind = tidyType------------------  -- | Tidy a Coercion --
GHC/Core/TyCon.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP                #-}+ {-# LANGUAGE FlexibleInstances  #-} {-# LANGUAGE LambdaCase         #-} {-# LANGUAGE DeriveDataTypeable #-}@@ -25,7 +25,7 @@         mkRequiredTyConBinder,         mkAnonTyConBinder, mkAnonTyConBinders,         tyConBinderArgFlag, tyConBndrVisArgFlag, isNamedTyConBinder,-        isVisibleTyConBinder, isInvisibleTyConBinder,+        isVisibleTyConBinder, isInvisibleTyConBinder, isVisibleTcbVis,          -- ** Field labels         tyConFieldLabels, lookupTyConFieldLabel,@@ -35,11 +35,10 @@         mkClassTyCon,         mkFunTyCon,         mkPrimTyCon,-        mkKindTyCon,-        mkLiftedPrimTyCon,         mkTupleTyCon,         mkSumTyCon,         mkDataTyConRhs,+        mkLevPolyDataTyConRhs,         mkSynonymTyCon,         mkFamilyTyCon,         mkPromotedDataCon,@@ -68,13 +67,13 @@         isOpenTypeFamilyTyCon, isClosedSynFamilyTyConWithAxiom_maybe,         tyConInjectivityInfo,         isBuiltInSynFamTyCon_maybe,-        isUnliftedTyCon,         isGadtSyntaxTyCon, isInjectiveTyCon, isGenerativeTyCon, isGenInjAlgRhs,         isTyConAssoc, tyConAssoc_maybe, tyConFlavourAssoc_maybe,         isImplicitTyCon,         isTyConWithSrcDataCons,         isTcTyCon, setTcTyConKind,-        isTcLevPoly,+        tcHasFixedRuntimeRep,+        isConcreteTyCon,          -- ** Extracting information out of TyCons         tyConName,@@ -133,13 +132,11 @@  ) where -#include "HsVersions.h"- import GHC.Prelude import GHC.Platform  import {-# SOURCE #-} GHC.Core.TyCo.Rep-   ( Kind, Type, PredType, mkForAllTy, mkFunTyMany, mkTyConTy_ )+   ( Kind, Type, PredType, mkForAllTy, mkFunTyMany, mkNakedTyConTy ) import {-# SOURCE #-} GHC.Core.TyCo.Ppr    ( pprType ) import {-# SOURCE #-} GHC.Builtin.Types@@ -169,6 +166,7 @@ import GHC.Data.Maybe import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Data.FastString.Env import GHC.Types.FieldLabel import GHC.Settings.Constants@@ -394,7 +392,7 @@ 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 levity polymorphism, and therefore+For boxed tuples, there is no representation polymorphism, and therefore we add RuntimeReps only for the unboxed version.  Type constructor (no kind arguments)@@ -447,7 +445,7 @@ type TyConBinder     = VarBndr TyVar   TyConBndrVis type TyConTyCoBinder = VarBndr TyCoVar TyConBndrVis      -- Only PromotedDataCon has TyConTyCoBinders-     -- See Note [Promoted GADT data construtors]+     -- See Note [Promoted GADT data constructors]  data TyConBndrVis   = NamedTCB ArgFlag@@ -458,7 +456,7 @@   ppr (AnonTCB af)    = text "AnonTCB"  <> ppr af  mkAnonTyConBinder :: AnonArgFlag -> TyVar -> TyConBinder-mkAnonTyConBinder af tv = ASSERT( isTyVar tv)+mkAnonTyConBinder af tv = assert (isTyVar tv) $                           Bndr tv (AnonTCB af)  mkAnonTyConBinders :: AnonArgFlag -> [TyVar] -> [TyConBinder]@@ -466,7 +464,7 @@  mkNamedTyConBinder :: ArgFlag -> TyVar -> TyConBinder -- The odd argument order supports currying-mkNamedTyConBinder vis tv = ASSERT( isTyVar tv )+mkNamedTyConBinder vis tv = assert (isTyVar tv) $                             Bndr tv (NamedTCB vis)  mkNamedTyConBinders :: ArgFlag -> [TyVar] -> [TyConBinder]@@ -645,6 +643,8 @@   Note that there are three binders here, including the   kind variable k. +  See Note [tyConBinders and lexical scoping]+ * See Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in GHC.Core.TyCo.Rep   for what the visibility flag means. @@ -673,7 +673,47 @@ * 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 etaExpandAlgTyCon+  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.  Eample (#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@@ -682,10 +722,8 @@       ppr_bi (AnonTCB VisArg)     = text "anon-vis"       ppr_bi (AnonTCB InvisArg)   = text "anon-invis"       ppr_bi (NamedTCB Required)  = text "req"-      -- See Note [Explicit Case Statement for Specificity]-      ppr_bi (NamedTCB (Invisible spec)) = case spec of-        SpecifiedSpec -> text "spec"-        InferredSpec  -> text "inf"+      ppr_bi (NamedTCB Specified) = text "spec"+      ppr_bi (NamedTCB Inferred)  = text "inf"  instance Binary TyConBndrVis where   put_ bh (AnonTCB af)   = do { putByte bh 0; put_ bh af }@@ -734,7 +772,7 @@         tyConName   :: Name,     -- ^ Name of the constructor          -- See Note [The binders/kind/arity fields of a TyCon]-        tyConBinders :: [TyConBinder], -- ^ Full binders+        tyConBinders :: [TyConBinder],    -- ^ Full binders         tyConResKind :: Kind,             -- ^ Result kind         tyConKind    :: Kind,             -- ^ Kind of this TyCon         tyConArity   :: Arity,            -- ^ Arity@@ -752,8 +790,7 @@   --     - boxed tuples   --     - unboxed tuples   --     - constraint tuples-  -- All these constructors are lifted and boxed except unboxed tuples-  -- which should have an 'UnboxedAlgTyCon' parent.+  --     - unboxed sums   -- Data/newtype/type /families/ are handled by 'FamilyTyCon'.   -- See 'AlgTyConRhs' for more information.   | AlgTyCon {@@ -800,6 +837,8 @@                                         -- 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@@ -807,7 +846,8 @@         algTcFields :: FieldLabelEnv, -- ^ Maps a label to information                                       -- about the field -        algTcParent :: AlgTyConFlav -- ^ Gives the class or family declaration+        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. @@ -909,13 +949,9 @@                                  -- This list has length = tyConArity                                  -- See also Note [TyCon Role signatures] -        isUnlifted   :: Bool,    -- ^ Most primitive tycons are unlifted (may-                                 -- not contain bottom) but other are lifted,-                                 -- e.g. @RealWorld@-                                 -- Only relevant if tyConKind = *--        primRepName :: Maybe TyConRepName   -- Only relevant for kind TyCons-                                            -- i.e, *, #, ?+        primRepName :: TyConRepName   -- ^ The 'Typeable' representation.+                                      -- A cached version of+                                      -- @'mkPrelTyConRepName' ('tyConName' tc)@.     }    -- | Represents promoted data constructor.@@ -956,15 +992,18 @@           -- arguments to the type constructor; see the use           -- of tyConArity in generaliseTcTyCon -        tcTyConScopedTyVars :: [(Name,TyVar)],+        tcTyConScopedTyVars :: [(Name,TcTyVar)],           -- ^ Scoped tyvars over the tycon's body-          -- See Note [Scoped tyvars in a TcTyCon]+          -- The range is always a skolem or TcTyVar, be+          -- MonoTcTyCon only: see Note [Scoped tyvars in a TcTyCon]          tcTyConIsPoly     :: Bool, -- ^ Is this TcTyCon already generalized?+                                   -- Used only to make zonking more efficient          tcTyConFlavour :: TyConFlavour                            -- ^ What sort of 'TyCon' this represents.       }+ {- Note [Scoped tyvars in a TcTyCon] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The tcTyConScopedTyVars field records the lexicial-binding connection@@ -979,7 +1018,8 @@    * required_tvs the same as tyConTyVars    * tyConArity = length required_tvs -See also Note [How TcTyCons work] in GHC.Tc.TyCl+tcTyConScopedTyVars are used only for MonoTcTyCons, not PolyTcTyCons.+See Note [TcTyCon, MonoTcTyCon, and PolyTcTyCon] in GHC.Tc.Utils.TcType.  Note [Promoted GADT data constructors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -991,6 +1031,86 @@ will include CoVars.  That is why we use [TyConTyCoBinder] for the tyconBinders field.  TyConTyCoBinder is a synonym for TyConBinder, but with the clue that the binder can be a CoVar not just a TyVar.++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@@ -1013,8 +1133,21 @@                           -- 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?+        is_enum :: Bool,  -- ^ Cached value: is this an enumeration type?                           --   See Note [Enumeration types]+        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@@ -1051,35 +1184,46 @@                         -- See Note [Newtype eta]         nt_co :: CoAxiom Unbranched,                              -- The axiom coercion that creates the @newtype@-                             -- from the representation 'Type'.+                             -- 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_lev_poly :: Bool-                        -- 'True' if the newtype can be levity polymorphic when-                        -- fully applied to its arguments, 'False' otherwise.-                        -- This can only ever be 'True' with UnliftedNewtypes.+        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.                         ---                        -- Invariant: nt_lev_poly nt = isTypeLevPoly (nt_rhs nt)+                        -- Example:                         ---                        -- This is cached to make it cheaper to check if a-                        -- variable binding is levity polymorphic, as used by-                        -- isTcLevPoly.+                        -- > 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.     }  mkSumTyConRhs :: [DataCon] -> AlgTyConRhs mkSumTyConRhs data_cons = SumTyCon data_cons (length data_cons) -mkDataTyConRhs :: [DataCon] -> AlgTyConRhs-mkDataTyConRhs 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+                      -> [DataCon]+                      -> AlgTyConRhs+mkLevPolyDataTyConRhs fixed_lev cons   = DataTyCon {         data_cons = cons,         data_cons_size = length cons,-        is_enum = not (null cons) && all is_enum_con cons+        is_enum = not (null cons) && all is_enum_con cons,                   -- See Note [Enumeration types] in GHC.Core.TyCon+        data_fixed_lev = fixed_lev     }   where     is_enum_con con@@ -1087,6 +1231,12 @@            <- 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.+mkDataTyConRhs :: [DataCon] -> AlgTyConRhs+mkDataTyConRhs = mkLevPolyDataTyConRhs 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@@ -1113,20 +1263,20 @@ visibleDataCons (TupleTyCon{ data_con = c })  = [c] visibleDataCons (SumTyCon{ data_cons = cs })  = cs --- ^ Both type classes as well as family instances imply implicit--- type constructors.  These implicit type constructors refer to their parent--- structure (ie, the class or family from which they derive) using a type of--- the following form.+-- | 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 type constructor has no parent.+  = -- | 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 type constructor. The TyConRepName is a Maybe since we-    -- currently don't allow unboxed sums to be Typeable since there are too-    -- many of them. See #13276.-  | UnboxedAlgTyCon-       (Maybe TyConRepName)+    -- | 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.Core.TyCo.Rep"@@ -1169,11 +1319,11 @@         -- gives a representation tycon:         --      data R:TList a = ...         --      axiom co a :: T [a] ~ R:TList a-        -- with R:TList's algTcParent = DataFamInstTyCon T [a] co+        -- with R:TList's algTcFlavour = DataFamInstTyCon T [a] co  instance Outputable AlgTyConFlav where     ppr (VanillaAlgTyCon {})        = text "Vanilla ADT"-    ppr (UnboxedAlgTyCon {})        = text "Unboxed 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)@@ -1182,7 +1332,7 @@ -- name, if any okParent :: Name -> AlgTyConFlav -> Bool okParent _       (VanillaAlgTyCon {})            = True-okParent _       (UnboxedAlgTyCon {})            = True+okParent _       (UnboxedSumTyCon {})            = True okParent tc_name (ClassTyCon cls _)              = tc_name == tyConName (classTyCon cls) okParent _       (DataFamInstTyCon _ fam_tc tys) = tys `lengthAtLeast` tyConArity fam_tc @@ -1310,17 +1460,22 @@ ~~~~~~~~~~~~~~~~~~ Consider         newtype Parser a = MkParser (IO a) deriving Monad-Are these two types equal (that is, does a coercion exist between them)?+Are these two types equal? That is, does a coercion exist between them?         Monad Parser         Monad IO-which we need to make the derived instance for Monad Parser.+(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.  This eta reduction is done when the type-constructor is built, and cached in NewTyCon.+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 -Here's an example that I think showed up in practice+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)@@ -1332,14 +1487,15 @@         w2 = MkFoo (\(MkT x) -> case w1 of MkFoo f -> f x)  After desugaring, and discarding the data constructors for the newtypes,-we get:-        w2 = w1 `cast` Foo CoT-so the coercion tycon CoT must have-        kind:    T ~ []- and    arity:   0+we would like to get:+        w2 = w1 `cast` Foo axT -This eta-reduction is implemented in GHC.Tc.TyCl.Build.mkNewTyConRhs.+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.  ************************************************************************ *                                                                      *@@ -1355,12 +1511,13 @@ tyConRepName_maybe :: TyCon -> Maybe TyConRepName tyConRepName_maybe (FunTyCon   { tcRepName = rep_nm })   = Just rep_nm-tyConRepName_maybe (PrimTyCon  { primRepName = mb_rep_nm })-  = mb_rep_nm-tyConRepName_maybe (AlgTyCon { algTcParent = parent })-  | VanillaAlgTyCon rep_nm <- parent = Just rep_nm-  | ClassTyCon _ rep_nm    <- parent = Just rep_nm-  | UnboxedAlgTyCon rep_nm <- parent = rep_nm+tyConRepName_maybe (PrimTyCon  { primRepName = rep_nm })+  = Just rep_nm+tyConRepName_maybe (AlgTyCon { algTcFlavour = parent }) = case parent of+  VanillaAlgTyCon rep_nm -> Just rep_nm+  UnboxedSumTyCon        -> Nothing+  ClassTyCon _ rep_nm    -> Just rep_nm+  DataFamInstTyCon {}    -> Nothing tyConRepName_maybe (FamilyTyCon { famTcFlav = DataFamilyTyCon rep_nm })   = Just rep_nm tyConRepName_maybe (PromotedDataCon { dataCon = dc, tcRepName = rep_nm })@@ -1560,7 +1717,7 @@ 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.+-- 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) &&@@ -1673,7 +1830,7 @@ -}  -- | Given the name of the function type constructor and it's kind, create the--- corresponding 'TyCon'. It is recommended to use 'GHC.Core.TyCo.Rep.funTyCon' if you want+-- corresponding 'TyCon'. It is recommended to use 'GHC.Builtin.Types.funTyCon' if you want -- this functionality mkFunTyCon :: Name -> [TyConBinder] -> Name -> TyCon mkFunTyCon name binders rep_nm@@ -1685,7 +1842,7 @@               tyConResKind = liftedTypeKind,               tyConKind    = mkTyConKind binders liftedTypeKind,               tyConArity   = length binders,-              tyConNullaryTy = mkTyConTy_ tc,+              tyConNullaryTy = mkNakedTyConTy tc,               tcRepName    = rep_nm           }     in tc@@ -1712,14 +1869,14 @@               tyConResKind     = res_kind,               tyConKind        = mkTyConKind binders res_kind,               tyConArity       = length binders,-              tyConNullaryTy   = mkTyConTy_ tc,+              tyConNullaryTy   = mkNakedTyConTy tc,               tyConTyVars      = binderVars binders,               tcRoles          = roles,               tyConCType       = cType,               algTcStupidTheta = stupid,               algTcRhs         = rhs,               algTcFields      = fieldsOfAlgTcRhs rhs,-              algTcParent      = ASSERT2( okParent name parent, ppr name $$ ppr parent ) parent,+              algTcFlavour     = assertPpr (okParent name parent) (ppr name $$ ppr parent) parent,               algTcGadtSyntax  = gadt_syn           }     in tc@@ -1751,7 +1908,7 @@               tyConResKind     = res_kind,               tyConKind        = mkTyConKind binders res_kind,               tyConArity       = arity,-              tyConNullaryTy   = mkTyConTy_ tc,+              tyConNullaryTy   = mkNakedTyConTy tc,               tcRoles          = replicate arity Representational,               tyConCType       = Nothing,               algTcGadtSyntax  = False,@@ -1759,7 +1916,7 @@               algTcRhs         = TupleTyCon { data_con = con,                                               tup_sort = sort },               algTcFields      = emptyDFsEnv,-              algTcParent      = parent+              algTcFlavour     = parent           }     in tc @@ -1781,14 +1938,14 @@               tyConResKind     = res_kind,               tyConKind        = mkTyConKind binders res_kind,               tyConArity       = arity,-              tyConNullaryTy   = mkTyConTy_ tc,+              tyConNullaryTy   = mkNakedTyConTy tc,               tcRoles          = replicate arity Representational,               tyConCType       = Nothing,               algTcGadtSyntax  = False,               algTcStupidTheta = [],               algTcRhs         = mkSumTyConRhs cons,               algTcFields      = emptyDFsEnv,-              algTcParent      = parent+              algTcFlavour     = parent           }     in tc @@ -1816,7 +1973,7 @@                   , tyConResKind = res_kind                   , tyConKind    = mkTyConKind binders res_kind                   , tyConArity   = length binders-                  , tyConNullaryTy = mkTyConTy_ tc+                  , tyConNullaryTy = mkNakedTyConTy tc                   , tcTyConScopedTyVars = scoped_tvs                   , tcTyConIsPoly       = poly                   , tcTyConFlavour      = flav }@@ -1826,37 +1983,17 @@ noTcTyConScopedTyVars :: [(Name, TcTyVar)] noTcTyConScopedTyVars = [] --- | Create an unlifted primitive 'TyCon', such as @Int#@.+-- | 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, never levity-polymorphic-            -> [Role] -> TyCon+            -> 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-  = mkPrimTyCon' name binders res_kind roles True (Just $ mkPrelTyConRepName name)---- | Kind constructors-mkKindTyCon :: Name -> [TyConBinder]-            -> Kind  -- ^ /result/ kind-            -> [Role] -> Name -> TyCon-mkKindTyCon name binders res_kind roles rep_nm-  = tc-  where-    tc = mkPrimTyCon' name binders res_kind roles False (Just rep_nm)---- | Create a lifted primitive 'TyCon' such as @RealWorld@-mkLiftedPrimTyCon :: Name -> [TyConBinder]-                  -> Kind   -- ^ /result/ kind-                  -> [Role] -> TyCon-mkLiftedPrimTyCon name binders res_kind roles-  = mkPrimTyCon' name binders res_kind roles False (Just rep_nm)-  where rep_nm = mkPrelTyConRepName name--mkPrimTyCon' :: Name -> [TyConBinder]-             -> Kind    -- ^ /result/ kind, never levity-polymorphic-                        -- (If you need a levity-polymorphic PrimTyCon, change-                        --  isTcLevPoly.)-             -> [Role]-             -> Bool -> Maybe TyConRepName -> TyCon-mkPrimTyCon' name binders res_kind roles is_unlifted rep_nm   = let tc =           PrimTyCon {               tyConName    = name,@@ -1865,10 +2002,9 @@               tyConResKind = res_kind,               tyConKind    = mkTyConKind binders res_kind,               tyConArity   = length roles,-              tyConNullaryTy = mkTyConTy_ tc,+              tyConNullaryTy = mkNakedTyConTy tc,               tcRoles      = roles,-              isUnlifted   = is_unlifted,-              primRepName  = rep_nm+              primRepName  = mkPrelTyConRepName name           }     in tc @@ -1884,7 +2020,7 @@               tyConResKind   = res_kind,               tyConKind      = mkTyConKind binders res_kind,               tyConArity     = length binders,-              tyConNullaryTy = mkTyConTy_ tc,+              tyConNullaryTy = mkNakedTyConTy tc,               tyConTyVars    = binderVars binders,               tcRoles        = roles,               synTcRhs       = rhs,@@ -1907,7 +2043,7 @@             , tyConResKind = res_kind             , tyConKind    = mkTyConKind binders res_kind             , tyConArity   = length binders-            , tyConNullaryTy = mkTyConTy_ tc+            , tyConNullaryTy = mkNakedTyConTy tc             , tyConTyVars  = binderVars binders             , famTcResVar  = resVar             , famTcFlav    = flav@@ -1930,7 +2066,7 @@             tyConUnique   = nameUnique name,             tyConName     = name,             tyConArity    = length roles,-            tyConNullaryTy = mkTyConTy_ tc,+            tyConNullaryTy = mkNakedTyConTy tc,             tcRoles       = roles,             tyConBinders  = binders,             tyConResKind  = res_kind,@@ -1947,7 +2083,7 @@  -- | Test if the 'TyCon' is algebraic but abstract (invisible data constructors) isAbstractTyCon :: TyCon -> Bool-isAbstractTyCon (AlgTyCon { algTcRhs = AbstractTyCon }) = True+isAbstractTyCon (AlgTyCon { algTcRhs = AbstractTyCon {} }) = True isAbstractTyCon _ = False  -- | Does this 'TyCon' represent something that cannot be defined in Haskell?@@ -1955,19 +2091,6 @@ isPrimTyCon (PrimTyCon {}) = True isPrimTyCon _              = False --- | Is this 'TyCon' unlifted (i.e. cannot contain bottom)? Note that this can--- only be true for primitive and unboxed-tuple 'TyCon's-isUnliftedTyCon :: TyCon -> Bool-isUnliftedTyCon (PrimTyCon  {isUnlifted = is_unlifted})-  = is_unlifted-isUnliftedTyCon (AlgTyCon { algTcRhs = rhs } )-  | TupleTyCon { tup_sort = sort } <- rhs-  = not (isBoxed (tupleSortBoxity sort))-isUnliftedTyCon (AlgTyCon { algTcRhs = rhs } )-  | SumTyCon {} <- rhs-  = True-isUnliftedTyCon _ = False- -- | Returns @True@ if the supplied 'TyCon' resulted from either a -- @data@ or @newtype@ declaration isAlgTyCon :: TyCon -> Bool@@ -1977,7 +2100,7 @@ -- | Returns @True@ for vanilla AlgTyCons -- that is, those created -- with a @data@ or @newtype@ declaration. isVanillaAlgTyCon :: TyCon -> Bool-isVanillaAlgTyCon (AlgTyCon { algTcParent = VanillaAlgTyCon _ }) = True+isVanillaAlgTyCon (AlgTyCon { algTcFlavour = VanillaAlgTyCon _ }) = True isVanillaAlgTyCon _                                              = False  -- | Returns @True@ for the 'TyCon' of the 'Constraint' kind.@@ -2323,33 +2446,73 @@ -- 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 Invariant] in GHC.Tc.Gen.HsType+-- See Note [The Purely Kinded Type Invariant (PKTI)] in GHC.Tc.Gen.HsType setTcTyConKind tc@(TcTyCon {}) kind = let tc' = tc { tyConKind = kind-                                                   , tyConNullaryTy = mkTyConTy_ tc'+                                                   , tyConNullaryTy = mkNakedTyConTy tc'                                                        -- see Note [Sharing nullary TyCons]                                                    }                                       in tc' setTcTyConKind tc              _    = pprPanic "setTcTyConKind" (ppr tc) --- | Could this TyCon ever be levity-polymorphic when fully applied?--- True is safe. False means we're sure. Does only a quick check--- based on the TyCon's category.--- Precondition: The fully-applied TyCon has kind (TYPE blah)-isTcLevPoly :: TyCon -> Bool-isTcLevPoly FunTyCon{}           = False-isTcLevPoly (AlgTyCon { algTcParent = parent, algTcRhs = rhs })-  | UnboxedAlgTyCon _ <- parent-  = True-  | NewTyCon { nt_lev_poly = lev_poly } <- rhs-  = lev_poly -- Newtypes can be levity polymorphic with UnliftedNewtypes (#17360)-  | otherwise-  = False-isTcLevPoly SynonymTyCon{}       = True-isTcLevPoly FamilyTyCon{}        = True-isTcLevPoly PrimTyCon{}          = False-isTcLevPoly TcTyCon{}            = False-isTcLevPoly tc@PromotedDataCon{} = pprPanic "isTcLevPoly datacon" (ppr tc)+-- | 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 FunTyCon{}           = True+tcHasFixedRuntimeRep (AlgTyCon { algTcRhs = rhs }) = 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)++  SumTyCon {} -> False   -- only unboxed sums here++  NewTyCon { nt_fixed_rep = fixed_rep } -> fixed_rep+         -- A newtype might not have a fixed runtime representation+         -- with UnliftedNewtypes (#17360)++tcHasFixedRuntimeRep SynonymTyCon{}       = False   -- conservative choice+tcHasFixedRuntimeRep FamilyTyCon{}        = False+tcHasFixedRuntimeRep PrimTyCon{}          = True+tcHasFixedRuntimeRep TcTyCon{}            = False+tcHasFixedRuntimeRep tc@PromotedDataCon{} = pprPanic "tcHasFixedRuntimeRep datacon" (ppr tc)++-- | Is this 'TyCon' concrete (i.e. not a synonym/type family)?+--+-- Used for representation polymorphism checks.+isConcreteTyCon :: TyCon -> Bool+isConcreteTyCon = isConcreteTyConFlavour . tyConFlavour++-- | Is this 'TyConFlavour' concrete (i.e. not a synonym/type family)?+--+-- Used for representation polymorphism checks.+isConcreteTyConFlavour :: TyConFlavour -> Bool+isConcreteTyConFlavour = \case+  ClassFlavour             -> True+  TupleFlavour {}          -> True+  SumFlavour               -> True+  DataTypeFlavour          -> True+  NewtypeFlavour           -> True+  AbstractTypeFlavour      -> True  -- See Note [Concrete types] in GHC.Tc.Utils.Concrete+  DataFamilyFlavour {}     -> False+  OpenTypeFamilyFlavour {} -> False+  ClosedTypeFamilyFlavour  -> False+  TypeSynonymFlavour       -> False+  BuiltInTypeFlavour       -> True+  PromotedDataConFlavour   -> True+ {- ----------------------------------------------- --      Expand type-constructor applications@@ -2389,7 +2552,7 @@ -- exported tycon can have a pattern synonym bundled with it, e.g., -- module Foo (TyCon(.., PatSyn)) where isTyConWithSrcDataCons :: TyCon -> Bool-isTyConWithSrcDataCons (AlgTyCon { algTcRhs = rhs, algTcParent = parent }) =+isTyConWithSrcDataCons (AlgTyCon { algTcRhs = rhs, algTcFlavour = parent }) =   case rhs of     DataTyCon {}  -> isSrcParent     NewTyCon {}   -> isSrcParent@@ -2537,7 +2700,7 @@  -- | 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 ...@+-- @data Eq a => T a ...@. See @Note [The stupid context]@ in "GHC.Core.DataCon". tyConStupidTheta :: TyCon -> [PredType] tyConStupidTheta (AlgTyCon {algTcStupidTheta = stupid}) = stupid tyConStupidTheta (FunTyCon {}) = []@@ -2564,36 +2727,36 @@  -- | Is this 'TyCon' that for a class instance? isClassTyCon :: TyCon -> Bool-isClassTyCon (AlgTyCon {algTcParent = ClassTyCon {}}) = True+isClassTyCon (AlgTyCon {algTcFlavour = ClassTyCon {}}) = True isClassTyCon _                                        = 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 (AlgTyCon {algTcParent = ClassTyCon clas _}) = Just clas+tyConClass_maybe (AlgTyCon {algTcFlavour = ClassTyCon clas _}) = Just clas tyConClass_maybe _                                            = Nothing  -- | Return the associated types of the 'TyCon', if any tyConATs :: TyCon -> [TyCon]-tyConATs (AlgTyCon {algTcParent = ClassTyCon clas _}) = classATs clas+tyConATs (AlgTyCon {algTcFlavour = ClassTyCon clas _}) = classATs clas tyConATs _                                            = []  ---------------------------------------------------------------------------- -- | Is this 'TyCon' that for a data family instance? isFamInstTyCon :: TyCon -> Bool-isFamInstTyCon (AlgTyCon {algTcParent = DataFamInstTyCon {} })+isFamInstTyCon (AlgTyCon {algTcFlavour = DataFamInstTyCon {} })   = True isFamInstTyCon _ = False  tyConFamInstSig_maybe :: TyCon -> Maybe (TyCon, [Type], CoAxiom Unbranched)-tyConFamInstSig_maybe (AlgTyCon {algTcParent = DataFamInstTyCon ax f ts })+tyConFamInstSig_maybe (AlgTyCon {algTcFlavour = DataFamInstTyCon ax f ts })   = Just (f, ts, ax) tyConFamInstSig_maybe _ = 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 (AlgTyCon {algTcParent = DataFamInstTyCon _ f ts })+tyConFamInst_maybe (AlgTyCon {algTcFlavour = DataFamInstTyCon _ f ts })   = Just (f, ts) tyConFamInst_maybe _ = Nothing @@ -2601,7 +2764,7 @@ -- represents a coercion identifying the representation type with the type -- instance family.  Otherwise, return @Nothing@ tyConFamilyCoercion_maybe :: TyCon -> Maybe (CoAxiom Unbranched)-tyConFamilyCoercion_maybe (AlgTyCon {algTcParent = DataFamInstTyCon ax _ _ })+tyConFamilyCoercion_maybe (AlgTyCon {algTcFlavour = DataFamInstTyCon ax _ _ })   = Just ax tyConFamilyCoercion_maybe _ = Nothing @@ -2698,7 +2861,7 @@       go PromotedDataConFlavour  = "promoted data constructor"  tyConFlavour :: TyCon -> TyConFlavour-tyConFlavour (AlgTyCon { algTcParent = parent, algTcRhs = rhs })+tyConFlavour (AlgTyCon { algTcFlavour = parent, algTcRhs = rhs })   | ClassTyCon _ _ <- parent = ClassFlavour   | otherwise = case rhs of                   TupleTyCon { tup_sort = sort }@@ -2728,7 +2891,7 @@ tcFlavourMustBeSaturated DataFamilyFlavour{}     = False tcFlavourMustBeSaturated TupleFlavour{}          = False tcFlavourMustBeSaturated SumFlavour              = False-tcFlavourMustBeSaturated AbstractTypeFlavour     = False+tcFlavourMustBeSaturated AbstractTypeFlavour {}  = False tcFlavourMustBeSaturated BuiltInTypeFlavour      = False tcFlavourMustBeSaturated PromotedDataConFlavour  = False tcFlavourMustBeSaturated TypeSynonymFlavour      = True@@ -2745,7 +2908,7 @@ tcFlavourIsOpen NewtypeFlavour          = False tcFlavourIsOpen TupleFlavour{}          = False tcFlavourIsOpen SumFlavour              = False-tcFlavourIsOpen AbstractTypeFlavour     = False+tcFlavourIsOpen AbstractTypeFlavour {}  = False tcFlavourIsOpen BuiltInTypeFlavour      = False tcFlavourIsOpen PromotedDataConFlavour  = False tcFlavourIsOpen TypeSynonymFlavour      = False
GHC/Core/TyCon/Env.hs view
@@ -5,7 +5,7 @@ \section[TyConEnv]{@TyConEnv@: tyCon environments} -} -{-# LANGUAGE CPP #-}+ {-# LANGUAGE ScopedTypeVariables #-}  @@ -16,7 +16,7 @@         -- ** Manipulating these environments         mkTyConEnv, mkTyConEnvWith,         emptyTyConEnv, isEmptyTyConEnv,-        unitTyConEnv, nameEnvElts,+        unitTyConEnv, nonDetTyConEnvElts,         extendTyConEnv_C, extendTyConEnv_Acc, extendTyConEnv,         extendTyConEnvList, extendTyConEnvList_C,         filterTyConEnv, anyTyConEnv,@@ -33,8 +33,6 @@         adjustDTyConEnv, alterDTyConEnv, extendDTyConEnv, foldDTyConEnv     ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Types.Unique.FM@@ -58,7 +56,7 @@ isEmptyTyConEnv     :: TyConEnv a -> Bool mkTyConEnv          :: [(TyCon,a)] -> TyConEnv a mkTyConEnvWith      :: (a -> TyCon) -> [a] -> TyConEnv a-nameEnvElts        :: TyConEnv a -> [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@@ -80,7 +78,7 @@ mapTyConEnv         :: (elt1 -> elt2) -> TyConEnv elt1 -> TyConEnv elt2 disjointTyConEnv    :: TyConEnv a -> TyConEnv a -> Bool -nameEnvElts x         = eltsUFM x+nonDetTyConEnvElts x   = nonDetEltsUFM x emptyTyConEnv          = emptyUFM isEmptyTyConEnv        = isNullUFM unitTyConEnv x y       = unitUFM x y
GHC/Core/TyCon/RecWalk.hs view
@@ -6,8 +6,8 @@  -} -{-# LANGUAGE CPP #-} + module GHC.Core.TyCon.RecWalk (          -- * Recursion breaking@@ -15,8 +15,6 @@         setRecTcMaxBound, checkRecTc      ) where--#include "HsVersions.h"  import GHC.Prelude
GHC/Core/TyCon/Set.hs view
@@ -4,8 +4,8 @@  -} -{-# LANGUAGE CPP #-} + module GHC.Core.TyCon.Set (         -- * TyCons set type         TyConSet,@@ -17,8 +17,6 @@         intersectsTyConSet, disjointTyConSet, intersectTyConSet,         nameSetAny, nameSetAll     ) where--#include "HsVersions.h"  import GHC.Prelude
GHC/Core/Type.hs view
@@ -3,7 +3,7 @@ -- -- Type - public interface -{-# LANGUAGE CPP, FlexibleContexts, PatternSynonyms, ViewPatterns, MultiWayIf #-}+{-# LANGUAGE FlexibleContexts, PatternSynonyms, ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -17,7 +17,7 @@         -- $representation_types         Type, ArgFlag(..), AnonArgFlag(..),         Specificity(..),-        KindOrType, PredType, ThetaType,+        KindOrType, PredType, ThetaType, FRRType,         Var, TyVar, isTyVar, TyCoVar, TyCoBinder, TyCoVarBinder, TyVarBinder,         Mult, Scaled,         KnotTied,@@ -36,7 +36,7 @@         splitFunTy, splitFunTy_maybe,         splitFunTys, funResultTy, funArgTy, -        mkTyConApp, mkTyConTy, tYPE,+        mkTyConApp, mkTyConTy, mkTYPEapp,         tyConAppTyCon_maybe, tyConAppTyConPicky_maybe,         tyConAppArgs_maybe, tyConAppTyCon, tyConAppArgs,         splitTyConApp_maybe, splitTyConApp, tyConAppArgN,@@ -55,6 +55,7 @@         splitForAllTyCoVar_maybe, splitForAllTyCoVar,         splitForAllTyVar_maybe, splitForAllCoVar_maybe,         splitPiTy_maybe, splitPiTy, splitPiTys,+        getRuntimeArgTys,         mkTyConBindersPreferAnon,         mkPiTy, mkPiTys,         piResultTy, piResultTys,@@ -86,7 +87,7 @@          -- ** Analyzing types         TyCoMapper(..), mapTyCo, mapTyCoX,-        TyCoFolder(..), foldTyCo,+        TyCoFolder(..), foldTyCo, noView,          -- (Newtypes)         newTyConInstRhs,@@ -120,17 +121,20 @@         tyConAppNeedsKindSig,          -- *** Levity and boxity-        isLiftedType_maybe,+        typeLevity_maybe,         isLiftedTypeKind, isUnliftedTypeKind, isBoxedTypeKind, pickyIsLiftedTypeKind,-        isLiftedRuntimeRep, isUnliftedRuntimeRep, isBoxedRuntimeRep,+        isLiftedRuntimeRep, isUnliftedRuntimeRep, runtimeRepLevity_maybe,+        isBoxedRuntimeRep,         isLiftedLevity, isUnliftedLevity,-        isUnliftedType, isBoxedType, mightBeUnliftedType, isUnboxedTupleType, isUnboxedSumType,+        isUnliftedType, isBoxedType, isUnboxedTupleType, isUnboxedSumType,+        mightBeLiftedType, mightBeUnliftedType,+        isStateType,         isAlgType, isDataFamilyAppType,         isPrimitiveType, isStrictType,         isLevityTy, isLevityVar,         isRuntimeRepTy, isRuntimeRepVar, isRuntimeRepKindedTy,         dropRuntimeRepArgs,-        getRuntimeRep,+        getRuntimeRep, getLevity, getLevity_maybe,          -- * Multiplicity @@ -145,7 +149,7 @@         Kind,          -- ** Finding the kind of a type-        typeKind, tcTypeKind, isTypeLevPoly, resultIsLevPoly,+        typeKind, tcTypeKind, typeHasFixedRuntimeRep, resultHasFixedRuntimeRep,         tcIsLiftedTypeKind, tcIsConstraintKind, tcReturnsConstraintKind,         tcIsBoxedTypeKind, tcIsRuntimeTypeKind, @@ -222,22 +226,18 @@         -- * Tidying type related things up for printing         tidyType,      tidyTypes,         tidyOpenType,  tidyOpenTypes,-        tidyOpenKind,         tidyVarBndr, tidyVarBndrs, tidyFreeTyCoVars,         tidyOpenTyCoVar, tidyOpenTyCoVars,         tidyTyCoVarOcc,         tidyTopType,-        tidyKind,         tidyTyCoVarBinder, tidyTyCoVarBinders,          -- * Kinds         isConstraintKindCon,         classifiesTypeWithValues,-        isKindLevPoly+        isConcrete, isFixedRuntimeRepKind,     ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Types.Basic@@ -261,8 +261,9 @@ import {-# SOURCE #-} GHC.Builtin.Types                                  ( charTy, naturalTy, listTyCon                                  , typeSymbolKind, liftedTypeKind, unliftedTypeKind-                                 , liftedRepTyCon, unliftedRepTyCon-                                 , constraintKind+                                 , liftedRepTy, unliftedRepTy, zeroBitRepTy+                                 , boxedRepDataConTyCon+                                 , constraintKind, zeroBitTypeKind                                  , unrestrictedFunTyCon                                  , manyDataConTy, oneDataConTy ) import GHC.Types.Name( Name )@@ -276,13 +277,17 @@    , mkKindCo, mkSubCo    , decomposePiCos, coercionKind, coercionLKind    , coercionRKind, coercionType-   , isReflexiveCo, seqCo )+   , 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.Utils.Panic.Plain import GHC.Data.FastString import GHC.Data.Pair import GHC.Data.List.SetOps@@ -291,6 +296,7 @@ import GHC.Data.Maybe   ( orElse, expectJust ) import Data.Maybe       ( isJust ) import Control.Monad    ( guard )+-- import GHC.Utils.Trace  -- $type_classification -- #type_classification#@@ -321,6 +327,8 @@ -- -- [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. --@@ -373,21 +381,35 @@  See also #11715, which tracks removing this inconsistency. -The inconsistency actually leads to a potential soundness bug, in that-Constraint and Type are considered *apart* by the type family engine.-To wit, we can write+In order to prevent users from discerning between Type and Constraint+(which could create inconsistent axioms -- see #21092), we say that+Type and Constraint are not SurelyApart in the pure unifier. See+GHC.Core.Unify.unify_ty, where this case produces MaybeApart. -  type family F a-  type instance F Type = Bool-  type instance F Constraint = Int+One annoying consequence of this inconsistency is that we can get ill-kinded+updates to metavariables. #20356 is a case in point. Simplifying somewhat,+we end up with+  [W] (alpha :: Constraint)  ~  (Int :: Type)+This is heterogeneous, so we produce+  [W] co :: (Constraint ~ Type)+and transform our original wanted to become+  [W] alpha ~ Int |> sym co+in accordance with Note [Equalities with incompatible kinds] in GHC.Tc.Solver.Canonical.+Our transformed wanted is now homogeneous (both sides have kind Constraint)+and so we unify alpha := Int |> sym co. -and (because Type ~# Constraint in Core), thus build a coercion between-Int and Bool. I (Richard E) conjecture that this never happens in practice,-but it's very uncomfortable. This, essentially, is the root problem-underneath #11715, which is quite resistant to an easy fix. The best-idea is to have roles in kind coercions, but that has yet to be implemented.-See also "A Role for Dependent Types in Haskell", ICFP 2019, which describes-how roles in kinds might work out.+However, it's not so easy: when we build the cast (Int |> sym co), we actually+just get Int back. This is because we forbid reflexive casts (invariant (EQ2) of+Note [Respecting definitional equality] in GHC.Core.TyCo.Rep), and co looks+reflexive: it relates Type and Constraint, even though these are considered+identical in Core. Above, when we tried to say alpha := Int |> sym co, we+really ended up doing alpha := Int -- even though alpha :: Constraint and+Int :: Type have different kinds. Nothing has really gone wrong, though:+we still emitted [W] co :: (Constraint ~ Type), which will be insoluble+and lead to a decent error message. We simply need not to fall over at the+moment of unification, because all will be OK in the end. We thus use the+Core eqType, not the Haskell tcEqType, in the kind check for a meta-tyvar+unification in GHC.Tc.Utils.TcMType.writeMetaTyVarRef.  -} @@ -409,6 +431,8 @@ -- Returns 'Nothing' if there is nothing to look through. -- This function considers 'Constraint' to be a synonym of @Type@. --+-- 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 ty@(TyConApp tc tys)@@ -418,7 +442,7 @@   -- At the Core level, Constraint = Type   -- See Note [coreView vs tcView]   | isConstraintKindCon tc-  = ASSERT2( null tys, ppr ty )+  = assertPpr (null tys) (ppr ty) $     Just liftedTypeKind  coreView _ = Nothing@@ -431,39 +455,59 @@ -- instantiated at arguments @tys@, or returns 'Nothing' if @tc@ is not a -- synonym. expandSynTyConApp_maybe :: TyCon -> [Type] -> Maybe Type-expandSynTyConApp_maybe tc tys+{-# INLINE expandSynTyConApp_maybe #-}+-- This INLINE will inline the call to expandSynTyConApp_maybe in coreView,+-- which will eliminate the allocat ion Just/Nothing in the result+-- Don't be tempted to make `expand_syn` (which is NOINLIN) return the+-- Just/Nothing, else you'll increase allocation+expandSynTyConApp_maybe tc arg_tys   | Just (tvs, rhs) <- synTyConDefn_maybe tc-  , tys `lengthAtLeast` arity-  = Just (expand_syn arity tvs rhs tys)+  , arg_tys `lengthAtLeast` (tyConArity tc)+  = Just (expand_syn tvs rhs arg_tys)   | otherwise   = Nothing-  where-    arity = tyConArity tc--- Without this INLINE the call to expandSynTyConApp_maybe in coreView--- will result in an avoidable allocation.-{-# INLINE expandSynTyConApp_maybe #-}  -- | A helper for 'expandSynTyConApp_maybe' to avoid inlining this cold path -- into call-sites.-expand_syn :: Int      -- ^ the arity of the synonym-           -> [TyVar]  -- ^ the variables bound by the synonym+--+-- 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-expand_syn arity tvs rhs tys-  | tys `lengthExceeds` arity = mkAppTys rhs' (drop arity tys)-  | otherwise                 = rhs'+{-# 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-    rhs' = substTy (mkTvSubstPrs (tvs `zip` tys)) rhs-               -- The free vars of 'rhs' should all be bound by 'tenv', so it's-               -- ok to use 'substTy' here (which is what expandSynTyConApp_maybe does).-               -- See also Note [The substitution invariant] in GHC.Core.TyCo.Subst.-               -- Its important to use mkAppTys, rather than (foldl AppTy),-               -- because the function part might well return a-               -- partially-applied type constructor; indeed, usually will!--- We never want to inline this cold-path.-{-# INLINE expand_syn #-}+    empty_subst = mkEmptyTCvSubst 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+++ coreFullView :: Type -> Type -- ^ Iterates 'coreView' until there is no more to synonym to expand. -- See Note [Inlining coreView].@@ -622,7 +666,7 @@  -- | Returns True if the kind classifies types which are allocated on -- the GC'd heap and False otherwise. Note that this returns False for--- levity-polymorphic kinds, which may be specialized to a kind that+-- representation-polymorphic kinds, which may be specialized to a kind that -- classifies AddrRep or even unboxed kinds. isBoxedTypeKind :: Kind -> Bool isBoxedTypeKind kind@@ -663,8 +707,8 @@   | otherwise                          = False  -- | Returns True if the kind classifies unlifted types (like 'Int#') and False--- otherwise. Note that this returns False for levity-polymorphic kinds, which--- may be specialized to a kind that classifies unlifted types.+-- 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@@ -686,42 +730,59 @@   | otherwise   = Nothing -isLiftedRuntimeRep :: Type -> Bool--- isLiftedRuntimeRep is true of LiftedRep :: RuntimeRep--- False of type variables (a :: RuntimeRep)---   and of other reps e.g. (IntRep :: RuntimeRep)-isLiftedRuntimeRep rep-  | Just [lev] <- isTyConKeyApp_maybe boxedRepDataConKey rep-  = isLiftedLevity lev-  | otherwise-  = False--isUnliftedRuntimeRep :: Type -> Bool--- PRECONDITION: The type has kind RuntimeRep--- True of definitely-unlifted RuntimeReps--- False of           (LiftedRep :: RuntimeRep)---   and of variables (a :: RuntimeRep)-isUnliftedRuntimeRep rep-  | TyConApp rr_tc args <- coreFullView rep -- NB: args might be non-empty-                                            --     e.g. TupleRep [r1, .., rn]+-- | Check whether a type of kind 'RuntimeRep' is lifted, unlifted, or unknown.+--+-- @isLiftedRuntimeRep 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 :: Type -> Maybe Levity+runtimeRepLevity_maybe rep+  | TyConApp rr_tc args <- coreFullView rep   , isPromotedDataCon rr_tc =       -- NB: args might be non-empty e.g. TupleRep [r1, .., rn]       if (rr_tc `hasKey` boxedRepDataConKey)         then case args of-          [lev] -> isUnliftedLevity lev-          _     -> False-        else True+          [lev] | isLiftedLevity   lev -> Just Lifted+                | isUnliftedLevity lev -> Just Unlifted+          _                            -> Nothing+        else Just Unlifted         -- Avoid searching all the unlifted RuntimeRep type cons         -- In the RuntimeRep data type, only LiftedRep is lifted         -- But be careful of type families (F tys) :: RuntimeRep,         -- hence the isPromotedDataCon rr_tc-isUnliftedRuntimeRep _ = False+runtimeRepLevity_maybe _ = Nothing --- | An INLINE helper for function such as 'isLiftedRuntimeRep' below.+-- | 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 :: Type -> 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 :: Type -> 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+  = assert (null args) True   | otherwise   = False {-# INLINE isNullaryTyConKeyApp #-}@@ -1103,7 +1164,7 @@         in         (TyConApp tc tc_args1, tc_args2 ++ args)     split _   (FunTy _ w ty1 ty2) args-      = ASSERT( null args )+      = assert (null args )         (TyConApp funTyCon [], [w, rep1, rep2, ty1, ty2])       where         rep1 = getRuntimeRep ty1@@ -1123,7 +1184,7 @@         in         (TyConApp tc tc_args1, tc_args2 ++ args)     split (FunTy _ w ty1 ty2) args-      = ASSERT( null args )+      = assert (null args )         (TyConApp funTyCon [], [w, rep1, rep2, ty1, ty2])       where         rep1 = getRuntimeRep ty1@@ -1367,13 +1428,13 @@ -- applyTyxX beta-reduces (/\tvs. body_ty) arg_tys -- Assumes that (/\tvs. body_ty) is closed applyTysX tvs body_ty arg_tys-  = ASSERT2( arg_tys `lengthAtLeast` n_tvs, pp_stuff )-    ASSERT2( tyCoVarsOfType body_ty `subVarSet` mkVarSet tvs, pp_stuff )-    mkAppTys (substTyWith tvs (take n_tvs arg_tys) body_ty)-             (drop n_tvs 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]-    n_tvs = length tvs+    (arg_tys_prefix, arg_tys_rest) = splitAtList tvs arg_tys   @@ -1428,7 +1489,7 @@   FunTy {}      -> Just funTyCon   _             -> Nothing -tyConAppTyCon :: Type -> TyCon+tyConAppTyCon :: HasDebugCallStack => Type -> TyCon tyConAppTyCon ty = tyConAppTyCon_maybe ty `orElse` pprPanic "tyConAppTyCon" (ppr ty)  -- | The same as @snd . splitTyConApp@@@ -1441,7 +1502,7 @@     -> Just [w, rep1, rep2, arg, res]   _ -> Nothing -tyConAppArgs :: Type -> [Type]+tyConAppArgs :: HasCallStack => Type -> [Type] tyConAppArgs ty = tyConAppArgs_maybe ty `orElse` pprPanic "tyConAppArgs" (ppr ty)  tyConAppArgN :: Int -> Type -> Type@@ -1524,7 +1585,7 @@ -- arguments, using an eta-reduced version of the @newtype@ if possible. -- This requires tys to have at least @newTyConInstArity tycon@ elements. newTyConInstRhs tycon tys-    = ASSERT2( tvs `leLength` tys, ppr tycon $$ ppr tys $$ ppr tvs )+    = assertPpr (tvs `leLength` tys) (ppr tycon $$ ppr tys $$ ppr tvs) $       applyTysX tvs rhs tys   where     (tvs, rhs) = newTyConEtadRhs tycon@@ -1543,34 +1604,65 @@  -- | 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"+-- See @Note [Respecting definitional equality]@ in "GHC.Core.TyCo.Rep" mkCastTy :: Type -> Coercion -> Type-mkCastTy ty co | isReflexiveCo co = ty  -- (EQ2) from the Note+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 -mkCastTy (CastTy ty co1) co2-  -- (EQ3) from the Note-  = mkCastTy ty (co1 `mkTransCo` co2)-      -- call mkCastTy again for the reflexivity check+-- | 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' -mkCastTy (ForAllTy (Bndr tv vis) inner_ty) co-  -- (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 = mkEmptyTCvSubst (mkInScopeSet fvs)-             (subst, tv') = substVarBndr empty_subst tv-         in ForAllTy (Bndr tv' vis) (substTy subst inner_ty `mkCastTy` co)-    else ForAllTy (Bndr tv vis) (inner_ty `mkCastTy` co)+    go (CastTy ty co1)+      -- (EQ3) from the Note+      = mkCastTy ty (co1 `mkTransCo` co)+          -- call mkCastTy again for the reflexivity check -mkCastTy ty co = CastTy ty co+    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 = mkEmptyTCvSubst (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`.+-}+ tyConBindersTyCoBinders :: [TyConBinder] -> [TyCoBinder] -- Return the tyConBinders in TyCoBinder form tyConBindersTyCoBinders = map to_tyb@@ -1578,55 +1670,137 @@     to_tyb (Bndr tv (NamedTCB vis)) = Named (Bndr tv vis)     to_tyb (Bndr tv (AnonTCB af))   = Anon af (tymult (varType tv)) --- | Create the plain type constructor type which has been applied to no type arguments at all.+-- | (mkTyConTy tc) returns (TyConApp tc [])+-- but arranges to share that TyConApp among all calls+-- See Note [Sharing nullary TyConApps] in GHC.Core.TyCon mkTyConTy :: TyCon -> Type mkTyConTy tycon = tyConNullaryTy tycon-  -- see Note [Sharing nullary TyConApps] in GHC.Core.TyCon  -- | 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 tys-  | null tys-  = mkTyConTy tycon+mkTyConApp tycon []+  = -- See Note [Sharing nullary TyConApps] in GHC.Core.TyCon+    mkTyConTy tycon -  | isFunTyCon tycon-  , [w, _rep1,_rep2,ty1,ty2] <- tys-  -- The FunTyCon (->) is always a visible one-  = FunTy { ft_af = VisArg, ft_mult = w, ft_arg = ty1, ft_res = ty2 }+mkTyConApp tycon tys@(ty1:rest)+  | key == funTyConKey+  = case tys of+      [w, _rep1,_rep2,arg,res] -> FunTy { ft_af = VisArg, ft_mult = w+                                        , ft_arg = arg, ft_res = res }+      _ -> bale_out -  -- See Note [Prefer Type over TYPE 'LiftedRep].-  | tycon `hasKey` tYPETyConKey-  , [rep] <- tys-  = tYPE rep+  -- See Note [Using synonyms to compress types]+  | key == tYPETyConKey+  = assert (null rest) $+--    mkTYPEapp_maybe ty1 `orElse` bale_out+    case mkTYPEapp_maybe ty1 of+      Just ty -> ty -- pprTrace "mkTYPEapp:yes" (ppr ty) ty+      Nothing -> bale_out -- pprTrace "mkTYPEapp:no" (ppr bale_out) bale_out++  -- See Note [Using synonyms to compress types]+  | key == boxedRepDataConTyConKey+  = assert (null rest) $+--     mkBoxedRepApp_maybe ty1 `orElse` bale_out+    case mkBoxedRepApp_maybe ty1 of+      Just ty -> ty -- pprTrace "mkBoxedRepApp:yes" (ppr ty) ty+      Nothing -> bale_out -- pprTrace "mkBoxedRepApp:no" (ppr bale_out) bale_out++  | key == tupleRepDataConTyConKey+  = case mkTupleRepApp_maybe ty1 of+      Just ty -> ty -- pprTrace "mkTupleRepApp:yes" (ppr ty) ty+      Nothing -> bale_out -- pprTrace "mkTupleRepApp:no" (ppr bale_out) bale_out+   -- The catch-all case   | otherwise-  = TyConApp tycon tys+  = bale_out+  where+    key = tyConUnique tycon+    bale_out = TyConApp tycon tys -{--Note [Prefer Type over TYPE 'LiftedRep]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The Core of nearly any program will have numerous occurrences of-@TYPE 'LiftedRep@ (and, equivalently, 'Type') floating about. Concretely, while-investigating #17292 we found that these constituting a majority of TyConApp-constructors on the heap:+mkTYPEapp :: Type -> Type+mkTYPEapp rr+  = case mkTYPEapp_maybe rr of+       Just ty -> ty+       Nothing -> TyConApp tYPETyCon [rr] -```-(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 ...`-```+mkTYPEapp_maybe :: Type -> 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 RuntimeRep] 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 +mkBoxedRepApp_maybe :: Type -> 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 RuntimeRep] 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 RuntimeRep] 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++{- 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+ 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 @@ -1636,43 +1810,53 @@ applications (e.g. things like @TyConApp typeTyCon []@), Note [Comparing nullary type synonyms] in "GHC.Core.Type". -To accomplish these we use a number of tricks:+To accomplish these we use a number of tricks, implemented by mkTyConApp. - 1. Instead of representing the lifted kind as-    @TyConApp tYPETyCon [liftedRepDataCon]@ we rather prefer to-    use the 'GHC.Types.Type' type synonym (represented as a nullary TyConApp).-    This serves goal (b) since there are no applied type arguments to traverse,-    e.g., during comparison.+ 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. We have a 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)).+ 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 - 3. We use the sharing mechanism described in Note [Sharing nullary TyConApps]+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.--}+See #17958, #20541 +Note [Care using synonyms to compress types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Using a synonym to compress a types has a tricky wrinkle. Consider+coreView applied to (TyConApp LiftedRep []) --- | Given a @RuntimeRep@, applies @TYPE@ to it.--- See Note [TYPE and RuntimeRep] in GHC.Builtin.Types.Prim.-tYPE :: Type -> Type-tYPE rr@(TyConApp tc [arg])-  -- See Note [Prefer Type of TYPE 'LiftedRep]-  | tc `hasKey` boxedRepDataConKey-  , TyConApp tc' [] <- arg-  = if | tc' `hasKey` liftedDataConKey   -> liftedTypeKind   -- TYPE (BoxedRep 'Lifted)-       | tc' `hasKey` unliftedDataConKey -> unliftedTypeKind -- TYPE (BoxedRep 'Unlifted)-       | otherwise                       -> TyConApp tYPETyCon [rr]-  | tc == liftedRepTyCon                               -- TYPE LiftedRep-  = liftedTypeKind-  | tc == unliftedRepTyCon                             -- TYPE UnliftedRep-  = unliftedTypeKind-tYPE rr = TyConApp tYPETyCon [rr]+* 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.+-}+++ {- --------------------------------------------------------------------                             CoercionTy@@ -1732,7 +1916,7 @@  -- | Like 'mkTyCoInvForAllTy', but tv should be a tyvar mkInfForAllTy :: TyVar -> Type -> Type-mkInfForAllTy tv ty = ASSERT( isTyVar tv )+mkInfForAllTy tv ty = assert (isTyVar tv )                       ForAllTy (Bndr tv Inferred) ty  -- | Like 'mkForAllTys', but assumes all variables are dependent and@@ -1747,7 +1931,7 @@ -- | Like 'mkForAllTy', but assumes the variable is dependent and 'Specified', -- a common case mkSpecForAllTy :: TyVar -> Type -> Type-mkSpecForAllTy tv ty = ASSERT( isTyVar tv )+mkSpecForAllTy tv ty = assert (isTyVar tv )                        -- covar is always Inferred, so input should be tyvar                        ForAllTy (Bndr tv Specified) ty @@ -1758,7 +1942,7 @@  -- | Like mkForAllTys, but assumes all variables are dependent and visible mkVisForAllTys :: [TyVar] -> Type -> Type-mkVisForAllTys tvs = ASSERT( all isTyVar tvs )+mkVisForAllTys tvs = assert (all isTyVar tvs )                      -- covar is always Inferred, so all inputs should be tyvar                      mkForAllTys [ Bndr tv Required | tv <- tvs ] @@ -1772,7 +1956,7 @@ mkTyConBindersPreferAnon :: [TyVar]      -- ^ binders                          -> TyCoVarSet   -- ^ free variables of result                          -> [TyConBinder]-mkTyConBindersPreferAnon vars inner_tkvs = ASSERT( all isTyVar vars)+mkTyConBindersPreferAnon vars inner_tkvs = assert (all isTyVar vars)                                            fst (go vars)   where     go :: [TyVar] -> ([TyConBinder], VarSet) -- also returns the free vars@@ -1939,6 +2123,46 @@     split orig_ty ty bs | Just ty' <- coreView ty = split orig_ty ty' bs     split orig_ty _                bs = (reverse bs, orig_ty) +-- | 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, VisArg), (Bool, VisArg)]+--    getRuntimeArgTys (Identity Int -> Bool -> Double) == [(Identity Int, VisArg), (Bool, VisArg)]+--    getRuntimeArgTys (Int -> Identity (Bool -> Identity Double)) == [(Int, VisArg), (Bool, VisArg)]+--    getRuntimeArgTys (forall a. Show a => Identity a -> a -> Int -> Bool) == [(Show a, InvisArg), (Identity a, VisArg),(a, VisArg),(Int, VisArg)]+-- @+--+-- 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, VisArg)+-- @+getRuntimeArgTys :: Type -> [(Type, AnonArgFlag)]+getRuntimeArgTys = go+  where+    go :: Type -> [(Type, AnonArgFlag)]+    go (ForAllTy _ res)+      = go res+    go (FunTy { ft_arg = arg, ft_res = res, ft_af = af })+      = (arg, af) : go res+    go ty+      | Just ty' <- coreView ty+      = go ty'+      | Just (_,ty') <- topNormaliseNewType_maybe ty+      = go ty'+      | otherwise+      = []+ -- | Like 'splitPiTys' but split off only /named/ binders --   and returns 'TyCoVarBinder's rather than 'TyCoBinder's splitForAllTyCoVarBinders :: Type -> ([TyCoVarBinder], Type)@@ -2137,7 +2361,7 @@  tyBinderType :: TyBinder -> Type tyBinderType (Named (Bndr tv _))-  = ASSERT( isTyVar tv )+  = assert (isTyVar tv )     tyVarKind tv tyBinderType (Anon _ ty)   = scaledThing ty @@ -2167,7 +2391,7 @@ mkFamilyTyConApp tc tys   | Just (fam_tc, fam_tys) <- tyConFamInst_maybe tc   , let tvs = tyConTyVars tc-        fam_subst = ASSERT2( tvs `equalLength` tys, ppr tc <+> ppr tys )+        fam_subst = assertPpr (tvs `equalLength` tys) (ppr tc <+> ppr tys) $                     zipTvSubst tvs tys   = mkTyConApp fam_tc (substTys fam_subst fam_tys)   | otherwise@@ -2224,44 +2448,60 @@ ************************************************************************ -} --- | Returns Just True if this type is surely lifted, Just False--- if it is surely unlifted, Nothing if we can't be sure (i.e., it is--- levity polymorphic), and panics if the kind does not have the shape--- TYPE r.-isLiftedType_maybe :: HasDebugCallStack => Type -> Maybe Bool-isLiftedType_maybe ty = case coreFullView (getRuntimeRep ty) of-  ty' | isLiftedRuntimeRep ty'  -> Just True-  TyConApp {}                   -> Just False  -- Everything else is unlifted-  _                             -> Nothing     -- levity polymorphic+-- | 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) --- | See "Type#type_classification" for what an unlifted type is.--- Panics on levity polymorphic types; See 'mightBeUnliftedType' for+-- | 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--- levity polymorphism.+-- 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.         -- They are pretty bogus types, mind you.  It would be better never to         -- construct them-isUnliftedType ty-  = not (isLiftedType_maybe ty `orElse`-         pprPanic "isUnliftedType" (ppr ty <+> dcolon <+> ppr (typeKind ty)))+isUnliftedType ty =+  case typeLevity_maybe ty of+    Just Lifted   -> False+    Just Unlifted -> True+    Nothing       ->+      pprPanic "isUnliftedType" (ppr ty <+> dcolon <+> ppr (typeKind ty)) +-- | State token type.+isStateType :: Type -> Bool+isStateType ty+  = case tyConAppTyCon_maybe ty of+        Just tycon -> tycon == statePrimTyCon+        _          -> False+ -- | 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++-- | Returns:+-- -- * 'False' if the type is /guaranteed/ lifted or--- * 'True' if it is unlifted, OR we aren't sure (e.g. in a levity-polymorphic case)+-- * 'True' if it is unlifted, OR we aren't sure+--    (e.g. in a representation-polymorphic case) mightBeUnliftedType :: Type -> Bool-mightBeUnliftedType ty-  = case isLiftedType_maybe ty of-      Just is_lifted -> not is_lifted-      Nothing -> True+mightBeUnliftedType = mightBeUnlifted . typeLevity_maybe  -- | See "Type#type_classification" for what a boxed type is.--- Panics on levity polymorphic types; See 'mightBeUnliftedType' for+-- Panics on representation-polymorphic types; See 'mightBeUnliftedType' for -- a more approximate predicate that behaves better in the presence of--- levity polymorphism.+-- representation polymorphism. isBoxedType :: Type -> Bool isBoxedType ty = isBoxedRuntimeRep (getRuntimeRep ty) @@ -2279,7 +2519,7 @@ dropRuntimeRepArgs = dropWhile isRuntimeRepKindedTy  -- | Extract the RuntimeRep classifier of a type. For instance,--- @getRuntimeRep_maybe Int = LiftedRep@. Returns 'Nothing' if this is not+-- @getRuntimeRep_maybe Int = Just LiftedRep@. Returns 'Nothing' if this is not -- possible. getRuntimeRep_maybe :: HasDebugCallStack                     => Type -> Maybe Type@@ -2293,6 +2533,30 @@       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+  , Just (tc, [lev]) <- splitTyConApp_maybe rep+  , tc == boxedRepDataConTyCon+  = 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@@ -2310,7 +2574,7 @@ isAlgType :: Type -> Bool isAlgType ty   = case splitTyConApp_maybe ty of-      Just (tc, ty_args) -> ASSERT( ty_args `lengthIs` tyConArity tc )+      Just (tc, ty_args) -> assert (ty_args `lengthIs` tyConArity tc )                             isAlgTyCon tc       _other             -> False @@ -2322,14 +2586,15 @@  -- | 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 levity-polymorphic types.+-- Currently, it's just 'isUnliftedType'.+-- Panics on representation-polymorphic types. isStrictType :: HasDebugCallStack => Type -> Bool isStrictType = isUnliftedType  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 )+                        Just (tc, ty_args) -> assert (ty_args `lengthIs` tyConArity tc )                                               isPrimTyCon tc                         _                  -> False @@ -2469,14 +2734,14 @@  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 [Prefer Type over TYPE 'LiftedRep] in-GHC.Core.TyCo.Rep for details.+whenever possible. See Note [Using synonyms to compress types] in+GHC.Core.Type for details.  -}  eqType :: Type -> Type -> Bool--- ^ Type equality on source types. Does not look through @newtypes@ or--- 'PredType's, but it does look through type synonyms.+-- ^ Type equality on source types. Does not look through @newtypes@,+-- 'PredType's or type families, but it does look through type synonyms. -- This first checks that the kinds of the types are equal and then -- checks whether the types are equal, ignoring casts and coercions. -- (The kind check is a recursive call, but since all kinds have type@@ -2666,7 +2931,7 @@ -- See Note [nonDetCmpType nondeterminism] nonDetCmpTc :: TyCon -> TyCon -> Ordering nonDetCmpTc tc1 tc2-  = ASSERT( not (isConstraintKindCon tc1) && not (isConstraintKindCon tc2) )+  = assert (not (isConstraintKindCon tc1) && not (isConstraintKindCon tc2)) $     u1 `nonDetCmpUnique` u2   where     u1  = tyConUnique tc1@@ -2855,7 +3120,7 @@ tcIsConstraintKind ty   | Just (tc, args) <- tcSplitTyConApp_maybe ty    -- Note: tcSplit here   , isConstraintKindCon tc-  = ASSERT2( null args, ppr ty ) True+  = assertPpr (null args) (ppr ty) True    | otherwise   = False@@ -2912,30 +3177,32 @@ typeLiteralKind (StrTyLit {}) = typeSymbolKind typeLiteralKind (CharTyLit {}) = charTy --- | Returns True if a type is levity polymorphic. Should be the same--- as (isKindLevPoly . typeKind) but much faster.--- Precondition: The type has kind (TYPE blah)-isTypeLevPoly :: Type -> Bool-isTypeLevPoly = go+-- | 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 :: Type -> Bool+typeHasFixedRuntimeRep = go   where-    go ty@(TyVarTy {})                           = check_kind ty-    go ty@(AppTy {})                             = check_kind ty-    go ty@(TyConApp tc _) | not (isTcLevPoly tc) = False-                          | otherwise            = check_kind ty-    go (ForAllTy _ ty)                           = go ty-    go (FunTy {})                                = False-    go (LitTy {})                                = False-    go ty@(CastTy {})                            = check_kind ty-    go ty@(CoercionTy {})                        = pprPanic "isTypeLevPoly co" (ppr ty)--    check_kind = isKindLevPoly . typeKind---- | Looking past all pi-types, is the end result potentially levity polymorphic?--- Example: True for (forall r (a :: TYPE r). String -> a)--- Example: False for (forall r1 r2 (a :: TYPE r1) (b :: TYPE r2). a -> b -> Type)-resultIsLevPoly :: Type -> Bool-resultIsLevPoly = isTypeLevPoly . snd . splitPiTys+    go (TyConApp tc _)+      | tcHasFixedRuntimeRep tc = True+    go (FunTy {})               = True+    go (LitTy {})               = True+    go (ForAllTy _ ty)          = go ty+    go ty                       = isFixedRuntimeRepKind (typeKind ty) +-- | Looking past all pi-types, does the end result have a+-- fixed runtime rep, as per Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete?+--+-- Examples:+--+--   * False for @(forall r (a :: TYPE r). String -> a)@+--   * True for @(forall r1 r2 (a :: TYPE r1) (b :: TYPE r2). a -> b -> Type)@+resultHasFixedRuntimeRep :: Type -> Bool+resultHasFixedRuntimeRep = typeHasFixedRuntimeRep . snd . splitPiTys  {- ********************************************************************** *                                                                       *@@ -3274,36 +3541,43 @@ during type inference. -} --- | Tests whether the given kind (which should look like @TYPE x@)--- is something other than a constructor tree (that is, constructors at every node).--- E.g.  True of   TYPE k, TYPE (F Int)---       False of  TYPE 'LiftedRep-isKindLevPoly :: Kind -> Bool-isKindLevPoly k = ASSERT2( isLiftedTypeKind k || _is_type, ppr k )-                    -- the isLiftedTypeKind check is necessary b/c of Constraint-                  go k+-- | Checks that a kind of the form 'Type', 'Constraint'+-- or @'TYPE r@ is concrete. See 'isConcrete'.+--+-- __Precondition:__ The type has kind @('TYPE' blah)@.+isFixedRuntimeRepKind :: HasDebugCallStack => Kind -> Bool+isFixedRuntimeRepKind k+  = assertPpr (isLiftedTypeKind k || _is_type) (ppr k) $+    -- the isLiftedTypeKind check is necessary b/c of Constraint+    isConcrete k   where-    go ty | Just ty' <- coreView ty = go ty'-    go TyVarTy{}         = True-    go AppTy{}           = True  -- it can't be a TyConApp-    go (TyConApp tc tys) = isFamilyTyCon tc || any go tys-    go ForAllTy{}        = True-    go (FunTy _ w t1 t2) = go w || go t1 || go t2-    go LitTy{}           = False-    go CastTy{}          = True-    go CoercionTy{}      = True-     _is_type = classifiesTypeWithValues k ---------------------------------------------              Subkinding--- The tc variants are used during type-checking, where ConstraintKind--- is distinct from all other kinds--- After type-checking (in core), Constraint and liftedTypeKind are--- indistinguishable+-- | 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.+isConcrete :: Type -> Bool+isConcrete = go+  where+    go ty | Just ty' <- coreView ty = go ty'+    go (TyVarTy tv)        = isConcreteTyVar tv+    go (AppTy ty1 ty2)     = go ty1 && go ty2+    go (TyConApp tc tys)+      | isConcreteTyCon tc = all go tys+      | otherwise          = False+    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 +----------------------------------------- -- | Does this classify a type allowed to have values? Responds True to things--- like *, #, TYPE Lifted, TYPE v, Constraint.+-- like *, TYPE Lifted, TYPE IntRep, TYPE v, Constraint. classifiesTypeWithValues :: Kind -> Bool -- ^ True of any sub-kind of OpenTypeKind classifiesTypeWithValues k = isJust (kindRep_maybe k)@@ -3362,22 +3636,10 @@         _              -> emptyFV      source_of_injectivity Required  = True-    -- See Note [Explicit Case Statement for Specificity]-    source_of_injectivity (Invisible spec) = case spec of-      SpecifiedSpec -> spec_inj_pos-      InferredSpec  -> False+    source_of_injectivity Specified = spec_inj_pos+    source_of_injectivity Inferred  = False  {--Note [Explicit Case Statement for Specificity]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When pattern matching against an `ArgFlag`, you should not pattern match against-the pattern synonyms 'Specified' or 'Inferred', as this results in a-non-exhaustive pattern match warning.-Instead, pattern match against 'Invisible spec' and do another case analysis on-this specificity argument.-The issue has been fixed in GHC 8.10 (ticket #17876). This hack can thus be-dropped once version 8.10 is used as the minimum version for building GHC.- 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
GHC/Core/Type.hs-boot view
@@ -19,11 +19,14 @@ coreView :: Type -> Maybe Type tcView :: Type -> Maybe Type isRuntimeRepTy :: Type -> Bool+isLevityTy :: Type -> Bool isMultiplicityTy :: Type -> Bool isLiftedTypeKind :: Type -> Bool-tYPE :: Type -> Type+mkTYPEapp :: Type -> Type  splitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type]) tyConAppTyCon_maybe :: Type -> Maybe TyCon++getLevity :: HasDebugCallStack => Type -> Type  partitionInvisibleTypes :: TyCon -> [Type] -> ([Type], [Type])
GHC/Core/Unfold.hs view
@@ -15,10 +15,8 @@ find, unsurprisingly, a Core expression. -} -{-# LANGUAGE CPP #-}-{-# LANGUAGE BangPatterns #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}+{-# LANGUAGE BangPatterns #-}  module GHC.Core.Unfold (         Unfolding, UnfoldingGuidance,   -- Abstract types@@ -26,32 +24,30 @@         UnfoldingOpts (..), defaultUnfoldingOpts,         updateCreationThreshold, updateUseThreshold,         updateFunAppDiscount, updateDictDiscount,-        updateVeryAggressive, updateCaseScaling, updateCaseThreshold,+        updateVeryAggressive, updateCaseScaling,+        updateCaseThreshold, updateReportPrefix,          ArgSummary(..),          couldBeSmallEnoughToInline, inlineBoringOk,-        certainlyWillInline, smallEnoughToInline,+        smallEnoughToInline,          callSiteInline, CallCtxt(..),         calcUnfoldingGuidance     ) where -#include "HsVersions.h"- import GHC.Prelude -import GHC.Driver.Session-import GHC.Driver.Ppr+import GHC.Driver.Flags+ import GHC.Core import GHC.Core.Utils import GHC.Types.Id-import GHC.Types.Demand ( isDeadEndSig ) import GHC.Core.DataCon import GHC.Types.Literal import GHC.Builtin.PrimOps import GHC.Types.Id.Info-import GHC.Types.Basic  ( Arity, InlineSpec(..), inlinePragmaSpec )+import GHC.Types.Basic  ( Arity ) import GHC.Core.Type import GHC.Builtin.Names import GHC.Builtin.Types.Prim ( realWorldStatePrimTy )@@ -84,11 +80,14 @@    , unfoldingVeryAggressive :: !Bool       -- ^ Force inlining in many more cases -      -- Don't consider depth up to x    , unfoldingCaseThreshold :: !Int+      -- ^ Don't consider depth up to x -      -- Penalize depth with 1/x    , unfoldingCaseScaling :: !Int+      -- ^ Penalize depth with 1/x++   , unfoldingReportPrefix :: !(Maybe String)+      -- ^ Only report inlining decisions for names with this prefix    }  defaultUnfoldingOpts :: UnfoldingOpts@@ -120,6 +119,9 @@        -- Penalize depth with (size*depth)/scaling    , unfoldingCaseScaling = 30++      -- Don't filter inlining decision reports+   , unfoldingReportPrefix = Nothing    }  -- Helpers for "GHC.Driver.Session"@@ -146,6 +148,9 @@ updateCaseScaling :: Int -> UnfoldingOpts -> UnfoldingOpts updateCaseScaling n opts = opts { unfoldingCaseScaling = n } +updateReportPrefix :: Maybe String -> UnfoldingOpts -> UnfoldingOpts+updateReportPrefix n opts = opts { unfoldingReportPrefix = n }+ {- Note [Occurrence analysis of unfoldings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -242,13 +247,9 @@         -> UnfNever   -- See Note [Do not inline top-level bottoming functions]          | otherwise-        ->--          -- If you don't force this then we retain all the Ids-          let !discounts = strictMap (mk_discount cased_bndrs) val_bndrs-          in UnfIfGoodArgs { ug_args  = discounts-                           , ug_size  = size-                           , ug_res   = scrut_discount }+        -> UnfIfGoodArgs { ug_args  = map (mk_discount cased_bndrs) val_bndrs+                         , ug_size  = size+                         , ug_res   = scrut_discount }    where     (bndrs, body) = collectBinders expr@@ -521,7 +522,9 @@                  -- unboxed variables, inline primops and unsafe foreign calls                 -- are all "inline" things:-          is_inline_scrut (Var v) = isUnliftedType (idType v)+          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@@ -580,6 +583,7 @@       |  isTyVar bndr                 -- Doesn't exist at runtime       || isJoinId bndr                -- Not allocated at all       || isUnliftedType (idType bndr) -- Doesn't live in heap+           -- OK to call isUnliftedType: binders have a fixed RuntimeRep (search for FRRBinder)       = 0       | otherwise       = 10@@ -617,8 +621,7 @@ -- | Finds a nominal size of a string literal. litSize :: Literal -> Int -- Used by GHC.Core.Unfold.sizeExpr-litSize (LitNumber LitNumInteger _) = 100   -- Note [Size of literal integers]-litSize (LitNumber LitNumNatural _) = 100+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@@ -950,95 +953,15 @@  ---------------- smallEnoughToInline :: UnfoldingOpts -> Unfolding -> Bool-smallEnoughToInline opts (CoreUnfolding {uf_guidance = UnfIfGoodArgs {ug_size = size}})-  = size <= unfoldingUseThreshold opts+smallEnoughToInline opts (CoreUnfolding {uf_guidance = guidance})+  = case guidance of+       UnfIfGoodArgs {ug_size = size} -> size <= unfoldingUseThreshold opts+       UnfWhen {} -> True+       UnfNever   -> False smallEnoughToInline _ _   = False -------------------certainlyWillInline :: UnfoldingOpts -> IdInfo -> Maybe Unfolding--- ^ Sees if the unfolding is pretty certain to inline.--- If so, return a *stable* unfolding for it, that will always inline.-certainlyWillInline opts fn_info-  = case fn_unf of-      CoreUnfolding { uf_tmpl = expr, uf_guidance = guidance, uf_src = src }-        | loop_breaker -> Nothing       -- Won't inline, so try w/w-        | noinline     -> Nothing       -- See Note [Worker-wrapper for NOINLINE functions]-        | otherwise-        -> case guidance of-             UnfNever  -> Nothing-             UnfWhen {} -> Just (fn_unf { uf_src = src' })-                             -- INLINE functions have UnfWhen-             UnfIfGoodArgs { ug_size = size, ug_args = args }-               -> do_cunf expr size args src'-        where-          src' = case src of-                   InlineRhs -> InlineStable-                   _         -> src  -- Do not change InlineCompulsory!--      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-    loop_breaker = isStrongLoopBreaker (occInfo fn_info)-    noinline     = inlinePragmaSpec (inlinePragInfo fn_info) == NoInline-    fn_unf       = unfoldingInfo fn_info--        -- 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 expr size args src'-      | arityInfo fn_info > 0  -- See Note [certainlyWillInline: be careful of thunks]-      , not (isDeadEndSig (strictnessInfo 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_guidance = UnfWhen { ug_arity     = unf_arity-                                             , ug_unsat_ok  = unSaturatedOk-                                             , ug_boring_ok = inlineBoringOk expr } })-             -- 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]-+{- ************************************************************************ *                                                                      * \subsection{callSiteInline}@@ -1062,16 +985,6 @@ StrictAnal.addStrictnessInfoToTopId -} -callSiteInline :: Logger-               -> DynFlags-               -> Int                   -- Case depth-               -> Id                    -- The Id-               -> Bool                  -- True <=> unfolding is active-               -> 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- data ArgSummary = TrivArg       -- Nothing interesting                 | NonTrivArg    -- Arg has structure                 | ValueArg      -- Arg is a con-app or PAP@@ -1107,7 +1020,16 @@   ppr DiscArgCtxt = text "DiscArgCtxt"   ppr RuleArgCtxt = text "RuleArgCtxt" -callSiteInline logger dflags !case_depth id active_unfolding lone_variable arg_infos cont_info+callSiteInline :: Logger+               -> UnfoldingOpts+               -> Int                   -- Case depth+               -> Id                    -- The Id+               -> Bool                  -- True <=> unfolding is active+               -> 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 logger opts !case_depth id active_unfolding 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*@@ -1115,28 +1037,28 @@         CoreUnfolding { uf_tmpl = unf_template                       , uf_is_work_free = is_wf                       , uf_guidance = guidance, uf_expandable = is_exp }-          | active_unfolding -> tryUnfolding logger dflags case_depth id lone_variable+          | active_unfolding -> tryUnfolding logger opts case_depth id lone_variable                                     arg_infos cont_info unf_template                                     is_wf is_exp guidance-          | otherwise -> traceInline logger dflags id "Inactive unfolding:" (ppr id) Nothing+          | otherwise -> traceInline logger opts id "Inactive unfolding:" (ppr id) Nothing         NoUnfolding      -> Nothing         BootUnfolding    -> Nothing         OtherCon {}      -> Nothing         DFunUnfolding {} -> Nothing     -- Never unfold a DFun  -- | Report the inlining of an identifier's RHS to the user, if requested.-traceInline :: Logger -> DynFlags -> Id -> String -> SDoc -> a -> a-traceInline logger dflags inline_id str doc result+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    = putTraceMsg logger dflags str doc result+  | enable    = logTraceMsg logger str doc result   | otherwise = result   where     enable-      | dopt Opt_D_dump_inlinings dflags && dopt Opt_D_verbose_core2core dflags+      | logHasDumpFlag logger Opt_D_dump_verbose_inlinings       = True-      | Just prefix <- inlineCheck dflags+      | Just prefix <- unfoldingReportPrefix opts       = prefix `isPrefixOf` occNameString (getOccName inline_id)       | otherwise       = False@@ -1238,48 +1160,47 @@  -} -tryUnfolding :: Logger -> DynFlags -> Int -> Id -> Bool -> [ArgSummary] -> CallCtxt+tryUnfolding :: Logger -> UnfoldingOpts -> Int -> Id -> Bool -> [ArgSummary] -> CallCtxt              -> CoreExpr -> Bool -> Bool -> UnfoldingGuidance              -> Maybe CoreExpr-tryUnfolding logger dflags !case_depth id lone_variable+tryUnfolding logger opts !case_depth id lone_variable              arg_infos cont_info unf_template              is_wf is_exp guidance  = case guidance of-     UnfNever -> traceInline logger dflags id str (text "UnfNever") Nothing+     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 uf_opts)+        | enough_args && (boring_ok || some_benefit || unfoldingVeryAggressive opts)                 -- See Note [INLINE for small functions (3)]-        -> traceInline logger dflags id str (mk_doc some_benefit empty True) (Just unf_template)+        -> traceInline logger opts id str (mk_doc some_benefit empty True) (Just unf_template)         | otherwise-        -> traceInline logger dflags id str (mk_doc some_benefit empty False) Nothing+        -> traceInline logger opts id str (mk_doc some_benefit empty False) Nothing         where           some_benefit = calc_some_benefit uf_arity           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 }-        | unfoldingVeryAggressive uf_opts-        -> traceInline logger dflags id str (mk_doc some_benefit extra_doc True) (Just unf_template)+        | unfoldingVeryAggressive opts+        -> traceInline logger opts id str (mk_doc some_benefit extra_doc True) (Just unf_template)         | is_wf && some_benefit && small_enough-        -> traceInline logger dflags id str (mk_doc some_benefit extra_doc True) (Just unf_template)+        -> traceInline logger opts id str (mk_doc some_benefit extra_doc True) (Just unf_template)         | otherwise-        -> traceInline logger dflags id str (mk_doc some_benefit extra_doc False) Nothing+        -> traceInline logger opts id str (mk_doc some_benefit extra_doc False) Nothing         where           some_benefit = calc_some_benefit (length arg_discounts)           extra_doc = vcat [ text "case depth =" <+> int case_depth                            , text "depth based penalty =" <+> int depth_penalty                            , text "discounted size =" <+> int adjusted_size ]           -- See Note [Avoid inlining into deeply nested cases]-          depth_treshold = unfoldingCaseThreshold uf_opts-          depth_scaling = unfoldingCaseScaling uf_opts+          depth_treshold = unfoldingCaseThreshold opts+          depth_scaling = unfoldingCaseScaling opts           depth_penalty | case_depth <= depth_treshold = 0                         | otherwise       = (size * (case_depth - depth_treshold)) `div` depth_scaling           adjusted_size = size + depth_penalty - discount-          small_enough = adjusted_size <= unfoldingUseThreshold uf_opts+          small_enough = adjusted_size <= unfoldingUseThreshold opts           discount = computeDiscount arg_discounts res_discount arg_infos cont_info    where-    uf_opts = unfoldingOpts dflags     mk_doc some_benefit extra_doc yes_or_no       = vcat [ text "arg infos" <+> ppr arg_infos              , text "interesting continuation" <+> ppr cont_info@@ -1290,8 +1211,8 @@              , extra_doc              , text "ANSWER =" <+> if yes_or_no then text "YES" else text "NO"] -    ctx = initSDocContext dflags defaultDumpStyle-    str = "Considering inlining: " ++ showSDocDump ctx (ppr id)+    ctx = log_default_dump_context (logFlags logger)+    str = "Considering inlining: " ++ renderWithContext ctx (ppr id)     n_val_args = length arg_infos             -- some_benefit is used when the RHS is small enough@@ -1328,8 +1249,12 @@   {--Note [Unfold into lazy contexts], Note [RHS of lets]+Note [Unfold into lazy contexts] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Merged into Note [RHS of lets].++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.  For example      f y = (y,y,y)
GHC/Core/Unfold/Make.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}  -- | Unfolding creation module GHC.Core.Unfold.Make@@ -11,16 +11,15 @@    , mkInlineUnfolding    , mkInlineUnfoldingWithArity    , mkInlinableUnfolding-   , mkWwInlineRule+   , mkWrapperUnfolding    , mkCompulsoryUnfolding    , mkCompulsoryUnfolding'    , mkDFunUnfolding    , specUnfolding+   , certainlyWillInline    ) where -#include "HsVersions.h"- import GHC.Prelude import GHC.Core import GHC.Core.Unfold@@ -30,7 +29,8 @@ import GHC.Core.Utils import GHC.Types.Basic import GHC.Types.Id-import GHC.Types.Demand ( StrictSig, isDeadEndSig )+import GHC.Types.Id.Info+import GHC.Types.Demand ( DmdSig, isDeadEndSig )  import GHC.Utils.Outputable import GHC.Utils.Misc@@ -41,7 +41,7 @@   -mkFinalUnfolding :: UnfoldingOpts -> UnfoldingSource -> StrictSig -> CoreExpr -> Unfolding+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@@ -80,15 +80,18 @@                   , df_args = map occurAnalyseExpr ops }                   -- See Note [Occurrence analysis of unfoldings] -mkWwInlineRule :: SimpleOpts -> CoreExpr -> Arity -> Unfolding-mkWwInlineRule opts expr arity+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 InlineStable True-                   (simpleOptExpr opts expr)-                   (UnfWhen { ug_arity = arity, ug_unsat_ok = unSaturatedOk-                            , ug_boring_ok = boringCxtNotOk })+                    (simpleOptExpr opts expr)+                    (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+-- 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 })@@ -149,8 +152,8 @@ -- specUnfolding opts spec_bndrs spec_app rule_lhs_args               df@(DFunUnfolding { df_bndrs = old_bndrs, df_con = con, df_args = args })-  = ASSERT2( rule_lhs_args `equalLength` old_bndrs-           , ppr df $$ ppr rule_lhs_args )+  = assertPpr (rule_lhs_args `equalLength` old_bndrs)+              (ppr df $$ ppr rule_lhs_args) $            -- For this ASSERT see Note [DFunUnfoldings] in GHC.Core.Opt.Specialise     mkDFunUnfolding spec_bndrs con (map spec_arg args)       -- For DFunUnfoldings we transform@@ -168,14 +171,14 @@                              , uf_is_top = top_lvl                              , uf_guidance = old_guidance })  | isStableSource src  -- See Note [Specialising unfoldings]- , UnfWhen { ug_arity     = old_arity } <- old_guidance+ , UnfWhen { ug_arity = old_arity } <- old_guidance  = mkCoreUnfolding src top_lvl new_tmpl                    (old_guidance { ug_arity = old_arity - arity_decrease })  where    new_tmpl = simpleOptExpr opts $-              mkLams spec_bndrs    $+              mkLams spec_bndrs  $               spec_app tmpl  -- The beta-redexes created by spec_app-                             -- will besimplified away by simplOptExpr+                             -- will be simplified away by simplOptExpr    arity_decrease = count isValArg rule_lhs_args - count isId spec_bndrs  @@ -229,7 +232,7 @@ 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+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@@ -298,14 +301,157 @@                 -> UnfoldingGuidance -> Unfolding -- Occurrence-analyses the expression before capturing it mkCoreUnfolding src top_lvl expr guidance-  = CoreUnfolding { uf_tmpl         = occurAnalyseExpr expr,+  =++  let is_value = exprIsHNF expr+      is_conlike = exprIsConLike expr+      is_work_free = exprIsWorkFree expr+      is_expandable = exprIsExpandable expr+  in+  -- See #20905 for what is going on here. We are careful to make sure we only+  -- have one copy of an unfolding around at once.+  -- Note [Thoughtful forcing in mkCoreUnfolding]+  CoreUnfolding { uf_tmpl         = is_value `seq`+                                    is_conlike `seq`+                                    is_work_free `seq`+                                    is_expandable `seq`+                                      occurAnalyseExpr expr,                       -- See Note [Occurrence analysis of unfoldings]                     uf_src          = src,                     uf_is_top       = top_lvl,-                    uf_is_value     = exprIsHNF        expr,-                    uf_is_conlike   = exprIsConLike    expr,-                    uf_is_work_free = exprIsWorkFree   expr,-                    uf_expandable   = exprIsExpandable expr,+                    uf_is_value     = is_value,+                    uf_is_conlike   = is_conlike,+                    uf_is_work_free = is_work_free,+                    uf_expandable   = is_expandable,                     uf_guidance     = guidance } +----------------+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' = -- Do not change InlineCompulsory!+                 case src of+                   InlineCompulsory -> InlineCompulsory+                   _                -> InlineStable+          tmpl' = -- Do not overwrite stable unfoldings!+                  case src of+                    InlineRhs -> occurAnalyseExpr rhs'+                    _         -> uf_tmpl fn_unf++      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 particularlly 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 occurence analysis+  (Note [Occurrence analysis of unfoldings])+* 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 occurence 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
@@ -1,9 +1,9 @@ -- (c) The University of Glasgow 2006  {-# LANGUAGE ScopedTypeVariables, PatternSynonyms #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveFunctor, DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-}+ module GHC.Core.Unify (         tcMatchTy, tcMatchTyKi,         tcMatchTys, tcMatchTyKis,@@ -11,8 +11,8 @@         tcMatchTyX_BM, ruleMatchTyKiX,          -- * Rough matching-        RoughMatchTc(..), roughMatchTcs, instanceCantMatch,-        typesCantMatch, isRoughOtherTc,+        RoughMatchTc(..), roughMatchTcs, roughMatchTcsLookup, instanceCantMatch,+        typesCantMatch, isRoughWildcard,          -- Side-effect free unification         tcUnifyTy, tcUnifyTyKi, tcUnifyTys, tcUnifyTyKis,@@ -27,8 +27,6 @@         flattenTys, flattenTysX    ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Types.Var@@ -41,6 +39,7 @@ import GHC.Core.TyCo.Rep import GHC.Core.TyCo.FVs   ( tyCoVarsOfCoList, tyCoFVsOfTypes ) import GHC.Core.TyCo.Subst ( mkTvSubst )+import GHC.Core.RoughMap import GHC.Core.Map.Type import GHC.Utils.FV( FV, fvVarSet, fvVarList ) import GHC.Utils.Misc@@ -49,15 +48,17 @@ import GHC.Types.Unique import GHC.Types.Unique.FM import GHC.Types.Unique.Set+import {-# SOURCE #-} GHC.Tc.Utils.TcType ( tcEqType ) import GHC.Exts( oneShot )-import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Data.FastString -import Data.Data ( Data ) import Data.List ( mapAccumL ) import Control.Monad import qualified Data.Semigroup as S +import GHC.Builtin.Names (constraintKindTyConKey, liftedTypeKindTyConKey)+ {-  Unification is much tricker than you might think.@@ -291,28 +292,12 @@              albeit perhaps only after 'a' is instantiated. -} -data RoughMatchTc-  = 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]-  | OtherTc        -- e.g. type variable at the head-  deriving( Data )--isRoughOtherTc :: RoughMatchTc -> Bool-isRoughOtherTc OtherTc      = True-isRoughOtherTc (KnownTc {}) = False- roughMatchTcs :: [Type] -> [RoughMatchTc]-roughMatchTcs tys = map rough tys-  where-    rough ty-      | Just (ty', _) <- splitCastTy_maybe ty   = rough ty'-      | Just (tc,_)   <- splitTyConApp_maybe ty-      , not (isTypeFamilyTyCon tc)              = ASSERT2( isGenerativeTyCon tc Nominal, ppr tc )-                                                  KnownTc (tyConName tc)-        -- See Note [Rough matching in class and family instances]-      | otherwise                               = OtherTc+roughMatchTcs tys = map typeToRoughMatchTc tys +roughMatchTcsLookup :: [Type] -> [RoughMatchLookupTc]+roughMatchTcsLookup tys = map typeToRoughMatchLookupTc tys+ instanceCantMatch :: [RoughMatchTc] -> [RoughMatchTc] -> Bool -- (instanceCantMatch tcs1 tcs2) returns True if tcs1 cannot -- possibly be instantiated to actual, nor vice versa;@@ -321,7 +306,7 @@ instanceCantMatch _         _         =  False  -- Safe  itemCantMatch :: RoughMatchTc -> RoughMatchTc -> Bool-itemCantMatch (KnownTc t) (KnownTc a) = t /= a+itemCantMatch (RM_KnownTc t) (RM_KnownTc a) = t /= a itemCantMatch _           _           = False  @@ -414,8 +399,8 @@ when it should. See test case indexed-types/should_fail/Overlap15 for an example. -Note [Unificiation result]-~~~~~~~~~~~~~~~~~~~~~~~~~~+Note [Unification result]+~~~~~~~~~~~~~~~~~~~~~~~~~ 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.@@ -539,7 +524,7 @@ -- return the final result. See Note [Fine-grained unification] type UnifyResult = UnifyResultM TCvSubst --- | See Note [Unificiation result]+-- | 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@@ -548,19 +533,25 @@                     | SurelyApart                     deriving Functor --- | Why are two types 'MaybeApart'? 'MARTypeFamily' takes precedence:+-- | 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+                                             -- See Note [coreView vs tcView] in GHC.Core.Type  instance Outputable MaybeApartReason where-  ppr MARTypeFamily = text "MARTypeFamily"-  ppr MARInfinite   = text "MARInfinite"+  ppr MARTypeFamily       = text "MARTypeFamily"+  ppr MARInfinite         = text "MARInfinite"+  ppr MARTypeVsConstraint = text "MARTypeVsConstraint"  instance Semigroup MaybeApartReason where   -- see end of Note [Unification result] for why-  MARTypeFamily <> r = r-  MARInfinite   <> _ = MARInfinite+  MARTypeFamily       <> r = r+  MARInfinite         <> _ = MARInfinite+  MARTypeVsConstraint <> r = r  instance Applicative UnifyResultM where   pure  = Unifiable@@ -1069,13 +1060,22 @@ -- See Note [Specification of unification] -- Respects newtypes, PredTypes -- See Note [Computing equality on types] in GHC.Core.Type-unify_ty env ty1 ty2 kco+unify_ty _env (TyConApp tc1 []) (TyConApp tc2 []) _kco   -- See Note [Comparing nullary type synonyms] in GHC.Core.Type.-  | TyConApp tc1 [] <- ty1-  , TyConApp tc2 [] <- ty2-  , tc1 == tc2                = return ()+  | tc1 == tc2+  = return () -    -- TODO: More commentary needed here+  -- See Note [coreView vs tcView] in GHC.Core.Type.+  | tc1 `hasKey` constraintKindTyConKey+  , tc2 `hasKey` liftedTypeKindTyConKey+  = maybeApart MARTypeVsConstraint++  | tc2 `hasKey` constraintKindTyConKey+  , tc1 `hasKey` liftedTypeKindTyConKey+  = maybeApart MARTypeVsConstraint++unify_ty env ty1 ty2 kco+    -- Now handle the cases we can "look through": synonyms and casts.   | Just ty1' <- tcView ty1   = unify_ty env ty1' ty2 kco   | Just ty2' <- tcView ty2   = unify_ty env ty1 ty2' kco   | CastTy ty1' co <- ty1     = if um_unif env@@ -1114,11 +1114,20 @@             ; unless (um_inj_tf env) $ -- See (end of) Note [Specification of unification]               don'tBeSoSure MARTypeFamily $ unify_tys env noninj_tys1 noninj_tys2 } -  | isTyFamApp mb_tc_app1     -- A (not-over-saturated) type-family application-  = maybeApart MARTypeFamily  -- behaves like a type variable; might match+  | Just (tc1, _) <- mb_tc_app1+  , not (isGenerativeTyCon tc1 Nominal)+    -- E.g.   unify_ty (F ty1) b  =  MaybeApart+    --        because the (F ty1) behaves like a variable+    --        NB: if unifying, we have already dealt+    --            with the 'ty2 = variable' case+  = maybeApart MARTypeFamily -  | isTyFamApp mb_tc_app2     -- A (not-over-saturated) type-family application-  , um_unif env               -- behaves like a type variable; might unify+  | Just (tc2, _) <- mb_tc_app2+  , not (isGenerativeTyCon tc2 Nominal)+  , um_unif env+    -- E.g.   unify_ty [a] (F ty2) =  MaybeApart, when unifying (only)+    --        because the (F ty2) behaves like a variable+    --        NB: we have already dealt with the 'ty1 = variable' case   = maybeApart MARTypeFamily    where@@ -1207,17 +1216,6 @@       -- Possibly different saturations of a polykinded tycon       -- See Note [Polykinded tycon applications] -isTyFamApp :: Maybe (TyCon, [Type]) -> Bool--- True if we have a saturated or under-saturated type family application--- If it is /over/ saturated then we return False.  E.g.---     unify_ty (F a b) (c d)    where F has arity 1--- we definitely want to decompose that type application! (#22647)-isTyFamApp (Just (tc, tys))-  =  not (isGenerativeTyCon tc Nominal)       -- Type family-ish-  && not (tys `lengthExceeds` tyConArity tc)  -- Not over-saturated-isTyFamApp Nothing-  = False- --------------------------------- uVar :: UMEnv      -> InTyVar         -- Variable to be unified@@ -1239,8 +1237,17 @@                       -- this is because the range of the subst is the target                       -- type, not the template type. So, just check for                       -- normal type equality.-                      unless ((ty' `mkCastTy` kco) `eqType` ty) $-                      surelyApart+                      unless ((ty' `mkCastTy` kco) `tcEqType` ty) $+                        surelyApart+                      -- 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.           Nothing  -> uUnrefined env tv1' ty ty kco } -- No, continue  uUnrefined :: UMEnv@@ -1396,6 +1403,8 @@       (<*>)  = 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' })@@ -1537,10 +1546,13 @@ ty_co_match :: MatchEnv   -- ^ ambient helpful info             -> LiftCoEnv  -- ^ incoming subst             -> Type       -- ^ ty, type to match-            -> Coercion   -- ^ co, coercion to match against-            -> Coercion   -- ^ :: kind of L type of substed ty ~N L kind of co-            -> Coercion   -- ^ :: kind of R type of substed ty ~N R kind of co+            -> 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      -- why coreView here, not tcView? Because we're firmly after type-checking.@@ -1550,6 +1562,8 @@   | 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@@ -1608,14 +1622,17 @@ 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 _ w ty1 ty2) co _lkco _rkco-    -- Despite the fact that (->) is polymorphic in five type variables (two-    -- runtime rep, a multiplicity and two types), we shouldn't need to-    -- explicitly unify the runtime reps here; unifying the types themselves-    -- should be sufficient.  See Note [Representation of function types].-  | Just (tc, [co_mult, _,_,co1,co2]) <- splitTyConAppCo_maybe co+  | Just (tc, [co_mult,rrco1,rrco2,co1,co2]) <- splitTyConAppCo_maybe co   , tc == funTyCon-  = let Pair lkcos rkcos = traverse (fmap mkNomReflCo . coercionKind) [co_mult,co1,co2]-    in ty_co_match_args menv subst [w, ty1, ty2] [co_mult, co1, co2] lkcos rkcos+  = let rr1 = getRuntimeRep ty1+        rr2 = getRuntimeRep ty2+        Pair lkcos rkcos = traverse (fmap (mkNomReflCo . typeKind) . coercionKind)+                             [co_mult,rrco1, rrco2,co1,co2]+    in  -- NB: we include the RuntimeRep arguments in the matching; not doing so caused #21205.+        ty_co_match_args menv subst+          [w, rr1, rr2, ty1, ty2]+          [co_mult, rrco1, rrco2, co1, co2]+          lkcos rkcos  ty_co_match menv subst (ForAllTy (Bndr tv1 _) ty1)                        (ForAllCo tv2 kind_co2 co2)@@ -1684,7 +1701,7 @@        ; ty_co_match_args menv subst tys1 cos2 lkcos rkcos }   where     Pair lkcos rkcos-      = traverse (fmap mkNomReflCo . coercionKind) cos2+      = traverse (fmap (mkNomReflCo . typeKind) . coercionKind) cos2  ty_co_match_app :: MatchEnv -> LiftCoEnv                 -> Type -> [Type] -> Coercion -> [Coercion]@@ -1698,7 +1715,7 @@   = 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-       ; let Pair lkcos rkcos = traverse (fmap mkNomReflCo . coercionKind) co2args+       ; let Pair lkcos rkcos = traverse (fmap (mkNomReflCo . typeKind) . coercionKind) co2args        ; ty_co_match_args menv subst2 ty1args co2args lkcos rkcos }   where     ki1 = typeKind ty1@@ -2023,7 +2040,7 @@   where     arity = tyConArity fam_tc     tcv_subst = TCvSubst (fe_in_scope env) tv_subst emptyVarEnv-    (sat_fam_args, leftover_args) = ASSERT( arity <= length fam_args )+    (sat_fam_args, leftover_args) = assert (arity <= length fam_args) $                                     splitAt arity fam_args     -- Apply the substitution before looking up an application in the     -- environment. See Note [Flattening type-family applications when matching instances],
GHC/Core/Utils.hs view
@@ -6,8 +6,6 @@ Utility functions on @Core@ syntax -} -{-# LANGUAGE CPP #-}- -- | Commonly useful utilities for manipulating the Core language module GHC.Core.Utils (         -- * Constructing expressions@@ -25,29 +23,28 @@         -- * Properties of expressions         exprType, coreAltType, coreAltsType, mkLamType, mkLamTypes,         mkFunctionType,-        isExprLevPoly,         exprIsDupable, exprIsTrivial, getIdFromTrivialExpr, exprIsDeadEnd,         getIdFromTrivialExpr_maybe,         exprIsCheap, exprIsExpandable, exprIsCheapX, CheapAppFun,         exprIsHNF, exprOkForSpeculation, exprOkForSideEffects, exprIsWorkFree,         exprIsConLike,-        isCheapApp, isExpandableApp,+        isCheapApp, isExpandableApp, isSaturatedConApp,         exprIsTickedString, exprIsTickedString_maybe,         exprIsTopLevelBindable,         altsAreExhaustive,          -- * Equality         cheapEqExpr, cheapEqExpr', eqExpr,-        diffExpr, diffBinds,+        diffBinds,          -- * Lambdas and eta reduction-        tryEtaReduce, zapLamBndrs,+        tryEtaReduce, canEtaReduceToArity,          -- * Manipulating data constructors and types-        exprToType, exprToCoercion_maybe,-        applyTypeToArgs, applyTypeToArg,+        exprToType,+        applyTypeToArgs,         dataConRepInstPat, dataConRepFSInstPat,-        isEmptyTy,+        isEmptyTy, normSplitTyConApp_maybe,          -- * Working with ticks         stripTicksTop, stripTicksTopE, stripTicksTopT,@@ -59,6 +56,9 @@         -- * Join points         isJoinBind, +        -- * Tag inference+        mkStrictFieldSeqs, shouldStrictifyIdForCbv, shouldUseCbvForId,+         -- * unsafeEqualityProof         isUnsafeEqualityProof, @@ -66,17 +66,26 @@         dumpIdInfoOfProgram     ) where -#include "HsVersions.h"- import GHC.Prelude import GHC.Platform -import GHC.Driver.Ppr- import GHC.Core-import GHC.Builtin.Names (absentErrorIdKey, makeStaticName, unsafeEqualityProofName) import GHC.Core.Ppr import GHC.Core.FVs( exprFreeVars )+import GHC.Core.DataCon+import GHC.Core.Type as Type+import GHC.Core.FamInstEnv+import GHC.Core.Predicate+import GHC.Core.TyCo.Rep( TyCoBinder(..), TyBinder )+import GHC.Core.Coercion+import GHC.Core.Reduction+import GHC.Core.TyCon+import GHC.Core.Multiplicity+import GHC.Core.Map.Expr ( eqCoreExpr )++import GHC.Builtin.Names ( makeStaticName, unsafeEqualityProofIdKey )+import GHC.Builtin.PrimOps+ import GHC.Types.Var import GHC.Types.SrcLoc import GHC.Types.Var.Env@@ -84,33 +93,33 @@ import GHC.Types.Name import GHC.Types.Literal import GHC.Types.Tickish-import GHC.Types.Demand ( isDeadEndAppSig )-import GHC.Core.DataCon-import GHC.Builtin.PrimOps import GHC.Types.Id import GHC.Types.Id.Info-import GHC.Core.Type as Type-import GHC.Core.Predicate-import GHC.Core.TyCo.Rep( TyCoBinder(..), TyBinder )-import GHC.Core.Coercion-import GHC.Core.TyCon-import GHC.Core.Multiplicity+import GHC.Types.Basic( Arity, Levity(..)+                       ) import GHC.Types.Unique-import GHC.Utils.Outputable-import GHC.Utils.Panic+import GHC.Types.Unique.Set+ import GHC.Data.FastString import GHC.Data.Maybe import GHC.Data.List.SetOps( minusList )-import GHC.Types.Basic     ( Arity, FullArgCount )-import GHC.Utils.Misc import GHC.Data.Pair+import GHC.Data.OrdList++import GHC.Utils.Constants (debugIsOn)+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Utils.Panic.Plain+import GHC.Utils.Misc+import GHC.Utils.Trace+ import Data.ByteString     ( ByteString ) import Data.Function       ( on ) import Data.List           ( sort, sortBy, partition, zipWith4, mapAccumL ) import Data.Ord            ( comparing )-import GHC.Data.OrdList import qualified Data.Set as Set-import GHC.Types.Unique.Set+import GHC.Types.RepType (isZeroBitTy)+import GHC.Types.Demand (isStrictDmd, isAbsDmd, isDeadEndAppSig)  {- ************************************************************************@@ -120,7 +129,7 @@ ************************************************************************ -} -exprType :: CoreExpr -> Type+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@@ -154,7 +163,7 @@ 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 "corAltsType"+coreAltsType []      = panic "coreAltsType"  mkLamType  :: Var -> Type -> Type -- ^ Makes a @(->)@ type or an implicit forall type, depending@@ -180,7 +189,7 @@ -- See GHC.Types.Var Note [AnonArgFlag] mkFunctionType mult arg_ty res_ty    | isPredTy arg_ty -- See GHC.Types.Var Note [AnonArgFlag]-   = ASSERT(eqType mult Many)+   = assert (eqType mult Many) $      mkInvisFunTy mult arg_ty res_ty     | otherwise@@ -188,45 +197,6 @@  mkLamTypes vs ty = foldr mkLamType ty vs --- | Is this expression levity polymorphic? This should be the--- same as saying (isKindLevPoly . typeKind . exprType) but--- much faster.-isExprLevPoly :: CoreExpr -> Bool-isExprLevPoly = go-  where-   go (Var _)                      = False  -- no levity-polymorphic binders-   go (Lit _)                      = False  -- no levity-polymorphic literals-   go e@(App f _) | not (go_app f) = False-                  | otherwise      = check_type e-   go (Lam _ _)                    = False-   go (Let _ e)                    = go e-   go e@(Case {})                  = check_type e -- checking type is fast-   go e@(Cast {})                  = check_type e-   go (Tick _ e)                   = go e-   go e@(Type {})                  = pprPanic "isExprLevPoly ty" (ppr e)-   go (Coercion {})                = False  -- this case can happen in GHC.Core.Opt.SetLevels--   check_type = isTypeLevPoly . exprType  -- slow approach--      -- if the function is a variable (common case), check its-      -- levityInfo. This might mean we don't need to look up and compute-      -- on the type. Spec of these functions: return False if there is-      -- no possibility, ever, of this expression becoming levity polymorphic,-      -- no matter what it's applied to; return True otherwise.-      -- returning True is always safe. See also Note [Levity info] in-      -- IdInfo-   go_app (Var id)        = not (isNeverLevPolyId id)-   go_app (Lit _)         = False-   go_app (App f _)       = go_app f-   go_app (Lam _ e)       = go_app e-   go_app (Let _ e)       = go_app e-   go_app (Case _ _ ty _) = resultIsLevPoly ty-   go_app (Cast _ co)     = resultIsLevPoly (coercionRKind co)-   go_app (Tick _ e)      = go_app e-   go_app e@(Type {})     = pprPanic "isExprLevPoly app ty" (ppr e)-   go_app e@(Coercion {}) = pprPanic "isExprLevPoly app co" (ppr e)-- {- Note [Type bindings] ~~~~~~~~~~~~~~~~~~~~@@ -264,9 +234,9 @@ Note that there might be existentially quantified coercion variables, too. -} --- Not defined with applyTypeToArg because you can't print from GHC.Core.-applyTypeToArgs :: SDoc -> Type -> [CoreExpr] -> Type--- ^ A more efficient version of 'applyTypeToArg' when we have several arguments.+applyTypeToArgs :: HasDebugCallStack => SDoc -> Type -> [CoreExpr] -> Type+-- ^ Determines the type resulting from applying an expression with given type+--- to given argument expressions. -- The first argument is just for debugging, and gives some context applyTypeToArgs pp_e op_ty args   = go op_ty args@@ -313,9 +283,9 @@ -- identity coercions and coalescing nested coercions mkCast :: CoreExpr -> CoercionR -> CoreExpr mkCast e co-  | ASSERT2( coercionRole co == Representational-           , text "coercion" <+> ppr co <+> ptext (sLit "passed to mkCast")-             <+> ppr e <+> text "has wrong role" <+> ppr (coercionRole co) )+  | assertPpr (coercionRole co == Representational)+              (text "coercion" <+> ppr co <+> text "passed to mkCast"+               <+> ppr e <+> text "has wrong role" <+> ppr (coercionRole co)) $     isReflCo co   = e @@ -327,12 +297,13 @@   = Coercion (mkCoCast e_co co)  mkCast (Cast expr co2) co-  = WARN(let { from_ty = coercionLKind co;-               to_ty2  = coercionRKind co2 } in-            not (from_ty `eqType` to_ty2),-             vcat ([ text "expr:" <+> ppr expr+  = warnPprTrace (let { from_ty = coercionLKind co;+                        to_ty2  = coercionRKind co2 } in+                     not (from_ty `eqType` to_ty2))+             "mkCast"+             (vcat ([ text "expr:" <+> ppr expr                    , text "co2:" <+> ppr co2-                   , text "co:" <+> ppr co ]) )+                   , text "co:" <+> ppr co ])) $     mkCast expr (mkTransCo co2 co)  mkCast (Tick t expr) co@@ -340,11 +311,11 @@  mkCast expr co   = let from_ty = coercionLKind co in-    WARN( not (from_ty `eqType` exprType expr),-          text "Trying to coerce" <+> text "(" <> ppr expr+    warnPprTrace (not (from_ty `eqType` exprType expr))+          "Trying to coerce" (text "(" <> ppr expr           $$ text "::" <+> ppr (exprType expr) <> text ")"           $$ ppr co $$ ppr (coercionType co)-          $$ callStackDoc )+          $$ callStackDoc) $     (Cast expr co)  @@ -363,9 +334,9 @@   -- non-counting part having laxer placement properties.   canSplit = tickishCanSplit t && tickishPlace (mkNoCount t) /= tickishPlace t -  mkTick' :: (CoreExpr -> CoreExpr) -- ^ apply after adding tick (float through)-          -> (CoreExpr -> CoreExpr) -- ^ apply before adding tick (float with)-          -> CoreExpr               -- ^ current expression+  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 @@ -556,7 +527,8 @@ -- | 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_app_invariant" needsCaseBinding :: Type -> CoreExpr -> Bool-needsCaseBinding ty rhs = isUnliftedType ty && not (exprOkForSpeculation rhs)+needsCaseBinding ty rhs =+  mightBeUnliftedType ty && not (exprOkForSpeculation rhs)         -- Make a case expression instead of a let         -- These can arise either from the desugarer,         -- or from beta reductions: (\x.e) (x +# y)@@ -629,8 +601,8 @@  -- | 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)+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@@ -655,7 +627,7 @@       = 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+          GT -> assert (not (con1 == DEFAULT)) $ go alts deflt  {- Note [Unreachable code] ~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -710,8 +682,8 @@ -- 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 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)@@ -1117,7 +1089,7 @@   | otherwise   = go 0 e   where-    go n (Var v)                 = isDeadEndAppSig (idStrictness v) n+    go n (Var v)                 = isDeadEndAppSig (idDmdSig v) n     go n (App e a) | isTypeArg a = go n e                    | otherwise   = go (n+1) e     go n (Tick _ e)              = go n e@@ -1253,12 +1225,12 @@ Note [exprIsCheap] ~~~~~~~~~~~~~~~~~~ -See also Note [Interaction of exprIsCheap and lone variables] in GHC.Core.Unfold+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.]+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@@ -1316,12 +1288,15 @@  -------------------- exprIsWorkFree :: CoreExpr -> Bool   -- See Note [exprIsWorkFree]-exprIsWorkFree = exprIsCheapX isWorkFreeApp+exprIsWorkFree e = exprIsCheapX isWorkFreeApp e  exprIsCheap :: CoreExpr -> Bool-exprIsCheap = exprIsCheapX isCheapApp+exprIsCheap e = exprIsCheapX isCheapApp e  exprIsCheapX :: CheapAppFun -> CoreExpr -> Bool+{-# INLINE exprIsCheapX #-}+-- allow specialization of exprIsCheap and exprIsWorkFree+-- instead of having an unknown call to ok_app exprIsCheapX ok_app e   = ok e   where@@ -1619,6 +1594,7 @@   =  -- See Note [exprOkForSpeculation: case expressions]      expr_ok primop_ok scrut   && isUnliftedType (idType bndr)+      -- OK to call isUnliftedType: binders always have a fixed RuntimeRep   && all (\(Alt _ _ rhs) -> expr_ok primop_ok rhs) alts   && altsAreExhaustive alts @@ -1626,14 +1602,18 @@   | (expr, args) <- collectArgs other_expr   = case stripTicksTopE (not . tickishCounts) expr of         Var f            -> app_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).-        Lit LitRubbish{} -> True-#if defined(DEBUG)-        Lit _            -> pprPanic "Non-rubbish lit in app head" (ppr other_expr)-#endif-        _                -> False+        -- 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 :: (PrimOp -> Bool) -> Id -> [CoreExpr] -> Bool app_ok primop_ok fun args@@ -1669,21 +1649,37 @@         -> primop_ok op  -- Check the primop itself         && and (zipWith primop_arg_ok arg_tys args)  -- Check the arguments -      _other -> isUnliftedType (idType fun)          -- c.f. the Var case of exprIsHNF-             || idArity fun > n_val_args             -- Partial apps+      _  -- Unlifted types+         -- c.f. the Var case of exprIsHNF+         | Just Unlifted <- typeLevity_maybe (idType fun)+         -> assertPpr (n_val_args == 0) (ppr fun $$ ppr args)+            True  -- Our only unlifted types are Int# etc, 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.++         -- Partial applications+         | idArity fun > n_val_args -> True++         -- Functions that terminate fast without raising exceptions etc+         -- See Note [Discarding unnecessary unsafeEqualityProofs]+         | 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-               n_val_args = valArgCount args   where+    n_val_args   = valArgCount args     (arg_tys, _) = splitPiTys (idType fun)      primop_arg_ok :: TyBinder -> CoreExpr -> Bool     primop_arg_ok (Named _) _ = True   -- A type argument     primop_arg_ok (Anon _ ty) arg      -- A term argument-       | isUnliftedType (scaledThing ty) = expr_ok primop_ok arg-       | otherwise         = True  -- See Note [Primops with lifted arguments]+       | Just Lifted <- typeLevity_maybe (scaledThing ty)+       = True -- See Note [Primops with lifted arguments]+       | otherwise+       = expr_ok primop_ok arg  ----------------------------- altsAreExhaustive :: [Alt b] -> Bool@@ -1794,7 +1790,7 @@ Note [Primops with lifted arguments] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Is this ok-for-speculation (see #13027)?-   reallyUnsafePtrEq# a b+   reallyUnsafePtrEquality# a b Well, yes.  The primop accepts lifted arguments and does not evaluate them.  Indeed, in general primops are, well, primitive and do not perform evaluation.@@ -1849,6 +1845,20 @@ Note that exprIsHNF /can/ and does take advantage of evaluated-ness; it doesn't have the trickiness of the let/app invariant to worry about. +Note [Discarding unnecessary unsafeEqualityProofs]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In #20143 we found+   case unsafeEqualityProof @t1 @t2 of UnsafeRefl cv[dead] -> blah+where 'blah' didn't mention 'cv'.  We'd like to discard this+redundant use of unsafeEqualityProof, via GHC.Core.Opt.Simplify.rebuildCase.+To do this we need to know+  (a) that cv is unused (done by OccAnal), and+  (b) that unsafeEqualityProof terminates rapidly without side effects.++At the moment we check that explicitly here in exprOkForSideEffects,+but one might imagine a more systematic check in future.++ ************************************************************************ *                                                                      *              exprIsHNF, exprIsConLike@@ -1914,8 +1924,12 @@         -- 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+      || ( typeLevity_maybe (idType v) == Just Unlifted )+        -- Unlifted binders are always evaluated (#20140) -    is_hnf_like (Lit _)          = True+    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@@ -1944,13 +1958,10 @@     id_app_is_value id n_val_args        = is_con id        || idArity id > n_val_args-       || id `hasKey` absentErrorIdKey  -- See Note [aBSENT_ERROR_ID] in GHC.Core.Make-                      -- absentError behaves like an honorary data constructor - {- Note [exprIsHNF Tick]-+~~~~~~~~~~~~~~~~~~~~~ We can discard source annotations on HNFs as long as they aren't tick-like: @@ -1971,8 +1982,9 @@ --   see Note [Core top-level string literals] in "GHC.Core" exprIsTopLevelBindable expr ty   = not (mightBeUnliftedType ty)-    -- Note that 'expr' may be levity polymorphic here consequently we must use-    -- 'mightBeUnliftedType' rather than 'isUnliftedType' as the latter would panic.+    -- 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@@ -2042,7 +2054,7 @@ --  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 )+  = assert (univ_tvs `equalLength` inst_tys) $     (ex_bndrs, arg_ids)   where     univ_tvs = dataConUnivTyVars con@@ -2132,48 +2144,11 @@  eqExpr :: InScopeSet -> CoreExpr -> CoreExpr -> Bool -- Compares for equality, modulo alpha-eqExpr in_scope e1 e2-  = go (mkRnEnv2 in_scope) e1 e2-  where-    go env (Var v1) (Var v2)-      | rnOccL env v1 == rnOccR env v2-      = True--    go _   (Lit lit1)    (Lit lit2)      = lit1 == lit2-    go env (Type t1)    (Type t2)        = eqTypeX env t1 t2-    go env (Coercion co1) (Coercion co2) = eqCoercionX env co1 co2-    go env (Cast e1 co1) (Cast e2 co2) = eqCoercionX env co1 co2 && go env e1 e2-    go env (App f1 a1)   (App f2 a2)   = go env f1 f2 && go env a1 a2-    go env (Tick n1 e1)  (Tick n2 e2)  = eqTickish env n1 n2 && go env e1 e2--    go env (Lam b1 e1)  (Lam b2 e2)-      =  eqTypeX env (varType b1) (varType b2)   -- False for Id/TyVar combination-      && go (rnBndr2 env b1 b2) e1 e2--    go env (Let (NonRec v1 r1) e1) (Let (NonRec v2 r2) e2)-      =  go env r1 r2  -- No need to check binder types, since RHSs match-      && go (rnBndr2 env v1 v2) e1 e2--    go env (Let (Rec ps1) e1) (Let (Rec ps2) e2)-      = equalLength ps1 ps2-      && all2 (go env') rs1 rs2 && go env' e1 e2-      where-        (bs1,rs1) = unzip ps1-        (bs2,rs2) = unzip ps2-        env' = rnBndrs2 env bs1 bs2--    go env (Case e1 b1 t1 a1) (Case e2 b2 t2 a2)-      | null a1   -- See Note [Empty case alternatives] in GHC.Data.TrieMap-      = null a2 && go env e1 e2 && eqTypeX env t1 t2-      | otherwise-      =  go env e1 e2 && all2 (go_alt (rnBndr2 env b1 b2)) a1 a2--    go _ _ _ = False--    ------------    go_alt env (Alt c1 bs1 e1) (Alt c2 bs2 e2)-      = c1 == c2 && go (rnBndrs2 env bs1 bs2) e1 e2+-- TODO: remove eqExpr once GHC 9.4 is released+eqExpr _ = eqCoreExpr+{-# DEPRECATED eqExpr "Use 'GHC.Core.Map.Expr.eqCoreExpr', 'eqExpr' will be removed in GHC 9.6" #-} +-- 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 &&@@ -2181,47 +2156,6 @@         lext == rext eqTickish _ l r = l == r --- | 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]]- -- | Finds differences between core bindings, see @diffExpr@. -- -- The main problem here is that while we expect the binds to have the@@ -2232,6 +2166,8 @@ -- 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@@ -2252,8 +2188,9 @@             else (warn env binds1 binds2, env)        go fuel env ((bndr1,expr1):binds1) binds2           | let matchExpr (bndr,expr) =-                  (not top || null (diffIdInfo env bndr bndr1)) &&+                  (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)@@ -2276,9 +2213,56 @@        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]@@ -2292,7 +2276,7 @@     && callArityInfo info1 == callArityInfo info2     && levityInfo info1 == levityInfo info2   = locBind "in unfolding of" bndr1 bndr2 $-    diffUnfold env (unfoldingInfo info1) (unfoldingInfo info2)+    diffUnfold env (realUnfoldingInfo info1) (realUnfoldingInfo info2)   | otherwise   = locBind "in Id info of" bndr1 bndr2     [fsep [pprBndr LetBind bndr1, text "/=", pprBndr LetBind bndr2]]@@ -2371,7 +2355,9 @@   The above is correct, but eta-reducing g would yield g=f, the linter will   complain that g and f don't have the same type. -* Note [Arity care]: we need to be careful if we just look at f's+* Note [Arity care]+  ~~~~~~~~~~~~~~~~~+  We need to be careful if we just look at f's   arity. Currently (Dec07), f's arity is visible in its own RHS (see   Note [Arity robustness] in GHC.Core.Opt.Simplify.Env) so we must *not* trust the   arity when checking that 'f' is a value.  Otherwise we will@@ -2469,8 +2455,10 @@     ok_fun _fun                = False      ----------------    ok_fun_id fun = fun_arity fun >= incoming_arity-+    ok_fun_id fun = -- There are arguments to reduce...+                    fun_arity fun >= incoming_arity &&+                    -- ... and the function can be eta reduced to arity 0+                    canEtaReduceToArity fun 0 0     ---------------     fun_arity fun             -- See Note [Arity care]        | isLocalId fun@@ -2517,6 +2505,28 @@      ok_arg _ _ _ _ = Nothing +-- | Can we eta-reduce the given function to the specified arity?+-- See Note [Eta reduction conditions].+canEtaReduceToArity :: Id -> JoinArity -> Arity -> Bool+canEtaReduceToArity fun dest_join_arity dest_arity =+  not $+        hasNoBinding fun+       -- Don't undersaturate functions with no binding.++    ||  ( isJoinId fun && dest_join_arity < idJoinArity fun )+       -- Don't undersaturate join points.+       -- See Note [Invariants on join points] in GHC.Core, and #20599++    || ( dest_arity < idCbvMarkArity fun )+       -- Don't undersaturate StrictWorkerIds.+       -- See Note [CBV Function Ids]  in GHC.CoreToStg.Prep.++    ||  isLinearType (idType fun)+       -- Don't perform eta reduction on linear types.+       -- If `f :: A %1-> B` and `g :: A -> B`,+       -- then `g x = f x` is OK but `g = f` is not.+       -- See Note [Eta reduction conditions].+ {- Note [Eta reduction of an eval'd function] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -2535,31 +2545,6 @@  {- ********************************************************************* *                                                                      *-                  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 under the \x--- 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---{- *********************************************************************-*                                                                      * \subsection{Determining non-updatable right-hand-sides} *                                                                      * ************************************************************************@@ -2598,6 +2583,17 @@     | 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.+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+  = Just (tc, tc_args, co)+normSplitTyConApp_maybe _ _ = Nothing+ {- ***************************************************** *@@ -2631,16 +2627,258 @@ isJoinBind (Rec ((b, _) : _)) = isJoinId b isJoinBind _                  = False -dumpIdInfoOfProgram :: (IdInfo -> SDoc) -> CoreProgram -> SDoc-dumpIdInfoOfProgram ppr_id_info binds = vcat (map printId ids)+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-  printId id | isExportedId id = ppr id <> colon <+> (ppr_id_info (idInfo id))+  -- 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 Strict Field Invariant! See Note [Strict Field Invariant] 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 InferTags).+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 benefitial 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 InferTags.+  -- 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@@ -2652,6 +2890,6 @@ -- Note [Implementing unsafeCoerce] in base:Unsafe.Coerce isUnsafeEqualityProof e   | Var v `App` Type _ `App` Type _ `App` Type _ <- e-  = idName v == unsafeEqualityProofName+  = v `hasKey` unsafeEqualityProofIdKey   | otherwise   = False
GHC/CoreToIface.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE Strict #-} -- See Note [Avoiding space leaks in toIface*]  -- | Functions for converting Core things to interface file things.@@ -44,42 +44,45 @@     , toIfaceLFInfo     ) where -#include "HsVersions.h"- import GHC.Prelude -import GHC.Driver.Ppr-import GHC.Iface.Syntax-import GHC.Core.DataCon-import GHC.Types.Id-import GHC.Types.Literal-import GHC.Types.Id.Info 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.Tidy ( tidyCo )+ import GHC.Builtin.Types.Prim ( eqPrimTyCon, eqReprPrimTyCon ) import GHC.Builtin.Types ( heqTyCon )-import GHC.Types.Id.Make ( noinlineIdName ) import GHC.Builtin.Names++import GHC.Iface.Syntax+import GHC.Data.FastString++import GHC.Types.Id+import GHC.Types.Id.Info+import GHC.Types.Id.Make ( noinlineIdName )+import GHC.Types.Literal import GHC.Types.Name import GHC.Types.Basic-import GHC.Core.Type-import GHC.Core.Multiplicity-import GHC.Core.PatSyn-import GHC.Utils.Outputable-import GHC.Utils.Panic-import GHC.Data.FastString-import GHC.Utils.Misc import GHC.Types.Var import GHC.Types.Var.Env import GHC.Types.Var.Set import GHC.Types.Tickish-import GHC.Core.TyCo.Rep-import GHC.Core.TyCo.Tidy ( tidyCo ) import GHC.Types.Demand ( isTopSig ) import GHC.Types.Cpr ( topCprSig ) +import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Utils.Misc+import GHC.Utils.Trace+ import Data.Maybe ( catMaybes )  {- Note [Avoiding space leaks in toIface*]@@ -166,7 +169,7 @@ --    translates the tyvars in 'free' as IfaceFreeTyVars -- -- Synonyms are retained in the interface type-toIfaceTypeX fr (TyVarTy tv)   -- See Note [TcTyVars in IfaceType] in GHC.Iface.Type+toIfaceTypeX fr (TyVarTy tv)   -- See Note [Free tyvars in IfaceType] in GHC.Iface.Type   | tv `elemVarSet` fr         = IfaceFreeTyVar tv   | otherwise                  = IfaceTyVar (toIfaceTyVar tv) toIfaceTypeX fr ty@(AppTy {})  =@@ -279,7 +282,7 @@     go (Refl ty)            = IfaceReflCo (toIfaceTypeX fr ty)     go (GRefl r ty mco)     = IfaceGReflCo r (toIfaceTypeX fr ty) (go_mco mco)     go (CoVarCo cv)-      -- See [TcTyVars in IfaceType] in GHC.Iface.Type+      -- See Note [Free tyvars in IfaceType] in GHC.Iface.Type       | cv `elemVarSet` fr  = IfaceFreeCoVar cv       | otherwise           = IfaceCoVarCo (toIfaceCoVar cv)     go (HoleCo h)           = IfaceHoleCo  (coHoleCoVar h)@@ -299,7 +302,7 @@                                           (toIfaceTypeX fr t2)     go (TyConAppCo r tc cos)       | tc `hasKey` funTyConKey-      , [_,_,_,_, _] <- cos         = pprPanic "toIfaceCoercion" empty+      , [_,_,_,_, _] <- cos         = panic "toIfaceCoercion"       | otherwise                =         IfaceTyConAppCo r (toIfaceTyCon tc) (map go cos)     go (FunCo r w co1 co2)   = IfaceFunCo r (go w) (go co1) (go co2)@@ -369,7 +372,7 @@         -- 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)-        WARN( True, ppr kind $$ ppr ty_args )+        warnPprTrace True "toIfaceAppArgsX" (ppr kind $$ ppr ty_args) $         IA_Arg (toIfaceTypeX fr t1) Required (go env ty ts1)  tidyToIfaceType :: TidyEnv -> Type -> IfaceType@@ -438,6 +441,7 @@  toIfaceIdDetails :: IdDetails -> IfaceIdDetails toIfaceIdDetails VanillaId                      = IfVanillaId+toIfaceIdDetails (WorkerLikeId dmds)          = IfWorkerLikeId dmds toIfaceIdDetails (DFunId {})                    = IfDFunId toIfaceIdDetails (RecSelId { sel_naughty = n                            , sel_tycon = tc })  =@@ -471,16 +475,16 @@      ------------  Strictness  --------------         -- No point in explicitly exporting TopSig-    sig_info = strictnessInfo id_info-    strict_hsinfo | not (isTopSig sig_info) = Just (HsStrictness sig_info)+    sig_info = dmdSigInfo id_info+    strict_hsinfo | not (isTopSig sig_info) = Just (HsDmdSig sig_info)                   | otherwise               = Nothing      ------------  CPR ---------------    cpr_info = cprInfo id_info-    cpr_hsinfo | cpr_info /= topCprSig = Just (HsCpr cpr_info)+    cpr_info = cprSigInfo id_info+    cpr_hsinfo | cpr_info /= topCprSig = Just (HsCprSig cpr_info)                | otherwise             = Nothing     ------------  Unfolding  ---------------    unfold_hsinfo = toIfUnfolding loop_breaker (unfoldingInfo id_info)+    unfold_hsinfo = toIfUnfolding loop_breaker (realUnfoldingInfo id_info)     loop_breaker  = isStrongLoopBreaker (occInfo id_info)      ------------  Inline prag  --------------@@ -488,8 +492,8 @@     inline_hsinfo | isDefaultInlinePragma inline_prag = Nothing                   | otherwise = Just (HsInline inline_prag) -    ------------  Levity polymorphism  -----------    levity_hsinfo | isNeverLevPolyIdInfo id_info = Just HsLevity+    ------------  Representation polymorphism  ----------+    levity_hsinfo | isNeverRepPolyIdInfo id_info = Just HsLevity                   | otherwise                    = Nothing  toIfaceJoinInfo :: Maybe JoinArity -> IfaceJoinInfo@@ -524,7 +528,7 @@  toIfUnfolding _ (OtherCon {}) = Nothing   -- The binding site of an Id doesn't have OtherCon, except perhaps-  -- where we have called zapUnfolding; and that evald'ness info is+  -- where we have called trimUnfolding; and that evald'ness info is   -- not needed by importing modules  toIfUnfolding _ BootUnfolding = Nothing@@ -585,9 +589,9 @@ --------------------- toIfaceCon :: AltCon -> IfaceConAlt toIfaceCon (DataAlt dc) = IfaceDataAlt (getName dc)-toIfaceCon (LitAlt l)   = ASSERT2( (not (isLitRubbish l)) , ppr l )+toIfaceCon (LitAlt l)   = assertPpr (not (isLitRubbish l)) (ppr l) $                           -- assert: see Note [Rubbish literals] wrinkle (b)-                          (IfaceLitAlt l)+                          IfaceLitAlt l toIfaceCon DEFAULT      = IfaceDefault  ---------------------@@ -635,15 +639,15 @@     LFReEntrant top_lvl arity no_fvs _arg_descr ->       -- Exported LFReEntrant closures are top level, and top-level closures       -- don't have free variables-      ASSERT2(isTopLevel top_lvl, ppr nm)-      ASSERT2(no_fvs, ppr nm)+      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)-      ASSERT2(isTopLevel top_lvl, ppr nm)-      ASSERT2(no_fvs, ppr nm)-      ASSERT2(sfi == NonStandardThunk, ppr nm)+      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)
GHC/CoreToStg.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE TypeFamilies #-} @@ -15,50 +16,54 @@  module GHC.CoreToStg ( coreToStg ) where -#include "HsVersions.h"- import GHC.Prelude +import GHC.Driver.Session+import GHC.Driver.Config.Stg.Debug+ import GHC.Core import GHC.Core.Utils   ( exprType, findDefault, isJoinBind                         , exprIsTickedString_maybe ) import GHC.Core.Opt.Arity   ( manifestArity )+import GHC.Core.Type+import GHC.Core.TyCon+import GHC.Core.DataCon+ import GHC.Stg.Syntax import GHC.Stg.Debug+import GHC.Stg.Utils -import GHC.Core.Type import GHC.Types.RepType-import GHC.Core.TyCon import GHC.Types.Id.Make ( coercionTokenId ) import GHC.Types.Id import GHC.Types.Id.Info-import GHC.Core.DataCon import GHC.Types.CostCentre import GHC.Types.Tickish import GHC.Types.Var.Env-import GHC.Unit.Module import GHC.Types.Name   ( isExternalName, nameModule_maybe ) import GHC.Types.Basic  ( Arity )-import GHC.Builtin.Types ( unboxedUnitDataCon ) import GHC.Types.Literal-import GHC.Utils.Outputable-import GHC.Utils.Monad-import GHC.Data.FastString-import GHC.Utils.Misc-import GHC.Utils.Panic-import GHC.Driver.Session-import GHC.Platform.Ways-import GHC.Driver.Ppr import GHC.Types.ForeignCall import GHC.Types.IPE import GHC.Types.Demand    ( isUsedOnceDmd )-import GHC.Builtin.PrimOps ( PrimCall(..) ) import GHC.Types.SrcLoc    ( mkGeneralSrcSpan ) +import GHC.Unit.Module+import GHC.Builtin.Types ( unboxedUnitDataCon )+import GHC.Data.FastString+import GHC.Platform.Ways+import GHC.Builtin.PrimOps ( PrimCall(..) )++import GHC.Utils.Outputable+import GHC.Utils.Monad+import GHC.Utils.Misc (HasDebugCallStack)+import GHC.Utils.Panic+import GHC.Utils.Panic.Plain+import GHC.Utils.Trace+ import Control.Monad (ap) import Data.Maybe (fromMaybe) import Data.Tuple (swap)-import qualified Data.Set as Set  -- Note [Live vs free] -- ~~~~~~~~~~~~~~~~~~~@@ -242,10 +247,10 @@     -- See Note [Mapping Info Tables to Source Positions]     (!pgm'', !denv) =         if gopt Opt_InfoTableMap dflags-          then collectDebugInformation dflags ml pgm'+          then collectDebugInformation (initStgDebugOpts dflags) ml pgm'           else (pgm', emptyInfoTableProvMap) -    prof = WayProf `Set.member` ways dflags+    prof = ways dflags `hasWay` WayProf      final_ccs       | prof && gopt Opt_AutoSccsOnIndividualCafs dflags@@ -311,7 +316,7 @@     (env', ccs', bind)  coreTopBindToStg dflags this_mod env ccs (Rec pairs)-  = ASSERT( not (null pairs) )+  = assert (not (null pairs)) $     let         binders = map fst pairs @@ -344,7 +349,7 @@              stg_arity =                stgRhsArity stg_rhs -       ; return (ASSERT2( arity_ok stg_arity, mk_arity_msg stg_arity) stg_rhs,+       ; return (assertPpr (arity_ok stg_arity) (mk_arity_msg stg_arity) stg_rhs,                  ccs') }   where         -- It's vital that the arity on a top-level Id matches@@ -384,10 +389,9 @@ -- on these components, but it in turn is not scrutinised as the basis for any -- decisions.  Hence no black holes. --- No LitInteger's or LitNatural's should be left by the time this is called.+-- 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 LitNumInteger _)) = panic "coreToStgExpr: LitInteger"-coreToStgExpr (Lit (LitNumber LitNumNatural _)) = panic "coreToStgExpr: LitNatural"+coreToStgExpr (Lit (LitNumber LitNumBigNat _))  = panic "coreToStgExpr: LitNumBigNat" coreToStgExpr (Lit l)                           = return (StgLit l) coreToStgExpr (Var v) = coreToStgApp v [] [] coreToStgExpr (Coercion _)@@ -452,22 +456,26 @@        ; alts2 <- extendVarEnvCts [(bndr, LambdaBound)] (mapM vars_alt alts)        ; return (StgCase scrut2 bndr (mkStgAltType bndr alts) alts2) }   where-    vars_alt :: CoreAlt -> CtsM (AltCon, [Var], StgExpr)+    vars_alt :: CoreAlt -> CtsM StgAlt     vars_alt (Alt con binders rhs)       | DataAlt c <- con, c == unboxedUnitDataCon       = -- This case is a bit smelly.         -- See Note [Nullary unboxed tuple] in GHC.Core.Type         -- where a nullary tuple is mapped to (State# World#)-        ASSERT( null binders )+        assert (null binders) $         do { rhs2 <- coreToStgExpr rhs-           ; return (DEFAULT, [], rhs2)  }+           ; return GenStgAlt{alt_con=DEFAULT,alt_bndrs=mempty,alt_rhs=rhs2}+           }       | otherwise       = let     -- Remove type variables             binders' = filterStgBinders binders         in         extendVarEnvCts [(b, LambdaBound) | b <- binders'] $ do         rhs2 <- coreToStgExpr rhs-        return (con, binders', rhs2)+        return $! GenStgAlt{ alt_con   = con+                           , alt_bndrs = binders'+                           , alt_rhs   = rhs2+                           }  coreToStgExpr (Let bind body) = coreToStgLet bind body coreToStgExpr e               = pprPanic "coreToStgExpr" (ppr e)@@ -484,8 +492,7 @@           Just tc             | isAbstractTyCon tc -> look_for_better_tycon             | isAlgTyCon tc      -> AlgAlt tc-            | otherwise          -> ASSERT2( _is_poly_alt_tycon tc, ppr tc )-                                    PolyAlt+            | otherwise          -> assertPpr (_is_poly_alt_tycon tc) (ppr tc) PolyAlt           Nothing                -> PolyAlt       [non_gcd] -> PrimAlt non_gcd       not_unary -> MultiValAlt (length not_unary)@@ -508,7 +515,7 @@         | ((Alt (DataAlt con) _ _) : _) <- data_alts =                 AlgAlt (dataConTyCon con)         | otherwise =-                ASSERT(null data_alts)+                assert (null data_alts)                 PolyAlt         where                 (data_alts, _deflt) = findDefault alts@@ -547,17 +554,17 @@                 -- 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      -> ASSERT( saturated )+                PrimOpId op      -> assert saturated $                                     StgOpApp (StgPrimOp op) args' res_ty                  -- A call to some primitive Cmm function.                 FCallId (CCall (CCallSpec (StaticTarget _ lbl (Just pkgId) True)                                           PrimCallConv _))-                                 -> ASSERT( saturated )+                                 -> assert saturated $                                     StgOpApp (StgPrimCallOp (PrimCall lbl pkgId)) args' res_ty                  -- A regular foreign call.-                FCallId call     -> ASSERT( saturated )+                FCallId call     -> assert saturated $                                     StgOpApp (StgFCallOp call (idType f)) args' res_ty                  TickBoxOpId {}   -> pprPanic "coreToStg TickBox" $ ppr (f,args')@@ -588,7 +595,7 @@        ; return (StgVarArg coercionTokenId : args', ts) }  coreToStgArgs (Tick t e : args)-  = ASSERT( not (tickishIsCode t) )+  = assert (not (tickishIsCode t)) $     do { (args', ts) <- coreToStgArgs (e : args)        ; let !t' = coreToStgTick (exprType e) t        ; return (args', t':ts) }@@ -620,7 +627,7 @@         stg_arg_rep = typePrimRep (stgArgType stg_arg)         bad_args = not (primRepsCompatible platform arg_rep stg_arg_rep) -    WARN( bad_args, text "Dangerous-looking argument. Probable cause: bad unsafeCoerce#" $$ ppr arg )+    warnPprTrace bad_args "Dangerous-looking argument. Probable cause: bad unsafeCoerce#" (ppr arg) $      return (stg_arg : stg_args, ticks ++ aticks)  coreToStgTick :: Type -- type of the ticked expression@@ -725,10 +732,10 @@   -- so this is not a function binding   | StgConApp con mn args _ <- unticked_rhs   , -- Dynamic StgConApps are updatable-    not (isDllConApp dflags this_mod con args)+    not (isDllConApp (targetPlatform dflags) (gopt Opt_ExternalDynamicRefs dflags) this_mod con args)   = -- CorePrep does this right, but just to make sure-    ASSERT2( not (isUnboxedTupleDataCon con || isUnboxedSumDataCon con)-           , ppr bndr $$ ppr con $$ ppr args)+    assertPpr (not (isUnboxedTupleDataCon con || isUnboxedSumDataCon con))+              (ppr bndr $$ ppr con $$ ppr args)     ( StgRhsCon dontCareCCS con mn ticks args, ccs )    -- Otherwise it's a CAF, see Note [Cost-centre initialization plan].@@ -774,8 +781,10 @@    -- After this point we know that `bndrs` is empty,   -- so this is not a function binding-  | isJoinId bndr -- must be a nullary join point-  = ASSERT(idJoinArity bndr == 0)++  | isJoinId bndr -- Must be a nullary join point+  = -- It might have /type/ arguments (T18328),+    -- so its JoinArity might be >0     StgRhsClosure noExtFieldSilent                   currentCCS                   ReEntrant -- ignored for LNE@@ -930,7 +939,7 @@ lookupBinding :: IdEnv HowBound -> Id -> HowBound lookupBinding env v = case lookupVarEnv env v of                         Just xx -> xx-                        Nothing -> ASSERT2( isGlobalId v, ppr v ) ImportBound+                        Nothing -> assertPpr (isGlobalId v) (ppr v) ImportBound  getAllCAFsCC :: Module -> (CostCentre, CostCentreStack) getAllCAFsCC this_mod =@@ -962,8 +971,8 @@   where     go h@(Var _v)       as ts = (h, as, ts)     go (App f a)        as ts = go f (a:as) ts-    go (Tick t e)       as ts = ASSERT2( not (tickishIsCode t) || all isTypeArg as-                                       , ppr e $$ ppr as $$ ppr ts )+    go (Tick t e)       as ts = assertPpr (not (tickishIsCode t) || all isTypeArg as)+                                          (ppr e $$ ppr as $$ ppr ts) $                                 -- See Note [Ticks in applications]                                 go e as (t:ts) -- ticks can appear in type apps     go (Cast e _)       as ts = go e as ts
GHC/CoreToStg/Prep.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP          #-}+ {-# LANGUAGE BangPatterns #-}  {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}@@ -17,12 +17,9 @@    ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Platform-import GHC.Platform.Ways  import GHC.Driver.Session import GHC.Driver.Env@@ -33,7 +30,6 @@  import GHC.Builtin.Names import GHC.Builtin.Types-import GHC.Types.Id.Make ( realWorldPrimId )  import GHC.Core.Utils import GHC.Core.Opt.Arity@@ -49,17 +45,19 @@ import GHC.Core.Opt.OccurAnal import GHC.Core.TyCo.Rep( UnivCoProvenance(..) ) - import GHC.Data.Maybe import GHC.Data.OrdList import GHC.Data.FastString+import GHC.Data.Pair  import GHC.Utils.Error import GHC.Utils.Misc import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Utils.Outputable import GHC.Utils.Monad  ( mapAccumLM ) import GHC.Utils.Logger+import GHC.Utils.Trace  import GHC.Types.Demand import GHC.Types.Var@@ -67,25 +65,22 @@ import GHC.Types.Var.Env import GHC.Types.Id import GHC.Types.Id.Info+import GHC.Types.Id.Make ( realWorldPrimId ) import GHC.Types.Basic import GHC.Types.Name   ( NamedThing(..), nameSrcSpan, isInternalName ) import GHC.Types.SrcLoc ( SrcSpan(..), realSrcLocSpan, mkRealSrcLoc ) import GHC.Types.Literal import GHC.Types.Tickish import GHC.Types.TyThing-import GHC.Types.CostCentre ( CostCentre, ccFromThisModule ) import GHC.Types.Unique.Supply -import GHC.Data.Pair import Data.List        ( unfoldr ) import Data.Functor.Identity import Control.Monad-import qualified Data.Set as S  {---- ------------------------------------------------------------------------------ Note [CorePrep Overview]--- ---------------------------------------------------------------------------+Note [CorePrep Overview]+~~~~~~~~~~~~~~~~~~~~~~~~  The goal of this pass is to prepare for code generation. @@ -133,8 +128,7 @@ 9.  Replace (lazy e) by e.  See Note [lazyId magic] in GHC.Types.Id.Make     Also replace (noinline e) by e. -10. Convert bignum literals (LitNatural and LitInteger) into their-    core representation.+10. Convert bignum literals into their core representation.  11. Uphold tick consistency while doing this: We move ticks out of     (non-type) applications where we can, and make sure that we@@ -142,7 +136,7 @@  12. Collect cost centres (including cost centres in unfoldings) if we're in     profiling mode. We have to do this here beucase we won't have unfoldings-    after this pass (see `zapUnfolding` and Note [Drop unfoldings and rules].+    after this pass (see `trimUnfolding` and Note [Drop unfoldings and rules].  13. Eliminate case clutter in favour of unsafe coercions.     See Note [Unsafe coercions]@@ -240,20 +234,15 @@ -}  corePrepPgm :: HscEnv -> Module -> ModLocation -> CoreProgram -> [TyCon]-            -> IO (CoreProgram, S.Set CostCentre)+            -> IO CoreProgram corePrepPgm hsc_env this_mod mod_loc binds data_tycons =-    withTiming logger dflags+    withTiming logger                (text "CorePrep"<+>brackets (ppr this_mod))-               (\(a,b) -> a `seqList` b `seq` ()) $ do+               (\a -> a `seqList` ()) $ do     us <- mkSplitUniqSupply 's'     initialCorePrepEnv <- mkInitialCorePrepEnv hsc_env -    let cost_centres-          | WayProf `S.member` ways dflags-          = collectCostCentres this_mod binds-          | otherwise-          = S.empty-+    let         implicit_binds = mkDataConWorkers dflags mod_loc data_tycons             -- NB: we must feed mkImplicitBinds through corePrep too             -- so that they are suitably cloned and eta-expanded@@ -264,20 +253,19 @@                       return (deFloatTop (floats1 `appendFloats` floats2))      endPassIO hsc_env alwaysQualify CorePrep binds_out []-    return (binds_out, cost_centres)+    return binds_out   where     dflags = hsc_dflags hsc_env     logger = hsc_logger hsc_env  corePrepExpr :: HscEnv -> CoreExpr -> IO CoreExpr corePrepExpr hsc_env expr = do-    let dflags = hsc_dflags hsc_env     let logger = hsc_logger hsc_env-    withTiming logger dflags (text "CorePrep [expr]") (\e -> e `seq` ()) $ do+    withTiming logger (text "CorePrep [expr]") (\e -> e `seq` ()) $ do       us <- mkSplitUniqSupply 's'       initialCorePrepEnv <- mkInitialCorePrepEnv hsc_env       let new_expr = initUs_ us (cpeBodyNF initialCorePrepEnv expr)-      dumpIfSet_dyn logger dflags Opt_D_dump_prep "CorePrep" FormatCore (ppr new_expr)+      putDumpFileMaybe logger Opt_D_dump_prep "CorePrep" FormatCore (ppr new_expr)       return new_expr  corePrepTopBinds :: CorePrepEnv -> [CoreBind] -> UniqSM Floats@@ -288,7 +276,7 @@     go _   []             = return emptyFloats     go env (bind : binds) = do (env', floats, maybe_new_bind)                                  <- cpeBind TopLevel env bind-                               MASSERT(isNothing maybe_new_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@@ -611,7 +599,7 @@        ; 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+  = 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,@@ -656,7 +644,7 @@ -- Used for all bindings -- The binder is already cloned, hence an OutId cpePair top_lvl is_rec dmd is_unlifted env bndr rhs-  = ASSERT(not (isJoinId bndr)) -- those should use cpeJoinPair+  = 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@@ -666,7 +654,7 @@        ; (floats3, rhs3)             <- if manifestArity rhs1 <= arity                then return (floats2, cpeEtaExpand arity rhs2)-               else WARN(True, text "CorePrep: silly extra arguments:" <+> ppr bndr)+               else warnPprTrace True "CorePrep: silly extra arguments:" (ppr bndr) $                                -- Note [Silly extra arguments]                     (do { v <- newVar (idType bndr)                         ; let float = mkFloat topDmd False v rhs2@@ -734,7 +722,7 @@ -- 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)+  = assert (isJoinId bndr) $     do { let Just join_arity = isJoinId_maybe bndr              (bndrs, body)   = collectNBinders join_arity rhs @@ -800,7 +788,8 @@        ; return (bind_floats `appendFloats` body_floats, expr') }  cpeRhsE env (Tick tickish expr)-  | tickishPlace tickish == PlaceNonLam && tickish `tickishScopesLike` SoftScope+  -- Pull out ticks if they are allowed to be floated.+  | floatableTick tickish   = do { (floats, body) <- cpeRhsE env expr          -- See [Floating Ticks in CorePrep]        ; return (unitFloat (FloatTick tickish) `appendFloats` floats, body) }@@ -864,7 +853,7 @@                  -- enabled we instead produce an 'error' expression to catch                  -- the case where a function we think should bottom                  -- unexpectedly returns.-               | gopt Opt_CatchBottoms (cpe_dynFlags env)+               | gopt Opt_CatchNonexhaustiveCases (cpe_dynFlags env)                , not (altsAreExhaustive alts)                = addDefault alts (Just err)                | otherwise = alts@@ -954,11 +943,51 @@   ppr (CpeCast co) = text "cast" <+> ppr co   ppr (CpeTick tick) = text "tick" <+> ppr tick +{- Note [Ticks and mandatory eta expansion]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Something like+    `foo x = ({-# SCC foo #-} tagToEnum#) x :: Bool`+caused a compiler panic in #20938. Why did this happen?+The simplifier will eta-reduce the rhs giving us a partial+application of tagToEnum#. The tick is then pushed inside the+type argument. That is we get+    `(Tick<foo> tagToEnum#) @Bool`+CorePrep would go on to see a undersaturated tagToEnum# application+and eta expand the expression under the tick. Giving us:+    (Tick<scc> (\forall a. x -> tagToEnum# @a x) @Bool+Suddenly tagToEnum# is applied to a polymorphic type and the code generator+panics as it needs a concrete type to determine the representation.++The problem in my eyes was that the tick covers a partial application+of a primop. There is no clear semantic for such a construct as we can't+partially apply a primop since they do not have bindings.+We fix this by expanding the scope of such ticks slightly to cover the body+of the eta-expanded expression.++We do this by:+* Checking if an application is headed by a primOpish thing.+* If so we collect floatable ticks and usually but also profiling ticks+  along with regular arguments.+* When rebuilding the application we check if any profiling ticks appear+  before the primop is fully saturated.+* If the primop isn't fully satured we eta expand the primop application+  and scope the tick to scope over the body of the saturated expression.++Going back to #20938 this means starting with+    `(Tick<foo> tagToEnum#) @Bool`+we check if the function head is a primop (yes). This means we collect the+profiling tick like if it was floatable. Giving us+    (tagToEnum#, [CpeTick foo, CpeApp @Bool]).+cpe_app filters out the tick as a underscoped tick on the expression+`tagToEnum# @Bool`. During eta expansion we then put that tick back onto the+body of the eta-expansion lambdas. Giving us `\x -> Tick<foo> (tagToEnum# @Bool x)`.+-} cpeApp :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs) -- May return a CpeRhs because of saturating primops cpeApp top_env expr-  = do { let (terminal, args, depth) = collect_args expr-       ; cpe_app top_env terminal args depth+  = do { let (terminal, args) = collect_args expr+      --  ; pprTraceM "cpeApp" $ (ppr expr)+       ; cpe_app top_env terminal args        }    where@@ -969,26 +998,34 @@     -- record casts and ticks.  Depth counts the number     -- of arguments that would consume strictness information     -- (so, no type or coercion arguments.)-    collect_args :: CoreExpr -> (CoreExpr, [ArgInfo], Int)-    collect_args e = go e [] 0+    collect_args :: CoreExpr -> (CoreExpr, [ArgInfo])+    collect_args e = go e []       where-        go (App fun arg)      as !depth+        go (App fun arg)      as             = go fun (CpeApp arg : as)-                (if isTyCoArg arg then depth else depth + 1)-        go (Cast fun co)      as depth-            = go fun (CpeCast co : as) depth-        go (Tick tickish fun) as depth-            | tickishPlace tickish == PlaceNonLam-            && tickish `tickishScopesLike` SoftScope-            = go fun (CpeTick tickish : as) depth-        go terminal as depth = (terminal, as, depth)+        go (Cast fun co)      as+            = go fun (CpeCast co : as)+        go (Tick tickish fun) as+            -- Profiling ticks are slightly less strict so we expand their scope+            -- if they cover partial applications of things like primOps.+            -- See Note [Ticks and mandatory eta expansion]+            | floatableTick tickish || isProfTick tickish+            , Var vh <- head+            , Var head' <- lookupCorePrepEnv top_env vh+            , hasNoBinding head'+            = (head,as')+            where+              (head,as') = go fun (CpeTick tickish : as) +        -- Terminal could still be an app if it's wrapped by a tick.+        -- E.g. Tick<foo> (f x) can give us (f x) as terminal.+        go terminal as = (terminal, as)+     cpe_app :: CorePrepEnv-            -> CoreExpr+            -> CoreExpr -- The thing we are calling             -> [ArgInfo]-            -> Int             -> UniqSM (Floats, CpeRhs)-    cpe_app env (Var f) (CpeApp Type{} : CpeApp arg : args) depth+    cpe_app env (Var f) (CpeApp Type{} : CpeApp arg : args)         | f `hasKey` lazyIdKey          -- Replace (lazy a) with a, and             -- See Note [lazyId magic] in GHC.Types.Id.Make        || f `hasKey` noinlineIdKey      -- Replace (noinline a) with a@@ -1007,36 +1044,43 @@         --      }         --         -- rather than the far superior "f x y".  Test case is par01.-        = let (terminal, args', depth') = collect_args arg-          in cpe_app env terminal (args' ++ args) (depth + depth' - 1)+        = let (terminal, args') = collect_args arg+          in cpe_app env terminal (args' ++ args) -    cpe_app env (Var f) (CpeApp _runtimeRep@Type{} : CpeApp _type@Type{} : CpeApp arg : rest) n+    -- runRW# magic+    cpe_app env (Var f) (CpeApp _runtimeRep@Type{} : CpeApp _type@Type{} : CpeApp arg : rest)         | f `hasKey` runRWKey         -- N.B. While it may appear that n == 1 in the case of runRW#         -- applications, keep in mind that we may have applications that return-        , n >= 1+        , has_value_arg (CpeApp arg : rest)         -- See Note [runRW magic]         -- Replace (runRW# f) by (f realWorld#), beta reducing if possible (this         -- is why we return a CorePrepEnv as well)         = case arg of-            Lam s body -> cpe_app (extendCorePrepEnv env s realWorldPrimId) body rest (n-2)-            _          -> cpe_app env arg (CpeApp (Var realWorldPrimId) : rest) (n-1)+            Lam s body -> cpe_app (extendCorePrepEnv env s realWorldPrimId) body rest+            _          -> cpe_app env arg (CpeApp (Var realWorldPrimId) : rest)              -- TODO: What about casts?+        where+          has_value_arg [] = False+          has_value_arg (CpeApp arg:_rest)+            | not (isTyCoArg arg) = True+          has_value_arg (_:rest) = has_value_arg rest -    cpe_app env (Var v) args depth+    cpe_app env (Var v) args       = do { v1 <- fiddleCCall v            ; let e2 = lookupCorePrepEnv env v1                  hd = getIdFromTrivialExpr_maybe e2-           -- NB: depth from collect_args is right, because e2 is a trivial expression-           -- and thus its embedded Id *must* be at the same depth as any-           -- Apps it is under are type applications only (c.f.-           -- exprIsTrivial).  But note that we need the type of the-           -- expression, not the id.-           ; (app, floats) <- rebuild_app env args e2 emptyFloats stricts-           ; mb_saturate hd app floats depth }+                 -- 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-          stricts = case idStrictness v of-                            StrictSig (DmdType _ demands _)+          depth = val_args args+          stricts = case idDmdSig v of+                            DmdSig (DmdType _ demands _)                               | listLengthCmp demands depth /= GT -> demands                                     -- length demands <= depth                               | otherwise                         -> []@@ -1048,22 +1092,45 @@          -- 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+    cpe_app env fun [] = cpeRhsE env fun -        -- N-variable fun, better let-bind it-    cpe_app env fun args depth+    -- 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-                          -- The evalDmd says that it's sure to be evaluated,-                          -- so we'll end up case-binding it-           ; (app, floats) <- rebuild_app env args fun' fun_floats []-           ; mb_saturate Nothing app floats depth }+                          -- If evalDmd says that it's sure to be evaluated,+                          -- we'll end up case-binding it+           ; (app, floats,unsat_ticks) <- rebuild_app env args fun' fun_floats [] Nothing+           ; mb_saturate Nothing app floats unsat_ticks (val_args args) } +    -- Count the number of value arguments *and* coercions (since we don't eliminate the later in STG)+    val_args :: [ArgInfo] -> Int+    val_args args = go args 0+      where+        go [] !n = n+        go (info:infos) n =+          case info of+            CpeCast {} -> go infos n+            CpeTick tickish+              | floatableTick tickish                 -> go infos n+              -- If we can't guarantee a tick will be floated out of the application+              -- we can't guarantee the value args following it will be applied.+              | otherwise                             -> n+            CpeApp e                                  -> go infos n'+              where+                !n'+                  | isTypeArg e = n+                  | otherwise   = n+1+     -- Saturate if necessary-    mb_saturate head app floats depth =+    mb_saturate head app floats unsat_ticks depth =        case head of-         Just fn_id -> do { sat_app <- maybeSaturate fn_id app depth+         Just fn_id -> do { sat_app <- maybeSaturate fn_id app depth unsat_ticks                           ; return (floats, sat_app) }-         _other              -> return (floats, 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,@@ -1073,25 +1140,51 @@     rebuild_app         :: CorePrepEnv         -> [ArgInfo]                  -- The arguments (inner to outer)+        -> CpeApp                     -- The function+        -> Floats+        -> [Demand]+        -> Maybe Arity+        -> UniqSM (CpeApp+                  ,Floats+                  ,[CoreTickish] -- Underscoped ticks. See Note [Ticks and mandatory eta expansion]+                  )+    rebuild_app env args app floats ss req_depth =+      rebuild_app' env args app floats ss [] (fromMaybe 0 req_depth)++    rebuild_app'+        :: CorePrepEnv+        -> [ArgInfo] -- The arguments (inner to outer)         -> CpeApp         -> Floats         -> [Demand]-        -> UniqSM (CpeApp, Floats)-    rebuild_app _ [] app floats ss-      = ASSERT(null ss) -- make sure we used all the strictness info-        return (app, floats)+        -> [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 = case a of+    rebuild_app' env (a : as) fun' floats ss rt_ticks req_depth = case a of+      -- See Note [Ticks and mandatory eta expansion]+      _+        | not (null rt_ticks)+        , req_depth <= 0+        ->+            let tick_fun = foldr mkTick fun' rt_ticks+            in rebuild_app' env (a : as) tick_fun floats ss rt_ticks req_depth        CpeApp (Type arg_ty)-        -> rebuild_app env as (App fun' (Type arg_ty')) floats ss+        -> rebuild_app' env as (App fun' (Type arg_ty')) floats ss rt_ticks req_depth         where           arg_ty' = cpSubstTy env arg_ty        CpeApp (Coercion co)-        -> rebuild_app env as (App fun' (Coercion co')) floats ss+        -> rebuild_app' env as (App fun' (Coercion co')) floats ss' rt_ticks req_depth         where             co' = cpSubstCo env co+            ss'+              | null ss = []+              | otherwise = tail ss        CpeApp arg -> do         let (ss1, ss_rest)  -- See Note [lazyId magic] in GHC.Types.Id.Make@@ -1100,16 +1193,21 @@                    (ss1 : ss_rest, False) -> (ss1,    ss_rest)                    ([],            _)     -> (topDmd, [])         (fs, arg') <- cpeArg top_env ss1 arg-        rebuild_app env as (App fun' arg') (fs `appendFloats` floats) ss_rest+        rebuild_app' env as (App fun' arg') (fs `appendFloats` floats) ss_rest rt_ticks (req_depth-1)        CpeCast co-        -> rebuild_app env as (Cast fun' co') floats ss+        -> rebuild_app' env as (Cast fun' co') floats ss rt_ticks req_depth         where            co' = cpSubstCo env co-+      -- See Note [Ticks and mandatory eta expansion]       CpeTick tickish+        | tickishPlace tickish == PlaceRuntime+        , req_depth > 0+        -> assert (isProfTick tickish) $+           rebuild_app' env as fun' floats ss (tickish:rt_ticks) req_depth+        | otherwise         -- See [Floating Ticks in CorePrep]-        -> rebuild_app env as fun' (addFloat floats (FloatTick tickish)) ss+        -> rebuild_app' env as fun' (addFloat floats (FloatTick tickish)) ss rt_ticks req_depth  isLazyExpr :: CoreExpr -> Bool -- See Note [lazyId magic] in GHC.Types.Id.Make@@ -1197,7 +1295,7 @@  The late inlining logic in cpe_app would transform this into: -   (case bot of {}) realWorldPrimId#+   (case bot of {}) realWorld#  Which would rise to a panic in CoreToStg.myCollectArgs, which expects only variables in function position.@@ -1393,8 +1491,9 @@ 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 just-foreign calls and unboxed tuple/sum constructors).+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.@@ -1403,18 +1502,41 @@ with this another way, as described in Note [Primop wrappers] in GHC.Builtin.PrimOps. -} -maybeSaturate :: Id -> CpeApp -> Int -> UniqSM CpeRhs-maybeSaturate fn expr n_args+maybeSaturate :: Id -> CpeApp -> Int -> [CoreTickish] -> UniqSM CpeRhs+maybeSaturate fn expr n_args unsat_ticks   | hasNoBinding fn        -- There's no binding-  = return sat_expr+  = return $ wrapLamBody (\body -> foldr mkTick body unsat_ticks) sat_expr +  | mark_arity > 0 -- A call-by-value function. See Note [CBV Function Ids]+  , not applied_marks+  = assertPpr+      ( not (isJoinId fn)) -- See Note [Do not eta-expand join points]+      ( ppr fn $$ text "expr:" <+> ppr expr $$ text "n_args:" <+> ppr n_args $$+          text "marks:" <+> ppr (idCbvMarks_maybe fn) $$+          text "join_arity" <+> ppr (isJoinId_maybe fn) $$+          text "fn_arity" <+> ppr fn_arity+       ) $+    -- pprTrace "maybeSat"+    --   ( ppr fn $$ text "expr:" <+> ppr expr $$ text "n_args:" <+> ppr n_args $$+    --       text "marks:" <+> ppr (idCbvMarks_maybe fn) $$+    --       text "join_arity" <+> ppr (isJoinId_maybe fn) $$+    --       text "fn_arity" <+> ppr fn_arity $$+    --       text "excess_arity" <+> ppr excess_arity $$+    --       text "mark_arity" <+> ppr mark_arity+    --    ) $+    return sat_expr+   | otherwise-  = return expr+  = assert (null unsat_ticks) $+    return expr   where-    fn_arity     = idArity fn-    excess_arity = fn_arity - n_args-    sat_expr     = cpeEtaExpand excess_arity expr-+    mark_arity    = idCbvMarkArity fn+    fn_arity      = idArity fn+    excess_arity  = (max fn_arity mark_arity) - n_args+    sat_expr      = cpeEtaExpand excess_arity expr+    applied_marks = n_args >= (length . dropWhile (not . isMarkedCbv) . reverse . expectJust "maybeSaturate" $ (idCbvMarks_maybe fn))+    -- For join points we never eta-expand (See Note [Do not eta-expand join points])+    -- so we assert all arguments that need to be passed cbv are visible so that the backend can evalaute them if required.. {- ************************************************************************ *                                                                      *@@ -1494,19 +1616,24 @@   , not (any (`elemVarSet` fvs_remaining) bndrs)   , exprIsHNF remaining_expr   -- Don't turn value into a non-value                                -- else the behaviour with 'seq' changes-  = Just remaining_expr+  =+    -- pprTrace "prep-reduce" (+    --   text "reduced:" <> ppr remaining_expr $$+    --   ppr (remaining_args)+    --   ) $+    Just remaining_expr   where     (f, args) = collectArgs expr     remaining_expr = mkApps f remaining_args     fvs_remaining = exprFreeVars remaining_expr     (remaining_args, last_args) = splitAt n_remaining args     n_remaining = length args - length bndrs+    n_remaining_vals = length $ filter isRuntimeArg remaining_args      ok bndr (Var arg) = bndr == arg     ok _    _         = False -    -- We can't eta reduce something which must be saturated.-    ok_to_eta_reduce (Var f) = not (hasNoBinding f) && not (isLinearType (idType f))+    ok_to_eta_reduce (Var f) = canEtaReduceToArity f n_remaining n_remaining_vals     ok_to_eta_reduce _       = False -- Safe. ToDo: generalise  @@ -1596,7 +1723,7 @@     -- Otherwise we get  case (\x -> e) of ...!    | is_unlifted = FloatCase rhs bndr DEFAULT [] True-      -- we used to ASSERT2(ok_for_spec, ppr rhs) here, but it is now disabled+      -- we used to assertPpr ok_for_spec (ppr rhs) here, but it is now disabled       -- because exprOkForSpeculation isn't stable under ANF-ing. See for       -- example #19489 where the following unlifted expression:       --@@ -1977,7 +2104,7 @@        -- Drop (now-useless) rules/unfoldings        -- See Note [Drop unfoldings and rules]        -- and Note [Preserve evaluatedness] in GHC.Core.Tidy-       ; let unfolding' = zapUnfolding (realIdUnfolding bndr)+       ; let unfolding' = trimUnfolding (realIdUnfolding bndr)                           -- Simplifier will set the Id's unfolding               bndr'' = bndr' `setIdUnfolding`      unfolding'@@ -2040,7 +2167,7 @@ -- --------------------------------------------------------------------------- -- -- 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@@ -2077,7 +2204,7 @@         -- those early, as relying on mkTick to spot it after the fact         -- can yield O(n^3) complexity [#11095]         go (floats, ticks) (FloatTick t)-          = ASSERT(tickishPlace t == PlaceNonLam)+          = assert (tickishPlace t == PlaceNonLam)             (floats, if any (flip tickishContains t) ticks                      then ticks else t:ticks)         go (floats, ticks) f@@ -2090,42 +2217,10 @@         wrapBind t (NonRec binder rhs) = NonRec binder (mkTick t rhs)         wrapBind t (Rec pairs)         = Rec (mapSnd (mkTick t) pairs) ---------------------------------------------------------------------------------- Collecting cost centres--- ------------------------------------------------------------------------------- | Collect cost centres defined in the current module, including those in--- unfoldings.-collectCostCentres :: Module -> CoreProgram -> S.Set CostCentre-collectCostCentres mod_name-  = foldl' go_bind S.empty-  where-    go cs e = case e of-      Var{} -> cs-      Lit{} -> cs-      App e1 e2 -> go (go cs e1) e2-      Lam _ e -> go cs e-      Let b e -> go (go_bind cs b) e-      Case scrt _ _ alts -> go_alts (go cs scrt) alts-      Cast e _ -> go cs e-      Tick (ProfNote cc _ _) e ->-        go (if ccFromThisModule cc mod_name then S.insert cc cs else cs) e-      Tick _ e -> go cs e-      Type{} -> cs-      Coercion{} -> cs--    go_alts = foldl' (\cs (Alt _con _bndrs e) -> go cs e)--    go_bind :: S.Set CostCentre -> CoreBind -> S.Set CostCentre-    go_bind cs (NonRec b e) =-      go (maybe cs (go cs) (get_unf b)) e-    go_bind cs (Rec bs) =-      foldl' (\cs' (b, e) -> go (maybe cs' (go cs') (get_unf b)) e) cs bs--    -- Unfoldings may have cost centres that in the original definion are-    -- optimized away, see #5889.-    get_unf = maybeUnfoldingTemplate . realIdUnfolding-+floatableTick :: GenTickish pass -> Bool+floatableTick tickish =+    tickishPlace tickish == PlaceNonLam &&+    tickish `tickishScopesLike` SoftScope  ------------------------------------------------------------------------------ -- Numeric literals@@ -2159,37 +2254,9 @@     let       convertNumLit nt i = case nt of-         LitNumInteger -> Just (convertInteger i)-         LitNumNatural -> Just (convertNatural i)+         LitNumBigNat  -> Just (convertBignatPrim i)          _             -> Nothing -      convertInteger i-         | platformInIntRange platform i -- fit in a Int#-         = mkConApp integerISDataCon [Lit (mkLitInt platform i)]--         | otherwise -- build a BigNat and embed into IN or IP-         = let con = if i > 0 then integerIPDataCon else integerINDataCon-           in mkBigNum con (convertBignatPrim (abs i))--      convertNatural i-         | platformInWordRange platform i -- fit in a Word#-         = mkConApp naturalNSDataCon [Lit (mkLitWord platform i)]--         | otherwise --build a BigNat and embed into NB-         = mkBigNum naturalNBDataCon (convertBignatPrim i)--      -- we can't simply generate:-      ---      --    NB (bigNatFromWordList# [W# 10, W# 20])-      ---      -- using `mkConApp` because it isn't in ANF form. Instead we generate:-      ---      --    case bigNatFromWordList# [W# 10, W# 20] of ba { DEFAULT -> NB ba }-      ---      -- via `mkCoreApps`--      mkBigNum con ba = mkCoreApps (Var (dataConWorkId con)) [ba]-       convertBignatPrim i =          let             target    = targetPlatform dflags@@ -2216,3 +2283,4 @@      return convertNumLit+
GHC/Data/Bag.hs view
@@ -6,7 +6,7 @@ Bag: an unordered collection with duplicates -} -{-# LANGUAGE ScopedTypeVariables, CPP, DeriveFunctor, TypeFamilies #-}+{-# LANGUAGE ScopedTypeVariables, DeriveFunctor, TypeFamilies #-}  module GHC.Data.Bag (         Bag, -- abstract type@@ -17,7 +17,7 @@         filterBag, partitionBag, partitionBagWith,         concatBag, catBagMaybes, foldBag,         isEmptyBag, isSingletonBag, consBag, snocBag, anyBag, allBag,-        listToBag, nonEmptyToBag, bagToList, mapAccumBagL,+        listToBag, nonEmptyToBag, bagToList, headMaybe, mapAccumBagL,         concatMapBag, concatMapBagPair, mapMaybeBag,         mapBagM, mapBagM_,         flatMapBagM, flatMapBagPairM,@@ -33,10 +33,11 @@ import GHC.Utils.Monad import Control.Monad import Data.Data-import Data.Maybe( mapMaybe )+import Data.Maybe( mapMaybe, listToMaybe ) import Data.List ( partition, mapAccumL ) import Data.List.NonEmpty ( NonEmpty(..) ) import qualified Data.Foldable as Foldable+import qualified Data.Semigroup ( (<>) )  infixr 3 `consBag` infixl 3 `snocBag`@@ -84,7 +85,7 @@  isEmptyBag :: Bag a -> Bool isEmptyBag EmptyBag = True-isEmptyBag _        = False -- NB invariants+isEmptyBag _ = False  isSingletonBag :: Bag a -> Bool isSingletonBag EmptyBag      = False@@ -145,7 +146,7 @@     add Nothing rs = rs     add (Just x) rs = x `consBag` rs -partitionBag :: (a -> Bool) -> Bag a -> (Bag a {- Satisfy predictate -},+partitionBag :: (a -> Bool) -> Bag a -> (Bag a {- Satisfy predicate -},                                          Bag a {- Don't -}) partitionBag _    EmptyBag = (EmptyBag, EmptyBag) partitionBag pred b@(UnitBag val)@@ -307,6 +308,12 @@ bagToList :: Bag a -> [a] bagToList b = foldr (:) [] b +headMaybe :: Bag a -> Maybe a+headMaybe EmptyBag = Nothing+headMaybe (UnitBag v) = Just v+headMaybe (TwoBags b1 _) = headMaybe b1+headMaybe (ListBag l) = listToMaybe l+ instance (Outputable a) => Outputable (Bag a) where     ppr bag = braces (pprWithCommas ppr (bagToList bag)) @@ -343,3 +350,9 @@   type Item (Bag a) = a   fromList = listToBag   toList   = bagToList++instance Semigroup (Bag a) where+  (<>) = unionBags++instance Monoid (Bag a) where+  mempty = emptyBag
+ GHC/Data/Bool.hs view
@@ -0,0 +1,25 @@+module GHC.Data.Bool+  ( OverridingBool(..)+  , overrideWith+  )+where++import GHC.Prelude++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/EnumSet.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | A tiny wrapper around 'IntSet.IntSet' for representing sets of 'Enum' -- things. module GHC.Data.EnumSet@@ -12,10 +14,12 @@     ) where  import GHC.Prelude+import GHC.Utils.Binary  import qualified Data.IntSet as IntSet  newtype EnumSet a = EnumSet IntSet.IntSet+  deriving (Semigroup, Monoid)  member :: Enum a => a -> EnumSet a -> Bool member x (EnumSet s) = IntSet.member (fromEnum x) s@@ -37,3 +41,30 @@  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/FastString.hs view
@@ -1,8 +1,7 @@--- (c) The University of Glasgow, 1997-2006- {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedTuples #-}@@ -31,7 +30,8 @@ --   * Pointer and size of a Latin-1 encoded string. --   * Practically no operations. --   * Outputting them is fast.---   * Generated by 'sLit'.+--   * 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.@@ -101,7 +101,6 @@         PtrString (..),          -- ** Construction-        sLit,         mkPtrString#,         mkPtrString, @@ -112,8 +111,6 @@         lengthPS        ) where -#include "HsVersions.h"- import GHC.Prelude as Prelude  import GHC.Utils.Encoding@@ -143,7 +140,7 @@  import Foreign -#if GHC_STAGE >= 2+#if MIN_VERSION_GLASGOW_HASKELL(9,3,0,0) import GHC.Conc.Sync    (sharedCAF) #endif @@ -155,10 +152,11 @@  -- | Gives the Modified UTF-8 encoded bytes corresponding to a 'FastString' bytesFS, fastStringToByteString :: FastString -> ByteString-bytesFS = fastStringToByteString+{-# INLINE[1] bytesFS #-}+bytesFS f = SBS.fromShort $ fs_sbs f  {-# DEPRECATED fastStringToByteString "Use `bytesFS` instead" #-}-fastStringToByteString f = SBS.fromShort $ fs_sbs f+fastStringToByteString = bytesFS  fastStringToShortByteString :: FastString -> ShortByteString fastStringToShortByteString = fs_sbs@@ -266,14 +264,12 @@ -- is not deterministic from one run to the other. newtype NonDetFastString    = NonDetFastString FastString-   deriving (Eq,Data)+   deriving newtype (Eq, Show)+   deriving stock Data  instance Ord NonDetFastString where    compare (NonDetFastString fs1) (NonDetFastString fs2) = uniqCompareFS fs1 fs2 -instance Show NonDetFastString where-   show (NonDetFastString fs) = show fs- -- | Lexical FastString -- -- This is a simple FastString wrapper with an Ord instance using@@ -281,14 +277,12 @@ -- representation). Hence it is deterministic from one run to the other. newtype LexicalFastString    = LexicalFastString FastString-   deriving (Eq,Data)+   deriving newtype (Eq, Show)+   deriving stock Data  instance Ord LexicalFastString where    compare (LexicalFastString fs1) (LexicalFastString fs2) = lexicalCompareFS fs1 fs2 -instance Show LexicalFastString where-   show (LexicalFastString fs) = show fs- -- ----------------------------------------------------------------------------- -- Construction @@ -387,13 +381,14 @@    -- use the support wired into the RTS to share this CAF among all images of   -- libHSghc-#if GHC_STAGE < 2+#if !MIN_VERSION_GLASGOW_HASKELL(9,3,0,0)   return tab #else   sharedCAF tab getOrSetLibHSghcFastStringTable --- from the RTS; thus we cannot use this mechanism when GHC_STAGE<2; the previous--- RTS might not have this symbol+-- from the 9.3 RTS; the previouss 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) #endif@@ -435,7 +430,7 @@   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@@ -533,11 +528,17 @@  -- | Creates a UTF-8 encoded 'FastString' from a 'String' mkFastString :: String -> FastString+{-# NOINLINE[1] mkFastString #-} mkFastString str =   inlinePerformIO $ do     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) = utf8EncodeString x #-}+ -- | Creates a 'FastString' from a UTF-8 encoded @[Word8]@ mkFastStringByteList :: [Word8] -> FastString mkFastStringByteList str = mkFastStringShortByteString (SBS.pack str)@@ -602,8 +603,8 @@ zEncodeFS fs = fs_zenc fs  appendFS :: FastString -> FastString -> FastString-appendFS fs1 fs2 = mkFastStringByteString-                 $ BS.append (bytesFS fs1) (bytesFS fs2)+appendFS fs1 fs2 = mkFastStringShortByteString+                 $ (Semi.<>) (fs_sbs fs1) (fs_sbs fs2)  concatFS :: [FastString] -> FastString concatFS = mkFastStringShortByteString . mconcat . map fs_sbs@@ -675,7 +676,7 @@ -- | Encode a 'String' into a newly allocated 'PtrString' using Latin-1 -- encoding.  The original string must not contain non-Latin-1 characters -- (above codepoint @0xff@).-{-# INLINE mkPtrString #-}+{-# NOINLINE[0] mkPtrString #-} -- see rules below mkPtrString :: String -> PtrString mkPtrString s =  -- we don't use `unsafeDupablePerformIO` here to avoid potential memory leaks@@ -693,6 +694,9 @@    return (PtrString p len)  ) +{-# RULES "mkPtrString"+    forall x . mkPtrString (unpackCString# x) = mkPtrString#  x #-}+ -- | Decode a 'PtrString' back into a 'String' using Latin-1 encoding. -- This does not free the memory associated with 'PtrString'. unpackPtrString :: PtrString -> String@@ -714,15 +718,9 @@ {-# INLINE ptrStrLength #-} ptrStrLength (Ptr a) = I# (cstringLength# a) -{-# NOINLINE sLit #-}-sLit :: String -> PtrString-sLit x  = mkPtrString x- {-# NOINLINE fsLit #-} fsLit :: String -> FastString fsLit x = mkFastString x -{-# RULES "slit"-    forall x . sLit  (unpackCString# x) = mkPtrString#  x #-} {-# RULES "fslit"     forall x . fsLit (unpackCString# x) = mkFastString# x #-}
GHC/Data/Graph/Base.hs view
@@ -42,7 +42,7 @@ --      There used to be more fields, but they were turfed out in a previous revision. --      maybe we'll want more later.. ---data Graph k cls color+newtype Graph k cls color         = Graph {         -- | All active nodes in the graph.           graphMap              :: UniqFM k (Node k cls color)  }
GHC/Data/Graph/Color.hs view
@@ -268,9 +268,9 @@ 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.+ 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])@@ -303,9 +303,9 @@ 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.+        => 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
GHC/Data/Graph/Directed.hs view
@@ -1,6 +1,6 @@ -- (c) The University of Glasgow 2006 -{-# LANGUAGE CPP #-}+ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-}@@ -12,7 +12,7 @@         stronglyConnCompG,         topologicalSortG,         verticesG, edgesG, hasVertexG,-        reachableG, reachablesG, transposeG,+        reachableG, reachablesG, transposeG, allReachable, outgoingG,         emptyG,          findCycle,@@ -25,9 +25,7 @@          -- Simple way to classify edges         EdgeType(..), classifyEdges-    ) where--#include "HsVersions.h"+        ) where  ------------------------------------------------------------------------------ -- A version of the graph algorithms described in:@@ -63,6 +61,10 @@ import Data.Tree import GHC.Types.Unique import GHC.Types.Unique.FM+import qualified Data.IntMap as IM+import qualified Data.IntSet as IS+import qualified Data.Map as M+import qualified Data.Set as S  {- ************************************************************************@@ -108,7 +110,7 @@   }  -instance (Outputable a, Outputable b) => Outputable (Node  a b) where+instance (Outputable a, Outputable b) => Outputable (Node a b) where   ppr (DigraphNode a b c) = ppr (a, b, c)  emptyGraph :: Graph a@@ -361,6 +363,11 @@   where from_vertex = expectJust "reachableG" (gr_node_to_vertex graph from)         result = {-# SCC "Digraph.reachable" #-} reachable (gr_int_graph graph) [from_vertex] +outgoingG :: Graph node -> node -> [node]+outgoingG graph from = map (gr_vertex_to_node graph) result+  where from_vertex = expectJust "reachableG" (gr_node_to_vertex graph from)+        result = gr_int_graph graph ! from_vertex+ -- | Given a list of roots return all reachable nodes. reachablesG :: Graph node -> [node] -> [node] reachablesG graph froms = map (gr_vertex_to_node graph) result@@ -368,6 +375,15 @@                  reachable (gr_int_graph graph) vs         vs = [ v | Just v <- map (gr_node_to_vertex graph) froms ] +-- | Efficiently construct a map which maps each key to it's set of transitive+-- dependencies.+allReachable :: Ord key => Graph node -> (node -> key) -> M.Map key (S.Set key)+allReachable (Graph g from _) conv =+  M.fromList [(conv (from v), IS.foldr (\k vs -> conv (from k) `S.insert` vs) S.empty vs)+             | (v, vs) <- IM.toList int_graph]+  where+    int_graph = reachableGraph g+ hasVertexG :: Graph node -> node -> Bool hasVertexG graph node = isJust $ gr_node_to_vertex graph node @@ -436,6 +452,12 @@ -- This generalizes reachable which was found in Data.Graph reachable    :: IntGraph -> [Vertex] -> [Vertex] reachable g vs = preorderF (dfs g vs)++reachableGraph :: IntGraph -> IM.IntMap IS.IntSet+reachableGraph g = res+  where+    do_one v = IS.unions (IS.fromList (g ! v) : mapMaybe (flip IM.lookup res) (g ! v))+    res = IM.fromList [(v, do_one v) | v <- vertices g]  {- ************************************************************************
GHC/Data/IOEnv.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE DerivingVia #-} {-# LANGUAGE PatternSynonyms #-} --@@ -36,6 +36,7 @@  import GHC.Driver.Session import {-# SOURCE #-} GHC.Driver.Hooks+import GHC.IO (catchException) import GHC.Utils.Exception import GHC.Unit.Module import GHC.Utils.Panic@@ -62,6 +63,7 @@ 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)@@ -183,7 +185,7 @@     -- 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)-      `catch` \(e :: SomeException) -> do+      `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
GHC/Data/List/SetOps.hs view
@@ -1,11 +1,13 @@+{-# LANGUAGE CPP #-}+ {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998  -} -{-# LANGUAGE CPP #-} + -- | Set-like operations on lists -- -- Avoid using them as much as possible@@ -16,21 +18,22 @@         Assoc, assoc, assocMaybe, assocUsing, assocDefault, assocDefaultUsing,          -- Duplicate handling-        hasNoDups, removeDups, findDupsEq,+        hasNoDups, removeDups, nubOrdBy, findDupsEq,         equivClasses,          -- Indexing-        getNth-   ) where+        getNth, -#include "HsVersions.h"+        -- Membership+        isIn, isn'tIn,+   ) where  import GHC.Prelude  import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Misc-import GHC.Driver.Ppr+import GHC.Utils.Trace  import qualified Data.List as L import qualified Data.List.NonEmpty as NE@@ -38,7 +41,7 @@ import qualified Data.Set as S  getNth :: Outputable a => [a] -> Int -> a-getNth xs n = ASSERT2( xs `lengthExceeds` n, ppr n $$ ppr xs )+getNth xs n = assertPpr (xs `lengthExceeds` n) (ppr n $$ ppr xs) $              xs !! n  {-@@ -63,7 +66,7 @@   | isIn "unionLists" y xs = xs   | otherwise = y:xs unionLists xs ys-  = WARN(lengthExceeds xs 100 || lengthExceeds ys 100, ppr xs $$ ppr 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@@ -157,6 +160,11 @@   where     eq a b = case cmp a b of { EQ -> True; _ -> False } +-- | Remove the duplicates from a list using the provided+-- comparison function.+--+-- 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@@ -173,8 +181,41 @@     collect_dups dups_so_far (x :| [])     = (dups_so_far,      x)     collect_dups dups_so_far dups@(x :| _) = (dups:dups_so_far, 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
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE KindSignatures #-}@@ -26,10 +26,11 @@     ) where  import GHC.Prelude+import GHC.IO (catchException)  import Control.Monad import Control.Monad.Trans.Maybe-import Control.Exception (catch, SomeException(..))+import Control.Exception (SomeException(..)) import Data.Maybe import Data.Foldable ( foldlM ) import GHC.Utils.Misc (HasCallStack)@@ -96,7 +97,7 @@  -- | Try performing an 'IO' action, failing on error. tryMaybeT :: IO a -> MaybeT IO a-tryMaybeT action = MaybeT $ catch (Just `fmap` action) handler+tryMaybeT action = MaybeT $ catchException (Just `fmap` action) handler   where     handler (SomeException _) = return Nothing
GHC/Data/Pair.hs view
@@ -3,7 +3,7 @@ Traversable instances. -} -{-# LANGUAGE CPP #-}+ {-# LANGUAGE DeriveFunctor #-}  module GHC.Data.Pair@@ -15,8 +15,6 @@    , pLiftSnd    ) where--#include "HsVersions.h"  import GHC.Prelude
+ GHC/Data/SmallArray.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE BlockArguments #-}++-- | Small-array+module GHC.Data.SmallArray+  ( SmallMutableArray (..)+  , SmallArray (..)+  , newSmallArray+  , writeSmallArray+  , freezeSmallArray+  , unsafeFreezeSmallArray+  , indexSmallArray+  , listToArray+  )+where++import GHC.Exts+import GHC.Prelude+import GHC.ST++data SmallArray a = SmallArray (SmallArray# a)++data SmallMutableArray s a = SmallMutableArray (SmallMutableArray# s 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 #)++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+++-- | 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 #)+++-- | 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+++-- | 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/Strict.hs view
@@ -0,0 +1,67 @@+-- 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,+    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++data Maybe a = Nothing | Just !a+  deriving (Eq, Ord, Show, Functor, Foldable, Traversable, Data)++fromMaybe :: a -> Maybe a -> a+fromMaybe d Nothing = d+fromMaybe _ (Just x) = 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
@@ -26,12 +26,14 @@         hPutStringBuffer,         appendStringBuffers,         stringToStringBuffer,+        stringBufferFromByteString,          -- * Inspection         nextChar,         currentChar,         prevChar,         atEnd,+        fingerprintStringBuffer,          -- * Moving and comparison         stepOn,@@ -52,23 +54,25 @@         bidirectionalFormatChars         ) where -#include "HsVersions.h"- import GHC.Prelude -import GHC.Utils.Encoding import GHC.Data.FastString+import GHC.Utils.Encoding import GHC.Utils.IO.Unsafe import GHC.Utils.Panic.Plain-import GHC.Utils.Misc+import GHC.Utils.Exception      ( bracket_ )+import GHC.Fingerprint  import Data.Maybe-import Control.Exception 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@@ -154,7 +158,7 @@   if size > 0 && offset == 0     then do       -- Validate assumption that handle is in binary mode.-      ASSERTM( hGetEncoding h >>= return . isNothing )+      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@@ -200,6 +204,15 @@     -- 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 @@ -314,6 +327,13 @@ -- | 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.
GHC/Driver/Backend.hs view
@@ -103,7 +103,6 @@          ArchX86_64    -> True          ArchPPC       -> True          ArchPPC_64 {} -> True-         ArchSPARC     -> True          ArchAArch64   -> True          _             -> False
GHC/Driver/Backpack.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE OverloadedStrings #-}@@ -18,13 +18,13 @@  module GHC.Driver.Backpack (doBackpack) where -#include "HsVersions.h"- import GHC.Prelude  -- In a separate module because it hooks into the parser. import GHC.Driver.Backpack.Syntax-import GHC.Driver.Config+import GHC.Driver.Config.Finder (initFinderOpts)+import GHC.Driver.Config.Parser (initParserOpts)+import GHC.Driver.Config.Diagnostic import GHC.Driver.Monad import GHC.Driver.Session import GHC.Driver.Ppr@@ -32,13 +32,15 @@ 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.Parser.Errors.Ppr +import GHC.Rename.Names+ import GHC hiding (Failed, Succeeded) import GHC.Tc.Utils.Monad import GHC.Iface.Recomp@@ -46,13 +48,13 @@  import GHC.Types.SrcLoc import GHC.Types.SourceError-import GHC.Types.SourceText import GHC.Types.SourceFile import GHC.Types.Unique.FM import GHC.Types.Unique.DFM import GHC.Types.Unique.DSet  import GHC.Utils.Outputable+import GHC.Utils.Fingerprint import GHC.Utils.Misc import GHC.Utils.Panic import GHC.Utils.Error@@ -61,7 +63,6 @@ import GHC.Unit import GHC.Unit.Env import GHC.Unit.External-import GHC.Unit.State import GHC.Unit.Finder import GHC.Unit.Module.Graph import GHC.Unit.Module.ModSummary@@ -92,23 +93,26 @@ -- | Entry point to compile a Backpack file. doBackpack :: [FilePath] -> Ghc () doBackpack [src_filename] = do-    logger <- getLogger-     -- Apply options from file to dflags     dflags0 <- getDynFlags     let dflags1 = dflags0-    src_opts <- liftIO $ getOptionsFromFile dflags1 src_filename+    let parser_opts1 = initParserOpts dflags1+    (p_warns, src_opts) <- liftIO $ getOptionsFromFile parser_opts1 src_filename     (dflags, unhandled_flags, warns) <- liftIO $ parseDynamicFilePragma dflags1 src_opts-    modifySession (\hsc_env -> hsc_env {hsc_dflags = dflags})+    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-    liftIO $ handleFlagWarnings logger dflags warns+    liftIO $ printOrThrowDiagnostics logger (initDiagOpts dflags) (GhcPsMessage <$> p_warns)+    liftIO $ handleFlagWarnings logger (initDiagOpts dflags) warns     -- TODO: Preprocessing not implemented      buf <- liftIO $ hGetStringBuffer src_filename     let loc = mkRealSrcLoc (mkFastString src_filename) 1 1 -- TODO: not great     case unP parseBackpack (initParserState (initParserOpts dflags) buf loc) of-        PFailed pst -> throwErrors (fmap pprError (getErrorMessages pst))+        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.@@ -121,14 +125,14 @@                     innerBkpM $ do                         let (cid, insts) = computeUnitId lunit                         if null insts-                            then if cid == Indefinite (UnitId (fsLit "main"))+                            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 -> (IndefUnitId, [(ModuleName, Module)])+computeUnitId :: LHsUnit HsComponentId -> (UnitId, [(ModuleName, Module)]) computeUnitId (L _ unit) = (cid, [ (r, mkHoleModule r) | r <- reqs ])   where     cid = hsComponentId (unLoc (hsunitName unit))@@ -154,7 +158,7 @@  -- | Create a temporary Session to do some sort of type checking or -- compilation.-withBkpSession :: IndefUnitId+withBkpSession :: UnitId                -> [(ModuleName, Module)]                -> [(Unit, ModRenaming)]                -> SessionType   -- what kind of session are we doing@@ -162,7 +166,7 @@                -> BkpM a withBkpSession cid insts deps session_type do_this = do     dflags <- getDynFlags-    let cid_fs = unitFS (indefUnit cid)+    let cid_fs = unitFS cid         is_primary = False         uid_str = unpackFS (mkInstantiatedUnitHash cid insts)         cid_str = unpackFS cid_fs@@ -180,18 +184,20 @@                  , not (null insts) = sub_comp (key_base p) </> uid_str                  | otherwise = sub_comp (key_base p) -        mk_temp_env hsc_env = hsc_env-            { hsc_dflags   = mk_temp_dflags (hsc_units hsc_env) (hsc_dflags hsc_env)-            }+        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 (indefUnit cid)+            , homeUnitInstanceOf_   = if null insts then Nothing else Just cid             , homeUnitId_ = case session_type of                 TcSession -> newUnitId cid Nothing                 -- No hash passed if no instances@@ -243,21 +249,21 @@  withBkpExeSession :: [(Unit, ModRenaming)] -> BkpM a -> BkpM a withBkpExeSession deps do_this =-    withBkpSession (Indefinite (UnitId (fsLit "main"))) [] deps ExeSession do_this+    withBkpSession (UnitId (fsLit "main")) [] deps ExeSession do_this -getSource :: IndefUnitId -> BkpM (LHsUnit HsComponentId)+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 :: IndefUnitId -> [(ModuleName, Module)] -> BkpM ()+typecheckUnit :: UnitId -> [(ModuleName, Module)] -> BkpM () typecheckUnit cid insts = do     lunit <- getSource cid     buildUnit TcSession cid insts lunit -compileUnit :: IndefUnitId -> [(ModuleName, Module)] -> BkpM ()+compileUnit :: UnitId -> [(ModuleName, Module)] -> BkpM () compileUnit cid insts = do     -- Let everyone know we're building this unit     msgUnitId (mkVirtUnit cid insts)@@ -285,7 +291,7 @@             convRn (L _ (Renaming (L _ from) (Just (L _ to)))) = (from, to)     get_dep _ = [] -buildUnit :: SessionType -> IndefUnitId -> [(ModuleName, Module)] -> LHsUnit HsComponentId -> BkpM ()+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@@ -318,10 +324,10 @@     conf <- withBkpSession cid insts deps_w_rns session $ do          dflags <- getDynFlags-        mod_graph <- hsunitModuleGraph (unLoc lunit)+        mod_graph <- hsunitModuleGraph False (unLoc lunit)          msg <- mkBackpackMsg-        ok <- load' LoadAllTargets (Just msg) mod_graph+        ok <- load' noIfaceCache LoadAllTargets (Just msg) mod_graph         when (failed ok) (liftIO $ exitWith (ExitFailure 1))          let hi_dir = expectJust (panic "hiDir Backpack") $ hiDir dflags@@ -336,11 +342,11 @@             linkables = map (expectJust "bkp link" . hm_linkable)                       . filter ((==HsSrcFile) . mi_hsc_src . hm_iface)                       $ home_mod_infos-            getOfiles (LM _ _ us) = map nameOfObject (filter isObject us)+            getOfiles LM{ linkableUnlinked = us } = map nameOfObject (filter isObject us)             obj_files = concatMap getOfiles linkables             state     = hsc_units hsc_env -        let compat_fs = unitIdFS (indefUnit cid)+        let compat_fs = unitIdFS cid             compat_pn = PackageName compat_fs             unit_id   = homeUnitId (hsc_home_unit hsc_env) @@ -408,9 +414,9 @@     forM_ (zip [1..] deps) $ \(i, dep) ->         compileInclude (length deps) (i, dep)     withBkpExeSession deps_w_rns $ do-        mod_graph <- hsunitModuleGraph (unLoc lunit)+        mod_graph <- hsunitModuleGraph True (unLoc lunit)         msg <- mkBackpackMsg-        ok <- load' LoadAllTargets (Just msg) mod_graph+        ok <- load' noIfaceCache LoadAllTargets (Just msg) mod_graph         when (failed ok) (liftIO $ exitWith (ExitFailure 1))  -- | Register a new virtual unit database containing a single unit@@ -419,7 +425,8 @@     hsc_env <- getSession     logger <- getLogger     let dflags0 = hsc_dflags hsc_env-    newdbs <- case hsc_unit_dbs hsc_env of+    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@@ -427,22 +434,23 @@                , 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)+    (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+    let unit_env = ue_setUnits unit_state $ ue_setUnitDbs (Just dbs) $ UnitEnv           { ue_platform  = targetPlatform dflags           , ue_namever   = ghcNameVersion dflags-          , ue_home_unit = home_unit-          , ue_units     = unit_state+          , ue_current_unit = homeUnitId home_unit++          , ue_home_unit_graph =+                unitEnv_singleton+                    (homeUnitId home_unit)+                    (mkHomeUnitEnv dflags (ue_hpt old_unit_env) (Just home_unit))+          , ue_eps       = ue_eps old_unit_env           }-    setSession $ hsc_env-        { hsc_unit_dbs = Just dbs-        , hsc_dflags   = dflags-        , hsc_unit_env = unit_env-        }+    setSession $ hscSetFlags dflags $ hsc_env { hsc_unit_env = unit_env }  compileInclude :: Int -> (Int, Unit) -> BkpM () compileInclude n (i, uid) = do@@ -473,7 +481,7 @@         -- | 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 IndefUnitId (LHsUnit HsComponentId),+        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.@@ -515,13 +523,13 @@ updateEpsGhc_ :: GhcMonad m => (ExternalPackageState -> ExternalPackageState) -> m () updateEpsGhc_ f = do     hsc_env <- getSession-    liftIO $ atomicModifyIORef' (hsc_EPS hsc_env) (\x -> (f x, ()))+    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 $ readIORef (hsc_EPS hsc_env)+    liftIO $ hscEPS hsc_env  -- | Run 'BkpM' in 'Ghc'. initBkpM :: FilePath -> [LHsUnit HsComponentId] -> BkpM a -> Ghc a@@ -540,10 +548,10 @@  -- | Print a compilation progress message, but with indentation according -- to @level@ (for nested compilation).-backpackProgressMsg :: Int -> Logger -> DynFlags -> SDoc -> IO ()-backpackProgressMsg level logger dflags msg =-    compilationProgressMsg logger dflags $ text (replicate (level * 2) ' ') -- TODO: use GHC.Utils.Ppr.RStr-                                      <> msg+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@@ -556,25 +564,28 @@           logger = hsc_logger hsc_env           state = hsc_units hsc_env           showMsg msg reason =-            backpackProgressMsg level logger dflags $ pprWithUnitState state $+            backpackProgressMsg level logger $ pprWithUnitState state $                 showModuleIndex mod_index <>                 msg <> showModMsg dflags (recompileRequired recomp) node                     <> reason       in case node of-        InstantiationNode _ ->+        InstantiationNode _ _ ->           case recomp of-            MustCompile -> showMsg (text "Instantiating ") empty             UpToDate               | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg (text "Skipping  ") empty               | otherwise -> return ()-            RecompBecause reason -> showMsg (text "Instantiating ") (text " [" <> text reason <> text "]")-        ModuleNode _ ->+            NeedsRecompile reason0 -> showMsg (text "Instantiating ") $ case reason0 of+              MustCompile -> empty+              RecompBecause reason -> text " [" <> pprWithUnitState state (ppr reason) <> text "]"+        ModuleNode _ _ ->           case recomp of-            MustCompile -> showMsg (text "Compiling ") empty             UpToDate               | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg (text "Skipping  ") empty               | otherwise -> return ()-            RecompBecause reason -> showMsg (text "Compiling ") (text " [" <> text reason <> text "]")+            NeedsRecompile reason0 -> showMsg (text "Compiling ") $ case reason0 of+              MustCompile -> empty+              RecompBecause reason -> text " [" <> pprWithUnitState state (ppr reason) <> text "]"+        LinkNode _ _ -> showMsg (text "Linking ")  empty  -- | 'PprStyle' for Backpack messages; here we usually want the module to -- be qualified (so we can tell how it was instantiated.) But we try not@@ -589,21 +600,19 @@ -- | Message when we initially process a Backpack unit. msgTopPackage :: (Int,Int) -> HsComponentId -> BkpM () msgTopPackage (i,n) (HsComponentId (PackageName fs_pn) _) = do-    dflags <- getDynFlags     logger <- getLogger     level <- getBkpLevel-    liftIO . backpackProgressMsg level logger dflags+    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-    dflags <- getDynFlags     logger <- getLogger     hsc_env <- getSession     level <- getBkpLevel     let state = hsc_units hsc_env-    liftIO . backpackProgressMsg level logger dflags+    liftIO . backpackProgressMsg level logger         $ pprWithUnitState state         $ text "Instantiating "            <> withPprStyle backpackStyle (ppr pk)@@ -611,12 +620,11 @@ -- | Message when we include a Backpack unit. msgInclude :: (Int,Int) -> Unit -> BkpM () msgInclude (i,n) uid = do-    dflags <- getDynFlags     logger <- getLogger     hsc_env <- getSession     level <- getBkpLevel     let state = hsc_units hsc_env-    liftIO . backpackProgressMsg level logger dflags+    liftIO . backpackProgressMsg level logger         $ pprWithUnitState state         $ showModuleIndex (i, n) <> text "Including "             <> withPprStyle backpackStyle (ppr uid)@@ -630,7 +638,7 @@ -- to use this for anything unitDefines :: LHsUnit PackageName -> (PackageName, HsComponentId) unitDefines (L _ HsUnit{ hsunitName = L _ pn@(PackageName fs) })-    = (pn, HsComponentId pn (Indefinite (UnitId fs)))+    = (pn, HsComponentId pn (UnitId fs))  bkpPackageNameMap :: [LHsUnit PackageName] -> PackageNameMap HsComponentId bkpPackageNameMap units = listToUFM (map unitDefines units)@@ -706,69 +714,84 @@ -- -- We don't bother trying to support GHC.Driver.Make for now, it's more trouble -- than it's worth for inline modules.-hsunitModuleGraph :: HsUnit HsComponentId -> BkpM ModuleGraph-hsunitModuleGraph unit = do+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 mb_hsmod)) =-          Just `fmap` summariseDecl pn hsc_src lmodname mb_hsmod+    let get_decl (L _ (DeclD hsc_src lmodname hsmod)) =+          Just <$> summariseDecl pn hsc_src lmodname hsmod (keys ++ sig_keys)         get_decl _ = return Nothing-    nodes <- catMaybes `fmap` mapM get_decl decls+    nodes <- mapMaybeM get_decl decls      --  2. For each hole which does not already have an hsig file,     --  create an "empty" hsig file to induce compilation for the     --  requirement.     let hsig_set = Set.fromList           [ ms_mod_name ms-          | ExtendedModSummary { emsModSummary = ms } <- nodes+          | ModuleNode _ ms <- nodes           , ms_hsc_src ms == HsigFile           ]     req_nodes <- fmap catMaybes . forM (homeUnitInstantiations home_unit) $ \(mod_name, _) ->         if Set.member mod_name hsig_set             then return Nothing-            else fmap (Just . extendModSummaryNoDeps) $ summariseRequirement pn mod_name-            -- Using extendModSummaryNoDeps here is okay because we're making a leaf node-            -- representing a signature that can't depend on any other unit.+            else fmap Just $ summariseRequirement pn mod_name +    let graph_nodes = nodes ++ req_nodes ++ (instantiationNodes (homeUnitId $ hsc_home_unit hsc_env) (hsc_units hsc_env))+        key_nodes = map mkNodeKey graph_nodes+        all_nodes = graph_nodes ++ [LinkNode key_nodes (homeUnitId $ hsc_home_unit hsc_env) | do_link]+    -- This error message is not very good but .bkp mode is just for testing so+    -- better to be direct rather than pretty.+    when+      (length key_nodes /= length (ordNub key_nodes))+      (pprPanic "Duplicate nodes keys in backpack file" (ppr key_nodes))+     -- 3. Return the kaboodle-    return $ mkModuleGraph' $-      (ModuleNode <$> (nodes ++ req_nodes)) ++ instantiationNodes (hsc_units hsc_env)+    return $ mkModuleGraph $ all_nodes -summariseRequirement :: PackageName -> ModuleName -> BkpM ModSummary++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-    location <- liftIO $ mkHomeModLocation2 dflags mod_name-                 (unpackFS pn_fs </> moduleNameSlashes mod_name) "hsig"+    let location = mkHomeModLocation2 fopts mod_name+                    (unpackFS pn_fs </> moduleNameSlashes mod_name) "hsig"      env <- getBkpEnv-    time <- liftIO $ getModificationUTCTime (bkp_filename env)+    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) -    mod <- liftIO $ addHomeModuleToFinder hsc_env mod_name location+    let fc = hsc_FC hsc_env+    mod <- liftIO $ addHomeModuleToFinder fc home_unit mod_name location      extra_sig_imports <- liftIO $ findExtraSigImports hsc_env HsigFile mod_name -    return ModSummary {+    let ms = ModSummary {         ms_mod = mod,         ms_hsc_src = HsigFile,         ms_location = location,-        ms_hs_date = time,+        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 = extra_sig_imports,+        ms_textual_imps = ((,) NoPkgQual . noLoc) <$> extra_sig_imports,+        ms_ghc_prim_import = False,         ms_parsed_mod = Just (HsParsedModule {                 hpm_module = L loc (HsModule {                         hsmodAnn = noAnn,@@ -786,39 +809,29 @@         ms_hspp_opts = dflags,         ms_hspp_buf = Nothing         }+    let nodes = [NodeKey_Module (ModNodeKeyWithUid (GWIB mn NotBoot) (homeUnitId home_unit)) | mn <- extra_sig_imports ]+    return (ModuleNode nodes ms)  summariseDecl :: PackageName               -> HscSource               -> Located ModuleName-              -> Maybe (Located HsModule)-              -> BkpM ExtendedModSummary-summariseDecl pn hsc_src (L _ modname) (Just hsmod) = hsModuleToModSummary pn hsc_src modname hsmod-summariseDecl _pn hsc_src lmodname@(L loc modname) Nothing-    = do hsc_env <- getSession-         -- TODO: this looks for modules in the wrong place-         r <- liftIO $ summariseModule hsc_env-                         emptyModNodeMap -- GHC API recomp not supported-                         (hscSourceToIsBoot hsc_src)-                         lmodname-                         True -- Target lets you disallow, but not here-                         Nothing -- GHC API buffer support not supported-                         [] -- No exclusions-         case r of-            Nothing -> throwOneError (mkPlainMsgEnvelope loc (text "module" <+> ppr modname <+> text "was not found"))-            Just (Left err) -> throwErrors err-            Just (Right summary) -> return summary+              -> Located HsModule+              -> [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 :: PackageName+hsModuleToModSummary :: [NodeKey]+                     -> PackageName                      -> HscSource                      -> ModuleName                      -> Located HsModule-                     -> BkpM ExtendedModSummary-hsModuleToModSummary pn hsc_src modname+                     -> BkpM ModuleGraphNode+hsModuleToModSummary home_keys pn hsc_src modname                      hsmod = do     let imps = hsmodImports (unLoc hsmod)         loc  = getLoc hsmod@@ -827,13 +840,14 @@     -- 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!-    location0 <- liftIO $ mkHomeModLocation2 dflags modname+    let location0 = mkHomeModLocation2 fopts modname                              (unpackFS unit_fs </>                               moduleNameSlashes modname)                               (case hsc_src of@@ -845,8 +859,6 @@                         HsBootFile -> addBootSuffixLocnOut location0                         _ -> location0     -- This duplicates a pile of logic in GHC.Driver.Make-    env <- getBkpEnv-    time <- liftIO $ getModificationUTCTime (bkp_filename env)     hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location)     hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_file location) @@ -854,24 +866,28 @@     let (src_idecls, ord_idecls) = partition ((== IsBoot) . ideclSource . unLoc) imps               -- GHC.Prim doesn't exist physically, so don't go looking for it.-        ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc . ideclName . unLoc)-                               ord_idecls+        (ordinary_imps, ghc_prim_import)+          = partition ((/= moduleName gHC_PRIM) . unLoc . ideclName . unLoc)+              ord_idecls          implicit_prelude = xopt LangExt.ImplicitPrelude dflags         implicit_imports = mkPrelImports modname loc                                          implicit_prelude imps-        convImport (L _ i) = (fmap sl_fs (ideclPkgQual i), reLoc $ ideclName i) +        rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) modname+        convImport (L _ i) = (rn_pkg_qual (ideclPkgQual i), reLoc $ ideclName i)+     extra_sig_imports <- liftIO $ findExtraSigImports hsc_env hsc_src modname      let normal_imports = map convImport (implicit_imports ++ ordinary_imps)     (implicit_sigs, inst_deps) <- liftIO $ implicitRequirementsShallow hsc_env normal_imports      -- So that Finder can find it, even though it doesn't exist...-    this_mod <- liftIO $ addHomeModuleToFinder hsc_env modname location-    return $ ExtendedModSummary-      { emsModSummary =-          ModSummary {+    this_mod <- liftIO $ do+      let home_unit = hsc_home_unit hsc_env+      let fc        = hsc_FC hsc_env+      addHomeModuleToFinder fc home_unit modname location+    let ms = ModSummary {             ms_mod = this_mod,             ms_hsc_src = hsc_src,             ms_location = location,@@ -881,28 +897,42 @@             ms_hspp_opts = dflags,             ms_hspp_buf = Nothing,             ms_srcimps = map convImport src_idecls,+            ms_ghc_prim_import = not (null ghc_prim_import),             ms_textual_imps = normal_imports                            -- We have to do something special here:                            -- due to merging, requirements may end up with                            -- extra imports-                           ++ extra_sig_imports-                           ++ ((,) Nothing . noLoc <$> implicit_sigs),+                           ++ ((,) NoPkgQual . noLoc <$> extra_sig_imports)+                           ++ ((,) NoPkgQual . noLoc <$> implicit_sigs),             -- This is our hack to get the parse tree to the right spot             ms_parsed_mod = Just (HsParsedModule {                     hpm_module = hsmod,                     hpm_src_files = [] -- TODO if we preprocessed it                 }),-            ms_hs_date = time,+            -- 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           }-      , emsInstantiatedUnits = inst_deps-      } +    -- Now, what are the dependencies.+    let inst_nodes = map NodeKey_Unit inst_deps+        mod_nodes  =+          -- hs-boot edge+          [k | k <- [NodeKey_Module (ModNodeKeyWithUid (GWIB (ms_mod_name ms) IsBoot)  (moduleUnitId this_mod))], NotBoot == isBootSummary ms,  k `elem` home_keys ] +++          -- Normal edges+          [k | (_, mnwib) <- msDeps ms, let k = NodeKey_Module (ModNodeKeyWithUid (fmap unLoc mnwib) (moduleUnitId this_mod)), k `elem` home_keys]+++    return (ModuleNode (mod_nodes ++ inst_nodes) ms)+ -- | Create a new, externally provided hashed unit id from -- a hash.-newUnitId :: IndefUnitId -> Maybe FastString -> UnitId+newUnitId :: UnitId -> Maybe FastString -> UnitId newUnitId uid mhash = case mhash of-   Nothing   -> indefUnit uid-   Just hash -> UnitId (unitIdFS (indefUnit uid) `appendFS` mkFastString "+" `appendFS` hash)+   Nothing   -> uid+   Just hash -> UnitId (unitIdFS uid `appendFS` mkFastString "+" `appendFS` hash)
GHC/Driver/Backpack/Syntax.hs view
@@ -39,7 +39,7 @@  data HsComponentId = HsComponentId {     hsPackageName :: PackageName,-    hsComponentId :: IndefUnitId+    hsComponentId :: UnitId     }  instance Outputable HsComponentId where@@ -65,7 +65,7 @@ -- | A declaration in a package, e.g. a module or signature definition, -- or an include. data HsUnitDecl n-    = DeclD   HscSource (Located ModuleName) (Maybe (Located HsModule))+    = DeclD   HscSource (Located ModuleName) (Located HsModule)     | IncludeD   (IncludeDecl n) type LHsUnitDecl n = Located (HsUnitDecl n)
GHC/Driver/CmdLine.hs view
@@ -1,5 +1,4 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE RankNTypes #-}  ------------------------------------------------------------------------------- --@@ -13,32 +12,34 @@  module GHC.Driver.CmdLine     (-      processArgs, OptKind(..), GhcFlagMode(..),-      CmdLineP(..), getCmdLineState, putCmdLineState,-      Flag(..), defFlag, defGhcFlag, defGhciFlag, defHiddenFlag,+      processArgs, parseResponseFile, OptKind(..), GhcFlagMode(..),+      Flag(..), defFlag, defGhcFlag, defGhciFlag, defHiddenFlag, hoistFlag,       errorsToGhcException,        Err(..), Warn(..), WarnReason(..), -      EwM, runEwM, addErr, addWarn, addFlagWarn, getArg, getCurLoc, liftEwM,-      deprecate+      EwM, runEwM, addErr, addWarn, addFlagWarn, getArg, getCurLoc, liftEwM     ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Data.Bag import GHC.Types.SrcLoc import GHC.Utils.Json +import GHC.Types.Error ( DiagnosticReason(..) )+ import Data.Function import Data.List (sortBy, intercalate, stripPrefix) +import GHC.ResponseFile+import Control.Exception (IOException, catch) import Control.Monad (liftM, ap)+import Control.Monad.IO.Class  -------------------------------------------------------- --         The Flag and OptKind types@@ -62,6 +63,24 @@ 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 (WordSuffix k) = WordSuffix (\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@@ -107,7 +126,7 @@  -- | A command-line warning message and the reason it arose data Warn = Warn-  {   warnReason :: WarnReason,+  {   warnReason :: DiagnosticReason,       warnMsg    :: Located String   } @@ -130,6 +149,8 @@ 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 emptyBag@@ -141,17 +162,12 @@ addErr e = EwM (\(L loc _) es ws -> return (es `snocBag` Err (L loc e), ws, ()))  addWarn :: Monad m => String -> EwM m ()-addWarn = addFlagWarn NoReason+addWarn = addFlagWarn WarningWithoutFlag -addFlagWarn :: Monad m => WarnReason -> String -> EwM m ()+addFlagWarn :: Monad m => DiagnosticReason -> String -> EwM m () addFlagWarn reason msg = EwM $   (\(L loc _) es ws -> return (es, ws `snocBag` Warn reason (L loc msg), ())) -deprecate :: Monad m => String -> EwM m ()-deprecate s = do-    arg <- getArg-    addFlagWarn ReasonDeprecatedFlag (arg ++ " is deprecated: " ++ s)- getArg :: Monad m => EwM m String getArg = EwM (\(L _ arg) es ws -> return (es, ws, arg)) @@ -163,40 +179,17 @@   ----------------------------------------------------------- A state monad for use in the command-line parser------------------------------------------------------------- (CmdLineP s) typically instantiates the 'm' in (EwM m) and (OptKind m)-newtype CmdLineP s a = CmdLineP { runCmdLine :: s -> (a, s) }-    deriving (Functor)--instance Applicative (CmdLineP s) where-    pure a = CmdLineP $ \s -> (a, s)-    (<*>) = ap--instance Monad (CmdLineP s) where-    m >>= k = CmdLineP $ \s ->-                  let (a, s') = runCmdLine m s-                  in runCmdLine (k a) s'---getCmdLineState :: CmdLineP s s-getCmdLineState   = CmdLineP $ \s -> (s,s)-putCmdLineState :: s -> CmdLineP s ()-putCmdLineState s = CmdLineP $ \_ -> ((),s)----------------------------------------------------------- --         Processing arguments --------------------------------------------------------  processArgs :: Monad m-            => [Flag m]               -- cmdline parser spec-            -> [Located String]       -- args+            => [Flag m]               -- ^ cmdline parser spec+            -> [Located String]       -- ^ args+            -> (FilePath -> EwM m [Located String]) -- ^ response file handler             -> m ( [Located String],  -- spare args                    [Err],  -- errors                    [Warn] ) -- warnings-processArgs spec args = do+processArgs spec args handleRespFile = do     (errs, warns, spare) <- runEwM action     return (spare, bagToList errs, bagToList warns)   where@@ -205,6 +198,10 @@     -- 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) ->@@ -228,7 +225,7 @@   = let dash_arg = '-' : arg         rest_no_eq = dropEq rest     in case opt_kind of-        NoArg  a -> ASSERT(null rest) Right (a, args)+        NoArg  a -> assert (null rest) Right (a, args)          HasArg f | notNull rest_no_eq -> Right (f rest_no_eq, args)                  | otherwise -> case args of@@ -324,16 +321,24 @@ -- 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 flags]+-- 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 commandline flags]-+{- 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
GHC/Driver/CodeOutput.hs view
@@ -4,7 +4,7 @@ \section{Code output phase} -} -{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}  module GHC.Driver.CodeOutput    ( codeOutput@@ -14,8 +14,6 @@    ) where -#include "HsVersions.h"- import GHC.Prelude import GHC.Platform import GHC.ForeignSrcLang@@ -25,10 +23,13 @@  import GHC.CmmToC           ( cmmToC ) import GHC.Cmm.Lint         ( cmmLint )-import GHC.Cmm              ( RawCmmGroup )+import GHC.Cmm import GHC.Cmm.CLabel  import GHC.Driver.Session+import GHC.Driver.Config.Finder    (initFinderOpts)+import GHC.Driver.Config.CmmToAsm  (initNCGConfig)+import GHC.Driver.Config.CmmToLlvm (initLlvmCgConfig) import GHC.Driver.Ppr import GHC.Driver.Backend @@ -43,9 +44,10 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Logger+import GHC.Utils.Exception (bracket)+import GHC.Utils.Ppr (Mode(..))  import GHC.Unit-import GHC.Unit.State import GHC.Unit.Finder      ( mkStubPaths )  import GHC.Types.SrcLoc@@ -53,10 +55,11 @@ import GHC.Types.ForeignStubs import GHC.Types.Unique.Supply ( mkSplitUniqSupply ) -import Control.Exception import System.Directory import System.FilePath import System.IO+import Data.Set (Set)+import qualified Data.Set as Set  {- ************************************************************************@@ -67,7 +70,8 @@ -}  codeOutput-    :: Logger+    :: forall a.+       Logger     -> TmpFs     -> DynFlags     -> UnitState@@ -77,7 +81,7 @@     -> (a -> ForeignStubs)     -> [(ForeignSrcLang, FilePath)]     -- ^ additional files to be compiled with the C compiler-    -> [UnitId]+    -> Set UnitId -- ^ Dependencies     -> Stream IO RawCmmGroup a                       -- Compiled C--     -> IO (FilePath,            (Bool{-stub_h_exists-}, Maybe FilePath{-stub_c_exists-}),@@ -94,34 +98,52 @@                     else cmm_stream                do_lint cmm = withTimingSilent logger-                  dflags                   (text "CmmLint"<+>brackets (ppr this_mod))                   (const ()) $ do                 { case cmmLint (targetPlatform dflags) cmm of-                        Just err -> do { putLogMsg logger-                                                   dflags-                                                   NoReason-                                                   SevDump+                        Just err -> do { logMsg logger+                                                   MCDump                                                    noSrcSpan                                                    $ withPprStyle defaultDumpStyle err-                                       ; ghcExit logger dflags 1+                                       ; ghcExit logger 1                                        }                         Nothing  -> return ()                 ; return cmm                 } -        ; a <- case backend dflags of+        ; let final_stream :: Stream IO RawCmmGroup (ForeignStubs, a)+              final_stream = do+                  { a <- linted_cmm_stream+                  ; let stubs = genForeignStubs a+                  ; emitInitializerDecls this_mod stubs+                  ; return (stubs, a) }++        ; (stubs, a) <- case backend dflags of                  NCG         -> outputAsm logger dflags this_mod location filenm-                                          linted_cmm_stream-                 ViaC        -> outputC logger dflags filenm linted_cmm_stream pkg_deps-                 LLVM        -> outputLlvm logger dflags filenm linted_cmm_stream+                                          final_stream+                 ViaC        -> outputC logger dflags filenm final_stream pkg_deps+                 LLVM        -> outputLlvm logger dflags filenm final_stream                  Interpreter -> panic "codeOutput: Interpreter"                  NoBackend   -> panic "codeOutput: NoBackend"-        ; let stubs = genForeignStubs a         ; stubs_exist <- outputForeignStubs logger tmpfs dflags unit_state this_mod location stubs         ; return (filenm, stubs_exist, foreign_fps, a)         } +-- | See Note [Initializers and finalizers in Cmm] in GHC.Cmm.InitFini for details.+emitInitializerDecls :: Module -> ForeignStubs -> Stream IO RawCmmGroup ()+emitInitializerDecls this_mod (ForeignStubs _ cstub)+  | initializers <- getInitializers cstub+  , not $ null initializers =+      let init_array = CmmData sect statics+          lbl = mkInitializerArrayLabel this_mod+          sect = Section InitArray lbl+          statics = CmmStaticsRaw lbl+            [ CmmStaticLit $ CmmLabel fn_name+            | fn_name <- initializers+            ]+    in Stream.yield [init_array]+emitInitializerDecls _ _ = return ()+ doOutput :: String -> (Handle -> IO a) -> IO a doOutput filenm io_action = bracket (openFile filenm WriteMode) hClose io_action @@ -137,22 +159,23 @@         -> DynFlags         -> FilePath         -> Stream IO RawCmmGroup a-        -> [UnitId]+        -> Set UnitId         -> IO a-outputC logger dflags filenm cmm_stream packages =-  withTiming logger dflags (text "C codegen") (\a -> seq a () {- FIXME -}) $ do-    let pkg_names = map unitIdString packages+outputC logger dflags filenm cmm_stream unit_deps =+  withTiming logger (text "C codegen") (\a -> seq a () {- FIXME -}) $ do+    let pkg_names = map unitIdString (Set.toAscList unit_deps)     doOutput filenm $ \ h -> do       hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n")       hPutStr h "#include \"Stg.h\"\n"       let platform = targetPlatform dflags           writeC cmm = do             let doc = cmmToC platform cmm-            dumpIfSet_dyn logger dflags Opt_D_dump_c_backend+            putDumpFileMaybe logger Opt_D_dump_c_backend                           "C backend output"                           FormatC                           doc-            printForC dflags h doc+            let ctx = initSDocContext dflags (PprCode CStyle)+            printSDocLn ctx LeftMode h doc       Stream.consume cmm_stream id writeC  {-@@ -172,10 +195,11 @@           -> IO a outputAsm logger dflags this_mod location filenm cmm_stream = do   ncg_uniqs <- mkSplitUniqSupply 'n'-  debugTraceMsg logger dflags 4 (text "Outputing asm to" <+> text filenm)+  debugTraceMsg logger 4 (text "Outputing asm to" <+> text filenm)+  let ncg_config = initNCGConfig dflags this_mod   {-# SCC "OutputAsm" #-} doOutput filenm $     \h -> {-# SCC "NativeCodeGen" #-}-      nativeCodeGen logger dflags this_mod location h ncg_uniqs cmm_stream+      nativeCodeGen logger ncg_config location h ncg_uniqs cmm_stream  {- ************************************************************************@@ -186,10 +210,11 @@ -}  outputLlvm :: Logger -> DynFlags -> FilePath -> Stream IO RawCmmGroup a -> IO a-outputLlvm logger dflags filenm cmm_stream =+outputLlvm logger dflags filenm cmm_stream = do+  lcg_config <- initLlvmCgConfig logger dflags   {-# SCC "llvm_output" #-} doOutput filenm $     \f -> {-# SCC "llvm_CodeGen" #-}-      llvmCodeGen logger dflags f cmm_stream+      llvmCodeGen logger lcg_config f cmm_stream  {- ************************************************************************@@ -220,14 +245,14 @@            Maybe FilePath) -- C file created outputForeignStubs logger tmpfs dflags unit_state mod location stubs  = do-   let stub_h = mkStubPaths dflags (moduleName mod) location-   stub_c <- newTempName logger tmpfs dflags TFL_CurrentModule "c"+   let stub_h = mkStubPaths (initFinderOpts dflags) (moduleName mod) location+   stub_c <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "c"     case stubs of      NoStubs ->         return (False, Nothing) -     ForeignStubs (CHeader h_code) (CStub c_code) -> do+     ForeignStubs (CHeader h_code) (CStub c_code _ _) -> do         let             stub_c_output_d = pprCode CStyle c_code             stub_c_output_w = showSDoc dflags stub_c_output_d@@ -238,7 +263,7 @@          createDirectoryIfMissing True (takeDirectory stub_h) -        dumpIfSet_dyn logger dflags Opt_D_dump_foreign+        putDumpFileMaybe logger Opt_D_dump_foreign                       "Foreign export header file"                       FormatC                       stub_h_output_d@@ -263,7 +288,7 @@            <- outputForeignStubs_help stub_h stub_h_output_w                 ("#include <HsFFI.h>\n" ++ cplusplus_hdr) cplusplus_ftr -        dumpIfSet_dyn logger dflags Opt_D_dump_foreign+        putDumpFileMaybe logger Opt_D_dump_foreign                       "Foreign export stubs" FormatC stub_c_output_d          stub_c_file_exists@@ -304,20 +329,19 @@ -- | Generate code to initialise cost centres profilingInitCode :: Platform -> Module -> CollectedCCs -> CStub profilingInitCode platform this_mod (local_CCs, singleton_CCSs)- = CStub $ vcat-    $  map emit_cc_decl local_CCs-    ++ map emit_ccs_decl singleton_CCSs-    ++ [emit_cc_list local_CCs]-    ++ [emit_ccs_list singleton_CCSs]-    ++ [ text "static void prof_init_" <> ppr this_mod-            <> text "(void) __attribute__((constructor));"-       , text "static void prof_init_" <> ppr this_mod <> text "(void)"-       , braces (vcat-                 [ text "registerCcList" <> parens local_cc_list_label <> semi-                 , text "registerCcsList" <> parens singleton_cc_list_label <> semi-                 ])-       ]+ = {-# SCC profilingInitCode #-}+   initializerCStub platform fn_name decls body  where+   fn_name = mkInitializerStubLabel this_mod "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 = pdoc platform (mkCCLabel cc)@@ -341,23 +365,22 @@       <> semi  -- | Generate code to initialise info pointer origin--- See note [Mapping Info Tables to Source Positions]-ipInitCode :: DynFlags -> Module -> [InfoProvEnt] -> CStub-ipInitCode dflags this_mod ents- = if not (gopt Opt_InfoTableMap dflags)-    then mempty-    else CStub $ vcat-    $  map emit_ipe_decl ents-    ++ [emit_ipe_list ents]-    ++ [ text "static void ip_init_" <> ppr this_mod-            <> text "(void) __attribute__((constructor));"-       , text "static void ip_init_" <> ppr this_mod <> text "(void)"-       , braces (vcat-                 [ text "registerInfoProvList" <> parens local_ipe_list_label <> semi-                 ])-       ]+-- See Note [Mapping Info Tables to Source Positions]+ipInitCode+  :: Bool            -- is Opt_InfoTableMap enabled or not+  -> Platform+  -> Module+  -> [InfoProvEnt]+  -> CStub+ipInitCode do_info_table platform this_mod ents+  | not do_info_table = mempty+  | otherwise = initializerCStub platform fn_nm decls body  where-   platform = targetPlatform dflags+   fn_nm = mkInitializerStubLabel this_mod "ip_init"+   decls = vcat+        $  map emit_ipe_decl ents+        ++ [emit_ipe_list ents]+   body = text "registerInfoProvList" <> parens local_ipe_list_label <> semi    emit_ipe_decl ipe =        text "extern InfoProvEnt" <+> ipe_lbl <> text "[];"      where ipe_lbl = pprCLabel platform CStyle (mkIPELabel ipe)
GHC/Driver/Config.hs view
@@ -2,7 +2,8 @@ module GHC.Driver.Config    ( initOptCoercionOpts    , initSimpleOpts-   , initParserOpts+   , initBCOOpts+   , initEvalOpts    ) where @@ -11,8 +12,12 @@ import GHC.Driver.Session import GHC.Core.SimpleOpt import GHC.Core.Coercion.Opt-import GHC.Parser.Lexer+import GHC.Runtime.Interpreter (BCOOpts(..))+import GHCi.Message (EvalOpts(..)) +import GHC.Conc (getNumProcessors)+import Control.Monad.IO.Class+ -- | Initialise coercion optimiser configuration from DynFlags initOptCoercionOpts :: DynFlags -> OptCoercionOpts initOptCoercionOpts dflags = OptCoercionOpts@@ -26,13 +31,23 @@    , so_co_opts = initOptCoercionOpts dflags    } --- | Extracts the flag information needed for parsing-initParserOpts :: DynFlags -> ParserOpts-initParserOpts =-  mkParserOpts-    <$> warningFlags-    <*> extensionFlags-    <*> safeImportsOn-    <*> gopt Opt_Haddock-    <*> gopt Opt_KeepRawTokenStream-    <*> const True+-- | Extract BCO options from DynFlags+initBCOOpts :: DynFlags -> IO BCOOpts+initBCOOpts dflags = do+  -- Serializing ResolvedBCO is expensive, so if we're in parallel mode+  -- (-j<n>) parallelise the serialization.+  n_jobs <- case parMakeCount dflags of+              Nothing -> liftIO getNumProcessors+              Just n  -> return n+  return $ BCOOpts n_jobs++-- | Extract GHCi options from DynFlags and step+initEvalOpts :: DynFlags -> Bool -> EvalOpts+initEvalOpts dflags step =+  EvalOpts+    { useSandboxThread = gopt Opt_GhciSandbox dflags+    , singleStep       = step+    , breakOnException = gopt Opt_BreakOnException dflags+    , breakOnError     = gopt Opt_BreakOnError dflags+    }+
+ GHC/Driver/Config/Cmm.hs view
@@ -0,0 +1,33 @@+module GHC.Driver.Config.Cmm+  ( initCmmConfig+  ) where++import GHC.Cmm.Config+import GHC.Cmm.Switch (backendSupportsSwitch)++import GHC.Driver.Session+import GHC.Driver.Backend++import GHC.Platform++import GHC.Prelude++initCmmConfig :: DynFlags -> CmmConfig+initCmmConfig dflags = CmmConfig+  { cmmProfile             = targetProfile                dflags+  , cmmOptControlFlow      = gopt Opt_CmmControlFlow      dflags+  , cmmDoLinting           = gopt Opt_DoCmmLinting        dflags+  , cmmOptElimCommonBlks   = gopt Opt_CmmElimCommonBlocks dflags+  , cmmOptSink             = gopt Opt_CmmSink             dflags+  , cmmGenStackUnwindInstr = debugLevel dflags > 0+  , cmmExternalDynamicRefs = gopt Opt_ExternalDynamicRefs dflags+  , cmmDoCmmSwitchPlans    = not . backendSupportsSwitch . backend $ dflags+  , cmmSplitProcPoints     = (backend dflags /= NCG)+                             || not (platformTablesNextToCode platform)+                             || usingInconsistentPicReg+  }+  where platform                = targetPlatform dflags+        usingInconsistentPicReg =+          case (platformArch platform, platformOS platform, positionIndependent dflags)+          of   (ArchX86, OSDarwin, pic) -> pic+               _                        -> False
+ GHC/Driver/Config/CmmToAsm.hs view
@@ -0,0 +1,75 @@+module GHC.Driver.Config.CmmToAsm+  ( initNCGConfig+  )+where++import GHC.Prelude++import GHC.Driver.Session++import GHC.Platform+import GHC.Unit.Types (Module)+import GHC.CmmToAsm.Config+import GHC.Utils.Outputable+import GHC.CmmToAsm.BlockLayout++-- | Initialize the native code generator configuration from the DynFlags+initNCGConfig :: DynFlags -> Module -> NCGConfig+initNCGConfig dflags this_mod = NCGConfig+   { ncgPlatform              = targetPlatform dflags+   , ncgThisModule            = this_mod+   , ncgAsmContext            = initSDocContext dflags (PprCode AsmStyle)+   , ncgProcAlignment         = cmmProcAlignment dflags+   , ncgExternalDynamicRefs   = gopt Opt_ExternalDynamicRefs dflags+   , ncgPIC                   = positionIndependent dflags+   , ncgInlineThresholdMemcpy = fromIntegral $ maxInlineMemcpyInsns dflags+   , ncgInlineThresholdMemset = fromIntegral $ maxInlineMemsetInsns dflags+   , ncgSplitSections         = gopt Opt_SplitSections dflags+   , ncgRegsIterative         = gopt Opt_RegsIterative dflags+   , ncgRegsGraph             = gopt Opt_RegsGraph dflags+   , ncgAsmLinting            = gopt Opt_DoAsmLinting dflags+   , ncgCfgWeights            = cfgWeights dflags+   , ncgCfgBlockLayout        = gopt Opt_CfgBlocklayout dflags+   , ncgCfgWeightlessLayout   = gopt Opt_WeightlessBlocklayout dflags++     -- When constant-folding is enabled, the cmmSink pass does constant-folding, so+     -- we don't need to do it again in the native code generator.+   , ncgDoConstantFolding     = not (gopt Opt_CoreConstantFolding dflags || gopt Opt_CmmSink dflags)++   , ncgDumpRegAllocStages    = dopt Opt_D_dump_asm_regalloc_stages dflags+   , ncgDumpAsmStats          = dopt Opt_D_dump_asm_stats dflags+   , ncgDumpAsmConflicts      = dopt Opt_D_dump_asm_conflicts dflags+   , ncgBmiVersion            = case platformArch (targetPlatform dflags) of+                                 ArchX86_64 -> bmiVersion dflags+                                 ArchX86    -> bmiVersion dflags+                                 _          -> Nothing++     -- We assume  SSE1 and SSE2 operations are available on both+     -- x86 and x86_64. Historically we didn't default to SSE2 and+     -- SSE1 on x86, which results in defacto nondeterminism for how+     -- rounding behaves in the associated x87 floating point instructions+     -- because variations in the spill/fpu stack placement of arguments for+     -- operations would change the precision and final result of what+     -- would otherwise be the same expressions with respect to single or+     -- double precision IEEE floating point computations.+   , ncgSseVersion =+      let v | sseVersion dflags < Just SSE2 = Just SSE2+            | otherwise                     = sseVersion dflags+      in case platformArch (targetPlatform dflags) of+            ArchX86_64 -> v+            ArchX86    -> v+            _          -> Nothing++   , ncgDwarfEnabled        = osElfTarget (platformOS (targetPlatform dflags)) && debugLevel dflags > 0 && platformArch (targetPlatform dflags) /= ArchAArch64+   , ncgDwarfUnwindings     = osElfTarget (platformOS (targetPlatform dflags)) && debugLevel dflags > 0+   , ncgDwarfStripBlockInfo = osElfTarget (platformOS (targetPlatform dflags)) && debugLevel dflags < 2 -- We strip out block information when running with -g0 or -g1.+   , ncgDwarfSourceNotes    = osElfTarget (platformOS (targetPlatform dflags)) && debugLevel dflags > 2 -- We produce GHC-specific source-note DIEs only with -g3+   , ncgExposeInternalSymbols = gopt Opt_ExposeInternalSymbols dflags+   , ncgCmmStaticPred       = gopt Opt_CmmStaticPred dflags+   , ncgEnableShortcutting  = gopt Opt_AsmShortcutting dflags+   , ncgComputeUnwinding    = debugLevel dflags > 0+   , ncgEnableDeadCodeElimination = not (gopt Opt_InfoTableMap dflags)+                                     -- Disable when -finfo-table-map is on (#20428)+                                     && backendMaintainsCfg (targetPlatform dflags)+                                     -- Enable if the platform maintains the CFG+   }
+ GHC/Driver/Config/CmmToLlvm.hs view
@@ -0,0 +1,30 @@+module GHC.Driver.Config.CmmToLlvm+  ( initLlvmCgConfig+  ) where++import GHC.Prelude+import GHC.Driver.Session+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 -> DynFlags -> IO LlvmCgConfig+initLlvmCgConfig logger dflags = do+  version <- figureLlvmVersion logger dflags+  pure $! LlvmCgConfig {+    llvmCgPlatform               = targetPlatform dflags+    , llvmCgContext              = initSDocContext dflags (PprCode CStyle)+    , llvmCgFillUndefWithGarbage = gopt Opt_LlvmFillUndefWithGarbage dflags+    , llvmCgSplitSection         = gopt Opt_SplitSections dflags+    , llvmCgBmiVersion           = case platformArch (targetPlatform dflags) of+                                      ArchX86_64 -> bmiVersion dflags+                                      ArchX86    -> bmiVersion dflags+                                      _          -> Nothing+    , llvmCgLlvmVersion          = version+    , llvmCgDoWarn               = wopt Opt_WarnUnsupportedLlvmVersion dflags+    , llvmCgLlvmTarget           = platformMisc_llvmTarget $! platformMisc dflags+    , llvmCgLlvmConfig           = llvmConfig dflags+    }
+ GHC/Driver/Config/Diagnostic.hs view
@@ -0,0 +1,21 @@+module GHC.Driver.Config.Diagnostic+  ( initDiagOpts+  )+where++import GHC.Driver.Flags+import GHC.Driver.Session++import GHC.Utils.Outputable+import GHC.Utils.Error (DiagOpts (..))++initDiagOpts :: DynFlags -> DiagOpts+initDiagOpts dflags = DiagOpts+  { diag_warning_flags       = warningFlags dflags+  , diag_fatal_warning_flags = fatalWarningFlags 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+  }+
+ GHC/Driver/Config/Finder.hs view
@@ -0,0 +1,34 @@+module GHC.Driver.Config.Finder (+    FinderOpts(..),+    initFinderOpts+  ) where++import GHC.Prelude++import GHC.Driver.Session+import GHC.Unit.Finder.Types+import GHC.Data.FastString+++-- | Create a new 'FinderOpts' from DynFlags.+initFinderOpts :: DynFlags -> FinderOpts+initFinderOpts flags = FinderOpts+  { finder_importPaths = importPaths flags+  , finder_lookupHomeInterfaces = isOneShot (ghcMode flags)+  , finder_bypassHiFileCheck = MkDepend == (ghcMode flags)+  , finder_ways = ways flags+  , finder_enableSuggestions = gopt Opt_HelpfulErrors flags+  , finder_workingDirectory = workingDirectory flags+  , finder_thisPackageName  = mkFastString <$> thisPackageName flags+  , finder_hiddenModules = hiddenModules flags+  , finder_reexportedModules = reexportedModules flags+  , finder_hieDir = hieDir flags+  , finder_hieSuf = hieSuf flags+  , finder_hiDir = hiDir flags+  , finder_hiSuf = hiSuf_ flags+  , finder_dynHiSuf = dynHiSuf_ flags+  , finder_objectDir = objectDir flags+  , finder_objectSuf = objectSuf_ flags+  , finder_dynObjectSuf = dynObjectSuf_ flags+  , finder_stubDir = stubDir flags+  }
+ 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.Session+import qualified GHC.LanguageExtensions as LangExt++initBangOpts :: DynFlags -> BangOpts+initBangOpts dflags = BangOpts+  { bang_opt_strict_data   = xopt LangExt.StrictData dflags+  , bang_opt_unbox_disable = gopt Opt_OmitInterfacePragmas dflags+      -- Don't unbox if we aren't optimising; rather arbitrarily,+      -- we use -fomit-iface-pragmas as the indication+  , bang_opt_unbox_strict  = gopt Opt_UnboxStrictFields dflags+  , bang_opt_unbox_small   = gopt Opt_UnboxSmallStrictFields dflags+  }+
+ GHC/Driver/Config/Logger.hs view
@@ -0,0 +1,29 @@+module GHC.Driver.Config.Logger+  ( initLogFlags+  )+where++import GHC.Prelude++import GHC.Driver.Session++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_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_enable_debug         = not (hasNoDebugOutput dflags)+  , log_verbosity            = verbosity dflags+  }+
+ GHC/Driver/Config/Parser.hs view
@@ -0,0 +1,25 @@+module GHC.Driver.Config.Parser+  ( initParserOpts+  )+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+    <*> (supportedLanguagesAndExtensions . platformArchOS . targetPlatform)+    <*> safeImportsOn+    <*> gopt Opt_Haddock+    <*> gopt Opt_KeepRawTokenStream+    <*> const True -- use LINE/COLUMN to update the internal location+
+ 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.Session++-- | Initialize STG pretty-printing options from DynFlags+initStgDebugOpts :: DynFlags -> StgDebugOpts+initStgDebugOpts dflags = StgDebugOpts+  { stgDebug_infoTableMap = gopt Opt_InfoTableMap dflags+  , stgDebug_distinctConstructorTables = gopt Opt_DistinctConstructorTables dflags+  }
+ 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.Session++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,47 @@+module GHC.Driver.Config.Stg.Pipeline+  ( initStgPipelineOpts+  ) where++import GHC.Prelude++import Control.Monad (guard)++import GHC.Stg.Pipeline++import GHC.Driver.Config.Diagnostic+import GHC.Driver.Config.Stg.Lift+import GHC.Driver.Config.Stg.Ppr+import GHC.Driver.Session++-- | Initialize STG pretty-printing options from DynFlags+initStgPipelineOpts :: DynFlags -> Bool -> StgPipelineOpts+initStgPipelineOpts dflags for_bytecode = StgPipelineOpts+  { stgPipeline_lint = do+      guard $ gopt Opt_DoStgLinting dflags+      Just $ initDiagOpts dflags+  , stgPipeline_pprOpts = initStgPprOpts dflags+  , stgPipeline_phases = getStgToDo for_bytecode dflags+  , stgPlatform = targetPlatform dflags+  }++-- | Which Stg-to-Stg passes to run. Depends on flags, ways etc.+getStgToDo+  :: Bool -- ^ Are we preparing for bytecode?+  -> DynFlags+  -> [StgToDo]+getStgToDo for_bytecode dflags =+  filter (/= StgDoNothing)+    [ mandatory StgUnarise+    -- Important that unarisation comes first+    -- See Note [StgCse after unarisation] in GHC.Stg.CSE+    , optional Opt_StgCSE StgCSE+    , optional Opt_StgLiftLams $ StgLiftLams $ initStgLiftConfig dflags+    , runWhen for_bytecode StgBcPrep+    , optional Opt_StgStats StgStats+    ] where+      optional opt = runWhen (gopt opt dflags)+      mandatory = id++runWhen :: Bool -> StgToDo -> StgToDo+runWhen True todo = todo+runWhen _    _    = StgDoNothing
+ 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,78 @@+module GHC.Driver.Config.StgToCmm+  ( initStgToCmmConfig+  ) where++import GHC.StgToCmm.Config++import GHC.Driver.Backend+import GHC.Driver.Session+import GHC.Platform+import GHC.Platform.Profile+import GHC.Unit.Module+import GHC.Utils.Outputable++import Data.Maybe+import Prelude++initStgToCmmConfig :: DynFlags -> Module -> StgToCmmConfig+initStgToCmmConfig dflags mod = StgToCmmConfig+  -- settings+  { stgToCmmProfile       = profile+  , stgToCmmThisModule    = mod+  , stgToCmmTmpDir        = tmpDir          dflags+  , stgToCmmContext       = initSDocContext dflags defaultDumpStyle+  , stgToCmmDebugLevel    = debugLevel      dflags+  , stgToCmmBinBlobThresh = b_blob+  , stgToCmmMaxInlAllocSize = maxInlineAllocSize           dflags+  -- ticky options+  , stgToCmmDoTicky       = gopt Opt_Ticky                 dflags+  , stgToCmmTickyAllocd   = gopt Opt_Ticky_Allocd          dflags+  , stgToCmmTickyLNE      = gopt Opt_Ticky_LNE             dflags+  , stgToCmmTickyDynThunk = gopt Opt_Ticky_Dyn_Thunk       dflags+  , stgToCmmTickyTag      = gopt Opt_Ticky_Tag             dflags+  -- flags+  , stgToCmmLoopification = gopt Opt_Loopification         dflags+  , stgToCmmAlignCheck    = gopt Opt_AlignmentSanitisation dflags+  , stgToCmmOptHpc        = gopt Opt_Hpc                   dflags+  , stgToCmmFastPAPCalls  = gopt Opt_FastPAPCalls          dflags+  , stgToCmmSCCProfiling  = sccProfilingEnabled            dflags+  , stgToCmmEagerBlackHole = gopt Opt_EagerBlackHoling     dflags+  , stgToCmmInfoTableMap  = gopt Opt_InfoTableMap          dflags+  , stgToCmmOmitYields    = gopt Opt_OmitYields            dflags+  , stgToCmmOmitIfPragmas = gopt Opt_OmitInterfacePragmas  dflags+  , stgToCmmPIC           = gopt Opt_PIC                   dflags+  , stgToCmmPIE           = gopt Opt_PIE                   dflags+  , stgToCmmExtDynRefs    = gopt Opt_ExternalDynamicRefs   dflags+  , stgToCmmDoBoundsCheck = gopt Opt_DoBoundsChecking      dflags+  , stgToCmmDoTagCheck    = gopt Opt_DoTagInferenceChecks  dflags+  -- backend flags+  , stgToCmmAllowBigArith             = not ncg+  , stgToCmmAllowQuotRemInstr         = ncg  && (x86ish || ppc)+  , stgToCmmAllowQuotRem2             = (ncg && (x86ish || ppc)) || llvm+  , stgToCmmAllowExtendedAddSubInstrs = (ncg && (x86ish || ppc)) || llvm+  , stgToCmmAllowIntMul2Instr         = (ncg && x86ish) || llvm+  , stgToCmmAllowFabsInstrs           = (ncg && (x86ish || ppc || aarch64)) || llvm+  -- SIMD flags+  , stgToCmmVecInstrsErr  = vec_err+  , stgToCmmAvx           = isAvxEnabled                   dflags+  , stgToCmmAvx2          = isAvx2Enabled                  dflags+  , stgToCmmAvx512f       = isAvx512fEnabled               dflags+  , stgToCmmTickyAP       = gopt Opt_Ticky_AP dflags+  } where profile  = targetProfile dflags+          platform = profilePlatform profile+          bk_end  = backend dflags+          ncg     = bk_end == NCG+          llvm    = bk_end == LLVM+          b_blob  = if not ncg then Nothing else binBlobThreshold dflags+          x86ish  = case platformArch platform of+                      ArchX86    -> True+                      ArchX86_64 -> True+                      _          -> False+          ppc     = case platformArch platform of+                      ArchPPC      -> True+                      ArchPPC_64 _ -> True+                      _            -> False+          aarch64 = platformArch platform == ArchAArch64+          vec_err = case backend dflags of+                      LLVM -> Nothing+                      _    -> Just (unlines ["SIMD vector instructions require the LLVM back-end.", "Please use -fllvm."])
+ GHC/Driver/Config/Tidy.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE LambdaCase #-}++module GHC.Driver.Config.Tidy+  ( initTidyOpts+  , initStaticPtrOpts+  )+where++import GHC.Prelude++import GHC.Iface.Tidy+import GHC.Iface.Tidy.StaticPtrTable++import GHC.Driver.Session+import GHC.Driver.Env+import GHC.Driver.Backend++import GHC.Core.Make (getMkStringIds)+import GHC.Data.Maybe+import GHC.Utils.Panic+import GHC.Utils.Outputable+import GHC.Builtin.Names+import GHC.Tc.Utils.Env (lookupGlobal_maybe)+import GHC.Types.TyThing+import GHC.Platform.Ways++import qualified GHC.LanguageExtensions as LangExt++initTidyOpts :: HscEnv -> IO TidyOpts+initTidyOpts hsc_env = do+  let dflags = hsc_dflags hsc_env+  static_ptr_opts <- if not (xopt LangExt.StaticPointers dflags)+    then pure Nothing+    else Just <$> initStaticPtrOpts hsc_env+  pure $ TidyOpts+    { opt_name_cache        = hsc_NC hsc_env+    , opt_collect_ccs       = ways dflags `hasWay` WayProf+    , opt_unfolding_opts    = unfoldingOpts dflags+    , opt_expose_unfoldings = if | gopt Opt_OmitInterfacePragmas dflags -> ExposeNone+                                 | gopt Opt_ExposeAllUnfoldings dflags  -> ExposeAll+                                 | otherwise                            -> ExposeSome+    , opt_expose_rules      = not (gopt Opt_OmitInterfacePragmas dflags)+    , opt_trim_ids          = gopt Opt_OmitInterfacePragmas dflags+    , opt_static_ptr_opts   = static_ptr_opts+    }++initStaticPtrOpts :: HscEnv -> IO StaticPtrOpts+initStaticPtrOpts hsc_env = do+  let dflags = hsc_dflags hsc_env++  let lookupM n = lookupGlobal_maybe hsc_env n >>= \case+        Succeeded r -> pure r+        Failed err  -> pprPanic "initStaticPtrOpts: couldn't find" (ppr (err,n))++  mk_string <- getMkStringIds (fmap tyThingId . lookupM)+  static_ptr_info_datacon <- tyThingDataCon <$> lookupM staticPtrInfoDataConName+  static_ptr_datacon      <- tyThingDataCon <$> lookupM staticPtrDataConName++  pure $ StaticPtrOpts+    { opt_platform = targetPlatform dflags++      -- If we are compiling for the interpreter we will insert any necessary+      -- SPT entries dynamically, otherwise we add a C stub to do so+    , opt_gen_cstub = case backend dflags of+                        Interpreter -> False+                        _           -> True++    , opt_mk_string = mk_string+    , opt_static_ptr_info_datacon = static_ptr_info_datacon+    , opt_static_ptr_datacon      = static_ptr_datacon+    }+
GHC/Driver/Env.hs view
@@ -1,53 +1,71 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}  module GHC.Driver.Env    ( Hsc(..)    , HscEnv (..)+   , hscUpdateFlags+   , hscSetFlags    , hsc_home_unit+   , hsc_home_unit_maybe    , hsc_units+   , hsc_HPT+   , hsc_HUE+   , hsc_HUG+   , hsc_all_home_unit_ids+   , hscUpdateLoggerFlags+   , hscUpdateHUG+   , hscUpdateHPT+   , hscSetActiveHomeUnit+   , hscSetActiveUnitId+   , hscActiveUnitId    , runHsc+   , runHsc'    , mkInteractiveHscEnv    , runInteractiveHsc    , hscEPS+   , hscInterp    , hptCompleteSigs-   , hptInstances+   , hptAllInstances+   , hptInstancesBelow    , hptAnns    , hptAllThings    , hptSomeThingsBelowUs    , hptRules    , prepareAnnotations+   , discardIC    , lookupType    , lookupIfaceByModule    , mainModIs    ) where -#include "HsVersions.h"- import GHC.Prelude -import GHC.Driver.Ppr import GHC.Driver.Session-import GHC.Driver.Errors ( printOrThrowWarnings )+import GHC.Driver.Errors ( printOrThrowDiagnostics )+import GHC.Driver.Errors.Types ( GhcMessage )+import GHC.Driver.Config.Logger (initLogFlags)+import GHC.Driver.Config.Diagnostic (initDiagOpts)+import GHC.Driver.Env.Types ( Hsc(..), HscEnv(..) )  import GHC.Runtime.Context-import GHC.Driver.Env.Types ( Hsc(..), HscEnv(..) )+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.Module.Deps import GHC.Unit.Home.ModInfo import GHC.Unit.Env import GHC.Unit.External  import GHC.Core         ( CoreRule ) import GHC.Core.FamInstEnv-import GHC.Core.InstEnv ( ClsInst )+import GHC.Core.InstEnv  import GHC.Types.Annotations ( Annotation, AnnEnv, mkAnnEnv, plusAnnEnv ) import GHC.Types.CompleteMatch+import GHC.Types.Error ( emptyMessages, Messages ) import GHC.Types.Name import GHC.Types.Name.Env import GHC.Types.TyThing@@ -55,29 +73,39 @@ import GHC.Builtin.Names ( gHC_PRIM )  import GHC.Data.Maybe-import GHC.Data.Bag +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.Utils.Trace -import Control.Monad    ( guard ) import Data.IORef+import qualified Data.Set as Set+import Data.Set (Set)+import GHC.Unit.Module.Graph+import Data.List (sort)+import qualified Data.Map as Map  runHsc :: HscEnv -> Hsc a -> IO a runHsc hsc_env (Hsc hsc) = do-    (a, w) <- hsc hsc_env emptyBag-    printOrThrowWarnings (hsc_logger hsc_env) (hsc_dflags hsc_env) w+    (a, w) <- hsc hsc_env emptyMessages+    let dflags = hsc_dflags hsc_env+    let !diag_opts = initDiagOpts dflags+    printOrThrowDiagnostics (hsc_logger hsc_env) 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 hsc_env { hsc_dflags  = ic_dflags  ic-               , hsc_plugins = ic_plugins ic-               }+    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.@@ -85,11 +113,32 @@ runInteractiveHsc hsc_env = runHsc (mkInteractiveHscEnv hsc_env)  hsc_home_unit :: HscEnv -> HomeUnit-hsc_home_unit = ue_home_unit . hsc_unit_env+hsc_home_unit = unsafeGetHomeUnit . hsc_unit_env -hsc_units :: HscEnv -> UnitState+hsc_home_unit_maybe :: HscEnv -> Maybe HomeUnit+hsc_home_unit_maybe = ue_homeUnit . hsc_unit_env++hsc_units :: HasDebugCallStack => HscEnv -> UnitState hsc_units = ue_units . 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_all_home_unit_ids :: HscEnv -> Set.Set UnitId+hsc_all_home_unit_ids = unitEnv_keys . hsc_HUG++hscUpdateHPT :: (HomePackageTable -> HomePackageTable) -> HscEnv -> HscEnv+hscUpdateHPT f hsc_env = hsc_env { hsc_unit_env = updateHpt f (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) }+ {-  Note [Target code interpreter]@@ -162,7 +211,7 @@  -- | Retrieve the ExternalPackageState cache. hscEPS :: HscEnv -> IO ExternalPackageState-hscEPS hsc_env = readIORef (hsc_EPS hsc_env)+hscEPS hsc_env = readIORef (euc_eps (ue_eps (hsc_unit_env hsc_env)))  hptCompleteSigs :: HscEnv -> [CompleteMatch] hptCompleteSigs = hptAllThings  (md_complete_matches . hm_details)@@ -171,39 +220,87 @@ -- the Home Package Table filtered by the provided predicate function. -- Used in @tcRnImports@, to select the instances that are in the -- transitive closure of imports from the currently compiled module.-hptInstances :: HscEnv -> (ModuleName -> Bool) -> ([ClsInst], [FamInst])-hptInstances hsc_env want_this_module+hptAllInstances :: HscEnv -> (InstEnv, [FamInst])+hptAllInstances hsc_env   = let (insts, famInsts) = unzip $ flip hptAllThings hsc_env $ \mod_info -> do-                guard (want_this_module (moduleName (mi_module (hm_iface mod_info))))                 let details = hm_details mod_info                 return (md_insts details, md_fam_insts details)-    in (concat insts, concat famInsts)+    in (foldl' unionInstEnv emptyInstEnv insts, concat famInsts) +-- | Find instances visible from the given set of imports+hptInstancesBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> (InstEnv, [FamInst])+hptInstancesBelow hsc_env uid mnwib =+  let+    mn = gwib_mod mnwib+    (insts, famInsts) =+        unzip $ hptSomeThingsBelowUs (\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+  in (foldl' unionInstEnv emptyInstEnv insts, concat famInsts)+ -- | Get rules from modules "below" this one (in the dependency sense)-hptRules :: HscEnv -> [ModuleNameWithIsBoot] -> [CoreRule]+hptRules :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> [CoreRule] hptRules = hptSomeThingsBelowUs (md_rules . hm_details) False   -- | Get annotations from modules "below" this one (in the dependency sense)-hptAnns :: HscEnv -> Maybe [ModuleNameWithIsBoot] -> [Annotation]-hptAnns hsc_env (Just deps) = hptSomeThingsBelowUs (md_anns . hm_details) False hsc_env deps+hptAnns :: HscEnv -> Maybe (UnitId, ModuleNameWithIsBoot) -> [Annotation]+hptAnns hsc_env (Just (uid, mn)) = hptSomeThingsBelowUs (md_anns . hm_details) False hsc_env uid mn hptAnns hsc_env Nothing = hptAllThings (md_anns . hm_details) hsc_env  hptAllThings :: (HomeModInfo -> [a]) -> HscEnv -> [a]-hptAllThings extract hsc_env = concatMap extract (eltsHpt (hsc_HPT hsc_env))+hptAllThings extract hsc_env = concatMap (concatMap extract . eltsHpt . homeUnitEnv_hpt . snd)+                                (hugElts (hsc_HUG hsc_env)) +-- | This function returns all the modules belonging to the home-unit that can+-- be reached by following the given dependencies. Additionally, if both the+-- boot module and the non-boot module can be reached, it only returns the+-- non-boot one.+hptModulesBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> Set ModNodeKeyWithUid+hptModulesBelow hsc_env uid mn = filtered_mods $ [ mn |  NodeKey_Module mn <- modules_below]+  where+    td_map = mgTransDeps (hsc_mod_graph hsc_env)++    modules_below = maybe [] Set.toList $ Map.lookup (NodeKey_Module (ModNodeKeyWithUid mn uid)) td_map++    filtered_mods = Set.fromDistinctAscList . filter_mods . sort++    -- IsBoot and NotBoot modules are necessarily consecutive in the sorted list+    -- (cf Ord instance of GenWithIsBoot). Hence we only have to perform a+    -- linear sweep with a window of size 2 to remove boot modules for which we+    -- have the corresponding non-boot.+    filter_mods = \case+      (r1@(ModNodeKeyWithUid (GWIB m1 b1) uid1) : r2@(ModNodeKeyWithUid (GWIB m2 _) uid2): rs)+        | m1 == m2  && uid1 == uid2 ->+                       let !r' = case b1 of+                                  NotBoot -> r1+                                  IsBoot  -> r2+                       in r' : filter_mods rs+        | otherwise -> r1 : filter_mods (r2:rs)+      rs -> rs+++ -- | Get things from modules "below" this one (in the dependency sense) -- C.f Inst.hptInstances-hptSomeThingsBelowUs :: (HomeModInfo -> [a]) -> Bool -> HscEnv -> [ModuleNameWithIsBoot] -> [a]-hptSomeThingsBelowUs extract include_hi_boot hsc_env deps+hptSomeThingsBelowUs :: (HomeModInfo -> [a]) -> Bool -> HscEnv -> UnitId -> ModuleNameWithIsBoot -> [a]+hptSomeThingsBelowUs extract include_hi_boot hsc_env uid mn   | isOneShot (ghcMode (hsc_dflags hsc_env)) = []    | otherwise-  = let hpt = hsc_HPT hsc_env+  = let hug = hsc_HUG hsc_env     in     [ thing-    |   -- Find each non-hi-boot module below me-      GWIB { gwib_mod = mod, gwib_isBoot = is_boot } <- deps+    |+    -- Find each non-hi-boot module below me+      (ModNodeKeyWithUid (GWIB { gwib_mod = mod, gwib_isBoot = is_boot }) mod_uid) <- Set.toList (hptModulesBelow hsc_env uid mn)     , include_hi_boot || (is_boot == NotBoot)          -- unsavoury: when compiling the base package with --make, we@@ -211,17 +308,20 @@         -- 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 HPT-    , let things = case lookupHpt hpt mod of+    , let things = case lookupHug hug mod_uid mod of                     Just info -> extract info-                    Nothing -> pprTrace "WARNING in hptSomeThingsBelowUs" msg []+                    Nothing -> pprTrace "WARNING in hptSomeThingsBelowUs" msg mempty           msg = vcat [text "missing module" <+> ppr mod,+                     text "When starting from"  <+> ppr mn,+                     text "below:" <+> ppr (hptModulesBelow hsc_env uid mn),                       text "Probable cause: out-of-date interface files"]                         -- This really shouldn't happen, but see #962+    , thing <- things+    ] -        -- And get its dfuns-    , thing <- things ]   -- | Deal with gathering annotations in from all possible places@@ -234,7 +334,8 @@         -- Extract dependencies of the module if we are supplied one,         -- otherwise load annotations from all home package table         -- entries regardless of dependency ordering.-        home_pkg_anns  = (mkAnnEnv . hptAnns hsc_env) $ fmap (dep_mods . mg_deps) mb_guts+        get_mod mg = (moduleUnitId (mg_module mg), GWIB (moduleName (mg_module mg)) NotBoot)+        home_pkg_anns  = (mkAnnEnv . hptAnns hsc_env) $ fmap get_mod mb_guts         other_pkg_anns = eps_ann_env eps         ann_env        = foldl1' plusAnnEnv $ catMaybes [mb_this_module_anns,                                                          Just home_pkg_anns,@@ -248,11 +349,11 @@ -- have to do that yourself, if desired lookupType :: HscEnv -> Name -> IO (Maybe TyThing) lookupType hsc_env name = do-   eps <- liftIO $ readIORef (hsc_EPS hsc_env)+   eps <- liftIO $ hscEPS hsc_env    let pte = eps_PTE eps-       hpt = hsc_HPT hsc_env+       hpt = hsc_HUG hsc_env -       mod = ASSERT2( isExternalName name, ppr name )+       mod = assertPpr (isExternalName name) (ppr name) $              if isHoleName name                then mkHomeModule (hsc_home_unit hsc_env) (moduleName (nameModule name))                else nameModule name@@ -260,7 +361,7 @@        !ty = if isOneShot (ghcMode (hsc_dflags hsc_env))                -- in one-shot, we don't use the HPT                then lookupNameEnv pte name-               else case lookupHptByModule hpt mod of+               else case lookupHugByModule mod hpt of                 Just hm -> lookupNameEnv (md_types (hm_details hm)) name                 Nothing -> lookupNameEnv pte name    pure ty@@ -268,12 +369,12 @@ -- | Find the 'ModIface' for a 'Module', searching in both the loaded home -- and external package module information lookupIfaceByModule-        :: HomePackageTable+        :: HomeUnitGraph         -> PackageIfaceTable         -> Module         -> Maybe ModIface-lookupIfaceByModule hpt pit mod-  = case lookupHptByModule hpt mod of+lookupIfaceByModule hug pit mod+  = case lookupHugByModule mod hug of        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?@@ -283,5 +384,65 @@    -- 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. -mainModIs :: HscEnv -> Module-mainModIs hsc_env = mkHomeModule (hsc_home_unit hsc_env) (mainModuleNameIs (hsc_dflags hsc_env))+mainModIs :: HomeUnitEnv -> Module+mainModIs hue = mkHomeModule (expectJust "mainModIs" $ 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
+ 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+togethed 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 environemnt 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 accidently 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
@@ -1,52 +1,44 @@-{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DerivingVia #-}+ module GHC.Driver.Env.Types   ( Hsc(..)   , HscEnv(..)   ) where +import GHC.Driver.Errors.Types ( GhcMessage ) import {-# SOURCE #-} GHC.Driver.Hooks-import GHC.Driver.Session ( DynFlags, HasDynFlags(..) )+import GHC.Driver.Session ( ContainsDynFlags(..), HasDynFlags(..), DynFlags ) import GHC.Prelude import GHC.Runtime.Context import GHC.Runtime.Interpreter.Types ( Interp )-import GHC.Types.Error ( WarningMessages )+import GHC.Types.Error ( Messages ) import GHC.Types.Name.Cache import GHC.Types.Target import GHC.Types.TypeEnv-import GHC.Unit.External import GHC.Unit.Finder.Types-import GHC.Unit.Home.ModInfo import GHC.Unit.Module.Graph import GHC.Unit.Env-import GHC.Unit.State-import GHC.Unit.Types import GHC.Utils.Logger import GHC.Utils.TmpFs import {-# SOURCE #-} GHC.Driver.Plugins -import Control.Monad ( ap ) import Control.Monad.IO.Class+import Control.Monad.Trans.Reader+import Control.Monad.Trans.State import Data.IORef---- | The Hsc monad: Passing an environment and warning state-newtype Hsc a = Hsc (HscEnv -> WarningMessages -> IO (a, WarningMessages))-    deriving (Functor)--instance Applicative Hsc where-    pure a = Hsc $ \_ w -> return (a, w)-    (<*>) = ap--instance Monad Hsc where-    Hsc m >>= k = Hsc $ \e w -> do (a, w1) <- m e w-                                   case k a of-                                       Hsc k' -> k' e w1+import GHC.Driver.Env.KnotVars -instance MonadIO Hsc where-    liftIO io = Hsc $ \_ w -> do a <- io; return (a, w)+-- | 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) @@ -77,40 +69,14 @@         hsc_IC :: InteractiveContext,                 -- ^ The context for evaluating interactive statements -        hsc_HPT    :: HomePackageTable,-                -- ^ The home package table describes already-compiled-                -- home-package modules, /excluding/ the module we-                -- are compiling right now.-                -- (In one-shot mode the current module is the only-                -- home-package module, so hsc_HPT is empty.  All other-                -- modules count as \"external-package\" modules.-                -- However, even in GHCi mode, hi-boot interfaces are-                -- demand-loaded into the external-package table.)-                ---                -- 'hsc_HPT' is not mutable because we only demand-load-                -- external packages; the home package is eagerly-                -- loaded, module by module, by the compilation manager.-                ---                -- The HPT may contain modules compiled earlier by @--make@-                -- but not actually below the current module in the dependency-                -- graph.-                ---                -- (This changes a previous invariant: changed Jan 05.)--        hsc_EPS :: {-# UNPACK #-} !(IORef ExternalPackageState),-                -- ^ Information about the currently loaded external packages.-                -- This is mutable because packages will be demand-loaded during-                -- a compilation run as required.--        hsc_NC  :: {-# UNPACK #-} !(IORef NameCache),-                -- ^ As with 'hsc_EPS', this is side-effected by compiling to-                -- reflect sucking in interface files.  They cache the state of-                -- external interface files, in effect.+        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 #-} !(IORef FinderCache),+        hsc_FC   :: {-# UNPACK #-} !FinderCache,                 -- ^ The cached result of performing finding in the file system -        hsc_type_env_var :: Maybe (Module, IORef TypeEnv)+        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]@@ -119,31 +85,8 @@                 -- ^ target code interpreter (if any) to use for TH and GHCi.                 -- See Note [Target code interpreter] -        , hsc_plugins :: ![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'.--        , hsc_static_plugins :: ![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.--        , hsc_unit_dbs :: !(Maybe [UnitDatabase UnitId])-                -- ^ Stack of unit databases for the target platform.-                ---                -- This field is populated with the result of `initUnits`.-                ---                -- 'Nothing' means the databases have never been read from disk.-                ---                -- Usually we don't reload the databases from disk if they are-                -- cached, even if the database flags changed!+        , hsc_plugins :: !Plugins+                -- ^ Plugins          , hsc_unit_env :: UnitEnv                 -- ^ Unit environment (unit state, home unit, etc.).@@ -152,7 +95,11 @@                 -- from the DynFlags.          , hsc_logger :: !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@@ -160,4 +107,3 @@         , hsc_tmpfs :: !TmpFs                 -- ^ Temporary files  }-
GHC/Driver/Errors.hs view
@@ -1,97 +1,66 @@ module GHC.Driver.Errors (-    warningsToMessages-  , printOrThrowWarnings-  , printBagOfErrors-  , isWarnMsgFatal+    printOrThrowDiagnostics+  , printMessages   , handleFlagWarnings+  , mkDriverPsHeaderMessage   ) where -import GHC.Driver.Session+import GHC.Driver.Errors.Types import GHC.Data.Bag-import GHC.Utils.Exception-import GHC.Utils.Error ( formatBulleted, sortMsgBag )-import GHC.Types.SourceError ( mkSrcErr ) import GHC.Prelude import GHC.Types.SrcLoc+import GHC.Types.SourceError import GHC.Types.Error-import GHC.Utils.Outputable ( text, withPprStyle, mkErrStyle )+import GHC.Utils.Error+import GHC.Utils.Outputable (hang, ppr, ($$), SDocContext,  text, withPprStyle, mkErrStyle, sdocStyle ) import GHC.Utils.Logger import qualified GHC.Driver.CmdLine as CmdLine --- | Converts a list of 'WarningMessages' into a tuple where the second element contains only--- error, i.e. warnings that are considered fatal by GHC based on the input 'DynFlags'.-warningsToMessages :: DynFlags -> WarningMessages -> (WarningMessages, ErrorMessages)-warningsToMessages dflags =-  partitionBagWith $ \warn ->-    case isWarnMsgFatal dflags warn of-      Nothing -> Left warn-      Just err_reason ->-        Right warn{ errMsgSeverity = SevError-                  , errMsgReason = ErrReason err_reason }--printBagOfErrors :: RenderableDiagnostic a => Logger -> DynFlags -> Bag (MsgEnvelope a) -> IO ()-printBagOfErrors logger dflags bag_of_errors+printMessages :: Diagnostic a => Logger -> DiagOpts -> Messages a -> IO ()+printMessages logger opts msgs   = sequence_ [ let style = mkErrStyle unqual-                    ctx   = initSDocContext dflags style-                in putLogMsg logger dflags reason sev s $-                   withPprStyle style (formatBulleted ctx (renderDiagnostic doc))+                    ctx   = (diag_ppr_ctx opts) { sdocStyle = style }+                in logMsg logger (MCDiagnostic sev . diagnosticReason $ dia) s $+                   withPprStyle style (messageWithHints ctx dia)               | MsgEnvelope { errMsgSpan      = s,-                              errMsgDiagnostic = doc,-                              errMsgSeverity  = sev,-                              errMsgReason    = reason,-                              errMsgContext   = unqual } <- sortMsgBag (Just dflags)-                                                                       bag_of_errors ]--handleFlagWarnings :: Logger -> DynFlags -> [CmdLine.Warn] -> IO ()-handleFlagWarnings logger dflags warns = do-  let warns' = filter (shouldPrintWarning dflags . CmdLine.warnReason)  warns--      toWarnReason CmdLine.ReasonDeprecatedFlag = Reason Opt_WarnDeprecatedFlags-      toWarnReason CmdLine.ReasonUnrecognisedFlag = Reason Opt_WarnUnrecognisedWarningFlags-      toWarnReason CmdLine.NoReason = NoReason+                              errMsgDiagnostic = dia,+                              errMsgSeverity = sev,+                              errMsgContext   = unqual } <- sortMsgBag (Just opts)+                                                                       (getMessages msgs) ]+  where+    messageWithHints :: Diagnostic a => SDocContext -> a -> SDoc+    messageWithHints ctx e =+      let main_msg = formatBulleted ctx $ diagnosticMessage 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 ctx . mkDecorated . map ppr $ hs) -      -- It would be nicer if warns :: [Located SDoc], but that+handleFlagWarnings :: Logger -> DiagOpts -> [CmdLine.Warn] -> IO ()+handleFlagWarnings logger opts warns = do+  let -- It would be nicer if warns :: [Located SDoc], but that       -- has circular import problems.-      bag = listToBag [ makeIntoWarning (toWarnReason reason) (mkPlainWarnMsg loc (text warn))-                      | CmdLine.Warn reason (L loc warn) <- warns' ]--  printOrThrowWarnings logger dflags bag+      bag = listToBag [ mkPlainMsgEnvelope opts loc $+                        GhcDriverMessage $+                        DriverUnknownMessage $+                        mkPlainDiagnostic reason noHints $ text warn+                      | CmdLine.Warn reason (L loc warn) <- warns ] --- | Checks if given 'WarnMsg' is a fatal warning.-isWarnMsgFatal :: DynFlags -> WarnMsg -> Maybe (Maybe WarningFlag)-isWarnMsgFatal dflags MsgEnvelope{errMsgReason = Reason wflag}-  = if wopt_fatal wflag dflags-      then Just (Just wflag)-      else Nothing-isWarnMsgFatal dflags _-  = if gopt Opt_WarnIsError dflags-      then Just Nothing-      else Nothing+  printOrThrowDiagnostics logger opts (mkMessages bag) --- Given a warn reason, check to see if it's associated -W opt is enabled-shouldPrintWarning :: DynFlags -> CmdLine.WarnReason -> Bool-shouldPrintWarning dflags CmdLine.ReasonDeprecatedFlag-  = wopt Opt_WarnDeprecatedFlags dflags-shouldPrintWarning dflags CmdLine.ReasonUnrecognisedFlag-  = wopt Opt_WarnUnrecognisedWarningFlags dflags-shouldPrintWarning _ _-  = True+-- | Given a bag of diagnostics, turn them into an exception if+-- any has 'SevError', or print them out otherwise.+printOrThrowDiagnostics :: Logger -> DiagOpts -> Messages GhcMessage -> IO ()+printOrThrowDiagnostics logger opts msgs+  | errorsOrFatalWarningsFound msgs+  = throwErrors msgs+  | otherwise+  = printMessages logger opts msgs --- | Given a bag of warnings, turn them into an exception if--- -Werror is enabled, or print them out otherwise.-printOrThrowWarnings :: Logger -> DynFlags -> Bag WarnMsg -> IO ()-printOrThrowWarnings logger dflags warns = do-  let (make_error, warns') =-        mapAccumBagL-          (\make_err warn ->-            case isWarnMsgFatal dflags warn of-              Nothing ->-                (make_err, warn)-              Just err_reason ->-                (True, warn{ errMsgSeverity = SevError-                           , errMsgReason = ErrReason err_reason-                           }))-          False warns-  if make_error-    then throwIO (mkSrcErr warns')-    else printBagOfErrors logger dflags warns+-- | 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,313 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic {DriverMessage, GhcMessage}++module GHC.Driver.Errors.Ppr where++import GHC.Prelude++import GHC.Driver.Errors.Types+import GHC.Driver.Flags+import GHC.Driver.Session+import GHC.HsToCore.Errors.Ppr ()+import GHC.Parser.Errors.Ppr ()+import GHC.Tc.Errors.Ppr ()+import GHC.Types.Error+import GHC.Unit.Types+import GHC.Utils.Outputable+import GHC.Unit.Module+import GHC.Unit.State+import GHC.Types.Hint+import GHC.Types.SrcLoc+import Data.Version++import Language.Haskell.Syntax.Decls (RuleDecl(..))++--+-- 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 Diagnostic GhcMessage where+  diagnosticMessage = \case+    GhcPsMessage m+      -> diagnosticMessage m+    GhcTcRnMessage m+      -> diagnosticMessage m+    GhcDsMessage m+      -> diagnosticMessage m+    GhcDriverMessage m+      -> diagnosticMessage m+    GhcUnknownMessage m+      -> diagnosticMessage 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++instance Diagnostic DriverMessage where+  diagnosticMessage = \case+    DriverUnknownMessage m+      -> diagnosticMessage m+    DriverPsHeaderMessage m+      -> diagnosticMessage m+    DriverMissingHomeModules missing buildingCabalPackage+      -> let msg | buildingCabalPackage == YesBuildingCabalPackage+                 = hang+                     (text "These modules are needed for compilation but not listed in your .cabal file's other-modules: ")+                     4+                     (sep (map ppr missing))+                 | otherwise+                 =+                   hang+                     (text "Modules are not listed in command line but needed for compilation: ")+                     4+                     (sep (map ppr missing))+         in mkSimpleDecorated msg+    DriverUnknownHiddenModules missing+      -> let msg = hang+                     (text "Modules are listened as hidden but not part of the unit: ")+                     4+                     (sep (map ppr missing))+         in mkSimpleDecorated msg+    DriverUnknownReexportedModules missing+      -> let msg = hang+                     (text "Modules are listened as reexported 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 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 (snd $ unLoc n) <> text "\" ignored" $+$+            text "User defined rules are 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)++  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++  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
+ GHC/Driver/Errors/Types.hs view
@@ -0,0 +1,366 @@+{-# LANGUAGE GADTs #-}++module GHC.Driver.Errors.Types (+    GhcMessage(..)+  , DriverMessage(..), DriverMessages, PsMessage(PsHeaderMessage)+  , BuildingCabalPackage(..)+  , WarningMessages+  , ErrorMessages+  , WarnMsg+  -- * Constructors+  , ghcUnknownMessage+  -- * Utility functions+  , hoistTcRnMessage+  , hoistDsMessage+  , checkBuildingCabalPackage+  ) where++import GHC.Prelude++import Data.Bifunctor+import Data.Typeable++import GHC.Driver.Session+import GHC.Types.Error+import GHC.Unit.Module+import GHC.Unit.State++import GHC.Parser.Errors.Types ( PsMessage(PsHeaderMessage) )+import GHC.Tc.Errors.Types     ( TcRnMessage )+import GHC.HsToCore.Errors.Types ( DsMessage )+import GHC.Hs.Extension          (GhcTc)++import Language.Haskell.Syntax.Decls (RuleDecl)++-- | 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 :: forall a. (Diagnostic a, Typeable a) => a -> GhcMessage++-- | 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 :: (Diagnostic a, Typeable a) => a -> GhcMessage+ghcUnknownMessage = GhcUnknownMessage++-- | 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 :: (Diagnostic a, Typeable a) => a -> 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 :: [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 :: [ModuleName] -> DriverMessage++  {-| DriverUnknownHiddenModules is a warning that arises when a user tries to+      hide a module which isn't part of that unit.+  -}+  DriverUnknownHiddenModules :: [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 :: !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++-- | Pass to a 'DriverMessage' the information whether or not the+-- '-fbuilding-cabal-package' flag is set.+data BuildingCabalPackage+  = YesBuildingCabalPackage+  | NoBuildingCabalPackage+  deriving Eq++-- | 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
@@ -1,18 +1,43 @@ module GHC.Driver.Flags    ( DumpFlag(..)    , GeneralFlag(..)-   , WarningFlag(..)-   , WarnReason (..)    , Language(..)    , optimisationFlags++   -- * Warnings+   , WarningFlag(..)+   , warnFlagNames+   , warningGroups+   , warningHierarchies+   , smallestWarningGroups+   , standardWarnings+   , minusWOpts+   , minusWallOpts+   , minusWeverythingOpts+   , minusWcompatOpts+   , unusedBindsFlags    ) where  import GHC.Prelude import GHC.Utils.Outputable+import GHC.Utils.Binary import GHC.Data.EnumSet as EnumSet-import GHC.Utils.Json +import Control.Monad (guard)+import Data.List.NonEmpty (NonEmpty(..))+import Data.Maybe (fromMaybe,mapMaybe)++data Language = Haskell98 | Haskell2010 | GHC2021+   deriving (Eq, Enum, Show, Bounded)++instance Outputable Language where+    ppr = text . show++instance Binary Language where+  put_ bh = put_ bh . fromEnum+  get bh = toEnum <$> get bh+ -- | Debugging flags data DumpFlag -- See Note [Updating flag description in the User's Guide]@@ -48,7 +73,6 @@    | Opt_D_dump_asm_regalloc_stages    | Opt_D_dump_asm_conflicts    | Opt_D_dump_asm_stats-   | Opt_D_dump_asm_expanded    | Opt_D_dump_c_backend    | Opt_D_dump_llvm    | Opt_D_dump_core_stats@@ -57,6 +81,7 @@    | 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@@ -69,9 +94,12 @@    | Opt_D_dump_simpl_iterations    | Opt_D_dump_spec    | 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_final     -- ^ Final STG (after stg2stg)+   | 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_call_arity    | Opt_D_dump_exitify    | Opt_D_dump_stranal@@ -93,7 +121,6 @@    | Opt_D_dump_tc_trace    | Opt_D_dump_ec_trace -- Pattern match exhaustiveness checker    | Opt_D_dump_if_trace-   | Opt_D_dump_vt_trace    | Opt_D_dump_splices    | Opt_D_th_dec_file    | Opt_D_dump_BCOs@@ -113,6 +140,7 @@    | Opt_D_ppr_debug    | Opt_D_no_debug_output    | Opt_D_dump_faststrings+   | Opt_D_faststring_stats    deriving (Eq, Show, Enum)  -- | Enumerates the simple on-or-off dynamic flags@@ -120,7 +148,6 @@ -- See Note [Updating flag description in the User's Guide]     = Opt_DumpToFile                     -- ^ Append dump output to files instead of stdout.-   | Opt_D_faststring_stats    | Opt_D_dump_minimal_imports    | Opt_DoCoreLinting    | Opt_DoLinearCoreLinting@@ -192,9 +219,10 @@    | Opt_CmmSink    | Opt_CmmStaticPred    | Opt_CmmElimCommonBlocks+   | Opt_CmmControlFlow    | Opt_AsmShortcutting    | Opt_OmitYields-   | Opt_FunToThunk               -- allow GHC.Core.Opt.WorkWrap.Utils.mkWorkerArgs to remove all value lambdas+   | 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@@ -203,11 +231,17 @@    | 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_CatchBottoms+   | Opt_CatchNonexhaustiveCases    | Opt_NumConstantFolding+   | Opt_CoreConstantFolding+   | Opt_FastPAPCalls                  -- #6084 +   -- 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@@ -222,6 +256,9 @@    -- profiling opts    | Opt_AutoSccsOnIndividualCafs    | Opt_ProfCountEntries+   | Opt_ProfLateInlineCcs+   | Opt_ProfLateCcs+   | Opt_ProfManualCcs -- ^ Ignore manual SCC annotations     -- misc opts    | Opt_Pp@@ -254,8 +291,8 @@    | Opt_LocalGhciHistory    | Opt_NoIt    | Opt_HelpfulErrors-   | Opt_DeferTypeErrors-   | Opt_DeferTypedHoles+   | Opt_DeferTypeErrors             -- Since 7.6+   | Opt_DeferTypedHoles             -- Since 7.10    | Opt_DeferOutOfScopeVariables    | Opt_PIC                         -- ^ @-fPIC@    | Opt_PIE                         -- ^ @-fPIE@@@ -265,6 +302,8 @@    | 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_RPath    | Opt_RelativeDynlibPaths    | Opt_CompactUnwind               -- ^ @-fcompact-unwind@@@ -297,7 +336,7 @@    | 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+    -- See Note [Valid hole fits include ...] in GHC.Tc.Errors.Hole    | Opt_ShowValidHoleFits    | Opt_SortValidHoleFits    | Opt_SortBySizeHoleFits@@ -335,6 +374,7 @@    | Opt_SuppressStgExts    | Opt_SuppressTicks     -- Replaces Opt_PprShowTicks    | Opt_SuppressTimestamps -- ^ Suppress timestamps in dumps+   | Opt_SuppressCoreSizes  -- ^ Suppress per binding Core size stats in dumps     -- temporary flags    | Opt_AutoLinkPackages@@ -418,8 +458,9 @@    , Opt_WeightlessBlocklayout    , Opt_CprAnal    , Opt_WorkerWrapper+   , Opt_WorkerWrapperUnlift    , Opt_SolveConstantDicts-   , Opt_CatchBottoms+   , Opt_CatchNonexhaustiveCases    , Opt_IgnoreAsserts    ] @@ -456,8 +497,8 @@    | Opt_WarnRedundantRecordWildcards    | Opt_WarnWarningsDeprecations    | Opt_WarnDeprecatedFlags-   | Opt_WarnMissingMonadFailInstances -- since 8.0, has no effect since 8.8-   | Opt_WarnSemigroup -- since 8.0+   | Opt_WarnMissingMonadFailInstances               -- since 8.0, has no effect since 8.8+   | Opt_WarnSemigroup                               -- since 8.0    | Opt_WarnDodgyExports    | Opt_WarnDodgyImports    | Opt_WarnOrphans@@ -465,6 +506,7 @@    | Opt_WarnIdentities    | Opt_WarnTabs    | Opt_WarnUnrecognisedPragmas+   | Opt_WarnMisplacedPragmas    | Opt_WarnDodgyForeignImports    | Opt_WarnUnusedDoBind    | Opt_WarnWrongDoBind@@ -485,62 +527,301 @@    | Opt_WarnDerivingTypeable    | Opt_WarnDeferredTypeErrors    | Opt_WarnDeferredOutOfScopeVariables-   | Opt_WarnNonCanonicalMonadInstances   -- since 8.0-   | Opt_WarnNonCanonicalMonadFailInstances   -- since 8.0, removed 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_WarnNonCanonicalMonadInstances              -- since 8.0+   | Opt_WarnNonCanonicalMonadFailInstances          -- since 8.0, removed 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_WarnStarIsType                              -- Since 8.6+   | Opt_WarnStarBinder                              -- Since 8.6+   | Opt_WarnImplicitKindVars                        -- Since 8.6    | Opt_WarnSpaceAfterBang-   | Opt_WarnMissingDerivingStrategies    -- Since 8.8-   | Opt_WarnPrepositiveQualifiedModule   -- Since TBD-   | Opt_WarnUnusedPackages               -- Since 8.10-   | Opt_WarnInferredSafeImports          -- Since 8.10-   | Opt_WarnMissingSafeHaskellMode       -- Since 8.10-   | Opt_WarnCompatUnqualifiedImports     -- Since 8.10+   | 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 8.12-   | 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_WarnUnicodeBidirectionalFormatCharacters -- Since 9.0.2+   | 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_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    deriving (Eq, Ord, Show, Enum) --- | Used when outputting warnings: if a reason is given, it is--- displayed. If a warning isn't controlled by a flag, this is made--- explicit at the point of use.-data WarnReason-  = NoReason-  -- | Warning was enabled with the flag-  | Reason !WarningFlag-  -- | Warning was made an error because of -Werror or -Werror=WarningFlag-  | ErrReason !(Maybe WarningFlag)-  deriving Show+-- | 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_WarnCPPUndef                                -> "cpp-undef" :| []+  Opt_WarnUnbangedStrictPatterns                  -> "unbanged-strict-patterns" :| []+  Opt_WarnDeferredTypeErrors                      -> "deferred-type-errors" :| []+  Opt_WarnDeferredOutOfScopeVariables             -> "deferred-out-of-scope-variables" :| []+  Opt_WarnWarningsDeprecations                    -> "deprecations" :| ["warnings-deprecations"]+  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_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_WarnTypeEqualityRequiresOperators           -> "type-equality-requires-operators" :| [] -instance Outputable WarnReason where-  ppr = text . show+-- -----------------------------------------------------------------------------+-- Standard sets of warning options -instance ToJson WarnReason where-  json NoReason = JSNull-  json (Reason wf) = JSString (show wf)-  json (ErrReason Nothing) = JSString "Opt_WarnIsError"-  json (ErrReason (Just wf)) = JSString (show wf)+-- Note [Documenting warning flags]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- If you change the list of warning enabled by default+-- please remember to update the User's Guide. The relevant file is:+--+--  docs/users_guide/using-warnings.rst +-- | Warning groups.+--+-- As all warnings are in the Weverything set, it is ignored when+-- displaying to the user which group a warning is in.+warningGroups :: [(String, [WarningFlag])]+warningGroups =+    [ ("compat",       minusWcompatOpts)+    , ("unused-binds", unusedBindsFlags)+    , ("default",      standardWarnings)+    , ("extra",        minusWOpts)+    , ("all",          minusWallOpts)+    , ("everything",   minusWeverythingOpts)+    ] -data Language = Haskell98 | Haskell2010 | GHC2021-   deriving (Eq, Enum, Show, Bounded)+-- | 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 Weverything group is not included.+warningHierarchies :: [[String]]+warningHierarchies = hierarchies ++ map (:[]) rest+  where+    hierarchies = [["default", "extra", "all"]]+    rest = filter (`notElem` "everything" : concat hierarchies) $+           map fst warningGroups -instance Outputable Language where-    ppr = text . show+-- | Find the smallest group in every hierarchy which a warning+-- belongs to, excluding Weverything.+smallestWarningGroups :: WarningFlag -> [String]+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+        flags <- lookup group warningGroups+        guard (flag `elem` flags)+        pure (Just group)+    go [] = Nothing +-- | Warnings enabled unless specified otherwise+standardWarnings :: [WarningFlag]+standardWarnings -- see Note [Documenting warning flags]+    = [ Opt_WarnOverlappingPatterns,+        Opt_WarnWarningsDeprecations,+        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_WarnInaccessibleCode,+        Opt_WarnSpaceAfterBang,+        Opt_WarnNonCanonicalMonadInstances,+        Opt_WarnNonCanonicalMonoidInstances,+        Opt_WarnOperatorWhitespaceExtConflict,+        Opt_WarnForallIdentifier,+        Opt_WarnUnicodeBidirectionalFormatCharacters,+        Opt_WarnGADTMonoLocalBinds,+        Opt_WarnTypeEqualityRequiresOperators+      ]++-- | 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_WarnStarIsType,+        Opt_WarnIncompleteUniPatterns,+        Opt_WarnIncompletePatternsRecUpd+      ]++-- | 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_WarnSemigroup+      , Opt_WarnNonCanonicalMonoidInstances+      , Opt_WarnStarIsType+      , Opt_WarnCompatUnqualifiedImports+      , Opt_WarnTypeEqualityOutOfScope+      ]++-- | Things you get with -Wunused-binds+unusedBindsFlags :: [WarningFlag]+unusedBindsFlags = [ Opt_WarnUnusedTopBinds+                   , Opt_WarnUnusedLocalBinds+                   , Opt_WarnUnusedPatternBinds+                   ]
+ GHC/Driver/GenerateCgIPEStub.hs view
@@ -0,0 +1,269 @@+{-# LANGUAGE GADTs #-}++module GHC.Driver.GenerateCgIPEStub (generateCgIPEStub) where++import qualified Data.Map.Strict as Map+import Data.Maybe (catMaybes, listToMaybe)+import GHC.Cmm+import GHC.Cmm.CLabel (CLabel)+import GHC.Cmm.Dataflow (Block, C, O)+import GHC.Cmm.Dataflow.Block (blockSplit, blockToList)+import GHC.Cmm.Dataflow.Collections (mapToList)+import GHC.Cmm.Dataflow.Label (Label)+import GHC.Cmm.Info.Build (emptySRT)+import GHC.Cmm.Pipeline (cmmPipeline)+import GHC.Cmm.Utils (toBlockList)+import GHC.Data.Maybe (firstJusts)+import GHC.Data.Stream (Stream, liftIO)+import qualified GHC.Data.Stream as Stream+import GHC.Driver.Env (hsc_dflags)+import GHC.Driver.Env.Types (HscEnv)+import GHC.Driver.Flags (GeneralFlag (Opt_InfoTableMap))+import GHC.Driver.Session (gopt, targetPlatform)+import GHC.Driver.Config.StgToCmm+import GHC.Prelude+import GHC.Runtime.Heap.Layout (isStackRep)+import GHC.Settings (Platform, platformUnregisterised)+import GHC.StgToCmm.Monad (getCmm, initC, runC, initFCodeState)+import GHC.StgToCmm.Prof (initInfoTableProv)+import GHC.StgToCmm.Types (CgInfos (..), ModuleLFInfos)+import GHC.Stg.InferTags.TagSig (TagSig)+import GHC.Types.IPE (InfoTableProvMap (provInfoTables), IpeSourceLocation)+import GHC.Types.Name.Set (NonCaffySet)+import GHC.Types.Name.Env (NameEnv)+import GHC.Types.Tickish (GenTickish (SourceNote))+import GHC.Unit.Types (Module)+import GHC.Utils.Misc++{-+Note [Stacktraces from Info Table Provenance Entries (IPE based stack unwinding)]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Stacktraces can be created from return frames as they are pushed to stack for every case scrutinee.+But to make them readable / meaningful, one needs to know the source location of each return frame.++Every return frame has a distinct info table and thus a distinct code pointer (for tables next to+code) or at least a distict address itself. Info Table Provernance Entries (IPE) are searchable by+this pointer and contain a source location.++The info table / info table code pointer to source location map is described in:+Note [Mapping Info Tables to Source Positions]++To be able to lookup IPEs for return frames one needs to emit them during compile time. This is done+by `generateCgIPEStub`.++This leads to the question: How to figure out the source location of a return frame?++While the lookup algorithms for registerised and unregisterised builds differ in details, they have in+common that we want to lookup the `CmmNode.CmmTick` (containing a `SourceNote`) that is nearest+(before) the usage of the return frame's label. (Which label and label type is used differs between+these two use cases.)++Registerised+~~~~~~~~~~~~~++Let's consider this example:+```+ Main.returnFrame_entry() { //  [R2]+         { info_tbls: [(c18g,+                        label: block_c18g_info+                        rep: StackRep []+                        srt: Just GHC.CString.unpackCString#_closure),+                       (c18r,+                        label: Main.returnFrame_info+                        rep: HeapRep static { Fun {arity: 1 fun_type: ArgSpec 5} }+                        srt: Nothing)]+           stack_info: arg_space: 8+         }+     {offset++      [...]++       c18u: // global+           //tick src<Main.hs:(7,1)-(16,15)>+           I64[Hp - 16] = sat_s16B_info;+           P64[Hp] = _s16r::P64;+           _c17j::P64 = Hp - 16;+           //tick src<Main.hs:8:25-39>+           I64[Sp - 8] = c18g;+           R3 = _c17j::P64;+           R2 = GHC.IO.Unsafe.unsafePerformIO_closure;+           R1 = GHC.Base.$_closure;+           Sp = Sp - 8;+           call stg_ap_pp_fast(R3,+                               R2,+                               R1) returns to c18g, args: 8, res: 8, upd: 8;+```++The return frame `block_c18g_info` has the label `c18g` which is used in the call to `stg_ap_pp_fast`+(`returns to c18g`) as continuation (`cml_cont`). The source location we're after, is the nearest+`//tick` before the call (`//tick src<Main.hs:8:25-39>`).++In code the Cmm program is represented as a Hoopl graph. Hoopl distinguishes nodes by defining if they+are open or closed on entry (one can fallthrough to them from the previous instruction) and if they are+open or closed on exit (one can fallthrough from them to the next node).++Please refer to the paper "Hoopl: A Modular, Reusable Library for Dataflow Analysis and Transformation"+for a detailed explanation.++Here we use the fact, that calls (represented by `CmmNode.CmmCall`) are always closed on exit+(`CmmNode O C`, `O` means open, `C` closed). In other words, they are always at the end of a block.++So, given a stack represented info table (likely representing a return frame, but this isn't completely+sure as there are e.g. update frames, too) with it's label (`c18g` in the example above) and a `CmmGraph`:+  - Look at the end of every block, if it's a `CmmNode.CmmCall` returning to the continuation with the+    label of the return frame.+  - If there's such a call, lookup the nearest `CmmNode.CmmTick` by traversing the middle part of the block+    backwards (from end to beginning).+  - Take the first `CmmNode.CmmTick` that contains a `Tickish.SourceNote` and return it's payload as+    `IpeSourceLocation`. (There are other `Tickish` constructors like `ProfNote` or `HpcTick`, these are+    ignored.)++Unregisterised+~~~~~~~~~~~~~++In unregisterised builds there is no return frame / continuation label in calls. The continuation (i.e. return+frame) is set in an explicit Cmm assignment. Thus the tick lookup algorithm has to be slightly different.++```+ sat_s16G_entry() { //  [R1]+         { info_tbls: [(c18O,+                        label: sat_s16G_info+                        rep: HeapRep { Thunk }+                        srt: Just _u18Z_srt)]+           stack_info: arg_space: 0+         }+     {offset+       c18O: // global+           _s16G::P64 = R1;+           if ((Sp + 8) - 40 < SpLim) (likely: False) goto c18P; else goto c18Q;+       c18P: // global+           R1 = _s16G::P64;+           call (stg_gc_enter_1)(R1) args: 8, res: 0, upd: 8;+       c18Q: // global+           I64[Sp - 16] = stg_upd_frame_info;+           P64[Sp - 8] = _s16G::P64;+           //tick src<Main.hs:20:9-13>+           I64[Sp - 24] = block_c18M_info;+           R1 = GHC.Show.$fShow[]_closure;+           P64[Sp - 32] = GHC.Show.$fShowChar_closure;+           Sp = Sp - 32;+           call stg_ap_p_fast(R1) args: 16, res: 8, upd: 24;+     }+ },+ _blk_c18M() { //  [R1]+         { info_tbls: [(c18M,+                        label: block_c18M_info+                        rep: StackRep []+                        srt: Just System.IO.print_closure)]+           stack_info: arg_space: 0+         }+     {offset+       c18M: // global+           _s16F::P64 = R1;+           R1 = System.IO.print_closure;+           P64[Sp] = _s16F::P64;+           call stg_ap_p_fast(R1) args: 32, res: 0, upd: 24;+     }+ },+```++In this example we have to lookup `//tick src<Main.hs:20:9-13>` for the return frame `c18M`.+Notice, that this cannot be done with the `Label` `c18M`, but with the `CLabel` `block_c18M_info`+(`label: block_c18M_info` is actually a `CLabel`).++The find the tick:+  - Every `Block` is checked from top (first) to bottom (last) node for an assignment like+   `I64[Sp - 24] = block_c18M_info;`. The lefthand side is actually ignored.+  - If such an assignment is found the search is over, because the payload (content of+    `Tickish.SourceNote`, represented as `IpeSourceLocation`) of last visited tick is always+    remembered in a `Maybe`.+-}++generateCgIPEStub :: HscEnv -> Module -> InfoTableProvMap -> NameEnv TagSig -> Stream IO CmmGroupSRTs (NonCaffySet, ModuleLFInfos) -> Stream IO CmmGroupSRTs CgInfos+generateCgIPEStub hsc_env this_mod denv tag_sigs s = do+  let dflags   = hsc_dflags hsc_env+      platform = targetPlatform dflags+      fstate   = initFCodeState platform+  cgState <- liftIO initC++  -- Collect info tables, but only if -finfo-table-map is enabled, otherwise labeledInfoTablesWithTickishes is empty.+  let collectFun = if gopt Opt_InfoTableMap dflags then collect platform else collectNothing+  (labeledInfoTablesWithTickishes, (nonCaffySet, moduleLFInfos)) <- Stream.mapAccumL_ collectFun [] s++  -- Yield Cmm for Info Table Provenance Entries (IPEs)+  let denv' = denv {provInfoTables = Map.fromList (map (\(_, i, t) -> (cit_lbl i, t)) labeledInfoTablesWithTickishes)}+      ((ipeStub, ipeCmmGroup), _) = runC (initStgToCmmConfig dflags this_mod) fstate cgState $ getCmm (initInfoTableProv (map sndOf3 labeledInfoTablesWithTickishes) denv')++  (_, ipeCmmGroupSRTs) <- liftIO $ cmmPipeline hsc_env (emptySRT this_mod) ipeCmmGroup+  Stream.yield ipeCmmGroupSRTs++  return CgInfos {cgNonCafs = nonCaffySet, cgLFInfos = moduleLFInfos, cgIPEStub = ipeStub, cgTagSigs = tag_sigs}+  where+    collect :: Platform -> [(Label, CmmInfoTable, Maybe IpeSourceLocation)] -> CmmGroupSRTs -> IO ([(Label, CmmInfoTable, Maybe IpeSourceLocation)], CmmGroupSRTs)+    collect platform acc cmmGroupSRTs = do+      let labelsToInfoTables = collectInfoTables cmmGroupSRTs+          labelsToInfoTablesToTickishes = map (\(l, i) -> (l, i, lookupEstimatedTick platform cmmGroupSRTs l i)) labelsToInfoTables+      return (acc ++ labelsToInfoTablesToTickishes, cmmGroupSRTs)++    collectNothing :: [a] -> CmmGroupSRTs -> IO ([a], CmmGroupSRTs)+    collectNothing _ cmmGroupSRTs = pure ([], cmmGroupSRTs)++    collectInfoTables :: CmmGroupSRTs -> [(Label, CmmInfoTable)]+    collectInfoTables cmmGroup = concat $ catMaybes $ map extractInfoTables cmmGroup++    extractInfoTables :: GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph -> Maybe [(Label, CmmInfoTable)]+    extractInfoTables (CmmProc h _ _ _) = Just $ mapToList (info_tbls h)+    extractInfoTables _ = Nothing++    lookupEstimatedTick :: Platform -> CmmGroupSRTs -> Label -> CmmInfoTable -> Maybe IpeSourceLocation+    lookupEstimatedTick platform cmmGroup infoTableLabel infoTable = do+      -- All return frame info tables are stack represented, though not all stack represented info+      -- tables have to be return frames.+      if (isStackRep . cit_rep) infoTable+        then do+          let findFun =+                if platformUnregisterised platform+                  then findCmmTickishForForUnregistered (cit_lbl infoTable)+                  else findCmmTickishForRegistered infoTableLabel+              blocks = concatMap toBlockList (graphs cmmGroup)+          firstJusts $ map findFun blocks+        else Nothing+    graphs :: CmmGroupSRTs -> [CmmGraph]+    graphs = foldl' go []+      where+        go :: [CmmGraph] -> GenCmmDecl d h CmmGraph -> [CmmGraph]+        go acc (CmmProc _ _ _ g) = g : acc+        go acc _ = acc++    findCmmTickishForRegistered :: Label -> Block CmmNode C C -> Maybe IpeSourceLocation+    findCmmTickishForRegistered label block = do+      let (_, middleBlock, endBlock) = blockSplit block++      isCallWithReturnFrameLabel endBlock label+      lastTickInBlock middleBlock+      where+        isCallWithReturnFrameLabel :: CmmNode O C -> Label -> Maybe ()+        isCallWithReturnFrameLabel (CmmCall _ (Just l) _ _ _ _) clabel | l == clabel = Just ()+        isCallWithReturnFrameLabel _ _ = Nothing++        lastTickInBlock block =+          listToMaybe $+            catMaybes $+              map maybeTick $ (reverse . blockToList) block++        maybeTick :: CmmNode O O -> Maybe IpeSourceLocation+        maybeTick (CmmTick (SourceNote span name)) = Just (span, name)+        maybeTick _ = Nothing++    findCmmTickishForForUnregistered :: CLabel -> Block CmmNode C C -> Maybe IpeSourceLocation+    findCmmTickishForForUnregistered cLabel block = do+      let (_, middleBlock, _) = blockSplit block+      find cLabel (blockToList middleBlock) Nothing+      where+        find :: CLabel -> [CmmNode O O] -> Maybe IpeSourceLocation -> Maybe IpeSourceLocation+        find label (b : blocks) lastTick = case b of+          (CmmStore _ (CmmLit (CmmLabel l)) _) -> if label == l then lastTick else find label blocks lastTick+          (CmmTick (SourceNote span name)) -> find label blocks $ Just (span, name)+          _ -> find label blocks lastTick+        find _ [] _ = Nothing
GHC/Driver/Hooks.hs view
@@ -3,7 +3,7 @@ -- NB: this module is SOURCE-imported by DynFlags, and should primarily --     refer to *types*, rather than *code* -{-# LANGUAGE CPP, RankNTypes, TypeFamilies #-}+{-# LANGUAGE RankNTypes, TypeFamilies #-}  module GHC.Driver.Hooks    ( Hooks@@ -33,7 +33,7 @@  import GHC.Driver.Env import GHC.Driver.Session-import GHC.Driver.Pipeline.Monad+import GHC.Driver.Pipeline.Phases  import GHC.Hs.Decls import GHC.Hs.Binds@@ -49,7 +49,6 @@ import GHC.Types.IPE import GHC.Types.Meta import GHC.Types.HpcInfo-import GHC.Types.ForeignStubs  import GHC.Unit.Module import GHC.Unit.Module.ModSummary@@ -63,6 +62,7 @@ import GHC.Tc.Types import GHC.Stg.Syntax import GHC.StgToCmm.Types (ModuleLFInfos)+import GHC.StgToCmm.Config import GHC.Cmm  import GHCi.RemoteTypes@@ -72,6 +72,7 @@  import qualified Data.Kind import System.Process+import GHC.Linker.Types  {- ************************************************************************@@ -134,19 +135,18 @@   , tcForeignExportsHook   :: !(Maybe ([LForeignDecl GhcRn]             -> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt)))   , hscFrontendHook        :: !(Maybe (ModSummary -> Hsc FrontendResult))-  , hscCompileCoreExprHook ::-               !(Maybe (HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue))+  , hscCompileCoreExprHook :: !(Maybe (HscEnv -> SrcSpan -> CoreExpr -> IO (ForeignHValue, [Linkable], PkgsLoaded)))   , ghcPrimIfaceHook       :: !(Maybe ModIface)-  , runPhaseHook           :: !(Maybe (PhasePlus -> FilePath -> CompPipeline (PhasePlus, FilePath)))+  , runPhaseHook           :: !(Maybe PhaseHook)   , runMetaHook            :: !(Maybe (MetaHook TcM))   , linkHook               :: !(Maybe (GhcLink -> DynFlags -> Bool                                          -> HomePackageTable -> IO SuccessFlag))   , runRnSpliceHook        :: !(Maybe (HsSplice GhcRn -> RnM (HsSplice GhcRn)))   , getValueSafelyHook     :: !(Maybe (HscEnv -> Name -> Type-                                                          -> IO (Maybe HValue)))+                                         -> IO (Either Type (HValue, [Linkable], PkgsLoaded))))   , createIservProcessHook :: !(Maybe (CreateProcess -> IO ProcessHandle))-  , stgToCmmHook           :: !(Maybe (DynFlags -> Module -> InfoTableProvMap -> [TyCon] -> CollectedCCs-                                 -> [CgStgTopBinding] -> HpcInfo -> Stream IO CmmGroup (CStub, ModuleLFInfos)))+  , stgToCmmHook           :: !(Maybe (StgToCmmConfig -> InfoTableProvMap -> [TyCon] -> CollectedCCs+                                 -> [CgStgTopBinding] -> HpcInfo -> Stream IO CmmGroup ModuleLFInfos))   , cmmToRawCmmHook        :: !(forall a . Maybe (DynFlags -> Maybe Module -> Stream IO CmmGroupSRTs a                                  -> IO (Stream IO RawCmmGroup a)))   }
GHC/Driver/Main.hs view
@@ -1,2265 +1,2356 @@ {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE NondecreasingIndentation #-}--{-# OPTIONS_GHC -fprof-auto-top #-}--------------------------------------------------------------------------------------- | Main API for compiling plain Haskell source code.------ This module implements compilation of a Haskell source. It is--- /not/ concerned with preprocessing of source files; this is handled--- in "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--    -- * Compiling complete source files-    , Messager, batchMsg-    , HscStatus (..)-    , hscIncrementalCompile-    , initModDetails-    , hscMaybeWriteIface-    , hscCompileCmmFile--    , hscGenHardCode-    , hscInteractive--    -- * Running passes separately-    , hscParse-    , hscTypecheckRename-    , hscDesugar-    , makeSimpleDetails-    , hscSimplify -- ToDo, shouldn't really export this--    -- * Safe Haskell-    , hscCheckSafe-    , hscGetSafe--    -- * Support for interactive evaluation-    , hscParseIdentifier-    , hscTcRcLookupName-    , hscTcRnGetInfo-    , hscIsGHCiMonad-    , hscGetModuleInterface-    , hscRnImportDecls-    , hscTcRnLookupRdrName-    , hscStmt, hscParseStmtWithLocation, hscStmtWithLocation, hscParsedStmt-    , hscDecls, hscParseDeclsWithLocation, hscDeclsWithLocation, hscParsedDecls-    , hscTcExpr, TcRnExprMode(..), hscImport, hscKcType-    , hscParseExpr-    , hscParseType-    , hscCompileCoreExpr-    -- * 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-    ) where--import GHC.Prelude--import GHC.Driver.Plugins-import GHC.Driver.Session-import GHC.Driver.Backend-import GHC.Driver.Env-import GHC.Driver.Errors-import GHC.Driver.CodeOutput-import GHC.Driver.Config-import GHC.Driver.Hooks-import GHC.Parser.Errors--import GHC.Runtime.Context-import GHC.Runtime.Interpreter ( addSptEntry, hscInterp )-import GHC.Runtime.Loader      ( initializePlugins )-import GHCi.RemoteTypes        ( ForeignHValue )-import GHC.ByteCode.Types--import GHC.Linker.Loader-import GHC.Linker.Types--import GHC.Hs-import GHC.Hs.Dump-import GHC.Hs.Stats         ( ppSourceStats )--import GHC.HsToCore--import GHC.StgToByteCode    ( byteCodeGen )--import GHC.IfaceToCore  ( typecheckIface )--import GHC.Iface.Load   ( ifaceStats, initExternalPackageState, writeIface )-import GHC.Iface.Make-import GHC.Iface.Recomp-import GHC.Iface.Tidy-import GHC.Iface.Ext.Ast    ( mkHieFile )-import GHC.Iface.Ext.Types  ( getAsts, hie_asts, hie_module )-import GHC.Iface.Ext.Binary ( readHieFile, writeHieFile , hie_file_result, NameCacheUpdater(..))-import GHC.Iface.Ext.Debug  ( diffFile, validateScopes )-import GHC.Iface.Env        ( updNameCache )--import GHC.Core-import GHC.Core.Tidy           ( tidyExpr )-import GHC.Core.Type           ( Type, Kind )-import GHC.Core.Lint           ( lintInteractiveExpr )-import GHC.Core.Multiplicity-import GHC.Core.Utils          ( exprType )-import GHC.Core.ConLike-import GHC.Core.Opt.Pipeline-import GHC.Core.TyCon-import GHC.Core.InstEnv-import GHC.Core.FamInstEnv--import GHC.CoreToStg.Prep-import GHC.CoreToStg    ( coreToStg )--import GHC.Parser.Errors.Ppr-import GHC.Parser-import GHC.Parser.Lexer as Lexer--import GHC.Tc.Module-import GHC.Tc.Utils.Monad-import GHC.Tc.Utils.Zonk    ( ZonkFlexi (DefaultFlexi) )--import GHC.Stg.Syntax-import GHC.Stg.FVs      ( annTopBindingsFreeVars )-import GHC.Stg.Pipeline ( stg2stg )--import GHC.Builtin.Utils-import GHC.Builtin.Names-import GHC.Builtin.Uniques ( mkPseudoUniqueE )--import qualified GHC.StgToCmm as StgToCmm ( codeGen )-import GHC.StgToCmm.Types (CgInfos (..), ModuleLFInfos)--import GHC.Cmm-import GHC.Cmm.Parser       ( parseCmmFile )-import GHC.Cmm.Info.Build-import GHC.Cmm.Pipeline-import GHC.Cmm.Info--import GHC.Unit-import GHC.Unit.External-import GHC.Unit.State-import GHC.Unit.Module.ModDetails-import GHC.Unit.Module.ModGuts-import GHC.Unit.Module.ModIface-import GHC.Unit.Module.ModSummary-import GHC.Unit.Module.Graph-import GHC.Unit.Module.Imported-import GHC.Unit.Module.Deps-import GHC.Unit.Module.Status-import GHC.Unit.Home.ModInfo--import GHC.Types.Id-import GHC.Types.SourceError-import GHC.Types.SafeHaskell-import GHC.Types.ForeignStubs-import GHC.Types.Var.Env       ( emptyTidyEnv )-import GHC.Types.Error-import GHC.Types.Fixity.Env-import GHC.Types.CostCentre-import GHC.Types.IPE-import GHC.Types.Unique.Supply-import GHC.Types.SourceFile-import GHC.Types.SrcLoc-import GHC.Types.Name-import GHC.Types.Name.Env-import GHC.Types.Name.Cache ( initNameCache )-import GHC.Types.Name.Reader-import GHC.Types.Name.Ppr-import GHC.Types.TyThing-import GHC.Types.HpcInfo--import GHC.Utils.Fingerprint ( Fingerprint )-import GHC.Utils.Panic-import GHC.Utils.Error-import GHC.Utils.Outputable-import GHC.Utils.Exception-import GHC.Utils.Misc-import GHC.Utils.Logger-import GHC.Utils.TmpFs--import GHC.Data.FastString-import GHC.Data.Bag-import GHC.Data.StringBuffer-import qualified GHC.Data.Stream as Stream-import GHC.Data.Stream (Stream)--import Data.Data hiding (Fixity, TyCon)-import Data.List        ( nub, isPrefixOf, partition )-import Control.Monad-import Data.IORef-import System.FilePath as FilePath-import System.Directory-import System.IO (fixIO)-import qualified Data.Set as S-import Data.Set (Set)-import Data.Functor-import Control.DeepSeq (force)-import Data.Bifunctor (first, bimap)-import GHC.Data.Maybe-import Data.List.NonEmpty (NonEmpty ((:|)))--#include "HsVersions.h"---{- **********************************************************************-%*                                                                      *-                Initialisation-%*                                                                      *-%********************************************************************* -}--newHscEnv :: DynFlags -> IO HscEnv-newHscEnv dflags = do-    -- we don't store the unit databases and the unit state to still-    -- allow `setSessionDynFlags` to be used to set unit db flags.-    eps_var <- newIORef initExternalPackageState-    us      <- mkSplitUniqSupply 'r'-    nc_var  <- newIORef (initNameCache us knownKeyNames)-    fc_var  <- newIORef emptyInstalledModuleEnv-    logger  <- initLogger-    tmpfs   <- initTmpFs-    -- FIXME: it's sad that we have so many "unitialized" fields filled with-    -- empty stuff or lazy panics. We should have two kinds of HscEnv-    -- (initialized or not) instead and less fields that are mutable over time.-    return HscEnv {  hsc_dflags         = dflags-                  ,  hsc_logger         = logger-                  ,  hsc_targets        = []-                  ,  hsc_mod_graph      = emptyMG-                  ,  hsc_IC             = emptyInteractiveContext dflags-                  ,  hsc_HPT            = emptyHomePackageTable-                  ,  hsc_EPS            = eps_var-                  ,  hsc_NC             = nc_var-                  ,  hsc_FC             = fc_var-                  ,  hsc_type_env_var   = Nothing-                  ,  hsc_interp         = Nothing-                  ,  hsc_unit_env       = panic "hsc_unit_env not initialized"-                  ,  hsc_plugins        = []-                  ,  hsc_static_plugins = []-                  ,  hsc_unit_dbs       = Nothing-                  ,  hsc_hooks          = emptyHooks-                  ,  hsc_tmpfs          = tmpfs-                  }---- -------------------------------------------------------------------------------getWarnings :: Hsc WarningMessages-getWarnings = Hsc $ \_ w -> return (w, w)--clearWarnings :: Hsc ()-clearWarnings = Hsc $ \_ _ -> return ((), emptyBag)--logWarnings :: WarningMessages -> Hsc ()-logWarnings w = Hsc $ \_ w0 -> return ((), w0 `unionBags` w)--getHscEnv :: Hsc HscEnv-getHscEnv = Hsc $ \e w -> return (e, w)--handleWarnings :: Hsc ()-handleWarnings = do-    dflags <- getDynFlags-    logger <- getLogger-    w <- getWarnings-    liftIO $ printOrThrowWarnings logger dflags w-    clearWarnings---- | log warning in the monad, and if there are errors then--- throw a SourceError exception.-logWarningsReportErrors :: (Bag PsWarning, Bag PsError) -> Hsc ()-logWarningsReportErrors (warnings,errors) = do-    let warns = fmap pprWarning warnings-        errs  = fmap pprError   errors-    logWarnings warns-    when (not $ isEmptyBag errs) $ throwErrors errs---- | Log warnings and throw errors, assuming the messages--- contain at least one error (e.g. coming from PFailed)-handleWarningsThrowErrors :: (Bag PsWarning, Bag PsError) -> Hsc a-handleWarningsThrowErrors (warnings, errors) = do-    let warns = fmap pprWarning warnings-        errs  = fmap pprError   errors-    logWarnings warns-    dflags <- getDynFlags-    logger <- getLogger-    (wWarns, wErrs) <- warningsToMessages dflags <$> getWarnings-    liftIO $ printBagOfErrors logger dflags wWarns-    throwErrors (unionBags errs wErrs)---- | Deal with errors and warnings returned by a compilation step------ In order to reduce dependencies to other parts of the compiler, functions--- outside the "main" parts of GHC return warnings and errors as a parameter--- and signal success via by wrapping the result in a 'Maybe' type. This--- function logs the returned warnings and propagates errors as exceptions--- (of type 'SourceError').------ This function assumes the following invariants:------  1. If the second result indicates success (is of the form 'Just x'),---     there must be no error messages in the first result.------  2. If there are no error messages, but the second result indicates failure---     there should be warnings in the first result. That is, if the action---     failed, it must have been due to the warnings (i.e., @-Werror@).-ioMsgMaybe :: IO (Messages DecoratedSDoc, Maybe a) -> Hsc a-ioMsgMaybe ioA = do-    (msgs, mb_r) <- liftIO ioA-    let (warns, errs) = partitionMessages msgs-    logWarnings warns-    case mb_r of-        Nothing -> throwErrors errs-        Just r  -> ASSERT( isEmptyBag errs ) return r---- | like ioMsgMaybe, except that we ignore error messages and return--- 'Nothing' instead.-ioMsgMaybe' :: IO (Messages DecoratedSDoc, Maybe a) -> Hsc (Maybe a)-ioMsgMaybe' ioA = do-    (msgs, mb_r) <- liftIO $ ioA-    logWarnings (getWarningMessages msgs)-    return mb_r---- -------------------------------------------------------------------------------- | Lookup things in the compiler's environment--hscTcRnLookupRdrName :: HscEnv -> LocatedN RdrName -> IO [Name]-hscTcRnLookupRdrName hsc_env0 rdr_name-  = runInteractiveHsc hsc_env0 $-    do { hsc_env <- getHscEnv-       ; ioMsgMaybe $ tcRnLookupRdrName hsc_env rdr_name }--hscTcRcLookupName :: HscEnv -> Name -> IO (Maybe TyThing)-hscTcRcLookupName hsc_env0 name = runInteractiveHsc hsc_env0 $ do-  hsc_env <- getHscEnv-  ioMsgMaybe' $ tcRnLookupName hsc_env name-      -- ignore errors: the only error we're likely to get is-      -- "name not found", and the Maybe in the return type-      -- is used to indicate that.--hscTcRnGetInfo :: HscEnv -> Name-               -> IO (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))-hscTcRnGetInfo hsc_env0 name-  = runInteractiveHsc hsc_env0 $-    do { hsc_env <- getHscEnv-       ; ioMsgMaybe' $ tcRnGetInfo hsc_env name }--hscIsGHCiMonad :: HscEnv -> String -> IO Name-hscIsGHCiMonad hsc_env name-  = runHsc hsc_env $ ioMsgMaybe $ isGHCiMonad hsc_env name--hscGetModuleInterface :: HscEnv -> Module -> IO ModIface-hscGetModuleInterface hsc_env0 mod = runInteractiveHsc hsc_env0 $ do-  hsc_env <- getHscEnv-  ioMsgMaybe $ getModuleInterface hsc_env mod---- -------------------------------------------------------------------------------- | Rename some import declarations-hscRnImportDecls :: HscEnv -> [LImportDecl GhcPs] -> IO GlobalRdrEnv-hscRnImportDecls hsc_env0 import_decls = runInteractiveHsc hsc_env0 $ do-  hsc_env <- getHscEnv-  ioMsgMaybe $ tcRnImportDecls hsc_env import_decls---- -------------------------------------------------------------------------------- | parse a file, returning the abstract syntax--hscParse :: HscEnv -> ModSummary -> IO HsParsedModule-hscParse hsc_env mod_summary = runHsc hsc_env $ hscParse' mod_summary---- internal version, that doesn't fail due to -Werror-hscParse' :: ModSummary -> Hsc HsParsedModule-hscParse' mod_summary- | Just r <- ms_parsed_mod mod_summary = return r- | otherwise = do-    dflags <- getDynFlags-    logger <- getLogger-    {-# SCC "Parser" #-} withTiming logger dflags-                (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--    when (wopt Opt_WarnUnicodeBidirectionalFormatCharacters dflags) $ do-      case checkBidirectionFormatChars (PsLoc loc (BufPos 0)) buf of-        Nothing -> pure ()-        Just chars ->-          logWarnings $ unitBag $ pprWarning $-               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 (getMessages pst)-        POk pst rdr_module -> do-            let (warns, errs) = bimap (fmap pprWarning) (fmap pprError) (getMessages pst)-            logWarnings warns-            liftIO $ dumpIfSet_dyn logger dflags Opt_D_dump_parsed "Parser"-                        FormatHaskell (ppr rdr_module)-            liftIO $ dumpIfSet_dyn logger dflags Opt_D_dump_parsed_ast "Parser AST"-                        FormatHaskell (showAstData NoBlankSrcSpan-                                                   NoBlankEpAnnotations-                                                   rdr_module)-            liftIO $ dumpIfSet_dyn logger dflags Opt_D_source_stats "Source Statistics"-                        FormatText (ppSourceStats False rdr_module)-            when (not $ isEmptyBag errs) $ throwErrors errs--            -- To get the list of extra source files, we take the list-            -- that the parser gave us,-            --   - eliminate files beginning with '<'.  gcc likes to use-            --     pseudo-filenames like "<built-in>" and "<command-line>"-            --   - normalise them (eliminate differences between ./f and f)-            --   - filter out the preprocessed source file-            --   - filter out anything beginning with tmpdir-            --   - remove duplicates-            --   - filter out the .hs/.lhs source filename if we have one-            ---            let n_hspp  = FilePath.normalise src_filename-                srcs0 = nub $ filter (not . (tmpDir dflags `isPrefixOf`))-                            $ filter (not . (== n_hspp))-                            $ map FilePath.normalise-                            $ filter (not . isPrefixOf "<")-                            $ map unpackFS-                            $ srcfiles pst-                srcs1 = case ml_hs_file (ms_location mod_summary) of-                          Just f  -> filter (/= FilePath.normalise f) srcs0-                          Nothing -> srcs0--            -- sometimes we see source files from earlier-            -- preprocessing stages that cannot be found, so just-            -- filter them out:-            srcs2 <- liftIO $ filterM doesFileExist srcs1--            let res = HsParsedModule {-                      hpm_module    = rdr_module,-                      hpm_src_files = srcs2-                   }--            -- apply parse transformation of plugins-            let applyPluginAction p opts-                  = parsedResultAction p opts mod_summary-            hsc_env <- getHscEnv-            withPlugins hsc_env applyPluginAction res--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 $ dumpIfSet_dyn logger dflags 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 $ dumpIfSet_dyn logger dflags Opt_D_dump_hie "HIE AST" FormatHaskell (ppr $ hie_asts hieFile)--        -- Validate HIE files-        when (gopt Opt_ValidateHie dflags) $ do-            hs_env <- Hsc $ \e w -> return (e, w)-            liftIO $ do-              -- Validate Scopes-              case validateScopes (hie_module hieFile) $ getAsts $ hie_asts hieFile of-                  [] -> putMsg logger dflags $ text "Got valid scopes"-                  xs -> do-                    putMsg logger dflags $ text "Got invalid scopes"-                    mapM_ (putMsg logger dflags) xs-              -- Roundtrip testing-              file' <- readHieFile (NCU $ updNameCache $ hsc_NC hs_env) out_file-              case diffFile hieFile (hie_file_result file') of-                [] ->-                  putMsg logger dflags $ text "Got no roundtrip errors"-                xs -> do-                  putMsg logger dflags $ text "Got roundtrip errors"-                  mapM_ (putMsg logger (dopt_set dflags Opt_D_ppr_debug)) xs-    return rn_info----- -------------------------------------------------------------------------------- | Rename and typecheck a module, additionally returning the renamed syntax-hscTypecheckRename :: HscEnv -> ModSummary -> HsParsedModule-                   -> IO (TcGblEnv, RenamedStuff)-hscTypecheckRename hsc_env mod_summary rdr_module = runHsc hsc_env $-    hsc_typecheck True mod_summary (Just rdr_module)----- | 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 $ tcRnInstantiateSignature hsc_env outer_mod' real_loc-        else-         do hpm <- case mb_rdr_module of-                    Just hpm -> return hpm-                    Nothing -> hscParse' mod_summary-            tc_result0 <- tcRnModule' mod_summary keep_rn' hpm-            if hsc_src == HsigFile-                then do (iface, _, _) <- liftIO $ hscSimpleIface hsc_env tc_result0 Nothing-                        ioMsgMaybe $-                            tcRnMergeSignatures hsc_env hpm tc_result0 iface-                else return tc_result0-    -- 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--    -- -Wmissing-safe-haskell-mode-    when (not (safeHaskellModeEnabled dflags)-          && wopt Opt_WarnMissingSafeHaskellMode dflags) $-        logWarnings $ unitBag $-        makeIntoWarning (Reason Opt_WarnMissingSafeHaskellMode) $-        mkPlainWarnMsg (getLoc (hpm_module mod)) $-        warnMissingSafeHaskellMode--    tcg_res <- {-# SCC "Typecheck-Rename" #-}-               ioMsgMaybe $-                   tcRnModule hsc_env sum-                     save_rn_syntax mod--    -- See Note [Safe Haskell Overlapping Instances Implementation]-    -- although this is used for more than just that failure case.-    (tcSafeOK, whyUnsafe) <- liftIO $ readIORef (tcg_safeInfer tcg_res)-    let allSafeOK = safeInferred dflags && tcSafeOK--    -- end of the safe haskell line, how to respond to user?-    if not (safeHaskellOn dflags)-         || (safeInferOn dflags && not allSafeOK)-      -- if safe Haskell off or safe infer failed, mark unsafe-      then markUnsafeInfer tcg_res whyUnsafe--      -- module (could be) safe, throw warning if needed-      else do-          tcg_res' <- hscCheckSafeImports tcg_res-          safe <- liftIO $ fst <$> readIORef (tcg_safeInfer tcg_res')-          when safe $-            case wopt Opt_WarnSafe dflags of-              True-                | safeHaskell dflags == Sf_Safe -> return ()-                | otherwise -> (logWarnings $ unitBag $-                       makeIntoWarning (Reason Opt_WarnSafe) $-                       mkPlainWarnMsg (warnSafeOnLoc dflags) $-                       errSafe tcg_res')-              False | safeHaskell dflags == Sf_Trustworthy &&-                      wopt Opt_WarnTrustworthySafe dflags ->-                      (logWarnings $ unitBag $-                       makeIntoWarning (Reason Opt_WarnTrustworthySafe) $-                       mkPlainWarnMsg (trustworthyOnLoc dflags) $-                       errTwthySafe tcg_res')-              False -> return ()-          return tcg_res'-  where-    pprMod t  = ppr $ moduleName $ tcg_mod t-    errSafe t = quotes (pprMod t) <+> text "has been inferred as safe!"-    errTwthySafe t = quotes (pprMod t)-      <+> text "is marked as Trustworthy but has been inferred as safe!"-    warnMissingSafeHaskellMode = ppr (moduleName (ms_mod sum))-      <+> text "is missing Safe Haskell mode"---- | Convert a typechecked module to Core-hscDesugar :: HscEnv -> ModSummary -> TcGblEnv -> IO ModGuts-hscDesugar hsc_env mod_summary tc_result =-    runHsc hsc_env $ hscDesugar' (ms_location mod_summary) tc_result--hscDesugar' :: ModLocation -> TcGblEnv -> Hsc ModGuts-hscDesugar' mod_location tc_result = do-    hsc_env <- getHscEnv-    r <- ioMsgMaybe $-      {-# SCC "deSugar" #-}-      deSugar hsc_env mod_location tc_result--    -- always check -Werror after desugaring, this is the last opportunity for-    -- warnings to arise before the backend.-    handleWarnings-    return r---- | Make a 'ModDetails' from the results of typechecking. Used when--- typechecking only, as opposed to full compilation.-makeSimpleDetails :: HscEnv -> TcGblEnv -> IO ModDetails-makeSimpleDetails hsc_env tc_result = mkBootModDetailsTc hsc_env tc_result---{- **********************************************************************-%*                                                                      *-                The main compiler pipeline-%*                                                                      *-%********************************************************************* -}--{--                   ---------------------------------                        The compilation proper-                   ----------------------------------It's the task of the compilation proper to compile Haskell, hs-boot and core-files to either byte-code, hard-code (C, asm, LLVM, etc.) or to nothing at all-(the module is still parsed and type-checked. This feature is mostly used by-IDE's and the likes). Compilation can happen in either 'one-shot', 'batch',-'nothing', or 'interactive' mode. 'One-shot' mode targets hard-code, 'batch'-mode targets hard-code, 'nothing' mode targets nothing and 'interactive' mode-targets byte-code.--The modes are kept separate because of their different types and meanings:-- * In 'one-shot' mode, we're only compiling a single file and can therefore- discard the new ModIface and ModDetails. This is also the reason it only- targets hard-code; compiling to byte-code or nothing doesn't make sense when- we discard the result.-- * 'Batch' mode is like 'one-shot' except that we keep the resulting ModIface- and ModDetails. 'Batch' mode doesn't target byte-code since that require us to- return the newly compiled byte-code.-- * 'Nothing' mode has exactly the same type as 'batch' mode but they're still- kept separate. This is because compiling to nothing is fairly special: We- don't output any interface files, we don't run the simplifier and we don't- generate any code.-- * 'Interactive' mode is similar to 'batch' mode except that we return the- compiled byte-code together with the ModIface and ModDetails.--Trying to compile a hs-boot file to byte-code will result in a run-time error.-This is the only thing that isn't caught by the type-system.--}---type Messager = HscEnv -> (Int,Int) -> RecompileRequired -> ModuleGraphNode -> IO ()---- | This function runs GHC's frontend with recompilation--- avoidance. Specifically, it checks if recompilation is needed,--- and if it is, it parses and typechecks the input module.--- It does not write out the results of typechecking (See--- compileOne and hscIncrementalCompile).-hscIncrementalFrontend :: Bool -- always do basic recompilation check?-                       -> Maybe TcGblEnv-                       -> Maybe Messager-                       -> ModSummary-                       -> SourceModified-                       -> Maybe ModIface  -- Old interface, if available-                       -> (Int,Int)       -- (i,n) = module i of n (for msgs)-                       -> Hsc (Either ModIface (FrontendResult, Maybe Fingerprint))--hscIncrementalFrontend-  always_do_basic_recompilation_check m_tc_result-  mHscMessage mod_summary source_modified mb_old_iface mod_index-    = do-    hsc_env <- getHscEnv--    let msg what = case mHscMessage of-          -- We use extendModSummaryNoDeps because extra backpack deps are only needed for batch mode-          Just hscMessage -> hscMessage hsc_env mod_index what (ModuleNode (extendModSummaryNoDeps mod_summary))-          Nothing -> return ()--        skip iface = do-            liftIO $ msg UpToDate-            return $ Left iface--        compile mb_old_hash reason = do-            liftIO $ msg reason-            tc_result <- case hscFrontendHook (hsc_hooks hsc_env) of-              Nothing -> FrontendTypecheck . fst <$> hsc_typecheck False mod_summary Nothing-              Just h  -> h mod_summary-            return $ Right (tc_result, mb_old_hash)--        stable = case source_modified of-                     SourceUnmodifiedAndStable -> True-                     _                         -> False--    case m_tc_result of-         Just tc_result-          | not always_do_basic_recompilation_check ->-             return $ Right (FrontendTypecheck tc_result, Nothing)-         _ -> do-            (recomp_reqd, mb_checked_iface)-                <- {-# SCC "checkOldIface" #-}-                   liftIO $ checkOldIface hsc_env mod_summary-                                source_modified mb_old_iface-            -- save the interface that comes back from checkOldIface.-            -- In one-shot mode we don't have the old iface until this-            -- point, when checkOldIface reads it from the disk.-            let mb_old_hash = fmap (mi_iface_hash . mi_final_exts) mb_checked_iface--            case mb_checked_iface of-                Just iface | not (recompileRequired recomp_reqd) ->-                    -- If the module used TH splices when it was last-                    -- compiled, then the recompilation check is not-                    -- accurate enough (#481) and we must ignore-                    -- it.  However, if the module is stable (none of-                    -- the modules it depends on, directly or-                    -- indirectly, changed), then we *can* skip-                    -- recompilation. This is why the SourceModified-                    -- type contains SourceUnmodifiedAndStable, and-                    -- it's pretty important: otherwise ghc --make-                    -- would always recompile TH modules, even if-                    -- nothing at all has changed. Stability is just-                    -- the same check that make is doing for us in-                    -- one-shot mode.-                    case m_tc_result of-                    Nothing-                     | mi_used_th iface && not stable ->-                        compile mb_old_hash (RecompBecause "TH")-                    _ ->-                        skip iface-                _ ->-                    case m_tc_result of-                    Nothing -> compile mb_old_hash recomp_reqd-                    Just tc_result ->-                        return $ Right (FrontendTypecheck tc_result, mb_old_hash)------------------------------------------------------------------- Compilers------------------------------------------------------------------- | Used by both OneShot and batch mode. Runs the pipeline HsSyn and Core parts--- of the pipeline.--- We return a interface if we already had an old one around and recompilation--- was not needed. Otherwise it will be created during later passes when we--- run the compilation pipeline.-hscIncrementalCompile :: Bool-                      -> Maybe TcGblEnv-                      -> Maybe Messager-                      -> HscEnv-                      -> ModSummary-                      -> SourceModified-                      -> Maybe ModIface-                      -> (Int,Int)-                      -> IO (HscStatus, HscEnv)-hscIncrementalCompile always_do_basic_recompilation_check m_tc_result-    mHscMessage hsc_env' mod_summary source_modified mb_old_iface mod_index-  = do-    hsc_env'' <- initializePlugins hsc_env'--    -- One-shot mode needs a 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 mod = ms_mod mod_summary-        hsc_env | isOneShot (ghcMode (hsc_dflags hsc_env''))-                = hsc_env'' { hsc_type_env_var = Just (mod, type_env_var) }-                | otherwise-                = hsc_env''--    -- NB: enter Hsc monad here so that we don't bail out early with-    -- -Werror on typechecker warnings; we also want to run the desugarer-    -- to get those warnings too. (But we'll always exit at that point-    -- because the desugarer runs ioMsgMaybe.)-    runHsc hsc_env $ do-    e <- hscIncrementalFrontend always_do_basic_recompilation_check m_tc_result mHscMessage-            mod_summary source_modified mb_old_iface mod_index-    case e of-        -- We didn't need to do any typechecking; the old interface-        -- file on disk was good enough.-        Left iface -> do-            details <- liftIO $ initModDetails hsc_env mod_summary iface-            return (HscUpToDate iface details, hsc_env')-        -- We finished type checking.  (mb_old_hash is the hash of-        -- the interface that existed on disk; it's possible we had-        -- to retypecheck but the resulting interface is exactly-        -- the same.)-        Right (FrontendTypecheck tc_result, mb_old_hash) -> do-            status <- finish mod_summary tc_result mb_old_hash-            return (status, hsc_env)---- Knot tying!  See Note [Knot-tying typecheckIface]--- See Note [ModDetails and --make mode]-initModDetails :: HscEnv -> ModSummary -> ModIface -> IO ModDetails-initModDetails hsc_env mod_summary iface =-  fixIO $ \details' -> do-    let hsc_env' =-          hsc_env {-              hsc_HPT = addToHpt (hsc_HPT hsc_env)-                          (ms_mod_name mod_summary)-                          (HomeModInfo iface details' Nothing)-                  }-    -- 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---{--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.-finish :: ModSummary-       -> TcGblEnv-       -> Maybe Fingerprint-       -> Hsc HscStatus-finish summary tc_result mb_old_hash = do-  hsc_env <- getHscEnv-  dflags <- getDynFlags-  logger <- getLogger-  let bcknd  = backend dflags-      hsc_src = ms_hsc_src summary--  -- Desugar, if appropriate-  ---  -- We usually desugar even when we are not generating code, otherwise we-  -- would miss errors thrown by the desugaring (see #10600). The only-  -- exceptions are when the Module is Ghc.Prim or when it is not a-  -- HsSrcFile Module.-  mb_desugar <--      if ms_mod summary /= gHC_PRIM && hsc_src == HsSrcFile-      then Just <$> hscDesugar' (ms_location summary) tc_result-      else pure Nothing--  -- 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 | bcknd /= NoBackend -> do-          plugins <- liftIO $ readIORef (tcg_th_coreplugins tc_result)-          simplified_guts <- hscSimplify' plugins desugared_guts--          (cg_guts, details) <- {-# SCC "CoreTidy" #-}-              liftIO $ tidyProgram hsc_env simplified_guts--          let !partial_iface =-                {-# SCC "GHC.Driver.Main.mkPartialIface" #-}-                -- This `force` saves 2M residency in test T10370-                -- See Note [Avoiding space leaks in toIface*] for details.-                force (mkPartialIface hsc_env details 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-                           }--      -- We are not generating code, so we can skip simplification-      -- and generate a simple interface.-      _ -> do-        (iface, mb_old_iface_hash, details) <- liftIO $-          hscSimpleIface hsc_env tc_result mb_old_hash--        liftIO $ hscMaybeWriteIface logger dflags True iface mb_old_iface_hash (ms_location summary)--        return $ case bcknd of-          NoBackend -> HscNotGeneratingCode iface details-          _         -> case hsc_src of-                        HsBootFile -> HscUpdateBoot iface details-                        HsigFile   -> HscUpdateSig iface details-                        _          -> panic "finish"--{--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.finish: 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 -> ModIface -> Maybe Fingerprint -> ModLocation -> IO ()-hscMaybeWriteIface logger dflags is_simple iface old_iface mod_location = do-    let force_write_interface = gopt Opt_WriteInterface dflags-        write_interface = case backend dflags of-                            NoBackend    -> False-                            Interpreter  -> False-                            _            -> True--      -- mod_location only contains the base name, so we rebuild the-      -- correct file extension from the dynflags.-        baseName = ml_hi_file mod_location-        buildIfName suffix is_dynamic-          | Just name <- (if is_dynamic then dynOutputHi else outputHi) dflags-          = name-          | otherwise-          = let with_hi = replaceExtension baseName suffix-            in  addBootSuffix_maybe (mi_boot iface) with_hi--        write_iface dflags' iface =-          let !iface_name = buildIfName (hiSuf dflags') (dynamicNow dflags')-          in-          {-# SCC "writeIface" #-}-          withTiming logger dflags'-              (text "WriteIface"<+>brackets (text iface_name))-              (const ())-              (writeIface logger dflags' iface_name iface)--    when (write_interface || force_write_interface) $ do--      -- FIXME: with -dynamic-too, "no_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 "no_change".-      ---      --    * when we write two simple interfaces at once because of-      --    dynamic-too, we use "no_change" both for the non-dynamic and the-      --    dynamic interfaces. Hopefully both the dynamic and the non-dynamic-      --    interfaces stay in sync...-      ---      let no_change = old_iface == Just (mi_iface_hash (mi_final_exts iface))--      dt <- dynamicTooState dflags--      when (dopt Opt_D_dump_if_trace dflags) $ putMsg logger dflags $-        hang (text "Writing interface(s):") 2 $ vcat-         [ text "Kind:" <+> if is_simple then text "simple" else text "full"-         , text "Hash change:" <+> ppr (not no_change)-         , text "DynamicToo state:" <+> text (show dt)-         ]--      if is_simple-         then unless no_change $ do -- FIXME: see no_change' comment above-            write_iface dflags iface-            case dt of-               DT_Dont   -> return ()-               DT_Failed -> 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 | not no_change             -> write_iface dflags iface-               DT_OK   | not no_change             -> write_iface dflags iface-               -- FIXME: see no_change' comment above-               DT_Dyn                              -> write_iface dflags iface-               DT_Failed | not (dynamicNow dflags) -> write_iface dflags iface-               _                                   -> return ()------------------------------------------------------------------- NoRecomp handlers------------------------------------------------------------------- NB: this must be knot-tied appropriately, see hscIncrementalCompile-genModDetails :: HscEnv -> ModIface -> IO ModDetails-genModDetails hsc_env old_iface-  = do-    new_details <- {-# SCC "tcRnIface" #-}-                   initIfaceLoad hsc_env (typecheckIface old_iface)-    dumpIfaceStats hsc_env-    return new_details------------------------------------------------------------------- Progress displayers.-----------------------------------------------------------------oneShotMsg :: HscEnv -> RecompileRequired -> IO ()-oneShotMsg hsc_env recomp =-    case recomp of-        UpToDate ->-            compilationProgressMsg logger dflags $-                   text "compilation IS NOT required"-        _ ->-            return ()-    where-        dflags = hsc_dflags hsc_env-        logger = hsc_logger hsc_env--batchMsg :: Messager-batchMsg hsc_env mod_index recomp node = case node of-    InstantiationNode _ ->-        case recomp of-            MustCompile -> showMsg (text "Instantiating ") empty-            UpToDate-                | verbosity dflags >= 2 -> showMsg (text "Skipping  ") empty-                | otherwise -> return ()-            RecompBecause reason -> showMsg (text "Instantiating ") (text " [" <> text reason <> text "]")-    ModuleNode _ ->-        case recomp of-            MustCompile -> showMsg (text "Compiling ") empty-            UpToDate-                | verbosity dflags >= 2 -> showMsg (text "Skipping  ") empty-                | otherwise -> return ()-            RecompBecause reason -> showMsg (text "Compiling ") (text " [" <> text reason <> text "]")-    where-        dflags = hsc_dflags hsc_env-        logger = hsc_logger hsc_env-        showMsg msg reason =-            compilationProgressMsg logger dflags $-            (showModuleIndex mod_index <>-            msg <> showModMsg dflags (recompileRequired recomp) node)-                <> reason------------------------------------------------------------------- Safe Haskell------------------------------------------------------------------- Note [Safe Haskell Trust Check]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- Safe Haskell checks that an import is trusted according to the following--- rules for an import of module M that resides in Package P:------   * If M is recorded as Safe and all its trust dependencies are OK---     then M is considered safe.---   * If M is recorded as Trustworthy and P is considered trusted and---     all M's trust dependencies are OK then M is considered safe.------ By trust dependencies we mean that the check is transitive. So if--- a module M that is Safe relies on a module N that is trustworthy,--- importing module M will first check (according to the second case)--- that N is trusted before checking M is trusted.------ This is a minimal description, so please refer to the user guide--- for more details. The user guide is also considered the authoritative--- source in this matter, not the comments or code.----- Note [Safe Haskell Inference]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- Safe Haskell does Safe inference on modules that don't have any specific--- safe haskell mode flag. The basic approach to this is:---   * When deciding if we need to do a Safe language check, treat---     an unmarked module as having -XSafe mode specified.---   * For checks, don't throw errors but return them to the caller.---   * Caller checks if there are errors:---     * For modules explicitly marked -XSafe, we throw the errors.---     * For unmarked modules (inference mode), we drop the errors---       and mark the module as being Unsafe.------ It used to be that we only did safe inference on modules that had no Safe--- Haskell flags, but now we perform safe inference on all modules as we want--- to allow users to set the `-Wsafe`, `-Wunsafe` and--- `-Wtrustworthy-safe` flags on Trustworthy and Unsafe modules so that a--- user can ensure their assumptions are correct and see reasons for why a--- module is safe or unsafe.------ This is tricky as we must be careful when we should throw an error compared--- to just warnings. For checking safe imports we manage it as two steps. First--- we check any imports that are required to be safe, then we check all other--- imports to see if we can infer them to be safe.----- | Check that the safe imports of the module being compiled are valid.--- If not we either issue a compilation error if the module is explicitly--- using Safe Haskell, or mark the module as unsafe if we're in safe--- inference mode.-hscCheckSafeImports :: TcGblEnv -> Hsc TcGblEnv-hscCheckSafeImports tcg_env = do-    dflags   <- getDynFlags-    tcg_env' <- checkSafeImports tcg_env-    checkRULES dflags tcg_env'--  where-    checkRULES dflags tcg_env' =-      case safeLanguageOn dflags of-          True -> do-              -- XSafe: we nuke user written RULES-              logWarnings $ warns (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 (tcg_rules tcg_env')--                -- Trustworthy OR SafeInferred: with no RULES-              | otherwise-              -> return tcg_env'--    warns rules = listToBag $ map warnRules rules--    warnRules :: LRuleDecl GhcTc -> MsgEnvelope DecoratedSDoc-    warnRules (L loc (HsRule { rd_name = n })) =-        mkPlainWarnMsg (locA loc) $-            text "Rule \"" <> ftext (snd $ unLoc n) <> text "\" ignored" $+$-            text "User defined rules are disabled under Safe Haskell"---- | 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 <- getWarnings-        clearWarnings--        -- Check safe imports are correct-        safePkgs <- S.fromList <$> mapMaybeM checkSafe safeImps-        safeErrs <- getWarnings-        clearWarnings--        -- Check non-safe imports are correct if inferring safety-        -- See the Note [Safe Haskell Inference]-        (infErrs, infPkgs) <- case (safeInferOn dflags) of-          False -> return (emptyBag, S.empty)-          True -> do infPkgs <- S.fromList <$> mapMaybeM checkSafe regImps-                     infErrs <- getWarnings-                     clearWarnings-                     return (infErrs, infPkgs)--        -- restore old errors-        logWarnings oldErrs--        logger <- getLogger-        -- Will throw if failed safe check-        ---        -- Zubin: printOrThrowWarnings doesn't actually throw if we-        -- have SevError warnings, so we need to do an additional check-        -- before calling it to see if we need to throw, because SevError-        -- safe haskell warnings are supposed to be fatal.-        -- We don't want to modify printOrThrowWarnings on GHC 9.2 to-        -- perform this check because it affects other error messages (like T10647)-        -- and changes the behavior of the compiler.-        -- This is fixed in GHC 9.4-        when (anyBag isErrorMessage safeErrs) $-          liftIO $ throwIO (mkSrcErr safeErrs)-        liftIO $ printOrThrowWarnings logger dflags safeErrs--        -- No fatal warnings or errors: passed safe check-        let infPassed = isEmptyBag infErrs-        tcg_env' <- case (not infPassed) of-          True  -> markUnsafeInfer tcg_env infErrs-          False -> return tcg_env-        when (packageTrustOn dflags) $ checkPkgTrust pkgReqs-        let newTrust = pkgTrustReqs dflags safePkgs infPkgs infPassed-        return tcg_env' { tcg_imports = impInfo `plusImportAvails` newTrust }--  where-    impInfo  = tcg_imports tcg_env     -- ImportAvails-    imports  = imp_mods impInfo        -- ImportedMods-    imports1 = moduleEnvToList imports -- (Module, [ImportedBy])-    imports' = map (fmap importedByUser) imports1 -- (Module, [ImportedModsVal])-    pkgReqs  = imp_trust_pkgs impInfo  -- [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 $ mkPlainMsgEnvelope (imv_span v1)-              (text "Module" <+> ppr (imv_name v1) <+>-              (text $ "is imported both as a safe and unsafe import!"))-        | otherwise-        = return v1--    -- easier interface to work with-    checkSafe :: (Module, SrcSpan, a) -> Hsc (Maybe 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 <- getWarnings-    return $ isEmptyBag errs---- | Return if a module is trusted and the pkgs it depends on to be trusted.-hscGetSafe :: HscEnv -> Module -> SrcSpan -> IO (Bool, Set UnitId)-hscGetSafe hsc_env m l = runHsc hsc_env $ do-    (self, pkgs) <- hscCheckSafe' m l-    good         <- isEmptyBag `fmap` getWarnings-    clearWarnings -- don't want them printed...-    let pkgs' | Just p <- self = S.insert p pkgs-              | otherwise      = pkgs-    return (good, pkgs')---- | Is a module trusted? If not, throw or log errors depending on the type.--- Return (regardless of trusted or not) if the trust type requires the modules--- own package be trusted and a list of other packages required to be trusted--- (these later ones haven't been checked) but the own package trust has been.-hscCheckSafe' :: Module -> SrcSpan-  -> Hsc (Maybe 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-        case iface of-            -- can't load iface to check trust!-            Nothing -> throwOneError $ mkPlainMsgEnvelope l-                         $ text "Can't load the interface file for" <+> ppr m-                           <> text ", to check that it can be safely imported"--            -- got iface, check trust-            Just iface' ->-                let trust = getSafeMode $ mi_trust iface'-                    trust_own_pkg = mi_trust_pkg iface'-                    -- check module is trusted-                    safeM = trust `elem` [Sf_Safe, Sf_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 = S.fromList . map fst $ filter snd $ dep_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-                                else emptyBag-                    -- General errors we throw but Safe errors we log-                    errs = case (safeM, safeP) of-                        (True, True ) -> emptyBag-                        (True, False) -> pkgTrustErr-                        (False, _   ) -> modTrustErr-                in do-                    logWarnings warns-                    logWarnings errs-                    return (trust == Sf_Trustworthy, pkgRs)--                where-                    state = hsc_units hsc_env-                    inferredImportWarn = unitBag-                        $ makeIntoWarning (Reason Opt_WarnInferredSafeImports)-                        $ mkWarnMsg l (pkgQual state)-                        $ sep-                            [ text "Importing Safe-Inferred module "-                                <> ppr (moduleName m)-                                <> text " from explicitly Safe module"-                            ]-                    pkgTrustErr = unitBag $ mkMsgEnvelope l (pkgQual state) $-                        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."-                            ]-                    modTrustErr = unitBag $ mkMsgEnvelope l (pkgQual state) $-                        sep [ ppr (moduleName m)-                                <> text ": Can't be safely imported!"-                            , text "The module itself isn't safe." ]--    -- | Check the package a module resides in is trusted. Safe compiled-    -- modules are trusted without requiring that their package is trusted. For-    -- trustworthy modules, modules in the home package are trusted but-    -- otherwise we check the package trust flag.-    packageTrusted :: DynFlags -> UnitState -> HomeUnit -> SafeHaskellMode -> Bool -> Module -> Bool-    packageTrusted dflags unit_state home_unit safe_mode trust_own_pkg mod =-        case safe_mode of-            Sf_None      -> False -- shouldn't hit these cases-            Sf_Ignore    -> False -- shouldn't hit these cases-            Sf_Unsafe    -> False -- prefer for completeness.-            _ | not (packageTrustOn dflags)     -> True-            Sf_Safe | not trust_own_pkg         -> True-            Sf_SafeInferred | not trust_own_pkg -> True-            _ | isHomeModule home_unit mod      -> True-            _ -> unitIsTrusted $ unsafeLookupUnit unit_state (moduleUnit m)--    lookup' :: Module -> Hsc (Maybe ModIface)-    lookup' m = do-        hsc_env <- getHscEnv-        hsc_eps <- liftIO $ hscEPS hsc_env-        let pkgIfaceT = eps_PIT hsc_eps-            homePkgT  = hsc_HPT hsc_env-            iface     = lookupIfaceByModule homePkgT pkgIfaceT m-        -- the 'lookupIfaceByModule' method will always fail when calling from GHCi-        -- as the compiler hasn't filled in the various module tables-        -- so we need to call 'getModuleInterface' to load from disk-        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 [] pkgs-        state  = hsc_units hsc_env-        go pkg acc-            | unitIsTrusted $ unsafeLookupUnitId state pkg-            = acc-            | otherwise-            = (:acc) $ mkMsgEnvelope noSrcSpan (pkgQual state)-                     $ pprWithUnitState state-                     $ text "The package ("-                        <> ppr pkg-                        <> text ") is required to be trusted but it isn't!"-    case errors of-        [] -> return ()-        _  -> (liftIO . throwIO . mkSrcErr . listToBag) errors---- | Set module to unsafe and (potentially) wipe trust information.------ Make sure to call this method to set a module to inferred unsafe, it should--- be a central and single failure method. We only wipe the trust information--- when we aren't in a specific Safe Haskell mode.------ While we only use this for recording that a module was inferred unsafe, we--- may call it on modules using Trustworthy or Unsafe flags so as to allow--- warning flags for safety to function correctly. See Note [Safe Haskell--- Inference].-markUnsafeInfer :: TcGblEnv -> WarningMessages -> Hsc TcGblEnv-markUnsafeInfer tcg_env whyUnsafe = do-    dflags <- getDynFlags--    when (wopt Opt_WarnUnsafe dflags)-         (logWarnings $ unitBag $ makeIntoWarning (Reason Opt_WarnUnsafe) $-             mkPlainWarnMsg (warnUnsafeOnLoc dflags) (whyUnsafe' dflags))--    liftIO $ writeIORef (tcg_safeInfer tcg_env) (False, whyUnsafe)-    -- NOTE: Only wipe trust when not in an explicitly safe haskell mode. Other-    -- times inference may be on but we are in Trustworthy mode -- so we want-    -- to record safe-inference failed but not wipe the trust dependencies.-    case not (safeHaskellModeEnabled dflags) of-      True  -> return $ tcg_env { tcg_imports = wiped_trust }-      False -> return tcg_env--  where-    wiped_trust   = (tcg_imports tcg_env) { imp_trust_pkgs = S.empty }-    pprMod        = ppr $ moduleName $ tcg_mod tcg_env-    whyUnsafe' df = vcat [ quotes pprMod <+> text "has been inferred as unsafe!"-                         , text "Reason:"-                         , nest 4 $ (vcat $ badFlags df) $+$-                                    (vcat $ pprMsgEnvelopeBagWithLoc whyUnsafe) $+$-                                    (vcat $ badInsts $ tcg_insts tcg_env)-                         ]-    badFlags df   = concatMap (badFlag df) unsafeFlagsForInfer-    badFlag df (str,loc,on,_)-        | on df     = [mkLocMessage SevOutput (loc df) $-                            text str <+> text "is not allowed in Safe Haskell"]-        | otherwise = []-    badInsts insts = concatMap badInst insts--    checkOverlap (NoOverlap _) = False-    checkOverlap _             = True--    badInst ins | checkOverlap (overlapMode (is_flag ins))-                = [mkLocMessage SevOutput (nameSrcSpan $ getName $ is_dfun ins) $-                      ppr (overlapMode $ is_flag ins) <+>-                      text "overlap mode isn't allowed in Safe Haskell"]-                | otherwise = []----- | Figure out the final correct safe haskell mode-hscGetSafeMode :: TcGblEnv -> Hsc SafeHaskellMode-hscGetSafeMode tcg_env = do-    dflags  <- getDynFlags-    liftIO $ finalSafeMode dflags tcg_env------------------------------------------------------------------- Simplifiers------------------------------------------------------------------- | 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 $ hsc_env-                { hsc_dflags = foldr addPluginModuleName (hsc_dflags hsc_env) plugins-                }-    {-# SCC "Core2Core" #-}-      liftIO $ core2core hsc_env_with_plugins ds_result------------------------------------------------------------------- Interface generators------------------------------------------------------------------- | Generate a striped down interface file, e.g. for boot files or when ghci--- generates interface files. See Note [simpleTidyPgm - mkBootModDetailsTc]-hscSimpleIface :: HscEnv-               -> TcGblEnv-               -> Maybe Fingerprint-               -> IO (ModIface, Maybe Fingerprint, ModDetails)-hscSimpleIface hsc_env tc_result mb_old_iface-    = runHsc hsc_env $ hscSimpleIface' tc_result mb_old_iface--hscSimpleIface' :: TcGblEnv-                -> Maybe Fingerprint-                -> Hsc (ModIface, Maybe Fingerprint, ModDetails)-hscSimpleIface' tc_result mb_old_iface = do-    hsc_env   <- getHscEnv-    details   <- liftIO $ mkBootModDetailsTc hsc_env tc_result-    safe_mode <- hscGetSafeMode tc_result-    new_iface-        <- {-# SCC "MkFinalIface" #-}-           liftIO $-               mkIfaceTc hsc_env safe_mode details tc_result-    -- And the answer is ...-    liftIO $ dumpIfaceStats hsc_env-    return (new_iface, mb_old_iface, details)------------------------------------------------------------------- BackEnd combinators------------------------------------------------------------------- | Compile to hard-code.-hscGenHardCode :: HscEnv -> CgGuts -> ModLocation -> FilePath-               -> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)], CgInfos)-               -- ^ @Just f@ <=> _stub.c is f-hscGenHardCode hsc_env cgguts location output_filename = do-        let CgGuts{ -- This is the last use of the ModGuts in a compilation.-                    -- From now on, we just use the bits we need.-                    cg_module   = this_mod,-                    cg_binds    = core_binds,-                    cg_tycons   = tycons,-                    cg_foreign  = foreign_stubs0,-                    cg_foreign_files = foreign_files,-                    cg_dep_pkgs = dependencies,-                    cg_hpc_info = hpc_info } = cgguts-            dflags = hsc_dflags hsc_env-            logger = hsc_logger hsc_env-            hooks  = hsc_hooks hsc_env-            tmpfs  = hsc_tmpfs hsc_env-            data_tycons = filter isDataTyCon tycons-            -- cg_tycons includes newtypes, for the benefit of External Core,-            -- but we don't generate any code for newtypes--        --------------------        -- PREPARE FOR CODE GENERATION-        -- Do saturation and convert to A-normal form-        (prepd_binds, local_ccs) <- {-# SCC "CorePrep" #-}-                       corePrepPgm hsc_env this_mod location-                                   core_binds data_tycons--        -----------------  Convert to STG -------------------        (stg_binds, denv, (caf_ccs, caf_cc_stacks))-            <- {-# SCC "CoreToStg" #-}-               withTiming logger dflags-                   (text "CoreToStg"<+>brackets (ppr this_mod))-                   (\(a, b, (c,d)) -> a `seqList` b `seq` c `seqList` d `seqList` ())-                   (myCoreToStg logger dflags (hsc_IC hsc_env) this_mod location prepd_binds)--        let cost_centre_info =-              (S.toList 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 showPass isn't very useful here.-        -- Hence we have one showPass for the whole backend, the-        -- next showPass after this will be "Assembler".-        withTiming logger dflags-                   (text "CodeGen"<+>brackets (ppr this_mod))-                   (const ()) $ do-            cmms <- {-# SCC "StgToCmm" #-}-                            doCodeGen hsc_env this_mod denv data_tycons-                                cost_centre_info-                                stg_binds hpc_info--            ------------------  Code output ------------------------            rawcmms0 <- {-# SCC "cmmToRawCmm" #-}-                        case cmmToRawCmmHook hooks of-                            Nothing -> cmmToRawCmm logger dflags cmms-                            Just h  -> h dflags (Just this_mod) cmms--            let dump a = do-                  unless (null a) $-                    dumpIfSet_dyn logger dflags Opt_D_dump_cmm_raw "Raw Cmm" FormatCMM (pdoc platform a)-                  return a-                rawcmms1 = Stream.mapM dump rawcmms0--            let foreign_stubs st = foreign_stubs0 `appendStubC` prof_init-                                                  `appendStubC` cgIPEStub st--            (output_filename, (_stub_h_exists, stub_c_exists), foreign_fps, cg_infos)-                <- {-# SCC "codeOutput" #-}-                  codeOutput logger tmpfs dflags (hsc_units hsc_env) this_mod output_filename location-                  foreign_stubs foreign_files dependencies rawcmms1-            return (output_filename, stub_c_exists, foreign_fps, cg_infos)---hscInteractive :: HscEnv-               -> CgGuts-               -> ModLocation-               -> IO (Maybe FilePath, CompiledByteCode, [SptEntry])-hscInteractive hsc_env cgguts location = do-    let dflags = hsc_dflags hsc_env-    let logger = hsc_logger hsc_env-    let tmpfs  = hsc_tmpfs hsc_env-    let CgGuts{ -- This is the last use of the ModGuts in a compilation.-                -- From now on, we just use the bits we need.-               cg_module   = this_mod,-               cg_binds    = core_binds,-               cg_tycons   = tycons,-               cg_foreign  = foreign_stubs,-               cg_modBreaks = mod_breaks,-               cg_spt_entries = spt_entries } = cgguts--        data_tycons = filter isDataTyCon tycons-        -- cg_tycons includes newtypes, for the benefit of External Core,-        -- but we don't generate any code for newtypes--    --------------------    -- PREPARE FOR CODE GENERATION-    -- Do saturation and convert to A-normal form-    (prepd_binds, _) <- {-# SCC "CorePrep" #-}-                   corePrepPgm hsc_env this_mod location core_binds data_tycons--    (stg_binds, _infotable_prov, _caf_ccs__caf_cc_stacks)-      <- {-# SCC "CoreToStg" #-}-          myCoreToStg logger dflags (hsc_IC hsc_env) this_mod location prepd_binds-    -----------------  Generate byte code -------------------    comp_bc <- byteCodeGen hsc_env this_mod stg_binds data_tycons mod_breaks-    ------------------ Create f-x-dynamic C-side stuff ------    (_istub_h_exists, istub_c_exists)-        <- outputForeignStubs logger tmpfs dflags (hsc_units hsc_env) this_mod location foreign_stubs-    return (istub_c_exists, comp_bc, spt_entries)----------------------------------hscCompileCmmFile :: HscEnv -> FilePath -> FilePath -> IO (Maybe FilePath)-hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do-    let dflags   = hsc_dflags hsc_env-    let logger   = hsc_logger hsc_env-    let hooks    = hsc_hooks hsc_env-    let tmpfs    = hsc_tmpfs hsc_env-        home_unit = hsc_home_unit hsc_env-        platform  = targetPlatform dflags-        -- Make up a module name to give the NCG. We can't pass bottom here-        -- lest we reproduce #11784.-        mod_name = mkModuleName $ "Cmm$" ++ FilePath.takeFileName filename-        cmm_mod = mkHomeModule home_unit mod_name-    (cmm, ents) <- ioMsgMaybe-               $ do-                  (warns,errs,cmm) <- withTiming logger dflags (text "ParseCmm"<+>brackets (text filename)) (\_ -> ())-                                       $ parseCmmFile dflags cmm_mod home_unit filename-                  return (mkMessages (fmap pprWarning warns `unionBags` fmap pprError errs), cmm)-    liftIO $ do-        dumpIfSet_dyn logger dflags Opt_D_dump_cmm_verbose_by_proc "Parsed Cmm" FormatCMM (pdoc platform cmm)--        -- Compile decls in Cmm files one decl at a time, to avoid re-ordering-        -- them in SRT analysis.-        ---        -- Re-ordering here causes breakage when booting with C backend because-        -- in C we must declare before use, but SRT algorithm is free to-        -- re-order [A, B] (B refers to A) when A is not CAFFY and return [B, A]-        cmmgroup <--          concatMapM (\cmm -> snd <$> cmmPipeline hsc_env (emptySRT cmm_mod) [cmm]) cmm--        unless (null cmmgroup) $-          dumpIfSet_dyn logger dflags Opt_D_dump_cmm "Output Cmm"-            FormatCMM (pdoc platform cmmgroup)--        rawCmms <- case cmmToRawCmmHook hooks of-          Nothing -> cmmToRawCmm logger dflags         (Stream.yield cmmgroup)-          Just h  -> h                  dflags Nothing (Stream.yield cmmgroup)--        let foreign_stubs _ =-              let ip_init = ipInitCode dflags cmm_mod ents-              in NoStubs `appendStubC` ip_init--        (_output_filename, (_stub_h_exists, stub_c_exists), _foreign_fps, _caf_infos)-          <- codeOutput logger tmpfs dflags (hsc_units hsc_env) cmm_mod output_filename no_loc foreign_stubs [] []-             rawCmms-        return stub_c_exists-  where-    no_loc = ModLocation{ ml_hs_file  = Just filename,-                          ml_hi_file  = panic "hscCompileCmmFile: no hi file",-                          ml_obj_file = panic "hscCompileCmmFile: no obj file",-                          ml_hie_file = panic "hscCompileCmmFile: no hie file"}---------------------- Stuff for new code gen -----------------------{--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-            -> [StgTopBinding]-            -> HpcInfo-            -> IO (Stream IO CmmGroupSRTs CgInfos)-         -- Note we produce a 'Stream' of CmmGroups, so that the-         -- backend can be run incrementally.  Otherwise it generates all-         -- the C-- up front, which has a significant space cost.-doCodeGen hsc_env this_mod denv data_tycons-              cost_centre_info stg_binds hpc_info = do-    let dflags = hsc_dflags hsc_env-    let logger = hsc_logger hsc_env-    let hooks  = hsc_hooks hsc_env-    let tmpfs  = hsc_tmpfs hsc_env-    let platform = targetPlatform dflags--    let stg_binds_w_fvs = annTopBindingsFreeVars stg_binds--    dumpIfSet_dyn logger dflags Opt_D_dump_stg_final "Final STG:" FormatSTG (pprGenStgTopBindings (initStgPprOpts dflags) stg_binds_w_fvs)--    let stg_to_cmm = case stgToCmmHook hooks of-                        Nothing -> StgToCmm.codeGen logger tmpfs-                        Just h  -> h--    let cmm_stream :: Stream IO CmmGroup (CStub, ModuleLFInfos)-        -- See Note [Forcing of stg_binds]-        cmm_stream = stg_binds_w_fvs `seqList` {-# SCC "StgToCmm" #-}-            stg_to_cmm dflags this_mod denv data_tycons cost_centre_info stg_binds_w_fvs hpc_info--        -- codegen consumes a stream of CmmGroup, and produces a new-        -- stream of CmmGroup (not necessarily synchronised: one-        -- CmmGroup on input may produce many CmmGroups on output due-        -- to proc-point splitting).--    let dump1 a = do-          unless (null a) $-            dumpIfSet_dyn logger dflags Opt_D_dump_cmm_from_stg-              "Cmm produced by codegen" FormatCMM (pdoc platform a)-          return a--        ppr_stream1 = Stream.mapM dump1 cmm_stream--        pipeline_stream :: Stream IO CmmGroupSRTs CgInfos-        pipeline_stream = do-          (non_cafs, (used_info, lf_infos)) <--            {-# SCC "cmmPipeline" #-}-            Stream.mapAccumL_ (cmmPipeline hsc_env) (emptySRT this_mod) ppr_stream1-              <&> first (srtMapNonCAFs . moduleSRTMap)--          return CgInfos{ cgNonCafs = non_cafs, cgLFInfos = lf_infos, cgIPEStub = used_info }--        dump2 a = do-          unless (null a) $-            dumpIfSet_dyn logger dflags Opt_D_dump_cmm "Output Cmm" FormatCMM (pdoc platform a)-          return a--    return (Stream.mapM dump2 pipeline_stream)--myCoreToStgExpr :: Logger -> DynFlags -> InteractiveContext-                -> Module -> ModLocation -> CoreExpr-                -> IO ( Id-                      , [StgTopBinding]-                      , InfoTableProvMap-                      , CollectedCCs )-myCoreToStgExpr logger dflags ictxt this_mod ml prepd_expr = do-    {- Create a temporary binding (just because myCoreToStg needs a-       binding for the stg2stg step) -}-    let bco_tmp_id = mkSysLocal (fsLit "BCO_toplevel")-                                (mkPseudoUniqueE 0)-                                Many-                                (exprType prepd_expr)-    (stg_binds, prov_map, collected_ccs) <--       myCoreToStg logger-                   dflags-                   ictxt-                   this_mod-                   ml-                   [NonRec bco_tmp_id prepd_expr]-    return (bco_tmp_id, stg_binds, prov_map, collected_ccs)--myCoreToStg :: Logger -> DynFlags -> InteractiveContext-            -> Module -> ModLocation -> CoreProgram-            -> IO ( [StgTopBinding] -- output program-                  , InfoTableProvMap-                  , CollectedCCs )  -- CAF cost centre info (declared and used)-myCoreToStg logger dflags ictxt this_mod ml prepd_binds = do-    let (stg_binds, denv, cost_centre_info)-         = {-# SCC "Core2Stg" #-}-           coreToStg dflags this_mod ml prepd_binds--    stg_binds2-        <- {-# SCC "Stg2Stg" #-}-           stg2stg logger dflags ictxt this_mod stg_binds--    return (stg_binds2, denv, cost_centre_info)--{- **********************************************************************-%*                                                                      *-\subsection{Compiling a do-statement}-%*                                                                      *-%********************************************************************* -}--{--When the UnlinkedBCOExpr is linked you get an HValue of type *IO [HValue]* When-you run it you get a list of HValues that should be the same length as the list-of names; add them to the ClosureEnv.--A naked expression returns a singleton Name [it]. The stmt is lifted into the-IO monad as explained in Note [Interactively-bound Ids in GHCi] in 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 $ tcRnStmt hsc_env stmt--  -- Desugar it-  ds_expr <- ioMsgMaybe $ deSugarExpr hsc_env tc_expr-  liftIO (lintInteractiveExpr (text "desugar expression") hsc_env ds_expr)-  handleWarnings--  -- Then code-gen, and link it-  -- It's important NOT to have package 'interactive' as thisUnitId-  -- for linking, else we try to link 'main' and can't find it.-  -- Whereas the linker already knows to ignore 'interactive'-  let src_span = srcLocSpan interactiveSrcLoc-  hval <- liftIO $ hscCompileCoreExpr hsc_env src_span ds_expr--  return $ Just (ids, hval, fix_env)---- | Compile a decls-hscDecls :: HscEnv-         -> String -- ^ The statement-         -> IO ([TyThing], InteractiveContext)-hscDecls hsc_env str = hscDeclsWithLocation hsc_env str "<interactive>" 1--hscParseDeclsWithLocation :: HscEnv -> String -> Int -> String -> IO [LHsDecl GhcPs]-hscParseDeclsWithLocation hsc_env source line_num str = do-    L _ (HsModule{ hsmodDecls = decls }) <--      runInteractiveHsc hsc_env $-        hscParseThingWithLocation source line_num parseModule str-    return decls---- | Compile a decls-hscDeclsWithLocation :: HscEnv-                     -> String -- ^ The statement-                     -> String -- ^ The source-                     -> Int    -- ^ Starting line-                     -> IO ([TyThing], InteractiveContext)-hscDeclsWithLocation hsc_env str source linenumber = do-    L _ (HsModule{ hsmodDecls = decls }) <--      runInteractiveHsc hsc_env $-        hscParseThingWithLocation source linenumber parseModule str-    hscParsedDecls hsc_env decls--hscParsedDecls :: HscEnv -> [LHsDecl GhcPs] -> IO ([TyThing], InteractiveContext)-hscParsedDecls hsc_env decls = runInteractiveHsc hsc_env $ do-    hsc_env <- getHscEnv-    let interp = hscInterp hsc_env--    {- Rename and typecheck it -}-    tc_gblenv <- ioMsgMaybe $ tcRnDeclsi hsc_env decls--    {- Grab the new instances -}-    -- We grab the whole environment because of the overlapping that may have-    -- been done. See the notes at the definition of InteractiveContext-    -- (ic_instances) for more details.-    let defaults = tcg_default tc_gblenv--    {- Desugar it -}-    -- We use a basically null location for iNTERACTIVE-    let iNTERACTIVELoc = ModLocation{ ml_hs_file   = Nothing,-                                      ml_hi_file   = panic "hsDeclsWithLocation:ml_hi_file",-                                      ml_obj_file  = panic "hsDeclsWithLocation:ml_obj_file",-                                      ml_hie_file  = panic "hsDeclsWithLocation:ml_hie_file" }-    ds_result <- hscDesugar' iNTERACTIVELoc tc_gblenv--    {- Simplify -}-    simpl_mg <- liftIO $ do-      plugins <- readIORef (tcg_th_coreplugins tc_gblenv)-      hscSimplify hsc_env plugins ds_result--    {- Tidy -}-    (tidy_cg, mod_details) <- liftIO $ tidyProgram hsc_env simpl_mg--    let !CgGuts{ cg_module    = this_mod,-                 cg_binds     = core_binds,-                 cg_tycons    = tycons,-                 cg_modBreaks = mod_breaks } = tidy_cg--        !ModDetails { md_insts     = cls_insts-                    , md_fam_insts = fam_insts } = mod_details-            -- Get the *tidied* cls_insts and fam_insts--        data_tycons = filter isDataTyCon tycons--    {- Prepare For Code Generation -}-    -- Do saturation and convert to A-normal form-    (prepd_binds, _) <- {-# SCC "CorePrep" #-}-      liftIO $ corePrepPgm hsc_env this_mod iNTERACTIVELoc core_binds data_tycons--    (stg_binds, _infotable_prov, _caf_ccs__caf_cc_stacks)-        <- {-# SCC "CoreToStg" #-}-           liftIO $ myCoreToStg (hsc_logger hsc_env)-                                (hsc_dflags hsc_env)-                                (hsc_IC hsc_env)-                                this_mod-                                iNTERACTIVELoc-                                prepd_binds--    {- Generate byte code -}-    cbc <- liftIO $ byteCodeGen hsc_env this_mod-                                stg_binds data_tycons mod_breaks--    let src_span = srcLocSpan interactiveSrcLoc-    _ <- liftIO $ loadDecls interp hsc_env src_span cbc--    {- Load static pointer table entries -}-    liftIO $ hscAddSptEntries hsc_env (cg_spt_entries tidy_cg)--    let tcs = filterOut isImplicitTyCon (mg_tcs simpl_mg)-        patsyns = mg_patsyns simpl_mg--        ext_ids = [ id | id <- bindersOfBinds core_binds-                       , isExternalName (idName id)-                       , not (isDFunId id || isImplicitId id) ]-            -- We only need to keep around the external bindings-            -- (as decided by GHC.Iface.Tidy), since those are the only ones-            -- that might later be looked up by name.  But we can exclude-            --    - DFunIds, which are in 'cls_insts' (see Note [ic_tythings] in GHC.Runtime.Context-            --    - Implicit Ids, which are implicit in tcs-            -- c.f. GHC.Tc.Module.runTcInteractive, which reconstructs the TypeEnv--        new_tythings = map AnId ext_ids ++ map ATyCon tcs ++ map (AConLike . PatSynCon) patsyns-        ictxt        = hsc_IC hsc_env-        -- See Note [Fixity declarations in GHCi]-        fix_env      = tcg_fix_env tc_gblenv-        new_ictxt    = extendInteractiveContext ictxt new_tythings cls_insts-                                                fam_insts defaults fix_env-    return (new_tythings, new_ictxt)---- | Load the given static-pointer table entries into the interpreter.--- See Note [Grand plan for static forms] in "GHC.Iface.Tidy.StaticPtrTable".-hscAddSptEntries :: HscEnv -> [SptEntry] -> IO ()-hscAddSptEntries hsc_env entries = do-    let interp = hscInterp hsc_env-    let add_spt_entry :: SptEntry -> IO ()-        add_spt_entry (SptEntry i fpr) = do-            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-    (L _ (HsModule{hsmodImports=is})) <--       hscParseThing parseModule str-    case is of-        [L _ i] -> return i-        _ -> liftIO $ throwOneError $-                 mkPlainMsgEnvelope noSrcSpan $-                     text "parse error in import declaration"---- | Typecheck an expression (but don't run it)-hscTcExpr :: HscEnv-          -> TcRnExprMode-          -> String -- ^ The expression-          -> IO Type-hscTcExpr hsc_env0 mode expr = runInteractiveHsc hsc_env0 $ do-  hsc_env <- getHscEnv-  parsed_expr <- hscParseExpr expr-  ioMsgMaybe $ tcRnExpr hsc_env mode parsed_expr---- | Find the kind of a type, after generalisation-hscKcType-  :: HscEnv-  -> Bool            -- ^ Normalise the type-  -> String          -- ^ The type as a string-  -> IO (Type, Kind) -- ^ Resulting type (possibly normalised) and kind-hscKcType hsc_env0 normalise str = runInteractiveHsc hsc_env0 $ do-    hsc_env <- getHscEnv-    ty <- hscParseType str-    ioMsgMaybe $ tcRnType hsc_env 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 $ mkPlainMsgEnvelope noSrcSpan-      (text "not an expression:" <+> quotes (text expr))--hscParseStmt :: String -> Hsc (Maybe (GhciLStmt GhcPs))-hscParseStmt = hscParseThing parseStmt--hscParseStmtWithLocation :: String -> Int -> String-                         -> Hsc (Maybe (GhciLStmt GhcPs))-hscParseStmtWithLocation source linenumber stmt =-    hscParseThingWithLocation source linenumber parseStmt stmt--hscParseType :: String -> Hsc (LHsType GhcPs)-hscParseType = hscParseThing parseType--hscParseIdentifier :: HscEnv -> String -> IO (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 dflags-               (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 (getMessages pst)-            POk pst thing -> do-                logWarningsReportErrors (getMessages pst)-                liftIO $ dumpIfSet_dyn logger dflags Opt_D_dump_parsed "Parser"-                            FormatHaskell (ppr thing)-                liftIO $ dumpIfSet_dyn logger dflags Opt_D_dump_parsed_ast "Parser AST"-                            FormatHaskell (showAstData NoBlankSrcSpan NoBlankEpAnnotations thing)-                return thing---{- **********************************************************************-%*                                                                      *-        Desugar, simplify, convert to bytecode, and link an expression-%*                                                                      *-%********************************************************************* -}--hscCompileCoreExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue-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-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.-           simpl_expr <- simplifyExpr hsc_env ds_expr--           {- Tidy it (temporary, until coreSat does cloning) -}-         ; let tidy_expr = tidyExpr emptyTidyEnv simpl_expr--           {- Prepare for codegen -}-         ; prepd_expr <- corePrepExpr hsc_env tidy_expr--           {- Lint if necessary -}-         ; lintInteractiveExpr (text "hscCompileExpr") hsc_env prepd_expr-         ; let iNTERACTIVELoc = ModLocation{ ml_hs_file   = Nothing,-                                      ml_hi_file   = panic "hscCompileCoreExpr':ml_hi_file",-                                      ml_obj_file  = panic "hscCompileCoreExpr':ml_obj_file",-                                      ml_hie_file  = panic "hscCompileCoreExpr':ml_hie_file" }--         ; let ictxt = hsc_IC hsc_env-         ; (binding_id, stg_expr, _, _) <--             myCoreToStgExpr (hsc_logger hsc_env)-                             (hsc_dflags hsc_env)-                             ictxt-                             (icInteractiveModule ictxt)-                             iNTERACTIVELoc-                             prepd_expr--           {- Convert to BCOs -}-         ; bcos <- byteCodeGen hsc_env-                     (icInteractiveModule ictxt)-                     stg_expr-                     [] Nothing--           {- load it -}-         ; fv_hvs <- loadDecls (hscInterp hsc_env) hsc_env srcspan bcos-           {- Get the HValue for the root -}-         ; return (expectJust "hscCompileCoreExpr'"-              $ lookup (idName binding_id) fv_hvs) }---{- **********************************************************************-%*                                                                      *-        Statistics on reading interfaces-%*                                                                      *-%********************************************************************* -}--dumpIfaceStats :: HscEnv -> IO ()-dumpIfaceStats hsc_env = do-    eps <- readIORef (hsc_EPS hsc_env)-    dumpIfSet logger dflags (dump_if_trace || dump_rn_stats)-              "Interface statistics"-              (ifaceStats eps)-  where-    dflags = hsc_dflags hsc_env-    logger = hsc_logger hsc_env-    dump_rn_stats = dopt Opt_D_dump_rn_stats dflags-    dump_if_trace = dopt Opt_D_dump_if_trace dflags---{- **********************************************************************-%*                                                                      *-        Progress Messages: Module i of n-%*                                                                      *-%********************************************************************* -}--showModuleIndex :: (Int, Int) -> 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++{-# LANGUAGE NondecreasingIndentation #-}+{-# LANGUAGE GADTs #-}++{-# 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++    -- * Compiling complete source files+    , Messager, batchMsg, batchMultiMsg+    , HscBackendAction (..), HscRecompStatus (..)+    , initModDetails+    , hscMaybeWriteIface+    , hscCompileCmmFile++    , hscGenHardCode+    , hscInteractive++    -- * Running passes separately+    , hscRecompStatus+    , hscParse+    , hscTypecheckRename+    , hscTypecheckAndGetWarnings+    , hscDesugar+    , makeSimpleDetails+    , hscSimplify -- ToDo, shouldn't really export this+    , hscDesugarAndSimplify++    -- * Safe Haskell+    , hscCheckSafe+    , hscGetSafe++    -- * Support for interactive evaluation+    , hscParseIdentifier+    , hscTcRcLookupName+    , hscTcRnGetInfo+    , hscIsGHCiMonad+    , hscGetModuleInterface+    , hscRnImportDecls+    , hscTcRnLookupRdrName+    , hscStmt, hscParseStmtWithLocation, hscStmtWithLocation, hscParsedStmt+    , hscDecls, hscParseDeclsWithLocation, hscDeclsWithLocation, hscParsedDecls+    , hscParseModuleWithLocation+    , hscTcExpr, TcRnExprMode(..), hscImport, hscKcType+    , hscParseExpr+    , hscParseType+    , hscCompileCoreExpr+    , hscTidy+++    -- * Low-level exports for hooks+    , hscCompileCoreExpr'+      -- We want to make sure that we export enough to be able to redefine+      -- hsc_typecheck in client code+    , hscParse', hscSimplify', hscDesugar', tcRnModule', doCodeGen+    , getHscEnv+    , hscSimpleIface'+    , oneShotMsg+    , dumpIfaceStats+    , ioMsgMaybe+    , showModuleIndex+    , hscAddSptEntries+    , writeInterfaceOnlyMode+    ) where++import GHC.Prelude++import GHC.Driver.Plugins+import GHC.Driver.Session+import GHC.Driver.Backend+import GHC.Driver.Env+import GHC.Driver.Errors+import GHC.Driver.Errors.Types+import GHC.Driver.CodeOutput+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.Diagnostic+import GHC.Driver.Config.Tidy+import GHC.Driver.Hooks++import GHC.Runtime.Context+import GHC.Runtime.Interpreter ( addSptEntry )+import GHC.Runtime.Loader      ( initializePlugins )+import GHCi.RemoteTypes        ( ForeignHValue )+import GHC.ByteCode.Types++import GHC.Linker.Loader+import GHC.Linker.Types++import GHC.Hs+import GHC.Hs.Dump+import GHC.Hs.Stats         ( ppSourceStats )++import GHC.HsToCore++import GHC.StgToByteCode    ( byteCodeGen )++import GHC.IfaceToCore  ( typecheckIface )++import GHC.Iface.Load   ( ifaceStats, writeIface )+import GHC.Iface.Make+import GHC.Iface.Recomp+import GHC.Iface.Tidy+import GHC.Iface.Ext.Ast    ( mkHieFile )+import GHC.Iface.Ext.Types  ( getAsts, hie_asts, hie_module )+import GHC.Iface.Ext.Binary ( readHieFile, writeHieFile , hie_file_result)+import GHC.Iface.Ext.Debug  ( diffFile, validateScopes )++import GHC.Core+import GHC.Core.Tidy           ( tidyExpr )+import GHC.Core.Type           ( Type, Kind )+import GHC.Core.Lint           ( lintInteractiveExpr, endPassIO )+import GHC.Core.Multiplicity+import GHC.Core.Utils          ( exprType )+import GHC.Core.ConLike+import GHC.Core.Opt.Monad      ( CoreToDo (..))+import GHC.Core.Opt.Pipeline+import GHC.Core.TyCon+import GHC.Core.InstEnv+import GHC.Core.FamInstEnv+import GHC.Core.Rules+import GHC.Core.Stats+import GHC.Core.LateCC (addLateCostCentresPgm)+++import GHC.CoreToStg.Prep+import GHC.CoreToStg    ( coreToStg )++import GHC.Parser.Errors.Types+import GHC.Parser+import GHC.Parser.Lexer as Lexer++import GHC.Tc.Module+import GHC.Tc.Utils.Monad+import GHC.Tc.Utils.Zonk    ( ZonkFlexi (DefaultFlexi) )++import GHC.Stg.Syntax+import GHC.Stg.Pipeline ( stg2stg )+import GHC.Stg.InferTags++import GHC.Builtin.Utils+import GHC.Builtin.Names+import GHC.Builtin.Uniques ( mkPseudoUniqueE )++import qualified GHC.StgToCmm as StgToCmm ( codeGen )+import GHC.StgToCmm.Types (CgInfos (..), ModuleLFInfos)++import GHC.Cmm+import GHC.Cmm.Parser       ( parseCmmFile )+import GHC.Cmm.Info.Build+import GHC.Cmm.Pipeline+import GHC.Cmm.Info++import GHC.Unit+import GHC.Unit.Env+import GHC.Unit.Finder+import GHC.Unit.External+import GHC.Unit.Module.ModDetails+import GHC.Unit.Module.ModGuts+import GHC.Unit.Module.ModIface+import GHC.Unit.Module.ModSummary+import GHC.Unit.Module.Graph+import GHC.Unit.Module.Imported+import GHC.Unit.Module.Deps+import GHC.Unit.Module.Status+import GHC.Unit.Home.ModInfo++import GHC.Types.Id+import GHC.Types.SourceError+import GHC.Types.SafeHaskell+import GHC.Types.ForeignStubs+import GHC.Types.Var.Env       ( emptyTidyEnv )+import GHC.Types.Error+import GHC.Types.Fixity.Env+import GHC.Types.CostCentre+import GHC.Types.IPE+import GHC.Types.SourceFile+import GHC.Types.SrcLoc+import GHC.Types.Name+import GHC.Types.Name.Cache ( initNameCache )+import GHC.Types.Name.Reader+import GHC.Types.Name.Ppr+import GHC.Types.TyThing+import GHC.Types.HpcInfo++import GHC.Utils.Fingerprint ( Fingerprint )+import GHC.Utils.Panic+import GHC.Utils.Panic.Plain+import GHC.Utils.Error+import GHC.Utils.Outputable+import GHC.Utils.Misc+import GHC.Utils.Logger+import GHC.Utils.TmpFs++import GHC.Data.FastString+import GHC.Data.Bag+import GHC.Data.StringBuffer+import qualified GHC.Data.Stream as Stream+import GHC.Data.Stream (Stream)+import qualified GHC.SysTools++import Data.Data hiding (Fixity, TyCon)+import Data.List        ( nub, isPrefixOf, partition )+import Control.Monad+import Data.IORef+import System.FilePath as FilePath+import System.Directory+import System.IO (fixIO)+import qualified Data.Set as S+import Data.Set (Set)+import Data.Functor+import Control.DeepSeq (force)+import Data.Bifunctor (first)+import GHC.Data.Maybe+import GHC.Driver.Env.KnotVars+import GHC.Types.Name.Set (NonCaffySet)+import GHC.Driver.GenerateCgIPEStub (generateCgIPEStub)+import Data.List.NonEmpty (NonEmpty ((:|)))+++{- **********************************************************************+%*                                                                      *+                Initialisation+%*                                                                      *+%********************************************************************* -}++newHscEnv :: DynFlags -> IO HscEnv+newHscEnv dflags = newHscEnvWithHUG dflags (homeUnitId_ dflags) home_unit_graph+  where+    home_unit_graph = unitEnv_singleton+                        (homeUnitId_ dflags)+                        (mkHomeUnitEnv dflags emptyHomePackageTable Nothing)++newHscEnvWithHUG :: DynFlags -> UnitId -> HomeUnitGraph -> IO HscEnv+newHscEnvWithHUG top_dynflags cur_unit home_unit_graph = do+    nc_var  <- initNameCache 'r' knownKeyNames+    fc_var  <- initFinderCache+    logger  <- initLogger+    tmpfs   <- initTmpFs+    let dflags = homeUnitEnv_dflags $ unitEnv_lookup cur_unit home_unit_graph+    unit_env <- initUnitEnv cur_unit home_unit_graph (ghcNameVersion dflags) (targetPlatform dflags)+    return HscEnv { hsc_dflags = top_dynflags+                  , hsc_logger         = setLogFlags logger (initLogFlags top_dynflags)+                  ,  hsc_targets        = []+                  ,  hsc_mod_graph      = emptyMG+                  ,  hsc_IC             = emptyInteractiveContext dflags+                  ,  hsc_NC             = nc_var+                  ,  hsc_FC             = fc_var+                  ,  hsc_type_env_vars  = emptyKnotVars+                  ,  hsc_interp         = Nothing+                  ,  hsc_unit_env       = unit_env+                  ,  hsc_plugins        = emptyPlugins+                  ,  hsc_hooks          = emptyHooks+                  ,  hsc_tmpfs          = tmpfs+                  }++-- -----------------------------------------------------------------------------++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+    logger <- getLogger+    w <- getDiagnostics+    liftIO $ printOrThrowDiagnostics logger 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 diag_opts wWarns+    throwErrors $ fmap GhcPsMessage $ errors `unionMessages` wErrs++-- | Deal with errors and warnings returned by a compilation step+--+-- In order to reduce dependencies to other parts of the compiler, functions+-- outside the "main" parts of GHC return warnings and errors as a parameter+-- and signal success via by wrapping the result in a 'Maybe' type. This+-- function logs the returned warnings and propagates errors as exceptions+-- (of type 'SourceError').+--+-- This function assumes the following invariants:+--+--  1. If the second result indicates success (is of the form 'Just x'),+--     there must be no error messages in the first result.+--+--  2. If there are no error messages, but the second result indicates failure+--     there should be warnings in the first result. That is, if the action+--     failed, it must have been due to the warnings (i.e., @-Werror@).+ioMsgMaybe :: IO (Messages GhcMessage, Maybe a) -> Hsc a+ioMsgMaybe ioA = do+    (msgs, mb_r) <- liftIO ioA+    let (warns, errs) = partitionMessages msgs+    logDiagnostics warns+    case mb_r of+        Nothing -> throwErrors errs+        Just r  -> assert (isEmptyMessages errs ) return r++-- | like ioMsgMaybe, except that we ignore error messages and return+-- 'Nothing' instead.+ioMsgMaybe' :: IO (Messages GhcMessage, Maybe a) -> Hsc (Maybe a)+ioMsgMaybe' ioA = do+    (msgs, mb_r) <- liftIO $ ioA+    logDiagnostics (mkMessages $ getWarningMessages msgs)+    return mb_r++-- -----------------------------------------------------------------------------+-- | Lookup things in the compiler's environment++hscTcRnLookupRdrName :: HscEnv -> LocatedN RdrName -> IO [Name]+hscTcRnLookupRdrName hsc_env0 rdr_name+  = runInteractiveHsc hsc_env0 $+    do { hsc_env <- getHscEnv+       ; ioMsgMaybe $ hoistTcRnMessage $ tcRnLookupRdrName hsc_env rdr_name }++hscTcRcLookupName :: HscEnv -> Name -> IO (Maybe TyThing)+hscTcRcLookupName hsc_env0 name = runInteractiveHsc hsc_env0 $ do+  hsc_env <- getHscEnv+  ioMsgMaybe' $ hoistTcRnMessage $ tcRnLookupName hsc_env name+      -- ignore errors: the only error we're likely to get is+      -- "name not found", and the Maybe in the return type+      -- is used to indicate that.++hscTcRnGetInfo :: HscEnv -> Name+               -> IO (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))+hscTcRnGetInfo hsc_env0 name+  = runInteractiveHsc hsc_env0 $+    do { hsc_env <- getHscEnv+       ; ioMsgMaybe' $ hoistTcRnMessage $ tcRnGetInfo hsc_env name }++hscIsGHCiMonad :: HscEnv -> String -> IO Name+hscIsGHCiMonad hsc_env name+  = runHsc hsc_env $ ioMsgMaybe $ hoistTcRnMessage $ isGHCiMonad hsc_env name++hscGetModuleInterface :: HscEnv -> Module -> IO ModIface+hscGetModuleInterface hsc_env0 mod = runInteractiveHsc hsc_env0 $ do+  hsc_env <- getHscEnv+  ioMsgMaybe $ hoistTcRnMessage $ getModuleInterface hsc_env mod++-- -----------------------------------------------------------------------------+-- | Rename some import declarations+hscRnImportDecls :: HscEnv -> [LImportDecl GhcPs] -> IO GlobalRdrEnv+hscRnImportDecls hsc_env0 import_decls = runInteractiveHsc hsc_env0 $ do+  hsc_env <- getHscEnv+  ioMsgMaybe $ hoistTcRnMessage $ tcRnImportDecls hsc_env import_decls++-- -----------------------------------------------------------------------------+-- | parse a file, returning the abstract syntax++hscParse :: HscEnv -> ModSummary -> IO HsParsedModule+hscParse hsc_env mod_summary = runHsc hsc_env $ hscParse' mod_summary++-- internal version, that doesn't fail due to -Werror+hscParse' :: ModSummary -> Hsc HsParsedModule+hscParse' mod_summary+ | Just r <- ms_parsed_mod mod_summary = return r+ | otherwise = do+    dflags <- getDynFlags+    logger <- getLogger+    {-# SCC "Parser" #-} withTiming logger+                (text "Parser"<+>brackets (ppr $ ms_mod mod_summary))+                (const ()) $ do+    let src_filename  = ms_hspp_file mod_summary+        maybe_src_buf = ms_hspp_buf  mod_summary++    --------------------------  Parser  ----------------+    -- sometimes we already have the buffer in memory, perhaps+    -- because we needed to parse the imports out of it, or get the+    -- module name.+    buf <- case maybe_src_buf of+               Just b  -> return b+               Nothing -> liftIO $ hGetStringBuffer src_filename++    let loc = mkRealSrcLoc (mkFastString src_filename) 1 1++    let diag_opts = initDiagOpts dflags+    when (wopt Opt_WarnUnicodeBidirectionalFormatCharacters dflags) $ do+      case checkBidirectionFormatChars (PsLoc loc (BufPos 0)) buf of+        Nothing -> pure ()+        Just chars@((eloc,chr,_) :| _) ->+          let span = mkSrcSpanPs $ mkPsSpan eloc (advancePsLoc eloc chr)+          in logDiagnostics $ singleMessage $+               mkPlainMsgEnvelope diag_opts span $+               GhcPsMessage $ PsWarnBidirectionalFormatChars chars++    let parseMod | HsigFile == ms_hsc_src mod_summary+                 = parseSignature+                 | otherwise = parseModule++    case unP parseMod (initParserState (initParserOpts dflags) buf loc) of+        PFailed pst ->+            handleWarningsThrowErrors (getPsMessages pst)+        POk pst rdr_module -> do+            liftIO $ putDumpFileMaybe logger Opt_D_dump_parsed "Parser"+                        FormatHaskell (ppr rdr_module)+            liftIO $ putDumpFileMaybe logger Opt_D_dump_parsed_ast "Parser AST"+                        FormatHaskell (showAstData NoBlankSrcSpan+                                                   NoBlankEpAnnotations+                                                   rdr_module)+            liftIO $ putDumpFileMaybe logger Opt_D_source_stats "Source Statistics"+                        FormatText (ppSourceStats False rdr_module)++            -- To get the list of extra source files, we take the list+            -- that the parser gave us,+            --   - eliminate files beginning with '<'.  gcc likes to use+            --     pseudo-filenames like "<built-in>" and "<command-line>"+            --   - normalise them (eliminate differences between ./f and f)+            --   - filter out the preprocessed source file+            --   - filter out anything beginning with tmpdir+            --   - remove duplicates+            --   - filter out the .hs/.lhs source filename if we have one+            --+            let n_hspp  = FilePath.normalise src_filename+                TempDir tmp_dir = tmpDir dflags+                srcs0 = nub $ filter (not . (tmp_dir `isPrefixOf`))+                            $ filter (not . (== n_hspp))+                            $ map FilePath.normalise+                            $ filter (not . isPrefixOf "<")+                            $ map unpackFS+                            $ srcfiles pst+                srcs1 = case ml_hs_file (ms_location mod_summary) of+                          Just f  -> filter (/= FilePath.normalise f) srcs0+                          Nothing -> srcs0++            -- sometimes we see source files from earlier+            -- preprocessing stages that cannot be found, so just+            -- filter them out:+            srcs2 <- liftIO $ filterM doesFileExist srcs1++            let res = HsParsedModule {+                      hpm_module    = rdr_module,+                      hpm_src_files = srcs2+                   }++            -- apply parse transformation of plugins+            let applyPluginAction p opts+                  = parsedResultAction p opts mod_summary+            hsc_env <- getHscEnv+            (ParsedResult transformed (PsMessages warns errs)) <-+              withPlugins (hsc_plugins hsc_env) applyPluginAction+                (ParsedResult res (uncurry PsMessages $ getPsMessages pst))++            logDiagnostics (GhcPsMessage <$> warns)+            unless (isEmptyMessages errs) $ throwErrors (GhcPsMessage <$> errs)++            return transformed++checkBidirectionFormatChars :: PsLoc -> StringBuffer -> Maybe (NonEmpty (PsLoc, Char, String))+checkBidirectionFormatChars start_loc sb+  | containsBidirectionalFormatChar sb = Just $ go start_loc sb+  | otherwise = Nothing+  where+    go :: PsLoc -> StringBuffer -> NonEmpty (PsLoc, Char, String)+    go loc sb+      | atEnd sb = panic "checkBidirectionFormatChars: no char found"+      | otherwise = case nextChar sb of+          (chr, sb)+            | Just desc <- lookup chr bidirectionalFormatChars ->+                (loc, chr, desc) :| go1 (advancePsLoc loc chr) sb+            | otherwise -> go (advancePsLoc loc chr) sb++    go1 :: PsLoc -> StringBuffer -> [(PsLoc, Char, String)]+    go1 loc sb+      | atEnd sb = []+      | otherwise = case nextChar sb of+          (chr, sb)+            | Just desc <- lookup chr bidirectionalFormatChars ->+                (loc, chr, desc) : go1 (advancePsLoc loc chr) sb+            | otherwise -> go1 (advancePsLoc loc chr) sb+++-- -----------------------------------------------------------------------------+-- | If the renamed source has been kept, extract it. Dump it if requested.+++extract_renamed_stuff :: ModSummary -> TcGblEnv -> Hsc RenamedStuff+extract_renamed_stuff mod_summary tc_result = do+    let rn_info = getRenamedStuff tc_result++    dflags <- getDynFlags+    logger <- getLogger+    liftIO $ putDumpFileMaybe logger Opt_D_dump_rn_ast "Renamer"+                FormatHaskell (showAstData NoBlankSrcSpan NoBlankEpAnnotations rn_info)++    -- Create HIE files+    when (gopt Opt_WriteHie dflags) $ do+        -- I assume this fromJust is safe because `-fwrite-hie-file`+        -- enables the option which keeps the renamed source.+        hieFile <- mkHieFile mod_summary tc_result (fromJust rn_info)+        let out_file = ml_hie_file $ ms_location mod_summary+        liftIO $ writeHieFile out_file hieFile+        liftIO $ putDumpFileMaybe logger Opt_D_dump_hie "HIE AST" FormatHaskell (ppr $ hie_asts hieFile)++        -- Validate HIE files+        when (gopt Opt_ValidateHie dflags) $ do+            hs_env <- Hsc $ \e w -> return (e, w)+            liftIO $ do+              -- Validate Scopes+              case validateScopes (hie_module hieFile) $ getAsts $ hie_asts hieFile of+                  [] -> putMsg logger $ text "Got valid scopes"+                  xs -> do+                    putMsg logger $ text "Got invalid scopes"+                    mapM_ (putMsg logger) xs+              -- Roundtrip testing+              file' <- readHieFile (hsc_NC hs_env) out_file+              case diffFile hieFile (hie_file_result file') of+                [] ->+                  putMsg logger $ text "Got no roundtrip errors"+                xs -> do+                  putMsg logger $ text "Got roundtrip errors"+                  let logger' = updateLogFlags logger (log_set_dopt Opt_D_ppr_debug)+                  mapM_ (putMsg logger') xs+    return rn_info+++-- -----------------------------------------------------------------------------+-- | Rename and typecheck a module, additionally returning the renamed syntax+hscTypecheckRename :: HscEnv -> ModSummary -> HsParsedModule+                   -> IO (TcGblEnv, RenamedStuff)+hscTypecheckRename hsc_env mod_summary rdr_module = runHsc hsc_env $+    hsc_typecheck True mod_summary (Just rdr_module)++-- | Do Typechecking without throwing SourceError exception with -Werror+hscTypecheckAndGetWarnings :: HscEnv ->  ModSummary -> IO (FrontendResult, WarningMessages)+hscTypecheckAndGetWarnings hsc_env summary = runHsc' hsc_env $ do+  case hscFrontendHook (hsc_hooks hsc_env) of+    Nothing -> FrontendTypecheck . fst <$> hsc_typecheck False summary Nothing+    Just h  -> h summary++-- | A bunch of logic piled around @tcRnModule'@, concerning a) backpack+-- b) concerning dumping rename info and hie files. It would be nice to further+-- separate this stuff out, probably in conjunction better separating renaming+-- and type checking (#17781).+hsc_typecheck :: Bool -- ^ Keep renamed source?+              -> ModSummary -> Maybe HsParsedModule+              -> Hsc (TcGblEnv, RenamedStuff)+hsc_typecheck keep_rn mod_summary mb_rdr_module = do+    hsc_env <- getHscEnv+    let hsc_src = ms_hsc_src mod_summary+        dflags = hsc_dflags hsc_env+        home_unit = hsc_home_unit hsc_env+        outer_mod = ms_mod mod_summary+        mod_name = moduleName outer_mod+        outer_mod' = mkHomeModule home_unit mod_name+        inner_mod = homeModuleNameInstantiation home_unit mod_name+        src_filename  = ms_hspp_file mod_summary+        real_loc = realSrcLocSpan $ mkRealSrcLoc (mkFastString src_filename) 1 1+        keep_rn' = gopt Opt_WriteHie dflags || keep_rn+    massert (isHomeModule home_unit outer_mod)+    tc_result <- if hsc_src == HsigFile && not (isHoleModule inner_mod)+        then ioMsgMaybe $ hoistTcRnMessage $ tcRnInstantiateSignature hsc_env outer_mod' real_loc+        else+         do hpm <- case mb_rdr_module of+                    Just hpm -> return hpm+                    Nothing -> hscParse' mod_summary+            tc_result0 <- tcRnModule' mod_summary keep_rn' hpm+            if hsc_src == HsigFile+                then do (iface, _) <- liftIO $ hscSimpleIface hsc_env tc_result0 mod_summary+                        ioMsgMaybe $ hoistTcRnMessage $+                            tcRnMergeSignatures hsc_env hpm tc_result0 iface+                else return tc_result0+    -- TODO are we extracting anything when we merely instantiate a signature?+    -- If not, try to move this into the "else" case above.+    rn_info <- extract_renamed_stuff mod_summary tc_result+    return (tc_result, rn_info)++-- wrapper around tcRnModule to handle safe haskell extras+tcRnModule' :: ModSummary -> Bool -> HsParsedModule+            -> Hsc TcGblEnv+tcRnModule' sum save_rn_syntax mod = do+    hsc_env <- getHscEnv+    dflags  <- getDynFlags++    let diag_opts = initDiagOpts dflags+    -- -Wmissing-safe-haskell-mode+    when (not (safeHaskellModeEnabled dflags)+          && wopt Opt_WarnMissingSafeHaskellMode dflags) $+        logDiagnostics $ singleMessage $+        mkPlainMsgEnvelope diag_opts (getLoc (hpm_module mod)) $+        GhcDriverMessage $ DriverMissingSafeHaskellMode (ms_mod sum)++    tcg_res <- {-# SCC "Typecheck-Rename" #-}+               ioMsgMaybe $ hoistTcRnMessage $+                   tcRnModule hsc_env sum+                     save_rn_syntax mod++    -- See Note [Safe Haskell Overlapping Instances Implementation]+    -- although this is used for more than just that failure case.+    tcSafeOK <- liftIO $ readIORef (tcg_safe_infer tcg_res)+    whyUnsafe <- liftIO $ readIORef (tcg_safe_infer_reasons tcg_res)+    let allSafeOK = safeInferred dflags && tcSafeOK++    -- end of the safe haskell line, how to respond to user?+    if not (safeHaskellOn dflags)+         || (safeInferOn dflags && not allSafeOK)+      -- if safe Haskell off or safe infer failed, mark unsafe+      then markUnsafeInfer tcg_res whyUnsafe++      -- module (could be) safe, throw warning if needed+      else do+          tcg_res' <- hscCheckSafeImports tcg_res+          safe <- liftIO $ readIORef (tcg_safe_infer tcg_res')+          when safe $+            case wopt Opt_WarnSafe dflags of+              True+                | safeHaskell dflags == Sf_Safe -> return ()+                | otherwise -> (logDiagnostics $ singleMessage $+                       mkPlainMsgEnvelope diag_opts (warnSafeOnLoc dflags) $+                       GhcDriverMessage $ DriverInferredSafeModule (tcg_mod tcg_res'))+              False | safeHaskell dflags == Sf_Trustworthy &&+                      wopt Opt_WarnTrustworthySafe dflags ->+                      (logDiagnostics $ singleMessage $+                       mkPlainMsgEnvelope diag_opts (trustworthyOnLoc dflags) $+                       GhcDriverMessage $ DriverMarkedTrustworthyButInferredSafe (tcg_mod tcg_res'))+              False -> return ()+          return tcg_res'++-- | Convert a typechecked module to Core+hscDesugar :: HscEnv -> ModSummary -> TcGblEnv -> IO ModGuts+hscDesugar hsc_env mod_summary tc_result =+    runHsc hsc_env $ hscDesugar' (ms_location mod_summary) tc_result++hscDesugar' :: ModLocation -> TcGblEnv -> Hsc ModGuts+hscDesugar' mod_location tc_result = do+    hsc_env <- getHscEnv+    ioMsgMaybe $ hoistDsMessage $+      {-# SCC "deSugar" #-}+      deSugar hsc_env mod_location tc_result++-- | Make a 'ModDetails' from the results of typechecking. Used when+-- typechecking only, as opposed to full compilation.+makeSimpleDetails :: Logger -> TcGblEnv -> IO ModDetails+makeSimpleDetails logger tc_result = mkBootModDetailsTc logger tc_result+++{- **********************************************************************+%*                                                                      *+                The main compiler pipeline+%*                                                                      *+%********************************************************************* -}++{-+                   --------------------------------+                        The compilation proper+                   --------------------------------++It's the task of the compilation proper to compile Haskell, hs-boot and core+files to either byte-code, hard-code (C, asm, LLVM, etc.) or to nothing at all+(the module is still parsed and type-checked. This feature is mostly used by+IDE's and the likes). Compilation can happen in either 'one-shot', 'batch',+'nothing', or 'interactive' mode. 'One-shot' mode targets hard-code, 'batch'+mode targets hard-code, 'nothing' mode targets nothing and 'interactive' mode+targets byte-code.++The modes are kept separate because of their different types and meanings:++ * In 'one-shot' mode, we're only compiling a single file and can therefore+ discard the new ModIface and ModDetails. This is also the reason it only+ targets hard-code; compiling to byte-code or nothing doesn't make sense when+ we discard the result.++ * 'Batch' mode is like 'one-shot' except that we keep the resulting ModIface+ and ModDetails. 'Batch' mode doesn't target byte-code since that require us to+ return the newly compiled byte-code.++ * 'Nothing' mode has exactly the same type as 'batch' mode but they're still+ kept separate. This is because compiling to nothing is fairly special: We+ don't output any interface files, we don't run the simplifier and we don't+ generate any code.++ * 'Interactive' mode is similar to 'batch' mode except that we return the+ compiled byte-code together with the ModIface and ModDetails.++Trying to compile a hs-boot file to byte-code will result in a run-time error.+This is the only thing that isn't caught by the type-system.+-}+++type Messager = HscEnv -> (Int,Int) -> RecompileRequired -> ModuleGraphNode -> IO ()++-- | Do the recompilation avoidance checks for both one-shot and --make modes+-- This function is the *only* place in the compiler where we decide whether to+-- recompile a module or not!+hscRecompStatus :: Maybe Messager+                -> HscEnv+                -> ModSummary+                -> Maybe ModIface+                -> Maybe Linkable+                -> (Int,Int)+                -> IO HscRecompStatus+hscRecompStatus+    mHscMessage hsc_env mod_summary mb_old_iface old_linkable mod_index+  = do+    let+        msg what = case mHscMessage of+          Just hscMessage -> hscMessage hsc_env mod_index what (ModuleNode [] mod_summary)+          Nothing -> return ()++    -- First check to see if the interface file agrees with the+    -- source file.+    --+    -- Save the interface that comes back from checkOldIface.+    -- In one-shot mode we don't have the old iface until this+    -- point, when checkOldIface reads it from the disk.+    recomp_if_result+          <- {-# SCC "checkOldIface" #-}+             liftIO $ checkOldIface hsc_env mod_summary mb_old_iface+    case recomp_if_result of+      OutOfDateItem reason mb_checked_iface -> do+        msg $ NeedsRecompile reason+        return $ HscRecompNeeded $ fmap (mi_iface_hash . mi_final_exts) mb_checked_iface+      UpToDateItem checked_iface -> do+        let lcl_dflags = ms_hspp_opts mod_summary+        case backend lcl_dflags of+          -- No need for a linkable, we're good to go+          NoBackend -> do+            msg $ UpToDate+            return $ HscUpToDate checked_iface Nothing+          -- Do need linkable+          _ -> do+            -- Check to see whether the expected build products already exist.+            -- If they don't exists then we trigger recompilation.+            recomp_linkable_result <- case () of+               -- Interpreter can use either already loaded bytecode or loaded object code+               _ | Interpreter <- backend lcl_dflags -> do+                     let res = checkByteCode old_linkable+                     case res of+                       UpToDateItem _ -> pure res+                       _ -> liftIO $ checkObjects lcl_dflags old_linkable mod_summary+                 -- Need object files for making object files+                 | backendProducesObject (backend lcl_dflags) -> liftIO $ checkObjects lcl_dflags old_linkable mod_summary+                 | otherwise -> pprPanic "hscRecompStatus" (text $ show $ backend lcl_dflags)+            case recomp_linkable_result of+              UpToDateItem linkable -> do+                msg $ UpToDate+                return $ HscUpToDate checked_iface $ Just linkable+              OutOfDateItem reason _ -> do+                msg $ NeedsRecompile reason+                return $ HscRecompNeeded $ Just $ mi_iface_hash $ mi_final_exts $ checked_iface++-- | Check that the .o files produced by compilation are already up-to-date+-- or not.+checkObjects :: DynFlags -> Maybe Linkable -> ModSummary -> IO (MaybeValidated Linkable)+checkObjects dflags mb_old_linkable summary = do+  let+    dt_enabled  = gopt Opt_BuildDynamicToo dflags+    this_mod    = ms_mod summary+    mb_obj_date = ms_obj_date summary+    mb_dyn_obj_date = ms_dyn_obj_date summary+    mb_if_date  = ms_iface_date summary+    obj_fn      = ml_obj_file (ms_location summary)+    -- dynamic-too *also* produces the dyn_o_file, so have to check+    -- that's there, and if it's not, regenerate both .o and+    -- .dyn_o+    checkDynamicObj k = if dt_enabled+      then case (>=) <$> mb_dyn_obj_date <*> mb_if_date of+        Just True -> k+        _ -> return $ outOfDateItemBecause MissingDynObjectFile Nothing+      -- Not in dynamic-too mode+      else k++  checkDynamicObj $+    case (,) <$> mb_obj_date <*> mb_if_date of+      Just (obj_date, if_date)+        | obj_date >= if_date ->+            case mb_old_linkable of+              Just old_linkable+                | isObjectLinkable old_linkable, linkableTime old_linkable == obj_date+                -> return $ UpToDateItem old_linkable+              _ -> UpToDateItem <$> findObjectLinkable this_mod obj_fn obj_date+      _ -> return $ outOfDateItemBecause MissingObjectFile Nothing++-- | Check to see if we can reuse the old linkable, by this point we will+-- have just checked that the old interface matches up with the source hash, so+-- no need to check that again here+checkByteCode :: Maybe Linkable -> MaybeValidated Linkable+checkByteCode mb_old_linkable =+  case mb_old_linkable of+    Just old_linkable+      | not (isObjectLinkable old_linkable)+      -> UpToDateItem old_linkable+    _ -> outOfDateItemBecause MissingBytecode Nothing++--------------------------------------------------------------+-- Compilers+--------------------------------------------------------------+++-- Knot tying!  See Note [Knot-tying typecheckIface]+-- See Note [ModDetails and --make mode]+initModDetails :: HscEnv -> ModSummary -> ModIface -> IO ModDetails+initModDetails hsc_env mod_summary iface =+  fixIO $ \details' -> do+    let act hpt  = addToHpt hpt (ms_mod_name mod_summary)+                                (HomeModInfo iface details' Nothing)+    let hsc_env' = hscUpdateHPT act hsc_env+    -- NB: This result is actually not that useful+    -- in one-shot mode, since we're not going to do+    -- any further typechecking.  It's much more useful+    -- in make mode, since this HMI will go into the HPT.+    genModDetails hsc_env' iface+++{-+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++  -- Desugar, if appropriate+  --+  -- We usually desugar even when we are not generating code, otherwise we+  -- would miss errors thrown by the desugaring (see #10600). The only+  -- exceptions are when the Module is Ghc.Prim or when it is not a+  -- HsSrcFile Module.+  mb_desugar <-+      if ms_mod summary /= gHC_PRIM && hsc_src == HsSrcFile+      then Just <$> hscDesugar' (ms_location summary) tc_result+      else pure Nothing++  -- Report the warnings from both typechecking and desugar together+  w <- getDiagnostics+  liftIO $ printOrThrowDiagnostics logger 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 | bcknd /= NoBackend -> do+          plugins <- liftIO $ readIORef (tcg_th_coreplugins tc_result)+          simplified_guts <- hscSimplify' plugins desugared_guts++          (cg_guts, details) <-+              liftIO $ hscTidy hsc_env simplified_guts++          let !partial_iface =+                {-# SCC "GHC.Driver.Main.mkPartialIface" #-}+                -- This `force` saves 2M residency in test T10370+                -- See Note [Avoiding space leaks in toIface*] for details.+                force (mkPartialIface hsc_env details summary simplified_guts)++          return HscRecomp { hscs_guts = cg_guts,+                             hscs_mod_location = ms_location summary,+                             hscs_partial_iface = partial_iface,+                             hscs_old_iface_hash = mb_old_hash+                           }++      -- We are not generating code, so we can skip simplification+      -- and generate a simple interface.+      _ -> do+        (iface, _details) <- liftIO $+          hscSimpleIface hsc_env tc_result summary++        liftIO $ hscMaybeWriteIface logger dflags True iface mb_old_hash (ms_location summary)++        return $ HscUpdate iface++{-+Note [Writing interface files]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We write one interface file per module and per compilation, except with+-dynamic-too where we write two interface files (non-dynamic and dynamic).++We can write two kinds of interfaces (see Note [Interface file stages] in+"GHC.Driver.Types"):++   * simple interface: interface generated after the core pipeline++   * full interface: simple interface completed with information from the+     backend++Depending on the situation, we write one or the other (using+`hscMaybeWriteIface`). We must be careful with `-dynamic-too` because only the+backend is run twice, so if we write a simple interface we need to write both+the non-dynamic and the dynamic interfaces at the same time (with the same+contents).++Cases for which we generate simple interfaces:++   * GHC.Driver.Main.hscDesugarAndSimplify: when a compilation does NOT require (re)compilation+   of the hard code++   * GHC.Driver.Pipeline.compileOne': when we run in One Shot mode and target+   bytecode (if interface writing is forced).++   * GHC.Driver.Backpack uses simple interfaces for indefinite units+   (units with module holes). It writes them indirectly by forcing the+   -fwrite-interface flag while setting backend to NoBackend.++Cases for which we generate full interfaces:++   * GHC.Driver.Pipeline.runPhase: when we must be compiling to regular hard+   code and/or require recompilation.++By default interface file names are derived from module file names by adding+suffixes. The interface file name can be overloaded with "-ohi", except when+`-dynamic-too` is used.++-}++-- | Write interface files+hscMaybeWriteIface+  :: Logger+  -> DynFlags+  -> Bool+  -- ^ Is this a simple interface generated after the core pipeline, or one+  -- with information from the backend? See: Note [Writing interface files]+  -> ModIface+  -> Maybe Fingerprint+  -- ^ The old interface hash, used to decide if we need to actually write the+  -- new interface.+  -> ModLocation+  -> IO ()+hscMaybeWriteIface logger dflags is_simple iface old_iface mod_location = do+    let force_write_interface = gopt Opt_WriteInterface dflags+        write_interface = case backend dflags of+                            NoBackend    -> False+                            Interpreter  -> False+                            _            -> True++        write_iface dflags' iface =+          let !iface_name = if dynamicNow dflags' then ml_dyn_hi_file mod_location else ml_hi_file mod_location+              profile     = targetProfile dflags'+          in+          {-# SCC "writeIface" #-}+          withTiming logger+              (text "WriteIface"<+>brackets (text iface_name))+              (const ())+              (writeIface logger profile iface_name iface)++    if (write_interface || force_write_interface) then do++      -- FIXME: with -dynamic-too, "change" is only meaningful for the+      -- non-dynamic interface, not for the dynamic one. We should have another+      -- flag for the dynamic interface. In the meantime:+      --+      --    * when we write a single full interface, we check if we are+      --    currently writing the dynamic interface due to -dynamic-too, in+      --    which case we ignore "change".+      --+      --    * when we write two simple interfaces at once because of+      --    dynamic-too, we use "change" both for the non-dynamic and the+      --    dynamic interfaces. Hopefully both the dynamic and the non-dynamic+      --    interfaces stay in sync...+      --+      let change = old_iface /= Just (mi_iface_hash (mi_final_exts iface))++      let dt = dynamicTooState dflags++      when (logHasDumpFlag logger Opt_D_dump_if_trace) $ putMsg logger $+        hang (text "Writing interface(s):") 2 $ vcat+         [ text "Kind:" <+> if is_simple then text "simple" else text "full"+         , text "Hash change:" <+> ppr change+         , text "DynamicToo state:" <+> text (show dt)+         ]++      if is_simple+         then when change $ do -- FIXME: see 'change' comment above+            write_iface dflags iface+            case dt of+               DT_Dont   -> return ()+               DT_Dyn    -> panic "Unexpected DT_Dyn state when writing simple interface"+               DT_OK     -> write_iface (setDynamicNow dflags) iface+         else case dt of+               DT_Dont | change                    -> write_iface dflags iface+               DT_OK   | change                    -> write_iface dflags iface+               -- FIXME: see change' comment above+               DT_Dyn                              -> write_iface dflags iface+               _                                   -> return ()++      when (gopt Opt_WriteHie dflags) $ do+          -- This is slightly hacky. A hie file is considered to be up to date+          -- if its modification time on disk is greater than or equal to that+          -- of the .hi file (since we should always write a .hi file if we are+          -- writing a .hie file). However, with the way this code is+          -- structured at the moment, the .hie file is often written before+          -- the .hi file; by touching the file here, we ensure that it is+          -- correctly considered up-to-date.+          --+          -- The file should exist by the time we get here, but we check for+          -- existence just in case, so that we don't accidentally create empty+          -- .hie files.+          let hie_file = ml_hie_file mod_location+          whenM (doesFileExist hie_file) $+            GHC.SysTools.touch logger dflags "Touching hie file" hie_file+    else+        -- See Note [Strictness in ModIface]+        forceModIface iface++--------------------------------------------------------------+-- NoRecomp handlers+--------------------------------------------------------------+++-- | genModDetails is used to initialise 'ModDetails' at the end of compilation.+-- This has two main effects:+-- 1. Increases memory usage by unloading a lot of the TypeEnv+-- 2. Globalising certain parts (DFunIds) in the TypeEnv (which used to be achieved using UpdateIdInfos)+-- For the second part to work, it's critical that we use 'initIfaceLoadModule' here rather than+-- 'initIfaceCheck' as 'initIfaceLoadModule' removes the module from the KnotVars, otherwise name lookups+-- succeed by hitting the old TypeEnv, which missing out the critical globalisation step for DFuns.++-- After the DFunIds are globalised, it's critical to overwrite the old TypeEnv with the new+-- more compact and more correct version. This reduces memory usage whilst compiling the rest of+-- the module loop.+genModDetails :: HscEnv -> ModIface -> IO ModDetails+genModDetails hsc_env old_iface+  = do+    -- CRITICAL: To use initIfaceLoadModule as that removes the current module from the KnotVars and+    -- hence properly globalises DFunIds.+    new_details <- {-# SCC "tcRnIface" #-}+                  initIfaceLoadModule hsc_env (mi_module old_iface) (typecheckIface old_iface)+    case lookupKnotVars (hsc_type_env_vars hsc_env) (mi_module old_iface) of+      Nothing -> return ()+      Just te_var -> writeIORef te_var (md_types new_details)+    dumpIfaceStats hsc_env+    return new_details++--------------------------------------------------------------+-- Progress displayers.+--------------------------------------------------------------++oneShotMsg :: Logger -> RecompileRequired -> IO ()+oneShotMsg logger recomp =+    case recomp of+        UpToDate -> compilationProgressMsg logger $ text "compilation IS NOT required"+        NeedsRecompile _ -> return ()++batchMsg :: Messager+batchMsg = batchMsgWith (\_ _ _ _ -> empty)+batchMultiMsg :: Messager+batchMultiMsg = batchMsgWith (\_ _ _ node -> brackets (ppr (moduleGraphNodeUnitId node)))++batchMsgWith :: (HscEnv -> (Int, Int) -> RecompileRequired -> ModuleGraphNode -> SDoc) -> Messager+batchMsgWith extra hsc_env_start mod_index recomp node =+      case recomp of+        UpToDate+          | logVerbAtLeast logger 2 -> showMsg (text "Skipping") empty+          | otherwise -> return ()+        NeedsRecompile reason0 -> showMsg (text herald) $ case reason0 of+          MustCompile            -> empty+          (RecompBecause reason) -> text " [" <> pprWithUnitState state (ppr reason) <> text "]"+    where+        herald = case node of+                    LinkNode {} -> "Linking"+                    InstantiationNode {} -> "Instantiating"+                    ModuleNode {} -> "Compiling"+        hsc_env = hscSetActiveUnitId (moduleGraphNodeUnitId node) hsc_env_start+        dflags = hsc_dflags hsc_env+        logger = hsc_logger hsc_env+        state  = hsc_units hsc_env+        showMsg msg reason =+            compilationProgressMsg logger $+            (showModuleIndex mod_index <>+            msg <+> showModMsg dflags (recompileRequired recomp) node)+                <> extra hsc_env mod_index recomp node+                <> reason++--------------------------------------------------------------+-- Safe Haskell+--------------------------------------------------------------++-- Note [Safe Haskell Trust Check]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Safe Haskell checks that an import is trusted according to the following+-- rules for an import of module M that resides in Package P:+--+--   * If M is recorded as Safe and all its trust dependencies are OK+--     then M is considered safe.+--   * If M is recorded as Trustworthy and P is considered trusted and+--     all M's trust dependencies are OK then M is considered safe.+--+-- By trust dependencies we mean that the check is transitive. So if+-- a module M that is Safe relies on a module N that is trustworthy,+-- importing module M will first check (according to the second case)+-- that N is trusted before checking M is trusted.+--+-- This is a minimal description, so please refer to the user guide+-- for more details. The user guide is also considered the authoritative+-- source in this matter, not the comments or code.+++-- Note [Safe Haskell Inference]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Safe Haskell does Safe inference on modules that don't have any specific+-- safe haskell mode flag. The basic approach to this is:+--   * When deciding if we need to do a Safe language check, treat+--     an unmarked module as having -XSafe mode specified.+--   * For checks, don't throw errors but return them to the caller.+--   * Caller checks if there are errors:+--     * For modules explicitly marked -XSafe, we throw the errors.+--     * For unmarked modules (inference mode), we drop the errors+--       and mark the module as being Unsafe.+--+-- It used to be that we only did safe inference on modules that had no Safe+-- Haskell flags, but now we perform safe inference on all modules as we want+-- to allow users to set the `-Wsafe`, `-Wunsafe` and+-- `-Wtrustworthy-safe` flags on Trustworthy and Unsafe modules so that a+-- user can ensure their assumptions are correct and see reasons for why a+-- module is safe or unsafe.+--+-- This is tricky as we must be careful when we should throw an error compared+-- to just warnings. For checking safe imports we manage it as two steps. First+-- we check any imports that are required to be safe, then we check all other+-- imports to see if we can infer them to be safe.+++-- | Check that the safe imports of the module being compiled are valid.+-- If not we either issue a compilation error if the module is explicitly+-- using Safe Haskell, or mark the module as unsafe if we're in safe+-- inference mode.+hscCheckSafeImports :: TcGblEnv -> Hsc TcGblEnv+hscCheckSafeImports tcg_env = do+    dflags   <- getDynFlags+    tcg_env' <- checkSafeImports tcg_env+    checkRULES dflags tcg_env'++  where+    checkRULES dflags tcg_env' =+      let diag_opts = initDiagOpts dflags+      in case safeLanguageOn dflags of+          True -> do+              -- XSafe: we nuke user written RULES+              logDiagnostics $ fmap GhcDriverMessage $ warns diag_opts (tcg_rules tcg_env')+              return tcg_env' { tcg_rules = [] }+          False+                -- SafeInferred: user defined RULES, so not safe+              | safeInferOn dflags && not (null $ tcg_rules tcg_env')+              -> markUnsafeInfer tcg_env' $ warns diag_opts (tcg_rules tcg_env')++                -- Trustworthy OR SafeInferred: with no RULES+              | otherwise+              -> return tcg_env'++    warns diag_opts rules = mkMessages $ listToBag $ map (warnRules diag_opts) rules++    warnRules :: DiagOpts -> LRuleDecl GhcTc -> MsgEnvelope DriverMessage+    warnRules diag_opts (L loc rule) =+        mkPlainMsgEnvelope diag_opts (locA loc) $ DriverUserDefinedRuleIgnored rule++-- | Validate that safe imported modules are actually safe.  For modules in the+-- HomePackage (the package the module we are compiling in resides) this just+-- involves checking its trust type is 'Safe' or 'Trustworthy'. For modules+-- that reside in another package we also must check that the external package+-- is trusted. See the Note [Safe Haskell Trust Check] above for more+-- information.+--+-- The code for this is quite tricky as the whole algorithm is done in a few+-- distinct phases in different parts of the code base. See+-- 'GHC.Rename.Names.rnImportDecl' for where package trust dependencies for a+-- module are collected and unioned.  Specifically see the Note [Tracking Trust+-- Transitively] in "GHC.Rename.Names" and the Note [Trust Own Package] in+-- "GHC.Rename.Names".+checkSafeImports :: TcGblEnv -> Hsc TcGblEnv+checkSafeImports tcg_env+    = do+        dflags <- getDynFlags+        imps <- mapM condense imports'+        let (safeImps, regImps) = partition (\(_,_,s) -> s) imps++        -- We want to use the warning state specifically for detecting if safe+        -- inference has failed, so store and clear any existing warnings.+        oldErrs <- getDiagnostics+        clearDiagnostics++        -- Check safe imports are correct+        safePkgs <- S.fromList <$> mapMaybeM checkSafe safeImps+        safeErrs <- getDiagnostics+        clearDiagnostics++        -- Check non-safe imports are correct if inferring safety+        -- See the Note [Safe Haskell Inference]+        (infErrs, infPkgs) <- case (safeInferOn dflags) of+          False -> return (emptyMessages, S.empty)+          True -> do infPkgs <- S.fromList <$> mapMaybeM checkSafe regImps+                     infErrs <- getDiagnostics+                     clearDiagnostics+                     return (infErrs, infPkgs)++        -- restore old errors+        logDiagnostics oldErrs++        case (isEmptyMessages safeErrs) of+          -- Failed safe check+          False -> liftIO . throwErrors $ safeErrs++          -- Passed safe check+          True -> do+            let infPassed = isEmptyMessages infErrs+            tcg_env' <- case (not infPassed) of+              True  -> markUnsafeInfer tcg_env infErrs+              False -> return tcg_env+            when (packageTrustOn dflags) $ checkPkgTrust pkgReqs+            let newTrust = pkgTrustReqs dflags safePkgs infPkgs infPassed+            return tcg_env' { tcg_imports = impInfo `plusImportAvails` newTrust }++  where+    impInfo  = tcg_imports tcg_env     -- ImportAvails+    imports  = imp_mods impInfo        -- ImportedMods+    imports1 = moduleEnvToList imports -- (Module, [ImportedBy])+    imports' = map (fmap importedByUser) imports1 -- (Module, [ImportedModsVal])+    pkgReqs  = imp_trust_pkgs impInfo  -- [Unit]++    condense :: (Module, [ImportedModsVal]) -> Hsc (Module, SrcSpan, IsSafeImport)+    condense (_, [])   = panic "GHC.Driver.Main.condense: Pattern match failure!"+    condense (m, x:xs) = do imv <- foldlM cond' x xs+                            return (m, imv_span imv, imv_is_safe imv)++    -- ImportedModsVal = (ModuleName, Bool, SrcSpan, IsSafeImport)+    cond' :: ImportedModsVal -> ImportedModsVal -> Hsc ImportedModsVal+    cond' v1 v2+        | imv_is_safe v1 /= imv_is_safe v2+        = throwOneError $+            mkPlainErrorMsgEnvelope (imv_span v1) $+            GhcDriverMessage $ DriverMixedSafetyImport (imv_name v1)+        | otherwise+        = return v1++    -- easier interface to work with+    checkSafe :: (Module, SrcSpan, a) -> Hsc (Maybe UnitId)+    checkSafe (m, l, _) = fst `fmap` hscCheckSafe' m l++    -- what pkg's to add to our trust requirements+    pkgTrustReqs :: DynFlags -> Set UnitId -> Set UnitId ->+          Bool -> ImportAvails+    pkgTrustReqs dflags req inf infPassed | safeInferOn dflags+                                  && not (safeHaskellModeEnabled dflags) && infPassed+                                   = emptyImportAvails {+                                       imp_trust_pkgs = req `S.union` inf+                                   }+    pkgTrustReqs dflags _   _ _ | safeHaskell dflags == Sf_Unsafe+                         = emptyImportAvails+    pkgTrustReqs _ req _ _ = emptyImportAvails { imp_trust_pkgs = req }++-- | Check that a module is safe to import.+--+-- We return True to indicate the import is safe and False otherwise+-- although in the False case an exception may be thrown first.+hscCheckSafe :: HscEnv -> Module -> SrcSpan -> IO Bool+hscCheckSafe hsc_env m l = runHsc hsc_env $ do+    dflags <- getDynFlags+    pkgs <- snd `fmap` hscCheckSafe' m l+    when (packageTrustOn dflags) $ checkPkgTrust pkgs+    errs <- getDiagnostics+    return $ isEmptyMessages errs++-- | Return if a module is trusted and the pkgs it depends on to be trusted.+hscGetSafe :: HscEnv -> Module -> SrcSpan -> IO (Bool, Set UnitId)+hscGetSafe hsc_env m l = runHsc hsc_env $ do+    (self, pkgs) <- hscCheckSafe' m l+    good         <- isEmptyMessages `fmap` getDiagnostics+    clearDiagnostics -- don't want them printed...+    let pkgs' | Just p <- self = S.insert p pkgs+              | otherwise      = pkgs+    return (good, pkgs')++-- | Is a module trusted? If not, throw or log errors depending on the type.+-- Return (regardless of trusted or not) if the trust type requires the modules+-- own package be trusted and a list of other packages required to be trusted+-- (these later ones haven't been checked) but the own package trust has been.+hscCheckSafe' :: Module -> SrcSpan+  -> Hsc (Maybe UnitId, Set UnitId)+hscCheckSafe' m l = do+    hsc_env <- getHscEnv+    let home_unit = hsc_home_unit hsc_env+    (tw, pkgs) <- isModSafe home_unit m l+    case tw of+        False                           -> return (Nothing, pkgs)+        True | isHomeModule home_unit m -> return (Nothing, pkgs)+             -- TODO: do we also have to check the trust of the instantiation?+             -- Not necessary if that is reflected in dependencies+             | otherwise   -> return (Just $ toUnitId (moduleUnit m), pkgs)+  where+    isModSafe :: HomeUnit -> Module -> SrcSpan -> Hsc (Bool, Set UnitId)+    isModSafe home_unit m l = do+        hsc_env <- getHscEnv+        dflags <- getDynFlags+        iface <- lookup' m+        let diag_opts = initDiagOpts dflags+        case iface of+            -- can't load iface to check trust!+            Nothing -> throwOneError $+                         mkPlainErrorMsgEnvelope l $+                         GhcDriverMessage $ DriverCannotLoadInterfaceFile m++            -- got iface, check trust+            Just iface' ->+                let trust = getSafeMode $ mi_trust iface'+                    trust_own_pkg = mi_trust_pkg iface'+                    -- check module is trusted+                    safeM = trust `elem` [Sf_Safe, Sf_SafeInferred, Sf_Trustworthy]+                    -- check package is trusted+                    safeP = packageTrusted dflags (hsc_units hsc_env) home_unit trust trust_own_pkg m+                    -- pkg trust reqs+                    pkgRs = dep_trusted_pkgs $ mi_deps iface'+                    -- warn if Safe module imports Safe-Inferred module.+                    warns = if wopt Opt_WarnInferredSafeImports dflags+                                && safeLanguageOn dflags+                                && trust == Sf_SafeInferred+                                then inferredImportWarn diag_opts+                                else emptyMessages+                    -- General errors we throw but Safe errors we log+                    errs = case (safeM, safeP) of+                        (True, True ) -> emptyMessages+                        (True, False) -> pkgTrustErr+                        (False, _   ) -> modTrustErr+                in do+                    logDiagnostics warns+                    logDiagnostics errs+                    return (trust == Sf_Trustworthy, pkgRs)++                where+                    state = hsc_units hsc_env+                    inferredImportWarn diag_opts = singleMessage+                        $ mkMsgEnvelope diag_opts l (pkgQual state)+                        $ GhcDriverMessage $ DriverInferredSafeImport m+                    pkgTrustErr = singleMessage+                      $ mkErrorMsgEnvelope l (pkgQual state)+                      $ GhcDriverMessage $ DriverCannotImportFromUntrustedPackage state m+                    modTrustErr = singleMessage+                      $ mkErrorMsgEnvelope l (pkgQual state)+                      $ GhcDriverMessage $ DriverCannotImportUnsafeModule m++    -- Check the package a module resides in is trusted. Safe compiled+    -- modules are trusted without requiring that their package is trusted. For+    -- trustworthy modules, modules in the home package are trusted but+    -- otherwise we check the package trust flag.+    packageTrusted :: DynFlags -> UnitState -> HomeUnit -> SafeHaskellMode -> Bool -> Module -> Bool+    packageTrusted dflags unit_state home_unit safe_mode trust_own_pkg mod =+        case safe_mode of+            Sf_None      -> False -- shouldn't hit these cases+            Sf_Ignore    -> False -- shouldn't hit these cases+            Sf_Unsafe    -> False -- prefer for completeness.+            _ | not (packageTrustOn dflags)     -> True+            Sf_Safe | not trust_own_pkg         -> True+            Sf_SafeInferred | not trust_own_pkg -> True+            _ | isHomeModule home_unit mod      -> True+            _ -> unitIsTrusted $ unsafeLookupUnit unit_state (moduleUnit m)++    lookup' :: Module -> Hsc (Maybe ModIface)+    lookup' m = do+        hsc_env <- getHscEnv+        hsc_eps <- liftIO $ hscEPS hsc_env+        let pkgIfaceT = eps_PIT hsc_eps+            hug       = hsc_HUG hsc_env+            iface     = lookupIfaceByModule hug pkgIfaceT m+        -- the 'lookupIfaceByModule' method will always fail when calling from GHCi+        -- as the compiler hasn't filled in the various module tables+        -- so we need to call 'getModuleInterface' to load from disk+        case iface of+            Just _  -> return iface+            Nothing -> snd `fmap` (liftIO $ getModuleInterface hsc_env m)+++-- | Check the list of packages are trusted.+checkPkgTrust :: Set UnitId -> Hsc ()+checkPkgTrust pkgs = do+    hsc_env <- getHscEnv+    let errors = S.foldr go emptyBag pkgs+        state  = hsc_units hsc_env+        go pkg acc+            | unitIsTrusted $ unsafeLookupUnitId state pkg+            = acc+            | otherwise+            = (`consBag` acc)+                     $ mkErrorMsgEnvelope noSrcSpan (pkgQual state)+                     $ GhcDriverMessage+                     $ DriverPackageNotTrusted state pkg+    if isEmptyBag errors+      then return ()+      else liftIO $ throwErrors $ mkMessages errors++-- | Set module to unsafe and (potentially) wipe trust information.+--+-- Make sure to call this method to set a module to inferred unsafe, it should+-- be a central and single failure method. We only wipe the trust information+-- when we aren't in a specific Safe Haskell mode.+--+-- While we only use this for recording that a module was inferred unsafe, we+-- may call it on modules using Trustworthy or Unsafe flags so as to allow+-- warning flags for safety to function correctly. See Note [Safe Haskell+-- Inference].+markUnsafeInfer :: 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 $+             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) $+$+                                    (vcat $ pprMsgEnvelopeBagWithLoc (getMessages whyUnsafe)) $+$+                                    (vcat $ badInsts $ tcg_insts tcg_env)+                         ]+    badFlags df   = concatMap (badFlag df) unsafeFlagsForInfer+    badFlag df (str,loc,on,_)+        | on df     = [mkLocMessage MCOutput (loc df) $+                            text str <+> text "is not allowed in Safe Haskell"]+        | otherwise = []+    badInsts insts = concatMap badInst insts++    checkOverlap (NoOverlap _) = False+    checkOverlap _             = True++    badInst ins | checkOverlap (overlapMode (is_flag ins))+                = [mkLocMessage MCOutput (nameSrcSpan $ getName $ is_dfun ins) $+                      ppr (overlapMode $ is_flag ins) <+>+                      text "overlap mode isn't allowed in Safe Haskell"]+                | otherwise = []++-- | Figure out the final correct safe haskell mode+hscGetSafeMode :: TcGblEnv -> Hsc SafeHaskellMode+hscGetSafeMode tcg_env = do+    dflags  <- getDynFlags+    liftIO $ finalSafeMode dflags tcg_env++--------------------------------------------------------------+-- Simplifiers+--------------------------------------------------------------++-- | Run Core2Core simplifier. The list of String is a list of (Core) plugin+-- module names added via TH (cf 'addCorePlugin').+hscSimplify :: HscEnv -> [String] -> ModGuts -> IO ModGuts+hscSimplify hsc_env plugins modguts =+    runHsc hsc_env $ hscSimplify' plugins modguts++-- | Run Core2Core simplifier. The list of String is a list of (Core) plugin+-- module names added via TH (cf 'addCorePlugin').+hscSimplify' :: [String] -> ModGuts -> Hsc ModGuts+hscSimplify' plugins ds_result = do+    hsc_env <- getHscEnv+    hsc_env_with_plugins <- if null plugins -- fast path+        then return hsc_env+        else liftIO $ initializePlugins+                    $ hscUpdateFlags (\dflags -> foldr addPluginModuleName dflags plugins)+                      hsc_env+    {-# SCC "Core2Core" #-}+      liftIO $ core2core hsc_env_with_plugins ds_result++--------------------------------------------------------------+-- Interface generators+--------------------------------------------------------------++-- | Generate a striped down interface file, e.g. for boot files or when ghci+-- generates interface files. See Note [simpleTidyPgm - mkBootModDetailsTc]+hscSimpleIface :: HscEnv+               -> TcGblEnv+               -> ModSummary+               -> IO (ModIface, ModDetails)+hscSimpleIface hsc_env tc_result summary+    = runHsc hsc_env $ hscSimpleIface' tc_result summary++hscSimpleIface' :: TcGblEnv+                -> ModSummary+                -> Hsc (ModIface, ModDetails)+hscSimpleIface' 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 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 CgInfos)+                -- ^ @Just f@ <=> _stub.c is f+hscGenHardCode hsc_env cgguts location output_filename = do+        let CgGuts{ -- This is the last use of the ModGuts in a compilation.+                    -- From now on, we just use the bits we need.+                    cg_module   = this_mod,+                    cg_binds    = core_binds,+                    cg_ccs      = local_ccs,+                    cg_tycons   = tycons,+                    cg_foreign  = foreign_stubs0,+                    cg_foreign_files = foreign_files,+                    cg_dep_pkgs = dependencies,+                    cg_hpc_info = hpc_info } = cgguts+            dflags = hsc_dflags hsc_env+            logger = hsc_logger hsc_env+            hooks  = hsc_hooks hsc_env+            tmpfs  = hsc_tmpfs hsc_env+            profile = targetProfile dflags+            data_tycons = filter isDataTyCon tycons+            -- cg_tycons includes newtypes, for the benefit of External Core,+            -- but we don't generate any code for newtypes++        -------------------+        -- Insert late cost centres if enabled.+        -- If `-fprof-late-inline` is enabled we can skip this, as it will have added+        -- a superset of cost centres we would add here already.++        (late_cc_binds, late_local_ccs) <-+              if gopt Opt_ProfLateCcs dflags && not (gopt Opt_ProfLateInlineCcs dflags)+                  then  {-# SCC lateCC #-} do+                    (binds,late_ccs) <- addLateCostCentresPgm dflags logger this_mod core_binds+                    return ( binds, (S.toList late_ccs `mappend` local_ccs ))+                  else+                    return (core_binds, local_ccs)++++        -------------------+        -- PREPARE FOR CODE GENERATION+        -- Do saturation and convert to A-normal form+        (prepd_binds) <- {-# SCC "CorePrep" #-}+                       corePrepPgm hsc_env this_mod location+                                   late_cc_binds data_tycons++        -----------------  Convert to STG ------------------+        (stg_binds, denv, (caf_ccs, caf_cc_stacks))+            <- {-# SCC "CoreToStg" #-}+               withTiming logger+                   (text "CoreToStg"<+>brackets (ppr this_mod))+                   (\(a, b, (c,d)) -> a `seqList` b `seq` c `seqList` d `seqList` ())+                   (myCoreToStg logger dflags (hsc_IC hsc_env) False this_mod location prepd_binds)++        let cost_centre_info =+              (late_local_ccs ++ caf_ccs, caf_cc_stacks)+            platform = targetPlatform dflags+            prof_init+              | sccProfilingEnabled dflags = profilingInitCode platform this_mod cost_centre_info+              | otherwise = mempty++        ------------------  Code generation ------------------+        -- The back-end is streamed: each top-level function goes+        -- from Stg all the way to asm before dealing with the next+        -- top-level function, so showPass isn't very useful here.+        -- Hence we have one showPass for the whole backend, the+        -- next showPass after this will be "Assembler".+        withTiming logger+                   (text "CodeGen"<+>brackets (ppr this_mod))+                   (const ()) $ do+            cmms <- {-# SCC "StgToCmm" #-}+                            doCodeGen hsc_env this_mod denv data_tycons+                                cost_centre_info+                                stg_binds hpc_info++            ------------------  Code output -----------------------+            rawcmms0 <- {-# SCC "cmmToRawCmm" #-}+                        case cmmToRawCmmHook hooks of+                            Nothing -> cmmToRawCmm logger profile cmms+                            Just h  -> h dflags (Just this_mod) cmms++            let dump a = do+                  unless (null a) $+                    putDumpFileMaybe logger Opt_D_dump_cmm_raw "Raw Cmm" FormatCMM (pdoc platform a)+                  return a+                rawcmms1 = Stream.mapM dump rawcmms0++            let foreign_stubs st = foreign_stubs0 `appendStubC` prof_init+                                                  `appendStubC` cgIPEStub st++            (output_filename, (_stub_h_exists, stub_c_exists), foreign_fps, cg_infos)+                <- {-# SCC "codeOutput" #-}+                  codeOutput logger tmpfs dflags (hsc_units hsc_env) this_mod output_filename location+                  foreign_stubs foreign_files dependencies rawcmms1+            return (output_filename, stub_c_exists, foreign_fps, Just cg_infos)+++hscInteractive :: HscEnv+               -> CgGuts+               -> ModLocation+               -> IO (Maybe FilePath, CompiledByteCode, [SptEntry])+hscInteractive hsc_env cgguts location = do+    let dflags = hsc_dflags hsc_env+    let logger = hsc_logger hsc_env+    let tmpfs  = hsc_tmpfs hsc_env+    let CgGuts{ -- This is the last use of the ModGuts in a compilation.+                -- From now on, we just use the bits we need.+               cg_module   = this_mod,+               cg_binds    = core_binds,+               cg_tycons   = tycons,+               cg_foreign  = foreign_stubs,+               cg_modBreaks = mod_breaks,+               cg_spt_entries = spt_entries } = cgguts++        data_tycons = filter isDataTyCon tycons+        -- cg_tycons includes newtypes, for the benefit of External Core,+        -- but we don't generate any code for newtypes++    -------------------+    -- PREPARE FOR CODE GENERATION+    -- Do saturation and convert to A-normal form+    prepd_binds <- {-# SCC "CorePrep" #-}+                   corePrepPgm hsc_env this_mod location core_binds data_tycons++    (stg_binds, _infotable_prov, _caf_ccs__caf_cc_stacks)+      <- {-# SCC "CoreToStg" #-}+          myCoreToStg logger dflags (hsc_IC hsc_env) True this_mod location prepd_binds+    -----------------  Generate byte code ------------------+    comp_bc <- byteCodeGen hsc_env this_mod stg_binds data_tycons mod_breaks+    ------------------ Create f-x-dynamic C-side stuff -----+    (_istub_h_exists, istub_c_exists)+        <- outputForeignStubs logger tmpfs dflags (hsc_units hsc_env) this_mod location foreign_stubs+    return (istub_c_exists, comp_bc, spt_entries)++------------------------------++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+        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+    (cmm, ents) <- ioMsgMaybe+               $ do+                  (warns,errs,cmm) <- withTiming logger (text "ParseCmm"<+>brackets (text filename)) (\_ -> ())+                                       $ parseCmmFile dflags cmm_mod home_unit filename+                  let msgs = warns `unionMessages` errs+                  return (GhcPsMessage <$> msgs, cmm)+    liftIO $ do+        putDumpFileMaybe logger Opt_D_dump_cmm_verbose_by_proc "Parsed Cmm" FormatCMM (pdoc platform cmm)++        -- Compile decls in Cmm files one decl at a time, to avoid re-ordering+        -- them in SRT analysis.+        --+        -- Re-ordering here causes breakage when booting with C backend because+        -- in C we must declare before use, but SRT algorithm is free to+        -- re-order [A, B] (B refers to A) when A is not CAFFY and return [B, A]+        cmmgroup <-+          concatMapM (\cmm -> snd <$> cmmPipeline hsc_env (emptySRT cmm_mod) [cmm]) cmm++        unless (null cmmgroup) $+          putDumpFileMaybe logger Opt_D_dump_cmm "Output Cmm"+            FormatCMM (pdoc platform cmmgroup)++        rawCmms <- case cmmToRawCmmHook hooks of+          Nothing -> cmmToRawCmm logger profile (Stream.yield cmmgroup)+          Just h  -> h           dflags Nothing (Stream.yield cmmgroup)++        let foreign_stubs _ =+              let ip_init   = ipInitCode do_info_table platform cmm_mod ents+              in NoStubs `appendStubC` ip_init++        (_output_filename, (_stub_h_exists, stub_c_exists), _foreign_fps, _caf_infos)+          <- codeOutput logger tmpfs dflags (hsc_units hsc_env) cmm_mod output_filename no_loc foreign_stubs [] S.empty+             rawCmms+        return stub_c_exists+  where+    no_loc = ModLocation{ ml_hs_file  = Just filename,+                          ml_hi_file  = panic "hscCompileCmmFile: no hi file",+                          ml_obj_file = panic "hscCompileCmmFile: no obj file",+                          ml_dyn_obj_file = panic "hscCompileCmmFile: no dyn obj file",+                          ml_dyn_hi_file  = panic "hscCompileCmmFile: no dyn obj file",+                          ml_hie_file = panic "hscCompileCmmFile: no hie file"}++-------------------- Stuff for new code gen ---------------------++{-+Note [Forcing of stg_binds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+The two last steps in the STG pipeline are:++* Sorting the bindings in dependency order.+* Annotating them with free variables.++We want to make sure we do not keep references to unannotated STG bindings+alive, nor references to bindings which have already been compiled to Cmm.++We explicitly force the bindings to avoid this.++This reduces residency towards the end of the CodeGen phase significantly+(5-10%).+-}++doCodeGen :: HscEnv -> Module -> InfoTableProvMap -> [TyCon]+          -> CollectedCCs+          -> [CgStgTopBinding] -- ^ Bindings come already annotated with fvs+          -> HpcInfo+          -> IO (Stream IO CmmGroupSRTs CgInfos)+         -- Note we produce a 'Stream' of CmmGroups, so that the+         -- backend can be run incrementally.  Otherwise it generates all+         -- the C-- up front, which has a significant space cost.+doCodeGen hsc_env this_mod denv data_tycons+              cost_centre_info stg_binds_w_fvs hpc_info = do+    let dflags     = hsc_dflags hsc_env+        logger     = hsc_logger hsc_env+        hooks      = hsc_hooks  hsc_env+        tmpfs      = hsc_tmpfs  hsc_env+        platform   = targetPlatform dflags++    -- Do tag inference on optimized STG+    (!stg_post_infer,export_tag_info) <-+        {-# SCC "StgTagFields" #-} inferTags dflags logger this_mod stg_binds_w_fvs++    putDumpFileMaybe logger Opt_D_dump_stg_final "Final STG:" FormatSTG+        (pprGenStgTopBindings (initStgPprOpts dflags) stg_post_infer)++    let stg_to_cmm dflags mod = case stgToCmmHook hooks of+                        Nothing -> StgToCmm.codeGen logger tmpfs (initStgToCmmConfig dflags mod)+                        Just h  -> h                             (initStgToCmmConfig dflags mod)++    let cmm_stream :: Stream IO CmmGroup ModuleLFInfos+        -- See Note [Forcing of stg_binds]+        cmm_stream = stg_post_infer `seqList` {-# SCC "StgToCmm" #-}+            stg_to_cmm dflags this_mod denv data_tycons cost_centre_info stg_post_infer hpc_info++        -- codegen consumes a stream of CmmGroup, and produces a new+        -- stream of CmmGroup (not necessarily synchronised: one+        -- CmmGroup on input may produce many CmmGroups on output due+        -- to proc-point splitting).++    let dump1 a = do+          unless (null a) $+            putDumpFileMaybe logger Opt_D_dump_cmm_from_stg+              "Cmm produced by codegen" FormatCMM (pdoc platform a)+          return a++        ppr_stream1 = Stream.mapM dump1 cmm_stream++        pipeline_stream :: Stream IO CmmGroupSRTs (NonCaffySet, ModuleLFInfos)+        pipeline_stream = do+          (non_cafs,  lf_infos) <-+            {-# SCC "cmmPipeline" #-}+            Stream.mapAccumL_ (cmmPipeline hsc_env) (emptySRT this_mod) ppr_stream1+              <&> first (srtMapNonCAFs . moduleSRTMap)++          return (non_cafs, lf_infos)++        dump2 a = do+          unless (null a) $+            putDumpFileMaybe logger Opt_D_dump_cmm "Output Cmm" FormatCMM (pdoc platform a)+          return a++    return $ Stream.mapM dump2 $ generateCgIPEStub hsc_env this_mod denv export_tag_info pipeline_stream++myCoreToStgExpr :: Logger -> DynFlags -> InteractiveContext+                -> Bool+                -> Module -> ModLocation -> CoreExpr+                -> IO ( Id+                      , [CgStgTopBinding]+                      , InfoTableProvMap+                      , CollectedCCs )+myCoreToStgExpr logger dflags ictxt for_bytecode this_mod ml prepd_expr = do+    {- Create a temporary binding (just because myCoreToStg needs a+       binding for the stg2stg step) -}+    let bco_tmp_id = mkSysLocal (fsLit "BCO_toplevel")+                                (mkPseudoUniqueE 0)+                                Many+                                (exprType prepd_expr)+    (stg_binds, prov_map, collected_ccs) <-+       myCoreToStg logger+                   dflags+                   ictxt+                   for_bytecode+                   this_mod+                   ml+                   [NonRec bco_tmp_id prepd_expr]+    return (bco_tmp_id, stg_binds, prov_map, collected_ccs)++myCoreToStg :: Logger -> DynFlags -> InteractiveContext+            -> Bool+            -> Module -> ModLocation -> CoreProgram+            -> IO ( [CgStgTopBinding] -- output program+                  , InfoTableProvMap+                  , CollectedCCs )  -- CAF cost centre info (declared and used)+myCoreToStg logger dflags ictxt for_bytecode this_mod ml prepd_binds = do+    let (stg_binds, denv, cost_centre_info)+         = {-# SCC "Core2Stg" #-}+           coreToStg dflags this_mod ml prepd_binds++    stg_binds_with_fvs+        <- {-# SCC "Stg2Stg" #-}+           stg2stg logger ictxt (initStgPipelineOpts dflags for_bytecode)+                   this_mod stg_binds++    putDumpFileMaybe logger Opt_D_dump_stg_cg "CodeGenInput STG:" FormatSTG+        (pprGenStgTopBindings (initStgPprOpts dflags) stg_binds_with_fvs)++    return (stg_binds_with_fvs, denv, cost_centre_info)++{- **********************************************************************+%*                                                                      *+\subsection{Compiling a do-statement}+%*                                                                      *+%********************************************************************* -}++{-+When the UnlinkedBCOExpr is linked you get an HValue of type *IO [HValue]* When+you run it you get a list of HValues that should be the same length as the list+of names; add them to the ClosureEnv.++A naked expression returns a singleton Name [it]. The stmt is lifted into the+IO monad as explained in Note [Interactively-bound Ids in GHCi] in GHC.Runtime.Context+-}++-- | Compile a stmt all the way to an HValue, but don't run it+--+-- We return Nothing to indicate an empty statement (or comment only), not a+-- parse error.+hscStmt :: HscEnv -> String -> IO (Maybe ([Id], ForeignHValue, FixityEnv))+hscStmt hsc_env stmt = hscStmtWithLocation hsc_env stmt "<interactive>" 1++-- | Compile a stmt all the way to an HValue, but don't run it+--+-- We return Nothing to indicate an empty statement (or comment only), not a+-- parse error.+hscStmtWithLocation :: HscEnv+                    -> String -- ^ The statement+                    -> String -- ^ The source+                    -> Int    -- ^ Starting line+                    -> IO ( Maybe ([Id]+                          , ForeignHValue {- IO [HValue] -}+                          , FixityEnv))+hscStmtWithLocation hsc_env0 stmt source linenumber =+  runInteractiveHsc hsc_env0 $ do+    maybe_stmt <- hscParseStmtWithLocation source linenumber stmt+    case maybe_stmt of+      Nothing -> return Nothing++      Just parsed_stmt -> do+        hsc_env <- getHscEnv+        liftIO $ hscParsedStmt hsc_env parsed_stmt++hscParsedStmt :: HscEnv+              -> GhciLStmt GhcPs  -- ^ The parsed statement+              -> IO ( Maybe ([Id]+                    , ForeignHValue {- IO [HValue] -}+                    , FixityEnv))+hscParsedStmt hsc_env stmt = runInteractiveHsc hsc_env $ do+  -- Rename and typecheck it+  (ids, tc_expr, fix_env) <- ioMsgMaybe $ hoistTcRnMessage $ tcRnStmt hsc_env stmt++  -- Desugar it+  ds_expr <- ioMsgMaybe $ hoistDsMessage $ deSugarExpr hsc_env tc_expr+  liftIO (lintInteractiveExpr (text "desugar expression") hsc_env ds_expr)+  handleWarnings++  -- Then code-gen, and link it+  -- It's important NOT to have package 'interactive' as thisUnitId+  -- for linking, else we try to link 'main' and can't find it.+  -- Whereas the linker already knows to ignore 'interactive'+  let src_span = srcLocSpan interactiveSrcLoc+  (hval,_,_) <- liftIO $ hscCompileCoreExpr hsc_env src_span ds_expr++  return $ Just (ids, hval, fix_env)++-- | Compile a decls+hscDecls :: HscEnv+         -> String -- ^ The statement+         -> IO ([TyThing], InteractiveContext)+hscDecls hsc_env str = hscDeclsWithLocation hsc_env str "<interactive>" 1++hscParseModuleWithLocation :: HscEnv -> String -> Int -> String -> IO HsModule+hscParseModuleWithLocation hsc_env source line_num str = do+    L _ mod <-+      runInteractiveHsc hsc_env $+        hscParseThingWithLocation source line_num parseModule str+    return mod++hscParseDeclsWithLocation :: HscEnv -> String -> Int -> String -> IO [LHsDecl GhcPs]+hscParseDeclsWithLocation hsc_env source line_num str = do+  HsModule { hsmodDecls = decls } <- hscParseModuleWithLocation hsc_env source line_num str+  return decls++-- | Compile a decls+hscDeclsWithLocation :: HscEnv+                     -> String -- ^ The statement+                     -> String -- ^ The source+                     -> Int    -- ^ Starting line+                     -> IO ([TyThing], InteractiveContext)+hscDeclsWithLocation hsc_env str source linenumber = do+    L _ (HsModule{ hsmodDecls = decls }) <-+      runInteractiveHsc hsc_env $+        hscParseThingWithLocation source linenumber parseModule str+    hscParsedDecls hsc_env decls++hscParsedDecls :: HscEnv -> [LHsDecl GhcPs] -> IO ([TyThing], InteractiveContext)+hscParsedDecls hsc_env decls = runInteractiveHsc hsc_env $ do+    hsc_env <- getHscEnv+    let interp = hscInterp hsc_env++    {- Rename and typecheck it -}+    tc_gblenv <- ioMsgMaybe $ hoistTcRnMessage $ tcRnDeclsi hsc_env decls++    {- Grab the new instances -}+    -- We grab the whole environment because of the overlapping that may have+    -- been done. See the notes at the definition of InteractiveContext+    -- (ic_instances) for more details.+    let defaults = tcg_default tc_gblenv++    {- Desugar it -}+    -- We use a basically null location for iNTERACTIVE+    let iNTERACTIVELoc = ModLocation{ ml_hs_file   = Nothing,+                                      ml_hi_file   = panic "hsDeclsWithLocation:ml_hi_file",+                                      ml_obj_file  = panic "hsDeclsWithLocation:ml_obj_file",+                                      ml_dyn_obj_file = panic "hsDeclsWithLocation:ml_dyn_obj_file",+                                      ml_dyn_hi_file = panic "hsDeclsWithLocation:ml_dyn_hi_file",+                                      ml_hie_file  = panic "hsDeclsWithLocation:ml_hie_file" }+    ds_result <- hscDesugar' iNTERACTIVELoc tc_gblenv++    {- Simplify -}+    simpl_mg <- liftIO $ do+      plugins <- readIORef (tcg_th_coreplugins tc_gblenv)+      hscSimplify hsc_env plugins ds_result++    {- Tidy -}+    (tidy_cg, mod_details) <- liftIO $ hscTidy hsc_env simpl_mg++    let !CgGuts{ cg_module    = this_mod,+                 cg_binds     = core_binds,+                 cg_tycons    = tycons,+                 cg_modBreaks = mod_breaks } = tidy_cg++        !ModDetails { md_insts     = cls_insts+                    , md_fam_insts = fam_insts } = mod_details+            -- Get the *tidied* cls_insts and fam_insts++        data_tycons = filter isDataTyCon tycons++    {- Prepare For Code Generation -}+    -- Do saturation and convert to A-normal form+    prepd_binds <- {-# SCC "CorePrep" #-}+      liftIO $ corePrepPgm hsc_env this_mod iNTERACTIVELoc core_binds data_tycons++    (stg_binds, _infotable_prov, _caf_ccs__caf_cc_stacks)+        <- {-# SCC "CoreToStg" #-}+           liftIO $ myCoreToStg (hsc_logger hsc_env)+                                (hsc_dflags hsc_env)+                                (hsc_IC hsc_env)+                                True+                                this_mod+                                iNTERACTIVELoc+                                prepd_binds++    {- Generate byte code -}+    cbc <- liftIO $ byteCodeGen hsc_env this_mod+                                stg_binds data_tycons mod_breaks++    let src_span = srcLocSpan interactiveSrcLoc+    _ <- liftIO $ loadDecls interp hsc_env src_span cbc++    {- Load static pointer table entries -}+    liftIO $ hscAddSptEntries hsc_env (cg_spt_entries tidy_cg)++    let tcs = filterOut isImplicitTyCon (mg_tcs simpl_mg)+        patsyns = mg_patsyns simpl_mg++        ext_ids = [ id | id <- bindersOfBinds core_binds+                       , isExternalName (idName id)+                       , not (isDFunId id || isImplicitId id) ]+            -- We only need to keep around the external bindings+            -- (as decided by GHC.Iface.Tidy), since those are the only ones+            -- that might later be looked up by name.  But we can exclude+            --    - DFunIds, which are in 'cls_insts' (see Note [ic_tythings] in GHC.Runtime.Context+            --    - Implicit Ids, which are implicit in tcs+            -- c.f. GHC.Tc.Module.runTcInteractive, which reconstructs the TypeEnv++        new_tythings = map AnId ext_ids ++ map ATyCon tcs ++ map (AConLike . PatSynCon) patsyns+        ictxt        = hsc_IC hsc_env+        -- See Note [Fixity declarations in GHCi]+        fix_env      = tcg_fix_env tc_gblenv+        new_ictxt    = extendInteractiveContext ictxt new_tythings cls_insts+                                                fam_insts defaults fix_env+    return (new_tythings, new_ictxt)++-- | Load the given static-pointer table entries into the interpreter.+-- See Note [Grand plan for static forms] in "GHC.Iface.Tidy.StaticPtrTable".+hscAddSptEntries :: HscEnv -> [SptEntry] -> IO ()+hscAddSptEntries hsc_env entries = do+    let interp = hscInterp hsc_env+    let add_spt_entry :: SptEntry -> IO ()+        add_spt_entry (SptEntry i fpr) = do+            -- These are only names from the current module+            (val, _, _) <- loadName interp hsc_env (idName i)+            addSptEntry interp fpr val+    mapM_ add_spt_entry entries++{-+  Note [Fixity declarations in GHCi]+  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+  To support fixity declarations on types defined within GHCi (as requested+  in #10018) we record the fixity environment in InteractiveContext.+  When we want to evaluate something GHC.Tc.Module.runTcInteractive pulls out this+  fixity environment and uses it to initialize the global typechecker environment.+  After the typechecker has finished its business, an updated fixity environment+  (reflecting whatever fixity declarations were present in the statements we+  passed it) will be returned from hscParsedStmt. This is passed to+  updateFixityEnv, which will stuff it back into InteractiveContext, to be+  used in evaluating the next statement.++-}++hscImport :: HscEnv -> String -> IO (ImportDecl GhcPs)+hscImport hsc_env str = runInteractiveHsc hsc_env $ do+    (L _ (HsModule{hsmodImports=is})) <-+       hscParseThing parseModule str+    case is of+        [L _ i] -> return i+        _ -> liftIO $ throwOneError $+                 mkPlainErrorMsgEnvelope noSrcSpan $+                 GhcPsMessage $ PsUnknownMessage $ 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 $ 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 print_unqual   = mkPrintUnqualified (hsc_unit_env hsc_env) (mg_rdr_env guts)++  endPassIO hsc_env print_unqual CoreTidy all_tidy_binds tidy_rules++  -- If the endPass didn't print the rules, but ddump-rules is+  -- on, print now+  unless (logHasDumpFlag logger Opt_D_dump_simpl) $+    putDumpFileMaybe logger Opt_D_dump_rules+      (renderWithContext defaultSDocContext (ppr CoreTidy <+> text "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.+           simpl_expr <- simplifyExpr hsc_env ds_expr++           {- Tidy it (temporary, until coreSat does cloning) -}+         ; let tidy_expr = tidyExpr emptyTidyEnv simpl_expr++           {- Prepare for codegen -}+         ; prepd_expr <- corePrepExpr hsc_env tidy_expr++           {- Lint if necessary -}+         ; lintInteractiveExpr (text "hscCompileExpr") hsc_env prepd_expr+         ; let iNTERACTIVELoc = ModLocation{ ml_hs_file   = Nothing,+                                      ml_hi_file   = panic "hscCompileCoreExpr':ml_hi_file",+                                      ml_obj_file  = panic "hscCompileCoreExpr':ml_obj_file",+                                      ml_dyn_obj_file = panic "hscCompileCoreExpr': ml_obj_file",+                                      ml_dyn_hi_file  = panic "hscCompileCoreExpr': ml_dyn_hi_file",+                                      ml_hie_file  = panic "hscCompileCoreExpr':ml_hie_file" }++         ; let ictxt = hsc_IC hsc_env+         ; (binding_id, stg_expr, _, _) <-+             myCoreToStgExpr (hsc_logger hsc_env)+                             (hsc_dflags hsc_env)+                             ictxt+                             True+                             (icInteractiveModule ictxt)+                             iNTERACTIVELoc+                             prepd_expr++           {- Convert to BCOs -}+         ; bcos <- byteCodeGen hsc_env+                     (icInteractiveModule ictxt)+                     stg_expr+                     [] Nothing++           {- load it -}+         ; (fv_hvs, mods_needed, units_needed) <- loadDecls (hscInterp hsc_env) hsc_env srcspan bcos+           {- Get the HValue for the root -}+         ; return (expectJust "hscCompileCoreExpr'"+              $ lookup (idName binding_id) fv_hvs, mods_needed, units_needed) }+++{- **********************************************************************+%*                                                                      *+        Statistics on reading interfaces+%*                                                                      *+%********************************************************************* -}++dumpIfaceStats :: HscEnv -> IO ()+dumpIfaceStats hsc_env = do+  eps <- hscEPS hsc_env+  let+    logger = hsc_logger hsc_env+    dump_rn_stats = logHasDumpFlag logger Opt_D_dump_rn_stats+    dump_if_trace = logHasDumpFlag logger Opt_D_dump_if_trace+  when (dump_if_trace || dump_rn_stats) $+    logDumpMsg logger "Interface statistics" (ifaceStats eps)+++{- **********************************************************************+%*                                                                      *+        Progress Messages: Module i of n+%*                                                                      *+%********************************************************************* -}++showModuleIndex :: (Int, Int) -> SDoc+showModuleIndex (i,n) = text "[" <> pad <> int i <> text " of " <> int n <> text "] "+  where+    -- compute the length of x > 0 in base 10+    len x = ceiling (logBase 10 (fromIntegral x+1) :: Float)+    pad = text (replicate (len n - len i) ' ') -- TODO: use GHC.Utils.Ppr.RStr++writeInterfaceOnlyMode :: DynFlags -> Bool+writeInterfaceOnlyMode dflags =+ gopt Opt_WriteInterface dflags &&+ NoBackend == backend dflags
GHC/Driver/Make.hs view
@@ -1,2928 +1,2736 @@ {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE NondecreasingIndentation #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}---- ----------------------------------------------------------------------------------- (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, load', LoadHowMuch(..),-        instantiationNodes,--        downsweep,--        topSortModuleGraph,--        ms_home_srcimps, ms_home_imps,--        summariseModule,-        hscSourceToIsBoot,-        findExtraSigImports,-        implicitRequirementsShallow,--        noModError, cyclicModuleErr,-        moduleGraphNodes, SummaryNode,-        IsBootInterface(..),--        ModNodeMap(..), emptyModNodeMap, modNodeMapElems, modNodeMapLookup, modNodeMapInsert-    ) where--#include "HsVersions.h"--import GHC.Prelude--import GHC.Tc.Utils.Backpack-import GHC.Tc.Utils.Monad  ( initIfaceCheck )--import GHC.Runtime.Interpreter-import qualified GHC.Linker.Loader as Linker-import GHC.Linker.Types--import GHC.Runtime.Context--import GHC.Driver.Config-import GHC.Driver.Phases-import GHC.Driver.Pipeline-import GHC.Driver.Session-import GHC.Driver.Backend-import GHC.Driver.Monad-import GHC.Driver.Env-import GHC.Driver.Errors-import GHC.Driver.Main--import GHC.Parser.Header-import GHC.Parser.Errors.Ppr--import GHC.Iface.Load      ( cannotFindModule )-import GHC.IfaceToCore     ( typecheckIface )-import GHC.Iface.Recomp    ( RecompileRequired ( MustCompile ) )--import GHC.Data.Bag        ( unitBag, listToBag, unionManyBags, isEmptyBag )-import GHC.Data.Graph.Directed-import GHC.Data.FastString-import GHC.Data.Maybe      ( expectJust )-import GHC.Data.StringBuffer-import qualified GHC.LanguageExtensions as LangExt--import GHC.Utils.Exception ( tryIO )-import GHC.Utils.Monad     ( allM )-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.Target-import GHC.Types.SourceFile-import GHC.Types.SourceError-import GHC.Types.SrcLoc-import GHC.Types.Unique.DSet-import GHC.Types.Unique.Set-import GHC.Types.Name-import GHC.Types.Name.Env--import GHC.Unit-import GHC.Unit.State-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 Data.Either ( rights, partitionEithers )-import qualified Data.Map as Map-import Data.Map (Map)-import qualified Data.Set as Set-import qualified GHC.Data.FiniteMap as Map ( insertListWith )--import Control.Concurrent ( forkIOWithUnmask, killThread )-import qualified GHC.Conc as CC-import Control.Concurrent.MVar-import Control.Concurrent.QSem-import Control.Exception-import Control.Monad-import Control.Monad.Trans.Except ( ExceptT(..), runExceptT, throwE )-import qualified Control.Monad.Catch as MC-import Data.IORef-import Data.List (nub, sortBy, partition)-import qualified Data.List as List-import Data.Foldable (toList)-import Data.Maybe-import Data.Ord ( comparing )-import Data.Time-import Data.Bifunctor (first)-import System.Directory-import System.FilePath-import System.IO        ( fixIO )-import System.IO.Error  ( isDoesNotExistError )--import GHC.Conc ( getNumProcessors, getNumCapabilities, setNumCapabilities )--label_self :: String -> IO ()-label_self thread_name = do-    self_tid <- CC.myThreadId-    CC.labelThread self_tid thread_name---- -------------------------------------------------------------------------------- Loading the program---- | Perform a dependency analysis starting from the current targets--- and update the session with the new module graph.------ Dependency analysis entails parsing the @import@ directives and may--- therefore require running certain preprocessors.------ Note that each 'ModSummary' in the module graph caches its 'DynFlags'.--- These 'DynFlags' are determined by the /current/ session 'DynFlags' and the--- @OPTIONS@ and @LANGUAGE@ pragmas of the parsed module.  Thus if you want--- changes to the 'DynFlags' to take effect you need to call this function--- again.--- In case of errors, just throw them.----depanal :: GhcMonad m =>-           [ModuleName]  -- ^ excluded modules-        -> Bool          -- ^ allow duplicate roots-        -> m ModuleGraph-depanal excluded_mods allow_dup_roots = do-    (errs, mod_graph) <- depanalE excluded_mods allow_dup_roots-    if isEmptyBag errs-      then pure mod_graph-      else throwErrors errs---- | Perform dependency analysis like in 'depanal'.--- In case of errors, the errors and an empty module graph are returned.-depanalE :: GhcMonad m =>     -- New for #17459-            [ModuleName]      -- ^ excluded modules-            -> Bool           -- ^ allow duplicate roots-            -> m (ErrorMessages, ModuleGraph)-depanalE excluded_mods allow_dup_roots = do-    hsc_env <- getSession-    (errs, mod_graph) <- depanalPartial excluded_mods allow_dup_roots-    if isEmptyBag errs-      then do-        let unused_home_mod_err = warnMissingHomeModules hsc_env mod_graph-            unused_pkg_err = warnUnusedPackages hsc_env mod_graph-            warns = unused_home_mod_err ++ unused_pkg_err-        when (not $ null warns) $-          logWarnings (listToBag warns)-        setSession hsc_env { hsc_mod_graph = mod_graph }-        pure (errs, mod_graph)-      else do-        -- We don't have a complete module dependency graph,-        -- The graph may be disconnected and is unusable.-        setSession hsc_env { hsc_mod_graph = emptyMG }-        pure (errs, emptyMG)----- | Perform dependency analysis like 'depanal' but return a partial module--- graph even in the face of problems with some modules.------ Modules which have parse errors in the module header, failing--- preprocessors or other issues preventing them from being summarised will--- simply be absent from the returned module graph.------ Unlike 'depanal' this function will not update 'hsc_mod_graph' with the--- new module graph.-depanalPartial-    :: GhcMonad m-    => [ModuleName]  -- ^ excluded modules-    -> Bool          -- ^ allow duplicate roots-    -> m (ErrorMessages, ModuleGraph)-    -- ^ possibly empty 'Bag' of errors and a module graph.-depanalPartial excluded_mods allow_dup_roots = do-  hsc_env <- getSession-  let-         dflags  = hsc_dflags hsc_env-         targets = hsc_targets hsc_env-         old_graph = hsc_mod_graph hsc_env-         logger  = hsc_logger hsc_env--  withTiming logger dflags (text "Chasing dependencies") (const ()) $ do-    liftIO $ debugTraceMsg logger dflags 2 (hcat [-              text "Chasing modules from: ",-              hcat (punctuate comma (map pprTarget targets))])--    -- Home package modules may have been moved or deleted, and new-    -- source files may have appeared in the home package that shadow-    -- external package modules, so we have to discard the existing-    -- cached finder data.-    liftIO $ flushFinderCaches hsc_env--    mod_summariesE <- liftIO $ downsweep-      hsc_env (mgExtendedModSummaries old_graph)-      excluded_mods allow_dup_roots-    let-      (errs, mod_summaries) = partitionEithers mod_summariesE-      mod_graph = mkModuleGraph' $-        fmap ModuleNode mod_summaries ++ instantiationNodes (hsc_units hsc_env)-    return (unionManyBags errs, mod_graph)---- | Collect the instantiations of dependencies to create 'InstantiationNode' work graph nodes.--- These are used to represent the type checking that is done after--- all the free holes (sigs in current package) relevant to that instantiation--- are compiled. This is necessary to catch some instantiation errors.------ In the future, perhaps more of the work of instantiation could be moved here,--- instead of shoved in with the module compilation nodes. That could simplify--- backpack, and maybe hs-boot too.-instantiationNodes :: UnitState -> [ModuleGraphNode]-instantiationNodes unit_state = InstantiationNode <$> iuids_to_check-  where-    iuids_to_check :: [InstantiatedUnit]-    iuids_to_check =-      nubSort $ concatMap goUnitId (explicitUnits unit_state)-     where-      goUnitId uid =-        [ recur-        | VirtUnit indef <- [uid]-        , inst <- instUnitInsts indef-        , recur <- (indef :) $ goUnitId $ moduleUnit $ snd inst-        ]---- Note [Missing home modules]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- Sometimes user doesn't want GHC to pick up modules, not explicitly listed--- in a command line. For example, cabal may want to enable this warning--- when building a library, so that GHC warns user about modules, not listed--- neither in `exposed-modules`, nor in `other-modules`.------ Here "home module" means a module, that doesn't come from an other package.------ For example, if GHC is invoked with modules "A" and "B" as targets,--- but "A" imports some other module "C", then GHC will issue a warning--- about module "C" not being listed in a command line.------ The warning in enabled by `-Wmissing-home-modules`. See #13129-warnMissingHomeModules :: HscEnv -> ModuleGraph -> [MsgEnvelope DecoratedSDoc]-warnMissingHomeModules hsc_env mod_graph =-    if (wopt Opt_WarnMissingHomeModules dflags && not (null missing))-    then [warn]-    else []-  where-    dflags = hsc_dflags hsc_env-    targets = map targetId (hsc_targets hsc_env)--    is_known_module mod = any (is_my_target mod) targets--    -- We need to be careful to handle the case where (possibly-    -- path-qualified) filenames (aka 'TargetFile') rather than module-    -- names are being passed on the GHC command-line.-    ---    -- For instance, `ghc --make src-exe/Main.hs` and-    -- `ghc --make -isrc-exe Main` are supposed to be equivalent.-    -- Note also that we can't always infer the associated module name-    -- directly from the filename argument.  See #13727.-    is_my_target mod (TargetModule name)-      = moduleName (ms_mod mod) == name-    is_my_target mod (TargetFile target_file _)-      | Just mod_file <- ml_hs_file (ms_location mod)-      = target_file == mod_file ||--           --  Don't warn on B.hs-boot if B.hs is specified (#16551)-           addBootSuffix target_file == mod_file ||--           --  We can get a file target even if a module name was-           --  originally specified in a command line because it can-           --  be converted in guessTarget (by appending .hs/.lhs).-           --  So let's convert it back and compare with module name-           mkModuleName (fst $ splitExtension target_file)-            == moduleName (ms_mod mod)-    is_my_target _ _ = False--    missing = map (moduleName . ms_mod) $-      filter (not . is_known_module) (mgModSummaries mod_graph)--    msg-      | gopt Opt_BuildingCabalPackage dflags-      = hang-          (text "These modules are needed for compilation but not listed in your .cabal file's other-modules: ")-          4-          (sep (map ppr missing))-      | otherwise-      =-        hang-          (text "Modules are not listed in command line but needed for compilation: ")-          4-          (sep (map ppr missing))-    warn = makeIntoWarning-      (Reason Opt_WarnMissingHomeModules)-      (mkPlainMsgEnvelope noSrcSpan msg)---- | Describes which modules of the module graph need to be loaded.-data LoadHowMuch-   = LoadAllTargets-     -- ^ Load all targets and its dependencies.-   | LoadUpTo ModuleName-     -- ^ Load only the given module and its dependencies.-   | LoadDependenciesOf ModuleName-     -- ^ Load only the dependencies of the given module, but not the module-     -- itself.---- | Try to load the program.  See 'LoadHowMuch' for the different modes.------ This function implements the core of GHC's @--make@ mode.  It preprocesses,--- compiles and loads the specified modules, avoiding re-compilation wherever--- possible.  Depending on the 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 m => LoadHowMuch -> m SuccessFlag-load how_much = do-    (errs, mod_graph) <- depanalE [] False                        -- #17459-    success <- load' how_much (Just batchMsg) mod_graph-    if isEmptyBag errs-      then pure success-      else throwErrors 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 :: HscEnv -> ModuleGraph -> [MsgEnvelope DecoratedSDoc]-warnUnusedPackages hsc_env mod_graph =-    let dflags = hsc_dflags hsc_env-        state  = hsc_units hsc_env--    -- Only need non-source imports here because SOURCE imports are always HPT-        loadedPackages = concat $-          mapMaybe (\(fs, mn) -> lookupModulePackage state (unLoc mn) fs)-            $ concatMap ms_imps (mgModSummaries mod_graph)--        requestedArgs = mapMaybe packageArg (packageFlags dflags)--        unusedArgs-          = filter (\arg -> not $ any (matching state arg) loadedPackages)-                   requestedArgs--        warn = makeIntoWarning-          (Reason Opt_WarnUnusedPackages)-          (mkPlainMsgEnvelope noSrcSpan msg)-        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 . pprUnusedArg) unusedArgs)) ]--    in if not (null unusedArgs) && wopt Opt_WarnUnusedPackages dflags-       then [warn]-       else []--    where-        packageArg (ExposePackage _ arg _) = Just arg-        packageArg _ = Nothing--        pprUnusedArg (PackageArg str) = text str-        pprUnusedArg (UnitIdArg uid) = ppr uid--        withDash = (<+>) (text "-")--        matchingStr :: String -> UnitInfo -> Bool-        matchingStr str p-                =  str == unitPackageIdString p-                || str == unitPackageNameString p--        matching :: UnitState -> PackageArg -> UnitInfo -> Bool-        matching _ (PackageArg str) p = matchingStr str p-        matching state (UnitIdArg uid) p = uid == realUnit state p--        -- For wired-in packages, we have to unwire their id,-        -- otherwise they won't match package flags-        realUnit :: UnitState -> UnitInfo -> Unit-        realUnit state-          = unwireUnit state-          . RealUnit-          . Definite-          . unitId---- | Generalized version of 'load' which also supports a custom--- 'Messager' (for reporting progress) and 'ModuleGraph' (generally--- produced by calling 'depanal'.-load' :: GhcMonad m => LoadHowMuch -> Maybe Messager -> ModuleGraph -> m SuccessFlag-load' how_much mHscMessage mod_graph = do-    modifySession $ \hsc_env -> hsc_env { hsc_mod_graph = mod_graph }-    guessOutputFile-    hsc_env <- getSession--    let hpt1   = hsc_HPT hsc_env-    let dflags = hsc_dflags hsc_env-    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 =-          mkUniqSet [ ms_mod_name s-                    | s <- mgModSummaries mod_graph, isBootSummary s == NotBoot]-    -- TODO: Figure out what the correct form of this assert is. It's violated-    -- when you have HsBootMerge nodes in the graph: then you'll have hs-boot-    -- files without corresponding hs files.-    --  bad_boot_mods = [s        | s <- mod_graph, isBootSummary s,-    --                              not (ms_mod_name s `elem` all_home_mods)]-    -- ASSERT( null bad_boot_mods ) return ()--    -- check that the module given in HowMuch actually exists, otherwise-    -- topSortModuleGraph will bomb later.-    let checkHowMuch (LoadUpTo m)           = checkMod m-        checkHowMuch (LoadDependenciesOf m) = checkMod m-        checkHowMuch _ = id--        checkMod m and_then-            | m `elementOfUniqSet` all_home_mods = and_then-            | otherwise = do-                    liftIO $ errorMsg logger dflags-                        (text "no such module:" <+> quotes (ppr m))-                    return Failed--    checkHowMuch how_much $ do--    -- mg2_with_srcimps drops the hi-boot nodes, returning a-    -- graph with cycles.  Among other things, it is used for-    -- backing out partially complete cycles following a failed-    -- upsweep, and for removing from hpt all the modules-    -- not in strict downwards closure, during calls to compile.-    let mg2_with_srcimps :: [SCC ModSummary]-        mg2_with_srcimps = filterToposortToModules $-          topSortModuleGraph True mod_graph Nothing--    -- If we can determine that any of the {-# SOURCE #-} imports-    -- are definitely unnecessary, then emit a warning.-    warnUnnecessarySourceImports mg2_with_srcimps--    let-        -- check the stability property for each module.-        stable_mods@(stable_obj,stable_bco)-            = checkStability hpt1 mg2_with_srcimps all_home_mods--        pruned_hpt = hpt1--    _ <- liftIO $ evaluate pruned_hpt--    -- before we unload anything, make sure we don't leave an old-    -- interactive context around pointing to dead bindings.  Also,-    -- write the pruned HPT to allow the old HPT to be GC'd.-    setSession $ discardIC $ hsc_env { hsc_HPT = pruned_hpt }--    liftIO $ debugTraceMsg logger dflags 2 (text "Stable obj:" <+> ppr stable_obj $$-                            text "Stable BCO:" <+> ppr stable_bco)--    -- Unload any modules which are going to be re-linked this time around.-    let stable_linkables = [ linkable-                           | m <- nonDetEltsUniqSet stable_obj ++-                                  nonDetEltsUniqSet stable_bco,-                             -- It's OK to use nonDetEltsUniqSet here-                             -- because it only affects linking. Besides-                             -- this list only serves as a poor man's set.-                             Just hmi <- [lookupHpt pruned_hpt m],-                             Just linkable <- [hm_linkable hmi] ]-    liftIO $ unload interp hsc_env stable_linkables--    -- We could at this point detect cycles which aren't broken by-    -- a source-import, and complain immediately, but it seems better-    -- to let upsweep_mods do this, so at least some useful work gets-    -- done before the upsweep is abandoned.-    --hPutStrLn stderr "after tsort:\n"-    --hPutStrLn stderr (showSDoc (vcat (map ppr mg2)))--    -- Now do the upsweep, calling compile for each module in-    -- turn.  Final result is version 3 of everything.--    -- Topologically sort the module graph, this time including hi-boot-    -- nodes, and possibly just including the portion of the graph-    -- reachable from the module specified in the 2nd argument to load.-    -- This graph should be cycle-free.-    -- If we're restricting the upsweep to a portion of the graph, we-    -- also want to retain everything that is still stable.-    let full_mg, partial_mg0, partial_mg, unstable_mg :: [SCC ModuleGraphNode]-        stable_mg :: [SCC ExtendedModSummary]-        full_mg    = topSortModuleGraph False mod_graph Nothing--        maybe_top_mod = case how_much of-                            LoadUpTo m           -> Just m-                            LoadDependenciesOf m -> Just m-                            _                    -> Nothing--        partial_mg0 = topSortModuleGraph False mod_graph maybe_top_mod--        -- LoadDependenciesOf m: we want the upsweep to stop just-        -- short of the specified module (unless the specified module-        -- is stable).-        partial_mg-            | LoadDependenciesOf _mod <- how_much-            = ASSERT( case last partial_mg0 of-                        AcyclicSCC (ModuleNode (ExtendedModSummary ms _)) -> ms_mod_name ms == _mod; _ -> False )-              List.init partial_mg0-            | otherwise-            = partial_mg0--        stable_mg =-            [ AcyclicSCC ems-            | AcyclicSCC (ModuleNode ems@(ExtendedModSummary ms _)) <- full_mg-            , stable_mod_summary ms-            ]--        stable_mod_summary ms =-          ms_mod_name ms `elementOfUniqSet` stable_obj ||-          ms_mod_name ms `elementOfUniqSet` stable_bco--        -- the modules from partial_mg that are not also stable-        -- NB. also keep cycles, we need to emit an error message later-        unstable_mg = filter not_stable partial_mg-          where not_stable (CyclicSCC _) = True-                not_stable (AcyclicSCC (InstantiationNode _)) = True-                not_stable (AcyclicSCC (ModuleNode (ExtendedModSummary ms _)))-                   = not $ stable_mod_summary ms--        -- Load all the stable modules first, before attempting to load-        -- an unstable module (#7231).-        mg = fmap (fmap ModuleNode) stable_mg ++ unstable_mg--    liftIO $ debugTraceMsg logger dflags 2 (hang (text "Ready for upsweep")-                               2 (ppr mg))--    n_jobs <- case parMakeCount dflags of-                    Nothing -> liftIO getNumProcessors-                    Just n  -> return n-    let upsweep_fn | n_jobs > 1 = parUpsweep n_jobs-                   | otherwise  = upsweep--    setSession hsc_env{ hsc_HPT = emptyHomePackageTable }-    (upsweep_ok, modsUpswept) <- withDeferredDiagnostics $-      upsweep_fn mHscMessage pruned_hpt stable_mods mg--    -- Make modsDone be the summaries for each home module now-    -- available; this should equal the domain of hpt3.-    -- Get in in a roughly top .. bottom order (hence reverse).--    let nodesDone = reverse modsUpswept-        (_, modsDone) = partitionNodes nodesDone--    -- Try and do linking in some form, depending on whether the-    -- upsweep was completely or only partially successful.--    if succeeded upsweep_ok--     then-       -- Easy; just relink it all.-       do liftIO $ debugTraceMsg logger dflags 2 (text "Upsweep completely successful.")--          -- Clean up after ourselves-          hsc_env1 <- getSession-          liftIO $ cleanCurrentModuleTempFiles logger (hsc_tmpfs hsc_env1) dflags--          -- Issue a warning for the confusing case where the user-          -- said '-o foo' but we're not going to do any linking.-          -- We attempt linking if either (a) one of the modules is-          -- called Main, or (b) the user said -no-hs-main, indicating-          -- that main() is going to come from somewhere else.-          ---          let ofile = outputFile dflags-          let no_hs_main = gopt Opt_NoHsMain dflags-          let-            main_mod = mainModIs hsc_env-            a_root_is_Main = mgElemModule mod_graph main_mod-            do_linking = a_root_is_Main || no_hs_main || ghcLink dflags == LinkDynLib || ghcLink dflags == LinkStaticLib--          -- link everything together-          hsc_env <- getSession-          linkresult <- liftIO $ link (ghcLink dflags)-                                      logger-                                      (hsc_tmpfs hsc_env)-                                      (hsc_hooks hsc_env)-                                      dflags-                                      (hsc_unit_env hsc_env)-                                      do_linking-                                      (hsc_HPT hsc_env1)--          if ghcLink dflags == LinkBinary && isJust ofile && not do_linking-             then do-                liftIO $ errorMsg logger dflags $ text-                   ("output was redirected with -o, " ++-                    "but no output will be generated\n" ++-                    "because there is no " ++-                    moduleNameString (moduleName main_mod) ++ " module.")-                -- This should be an error, not a warning (#10895).-                loadFinish Failed linkresult-             else-                loadFinish Succeeded linkresult--     else-       -- Tricky.  We need to back out the effects of compiling any-       -- half-done cycles, both so as to clean up the top level envs-       -- and to avoid telling the interactive linker to link them.-       do liftIO $ debugTraceMsg logger dflags 2 (text "Upsweep partially successful.")--          let modsDone_names-                 = map (ms_mod . emsModSummary) modsDone-          let mods_to_zap_names-                 = findPartiallyCompletedCycles modsDone_names-                      mg2_with_srcimps-          let (mods_to_clean, mods_to_keep) =-                partition ((`Set.member` mods_to_zap_names).ms_mod) $-                emsModSummary <$> modsDone-          hsc_env1 <- getSession-          let hpt4 = hsc_HPT hsc_env1-              -- We must change the lifetime to TFL_CurrentModule for any temp-              -- file created for an element of mod_to_clean during the upsweep.-              -- These include preprocessed files and object files for loaded-              -- modules.-              unneeded_temps = concat-                [ms_hspp_file : object_files-                | ModSummary{ms_mod, ms_hspp_file} <- mods_to_clean-                , let object_files = maybe [] linkableObjs $-                        lookupHpt hpt4 (moduleName ms_mod)-                        >>= hm_linkable-                ]-          tmpfs <- hsc_tmpfs <$> getSession-          liftIO $ changeTempFilesLifetime tmpfs TFL_CurrentModule unneeded_temps-          liftIO $ cleanCurrentModuleTempFiles logger tmpfs dflags--          let hpt5 = retainInTopLevelEnvs (map ms_mod_name mods_to_keep)-                                          hpt4--          -- Clean up after ourselves--          -- there should be no Nothings where linkables should be, now-          let just_linkables =-                    isNoLink (ghcLink dflags)-                 || allHpt (isJust.hm_linkable)-                        (filterHpt ((== HsSrcFile).mi_hsc_src.hm_iface)-                                hpt5)-          ASSERT( just_linkables ) do--          -- Link everything together-          hsc_env <- getSession-          linkresult <- liftIO $ link (ghcLink dflags)-                                      logger-                                      (hsc_tmpfs hsc_env)-                                      (hsc_hooks hsc_env)-                                      dflags-                                      (hsc_unit_env hsc_env)-                                      False-                                      hpt5--          modifySession $ \hsc_env -> hsc_env{ hsc_HPT = hpt5 }-          loadFinish Failed linkresult--partitionNodes-  :: [ModuleGraphNode]-  -> ( [InstantiatedUnit]-     , [ExtendedModSummary]-     )-partitionNodes ns = partitionEithers $ flip fmap ns $ \case-  InstantiationNode x -> Left x-  ModuleNode x -> Right x---- | Finish up after a load.-loadFinish :: GhcMonad m => SuccessFlag -> SuccessFlag -> m SuccessFlag---- If the link failed, unload everything and return.-loadFinish _all_ok Failed-  = do hsc_env <- getSession-       let interp = hscInterp hsc_env-       liftIO $ unload interp hsc_env []-       modifySession discardProg-       return Failed---- Empty the interactive context and set the module context to the topmost--- newly loaded module, or the Prelude if none were loaded.-loadFinish all_ok Succeeded-  = do modifySession discardIC-       return all_ok----- | Forget the current program, but retain the persistent info in HscEnv-discardProg :: HscEnv -> HscEnv-discardProg hsc_env-  = discardIC $ hsc_env { hsc_mod_graph = emptyMG-                        , hsc_HPT = emptyHomePackageTable }---- | Discard the contents of the InteractiveContext, but keep the DynFlags 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---- | If there is no -o option, guess the name of target executable--- by using top-level source file name as a base.-guessOutputFile :: GhcMonad m => m ()-guessOutputFile = modifySession $ \env ->-    let dflags = hsc_dflags env-        -- Force mod_graph to avoid leaking env-        !mod_graph = hsc_mod_graph env-        mainModuleSrcPath :: Maybe String-        mainModuleSrcPath = do-            ms <- mgLookupModule mod_graph (mainModIs env)-            ml_hs_file (ms_location ms)-        name = fmap dropExtension mainModuleSrcPath--        name_exe = do-#if defined(mingw32_HOST_OS)-          -- we must add the .exe extension unconditionally here, otherwise-          -- when name has an extension of its own, the .exe extension will-          -- not be added by GHC.Driver.Pipeline.exeFileName.  See #2248-          name' <- fmap (<.> "exe") name-#else-          name' <- name-#endif-          mainModuleSrcPath' <- mainModuleSrcPath-          -- #9930: don't clobber input files (unless they ask for it)-          if name' == mainModuleSrcPath'-            then throwGhcException . UsageError $-                 "default output name would overwrite the input file; " ++-                 "must specify -o explicitly"-            else Just name'-    in-    case outputFile_ dflags of-        Just _ -> env-        Nothing -> env { hsc_dflags = dflags { outputFile_ = name_exe } }---- ----------------------------------------------------------------------------------- | Return (names of) all those in modsDone who are part of a cycle as defined--- by theGraph.-findPartiallyCompletedCycles :: [Module] -> [SCC ModSummary] -> Set.Set Module-findPartiallyCompletedCycles modsDone theGraph-   = Set.unions-       [mods_in_this_cycle-       | CyclicSCC vs <- theGraph  -- Acyclic? Not interesting.-       , let names_in_this_cycle = Set.fromList (map ms_mod vs)-             mods_in_this_cycle =-                    Set.intersection (Set.fromList modsDone) names_in_this_cycle-         -- If size mods_in_this_cycle == size names_in_this_cycle,-         -- then this cycle has already been completed and we're not-         -- interested.-       , Set.size mods_in_this_cycle < Set.size names_in_this_cycle]----- --------------------------------------------------------------------------------- | Unloading-unload :: Interp -> HscEnv -> [Linkable] -> IO ()-unload interp hsc_env stable_linkables -- Unload everything *except* 'stable_linkables'-  = case ghcLink (hsc_dflags hsc_env) of-        LinkInMemory -> Linker.unload interp hsc_env stable_linkables-        _other -> return ()---- ------------------------------------------------------------------------------{- |--  Stability tells us which modules definitely do not need to be recompiled.-  There are two main reasons for having stability:--   - avoid doing a complete upsweep of the module graph in GHCi when-     modules near the bottom of the tree have not changed.--   - to tell GHCi when it can load object code: we can only load object code-     for a module when we also load object code fo  all of the imports of the-     module.  So we need to know that we will definitely not be recompiling-     any of these modules, and we can use the object code.--  The stability check is as follows.  Both stableObject and-  stableBCO are used during the upsweep phase later.--@-  stable m = stableObject m || stableBCO m--  stableObject m =-        all stableObject (imports m)-        && old linkable does not exist, or is == on-disk .o-        && date(on-disk .o) > date(.hs)--  stableBCO m =-        all stable (imports m)-        && date(BCO) > date(.hs)-@--  These properties embody the following ideas:--    - if a module is stable, then:--        - if it has been compiled in a previous pass (present in HPT)-          then it does not need to be compiled or re-linked.--        - if it has not been compiled in a previous pass,-          then we only need to read its .hi file from disk and-          link it to produce a 'ModDetails'.--    - if a modules is not stable, we will definitely be at least-      re-linking, and possibly re-compiling it during the 'upsweep'.-      All non-stable modules can (and should) therefore be unlinked-      before the 'upsweep'.--    - Note that objects are only considered stable if they only depend-      on other objects.  We can't link object code against byte code.--    - Note that even if an object is stable, we may end up recompiling-      if the interface is out of date because an *external* interface-      has changed.  The current code in GHC.Driver.Make handles this case-      fairly poorly, so be careful.--}--type StableModules =-  ( UniqSet ModuleName  -- stableObject-  , UniqSet ModuleName  -- stableBCO-  )---checkStability-        :: HomePackageTable   -- HPT from last compilation-        -> [SCC ModSummary]   -- current module graph (cyclic)-        -> UniqSet ModuleName -- all home modules-        -> StableModules--checkStability hpt sccs all_home_mods =-  foldl' checkSCC (emptyUniqSet, emptyUniqSet) sccs-  where-   checkSCC :: StableModules -> SCC ModSummary -> StableModules-   checkSCC (stable_obj, stable_bco) scc0-     | stableObjects = (addListToUniqSet stable_obj scc_mods, stable_bco)-     | stableBCOs    = (stable_obj, addListToUniqSet stable_bco scc_mods)-     | otherwise     = (stable_obj, stable_bco)-     where-        scc = flattenSCC scc0-        scc_mods = map ms_mod_name scc-        home_module m =-          m `elementOfUniqSet` all_home_mods && m `notElem` scc_mods--        scc_allimps = nub (filter home_module (concatMap ms_home_allimps scc))-            -- all imports outside the current SCC, but in the home pkg--        stable_obj_imps = map (`elementOfUniqSet` stable_obj) scc_allimps-        stable_bco_imps = map (`elementOfUniqSet` stable_bco) scc_allimps--        stableObjects =-           and stable_obj_imps-           && all object_ok scc--        stableBCOs =-           and (zipWith (||) stable_obj_imps stable_bco_imps)-           && all bco_ok scc--        object_ok ms-          | gopt Opt_ForceRecomp (ms_hspp_opts ms) = False-          | Just t <- ms_obj_date ms  =  t >= ms_hs_date ms-                                         && same_as_prev t-          | otherwise = False-          where-             same_as_prev t = case lookupHpt hpt (ms_mod_name ms) of-                                Just hmi  | Just l <- hm_linkable hmi-                                 -> isObjectLinkable l && t == linkableTime l-                                _other  -> True-                -- why '>=' rather than '>' above?  If the filesystem stores-                -- times to the nearest second, we may occasionally find that-                -- the object & source have the same modification time,-                -- especially if the source was automatically generated-                -- and compiled.  Using >= is slightly unsafe, but it matches-                -- make's behaviour.-                ---                -- But see #5527, where someone ran into this and it caused-                -- a problem.--        bco_ok ms-          | gopt Opt_ForceRecomp (ms_hspp_opts ms) = False-          | otherwise = case lookupHpt hpt (ms_mod_name ms) of-                Just hmi  | Just l <- hm_linkable hmi ->-                        not (isObjectLinkable l) &&-                        linkableTime l >= ms_hs_date ms-                _other  -> False--{- Parallel Upsweep- -- - The parallel upsweep attempts to concurrently compile the modules in the- - compilation graph using multiple Haskell threads.- -- - The Algorithm- -- - A Haskell thread is spawned for each module in the module graph, waiting for- - its direct dependencies to finish building before it itself begins to build.- -- - Each module is associated with an initially empty MVar that stores the- - result of that particular module's compile. If the compile succeeded, then- - the HscEnv (synchronized by an MVar) is updated with the fresh HMI of that- - module, and the module's HMI is deleted from the old HPT (synchronized by an- - IORef) to save space.- -- - Instead of immediately outputting messages to the standard handles, all- - compilation output is deferred to a per-module TQueue. A QSem is used to- - limit the number of workers that are compiling simultaneously.- -- - Meanwhile, the main thread sequentially loops over all the modules in the- - module graph, outputting the messages stored in each module's TQueue.--}---- | Each module is given a unique 'LogQueue' to redirect compilation messages--- to. A 'Nothing' value contains the result of compilation, and denotes the--- end of the message queue.-data LogQueue = LogQueue !(IORef [Maybe (WarnReason, Severity, SrcSpan, SDoc)])-                         !(MVar ())---- | The graph of modules to compile and their corresponding result 'MVar' and--- 'LogQueue'.-type CompilationGraph = [(ModuleGraphNode, MVar SuccessFlag, LogQueue)]---- | Build a 'CompilationGraph' out of a list of strongly-connected modules,--- also returning the first, if any, encountered module cycle.-buildCompGraph :: [SCC ModuleGraphNode] -> IO (CompilationGraph, Maybe [ModuleGraphNode])-buildCompGraph [] = return ([], Nothing)-buildCompGraph (scc:sccs) = case scc of-    AcyclicSCC ms -> do-        mvar <- newEmptyMVar-        log_queue <- do-            ref <- newIORef []-            sem <- newEmptyMVar-            return (LogQueue ref sem)-        (rest,cycle) <- buildCompGraph sccs-        return ((ms,mvar,log_queue):rest, cycle)-    CyclicSCC mss -> return ([], Just mss)---- | A Module and whether it is a boot module.------ We need to treat boot modules specially when building compilation graphs,--- since they break cycles. Regular source files and signature files are treated--- equivalently.-data BuildModule = BuildModule_Unit {-# UNPACK #-} !InstantiatedUnit | BuildModule_Module {-# UNPACK #-} !ModuleWithIsBoot-  deriving (Eq, Ord)---- | Tests if an 'HscSource' is a boot file, primarily for constructing elements--- of 'BuildModule'. We conflate signatures and modules because they are bound--- in the same namespace; only boot interfaces can be disambiguated with--- `import {-# SOURCE #-}`.-hscSourceToIsBoot :: HscSource -> IsBootInterface-hscSourceToIsBoot HsBootFile = IsBoot-hscSourceToIsBoot _ = NotBoot--mkBuildModule :: ModuleGraphNode -> BuildModule-mkBuildModule = \case-  InstantiationNode x -> BuildModule_Unit x-  ModuleNode ems -> BuildModule_Module $ mkBuildModule0 (emsModSummary ems)--mkHomeBuildModule :: ModuleGraphNode -> NodeKey-mkHomeBuildModule = \case-  InstantiationNode x -> NodeKey_Unit x-  ModuleNode ems -> NodeKey_Module $ mkHomeBuildModule0 (emsModSummary ems)--mkBuildModule0 :: ModSummary -> ModuleWithIsBoot-mkBuildModule0 ms = GWIB-  { gwib_mod = ms_mod ms-  , gwib_isBoot = isBootSummary ms-  }--mkHomeBuildModule0 :: ModSummary -> ModuleNameWithIsBoot-mkHomeBuildModule0 ms = GWIB-  { gwib_mod = moduleName $ ms_mod ms-  , gwib_isBoot = isBootSummary ms-  }---- | The entry point to the parallel upsweep.------ See also the simpler, sequential 'upsweep'.-parUpsweep-    :: GhcMonad m-    => Int-    -- ^ The number of workers we wish to run in parallel-    -> Maybe Messager-    -> HomePackageTable-    -> StableModules-    -> [SCC ModuleGraphNode]-    -> m (SuccessFlag,-          [ModuleGraphNode])-parUpsweep n_jobs mHscMessage old_hpt stable_mods sccs = do-    hsc_env <- getSession-    let dflags = hsc_dflags hsc_env-    let logger = hsc_logger hsc_env-    let tmpfs  = hsc_tmpfs hsc_env--    -- The bits of shared state we'll be using:--    -- The global HscEnv is updated with the module's HMI when a module-    -- successfully compiles.-    hsc_env_var <- liftIO $ newMVar hsc_env--    -- The old HPT is used for recompilation checking in upsweep_mod. When a-    -- module successfully gets compiled, its HMI is pruned from the old HPT.-    old_hpt_var <- liftIO $ newIORef old_hpt--    -- What we use to limit parallelism with.-    par_sem <- liftIO $ newQSem n_jobs---    let updNumCapabilities = liftIO $ do-            n_capabilities <- getNumCapabilities-            n_cpus <- getNumProcessors-            -- Setting number of capabilities more than-            -- CPU count usually leads to high userspace-            -- lock contention. #9221-            let n_caps = min n_jobs n_cpus-            unless (n_capabilities /= 1) $ setNumCapabilities n_caps-            return n_capabilities-    -- Reset the number of capabilities once the upsweep ends.-    let resetNumCapabilities orig_n = liftIO $ setNumCapabilities orig_n--    MC.bracket updNumCapabilities resetNumCapabilities $ \_ -> do--    -- Sync the global session with the latest HscEnv once the upsweep ends.-    let finallySyncSession io = io `MC.finally` do-            hsc_env <- liftIO $ readMVar hsc_env_var-            setSession hsc_env--    finallySyncSession $ do--    -- Build the compilation graph out of the list of SCCs. Module cycles are-    -- handled at the very end, after some useful work gets done. Note that-    -- this list is topologically sorted (by virtue of 'sccs' being sorted so).-    (comp_graph,cycle) <- liftIO $ buildCompGraph sccs-    let comp_graph_w_idx = zip comp_graph [1..]--    -- The list of all loops in the compilation graph.-    -- NB: For convenience, the last module of each loop (aka the module that-    -- finishes the loop) is prepended to the beginning of the loop.-    let graph = map fstOf3 (reverse comp_graph)-        boot_modules = mkModuleSet-          [ms_mod ms | ModuleNode (ExtendedModSummary ms _) <- graph, isBootSummary ms == IsBoot]-        comp_graph_loops = go graph boot_modules-          where-            remove ms bm = case isBootSummary ms of-              IsBoot -> delModuleSet bm (ms_mod ms)-              NotBoot -> bm-            go [] _ = []-            go (InstantiationNode _ : mss) boot_modules-              = go mss boot_modules-            go mg@(mnode@(ModuleNode (ExtendedModSummary ms _)) : mss) boot_modules-              | Just loop <- getModLoop ms mg (`elemModuleSet` boot_modules)-              = map mkBuildModule (mnode : loop) : go mss (remove ms boot_modules)-              | otherwise-              = go mss (remove ms boot_modules)--    -- Build a Map out of the compilation graph with which we can efficiently-    -- look up the result MVar associated with a particular home module.-    let home_mod_map :: Map BuildModule (MVar SuccessFlag, Int)-        home_mod_map =-            Map.fromList [ (mkBuildModule ms, (mvar, idx))-                         | ((ms,mvar,_),idx) <- comp_graph_w_idx ]---    liftIO $ label_self "main --make thread"--    -- Make the logger thread_safe: we only make the "log" action thread-safe in-    -- each worker by setting a LogAction hook, so we need to make the logger-    -- thread-safe for other actions (DumpAction, TraceAction).-    thread_safe_logger <- liftIO $ makeThreadSafe logger--    -- For each module in the module graph, spawn a worker thread that will-    -- compile this module.-    let { spawnWorkers = forM comp_graph_w_idx $ \((mod,!mvar,!log_queue),!mod_idx) ->-            forkIOWithUnmask $ \unmask -> do-                liftIO $ label_self $ unwords $ concat-                    [ [ "worker --make thread" ]-                    , case mod of-                        InstantiationNode iuid ->-                          [ "for instantiation of unit"-                          , show $ VirtUnit iuid-                          ]-                        ModuleNode ems ->-                          [ "for module"-                          , show (moduleNameString (ms_mod_name (emsModSummary ems)))-                          ]-                    , ["number"-                      , show mod_idx-                      ]-                    ]-                -- Replace the default log_action with one that writes each-                -- message to the module's log_queue. The main thread will-                -- deal with synchronously printing these messages.-                let lcl_logger = pushLogHook (const (parLogAction log_queue)) thread_safe_logger--                -- Use a local TmpFs so that we can clean up intermediate files-                -- in a timely fashion (as soon as compilation for that module-                -- is finished) without having to worry about accidentally-                -- deleting a simultaneous compile's important files.-                lcl_tmpfs <- forkTmpFsFrom tmpfs--                -- Unmask asynchronous exceptions and perform the thread-local-                -- work to compile the module (see parUpsweep_one).-                m_res <- MC.try $ unmask $ prettyPrintGhcErrors dflags $-                  case mod of-                    InstantiationNode iuid -> do-                      hsc_env <- readMVar hsc_env_var-                      liftIO $ upsweep_inst hsc_env mHscMessage mod_idx (length sccs) iuid-                      pure Succeeded-                    ModuleNode ems ->-                      parUpsweep_one (emsModSummary ems) home_mod_map comp_graph_loops-                                     lcl_logger lcl_tmpfs dflags (hsc_home_unit hsc_env)-                                     mHscMessage-                                     par_sem hsc_env_var old_hpt_var-                                     stable_mods mod_idx (length sccs)--                res <- case m_res of-                    Right flag -> return flag-                    Left exc -> do-                        -- Don't print ThreadKilled exceptions: they are used-                        -- to kill the worker thread in the event of a user-                        -- interrupt, and the user doesn't have to be informed-                        -- about that.-                        when (fromException exc /= Just ThreadKilled)-                             (errorMsg lcl_logger dflags (text (show exc)))-                        return Failed--                -- Populate the result MVar.-                putMVar mvar res--                -- Write the end marker to the message queue, telling the main-                -- thread that it can stop waiting for messages from this-                -- particular compile.-                writeLogQueue log_queue Nothing--                -- Add the remaining files that weren't cleaned up to the-                -- global TmpFs, for cleanup later.-                mergeTmpFsInto lcl_tmpfs tmpfs--        -- Kill all the workers, masking interrupts (since killThread is-        -- interruptible). XXX: This is not ideal.-        ; killWorkers = MC.uninterruptibleMask_ . mapM_ killThread }---    -- Spawn the workers, making sure to kill them later. Collect the results-    -- of each compile.-    results <- liftIO $ MC.bracket spawnWorkers killWorkers $ \_ ->-        -- Loop over each module in the compilation graph in order, printing-        -- each message from its log_queue.-        forM comp_graph $ \(mod,mvar,log_queue) -> do-            printLogs logger dflags log_queue-            result <- readMVar mvar-            if succeeded result then return (Just mod) else return Nothing---    -- Collect and return the ModSummaries of all the successful compiles.-    -- NB: Reverse this list to maintain output parity with the sequential upsweep.-    let ok_results = reverse (catMaybes results)--    -- Handle any cycle in the original compilation graph and return the result-    -- of the upsweep.-    case cycle of-        Just mss -> do-            liftIO $ fatalErrorMsg logger dflags (cyclicModuleErr mss)-            return (Failed,ok_results)-        Nothing  -> do-            let success_flag = successIf (all isJust results)-            return (success_flag,ok_results)--  where-    writeLogQueue :: LogQueue -> Maybe (WarnReason,Severity,SrcSpan,SDoc) -> IO ()-    writeLogQueue (LogQueue ref sem) msg = do-        atomicModifyIORef' ref $ \msgs -> (msg:msgs,())-        _ <- tryPutMVar sem ()-        return ()--    -- The log_action callback that is used to synchronize messages from a-    -- worker thread.-    parLogAction :: LogQueue -> LogAction-    parLogAction log_queue _dflags !reason !severity !srcSpan !msg =-        writeLogQueue log_queue (Just (reason,severity,srcSpan,msg))--    -- Print each message from the log_queue using the log_action from the-    -- session's DynFlags.-    printLogs :: Logger -> DynFlags -> LogQueue -> IO ()-    printLogs !logger !dflags (LogQueue ref sem) = read_msgs-      where read_msgs = do-                takeMVar sem-                msgs <- atomicModifyIORef' ref $ \xs -> ([], reverse xs)-                print_loop msgs--            print_loop [] = read_msgs-            print_loop (x:xs) = case x of-                Just (reason,severity,srcSpan,msg) -> do-                    putLogMsg logger dflags reason severity srcSpan msg-                    print_loop xs-                -- Exit the loop once we encounter the end marker.-                Nothing -> return ()---- The interruptible subset of the worker threads' work.-parUpsweep_one-    :: ModSummary-    -- ^ The module we wish to compile-    -> Map BuildModule (MVar SuccessFlag, Int)-    -- ^ The map of home modules and their result MVar-    -> [[BuildModule]]-    -- ^ The list of all module loops within the compilation graph.-    -> Logger-    -- ^ The thread-local Logger-    -> TmpFs-    -- ^ The thread-local TmpFs-    -> DynFlags-    -- ^ The thread-local DynFlags-    -> HomeUnit-    -- ^ The home-unit-    -> Maybe Messager-    -- ^ The messager-    -> QSem-    -- ^ The semaphore for limiting the number of simultaneous compiles-    -> MVar HscEnv-    -- ^ The MVar that synchronizes updates to the global HscEnv-    -> IORef HomePackageTable-    -- ^ The old HPT-    -> StableModules-    -- ^ Sets of stable objects and BCOs-    -> Int-    -- ^ The index of this module-    -> Int-    -- ^ The total number of modules-    -> IO SuccessFlag-    -- ^ The result of this compile-parUpsweep_one mod home_mod_map comp_graph_loops lcl_logger lcl_tmpfs lcl_dflags home_unit mHscMessage par_sem-               hsc_env_var old_hpt_var stable_mods mod_index num_mods = do--    let this_build_mod = mkBuildModule0 mod--    let home_imps     = map unLoc $ ms_home_imps mod-    let home_src_imps = map unLoc $ ms_home_srcimps mod--    -- All the textual imports of this module.-    let textual_deps = Set.fromList $-            zipWith f home_imps     (repeat NotBoot) ++-            zipWith f home_src_imps (repeat IsBoot)-          where f mn isBoot = BuildModule_Module $ GWIB-                  { gwib_mod = mkHomeModule home_unit mn-                  , gwib_isBoot = isBoot-                  }--    -- Dealing with module loops-    -- ~~~~~~~~~~~~~~~~~~~~~~~~~-    ---    -- Not only do we have to deal with explicit textual dependencies, we also-    -- have to deal with implicit dependencies introduced by import cycles that-    -- are broken by an hs-boot file. We have to ensure that:-    ---    -- 1. A module that breaks a loop must depend on all the modules in the-    --    loop (transitively or otherwise). This is normally always fulfilled-    --    by the module's textual dependencies except in degenerate loops,-    --    e.g.:-    ---    --    A.hs imports B.hs-boot-    --    B.hs doesn't import A.hs-    --    C.hs imports A.hs, B.hs-    ---    --    In this scenario, getModLoop will detect the module loop [A,B] but-    --    the loop finisher B doesn't depend on A. So we have to explicitly add-    --    A in as a dependency of B when we are compiling B.-    ---    -- 2. A module that depends on a module in an external loop can't proceed-    --    until the entire loop is re-typechecked.-    ---    -- These two invariants have to be maintained to correctly build a-    -- compilation graph with one or more loops.---    -- The loop that this module will finish. After this module successfully-    -- compiles, this loop is going to get re-typechecked.-    let finish_loop :: Maybe [ModuleWithIsBoot]-        finish_loop = listToMaybe-          [ flip mapMaybe (tail loop) $ \case-              BuildModule_Unit _ -> Nothing-              BuildModule_Module ms -> Just ms-          | loop <- comp_graph_loops-          , head loop == BuildModule_Module this_build_mod-          ]--    -- If this module finishes a loop then it must depend on all the other-    -- modules in that loop because the entire module loop is going to be-    -- re-typechecked once this module gets compiled. These extra dependencies-    -- are this module's "internal" loop dependencies, because this module is-    -- inside the loop in question.-    let int_loop_deps :: Set.Set BuildModule-        int_loop_deps = Set.fromList $-            case finish_loop of-                Nothing   -> []-                Just loop -> BuildModule_Module <$> filter (/= this_build_mod) loop--    -- If this module depends on a module within a loop then it must wait for-    -- that loop to get re-typechecked, i.e. it must wait on the module that-    -- finishes that loop. These extra dependencies are this module's-    -- "external" loop dependencies, because this module is outside of the-    -- loop(s) in question.-    let ext_loop_deps :: Set.Set BuildModule-        ext_loop_deps = Set.fromList-            [ head loop | loop <- comp_graph_loops-                        , any (`Set.member` textual_deps) loop-                        , BuildModule_Module this_build_mod `notElem` loop ]---    let all_deps = foldl1 Set.union [textual_deps, int_loop_deps, ext_loop_deps]--    -- All of the module's home-module dependencies.-    let home_deps_with_idx =-            [ home_dep | dep <- Set.toList all_deps-                       , Just home_dep <- [Map.lookup dep home_mod_map]-                       ]--    -- Sort the list of dependencies in reverse-topological order. This way, by-    -- the time we get woken up by the result of an earlier dependency,-    -- subsequent dependencies are more likely to have finished. This step-    -- effectively reduces the number of MVars that each thread blocks on.-    let home_deps = map fst $ sortBy (flip (comparing snd)) home_deps_with_idx--    -- Wait for the all the module's dependencies to finish building.-    deps_ok <- allM (fmap succeeded . readMVar) home_deps--    -- We can't build this module if any of its dependencies failed to build.-    if not deps_ok-      then return Failed-      else do-        -- Any hsc_env at this point is OK to use since we only really require-        -- that the HPT contains the HMIs of our dependencies.-        hsc_env <- readMVar hsc_env_var-        old_hpt <- readIORef old_hpt_var--        let logg err = printBagOfErrors lcl_logger lcl_dflags (srcErrorMessages err)--        -- Limit the number of parallel compiles.-        let withSem sem = MC.bracket_ (waitQSem sem) (signalQSem sem)-        mb_mod_info <- withSem par_sem $-            handleSourceError (\err -> do logg err; return Nothing) $ do-                -- Have the HscEnv point to our local logger and tmpfs.-                let lcl_hsc_env = localize_hsc_env hsc_env--                -- Re-typecheck the loop-                -- This is necessary to make sure the knot is tied when-                -- we close a recursive module loop, see bug #12035.-                type_env_var <- liftIO $ newIORef emptyNameEnv-                let lcl_hsc_env' = lcl_hsc_env { hsc_type_env_var =-                                    Just (ms_mod mod, type_env_var) }-                lcl_hsc_env'' <- case finish_loop of-                    Nothing   -> return lcl_hsc_env'-                    -- In the non-parallel case, the retypecheck prior to-                    -- typechecking the loop closer includes all modules-                    -- EXCEPT the loop closer.  However, our precomputed-                    -- SCCs include the loop closer, so we have to filter-                    -- it out.-                    Just loop -> typecheckLoop lcl_dflags lcl_hsc_env' $-                                 filter (/= moduleName (gwib_mod this_build_mod)) $-                                 map (moduleName . gwib_mod) loop--                -- Compile the module.-                mod_info <- upsweep_mod lcl_hsc_env'' mHscMessage old_hpt stable_mods-                                        mod mod_index num_mods-                return (Just mod_info)--        case mb_mod_info of-            Nothing -> return Failed-            Just mod_info -> do-                let this_mod = ms_mod_name mod--                -- Prune the old HPT unless this is an hs-boot module.-                unless (isBootSummary mod == IsBoot) $-                    atomicModifyIORef' old_hpt_var $ \old_hpt ->-                        (delFromHpt old_hpt this_mod, ())--                -- Update and fetch the global HscEnv.-                lcl_hsc_env' <- modifyMVar hsc_env_var $ \hsc_env -> do-                    let hsc_env' = hsc_env-                                     { hsc_HPT = addToHpt (hsc_HPT hsc_env)-                                                           this_mod mod_info }-                    -- We've finished typechecking the module, now we must-                    -- retypecheck the loop AGAIN to ensure unfoldings are-                    -- updated.  This time, however, we include the loop-                    -- closer!-                    hsc_env'' <- case finish_loop of-                        Nothing   -> return hsc_env'-                        Just loop -> typecheckLoop lcl_dflags hsc_env' $-                                     map (moduleName . gwib_mod) loop-                    return (hsc_env'', localize_hsc_env hsc_env'')--                -- Clean up any intermediate files.-                cleanCurrentModuleTempFiles (hsc_logger lcl_hsc_env')-                                            (hsc_tmpfs  lcl_hsc_env')-                                            (hsc_dflags lcl_hsc_env')-                return Succeeded--  where-    localize_hsc_env hsc_env-        = hsc_env { hsc_logger = lcl_logger-                  , hsc_tmpfs  = lcl_tmpfs-                  }---- ----------------------------------------------------------------------------------- | The upsweep------ This is where we compile each module in the module graph, in a pass--- from the bottom to the top of the graph.------ There better had not be any cyclic groups here -- we check for them.-upsweep-    :: forall m-    .  GhcMonad m-    => Maybe Messager-    -> HomePackageTable            -- ^ HPT from last time round (pruned)-    -> StableModules               -- ^ stable modules (see checkStability)-    -> [SCC ModuleGraphNode]       -- ^ Mods to do (the worklist)-    -> m (SuccessFlag,-          [ModuleGraphNode])-       -- ^ Returns:-       ---       --  1. A flag whether the complete upsweep was successful.-       --  2. The 'HscEnv' in the monad has an updated HPT-       --  3. A list of modules which succeeded loading.--upsweep mHscMessage old_hpt stable_mods sccs = do-   (res, done) <- upsweep' old_hpt emptyMG sccs 1 (length sccs)-   return (res, reverse $ mgModSummaries' done)- where-  keep_going-    :: [NodeKey]-    -> HomePackageTable-    -> ModuleGraph-    -> [SCC ModuleGraphNode]-    -> Int-    -> Int-    -> m (SuccessFlag, ModuleGraph)-  keep_going this_mods old_hpt done mods mod_index nmods = do-    let sum_deps ms (AcyclicSCC iuidOrMod) =-          if any (flip elem $ unfilteredEdges False iuidOrMod) $ ms-          then mkHomeBuildModule iuidOrMod : ms-          else ms-        sum_deps ms _ = ms-        dep_closure = foldl' sum_deps this_mods mods-        dropped_ms = drop (length this_mods) (reverse dep_closure)-        prunable (AcyclicSCC node) = elem (mkHomeBuildModule node) dep_closure-        prunable _ = False-        mods' = filter (not . prunable) mods-        nmods' = nmods - length dropped_ms--    when (not $ null dropped_ms) $ do-        dflags <- getSessionDynFlags-        logger <- getLogger-        liftIO $ fatalErrorMsg logger dflags (keepGoingPruneErr $ dropped_ms)-    (_, done') <- upsweep' old_hpt done mods' (mod_index+1) nmods'-    return (Failed, done')--  upsweep'-    :: HomePackageTable-    -> ModuleGraph-    -> [SCC ModuleGraphNode]-    -> Int-    -> Int-    -> m (SuccessFlag, ModuleGraph)-  upsweep' _old_hpt done-     [] _ _-     = return (Succeeded, done)--  upsweep' _old_hpt done-     (CyclicSCC ms : mods) mod_index nmods-   = do dflags <- getSessionDynFlags-        logger <- getLogger-        liftIO $ fatalErrorMsg logger dflags (cyclicModuleErr ms)-        if gopt Opt_KeepGoing dflags-          then keep_going (mkHomeBuildModule <$> ms) old_hpt done mods mod_index nmods-          else return (Failed, done)--  upsweep' old_hpt done-     (AcyclicSCC (InstantiationNode iuid) : mods) mod_index nmods-   = do hsc_env <- getSession-        liftIO $ upsweep_inst hsc_env mHscMessage mod_index nmods iuid-        upsweep' old_hpt done mods (mod_index+1) nmods--  upsweep' old_hpt done-     (AcyclicSCC (ModuleNode ems@(ExtendedModSummary mod _)) : mods) mod_index nmods-   = do -- putStrLn ("UPSWEEP_MOD: hpt = " ++-        --           show (map (moduleUserString.moduleName.mi_module.hm_iface)-        --                     (moduleEnvElts (hsc_HPT hsc_env)))-        let logg _mod = defaultWarnErrLogger--        hsc_env <- getSession--        -- Remove unwanted tmp files between compilations-        liftIO $ cleanCurrentModuleTempFiles (hsc_logger hsc_env)-                                             (hsc_tmpfs  hsc_env)-                                             (hsc_dflags hsc_env)--        -- Get ready to tie the knot-        type_env_var <- liftIO $ newIORef emptyNameEnv-        let hsc_env1 = hsc_env { hsc_type_env_var =-                                    Just (ms_mod mod, type_env_var) }-        setSession hsc_env1--        -- Lazily reload the HPT modules participating in the loop.-        -- See Note [Tying the knot]--if we don't throw out the old HPT-        -- and reinitalize the knot-tying process, anything that was forced-        -- while we were previously typechecking won't get updated, this-        -- was bug #12035.-        hsc_env2 <- liftIO $ reTypecheckLoop hsc_env1 mod done-        setSession hsc_env2--        mb_mod_info-            <- handleSourceError-                   (\err -> do logg mod (Just err); return Nothing) $ do-                 mod_info <- liftIO $ upsweep_mod hsc_env2 mHscMessage old_hpt stable_mods-                                                  mod mod_index nmods-                 logg mod Nothing -- log warnings-                 return (Just mod_info)--        case mb_mod_info of-          Nothing -> do-                dflags <- getSessionDynFlags-                if gopt Opt_KeepGoing dflags-                  then keep_going [NodeKey_Module $ mkHomeBuildModule0 mod] old_hpt done mods mod_index nmods-                  else return (Failed, done)-          Just mod_info -> do-                let this_mod = ms_mod_name mod--                        -- Add new info to hsc_env-                    hpt1     = addToHpt (hsc_HPT hsc_env2) this_mod mod_info-                    hsc_env3 = hsc_env2 { hsc_HPT = hpt1, hsc_type_env_var = Nothing }--                        -- Space-saving: delete the old HPT entry-                        -- for mod BUT if mod is a hs-boot-                        -- node, don't delete it.  For the-                        -- interface, the HPT entry is probably for the-                        -- main Haskell source file.  Deleting it-                        -- would force the real module to be recompiled-                        -- every time.-                    old_hpt1 = case isBootSummary mod of-                      IsBoot -> old_hpt-                      NotBoot -> delFromHpt old_hpt this_mod--                    done' = extendMG done ems--                        -- fixup our HomePackageTable after we've finished compiling-                        -- a mutually-recursive loop.  We have to do this again-                        -- to make sure we have the final unfoldings, which may-                        -- not have been computed accurately in the previous-                        -- retypecheck.-                hsc_env4 <- liftIO $ reTypecheckLoop hsc_env3 mod done'-                setSession hsc_env4--                        -- Add any necessary entries to the static pointer-                        -- table. See Note [Grand plan for static forms] in-                        -- GHC.Iface.Tidy.StaticPtrTable.-                when (backend (hsc_dflags hsc_env4) == Interpreter) $-                    liftIO $ hscAddSptEntries hsc_env4-                                 [ spt-                                 | Just linkable <- pure $ hm_linkable mod_info-                                 , unlinked <- linkableUnlinked linkable-                                 , BCOs _ spts <- pure unlinked-                                 , spt <- spts-                                 ]--                upsweep' old_hpt1 done' mods (mod_index+1) nmods--maybeGetIfaceDate :: DynFlags -> ModLocation -> IO (Maybe UTCTime)-maybeGetIfaceDate dflags location- | writeInterfaceOnlyMode dflags-    -- Minor optimization: it should be harmless to check the hi file location-    -- always, but it's better to avoid hitting the filesystem if possible.-    = modificationTimeIfExists (ml_hi_file location)- | otherwise-    = return Nothing--upsweep_inst :: HscEnv-             -> Maybe Messager-             -> Int  -- index of module-             -> Int  -- total number of modules-             -> InstantiatedUnit-             -> IO ()-upsweep_inst hsc_env mHscMessage mod_index nmods iuid = do-        case mHscMessage of-            Just hscMessage -> hscMessage hsc_env (mod_index, nmods) MustCompile (InstantiationNode iuid)-            Nothing -> return ()-        runHsc hsc_env $ ioMsgMaybe $ 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-            -> HomePackageTable-            -> StableModules-            -> ModSummary-            -> Int  -- index of module-            -> Int  -- total number of modules-            -> IO HomeModInfo-upsweep_mod hsc_env mHscMessage old_hpt (stable_obj, stable_bco) summary mod_index nmods-   =    let-            this_mod_name = ms_mod_name summary-            this_mod    = ms_mod summary-            mb_obj_date = ms_obj_date summary-            mb_if_date  = ms_iface_date summary-            obj_fn      = ml_obj_file (ms_location summary)-            hs_date     = ms_hs_date summary--            is_stable_obj = this_mod_name `elementOfUniqSet` stable_obj-            is_stable_bco = this_mod_name `elementOfUniqSet` stable_bco--            old_hmi = lookupHpt old_hpt this_mod_name--            -- We're using the dflags for this module now, obtained by-            -- applying any options in its LANGUAGE & OPTIONS_GHC pragmas.-            lcl_dflags = ms_hspp_opts summary-            prevailing_backend = backend (hsc_dflags hsc_env)-            local_backend      = backend lcl_dflags--            -- If OPTIONS_GHC contains -fasm or -fllvm, be careful that-            -- we don't do anything dodgy: these should only work to change-            -- from -fllvm to -fasm and vice-versa, or away from -fno-code,-            -- otherwise we could end up trying to link object code to byte-            -- code.-            bcknd = case (prevailing_backend,local_backend) of-               (LLVM,NCG) -> NCG-               (NCG,LLVM) -> LLVM-               (NoBackend,b)-                  | backendProducesObject b -> b-               (Interpreter,b)-                  | backendProducesObject b -> b-               _ -> prevailing_backend--            -- store the corrected backend into the summary-            summary' = summary{ ms_hspp_opts = lcl_dflags { backend = bcknd } }--            -- The old interface is ok if-            --  a) we're compiling a source file, and the old HPT-            --     entry is for a source file-            --  b) we're compiling a hs-boot file-            -- Case (b) allows an hs-boot file to get the interface of its-            -- real source file on the second iteration of the compilation-            -- manager, but that does no harm.  Otherwise the hs-boot file-            -- will always be recompiled--            mb_old_iface-                = case old_hmi of-                     Nothing                                        -> Nothing-                     Just hm_info | isBootSummary summary == IsBoot -> Just iface-                                  | mi_boot iface == NotBoot        -> Just iface-                                  | otherwise                       -> Nothing-                                   where-                                     iface = hm_iface hm_info--            compile_it :: Maybe Linkable -> SourceModified -> IO HomeModInfo-            compile_it  mb_linkable src_modified =-                  compileOne' Nothing mHscMessage hsc_env summary' mod_index nmods-                             mb_old_iface mb_linkable src_modified--            compile_it_discard_iface :: Maybe Linkable -> SourceModified-                                     -> IO HomeModInfo-            compile_it_discard_iface mb_linkable  src_modified =-                  compileOne' Nothing mHscMessage hsc_env summary' mod_index nmods-                             Nothing mb_linkable src_modified--            -- With NoBackend we create empty linkables to avoid recompilation.-            -- We have to detect these to recompile anyway if the backend changed-            -- since the last compile.-            is_fake_linkable-               | Just hmi <- old_hmi, Just l <- hm_linkable hmi =-                  null (linkableUnlinked l)-               | otherwise =-                   -- we have no linkable, so it cannot be fake-                   False--            implies False _ = True-            implies True x  = x--            debug_trace n t = liftIO $ debugTraceMsg (hsc_logger hsc_env) (hsc_dflags hsc_env) n t--        in-        case () of-         _-                -- Regardless of whether we're generating object code or-                -- byte code, we can always use an existing object file-                -- if it is *stable* (see checkStability).-          | is_stable_obj, Just hmi <- old_hmi -> do-                debug_trace 5 (text "skipping stable obj mod:" <+> ppr this_mod_name)-                return hmi-                -- object is stable, and we have an entry in the-                -- old HPT: nothing to do--          | is_stable_obj, isNothing old_hmi -> do-                debug_trace 5 (text "compiling stable on-disk mod:" <+> ppr this_mod_name)-                linkable <- liftIO $ findObjectLinkable this_mod obj_fn-                              (expectJust "upsweep1" mb_obj_date)-                compile_it (Just linkable) SourceUnmodifiedAndStable-                -- object is stable, but we need to load the interface-                -- off disk to make a HMI.--          | not (backendProducesObject bcknd), is_stable_bco,-            (bcknd /= NoBackend) `implies` not is_fake_linkable ->-                ASSERT(isJust old_hmi) -- must be in the old_hpt-                let Just hmi = old_hmi in do-                debug_trace 5 (text "skipping stable BCO mod:" <+> ppr this_mod_name)-                return hmi-                -- BCO is stable: nothing to do--          | not (backendProducesObject bcknd),-            Just hmi <- old_hmi,-            Just l <- hm_linkable hmi,-            not (isObjectLinkable l),-            (bcknd /= NoBackend) `implies` not is_fake_linkable,-            linkableTime l >= ms_hs_date summary -> do-                debug_trace 5 (text "compiling non-stable BCO mod:" <+> ppr this_mod_name)-                compile_it (Just l) SourceUnmodified-                -- we have an old BCO that is up to date with respect-                -- to the source: do a recompilation check as normal.--          -- When generating object code, if there's an up-to-date-          -- object file on the disk, then we can use it.-          -- However, if the object file is new (compared to any-          -- linkable we had from a previous compilation), then we-          -- must discard any in-memory interface, because this-          -- means the user has compiled the source file-          -- separately and generated a new interface, that we must-          -- read from the disk.-          ---          | backendProducesObject bcknd,-            Just obj_date <- mb_obj_date,-            obj_date >= hs_date -> do-                case old_hmi of-                  Just hmi-                    | Just l <- hm_linkable hmi,-                      isObjectLinkable l && linkableTime l == obj_date -> do-                          debug_trace 5 (text "compiling mod with new on-disk obj:" <+> ppr this_mod_name)-                          compile_it (Just l) SourceUnmodified-                  _otherwise -> do-                          debug_trace 5 (text "compiling mod with new on-disk obj2:" <+> ppr this_mod_name)-                          linkable <- liftIO $ findObjectLinkable this_mod obj_fn obj_date-                          compile_it_discard_iface (Just linkable) SourceUnmodified--          -- See Note [Recompilation checking in -fno-code mode]-          | writeInterfaceOnlyMode lcl_dflags,-            Just if_date <- mb_if_date,-            if_date >= hs_date -> do-                debug_trace 5 (text "skipping tc'd mod:" <+> ppr this_mod_name)-                compile_it Nothing SourceUnmodified--         _otherwise -> do-                debug_trace 5 (text "compiling mod:" <+> ppr this_mod_name)-                compile_it Nothing SourceModified---{- Note [-fno-code mode]-~~~~~~~~~~~~~~~~~~~~~~~~-GHC offers the flag -fno-code for the purpose of parsing and typechecking a-program without generating object files. This is intended to be used by tooling-and IDEs to provide quick feedback on any parser or type errors as cheaply as-possible.--When GHC is invoked with -fno-code no object files or linked output will be-generated. As many errors and warnings as possible will be generated, as if--fno-code had not been passed. The session DynFlags will have-backend == NoBackend.---fwrite-interface-~~~~~~~~~~~~~~~~-Whether interface files are generated in -fno-code mode is controlled by the--fwrite-interface flag. The -fwrite-interface flag is a no-op if -fno-code is-not also passed. Recompilation avoidance requires interface files, so passing--fno-code without -fwrite-interface should be avoided. If -fno-code were-re-implemented today, -fwrite-interface would be discarded and it would be-considered always on; this behaviour is as it is for backwards compatibility.--================================================================-IN SUMMARY: ALWAYS PASS -fno-code AND -fwrite-interface TOGETHER-================================================================--Template Haskell-~~~~~~~~~~~~~~~~-A module using template haskell may invoke an imported function from inside a-splice. This will cause the type-checker to attempt to execute that code, which-would fail if no object files had been generated. See #8025. To rectify this,-during the downsweep we patch the DynFlags in the ModSummary of any home module-that is imported by a module that uses template haskell, to generate object-code.--The flavour of generated object code is chosen by defaultObjectTarget for the-target platform. It would likely be faster to generate bytecode, but this is not-supported on all platforms(?Please Confirm?), and does not support the entirety-of GHC haskell. See #1257.--The object files (and interface files if -fwrite-interface is disabled) produced-for template haskell are written to temporary files.--Note that since template haskell can run arbitrary IO actions, -fno-code mode-is no more secure than running without it.--Potential TODOS:-~~~~~-* Remove -fwrite-interface and have interface files always written in -fno-code-  mode-* Both .o and .dyn_o files are generated for template haskell, but we only need-  .dyn_o. Fix it.-* In make mode, a message like-  Compiling A (A.hs, /tmp/ghc_123.o)-  is shown if downsweep enabled object code generation for A. Perhaps we should-  show "nothing" or "temporary object file" instead. Note that one-  can currently use -keep-tmp-files and inspect the generated file with the-  current behaviour.-* Offer a -no-codedir command line option, and write what were temporary-  object files there. This would speed up recompilation.-* Use existing object files (if they are up to date) instead of always-  generating temporary ones.--}---- Note [Recompilation checking in -fno-code mode]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- If we are compiling with -fno-code -fwrite-interface, there won't--- be any object code that we can compare against, nor should there--- be: we're *just* generating interface files.  In this case, we--- want to check if the interface file is new, in lieu of the object--- file.  See also #9243.---- Filter modules in the HPT-retainInTopLevelEnvs :: [ModuleName] -> HomePackageTable -> HomePackageTable-retainInTopLevelEnvs keep_these hpt-   = listToHpt   [ (mod, expectJust "retain" mb_mod_info)-                 | mod <- keep_these-                 , let mb_mod_info = lookupHpt hpt mod-                 , isJust mb_mod_info ]---- ------------------------------------------------------------------------------ Typecheck module loops-{--See bug #930.  This code fixes a long-standing bug in --make.  The-problem is that when compiling the modules *inside* a loop, a data-type that is only defined at the top of the loop looks opaque; but-after the loop is done, the structure of the data type becomes-apparent.--The difficulty is then that two different bits of code have-different notions of what the data type looks like.--The idea is that after we compile a module which also has an .hs-boot-file, we re-generate the ModDetails for each of the modules that-depends on the .hs-boot file, so that everyone points to the proper-TyCons, Ids etc. defined by the real module, not the boot module.-Fortunately re-generating a ModDetails from a ModIface is easy: the-function GHC.IfaceToCore.typecheckIface does exactly that.--Picking the modules to re-typecheck is slightly tricky.  Starting from-the module graph consisting of the modules that have already been-compiled, we reverse the edges (so they point from the imported module-to the importing module), and depth-first-search from the .hs-boot-node.  This gives us all the modules that depend transitively on the-.hs-boot module, and those are exactly the modules that we need to-re-typecheck.--Following this fix, GHC can compile itself with --make -O2.--}--reTypecheckLoop :: HscEnv -> ModSummary -> ModuleGraph -> IO HscEnv-reTypecheckLoop hsc_env ms graph-  | Just loop <- getModLoop ms mss appearsAsBoot-  -- SOME hs-boot files should still-  -- get used, just not the loop-closer.-  , let non_boot = flip mapMaybe loop $ \case-          InstantiationNode _ -> Nothing-          ModuleNode ems -> do-            let l = emsModSummary ems-            guard $ not $ isBootSummary l == IsBoot && ms_mod l == ms_mod ms-            pure l-  = typecheckLoop (hsc_dflags hsc_env) hsc_env (map ms_mod_name non_boot)-  | otherwise-  = return hsc_env-  where-  mss = mgModSummaries' graph-  appearsAsBoot = (`elemModuleSet` mgBootModules graph)---- | Given a non-boot ModSummary @ms@ of a module, for which there exists a--- corresponding boot file in @graph@, return the set of modules which--- transitively depend on this boot file.  This function is slightly misnamed,--- but its name "getModLoop" alludes to the fact that, when getModLoop is called--- with a graph that does not contain @ms@ (non-parallel case) or is an--- SCC with hs-boot nodes dropped (parallel-case), the modules which--- depend on the hs-boot file are typically (but not always) the--- modules participating in the recursive module loop.  The returned--- list includes the hs-boot file.------ Example:---      let g represent the module graph:---          C.hs---          A.hs-boot imports C.hs---          B.hs imports A.hs-boot---          A.hs imports B.hs---      genModLoop A.hs g == Just [A.hs-boot, B.hs, A.hs]------      It would also be permissible to omit A.hs from the graph,---      in which case the result is [A.hs-boot, B.hs]------ Example:---      A counter-example to the claim that modules returned---      by this function participate in the loop occurs here:------      let g represent the module graph:---          C.hs---          A.hs-boot imports C.hs---          B.hs imports A.hs-boot---          A.hs imports B.hs---          D.hs imports A.hs-boot---      genModLoop A.hs g == Just [A.hs-boot, B.hs, A.hs, D.hs]------      Arguably, D.hs should import A.hs, not A.hs-boot, but---      a dependency on the boot file is not illegal.----getModLoop-  :: ModSummary-  -> [ModuleGraphNode]-  -> (Module -> Bool) -- check if a module appears as a boot module in 'graph'-  -> Maybe [ModuleGraphNode]-getModLoop ms graph appearsAsBoot-  | isBootSummary ms == NotBoot-  , appearsAsBoot this_mod-  , let mss = reachableBackwards (ms_mod_name ms) graph-  = Just mss-  | otherwise-  = Nothing- where-  this_mod = ms_mod ms---- NB: sometimes mods has duplicates; this is harmless because--- any duplicates get clobbered in addListToHpt and never get forced.-typecheckLoop :: DynFlags -> HscEnv -> [ModuleName] -> IO HscEnv-typecheckLoop dflags hsc_env mods = do-  debugTraceMsg logger dflags 2 $-     text "Re-typechecking loop: " <> ppr mods-  new_hpt <--    fixIO $ \new_hpt -> do-      let new_hsc_env = hsc_env{ hsc_HPT = new_hpt }-      mds <- initIfaceCheck (text "typecheckLoop") new_hsc_env $-                mapM (typecheckIface . hm_iface) hmis-      let new_hpt = addListToHpt old_hpt-                        (zip mods [ hmi{ hm_details = details }-                                  | (hmi,details) <- zip hmis mds ])-      return new_hpt-  return hsc_env{ hsc_HPT = new_hpt }-  where-    logger  = hsc_logger hsc_env-    old_hpt = hsc_HPT hsc_env-    hmis    = map (expectJust "typecheckLoop" . lookupHpt old_hpt) mods--reachableBackwards :: ModuleName -> [ModuleGraphNode] -> [ModuleGraphNode]-reachableBackwards mod summaries-  = [ node_payload node | node <- reachableG (transposeG graph) root ]-  where -- the rest just sets up the graph:-        (graph, lookup_node) = moduleGraphNodes False summaries-        root  = expectJust "reachableBackwards" (lookup_node $ NodeKey_Module $ GWIB mod IsBoot)---- --------------------------------------------------------------------------------- | Topological sort of the module graph-topSortModuleGraph-          :: Bool-          -- ^ Drop hi-boot nodes? (see below)-          -> ModuleGraph-          -> Maybe ModuleName-             -- ^ Root module name.  If @Nothing@, use the full graph.-          -> [SCC 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-  = map (fmap summaryNodeSummary) $ stronglyConnCompG initial_graph-  where-    summaries = mgModSummaries' module_graph-    -- stronglyConnCompG flips the original order, so if we reverse-    -- the summaries we get a stable topological sort.-    (graph, lookup_node) =-      moduleGraphNodes drop_hs_boot_nodes (reverse summaries)--    initial_graph = case mb_root_mod of-        Nothing -> graph-        Just root_mod ->-            -- restrict the graph to just those modules reachable from-            -- the specified module.  We do this by building a graph with-            -- the full set of nodes, and determining the reachable set from-            -- the specified node.-            let root | Just node <- lookup_node $ NodeKey_Module $ GWIB root_mod NotBoot-                     , graph `hasVertexG` node-                     = node-                     | otherwise-                     = throwGhcException (ProgramError "module does not exist")-            in graphFromEdgedVerticesUniq (seq root (reachableG graph root))--type SummaryNode = Node Int ModuleGraphNode--summaryNodeKey :: SummaryNode -> Int-summaryNodeKey = node_key--summaryNodeSummary :: SummaryNode -> ModuleGraphNode-summaryNodeSummary = node_payload---- | Collect the immediate dependencies of a ModuleGraphNode,--- optionally avoiding hs-boot dependencies.--- If the drop_hs_boot_nodes flag is False, and if this is a .hs and there is--- an equivalent .hs-boot, add a link from the former to the latter.  This--- has the effect of detecting bogus cases where the .hs-boot depends on the--- .hs, by introducing a cycle.  Additionally, it ensures that we will always--- process the .hs-boot before the .hs, and so the HomePackageTable will always--- have the most up to date information.-unfilteredEdges :: Bool -> ModuleGraphNode -> [NodeKey]-unfilteredEdges drop_hs_boot_nodes = \case-    InstantiationNode iuid ->-      NodeKey_Module . flip GWIB NotBoot <$> uniqDSetToList (instUnitHoles iuid)-    ModuleNode (ExtendedModSummary ms bds) ->-      (NodeKey_Module . flip GWIB hs_boot_key . unLoc <$> ms_home_srcimps ms) ++-      (NodeKey_Module . flip GWIB NotBoot     . unLoc <$> ms_home_imps ms) ++-      [ NodeKey_Module $ GWIB (ms_mod_name ms) IsBoot-      | not $ drop_hs_boot_nodes || ms_hsc_src ms == HsBootFile-      ] ++-      [ NodeKey_Unit inst_unit-      | inst_unit <- bds-      ]-  where-    -- Drop hs-boot nodes by using HsSrcFile as the key-    hs_boot_key | drop_hs_boot_nodes = NotBoot -- is regular mod or signature-                | otherwise          = IsBoot--moduleGraphNodes :: Bool -> [ModuleGraphNode]-  -> (Graph SummaryNode, NodeKey -> Maybe SummaryNode)-moduleGraphNodes drop_hs_boot_nodes summaries =-  (graphFromEdgedVerticesUniq nodes, lookup_node)-  where-    numbered_summaries = zip summaries [1..]--    lookup_node :: NodeKey -> Maybe SummaryNode-    lookup_node key = Map.lookup key (unNodeMap node_map)--    lookup_key :: NodeKey -> Maybe Int-    lookup_key = fmap summaryNodeKey . lookup_node--    node_map :: NodeMap SummaryNode-    node_map = NodeMap $-      Map.fromList [ (mkHomeBuildModule s, node)-                   | node <- nodes-                   , let s = summaryNodeSummary node-                   ]--    -- We use integers as the keys for the SCC algorithm-    nodes :: [SummaryNode]-    nodes = [ DigraphNode s key $ out_edge_keys $ unfilteredEdges drop_hs_boot_nodes s-            | (s, key) <- numbered_summaries-             -- Drop the hi-boot ones if told to do so-            , case s of-                InstantiationNode _ -> True-                ModuleNode ems -> not $ isBootSummary (emsModSummary ems) == IsBoot && drop_hs_boot_nodes-            ]--    out_edge_keys :: [NodeKey] -> [Int]-    out_edge_keys = mapMaybe lookup_key-        -- If we want keep_hi_boot_nodes, then we do lookup_key with-        -- IsBoot; else False---- The nodes of the graph are keyed by (mod, is boot?) pairs for the current--- modules, and indefinite unit IDs for dependencies which are instantiated with--- our holes.------ NB: hsig files show up as *normal* nodes (not boot!), since they don't--- participate in cycles (for now)-type ModNodeKey = ModuleNameWithIsBoot-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--data NodeKey = NodeKey_Unit {-# UNPACK #-} !InstantiatedUnit | NodeKey_Module {-# UNPACK #-} !ModNodeKey-  deriving (Eq, Ord)--newtype NodeMap a = NodeMap { unNodeMap :: Map.Map NodeKey a }-  deriving (Functor, Traversable, Foldable)--msKey :: ModSummary -> ModNodeKey-msKey = mkHomeBuildModule0--mkNodeKey :: ModuleGraphNode -> NodeKey-mkNodeKey = \case-  InstantiationNode x -> NodeKey_Unit x-  ModuleNode x -> NodeKey_Module $ mkHomeBuildModule0 (emsModSummary x)--pprNodeKey :: NodeKey -> SDoc-pprNodeKey (NodeKey_Unit iu) = ppr iu-pprNodeKey (NodeKey_Module mk) = ppr mk--mkNodeMap :: [ExtendedModSummary] -> ModNodeMap ExtendedModSummary-mkNodeMap summaries = ModNodeMap $ Map.fromList-  [ (msKey $ emsModSummary s, s) | s <- summaries]---- | If there are {-# SOURCE #-} imports between strongly connected--- components in the topological sort, then those imports can--- definitely be replaced by ordinary non-SOURCE imports: if SOURCE--- were necessary, then the edge would be part of a cycle.-warnUnnecessarySourceImports :: GhcMonad m => [SCC ModSummary] -> m ()-warnUnnecessarySourceImports sccs = do-  dflags <- getDynFlags-  when (wopt Opt_WarnUnusedImports dflags)-    (logWarnings (listToBag (concatMap (check . flattenSCC) sccs)))-  where check ms =-           let mods_in_this_cycle = map ms_mod_name ms in-           [ warn i | m <- ms, i <- ms_home_srcimps m,-                      unLoc i `notElem`  mods_in_this_cycle ]--        warn :: Located ModuleName -> WarnMsg-        warn (L loc mod) =-           mkPlainMsgEnvelope loc-                (text "Warning: {-# SOURCE #-} unnecessary in import of "-                 <+> quotes (ppr mod))-------------------------------------------------------------------------------------- | Downsweep (dependency analysis)------ Chase downwards from the specified root set, returning summaries--- for all home modules encountered.  Only follow source-import--- links.------ We pass in the previous collection of summaries, which is used as a--- cache to avoid recalculating a module summary if the source is--- unchanged.------ The returned list of [ModSummary] nodes has one node for each home-package--- module, plus one for any hs-boot files.  The imports of these nodes--- are all there, including the imports of non-home-package modules.-downsweep :: HscEnv-          -> [ExtendedModSummary]-          -- ^ Old summaries-          -> [ModuleName]       -- Ignore dependencies on these; treat-                                -- them as if they were package modules-          -> Bool               -- True <=> allow multiple targets to have-                                --          the same module name; this is-                                --          very useful for ghc -M-          -> IO [Either ErrorMessages ExtendedModSummary]-                -- The non-error elements of the returned list all have distinct-                -- (Modules, IsBoot) identifiers, unless the Bool is true in-                -- which case there can be repeats-downsweep hsc_env old_summaries excl_mods allow_dup_roots-   = do-       rootSummaries <- mapM getRootSummary roots-       let (errs, rootSummariesOk) = partitionEithers rootSummaries -- #17549-           root_map = mkRootMap rootSummariesOk-       checkDuplicates root_map-       map0 <- loop (concatMap calcDeps rootSummariesOk) root_map-       -- if we have been passed -fno-code, we enable code generation-       -- for dependencies of modules that have -XTemplateHaskell,-       -- otherwise those modules will fail to compile.-       -- See Note [-fno-code mode] #8025-       let default_backend = platformDefaultBackend (targetPlatform dflags)-       let home_unit       = hsc_home_unit hsc_env-       let tmpfs           = hsc_tmpfs     hsc_env-       map1 <- case backend dflags of-         NoBackend   -> enableCodeGenForTH logger tmpfs home_unit default_backend map0-         _           -> return map0-       if null errs-         then pure $ concat $ modNodeMapElems map1-         else pure $ map Left errs-     where-        -- TODO(@Ericson2314): Probably want to include backpack instantiations-        -- in the map eventually for uniformity-        calcDeps (ExtendedModSummary ms _bkp_deps) = msDeps ms--        dflags = hsc_dflags hsc_env-        logger = hsc_logger hsc_env-        roots = hsc_targets hsc_env--        old_summary_map :: ModNodeMap ExtendedModSummary-        old_summary_map = mkNodeMap old_summaries--        getRootSummary :: Target -> IO (Either ErrorMessages ExtendedModSummary)-        getRootSummary (Target (TargetFile file mb_phase) obj_allowed maybe_buf)-           = do exists <- liftIO $ doesFileExist file-                if exists || isJust maybe_buf-                    then summariseFile hsc_env old_summaries file mb_phase-                                       obj_allowed maybe_buf-                    else return $ Left $ unitBag $ mkPlainMsgEnvelope noSrcSpan $-                           text "can't find file:" <+> text file-        getRootSummary (Target (TargetModule modl) obj_allowed maybe_buf)-           = do maybe_summary <- summariseModule hsc_env old_summary_map NotBoot-                                           (L rootLoc modl) obj_allowed-                                           maybe_buf excl_mods-                case maybe_summary of-                   Nothing -> return $ Left $ moduleNotFoundErr modl-                   Just s  -> return s--        rootLoc = mkGeneralSrcSpan (fsLit "<command line>")--        -- In a root module, the filename is allowed to diverge from the module-        -- name, so we have to check that there aren't multiple root files-        -- defining the same module (otherwise the duplicates will be silently-        -- ignored, leading to confusing behaviour).-        checkDuplicates-          :: ModNodeMap-               [Either ErrorMessages-                       ExtendedModSummary]-          -> IO ()-        checkDuplicates root_map-           | allow_dup_roots = return ()-           | null dup_roots  = return ()-           | otherwise       = liftIO $ multiRootsErr (emsModSummary <$> head dup_roots)-           where-             dup_roots :: [[ExtendedModSummary]]        -- Each at least of length 2-             dup_roots = filterOut isSingleton $ map rights $ modNodeMapElems root_map--        loop :: [GenWithIsBoot (Located ModuleName)]-                        -- Work list: process these modules-             -> ModNodeMap [Either ErrorMessages ExtendedModSummary]-                        -- Visited set; the range is a list because-                        -- the roots can have the same module names-                        -- if allow_dup_roots is True-             -> IO (ModNodeMap [Either ErrorMessages ExtendedModSummary])-                        -- The result is the completed NodeMap-        loop [] done = return done-        loop (s : ss) done-          | Just summs <- modNodeMapLookup key done-          = if isSingleton summs then-                loop ss done-            else-                do { multiRootsErr (emsModSummary <$> rights summs)-                   ; return (ModNodeMap Map.empty)-                   }-          | otherwise-          = do mb_s <- summariseModule hsc_env old_summary_map-                                       is_boot wanted_mod True-                                       Nothing excl_mods-               case mb_s of-                   Nothing -> loop ss done-                   Just (Left e) -> loop ss (modNodeMapInsert key [Left e] done)-                   Just (Right s)-> do-                     new_map <--                       loop (calcDeps s) (modNodeMapInsert key [Right s] done)-                     loop ss new_map-          where-            GWIB { gwib_mod = L loc mod, gwib_isBoot = is_boot } = s-            wanted_mod = L loc mod-            key = GWIB-                    { gwib_mod = unLoc wanted_mod-                    , gwib_isBoot = is_boot-                    }---- | Update the every ModSummary that is depended on--- by a module that needs template haskell. We enable codegen to--- the specified target, disable optimization and change the .hi--- and .o file locations to be temporary files.--- See Note [-fno-code mode]-enableCodeGenForTH-  :: Logger-  -> TmpFs-  -> HomeUnit-  -> Backend-  -> ModNodeMap [Either ErrorMessages ExtendedModSummary]-  -> IO (ModNodeMap [Either ErrorMessages ExtendedModSummary])-enableCodeGenForTH logger tmpfs home_unit =-  enableCodeGenWhen logger tmpfs condition should_modify TFL_CurrentModule TFL_GhcSession-  where-    condition = isTemplateHaskellOrQQNonBoot-    should_modify (ModSummary { ms_hspp_opts = dflags }) =-      backend dflags == NoBackend &&-      -- Don't enable codegen for TH on indefinite packages; we-      -- can't compile anything anyway! See #16219.-      isHomeUnitDefinite home_unit---- | 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-  -> (ModSummary -> Bool)-  -> (ModSummary -> Bool)-  -> TempFileLifetime-  -> TempFileLifetime-  -> Backend-  -> ModNodeMap [Either ErrorMessages ExtendedModSummary]-  -> IO (ModNodeMap [Either ErrorMessages ExtendedModSummary])-enableCodeGenWhen logger tmpfs condition should_modify staticLife dynLife bcknd nodemap =-  traverse (traverse (traverse enable_code_gen)) nodemap-  where-    enable_code_gen :: ExtendedModSummary -> IO ExtendedModSummary-    enable_code_gen (ExtendedModSummary ms bkp_deps)-      | ModSummary-        { ms_mod = ms_mod-        , ms_location = ms_location-        , ms_hsc_src = HsSrcFile-        , ms_hspp_opts = dflags-        } <- ms-      , should_modify ms-      , ms_mod `Set.member` needs_codegen_set-      = do-        let new_temp_file suf dynsuf = do-              tn <- newTempName logger tmpfs dflags staticLife suf-              let dyn_tn = tn -<.> dynsuf-              addFilesToClean tmpfs dynLife [dyn_tn]-              return tn-          -- We don't want to create .o or .hi files unless we have been asked-          -- to by the user. But we need them, so we patch their locations in-          -- the ModSummary with temporary files.-          ---        (hi_file, o_file) <--          -- If ``-fwrite-interface` is specified, then the .o and .hi files-          -- are written into `-odir` and `-hidir` respectively.  #16670-          if gopt Opt_WriteInterface dflags-            then return (ml_hi_file ms_location, ml_obj_file ms_location)-            else (,) <$> (new_temp_file (hiSuf_ dflags) (dynHiSuf_ dflags))-                     <*> (new_temp_file (objectSuf_ dflags) (dynObjectSuf_ dflags))-        let ms' = ms-              { ms_location =-                  ms_location {ml_hi_file = hi_file, ml_obj_file = o_file}-              , ms_hspp_opts = updOptLevel 0 $ dflags {backend = bcknd}-              }-        pure (ExtendedModSummary ms' bkp_deps)-      | otherwise = return (ExtendedModSummary ms bkp_deps)--    needs_codegen_set = transitive_deps_set-      [ ms-      | mss <- modNodeMapElems nodemap-      , Right (ExtendedModSummary { emsModSummary = ms }) <- mss-      , condition ms-      ]--    -- find the set of all transitive dependencies of a list of modules.-    transitive_deps_set :: [ModSummary] -> Set.Set Module-    transitive_deps_set modSums = foldl' go Set.empty modSums-      where-        go marked_mods ms@ModSummary{ms_mod}-          | ms_mod `Set.member` marked_mods = marked_mods-          | otherwise =-            let deps =-                  [ dep_ms-                  -- If a module imports a boot module, msDeps helpfully adds a-                  -- dependency to that non-boot module in it's result. This-                  -- means we don't have to think about boot modules here.-                  | dep <- msDeps ms-                  , NotBoot == gwib_isBoot dep-                  , dep_ms_0 <- toList $ modNodeMapLookup (unLoc <$> dep) nodemap-                  , dep_ms_1 <- toList $ dep_ms_0-                  , (ExtendedModSummary { emsModSummary = dep_ms }) <- toList $ dep_ms_1-                  ]-                new_marked_mods = Set.insert ms_mod marked_mods-            in foldl' go new_marked_mods deps--mkRootMap-  :: [ExtendedModSummary]-  -> ModNodeMap [Either ErrorMessages ExtendedModSummary]-mkRootMap summaries = ModNodeMap $ Map.insertListWith-  (flip (++))-  [ (msKey $ emsModSummary s, [Right s]) | s <- summaries ]-  Map.empty---- | Returns the dependencies of the ModSummary s.--- A wrinkle is that for a {-# SOURCE #-} import we return---      *both* the hs-boot file---      *and* the source file--- as "dependencies".  That ensures that the list of all relevant--- modules always contains B.hs if it contains B.hs-boot.--- Remember, this pass isn't doing the topological sort.  It's--- just gathering the list of all relevant ModSummaries-msDeps :: ModSummary -> [GenWithIsBoot (Located ModuleName)]-msDeps s = [ d-           | m <- ms_home_srcimps s-           , d <- [ GWIB { gwib_mod = m, gwib_isBoot = IsBoot }-                  , GWIB { gwib_mod = m, gwib_isBoot = NotBoot }-                  ]-           ]-        ++ [ GWIB { gwib_mod = m, gwib_isBoot = NotBoot }-           | m <- ms_home_imps s-           ]---------------------------------------------------------------------------------- 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-        -> [ExtendedModSummary]         -- old summaries-        -> FilePath                     -- source file name-        -> Maybe Phase                  -- start phase-        -> Bool                         -- object code allowed?-        -> Maybe (StringBuffer,UTCTime)-        -> IO (Either ErrorMessages ExtendedModSummary)--summariseFile hsc_env old_summaries src_fn mb_phase obj_allowed maybe_buf-        -- we can use a cached summary if one is available and the-        -- source file hasn't changed,  But we have to look up the summary-        -- by source file, rather than module name as we do in summarise.-   | Just old_summary <- findSummaryBySourceFile old_summaries src_fn-   = do-        let location = ms_location $ emsModSummary old_summary-            dflags = hsc_dflags hsc_env--        src_timestamp <- get_src_timestamp-                -- The file exists; we checked in getRootSummary above.-                -- If it gets removed subsequently, then this-                -- getModificationUTCTime may fail, but that's the right-                -- behaviour.--                -- return the cached summary if the source didn't change-        checkSummaryTimestamp-            hsc_env dflags obj_allowed NotBoot (new_summary src_fn)-            old_summary location src_timestamp--   | otherwise-   = do src_timestamp <- get_src_timestamp-        new_summary src_fn src_timestamp-  where-    get_src_timestamp = case maybe_buf of-                           Just (_,t) -> return t-                           Nothing    -> liftIO $ getModificationUTCTime src_fn-                        -- getModificationUTCTime may fail--    new_summary src_fn src_timestamp = runExceptT $ do-        preimps@PreprocessedImports {..}-            <- getPreprocessedImports hsc_env src_fn mb_phase maybe_buf---        -- Make a ModLocation for this file-        location <- liftIO $ mkHomeModLocation (hsc_dflags hsc_env) pi_mod_name src_fn--        -- Tell the Finder cache where it is, so that subsequent calls-        -- to findModule will find it, even if it's not on any search path-        mod <- liftIO $ addHomeModuleToFinder hsc_env pi_mod_name location--        liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary-            { nms_src_fn = src_fn-            , nms_src_timestamp = src_timestamp-            , nms_is_boot = NotBoot-            , nms_hsc_src =-                if isHaskellSigFilename src_fn-                   then HsigFile-                   else HsSrcFile-            , nms_location = location-            , nms_mod = mod-            , nms_obj_allowed = obj_allowed-            , nms_preimps = preimps-            }--findSummaryBySourceFile :: [ExtendedModSummary] -> FilePath -> Maybe ExtendedModSummary-findSummaryBySourceFile summaries file = case-    [ ms-    | ms <- summaries-    , HsSrcFile <- [ms_hsc_src $ emsModSummary ms]-    , let derived_file = ml_hs_file $ ms_location $ emsModSummary ms-    , expectJust "findSummaryBySourceFile" derived_file == file-    ]-  of-    [] -> Nothing-    (x:_) -> Just x--checkSummaryTimestamp-    :: HscEnv -> DynFlags -> Bool -> IsBootInterface-    -> (UTCTime -> IO (Either e ExtendedModSummary))-    -> ExtendedModSummary -> ModLocation -> UTCTime-    -> IO (Either e ExtendedModSummary)-checkSummaryTimestamp-  hsc_env dflags obj_allowed is_boot new_summary-  (ExtendedModSummary { emsModSummary = old_summary, emsInstantiatedUnits = bkp_deps})-  location src_timestamp-  | ms_hs_date old_summary == src_timestamp &&-      not (gopt Opt_ForceRecomp (hsc_dflags hsc_env)) = do-           -- update the object-file timestamp-           obj_timestamp <--             if backendProducesObject (backend (hsc_dflags hsc_env))-                 || obj_allowed -- bug #1205-                 then liftIO $ getObjTimestamp location is_boot-                 else return Nothing--           -- 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.-           _ <- addHomeModuleToFinder hsc_env-                  (moduleName (ms_mod old_summary)) location--           hi_timestamp <- maybeGetIfaceDate dflags location-           hie_timestamp <- modificationTimeIfExists (ml_hie_file location)--           return $ Right-             ( ExtendedModSummary { emsModSummary = old_summary-                     { ms_obj_date = obj_timestamp-                     , ms_iface_date = hi_timestamp-                     , ms_hie_date = hie_timestamp-                     }-                   , emsInstantiatedUnits = bkp_deps-                   }-             )--   | otherwise =-           -- source changed: re-summarise.-           new_summary src_timestamp---- Summarise a module, and pick up source and timestamp.-summariseModule-          :: HscEnv-          -> ModNodeMap ExtendedModSummary-          -- ^ Map of old summaries-          -> IsBootInterface    -- True <=> a {-# SOURCE #-} import-          -> Located ModuleName -- Imported module to be summarised-          -> Bool               -- object code allowed?-          -> Maybe (StringBuffer, UTCTime)-          -> [ModuleName]               -- Modules to exclude-          -> IO (Maybe (Either ErrorMessages ExtendedModSummary))      -- Its new summary--summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)-                obj_allowed maybe_buf excl_mods-  | wanted_mod `elem` excl_mods-  = return Nothing--  | Just old_summary <- modNodeMapLookup-      (GWIB { gwib_mod = wanted_mod, gwib_isBoot = is_boot })-      old_summary_map-  = do          -- Find its new timestamp; all the-                -- ModSummaries in the old map have valid ml_hs_files-        let location = ms_location $ emsModSummary old_summary-            src_fn = expectJust "summariseModule" (ml_hs_file location)--                -- check the modification time on the source file, and-                -- return the cached summary if it hasn't changed.  If the-                -- file has disappeared, we need to call the Finder again.-        case maybe_buf of-           Just (_,t) ->-               Just <$> check_timestamp old_summary location src_fn t-           Nothing    -> do-                m <- tryIO (getModificationUTCTime src_fn)-                case m of-                   Right t ->-                       Just <$> check_timestamp old_summary location src_fn t-                   Left e | isDoesNotExistError e -> find_it-                          | otherwise             -> ioError e--  | otherwise  = find_it-  where-    dflags = hsc_dflags hsc_env-    home_unit = hsc_home_unit hsc_env--    check_timestamp old_summary location src_fn =-        checkSummaryTimestamp-          hsc_env dflags obj_allowed is_boot-          (new_summary location (ms_mod $ emsModSummary old_summary) src_fn)-          old_summary location--    find_it = do-        found <- findImportedModule hsc_env wanted_mod Nothing-        case found of-             Found location mod-                | isJust (ml_hs_file location) ->-                        -- Home package-                         Just <$> just_found location mod--             _ -> return Nothing-                        -- Not found-                        -- (If it is TRULY not found at all, we'll-                        -- error when we actually try to compile)--    just_found location mod = do-                -- Adjust location to point to the hs-boot source file,-                -- hi file, object file, when is_boot says so-        let location' = case is_boot of-              IsBoot -> addBootSuffixLocn location-              NotBoot -> location-            src_fn = expectJust "summarise2" (ml_hs_file location')--                -- Check that it exists-                -- It might have been deleted since the Finder last found it-        maybe_t <- modificationTimeIfExists src_fn-        case maybe_t of-          Nothing -> return $ Left $ noHsFileErr loc src_fn-          Just t  -> new_summary location' mod src_fn t--    new_summary location mod src_fn src_timestamp-      = runExceptT $ do-        preimps@PreprocessedImports {..}-            <- getPreprocessedImports hsc_env src_fn Nothing maybe_buf--        -- NB: Despite the fact that is_boot is a top-level parameter, we-        -- don't actually know coming into this function what the HscSource-        -- of the module in question is.  This is because we may be processing-        -- this module because another module in the graph imported it: in this-        -- case, we know if it's a boot or not because of the {-# SOURCE #-}-        -- annotation, but we don't know if it's a signature or a regular-        -- module until we actually look it up on the filesystem.-        let hsc_src-              | is_boot == IsBoot = HsBootFile-              | isHaskellSigFilename src_fn = HsigFile-              | otherwise = HsSrcFile--        when (pi_mod_name /= wanted_mod) $-                throwE $ unitBag $ mkPlainMsgEnvelope pi_mod_name_loc $-                              text "File name does not match module name:"-                              $$ text "Saw:" <+> quotes (ppr pi_mod_name)-                              $$ text "Expected:" <+> quotes (ppr wanted_mod)--        when (hsc_src == HsigFile && isNothing (lookup pi_mod_name (homeUnitInstantiations home_unit))) $-            let suggested_instantiated_with =-                    hcat (punctuate comma $-                        [ ppr k <> text "=" <> ppr v-                        | (k,v) <- ((pi_mod_name, mkHoleModule pi_mod_name)-                                : homeUnitInstantiations home_unit)-                        ])-            in throwE $ unitBag $ mkPlainMsgEnvelope pi_mod_name_loc $-                text "Unexpected signature:" <+> quotes (ppr pi_mod_name)-                $$ if gopt Opt_BuildingCabalPackage dflags-                    then parens (text "Try adding" <+> quotes (ppr pi_mod_name)-                            <+> text "to the"-                            <+> quotes (text "signatures")-                            <+> text "field in your Cabal file.")-                    else parens (text "Try passing -instantiated-with=\"" <>-                                 suggested_instantiated_with <> text "\"" $$-                                text "replacing <" <> ppr pi_mod_name <> text "> as necessary.")--        liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary-            { nms_src_fn = src_fn-            , nms_src_timestamp = src_timestamp-            , nms_is_boot = is_boot-            , nms_hsc_src = hsc_src-            , nms_location = location-            , nms_mod = mod-            , nms_obj_allowed = obj_allowed-            , 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_timestamp :: UTCTime-      , nms_is_boot :: IsBootInterface-      , nms_hsc_src :: HscSource-      , nms_location :: ModLocation-      , nms_mod :: Module-      , nms_obj_allowed :: Bool-      , nms_preimps :: PreprocessedImports-      }--makeNewModSummary :: HscEnv -> MakeNewModSummary -> IO ExtendedModSummary-makeNewModSummary hsc_env MakeNewModSummary{..} = do-  let PreprocessedImports{..} = nms_preimps-  let dflags = hsc_dflags hsc_env--  -- when the user asks to load a source file by name, we only-  -- use an object file if -fobject-code is on.  See #1205.-  obj_timestamp <- liftIO $-      if backendProducesObject (backend dflags)-         || nms_obj_allowed -- bug #1205-          then getObjTimestamp nms_location nms_is_boot-          else return Nothing--  hi_timestamp <- maybeGetIfaceDate dflags 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 hsc_env pi_theimps--  return $ ExtendedModSummary-    { emsModSummary =-        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 =-            pi_theimps ++-            extra_sig_imports ++-            ((,) Nothing . noLoc <$> implicit_sigs)-        , ms_hs_date = nms_src_timestamp-        , ms_iface_date = hi_timestamp-        , ms_hie_date = hie_timestamp-        , ms_obj_date = obj_timestamp-        }-    , emsInstantiatedUnits = inst_deps-    }--getObjTimestamp :: ModLocation -> IsBootInterface -> IO (Maybe UTCTime)-getObjTimestamp location is_boot-  = case is_boot of-      IsBoot -> return Nothing-      NotBoot -> modificationTimeIfExists (ml_obj_file location)--data PreprocessedImports-  = PreprocessedImports-      { pi_local_dflags :: DynFlags-      , pi_srcimps  :: [(Maybe FastString, Located ModuleName)]-      , pi_theimps  :: [(Maybe FastString, 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 ErrorMessages 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 (fmap pprError) mimps)-  return PreprocessedImports {..}-----------------------------------------------------------------------------------                      Error messages---------------------------------------------------------------------------------- Defer and group warning, error and fatal messages so they will not get lost--- in the regular output.-withDeferredDiagnostics :: GhcMonad m => m a -> m a-withDeferredDiagnostics f = do-  dflags <- getDynFlags-  if not $ gopt Opt_DeferDiagnostics dflags-  then f-  else do-    warnings <- liftIO $ newIORef []-    errors <- liftIO $ newIORef []-    fatals <- liftIO $ newIORef []-    logger <- getLogger--    let deferDiagnostics _dflags !reason !severity !srcSpan !msg = do-          let action = putLogMsg logger dflags reason severity srcSpan msg-          case severity of-            SevWarning -> atomicModifyIORef' warnings $ \i -> (action: i, ())-            SevError -> atomicModifyIORef' errors $ \i -> (action: i, ())-            SevFatal -> atomicModifyIORef' fatals $ \i -> (action: i, ())-            _ -> action--        printDeferredDiagnostics = liftIO $-          forM_ [warnings, errors, fatals] $ \ref -> do-            -- This IORef can leak when the dflags leaks, so let us always-            -- reset the content.-            actions <- atomicModifyIORef' ref $ \i -> ([], i)-            sequence_ $ reverse actions--    MC.bracket-      (pushLogHookM (const deferDiagnostics))-      (\_ -> popLogHookM >> printDeferredDiagnostics)-      (\_ -> f)--noModError :: HscEnv -> SrcSpan -> ModuleName -> FindResult -> MsgEnvelope DecoratedSDoc--- ToDo: we don't have a proper line number for this error-noModError hsc_env loc wanted_mod err-  = mkPlainMsgEnvelope loc $ cannotFindModule hsc_env wanted_mod err--noHsFileErr :: SrcSpan -> String -> ErrorMessages-noHsFileErr loc path-  = unitBag $ mkPlainMsgEnvelope loc $ text "Can't find" <+> text path--moduleNotFoundErr :: ModuleName -> ErrorMessages-moduleNotFoundErr mod-  = unitBag $ mkPlainMsgEnvelope noSrcSpan $-        text "module" <+> quotes (ppr mod) <+> text "cannot be found locally"--multiRootsErr :: [ModSummary] -> IO ()-multiRootsErr [] = panic "multiRootsErr"-multiRootsErr summs@(summ1:_)-  = throwOneError $ mkPlainMsgEnvelope noSrcSpan $-        text "module" <+> quotes (ppr mod) <+>-        text "is defined in multiple files:" <+>-        sep (map text files)-  where-    mod = ms_mod summ1-    files = map (expectJust "checkDup" . ml_hs_file . ms_location) summs--keepGoingPruneErr :: [NodeKey] -> SDoc-keepGoingPruneErr ms-  = vcat (( text "-fkeep-going in use, removing the following" <+>-            text "dependencies and continuing:"):-          map (nest 6 . pprNodeKey) ms )--cyclicModuleErr :: [ModuleGraphNode] -> SDoc--- From a strongly connected component we find--- a single cycle to report-cyclicModuleErr mss-  = ASSERT( not (null mss) )-    case findCycle graph of-       Nothing   -> text "Unexpected non-cycle" <+> ppr mss-       Just path0 -> vcat-        [ case partitionNodes path0 of-            ([],_) -> text "Module imports form a cycle:"-            (_,[]) -> text "Module instantiations form a cycle:"-            _ -> text "Module imports and instantiations form a cycle:"-        , nest 2 (show_path path0)]-  where-    graph :: [Node NodeKey ModuleGraphNode]-    graph =-      [ DigraphNode-        { node_payload = ms-        , node_key = mkNodeKey ms-        , node_dependencies = get_deps ms-        }-      | ms <- mss-      ]--    get_deps :: ModuleGraphNode -> [NodeKey]-    get_deps = \case-      InstantiationNode iuid ->-        [ NodeKey_Module $ GWIB { gwib_mod = hole, gwib_isBoot = NotBoot }-        | hole <- uniqDSetToList $ instUnitHoles iuid-        ]-      ModuleNode (ExtendedModSummary ms bds) ->-        [ NodeKey_Module $ GWIB { gwib_mod = unLoc m, gwib_isBoot = IsBoot }-        | m <- ms_home_srcimps ms ] ++-        [ NodeKey_Module $ GWIB { gwib_mod = unLoc m, gwib_isBoot = NotBoot }-        | m <- ms_home_imps    ms ] ++-        [ NodeKey_Unit inst_unit-        | inst_unit <- bds-        ]--    show_path :: [ModuleGraphNode] -> SDoc-    show_path []  = panic "show_path"-    show_path [m] = ppr_node m <+> text "imports itself"-    show_path (m1:m2:ms) = vcat ( nest 6 (ppr_node m1)-                                : nest 6 (text "imports" <+> ppr_node m2)-                                : go ms )-       where-         go []     = [text "which imports" <+> ppr_node m1]-         go (m:ms) = (text "which imports" <+> ppr_node m) : go ms--    ppr_node :: ModuleGraphNode -> SDoc-    ppr_node (ModuleNode m) = text "module" <+> ppr_ms (emsModSummary m)-    ppr_node (InstantiationNode u) = text "instantiated unit" <+> ppr u--    ppr_ms :: ModSummary -> SDoc-    ppr_ms ms = quotes (ppr (moduleName (ms_mod ms))) <+>-                (parens (text (msHsFilePath ms)))+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE NondecreasingIndentation #-}+{-# LANGUAGE ScopedTypeVariables #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralisedNewtypeDeriving #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE RecordWildCards #-}++-- -----------------------------------------------------------------------------+--+-- (c) The University of Glasgow, 2011+--+-- This module implements multi-module compilation, and is used+-- by --make and GHCi.+--+-- -----------------------------------------------------------------------------+module GHC.Driver.Make (+        depanal, depanalE, depanalPartial, checkHomeUnitsClosed,+        load, loadWithCache, load', LoadHowMuch(..), ModIfaceCache(..), noIfaceCache, newIfaceCache,+        instantiationNodes,++        downsweep,++        topSortModuleGraph,++        ms_home_srcimps, ms_home_imps,++        summariseModule,+        SummariseResult(..),+        summariseFile,+        hscSourceToIsBoot,+        findExtraSigImports,+        implicitRequirementsShallow,++        noModError, cyclicModuleErr,+        SummaryNode,+        IsBootInterface(..), mkNodeKey,++        ModNodeKey, ModNodeKeyWithUid(..),+        ModNodeMap(..), emptyModNodeMap, modNodeMapElems, modNodeMapLookup, modNodeMapInsert, modNodeMapSingleton, modNodeMapUnionWith+        ) where++import GHC.Prelude+import GHC.Platform++import GHC.Tc.Utils.Backpack+import GHC.Tc.Utils.Monad  ( initIfaceCheck )++import GHC.Runtime.Interpreter+import qualified GHC.Linker.Loader as Linker+import GHC.Linker.Types++import GHC.Platform.Ways++import GHC.Driver.Config.Finder (initFinderOpts)+import GHC.Driver.Config.Parser (initParserOpts)+import GHC.Driver.Config.Diagnostic+import GHC.Driver.Phases+import GHC.Driver.Pipeline+import GHC.Driver.Session+import GHC.Driver.Backend+import GHC.Driver.Monad+import GHC.Driver.Env+import GHC.Driver.Errors+import GHC.Driver.Errors.Types+import GHC.Driver.Main++import GHC.Parser.Header++import GHC.Iface.Load      ( cannotFindModule )+import GHC.IfaceToCore     ( typecheckIface )+import GHC.Iface.Recomp    ( RecompileRequired(..), CompileReason(..) )++import GHC.Data.Bag        ( listToBag )+import GHC.Data.Graph.Directed+import GHC.Data.FastString+import GHC.Data.Maybe      ( expectJust )+import GHC.Data.StringBuffer+import qualified GHC.LanguageExtensions as LangExt++import GHC.Utils.Exception ( throwIO, SomeAsyncException )+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Utils.Panic.Plain+import GHC.Utils.Misc+import GHC.Utils.Error+import GHC.Utils.Logger+import GHC.Utils.Fingerprint+import GHC.Utils.TmpFs++import GHC.Types.Basic+import GHC.Types.Error+import GHC.Types.Target+import GHC.Types.SourceFile+import GHC.Types.SourceError+import GHC.Types.SrcLoc+import GHC.Types.Unique.FM+import GHC.Types.PkgQual++import GHC.Unit+import GHC.Unit.Env+import GHC.Unit.Finder+import GHC.Unit.Module.ModSummary+import GHC.Unit.Module.ModIface+import GHC.Unit.Module.Graph+import GHC.Unit.Home.ModInfo+import GHC.Unit.Module.ModDetails++import Data.Either ( rights, partitionEithers, lefts )+import qualified Data.Map as Map+import qualified Data.Set as Set++import Control.Concurrent ( newQSem, waitQSem, signalQSem, ThreadId, killThread, forkIOWithUnmask )+import qualified GHC.Conc as CC+import Control.Concurrent.MVar+import Control.Monad+import Control.Monad.Trans.Except ( ExceptT(..), runExceptT, throwE )+import qualified Control.Monad.Catch as MC+import Data.IORef+import Data.Maybe+import Data.Time+import Data.Bifunctor (first)+import System.Directory+import System.FilePath+import System.IO        ( fixIO )++import GHC.Conc ( getNumProcessors, getNumCapabilities, setNumCapabilities )+import Control.Monad.IO.Class+import Control.Monad.Trans.Reader+import GHC.Driver.Pipeline.LogQueue+import qualified Data.Map.Strict as M+import GHC.Types.TypeEnv+import Control.Monad.Trans.State.Lazy+import Control.Monad.Trans.Class+import GHC.Driver.Env.KnotVars+import Control.Concurrent.STM+import Control.Monad.Trans.Maybe+import GHC.Runtime.Loader+import GHC.Rename.Names+import GHC.Utils.Constants++-- -----------------------------------------------------------------------------+-- Loading the program++-- | Perform a dependency analysis starting from the current targets+-- and update the session with the new module graph.+--+-- Dependency analysis entails parsing the @import@ directives and may+-- therefore require running certain preprocessors.+--+-- Note that each 'ModSummary' in the module graph caches its 'DynFlags'.+-- These 'DynFlags' are determined by the /current/ session 'DynFlags' and the+-- @OPTIONS@ and @LANGUAGE@ pragmas of the parsed module.  Thus if you want+-- changes to the 'DynFlags' to take effect you need to call this function+-- again.+-- In case of errors, just throw them.+--+depanal :: GhcMonad m =>+           [ModuleName]  -- ^ excluded modules+        -> Bool          -- ^ allow duplicate roots+        -> m ModuleGraph+depanal excluded_mods allow_dup_roots = do+    (errs, mod_graph) <- depanalE excluded_mods allow_dup_roots+    if isEmptyMessages errs+      then pure mod_graph+      else throwErrors (fmap GhcDriverMessage errs)++-- | Perform dependency analysis like in 'depanal'.+-- In case of errors, the errors and an empty module graph are returned.+depanalE :: GhcMonad m =>     -- New for #17459+            [ModuleName]      -- ^ excluded modules+            -> Bool           -- ^ allow duplicate roots+            -> m (DriverMessages, ModuleGraph)+depanalE excluded_mods allow_dup_roots = do+    hsc_env <- getSession+    (errs, mod_graph) <- depanalPartial excluded_mods allow_dup_roots+    if isEmptyMessages errs+      then do+        hsc_env <- getSession+        let one_unit_messages get_mod_errs k hue = do+              errs <- get_mod_errs+              unknown_module_err <- warnUnknownModules (hscSetActiveUnitId k hsc_env) (homeUnitEnv_dflags hue) mod_graph++              let unused_home_mod_err = warnMissingHomeModules (homeUnitEnv_dflags hue) (hsc_targets hsc_env) mod_graph+                  unused_pkg_err = warnUnusedPackages (homeUnitEnv_units hue) (homeUnitEnv_dflags hue) mod_graph+++              return $ errs `unionMessages` unused_home_mod_err+                          `unionMessages` unused_pkg_err+                          `unionMessages` unknown_module_err++        all_errs <- liftIO $ unitEnv_foldWithKey one_unit_messages (return emptyMessages) (hsc_HUG hsc_env)+        logDiagnostics (GhcDriverMessage <$> all_errs)+        setSession hsc_env { hsc_mod_graph = mod_graph }+        pure (emptyMessages, mod_graph)+      else do+        -- We don't have a complete module dependency graph,+        -- The graph may be disconnected and is unusable.+        setSession hsc_env { hsc_mod_graph = emptyMG }+        pure (errs, emptyMG)+++-- | Perform dependency analysis like 'depanal' but return a partial module+-- graph even in the face of problems with some modules.+--+-- Modules which have parse errors in the module header, failing+-- preprocessors or other issues preventing them from being summarised will+-- simply be absent from the returned module graph.+--+-- Unlike 'depanal' this function will not update 'hsc_mod_graph' with the+-- new module graph.+depanalPartial+    :: GhcMonad m+    => [ModuleName]  -- ^ excluded modules+    -> Bool          -- ^ allow duplicate roots+    -> m (DriverMessages, ModuleGraph)+    -- ^ possibly empty 'Bag' of errors and a module graph.+depanalPartial excluded_mods allow_dup_roots = do+  hsc_env <- getSession+  let+         targets = hsc_targets hsc_env+         old_graph = hsc_mod_graph hsc_env+         logger  = hsc_logger hsc_env++  withTiming logger (text "Chasing dependencies") (const ()) $ do+    liftIO $ debugTraceMsg logger 2 (hcat [+              text "Chasing modules from: ",+              hcat (punctuate comma (map pprTarget targets))])++    -- Home package modules may have been moved or deleted, and new+    -- source files may have appeared in the home package that shadow+    -- external package modules, so we have to discard the existing+    -- cached finder data.+    liftIO $ flushFinderCaches (hsc_FC hsc_env) (hsc_unit_env hsc_env)++    (errs, graph_nodes) <- liftIO $ downsweep+      hsc_env (mgModSummaries old_graph)+      excluded_mods allow_dup_roots+    let+      mod_graph = mkModuleGraph graph_nodes+    return (unionManyMessages errs, mod_graph)++-- | Collect the instantiations of dependencies to create 'InstantiationNode' work graph nodes.+-- These are used to represent the type checking that is done after+-- all the free holes (sigs in current package) relevant to that instantiation+-- are compiled. This is necessary to catch some instantiation errors.+--+-- In the future, perhaps more of the work of instantiation could be moved here,+-- instead of shoved in with the module compilation nodes. That could simplify+-- backpack, and maybe hs-boot too.+instantiationNodes :: UnitId -> UnitState -> [ModuleGraphNode]+instantiationNodes uid unit_state = InstantiationNode uid <$> iuids_to_check+  where+    iuids_to_check :: [InstantiatedUnit]+    iuids_to_check =+      nubSort $ concatMap (goUnitId . fst) (explicitUnits unit_state)+     where+      goUnitId uid =+        [ recur+        | VirtUnit indef <- [uid]+        , inst <- instUnitInsts indef+        , recur <- (indef :) $ goUnitId $ moduleUnit $ snd inst+        ]++-- The linking plan for each module. If we need to do linking for a home unit+-- then this function returns a graph node which depends on all the modules in the home unit.++-- At the moment nothing can depend on these LinkNodes.+linkNodes :: [ModuleGraphNode] -> UnitId -> HomeUnitEnv -> Maybe (Either (Messages DriverMessage) ModuleGraphNode)+linkNodes summaries uid hue =+  let dflags = homeUnitEnv_dflags hue+      ofile = outputFile_ dflags++      unit_nodes :: [NodeKey]+      unit_nodes = map mkNodeKey (filter ((== uid) . moduleGraphNodeUnitId) summaries)+  -- Issue a warning for the confusing case where the user+  -- said '-o foo' but we're not going to do any linking.+  -- We attempt linking if either (a) one of the modules is+  -- called Main, or (b) the user said -no-hs-main, indicating+  -- that main() is going to come from somewhere else.+  --+      no_hs_main = gopt Opt_NoHsMain dflags++      main_sum = any (== NodeKey_Module (ModNodeKeyWithUid (GWIB (mainModuleNameIs dflags) NotBoot) uid)) unit_nodes++      do_linking =  main_sum || no_hs_main || ghcLink dflags == LinkDynLib || ghcLink dflags == LinkStaticLib++  in if | ghcLink dflags == LinkBinary && isJust ofile && not do_linking ->+            Just (Left $ singleMessage $ mkPlainErrorMsgEnvelope noSrcSpan (DriverRedirectedNoMain $ mainModuleNameIs dflags))+        -- This should be an error, not a warning (#10895).+        | do_linking -> Just (Right (LinkNode unit_nodes uid))+        | otherwise  -> Nothing++-- Note [Missing home modules]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Sometimes user doesn't want GHC to pick up modules, not explicitly listed+-- in a command line. For example, cabal may want to enable this warning+-- when building a library, so that GHC warns user about modules, not listed+-- neither in `exposed-modules`, nor in `other-modules`.+--+-- Here "home module" means a module, that doesn't come from an other package.+--+-- For example, if GHC is invoked with modules "A" and "B" as targets,+-- but "A" imports some other module "C", then GHC will issue a warning+-- about module "C" not being listed in a command line.+--+-- The warning in enabled by `-Wmissing-home-modules`. See #13129+warnMissingHomeModules ::  DynFlags -> [Target] -> ModuleGraph -> DriverMessages+warnMissingHomeModules dflags targets mod_graph =+    if null missing+      then emptyMessages+      else warn+  where+    diag_opts = initDiagOpts dflags++    is_known_module mod = any (is_my_target mod) targets++    -- We need to be careful to handle the case where (possibly+    -- path-qualified) filenames (aka 'TargetFile') rather than module+    -- names are being passed on the GHC command-line.+    --+    -- For instance, `ghc --make src-exe/Main.hs` and+    -- `ghc --make -isrc-exe Main` are supposed to be equivalent.+    -- Note also that we can't always infer the associated module name+    -- directly from the filename argument.  See #13727.+    is_my_target mod target =+      let tuid = targetUnitId target+      in case targetId target of+          TargetModule name+            -> moduleName (ms_mod mod) == name+                && tuid == ms_unitid mod+          TargetFile target_file _+            | Just mod_file <- ml_hs_file (ms_location mod)+            ->+             target_file == mod_file ||++             --  Don't warn on B.hs-boot if B.hs is specified (#16551)+             addBootSuffix target_file == mod_file ||++             --  We can get a file target even if a module name was+             --  originally specified in a command line because it can+             --  be converted in guessTarget (by appending .hs/.lhs).+             --  So let's convert it back and compare with module name+             mkModuleName (fst $ splitExtension target_file)+              == moduleName (ms_mod mod)+          _ -> False++    missing = map (moduleName . ms_mod) $+      filter (not . is_known_module) $+        (filter (\ms -> ms_unitid ms == homeUnitId_ dflags)+                (mgModSummaries mod_graph))++    warn = singleMessage $ mkPlainMsgEnvelope diag_opts noSrcSpan+                         $ DriverMissingHomeModules missing (checkBuildingCabalPackage dflags)++-- Check that any modules we want to reexport or hide are actually in the package.+warnUnknownModules :: HscEnv -> DynFlags -> ModuleGraph -> IO DriverMessages+warnUnknownModules hsc_env dflags mod_graph = do+  reexported_warns <- filterM check_reexport (Set.toList reexported_mods)+  return $ final_msgs hidden_warns reexported_warns+  where+    diag_opts = initDiagOpts dflags++    unit_mods = Set.fromList (map ms_mod_name+                  (filter (\ms -> ms_unitid ms == homeUnitId_ dflags)+                       (mgModSummaries mod_graph)))++    reexported_mods = reexportedModules dflags+    hidden_mods     = hiddenModules dflags++    hidden_warns = hidden_mods `Set.difference` unit_mods++    lookupModule mn = findImportedModule hsc_env mn NoPkgQual++    check_reexport mn = do+      fr <- lookupModule mn+      case fr of+        Found _ m -> return (moduleUnitId m == homeUnitId_ dflags)+        _ -> return True+++    warn flag mod = singleMessage $ mkPlainMsgEnvelope diag_opts noSrcSpan+                         $ flag mod++    final_msgs hidden_warns reexported_warns+          =+        unionManyMessages $+          [warn DriverUnknownHiddenModules (Set.toList hidden_warns) | not (Set.null hidden_warns)]+          ++ [warn DriverUnknownReexportedModules reexported_warns | not (null reexported_warns)]++-- | Describes which modules of the module graph need to be loaded.+data LoadHowMuch+   = LoadAllTargets+     -- ^ Load all targets and its dependencies.+   | LoadUpTo HomeUnitModule+     -- ^ Load only the given module and its dependencies.+   | LoadDependenciesOf HomeUnitModule+     -- ^ Load only the dependencies of the given module, but not the module+     -- itself.++{-+Note [Caching HomeModInfo]+~~~~~~~~~~~~~~~~~~~~~~~~~~++API clients who call `load` like to cache the HomeModInfo in memory between+calls to this function. In the old days, this cache was a simple MVar which stored+a HomePackageTable. This was insufficient, as the interface files for boot modules+were not recorded in the cache. In the less old days, the cache was returned at the+end of load, and supplied at the start of load, however, this was not sufficient+because it didn't account for the possibility of exceptions such as SIGINT (#20780).++So now, in the current day, we have this ModIfaceCache abstraction which+can incrementally be updated during the process of upsweep. This allows us+to store interface files for boot modules in an exception-safe way.++When the final version of an interface file is completed then it is placed into+the cache. The contents of the cache is retrieved, and the cache cleared, by iface_clearCache.++Note that because we only store the ModIface and Linkable in the ModIfaceCache,+hydration and rehydration is totally irrelevant, and we just store the CachedIface as+soon as it is completed.++-}+++-- Abstract interface to a cache of HomeModInfo+-- See Note [Caching HomeModInfo]+data ModIfaceCache = ModIfaceCache { iface_clearCache :: IO [CachedIface]+                                   , iface_addToCache :: CachedIface -> IO () }++addHmiToCache :: ModIfaceCache -> HomeModInfo -> IO ()+addHmiToCache c (HomeModInfo i _ l) = iface_addToCache c (CachedIface i l)++data CachedIface = CachedIface { cached_modiface :: !ModIface+                               , cached_linkable :: !(Maybe Linkable) }++noIfaceCache :: Maybe ModIfaceCache+noIfaceCache = Nothing++newIfaceCache :: IO ModIfaceCache+newIfaceCache = do+  ioref <- newIORef []+  return $+    ModIfaceCache+      { iface_clearCache = atomicModifyIORef' ioref (\c -> ([], c))+      , iface_addToCache = \hmi -> atomicModifyIORef' ioref (\c -> (hmi:c, ()))+      }+++++-- | Try to load the program.  See 'LoadHowMuch' for the different modes.+--+-- This function implements the core of GHC's @--make@ mode.  It preprocesses,+-- compiles and loads the specified modules, avoiding re-compilation wherever+-- possible.  Depending on the backend (see 'DynFlags.backend' field) compiling+-- and loading may result in files being created on disk.+--+-- Calls the 'defaultWarnErrLogger' after each compiling each module, whether+-- successful or not.+--+-- If errors are encountered during dependency analysis, the module `depanalE`+-- returns together with the errors an empty ModuleGraph.+-- After processing this empty ModuleGraph, the errors of depanalE are thrown.+-- All other errors are reported using the 'defaultWarnErrLogger'.++load :: GhcMonad f => LoadHowMuch -> f SuccessFlag+load how_much = loadWithCache noIfaceCache how_much++mkBatchMsg :: HscEnv -> Messager+mkBatchMsg hsc_env =+  if length (hsc_all_home_unit_ids hsc_env) > 1+    -- This also displays what unit each module is from.+    then batchMultiMsg+    else batchMsg+++loadWithCache :: GhcMonad m => Maybe ModIfaceCache -> LoadHowMuch -> m SuccessFlag+loadWithCache cache how_much = do+    (errs, mod_graph) <- depanalE [] False                        -- #17459+    msg <- mkBatchMsg <$> getSession+    success <- load' cache how_much (Just msg) mod_graph+    if isEmptyMessages errs+      then pure success+      else throwErrors (fmap GhcDriverMessage errs)++-- Note [Unused packages]+-- ~~~~~~~~~~~~~~~~~~~~~~+-- Cabal passes `--package-id` flag for each direct dependency. But GHC+-- loads them lazily, so when compilation is done, we have a list of all+-- actually loaded packages. All the packages, specified on command line,+-- but never loaded, are probably unused dependencies.++warnUnusedPackages :: UnitState -> DynFlags -> ModuleGraph -> DriverMessages+warnUnusedPackages us dflags mod_graph =+    let diag_opts = initDiagOpts dflags++    -- Only need non-source imports here because SOURCE imports are always HPT+        loadedPackages = concat $+          mapMaybe (\(fs, mn) -> lookupModulePackage us (unLoc mn) fs)+            $ concatMap ms_imps (+              filter (\ms -> homeUnitId_ dflags == ms_unitid ms) (mgModSummaries mod_graph))++        used_args = Set.fromList $ map unitId loadedPackages++        resolve (u,mflag) = do+                  -- The units which we depend on via the command line explicitly+                  flag <- mflag+                  -- Which we can find the UnitInfo for (should be all of them)+                  ui <- lookupUnit us u+                  -- Which are not explicitly used+                  guard (Set.notMember (unitId ui) used_args)+                  return (unitId ui, unitPackageName ui, unitPackageVersion ui, flag)++        unusedArgs = mapMaybe resolve (explicitUnits us)++        warn = singleMessage $ mkPlainMsgEnvelope diag_opts noSrcSpan (DriverUnusedPackages unusedArgs)++    in if null unusedArgs+        then emptyMessages+        else warn+++-- | A ModuleGraphNode which also has a hs-boot file, and the list of nodes on any+-- path from module to its boot file.+data ModuleGraphNodeWithBootFile+  = ModuleGraphNodeWithBootFile ModuleGraphNode [ModuleGraphNode]++instance Outputable ModuleGraphNodeWithBootFile where+  ppr (ModuleGraphNodeWithBootFile mgn deps) = text "ModeGraphNodeWithBootFile: " <+> ppr mgn $$ ppr deps++getNode :: ModuleGraphNodeWithBootFile -> ModuleGraphNode+getNode (ModuleGraphNodeWithBootFile mgn _) = mgn+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 ModuleGraphNodeWithBootFile]   -- A resolved cycle, linearised by hs-boot files+               | UnresolvedCycle [ModuleGraphNode] -- An actual cycle, which wasn't resolved by hs-boot files++instance Outputable BuildPlan where+  ppr (SingleModule mgn) = text "SingleModule" <> parens (ppr mgn)+  ppr (ResolvedCycle mgn)   = text "ResolvedCycle:" <+> ppr mgn+  ppr (UnresolvedCycle mgn) = text "UnresolvedCycle:" <+> ppr mgn+++-- Just used for an assertion+countMods :: BuildPlan -> Int+countMods (SingleModule _) = 1+countMods (ResolvedCycle ns) = length ns+countMods (UnresolvedCycle ns) = length ns++-- See Note [Upsweep] for a high-level description.+createBuildPlan :: ModuleGraph -> Maybe HomeUnitModule -> [BuildPlan]+createBuildPlan mod_graph maybe_top_mod =+    let -- Step 1: Compute SCCs without .hi-boot files, to find the cycles+        cycle_mod_graph = topSortModuleGraph True mod_graph maybe_top_mod++        -- Step 2: Reanalyse loops, with relevant boot modules, to solve the cycles.+        build_plan :: [BuildPlan]+        build_plan+          -- Fast path, if there are no boot modules just do a normal toposort+          | isEmptyModuleEnv boot_modules = collapseAcyclic $ topSortModuleGraph False mod_graph maybe_top_mod+          | otherwise = toBuildPlan cycle_mod_graph []++        toBuildPlan :: [SCC ModuleGraphNode] -> [ModuleGraphNode] -> [BuildPlan]+        toBuildPlan [] mgn = collapseAcyclic (topSortWithBoot mgn)+        toBuildPlan ((AcyclicSCC node):sccs) mgn = toBuildPlan sccs (node:mgn)+        -- Interesting case+        toBuildPlan ((CyclicSCC nodes):sccs) mgn =+          let acyclic = collapseAcyclic (topSortWithBoot mgn)+              -- Now perform another toposort but just with these nodes and relevant hs-boot files.+              -- The result should be acyclic, if it's not, then there's an unresolved cycle in the graph.+              mresolved_cycle = collapseSCC (topSortWithBoot nodes)+          in acyclic ++ [maybe (UnresolvedCycle nodes) ResolvedCycle mresolved_cycle] ++ toBuildPlan sccs []++        (mg, lookup_node) = moduleGraphNodes False (mgModSummaries' mod_graph)+        trans_deps_map = allReachable mg (mkNodeKey . node_payload)+        -- Compute the intermediate modules between a file and its hs-boot file.+        -- See Step 2a in Note [Upsweep]+        boot_path mn uid =+          map (summaryNodeSummary . expectJust "toNode" . lookup_node) $ Set.toList $+          -- Don't include the boot module itself+          Set.delete (NodeKey_Module (key IsBoot))  $+          -- Keep intermediate dependencies: as per Step 2a in Note [Upsweep], these are+          -- the transitive dependencies of the non-boot file which transitively depend+          -- on the boot file.+          Set.filter (\nk -> nodeKeyUnitId nk == uid  -- Cheap test+                              && (NodeKey_Module (key IsBoot)) `Set.member` expectJust "dep_on_boot" (M.lookup nk trans_deps_map)) $+          expectJust "not_boot_dep" (M.lookup (NodeKey_Module (key NotBoot)) trans_deps_map)+          where+            key ib = ModNodeKeyWithUid (GWIB mn ib) uid+++        -- An environment mapping a module to its hs-boot file and all nodes on the path between the two, if one exists+        boot_modules = mkModuleEnv+          [ (ms_mod ms, (m, boot_path (ms_mod_name ms) (ms_unitid ms))) | m@(ModuleNode _ ms) <- (mgModSummaries' mod_graph), isBootSummary ms == IsBoot]++        select_boot_modules :: [ModuleGraphNode] -> [ModuleGraphNode]+        select_boot_modules = mapMaybe (fmap fst . get_boot_module)++        get_boot_module :: (ModuleGraphNode -> Maybe (ModuleGraphNode, [ModuleGraphNode]))+        get_boot_module m = case m of ModuleNode _ ms | HsSrcFile <- ms_hsc_src ms -> lookupModuleEnv boot_modules (ms_mod ms); _ -> Nothing++        -- Any cycles should be resolved now+        collapseSCC :: [SCC ModuleGraphNode] -> Maybe [(Either ModuleGraphNode ModuleGraphNodeWithBootFile)]+        -- Must be at least two nodes, as we were in a cycle+        collapseSCC [AcyclicSCC node1, AcyclicSCC node2] = Just [toNodeWithBoot node1, toNodeWithBoot node2]+        collapseSCC (AcyclicSCC node : nodes) = (toNodeWithBoot node :) <$> collapseSCC nodes+        -- Cyclic+        collapseSCC _ = Nothing++        toNodeWithBoot :: (ModuleGraphNode -> Either ModuleGraphNode ModuleGraphNodeWithBootFile)+        toNodeWithBoot mn =+          case get_boot_module mn of+            -- The node doesn't have a boot file+            Nothing -> Left mn+            -- The node does have a boot file+            Just path -> Right (ModuleGraphNodeWithBootFile mn (snd path))++        -- The toposort and accumulation of acyclic modules is solely to pick-up+        -- hs-boot files which are **not** part of cycles.+        collapseAcyclic :: [SCC ModuleGraphNode] -> [BuildPlan]+        collapseAcyclic (AcyclicSCC node : nodes) = SingleModule node : collapseAcyclic nodes+        collapseAcyclic (CyclicSCC cy_nodes : nodes) = (UnresolvedCycle cy_nodes) : collapseAcyclic nodes+        collapseAcyclic [] = []++        topSortWithBoot nodes = topSortModules False (select_boot_modules nodes ++ nodes) Nothing+++  in++    assertPpr (sum (map countMods build_plan) == length (mgModSummaries' mod_graph))+              (vcat [text "Build plan missing nodes:", (text "PLAN:" <+> ppr (sum (map countMods build_plan))), (text "GRAPH:" <+> ppr (length (mgModSummaries' mod_graph )))])+              build_plan++-- | Generalized version of 'load' which also supports a custom+-- 'Messager' (for reporting progress) and 'ModuleGraph' (generally+-- produced by calling 'depanal'.+load' :: GhcMonad m => Maybe ModIfaceCache -> LoadHowMuch -> Maybe Messager -> ModuleGraph -> m SuccessFlag+load' mhmi_cache how_much mHscMessage mod_graph = do+    modifySession $ \hsc_env -> hsc_env { hsc_mod_graph = mod_graph }+    guessOutputFile+    hsc_env <- getSession++    let dflags = hsc_dflags hsc_env+    let logger = hsc_logger hsc_env+    let interp = hscInterp hsc_env++    -- The "bad" boot modules are the ones for which we have+    -- B.hs-boot in the module graph, but no B.hs+    -- The downsweep should have ensured this does not happen+    -- (see msDeps)+    let all_home_mods =+          Set.fromList [ Module (ms_unitid s) (ms_mod_name s)+                    | s <- mgModSummaries mod_graph, isBootSummary s == NotBoot]+    -- TODO: Figure out what the correct form of this assert is. It's violated+    -- when you have HsBootMerge nodes in the graph: then you'll have hs-boot+    -- files without corresponding hs files.+    --  bad_boot_mods = [s        | s <- mod_graph, isBootSummary s,+    --                              not (ms_mod_name s `elem` all_home_mods)]+    -- assert (null bad_boot_mods ) return ()++    -- check that the module given in HowMuch actually exists, otherwise+    -- topSortModuleGraph will bomb later.+    let checkHowMuch (LoadUpTo m)           = checkMod m+        checkHowMuch (LoadDependenciesOf m) = checkMod m+        checkHowMuch _ = id++        checkMod m and_then+            | m `Set.member` all_home_mods = and_then+            | otherwise = do+                    liftIO $ errorMsg logger+                        (text "no such module:" <+> quotes (ppr (moduleUnit m) <> colon <> ppr (moduleName m)))+                    return Failed++    checkHowMuch how_much $ do++    -- mg2_with_srcimps drops the hi-boot nodes, returning a+    -- graph with cycles. It is just used for warning about unecessary source imports.+    let mg2_with_srcimps :: [SCC ModuleGraphNode]+        mg2_with_srcimps = topSortModuleGraph True mod_graph Nothing++    -- If we can determine that any of the {-# SOURCE #-} imports+    -- are definitely unnecessary, then emit a warning.+    warnUnnecessarySourceImports (filterToposortToModules mg2_with_srcimps)++    let maybe_top_mod = case how_much of+                          LoadUpTo m           -> Just m+                          LoadDependenciesOf m -> Just m+                          _                    -> Nothing++        build_plan = createBuildPlan mod_graph maybe_top_mod+++    cache <- liftIO $ maybe (return []) iface_clearCache mhmi_cache+    let+        -- prune the HPT so everything is not retained when doing an+        -- upsweep.+        !pruned_cache = pruneCache cache+                            (flattenSCCs (filterToposortToModules  mg2_with_srcimps))+++    -- before we unload anything, make sure we don't leave an old+    -- interactive context around pointing to dead bindings.  Also,+    -- write an empty HPT to allow the old HPT to be GC'd.++    let pruneHomeUnitEnv hme = hme { homeUnitEnv_hpt = emptyHomePackageTable }+    setSession $ discardIC $ hscUpdateHUG (unitEnv_map pruneHomeUnitEnv) hsc_env++    -- Unload everything+    liftIO $ unload interp hsc_env++    liftIO $ debugTraceMsg logger 2 (hang (text "Ready for upsweep")+                                    2 (ppr build_plan))++    n_jobs <- case parMakeCount (hsc_dflags hsc_env) of+                    Nothing -> liftIO getNumProcessors+                    Just n  -> return n++    setSession $ hscUpdateHUG (unitEnv_map pruneHomeUnitEnv) hsc_env+    hsc_env <- getSession+    (upsweep_ok, hsc_env1) <- withDeferredDiagnostics $+      liftIO $ upsweep n_jobs hsc_env mhmi_cache mHscMessage (toCache pruned_cache) build_plan+    setSession hsc_env1+    case upsweep_ok of+      Failed -> loadFinish upsweep_ok+      Succeeded -> do+          liftIO $ debugTraceMsg logger 2 (text "Upsweep completely successful.")+          -- Clean up after ourselves+          liftIO $ cleanCurrentModuleTempFilesMaybe logger (hsc_tmpfs hsc_env1) dflags+          loadFinish upsweep_ok++++-- | Finish up after a load.+loadFinish :: GhcMonad m => SuccessFlag -> m SuccessFlag+-- Empty the interactive context and set the module context to the topmost+-- newly loaded module, or the Prelude if none were loaded.+loadFinish all_ok+  = do modifySession discardIC+       return all_ok+++-- | If there is no -o option, guess the name of target executable+-- by using top-level source file name as a base.+guessOutputFile :: GhcMonad m => m ()+guessOutputFile = modifySession $ \env ->+    -- Force mod_graph to avoid leaking env+    let !mod_graph = hsc_mod_graph env+        new_home_graph =+          flip unitEnv_map (hsc_HUG env) $ \hue ->+            let dflags = homeUnitEnv_dflags hue+                platform = targetPlatform dflags+                mainModuleSrcPath :: Maybe String+                mainModuleSrcPath = do+                  ms <- mgLookupModule mod_graph (mainModIs hue)+                  ml_hs_file (ms_location ms)+                name = fmap dropExtension mainModuleSrcPath++                -- MP: This exception is quite sensitive to being forced, if you+                -- force it here then the error message is different because it gets+                -- caught by a different error handler than the test (T9930fail) expects.+                -- Putting an exception into DynFlags is probably not a great design but+                -- I'll write this comment rather than more eagerly force the exception.+                name_exe = do+                  -- we must add the .exe extension unconditionally here, otherwise+                  -- when name has an extension of its own, the .exe extension will+                 -- not be added by GHC.Driver.Pipeline.exeFileName.  See #2248+                 !name' <- if platformOS platform == OSMinGW32+                           then fmap (<.> "exe") name+                           else name+                 mainModuleSrcPath' <- mainModuleSrcPath+                 -- #9930: don't clobber input files (unless they ask for it)+                 if name' == mainModuleSrcPath'+                   then throwGhcException . UsageError $+                        "default output name would overwrite the input file; " +++                        "must specify -o explicitly"+                   else Just name'+            in+              case outputFile_ dflags of+                Just _ -> hue+                Nothing -> hue {homeUnitEnv_dflags = dflags { outputFile_ = name_exe } }+    in env { hsc_unit_env = (hsc_unit_env env) { ue_home_unit_graph = new_home_graph } }++-- -----------------------------------------------------------------------------+--+-- | Prune the HomePackageTable+--+-- Before doing an upsweep, we can throw away:+--+--   - all ModDetails, all linked code+--   - all unlinked code that is out of date with respect to+--     the source file+--+-- This is VERY IMPORTANT otherwise we'll end up requiring 2x the+-- space at the end of the upsweep, because the topmost ModDetails of the+-- old HPT holds on to the entire type environment from the previous+-- compilation.+-- Note [GHC Heap Invariants]+pruneCache :: [CachedIface]+                      -> [ModSummary]+                      -> [HomeModInfo]+pruneCache hpt summ+  = strictMap prune hpt+  where prune (CachedIface { cached_modiface = iface+                           , cached_linkable = linkable+                           }) = HomeModInfo iface emptyModDetails linkable'+          where+           modl = moduleName (mi_module iface)+           linkable'+                | Just ms <- lookupUFM ms_map modl+                , mi_src_hash iface /= ms_hs_hash ms+                = Nothing+                | otherwise+                = linkable++        ms_map = listToUFM [(ms_mod_name ms, ms) | ms <- summ]++-- ---------------------------------------------------------------------------+--+-- | Unloading+unload :: Interp -> HscEnv -> IO ()+unload interp hsc_env+  = case ghcLink (hsc_dflags hsc_env) of+        LinkInMemory -> Linker.unload interp hsc_env []+        _other -> return ()+++{- Parallel Upsweep++The parallel upsweep attempts to concurrently compile the modules in the+compilation graph using multiple Haskell threads.++The Algorithm++* The list of `MakeAction`s are created by `interpretBuildPlan`. A `MakeAction` is+a pair of an `IO a` action and a `MVar a`, where to place the result.+  The list is sorted topologically, so can be executed in order without fear of+  blocking.+* runPipelines takes this list and eventually passes it to runLoop which executes+  each action and places the result into the right MVar.+* The amount of parrelism 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 overal 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))++instance Functor ResultVar where+  fmap f (ResultVar g var) = ResultVar (f . g) var++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 BuildLoopState = BuildLoopState { buildDep :: M.Map NodeKey (SDoc, ResultVar (Maybe HomeModInfo))+                                          -- The current way to build a specific TNodeKey, without cycles this just points to+                                          -- the appropiate result of compiling a module  but with+                                          -- cycles there can be additional indirection and can point to the result of typechecking a loop+                                     , nNODE :: Int+                                     , hug_var :: MVar HomeUnitGraph+                                     -- A global variable which is incrementally updated with the result+                                     -- of compiling modules.+                                     }++nodeId :: BuildM Int+nodeId = do+  n <- gets nNODE+  modify (\m -> m { nNODE = n + 1 })+  return n++setModulePipeline :: NodeKey -> SDoc -> ResultVar (Maybe HomeModInfo) -> BuildM ()+setModulePipeline mgn doc wrapped_pipeline = do+  modify (\m -> m { buildDep = M.insert mgn (doc, wrapped_pipeline) (buildDep m) })++getBuildMap :: BuildM (M.Map+                    NodeKey (SDoc, ResultVar (Maybe HomeModInfo)))+getBuildMap = gets buildDep++type BuildM a = StateT BuildLoopState IO a+++-- | Abstraction over the operations of a semaphore which allows usage with the+--  -j1 case+data AbstractSem = AbstractSem { acquireSem :: IO ()+                               , releaseSem :: IO () }++withAbstractSem :: AbstractSem -> IO b -> IO b+withAbstractSem sem = MC.bracket_ (acquireSem sem) (releaseSem sem)++-- | Environment used when compiling a module+data MakeEnv = MakeEnv { hsc_env :: !HscEnv -- The basic HscEnv which will be augmented for each module+                       , compile_sem :: !AbstractSem+                       -- Modify the environment for module k, with the supplied logger modification function.+                       -- For -j1, this wrapper doesn't do anything+                       -- For -jn, the wrapper initialised a log queue and then modifies the logger to pipe its output+                       --          into the log queue.+                       , withLogger :: forall a . Int -> ((Logger -> Logger) -> IO a) -> IO a+                       , env_messager :: !(Maybe Messager)+                       }++type RunMakeM a = ReaderT MakeEnv (MaybeT IO) a++-- | Given the build plan, creates a graph which indicates where each NodeKey should+-- get its direct dependencies from. This might not be the corresponding build action+-- if the module participates in a loop. This step also labels each node with a number for the output.+-- See Note [Upsweep] for a high-level description.+interpretBuildPlan :: HomeUnitGraph+                   -> Maybe ModIfaceCache+                   -> M.Map ModNodeKeyWithUid HomeModInfo+                   -> [BuildPlan]+                   -> IO ( Maybe [ModuleGraphNode] -- Is there an unresolved cycle+                         , [MakeAction] -- Actions we need to run in order to build everything+                         , IO [Maybe (Maybe HomeModInfo)]) -- An action to query to get all the built modules at the end.+interpretBuildPlan hug mhmi_cache old_hpt plan = do+  hug_var <- newMVar hug+  ((mcycle, plans), build_map) <- runStateT (buildLoop plan) (BuildLoopState M.empty 1 hug_var)+  let wait = collect_results (buildDep build_map)+  return (mcycle, plans, wait)++  where+    collect_results build_map =+      sequence (map (\(_doc, res_var) -> collect_result res_var) (M.elems build_map))+      where+        collect_result res_var = runMaybeT (waitResult res_var)++    n_mods = sum (map countMods plan)++    buildLoop :: [BuildPlan]+              -> BuildM (Maybe [ModuleGraphNode], [MakeAction])+    -- Build the abstract pipeline which we can execute+    -- Building finished+    buildLoop []           = return (Nothing, [])+    buildLoop (plan:plans) =+      case plan of+        -- If there was no cycle, then typecheckLoop is not necessary+        SingleModule m -> do+          (one_plan, _) <- buildSingleModule Nothing 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 [ModuleGraphNode]  -- Modules we need to rehydrate before compiling this module+                      -> ModuleGraphNode          -- The node we are compiling+                      -> BuildM (MakeAction, ResultVar (Maybe HomeModInfo))+    buildSingleModule rehydrate_nodes mod = do+      mod_idx <- nodeId+      home_mod_map <- getBuildMap+      hug_var <- gets hug_var+      -- 1. Get the transitive dependencies of this module, by looking up in the dependency map+      let direct_deps = nodeDependencies False mod+          doc_build_deps = map (expectJust "dep_map" . flip M.lookup home_mod_map) direct_deps+          build_deps = map snd doc_build_deps+      -- 2. Set the default way to build this node, not in a loop here+      let build_action = withCurrentUnit (moduleGraphNodeUnitId mod) $+            case mod of+              InstantiationNode uid iu ->+                const Nothing <$> executeInstantiationNode mod_idx n_mods (wait_deps_hug hug_var build_deps) uid iu+              ModuleNode _build_deps ms -> do+                  let !old_hmi = M.lookup (msKey ms) old_hpt+                      rehydrate_mods = mapMaybe moduleGraphNodeModule <$> rehydrate_nodes+                  hmi <- executeCompileNode mod_idx n_mods old_hmi (wait_deps_hug hug_var build_deps) rehydrate_mods ms++                  -- Write the HMI to an external cache (if one exists)+                  -- See Note [Caching HomeModInfo]+                  liftIO $ forM mhmi_cache $ \hmi_cache -> addHmiToCache hmi_cache hmi+                  -- This global MVar is incrementally modified in order to avoid having to+                  -- recreate the HPT before compiling each module which leads to a quadratic amount of work.+                  hsc_env <- asks hsc_env+                  hmi' <- liftIO $ modifyMVar hug_var (\hug -> do+                    let new_hpt = addHomeModInfoToHug hmi hug+                        new_hsc = setHUG new_hpt hsc_env+                    maybeRehydrateAfter hmi new_hsc rehydrate_mods+                      )+                  return (Just hmi')+              LinkNode _nks uid -> do+                  executeLinkNode (wait_deps_hug hug_var build_deps) (mod_idx, n_mods) uid direct_deps+                  return Nothing+++      res_var <- liftIO newEmptyMVar+      let result_var = mkResultVar res_var+      setModulePipeline (mkNodeKey mod) (text "N") result_var+      return $ (MakeAction build_action res_var, result_var)+++    buildOneLoopyModule ::  ModuleGraphNodeWithBootFile -> BuildM (MakeAction, (ResultVar (Maybe HomeModInfo)))+    buildOneLoopyModule (ModuleGraphNodeWithBootFile mn deps) =+      buildSingleModule (Just deps) mn++    buildModuleLoop :: [Either ModuleGraphNode ModuleGraphNodeWithBootFile] ->  BuildM [MakeAction]+    buildModuleLoop ms = do+      (build_modules, wait_modules) <- mapAndUnzipM (either (buildSingleModule Nothing) buildOneLoopyModule) ms+      res_var <- liftIO newEmptyMVar+      let loop_action = wait_deps wait_modules+      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.+      let update_module_pipeline (m, i) = setModulePipeline (NodeKey_Module m) (text "T") (fanout i)++      let ms_i = zip (mapMaybe (fmap msKey . moduleGraphNodeModSum . either id getNode) ms) [0..]+      mapM update_module_pipeline ms_i+      return $ build_modules ++ [MakeAction loop_action res_var]+++withCurrentUnit :: UnitId -> RunMakeM a -> RunMakeM a+withCurrentUnit uid = do+  local (\env -> env { hsc_env = hscSetActiveUnitId uid (hsc_env env)})+++upsweep+    :: Int -- ^ The number of workers we wish to run in parallel+    -> HscEnv -- ^ The base HscEnv, which is augmented for each module+    -> Maybe ModIfaceCache -- ^ A cache to incrementally write final interface files to+    -> Maybe Messager+    -> M.Map ModNodeKeyWithUid HomeModInfo+    -> [BuildPlan]+    -> IO (SuccessFlag, HscEnv)+upsweep n_jobs hsc_env hmi_cache mHscMessage old_hpt build_plan = do+    (cycle, pipelines, collect_result) <- interpretBuildPlan (hsc_HUG hsc_env) hmi_cache old_hpt build_plan+    runPipelines n_jobs hsc_env mHscMessage pipelines+    res <- collect_result++    let completed = [m | Just (Just m) <- res]+    let hsc_env' = addDepsToHscEnv completed hsc_env++    -- Handle any cycle in the original compilation graph and return the result+    -- of the upsweep.+    case cycle of+        Just mss -> do+          let logger = hsc_logger hsc_env+          liftIO $ fatalErrorMsg logger (cyclicModuleErr mss)+          return (Failed, hsc_env)+        Nothing  -> do+          let success_flag = successIf (all isJust res)+          return (success_flag, hsc_env')++toCache :: [HomeModInfo] -> M.Map (ModNodeKeyWithUid) HomeModInfo+toCache hmis = M.fromList ([(miKey $ hm_iface hmi, hmi) | hmi <- hmis])++miKey :: ModIface -> ModNodeKeyWithUid+miKey hmi = ModNodeKeyWithUid (mi_mnwib hmi) ((toUnitId $ moduleUnit (mi_module hmi)))++upsweep_inst :: HscEnv+             -> Maybe Messager+             -> Int  -- index of module+             -> Int  -- total number of modules+             -> UnitId+             -> InstantiatedUnit+             -> IO ()+upsweep_inst hsc_env mHscMessage mod_index nmods uid iuid = do+        case mHscMessage of+            Just hscMessage -> hscMessage hsc_env (mod_index, nmods) (NeedsRecompile MustCompile) (InstantiationNode uid iuid)+            Nothing -> return ()+        runHsc hsc_env $ ioMsgMaybe $ hoistTcRnMessage $ tcRnCheckUnit hsc_env $ VirtUnit iuid+        pure ()++-- | Compile a single module.  Always produce a Linkable for it if+-- successful.  If no compilation happened, return the old Linkable.+upsweep_mod :: HscEnv+            -> Maybe Messager+            -> Maybe HomeModInfo+            -> ModSummary+            -> Int  -- index of module+            -> Int  -- total number of modules+            -> IO HomeModInfo+upsweep_mod hsc_env mHscMessage old_hmi summary mod_index nmods =  do+  hmi <- compileOne' mHscMessage hsc_env summary+          mod_index nmods (hm_iface <$> old_hmi) (old_hmi >>= hm_linkable)++  -- MP: This is a bit janky, because before you add the entries you have to extend the HPT with the module+  -- you just compiled. Another option, would be delay adding anything until after upsweep has finished, but I+  -- am unsure if this is sound (wrt running TH splices for example).+  -- This function only does anything if the linkable produced is a BCO, which only happens with the+  -- bytecode backend, no need to guard against the backend type additionally.+  addSptEntries (hscUpdateHPT (\hpt -> addToHpt hpt (ms_mod_name summary) hmi) hsc_env)+                (hm_linkable hmi)++  return hmi++-- | Add the entries from a BCO linkable to the SPT table, see+-- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable.+addSptEntries :: HscEnv -> Maybe Linkable -> IO ()+addSptEntries hsc_env mlinkable =+  hscAddSptEntries hsc_env+     [ spt+     | Just linkable <- [mlinkable]+     , unlinked <- linkableUnlinked linkable+     , BCOs _ spts <- pure unlinked+     , spt <- spts+     ]++{- Note [-fno-code mode]+~~~~~~~~~~~~~~~~~~~~~~~~+GHC offers the flag -fno-code for the purpose of parsing and typechecking a+program without generating object files. This is intended to be used by tooling+and IDEs to provide quick feedback on any parser or type errors as cheaply as+possible.++When GHC is invoked with -fno-code no object files or linked output will be+generated. As many errors and warnings as possible will be generated, as if+-fno-code had not been passed. The session DynFlags will have+backend == NoBackend.++-fwrite-interface+~~~~~~~~~~~~~~~~+Whether interface files are generated in -fno-code mode is controlled by the+-fwrite-interface flag. The -fwrite-interface flag is a no-op if -fno-code is+not also passed. Recompilation avoidance requires interface files, so passing+-fno-code without -fwrite-interface should be avoided. If -fno-code were+re-implemented today, -fwrite-interface would be discarded and it would be+considered always on; this behaviour is as it is for backwards compatibility.++================================================================+IN SUMMARY: ALWAYS PASS -fno-code AND -fwrite-interface TOGETHER+================================================================++Template Haskell+~~~~~~~~~~~~~~~~+A module using template haskell may invoke an imported function from inside a+splice. This will cause the type-checker to attempt to execute that code, which+would fail if no object files had been generated. See #8025. To rectify this,+during the downsweep we patch the DynFlags in the ModSummary of any home module+that is imported by a module that uses template haskell, to generate object+code.++The flavour of generated object code is chosen by defaultObjectTarget for the+target platform. It would likely be faster to generate bytecode, but this is not+supported on all platforms(?Please Confirm?), and does not support the entirety+of GHC haskell. See #1257.++The object files (and interface files if -fwrite-interface is disabled) produced+for template haskell are written to temporary files.++Note that since template haskell can run arbitrary IO actions, -fno-code mode+is no more secure than running without it.++Potential TODOS:+~~~~~+* Remove -fwrite-interface and have interface files always written in -fno-code+  mode+* Both .o and .dyn_o files are generated for template haskell, but we only need+  .dyn_o. Fix it.+* In make mode, a message like+  Compiling A (A.hs, /tmp/ghc_123.o)+  is shown if downsweep enabled object code generation for A. Perhaps we should+  show "nothing" or "temporary object file" instead. Note that one+  can currently use -keep-tmp-files and inspect the generated file with the+  current behaviour.+* Offer a -no-codedir command line option, and write what were temporary+  object files there. This would speed up recompilation.+* Use existing object files (if they are up to date) instead of always+  generating temporary ones.+-}++-- Note [When source is considered modified]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- A number of functions in GHC.Driver accept a SourceModified argument, which+-- is part of how GHC determines whether recompilation may be avoided (see the+-- definition of the SourceModified data type for details).+--+-- Determining whether or not a source file is considered modified depends not+-- only on the source file itself, but also on the output files which compiling+-- that module would produce. This is done because GHC supports a number of+-- flags which control which output files should be produced, e.g. -fno-code+-- -fwrite-interface and -fwrite-ide-file; we must check not only whether the+-- source file has been modified since the last compile, but also whether the+-- source file has been modified since the last compile which produced all of+-- the output files which have been requested.+--+-- Specifically, a source file is considered unmodified if it is up-to-date+-- relative to all of the output files which have been requested. Whether or+-- not an output file is up-to-date depends on what kind of file it is:+--+-- * iface (.hi) files are considered up-to-date if (and only if) their+--   mi_src_hash field matches the hash of the source file,+--+-- * all other output files (.o, .dyn_o, .hie, etc) are considered up-to-date+--   if (and only if) their modification times on the filesystem are greater+--   than or equal to the modification time of the corresponding .hi file.+--+-- Why do we use '>=' rather than '>' for output files other than the .hi file?+-- If the filesystem has poor resolution for timestamps (e.g. FAT32 has a+-- resolution of 2 seconds), we may often find that the .hi and .o files have+-- the same modification time. Using >= is slightly unsafe, but it matches+-- make's behaviour.+--+-- This strategy allows us to do the minimum work necessary in order to ensure+-- that all the files the user cares about are up-to-date; e.g. we should not+-- worry about .o files if the user has indicated that they are not interested+-- in them via -fno-code. See also #9243.+--+-- Note that recompilation avoidance is dependent on .hi files being produced,+-- which does not happen if -fno-write-interface -fno-code is passed. That is,+-- passing -fno-write-interface -fno-code means that you cannot benefit from+-- recompilation avoidance. See also Note [-fno-code mode].+--+-- The correctness of this strategy depends on an assumption that whenever we+-- are producing multiple output files, the .hi file is always written first.+-- If this assumption is violated, we risk recompiling unnecessarily by+-- incorrectly regarding non-.hi files as outdated.+--++-- ---------------------------------------------------------------------------+--+-- | Topological sort of the module graph+topSortModuleGraph+          :: Bool+          -- ^ Drop hi-boot nodes? (see below)+          -> ModuleGraph+          -> Maybe HomeUnitModule+             -- ^ Root module name.  If @Nothing@, use the full graph.+          -> [SCC ModuleGraphNode]+-- ^ Calculate SCCs of the module graph, possibly dropping the hi-boot nodes+-- The resulting list of strongly-connected-components is in topologically+-- sorted order, starting with the module(s) at the bottom of the+-- dependency graph (ie compile them first) and ending with the ones at+-- the top.+--+-- Drop hi-boot nodes (first boolean arg)?+--+-- - @False@:   treat the hi-boot summaries as nodes of the graph,+--              so the graph must be acyclic+--+-- - @True@:    eliminate the hi-boot nodes, and instead pretend+--              the a source-import of Foo is an import of Foo+--              The resulting graph has no hi-boot nodes, but can be cyclic+topSortModuleGraph drop_hs_boot_nodes module_graph mb_root_mod =+    -- stronglyConnCompG flips the original order, so if we reverse+    -- the summaries we get a stable topological sort.+  topSortModules drop_hs_boot_nodes (reverse $ mgModSummaries' module_graph) mb_root_mod++topSortModules :: Bool -> [ModuleGraphNode] -> Maybe HomeUnitModule -> [SCC ModuleGraphNode]+topSortModules drop_hs_boot_nodes summaries mb_root_mod+  = map (fmap summaryNodeSummary) $ stronglyConnCompG initial_graph+  where+    (graph, lookup_node) =+      moduleGraphNodes drop_hs_boot_nodes summaries++    initial_graph = case mb_root_mod of+        Nothing -> graph+        Just (Module uid root_mod) ->+            -- restrict the graph to just those modules reachable from+            -- the specified module.  We do this by building a graph with+            -- the full set of nodes, and determining the reachable set from+            -- the specified node.+            let root | Just node <- lookup_node $ NodeKey_Module $ ModNodeKeyWithUid (GWIB root_mod NotBoot) uid+                     , graph `hasVertexG` node+                     = node+                     | otherwise+                     = throwGhcException (ProgramError "module does not exist")+            in graphFromEdgedVerticesUniq (seq root (reachableG graph root))++newtype ModNodeMap a = ModNodeMap { unModNodeMap :: Map.Map ModNodeKey a }+  deriving (Functor, Traversable, Foldable)++emptyModNodeMap :: ModNodeMap a+emptyModNodeMap = ModNodeMap Map.empty++modNodeMapInsert :: ModNodeKey -> a -> ModNodeMap a -> ModNodeMap a+modNodeMapInsert k v (ModNodeMap m) = ModNodeMap (Map.insert k v m)++modNodeMapElems :: ModNodeMap a -> [a]+modNodeMapElems (ModNodeMap m) = Map.elems m++modNodeMapLookup :: ModNodeKey -> ModNodeMap a -> Maybe a+modNodeMapLookup k (ModNodeMap m) = Map.lookup k m++modNodeMapSingleton :: ModNodeKey -> a -> ModNodeMap a+modNodeMapSingleton k v = ModNodeMap (M.singleton k v)++modNodeMapUnionWith :: (a -> a -> a) -> ModNodeMap a -> ModNodeMap a -> ModNodeMap a+modNodeMapUnionWith f (ModNodeMap m) (ModNodeMap n) = ModNodeMap (M.unionWith f m n)++-- | If there are {-# SOURCE #-} imports between strongly connected+-- components in the topological sort, then those imports can+-- definitely be replaced by ordinary non-SOURCE imports: if SOURCE+-- were necessary, then the edge would be part of a cycle.+warnUnnecessarySourceImports :: GhcMonad m => [SCC ModSummary] -> m ()+warnUnnecessarySourceImports sccs = do+  diag_opts <- initDiagOpts <$> getDynFlags+  when (diag_wopt Opt_WarnUnusedImports diag_opts) $ do+    let check ms =+           let mods_in_this_cycle = map ms_mod_name ms in+           [ warn i | m <- ms, i <- ms_home_srcimps m,+                      unLoc i `notElem`  mods_in_this_cycle ]++        warn :: Located ModuleName -> MsgEnvelope GhcMessage+        warn (L loc mod) = GhcDriverMessage <$> mkPlainMsgEnvelope diag_opts+                                                  loc (DriverUnnecessarySourceImports mod)+    logDiagnostics (mkMessages $ listToBag (concatMap (check . flattenSCC) sccs))+++-- This caches the answer to the question, if we are in this unit, what does+-- an import of this module mean.+type DownsweepCache = M.Map (UnitId, PkgQual, ModuleNameWithIsBoot) [Either DriverMessages ModSummary]++-----------------------------------------------------------------------------+--+-- | Downsweep (dependency analysis)+--+-- Chase downwards from the specified root set, returning summaries+-- for all home modules encountered.  Only follow source-import+-- links.+--+-- We pass in the previous collection of summaries, which is used as a+-- cache to avoid recalculating a module summary if the source is+-- unchanged.+--+-- The returned list of [ModSummary] nodes has one node for each home-package+-- module, plus one for any hs-boot files.  The imports of these nodes+-- are all there, including the imports of non-home-package modules.+downsweep :: HscEnv+          -> [ModSummary]+          -- ^ Old summaries+          -> [ModuleName]       -- Ignore dependencies on these; treat+                                -- them as if they were package modules+          -> Bool               -- True <=> allow multiple targets to have+                                --          the same module name; this is+                                --          very useful for ghc -M+          -> IO ([DriverMessages], [ModuleGraphNode])+                -- The non-error elements of the returned list all have distinct+                -- (Modules, IsBoot) identifiers, unless the Bool is true in+                -- which case there can be repeats+downsweep hsc_env old_summaries excl_mods allow_dup_roots+   = do+       rootSummaries <- mapM getRootSummary roots+       let (root_errs, rootSummariesOk) = partitionEithers rootSummaries -- #17549+           root_map = mkRootMap rootSummariesOk+       checkDuplicates root_map+       (deps, pkg_deps, map0) <- loopSummaries rootSummariesOk (M.empty, Set.empty, root_map)+       let closure_errs = checkHomeUnitsClosed (hsc_unit_env hsc_env) (hsc_all_home_unit_ids hsc_env) (Set.toList pkg_deps)+       let unit_env = hsc_unit_env hsc_env+       let tmpfs    = hsc_tmpfs    hsc_env++       let downsweep_errs = lefts $ concat $ M.elems map0+           downsweep_nodes = M.elems deps++           (other_errs, unit_nodes) = partitionEithers $ unitEnv_foldWithKey (\nodes uid hue -> nodes ++ unitModuleNodes downsweep_nodes uid hue) [] (hsc_HUG hsc_env)+           all_nodes = downsweep_nodes ++ unit_nodes+           all_errs  = all_root_errs ++  downsweep_errs ++ other_errs+           all_root_errs =  closure_errs ++ map snd root_errs++       -- if we have been passed -fno-code, we enable code generation+       -- for dependencies of modules that have -XTemplateHaskell,+       -- otherwise those modules will fail to compile.+       -- See Note [-fno-code mode] #8025+       th_enabled_nodes <- enableCodeGenForTH logger tmpfs unit_env all_nodes+       if null all_root_errs+         then return (all_errs, th_enabled_nodes)+         else pure $ (all_root_errs, [])+     where+        -- Dependencies arising on a unit (backpack and module linking deps)+        unitModuleNodes :: [ModuleGraphNode] -> UnitId -> HomeUnitEnv -> [Either (Messages DriverMessage) ModuleGraphNode]+        unitModuleNodes summaries uid hue =+          let instantiation_nodes = instantiationNodes uid (homeUnitEnv_units hue)+          in map Right instantiation_nodes+              ++ maybeToList (linkNodes (instantiation_nodes ++ summaries) uid hue)++        calcDeps ms =+          -- Add a dependency on the HsBoot file if it exists+          -- This gets passed to the loopImports function which just ignores it if it+          -- can't be found.+          [(ms_unitid ms, NoPkgQual, GWIB (noLoc $ ms_mod_name ms) IsBoot) | NotBoot <- [isBootSummary ms] ] +++          [(ms_unitid ms, b, c) | (b, c) <- msDeps ms ]++        logger = hsc_logger hsc_env+        roots  = hsc_targets hsc_env++        -- A cache from file paths to the already summarised modules.+        -- Reuse these if we can because the most expensive part of downsweep is+        -- reading the headers.+        old_summary_map :: M.Map FilePath ModSummary+        old_summary_map = M.fromList [(msHsFilePath ms, ms) | ms <- old_summaries]++        getRootSummary :: Target -> IO (Either (UnitId, DriverMessages) ModSummary)+        getRootSummary Target { targetId = TargetFile file mb_phase+                              , targetContents = maybe_buf+                              , targetUnitId = uid+                              }+           = do let offset_file = augmentByWorkingDirectory dflags file+                exists <- liftIO $ doesFileExist offset_file+                if exists || isJust maybe_buf+                    then first (uid,) <$>+                        summariseFile hsc_env home_unit old_summary_map offset_file mb_phase+                                       maybe_buf+                    else return $ Left $ (uid,) $ singleMessage+                                $ mkPlainErrorMsgEnvelope noSrcSpan (DriverFileNotFound offset_file)+            where+              dflags = homeUnitEnv_dflags (ue_findHomeUnitEnv uid (hsc_unit_env hsc_env))+              home_unit = ue_unitHomeUnit uid (hsc_unit_env hsc_env)+        getRootSummary Target { targetId = TargetModule modl+                              , targetContents = maybe_buf+                              , targetUnitId = uid+                              }+           = do maybe_summary <- summariseModule hsc_env home_unit old_summary_map NotBoot+                                           (L rootLoc modl) (ThisPkg (homeUnitId home_unit))+                                           maybe_buf excl_mods+                case maybe_summary of+                   FoundHome s  -> return (Right s)+                   FoundHomeWithError err -> return (Left err)+                   _ -> return $ Left $ (uid, moduleNotFoundErr modl)+            where+              home_unit = ue_unitHomeUnit uid (hsc_unit_env hsc_env)+        rootLoc = mkGeneralSrcSpan (fsLit "<command line>")++        -- In a root module, the filename is allowed to diverge from the module+        -- name, so we have to check that there aren't multiple root files+        -- defining the same module (otherwise the duplicates will be silently+        -- ignored, leading to confusing behaviour).+        checkDuplicates+          :: DownsweepCache+          -> IO ()+        checkDuplicates root_map+           | allow_dup_roots = return ()+           | null dup_roots  = return ()+           | otherwise       = liftIO $ multiRootsErr (head dup_roots)+           where+             dup_roots :: [[ModSummary]]        -- Each at least of length 2+             dup_roots = filterOut isSingleton $ map rights (M.elems root_map)++        -- This loops over all the mod summaries in the dependency graph, accumulates the actual dependencies for each module/unit+        loopSummaries :: [ModSummary]+              -> (M.Map NodeKey ModuleGraphNode, Set.Set (UnitId, UnitId),+                    DownsweepCache)+              -> IO ((M.Map NodeKey ModuleGraphNode), Set.Set (UnitId, UnitId), DownsweepCache)+        loopSummaries [] done = return done+        loopSummaries (ms:next) (done, pkgs, summarised)+          | Just {} <- M.lookup k done+          = loopSummaries next (done, pkgs, summarised)+          -- Didn't work out what the imports mean yet, now do that.+          | otherwise = do+             (final_deps, pkgs1, done', summarised') <- loopImports (calcDeps ms) done summarised+             -- This has the effect of finding a .hs file if we are looking at the .hs-boot file.+             (_, _, done'', summarised'') <- loopImports (maybeToList hs_file_for_boot) done' summarised'+             loopSummaries next (M.insert k (ModuleNode final_deps ms) done'', pkgs1 `Set.union` pkgs, summarised'')+          where+            k = NodeKey_Module (msKey ms)++            hs_file_for_boot+              | HsBootFile <- ms_hsc_src ms = Just $ ((ms_unitid ms), NoPkgQual, (GWIB (noLoc $ ms_mod_name ms) NotBoot))+              | otherwise = Nothing+++        -- This loops over each import in each summary. It is mutually recursive with loopSummaries if we discover+        -- a new module by doing this.+        loopImports :: [(UnitId, PkgQual, GenWithIsBoot (Located ModuleName))]+                        -- Work list: process these modules+             -> M.Map NodeKey ModuleGraphNode+             -> DownsweepCache+                        -- Visited set; the range is a list because+                        -- the roots can have the same module names+                        -- if allow_dup_roots is True+             -> IO ([NodeKey], Set.Set (UnitId, UnitId),++                  M.Map NodeKey ModuleGraphNode, DownsweepCache)+                        -- The result is the completed NodeMap+        loopImports [] done summarised = return ([], Set.empty, done, summarised)+        loopImports ((home_uid,mb_pkg, gwib) : ss) done summarised+          | Just summs <- M.lookup cache_key summarised+          = case summs of+              [Right ms] -> do+                let nk = NodeKey_Module (msKey ms)+                (rest, pkgs, summarised', done') <- loopImports ss done summarised+                return (nk: rest, pkgs, summarised', done')+              [Left _err] ->+                loopImports ss done summarised+              _errs ->  do+                loopImports ss done summarised+          | otherwise+          = do+               mb_s <- summariseModule hsc_env home_unit old_summary_map+                                       is_boot wanted_mod mb_pkg+                                       Nothing excl_mods+               case mb_s of+                   NotThere -> loopImports ss done summarised+                   External uid -> do+                    (other_deps, pkgs, done', summarised') <- loopImports ss done summarised+                    return (other_deps, Set.insert (homeUnitId home_unit, uid) pkgs, done', summarised')+                   FoundInstantiation iud -> do+                    (other_deps, pkgs, done', summarised') <- loopImports ss done summarised+                    return (NodeKey_Unit iud : other_deps, pkgs, done', summarised')+                   FoundHomeWithError (_uid, e) ->  loopImports ss done (Map.insert cache_key [(Left e)] summarised)+                   FoundHome s -> do+                     (done', pkgs1, summarised') <-+                       loopSummaries [s] (done, Set.empty, Map.insert cache_key [Right s] summarised)+                     (other_deps, pkgs2, final_done, final_summarised) <- loopImports ss done' summarised'++                     -- MP: This assumes that we can only instantiate non home units, which is probably fair enough for now.+                     return (NodeKey_Module (msKey s) : other_deps, pkgs1 `Set.union` pkgs2, final_done, final_summarised)+          where+            cache_key = (home_uid, mb_pkg, unLoc <$> gwib)+            home_unit = ue_unitHomeUnit home_uid (hsc_unit_env hsc_env)+            GWIB { gwib_mod = L loc mod, gwib_isBoot = is_boot } = gwib+            wanted_mod = L loc mod++-- This function checks then important property that if both p and q are home units+-- then any dependency of p, which transitively depends on q is also a home unit.+checkHomeUnitsClosed ::  UnitEnv -> Set.Set UnitId -> [(UnitId, UnitId)] -> [DriverMessages]+-- Fast path, trivially closed.+checkHomeUnitsClosed ue home_id_set home_imp_ids+  | Set.size home_id_set == 1 = []+  | otherwise =+  let res = foldMap loop home_imp_ids+  -- Now check whether everything which transitively depends on a home_unit is actually a home_unit+  -- These units are the ones which we need to load as home packages but failed to do for some reason,+  -- it's a bug in the tool invoking GHC.+      bad_unit_ids = Set.difference res home_id_set+  in if Set.null bad_unit_ids+        then []+        else [singleMessage $ mkPlainErrorMsgEnvelope rootLoc $ DriverHomePackagesNotClosed (Set.toList bad_unit_ids)]++  where+    rootLoc = mkGeneralSrcSpan (fsLit "<command line>")+    -- TODO: This could repeat quite a bit of work but I struggled to write this function.+    -- Which units transitively depend on a home unit+    loop :: (UnitId, UnitId) -> Set.Set UnitId -- The units which transitively depend on a home unit+    loop (from_uid, uid) =+      let us = ue_findHomeUnitEnv from_uid ue in+      let um = unitInfoMap (homeUnitEnv_units us) in+      case Map.lookup uid um of+        Nothing -> pprPanic "uid not found" (ppr uid)+        Just ui ->+          let depends = unitDepends ui+              home_depends = Set.fromList depends `Set.intersection` home_id_set+              other_depends = Set.fromList depends `Set.difference` home_id_set+          in+            -- Case 1: The unit directly depends on a home_id+            if not (null home_depends)+              then+                let res = foldMap (loop . (from_uid,)) other_depends+                in Set.insert uid res+             -- Case 2: Check the rest of the dependencies, and then see if any of them depended on+              else+                let res = foldMap (loop . (from_uid,)) other_depends+                in+                  if not (Set.null res)+                    then Set.insert uid res+                    else res++-- | Update the every ModSummary that is depended on+-- by a module that needs template haskell. We enable codegen to+-- the specified target, disable optimization and change the .hi+-- and .o file locations to be temporary files.+-- See Note [-fno-code mode]+enableCodeGenForTH+  :: Logger+  -> TmpFs+  -> UnitEnv+  -> [ModuleGraphNode]+  -> IO [ModuleGraphNode]+enableCodeGenForTH logger tmpfs unit_env =+  enableCodeGenWhen logger tmpfs TFL_CurrentModule TFL_GhcSession unit_env++-- | Helper used to implement 'enableCodeGenForTH'.+-- In particular, this enables+-- unoptimized code generation for all modules that meet some+-- condition (first parameter), or are dependencies of those+-- modules. The second parameter is a condition to check before+-- marking modules for code generation.+enableCodeGenWhen+  :: Logger+  -> TmpFs+  -> TempFileLifetime+  -> TempFileLifetime+  -> UnitEnv+  -> [ModuleGraphNode]+  -> IO [ModuleGraphNode]+enableCodeGenWhen logger tmpfs staticLife dynLife unit_env mod_graph =+  mapM enable_code_gen mod_graph+  where+    defaultBackendOf ms = platformDefaultBackend (targetPlatform $ ue_unitFlags (ms_unitid ms) unit_env)+    enable_code_gen :: ModuleGraphNode -> IO ModuleGraphNode+    enable_code_gen n@(ModuleNode deps ms)+      | ModSummary+        { ms_location = ms_location+        , ms_hsc_src = HsSrcFile+        , ms_hspp_opts = dflags+        } <- ms+      , mkNodeKey n `Set.member` needs_codegen_set =+      if | nocode_enable ms -> do+               let new_temp_file suf dynsuf = do+                     tn <- newTempName logger tmpfs (tmpDir dflags) staticLife suf+                     let dyn_tn = tn -<.> dynsuf+                     addFilesToClean tmpfs dynLife [dyn_tn]+                     return (tn, dyn_tn)+                 -- We don't want to create .o or .hi files unless we have been asked+                 -- to by the user. But we need them, so we patch their locations in+                 -- the ModSummary with temporary files.+                 --+               ((hi_file, dyn_hi_file), (o_file, dyn_o_file)) <-+                 -- If ``-fwrite-interface` is specified, then the .o and .hi files+                 -- are written into `-odir` and `-hidir` respectively.  #16670+                 if gopt Opt_WriteInterface dflags+                   then return ((ml_hi_file ms_location, ml_dyn_hi_file ms_location)+                               , (ml_obj_file ms_location, ml_dyn_obj_file ms_location))+                   else (,) <$> (new_temp_file (hiSuf_ dflags) (dynHiSuf_ dflags))+                            <*> (new_temp_file (objectSuf_ dflags) (dynObjectSuf_ dflags))+               let ms' = ms+                     { ms_location =+                         ms_location { ml_hi_file = hi_file+                                     , ml_obj_file = o_file+                                     , ml_dyn_hi_file = dyn_hi_file+                                     , ml_dyn_obj_file = dyn_o_file }+                     , ms_hspp_opts = updOptLevel 0 $ dflags {backend = defaultBackendOf ms}+                     }+               -- Recursive call to catch the other cases+               enable_code_gen (ModuleNode deps ms')+         | dynamic_too_enable ms -> do+               let ms' = ms+                     { ms_hspp_opts = gopt_set (ms_hspp_opts ms) Opt_BuildDynamicToo+                     }+               -- Recursive call to catch the other cases+               enable_code_gen (ModuleNode deps ms')+         | ext_interp_enable ms -> do+               let ms' = ms+                     { ms_hspp_opts = gopt_set (ms_hspp_opts ms) Opt_ExternalInterpreter+                     }+               -- Recursive call to catch the other cases+               enable_code_gen (ModuleNode deps ms')++         | otherwise -> return n++    enable_code_gen ms = return ms++    nocode_enable ms@(ModSummary { ms_hspp_opts = dflags }) =+      backend dflags == NoBackend &&+      -- 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)++    -- #8180 - when using TemplateHaskell, switch on -dynamic-too so+    -- the linker can correctly load the object files.  This isn't necessary+    -- when using -fexternal-interpreter.+    dynamic_too_enable ms+      = hostIsDynamic && internalInterpreter &&+            not isDynWay && not isProfWay &&  not dyn_too_enabled+      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++    -- #16331 - when no "internal interpreter" is available but we+    -- need to process some TemplateHaskell or QuasiQuotes, we automatically+    -- turn on -fexternal-interpreter.+    ext_interp_enable ms = not ghciSupported && internalInterpreter+      where+       lcl_dflags   = ms_hspp_opts ms+       internalInterpreter = not (gopt Opt_ExternalInterpreter lcl_dflags)+++++    (mg, lookup_node) = moduleGraphNodes False mod_graph+    needs_codegen_set = Set.fromList $ map (mkNodeKey . node_payload) $ reachablesG mg (map (expectJust "needs_th" . lookup_node) has_th_set)+++    has_th_set =+      [ mkNodeKey mn+      | mn@(ModuleNode _ ms) <- mod_graph+      , isTemplateHaskellOrQQNonBoot ms+      ]++-- | Populate the Downsweep cache with the root modules.+mkRootMap+  :: [ModSummary]+  -> DownsweepCache+mkRootMap summaries = Map.fromListWith (flip (++))+  [ ((ms_unitid s, NoPkgQual, ms_mnwib s), [Right s]) | s <- summaries ]++-----------------------------------------------------------------------------+-- Summarising modules++-- We have two types of summarisation:+--+--    * Summarise a file.  This is used for the root module(s) passed to+--      cmLoadModules.  The file is read, and used to determine the root+--      module name.  The module name may differ from the filename.+--+--    * Summarise a module.  We are given a module name, and must provide+--      a summary.  The finder is used to locate the file in which the module+--      resides.++summariseFile+        :: HscEnv+        -> HomeUnit+        -> M.Map FilePath ModSummary    -- old summaries+        -> FilePath                     -- source file name+        -> Maybe Phase                  -- start phase+        -> Maybe (StringBuffer,UTCTime)+        -> IO (Either DriverMessages ModSummary)++summariseFile hsc_env' home_unit old_summaries src_fn mb_phase maybe_buf+        -- we can use a cached summary if one is available and the+        -- source file hasn't changed,  But we have to look up the summary+        -- by source file, rather than module name as we do in summarise.+   | Just old_summary <- M.lookup src_fn old_summaries+   = do+        let location = ms_location $ old_summary++        src_hash <- get_src_hash+                -- The file exists; we checked in getRootSummary above.+                -- If it gets removed subsequently, then this+                -- getFileHash may fail, but that's the right+                -- behaviour.++                -- return the cached summary if the source didn't change+        checkSummaryHash+            hsc_env (new_summary src_fn)+            old_summary location src_hash++   | otherwise+   = do src_hash <- get_src_hash+        new_summary src_fn src_hash+  where+    -- change the main active unit so all operations happen relative to the given unit+    hsc_env = hscSetActiveHomeUnit home_unit hsc_env'+    -- src_fn does not necessarily exist on the filesystem, so we need to+    -- check what kind of target we are dealing with+    get_src_hash = case maybe_buf of+                      Just (buf,_) -> return $ fingerprintStringBuffer buf+                      Nothing -> liftIO $ getFileHash src_fn++    new_summary src_fn src_hash = runExceptT $ do+        preimps@PreprocessedImports {..}+            <- getPreprocessedImports hsc_env src_fn mb_phase maybe_buf++        let fopts = initFinderOpts (hsc_dflags hsc_env)++        -- Make a ModLocation for this file+        let location = mkHomeModLocation fopts pi_mod_name src_fn++        -- Tell the Finder cache where it is, so that subsequent calls+        -- to findModule will find it, even if it's not on any search path+        mod <- liftIO $ do+          let home_unit = hsc_home_unit hsc_env+          let fc        = hsc_FC hsc_env+          addHomeModuleToFinder fc home_unit pi_mod_name location++        liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary+            { nms_src_fn = src_fn+            , nms_src_hash = src_hash+            , nms_is_boot = NotBoot+            , nms_hsc_src =+                if isHaskellSigFilename src_fn+                   then HsigFile+                   else HsSrcFile+            , nms_location = location+            , nms_mod = mod+            , nms_preimps = preimps+            }++checkSummaryHash+    :: HscEnv+    -> (Fingerprint -> IO (Either e ModSummary))+    -> ModSummary -> ModLocation -> Fingerprint+    -> IO (Either e ModSummary)+checkSummaryHash+  hsc_env new_summary+  old_summary+  location src_hash+  | ms_hs_hash old_summary == src_hash &&+      not (gopt Opt_ForceRecomp (hsc_dflags hsc_env)) = do+           -- update the object-file timestamp+           obj_timestamp <- modificationTimeIfExists (ml_obj_file location)++           -- We have to repopulate the Finder's cache for file targets+           -- because the file might not even be on the regular search path+           -- and it was likely flushed in depanal. This is not technically+           -- needed when we're called from sumariseModule but it shouldn't+           -- hurt.+           -- Also, only add to finder cache for non-boot modules as the finder cache+           -- makes sure to add a boot suffix for boot files.+           _ <- do+              let fc        = hsc_FC hsc_env+              case ms_hsc_src old_summary of+                HsSrcFile -> addModuleToFinder fc (ms_mod old_summary) location+                _ -> return ()++           hi_timestamp <- modificationTimeIfExists (ml_hi_file location)+           hie_timestamp <- modificationTimeIfExists (ml_hie_file location)++           return $ Right+             ( old_summary+                     { ms_obj_date = obj_timestamp+                     , ms_iface_date = hi_timestamp+                     , ms_hie_date = hie_timestamp+                     }+             )++   | otherwise =+           -- source changed: re-summarise.+           new_summary src_hash++data SummariseResult =+        FoundInstantiation InstantiatedUnit+      | FoundHomeWithError (UnitId, DriverMessages)+      | FoundHome ModSummary+      | External UnitId+      | NotThere++-- Summarise a module, and pick up source and timestamp.+summariseModule+          :: HscEnv+          -> HomeUnit+          -> M.Map FilePath ModSummary+          -- ^ Map of old summaries+          -> IsBootInterface    -- True <=> a {-# SOURCE #-} import+          -> Located ModuleName -- Imported module to be summarised+          -> PkgQual+          -> Maybe (StringBuffer, UTCTime)+          -> [ModuleName]               -- Modules to exclude+          -> IO SummariseResult+++summariseModule hsc_env' home_unit old_summary_map is_boot (L _ wanted_mod) mb_pkg+                maybe_buf excl_mods+  | wanted_mod `elem` excl_mods+  = return NotThere+  | otherwise  = find_it+  where+    -- Temporarily change the currently active home unit so all operations+    -- happen relative to it+    hsc_env   = hscSetActiveHomeUnit home_unit hsc_env'+    dflags    = hsc_dflags hsc_env++    find_it :: IO SummariseResult++    find_it = do+        found <- findImportedModule hsc_env wanted_mod mb_pkg+        case found of+             Found location mod+                | isJust (ml_hs_file location) ->+                        -- Home package+                         just_found location mod+                | VirtUnit iud <- moduleUnit mod+                , not (isHomeModule home_unit mod)+                  -> return $ FoundInstantiation iud+                | otherwise -> return $ External (moduleUnitId mod)+             _ -> return NotThere+                        -- Not found+                        -- (If it is TRULY not found at all, we'll+                        -- error when we actually try to compile)++    just_found location mod = do+                -- Adjust location to point to the hs-boot source file,+                -- hi file, object file, when is_boot says so+        let location' = case is_boot of+              IsBoot -> addBootSuffixLocn location+              NotBoot -> location+            src_fn = expectJust "summarise2" (ml_hs_file location')++                -- Check that it exists+                -- It might have been deleted since the Finder last found it+        maybe_h <- fileHashIfExists src_fn+        case maybe_h of+          -- This situation can also happen if we have found the .hs file but the+          -- .hs-boot file doesn't exist.+          Nothing -> return NotThere+          Just h  -> do+            fresult <- new_summary_cache_check location' mod src_fn h+            return $ case fresult of+              Left err -> FoundHomeWithError (moduleUnitId mod, err)+              Right ms -> FoundHome ms++    new_summary_cache_check loc mod src_fn h+      | Just old_summary <- Map.lookup src_fn old_summary_map =++         -- check the hash on the source file, and+         -- return the cached summary if it hasn't changed.  If the+         -- file has changed then need to resummarise.+        case maybe_buf of+           Just (buf,_) ->+               checkSummaryHash hsc_env (new_summary loc mod src_fn) old_summary loc (fingerprintStringBuffer buf)+           Nothing    ->+               checkSummaryHash hsc_env (new_summary loc mod src_fn) old_summary loc h+      | otherwise = new_summary loc mod src_fn h++    new_summary :: ModLocation+                  -> Module+                  -> FilePath+                  -> Fingerprint+                  -> IO (Either DriverMessages ModSummary)+    new_summary location mod src_fn src_hash+      = runExceptT $ do+        preimps@PreprocessedImports {..}+            -- Remember to set the active unit here, otherwise the wrong include paths are passed to CPP+            -- See multiHomeUnits_cpp2 test+            <- getPreprocessedImports (hscSetActiveUnitId (moduleUnitId mod) hsc_env) src_fn Nothing maybe_buf++        -- NB: Despite the fact that is_boot is a top-level parameter, we+        -- don't actually know coming into this function what the HscSource+        -- of the module in question is.  This is because we may be processing+        -- this module because another module in the graph imported it: in this+        -- case, we know if it's a boot or not because of the {-# SOURCE #-}+        -- annotation, but we don't know if it's a signature or a regular+        -- module until we actually look it up on the filesystem.+        let hsc_src+              | is_boot == IsBoot = HsBootFile+              | isHaskellSigFilename src_fn = HsigFile+              | otherwise = HsSrcFile++        when (pi_mod_name /= wanted_mod) $+                throwE $ singleMessage $ mkPlainErrorMsgEnvelope pi_mod_name_loc+                       $ DriverFileModuleNameMismatch pi_mod_name wanted_mod++        let instantiations = homeUnitInstantiations home_unit+        when (hsc_src == HsigFile && isNothing (lookup pi_mod_name instantiations)) $+            throwE $ singleMessage $ mkPlainErrorMsgEnvelope pi_mod_name_loc+                   $ DriverUnexpectedSignature pi_mod_name (checkBuildingCabalPackage dflags) instantiations++        liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary+            { nms_src_fn = src_fn+            , nms_src_hash = src_hash+            , nms_is_boot = is_boot+            , nms_hsc_src = hsc_src+            , nms_location = location+            , nms_mod = mod+            , nms_preimps = preimps+            }++-- | Convenience named arguments for 'makeNewModSummary' only used to make+-- code more readable, not exported.+data MakeNewModSummary+  = MakeNewModSummary+      { nms_src_fn :: FilePath+      , nms_src_hash :: Fingerprint+      , nms_is_boot :: IsBootInterface+      , nms_hsc_src :: HscSource+      , nms_location :: ModLocation+      , nms_mod :: Module+      , nms_preimps :: PreprocessedImports+      }++makeNewModSummary :: HscEnv -> MakeNewModSummary -> IO ModSummary+makeNewModSummary hsc_env MakeNewModSummary{..} = do+  let PreprocessedImports{..} = nms_preimps+  obj_timestamp <- modificationTimeIfExists (ml_obj_file nms_location)+  dyn_obj_timestamp <- modificationTimeIfExists (ml_dyn_obj_file nms_location)+  hi_timestamp <- modificationTimeIfExists (ml_hi_file nms_location)+  hie_timestamp <- modificationTimeIfExists (ml_hie_file nms_location)++  extra_sig_imports <- findExtraSigImports hsc_env nms_hsc_src pi_mod_name+  (implicit_sigs, _inst_deps) <- implicitRequirementsShallow (hscSetActiveUnitId (moduleUnitId nms_mod) hsc_env) pi_theimps++  return $+        ModSummary+        { ms_mod = nms_mod+        , ms_hsc_src = nms_hsc_src+        , ms_location = nms_location+        , ms_hspp_file = pi_hspp_fn+        , ms_hspp_opts = pi_local_dflags+        , ms_hspp_buf  = Just pi_hspp_buf+        , ms_parsed_mod = Nothing+        , ms_srcimps = pi_srcimps+        , ms_ghc_prim_import = pi_ghc_prim_import+        , ms_textual_imps =+            ((,) NoPkgQual . noLoc <$> extra_sig_imports) +++            ((,) NoPkgQual . noLoc <$> implicit_sigs) +++            pi_theimps+        , ms_hs_hash = nms_src_hash+        , ms_iface_date = hi_timestamp+        , ms_hie_date = hie_timestamp+        , ms_obj_date = obj_timestamp+        , ms_dyn_obj_date = dyn_obj_timestamp+        }++data PreprocessedImports+  = PreprocessedImports+      { pi_local_dflags :: DynFlags+      , pi_srcimps  :: [(PkgQual, Located ModuleName)]+      , pi_theimps  :: [(PkgQual, Located ModuleName)]+      , pi_ghc_prim_import :: Bool+      , pi_hspp_fn  :: FilePath+      , pi_hspp_buf :: StringBuffer+      , pi_mod_name_loc :: SrcSpan+      , pi_mod_name :: ModuleName+      }++-- Preprocess the source file and get its imports+-- The pi_local_dflags contains the OPTIONS pragmas+getPreprocessedImports+    :: HscEnv+    -> FilePath+    -> Maybe Phase+    -> Maybe (StringBuffer, UTCTime)+    -- ^ optional source code buffer and modification time+    -> ExceptT DriverMessages IO PreprocessedImports+getPreprocessedImports hsc_env src_fn mb_phase maybe_buf = do+  (pi_local_dflags, pi_hspp_fn)+      <- ExceptT $ preprocess hsc_env src_fn (fst <$> maybe_buf) mb_phase+  pi_hspp_buf <- liftIO $ hGetStringBuffer pi_hspp_fn+  (pi_srcimps', pi_theimps', pi_ghc_prim_import, L pi_mod_name_loc pi_mod_name)+      <- ExceptT $ do+          let imp_prelude = xopt LangExt.ImplicitPrelude pi_local_dflags+              popts = initParserOpts pi_local_dflags+          mimps <- getImports popts imp_prelude pi_hspp_buf pi_hspp_fn src_fn+          return (first (mkMessages . fmap mkDriverPsHeaderMessage . getMessages) mimps)+  let rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env)+  let rn_imps = fmap (\(pk, lmn@(L _ mn)) -> (rn_pkg_qual mn pk, lmn))+  let pi_srcimps = rn_imps pi_srcimps'+  let pi_theimps = rn_imps pi_theimps'+  return PreprocessedImports {..}+++-----------------------------------------------------------------------------+--                      Error messages+-----------------------------------------------------------------------------++-- Defer and group warning, error and fatal messages so they will not get lost+-- in the regular output.+withDeferredDiagnostics :: GhcMonad m => m a -> m a+withDeferredDiagnostics f = do+  dflags <- getDynFlags+  if not $ gopt Opt_DeferDiagnostics dflags+  then f+  else do+    warnings <- liftIO $ newIORef []+    errors <- liftIO $ newIORef []+    fatals <- liftIO $ newIORef []+    logger <- getLogger++    let deferDiagnostics _dflags !msgClass !srcSpan !msg = do+          let action = logMsg logger msgClass srcSpan msg+          case msgClass of+            MCDiagnostic SevWarning _reason+              -> atomicModifyIORef' warnings $ \i -> (action: i, ())+            MCDiagnostic SevError _reason+              -> atomicModifyIORef' errors   $ \i -> (action: i, ())+            MCFatal+              -> atomicModifyIORef' fatals   $ \i -> (action: i, ())+            _ -> action++        printDeferredDiagnostics = liftIO $+          forM_ [warnings, errors, fatals] $ \ref -> do+            -- This IORef can leak when the dflags leaks, so let us always+            -- reset the content.+            actions <- atomicModifyIORef' ref $ \i -> ([], i)+            sequence_ $ reverse actions++    MC.bracket+      (pushLogHookM (const deferDiagnostics))+      (\_ -> popLogHookM >> printDeferredDiagnostics)+      (\_ -> f)++noModError :: HscEnv -> SrcSpan -> ModuleName -> FindResult -> MsgEnvelope GhcMessage+-- ToDo: we don't have a proper line number for this error+noModError hsc_env loc wanted_mod err+  = mkPlainErrorMsgEnvelope loc $ GhcDriverMessage $ DriverUnknownMessage $ mkPlainError noHints $+    cannotFindModule hsc_env wanted_mod err++{-+noHsFileErr :: SrcSpan -> String -> DriverMessages+noHsFileErr loc path+  = singleMessage $ mkPlainErrorMsgEnvelope loc (DriverFileNotFound path)+  -}++moduleNotFoundErr :: ModuleName -> DriverMessages+moduleNotFoundErr mod = singleMessage $ mkPlainErrorMsgEnvelope noSrcSpan (DriverModuleNotFound mod)++multiRootsErr :: [ModSummary] -> IO ()+multiRootsErr [] = panic "multiRootsErr"+multiRootsErr summs@(summ1:_)+  = throwOneError $ fmap GhcDriverMessage $+    mkPlainErrorMsgEnvelope noSrcSpan $ DriverDuplicatedModuleDeclaration mod files+  where+    mod = ms_mod summ1+    files = map (expectJust "checkDup" . ml_hs_file . ms_location) summs++cyclicModuleErr :: [ModuleGraphNode] -> SDoc+-- From a strongly connected component we find+-- a single cycle to report+cyclicModuleErr mss+  = assert (not (null mss)) $+    case findCycle graph of+       Nothing   -> text "Unexpected non-cycle" <+> ppr mss+       Just path0 -> vcat+        [ text "Module graph contains a cycle:"+        , nest 2 (show_path path0)]+  where+    graph :: [Node NodeKey ModuleGraphNode]+    graph =+      [ DigraphNode+        { node_payload = ms+        , node_key = mkNodeKey ms+        , node_dependencies = nodeDependencies False ms+        }+      | ms <- mss+      ]++    show_path :: [ModuleGraphNode] -> SDoc+    show_path []  = panic "show_path"+    show_path [m] = ppr_node m <+> text "imports itself"+    show_path (m1:m2:ms) = vcat ( nest 6 (ppr_node m1)+                                : nest 6 (text "imports" <+> ppr_node m2)+                                : go ms )+       where+         go []     = [text "which imports" <+> ppr_node m1]+         go (m:ms) = (text "which imports" <+> ppr_node m) : go ms++    ppr_node :: ModuleGraphNode -> SDoc+    ppr_node (ModuleNode _deps m) = text "module" <+> ppr_ms m+    ppr_node (InstantiationNode _uid u) = text "instantiated unit" <+> ppr u+    ppr_node (LinkNode uid _) = pprPanic "LinkNode should not be in a cycle" (ppr uid)++    ppr_ms :: ModSummary -> SDoc+    ppr_ms ms = quotes (ppr (moduleName (ms_mod ms))) <+>+                (parens (text (msHsFilePath ms)))+++cleanCurrentModuleTempFilesMaybe :: MonadIO m => Logger -> TmpFs -> DynFlags -> m ()+cleanCurrentModuleTempFilesMaybe logger tmpfs dflags =+  unless (gopt Opt_KeepTmpFiles dflags) $+    liftIO $ cleanCurrentModuleTempFiles logger tmpfs+++addDepsToHscEnv ::  [HomeModInfo] -> HscEnv -> HscEnv+addDepsToHscEnv deps hsc_env =+  hscUpdateHUG (\hug -> foldr addHomeModInfoToHug hug deps) hsc_env++setHPT ::  HomePackageTable -> HscEnv -> HscEnv+setHPT deps hsc_env =+  hscUpdateHPT (const $ deps) hsc_env++setHUG ::  HomeUnitGraph -> HscEnv -> HscEnv+setHUG deps hsc_env =+  hscUpdateHUG (const $ deps) hsc_env++-- | Wrap an action to catch and handle exceptions.+wrapAction :: HscEnv -> IO a -> IO (Maybe a)+wrapAction hsc_env k = do+  let lcl_logger = hsc_logger hsc_env+      lcl_dynflags = hsc_dflags hsc_env+  let logg err = printMessages lcl_logger (initDiagOpts lcl_dynflags) (srcErrorMessages err)+  -- MP: It is a bit strange how prettyPrintGhcErrors handles some errors but then we handle+  -- SourceError and ThreadKilled differently directly below. TODO: Refactor to use `catches`+  -- directly. MP should probably use safeTry here to not catch async exceptions but that will regress performance due to+  -- internally using forkIO.+  mres <- MC.try $ liftIO $ prettyPrintGhcErrors lcl_logger $ k+  case mres of+    Right res -> return $ Just res+    Left exc -> do+        case fromException exc of+          Just (err :: SourceError)+            -> logg err+          Nothing -> case fromException exc of+                        -- ThreadKilled in particular needs to actually kill the thread.+                        -- So rethrow that and the other async exceptions+                        Just (err :: SomeAsyncException) -> throwIO err+                        _ -> errorMsg lcl_logger (text (show exc))+        return Nothing++withParLog :: TVar LogQueueQueue -> Int -> ((Logger -> Logger) -> IO b) -> IO b+withParLog lqq_var k cont = do+  let init_log = do+        -- Make a new log queue+        lq <- newLogQueue k+        -- Add it into the LogQueueQueue+        atomically $ initLogQueue lqq_var lq+        return lq+      finish_log lq = liftIO (finishLogQueue lq)+  MC.bracket init_log finish_log $ \lq -> cont (pushLogHook (const (parLogAction lq)))++withLoggerHsc :: Int -> MakeEnv -> (HscEnv -> IO a) -> IO a+withLoggerHsc k MakeEnv{withLogger, hsc_env} cont = do+  withLogger k $ \modifyLogger -> do+    let lcl_logger = modifyLogger (hsc_logger hsc_env)+        hsc_env' = hsc_env { hsc_logger = lcl_logger }+    -- Run continuation with modified logger+    cont hsc_env'+++executeInstantiationNode :: Int+  -> Int+  -> RunMakeM HomeUnitGraph+  -> UnitId+  -> InstantiatedUnit+  -> RunMakeM ()+executeInstantiationNode k n wait_deps uid iu = do+        -- Wait for the dependencies of this node+        deps <- wait_deps+        env <- ask+        -- Output of the logger is mediated by a central worker to+        -- avoid output interleaving+        msg <- asks env_messager+        lift $ MaybeT $ withLoggerHsc k env $ \hsc_env ->+          let lcl_hsc_env = setHUG deps hsc_env+          in wrapAction lcl_hsc_env $ do+            res <- upsweep_inst lcl_hsc_env msg k n uid iu+            cleanCurrentModuleTempFilesMaybe (hsc_logger hsc_env) (hsc_tmpfs hsc_env) (hsc_dflags hsc_env)+            return res+++executeCompileNode :: Int+  -> Int+  -> Maybe HomeModInfo+  -> RunMakeM HomeUnitGraph+  -> Maybe [ModuleName] -- List of modules we need to rehydrate before compiling+  -> ModSummary+  -> RunMakeM HomeModInfo+executeCompileNode k n !old_hmi wait_deps mrehydrate_mods mod = do+  me@MakeEnv{..} <- ask+  deps <- wait_deps+  -- Rehydrate any dependencies if this module had a boot file or is a signature file.+  lift $ MaybeT (withAbstractSem compile_sem $ withLoggerHsc k me $ \hsc_env -> do+     hydrated_hsc_env <- liftIO $ maybeRehydrateBefore (setHUG deps hsc_env) mod fixed_mrehydrate_mods+     let -- Use the cached DynFlags which includes OPTIONS_GHC pragmas+         lcl_dynflags = ms_hspp_opts mod+     let lcl_hsc_env =+             -- Localise the hsc_env to use the cached flags+             hscSetFlags lcl_dynflags $+             hydrated_hsc_env+     -- Compile the module, locking with a semphore to avoid too many modules+     -- being compiled at the same time leading to high memory usage.+     wrapAction lcl_hsc_env $ do+      res <- upsweep_mod lcl_hsc_env env_messager old_hmi mod k n+      cleanCurrentModuleTempFilesMaybe (hsc_logger hsc_env) (hsc_tmpfs hsc_env) lcl_dynflags+      return res)++  where+    fixed_mrehydrate_mods =+      case ms_hsc_src mod of+        -- MP: It is probably a bit of a misimplementation in backpack that+        -- compiling a signature requires an knot_var for that unit.+        -- If you remove this then a lot of backpack tests fail.+        HsigFile -> Just []+        _ -> mrehydrate_mods++{- Rehydration, see Note [Rehydrating Modules] -}++rehydrate :: HscEnv        -- ^ The HPT in this HscEnv needs rehydrating.+          -> [HomeModInfo] -- ^ These are the modules we want to rehydrate.+          -> IO HscEnv+rehydrate hsc_env hmis = do+  debugTraceMsg logger 2 $+     text "Re-hydrating loop: "+  new_mods <- fixIO $ \new_mods -> do+      let new_hpt = addListToHpt old_hpt new_mods+      let new_hsc_env = hscUpdateHPT (const new_hpt) hsc_env+      mds <- initIfaceCheck (text "rehydrate") new_hsc_env $+                mapM (typecheckIface . hm_iface) hmis+      let new_mods = [ (mn,hmi{ hm_details = details })+                     | (hmi,details) <- zip hmis mds+                     , let mn = moduleName (mi_module (hm_iface hmi)) ]+      return new_mods+  return $ setHPT (foldl' (\old (mn, hmi) -> addToHpt old mn hmi) old_hpt new_mods) hsc_env++  where+    logger  = hsc_logger hsc_env+    to_delete =  (map (moduleName . mi_module . hm_iface) hmis)+    -- Filter out old modules before tying the knot, otherwise we can end+    -- up with a thunk which keeps reference to the old HomeModInfo.+    !old_hpt = foldl' delFromHpt (hsc_HPT hsc_env) to_delete++-- If needed, then rehydrate the necessary modules with a suitable KnotVars for the+-- module currently being compiled.+maybeRehydrateBefore :: HscEnv -> ModSummary -> Maybe [ModuleName] -> IO HscEnv+maybeRehydrateBefore hsc_env _ Nothing = return hsc_env+maybeRehydrateBefore hsc_env mod (Just mns) = do+  knot_var <- initialise_knot_var hsc_env+  let hmis = map (expectJust "mr" . lookupHpt (hsc_HPT hsc_env)) mns+  rehydrate (hsc_env { hsc_type_env_vars = knotVarsFromModuleEnv knot_var }) hmis++  where+   initialise_knot_var hsc_env = liftIO $+    let mod_name = homeModuleInstantiation (hsc_home_unit_maybe hsc_env) (ms_mod mod)+    in mkModuleEnv . (:[]) . (mod_name,) <$> newIORef emptyTypeEnv++maybeRehydrateAfter :: HomeModInfo+  -> HscEnv+  -> Maybe [ModuleName]+  -> IO (HomeUnitGraph, HomeModInfo)+maybeRehydrateAfter hmi new_hsc Nothing = return (hsc_HUG new_hsc, hmi)+maybeRehydrateAfter hmi new_hsc (Just mns) = do+  let new_hpt = hsc_HPT new_hsc+      hmis = map (expectJust "mrAfter" . lookupHpt new_hpt) mns+      new_mod_name = moduleName (mi_module (hm_iface hmi))+  hsc_env <- rehydrate (new_hsc { hsc_type_env_vars = emptyKnotVars }) (hmi : hmis)+  return (hsc_HUG hsc_env, expectJust "rehydrate" $ lookupHpt (hsc_HPT hsc_env) new_mod_name)++{-+Note [Hydrating Modules]+~~~~~~~~~~~~~~~~~~~~~~~~+There are at least 4 different representations of an interface file as described+by this diagram.++------------------------------+|       On-disk M.hi         |+------------------------------+    |             ^+    | Read file   | Write file+    V             |+-------------------------------+|      ByteString             |+-------------------------------+    |             ^+    | Binary.get  | Binary.put+    V             |+--------------------------------+|    ModIface (an acyclic AST) |+--------------------------------+    |           ^+    | hydrate   | mkIfaceTc+    V           |+---------------------------------+|  ModDetails (lots of cycles)  |+---------------------------------++The last step, converting a ModIface into a ModDetails is known as "hydration".++Hydration happens in three different places++* When an interface file is initially loaded from disk, it has to be hydrated.+* When a module is finished compiling, we hydrate the ModIface in order to generate+  the version of ModDetails which exists in memory (see Note [ModDetails and --make mode])+* When dealing with boot files and module loops (see Note [Rehydrating Modules])++Note [Rehydrating Modules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+If a module has a boot file then it is critical to rehydrate the modules on+the path between the two (see #20561).++Suppose we have ("R" for "recursive"):+```+R.hs-boot:   module R where+               data T+               g :: T -> T++A.hs:        module A( f, T, g ) where+                import {-# SOURCE #-} R+                data S = MkS T+                f :: T -> S = ...g...++R.hs:        module R where+                import A+                data T = T1 | T2 S+                g = ...f...+```++== Why we need to rehydrate A's ModIface before compiling R.hs++After compiling A.hs we'll have a TypeEnv in which the Id for `f` has a type+type uses the AbstractTyCon T; and a TyCon for `S` that also mentions that same+AbstractTyCon. (Abstract because it came from R.hs-boot; we know nothing about+it.)++When compiling R.hs, we build a TyCon for `T`.  But that TyCon mentions `S`, and+it currently has an AbstractTyCon for `T` inside it.  But we want to build a+fully cyclic structure, in which `S` refers to `T` and `T` refers to `S`.++Solution: **rehydration**.  *Before compiling `R.hs`*, rehydrate all the+ModIfaces below it that depend on R.hs-boot.  To rehydrate a ModIface, call+`typecheckIface` to convert it to a ModDetails.  It's just a de-serialisation+step, no type inference, just lookups.++Now `S` will be bound to a thunk that, when forced, will "see" the final binding+for `T`; see [Tying the knot](https://gitlab.haskell.org/ghc/ghc/-/wikis/commentary/compiler/tying-the-knot).+But note that this must be done *before* compiling R.hs.++== Why we need to rehydrate A's ModIface after compiling R.hs++When compiling R.hs, the knot-tying stuff above will ensure that `f`'s unfolding+mentions the `LocalId` for `g`.  But when we finish R, we carefully ensure that+all those `LocalIds` are turned into completed `GlobalIds`, replete with+unfoldings etc.   Alas, that will not apply to the occurrences of `g` in `f`'s+unfolding. And if we leave matters like that, they will stay that way, and *all*+subsequent modules that import A will see a crippled unfolding for `f`.++Solution: rehydrate both R and A's ModIface together, right after completing R.hs.++~~ Which modules to rehydrate++We only need rehydrate modules that are+* Below R.hs+* Above R.hs-boot++There might be many unrelated modules (in the home package) that don't need to be+rehydrated.++== 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 the argument type of `MkX`.  So:++* Either we should delay compiling X until after R has beeen 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 :: RunMakeM HomeUnitGraph -> (Int, Int) -> UnitId -> [NodeKey] -> RunMakeM ()+executeLinkNode wait_deps kn uid deps = do+  withCurrentUnit uid $ do+    MakeEnv{..} <- ask+    hug <- wait_deps+    let dflags = hsc_dflags hsc_env+    let hsc_env' = setHUG hug hsc_env+        msg' = (\messager -> \recomp -> messager hsc_env kn recomp (LinkNode deps uid)) <$> env_messager++    linkresult <- liftIO $ withAbstractSem compile_sem $ do+                            link (ghcLink dflags)+                                (hsc_logger hsc_env')+                                (hsc_tmpfs hsc_env')+                                (hsc_hooks hsc_env')+                                dflags+                                (hsc_unit_env hsc_env')+                                True -- We already decided to link+                                msg'+                                (hsc_HPT hsc_env')+    case linkresult of+      Failed -> fail "Link Failed"+      Succeeded -> return ()+++-- | Wait for some dependencies to finish and then read from the given MVar.+wait_deps_hug :: MVar b -> [ResultVar (Maybe HomeModInfo)] -> ReaderT MakeEnv (MaybeT IO) b+wait_deps_hug hug_var deps = do+  _ <- wait_deps deps+  liftIO $ readMVar hug_var+++-- | Wait for dependencies to finish, and then return their results.+wait_deps :: [ResultVar (Maybe HomeModInfo)] -> RunMakeM [HomeModInfo]+wait_deps [] = return []+wait_deps (x:xs) = do+  res <- lift $ waitResult x+  case res of+    Nothing -> wait_deps xs+    Just hmi -> (hmi:) <$> wait_deps xs+++-- Executing the pipelines++-- | Start a thread which reads from the LogQueueQueue+++label_self :: String -> IO ()+label_self thread_name = do+    self_tid <- CC.myThreadId+    CC.labelThread self_tid thread_name+++runPipelines :: Int -> HscEnv -> Maybe Messager -> [MakeAction] -> IO ()+-- Don't even initialise plugins if there are no pipelines+runPipelines _ _ _ [] = return ()+runPipelines n_job orig_hsc_env mHscMessager all_pipelines = do+  liftIO $ label_self "main --make thread"++  plugins_hsc_env <- initializePlugins orig_hsc_env+  case n_job of+    1 -> runSeqPipelines plugins_hsc_env mHscMessager all_pipelines+    _n -> runParPipelines n_job plugins_hsc_env mHscMessager all_pipelines++runSeqPipelines :: HscEnv -> Maybe Messager -> [MakeAction] -> IO ()+runSeqPipelines plugin_hsc_env mHscMessager all_pipelines =+  let env = MakeEnv { hsc_env = plugin_hsc_env+                    , withLogger = \_ k -> k id+                    , compile_sem = AbstractSem (return ()) (return ())+                    , env_messager = mHscMessager+                    }+  in runAllPipelines 1 env all_pipelines+++-- | Build and run a pipeline+runParPipelines :: Int              -- ^ How many capabilities to use+             -> HscEnv           -- ^ The basic HscEnv which is augmented with specific info for each module+             -> Maybe Messager   -- ^ Optional custom messager to use to report progress+             -> [MakeAction]  -- ^ The build plan for all the module nodes+             -> IO ()+runParPipelines n_jobs plugin_hsc_env mHscMessager all_pipelines = do+++  -- A variable which we write to when an error has happened and we have to tell the+  -- logging thread to gracefully shut down.+  stopped_var <- newTVarIO False+  -- The queue of LogQueues which actions are able to write to. When an action starts it+  -- will add it's LogQueue into this queue.+  log_queue_queue_var <- newTVarIO newLogQueueQueue+  -- Thread which coordinates the printing of logs+  wait_log_thread <- logThread n_jobs (length all_pipelines) (hsc_logger plugin_hsc_env) stopped_var log_queue_queue_var+++  -- Make the logger thread-safe, in case there is some output which isn't sent via the LogQueue.+  thread_safe_logger <- liftIO $ makeThreadSafe (hsc_logger plugin_hsc_env)+  let thread_safe_hsc_env = plugin_hsc_env { hsc_logger = thread_safe_logger }++  let updNumCapabilities = liftIO $ do+          n_capabilities <- getNumCapabilities+          n_cpus <- getNumProcessors+          -- Setting number of capabilities more than+          -- CPU count usually leads to high userspace+          -- lock contention. #9221+          let n_caps = min n_jobs n_cpus+          unless (n_capabilities /= 1) $ setNumCapabilities n_caps+          return n_capabilities++  let resetNumCapabilities orig_n = do+          liftIO $ setNumCapabilities orig_n+          atomically $ writeTVar stopped_var True+          wait_log_thread++  compile_sem <- newQSem n_jobs+  let abstract_sem = AbstractSem (waitQSem compile_sem) (signalQSem compile_sem)+    -- Reset the number of capabilities once the upsweep ends.+  let env = MakeEnv { hsc_env = thread_safe_hsc_env+                    , withLogger = withParLog log_queue_queue_var+                    , compile_sem = abstract_sem+                    , env_messager = mHscMessager+                    }++  MC.bracket updNumCapabilities resetNumCapabilities $ \_ ->+    runAllPipelines n_jobs env all_pipelines++withLocalTmpFS :: RunMakeM a -> RunMakeM a+withLocalTmpFS act = do+  let initialiser = do+        MakeEnv{..} <- ask+        lcl_tmpfs <- liftIO $ forkTmpFsFrom (hsc_tmpfs hsc_env)+        return $ hsc_env { hsc_tmpfs  = lcl_tmpfs }+      finaliser lcl_env = do+        gbl_env <- ask+        liftIO $ mergeTmpFsInto (hsc_tmpfs lcl_env) (hsc_tmpfs (hsc_env gbl_env))+       -- Add remaining files which weren't cleaned up into local tmp fs for+       -- clean-up later.+       -- Clear the logQueue if this node had it's own log queue+  MC.bracket initialiser finaliser $ \lcl_hsc_env -> local (\env -> env { hsc_env = lcl_hsc_env}) act++-- | Run the given actions and then wait for them all to finish.+runAllPipelines :: Int -> MakeEnv -> [MakeAction] -> IO ()+runAllPipelines n_jobs env acts = do+  let spawn_actions :: IO [ThreadId]+      spawn_actions = if n_jobs == 1+        then (:[]) <$> (forkIOWithUnmask $ \unmask -> void $ runLoop (\io -> io unmask) env acts)+        else runLoop forkIOWithUnmask env acts++      kill_actions :: [ThreadId] -> IO ()+      kill_actions tids = mapM_ killThread tids++  MC.bracket spawn_actions kill_actions $ \_ -> do+    mapM_ waitMakeAction acts++-- | Execute each action in order, limiting the amount of parrelism by the given+-- semaphore.+runLoop :: (((forall a. IO a -> IO a) -> IO ()) -> IO a) -> MakeEnv -> [MakeAction] -> IO [a]+runLoop _ _env [] = return []+runLoop fork_thread env (MakeAction act res_var :acts) = do+  new_thread <-+    fork_thread $ \unmask -> (do+            mres <- (unmask $ run_pipeline (withLocalTmpFS act))+                      `MC.onException` (putMVar res_var Nothing) -- Defensive: If there's an unhandled exception then still signal the failure.+            putMVar res_var mres)+  threads <- runLoop fork_thread env acts+  return (new_thread : threads)+  where+      run_pipeline :: RunMakeM a -> IO (Maybe a)+      run_pipeline p = runMaybeT (runReaderT p env)++data MakeAction = forall a . MakeAction (RunMakeM a) (MVar (Maybe a))++waitMakeAction :: MakeAction -> IO ()+waitMakeAction (MakeAction _ mvar) = () <$ readMVar mvar++{- Note [GHC Heap Invariants]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~+This note is a general place to explain some of the heap invariants which should+hold for a program compiled with --make mode. These invariants are all things+which can be checked easily using ghc-debug.++1. No HomeModInfo are reachable via the EPS.+   Why? Interfaces are lazily loaded into the EPS and the lazy thunk retains+        a reference to the entire HscEnv, if we are not careful the HscEnv will+        contain the HomePackageTable at the time the interface was loaded and+        it will never be released.+   Where? dontLeakTheHPT in GHC.Iface.Load++2. No KnotVars are live at the end of upsweep (#20491)+   Why? KnotVars contains an old stale reference to the TypeEnv for modules+        which participate in a loop. At the end of a loop all the KnotVars references+        should be removed by the call to typecheckLoop.+   Where? typecheckLoop in GHC.Driver.Make.++3. Immediately after a reload, no ModDetails are live.+   Why? During the upsweep all old ModDetails are replaced with a new ModDetails+        generated from a ModIface. If we don't clear the ModDetails before the+        reload takes place then memory usage during the reload is twice as much+        as it should be as we retain a copy of the ModDetails for too long.+   Where? pruneCache in GHC.Driver.Make++4. No TcGblEnv or TcLclEnv are live after typechecking is completed.+   Why? By the time we get to simplification all the data structures from typechecking+        should be eliminated.+   Where? No one place in the compiler. These leaks can be introduced by not suitable+          forcing functions which take a TcLclEnv as an argument.++-}
GHC/Driver/MakeFile.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE CPP #-} + ----------------------------------------------------------------------------- -- -- Makefile Dependency Generation@@ -13,8 +13,6 @@    ) where -#include "HsVersions.h"- import GHC.Prelude  import qualified GHC@@ -23,14 +21,16 @@ import GHC.Driver.Ppr import GHC.Utils.Misc import GHC.Driver.Env+import GHC.Driver.Errors.Types import qualified GHC.SysTools as SysTools import GHC.Data.Graph.Directed ( SCC(..) ) import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Types.SourceError import GHC.Types.SrcLoc+import GHC.Types.PkgQual import Data.List (partition)-import GHC.Data.FastString import GHC.Utils.TmpFs  import GHC.Iface.Load (cannotFindModule)@@ -72,21 +72,23 @@     -- We therefore do the initial dependency generation with an empty     -- way and .o/.hi extensions, regardless of any flags that might     -- be specified.-    let dflags = dflags0+    let dflags1 = dflags0             { targetWays_ = Set.empty             , hiSuf_      = "hi"             , objectSuf_  = "o"             }-    GHC.setSessionDynFlags dflags+    GHC.setSessionDynFlags dflags1 -    when (null (depSuffixes dflags)) $ liftIO $-        throwGhcExceptionIO (ProgramError "You must specify at least one -dep-suffix")+    -- If no suffix is provided, use the default -- the empty one+    let dflags = if null (depSuffixes dflags1)+                 then dflags1 { depSuffixes = [""] }+                 else dflags1      tmpfs <- hsc_tmpfs <$> getSession     files <- liftIO $ beginMkDependHS logger tmpfs dflags      -- Do the downsweep to find all the modules-    targets <- mapM (\s -> GHC.guessTarget s Nothing) srcs+    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 -}@@ -96,7 +98,7 @@     let sorted = GHC.topSortModuleGraph False module_graph Nothing      -- Print out the dependencies if wanted-    liftIO $ debugTraceMsg logger dflags 2 (text "Module dependencies" $$ ppr sorted)+    liftIO $ debugTraceMsg logger 2 (text "Module dependencies" $$ ppr sorted)      -- Process them one by one, dumping results into makefile     -- and complaining about cycles@@ -105,10 +107,10 @@     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 dflags module_graph+    liftIO $ dumpModCycles logger module_graph      -- Tidy up-    liftIO $ endMkDependHS logger dflags files+    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@@ -136,7 +138,7 @@ 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 dflags TFL_CurrentModule "dep"+  tmp_file <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "dep"   tmp_hdl <- openFile tmp_file WriteMode          -- open the makefile@@ -212,14 +214,15 @@     throwGhcExceptionIO $ ProgramError $       showSDoc dflags $ GHC.cyclicModuleErr nodes -processDeps dflags _ _ _ _ (AcyclicSCC (InstantiationNode node))+processDeps dflags _ _ _ _ (AcyclicSCC (InstantiationNode _uid node))   =     -- There shouldn't be any backpack instantiations; report them as well     throwGhcExceptionIO $ ProgramError $       showSDoc dflags $         vcat [ text "Unexpected backpack instantiation in dependency graph while constructing Makefile:"              , nest 2 $ ppr node ]+processDeps _dflags _ _ _ _ (AcyclicSCC (LinkNode {})) = return () -processDeps dflags hsc_env excl_mods root hdl (AcyclicSCC (ModuleNode (ExtendedModSummary node _)))+processDeps dflags hsc_env excl_mods root hdl (AcyclicSCC (ModuleNode _ node))   = do  { let extra_suffixes = depSuffixes dflags               include_pkg_deps = depIncludePkgDeps dflags               src_file  = msHsFilePath node@@ -281,29 +284,30 @@  findDependency  :: HscEnv                 -> SrcSpan-                -> Maybe FastString     -- package qualifier, if any+                -> PkgQual              -- package qualifier, if any                 -> ModuleName           -- Imported module                 -> IsBootInterface      -- Source import                 -> Bool                 -- Record dependency on package modules                 -> IO (Maybe FilePath)  -- Interface file-findDependency hsc_env srcloc pkg imp is_boot include_pkg_deps-  = do  {       -- Find the module; this will be fast because-                -- we've done it once during downsweep-          r <- findImportedModule hsc_env imp pkg-        ; case r of-            Found loc _-                -- Home package: just depend on the .hi or hi-boot file-                | isJust (ml_hs_file loc) || include_pkg_deps-                -> return (Just (addBootSuffix_maybe is_boot (ml_hi_file loc)))+findDependency hsc_env srcloc pkg imp is_boot include_pkg_deps = do+  -- Find the module; this will be fast because+  -- we've done it once during downsweep+  r <- findImportedModule hsc_env imp pkg+  case r of+    Found loc _+        -- Home package: just depend on the .hi or hi-boot file+        | isJust (ml_hs_file loc) || include_pkg_deps+        -> return (Just (addBootSuffix_maybe is_boot (ml_hi_file loc))) -                -- Not in this package: we don't need a dependency-                | otherwise-                -> return Nothing+        -- Not in this package: we don't need a dependency+        | otherwise+        -> return Nothing -            fail ->-                throwOneError $ mkPlainMsgEnvelope srcloc $-                     cannotFindModule hsc_env imp fail-        }+    fail ->+        throwOneError $+          mkPlainErrorMsgEnvelope srcloc $+          GhcDriverMessage $ DriverUnknownMessage $ mkPlainError noHints $+             cannotFindModule hsc_env imp fail  ----------------------------- writeDependency :: FilePath -> Handle -> [FilePath] -> FilePath -> IO ()@@ -342,9 +346,9 @@ -- ----------------------------------------------------------------- -endMkDependHS :: Logger -> DynFlags -> MkDepFiles -> IO ()+endMkDependHS :: Logger -> MkDepFiles -> IO () -endMkDependHS logger dflags+endMkDependHS logger    (MkDep { mkd_make_file = makefile, mkd_make_hdl =  makefile_hdl,             mkd_tmp_file  = tmp_file, mkd_tmp_hdl  =  tmp_hdl })   = do@@ -354,79 +358,74 @@   case makefile_hdl of      Nothing  -> return ()      Just hdl -> do--          -- slurp the rest of the original makefile and copy it into the output-        let slurp = do-                l <- hGetLine hdl-                hPutStrLn tmp_hdl l-                slurp--        catchIO slurp-                (\e -> if isEOFError e then return () else ioError e)-+        -- 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)-       (SysTools.copy logger dflags ("Backing up " ++ makefile)-          makefile (makefile++".bak"))+  when (isJust makefile_hdl) $ do+    showPass logger ("Backing up " ++ makefile)+    SysTools.copyFile makefile (makefile++".bak")          -- Copy the new makefile in place-  SysTools.copy logger dflags "Installing new makefile" tmp_file makefile+  showPass logger "Installing new makefile"+  SysTools.copyFile tmp_file makefile   ----------------------------------------------------------------- --              Module cycles ----------------------------------------------------------------- -dumpModCycles :: Logger -> DynFlags -> ModuleGraph -> IO ()-dumpModCycles logger dflags module_graph-  | not (dopt Opt_D_dump_mod_cycles dflags)+dumpModCycles :: Logger -> ModuleGraph -> IO ()+dumpModCycles logger module_graph+  | not (logHasDumpFlag logger Opt_D_dump_mod_cycles)   = return ()    | null cycles-  = putMsg logger dflags (text "No module cycles")+  = putMsg logger (text "No module cycles")    | otherwise-  = putMsg logger dflags (hang (text "Module cycles found:") 2 pp_cycles)+  = putMsg logger (hang (text "Module cycles found:") 2 pp_cycles)   where-    topoSort = filterToposortToModules $-      GHC.topSortModuleGraph True module_graph Nothing+    topoSort = GHC.topSortModuleGraph True module_graph Nothing -    cycles :: [[ModSummary]]+    cycles :: [[ModuleGraphNode]]     cycles =       [ c | CyclicSCC c <- topoSort ] -    pp_cycles = vcat [ (text "---------- Cycle" <+> int n <+> ptext (sLit "----------"))+    pp_cycles = vcat [ (text "---------- Cycle" <+> int n <+> text "----------")                         $$ pprCycle c $$ blankLine                      | (n,c) <- [1..] `zip` cycles ] -pprCycle :: [ModSummary] -> SDoc+pprCycle :: [ModuleGraphNode] -> SDoc -- Print a cycle, but show only the imports within the cycle pprCycle summaries = pp_group (CyclicSCC summaries)   where     cycle_mods :: [ModuleName]  -- The modules in this cycle-    cycle_mods = map (moduleName . ms_mod) summaries+    cycle_mods = map (moduleName . ms_mod) [ms | ModuleNode _ ms <- summaries] -    pp_group (AcyclicSCC ms) = pp_ms ms+    pp_group :: SCC ModuleGraphNode -> SDoc+    pp_group (AcyclicSCC (ModuleNode _ ms)) = pp_ms ms+    pp_group (AcyclicSCC _) = empty     pp_group (CyclicSCC mss)-        = ASSERT( not (null boot_only) )+        = assert (not (null boot_only)) $                 -- The boot-only list must be non-empty, else there would                 -- be an infinite chain of non-boot imports, and we've                 -- already checked for that in processModDeps           pp_ms loop_breaker $$ vcat (map pp_group groups)         where           (boot_only, others) = partition is_boot_only mss-          is_boot_only ms = not (any in_group (map snd (ms_imps ms)))+          is_boot_only (ModuleNode _ ms) = not (any in_group (map snd (ms_imps ms)))+          is_boot_only  _ = False           in_group (L _ m) = m `elem` group_mods-          group_mods = map (moduleName . ms_mod) mss+          group_mods = map (moduleName . ms_mod) [ms | ModuleNode _ ms <- mss] -          loop_breaker = head boot_only+          loop_breaker = head ([ms | ModuleNode _ ms  <- boot_only])           all_others   = tail boot_only ++ others-          groups = filterToposortToModules $-            GHC.topSortModuleGraph True (mkModuleGraph $ extendModSummaryNoDeps <$> all_others) Nothing+          groups =+            GHC.topSortModuleGraph True (mkModuleGraph all_others) Nothing      pp_ms summary = text mod_str <> text (take (20 - length mod_str) (repeat ' '))                        <+> (pp_imps empty (map snd (ms_imps summary)) $$@@ -451,4 +450,3 @@ depStartMarker, depEndMarker :: String depStartMarker = "# DO NOT DELETE: Beginning of Haskell dependencies" depEndMarker   = "# DO NOT DELETE: End of Haskell dependencies"-
GHC/Driver/Monad.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, DeriveFunctor, DerivingVia, RankNTypes #-}+{-# LANGUAGE DeriveFunctor, DerivingVia, RankNTypes #-} {-# OPTIONS_GHC -funbox-strict-fields #-} -- ----------------------------------------------------------------------------- --@@ -27,8 +27,8 @@         putMsgM,         withTimingM, -        -- ** Warnings-        logWarnings, printException,+        -- ** Diagnostics+        logDiagnostics, printException,         WarnErrLogger, defaultWarnErrLogger   ) where @@ -36,7 +36,9 @@  import GHC.Driver.Session import GHC.Driver.Env-import GHC.Driver.Errors ( printOrThrowWarnings, printBagOfErrors )+import GHC.Driver.Errors ( printOrThrowDiagnostics, printMessages )+import GHC.Driver.Errors.Types+import GHC.Driver.Config.Diagnostic  import GHC.Utils.Monad import GHC.Utils.Exception@@ -122,32 +124,30 @@ -- | Put a log message putMsgM :: GhcMonad m => SDoc -> m () putMsgM doc = do-    dflags <- getDynFlags     logger <- getLogger-    liftIO $ putMsg logger dflags doc+    liftIO $ putMsg logger doc  -- | Put a log message-putLogMsgM :: GhcMonad m => WarnReason -> Severity -> SrcSpan -> SDoc -> m ()-putLogMsgM reason sev loc doc = do-    dflags <- getDynFlags+putLogMsgM :: GhcMonad m => MessageClass -> SrcSpan -> SDoc -> m ()+putLogMsgM msg_class loc doc = do     logger <- getLogger-    liftIO $ putLogMsg logger dflags reason sev loc doc+    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-    dflags <- getDynFlags-    withTiming logger dflags doc force action+    withTiming logger doc force action  -- -------------------------------------------------------------------------------- | A monad that allows logging of warnings.+-- | A monad that allows logging of diagnostics. -logWarnings :: GhcMonad m => WarningMessages -> m ()-logWarnings warns = do+logDiagnostics :: GhcMonad m => Messages GhcMessage -> m ()+logDiagnostics warns = do   dflags <- getSessionDynFlags   logger <- getLogger-  liftIO $ printOrThrowWarnings logger dflags warns+  let !diag_opts = initDiagOpts dflags+  liftIO $ printOrThrowDiagnostics logger diag_opts warns  -- ----------------------------------------------------------------------------- -- | A minimal implementation of a 'GhcMonad'.  If you need a custom monad,@@ -240,18 +240,18 @@   setSession s' = GhcT $ \(Session r) -> liftIO $ writeIORef r s'  --- | Print the error message and all warnings.  Useful inside exception---   handlers.  Clears warnings after printing.-printException :: GhcMonad m => SourceError -> m ()+-- | Print the all diagnostics in a 'SourceError'.  Useful inside exception+--   handlers.+printException :: (HasLogger m, MonadIO m, HasDynFlags m) => SourceError -> m () printException err = do-  dflags <- getSessionDynFlags+  dflags <- getDynFlags   logger <- getLogger-  liftIO $ printBagOfErrors logger dflags (srcErrorMessages err)+  let !diag_opts = initDiagOpts dflags+  liftIO $ printMessages logger diag_opts (srcErrorMessages err)  -- | A function called to log warnings and errors.-type WarnErrLogger = forall m. GhcMonad m => Maybe SourceError -> m ()+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
@@ -1,5 +1,3 @@-{-# LANGUAGE CPP #-}- ----------------------------------------------------------------------------- -- -- GHC Driver@@ -10,10 +8,13 @@  module GHC.Driver.Phases (    Phase(..),-   happensBefore, eqPhase, anyHsc, isStopLn,+   happensBefore, eqPhase, isStopLn,    startPhase,    phaseInputExt, +   StopPhase(..),+   stopPhaseToPhase,+    isHaskellishSuffix,    isHaskellSrcSuffix,    isBackpackishSuffix,@@ -38,8 +39,6 @@    phaseForeignLanguage  ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Platform@@ -67,8 +66,22 @@    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@@ -88,7 +101,6 @@         | MergeForeign  -- merge in the foreign object files          -- The final phase is a pseudo-phase that tells the pipeline to stop.-        -- There is no runPhase case for it.         | StopLn        -- Stop, but linking will follow, so generate .o file   deriving (Eq, Show) @@ -124,22 +136,8 @@ eqPhase Cobjcxx     Cobjcxx    = True eqPhase _           _          = False -{- Note [Partial ordering on phases]--We want to know which phases will occur before which others. This is used for-sanity checking, to ensure that the pipeline will stop at some point (see-GHC.Driver.Pipeline.runPipeline).--A < B iff A occurs before B in a normal compilation pipeline.--There is explicitly not a total ordering on phases, because in registerised-builds, the phase `HsC` doesn't happen before nor after any other phase.--Although we check that a normal user doesn't set the stop_phase to HsC through-use of -C with registerised builds (in Main.checkOptions), it is still-possible for a ghc-api user to do so. So be careful when using the function-happensBefore, and don't think that `not (a <= b)` implies `b < a`.--}+-- 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@@ -213,7 +211,7 @@ phaseInputExt (HsPp  _)           = "hscpp"     -- intermediate only phaseInputExt (Hsc   _)           = "hspp"      -- intermediate only         -- NB: as things stand, phaseInputExt (Hsc x) must not evaluate x-        --     because runPipeline uses the StopBefore phase to pick the+        --     because runPhase uses the StopBefore phase to pick the         --     output filename.  That could be fixed, but watch out. phaseInputExt HCc                 = "hc" phaseInputExt Ccxx                = "cpp"
GHC/Driver/Pipeline.hs view
@@ -1,2251 +1,909 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE NondecreasingIndentation #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE LambdaCase #-}--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}------------------------------------------------------------------------------------- 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',-   link,--        -- Exports for hooks to override runPhase and link-   PhasePlus(..), CompPipeline(..), PipeEnv(..), PipeState(..),-   phaseOutputFilename, getOutputFilename, getPipeState, getPipeEnv,-   hscPostBackendPhase, getLocation, setModLocation, setDynFlags,-   runPhase,-   doCpp,-   linkingNeeded, checkLinkInfo, writeInterfaceOnlyMode-  ) where--#include <ghcplatform.h>-#include "HsVersions.h"--import GHC.Prelude--import GHC.Platform--import GHC.Tc.Types--import GHC.Driver.Main-import GHC.Driver.Env hiding ( Hsc )-import GHC.Driver.Errors-import GHC.Driver.Pipeline.Monad-import GHC.Driver.Config-import GHC.Driver.Phases-import GHC.Driver.Session-import GHC.Driver.Backend-import GHC.Driver.Ppr-import GHC.Driver.Hooks--import GHC.Platform.Ways-import GHC.Platform.ArchOS--import GHC.Parser.Header-import GHC.Parser.Errors.Ppr--import GHC.SysTools-import GHC.Utils.TmpFs--import GHC.Linker.ExtraObj-import GHC.Linker.Dynamic-import GHC.Linker.Static-import GHC.Linker.Types--import GHC.Utils.Outputable-import GHC.Utils.Error-import GHC.Utils.Panic-import GHC.Utils.Misc-import GHC.Utils.Monad-import GHC.Utils.Exception as Exception-import GHC.Utils.Logger--import GHC.CmmToLlvm         ( llvmFixupAsm, llvmVersionList )-import qualified GHC.LanguageExtensions as LangExt-import GHC.Settings--import GHC.Data.Bag            ( unitBag )-import GHC.Data.FastString     ( mkFastString )-import GHC.Data.StringBuffer   ( hGetStringBuffer, hPutStringBuffer )-import GHC.Data.Maybe          ( expectJust )--import GHC.Iface.Make          ( mkFullIface )--import GHC.Types.Basic       ( SuccessFlag(..) )-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.State-import GHC.Unit.Finder-import GHC.Unit.Module.ModSummary-import GHC.Unit.Module.ModIface-import GHC.Unit.Module.Graph (needsTemplateHaskellOrQQ)-import GHC.Unit.Module.Deps-import GHC.Unit.Home.ModInfo--import System.Directory-import System.FilePath-import System.IO-import Control.Monad-import qualified Control.Monad.Catch as MC (handle)-import Data.List        ( isInfixOf, intercalate )-import Data.Maybe-import Data.Version-import Data.Either      ( partitionEithers )--import Data.Time        ( UTCTime )---- ------------------------------------------------------------------------------ Pre-process---- | Just preprocess a file, put the result in a temp. file (used by the--- compilation manager during the summary phase).------ We return the augmented DynFlags, because they contain the result--- of slurping in the OPTIONS pragmas--preprocess :: HscEnv-           -> FilePath -- ^ input filename-           -> Maybe InputFileBuffer-           -- ^ optional buffer to use instead of reading the input file-           -> Maybe Phase -- ^ starting phase-           -> IO (Either ErrorMessages (DynFlags, FilePath))-preprocess hsc_env input_fn mb_input_buf mb_phase =-  handleSourceError (\err -> return (Left (srcErrorMessages err))) $-  MC.handle handler $-  fmap Right $ do-  MASSERT2(isJust mb_phase || isHaskellSrcFilename input_fn, text input_fn)-  (dflags, fp, mb_iface) <- runPipeline anyHsc hsc_env (input_fn, mb_input_buf, fmap RealPhase mb_phase)-        Nothing-        -- We keep the processed file for the whole session to save on-        -- duplicated work in ghci.-        (Temporary TFL_GhcSession)-        Nothing{-no ModLocation-}-        []{-no foreign objects-}-  -- We stop before Hsc phase so we shouldn't generate an interface-  MASSERT(isNothing mb_iface)-  return (dflags, fp)-  where-    srcspan = srcLocSpan $ mkSrcLoc (mkFastString input_fn) 1 1-    handler (ProgramError msg) = return $ Left $ unitBag $-        mkPlainMsgEnvelope srcspan $ text msg-    handler ex = throwGhcExceptionIO ex---- ------------------------------------------------------------------------------- | Compile------ Compile a single module, under the control of the compilation manager.------ This is the interface between the compilation manager and the--- compiler proper (hsc), where we deal with tedious details like--- reading the OPTIONS pragma from the source file, converting the--- C or assembly that GHC produces into an object file, and compiling--- FFI stub files.------ NB.  No old interface can also mean that the source has changed.--compileOne :: HscEnv-           -> ModSummary      -- ^ summary for module being compiled-           -> Int             -- ^ module N ...-           -> Int             -- ^ ... of M-           -> Maybe ModIface  -- ^ old interface, if we have one-           -> Maybe Linkable  -- ^ old linkable, if we have one-           -> SourceModified-           -> IO HomeModInfo   -- ^ the complete HomeModInfo, if successful--compileOne = compileOne' Nothing (Just batchMsg)--compileOne' :: Maybe TcGblEnv-            -> Maybe Messager-            -> HscEnv-            -> ModSummary      -- ^ summary for module being compiled-            -> Int             -- ^ module N ...-            -> Int             -- ^ ... of M-            -> Maybe ModIface  -- ^ old interface, if we have one-            -> Maybe Linkable  -- ^ old linkable, if we have one-            -> SourceModified-            -> IO HomeModInfo   -- ^ the complete HomeModInfo, if successful--compileOne' m_tc_result mHscMessage-            hsc_env0 summary mod_index nmods mb_old_iface mb_old_linkable-            source_modified0- = do--   let logger = hsc_logger hsc_env0-   let tmpfs  = hsc_tmpfs hsc_env0-   debugTraceMsg logger dflags1 2 (text "compile: input file" <+> text input_fnpp)--   -- Run the pipeline up to codeGen (so everything up to, but not including, STG)-   (status, plugin_hsc_env) <- hscIncrementalCompile-                        always_do_basic_recompilation_check-                        m_tc_result mHscMessage-                        hsc_env summary source_modified mb_old_iface (mod_index, nmods)-   -- Use an HscEnv updated with the plugin info-   let hsc_env' = plugin_hsc_env--   let flags = hsc_dflags hsc_env0-     in do unless (gopt Opt_KeepHiFiles flags) $-               addFilesToClean tmpfs TFL_CurrentModule $-                   [ml_hi_file $ ms_location summary]-           unless (gopt Opt_KeepOFiles flags) $-               addFilesToClean tmpfs TFL_GhcSession $-                   [ml_obj_file $ ms_location summary]--   case (status, bcknd) of-        (HscUpToDate iface hmi_details, _) ->-            -- TODO recomp014 triggers this assert. What's going on?!-            -- ASSERT( isJust mb_old_linkable || isNoLink (ghcLink dflags) )-            return $! HomeModInfo iface hmi_details mb_old_linkable-        (HscNotGeneratingCode iface hmi_details, NoBackend) ->-            let mb_linkable = if isHsBootOrSig src_flavour-                                then Nothing-                                -- TODO: Questionable.-                                else Just (LM (ms_hs_date summary) this_mod [])-            in return $! HomeModInfo iface hmi_details mb_linkable-        (HscNotGeneratingCode _ _, _) -> panic "compileOne HscNotGeneratingCode"-        (_, NoBackend) -> panic "compileOne NoBackend"-        (HscUpdateBoot iface hmi_details, Interpreter) ->-            return $! HomeModInfo iface hmi_details Nothing-        (HscUpdateBoot iface hmi_details, _) -> do-            touchObjectFile logger dflags object_filename-            return $! HomeModInfo iface hmi_details Nothing-        (HscUpdateSig iface hmi_details, Interpreter) -> do-            let !linkable = LM (ms_hs_date summary) this_mod []-            return $! HomeModInfo iface hmi_details (Just linkable)-        (HscUpdateSig iface hmi_details, _) -> do-            output_fn <- getOutputFilename logger tmpfs next_phase-                            (Temporary TFL_CurrentModule) basename dflags-                            next_phase (Just location)--            -- #10660: Use the pipeline instead of calling-            -- compileEmptyStub directly, so -dynamic-too gets-            -- handled properly-            _ <- runPipeline StopLn hsc_env'-                              (output_fn,-                               Nothing,-                               Just (HscOut src_flavour-                                            mod_name (HscUpdateSig iface hmi_details)))-                              (Just basename)-                              Persistent-                              (Just location)-                              []-            o_time <- getModificationUTCTime object_filename-            let !linkable = LM o_time this_mod [DotO object_filename]-            return $! HomeModInfo iface hmi_details (Just linkable)-        (HscRecomp { hscs_guts = cgguts,-                     hscs_mod_location = mod_location,-                     hscs_partial_iface = partial_iface,-                     hscs_old_iface_hash = mb_old_iface_hash-                   }, Interpreter) -> do-            -- In interpreted mode the regular codeGen backend is not run so we-            -- generate a interface without codeGen info.-            final_iface <- mkFullIface hsc_env' partial_iface Nothing-            -- Reconstruct the `ModDetails` from the just-constructed `ModIface`-            -- See Note [ModDetails and --make mode]-            hmi_details <- liftIO $ initModDetails hsc_env' summary final_iface-            liftIO $ hscMaybeWriteIface logger dflags True final_iface mb_old_iface_hash (ms_location summary)--            (hasStub, comp_bc, spt_entries) <- hscInteractive hsc_env' cgguts mod_location--            stub_o <- case hasStub of-                      Nothing -> return []-                      Just stub_c -> do-                          stub_o <- compileStub hsc_env' stub_c-                          return [DotO stub_o]--            let hs_unlinked = [BCOs comp_bc spt_entries]-                unlinked_time = ms_hs_date summary-              -- Why do we use the timestamp of the source file here,-              -- rather than the current time?  This works better in-              -- the case where the local clock is out of sync-              -- with the filesystem's clock.  It's just as accurate:-              -- if the source is modified, then the linkable will-              -- be out of date.-            let !linkable = LM unlinked_time (ms_mod summary)-                           (hs_unlinked ++ stub_o)-            return $! HomeModInfo final_iface hmi_details (Just linkable)-        (HscRecomp{}, _) -> do-            output_fn <- getOutputFilename logger tmpfs next_phase-                            (Temporary TFL_CurrentModule)-                            basename dflags next_phase (Just location)-            -- We're in --make mode: finish the compilation pipeline.-            (_, _, Just iface) <- runPipeline StopLn hsc_env'-                              (output_fn,-                               Nothing,-                               Just (HscOut src_flavour mod_name status))-                              (Just basename)-                              Persistent-                              (Just location)-                              []-                  -- The object filename comes from the ModLocation-            o_time <- getModificationUTCTime object_filename-            let !linkable = LM o_time this_mod [DotO object_filename]-            -- See Note [ModDetails and --make mode]-            details <- initModDetails hsc_env' summary iface-            return $! HomeModInfo iface details (Just linkable)-- where dflags0     = ms_hspp_opts summary-       this_mod    = ms_mod summary-       location    = ms_location summary-       input_fn    = expectJust "compile:hs" (ml_hs_file location)-       input_fnpp  = ms_hspp_file summary-       mod_graph   = hsc_mod_graph hsc_env0-       needsLinker = needsTemplateHaskellOrQQ mod_graph-       isDynWay    = any (== WayDyn) (ways dflags0)-       isProfWay   = any (== WayProf) (ways dflags0)-       internalInterpreter = not (gopt Opt_ExternalInterpreter dflags0)--       src_flavour = ms_hsc_src summary-       mod_name = ms_mod_name summary-       next_phase = hscPostBackendPhase src_flavour bcknd-       object_filename = ml_obj_file location--       -- #8180 - when using TemplateHaskell, switch on -dynamic-too so-       -- the linker can correctly load the object files.  This isn't necessary-       -- when using -fexternal-interpreter.-       dflags1 = if hostIsDynamic && internalInterpreter &&-                    not isDynWay && not isProfWay && needsLinker-                  then gopt_set dflags0 Opt_BuildDynamicToo-                  else dflags0--       -- #16331 - when no "internal interpreter" is available but we-       -- need to process some TemplateHaskell or QuasiQuotes, we automatically-       -- turn on -fexternal-interpreter.-       dflags2 = if not internalInterpreter && needsLinker-                 then gopt_set dflags1 Opt_ExternalInterpreter-                 else dflags1--       basename = dropExtension input_fn--       -- We add the directory in which the .hs files resides) to the import-       -- path.  This is needed when we try to compile the .hc file later, if it-       -- imports a _stub.h file that we created here.-       current_dir = takeDirectory basename-       old_paths   = includePaths dflags2-       loadAsByteCode-         | Just (Target _ 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-         = (Interpreter, dflags2 { backend = Interpreter })-         | otherwise-         = (backend dflags, dflags2)-       dflags  = dflags3 { includePaths = addImplicitQuoteInclude old_paths [current_dir] }-       hsc_env = hsc_env0 {hsc_dflags = dflags}--       -- -fforce-recomp should also work with --make-       force_recomp = gopt Opt_ForceRecomp dflags-       source_modified-         -- #8042: Usually pre-compiled code is preferred to be loaded in ghci-         -- if available. So, if the "*" prefix was used, force recompilation-         -- to make sure byte-code is loaded.-         | force_recomp || loadAsByteCode = SourceModified-         | otherwise = source_modified0--       always_do_basic_recompilation_check = case bcknd of-                                             Interpreter -> True-                                             _ -> False---------------------------------------------------------------------------------- stub .h and .c files (for foreign export support), and cc files.---- The _stub.c file is derived from the haskell source file, possibly taking--- into account the -stubdir option.------ The object file created by compiling the _stub.c file is put into a--- temporary file, which will be later combined with the main .o file--- (see the MergeForeigns phase).------ Moreover, we also let the user emit arbitrary C/C++/ObjC/ObjC++ files--- from TH, that are then compiled and linked to the module. This is--- useful to implement facilities such as inline-c.--compileForeign :: HscEnv -> ForeignSrcLang -> FilePath -> IO FilePath-compileForeign _ RawObject object_file = return object_file-compileForeign hsc_env lang stub_c = do-        let phase = case lang of-              LangC      -> Cc-              LangCxx    -> Ccxx-              LangObjc   -> Cobjc-              LangObjcxx -> Cobjcxx-              LangAsm    -> As True -- allow CPP-#if __GLASGOW_HASKELL__ < 811-              RawObject  -> panic "compileForeign: should be unreachable"-#endif-        (_, stub_o, _) <- runPipeline StopLn hsc_env-                       (stub_c, Nothing, Just (RealPhase phase))-                       Nothing (Temporary TFL_GhcSession)-                       Nothing{-no ModLocation-}-                       []-        return stub_o--compileStub :: HscEnv -> FilePath -> IO FilePath-compileStub hsc_env stub_c = compileForeign hsc_env LangC stub_c--compileEmptyStub :: DynFlags -> HscEnv -> FilePath -> ModLocation -> ModuleName -> IO ()-compileEmptyStub dflags hsc_env basename location mod_name = do-  -- To maintain the invariant that every Haskell file-  -- compiles to object code, we make an empty (but-  -- valid) stub object file for signatures.  However,-  -- we make sure this object file has a unique symbol,-  -- so that ranlib on OS X doesn't complain, see-  -- https://gitlab.haskell.org/ghc/ghc/issues/12673-  -- and https://github.com/haskell/cabal/issues/2257-  let logger = hsc_logger hsc_env-  let tmpfs  = hsc_tmpfs hsc_env-  empty_stub <- newTempName logger tmpfs dflags TFL_CurrentModule "c"-  let home_unit = hsc_home_unit hsc_env-      src = text "int" <+> ppr (mkHomeModule home_unit mod_name) <+> text "= 0;"-  writeFile empty_stub (showSDoc dflags (pprCode CStyle src))-  _ <- runPipeline StopLn hsc_env-                  (empty_stub, Nothing, Nothing)-                  (Just basename)-                  Persistent-                  (Just location)-                  []-  return ()---- ------------------------------------------------------------------------------ Link------ Note [Dynamic linking on macOS]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~------ Since macOS Sierra (10.14), the dynamic system linker enforces--- a limit on the Load Commands.  Specifically the Load Command Size--- Limit is at 32K (32768).  The Load Commands contain the install--- name, dependencies, runpaths, and a few other commands.  We however--- only have control over the install name, dependencies and runpaths.------ The install name is the name by which this library will be--- referenced.  This is such that we do not need to bake in the full--- absolute location of the library, and can move the library around.------ The dependency commands contain the install names from of referenced--- libraries.  Thus if a libraries install name is @rpath/libHS...dylib,--- that will end up as the dependency.------ Finally we have the runpaths, which informs the linker about the--- directories to search for the referenced dependencies.------ The system linker can do recursive linking, however using only the--- direct dependencies conflicts with ghc's ability to inline across--- packages, and as such would end up with unresolved symbols.------ Thus we will pass the full dependency closure to the linker, and then--- ask the linker to remove any unused dynamic libraries (-dead_strip_dylibs).------ We still need to add the relevant runpaths, for the dynamic linker to--- lookup the referenced libraries though.  The linker (ld64) does not--- have any option to dead strip runpaths; which makes sense as runpaths--- can be used for dependencies of dependencies as well.------ The solution we then take in GHC is to not pass any runpaths to the--- linker at link time, but inject them after the linking.  For this to--- work we'll need to ask the linker to create enough space in the header--- to add more runpaths after the linking (-headerpad 8000).------ After the library has been linked by $LD (usually ld64), we will use--- otool to inspect the libraries left over after dead stripping, compute--- the relevant runpaths, and inject them into the linked product using--- the install_name_tool command.------ This strategy should produce the smallest possible set of load commands--- while still retaining some form of relocatability via runpaths.------ The only way I can see to reduce the load command size further would be--- by shortening the library names, or start putting libraries into the same--- folders, such that one runpath would be sufficient for multiple/all--- libraries.-link :: GhcLink                 -- ^ interactive or batch-     -> Logger                  -- ^ Logger-     -> TmpFs-     -> Hooks-     -> DynFlags                -- ^ dynamic flags-     -> UnitEnv                 -- ^ unit environment-     -> Bool                    -- ^ attempt linking in batch mode?-     -> HomePackageTable        -- ^ what to link-     -> IO SuccessFlag---- For the moment, in the batch linker, we don't bother to tell doLink--- which packages to link -- it just tries all that are available.--- batch_attempt_linking should only be *looked at* in batch mode.  It--- should only be True if the upsweep was successful and someone--- exports main, i.e., we have good reason to believe that linking--- will succeed.--link ghcLink logger tmpfs hooks dflags unit_env batch_attempt_linking hpt =-  case linkHook hooks of-      Nothing -> case ghcLink of-          NoLink        -> return Succeeded-          LinkBinary    -> link' logger tmpfs dflags unit_env batch_attempt_linking hpt-          LinkStaticLib -> link' logger tmpfs dflags unit_env batch_attempt_linking hpt-          LinkDynLib    -> link' logger tmpfs dflags unit_env batch_attempt_linking hpt-          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---panicBadLink :: GhcLink -> a-panicBadLink other = panic ("link: GHC not built to link this way: " ++-                            show other)--link' :: Logger-      -> TmpFs-      -> DynFlags                -- ^ dynamic flags-      -> UnitEnv                 -- ^ unit environment-      -> Bool                    -- ^ attempt linking in batch mode?-      -> HomePackageTable        -- ^ what to link-      -> IO SuccessFlag--link' logger tmpfs dflags unit_env batch_attempt_linking hpt-   | batch_attempt_linking-   = do-        let-            staticLink = case ghcLink dflags of-                          LinkStaticLib -> True-                          _ -> False--            home_mod_infos = eltsHpt hpt--            -- the packages we depend on-            pkg_deps  = concatMap (map fst . dep_pkgs . mi_deps . hm_iface) home_mod_infos--            -- the linkables to link-            linkables = map (expectJust "link".hm_linkable) home_mod_infos--        debugTraceMsg logger dflags 3 (text "link: linkables are ..." $$ vcat (map ppr linkables))--        -- check for the -no-link flag-        if isNoLink (ghcLink dflags)-          then do debugTraceMsg logger dflags 3 (text "link(batch): linking omitted (-c flag given).")-                  return Succeeded-          else do--        let getOfiles (LM _ _ us) = map nameOfObject (filter isObject us)-            obj_files = concatMap getOfiles linkables-            platform  = targetPlatform dflags-            exe_file  = exeFileName platform staticLink (outputFile dflags)--        linking_needed <- linkingNeeded logger dflags unit_env staticLink linkables pkg_deps--        if not (gopt Opt_ForceRecomp dflags) && not linking_needed-           then do debugTraceMsg logger dflags 2 (text exe_file <+> text "is up to date, linking not required.")-                   return Succeeded-           else do--        compilationProgressMsg logger dflags (text "Linking " <> text exe_file <> text " ...")--        -- Don't showPass in Batch mode; doLink will do that for us.-        let link = case ghcLink dflags of-                LinkBinary    -> linkBinary logger tmpfs-                LinkStaticLib -> linkStaticLib logger-                LinkDynLib    -> linkDynLibCheck logger tmpfs-                other         -> panicBadLink other-        link dflags unit_env obj_files pkg_deps--        debugTraceMsg logger dflags 3 (text "link: done")--        -- linkBinary only returns if it succeeds-        return Succeeded--   | otherwise-   = do debugTraceMsg logger dflags 3 (text "link(batch): upsweep (partially) failed OR" $$-                                text "   Main.main not exported; not linking.")-        return Succeeded---linkingNeeded :: Logger -> DynFlags -> UnitEnv -> Bool -> [Linkable] -> [UnitId] -> IO Bool-linkingNeeded logger dflags unit_env staticLink linkables pkg_deps = do-        -- if the modification time on the executable is later than the-        -- modification times on all of the objects and libraries, then omit-        -- linking (unless the -fforce-recomp flag was given).-  let platform   = ue_platform unit_env-      unit_state = ue_units unit_env-      exe_file   = exeFileName platform staticLink (outputFile dflags)-  e_exe_time <- tryIO $ getModificationUTCTime exe_file-  case e_exe_time of-    Left _  -> return True-    Right t -> do-        -- first check object files and extra_ld_inputs-        let extra_ld_inputs = [ f | FileOption _ f <- ldInputs dflags ]-        e_extra_times <- mapM (tryIO . getModificationUTCTime) extra_ld_inputs-        let (errs,extra_times) = partitionEithers e_extra_times-        let obj_times =  map linkableTime linkables ++ extra_times-        if not (null errs) || any (t <) obj_times-            then return True-            else do--        -- next, check libraries. XXX this only checks Haskell libraries,-        -- not extra_libraries or -l things from the command line.-        let pkg_hslibs  = [ (collectLibraryDirs (ways dflags) [c], lib)-                          | Just c <- map (lookupUnitId unit_state) pkg_deps,-                            lib <- unitHsLibs (ghcNameVersion dflags) (ways dflags) c ]--        pkg_libfiles <- mapM (uncurry (findHSLib platform (ways dflags))) pkg_hslibs-        if any isNothing pkg_libfiles then return True else do-        e_lib_times <- mapM (tryIO . getModificationUTCTime)-                          (catMaybes pkg_libfiles)-        let (lib_errs,lib_times) = partitionEithers e_lib_times-        if not (null lib_errs) || any (t <) lib_times-           then return True-           else checkLinkInfo logger dflags unit_env pkg_deps exe_file--findHSLib :: Platform -> Ways -> [String] -> String -> IO (Maybe FilePath)-findHSLib platform ws dirs lib = do-  let batch_lib_file = if WayDyn `notElem` ws-                      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 -> Phase -> [(String, Maybe Phase)] -> IO ()-oneShot hsc_env stop_phase srcs = do-  o_files <- mapM (compileFile hsc_env stop_phase) srcs-  doLink hsc_env stop_phase o_files--compileFile :: HscEnv -> Phase -> (FilePath, Maybe Phase) -> IO FilePath-compileFile hsc_env stop_phase (src, mb_phase) = do-   exists <- doesFileExist src-   when (not exists) $-        throwGhcExceptionIO (CmdLineError ("does not exist: " ++ src))--   let-        dflags    = hsc_dflags hsc_env-        mb_o_file = outputFile dflags-        ghc_link  = ghcLink dflags      -- Set by -c or -no-link--        -- When linking, the -o argument refers to the linker's output.-        -- otherwise, we use it as the name for the pipeline's output.-        output-         -- If we are doing -fno-code, then act as if the output is-         -- 'Temporary'. This stops GHC trying to copy files to their-         -- final location.-         | NoBackend <- backend dflags = Temporary TFL_CurrentModule-         | StopLn <- stop_phase, not (isNoLink ghc_link) = Persistent-                -- -o foo applies to linker-         | isJust mb_o_file = SpecificFile-                -- -o foo applies to the file we are compiling now-         | otherwise = Persistent--   ( _, out_file, _) <- runPipeline stop_phase hsc_env-                            (src, Nothing, fmap RealPhase mb_phase)-                            Nothing-                            output-                            Nothing{-no ModLocation-} []-   return out_file---doLink :: HscEnv -> Phase -> [FilePath] -> IO ()-doLink hsc_env stop_phase o_files-  | not (isStopLn stop_phase)-  = return ()           -- We stopped before the linking phase--  | otherwise-  = let-        dflags   = hsc_dflags   hsc_env-        logger   = hsc_logger   hsc_env-        unit_env = hsc_unit_env hsc_env-        tmpfs    = hsc_tmpfs    hsc_env-    in case ghcLink dflags of-        NoLink        -> return ()-        LinkBinary    -> 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 []-        other         -> panicBadLink other----- ------------------------------------------------------------------------------- | Run a compilation pipeline, consisting of multiple phases.------ This is the interface to the compilation pipeline, which runs--- a series of compilation steps on a single source file, specifying--- at which stage to stop.------ The DynFlags can be modified by phases in the pipeline (eg. by--- OPTIONS_GHC pragmas), and the changes affect later phases in the--- pipeline.-runPipeline-  :: Phase                      -- ^ When to stop-  -> HscEnv                     -- ^ Compilation environment-  -> (FilePath, Maybe InputFileBuffer, Maybe PhasePlus)-                                -- ^ Pipeline input file name, optional-                                -- buffer and maybe -x suffix-  -> Maybe FilePath             -- ^ original basename (if different from ^^^)-  -> PipelineOutput             -- ^ Output filename-  -> Maybe ModLocation          -- ^ A ModLocation, if this is a Haskell module-  -> [FilePath]                 -- ^ foreign objects-  -> IO (DynFlags, FilePath, Maybe ModIface)-                                -- ^ (final flags, output filename, interface)-runPipeline stop_phase hsc_env0 (input_fn, mb_input_buf, mb_phase)-             mb_basename output maybe_loc foreign_os--    = do let-             dflags0 = hsc_dflags hsc_env0--             -- Decide where dump files should go based on the pipeline output-             dflags = dflags0 { dumpPrefix = Just (basename ++ ".") }-             hsc_env = hsc_env0 {hsc_dflags = dflags}-             logger = hsc_logger hsc_env-             tmpfs  = hsc_tmpfs  hsc_env--             (input_basename, suffix) = splitExtension input_fn-             suffix' = drop 1 suffix -- strip off the .-             basename | Just b <- mb_basename = b-                      | otherwise             = input_basename--             -- If we were given a -x flag, then use that phase to start from-             start_phase = fromMaybe (RealPhase (startPhase suffix')) mb_phase--             isHaskell (RealPhase (Unlit _)) = True-             isHaskell (RealPhase (Cpp   _)) = True-             isHaskell (RealPhase (HsPp  _)) = True-             isHaskell (RealPhase (Hsc   _)) = True-             isHaskell (HscOut {})           = True-             isHaskell _                     = False--             isHaskellishFile = isHaskell start_phase--             env = PipeEnv{ stop_phase,-                            src_filename = input_fn,-                            src_basename = basename,-                            src_suffix = suffix',-                            output_spec = output }--         when (isBackpackishSuffix suffix') $-           throwGhcExceptionIO (UsageError-                       ("use --backpack to process " ++ input_fn))--         -- We want to catch cases of "you can't get there from here" before-         -- we start the pipeline, because otherwise it will just run off the-         -- end.-         let happensBefore' = happensBefore (targetPlatform dflags)-         case start_phase of-             RealPhase start_phase' ->-                 -- See Note [Partial ordering on phases]-                 -- Not the same as: (stop_phase `happensBefore` start_phase')-                 when (not (start_phase' `happensBefore'` stop_phase ||-                            start_phase' `eqPhase` stop_phase)) $-                       throwGhcExceptionIO (UsageError-                                   ("cannot compile this file to desired target: "-                                      ++ input_fn))-             HscOut {} -> return ()--         -- Write input buffer to temp file if requested-         input_fn' <- case (start_phase, mb_input_buf) of-             (RealPhase real_start_phase, Just input_buf) -> do-                 let suffix = phaseInputExt real_start_phase-                 fn <- newTempName logger tmpfs dflags TFL_CurrentModule suffix-                 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-             (_, _) -> return input_fn--         debugTraceMsg logger dflags 4 (text "Running the pipeline")-         r <- runPipeline' start_phase hsc_env env input_fn'-                           maybe_loc foreign_os--         let dflags = hsc_dflags hsc_env-         when isHaskellishFile $-           dynamicTooState dflags >>= \case-               DT_Dont   -> return ()-               DT_Dyn    -> return ()-               DT_OK     -> return ()-               -- If we are compiling a Haskell module with -dynamic-too, we-               -- first try the "fast path": that is we compile the non-dynamic-               -- version and at the same time we check that interfaces depended-               -- on exist both for the non-dynamic AND the dynamic way. We also-               -- check that they have the same hash.-               --    If they don't, dynamicTooState is set to DT_Failed.-               --       See GHC.Iface.Load.checkBuildDynamicToo-               --    If they do, in the end we produce both the non-dynamic and-               --    dynamic outputs.-               ---               -- If this "fast path" failed, we execute the whole pipeline-               -- again, this time for the dynamic way *only*. To do that we-               -- just set the dynamicNow bit from the start to ensure that the-               -- dynamic DynFlags fields are used and we disable -dynamic-too-               -- (its state is already set to DT_Failed so it wouldn't do much-               -- anyway).-               DT_Failed-                   -- NB: Currently disabled on Windows (ref #7134, #8228, and #5987)-                   | OSMinGW32 <- platformOS (targetPlatform dflags) -> return ()-                   | otherwise -> do-                       debugTraceMsg logger dflags 4-                           (text "Running the full pipeline again for -dynamic-too")-                       let dflags0 = flip gopt_unset Opt_BuildDynamicToo-                                      $ setDynamicNow-                                      $ dflags-                       hsc_env' <- newHscEnv dflags0-                       (dbs,unit_state,home_unit,mconstants) <- initUnits logger dflags0 Nothing-                       dflags1 <- updatePlatformConstants dflags0 mconstants-                       let unit_env = UnitEnv-                             { ue_platform  = targetPlatform dflags1-                             , ue_namever   = ghcNameVersion dflags1-                             , ue_home_unit = home_unit-                             , ue_units     = unit_state-                             }-                       let hsc_env'' = hsc_env'-                            { hsc_dflags   = dflags1-                            , hsc_unit_env = unit_env-                            , hsc_unit_dbs = Just dbs-                            }-                       _ <- runPipeline' start_phase hsc_env'' env input_fn'-                                         maybe_loc foreign_os-                       return ()-         return r--runPipeline'-  :: PhasePlus                  -- ^ When to start-  -> HscEnv                     -- ^ Compilation environment-  -> PipeEnv-  -> FilePath                   -- ^ Input filename-  -> Maybe ModLocation          -- ^ A ModLocation, if this is a Haskell module-  -> [FilePath]                 -- ^ foreign objects, if we have one-  -> IO (DynFlags, FilePath, Maybe ModIface)-                                -- ^ (final flags, output filename, interface)-runPipeline' start_phase hsc_env env input_fn-             maybe_loc foreign_os-  = do-  -- Execute the pipeline...-  let state = PipeState{ hsc_env, maybe_loc, foreign_os = foreign_os, iface = Nothing }-  (pipe_state, fp) <- evalP (pipeLoop start_phase input_fn) env state-  return (pipeStateDynFlags pipe_state, fp, pipeStateModIface pipe_state)---- ------------------------------------------------------------------------------ outer pipeline loop---- | pipeLoop runs phases until we reach the stop phase-pipeLoop :: PhasePlus -> FilePath -> CompPipeline FilePath-pipeLoop phase input_fn = do-  env <- getPipeEnv-  dflags <- getDynFlags-  logger <- getLogger-  -- See Note [Partial ordering on phases]-  let happensBefore' = happensBefore (targetPlatform dflags)-      stopPhase = stop_phase env-  case phase of-   RealPhase realPhase | realPhase `eqPhase` stopPhase            -- All done-     -> -- Sometimes, a compilation phase doesn't actually generate any output-        -- (eg. the CPP phase when -fcpp is not turned on).  If we end on this-        -- stage, but we wanted to keep the output, then we have to explicitly-        -- copy the file, remembering to prepend a {-# LINE #-} pragma so that-        -- further compilation stages can tell what the original filename was.-        case output_spec env of-        Temporary _ ->-            return input_fn-        output ->-            do pst <- getPipeState-               tmpfs <- hsc_tmpfs <$> getPipeSession-               final_fn <- liftIO $ getOutputFilename logger tmpfs-                                        stopPhase output (src_basename env)-                                        dflags stopPhase (maybe_loc pst)-               when (final_fn /= input_fn) $ do-                  let msg = ("Copying `" ++ input_fn ++"' to `" ++ final_fn ++ "'")-                      line_prag = Just ("{-# LINE 1 \"" ++ src_filename env ++ "\" #-}\n")-                  liftIO $ copyWithHeader logger dflags msg line_prag input_fn final_fn-               return final_fn---     | not (realPhase `happensBefore'` stopPhase)-        -- Something has gone wrong.  We'll try to cover all the cases when-        -- this could happen, so if we reach here it is a panic.-        -- eg. it might happen if the -C flag is used on a source file that-        -- has {-# OPTIONS -fasm #-}.-     -> panic ("pipeLoop: at phase " ++ show realPhase ++-           " but I wanted to stop at phase " ++ show stopPhase)--   _-     -> do liftIO $ debugTraceMsg logger dflags 4-                                  (text "Running phase" <+> ppr phase)--           case phase of-               HscOut {} -> do-                   -- Depending on the dynamic-too state, we first run the-                   -- backend to generate the non-dynamic objects and then-                   -- re-run it to generate the dynamic ones.-                   let noDynToo = do-                        (next_phase, output_fn) <- runHookedPhase phase input_fn-                        pipeLoop next_phase output_fn-                   let dynToo = do-                          -- we must run the non-dynamic way before the dynamic-                          -- one because there may be interfaces loaded only in-                          -- the backend (e.g., in CorePrep). See #19264-                          r <- noDynToo--                          -- we must check the dynamic-too state again, because-                          -- we may have failed to load a dynamic interface in-                          -- the backend.-                          dynamicTooState dflags >>= \case-                            DT_OK -> do-                                let dflags' = setDynamicNow dflags -- set "dynamicNow"-                                setDynFlags dflags'-                                (next_phase, output_fn) <- runHookedPhase phase input_fn-                                _ <- pipeLoop next_phase output_fn-                                -- TODO: we probably shouldn't ignore the result of-                                -- the dynamic compilation-                                setDynFlags dflags -- restore flags without "dynamicNow" set-                                return r-                            _ -> return r--                   dynamicTooState dflags >>= \case-                     DT_Dont   -> noDynToo-                     DT_Failed -> noDynToo-                     DT_OK     -> dynToo-                     DT_Dyn    -> noDynToo-                        -- it shouldn't be possible to be in this last case-                        -- here. It would mean that we executed the whole-                        -- pipeline with DynamicNow and Opt_BuildDynamicToo set.-                        ---                        -- When we restart the whole pipeline for -dynamic-too-                        -- we set DynamicNow but we unset Opt_BuildDynamicToo so-                        -- it's weird.-               _ -> do-                  (next_phase, output_fn) <- runHookedPhase phase input_fn-                  pipeLoop next_phase output_fn--runHookedPhase :: PhasePlus -> FilePath -> CompPipeline (PhasePlus, FilePath)-runHookedPhase pp input = do-  hooks <- hsc_hooks <$> getPipeSession-  case runPhaseHook hooks of-    Nothing -> runPhase pp input-    Just h  -> h pp input---- -------------------------------------------------------------------------------- In each phase, we need to know into what filename to generate the--- output.  All the logic about which filenames we generate output--- into is embodied in the following function.---- | Computes the next output filename after we run @next_phase@.--- Like 'getOutputFilename', but it operates in the 'CompPipeline' monad--- (which specifies all of the ambient information.)-phaseOutputFilename :: Phase{-next phase-} -> CompPipeline FilePath-phaseOutputFilename next_phase = do-  PipeEnv{stop_phase, src_basename, output_spec} <- getPipeEnv-  PipeState{maybe_loc,hsc_env} <- getPipeState-  dflags <- getDynFlags-  logger <- getLogger-  let tmpfs = hsc_tmpfs hsc_env-  liftIO $ getOutputFilename logger tmpfs 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- | is_last_phase, Persistent   <- output = persistent_fn- | is_last_phase, SpecificFile <- output = case outputFile dflags of-                                           Just f -> return f-                                           Nothing ->-                                               panic "SpecificFile: No filename"- | keep_this_output                      = persistent_fn- | Temporary lifetime <- output          = newTempName logger tmpfs dflags lifetime suffix- | otherwise                             = newTempName logger tmpfs dflags TFL_CurrentModule-   suffix-    where-          hcsuf      = hcSuf dflags-          odir       = objectDir dflags-          osuf       = objectSuf dflags-          keep_hc    = gopt Opt_KeepHcFiles dflags-          keep_hscpp = gopt Opt_KeepHscppFiles dflags-          keep_s     = gopt Opt_KeepSFiles dflags-          keep_bc    = gopt Opt_KeepLlvmFiles dflags--          myPhaseInputExt HCc       = hcsuf-          myPhaseInputExt MergeForeign = osuf-          myPhaseInputExt StopLn    = osuf-          myPhaseInputExt other     = phaseInputExt other--          is_last_phase = next_phase `eqPhase` stop_phase--          -- sometimes, we keep output from intermediate stages-          keep_this_output =-               case next_phase of-                       As _    | keep_s     -> True-                       LlvmOpt | keep_bc    -> True-                       HCc     | keep_hc    -> True-                       HsPp _  | keep_hscpp -> True   -- See #10869-                       _other               -> False--          suffix = myPhaseInputExt next_phase--          -- persistent object files get put in odir-          persistent_fn-             | StopLn <- next_phase = return odir_persistent-             | otherwise            = return persistent--          persistent = basename <.> suffix--          odir_persistent-             | Just loc <- maybe_location = ml_obj_file loc-             | Just d <- odir = d </> persistent-             | otherwise      = persistent----- | LLVM Options. These are flags to be passed to opt and llc, to ensure--- consistency we list them in pairs, so that they form groups.-llvmOptions :: DynFlags-            -> [(String, String)]  -- ^ pairs of (opt, llc) arguments-llvmOptions dflags =-       [("-enable-tbaa -tbaa",  "-enable-tbaa") | gopt Opt_LlvmTBAA dflags ]-    ++ [("-relocation-model=" ++ rmodel-        ,"-relocation-model=" ++ rmodel) | not (null rmodel)]-    ++ [("-stack-alignment=" ++ (show align)-        ,"-stack-alignment=" ++ (show align)) | align > 0 ]--    -- Additional llc flags-    ++ [("", "-mcpu=" ++ mcpu)   | not (null mcpu)-                                 , not (any (isInfixOf "-mcpu") (getOpts dflags opt_lc)) ]-    ++ [("", "-mattr=" ++ attrs) | not (null attrs) ]-    ++ [("", "-target-abi=" ++ abi) | not (null abi) ]--  where target = platformMisc_llvmTarget $ platformMisc dflags-        Just (LlvmTarget _ mcpu mattr) = lookup target (llvmTargets $ llvmConfig dflags)--        -- Relocation models-        rmodel | gopt Opt_PIC dflags        = "pic"-               | positionIndependent dflags = "pic"-               | WayDyn `elem` ways dflags  = "dynamic-no-pic"-               | otherwise                  = "static"--        platform = targetPlatform dflags--        align :: Int-        align = case platformArch platform of-                  ArchX86_64 | isAvxEnabled dflags -> 32-                  _                                -> 0--        attrs :: String-        attrs = intercalate "," $ mattr-              ++ ["+sse42"   | isSse4_2Enabled dflags   ]-              ++ ["+sse2"    | isSse2Enabled platform   ]-              ++ ["+sse"     | isSseEnabled platform    ]-              ++ ["+avx512f" | isAvx512fEnabled dflags  ]-              ++ ["+avx2"    | isAvx2Enabled dflags     ]-              ++ ["+avx"     | isAvxEnabled dflags      ]-              ++ ["+avx512cd"| isAvx512cdEnabled dflags ]-              ++ ["+avx512er"| isAvx512erEnabled dflags ]-              ++ ["+avx512pf"| isAvx512pfEnabled dflags ]-              ++ ["+bmi"     | isBmiEnabled dflags      ]-              ++ ["+bmi2"    | isBmi2Enabled dflags     ]--        abi :: String-        abi = case platformArch (targetPlatform dflags) of-                ArchRISCV64 -> "lp64d"-                _           -> ""---- -------------------------------------------------------------------------------- | Each phase in the pipeline returns the next phase to execute, and the--- name of the file in which the output was placed.------ We must do things dynamically this way, because we often don't know--- what the rest of the phases will be until part-way through the--- compilation: for example, an {-# OPTIONS -fasm #-} at the beginning--- of a source file can change the latter stages of the pipeline from--- taking the LLVM route to using the native code generator.----runPhase :: PhasePlus   -- ^ Run this phase-         -> FilePath    -- ^ name of the input file-         -> CompPipeline (PhasePlus,           -- next phase to run-                          FilePath)            -- output filename--        -- Invariant: the output filename always contains the output-        -- Interesting case: Hsc when there is no recompilation to do-        --                   Then the output filename is still a .o file------------------------------------------------------------------------------------- Unlit phase--runPhase (RealPhase (Unlit sf)) input_fn = 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.Coverage.isGoodTickSrcSpan where we check that the filename in-       -- a SrcLoc is the same as the source filenaame, the two will-       -- look bogusly different. See test:-       -- libraries/hpc/tests/function/subdir/tough2.hs-       escape ('\\':cs) = '\\':'\\': escape cs-       escape ('\"':cs) = '\\':'\"': escape cs-       escape ('\'':cs) = '\\':'\'': escape cs-       escape (c:cs)    = c : escape cs-       escape []        = []--    output_fn <- phaseOutputFilename (Cpp sf)--    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-                ]--    dflags <- getDynFlags-    logger <- getLogger-    liftIO $ GHC.SysTools.runUnlit logger dflags flags--    return (RealPhase (Cpp sf), output_fn)------------------------------------------------------------------------------------ Cpp phase : (a) gets OPTIONS out of file---             (b) runs cpp if necessary--runPhase (RealPhase (Cpp sf)) input_fn-  = do-       dflags0 <- getDynFlags-       logger <- getLogger-       src_opts <- liftIO $ getOptionsFromFile dflags0 input_fn-       (dflags1, unhandled_flags, warns)-           <- liftIO $ parseDynamicFilePragma dflags0 src_opts-       setDynFlags dflags1-       liftIO $ checkProcessArgsResult unhandled_flags--       if not (xopt LangExt.Cpp dflags1) then do-           -- we have to be careful to emit warnings only once.-           unless (gopt Opt_Pp dflags1) $-               liftIO $ handleFlagWarnings logger dflags1 warns--           -- no need to preprocess CPP, just pass input file along-           -- to the next phase of the pipeline.-           return (RealPhase (HsPp sf), input_fn)-        else do-            output_fn <- phaseOutputFilename (HsPp sf)-            hsc_env <- getPipeSession-            liftIO $ doCpp logger-                           (hsc_tmpfs hsc_env)-                           (hsc_dflags hsc_env)-                           (hsc_unit_env hsc_env)-                           True{-raw-}-                           input_fn output_fn-            -- re-read the pragmas now that we've preprocessed the file-            -- See #2464,#3457-            src_opts <- liftIO $ getOptionsFromFile dflags0 output_fn-            (dflags2, unhandled_flags, warns)-                <- liftIO $ parseDynamicFilePragma dflags0 src_opts-            liftIO $ checkProcessArgsResult unhandled_flags-            unless (gopt Opt_Pp dflags2) $-                liftIO $ handleFlagWarnings logger dflags2 warns-            -- the HsPp pass below will emit warnings--            setDynFlags dflags2--            return (RealPhase (HsPp sf), output_fn)------------------------------------------------------------------------------------ HsPp phase--runPhase (RealPhase (HsPp sf)) input_fn = do-    dflags <- getDynFlags-    logger <- getLogger-    if not (gopt Opt_Pp dflags) then-      -- no need to preprocess, just pass input file along-      -- to the next phase of the pipeline.-       return (RealPhase (Hsc sf), input_fn)-    else do-        PipeEnv{src_basename, src_suffix} <- getPipeEnv-        let orig_fn = src_basename <.> src_suffix-        output_fn <- phaseOutputFilename (Hsc sf)-        liftIO $ GHC.SysTools.runPp logger dflags-                       ( [ GHC.SysTools.Option     orig_fn-                         , GHC.SysTools.Option     input_fn-                         , GHC.SysTools.FileOption "" output_fn-                         ]-                       )--        -- re-read pragmas now that we've parsed the file (see #3674)-        src_opts <- liftIO $ getOptionsFromFile dflags output_fn-        (dflags1, unhandled_flags, warns)-            <- liftIO $ parseDynamicFilePragma dflags src_opts-        setDynFlags dflags1-        liftIO $ checkProcessArgsResult unhandled_flags-        liftIO $ handleFlagWarnings logger dflags1 warns--        return (RealPhase (Hsc sf), output_fn)---------------------------------------------------------------------------------- Hsc phase---- Compilation of a single module, in "legacy" mode (_not_ under--- the direction of the compilation manager).-runPhase (RealPhase (Hsc src_flavour)) input_fn- = do   -- normal Hsc mode, not mkdependHS-        dflags0 <- getDynFlags--        PipeEnv{ stop_phase=stop,-                 src_basename=basename,-                 src_suffix=suff } <- getPipeEnv--  -- we add the current directory (i.e. the directory in which-  -- the .hs files resides) to the include path, since this is-  -- what gcc does, and it's probably what you want.-        let current_dir = takeDirectory basename-            new_includes = addImplicitQuoteInclude paths [current_dir]-            paths = includePaths dflags0-            dflags = dflags0 { includePaths = new_includes }--        setDynFlags dflags--  -- gather the imports and module name-        (hspp_buf,mod_name,imps,src_imps) <- liftIO $ do-            buf <- hGetStringBuffer input_fn-            let imp_prelude = xopt LangExt.ImplicitPrelude dflags-                popts = initParserOpts dflags-            eimps <- getImports popts imp_prelude buf input_fn (basename <.> suff)-            case eimps of-              Left errs -> throwErrors (fmap pprError errs)-              Right (src_imps,imps,L _ mod_name) -> return-                  (Just buf, mod_name, imps, src_imps)--  -- Take -o into account if present-  -- Very like -ohi, but we must *only* do this if we aren't linking-  -- (If we're linking then the -o applies to the linked thing, not to-  -- the object file for one module.)-  -- Note the nasty duplication with the same computation in compileFile above-        location <- getLocation src_flavour mod_name--        let o_file = ml_obj_file location -- The real object file-            hi_file = ml_hi_file location-            hie_file = ml_hie_file location-            dest_file | writeInterfaceOnlyMode dflags-                            = hi_file-                      | otherwise-                            = o_file--  -- Figure out if the source has changed, for recompilation avoidance.-  ---  -- Setting source_unchanged to True means that M.o (or M.hie) seems-  -- to be up to date wrt M.hs; so no need to recompile unless imports have-  -- changed (which the compiler itself figures out).-  -- Setting source_unchanged to False tells the compiler that M.o is out of-  -- date wrt M.hs (or M.o doesn't exist) so we must recompile regardless.-        src_timestamp <- liftIO $ getModificationUTCTime (basename <.> suff)--        source_unchanged <- liftIO $-          if not (isStopLn stop)-                -- SourceModified unconditionally if-                --      (a) recompilation checker is off, or-                --      (b) we aren't going all the way to .o file (e.g. ghc -S)-             then return SourceModified-                -- Otherwise look at file modification dates-             else do dest_file_mod <- sourceModified dest_file src_timestamp-                     hie_file_mod <- if gopt Opt_WriteHie dflags-                                        then sourceModified hie_file-                                                            src_timestamp-                                        else pure False-                     if dest_file_mod || hie_file_mod-                        then return SourceModified-                        else return SourceUnmodified--        PipeState{hsc_env=hsc_env'} <- getPipeState--  -- Tell the finder cache about this module-        mod <- liftIO $ addHomeModuleToFinder hsc_env' mod_name location--  -- Make the ModSummary to hand to hscMain-        let-            mod_summary = ModSummary {  ms_mod       = mod,-                                        ms_hsc_src   = src_flavour,-                                        ms_hspp_file = input_fn,-                                        ms_hspp_opts = dflags,-                                        ms_hspp_buf  = hspp_buf,-                                        ms_location  = location,-                                        ms_hs_date   = src_timestamp,-                                        ms_obj_date  = Nothing,-                                        ms_parsed_mod   = Nothing,-                                        ms_iface_date   = Nothing,-                                        ms_hie_date     = Nothing,-                                        ms_textual_imps = imps,-                                        ms_srcimps      = src_imps }--  -- run the compiler!-        let msg hsc_env _ what _ = oneShotMsg hsc_env what-        (result, plugin_hsc_env) <--          liftIO $ hscIncrementalCompile True Nothing (Just msg) hsc_env'-                            mod_summary source_unchanged Nothing (1,1)--        -- In the rest of the pipeline use the loaded plugins-        setPlugins (hsc_plugins        plugin_hsc_env)-                   (hsc_static_plugins plugin_hsc_env)-        -- "driver" plugins may have modified the DynFlags so we update them-        setDynFlags (hsc_dflags plugin_hsc_env)--        return (HscOut src_flavour mod_name result,-                panic "HscOut doesn't have an input filename")--runPhase (HscOut src_flavour mod_name result) _ = do-        dflags <- getDynFlags-        logger <- getLogger-        location <- getLocation src_flavour mod_name-        setModLocation location--        let o_file = ml_obj_file location -- The real object file-            next_phase = hscPostBackendPhase src_flavour (backend dflags)--        case result of-            HscNotGeneratingCode _ _ ->-                return (RealPhase StopLn,-                        panic "No output filename from Hsc when no-code")-            HscUpToDate _ _ ->-                do liftIO $ touchObjectFile logger dflags o_file-                   -- The .o file must have a later modification date-                   -- than the source file (else we wouldn't get Nothing)-                   -- but we touch it anyway, to keep 'make' happy (we think).-                   return (RealPhase StopLn, o_file)-            HscUpdateBoot _ _ ->-                do -- In the case of hs-boot files, generate a dummy .o-boot-                   -- stamp file for the benefit of Make-                   liftIO $ touchObjectFile logger dflags o_file-                   return (RealPhase StopLn, o_file)-            HscUpdateSig _ _ ->-                do -- We need to create a REAL but empty .o file-                   -- because we are going to attempt to put it in a library-                   PipeState{hsc_env=hsc_env'} <- getPipeState-                   let input_fn = expectJust "runPhase" (ml_hs_file location)-                       basename = dropExtension input_fn-                   liftIO $ compileEmptyStub dflags hsc_env' basename location mod_name-                   return (RealPhase StopLn, o_file)-            HscRecomp { hscs_guts = cgguts,-                        hscs_mod_location = mod_location,-                        hscs_partial_iface = partial_iface,-                        hscs_old_iface_hash = mb_old_iface_hash-                      }-              -> do output_fn <- phaseOutputFilename next_phase--                    PipeState{hsc_env=hsc_env'} <- getPipeState--                    (outputFilename, mStub, foreign_files, cg_infos) <- liftIO $-                      hscGenHardCode hsc_env' cgguts mod_location output_fn--                    let dflags = hsc_dflags hsc_env'-                    final_iface <- liftIO (mkFullIface hsc_env' partial_iface (Just cg_infos))-                    setIface final_iface--                    -- See Note [Writing interface files]-                    liftIO $ hscMaybeWriteIface logger dflags False final_iface mb_old_iface_hash mod_location--                    stub_o <- liftIO (mapM (compileStub hsc_env') mStub)-                    foreign_os <- liftIO $-                      mapM (uncurry (compileForeign hsc_env')) foreign_files-                    setForeignOs (maybe [] return stub_o ++ foreign_os)--                    return (RealPhase next_phase, outputFilename)---------------------------------------------------------------------------------- Cmm phase--runPhase (RealPhase CmmCpp) input_fn = do-       hsc_env <- getPipeSession-       logger <- getLogger-       output_fn <- phaseOutputFilename Cmm-       liftIO $ doCpp logger-                      (hsc_tmpfs hsc_env)-                      (hsc_dflags hsc_env)-                      (hsc_unit_env hsc_env)-                      False{-not raw-}-                      input_fn output_fn-       return (RealPhase Cmm, output_fn)--runPhase (RealPhase Cmm) input_fn = do-       hsc_env <- getPipeSession-       let dflags = hsc_dflags hsc_env-       let next_phase = hscPostBackendPhase HsSrcFile (backend dflags)-       output_fn <- phaseOutputFilename next_phase-       PipeState{hsc_env} <- getPipeState-       mstub <- liftIO $ hscCompileCmmFile hsc_env input_fn output_fn-       stub_o <- liftIO (mapM (compileStub hsc_env) mstub)-       setForeignOs (maybeToList stub_o)-       return (RealPhase next_phase, output_fn)---------------------------------------------------------------------------------- Cc phase--runPhase (RealPhase cc_phase) input_fn-   | any (cc_phase `eqPhase`) [Cc, Ccxx, HCc, Cobjc, Cobjcxx]-   = do-        hsc_env <- getPipeSession-        let dflags    = hsc_dflags hsc_env-        let unit_env  = hsc_unit_env hsc_env-        let home_unit = hsc_home_unit hsc_env-        let tmpfs     = hsc_tmpfs hsc_env-        let platform  = ue_platform unit_env-        let hcc       = cc_phase `eqPhase` HCc--        let cmdline_include_paths = includePaths dflags--        -- HC files have the dependent packages stamped into them-        pkgs <- if hcc then liftIO $ getHCFilePackages input_fn else return []--        -- add package include paths even if we're just compiling .c-        -- files; this is the Value Add(TM) that using ghc instead of-        -- gcc gives you :)-        ps <- liftIO $ mayThrowUnitErr (preloadUnitsInfo' unit_env pkgs)-        let pkg_include_dirs     = collectIncludeDirs ps-        let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) []-              (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs)-        let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) []-              (includePathsQuote cmdline_include_paths ++-               includePathsQuoteImplicit cmdline_include_paths)-        let include_paths = include_paths_quote ++ include_paths_global--        -- pass -D or -optP to preprocessor when compiling foreign C files-        -- (#16737). Doing it in this way is simpler and also enable the C-        -- compiler to perform preprocessing and parsing in a single pass,-        -- but it may introduce inconsistency if a different pgm_P is specified.-        let more_preprocessor_opts = concat-              [ ["-Xpreprocessor", i]-              | not hcc-              , i <- getOpts dflags opt_P-              ]--        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 | optLevel dflags >= 2 = [ "-O2" ]-                   | optLevel dflags >= 1 = [ "-O" ]-                   | otherwise            = []--        -- Decide next phase-        let next_phase = As False-        output_fn <- phaseOutputFilename next_phase--        let-          more_hcc_opts =-                -- on x86 the floating point regs have greater precision-                -- than a double, which leads to unpredictable results.-                -- By default, we turn this off with -ffloat-store unless-                -- the user specified -fexcess-precision.-                (if platformArch platform == ArchX86 &&-                    not (gopt Opt_ExcessPrecision dflags)-                        then [ "-ffloat-store" ]-                        else []) ++--                -- gcc's -fstrict-aliasing allows two accesses to memory-                -- to be considered non-aliasing if they have different types.-                -- This interacts badly with the C code we generate, which is-                -- very weakly typed, being derived from C--.-                ["-fno-strict-aliasing"]--        ghcVersionH <- liftIO $ getGhcVersionPathName dflags unit_env--        logger <- getLogger-        liftIO $ GHC.SysTools.runCc (phaseForeignLanguage cc_phase) logger tmpfs dflags (-                        [ GHC.SysTools.FileOption "" input_fn-                        , GHC.SysTools.Option "-o"-                        , GHC.SysTools.FileOption "" output_fn-                        ]-                       ++ map GHC.SysTools.Option (-                          pic_c_flags--                -- Stub files generated for foreign exports references the runIO_closure-                -- and runNonIO_closure symbols, which are defined in the base package.-                -- These symbols are imported into the stub.c file via RtsAPI.h, and the-                -- way we do the import depends on whether we're currently compiling-                -- the base package or not.-                       ++ (if platformOS platform == OSMinGW32 &&-                              isHomeUnitId home_unit baseUnitId-                                then [ "-DCOMPILING_BASE_PACKAGE" ]-                                else [])--        -- We only support SparcV9 and better because V8 lacks an atomic CAS-        -- instruction. Note that the user can still override this-        -- (e.g., -mcpu=ultrasparc) as GCC picks the "best" -mcpu flag-        -- regardless of the ordering.-        ---        -- This is a temporary hack. See #2872, commit-        -- 5bd3072ac30216a505151601884ac88bf404c9f2-                       ++ (if platformArch platform == ArchSPARC-                           then ["-mcpu=v9"]-                           else [])--                       -- GCC 4.6+ doesn't like -Wimplicit when compiling C++.-                       ++ (if (cc_phase /= Ccxx && cc_phase /= Cobjcxx)-                             then ["-Wimplicit"]-                             else [])--                       ++ (if hcc-                             then gcc_extra_viac_flags ++ more_hcc_opts-                             else [])-                       ++ verbFlags-                       ++ [ "-S" ]-                       ++ cc_opt-                       ++ [ "-include", ghcVersionH ]-                       ++ framework_paths-                       ++ include_paths-                       ++ more_preprocessor_opts-                       ++ pkg_extra_cc_opts-                       ))--        return (RealPhase next_phase, output_fn)---------------------------------------------------------------------------------- As, SpitAs phase : Assembler---- This is for calling the assembler on a regular assembly file-runPhase (RealPhase (As with_cpp)) input_fn-  = do-        hsc_env <- getPipeSession-        let dflags     = hsc_dflags   hsc_env-        let logger     = hsc_logger   hsc_env-        let unit_env   = hsc_unit_env hsc_env-        let platform   = ue_platform unit_env--        -- LLVM from version 3.0 onwards doesn't support the OS X system-        -- assembler, so we use clang as the assembler instead. (#5636)-        let as_prog | backend dflags == LLVM-                    , platformOS platform == OSDarwin-                    = GHC.SysTools.runClang-                    | otherwise-                    = GHC.SysTools.runAs--        let cmdline_include_paths = includePaths dflags-        let pic_c_flags = picCCOpts dflags--        next_phase <- maybeMergeForeign-        output_fn <- phaseOutputFilename next_phase--        -- we create directories for the object file, because it-        -- might be a hierarchical module.-        liftIO $ createDirectoryIfMissing True (takeDirectory output_fn)--        ccInfo <- liftIO $ getCompilerInfo logger dflags-        let global_includes = [ GHC.SysTools.Option ("-I" ++ p)-                              | p <- includePathsGlobal cmdline_include_paths ]-        let local_includes = [ GHC.SysTools.Option ("-iquote" ++ p)-                             | p <- includePathsQuote cmdline_include_paths ++-                                includePathsQuoteImplicit cmdline_include_paths]-        let runAssembler inputFilename outputFilename-              = liftIO $-                  withAtomicRename outputFilename $ \temp_outputFilename ->-                    as_prog-                       logger dflags-                       (local_includes ++ global_includes-                       -- See Note [-fPIC for assembler]-                       ++ map GHC.SysTools.Option pic_c_flags-                       -- See Note [Produce big objects on Windows]-                       ++ [ GHC.SysTools.Option "-Wa,-mbig-obj"-                          | platformOS (targetPlatform dflags) == OSMinGW32-                          , not $ target32Bit (targetPlatform dflags)-                          ]--        -- We only support SparcV9 and better because V8 lacks an atomic CAS-        -- instruction so we have to make sure that the assembler accepts the-        -- instruction set. Note that the user can still override this-        -- (e.g., -mcpu=ultrasparc). GCC picks the "best" -mcpu flag-        -- regardless of the ordering.-        ---        -- This is a temporary hack.-                       ++ (if platformArch (targetPlatform dflags) == ArchSPARC-                           then [GHC.SysTools.Option "-mcpu=v9"]-                           else [])-                       ++ (if any (ccInfo ==) [Clang, AppleClang, AppleClang51]-                            then [GHC.SysTools.Option "-Qunused-arguments"]-                            else [])-                       ++ [ GHC.SysTools.Option "-x"-                          , if with_cpp-                              then GHC.SysTools.Option "assembler-with-cpp"-                              else GHC.SysTools.Option "assembler"-                          , GHC.SysTools.Option "-c"-                          , GHC.SysTools.FileOption "" inputFilename-                          , GHC.SysTools.Option "-o"-                          , GHC.SysTools.FileOption "" temp_outputFilename-                          ])--        liftIO $ debugTraceMsg logger dflags 4 (text "Running the assembler")-        runAssembler input_fn output_fn--        return (RealPhase next_phase, output_fn)----------------------------------------------------------------------------------- LlvmOpt phase-runPhase (RealPhase LlvmOpt) input_fn = do-    dflags <- getDynFlags-    logger <- getLogger-    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 $ optLevel dflags  -- ensure we're in [0,2]-        llvmOpts = case lookup optIdx $ llvmPasses $ llvmConfig dflags 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 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 <- phaseOutputFilename LlvmLlc--    liftIO $ GHC.SysTools.runLlvmOpt logger dflags-               (   optFlag-                ++ defaultOptions ++-                [ GHC.SysTools.FileOption "" input_fn-                , GHC.SysTools.Option "-o"-                , GHC.SysTools.FileOption "" output_fn]-                )--    return (RealPhase LlvmLlc, output_fn)----------------------------------------------------------------------------------- LlvmLlc phase--runPhase (RealPhase LlvmLlc) 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-    ---    dflags <- getDynFlags-    logger <- getLogger-    let-        llvmOpts = case optLevel 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 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 <- phaseOutputFilename next_phase--    liftIO $ GHC.SysTools.runLlvmLlc logger dflags-                (  optFlag-                ++ defaultOptions-                ++ [ GHC.SysTools.FileOption "" input_fn-                   , GHC.SysTools.Option "-o"-                   , GHC.SysTools.FileOption "" output_fn-                   ]-                )--    return (RealPhase next_phase, output_fn)------------------------------------------------------------------------------------ LlvmMangle phase--runPhase (RealPhase LlvmMangle) input_fn = do-      let next_phase = As False-      output_fn <- phaseOutputFilename next_phase-      dflags <- getDynFlags-      logger <- getLogger-      liftIO $ llvmFixupAsm logger dflags input_fn output_fn-      return (RealPhase next_phase, output_fn)---------------------------------------------------------------------------------- merge in stub objects--runPhase (RealPhase MergeForeign) input_fn = do-     PipeState{foreign_os,hsc_env} <- getPipeState-     output_fn <- phaseOutputFilename StopLn-     liftIO $ createDirectoryIfMissing True (takeDirectory output_fn)-     if null foreign_os-       then panic "runPhase(MergeForeign): no foreign objects"-       else do-         dflags <- getDynFlags-         logger <- getLogger-         let tmpfs = hsc_tmpfs hsc_env-         liftIO $ joinObjectFiles logger tmpfs dflags (input_fn : foreign_os) output_fn-         return (RealPhase StopLn, output_fn)---- warning suppression-runPhase (RealPhase other) _input_fn =-   panic ("runPhase: don't know how to run phase " ++ show other)--maybeMergeForeign :: CompPipeline Phase-maybeMergeForeign- = do-     PipeState{foreign_os} <- getPipeState-     if null foreign_os then return StopLn else return MergeForeign--getLocation :: HscSource -> ModuleName -> CompPipeline ModLocation-getLocation src_flavour mod_name = do-    dflags <- getDynFlags--    PipeEnv{ src_basename=basename,-             src_suffix=suff } <- getPipeEnv-    PipeState { maybe_loc=maybe_loc} <- getPipeState-    case maybe_loc of-        -- Build a ModLocation to pass to hscMain.-        -- The source filename is rather irrelevant by now, but it's used-        -- by hscMain for messages.  hscMain also needs-        -- the .hi and .o filenames. If we already have a ModLocation-        -- then simply update the extensions of the interface and object-        -- files to match the DynFlags, otherwise use the logic in Finder.-      Just l -> return $ l-        { ml_hs_file = Just $ basename <.> suff-        , ml_hi_file = ml_hi_file l -<.> hiSuf dflags-        , ml_obj_file = ml_obj_file l -<.> objectSuf dflags-        }-      _ -> do-        location1 <- liftIO $ mkHomeModLocation2 dflags mod_name basename suff--        -- Boot-ify it if necessary-        let location2-              | HsBootFile <- src_flavour = addBootSuffixLocnOut location1-              | otherwise                 = location1---        -- Take -ohi into account if present-        -- This can't be done in mkHomeModuleLocation because-        -- it only applies to the module being compiles-        let ohi = outputHi dflags-            location3 | Just fn <- ohi = location2{ ml_hi_file = fn }-                      | otherwise      = location2--        -- Take -o into account if present-        -- Very like -ohi, but we must *only* do this if we aren't linking-        -- (If we're linking then the -o applies to the linked thing, not to-        -- the object file for one module.)-        -- Note the nasty duplication with the same computation in compileFile-        -- above-        let expl_o_file = outputFile dflags-            location4 | Just ofile <- expl_o_file-                      , isNoLink (ghcLink dflags)-                      = location3 { ml_obj_file = ofile }-                      | otherwise = location3-        return location4---------------------------------------------------------------------------------- Look for the /* GHC_PACKAGES ... */ comment at the top of a .hc file--getHCFilePackages :: FilePath -> IO [UnitId]-getHCFilePackages filename =-  Exception.bracket (openFile filename ReadMode) hClose $ \h -> do-    l <- hGetLine h-    case l of-      '/':'*':' ':'G':'H':'C':'_':'P':'A':'C':'K':'A':'G':'E':'S':rest ->-          return (map 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) $-    putLogMsg logger dflags NoReason SevInfo 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----- -------------------------------------------------------------------------------- Running CPP---- | Run CPP------ UnitState is needed to compute MIN_VERSION macros-doCpp :: Logger -> TmpFs -> DynFlags -> UnitEnv -> Bool -> FilePath -> FilePath -> IO ()-doCpp logger tmpfs dflags unit_env raw input_fn output_fn = do-    let hscpp_opts = picPOpts dflags-    let cmdline_include_paths = includePaths dflags-    let unit_state = ue_units unit_env-    pkg_include_dirs <- mayThrowUnitErr-                        (collectIncludeDirs <$> preloadUnitsInfo unit_env)-    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 verbFlags = getVerbFlags dflags--    let cpp_prog args | raw       = GHC.SysTools.runCpp logger dflags args-                      | otherwise = GHC.SysTools.runCc Nothing logger tmpfs dflags-                                        (GHC.SysTools.Option "-E" : args)--    let platform   = targetPlatform dflags-        targetArch = stringEncodeArch $ platformArch platform-        targetOS = stringEncodeOS $ platformOS platform-        isWindows = platformOS platform == OSMinGW32-    let target_defs =-          [ "-D" ++ HOST_OS     ++ "_BUILD_OS",-            "-D" ++ HOST_ARCH   ++ "_BUILD_ARCH",-            "-D" ++ targetOS    ++ "_HOST_OS",-            "-D" ++ targetArch  ++ "_HOST_ARCH" ]-        -- remember, in code we *compile*, the HOST is the same our TARGET,-        -- and BUILD is the same as our HOST.--    let io_manager_defs =-          [ "-D__IO_MANAGER_WINIO__=1" | isWindows ] ++-          [ "-D__IO_MANAGER_MIO__=1"               ]--    let sse_defs =-          [ "-D__SSE__"      | isSseEnabled      platform ] ++-          [ "-D__SSE2__"     | isSse2Enabled     platform ] ++-          [ "-D__SSE4_2__"   | isSse4_2Enabled   dflags ]--    let avx_defs =-          [ "-D__AVX__"      | isAvxEnabled      dflags ] ++-          [ "-D__AVX2__"     | isAvx2Enabled     dflags ] ++-          [ "-D__AVX512CD__" | isAvx512cdEnabled dflags ] ++-          [ "-D__AVX512ER__" | isAvx512erEnabled dflags ] ++-          [ "-D__AVX512F__"  | isAvx512fEnabled  dflags ] ++-          [ "-D__AVX512PF__" | isAvx512pfEnabled dflags ]--    backend_defs <- getBackendDefs logger dflags--    let th_defs = [ "-D__GLASGOW_HASKELL_TH__" ]-    -- Default CPP defines in Haskell source-    ghcVersionH <- getGhcVersionPathName dflags unit_env-    let hsSourceCppOpts = [ "-include", ghcVersionH ]--    -- MIN_VERSION macros-    let uids = explicitUnits unit_state-        pkgs = catMaybes (map (lookupUnit unit_state) uids)-    mb_macro_include <--        if not (null pkgs) && gopt Opt_VersionMacros dflags-            then do macro_stub <- newTempName logger tmpfs dflags TFL_CurrentModule "h"-                    writeFile macro_stub (generatePackageVersionMacros pkgs)-                    -- Include version macros for every *exposed* package.-                    -- Without -hide-all-packages and with a package database-                    -- size of 1000 packages, it takes cpp an estimated 2-                    -- milliseconds to process this file. See #10970-                    -- comment 8.-                    return [GHC.SysTools.FileOption "-include" macro_stub]-            else return []--    cpp_prog       (   map GHC.SysTools.Option verbFlags-                    ++ map GHC.SysTools.Option include_paths-                    ++ map GHC.SysTools.Option hsSourceCppOpts-                    ++ map GHC.SysTools.Option target_defs-                    ++ map GHC.SysTools.Option backend_defs-                    ++ map GHC.SysTools.Option th_defs-                    ++ map GHC.SysTools.Option hscpp_opts-                    ++ map GHC.SysTools.Option sse_defs-                    ++ map GHC.SysTools.Option avx_defs-                    ++ map GHC.SysTools.Option io_manager_defs-                    ++ mb_macro_include-        -- Set the language mode to assembler-with-cpp when preprocessing. This-        -- alleviates some of the C99 macro rules relating to whitespace and the hash-        -- operator, which we tend to abuse. Clang in particular is not very happy-        -- about this.-                    ++ [ GHC.SysTools.Option     "-x"-                       , GHC.SysTools.Option     "assembler-with-cpp"-                       , GHC.SysTools.Option     input_fn-        -- We hackily use Option instead of FileOption here, so that the file-        -- name is not back-slashed on Windows.  cpp is capable of-        -- dealing with / in filenames, so it works fine.  Furthermore-        -- if we put in backslashes, cpp outputs #line directives-        -- with *double* backslashes.   And that in turn means that-        -- our error messages get double backslashes in them.-        -- In due course we should arrange that the lexer deals-        -- with these \\ escapes properly.-                       , GHC.SysTools.Option     "-o"-                       , GHC.SysTools.FileOption "" output_fn-                       ])--getBackendDefs :: Logger -> DynFlags -> IO [String]-getBackendDefs logger dflags | backend dflags == LLVM = do-    llvmVer <- figureLlvmVersion logger dflags-    return $ case fmap llvmVersionList llvmVer of-               Just [m] -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,0) ]-               Just (m:n:_) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,n) ]-               _ -> []-  where-    format (major, minor)-      | minor >= 100 = error "getBackendDefs: Unsupported minor version"-      | otherwise = show $ (100 * major + minor :: Int) -- Contract is Int--getBackendDefs _ _ =-    return []---- ------------------------------------------------------------------------------ Macros (cribbed from Cabal)--generatePackageVersionMacros :: [UnitInfo] -> String-generatePackageVersionMacros pkgs = concat-  -- Do not add any C-style comments. See #3389.-  [ generateMacros "" pkgname version-  | pkg <- pkgs-  , let version = unitPackageVersion pkg-        pkgname = map fixchar (unitPackageNameString pkg)-  ]--fixchar :: Char -> Char-fixchar '-' = '_'-fixchar c   = c--generateMacros :: String -> String -> Version -> String-generateMacros prefix name version =-  concat-  ["#define ", prefix, "VERSION_",name," ",show (showVersion version),"\n"-  ,"#define MIN_", prefix, "VERSION_",name,"(major1,major2,minor) (\\\n"-  ,"  (major1) <  ",major1," || \\\n"-  ,"  (major1) == ",major1," && (major2) <  ",major2," || \\\n"-  ,"  (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")"-  ,"\n\n"-  ]-  where-    (major1:major2:minor:_) = map show (versionBranch version ++ repeat 0)---- ------------------------------------------------------------------------------ join object files into a single relocatable object file, using ld -r--{--Note [Produce big objects on Windows]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--The Windows Portable Executable object format has a limit of 32k sections, which-we tend to blow through pretty easily. Thankfully, there is a "big object"-extension, which raises this limit to 2^32. However, it must be explicitly-enabled in the toolchain:-- * the assembler accepts the -mbig-obj flag, which causes it to produce a-   bigobj-enabled COFF object.-- * the linker accepts the --oformat pe-bigobj-x86-64 flag. Despite what the name-   suggests, this tells the linker to produce a bigobj-enabled COFF object, no a-   PE executable.--We must enable bigobj output in a few places:-- * When merging object files (GHC.Driver.Pipeline.joinObjectFiles)-- * When assembling (GHC.Driver.Pipeline.runPhase (RealPhase As ...))--Unfortunately the big object format is not supported on 32-bit targets so-none of this can be used in that case.---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.---}--joinObjectFiles :: Logger -> TmpFs -> DynFlags -> [FilePath] -> FilePath -> IO ()-joinObjectFiles logger tmpfs dflags o_files output_fn = do-  let toolSettings' = toolSettings dflags-      ldIsGnuLd = toolSettings_ldIsGnuLd toolSettings'-      osInfo = platformOS (targetPlatform dflags)-      ld_r args = GHC.SysTools.runMergeObjects logger tmpfs dflags (-                        -- See Note [Produce big objects on Windows]-                        concat-                          [ [GHC.SysTools.Option "--oformat", GHC.SysTools.Option "pe-bigobj-x86-64"]-                          | OSMinGW32 == osInfo-                          , not $ target32Bit (targetPlatform dflags)-                          ]-                     ++ map GHC.SysTools.Option ld_build_id-                     ++ [ GHC.SysTools.Option "-o",-                          GHC.SysTools.FileOption "" output_fn ]-                     ++ args)--      -- suppress the generation of the .note.gnu.build-id section,-      -- which we don't need and sometimes causes ld to emit a-      -- warning:-      ld_build_id | toolSettings_ldSupportsBuildId toolSettings' = ["--build-id=none"]-                  | otherwise                     = []--  if ldIsGnuLd-     then do-          script <- newTempName logger tmpfs 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 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)---- -------------------------------------------------------------------------------- Misc.--writeInterfaceOnlyMode :: DynFlags -> Bool-writeInterfaceOnlyMode dflags =- gopt Opt_WriteInterface dflags &&- NoBackend == backend dflags---- | Figure out if a source file was modified after an output file (or if we--- anyways need to consider the source file modified since the output is gone).-sourceModified :: FilePath -- ^ destination file we are looking for-               -> UTCTime  -- ^ last time of modification of source file-               -> IO Bool  -- ^ do we need to regenerate the output?-sourceModified dest_file src_timestamp = do-  dest_file_exists <- doesFileExist dest_file-  if not dest_file_exists-    then return True       -- Need to recompile-     else do t2 <- getModificationUTCTime dest_file-             return (t2 <= src_timestamp)---- | What phase to run after one of the backend code generators has run-hscPostBackendPhase :: HscSource -> Backend -> Phase-hscPostBackendPhase HsBootFile _    =  StopLn-hscPostBackendPhase HsigFile _      =  StopLn-hscPostBackendPhase _ bcknd =-  case bcknd of-        ViaC        -> HCc-        NCG         -> As False-        LLVM        -> LlvmOpt-        NoBackend   -> StopLn-        Interpreter -> StopLn--touchObjectFile :: Logger -> DynFlags -> FilePath -> IO ()-touchObjectFile logger dflags path = do-  createDirectoryIfMissing True $ takeDirectory path-  GHC.SysTools.touch logger dflags "Touching object file" path---- | Find out path to @ghcversion.h@ file-getGhcVersionPathName :: DynFlags -> UnitEnv -> IO FilePath-getGhcVersionPathName dflags unit_env = do-  candidates <- case ghcVersionFile dflags of-    Just path -> return [path]-    Nothing -> do-        ps <- mayThrowUnitErr (preloadUnitsInfo' unit_env [rtsUnitId])-        return ((</> "ghcversion.h") <$> collectIncludeDirs ps)--  found <- filterM doesFileExist candidates-  case found of-      []    -> throwGhcExceptionIO (InstallationError-                                    ("ghcversion.h missing; tried: "-                                      ++ intercalate ", " candidates))-      (x:_) -> return x---- 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.Coverage.isGoodTickSrcSpan`, we compare the filename that a-  `SrcSpan` refers to with the name of the file we are currently compiling.-  For some reason I don't yet understand, they can sometimes legitimally be-  different, and then hpc ignores that SrcSpan.--Problem-  When running `ghc --make -fhpc A.hs`, where `A.hs` imports the literate-  module `B.lhs`, `B` is inferred to be in the file `./B.lhs` (1). At the-  start of the unlit phase, the name `./B.lhs` is normalised to `B.lhs` (2).-  Therefore the SrcSpans of `B` refer to the file `B.lhs` (3), but we are-  still compiling `./B.lhs`. Hpc thinks these two filenames are different (4),-  doesn't include ticks for B, and we have unhappy customers (#2991).--Solution-  Do not normalise `input_fn` when starting the unlit phase.--Alternative solution-  Another option would be to not compare the two filenames on equality, but to-  use System.FilePath.equalFilePath. That function first normalises its-  arguments. The problem is that by the time we need to do the comparison, the-  filenames have been turned into FastStrings, probably for performance-  reasons, so System.FilePath.equalFilePath can not be used directly.--Archeology-  The call to `normalise` was added in a commit called "Fix slash-  direction on Windows with the new filePath code" (c9b6b5e8). The problem-  that commit was addressing has since been solved in a different manner, in a-  commit called "Fix the filename passed to unlit" (1eedbc6b). So the-  `normalise` is no longer necessary.+{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}++{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE NondecreasingIndentation #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}++-----------------------------------------------------------------------------+--+-- 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,+   llvmPipeline, llvmLlcPipeline, llvmManglePipeline, pipelineStart,++   -- * Default method of running a pipeline+   runPipeline+) where+++import GHC.Prelude++import GHC.Platform++import GHC.Utils.Monad ( MonadIO(liftIO), mapMaybeM )++import GHC.Driver.Main+import GHC.Driver.Env hiding ( Hsc )+import GHC.Driver.Errors+import GHC.Driver.Errors.Types+import GHC.Driver.Pipeline.Monad+import GHC.Driver.Config.Diagnostic+import GHC.Driver.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.Utils.TmpFs++import GHC.Linker.ExtraObj+import GHC.Linker.Static+import GHC.Linker.Static.Utils+import GHC.Linker.Types++import GHC.Utils.Outputable+import GHC.Utils.Error+import GHC.Utils.Panic+import GHC.Utils.Misc+import GHC.Utils.Exception as Exception+import GHC.Utils.Logger++import qualified GHC.LanguageExtensions as LangExt++import GHC.Data.FastString     ( mkFastString )+import GHC.Data.StringBuffer   ( hPutStringBuffer )+import GHC.Data.Maybe          ( expectJust )++import GHC.Iface.Make          ( mkFullIface )+import GHC.Runtime.Loader      ( initializePlugins )+++import GHC.Types.Basic       ( SuccessFlag(..), ForeignSrcLang(..) )+import GHC.Types.Error       ( singleMessage, getMessages )+import GHC.Types.Target+import GHC.Types.SrcLoc+import GHC.Types.SourceFile+import GHC.Types.SourceError++import GHC.Unit+import GHC.Unit.Env+--import GHC.Unit.Finder+--import GHC.Unit.State+import GHC.Unit.Module.ModSummary+import GHC.Unit.Module.ModIface+import GHC.Unit.Module.Deps+import GHC.Unit.Home.ModInfo++import System.Directory+import System.FilePath+import System.IO+import Control.Monad+import qualified Control.Monad.Catch as MC (handle)+import Data.Maybe+import Data.Either      ( partitionEithers )+import qualified Data.Set as Set++import Data.Time        ( getCurrentTime )+import GHC.Iface.Recomp++-- Simpler type synonym for actions in the pipeline monad+type P m = TPipelineClass TPhase m++-- ---------------------------------------------------------------------------+-- Pre-process++-- | Just preprocess a file, put the result in a temp. file (used by the+-- compilation manager during the summary phase).+--+-- We return the augmented DynFlags, because they contain the result+-- of slurping in the OPTIONS pragmas++preprocess :: HscEnv+           -> FilePath -- ^ input filename+           -> Maybe InputFileBuffer+           -- ^ optional buffer to use instead of reading the input file+           -> Maybe Phase -- ^ starting phase+           -> IO (Either DriverMessages (DynFlags, FilePath))+preprocess hsc_env input_fn mb_input_buf mb_phase =+  handleSourceError (\err -> return $ Left $ to_driver_messages $ srcErrorMessages err) $+  MC.handle handler $+  fmap Right $ do+  massertPpr (isJust mb_phase || isHaskellSrcFilename input_fn) (text input_fn)+  input_fn_final <- mkInputFn+  let preprocess_pipeline = preprocessPipeline pipe_env (setDumpPrefix pipe_env hsc_env) input_fn_final+  runPipeline (hsc_hooks hsc_env) preprocess_pipeline++  where+    srcspan = srcLocSpan $ mkSrcLoc (mkFastString input_fn) 1 1+    handler (ProgramError msg) =+      return $ Left $ singleMessage $+        mkPlainErrorMsgEnvelope srcspan $+        DriverUnknownMessage $ 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"+                             (vcat $ pprMsgEnvelopeBagWithLoc (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 (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+           -> Maybe Linkable  -- ^ 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+            -> Maybe Linkable  -- ^ old linkable, if we have one+            -> 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)++   let flags = hsc_dflags hsc_env0+     in do unless (gopt Opt_KeepHiFiles flags) $+               addFilesToClean tmpfs TFL_CurrentModule $+                   [ml_hi_file $ ms_location summary]+           unless (gopt Opt_KeepOFiles flags) $+               addFilesToClean tmpfs TFL_GhcSession $+                   [ml_obj_file $ ms_location summary]++   plugin_hsc_env <- initializePlugins hsc_env+   let pipe_env = mkPipeEnv NoStop input_fn pipelineOutput+   status <- hscRecompStatus mHscMessage plugin_hsc_env upd_summary+                mb_old_iface mb_old_linkable (mod_index, nmods)+   let pipeline = hscPipeline pipe_env (setDumpPrefix pipe_env plugin_hsc_env, upd_summary, status)+   (iface, linkable) <- runPipeline (hsc_hooks hsc_env) pipeline+   -- See Note [ModDetails and --make mode]+   details <- initModDetails plugin_hsc_env upd_summary iface+   return $! HomeModInfo iface details linkable++ where lcl_dflags  = ms_hspp_opts summary+       location    = ms_location summary+       input_fn    = expectJust "compile:hs" (ml_hs_file location)+       input_fnpp  = ms_hspp_file summary++       pipelineOutput = case bcknd of+         Interpreter -> NoOutputFile+         NoBackend -> NoOutputFile+         _ -> Persistent++       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+         = (Interpreter, gopt_set (lcl_dflags { backend = Interpreter }) Opt_ForceRecomp)+         | otherwise+         = (backend dflags, lcl_dflags)+       -- See Note [Filepaths and Multiple Home Units]+       dflags  = dflags3 { includePaths = offsetIncludePaths dflags3 $ addImplicitQuoteInclude old_paths [current_dir] }+       upd_summary = summary { ms_hspp_opts = dflags }+       hsc_env = hscSetFlags dflags hsc_env0+++-- ---------------------------------------------------------------------------+-- Link+--+-- Note [Dynamic linking on macOS]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Since macOS Sierra (10.14), the dynamic system linker enforces+-- a limit on the Load Commands.  Specifically the Load Command Size+-- Limit is at 32K (32768).  The Load Commands contain the install+-- name, dependencies, runpaths, and a few other commands.  We however+-- only have control over the install name, dependencies and runpaths.+--+-- The install name is the name by which this library will be+-- referenced.  This is such that we do not need to bake in the full+-- absolute location of the library, and can move the library around.+--+-- The dependency commands contain the install names from of referenced+-- libraries.  Thus if a libraries install name is @rpath/libHS...dylib,+-- that will end up as the dependency.+--+-- Finally we have the runpaths, which informs the linker about the+-- directories to search for the referenced dependencies.+--+-- The system linker can do recursive linking, however using only the+-- direct dependencies conflicts with ghc's ability to inline across+-- packages, and as such would end up with unresolved symbols.+--+-- Thus we will pass the full dependency closure to the linker, and then+-- ask the linker to remove any unused dynamic libraries (-dead_strip_dylibs).+--+-- We still need to add the relevant runpaths, for the dynamic linker to+-- lookup the referenced libraries though.  The linker (ld64) does not+-- have any option to dead strip runpaths; which makes sense as runpaths+-- can be used for dependencies of dependencies as well.+--+-- The solution we then take in GHC is to not pass any runpaths to the+-- linker at link time, but inject them after the linking.  For this to+-- work we'll need to ask the linker to create enough space in the header+-- to add more runpaths after the linking (-headerpad 8000).+--+-- After the library has been linked by $LD (usually ld64), we will use+-- otool to inspect the libraries left over after dead stripping, compute+-- the relevant runpaths, and inject them into the linked product using+-- the install_name_tool command.+--+-- This strategy should produce the smallest possible set of load commands+-- while still retaining some form of relocatability via runpaths.+--+-- The only way I can see to reduce the load command size further would be+-- by shortening the library names, or start putting libraries into the same+-- folders, such that one runpath would be sufficient for multiple/all+-- libraries.+link :: GhcLink                 -- ^ interactive or batch+     -> Logger                  -- ^ Logger+     -> TmpFs+     -> Hooks+     -> DynFlags                -- ^ dynamic flags+     -> UnitEnv                 -- ^ unit environment+     -> Bool                    -- ^ attempt linking in batch mode?+     -> Maybe (RecompileRequired -> IO ())+     -> HomePackageTable        -- ^ what to link+     -> IO SuccessFlag++-- For the moment, in the batch linker, we don't bother to tell doLink+-- which packages to link -- it just tries all that are available.+-- batch_attempt_linking should only be *looked at* in batch mode.  It+-- should only be True if the upsweep was successful and someone+-- exports main, i.e., we have good reason to believe that linking+-- will succeed.++link ghcLink logger tmpfs hooks dflags unit_env batch_attempt_linking mHscMessage hpt =+  case linkHook hooks of+      Nothing -> case ghcLink of+          NoLink        -> return Succeeded+          LinkBinary    -> normal_link+          LinkStaticLib -> normal_link+          LinkDynLib    -> normal_link+          LinkMergedObj -> normal_link+          LinkInMemory+              | platformMisc_ghcWithInterpreter $ platformMisc dflags+              -> -- Not Linking...(demand linker will do the job)+                 return Succeeded+              | otherwise+              -> panicBadLink LinkInMemory+      Just h  -> h ghcLink dflags batch_attempt_linking hpt+  where+    normal_link = link' logger tmpfs dflags unit_env batch_attempt_linking mHscMessage hpt+++panicBadLink :: GhcLink -> a+panicBadLink other = panic ("link: GHC not built to link this way: " +++                            show other)++link' :: Logger+      -> TmpFs+      -> DynFlags                -- ^ dynamic flags+      -> UnitEnv                 -- ^ unit environment+      -> Bool                    -- ^ attempt linking in batch mode?+      -> Maybe (RecompileRequired -> IO ())+      -> HomePackageTable        -- ^ what to link+      -> IO SuccessFlag++link' logger tmpfs dflags unit_env batch_attempt_linking mHscMessager hpt+   | batch_attempt_linking+   = do+        let+            staticLink = case ghcLink dflags of+                          LinkStaticLib -> True+                          _ -> False++            home_mod_infos = eltsHpt hpt++            -- the packages we depend on+            pkg_deps  = Set.toList+                          $ Set.unions+                          $ fmap (dep_direct_pkgs . mi_deps . hm_iface)+                          $ home_mod_infos++            -- the linkables to link+            linkables = map (expectJust "link".hm_linkable) home_mod_infos++        debugTraceMsg logger 3 (text "link: linkables are ..." $$ vcat (map ppr linkables))++        -- check for the -no-link flag+        if isNoLink (ghcLink dflags)+          then do debugTraceMsg logger 3 (text "link(batch): linking omitted (-c flag given).")+                  return Succeeded+          else do++        let getOfiles LM{ linkableUnlinked } = map nameOfObject (filter isObject linkableUnlinked)+            obj_files = concatMap getOfiles linkables+            platform  = targetPlatform dflags+            exe_file  = exeFileName platform 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.+        let link = case ghcLink dflags of+                LinkBinary    -> linkBinary logger tmpfs+                LinkStaticLib -> linkStaticLib logger+                LinkDynLib    -> linkDynLibCheck logger tmpfs+                other         -> panicBadLink other+        link dflags unit_env obj_files pkg_deps++        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+++linkingNeeded :: Logger -> DynFlags -> UnitEnv -> Bool -> [Linkable] -> [UnitId] -> IO RecompileRequired+linkingNeeded logger dflags unit_env staticLink linkables pkg_deps = do+        -- if the modification time on the executable is later than the+        -- modification times on all of the objects and libraries, then omit+        -- linking (unless the -fforce-recomp flag was given).+  let platform   = ue_platform unit_env+      unit_state = ue_units unit_env+      exe_file   = exeFileName platform staticLink (outputFile_ dflags)+  e_exe_time <- tryIO $ getModificationUTCTime exe_file+  case e_exe_time of+    Left _  -> return $ NeedsRecompile MustCompile+    Right t -> do+        -- first check object files and extra_ld_inputs+        let extra_ld_inputs = [ f | FileOption _ f <- ldInputs dflags ]+        e_extra_times <- mapM (tryIO . getModificationUTCTime) extra_ld_inputs+        let (errs,extra_times) = partitionEithers e_extra_times+        let obj_times =  map linkableTime linkables ++ extra_times+        if not (null errs) || any (t <) obj_times+            then return $ needsRecompileBecause ObjectsChanged+            else do++        -- next, check libraries. XXX this only checks Haskell libraries,+        -- not extra_libraries or -l things from the command line.+        let pkg_hslibs  = [ (collectLibraryDirs (ways dflags) [c], lib)+                          | Just c <- map (lookupUnitId unit_state) pkg_deps,+                            lib <- unitHsLibs (ghcNameVersion dflags) (ways dflags) c ]++        pkg_libfiles <- mapM (uncurry (findHSLib platform (ways dflags))) pkg_hslibs+        if any isNothing pkg_libfiles then return $ needsRecompileBecause LibraryChanged else do+        e_lib_times <- mapM (tryIO . getModificationUTCTime)+                          (catMaybes pkg_libfiles)+        let (lib_errs,lib_times) = partitionEithers e_lib_times+        if not (null lib_errs) || any (t <) lib_times+           then return $ needsRecompileBecause LibraryChanged+           else do+            res <- checkLinkInfo logger dflags unit_env pkg_deps exe_file+            if res+              then return $ needsRecompileBecause FlagsChanged+              else return UpToDate+++findHSLib :: Platform -> Ways -> [String] -> String -> IO (Maybe FilePath)+findHSLib platform ws dirs lib = do+  let batch_lib_file = if ws `hasNotWay` WayDyn+                      then "lib" ++ lib <.> "a"+                      else platformSOName platform lib+  found <- filterM doesFileExist (map (</> batch_lib_file) dirs)+  case found of+    [] -> return Nothing+    (x:_) -> return (Just x)++-- -----------------------------------------------------------------------------+-- Compile files in one-shot mode.++oneShot :: HscEnv -> StopPhase -> [(String, Maybe Phase)] -> IO ()+oneShot hsc_env stop_phase srcs = do+  o_files <- mapMaybeM (compileFile hsc_env stop_phase) srcs+  case stop_phase of+    StopPreprocess -> return ()+    StopC  -> return ()+    StopAs -> return ()+    NoStop -> doLink hsc_env o_files++compileFile :: HscEnv -> StopPhase -> (FilePath, Maybe Phase) -> IO (Maybe FilePath)+compileFile hsc_env stop_phase (src, _mb_phase) = do+   exists <- doesFileExist src+   when (not exists) $+        throwGhcExceptionIO (CmdLineError ("does not exist: " ++ src))++   let+        dflags    = hsc_dflags hsc_env+        mb_o_file = outputFile dflags+        ghc_link  = ghcLink dflags      -- Set by -c or -no-link+        notStopPreprocess | StopPreprocess <- stop_phase = False+                          | _              <- stop_phase = True+        -- When linking, the -o argument refers to the linker's output.+        -- otherwise, we use it as the name for the pipeline's output.+        output+         | NoBackend <- backend dflags, notStopPreprocess = NoOutputFile+                -- avoid -E -fno-code undesirable interactions. see #20439+         | NoStop <- stop_phase, not (isNoLink ghc_link) = Persistent+                -- -o foo applies to linker+         | isJust mb_o_file = SpecificFile+                -- -o foo applies to the file we are compiling now+         | otherwise = Persistent+        pipe_env = mkPipeEnv stop_phase src output+        pipeline = pipelineStart pipe_env (setDumpPrefix pipe_env hsc_env) src+   runPipeline (hsc_hooks hsc_env) pipeline+++doLink :: HscEnv -> [FilePath] -> IO ()+doLink hsc_env o_files =+    let+        dflags   = hsc_dflags   hsc_env+        logger   = hsc_logger   hsc_env+        unit_env = hsc_unit_env hsc_env+        tmpfs    = hsc_tmpfs    hsc_env+    in case ghcLink dflags of+        NoLink        -> return ()+        LinkBinary    -> 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+#if __GLASGOW_HASKELL__ < 811+              RawObject  -> panic "compileForeign: should be unreachable"+#endif+            pipe_env = mkPipeEnv NoStop stub_c (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" (ppr 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+  empty_stub <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "c"+  let home_unit = hsc_home_unit hsc_env+      src = text "int" <+> ppr (mkHomeModule home_unit mod_name) <+> text "= 0;"+  writeFile empty_stub (showSDoc dflags (pprCode CStyle src))+  let pipe_env = (mkPipeEnv NoStop empty_stub Persistent) { src_basename = basename}+      pipeline = viaCPipeline HCc pipe_env hsc_env (Just location) empty_stub+  _ <- runPipeline (hsc_hooks hsc_env) pipeline+  return ()+++{- Environment Initialisation -}++mkPipeEnv :: StopPhase -- End phase+          -> FilePath -- input fn+          -> PipelineOutput -- Output+          -> PipeEnv+mkPipeEnv stop_phase  input_fn 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',+                     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)++  liftIO (printOrThrowDiagnostics (hsc_logger hsc_env) (initDiagOpts dflags3) (GhcPsMessage <$> p_warns3))+  liftIO (handleFlagWarnings (hsc_logger hsc_env) (initDiagOpts dflags3) warns3)+  return (dflags3, pp_fn)+++  -- This won't change through the compilation pipeline+  where platform = targetPlatform (hsc_dflags hsc_env)+        runAfter :: P p => Phase+                  -> a -> p a -> p a+        runAfter = phaseIfAfter platform start_phase+        start_phase = startPhase (src_suffix 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, Maybe Linkable)+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, Maybe Linkable)+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, Maybe Linkable)+hscBackendPipeline pipe_env hsc_env mod_sum result =+  case backend (hsc_dflags hsc_env) of+    NoBackend ->+      case result of+        HscUpdate iface ->  return (iface, Nothing)+        HscRecomp {} -> (,) <$> liftIO (mkFullIface hsc_env (hscs_partial_iface result) Nothing) <*> pure Nothing+    -- TODO: Why is there not a linkable?+    -- Interpreter -> (,) <$> use (T_IO (mkFullIface hsc_env (hscs_partial_iface result) Nothing)) <*> pure Nothing+    _ -> do+      res <- hscGenBackendPipeline pipe_env hsc_env mod_sum result+      when (gopt Opt_BuildDynamicToo (hsc_dflags hsc_env)) $ do+          let dflags' = setDynamicNow (hsc_dflags hsc_env) -- set "dynamicNow"+          () <$ hscGenBackendPipeline pipe_env (hscSetFlags dflags' hsc_env) mod_sum result+      return res++hscGenBackendPipeline :: P m+  => PipeEnv+  -> HscEnv+  -> ModSummary+  -> HscBackendAction+  -> m (ModIface, Maybe Linkable)+hscGenBackendPipeline pipe_env hsc_env mod_sum result = do+  let mod_name = moduleName (ms_mod mod_sum)+      src_flavour = (ms_hsc_src mod_sum)+  let location = ms_location mod_sum+  (fos, miface, mlinkable, o_file) <- use (T_HscBackend pipe_env hsc_env mod_name src_flavour location result)+  final_fp <- hscPostBackendPipeline pipe_env hsc_env (ms_hsc_src mod_sum) (backend (hsc_dflags hsc_env)) (Just location) o_file+  final_linkable <-+    case final_fp of+      -- No object file produced, bytecode or NoBackend+      Nothing -> return mlinkable+      Just o_fp -> do+        unlinked_time <- liftIO (liftIO getCurrentTime)+        final_unlinked <- DotO <$> use (T_MergeForeign pipe_env hsc_env o_fp fos)+        let !linkable = LM unlinked_time (ms_mod mod_sum) [final_unlinked]+        return (Just linkable)+  return (miface, final_linkable)++asPipeline :: P m => Bool -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe ObjFile)+asPipeline use_cpp pipe_env hsc_env location input_fn =+  case stop_phase pipe_env of+    StopAs -> return Nothing+    _ -> Just <$> use (T_As use_cpp pipe_env hsc_env location input_fn)++viaCPipeline :: P m => Phase -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe FilePath)+viaCPipeline c_phase pipe_env hsc_env location input_fn = do+  out_fn <- use (T_Cc c_phase pipe_env hsc_env input_fn)+  case stop_phase pipe_env of+    StopC -> return Nothing+    _ -> asPipeline False pipe_env hsc_env location out_fn++llvmPipeline :: P m => PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe FilePath)+llvmPipeline pipe_env hsc_env location fp = do+  opt_fn <- use (T_LlvmOpt pipe_env hsc_env fp)+  llvmLlcPipeline pipe_env hsc_env location opt_fn++llvmLlcPipeline :: P m => PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe FilePath)+llvmLlcPipeline pipe_env hsc_env location opt_fn = do+  llc_fn <- use (T_LlvmLlc pipe_env hsc_env opt_fn)+  llvmManglePipeline pipe_env hsc_env location llc_fn++llvmManglePipeline :: P m  => PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe FilePath)+llvmManglePipeline pipe_env hsc_env location llc_fn = do+  mangled_fn <-+    if gopt Opt_NoLlvmMangler (hsc_dflags hsc_env)+      then return llc_fn+      else use (T_LlvmMangle pipe_env hsc_env llc_fn)+  asPipeline False pipe_env hsc_env location mangled_fn++cmmCppPipeline :: P m => PipeEnv -> HscEnv -> FilePath -> m FilePath+cmmCppPipeline pipe_env hsc_env input_fn = do+  output_fn <- use (T_CmmCpp pipe_env hsc_env input_fn)+  cmmPipeline pipe_env hsc_env output_fn++cmmPipeline :: P m => PipeEnv -> HscEnv -> FilePath -> m FilePath+cmmPipeline pipe_env hsc_env input_fn = do+  (fos, output_fn) <- use (T_Cmm pipe_env hsc_env input_fn)+  mo_fn <- hscPostBackendPipeline pipe_env hsc_env HsSrcFile (backend (hsc_dflags hsc_env)) Nothing output_fn+  case mo_fn of+    Nothing -> panic "CMM pipeline - produced no .o file"+    Just mo_fn -> use (T_MergeForeign pipe_env hsc_env mo_fn fos)++hscPostBackendPipeline :: P m => PipeEnv -> HscEnv -> HscSource -> Backend -> Maybe ModLocation -> FilePath -> m (Maybe FilePath)+hscPostBackendPipeline _ _ HsBootFile _ _ _   = return Nothing+hscPostBackendPipeline _ _ HsigFile _ _ _     = return Nothing+hscPostBackendPipeline pipe_env hsc_env _ bcknd ml input_fn =+  case bcknd of+        ViaC        -> viaCPipeline HCc pipe_env hsc_env ml input_fn+        NCG         -> asPipeline False pipe_env hsc_env ml input_fn+        LLVM        -> llvmPipeline pipe_env hsc_env ml input_fn+        NoBackend   -> return Nothing+        Interpreter -> return Nothing++-- Pipeline from a given suffix+pipelineStart :: P m => PipeEnv -> HscEnv -> FilePath -> m (Maybe FilePath)+pipelineStart pipe_env hsc_env input_fn =+  fromSuffix (src_suffix pipe_env)+  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 (_, Just (LM _ _ [DotO lnk])) = Just lnk+   objFromLinkable _ = Nothing+++   fromSuffix :: P m => String -> m (Maybe FilePath)+   fromSuffix "lhs"      = frontend HsSrcFile+   fromSuffix "lhs-boot" = frontend HsBootFile+   fromSuffix "lhsig"    = frontend HsigFile+   fromSuffix "hs"       = frontend HsSrcFile+   fromSuffix "hs-boot"  = frontend HsBootFile+   fromSuffix "hsig"     = frontend HsigFile+   fromSuffix "hscpp"    = frontend HsSrcFile+   fromSuffix "hspp"     = frontend HsSrcFile+   fromSuffix "hc"       = c HCc+   fromSuffix "c"        = c Cc+   fromSuffix "cpp"      = c Ccxx+   fromSuffix "C"        = c Cc+   fromSuffix "m"        = c Cobjc+   fromSuffix "M"        = c Cobjcxx+   fromSuffix "mm"       = c Cobjcxx+   fromSuffix "cc"       = c Ccxx+   fromSuffix "cxx"      = c Ccxx+   fromSuffix "s"        = as False+   fromSuffix "S"        = as True+   fromSuffix "ll"       = llvmPipeline pipe_env hsc_env Nothing input_fn+   fromSuffix "bc"       = llvmLlcPipeline pipe_env hsc_env Nothing input_fn+   fromSuffix "lm_s"     = llvmManglePipeline pipe_env hsc_env Nothing input_fn+   fromSuffix "o"        = return (Just input_fn)+   fromSuffix "cmm"      = Just <$> cmmCppPipeline pipe_env hsc_env input_fn+   fromSuffix "cmmcpp"   = Just <$> cmmPipeline pipe_env hsc_env input_fn+   fromSuffix _          = return (Just input_fn)++{-+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 parrelism (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,13 @@+module GHC.Driver.Pipeline where+++import GHC.Driver.Env.Types ( HscEnv )+import GHC.ForeignSrcLang ( ForeignSrcLang )+import GHC.Prelude (FilePath, IO)+import GHC.Unit.Module.Location (ModLocation)+import GHC.Unit.Module.Name (ModuleName)+import GHC.Driver.Session (DynFlags)++-- 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 ()
+ GHC/Driver/Pipeline/Execute.hs view
@@ -0,0 +1,1373 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE GADTs #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+#include <ghcplatform.h>++{- Functions for providing the default interpretation of the 'TPhase' actions+-}+module GHC.Driver.Pipeline.Execute where++import GHC.Prelude+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Catch+import GHC.Driver.Hooks+import Control.Monad.Trans.Reader+import GHC.Driver.Pipeline.Monad+import GHC.Driver.Pipeline.Phases+import GHC.Driver.Env hiding (Hsc)+import GHC.Unit.Module.Location+import GHC.Driver.Phases+import GHC.Unit.Module.Name ( ModuleName )+import GHC.Unit.Types+import GHC.Types.SourceFile+import GHC.Unit.Module.Status+import GHC.Unit.Module.ModIface+import GHC.Linker.Types+import GHC.Driver.Backend+import GHC.Driver.Session+import GHC.Driver.CmdLine+import GHC.Unit.Module.ModSummary+import qualified GHC.LanguageExtensions as LangExt+import GHC.Types.SrcLoc+import GHC.Driver.Main+import GHC.Tc.Types+import GHC.Types.Error+import GHC.Driver.Errors.Types+import GHC.Fingerprint+import GHC.Utils.Logger+import GHC.Utils.TmpFs+import GHC.Platform+import Data.List (intercalate, isInfixOf)+import GHC.Unit.Env+import GHC.SysTools.Info+import GHC.Utils.Error+import Data.Maybe+import GHC.CmmToLlvm.Mangler+import GHC.SysTools+import GHC.Utils.Panic.Plain+import System.Directory+import System.FilePath+import GHC.Utils.Misc+import GHC.Utils.Outputable+import GHC.Unit.Info+import GHC.Unit.State+import GHC.Unit.Home+import GHC.Data.Maybe+import GHC.Iface.Make+import Data.Time+import GHC.Driver.Config.Parser+import GHC.Parser.Header+import GHC.Data.StringBuffer+import GHC.Types.SourceError+import GHC.Unit.Finder+import GHC.Runtime.Loader+import Data.IORef+import GHC.Types.Name.Env+import GHC.Platform.Ways+import GHC.Platform.ArchOS+import GHC.CmmToLlvm.Base ( llvmVersionList )+import {-# SOURCE #-} GHC.Driver.Pipeline (compileForeign, compileEmptyStub)+import GHC.Settings+import System.IO+import GHC.Linker.ExtraObj+import GHC.Linker.Dynamic+import Data.Version+import GHC.Utils.Panic+import GHC.Unit.Module.Env+import GHC.Driver.Env.KnotVars+import GHC.Driver.Config.Finder+import GHC.Rename.Names++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)+        False{-not raw-}+        input_fn output_fn+  return output_fn+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 input_fn) = runCcPhase phase pipe_env hsc_env input_fn+runPhase (T_As cpp pipe_env hsc_env location input_fn) = do+  runAsPhase cpp pipe_env hsc_env location input_fn+runPhase (T_LlvmOpt pipe_env hsc_env input_fn) =+  runLlvmOptPhase pipe_env hsc_env input_fn+runPhase (T_LlvmLlc pipe_env hsc_env input_fn) =+  runLlvmLlcPhase pipe_env hsc_env input_fn+runPhase (T_LlvmMangle pipe_env hsc_env input_fn) =+  runLlvmManglePhase pipe_env hsc_env input_fn+runPhase (T_MergeForeign pipe_env hsc_env input_fn fos) =+  runMergeForeign pipe_env hsc_env input_fn fos++runLlvmManglePhase :: PipeEnv -> HscEnv -> FilePath -> IO [Char]+runLlvmManglePhase pipe_env hsc_env input_fn = do+      let next_phase = As False+      output_fn <- phaseOutputFilenameNew next_phase pipe_env hsc_env Nothing+      let dflags = hsc_dflags hsc_env+      llvmFixupAsm (targetPlatform dflags) input_fn output_fn+      return output_fn++runMergeForeign :: PipeEnv -> HscEnv -> FilePath -> [FilePath] -> IO FilePath+runMergeForeign _pipe_env hsc_env input_fn foreign_os = do+     if null foreign_os+       then return input_fn+       else do+         -- Work around a binutil < 2.31 bug where you can't merge objects if the output file+         -- is one of the inputs+         new_o <- newTempName (hsc_logger hsc_env)+                              (hsc_tmpfs hsc_env)+                              (tmpDir (hsc_dflags hsc_env))+                              TFL_CurrentModule "o"+         copyFile input_fn new_o+         joinObjectFiles hsc_env (new_o : foreign_os) input_fn+         return input_fn++runLlvmLlcPhase :: PipeEnv -> HscEnv -> FilePath -> IO FilePath+runLlvmLlcPhase pipe_env hsc_env input_fn = do+    -- Note [Clamping of llc optimizations]+    -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+    -- See #13724+    --+    -- we clamp the llc optimization between [1,2]. This is because passing -O0+    -- to llc 3.9 or llc 4.0, the naive register allocator can fail with+    --+    --   Error while trying to spill R1 from class GPR: Cannot scavenge register+    --   without an emergency spill slot!+    --+    -- Observed at least with target 'arm-unknown-linux-gnueabihf'.+    --+    --+    -- With LLVM4, llc -O3 crashes when ghc-stage1 tries to compile+    --   rts/HeapStackCheck.cmm+    --+    -- llc -O3 '-mtriple=arm-unknown-linux-gnueabihf' -enable-tbaa /var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_6.bc -o /var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_7.lm_s+    -- 0  llc                      0x0000000102ae63e8 llvm::sys::PrintStackTrace(llvm::raw_ostream&) + 40+    -- 1  llc                      0x0000000102ae69a6 SignalHandler(int) + 358+    -- 2  libsystem_platform.dylib 0x00007fffc23f4b3a _sigtramp + 26+    -- 3  libsystem_c.dylib        0x00007fffc226498b __vfprintf + 17876+    -- 4  llc                      0x00000001029d5123 llvm::SelectionDAGISel::LowerArguments(llvm::Function const&) + 5699+    -- 5  llc                      0x0000000102a21a35 llvm::SelectionDAGISel::SelectAllBasicBlocks(llvm::Function const&) + 3381+    -- 6  llc                      0x0000000102a202b1 llvm::SelectionDAGISel::runOnMachineFunction(llvm::MachineFunction&) + 1457+    -- 7  llc                      0x0000000101bdc474 (anonymous namespace)::ARMDAGToDAGISel::runOnMachineFunction(llvm::MachineFunction&) + 20+    -- 8  llc                      0x00000001025573a6 llvm::MachineFunctionPass::runOnFunction(llvm::Function&) + 134+    -- 9  llc                      0x000000010274fb12 llvm::FPPassManager::runOnFunction(llvm::Function&) + 498+    -- 10 llc                      0x000000010274fd23 llvm::FPPassManager::runOnModule(llvm::Module&) + 67+    -- 11 llc                      0x00000001027501b8 llvm::legacy::PassManagerImpl::run(llvm::Module&) + 920+    -- 12 llc                      0x000000010195f075 compileModule(char**, llvm::LLVMContext&) + 12133+    -- 13 llc                      0x000000010195bf0b main + 491+    -- 14 libdyld.dylib            0x00007fffc21e5235 start + 1+    -- Stack dump:+    -- 0.  Program arguments: llc -O3 -mtriple=arm-unknown-linux-gnueabihf -enable-tbaa /var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_6.bc -o /var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_7.lm_s+    -- 1.  Running pass 'Function Pass Manager' on module '/var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_6.bc'.+    -- 2.  Running pass 'ARM Instruction Selection' on function '@"stg_gc_f1$def"'+    --+    -- Observed at least with -mtriple=arm-unknown-linux-gnueabihf -enable-tbaa+    --+    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 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+    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 $ llvmConfig dflags 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 dflags)++        -- don't specify anything if user has specified commands. We do this+        -- for opt but not llc since opt is very specifically for optimisation+        -- passes only, so if the user is passing us extra options we assume+        -- they know what they are doing and don't get in the way.+        optFlag = if null (getOpts dflags opt_lo)+                  then map GHC.SysTools.Option $ words llvmOpts+                  else []++    output_fn <- phaseOutputFilenameNew LlvmLlc pipe_env hsc_env Nothing++    GHC.SysTools.runLlvmOpt logger dflags+               (   optFlag+                ++ defaultOptions +++                [ GHC.SysTools.FileOption "" input_fn+                , GHC.SysTools.Option "-o"+                , GHC.SysTools.FileOption "" output_fn]+                )++    return output_fn+++runAsPhase :: Bool -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> IO FilePath+runAsPhase with_cpp pipe_env hsc_env location input_fn = do+        let dflags     = hsc_dflags   hsc_env+        let logger     = hsc_logger   hsc_env+        let unit_env   = hsc_unit_env hsc_env+        let platform   = ue_platform unit_env++        -- LLVM from version 3.0 onwards doesn't support the OS X system+        -- assembler, so we use clang as the assembler instead. (#5636)+        let (as_prog, get_asm_info) | backend dflags == LLVM+                    , platformOS platform == OSDarwin+                    = (GHC.SysTools.runClang, pure Clang)+                    | otherwise+                    = (GHC.SysTools.runAs, getAssemblerInfo logger dflags)++        asmInfo <- get_asm_info++        let cmdline_include_paths = includePaths dflags+        let pic_c_flags = picCCOpts dflags++        output_fn <- phaseOutputFilenameNew StopLn pipe_env hsc_env location++        -- we create directories for the object file, because it+        -- might be a hierarchical module.+        createDirectoryIfMissing True (takeDirectory output_fn)++        let global_includes = [ GHC.SysTools.Option ("-I" ++ p)+                              | p <- includePathsGlobal cmdline_include_paths ]+        let local_includes = [ GHC.SysTools.Option ("-iquote" ++ p)+                             | p <- includePathsQuote cmdline_include_paths +++                                includePathsQuoteImplicit cmdline_include_paths]+        let runAssembler inputFilename outputFilename+              = withAtomicRename outputFilename $ \temp_outputFilename ->+                    as_prog+                       logger dflags+                       (local_includes ++ global_includes+                       -- See Note [-fPIC for assembler]+                       ++ map GHC.SysTools.Option pic_c_flags+                       -- See Note [Produce big objects on Windows]+                       ++ [ GHC.SysTools.Option "-Wa,-mbig-obj"+                          | platformOS (targetPlatform dflags) == OSMinGW32+                          , not $ target32Bit (targetPlatform dflags)+                          ]++                       ++ (if any (asmInfo ==) [Clang, AppleClang, AppleClang51]+                            then [GHC.SysTools.Option "-Qunused-arguments"]+                            else [])+                       ++ [ GHC.SysTools.Option "-x"+                          , if with_cpp+                              then GHC.SysTools.Option "assembler-with-cpp"+                              else GHC.SysTools.Option "assembler"+                          , GHC.SysTools.Option "-c"+                          , GHC.SysTools.FileOption "" inputFilename+                          , GHC.SysTools.Option "-o"+                          , GHC.SysTools.FileOption "" temp_outputFilename+                          ])++        debugTraceMsg logger 4 (text "Running the assembler")+        runAssembler input_fn output_fn++        return output_fn+++runCcPhase :: Phase -> PipeEnv -> HscEnv -> FilePath -> IO FilePath+runCcPhase cc_phase pipe_env hsc_env input_fn = do+  let dflags    = hsc_dflags hsc_env+  let logger    = hsc_logger hsc_env+  let unit_env  = hsc_unit_env hsc_env+  let home_unit = hsc_home_unit hsc_env+  let tmpfs     = hsc_tmpfs hsc_env+  let platform  = ue_platform unit_env+  let hcc       = cc_phase `eqPhase` HCc++  let cmdline_include_paths =  offsetIncludePaths dflags (includePaths dflags)++  -- HC files have the dependent packages stamped into them+  pkgs <- if hcc then getHCFilePackages input_fn else return []++  -- add package include paths even if we're just compiling .c+  -- files; this is the Value Add(TM) that using ghc instead of+  -- gcc gives you :)+  ps <- mayThrowUnitErr (preloadUnitsInfo' unit_env pkgs)+  let pkg_include_dirs     = collectIncludeDirs ps+  let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) []+        (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs)+  let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) []+        (includePathsQuote cmdline_include_paths +++         includePathsQuoteImplicit cmdline_include_paths)+  let include_paths = include_paths_quote ++ include_paths_global++  -- pass -D or -optP to preprocessor when compiling foreign C files+  -- (#16737). Doing it in this way is simpler and also enable the C+  -- compiler to perform preprocessing and parsing in a single pass,+  -- but it may introduce inconsistency if a different pgm_P is specified.+  let opts = getOpts dflags opt_P+      aug_imports = augmentImports dflags opts++      more_preprocessor_opts = concat+        [ ["-Xpreprocessor", i]+        | not hcc+        , i <- aug_imports+        ]++  let gcc_extra_viac_flags = extraGccViaCFlags dflags+  let pic_c_flags = picCCOpts dflags++  let verbFlags = getVerbFlags dflags++  -- cc-options are not passed when compiling .hc files.  Our+  -- hc code doesn't not #include any header files anyway, so these+  -- options aren't necessary.+  let pkg_extra_cc_opts+          | hcc       = []+          | otherwise = collectExtraCcOpts ps++  let framework_paths+          | platformUsesFrameworks platform+          = let pkgFrameworkPaths     = collectFrameworksDirs ps+                cmdlineFrameworkPaths = frameworkPaths dflags+            in map ("-F"++) (cmdlineFrameworkPaths ++ pkgFrameworkPaths)+          | otherwise+          = []++  let cc_opt | llvmOptLevel dflags >= 2 = [ "-O2" ]+             | llvmOptLevel dflags >= 1 = [ "-O" ]+             | otherwise            = []++  -- Decide next phase+  let next_phase = As False+  output_fn <- phaseOutputFilenameNew next_phase pipe_env hsc_env Nothing++  let+    more_hcc_opts =+          -- on x86 the floating point regs have greater precision+          -- than a double, which leads to unpredictable results.+          -- By default, we turn this off with -ffloat-store unless+          -- the user specified -fexcess-precision.+          (if platformArch platform == ArchX86 &&+              not (gopt Opt_ExcessPrecision dflags)+                  then [ "-ffloat-store" ]+                  else []) ++++          -- gcc's -fstrict-aliasing allows two accesses to memory+          -- to be considered non-aliasing if they have different types.+          -- This interacts badly with the C code we generate, which is+          -- very weakly typed, being derived from C--.+          ["-fno-strict-aliasing"]++  ghcVersionH <- getGhcVersionPathName dflags unit_env++  GHC.SysTools.runCc (phaseForeignLanguage cc_phase) logger tmpfs dflags (+                  [ GHC.SysTools.FileOption "" input_fn+                  , GHC.SysTools.Option "-o"+                  , GHC.SysTools.FileOption "" output_fn+                  ]+                 ++ map GHC.SysTools.Option (+                    pic_c_flags++          -- Stub files generated for foreign exports references the runIO_closure+          -- and runNonIO_closure symbols, which are defined in the base package.+          -- These symbols are imported into the stub.c file via RtsAPI.h, and the+          -- way we do the import depends on whether we're currently compiling+          -- the base package or not.+                 ++ (if platformOS platform == OSMinGW32 &&+                        isHomeUnitId home_unit baseUnitId+                          then [ "-DCOMPILING_BASE_PACKAGE" ]+                          else [])++                 -- GCC 4.6+ doesn't like -Wimplicit when compiling C++.+                 ++ (if (cc_phase /= Ccxx && cc_phase /= Cobjcxx)+                       then ["-Wimplicit"]+                       else [])++                 ++ (if hcc+                       then gcc_extra_viac_flags ++ more_hcc_opts+                       else [])+                 ++ verbFlags+                 ++ [ "-S" ]+                 ++ cc_opt+                 ++ [ "-include", ghcVersionH ]+                 ++ framework_paths+                 ++ include_paths+                 ++ more_preprocessor_opts+                 ++ pkg_extra_cc_opts+                 ))++  return output_fn++-- This is where all object files get written from, for hs-boot and hsig files as well.+runHscBackendPhase :: PipeEnv+                   -> HscEnv+                   -> ModuleName+                   -> HscSource+                   -> ModLocation+                   -> HscBackendAction+                   -> IO ([FilePath], ModIface, Maybe Linkable, FilePath)+runHscBackendPhase pipe_env hsc_env mod_name src_flavour location result = do+  let dflags = hsc_dflags hsc_env+      logger = hsc_logger hsc_env+      o_file = if dynamicNow dflags then ml_dyn_obj_file location else ml_obj_file location -- The real object file+      next_phase = hscPostBackendPhase src_flavour (backend dflags)+  case result of+      HscUpdate iface ->+          do+             case src_flavour of+               HsigFile -> do+                 -- We need to create a REAL but empty .o file+                 -- because we are going to attempt to put it in a library+                 let input_fn = expectJust "runPhase" (ml_hs_file location)+                     basename = dropExtension input_fn+                 compileEmptyStub dflags hsc_env basename location mod_name++               -- In the case of hs-boot files, generate a dummy .o-boot+               -- stamp file for the benefit of Make+               HsBootFile -> touchObjectFile logger dflags o_file+               HsSrcFile -> panic "HscUpdate not relevant for HscSrcFile"++             return ([], iface, Nothing, o_file)+      HscRecomp { hscs_guts = cgguts,+                  hscs_mod_location = mod_location,+                  hscs_partial_iface = partial_iface,+                  hscs_old_iface_hash = mb_old_iface_hash+                }+        -> case backend dflags of+          NoBackend -> panic "HscRecomp not relevant for NoBackend"+          Interpreter -> do+              -- In interpreted mode the regular codeGen backend is not run so we+              -- generate a interface without codeGen info.+              final_iface <- mkFullIface hsc_env partial_iface Nothing+              hscMaybeWriteIface logger dflags True final_iface mb_old_iface_hash location++              (hasStub, comp_bc, spt_entries) <- hscInteractive hsc_env cgguts mod_location++              stub_o <- case hasStub of+                        Nothing -> return []+                        Just stub_c -> do+                            stub_o <- compileStub hsc_env stub_c+                            return [DotO stub_o]++              let hs_unlinked = [BCOs comp_bc spt_entries]+              unlinked_time <- getCurrentTime+              let !linkable = LM unlinked_time (mkHomeModule (hsc_home_unit hsc_env) mod_name)+                             (hs_unlinked ++ stub_o)+              return ([], final_iface, Just linkable, panic "interpreter")+          _ -> do+              output_fn <- phaseOutputFilenameNew next_phase pipe_env hsc_env (Just location)+              (outputFilename, mStub, foreign_files, mb_cg_infos) <-+                hscGenHardCode hsc_env cgguts mod_location output_fn+              final_iface <- mkFullIface hsc_env partial_iface mb_cg_infos++              -- See Note [Writing interface files]+              hscMaybeWriteIface logger dflags False final_iface mb_old_iface_hash mod_location++              stub_o <- mapM (compileStub hsc_env) mStub+              foreign_os <-+                mapM (uncurry (compileForeign hsc_env)) foreign_files+              let fos = (maybe [] return stub_o ++ foreign_os)++              -- This is awkward, no linkable is produced here because we still+              -- have some way to do before the object file is produced+              -- In future we can split up the driver logic more so that this function+              -- is in TPipeline and in this branch we can invoke the rest of the backend phase.+              return (fos, final_iface, Nothing, outputFilename)+++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.Coverage.isGoodTickSrcSpan where we check that the filename in+       -- a SrcLoc is the same as the source filenaame, the two will+       -- look bogusly different. See test:+       -- libraries/hpc/tests/function/subdir/tough2.hs+       escape ('\\':cs) = '\\':'\\': escape cs+       escape ('\"':cs) = '\\':'\"': escape cs+       escape ('\'':cs) = '\\':'\'': escape cs+       escape (c:cs)    = c : escape cs+       escape []        = []++    let flags = [ -- The -h option passes the file name for unlit to+                  -- put in a #line directive+                  GHC.SysTools.Option     "-h"+                  -- See Note [Don't normalise input filenames].+                , GHC.SysTools.Option $ escape input_fn+                , GHC.SysTools.FileOption "" input_fn+                , GHC.SysTools.FileOption "" output_fn+                ]++    let dflags = hsc_dflags hsc_env+        logger = hsc_logger hsc_env+    GHC.SysTools.runUnlit logger dflags flags++    return output_fn++getFileArgs :: HscEnv -> FilePath -> IO ((DynFlags, Messages PsMessage, [Warn]))+getFileArgs hsc_env input_fn = do+  let dflags0 = hsc_dflags hsc_env+      parser_opts = initParserOpts dflags0+  (warns0, src_opts) <- getOptionsFromFile parser_opts input_fn+  (dflags1, unhandled_flags, warns)+    <- parseDynamicFilePragma dflags0 src_opts+  checkProcessArgsResult unhandled_flags+  return (dflags1, warns0, warns)++runCppPhase :: HscEnv -> FilePath -> FilePath -> IO FilePath+runCppPhase hsc_env input_fn output_fn = do+  doCpp (hsc_logger hsc_env)+           (hsc_tmpfs hsc_env)+           (hsc_dflags hsc_env)+           (hsc_unit_env hsc_env)+           True{-raw-}+           input_fn output_fn+  return output_fn+++runHscPhase :: PipeEnv+  -> HscEnv+  -> FilePath+  -> HscSource+  -> IO (HscEnv, ModSummary, HscRecompStatus)+runHscPhase pipe_env hsc_env0 input_fn src_flavour = do+  let dflags0 = hsc_dflags hsc_env0+      PipeEnv{ src_basename=basename,+               src_suffix=suff } = pipe_env++  -- we add the current directory (i.e. the directory in which+  -- the .hs files resides) to the include path, since this is+  -- what gcc does, and it's probably what you want.+  let current_dir = takeDirectory basename+      new_includes = addImplicitQuoteInclude paths [current_dir]+      paths = includePaths dflags0+      dflags = dflags0 { includePaths = new_includes }+      hsc_env = hscSetFlags dflags hsc_env0++++  -- gather the imports and module name+  (hspp_buf,mod_name,imps,src_imps, ghc_prim_imp) <- do+    buf <- hGetStringBuffer input_fn+    let imp_prelude = xopt LangExt.ImplicitPrelude dflags+        popts = initParserOpts dflags+        rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env)+        rn_imps = fmap (\(rpk, lmn@(L _ mn)) -> (rn_pkg_qual mn rpk, lmn))+    eimps <- getImports popts imp_prelude buf input_fn (basename <.> suff)+    case eimps of+        Left errs -> throwErrors (GhcPsMessage <$> errs)+        Right (src_imps,imps, ghc_prim_imp, L _ mod_name) -> return+              (Just buf, mod_name, rn_imps imps, rn_imps src_imps, ghc_prim_imp)++  -- Take -o into account if present+  -- Very like -ohi, but we must *only* do this if we aren't linking+  -- (If we're linking then the -o applies to the linked thing, not to+  -- the object file for one module.)+  -- Note the nasty duplication with the same computation in compileFile above+  location <- mkOneShotModLocation pipe_env dflags src_flavour mod_name+  let o_file = ml_obj_file location -- The real object file+      hi_file = ml_hi_file location+      hie_file = ml_hie_file location+      dyn_o_file = ml_dyn_obj_file location++  src_hash <- getFileHash (basename <.> suff)+  hi_date <- modificationTimeIfExists hi_file+  hie_date <- modificationTimeIfExists hie_file+  o_mod <- modificationTimeIfExists o_file+  dyn_o_mod <- modificationTimeIfExists dyn_o_file++  -- Tell the finder cache about this module+  mod <- do+    let home_unit = hsc_home_unit hsc_env+    let fc        = hsc_FC hsc_env+    addHomeModuleToFinder fc home_unit mod_name location++  -- Make the ModSummary to hand to hscMain+  let+    mod_summary = ModSummary {  ms_mod       = mod,+                                ms_hsc_src   = src_flavour,+                                ms_hspp_file = input_fn,+                                ms_hspp_opts = dflags,+                                ms_hspp_buf  = hspp_buf,+                                ms_location  = location,+                                ms_hs_hash   = src_hash,+                                ms_obj_date  = o_mod,+                                ms_dyn_obj_date = dyn_o_mod,+                                ms_parsed_mod   = Nothing,+                                ms_iface_date   = hi_date,+                                ms_hie_date     = hie_date,+                                ms_ghc_prim_import = ghc_prim_imp,+                                ms_textual_imps = imps,+                                ms_srcimps      = src_imps }+++  -- run the compiler!+  let msg :: Messager+      msg hsc_env _ what _ = oneShotMsg (hsc_logger hsc_env) what+  plugin_hsc_env' <- initializePlugins hsc_env++  -- Need to set the knot-tying mutable variable for interface+  -- files. See GHC.Tc.Utils.TcGblEnv.tcg_type_env_var.+  -- See also Note [hsc_type_env_var hack]+  type_env_var <- newIORef emptyNameEnv+  let plugin_hsc_env = plugin_hsc_env' { hsc_type_env_vars = knotVarsFromModuleEnv (mkModuleEnv [(mod, type_env_var)]) }++  status <- hscRecompStatus (Just msg) plugin_hsc_env mod_summary+                        Nothing Nothing (1, 1)++  return (plugin_hsc_env, mod_summary, status)++-- | Calculate the ModLocation from the provided DynFlags. This function is only used+-- in one-shot mode and therefore takes into account the effect of -o/-ohi flags+-- (which do nothing in --make mode)+mkOneShotModLocation :: PipeEnv -> DynFlags -> HscSource -> ModuleName -> IO ModLocation+mkOneShotModLocation pipe_env dflags src_flavour mod_name = do+    let PipeEnv{ src_basename=basename,+             src_suffix=suff } = pipe_env+    let location1 = mkHomeModLocation2 fopts mod_name basename suff++    -- Boot-ify it if necessary+    let location2+          | HsBootFile <- src_flavour = addBootSuffixLocnOut location1+          | otherwise                 = location1+++    -- Take -ohi into account if present+    -- This can't be done in mkHomeModuleLocation because+    -- it only applies to the module being compiles+    let ohi = outputHi dflags+        location3 | Just fn <- ohi = location2{ ml_hi_file = fn }+                  | otherwise      = location2++    let dynohi = dynOutputHi dflags+        location4 | Just fn <- dynohi = location3{ ml_dyn_hi_file = fn }+                  | otherwise         = location3++    -- Take -o into account if present+    -- Very like -ohi, but we must *only* do this if we aren't linking+    -- (If we're linking then the -o applies to the linked thing, not to+    -- the object file for one module.)+    -- Note the nasty duplication with the same computation in compileFile+    -- above+    let expl_o_file = outputFile_ dflags+        expl_dyn_o_file  = dynOutputFile_ dflags+        location5 | Just ofile <- expl_o_file+                  , let dyn_ofile = fromMaybe (ofile -<.> dynObjectSuf_ dflags) expl_dyn_o_file+                  , isNoLink (ghcLink dflags)+                  = location4 { ml_obj_file = ofile+                              , ml_dyn_obj_file = dyn_ofile }+                  | Just dyn_ofile <- expl_dyn_o_file+                  = location4 { ml_dyn_obj_file = dyn_ofile }+                  | otherwise = location4+    return location5+    where+      fopts = initFinderOpts dflags++runHscTcPhase :: HscEnv -> ModSummary -> IO (FrontendResult, Messages GhcMessage)+runHscTcPhase = hscTypecheckAndGetWarnings++runHscPostTcPhase ::+    HscEnv+  -> ModSummary+  -> FrontendResult+  -> Messages GhcMessage+  -> Maybe Fingerprint+  -> IO HscBackendAction+runHscPostTcPhase hsc_env mod_summary tc_result tc_warnings mb_old_hash = do+        runHsc hsc_env $ do+            hscDesugarAndSimplify mod_summary tc_result tc_warnings mb_old_hash+++runHsPpPhase :: HscEnv -> FilePath -> FilePath -> FilePath -> IO FilePath+runHsPpPhase hsc_env orig_fn input_fn output_fn = do+    let dflags = hsc_dflags hsc_env+    let logger = hsc_logger hsc_env+    GHC.SysTools.runPp logger dflags+      ( [ GHC.SysTools.Option     orig_fn+      , GHC.SysTools.Option     input_fn+      , GHC.SysTools.FileOption "" output_fn+      ] )+    return output_fn++phaseOutputFilenameNew :: Phase -- ^ The next phase+                       -> PipeEnv+                       -> HscEnv+                       -> Maybe ModLocation -- ^ A ModLocation, if we are compiling a Haskell source file+                       -> IO FilePath+phaseOutputFilenameNew next_phase pipe_env hsc_env maybe_loc = do+  let PipeEnv{stop_phase, src_basename, output_spec} = pipe_env+  let dflags = hsc_dflags hsc_env+      logger = hsc_logger hsc_env+      tmpfs = hsc_tmpfs hsc_env+  getOutputFilename logger tmpfs (stopPhaseToPhase stop_phase) output_spec+                    src_basename dflags next_phase maybe_loc+++-- | Computes the next output filename for something in the compilation+-- pipeline.  This is controlled by several variables:+--+--      1. 'Phase': the last phase to be run (e.g. 'stopPhase').  This+--         is used to tell if we're in the last phase or not, because+--         in that case flags like @-o@ may be important.+--      2. 'PipelineOutput': is this intended to be a 'Temporary' or+--         'Persistent' build output?  Temporary files just go in+--         a fresh temporary name.+--      3. 'String': what was the basename of the original input file?+--      4. 'DynFlags': the obvious thing+--      5. 'Phase': the phase we want to determine the output filename of.+--      6. @Maybe ModLocation@: the 'ModLocation' of the module we're+--         compiling; this can be used to override the default output+--         of an object file.  (TODO: do we actually need this?)+getOutputFilename+  :: Logger+  -> TmpFs+  -> Phase+  -> PipelineOutput+  -> String+  -> DynFlags+  -> Phase -- next phase+  -> Maybe ModLocation+  -> IO FilePath+getOutputFilename logger tmpfs stop_phase output basename dflags next_phase maybe_location+  -- 1. If we are generating object files for a .hs file, then return the odir as the ModLocation+  -- will have been modified to point to the accurate locations+ | StopLn <- next_phase, Just loc <- maybe_location  =+      return $ if dynamicNow dflags then ml_dyn_obj_file loc+                                    else ml_obj_file loc+ -- 2. If output style is persistant 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, outputFile_ dflags, 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 :: DynFlags+            -> [(String, String)]  -- ^ pairs of (opt, llc) arguments+llvmOptions dflags =+       [("-enable-tbaa -tbaa",  "-enable-tbaa") | gopt Opt_LlvmTBAA dflags ]+    ++ [("-relocation-model=" ++ rmodel+        ,"-relocation-model=" ++ rmodel) | not (null rmodel)]+    ++ [("-stack-alignment=" ++ (show align)+        ,"-stack-alignment=" ++ (show align)) | align > 0 ]++    -- Additional llc flags+    ++ [("", "-mcpu=" ++ mcpu)   | not (null mcpu)+                                 , not (any (isInfixOf "-mcpu") (getOpts dflags opt_lc)) ]+    ++ [("", "-mattr=" ++ attrs) | not (null attrs) ]+    ++ [("", "-target-abi=" ++ abi) | not (null abi) ]++  where target = platformMisc_llvmTarget $ platformMisc dflags+        Just (LlvmTarget _ mcpu mattr) = lookup target (llvmTargets $ llvmConfig dflags)++        -- Relocation models+        rmodel | gopt Opt_PIC dflags         = "pic"+               | positionIndependent dflags  = "pic"+               | ways dflags `hasWay` WayDyn = "dynamic-no-pic"+               | otherwise                   = "static"++        platform = targetPlatform dflags++        align :: Int+        align = case platformArch platform of+                  ArchX86_64 | isAvxEnabled dflags -> 32+                  _                                -> 0++        attrs :: String+        attrs = intercalate "," $ mattr+              ++ ["+sse42"   | isSse4_2Enabled dflags   ]+              ++ ["+sse2"    | isSse2Enabled platform   ]+              ++ ["+sse"     | isSseEnabled platform    ]+              ++ ["+avx512f" | isAvx512fEnabled dflags  ]+              ++ ["+avx2"    | isAvx2Enabled dflags     ]+              ++ ["+avx"     | isAvxEnabled dflags      ]+              ++ ["+avx512cd"| isAvx512cdEnabled dflags ]+              ++ ["+avx512er"| isAvx512erEnabled dflags ]+              ++ ["+avx512pf"| isAvx512pfEnabled dflags ]+              ++ ["+bmi"     | isBmiEnabled dflags      ]+              ++ ["+bmi2"    | isBmi2Enabled dflags     ]++        abi :: String+        abi = case platformArch (targetPlatform dflags) of+                ArchRISCV64 -> "lp64d"+                _           -> ""+++-- Note [Filepaths and Multiple Home Units]+offsetIncludePaths :: DynFlags -> IncludeSpecs -> IncludeSpecs+offsetIncludePaths dflags (IncludeSpecs incs quotes impl) =+     let go = map (augmentByWorkingDirectory dflags)+     in IncludeSpecs (go incs) (go quotes) (go impl)+-- -----------------------------------------------------------------------------+-- Running CPP++-- | Run CPP+--+-- UnitEnv is needed to compute MIN_VERSION macros+doCpp :: Logger -> TmpFs -> DynFlags -> UnitEnv -> Bool -> FilePath -> FilePath -> IO ()+doCpp logger tmpfs dflags unit_env raw input_fn output_fn = do+    let hscpp_opts = picPOpts dflags+    let cmdline_include_paths = offsetIncludePaths dflags (includePaths dflags)+    let unit_state = ue_units unit_env+    pkg_include_dirs <- mayThrowUnitErr+                        (collectIncludeDirs <$> preloadUnitsInfo unit_env)+    -- MP: This is not quite right, the headers which are supposed to be installed in+    -- the package might not be the same as the provided include paths, but it's a close+    -- enough approximation for things to work. A proper solution would be to have to declare which paths should+    -- be propagated to dependent packages.+    let home_pkg_deps =+         [homeUnitEnv_dflags . ue_findHomeUnitEnv uid $ unit_env | uid <- ue_transitiveHomeDeps (ue_currentUnit unit_env) unit_env]+        dep_pkg_extra_inputs = [offsetIncludePaths fs (includePaths fs) | fs <- home_pkg_deps]++    let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) []+          (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs+                                                    ++ concatMap includePathsGlobal dep_pkg_extra_inputs)+    let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) []+          (includePathsQuote cmdline_include_paths +++           includePathsQuoteImplicit cmdline_include_paths)+    let include_paths = include_paths_quote ++ include_paths_global++    let verbFlags = getVerbFlags dflags++    let cpp_prog args | raw       = GHC.SysTools.runCpp logger dflags args+                      | otherwise = GHC.SysTools.runCc Nothing logger tmpfs dflags+                                        (GHC.SysTools.Option "-E" : args)++    let platform   = targetPlatform dflags+        targetArch = stringEncodeArch $ platformArch platform+        targetOS = stringEncodeOS $ platformOS platform+        isWindows = platformOS platform == OSMinGW32+    let target_defs =+          [ "-D" ++ HOST_OS     ++ "_BUILD_OS",+            "-D" ++ HOST_ARCH   ++ "_BUILD_ARCH",+            "-D" ++ targetOS    ++ "_HOST_OS",+            "-D" ++ targetArch  ++ "_HOST_ARCH" ]+        -- remember, in code we *compile*, the HOST is the same our TARGET,+        -- and BUILD is the same as our HOST.++    let io_manager_defs =+          [ "-D__IO_MANAGER_WINIO__=1" | isWindows ] +++          [ "-D__IO_MANAGER_MIO__=1"               ]++    let sse_defs =+          [ "-D__SSE__"      | isSseEnabled      platform ] +++          [ "-D__SSE2__"     | isSse2Enabled     platform ] +++          [ "-D__SSE4_2__"   | isSse4_2Enabled   dflags ]++    let avx_defs =+          [ "-D__AVX__"      | isAvxEnabled      dflags ] +++          [ "-D__AVX2__"     | isAvx2Enabled     dflags ] +++          [ "-D__AVX512CD__" | isAvx512cdEnabled dflags ] +++          [ "-D__AVX512ER__" | isAvx512erEnabled dflags ] +++          [ "-D__AVX512F__"  | isAvx512fEnabled  dflags ] +++          [ "-D__AVX512PF__" | isAvx512pfEnabled dflags ]++    backend_defs <- getBackendDefs logger dflags++    let th_defs = [ "-D__GLASGOW_HASKELL_TH__" ]+    -- Default CPP defines in Haskell source+    ghcVersionH <- getGhcVersionPathName dflags unit_env+    let hsSourceCppOpts = [ "-include", ghcVersionH ]++    -- MIN_VERSION macros+    let uids = explicitUnits unit_state+        pkgs = mapMaybe (lookupUnit unit_state . fst) uids+    mb_macro_include <-+        if not (null pkgs) && gopt Opt_VersionMacros dflags+            then do macro_stub <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "h"+                    writeFile macro_stub (generatePackageVersionMacros pkgs)+                    -- Include version macros for every *exposed* package.+                    -- Without -hide-all-packages and with a package database+                    -- size of 1000 packages, it takes cpp an estimated 2+                    -- milliseconds to process this file. See #10970+                    -- comment 8.+                    return [GHC.SysTools.FileOption "-include" macro_stub]+            else return []++    cpp_prog       (   map GHC.SysTools.Option verbFlags+                    ++ map GHC.SysTools.Option include_paths+                    ++ map GHC.SysTools.Option hsSourceCppOpts+                    ++ map GHC.SysTools.Option target_defs+                    ++ map GHC.SysTools.Option backend_defs+                    ++ map GHC.SysTools.Option th_defs+                    ++ map GHC.SysTools.Option hscpp_opts+                    ++ map GHC.SysTools.Option sse_defs+                    ++ map GHC.SysTools.Option avx_defs+                    ++ map GHC.SysTools.Option io_manager_defs+                    ++ mb_macro_include+        -- Set the language mode to assembler-with-cpp when preprocessing. This+        -- alleviates some of the C99 macro rules relating to whitespace and the hash+        -- operator, which we tend to abuse. Clang in particular is not very happy+        -- about this.+                    ++ [ GHC.SysTools.Option     "-x"+                       , GHC.SysTools.Option     "assembler-with-cpp"+                       , GHC.SysTools.Option     input_fn+        -- We hackily use Option instead of FileOption here, so that the file+        -- name is not back-slashed on Windows.  cpp is capable of+        -- dealing with / in filenames, so it works fine.  Furthermore+        -- if we put in backslashes, cpp outputs #line directives+        -- with *double* backslashes.   And that in turn means that+        -- our error messages get double backslashes in them.+        -- In due course we should arrange that the lexer deals+        -- with these \\ escapes properly.+                       , GHC.SysTools.Option     "-o"+                       , GHC.SysTools.FileOption "" output_fn+                       ])++getBackendDefs :: Logger -> DynFlags -> IO [String]+getBackendDefs logger dflags | backend dflags == LLVM = do+    llvmVer <- figureLlvmVersion logger dflags+    return $ case fmap llvmVersionList llvmVer of+               Just [m] -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,0) ]+               Just (m:n:_) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,n) ]+               _ -> []+  where+    format (major, minor)+      | minor >= 100 = error "getBackendDefs: Unsupported minor version"+      | otherwise = show $ (100 * major + minor :: Int) -- Contract is Int++getBackendDefs _ _ =+    return []++-- | What phase to run after one of the backend code generators has run+hscPostBackendPhase :: HscSource -> Backend -> Phase+hscPostBackendPhase HsBootFile _    =  StopLn+hscPostBackendPhase HsigFile _      =  StopLn+hscPostBackendPhase _ bcknd =+  case bcknd of+        ViaC        -> HCc+        NCG         -> As False+        LLVM        -> LlvmOpt+        NoBackend   -> StopLn+        Interpreter -> StopLn+++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,+partiall-linked-but-still-relocatable object. In a typical UNIX-style linker,+this is accomplished with the `ld -r` command. We rely on this for two ends:++ * We rely on `ld -r` to squash together split sections, making GHCi loading+   more efficient. See Note [Merging object files for GHCi].++ * We use merging to combine a module's object code (e.g. produced by the NCG)+   with its foreign stubs (typically produced by a C compiler).++The command used for object linking is set using the -pgmlm and -optlm+command-line options.++Sadly, the LLD linker that we use on Windows does not support the `-r` flag+needed to support object merging (see #21068). For this reason on Windows we do+not support GHCi objects.  To deal with foreign stubs we build a static archive+of all of a module's object files instead merging them. Consequently, we can+end up producing `.o` files which are in fact static archives. However,+toolchains generally don't have a problem with this as they use file headers,+not the filename, to determine the nature of inputs.++Note that this has somewhat non-obvious consequences when producing+initializers and finalizers. See Note [Initializers and finalizers in Cmm]+in GHC.Cmm.InitFini for details.+++Note [Merging object files for GHCi]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+GHCi can usually loads standard linkable object files using GHC's linker+implementation. However, most users build their projects with -split-sections,+meaning that such object files can have an extremely high number of sections.+As the linker must map each of these sections individually, loading such object+files is very inefficient.++To avoid this inefficiency, we use the linker's `-r` flag and a linker script+to produce a merged relocatable object file. This file will contain a singe+text section section and can consequently be mapped far more efficiently. As+gcc tends to do unpredictable things to our linker command line, we opt to+invoke ld directly in this case, in contrast to our usual strategy of linking+via gcc.+-}++-- | See Note [Object merging].+joinObjectFiles :: HscEnv -> [FilePath] -> FilePath -> IO ()+joinObjectFiles hsc_env o_files output_fn+  | can_merge_objs = 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) (+                        map GHC.SysTools.Option ld_build_id+                     ++ [ GHC.SysTools.Option "-o",+                          GHC.SysTools.FileOption "" output_fn ]+                     ++ args)++      -- suppress the generation of the .note.gnu.build-id section,+      -- which we don't need and sometimes causes ld to emit a+      -- warning:+      ld_build_id | toolSettings_ldSupportsBuildId toolSettings' = ["--build-id=none"]+                  | otherwise                                    = []++  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++++-- ---------------------------------------------------------------------------+-- Macros (cribbed from Cabal)++generatePackageVersionMacros :: [UnitInfo] -> String+generatePackageVersionMacros pkgs = concat+  -- Do not add any C-style comments. See #3389.+  [ generateMacros "" pkgname version+  | pkg <- pkgs+  , let version = unitPackageVersion pkg+        pkgname = map fixchar (unitPackageNameString pkg)+  ]++fixchar :: Char -> Char+fixchar '-' = '_'+fixchar c   = c++generateMacros :: String -> String -> Version -> String+generateMacros prefix name version =+  concat+  ["#define ", prefix, "VERSION_",name," ",show (showVersion version),"\n"+  ,"#define MIN_", prefix, "VERSION_",name,"(major1,major2,minor) (\\\n"+  ,"  (major1) <  ",major1," || \\\n"+  ,"  (major1) == ",major1," && (major2) <  ",major2," || \\\n"+  ,"  (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")"+  ,"\n\n"+  ]+  where+    (major1:major2:minor:_) = map show (versionBranch version ++ repeat 0)+++-- -----------------------------------------------------------------------------+-- Misc.++++touchObjectFile :: Logger -> DynFlags -> FilePath -> IO ()+touchObjectFile logger dflags path = do+  createDirectoryIfMissing True $ takeDirectory path+  GHC.SysTools.touch logger dflags "Touching object file" path++-- | Find out path to @ghcversion.h@ file+getGhcVersionPathName :: DynFlags -> UnitEnv -> IO FilePath+getGhcVersionPathName dflags unit_env = do+  candidates <- case ghcVersionFile dflags of+    Just path -> return [path]+    Nothing -> do+        ps <- mayThrowUnitErr (preloadUnitsInfo' unit_env [rtsUnitId])+        return ((</> "ghcversion.h") <$> collectIncludeDirs ps)++  found <- filterM doesFileExist candidates+  case found of+      []    -> throwGhcExceptionIO (InstallationError+                                    ("ghcversion.h missing; tried: "+                                      ++ intercalate ", " candidates))+      (x:_) -> return x++-- 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.Coverage.isGoodTickSrcSpan`, we compare the filename that a+  `SrcSpan` refers to with the name of the file we are currently compiling.+  For some reason I don't yet understand, they can sometimes legitimally be+  different, and then hpc ignores that SrcSpan.++Problem+  When running `ghc --make -fhpc A.hs`, where `A.hs` imports the literate+  module `B.lhs`, `B` is inferred to be in the file `./B.lhs` (1). At the+  start of the unlit phase, the name `./B.lhs` is normalised to `B.lhs` (2).+  Therefore the SrcSpans of `B` refer to the file `B.lhs` (3), but we are+  still compiling `./B.lhs`. Hpc thinks these two filenames are different (4),+  doesn't include ticks for B, and we have unhappy customers (#2991).++Solution+  Do not normalise `input_fn` when starting the unlit phase.++Alternative solution+  Another option would be to not compare the two filenames on equality, but to+  use System.FilePath.equalFilePath. That function first normalises its+  arguments. The problem is that by the time we need to do the comparison, the+  filenames have been turned into FastStrings, probably for performance+  reasons, so System.FilePath.equalFilePath can not be used directly.++Archeology+  The call to `normalise` was added in a commit called "Fix slash+  direction on Windows with the new filePath code" (c9b6b5e8). The problem+  that commit was addressing has since been solved in a different manner, in a+  commit called "Fix the filename passed to unlit" (1eedbc6b). So the+  `normalise` is no longer necessary.+-}
+ 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 :: Int -> Int -> Logger -> TVar Bool -- Signal that no more new logs will be added, clear the queue and exit+                    -> TVar LogQueueQueue -- Queue for logs+                    -> IO (IO ())+logThread _ _ logger stopped lqq_var = do+  finished_var <- newEmptyMVar+  _ <- forkIO $ print_logs *> putMVar finished_var ()+  return (takeMVar finished_var)+  where+    finish = mapM (printLogs logger)++    print_logs = join $ atomically $ do+      lqq <- readTVar lqq_var+      case dequeueLogQueueQueue lqq of+        Just (lq, lqq') -> do+          writeTVar lqq_var lqq'+          return (printLogs logger lq *> print_logs)+        Nothing -> do+          -- No log to print, check if we are finished.+          stopped <- readTVar stopped+          if not stopped then retry+                         else return (finish (allLogQueues lqq))
GHC/Driver/Pipeline/Monad.hs view
@@ -1,97 +1,38 @@-{-# LANGUAGE DeriveFunctor #-}--- | The CompPipeline monad and associated ops------ Defined in separate module so that it can safely be imported from Hooks+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE MultiParamTypeClasses #-}+-- | The 'TPipelineClass' and 'MonadUse' classes and associated types module GHC.Driver.Pipeline.Monad (-    CompPipeline(..), evalP-  , PhasePlus(..)-  , PipeEnv(..), PipeState(..), PipelineOutput(..)-  , getPipeEnv, getPipeState, getPipeSession-  , setDynFlags, setModLocation, setForeignOs, setIface-  , pipeStateDynFlags, pipeStateModIface, setPlugins+  TPipelineClass, MonadUse(..)++  , PipeEnv(..)+  , PipelineOutput(..)   ) where  import GHC.Prelude--import GHC.Utils.Monad-import GHC.Utils.Outputable-import GHC.Utils.Logger--import GHC.Driver.Session+import Control.Monad.IO.Class+import qualified Data.Kind as K import GHC.Driver.Phases-import GHC.Driver.Env-import GHC.Driver.Plugins--import GHC.Utils.TmpFs (TempFileLifetime)--import GHC.Types.SourceFile--import GHC.Unit.Module-import GHC.Unit.Module.ModIface-import GHC.Unit.Module.Status--import Control.Monad--newtype CompPipeline a = P { unP :: PipeEnv -> PipeState -> IO (PipeState, a) }-    deriving (Functor)--evalP :: CompPipeline a -> PipeEnv -> PipeState -> IO (PipeState, a)-evalP (P f) env st = f env st--instance Applicative CompPipeline where-    pure a = P $ \_env state -> return (state, a)-    (<*>) = ap--instance Monad CompPipeline where-  P m >>= k = P $ \env state -> do (state',a) <- m env state-                                   unP (k a) env state'--instance MonadIO CompPipeline where-    liftIO m = P $ \_env state -> do a <- m; return (state, a)--data PhasePlus = RealPhase Phase-               | HscOut HscSource ModuleName HscStatus+import GHC.Utils.TmpFs -instance Outputable PhasePlus where-    ppr (RealPhase p) = ppr p-    ppr (HscOut {}) = text "HscOut"+-- 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) --- -------------------------------------------------------------------------------- The pipeline uses a monad to carry around various bits of information+-- | Lift a `f` action into an `m` action.+class MonadUse f m where+  use :: f a -> m a --- PipeEnv: invariant information passed down+-- PipeEnv: invariant information passed down through the pipeline data PipeEnv = PipeEnv {-       stop_phase   :: Phase,       -- ^ Stop just before this phase+       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        output_spec  :: PipelineOutput -- ^ says where to put the pipeline output   } --- PipeState: information that might change during a pipeline run-data PipeState = PipeState {-       hsc_env   :: HscEnv,-          -- ^ only the DynFlags and the Plugins change in the HscEnv.  The-          -- DynFlags change at various points, for example when we read the-          -- OPTIONS_GHC pragmas in the Cpp phase.-       maybe_loc :: Maybe ModLocation,-          -- ^ the ModLocation.  This is discovered during compilation,-          -- in the Hsc phase where we read the module header.-       foreign_os :: [FilePath],-         -- ^ additional object files resulting from compiling foreign-         -- code. They come from two sources: foreign stubs, and-         -- add{C,Cxx,Objc,Objcxx}File from template haskell-       iface :: Maybe ModIface-         -- ^ Interface generated by HscOut phase. Only available after the-         -- phase runs.-  } -pipeStateDynFlags :: PipeState -> DynFlags-pipeStateDynFlags = hsc_dflags . hsc_env--pipeStateModIface :: PipeState -> Maybe ModIface-pipeStateModIface = iface- data PipelineOutput   = Temporary TempFileLifetime         -- ^ Output should be to a temporary file: we're going to@@ -104,39 +45,6 @@         -- ^ 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--getPipeEnv :: CompPipeline PipeEnv-getPipeEnv = P $ \env state -> return (state, env)--getPipeState :: CompPipeline PipeState-getPipeState = P $ \_env state -> return (state, state)--getPipeSession :: CompPipeline HscEnv-getPipeSession = P $ \_env state -> return (state, hsc_env state)--instance HasDynFlags CompPipeline where-    getDynFlags = P $ \_env state -> return (state, hsc_dflags (hsc_env state))--instance HasLogger CompPipeline where-    getLogger = P $ \_env state -> return (state, hsc_logger (hsc_env state))--setDynFlags :: DynFlags -> CompPipeline ()-setDynFlags dflags = P $ \_env state ->-  return (state{hsc_env= (hsc_env state){ hsc_dflags = dflags }}, ())--setPlugins :: [LoadedPlugin] -> [StaticPlugin] -> CompPipeline ()-setPlugins dyn static = P $ \_env state ->-  let hsc_env' = (hsc_env state){ hsc_plugins = dyn, hsc_static_plugins = static }-  in return (state{hsc_env = hsc_env'}, ())--setModLocation :: ModLocation -> CompPipeline ()-setModLocation loc = P $ \_env state ->-  return (state{ maybe_loc = Just loc }, ())--setForeignOs :: [FilePath] -> CompPipeline ()-setForeignOs os = P $ \_env state ->-  return (state{ foreign_os = os }, ())--setIface :: ModIface -> CompPipeline ()-setIface iface = P $ \_env state -> return (state{ iface = Just iface }, ())
+ GHC/Driver/Pipeline/Phases.hs view
@@ -0,0 +1,52 @@+{-# 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.Session+import GHC.Driver.CmdLine+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.Name ( ModuleName )+import GHC.Unit.Module.ModIface+import GHC.Linker.Types+import GHC.Driver.Phases++-- 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, [Warn])+  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, Maybe Linkable, FilePath)+  T_CmmCpp :: PipeEnv -> HscEnv -> FilePath -> TPhase FilePath+  T_Cmm :: PipeEnv -> HscEnv -> FilePath -> TPhase ([FilePath], FilePath)+  T_Cc :: Phase -> PipeEnv -> HscEnv -> FilePath -> TPhase FilePath+  T_As :: Bool -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> TPhase FilePath+  T_LlvmOpt :: PipeEnv -> HscEnv -> FilePath -> TPhase FilePath+  T_LlvmLlc :: PipeEnv -> HscEnv -> 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
@@ -1,15 +1,19 @@ {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE CPP #-} + -- | 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-      Plugin(..)+      Plugins (..)+    , emptyPlugins+    , Plugin(..)     , defaultPlugin     , CommandLineOption+    , PsMessages(..)+    , ParsedResult(..)       -- ** Recompilation checking     , purePlugin, impurePlugin, flagRecompile     , PluginRecompile(..)@@ -35,13 +39,17 @@       -- - 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        -- * Internal-    , PluginWithArgs(..), plugins, pluginRecompile'+    , PluginWithArgs(..), pluginsWithArgs, pluginRecompile'     , LoadedPlugin(..), lpModuleName     , StaticPlugin(..)     , mapPlugins, withPlugins, withPlugins_@@ -57,12 +65,15 @@ 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.FitTypes ( HoleFitPluginR )  import GHC.Core.Opt.Monad ( CoreToDo, CoreM ) import GHC.Hs+import GHC.Types.Error (Messages) import GHC.Utils.Fingerprint import GHC.Utils.Outputable (Outputable(..), text, (<+>)) @@ -73,11 +84,26 @@ import qualified Data.Semigroup  import Control.Monad+import GHC.Linker.Types+import GHC.Types.Unique.DFM  -- | 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@@ -94,6 +120,9 @@   , 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.@@ -107,10 +136,13 @@    , pluginRecompile :: [CommandLineOption] -> IO PluginRecompile     -- ^ Specify how the plugin should affect recompilation.-  , parsedResultAction :: [CommandLineOption] -> ModSummary -> HsParsedModule-                            -> Hsc HsParsedModule+  , parsedResultAction :: [CommandLineOption] -> ModSummary+                       -> ParsedResult -> Hsc ParsedResult     -- ^ Modify the module when it is parsed. This is called by-    -- "GHC.Driver.Main" when the parsing is successful.+    -- "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@@ -195,6 +227,7 @@  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  purePlugin, impurePlugin, flagRecompile :: [CommandLineOption] -> IO PluginRecompile@@ -213,6 +246,7 @@ defaultPlugin = Plugin {         installCoreToDos      = const return       , tcPlugin              = const Nothing+      , defaultingPlugin      = const Nothing       , holeFitPlugin         = const Nothing       , driverPlugin          = const return       , pluginRecompile       = impurePlugin@@ -242,25 +276,50 @@ type PluginOperation m a = Plugin -> [CommandLineOption] -> a -> m a type ConstPluginOperation m a = Plugin -> [CommandLineOption] -> a -> m () -plugins :: HscEnv -> [PluginWithArgs]-plugins hsc_env =-  map lpPlugin (hsc_plugins hsc_env) ++-  map spPlugin (hsc_static_plugins hsc_env)+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. +  , 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 [] [] ([], emptyUDFM)+++pluginsWithArgs :: Plugins -> [PluginWithArgs]+pluginsWithArgs plugins =+  map lpPlugin (loadedPlugins plugins) +++  map spPlugin (staticPlugins plugins)+ -- | Perform an operation by using all of the plugins in turn.-withPlugins :: Monad m => HscEnv -> PluginOperation m a -> a -> m a-withPlugins hsc_env transformation input = foldM go input (plugins hsc_env)+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 :: HscEnv -> (Plugin -> [CommandLineOption] -> a) -> [a]-mapPlugins hsc_env f = map (\(PluginWithArgs p opts) -> f p opts) (plugins hsc_env)+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 => HscEnv -> ConstPluginOperation m a -> a -> m ()-withPlugins_ hsc_env transformation input+withPlugins_ :: Monad m => Plugins -> ConstPluginOperation m a -> a -> m ()+withPlugins_ plugins transformation input   = mapM_ (\(PluginWithArgs p opts) -> transformation p opts input)-          (plugins hsc_env)+          (pluginsWithArgs plugins)  type FrontendPluginAction = [String] -> [(String, Maybe Phase)] -> Ghc () data FrontendPlugin = FrontendPlugin {
GHC/Driver/Plugins.hs-boot view
@@ -5,6 +5,9 @@ import GHC.Prelude ()  data Plugin+data Plugins++emptyPlugins :: Plugins  data LoadedPlugin data StaticPlugin
GHC/Driver/Ppr.hs view
@@ -1,39 +1,23 @@ -- | Printing related functions that depend on session state (DynFlags) module GHC.Driver.Ppr    ( showSDoc+   , showSDocUnsafe    , showSDocForUser-   , showSDocDebug-   , showSDocDump    , showPpr-   , pprDebugAndThen+   , showPprUnsafe    , printForUser-   , printForC-   -- ** Trace-   , warnPprTrace-   , pprTrace-   , pprTraceWithFlags-   , pprTraceM-   , pprTraceDebug-   , pprTraceIt-   , pprSTrace-   , pprTraceException    ) where  import GHC.Prelude -import {-# SOURCE #-} GHC.Driver.Session-import {-# SOURCE #-} GHC.Unit.State+import GHC.Driver.Session+import GHC.Unit.State -import GHC.Utils.Exception-import GHC.Utils.Misc import GHC.Utils.Outputable-import GHC.Utils.Panic-import GHC.Utils.GlobalVars import GHC.Utils.Ppr       ( Mode(..) )  import System.IO ( Handle )-import Control.Monad.IO.Class  -- | Show a SDoc as a String with the default user style showSDoc :: DynFlags -> SDoc -> String@@ -49,88 +33,7 @@       sty  = mkUserStyle unqual AllTheWay       doc' = pprWithUnitState unit_state doc -showSDocDump :: SDocContext -> SDoc -> String-showSDocDump ctx d = renderWithContext ctx (withPprStyle defaultDumpStyle d)--showSDocDebug :: DynFlags -> SDoc -> String-showSDocDebug dflags d = renderWithContext ctx d-   where-      ctx = (initSDocContext dflags defaultDumpStyle)-               { sdocPprDebug = True-               }- printForUser :: DynFlags -> Handle -> PrintUnqualified -> Depth -> SDoc -> IO () printForUser dflags handle unqual depth doc   = printSDocLn ctx (PageMode False) handle doc     where ctx = initSDocContext dflags (mkUserStyle unqual depth)---- | Like 'printSDocLn' but specialized with 'LeftMode' and--- @'PprCode' 'CStyle'@.  This is typically used to output C-- code.-printForC :: DynFlags -> Handle -> SDoc -> IO ()-printForC dflags handle doc =-  printSDocLn ctx LeftMode handle doc-  where ctx = initSDocContext dflags (PprCode CStyle)--pprDebugAndThen :: SDocContext -> (String -> a) -> SDoc -> SDoc -> a-pprDebugAndThen ctx cont heading pretty_msg- = cont (showSDocDump ctx doc)- where-     doc = sep [heading, nest 2 pretty_msg]---- | If debug output is on, show some 'SDoc' on the screen-pprTraceWithFlags :: DynFlags -> String -> SDoc -> a -> a-pprTraceWithFlags dflags str doc x-  | hasNoDebugOutput dflags = x-  | otherwise               = pprDebugAndThen (initSDocContext dflags defaultDumpStyle)-                                              trace (text str) doc x---- | If debug output is on, show some 'SDoc' on the screen-pprTrace :: String -> SDoc -> a -> a-pprTrace str doc x-  | unsafeHasNoDebugOutput = x-  | otherwise              = pprDebugAndThen defaultSDocContext trace (text str) doc x--pprTraceM :: Applicative f => String -> SDoc -> f ()-pprTraceM str doc = pprTrace str doc (pure ())--pprTraceDebug :: String -> SDoc -> a -> a-pprTraceDebug str doc x-   | debugIsOn && unsafeHasPprDebug = pprTrace str doc x-   | otherwise                      = x---- | @pprTraceWith desc f x@ is equivalent to @pprTrace desc (f x) x@.--- This allows you to print details from the returned value as well as from--- ambient variables.-pprTraceWith :: String -> (a -> SDoc) -> a -> a-pprTraceWith desc f x = pprTrace desc (f x) x---- | @pprTraceIt desc x@ is equivalent to @pprTrace desc (ppr x) x@-pprTraceIt :: Outputable a => String -> a -> a-pprTraceIt desc x = pprTraceWith desc ppr x---- | @pprTraceException desc x action@ runs action, printing a message--- if it throws an exception.-pprTraceException :: ExceptionMonad m => String -> SDoc -> m a -> m a-pprTraceException heading doc =-    handleGhcException $ \exc -> liftIO $ do-        putStrLn $ showSDocDump defaultSDocContext (sep [text heading, nest 2 doc])-        throwGhcExceptionIO exc---- | If debug output is on, show some 'SDoc' on the screen along--- with a call stack when available.-pprSTrace :: HasCallStack => SDoc -> a -> a-pprSTrace doc = pprTrace "" (doc $$ callStackDoc)--warnPprTrace :: HasCallStack => Bool -> String -> Int -> SDoc -> a -> a--- ^ Just warn about an assertion failure, recording the given file and line number.--- Should typically be accessed with the WARN macros-warnPprTrace _     _     _     _    x | not debugIsOn     = x-warnPprTrace _     _file _line _msg x-   | unsafeHasNoDebugOutput = x-warnPprTrace False _file _line _msg x = x-warnPprTrace True   file  line  msg x-  = pprDebugAndThen defaultSDocContext trace heading-                    (msg $$ callStackDoc )-                    x-  where-    heading = hsep [text "WARNING: file", text file <> comma, text "line", int line]
− GHC/Driver/Ppr.hs-boot 
@@ -1,9 +0,0 @@-module GHC.Driver.Ppr where--import GHC.Prelude-import GHC.Stack-import {-# SOURCE #-} GHC.Driver.Session-import {-# SOURCE #-} GHC.Utils.Outputable--showSDoc :: DynFlags -> SDoc -> String-warnPprTrace :: HasCallStack => Bool -> String -> Int -> SDoc -> a -> a
GHC/Driver/Session.hs view
@@ -22,13 +22,11 @@         -- * Dynamic flags and associated configuration types         DumpFlag(..),         GeneralFlag(..),-        WarningFlag(..), WarnReason(..),+        WarningFlag(..), DiagnosticReason(..),         Language(..),-        PlatformConstants(..),-        FatalMessager, FlushOut(..), FlushErr(..),+        FatalMessager, FlushOut(..),         ProfAuto(..),         glasgowExtsFlags,-        warningGroups, warningHierarchies,         hasPprDebug, hasNoDebugOutput, hasNoStateHack, hasNoOptCoercion,         dopt, dopt_set, dopt_unset,         gopt, gopt_set, gopt_unset, setGeneralFlag', unSetGeneralFlag',@@ -39,12 +37,11 @@         xopt_DuplicateRecordFields,         xopt_FieldSelectors,         lang_set,-        DynamicTooState(..), dynamicTooState, setDynamicNow, setDynamicTooFailed,-        dynamicOutputFile, dynamicOutputHi,+        DynamicTooState(..), dynamicTooState, setDynamicNow,         sccProfilingEnabled,         needSourceNotes,         DynFlags(..),-        outputFile, hiSuf, objectSuf, ways,+        outputFile, objectSuf, ways,         FlagSpec(..),         HasDynFlags(..), ContainsDynFlags(..),         RtsOptsEnabled(..),@@ -58,15 +55,12 @@         DynLibLoader(..),         fFlags, fLangFlags, xFlags,         wWarningFlags,-        wWarningFlagMap,-        dynFlagDependencies,         makeDynFlagsConsistent,         positionIndependent,         optimisationFlags,         setFlagsFromEnvFile,         pprDynFlagsDiff,         flagSpecOf,-        smallestGroups,          targetProfile, @@ -88,7 +82,6 @@         sGhciUsagePath,         sToolDir,         sTopDir,-        sTmpDir,         sGlobalPackageDatabasePath,         sLdSupportsCompactUnwind,         sLdSupportsBuildId,@@ -99,6 +92,7 @@         sPgm_P,         sPgm_F,         sPgm_c,+        sPgm_cxx,         sPgm_a,         sPgm_l,         sPgm_lm,@@ -129,19 +123,16 @@         sExtraGccViaCFlags,         sTargetPlatformString,         sGhcWithInterpreter,-        sGhcWithSMP,-        sGhcRTSWays,         sLibFFI,-        sGhcRtsWithLibdw,         GhcNameVersion(..),         FileSettings(..),         PlatformMisc(..),         settings,         programName, projectVersion,-        ghcUsagePath, ghciUsagePath, topDir, tmpDir,+        ghcUsagePath, ghciUsagePath, topDir,         versionedAppDir, versionedFilePath,         extraGccViaCFlags, globalPackageDatabasePath,-        pgm_L, pgm_P, pgm_F, pgm_c, pgm_a, pgm_l, pgm_lm, pgm_dll, pgm_T,+        pgm_L, pgm_P, pgm_F, pgm_c, pgm_cxx, pgm_a, pgm_l, pgm_lm, pgm_dll, pgm_T,         pgm_windres, pgm_libtool, pgm_ar, pgm_otool, pgm_install_name_tool,         pgm_ranlib, pgm_lo, pgm_lc, pgm_lcc, pgm_i,         opt_L, opt_P, opt_F, opt_c, opt_cxx, opt_a, opt_l, opt_lm, opt_i,@@ -155,7 +146,8 @@         initDynFlags,                   -- DynFlags -> IO DynFlags         defaultFatalMessager,         defaultFlushOut,-        defaultFlushErr,+        setOutputFile, setDynOutputFile, setOutputHi, setDynOutputHi,+        augmentByWorkingDirectory,          getOpts,                        -- DynFlags -> (DynFlags -> [a]) -> [a]         getVerbFlags,@@ -170,6 +162,11 @@         impliedOffGFlags,         impliedXFlags, +        -- ** State+        CmdLineP(..), runCmdLineP,+        getCmdLineState, putCmdLineState,+        processCmdLineP,+         -- ** Parsing DynFlags         parseDynamicFlagsCmdLine,         parseDynamicFilePragma,@@ -188,6 +185,9 @@         -- ** DynFlags C compiler options         picCCOpts, picPOpts, +        -- ** DynFlags C linker options+        pieCCLDOpts,+         -- * Compiler configuration suitable for display to the user         compilerInfo, @@ -196,8 +196,6 @@         setUnsafeGlobalDynFlags,          -- * SSE and AVX-        isSseEnabled,-        isSse2Enabled,         isSse4_2Enabled,         isBmiEnabled,         isBmi2Enabled,@@ -221,8 +219,6 @@         initSDocContext, initDefaultSDocContext,   ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Platform@@ -239,21 +235,24 @@ import GHC.Driver.Backend import GHC.Settings.Config import GHC.Utils.CliOption-import {-# SOURCE #-} GHC.Core.Unfold-import GHC.Driver.CmdLine hiding (WarnReason(..))-import qualified GHC.Driver.CmdLine as Cmd+import GHC.Core.Unfold+import GHC.Driver.CmdLine import GHC.Settings.Constants import GHC.Utils.Panic import qualified GHC.Utils.Ppr.Colour as Col import GHC.Utils.Misc+import GHC.Utils.Constants (debugIsOn) import GHC.Utils.GlobalVars import GHC.Data.Maybe+import GHC.Data.Bool import GHC.Utils.Monad+import GHC.Types.Error (DiagnosticReason(..)) import GHC.Types.SrcLoc import GHC.Types.SafeHaskell-import GHC.Types.Basic ( Alignment, alignmentOf, IntWithInf, treatZeroAsInf )+import GHC.Types.Basic ( IntWithInf, treatZeroAsInf ) import qualified GHC.Types.FieldLabel as FieldLabel import GHC.Data.FastString+import GHC.Utils.TmpFs import GHC.Utils.Fingerprint import GHC.Utils.Outputable import GHC.Settings@@ -270,11 +269,13 @@ import Control.Monad.Trans.Writer import Control.Monad.Trans.Reader import Control.Monad.Trans.Except+import Control.Monad.Trans.State as State+import Data.Functor.Identity  import Data.Ord import Data.Char import Data.List (intercalate, sortBy)-import Data.Map (Map)+import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map import qualified Data.Set as Set import System.FilePath@@ -297,6 +298,7 @@ -- 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] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -372,7 +374,7 @@ data IncludeSpecs   = IncludeSpecs { includePathsQuote  :: [String]                  , includePathsGlobal :: [String]-                 -- | See note [Implicit include paths]+                 -- | See Note [Implicit include paths]                  , includePathsQuoteImplicit :: [String]                  }   deriving Show@@ -391,7 +393,7 @@                               in spec { includePathsQuote = f ++ paths }  -- | These includes are not considered while fingerprinting the flags for iface--- | See note [Implicit include paths]+-- | See Note [Implicit include paths] addImplicitQuoteInclude :: IncludeSpecs -> [String] -> IncludeSpecs addImplicitQuoteInclude spec paths  = let f = includePathsQuoteImplicit spec                               in spec { includePathsQuoteImplicit = f ++ paths }@@ -449,17 +451,17 @@   toolSettings      :: {-# UNPACK #-} !ToolSettings,   platformMisc      :: {-# UNPACK #-} !PlatformMisc,   rawSettings       :: [(String, String)],+  tmpDir            :: TempDir,    llvmConfig            :: LlvmConfig,     -- ^ N.B. It's important that this field is lazy since we load the LLVM-    -- configuration lazily. See Note [LLVM Configuration] in "GHC.SysTools".+    -- configuration lazily. See Note [LLVM configuration] in "GHC.SysTools".+  llvmOptLevel          :: Int,         -- ^ LLVM optimisation level   verbosity             :: Int,         -- ^ Verbosity level: see Note [Verbosity levels]-  optLevel              :: Int,         -- ^ Optimisation level   debugLevel            :: Int,         -- ^ How much debug information to produce   simplPhases           :: Int,         -- ^ Number of simplifier phases   maxSimplIterations    :: Int,         -- ^ Max simplifier iterations   ruleCheck             :: Maybe String,-  inlineCheck           :: Maybe String, -- ^ A prefix to report inlining decisions about   strictnessBefore      :: [Int],       -- ^ Additional demand analysis    parMakeCount          :: Maybe Int,   -- ^ The number of modules to compile in parallel@@ -486,13 +488,17 @@                                         --   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   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      :: Word,        -- ^ Binary literals (e.g. strings) whose size is above+  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 to disable)+                                        --   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'@@ -519,6 +525,12 @@   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     :: Set.Set ModuleName,+   -- ways   targetWays_           :: Ways,         -- ^ Target way flags from the command line @@ -538,7 +550,6 @@   hiSuf_                :: String,   hieSuf                :: String, -  dynamicTooFailed      :: IORef Bool,   dynObjectSuf_         :: String,   dynHiSuf_             :: String, @@ -553,11 +564,12 @@                                   -- used to query the appropriate fields                                   -- (outputFile/dynOutputFile, ways, etc.) -  -- | This is set by 'GHC.Driver.Pipeline.runPipeline'-  --    or 'ghc.GHCi.UI.runStmt' based on where its output is going.-  dumpPrefix            :: Maybe FilePath,+  -- | 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.runPipeline'+  -- | Override the 'dumpPrefix' set by 'GHC.Driver.Pipeline.setDumpPrefix'   --    or 'ghc.GHCi.UI.runStmt'.   --    Set by @-ddump-file-prefix@   dumpPrefixForce       :: Maybe FilePath,@@ -577,6 +589,8 @@    -- 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*@@ -656,7 +670,6 @@   ghciHistSize          :: Int,    flushOut              :: FlushOut,-  flushErr              :: FlushErr,    ghcVersionFile        :: Maybe FilePath,   haddockOptions        :: Maybe String,@@ -679,8 +692,6 @@    interactivePrint      :: Maybe String, -  nextWrapperNum        :: IORef (ModuleEnv Int),-   -- | Machine dependent flags (-m\<blah> stuff)   sseVersion            :: Maybe SseVersion,   bmiVersion            :: Maybe BmiVersion,@@ -694,9 +705,12 @@   -- | Run-time linker information (what options we need, etc.)   rtldInfo              :: IORef (Maybe LinkerInfo), -  -- | Run-time compiler information+  -- | Run-time C compiler information   rtccInfo              :: IORef (Maybe CompilerInfo), +  -- | Run-time assembler information+  rtasmInfo              :: IORef (Maybe CompilerInfo),+   -- Constants used to control the amount of optimization done.    -- | Max size, in bytes, of inline array allocations.@@ -766,7 +780,7 @@   , lAttributes :: [String]   } --- | See Note [LLVM Configuration] in "GHC.SysTools".+-- | See Note [LLVM configuration] in "GHC.SysTools". data LlvmConfig = LlvmConfig { llvmTargets :: [(String, LlvmTarget)]                              , llvmPasses  :: [(Int, String)]                              }@@ -799,8 +813,6 @@ toolDir dflags = fileSettings_toolDir $ fileSettings dflags topDir                :: DynFlags -> FilePath topDir dflags = fileSettings_topDir $ fileSettings dflags-tmpDir                :: DynFlags -> String-tmpDir dflags = fileSettings_tmpDir $ fileSettings dflags extraGccViaCFlags     :: DynFlags -> [String] extraGccViaCFlags dflags = toolSettings_extraGccViaCFlags $ toolSettings dflags globalPackageDatabasePath   :: DynFlags -> FilePath@@ -813,11 +825,13 @@ 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_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 -> (String,[Option])+pgm_lm                 :: DynFlags -> Maybe (String,[Option]) pgm_lm dflags = toolSettings_pgm_lm $ toolSettings dflags pgm_dll               :: DynFlags -> (String,[Option]) pgm_dll dflags = toolSettings_pgm_dll $ toolSettings dflags@@ -938,6 +952,7 @@                         --   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@@ -1038,41 +1053,28 @@ -- Core optimisation, then the backend (from Core to object code) is executed -- twice. ----- The implementation is currently rather hacky: recompilation avoidance is--- broken (#17968), we don't clearly separate non-dynamic and dynamic loaded--- interfaces (#9176), etc.+-- 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'). ----- This somewhat explains why we have "dynamicTooFailed :: IORef Bool" in--- DynFlags: when -dynamic-too is enabled, we try to build the dynamic objects,--- but we may fail and we shouldn't abort the whole compilation because the user--- may not even have asked for -dynamic-too in the first place. So instead we--- use this global variable to indicate that we can't build dynamic objects and--- compilation continues to build non-dynamic objects only. At the end of the--- non-dynamic pipeline, if this value indicates that the dynamic compilation--- failed, we run the whole pipeline again for the dynamic way (except on--- Windows...). See GHC.Driver.Pipeline.runPipeline.+-- 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_Failed  -- ^ Won't try to generate dynamic objects for some reason    | DT_OK      -- ^ Will still try to generate dynamic objects    | DT_Dyn     -- ^ Currently generating dynamic objects (in the backend)    deriving (Eq,Show,Ord) -dynamicTooState :: MonadIO m => DynFlags -> m DynamicTooState+dynamicTooState :: DynFlags -> DynamicTooState dynamicTooState dflags-   | not (gopt Opt_BuildDynamicToo dflags) = return DT_Dont-   | otherwise = do-      failed <- liftIO $ readIORef (dynamicTooFailed dflags)-      if failed-         then return DT_Failed-         else if dynamicNow dflags-               then return DT_Dyn-               else return DT_OK+   | not (gopt Opt_BuildDynamicToo dflags) = DT_Dont+   | dynamicNow dflags = DT_Dyn+   | otherwise = DT_OK  setDynamicNow :: DynFlags -> DynFlags setDynamicNow dflags0 =@@ -1080,31 +1082,15 @@       { dynamicNow = True       } -setDynamicTooFailed :: MonadIO m => DynFlags -> m ()-setDynamicTooFailed dflags =-   liftIO $ writeIORef (dynamicTooFailed dflags) True---- | Compute the path of the dynamic object corresponding to an object file.-dynamicOutputFile :: DynFlags -> FilePath -> FilePath-dynamicOutputFile dflags outputFile = outputFile -<.> dynObjectSuf_ dflags--dynamicOutputHi :: DynFlags -> FilePath -> FilePath-dynamicOutputHi dflags hi = hi -<.> dynHiSuf_ dflags- -----------------------------------------------------------------------------  -- | Used by 'GHC.runGhc' to partially initialize a new 'DynFlags' value initDynFlags :: DynFlags -> IO DynFlags initDynFlags dflags = do- let -- We can't build with dynamic-too on Windows, as labels before-     -- the fork point are different depending on whether we are-     -- building dynamically or not.-     platformCanGenerateDynamicToo-         = platformOS (targetPlatform dflags) /= OSMinGW32- refDynamicTooFailed <- newIORef (not platformCanGenerateDynamicToo)+ let  refRtldInfo <- newIORef Nothing  refRtccInfo <- newIORef Nothing- wrapperNum <- newIORef emptyModuleEnv+ refRtasmInfo <- newIORef Nothing  canUseUnicode <- do let enc = localeEncoding                          str = "‘’"                      (withCString enc str $ \cstr ->@@ -1120,15 +1106,16 @@  let (useColor', colScheme') =        (adjustCols maybeGhcColoursEnv . adjustCols maybeGhcColorsEnv)        (useColor dflags, colScheme dflags)+ tmp_dir <- normalise <$> getTemporaryDirectory  return dflags{-        dynamicTooFailed = refDynamicTooFailed,-        nextWrapperNum = wrapperNum,         useUnicode    = useUnicode',         useColor      = useColor',         canUseColor   = stderrSupportsAnsiColors,         colScheme     = colScheme',         rtldInfo      = refRtldInfo,-        rtccInfo      = refRtccInfo+        rtccInfo      = refRtccInfo,+        rtasmInfo     = refRtasmInfo,+        tmpDir        = TempDir tmp_dir         }  -- | The normal 'DynFlags'. Note that they are not suitable for use in this form@@ -1141,13 +1128,11 @@         ghcLink                 = LinkBinary,         backend                 = platformDefaultBackend (sTargetPlatform mySettings),         verbosity               = 0,-        optLevel                = 0,         debugLevel              = 0,         simplPhases             = 2,         maxSimplIterations      = 4,         ruleCheck               = Nothing,-        inlineCheck             = Nothing,-        binBlobThreshold        = 500000, -- 500K is a good default (see #16190)+        binBlobThreshold        = Just 500000, -- 500K is a good default (see #16190)         maxRelevantBinds        = Just 6,         maxValidHoleFits   = Just 6,         maxRefHoleFits     = Just 6,@@ -1155,6 +1140,7 @@         maxUncoveredPatterns    = 4,         maxPmCheckModels        = 30,         simplTickFactor         = 100,+        dmdUnboxWidth           = 3,      -- Default: Assume an unboxed demand on function bodies returning a triple         specConstrThreshold     = Just 2000,         specConstrCount         = Just 3,         specConstrRecursive     = 3,@@ -1183,6 +1169,11 @@         homeUnitInstanceOf_     = Nothing,         homeUnitInstantiations_ = [], +        workingDirectory        = Nothing,+        thisPackageName         = Nothing,+        hiddenModules           = Set.empty,+        reexportedModules       = Set.empty,+         objectDir               = Nothing,         dylibInstallName        = Nothing,         hiDir                   = Nothing,@@ -1195,7 +1186,6 @@         hiSuf_                  = "hi",         hieSuf                  = "hie", -        dynamicTooFailed        = panic "defaultDynFlags: No dynamicTooFailed",         dynObjectSuf_           = "dyn_" ++ phaseInputExt StopLn,         dynHiSuf_               = "dyn_hi",         dynamicNow              = False,@@ -1209,7 +1199,7 @@         outputHi                = Nothing,         dynOutputHi             = Nothing,         dynLibLoader            = SystemDependent,-        dumpPrefix              = Nothing,+        dumpPrefix              = "non-module.",         dumpPrefixForce         = Nothing,         ldInputs                = [],         includePaths            = IncludeSpecs [] [] [],@@ -1238,8 +1228,11 @@         platformMisc = sPlatformMisc mySettings,         rawSettings = sRawSettings mySettings, +        tmpDir                  = panic "defaultDynFlags: uninitialized tmpDir",+         -- See Note [LLVM configuration].         llvmConfig              = llvmConfig,+        llvmOptLevel            = 0,          -- ghc -M values         depMakefile       = "Makefile",@@ -1277,7 +1270,6 @@         ghciHistSize = 50, -- keep a log of length 50 by default          flushOut = defaultFlushOut,-        flushErr = defaultFlushErr,         pprUserLength = 5,         pprCols = 100,         useUnicode = False,@@ -1287,7 +1279,6 @@         profAuto = NoProfAuto,         callerCcFilters = [],         interactivePrint = Nothing,-        nextWrapperNum = panic "defaultDynFlags: No nextWrapperNum",         sseVersion = Nothing,         bmiVersion = Nothing,         avx = False,@@ -1298,6 +1289,7 @@         avx512pf = False,         rtldInfo = panic "defaultDynFlags: no rtldInfo",         rtccInfo = panic "defaultDynFlags: no rtccInfo",+        rtasmInfo = panic "defaultDynFlags: no rtasmInfo",          maxInlineAllocSize = 128,         maxInlineMemcpyInsns = 32,@@ -1322,11 +1314,6 @@ defaultFlushOut :: FlushOut defaultFlushOut = FlushOut $ hFlush stdout -newtype FlushErr = FlushErr (IO ())--defaultFlushErr :: FlushErr-defaultFlushErr = FlushErr $ hFlush stderr- {- Note [Verbosity levels] ~~~~~~~~~~~~~~~~~~~~~~~@@ -1434,7 +1421,7 @@        LangExt.InstanceSigs,        LangExt.KindSignatures,        LangExt.MultiParamTypeClasses,-       LangExt.RecordPuns,+       LangExt.NamedFieldPuns,        LangExt.NamedWildCards,        LangExt.NumericUnderscores,        LangExt.PolyKinds,@@ -1469,7 +1456,6 @@           enableIfVerbose Opt_D_dump_rn_trace               = False           enableIfVerbose Opt_D_dump_cs_trace               = False           enableIfVerbose Opt_D_dump_if_trace               = False-          enableIfVerbose Opt_D_dump_vt_trace               = False           enableIfVerbose Opt_D_dump_tc                     = False           enableIfVerbose Opt_D_dump_rn                     = False           enableIfVerbose Opt_D_dump_rn_stats               = False@@ -1483,6 +1469,7 @@           enableIfVerbose Opt_D_dump_simpl_trace            = False           enableIfVerbose Opt_D_dump_rtti                   = False           enableIfVerbose Opt_D_dump_inlinings              = False+          enableIfVerbose Opt_D_dump_verbose_inlinings      = False           enableIfVerbose Opt_D_dump_core_stats             = False           enableIfVerbose Opt_D_dump_asm_stats              = False           enableIfVerbose Opt_D_dump_types                  = False@@ -1603,10 +1590,6 @@ setLanguage :: Language -> DynP () setLanguage l = upd (`lang_set` Just l) --- | Some modules have dependencies on others through the DynFlags rather than textual imports-dynFlagDependencies :: DynFlags -> [ModuleName]-dynFlagDependencies = pluginModNames- -- | Is the -fpackage-trust mode on packageTrustOn :: DynFlags -> Bool packageTrustOn = gopt Opt_PackageTrust@@ -1642,7 +1625,7 @@               safeM <- combineSafeFlags sf s               case s of                 Sf_Safe -> return $ dfs { safeHaskell = safeM, safeInfer = False }-                -- leave safe inferrence on in Trustworthy mode so we can warn+                -- leave safe inference on in Trustworthy mode so we can warn                 -- if it could have been inferred safe.                 Sf_Trustworthy -> do                   l <- getCurLoc@@ -1838,18 +1821,35 @@ ----------------------------------------------------------------------------- -- Setting the optimisation level -updOptLevel :: Int -> DynFlags -> DynFlags--- ^ Sets the 'DynFlags' to be appropriate to the optimisation level-updOptLevel n dfs-  = dfs2{ optLevel = final_n }+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 = foldr (flip gopt_unset) dfs  remove_gopts-   dfs2 = foldr (flip gopt_set)   dfs1 extra_gopts+   (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@@ -1880,22 +1880,58 @@                           -- list of warnings. parseDynamicFilePragma = parseDynamicFlagsFull flagsDynamic False +newtype CmdLineP s a = CmdLineP (forall m. (Monad m) => StateT s m a) +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++instance Functor (CmdLineP s) where+    fmap f (CmdLineP k) = CmdLineP (fmap f k)++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 :: MonadIO m-                  => [Flag (CmdLineP DynFlags)]    -- ^ valid flags to match against-                  -> Bool                          -- ^ are the arguments from the command line?-                  -> DynFlags                      -- ^ current dynamic flags-                  -> [Located String]              -- ^ arguments to parse-                  -> m (DynFlags, [Located String], [Warn])+parseDynamicFlagsFull+    :: forall m. MonadIO m+    => [Flag (CmdLineP DynFlags)]    -- ^ valid flags to match against+    -> Bool                          -- ^ are the arguments from the command line?+    -> DynFlags                      -- ^ current dynamic flags+    -> [Located String]              -- ^ arguments to parse+    -> m (DynFlags, [Located String], [Warn]) parseDynamicFlagsFull activeFlags cmdline dflags0 args = do-  let ((leftover, errs, warns), dflags1)-          = runCmdLine (processArgs activeFlags args) dflags0+  ((leftover, errs, warns), dflags1) <- processCmdLineP activeFlags dflags0 args -  -- See Note [Handling errors when parsing commandline flags]+  -- 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@@ -1908,26 +1944,19 @@       throwGhcExceptionIO (CmdLineError ("combination not supported: " ++                                intercalate "/" (map wayDesc (Set.toAscList theWays)))) -  let dflags3-        | Just outFile <- outputFile_ dflags2   -- Only iff user specified -o ...-        , not (isJust (dynOutputFile_ dflags2)) -- but not -dyno-        = dflags2 { dynOutputFile_ = Just $ dynamicOutputFile dflags2 outFile }-        | otherwise-        = dflags2--  let (dflags4, consistency_warnings) = makeDynFlagsConsistent dflags3+  let (dflags3, consistency_warnings) = makeDynFlagsConsistent dflags2    -- Set timer stats & heap size-  when (enableTimeStats dflags4) $ liftIO enableTimingStats-  case (ghcHeapSize dflags4) of+  when (enableTimeStats dflags3) $ liftIO enableTimingStats+  case (ghcHeapSize dflags3) of     Just x -> liftIO (setHeapSize x)     _      -> return () -  liftIO $ setUnsafeGlobalDynFlags dflags4+  liftIO $ setUnsafeGlobalDynFlags dflags3 -  let warns' = map (Warn Cmd.NoReason) (consistency_warnings ++ sh_warns)+  let warns' = map (Warn WarningWithoutFlag) (consistency_warnings ++ sh_warns) -  return (dflags4, leftover, warns' ++ warns)+  return (dflags3, leftover, warns' ++ warns)  -- | Check (and potentially disable) any extensions that aren't allowed -- in safe mode.@@ -2086,7 +2115,10 @@      ------- ways ---------------------------------------------------------------   , make_ord_flag defGhcFlag "prof"           (NoArg (addWayDynP WayProf))-  , make_ord_flag defGhcFlag "eventlog"       (NoArg (addWayDynP WayTracing))+  , (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)) @@ -2114,12 +2146,6 @@       (NoArg (setGeneralFlag Opt_SingleLibFolder))   , make_ord_flag defGhcFlag "pie"            (NoArg (setGeneralFlag Opt_PICExecutable))   , make_ord_flag defGhcFlag "no-pie"         (NoArg (unSetGeneralFlag Opt_PICExecutable))-  , make_ord_flag defGhcFlag "fcompact-unwind"-      (noArgM (\dflags -> do-       if platformOS (targetPlatform dflags) == OSDarwin-          then return (gopt_set dflags Opt_CompactUnwind)-          else do addWarn "-compact-unwind is only implemented by the darwin platform. Ignoring."-                  return dflags))          ------- Specific phases  --------------------------------------------     -- need to appear before -pgmL to be parsed as LLVM flags.@@ -2128,7 +2154,8 @@   , make_ord_flag defFlag "pgmlc"       $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_lc  = (f,[]) }   , make_ord_flag defFlag "pgmlm"-      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_lm  = (f,[]) }+      $ 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"@@ -2138,20 +2165,30 @@   , 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-         , -- Don't pass -no-pie with -pgmc-           -- (see #15319)-           toolSettings_ccSupportsNoPie = False-         }-  , make_ord_flag defFlag "pgmc-supports-no-pie"-      $ noArg $ alterToolSettings $ \s -> s { toolSettings_ccSupportsNoPie = True }+      $ 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,[]) }+      $ 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 "pgmdll"       $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_dll = (f,[]) }   , make_ord_flag defFlag "pgmwindres"@@ -2223,6 +2260,8 @@         (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) @@ -2257,7 +2296,7 @@   , make_ord_flag defGhcFlag "dumpdir"           (hasArg setDumpDir)   , make_ord_flag defGhcFlag "outputdir"         (hasArg setOutputDir)   , make_ord_flag defGhcFlag "ddump-file-prefix"-        (hasArg (setDumpPrefixForce . Just))+        (hasArg (setDumpPrefixForce . Just . flip (++) "."))    , make_ord_flag defGhcFlag "dynamic-too"         (NoArg (setGeneralFlag Opt_BuildDynamicToo))@@ -2342,8 +2381,12 @@         (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)@@ -2391,6 +2434,7 @@                   setGeneralFlag Opt_SuppressTicks                   setGeneralFlag Opt_SuppressStgExts                   setGeneralFlag Opt_SuppressTypeSignatures+                  setGeneralFlag Opt_SuppressCoreSizes                   setGeneralFlag Opt_SuppressTimestamps)          ------ Debugging ----------------------------------------------------@@ -2449,8 +2493,6 @@         (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-asm-expanded"-        (setDumpFlag Opt_D_dump_asm_expanded)   , make_ord_flag defGhcFlag "ddump-llvm"         (NoArg $ setDumpFlag' Opt_D_dump_llvm)   , make_ord_flag defGhcFlag "ddump-c-backend"@@ -2465,6 +2507,8 @@         (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"@@ -2477,6 +2521,8 @@         (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"@@ -2489,15 +2535,21 @@         (setDumpFlag Opt_D_dump_spec)   , 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-call-arity"         (setDumpFlag Opt_D_dump_call_arity)   , make_ord_flag defGhcFlag "ddump-exitify"@@ -2535,8 +2587,6 @@                    setDumpFlag' Opt_D_dump_cs_trace))   , make_ord_flag defGhcFlag "ddump-ec-trace"         (setDumpFlag Opt_D_dump_ec_trace)-  , make_ord_flag defGhcFlag "ddump-vt-trace"-        (setDumpFlag Opt_D_dump_vt_trace)   , make_ord_flag defGhcFlag "ddump-splices"         (setDumpFlag Opt_D_dump_splices)   , make_ord_flag defGhcFlag "dth-dec-file"@@ -2553,7 +2603,7 @@   , make_ord_flag defGhcFlag "dsource-stats"         (setDumpFlag Opt_D_source_stats)   , make_ord_flag defGhcFlag "dverbose-core2core"-        (NoArg $ setVerbosity (Just 2) >> setVerboseCore2Core)+        (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"@@ -2578,6 +2628,8 @@         (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"@@ -2590,10 +2642,12 @@         (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 "dfaststring-stats"-        (NoArg (setGeneralFlag Opt_D_faststring_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"@@ -2698,8 +2752,9 @@                 -- If the number is missing, use 1    , make_ord_flag defFlag "fbinary-blob-threshold"-      (intSuffix (\n d -> d { binBlobThreshold = fromIntegral n }))-+      (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"@@ -2735,6 +2790,8 @@           ; 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"@@ -2752,7 +2809,7 @@   , make_ord_flag defFlag "drule-check"       (sepArg (\s d -> d { ruleCheck = Just s }))   , make_ord_flag defFlag "dinline-check"-      (sepArg (\s d -> d { inlineCheck = Just s }))+      (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"@@ -2953,7 +3010,7 @@     action :: String -> EwM (CmdLineP DynFlags) ()     action flag = do       f <- wopt Opt_WarnUnrecognisedWarningFlags <$> liftEwM getCmdLineState-      when f $ addFlagWarn Cmd.ReasonUnrecognisedFlag $+      when f $ addFlagWarn (WarningWithFlag Opt_WarnUnrecognisedWarningFlags) $         "unrecognised warning flag: -" ++ prefix ++ flag  -- See Note [Supporting CLI completion]@@ -2977,6 +3034,12 @@   , 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)@@ -3036,6 +3099,17 @@           -> (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)@@ -3047,6 +3121,19 @@             -> (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@@ -3114,6 +3201,12 @@     = (dep,        Flag (flagPrefix ++ name) (NoArg (f flag >> extra_action turn_on)) mode) +-- here to avoid module cycle with GHC.Driver.CmdLine+deprecate :: Monad m => String -> EwM m ()+deprecate s = do+    arg <- getArg+    addFlagWarn (WarningWithFlag Opt_WarnDeprecatedFlags) (arg ++ " is deprecated: " ++ s)+ deprecatedForExtension :: String -> TurnOnFlag -> String deprecatedForExtension lang turn_on     = "use -X" ++ flag ++@@ -3132,136 +3225,132 @@ nop _ = return ()  -- | Find the 'FlagSpec' for a 'WarningFlag'.-wWarningFlagMap :: Map WarningFlag (FlagSpec WarningFlag)-wWarningFlagMap = Map.fromListWith (\_ x -> x) $ map (flagSpecFlag &&& id) wWarningFlags- 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 = [+wWarningFlagsDeps = mconcat [ -- 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 "alternative-layout-rule-transitional"-                                      Opt_WarnAlternativeLayoutRuleTransitional,-  flagSpec "ambiguous-fields"            Opt_WarnAmbiguousFields,-  depFlagSpec "auto-orphans"             Opt_WarnAutoOrphans-    "it has no effect",-  flagSpec "cpp-undef"                   Opt_WarnCPPUndef,-  flagSpec "unbanged-strict-patterns"    Opt_WarnUnbangedStrictPatterns,-  flagSpec "deferred-type-errors"        Opt_WarnDeferredTypeErrors,-  flagSpec "deferred-out-of-scope-variables"-                                         Opt_WarnDeferredOutOfScopeVariables,-  flagSpec "deprecations"                Opt_WarnWarningsDeprecations,-  flagSpec "deprecated-flags"            Opt_WarnDeprecatedFlags,-  flagSpec "deriving-defaults"           Opt_WarnDerivingDefaults,-  flagSpec "deriving-typeable"           Opt_WarnDerivingTypeable,-  flagSpec "dodgy-exports"               Opt_WarnDodgyExports,-  flagSpec "dodgy-foreign-imports"       Opt_WarnDodgyForeignImports,-  flagSpec "dodgy-imports"               Opt_WarnDodgyImports,-  flagSpec "empty-enumerations"          Opt_WarnEmptyEnumerations,-  depFlagSpec "duplicate-constraints"    Opt_WarnDuplicateConstraints-    "it is subsumed by -Wredundant-constraints",-  flagSpec "redundant-constraints"       Opt_WarnRedundantConstraints,-  flagSpec "duplicate-exports"           Opt_WarnDuplicateExports,-  depFlagSpec "hi-shadowing"                Opt_WarnHiShadows-    "it is not used, and was never implemented",-  flagSpec "inaccessible-code"           Opt_WarnInaccessibleCode,-  flagSpec "implicit-prelude"            Opt_WarnImplicitPrelude,-  depFlagSpec "implicit-kind-vars"       Opt_WarnImplicitKindVars-    "it is now an error",-  flagSpec "incomplete-patterns"         Opt_WarnIncompletePatterns,-  flagSpec "incomplete-record-updates"   Opt_WarnIncompletePatternsRecUpd,-  flagSpec "incomplete-uni-patterns"     Opt_WarnIncompleteUniPatterns,-  flagSpec "inline-rule-shadowing"       Opt_WarnInlineRuleShadowing,-  flagSpec "identities"                  Opt_WarnIdentities,-  flagSpec "missing-fields"              Opt_WarnMissingFields,-  flagSpec "missing-import-lists"        Opt_WarnMissingImportList,-  flagSpec "missing-export-lists"        Opt_WarnMissingExportList,-  depFlagSpec "missing-local-sigs"       Opt_WarnMissingLocalSignatures-    "it is replaced by -Wmissing-local-signatures",-  flagSpec "missing-local-signatures"    Opt_WarnMissingLocalSignatures,-  flagSpec "missing-methods"             Opt_WarnMissingMethods,-  depFlagSpec "missing-monadfail-instances"-                                         Opt_WarnMissingMonadFailInstances-    "fail is no longer a method of Monad",-  flagSpec "semigroup"                   Opt_WarnSemigroup,-  flagSpec "missing-signatures"          Opt_WarnMissingSignatures,-  flagSpec "missing-kind-signatures"     Opt_WarnMissingKindSignatures,-  depFlagSpec "missing-exported-sigs"    Opt_WarnMissingExportedSignatures-    "it is replaced by -Wmissing-exported-signatures",-  flagSpec "missing-exported-signatures" Opt_WarnMissingExportedSignatures,-  flagSpec "monomorphism-restriction"    Opt_WarnMonomorphism,-  flagSpec "name-shadowing"              Opt_WarnNameShadowing,-  flagSpec "noncanonical-monad-instances"-                                         Opt_WarnNonCanonicalMonadInstances,-  depFlagSpec "noncanonical-monadfail-instances"-                                         Opt_WarnNonCanonicalMonadInstances-    "fail is no longer a method of Monad",-  flagSpec "noncanonical-monoid-instances"-                                         Opt_WarnNonCanonicalMonoidInstances,-  flagSpec "orphans"                     Opt_WarnOrphans,-  flagSpec "overflowed-literals"         Opt_WarnOverflowedLiterals,-  flagSpec "overlapping-patterns"        Opt_WarnOverlappingPatterns,-  flagSpec "missed-specialisations"      Opt_WarnMissedSpecs,-  flagSpec "missed-specializations"      Opt_WarnMissedSpecs,-  flagSpec "all-missed-specialisations"  Opt_WarnAllMissedSpecs,-  flagSpec "all-missed-specializations"  Opt_WarnAllMissedSpecs,-  flagSpec' "safe"                       Opt_WarnSafe setWarnSafe,-  flagSpec "trustworthy-safe"            Opt_WarnTrustworthySafe,-  flagSpec "inferred-safe-imports"       Opt_WarnInferredSafeImports,-  flagSpec "missing-safe-haskell-mode"   Opt_WarnMissingSafeHaskellMode,-  flagSpec "tabs"                        Opt_WarnTabs,-  flagSpec "type-defaults"               Opt_WarnTypeDefaults,-  flagSpec "typed-holes"                 Opt_WarnTypedHoles,-  flagSpec "partial-type-signatures"     Opt_WarnPartialTypeSignatures,-  flagSpec "unrecognised-pragmas"        Opt_WarnUnrecognisedPragmas,-  flagSpec' "unsafe"                     Opt_WarnUnsafe setWarnUnsafe,-  flagSpec "unsupported-calling-conventions"-                                         Opt_WarnUnsupportedCallingConventions,-  flagSpec "unsupported-llvm-version"    Opt_WarnUnsupportedLlvmVersion,-  flagSpec "missed-extra-shared-lib"     Opt_WarnMissedExtraSharedLib,-  flagSpec "unticked-promoted-constructors"-                                         Opt_WarnUntickedPromotedConstructors,-  flagSpec "unused-do-bind"              Opt_WarnUnusedDoBind,-  flagSpec "unused-foralls"              Opt_WarnUnusedForalls,-  flagSpec "unused-imports"              Opt_WarnUnusedImports,-  flagSpec "unused-local-binds"          Opt_WarnUnusedLocalBinds,-  flagSpec "unused-matches"              Opt_WarnUnusedMatches,-  flagSpec "unused-pattern-binds"        Opt_WarnUnusedPatternBinds,-  flagSpec "unused-top-binds"            Opt_WarnUnusedTopBinds,-  flagSpec "unused-type-patterns"        Opt_WarnUnusedTypePatterns,-  flagSpec "unused-record-wildcards"     Opt_WarnUnusedRecordWildcards,-  flagSpec "redundant-bang-patterns"     Opt_WarnRedundantBangPatterns,-  flagSpec "redundant-record-wildcards"  Opt_WarnRedundantRecordWildcards,-  flagSpec "warnings-deprecations"       Opt_WarnWarningsDeprecations,-  flagSpec "wrong-do-bind"               Opt_WarnWrongDoBind,-  flagSpec "missing-pattern-synonym-signatures"-                                    Opt_WarnMissingPatternSynonymSignatures,-  flagSpec "missing-deriving-strategies" Opt_WarnMissingDerivingStrategies,-  flagSpec "simplifiable-class-constraints" Opt_WarnSimplifiableClassConstraints,-  flagSpec "missing-home-modules"        Opt_WarnMissingHomeModules,-  flagSpec "unrecognised-warning-flags"  Opt_WarnUnrecognisedWarningFlags,-  flagSpec "star-binder"                 Opt_WarnStarBinder,-  flagSpec "star-is-type"                Opt_WarnStarIsType,-  depFlagSpec "missing-space-after-bang" Opt_WarnSpaceAfterBang-    "bang patterns can no longer be written with a space",-  flagSpec "partial-fields"              Opt_WarnPartialFields,-  flagSpec "prepositive-qualified-module"-                                         Opt_WarnPrepositiveQualifiedModule,-  flagSpec "unused-packages"             Opt_WarnUnusedPackages,-  flagSpec "compat-unqualified-imports"  Opt_WarnCompatUnqualifiedImports,-  flagSpec "invalid-haddock"             Opt_WarnInvalidHaddock,-  flagSpec "operator-whitespace-ext-conflict"  Opt_WarnOperatorWhitespaceExtConflict,-  flagSpec "operator-whitespace"         Opt_WarnOperatorWhitespace,-  flagSpec "implicit-lift"               Opt_WarnImplicitLift,-  flagSpec "unicode-bidirectional-format-characters"-                                         Opt_WarnUnicodeBidirectionalFormatCharacters+  warnSpec    Opt_WarnAlternativeLayoutRuleTransitional,+  warnSpec    Opt_WarnAmbiguousFields,+  depWarnSpec Opt_WarnAutoOrphans+              "it has no effect",+  warnSpec    Opt_WarnCPPUndef,+  warnSpec    Opt_WarnUnbangedStrictPatterns,+  warnSpec    Opt_WarnDeferredTypeErrors,+  warnSpec    Opt_WarnDeferredOutOfScopeVariables,+  warnSpec    Opt_WarnWarningsDeprecations,+  warnSpec    Opt_WarnDeprecatedFlags,+  warnSpec    Opt_WarnDerivingDefaults,+  warnSpec    Opt_WarnDerivingTypeable,+  warnSpec    Opt_WarnDodgyExports,+  warnSpec    Opt_WarnDodgyForeignImports,+  warnSpec    Opt_WarnDodgyImports,+  warnSpec    Opt_WarnEmptyEnumerations,+  subWarnSpec "duplicate-constraints"+              Opt_WarnDuplicateConstraints+              "it is subsumed by -Wredundant-constraints",+  warnSpec    Opt_WarnRedundantConstraints,+  warnSpec    Opt_WarnDuplicateExports,+  depWarnSpec Opt_WarnHiShadows+              "it is not used, and was never implemented",+  warnSpec    Opt_WarnInaccessibleCode,+  warnSpec    Opt_WarnImplicitPrelude,+  depWarnSpec Opt_WarnImplicitKindVars+              "it is now an error",+  warnSpec    Opt_WarnIncompletePatterns,+  warnSpec    Opt_WarnIncompletePatternsRecUpd,+  warnSpec    Opt_WarnIncompleteUniPatterns,+  warnSpec    Opt_WarnInlineRuleShadowing,+  warnSpec    Opt_WarnIdentities,+  warnSpec    Opt_WarnMissingFields,+  warnSpec    Opt_WarnMissingImportList,+  warnSpec    Opt_WarnMissingExportList,+  subWarnSpec "missing-local-sigs"+              Opt_WarnMissingLocalSignatures+              "it is replaced by -Wmissing-local-signatures",+  warnSpec    Opt_WarnMissingLocalSignatures,+  warnSpec    Opt_WarnMissingMethods,+  depWarnSpec Opt_WarnMissingMonadFailInstances+              "fail is no longer a method of Monad",+  warnSpec    Opt_WarnSemigroup,+  warnSpec    Opt_WarnMissingSignatures,+  warnSpec    Opt_WarnMissingKindSignatures,+  subWarnSpec "missing-exported-sigs"+              Opt_WarnMissingExportedSignatures+              "it is replaced by -Wmissing-exported-signatures",+  warnSpec    Opt_WarnMissingExportedSignatures,+  warnSpec    Opt_WarnMonomorphism,+  warnSpec    Opt_WarnNameShadowing,+  warnSpec    Opt_WarnNonCanonicalMonadInstances,+  depWarnSpec Opt_WarnNonCanonicalMonadFailInstances+              "fail is no longer a method of Monad",+  warnSpec    Opt_WarnNonCanonicalMonoidInstances,+  warnSpec    Opt_WarnOrphans,+  warnSpec    Opt_WarnOverflowedLiterals,+  warnSpec    Opt_WarnOverlappingPatterns,+  warnSpec    Opt_WarnMissedSpecs,+  warnSpec    Opt_WarnAllMissedSpecs,+  warnSpec'   Opt_WarnSafe setWarnSafe,+  warnSpec    Opt_WarnTrustworthySafe,+  warnSpec    Opt_WarnInferredSafeImports,+  warnSpec    Opt_WarnMissingSafeHaskellMode,+  warnSpec    Opt_WarnTabs,+  warnSpec    Opt_WarnTypeDefaults,+  warnSpec    Opt_WarnTypedHoles,+  warnSpec    Opt_WarnPartialTypeSignatures,+  warnSpec    Opt_WarnUnrecognisedPragmas,+  warnSpec    Opt_WarnMisplacedPragmas,+  warnSpec'   Opt_WarnUnsafe setWarnUnsafe,+  warnSpec    Opt_WarnUnsupportedCallingConventions,+  warnSpec    Opt_WarnUnsupportedLlvmVersion,+  warnSpec    Opt_WarnMissedExtraSharedLib,+  warnSpec    Opt_WarnUntickedPromotedConstructors,+  warnSpec    Opt_WarnUnusedDoBind,+  warnSpec    Opt_WarnUnusedForalls,+  warnSpec    Opt_WarnUnusedImports,+  warnSpec    Opt_WarnUnusedLocalBinds,+  warnSpec    Opt_WarnUnusedMatches,+  warnSpec    Opt_WarnUnusedPatternBinds,+  warnSpec    Opt_WarnUnusedTopBinds,+  warnSpec    Opt_WarnUnusedTypePatterns,+  warnSpec    Opt_WarnUnusedRecordWildcards,+  warnSpec    Opt_WarnRedundantBangPatterns,+  warnSpec    Opt_WarnRedundantRecordWildcards,+  warnSpec    Opt_WarnRedundantStrictnessFlags,+  warnSpec    Opt_WarnWrongDoBind,+  warnSpec    Opt_WarnMissingPatternSynonymSignatures,+  warnSpec    Opt_WarnMissingDerivingStrategies,+  warnSpec    Opt_WarnSimplifiableClassConstraints,+  warnSpec    Opt_WarnMissingHomeModules,+  warnSpec    Opt_WarnUnrecognisedWarningFlags,+  warnSpec    Opt_WarnStarBinder,+  warnSpec    Opt_WarnStarIsType,+  depWarnSpec Opt_WarnSpaceAfterBang+              "bang patterns can no longer be written with a space",+  warnSpec    Opt_WarnPartialFields,+  warnSpec    Opt_WarnPrepositiveQualifiedModule,+  warnSpec    Opt_WarnUnusedPackages,+  warnSpec    Opt_WarnCompatUnqualifiedImports,+  warnSpec    Opt_WarnInvalidHaddock,+  warnSpec    Opt_WarnOperatorWhitespaceExtConflict,+  warnSpec    Opt_WarnOperatorWhitespace,+  warnSpec    Opt_WarnImplicitLift,+  warnSpec    Opt_WarnMissingExportedPatternSynonymSignatures,+  warnSpec    Opt_WarnForallIdentifier,+  warnSpec    Opt_WarnUnicodeBidirectionalFormatCharacters,+  warnSpec    Opt_WarnGADTMonoLocalBinds,+  warnSpec    Opt_WarnTypeEqualityOutOfScope,+  warnSpec    Opt_WarnTypeEqualityRequiresOperators  ]  -- | These @-\<blah\>@ flags can all be reversed with @-no-\<blah\>@@@ -3290,7 +3379,8 @@   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-var-kinds"         Opt_SuppressVarKinds,+  flagSpec "suppress-core-sizes"        Opt_SuppressCoreSizes   ]  -- | These @-f\<blah\>@ flags can all be reversed with @-fno-\<blah\>@@@ -3344,7 +3434,8 @@   flagSpec "ignore-optim-changes"             Opt_IgnoreOptimChanges,   flagSpec "ignore-hpc-changes"               Opt_IgnoreHpcChanges,   flagSpec "full-laziness"                    Opt_FullLaziness,-  flagSpec "fun-to-thunk"                     Opt_FunToThunk,+  depFlagSpec' "fun-to-thunk"                 Opt_FunToThunk+      (useInstead "-f" "full-laziness"),   flagSpec "gen-manifest"                     Opt_GenManifest,   flagSpec "ghci-history"                     Opt_GhciHistory,   flagSpec "ghci-leak-check"                  Opt_GhciLeakCheck,@@ -3387,6 +3478,9 @@   flagSpec "print-typechecker-elaboration"    Opt_PrintTypecheckerElaboration,   flagSpec "prof-cafs"                        Opt_AutoSccsOnIndividualCafs,   flagSpec "prof-count-entries"               Opt_ProfCountEntries,+  flagSpec "prof-late"                        Opt_ProfLateCcs,+  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@@ -3411,17 +3505,27 @@   flagSpec "unbox-strict-fields"              Opt_UnboxStrictFields,   flagSpec "version-macros"                   Opt_VersionMacros,   flagSpec "worker-wrapper"                   Opt_WorkerWrapper,+  flagSpec "worker-wrapper-cbv"               Opt_WorkerWrapperUnlift,   flagSpec "solve-constant-dicts"             Opt_SolveConstantDicts,-  flagSpec "catch-bottoms"                    Opt_CatchBottoms,+  flagSpec "catch-nonexhaustive-cases"        Opt_CatchNonexhaustiveCases,   flagSpec "alignment-sanitisation"           Opt_AlignmentSanitisation,   flagSpec "check-prim-bounds"                Opt_DoBoundsChecking,   flagSpec "num-constant-folding"             Opt_NumConstantFolding,+  flagSpec "core-constant-folding"            Opt_CoreConstantFolding,+  flagSpec "fast-pap-calls"                   Opt_FastPAPCalls,+  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 "link-rts"                         Opt_LinkRts,+  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))+   ]   ++ fHoleFlags @@ -3620,7 +3724,7 @@   flagSpec "MultiWayIf"                       LangExt.MultiWayIf,   flagSpec "NumericUnderscores"               LangExt.NumericUnderscores,   flagSpec "NPlusKPatterns"                   LangExt.NPlusKPatterns,-  flagSpec "NamedFieldPuns"                   LangExt.RecordPuns,+  flagSpec "NamedFieldPuns"                   LangExt.NamedFieldPuns,   flagSpec "NamedWildCards"                   LangExt.NamedWildCards,   flagSpec "NegativeLiterals"                 LangExt.NegativeLiterals,   flagSpec "HexFloatLiterals"                 LangExt.HexFloatLiterals,@@ -3653,7 +3757,7 @@   flagSpec "RebindableSyntax"                 LangExt.RebindableSyntax,   flagSpec "OverloadedRecordDot"              LangExt.OverloadedRecordDot,   flagSpec "OverloadedRecordUpdate"           LangExt.OverloadedRecordUpdate,-  depFlagSpec' "RecordPuns"                   LangExt.RecordPuns+  depFlagSpec' "RecordPuns"                   LangExt.NamedFieldPuns     (deprecatedForExtension "NamedFieldPuns"),   flagSpec "RecordWildCards"                  LangExt.RecordWildCards,   flagSpec "RecursiveDo"                      LangExt.RecursiveDo,@@ -3710,7 +3814,8 @@       Opt_SharedImplib,       Opt_SimplPreInlining,       Opt_VersionMacros,-      Opt_RPath+      Opt_RPath,+      Opt_CompactUnwind     ]      ++ [f | (ns,f) <- optLevelFlags, 0 `elem` ns]@@ -3846,6 +3951,10 @@     , (LangExt.TemplateHaskell, turnOn, LangExt.TemplateHaskellQuotes)     , (LangExt.Strict, turnOn, LangExt.StrictData) +    -- Historically only UnboxedTuples was required for unboxed sums to work.+    -- To avoid breaking code, we make UnboxedTuples imply UnboxedSums.+    , (LangExt.UnboxedTuples, turnOn, LangExt.UnboxedSums)+     -- The extensions needed to declare an H98 unlifted data type     , (LangExt.UnliftedDatatypes, turnOn, LangExt.DataKinds)     , (LangExt.UnliftedDatatypes, turnOn, LangExt.StandaloneKindSignatures)@@ -3879,10 +3988,14 @@   = [ ([0,1,2], Opt_DoLambdaEtaExpansion)     , ([0,1,2], Opt_DoEtaReduction)       -- See Note [Eta-reduction in -O0]     , ([0,1,2], Opt_LlvmTBAA)+    , ([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)@@ -3894,6 +4007,7 @@     , ([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@@ -3919,6 +4033,7 @@      , ([2],     Opt_LiberateCase)     , ([2],     Opt_SpecConstr)+    , ([2],     Opt_FastPAPCalls) --  , ([2],     Opt_RegsGraph) --   RegsGraph suffers performance regression. See #7679 --  , ([2],     Opt_StaticArgumentTransformation)@@ -3926,164 +4041,27 @@     ]  --- -------------------------------------------------------------------------------- Standard sets of warning options---- Note [Documenting warning flags]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~------ If you change the list of warning enabled by default--- please remember to update the User's Guide. The relevant file is:------  docs/users_guide/using-warnings.rst---- | Warning groups.------ As all warnings are in the Weverything set, it is ignored when--- displaying to the user which group a warning is in.-warningGroups :: [(String, [WarningFlag])]-warningGroups =-    [ ("compat",       minusWcompatOpts)-    , ("unused-binds", unusedBindsFlags)-    , ("default",      standardWarnings)-    , ("extra",        minusWOpts)-    , ("all",          minusWallOpts)-    , ("everything",   minusWeverythingOpts)-    ]---- | 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 Weverything group is not included.-warningHierarchies :: [[String]]-warningHierarchies = hierarchies ++ map (:[]) rest-  where-    hierarchies = [["default", "extra", "all"]]-    rest = filter (`notElem` "everything" : concat hierarchies) $-           map fst warningGroups---- | Find the smallest group in every hierarchy which a warning--- belongs to, excluding Weverything.-smallestGroups :: WarningFlag -> [String]-smallestGroups 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-        flags <- lookup group warningGroups-        guard (flag `elem` flags)-        pure (Just group)-    go [] = Nothing---- | Warnings enabled unless specified otherwise-standardWarnings :: [WarningFlag]-standardWarnings -- see Note [Documenting warning flags]-    = [ Opt_WarnOverlappingPatterns,-        Opt_WarnWarningsDeprecations,-        Opt_WarnDeprecatedFlags,-        Opt_WarnDeferredTypeErrors,-        Opt_WarnTypedHoles,-        Opt_WarnDeferredOutOfScopeVariables,-        Opt_WarnPartialTypeSignatures,-        Opt_WarnUnrecognisedPragmas,-        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_WarnInaccessibleCode,-        Opt_WarnSpaceAfterBang,-        Opt_WarnNonCanonicalMonadInstances,-        Opt_WarnNonCanonicalMonoidInstances,-        Opt_WarnOperatorWhitespaceExtConflict,-        Opt_WarnUnicodeBidirectionalFormatCharacters-      ]---- | 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_WarnUntickedPromotedConstructors,-        Opt_WarnMissingPatternSynonymSignatures,-        Opt_WarnUnusedRecordWildcards,-        Opt_WarnRedundantRecordWildcards,-        Opt_WarnStarIsType,-        Opt_WarnIncompleteUniPatterns,-        Opt_WarnIncompletePatternsRecUpd-      ]---- | 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_WarnSemigroup-      , Opt_WarnNonCanonicalMonoidInstances-      , Opt_WarnStarIsType-      , Opt_WarnCompatUnqualifiedImports-      ]- enableUnusedBinds :: DynP () enableUnusedBinds = mapM_ setWarningFlag unusedBindsFlags  disableUnusedBinds :: DynP () disableUnusedBinds = mapM_ unSetWarningFlag unusedBindsFlags --- Things you get with -Wunused-binds-unusedBindsFlags :: [WarningFlag]-unusedBindsFlags = [ Opt_WarnUnusedTopBinds-                   , Opt_WarnUnusedLocalBinds-                   , Opt_WarnUnusedPatternBinds-                   ]+-- | 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@@ -4230,7 +4208,7 @@    in dflags3  removeWayDyn :: DynP ()-removeWayDyn = upd (\dfs -> dfs { targetWays_ = Set.filter (WayDyn /=) (targetWays_ dfs) })+removeWayDyn = upd (\dfs -> dfs { targetWays_ = removeWay WayDyn (targetWays_ dfs) })  -------------------------- setGeneralFlag, unSetGeneralFlag :: GeneralFlag -> DynP ()@@ -4294,8 +4272,6 @@    --      (except for -fno-glasgow-exts, which is treated specially)  ---------------------------alterFileSettings :: (FileSettings -> FileSettings) -> DynFlags -> DynFlags-alterFileSettings f dynFlags = dynFlags { fileSettings = f (fileSettings dynFlags) }  alterToolSettings :: (ToolSettings -> ToolSettings) -> DynFlags -> DynFlags alterToolSettings f dynFlags = dynFlags { toolSettings = f (toolSettings dynFlags) }@@ -4323,9 +4299,6 @@           force_recomp dfs = isOneShot (ghcMode dfs)  -setVerboseCore2Core :: DynP ()-setVerboseCore2Core = setDumpFlag' Opt_D_verbose_core2core- setVerbosity :: Maybe Int -> DynP () setVerbosity mb_n = upd (\dfs -> dfs{ verbosity = mb_n `orElse` 3 }) @@ -4429,6 +4402,43 @@ setUnitId :: String -> DynFlags -> DynFlags setUnitId p d = d { homeUnitId_ = stringToUnitId 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  = Set.insert (mkModuleName p) (reexportedModules s) })++ -- 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 ()@@ -4452,13 +4462,6 @@ setOptLevel :: Int -> DynFlags -> DynP DynFlags setOptLevel n dflags = return (updOptLevel n dflags) -checkOptLevel :: Int -> DynFlags -> Either String DynFlags-checkOptLevel n dflags-   | backend dflags == Interpreter && n > 0-     = Left "-O conflicts with --interactive; -O ignored."-   | otherwise-     = Right dflags- setCallerCcFilters :: String -> DynP () setCallerCcFilters arg =   case parseCallerCcFilter arg of@@ -4500,6 +4503,7 @@         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@@ -4592,7 +4596,7 @@ -- tmpDir, where we store temporary files.  setTmpDir :: FilePath -> DynFlags -> DynFlags-setTmpDir dir = alterFileSettings $ \s -> s { fileSettings_tmpDir = normalise dir }+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 @@ -4626,9 +4630,7 @@ -- platform.  picCCOpts :: DynFlags -> [String]-picCCOpts dflags = pieOpts ++ picOpts-  where-    picOpts =+picCCOpts dflags =       case platformOS (targetPlatform dflags) of       OSDarwin           -- Apple prefers to do things the other way round.@@ -4650,13 +4652,14 @@       -- 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 || WayDyn `Set.member` ways dflags ->+       | gopt Opt_PIC dflags || ways dflags `hasWay` WayDyn ->           ["-fPIC", "-U__PIC__", "-D__PIC__"]       -- gcc may be configured to have PIC on by default, let's be       -- explicit here, see #15847        | otherwise -> ["-fno-PIC"] -    pieOpts+pieCCLDOpts :: DynFlags -> [String]+pieCCLDOpts dflags       | gopt Opt_PICExecutable dflags       = ["-pie"]         -- See Note [No PIE when linking]       | toolSettings_ccSupportsNoPie (toolSettings dflags) = ["-no-pie"]@@ -4664,8 +4667,8 @@   {--Note [No PIE while linking]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+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@@ -4694,6 +4697,10 @@           (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),        ("Booter version",              cBooterVersion),        ("Stage",                       cStage),        ("Build platform",              cBuildPlatformString),@@ -4738,13 +4745,11 @@     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 mtoold . expandTopDir topd+    expandDirectories topd mtoold = expandToolDir useInplaceMinGW mtoold . expandTopDir topd  -wordAlignment :: Platform -> Alignment-wordAlignment platform = alignmentOf (platformWordSizeInBytes platform)- -- | Get target profile targetProfile :: DynFlags -> Profile targetProfile dflags = Profile (targetPlatform dflags) (ways dflags)@@ -4788,6 +4793,12 @@     = 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     -- Via-C backend only supports unregisterised ABI. Switch to a backend    -- supporting it if possible.@@ -4826,17 +4837,24 @@    not (gopt Opt_PIC dflags)     = loop (gopt_set dflags Opt_PIC)            "Enabling -fPIC as it is always on for this platform"- | Left err <- checkOptLevel (optLevel dflags) dflags-    = loop (updOptLevel 0 dflags) err + | backend dflags == Interpreter+ , let (dflags', changed) = updOptLevelChanged 0 dflags+ , changed+    = loop dflags' "Optimization flags conflict with --interactive; optimization flags ignored."+  | LinkInMemory <- ghcLink dflags  , not (gopt Opt_ExternalInterpreter dflags)  , hostIsProfiled  , backendProducesObject (backend dflags)- , WayProf `Set.notMember` ways dflags+ , ways dflags `hasNotWay` WayProf     = loop dflags{targetWays_ = addWay WayProf (targetWays_ dflags)}          "Enabling -prof, because -fobject-code is enabled and GHCi is profiled" + | LinkMergedObj <- ghcLink dflags+ , Nothing <- outputFile dflags+ = pgmError "--output must be specified when using --merge-objs"+  | otherwise = (dflags, [])     where loc = mkGeneralSrcSpan (fsLit "when making flags consistent")           loop updated_dflags warning@@ -4857,31 +4875,6 @@ -- ----------------------------------------------------------------------------- -- SSE and AVX --- TODO: Instead of using a separate predicate (i.e. isSse2Enabled) to--- check if SSE is enabled, we might have x86-64 imply the -msse2--- flag.--isSseEnabled :: Platform -> Bool-isSseEnabled platform = case platformArch platform of-    ArchX86_64 -> True-    ArchX86    -> True-    _          -> False--isSse2Enabled :: Platform -> Bool-isSse2Enabled platform = case platformArch platform of-  -- We assume  SSE1 and SSE2 operations are available on both-  -- x86 and x86_64. Historically we didn't default to SSE2 and-  -- SSE1 on x86, which results in defacto nondeterminism for how-  -- rounding behaves in the associated x87 floating point instructions-  -- because variations in the spill/fpu stack placement of arguments for-  -- operations would change the precision and final result of what-  -- would otherwise be the same expressions with respect to single or-  -- double precision IEEE floating point computations.-    ArchX86_64 -> True-    ArchX86    -> True-    _          -> False-- isSse4_2Enabled :: DynFlags -> Bool isSse4_2Enabled dflags = sseVersion dflags >= Just SSE42 @@ -5051,11 +5044,6 @@ outputFile dflags    | dynamicNow dflags = dynOutputFile_ dflags    | otherwise         = outputFile_    dflags--hiSuf :: DynFlags -> String-hiSuf dflags-   | dynamicNow dflags = dynHiSuf_ dflags-   | otherwise         = hiSuf_    dflags  objectSuf :: DynFlags -> String objectSuf dflags
− GHC/Driver/Session.hs-boot 
@@ -1,12 +0,0 @@-module GHC.Driver.Session where--import GHC.Prelude-import GHC.Platform-import {-# SOURCE #-} GHC.Utils.Outputable--data DynFlags--targetPlatform           :: DynFlags -> Platform-hasPprDebug              :: DynFlags -> Bool-hasNoDebugOutput         :: DynFlags -> Bool-initSDocContext          :: DynFlags -> PprStyle -> SDocContext
GHC/Hs.hs view
@@ -68,7 +68,16 @@ -- -- All we actually declare here is the top-level structure for a module. data HsModule-  = HsModule {+  =  -- | 'GHC.Parser.Annotation.AnnKeywordId's+     --+     --  - 'GHC.Parser.Annotation.AnnModule','GHC.Parser.Annotation.AnnWhere'+     --+     --  - 'GHC.Parser.Annotation.AnnOpen','GHC.Parser.Annotation.AnnSemi',+     --    'GHC.Parser.Annotation.AnnClose' for explicit braces and semi around+     --    hsmodImports,hsmodDecls if this style is used.++     -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation+    HsModule {       hsmodAnn :: EpAnn AnnsModule,       hsmodLayout :: LayoutInfo,         -- ^ Layout info for the module.@@ -89,39 +98,30 @@         --  - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnOpen'         --                                   ,'GHC.Parser.Annotation.AnnClose' -        -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+        -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation       hsmodImports :: [LImportDecl GhcPs],         -- ^ 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 GhcPs],         -- ^ Type, class, value, and interface signature decls-      hsmodDeprecMessage :: Maybe (LocatedP WarningTxt),+      hsmodDeprecMessage :: Maybe (LocatedP (WarningTxt GhcPs)),         -- ^ reason\/explanation for warning/deprecation of this module         --         --  - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnOpen'         --                                   ,'GHC.Parser.Annotation.AnnClose'         -- -        -- For details on above see note [exact print annotations] in GHC.Parser.Annotation-      hsmodHaddockModHeader :: Maybe LHsDocString+        -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation+      hsmodHaddockModHeader :: Maybe (LHsDoc GhcPs)         -- ^ Haddock module info and description, unparsed         --         --  - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnOpen'         --                                   ,'GHC.Parser.Annotation.AnnClose' -        -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+        -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation    }-     -- ^ 'GHC.Parser.Annotation.AnnKeywordId's-     ---     --  - 'GHC.Parser.Annotation.AnnModule','GHC.Parser.Annotation.AnnWhere'-     ---     --  - 'GHC.Parser.Annotation.AnnOpen','GHC.Parser.Annotation.AnnSemi',-     --    'GHC.Parser.Annotation.AnnClose' for explicit braces and semi around-     --    hsmodImports,hsmodDecls if this style is used. -     -- For details on above see note [exact print annotations] in GHC.Parser.Annotation- deriving instance Data HsModule  data AnnsModule@@ -133,13 +133,13 @@ instance Outputable HsModule where      ppr (HsModule _ _ Nothing _ imports decls _ mbDoc)-      = pp_mb mbDoc $$ pp_nonnull imports-                    $$ pp_nonnull decls+      = pprMaybeWithDoc mbDoc $ pp_nonnull imports+                             $$ pp_nonnull decls      ppr (HsModule _ _ (Just name) exports imports decls deprec mbDoc)-      = vcat [-            pp_mb mbDoc,-            case exports of+      = pprMaybeWithDoc mbDoc $+        vcat+          [ case exports of               Nothing -> pp_header (text "where")               Just es -> vcat [                            pp_header lparen,@@ -155,10 +155,6 @@            Just d -> vcat [ pp_modname, ppr d, rest ]          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
GHC/Hs/Binds.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-}@@ -42,18 +43,17 @@ import GHC.Types.Basic import GHC.Types.SourceText import GHC.Types.SrcLoc as SrcLoc+import GHC.Types.Var import GHC.Data.Bag-import GHC.Data.FastString import GHC.Data.BooleanFormula (LBooleanFormula) import GHC.Types.Name.Reader import GHC.Types.Name-import GHC.Types.Id  import GHC.Utils.Outputable import GHC.Utils.Panic -import Data.List (sortBy) import Data.Function+import Data.List (sortBy) import Data.Data (Data)  {-@@ -72,7 +72,7 @@ type instance XHsValBinds      (GhcPass pL) (GhcPass pR) = EpAnn AnnList type instance XHsIPBinds       (GhcPass pL) (GhcPass pR) = EpAnn AnnList type instance XEmptyLocalBinds (GhcPass pL) (GhcPass pR) = NoExtField-type instance XXHsLocalBindsLR (GhcPass pL) (GhcPass pR) = NoExtCon+type instance XXHsLocalBindsLR (GhcPass pL) (GhcPass pR) = DataConCantHappen  -- --------------------------------------------------------------------- -- Deal with ValBindsOut@@ -84,33 +84,96 @@       [LSig GhcRn]  type instance XValBinds    (GhcPass pL) (GhcPass pR) = AnnSortKey-type instance XXValBindsLR (GhcPass pL) (GhcPass pR)+type instance XXValBindsLR (GhcPass pL) pR             = NHsValBindsLR (GhcPass pL)  -- ---------------------------------------------------------------------  type instance XFunBind    (GhcPass pL) GhcPs = NoExtField-type instance XFunBind    (GhcPass pL) GhcRn = NameSet    -- Free variables-type instance XFunBind    (GhcPass pL) GhcTc = HsWrapper  -- See comments on FunBind.fun_ext+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+-- ^ After the type-checker, the FunBind extension field contains 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) = EpAnn [AddEpAnn]-type instance XPatBind    GhcRn (GhcPass pR) = NameSet -- Free variables+type instance XPatBind    GhcRn (GhcPass pR) = NameSet -- See Note [Bind free vars] type instance XPatBind    GhcTc (GhcPass pR) = Type    -- Type of the GRHSs  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 -type instance XABE       (GhcPass p) = NoExtField-type instance XXABExport (GhcPass p) = NoExtCon+type instance XXHsBindsLR GhcPs pR = DataConCantHappen+type instance XXHsBindsLR GhcRn pR = DataConCantHappen+type instance XXHsBindsLR GhcTc pR = AbsBinds  type instance XPSB         (GhcPass idL) GhcPs = EpAnn [AddEpAnn]-type instance XPSB         (GhcPass idL) GhcRn = NameSet+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) = NoExtCon+type instance XXPatSynBind (GhcPass idL) (GhcPass idR) = DataConCantHappen +-- ---------------------------------------------------------------------++-- | 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] ~~~~~~~~~~~~~~~@@ -320,8 +383,8 @@  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+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)@@ -335,10 +398,10 @@  Specifically, -  * bind_fvs includes all free vars that are defined in this module+  * it 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+  * 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@@ -458,29 +521,36 @@     $$  whenPprDebug (pprIfTc @idR $ 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 })-  = 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)-               ]+ppr_monobind (XHsBindsLR b) = case ghcPass @idL of+#if __GLASGOW_HASKELL__ <= 900+  GhcPs -> dataConCantHappen b+  GhcRn -> dataConCantHappen b+#endif+  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 OutputableBndrId p => Outputable (ABExport (GhcPass p)) where+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)-           , pprIfTc @p $ nest 2 (text "wrap:" <+> ppr wrap) ]+           , ppr $ nest 2 (text "wrap:" <+> ppr wrap) ]  instance (OutputableBndrId l, OutputableBndrId r)           => Outputable (PatSynBind (GhcPass l) (GhcPass r)) where@@ -515,7 +585,7 @@       ppr_rhs = case dir of           Unidirectional           -> ppr_simple (text "<-")           ImplicitBidirectional    -> ppr_simple equals-          ExplicitBidirectional mg -> ppr_simple (text "<-") <+> ptext (sLit "where") $$+          ExplicitBidirectional mg -> ppr_simple (text "<-") <+> text "where" $$                                       (nest 2 $ pprFunBind mg)  pprTicks :: SDoc -> SDoc -> SDoc@@ -544,7 +614,7 @@                                                -- implicit parameters  -type instance XXHsIPBinds    (GhcPass p) = NoExtCon+type instance XXHsIPBinds    (GhcPass p) = DataConCantHappen  isEmptyIPBindsPR :: HsIPBinds (GhcPass p) -> Bool isEmptyIPBindsPR (IPBinds _ is) = null is@@ -552,8 +622,11 @@ isEmptyIPBindsTc :: HsIPBinds GhcTc -> Bool isEmptyIPBindsTc (IPBinds ds is) = null is && isEmptyTcEvBinds ds -type instance XCIPBind    (GhcPass p) = EpAnn [AddEpAnn]-type instance XXIPBind    (GhcPass p) = NoExtCon+-- EPA annotations in GhcPs, dictionary Id in GhcTc+type instance XCIPBind GhcPs = EpAnn [AddEpAnn]+type instance XCIPBind GhcRn = NoExtField+type instance XCIPBind GhcTc = Id+type instance XXIPBind    (GhcPass p) = DataConCantHappen  instance OutputableBndrId p        => Outputable (HsIPBinds (GhcPass p)) where@@ -561,10 +634,11 @@                         $$ whenPprDebug (pprIfTc @p $ ppr ds)  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 (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  {- ************************************************************************@@ -586,10 +660,10 @@ type instance XSCCFunSig        (GhcPass p) = EpAnn [AddEpAnn] type instance XCompleteMatchSig (GhcPass p) = EpAnn [AddEpAnn] -type instance XXSig             (GhcPass p) = NoExtCon+type instance XXSig             (GhcPass p) = DataConCantHappen  type instance XFixitySig  (GhcPass p) = NoExtField-type instance XXFixitySig (GhcPass p) = NoExtCon+type instance XXFixitySig (GhcPass p) = DataConCantHappen  data AnnSig   = AnnSig {@@ -598,6 +672,39 @@       } deriving Data  +-- | 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+ instance OutputableBndrId p => Outputable (Sig (GhcPass p)) where     ppr sig = ppr_sig sig @@ -610,14 +717,14 @@ 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)+  = pragSrcBrackets (inlinePragmaSource inl) pragmaSrc (pprSpec (unLoc var)                                              (interpp'SP ty) inl)     where       pragmaSrc = case spec of-        NoUserInlinePrag -> "{-# SPECIALISE"-        _                -> "{-# SPECIALISE_INLINE"+        NoUserInlinePrag -> "{-# " ++ extractSpecPragName (inl_src inl)+        _                -> "{-# " ++ extractSpecPragName (inl_src inl)  ++ "_INLINE" ppr_sig (InlineSig _ var inl)-  = pragSrcBrackets (inl_src inl) "{-# INLINE"  (pprInline inl+  = pragSrcBrackets (inlinePragmaSource inl) "{-# INLINE"  (pprInline inl                                    <+> pprPrefixOcc (unLoc var)) ppr_sig (SpecInstSig _ src ty)   = pragSrcBrackets src "{-# pragma" (text "instance" <+> ppr ty)@@ -675,7 +782,7 @@  instance Outputable TcSpecPrag where   ppr (SpecPrag var _ inl)-    = text "SPECIALIZE" <+> pprSpec var (text "<type>") inl+    = ppr (extractSpecPragName $ inl_src inl) <+> pprSpec var (text "<type>") inl  pprMinimalSig :: (OutputableBndr name)               => LBooleanFormula (GenLocated l name) -> SDoc@@ -700,7 +807,7 @@  type instance Anno (FixitySig (GhcPass p)) = SrcSpanAnnA -type instance Anno StringLiteral = SrcSpan+type instance Anno StringLiteral = SrcAnn NoEpAnns type instance Anno (LocatedN RdrName) = SrcSpan type instance Anno (LocatedN Name) = SrcSpan type instance Anno (LocatedN Id) = SrcSpan
GHC/Hs/Decls.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-}@@ -153,7 +153,7 @@ type instance XSpliceD    (GhcPass _) = NoExtField type instance XDocD       (GhcPass _) = NoExtField type instance XRoleAnnotD (GhcPass _) = NoExtField-type instance XXHsDecl    (GhcPass _) = NoExtCon+type instance XXHsDecl    (GhcPass _) = DataConCantHappen  -- | Partition a list of HsDecls into function/pattern bindings, signatures, -- type family declarations, type family instances, and documentation comments.@@ -188,7 +188,7 @@         _ -> pprPanic "partitionBindsAndSigs" (ppr decl)  type instance XCHsGroup (GhcPass _) = NoExtField-type instance XXHsGroup (GhcPass _) = NoExtCon+type instance XXHsGroup (GhcPass _) = DataConCantHappen   emptyGroup, emptyRdrGroup, emptyRnGroup :: HsGroup (GhcPass p)@@ -309,7 +309,7 @@           vcat_mb gap (Just d  : ds) = gap $$ d $$ vcat_mb blankLine ds  type instance XSpliceDecl      (GhcPass _) = NoExtField-type instance XXSpliceDecl     (GhcPass _) = NoExtCon+type instance XXSpliceDecl     (GhcPass _) = DataConCantHappen  instance OutputableBndrId p        => Outputable (SpliceDecl (GhcPass p)) where@@ -338,10 +338,10 @@ type instance XClassDecl    GhcRn = NameSet -- FVs type instance XClassDecl    GhcTc = NameSet -- FVs -type instance XXTyClDecl    (GhcPass _) = NoExtCon+type instance XXTyClDecl    (GhcPass _) = DataConCantHappen  type instance XCTyFamInstDecl (GhcPass _) = EpAnn [AddEpAnn]-type instance XXTyFamInstDecl (GhcPass _) = NoExtCon+type instance XXTyFamInstDecl (GhcPass _) = DataConCantHappen  -- Dealing with names @@ -464,7 +464,7 @@   ppr = pprFunDep  type instance XCFunDep    (GhcPass _) = EpAnn [AddEpAnn]-type instance XXFunDep    (GhcPass _) = NoExtCon+type instance XXFunDep    (GhcPass _) = DataConCantHappen  pprFundeps :: OutputableBndrId p => [FunDep (GhcPass p)] -> SDoc pprFundeps []  = empty@@ -482,7 +482,7 @@ ********************************************************************* -}  type instance XCTyClGroup (GhcPass _) = NoExtField-type instance XXTyClGroup (GhcPass _) = NoExtCon+type instance XXTyClGroup (GhcPass _) = DataConCantHappen   {- *********************************************************************@@ -495,10 +495,10 @@ type instance XCKindSig         (GhcPass _) = NoExtField  type instance XTyVarSig         (GhcPass _) = NoExtField-type instance XXFamilyResultSig (GhcPass _) = NoExtCon+type instance XXFamilyResultSig (GhcPass _) = DataConCantHappen  type instance XCFamilyDecl    (GhcPass _) = EpAnn [AddEpAnn]-type instance XXFamilyDecl    (GhcPass _) = NoExtCon+type instance XXFamilyDecl    (GhcPass _) = DataConCantHappen   ------------- Functions over FamilyDecls -----------@@ -525,7 +525,7 @@ ------------- Pretty printing FamilyDecls -----------  type instance XCInjectivityAnn  (GhcPass _) = EpAnn [AddEpAnn]-type instance XXInjectivityAnn  (GhcPass _) = NoExtCon+type instance XXInjectivityAnn  (GhcPass _) = DataConCantHappen  instance OutputableBndrId p        => Outputable (FamilyDecl (GhcPass p)) where@@ -569,10 +569,10 @@ ********************************************************************* -}  type instance XCHsDataDefn    (GhcPass _) = NoExtField-type instance XXHsDataDefn    (GhcPass _) = NoExtCon+type instance XXHsDataDefn    (GhcPass _) = DataConCantHappen  type instance XCHsDerivingClause    (GhcPass _) = EpAnn [AddEpAnn]-type instance XXHsDerivingClause    (GhcPass _) = NoExtCon+type instance XXHsDerivingClause    (GhcPass _) = DataConCantHappen  instance OutputableBndrId p        => Outputable (HsDerivingClause (GhcPass p)) where@@ -592,7 +592,7 @@  type instance XDctSingle (GhcPass _) = NoExtField type instance XDctMulti  (GhcPass _) = NoExtField-type instance XXDerivClauseTys (GhcPass _) = NoExtCon+type instance XXDerivClauseTys (GhcPass _) = DataConCantHappen  instance OutputableBndrId p => Outputable (DerivClauseTys (GhcPass p)) where   ppr (DctSingle _ ty) = ppr ty@@ -602,7 +602,7 @@ type instance XStandaloneKindSig GhcRn = NoExtField type instance XStandaloneKindSig GhcTc = NoExtField -type instance XXStandaloneKindSig (GhcPass p) = NoExtCon+type instance XXStandaloneKindSig (GhcPass p) = DataConCantHappen  standaloneKindSigName :: StandaloneKindSig (GhcPass p) -> IdP (GhcPass p) standaloneKindSigName (StandaloneKindSig _ lname _) = unLoc lname@@ -610,7 +610,7 @@ type instance XConDeclGADT (GhcPass _) = EpAnn [AddEpAnn] type instance XConDeclH98  (GhcPass _) = EpAnn [AddEpAnn] -type instance XXConDecl (GhcPass _) = NoExtCon+type instance XXConDecl (GhcPass _) = DataConCantHappen  getConNames :: ConDecl GhcRn -> [LocatedN Name] getConNames ConDeclH98  {con_name  = name}  = [name]@@ -626,7 +626,7 @@   InfixCon{}  -> Nothing getRecConArgs_maybe (ConDeclGADT{con_g_args = args}) = case args of   PrefixConGADT{} -> Nothing-  RecConGADT flds -> Just flds+  RecConGADT flds _ -> Just flds  hsConDeclTheta :: Maybe (LHsContext (GhcPass p)) -> [LHsType (GhcPass p)] hsConDeclTheta Nothing            = []@@ -686,8 +686,8 @@                        , con_mb_cxt = mcxt                        , con_args = args                        , con_doc = doc })-  = sep [ ppr_mbDoc doc-        , pprHsForAll (mkHsForAllInvisTele noAnn ex_tvs) mcxt+  = 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@@ -703,15 +703,18 @@ pprConDecl (ConDeclGADT { con_names = cons, con_bndrs = L _ outer_bndrs                         , con_mb_cxt = mcxt, con_g_args = args                         , con_res_ty = res_ty, con_doc = doc })-  = ppr_mbDoc doc <+> ppr_con_names cons <+> dcolon+  = pprMaybeWithDoc doc $ ppr_con_names cons <+> dcolon     <+> (sep [pprHsOuterSigTyVarBndrs outer_bndrs <+> pprLHsContext mcxt,-              ppr_arrow_chain (get_args args ++ [ppr res_ty]) ])+              sep (ppr_args args ++ [ppr res_ty]) ])   where-    get_args (PrefixConGADT args) = map ppr args-    get_args (RecConGADT fields)  = [pprConDeclFields (unLoc fields)]+    ppr_args (PrefixConGADT args) = map (\(HsScaled arr t) -> ppr t <+> ppr_arr arr) args+    ppr_args (RecConGADT fields _) = [pprConDeclFields (unLoc fields) <+> arrow] -    ppr_arrow_chain (a:as) = sep (a : map (arrow <+>) as)-    ppr_arrow_chain []     = empty+    -- Display linear arrows as unrestricted with -XNoLinearTypes+    -- (cf. dataConDisplayType in Note [Displaying linear fields] in GHC.Core.DataCon)+    ppr_arr (HsLinearArrow _) = 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)@@ -725,7 +728,7 @@ -}  type instance XCFamEqn    (GhcPass _) r = EpAnn [AddEpAnn]-type instance XXFamEqn    (GhcPass _) r = NoExtCon+type instance XXFamEqn    (GhcPass _) r = DataConCantHappen  type instance Anno (FamEqn (GhcPass p) _) = SrcSpanAnnA @@ -735,21 +738,19 @@ type instance XCClsInstDecl    GhcRn = NoExtField type instance XCClsInstDecl    GhcTc = NoExtField -type instance XXClsInstDecl    (GhcPass _) = NoExtCon+type instance XXClsInstDecl    (GhcPass _) = DataConCantHappen  ----------------- Instances of all kinds -------------  type instance XClsInstD     (GhcPass _) = NoExtField -type instance XDataFamInstD GhcPs = EpAnn [AddEpAnn]-type instance XDataFamInstD GhcRn = NoExtField-type instance XDataFamInstD GhcTc = 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 _) = NoExtCon+type instance XXInstDecl    (GhcPass _) = DataConCantHappen  instance OutputableBndrId p        => Outputable (TyFamInstDecl (GhcPass p)) where@@ -810,17 +811,7 @@ pprHsFamInstLHS thing bndrs typats fixity mb_ctxt    = hsep [ pprHsOuterFamEqnTyVarBndrs 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)]+          , pprHsArgsApp thing fixity typats ]  instance OutputableBndrId p        => Outputable (ClsInstDecl (GhcPass p)) where@@ -888,7 +879,7 @@ -}  type instance XCDerivDecl    (GhcPass _) = EpAnn [AddEpAnn]-type instance XXDerivDecl    (GhcPass _) = NoExtCon+type instance XXDerivDecl    (GhcPass _) = DataConCantHappen  type instance Anno OverlapMode = SrcSpanAnnP @@ -970,7 +961,7 @@ type instance XCDefaultDecl    GhcRn = NoExtField type instance XCDefaultDecl    GhcTc = NoExtField -type instance XXDefaultDecl    (GhcPass _) = NoExtCon+type instance XXDefaultDecl    (GhcPass _) = DataConCantHappen  instance OutputableBndrId p        => Outputable (DefaultDecl (GhcPass p)) where@@ -993,7 +984,7 @@ type instance XForeignExport   GhcRn = NoExtField type instance XForeignExport   GhcTc = Coercion -type instance XXForeignDecl    (GhcPass _) = NoExtCon+type instance XXForeignDecl    (GhcPass _) = DataConCantHappen  instance OutputableBndrId p        => Outputable (ForeignDecl (GhcPass p)) where@@ -1016,15 +1007,15 @@ type instance XCRuleDecls    GhcRn = NoExtField type instance XCRuleDecls    GhcTc = NoExtField -type instance XXRuleDecls    (GhcPass _) = NoExtCon+type instance XXRuleDecls    (GhcPass _) = DataConCantHappen  type instance XHsRule       GhcPs = EpAnn HsRuleAnn type instance XHsRule       GhcRn = HsRuleRn type instance XHsRule       GhcTc = HsRuleRn -type instance XXRuleDecl    (GhcPass _) = NoExtCon+type instance XXRuleDecl    (GhcPass _) = DataConCantHappen -type instance Anno (SourceText, RuleName) = SrcSpan+type instance Anno (SourceText, RuleName) = SrcAnn NoEpAnns  data HsRuleAnn   = HsRuleAnn@@ -1042,7 +1033,7 @@  type instance XCRuleBndr    (GhcPass _) = EpAnn [AddEpAnn] type instance XRuleBndrSig  (GhcPass _) = EpAnn [AddEpAnn]-type instance XXRuleBndr    (GhcPass _) = NoExtCon+type instance XXRuleBndr    (GhcPass _) = DataConCantHappen  instance (OutputableBndrId p) => Outputable (RuleDecls (GhcPass p)) where   ppr (HsRules { rds_src = st@@ -1083,10 +1074,10 @@ type instance XWarnings      GhcRn = NoExtField type instance XWarnings      GhcTc = NoExtField -type instance XXWarnDecls    (GhcPass _) = NoExtCon+type instance XXWarnDecls    (GhcPass _) = DataConCantHappen  type instance XWarning      (GhcPass _) = EpAnn [AddEpAnn]-type instance XXWarnDecl    (GhcPass _) = NoExtCon+type instance XXWarnDecl    (GhcPass _) = DataConCantHappen   instance OutputableBndrId p@@ -1110,7 +1101,7 @@ -}  type instance XHsAnnotation (GhcPass _) = EpAnn AnnPragma-type instance XXAnnDecl     (GhcPass _) = NoExtCon+type instance XXAnnDecl     (GhcPass _) = DataConCantHappen  instance (OutputableBndrId p) => Outputable (AnnDecl (GhcPass p)) where     ppr (HsAnnotation _ _ provenance expr)@@ -1135,9 +1126,9 @@ type instance XCRoleAnnotDecl GhcRn = NoExtField type instance XCRoleAnnotDecl GhcTc = NoExtField -type instance XXRoleAnnotDecl (GhcPass _) = NoExtCon+type instance XXRoleAnnotDecl (GhcPass _) = DataConCantHappen -type instance Anno (Maybe Role) = SrcSpan+type instance Anno (Maybe Role) = SrcAnn NoEpAnns  instance OutputableBndr (IdP (GhcPass p))        => Outputable (RoleAnnotDecl (GhcPass p)) where@@ -1163,15 +1154,15 @@ 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)) = SrcSpan+type instance Anno (FamilyResultSig (GhcPass p)) = SrcAnn NoEpAnns type instance Anno (FamilyDecl (GhcPass p)) = SrcSpanAnnA-type instance Anno (InjectivityAnn (GhcPass p)) = SrcSpan+type instance Anno (InjectivityAnn (GhcPass p)) = SrcAnn NoEpAnns type instance Anno CType = SrcSpanAnnP-type instance Anno (HsDerivingClause (GhcPass p)) = SrcSpan+type instance Anno (HsDerivingClause (GhcPass p)) = SrcAnn NoEpAnns type instance Anno (DerivClauseTys (GhcPass _)) = SrcSpanAnnC type instance Anno (StandaloneKindSig (GhcPass p)) = SrcSpanAnnA type instance Anno (ConDecl (GhcPass p)) = SrcSpanAnnA-type instance Anno Bool = SrcSpan+type instance Anno Bool = SrcAnn NoEpAnns type instance Anno [LocatedA (ConDeclField (GhcPass _))] = SrcSpanAnnL type instance Anno (FamEqn p (LocatedA (HsType p))) = SrcSpanAnnA type instance Anno (TyFamInstDecl (GhcPass p)) = SrcSpanAnnA@@ -1179,18 +1170,18 @@ 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 = 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)) = SrcSpan+type instance Anno (DerivStrategy (GhcPass p)) = SrcAnn NoEpAnns 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) = SrcSpan-type instance Anno (RuleBndr (GhcPass p)) = SrcSpan+type instance Anno (SourceText, RuleName) = SrcAnn NoEpAnns+type instance Anno (RuleBndr (GhcPass p)) = SrcAnn NoEpAnns 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) = SrcSpan+type instance Anno (Maybe Role) = SrcAnn NoEpAnns
GHC/Hs/Doc.hs view
@@ -1,163 +1,288 @@-{-# LANGUAGE CPP #-}+-- | Types and functions for raw and lexed docstrings. {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE StandaloneDeriving #-}  module GHC.Hs.Doc-  ( HsDocString-  , LHsDocString-  , mkHsDocString-  , mkHsDocStringUtf8ByteString-  , isEmptyDocString-  , unpackHDS-  , hsDocStringToByteString-  , ppr_mbDoc+  ( HsDoc+  , WithHsDocIdentifiers(..)+  , hsDocIds+  , LHsDoc+  , pprHsDocDebug+  , pprWithDoc+  , pprMaybeWithDoc -  , appendDocs-  , concatDocs+  , module GHC.Hs.DocString -  , DeclDocMap(..)-  , emptyDeclDocMap+  , ExtractedTHDocs(..) -  , ArgDocMap(..)-  , emptyArgDocMap+  , DocStructureItem(..)+  , DocStructure -  , ExtractedTHDocs(..)+  , Docs(..)+  , emptyDocs   ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Utils.Binary-import GHC.Utils.Encoding import GHC.Types.Name-import GHC.Utils.Outputable as Outputable+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.Unit.Module.Name+import GHC.Driver.Flags -import Data.ByteString (ByteString)-import qualified Data.ByteString as BS-import qualified Data.ByteString.Char8 as C8+import Control.Applicative (liftA2) 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 Data.List.NonEmpty (NonEmpty(..))+import GHC.LanguageExtensions.Type+import qualified GHC.Utils.Outputable as O+import Language.Haskell.Syntax.Extension+import GHC.Hs.Extension+import GHC.Types.Unique.Map+import Data.List (sortBy) --- | Haskell Documentation String------ 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)+import GHC.Hs.DocString --- | Located Haskell Documentation String-type LHsDocString = Located HsDocString+-- | A docstring with the (probable) identifiers found in it.+type HsDoc = WithHsDocIdentifiers HsDocString -instance Binary HsDocString where-  put_ bh (HsDocString bs) = put_ bh bs-  get bh = HsDocString <$> get bh+-- | Annotate a value with the probable identifiers found in it+-- These will be used by haddock to generate links.+--+-- 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)]+  } -instance Outputable HsDocString where-  ppr = doubleQuotes . text . unpackHDS+deriving instance (Data pass, Data (IdP pass), Data a) => Data (WithHsDocIdentifiers a pass)+deriving instance (Eq (IdP pass), Eq a) => Eq (WithHsDocIdentifiers a pass) -isEmptyDocString :: HsDocString -> Bool-isEmptyDocString (HsDocString bs) = BS.null bs+-- | 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 -mkHsDocString :: String -> HsDocString-mkHsDocString s = HsDocString (utf8EncodeString s)+instance Binary a => Binary (WithHsDocIdentifiers a GhcRn) where+  put_ bh (WithHsDocIdentifiers s ids) = do+    put_ bh s+    put_ bh ids+  get bh =+    liftA2 WithHsDocIdentifiers (get bh) (get bh) --- | Create a 'HsDocString' from a UTF8-encoded 'ByteString'.-mkHsDocStringUtf8ByteString :: ByteString -> HsDocString-mkHsDocStringUtf8ByteString = HsDocString+-- | 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 -unpackHDS :: HsDocString -> String-unpackHDS = utf8DecodeByteString . hsDocStringToByteString+-- | 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) --- | Return the contents of a 'HsDocString' as a UTF8-encoded 'ByteString'.-hsDocStringToByteString :: HsDocString -> ByteString-hsDocStringToByteString (HsDocString bs) = bs+-- | See 'pprWithHsDoc'+pprMaybeWithDoc :: Maybe (LHsDoc name) -> SDoc -> SDoc+pprMaybeWithDoc Nothing    = id+pprMaybeWithDoc (Just doc) = pprWithDoc doc -ppr_mbDoc :: Maybe LHsDocString -> SDoc-ppr_mbDoc (Just doc) = ppr doc-ppr_mbDoc Nothing    = empty+-- | 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))+         ] --- | 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])+type LHsDoc pass = Located (HsDoc pass) --- | 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+-- | A simplified version of 'HsImpExp.IE'.+data DocStructureItem+  = DsiSectionHeading Int (HsDoc GhcRn)+  | DsiDocChunk (HsDoc GhcRn)+  | DsiNamedChunkRef String+  | DsiExports Avails+  | 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+      Avails --- | Docs for declarations: functions, data types, instances, methods etc.-newtype DeclDocMap = DeclDocMap (Map Name HsDocString)+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 -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+  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 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 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) -emptyDeclDocMap :: DeclDocMap-emptyDeclDocMap = DeclDocMap Map.empty+type DocStructure = [DocStructureItem] --- | Docs for arguments. E.g. function arguments, method arguments.-newtype ArgDocMap = ArgDocMap (Map Name (IntMap HsDocString))+data Docs = Docs+  { docs_mod_hdr      :: Maybe (HsDoc GhcRn)+    -- ^ Module header.+  , 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 Binary ArgDocMap where-  put_ bh (ArgDocMap m) = put_ bh (Map.toList (IntMap.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 IntMap.fromDistinctAscList . Map.fromList <$> get bh+instance Binary Docs where+  put_ bh docs = do+    put_ bh (docs_mod_hdr docs)+    put_ bh (sortBy (\a b -> (fst a) `stableNameCmp` fst b) $ nonDetEltsUniqMap $ docs_decls docs)+    put_ bh (sortBy (\a b -> (fst a) `stableNameCmp` fst b) $ nonDetEltsUniqMap $ 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+    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_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 ArgDocMap where-  ppr (ArgDocMap m) = vcat (map pprPair (Map.toAscList m))+instance Outputable Docs where+  ppr docs =+      vcat+        [ pprField (pprMaybe pprHsDocDebug) "module header" docs_mod_hdr+        , 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 (IntMap.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_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 HsDocString+    { ethd_mod_header :: Maybe (HsDoc GhcRn)       -- ^ The added module header documentation, if it exists.-    , ethd_decl_docs  :: DeclDocMap+    , ethd_decl_docs  :: UniqMap Name (HsDoc GhcRn)       -- ^ The documentation added to declarations.-    , ethd_arg_docs   :: ArgDocMap+    , ethd_arg_docs   :: UniqMap Name (IntMap (HsDoc GhcRn))       -- ^ The documentation added to function arguments.-    , ethd_inst_docs  :: DeclDocMap+    , ethd_inst_docs  :: UniqMap Name (HsDoc GhcRn)       -- ^ The documentation added to class and family instances.     }
+ GHC/Hs/DocString.hs view
@@ -0,0 +1,197 @@+-- | An exactprintable structure for docstrings+{-# LANGUAGE DeriveDataTypeable #-}++module GHC.Hs.DocString+  ( LHsDocString+  , HsDocString(..)+  , HsDocStringDecorator(..)+  , HsDocStringChunk(..)+  , LHsDocStringChunk+  , isEmptyDocString+  , unpackHDSC+  , mkHsDocStringChunk+  , mkHsDocStringChunkUtf8ByteString+  , pprHsDocString+  , pprHsDocStrings+  , mkGeneratedHsDocString+  , docStringChunks+  , renderHsDocString+  , renderHsDocStrings+  , exactPrintHsDocString+  , pprWithDocString+  ) where++import GHC.Prelude++import GHC.Utils.Binary+import GHC.Utils.Encoding+import GHC.Utils.Outputable as Outputable hiding ((<>))+import GHC.Types.SrcLoc++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++-- | 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 xs+    NestedDocString dec x -> do+      putByte bh 1+      put_ bh dec+      put_ bh x+    GeneratedDocString x -> do+      putByte bh 2+      put_ bh x+  get bh = do+    tag <- getByte bh+    case tag of+      0 -> MultiLineDocString <$> get bh <*> get bh+      1 -> NestedDocString <$> get bh <*> 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++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 continguous chunk of documentation+newtype HsDocStringChunk = HsDocStringChunk ByteString+  deriving (Eq,Ord,Data, Show)++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 (utf8EncodeString 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+-- Seperates 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
@@ -12,6 +12,7 @@ module GHC.Hs.Dump (         -- * Dumping ASTs         showAstData,+        showAstDataFull,         BlankSrcSpan(..),         BlankEpAnnotations(..),     ) where@@ -35,12 +36,18 @@ import Data.Data hiding (Fixity) import qualified Data.ByteString as B +-- | 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@@ -57,12 +64,12 @@               `extQ` annotationAddEpAnn               `extQ` annotationGrhsAnn               `extQ` annotationEpAnnHsCase-              `extQ` annotationEpAnnHsLet               `extQ` annotationAnnList               `extQ` annotationEpAnnImportDecl               `extQ` annotationAnnParen               `extQ` annotationTrailingAnn               `extQ` annotationEpaLocation+              `extQ` annotationNoEpAnns               `extQ` addEpAnn               `extQ` lit `extQ` litr `extQ` litt               `extQ` sourceText@@ -242,9 +249,6 @@             annotationEpAnnHsCase :: EpAnn EpAnnHsCase -> SDoc             annotationEpAnnHsCase = annotation' (text "EpAnn EpAnnHsCase") -            annotationEpAnnHsLet :: EpAnn AnnsLet -> SDoc-            annotationEpAnnHsLet = annotation' (text "EpAnn AnnsLet")-             annotationAnnList :: EpAnn AnnList -> SDoc             annotationAnnList = annotation' (text "EpAnn AnnList") @@ -259,6 +263,9 @@              annotationEpaLocation :: EpAnn EpaLocation -> SDoc             annotationEpaLocation = annotation' (text "EpAnn EpaLocation")++            annotationNoEpAnns :: EpAnn NoEpAnns -> SDoc+            annotationNoEpAnns = annotation' (text "EpAnn NoEpAnns")              annotation' :: forall a .(Data a, Typeable a)                        => SDoc -> EpAnn a -> SDoc
GHC/Hs/Expr.hs view
@@ -28,8 +28,6 @@   , module GHC.Hs.Expr   ) where -#include "HsVersions.h"- import Language.Haskell.Syntax.Expr  -- friends:@@ -46,21 +44,24 @@  -- others: import GHC.Tc.Types.Evidence+import GHC.Core.DataCon (FieldLabelString) import GHC.Types.Name 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.Core.ConLike import GHC.Unit.Module (ModuleName) import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Data.FastString import GHC.Core.Type import GHC.Builtin.Types (mkTupleStr)-import GHC.Tc.Utils.TcType (TcType)+import GHC.Tc.Utils.TcType (TcType, TcTyVar) import {-# SOURCE #-} GHC.Tc.Types (TcLclEnv)  -- libraries:@@ -68,8 +69,9 @@ import qualified Data.Data as Data (Fixity(..)) import qualified Data.Kind import Data.Maybe (isJust)-import Data.Void  ( Void ) import Data.Foldable ( toList )+import Data.List (uncons)+import Data.Bifunctor (first)  {- ********************************************************************* *                                                                      *@@ -173,38 +175,104 @@                 -- For a data family, these are the type args of the                 -- /representation/ type constructor -      , rupd_wrap :: HsWrapper  -- See note [Record Update HsWrapper]+      , rupd_wrap :: HsWrapper  -- See Note [Record Update HsWrapper]       }  -- | HsWrap appears only in typechecker output--- Invariant: The contained Expr is *NOT* itself an HsWrap.--- See Note [Detecting forced eta expansion] in "GHC.HsToCore.Expr".--- This invariant is maintained by 'GHC.Hs.Utils.mkHsWrap'.--- hs_syn is something like HsExpr or HsCmd 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) -type instance HsDoRn (GhcPass _) = GhcRn-type instance HsBracketRn (GhcPass _) = GhcRn-type instance PendingRnSplice' (GhcPass _) = PendingRnSplice-type instance PendingTcSplice' (GhcPass _) = PendingTcSplice- -- --------------------------------------------------------------------- -{- Note [Constructor cannot occur]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Some data constructors can't occur in certain phases; e.g. the output-of the type checker never has OverLabel. We signal this by setting-the extension field to Void. For example:-   type instance XOverLabel GhcTc = Void-   dsExpr (HsOverLabel x _) = absurd x+{-+Note [The life cycle of a TH quotation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When desugaring a bracket (aka quotation), we want to produce Core+code that, when run, will produce the TH syntax tree for the quotation.+To that end, we want to desugar /renamed/ but not /typechecked/ code;+the latter is cluttered with the typechecker's elaboration that should+not appear in the TH syntax tree. So in (HsExpr GhcTc) tree, we must+have a (HsExpr GhcRn) for the quotation itself. -It would be better to omit the pattern match altogether, but we-could only do that if the extension field was strict (#18764)+As such, when typechecking both typed and untyped brackets,+we keep a /renamed/ bracket in the extension field.++The HsBracketTc, the GhcTc ext field for both brackets, contains:+  - The renamed quote :: HsQuote GhcRn -- for the desugarer+  - [PendingTcSplice]+  - The type of the quote+  - Maybe QuoteWrapper++Note that (HsBracketTc) stores the untyped (HsQuote GhcRn) for both typed and+untyped brackets. They are treated uniformly by the desugarer, and we can+easily construct untyped brackets from typed ones (with ExpBr).++Typed quotes+~~~~~~~~~~~~+Here is the life cycle of a /typed/ quote [|| e ||], whose datacon is+  HsTypedBracket   (XTypedBracket p)   (LHsExpr p)++  In pass p   (XTypedBracket p)       (LHsExpr p)+  -------------------------------------------+  GhcPs   Annotations only            LHsExpr GhcPs+  GhcRn   Annotations only            LHsExpr GhcRn+  GhcTc   HsBracketTc                 LHsExpr GhcTc: unused!++Note that in the GhcTc tree, the second field (HsExpr GhcTc)+is entirely unused; the desugarer uses the (HsExpr GhcRn) from the+first field.++Untyped quotes+~~~~~~~~~~~~~~+Here is the life cycle of an /untyped/ quote, whose datacon is+   HsUntypedBracket (XUntypedBracket p) (HsQuote p)++Here HsQuote is a sum-type of expressions [| e |], patterns [| p |],+types [| t |] etc.++  In pass p   (XUntypedBracket p)          (HsQuote p)+  -------------------------------------------------------+  GhcPs   Annotations only                 HsQuote GhcPs+  GhcRn   Annotations, [PendingRnSplice]   HsQuote GhcRn+  GhcTc   HsBracketTc                      HsQuote GhcTc: unused!++The difficulty is: the typechecker does not typecheck the body of an+untyped quote, so how do we make a (HsQuote GhcTc) to put in the+second field?++Answer: we use the extension constructor of HsQuote, XQuote, and make+all the other constructors into DataConCantHappen.  That is, the only+non-bottom value of type (HsQuote GhcTc) is (XQuote noExtField). Hence+the instances+  type instance XExpBr GhcTc = DataConCantHappen+  ...etc...++See the related Note [How brackets and nested splices are handled] in GHC.Tc.Gen.Splice -} +data HsBracketTc = HsBracketTc+  { brack_renamed_quote   :: (HsQuote GhcRn)      -- See Note [The life cycle of a TH quotation]+  , brack_ty              :: Type+  , brack_quote_wrapper   :: (Maybe QuoteWrapper) -- The wrapper to apply type and dictionary argument to the quote.+  , brack_pending_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 = EpAnn [AddEpAnn]+type instance XTypedBracket GhcRn = NoExtField+type instance XTypedBracket GhcTc = HsBracketTc+type instance XUntypedBracket GhcPs = EpAnn [AddEpAnn]+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++-- ---------------------------------------------------------------------+ -- API Annotations types  data EpAnnHsCase = EpAnnHsCase@@ -219,15 +287,20 @@      } deriving Data  type instance XVar           (GhcPass _) = NoExtField-type instance XConLikeOut    (GhcPass _) = NoExtField-type instance XRecFld        (GhcPass _) = NoExtField++-- 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+ type instance XLam           (GhcPass _) = NoExtField  -- OverLabel not present in GhcTc pass; see GHC.Rename.Expr -- Note [Handling overloaded and rebindable constructs] type instance XOverLabel     GhcPs = EpAnnCO type instance XOverLabel     GhcRn = EpAnnCO-type instance XOverLabel     GhcTc = Void  -- See Note [Constructor cannot occur]+type instance XOverLabel     GhcTc = DataConCantHappen  -- --------------------------------------------------------------------- @@ -241,15 +314,16 @@   -- Much, much easier just to define HoleExprRef with a Data instance and   -- store the whole structure. -type instance XConLikeOut    (GhcPass _) = NoExtField-type instance XRecFld        (GhcPass _) = NoExtField-type instance XIPVar         (GhcPass _) = EpAnnCO+type instance XIPVar         GhcPs = EpAnnCO+type instance XIPVar         GhcRn = EpAnnCO+type instance XIPVar         GhcTc = DataConCantHappen type instance XOverLitE      (GhcPass _) = EpAnnCO type instance XLitE          (GhcPass _) = EpAnnCO  type instance XLam           (GhcPass _) = NoExtField  type instance XLamCase       (GhcPass _) = EpAnn [AddEpAnn]+ type instance XApp           (GhcPass _) = EpAnnCO  type instance XAppTypeE      GhcPs = SrcSpan -- Where the `@` lives@@ -260,7 +334,7 @@ -- Note [Handling overloaded and rebindable constructs] type instance XOpApp         GhcPs = EpAnn [AddEpAnn] type instance XOpApp         GhcRn = Fixity-type instance XOpApp         GhcTc = Void  -- See Note [Constructor cannot occur]+type instance XOpApp         GhcTc = DataConCantHappen  -- SectionL, SectionR not present in GhcTc pass; see GHC.Rename.Expr -- Note [Handling overloaded and rebindable constructs]@@ -268,15 +342,15 @@ type instance XSectionR      GhcPs = EpAnnCO type instance XSectionL      GhcRn = EpAnnCO type instance XSectionR      GhcRn = EpAnnCO-type instance XSectionL      GhcTc = Void  -- See Note [Constructor cannot occur]-type instance XSectionR      GhcTc = Void  -- See Note [Constructor cannot occur]+type instance XSectionL      GhcTc = DataConCantHappen+type instance XSectionR      GhcTc = DataConCantHappen   type instance XNegApp        GhcPs = EpAnn [AddEpAnn] type instance XNegApp        GhcRn = NoExtField type instance XNegApp        GhcTc = NoExtField -type instance XPar           (GhcPass _) = EpAnn AnnParen+type instance XPar           (GhcPass _) = EpAnnCO  type instance XExplicitTuple GhcPs = EpAnn [AddEpAnn] type instance XExplicitTuple GhcRn = NoExtField@@ -298,7 +372,7 @@ type instance XMultiIf       GhcRn = NoExtField type instance XMultiIf       GhcTc = Type -type instance XLet           GhcPs = EpAnn AnnsLet+type instance XLet           GhcPs = EpAnnCO type instance XLet           GhcRn = NoExtField type instance XLet           GhcTc = NoExtField @@ -327,13 +401,13 @@  type instance XGetField     GhcPs = EpAnnCO type instance XGetField     GhcRn = NoExtField-type instance XGetField     GhcTc = Void+type instance XGetField     GhcTc = DataConCantHappen -- HsGetField is eliminated by the renamer. See [Handling overloaded -- and rebindable constructs].  type instance XProjection     GhcPs = EpAnn AnnProjection type instance XProjection     GhcRn = NoExtField-type instance XProjection     GhcTc = Void+type instance XProjection     GhcTc = DataConCantHappen -- HsProjection is eliminated by the renamer. See [Handling overloaded -- and rebindable constructs]. @@ -345,38 +419,20 @@ type instance XArithSeq      GhcRn = NoExtField type instance XArithSeq      GhcTc = PostTcExpr -type instance XBracket       (GhcPass _) = EpAnn [AddEpAnn]--type instance XRnBracketOut  (GhcPass _) = NoExtField-type instance XTcBracketOut  (GhcPass _) = NoExtField- type instance XSpliceE       (GhcPass _) = EpAnnCO type instance XProc          (GhcPass _) = EpAnn [AddEpAnn]  type instance XStatic        GhcPs = EpAnn [AddEpAnn] type instance XStatic        GhcRn = NameSet-type instance XStatic        GhcTc = NameSet--type instance XTick          (GhcPass _) = NoExtField-type instance XBinTick       (GhcPass _) = NoExtField+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 XPragE         (GhcPass _) = NoExtField -type instance XXExpr         GhcPs       = NoExtCon---- See Note [Rebindable syntax and HsExpansion] below-type instance XXExpr         GhcRn       = HsExpansion (HsExpr GhcRn)-                                                       (HsExpr GhcRn)-type instance XXExpr         GhcTc       = XXExprGhcTc-- type instance Anno [LocatedA ((StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (body (GhcPass pr)))))] = SrcSpanAnnL type instance Anno (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))) = SrcSpanAnnA -data XXExprGhcTc-  = WrapExpr {-# UNPACK #-} !(HsWrap HsExpr)-  | ExpansionExpr {-# UNPACK #-} !(HsExpansion (HsExpr GhcRn) (HsExpr GhcTc))- data AnnExplicitSum   = AnnExplicitSum {       aesOpen       :: EpaLocation,@@ -385,12 +441,6 @@       aesClose      :: EpaLocation       } deriving Data -data AnnsLet-  = AnnsLet {-      alLet :: EpaLocation,-      alIn :: EpaLocation-      } deriving Data- data AnnFieldLabel   = AnnFieldLabel {       afDot :: Maybe EpaLocation@@ -414,10 +464,10 @@ -- ---------------------------------------------------------------------  type instance XSCC           (GhcPass _) = EpAnn AnnPragma-type instance XXPragE        (GhcPass _) = NoExtCon+type instance XXPragE        (GhcPass _) = DataConCantHappen -type instance XCHsFieldLabel (GhcPass _) = EpAnn AnnFieldLabel-type instance XXHsFieldLabel (GhcPass _) = NoExtCon+type instance XCDotFieldOcc (GhcPass _) = EpAnn AnnFieldLabel+type instance XXDotFieldOcc (GhcPass _) = DataConCantHappen  type instance XPresent         (GhcPass _) = EpAnn [AddEpAnn] @@ -425,12 +475,58 @@ type instance XMissing         GhcRn = NoExtField type instance XMissing         GhcTc = Scaled Type -type instance XXTupArg         (GhcPass _) = NoExtCon+type instance XXTupArg         (GhcPass _) = DataConCantHappen  tupArgPresent :: HsTupArg (GhcPass p) -> Bool tupArgPresent (Present {}) = True tupArgPresent (Missing {}) = False ++{- *********************************************************************+*                                                                      *+            XXExpr: the extension constructor of HsExpr+*                                                                      *+********************************************************************* -}++type instance XXExpr GhcPs = DataConCantHappen+type instance XXExpr GhcRn = HsExpansion (HsExpr GhcRn) (HsExpr GhcRn)+type instance XXExpr GhcTc = XXExprGhcTc+-- HsExpansion: see Note [Rebindable syntax and HsExpansion] below+++data XXExprGhcTc+  = WrapExpr        -- Type and evidence application and abstractions+      {-# UNPACK #-} !(HsWrap HsExpr)++  | ExpansionExpr   -- See Note [Rebindable syntax and HsExpansion] below+      {-# UNPACK #-} !(HsExpansion (HsExpr GhcRn) (HsExpr GhcTc))++  | 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+++{- *********************************************************************+*                                                                      *+            Pretty-printing expressions+*                                                                      *+********************************************************************* -}+ instance (OutputableBndrId p) => Outputable (HsExpr (GhcPass p)) where     ppr expr = pprExpr expr @@ -467,13 +563,12 @@          => HsExpr (GhcPass p) -> SDoc ppr_expr (HsVar _ (L _ v))   = pprPrefixOcc v ppr_expr (HsUnboundVar _ uv) = pprPrefixOcc uv-ppr_expr (HsConLikeOut _ c)  = pprPrefixOcc c-ppr_expr (HsRecFld _ f)      = pprPrefixOcc f+ppr_expr (HsRecSel _ f)      = pprPrefixOcc f 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 (HsPar _ _ e _)     = parens (ppr_lexpr e)  ppr_expr (HsPragE _ prag e) = sep [ppr prag, ppr_lexpr e] @@ -550,19 +645,19 @@ ppr_expr (HsLam _ matches)   = pprMatches matches -ppr_expr (HsLamCase _ matches)-  = sep [ sep [text "\\case"],+ppr_expr (HsLamCase _ lc_variant matches)+  = sep [ sep [lamCaseKeyword lc_variant],           nest 2 (pprMatches matches) ]  ppr_expr (HsCase _ expr matches@(MG { mg_alts = L _ alts }))-  = sep [ sep [text "case", nest 4 (ppr expr), ptext (sLit "of")],+  = 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), ptext (sLit "then")],+  = sep [hsep [text "if", nest 2 (ppr e1), text "then"],          nest 4 (ppr e2),          text "else",          nest 4 (ppr e3)]@@ -579,11 +674,11 @@         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, ptext (sLit "in")]),+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)+ppr_expr (HsLet _ _ binds _ expr)   = sep [hang (text "let") 2 (pprBinds binds),          hang (text "in")  2 (ppr expr)] @@ -619,56 +714,83 @@ ppr_expr (ArithSeq _ _ info) = brackets (ppr info)  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 _ _wrap e []) = ppr e-ppr_expr (HsTcBracketOut _ _wrap e ps) = ppr e $$ text "pending(tc)" <+> pprIfTc @p (ppr ps) +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 $$ text "pending(rn)" <+> ppr ps+    GhcTc | HsBracketTc rnq  _ty _wrap ps <- b ->+      ppr rnq `ppr_with_pending_tc_splices` ps+ ppr_expr (HsProc _ pat (L _ (HsCmdTop _ cmd)))-  = hsep [text "proc", ppr pat, ptext (sLit "->"), ppr cmd]+  = hsep [text "proc", ppr pat, text "->", ppr cmd]  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 (XExpr x) = case ghcPass @p of #if __GLASGOW_HASKELL__ < 811   GhcPs -> ppr x #endif   GhcRn -> ppr x-  GhcTc -> case x of-    WrapExpr (HsWrap co_fn e) -> pprHsWrapper co_fn-      (\parens -> if parens then pprExpr e else pprExpr e)-    ExpansionExpr e -> ppr e -- e is an HsExpansion, we print the original-                             -- expression (LHsExpr GhcPs), not the-                             -- desugared one (LHsExpr GhcT).+  GhcTc -> ppr x +instance Outputable XXExprGhcTc where+  ppr (WrapExpr (HsWrap co_fn e))+    = pprHsWrapper co_fn (\_parens -> pprExpr e)++  ppr (ExpansionExpr e)+    = ppr e -- e is an HsExpansion, we print the original+            -- expression (LHsExpr GhcPs), not the+            -- desugared one (LHsExpr GhcTc).++  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_infix_expr :: forall p. (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 (HsRecSel _ f)       = Just (pprInfixOcc f) ppr_infix_expr (HsUnboundVar _ occ) = Just (pprInfixOcc occ)-ppr_infix_expr (XExpr x)            = case (ghcPass @p, x) of+ppr_infix_expr (XExpr x)            = case ghcPass @p of #if __GLASGOW_HASKELL__ < 901-  (GhcPs, _)                              -> Nothing+                                        GhcPs -> Nothing #endif-  (GhcRn, HsExpanded a _)                 -> ppr_infix_expr a-  (GhcTc, WrapExpr (HsWrap _ e))          -> ppr_infix_expr e-  (GhcTc, ExpansionExpr (HsExpanded a _)) -> ppr_infix_expr a+                                        GhcRn -> ppr_infix_expr_rn x+                                        GhcTc -> ppr_infix_expr_tc x ppr_infix_expr _ = Nothing +ppr_infix_expr_rn :: HsExpansion (HsExpr GhcRn) (HsExpr GhcRn) -> Maybe SDoc+ppr_infix_expr_rn (HsExpanded a _) = ppr_infix_expr a++ppr_infix_expr_tc :: XXExprGhcTc -> Maybe SDoc+ppr_infix_expr_tc (WrapExpr (HsWrap _ e))          = ppr_infix_expr e+ppr_infix_expr_tc (ExpansionExpr (HsExpanded a _)) = ppr_infix_expr a+ppr_infix_expr_tc (ConLikeTc {})                   = Nothing+ppr_infix_expr_tc (HsTick {})                      = Nothing+ppr_infix_expr_tc (HsBinTick {})                   = Nothing+ ppr_apps :: (OutputableBndrId p)          => HsExpr (GhcPass p)          -> [Either (LHsExpr (GhcPass p)) (LHsWcType (NoGhcTc (GhcPass p)))]@@ -708,101 +830,112 @@ -- | @'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 p = go+hsExprNeedsParens prec = go   where+    go :: HsExpr (GhcPass p) -> Bool     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 (HsLit _ l)                    = hsLitNeedsParens prec l+    go (HsOverLit _ ol)               = hsOverLitNeedsParens prec ol     go (HsPar{})                      = False-    go (HsApp{})                      = p >= appPrec-    go (HsAppType {})                 = p >= appPrec-    go (OpApp{})                      = p >= opPrec-    go (NegApp{})                     = p > topPrec+    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)-                                      = p >= appPrec+                                      = prec >= appPrec     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 (HsLam{})                      = prec > topPrec+    go (HsLamCase{})                  = prec > topPrec+    go (HsCase{})                     = prec > topPrec+    go (HsIf{})                       = prec > topPrec+    go (HsMultiIf{})                  = prec > topPrec+    go (HsLet{})                      = prec > topPrec     go (HsDo _ sc _)-      | isComprehensionContext sc     = False-      | otherwise                     = p > topPrec+      | isDoComprehensionContext sc   = False+      | otherwise                     = prec > topPrec     go (ExplicitList{})               = False     go (RecordUpd{})                  = False-    go (ExprWithTySig{})              = p >= sigPrec+    go (ExprWithTySig{})              = prec >= sigPrec     go (ArithSeq{})                   = False-    go (HsPragE{})                    = p >= appPrec+    go (HsPragE{})                    = prec >= appPrec     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 (HsTypedBracket{})             = False+    go (HsUntypedBracket{})           = False+    go (HsProc{})                     = prec > topPrec+    go (HsStatic{})                   = prec >= appPrec     go (RecordCon{})                  = False-    go (HsRecFld{})                   = False+    go (HsRecSel{})                   = False     go (HsProjection{})               = True     go (HsGetField{})                 = False-    go (XExpr x)-      | GhcTc <- ghcPass @p-      = case x of-          WrapExpr      (HsWrap _ e)     -> go e-          ExpansionExpr (HsExpanded a _) -> hsExprNeedsParens p a-      | GhcRn <- ghcPass @p-      = case x of HsExpanded a _ -> hsExprNeedsParens p a+    go (XExpr x) = case ghcPass @p of+                     GhcTc -> go_x_tc x+                     GhcRn -> go_x_rn x #if __GLASGOW_HASKELL__ <= 900-      | otherwise-      = True+                     GhcPs -> True #endif +    go_x_tc :: XXExprGhcTc -> Bool+    go_x_tc (WrapExpr (HsWrap _ e))          = hsExprNeedsParens prec e+    go_x_tc (ExpansionExpr (HsExpanded a _)) = hsExprNeedsParens prec a+    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_rn :: HsExpansion (HsExpr GhcRn) (HsExpr GhcRn) -> Bool+    go_x_rn (HsExpanded a _) = hsExprNeedsParens prec a+++-- | Parenthesize an expression without token information+gHsPar :: LHsExpr (GhcPass id) -> HsExpr (GhcPass id)+gHsPar e = HsPar noAnn noHsTok e noHsTok+ -- | @'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 (HsPar noAnn le)+  | hsExprNeedsParens p e = L loc (gHsPar le)   | otherwise             = le  stripParensLHsExpr :: LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)-stripParensLHsExpr (L _ (HsPar _ e)) = stripParensLHsExpr e+stripParensLHsExpr (L _ (HsPar _ _ e _)) = stripParensLHsExpr e stripParensLHsExpr e = e  stripParensHsExpr :: HsExpr (GhcPass p) -> HsExpr (GhcPass p)-stripParensHsExpr (HsPar _ (L _ e)) = stripParensHsExpr e+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 (HsConLikeOut {}) = True isAtomicHsExpr (HsLit {})        = True isAtomicHsExpr (HsOverLit {})    = True isAtomicHsExpr (HsIPVar {})      = True isAtomicHsExpr (HsOverLabel {})  = True isAtomicHsExpr (HsUnboundVar {}) = True-isAtomicHsExpr (HsRecFld{})      = True+isAtomicHsExpr (HsRecSel{})      = True isAtomicHsExpr (XExpr x)-  | GhcTc <- ghcPass @p          = case x of-      WrapExpr      (HsWrap _ e)     -> isAtomicHsExpr e-      ExpansionExpr (HsExpanded a _) -> isAtomicHsExpr a-  | GhcRn <- ghcPass @p          = case x of-      HsExpanded a _         -> isAtomicHsExpr a-isAtomicHsExpr _                 = False+  | GhcTc <- ghcPass @p          = go_x_tc x+  | GhcRn <- ghcPass @p          = go_x_rn x+  where+    go_x_tc (WrapExpr      (HsWrap _ e))     = isAtomicHsExpr e+    go_x_tc (ExpansionExpr (HsExpanded a _)) = isAtomicHsExpr a+    go_x_tc (ConLikeTc {})                   = True+    go_x_tc (HsTick {}) = False+    go_x_tc (HsBinTick {}) = False +    go_x_rn (HsExpanded a _) = isAtomicHsExpr a++isAtomicHsExpr _ = False+ instance Outputable (HsPragE (GhcPass p)) where   ppr (HsPragSCC _ st (StringLiteral stl lbl _)) =     pprWithSourceText st (text "{-# SCC")@@ -820,8 +953,9 @@ {- Note [Rebindable syntax and HsExpansion] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We implement rebindable syntax (RS) support by performing a desugaring-in the renamer. We transform GhcPs expressions affected by RS into the-appropriate desugared form, but **annotated with the original expression**.+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: @@ -912,18 +1046,24 @@  --- +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 (condition, true branch, false branch 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 in an XExpr: XExpr (HsExpanded <original node> <desugared>)+      them into an expansion construct:+        for expressions, XExpr (HsExpanded <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.@@ -974,13 +1114,15 @@ -}  -- See Note [Rebindable syntax and HsExpansion] just above.-data HsExpansion a b-  = HsExpanded a b+data HsExpansion orig expanded+  = HsExpanded orig expanded   deriving Data  -- | Just print the original expression (the @a@). instance (Outputable a, Outputable b) => Outputable (HsExpansion a b) where-  ppr (HsExpanded a b) = ifPprDebug (vcat [ppr a, ppr b]) (ppr a)+  ppr (HsExpanded orig expanded)+    = ifPprDebug (vcat [ppr orig, braces (text "Expansion:" <+> ppr expanded)])+                 (ppr orig)   {-@@ -1001,7 +1143,7 @@  type instance XCmdApp     (GhcPass _) = EpAnnCO type instance XCmdLam     (GhcPass _) = NoExtField-type instance XCmdPar     (GhcPass _) = EpAnn AnnParen+type instance XCmdPar     (GhcPass _) = EpAnnCO  type instance XCmdCase    GhcPs = EpAnn EpAnnHsCase type instance XCmdCase    GhcRn = NoExtField@@ -1013,7 +1155,7 @@ type instance XCmdIf      GhcRn = NoExtField type instance XCmdIf      GhcTc = NoExtField -type instance XCmdLet     GhcPs = EpAnn AnnsLet+type instance XCmdLet     GhcPs = EpAnnCO type instance XCmdLet     GhcRn = NoExtField type instance XCmdLet     GhcTc = NoExtField @@ -1023,8 +1165,8 @@  type instance XCmdWrap    (GhcPass _) = NoExtField -type instance XXCmd       GhcPs = NoExtCon-type instance XXCmd       GhcRn = NoExtCon+type instance XXCmd       GhcPs = DataConCantHappen+type instance XXCmd       GhcRn = DataConCantHappen type instance XXCmd       GhcTc = HsWrap HsCmd  type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsCmd (GhcPass pr))))]@@ -1043,7 +1185,7 @@ type instance XCmdTop  GhcRn = CmdSyntaxTable GhcRn -- See Note [CmdSyntaxTable] type instance XCmdTop  GhcTc = CmdTopTc -type instance XXCmdTop (GhcPass _) = NoExtCon+type instance XXCmdTop (GhcPass _) = DataConCantHappen  instance (OutputableBndrId p) => Outputable (HsCmd (GhcPass p)) where     ppr cmd = pprCmd cmd@@ -1073,7 +1215,7 @@  ppr_cmd :: forall p. (OutputableBndrId p                      ) => HsCmd (GhcPass p) -> SDoc-ppr_cmd (HsCmdPar _ c) = parens (ppr_lcmd c)+ppr_cmd (HsCmdPar _ _ c _) = parens (ppr_lcmd c)  ppr_cmd (HsCmdApp _ c e)   = let (fun, args) = collect_args c [e] in@@ -1086,28 +1228,28 @@   = pprMatches matches  ppr_cmd (HsCmdCase _ expr matches)-  = sep [ sep [text "case", nest 4 (ppr expr), ptext (sLit "of")],+  = sep [ sep [text "case", nest 4 (ppr expr), text "of"],           nest 2 (pprMatches matches) ] -ppr_cmd (HsCmdLamCase _ matches)-  = sep [ text "\\case", nest 2 (pprMatches matches) ]+ppr_cmd (HsCmdLamCase _ lc_variant matches)+  = sep [ lamCaseKeyword lc_variant, nest 2 (pprMatches matches) ]  ppr_cmd (HsCmdIf _ _ e ct ce)-  = sep [hsep [text "if", nest 2 (ppr e), ptext (sLit "then")],+  = 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, ptext (sLit "in")]),+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)+ppr_cmd (HsCmdLet _ _ 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 (HsCmdDo _ (L _ stmts))  = pprArrowExpr stmts  ppr_cmd (HsCmdArrApp _ arrow arg HsFirstOrderApp True)   = hsep [ppr_lexpr arrow, larrowt, ppr_lexpr arg]@@ -1118,21 +1260,27 @@ 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 (HsCmdArrForm _ (L _ op) ps_fix rn_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+      , 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 #if __GLASGOW_HASKELL__ < 811   GhcPs -> ppr x@@ -1160,10 +1308,10 @@ type instance XMG         GhcRn b = NoExtField type instance XMG         GhcTc b = MatchGroupTc -type instance XXMatchGroup (GhcPass _) b = NoExtCon+type instance XXMatchGroup (GhcPass _) b = DataConCantHappen  type instance XCMatch (GhcPass _) b = EpAnn [AddEpAnn]-type instance XXMatch (GhcPass _) b = NoExtCon+type instance XXMatch (GhcPass _) b = DataConCantHappen  instance (OutputableBndrId pr, Outputable body)             => Outputable (Match (GhcPass pr) body) where@@ -1197,7 +1345,7 @@ -- item. So this can never be used in practice. type instance XCGRHSs (GhcPass _) _ = EpAnnComments -type instance XXGRHSs (GhcPass _) _ = NoExtCon+type instance XXGRHSs (GhcPass _) _ = DataConCantHappen  data GrhsAnn   = GrhsAnn {@@ -1209,7 +1357,7 @@                                    -- Location of matchSeparator                                    -- TODO:AZ does this belong on the GRHS, or GRHSs? -type instance XXGRHS (GhcPass _) b = NoExtCon+type instance XXGRHS (GhcPass _) b = DataConCantHappen  pprMatches :: (OutputableBndrId idR, Outputable body)            => MatchGroup (GhcPass idR) body -> SDoc@@ -1240,7 +1388,7 @@         = case ctxt of             FunRhs {mc_fun=L _ fun, mc_fixity=fixity, mc_strictness=strictness}                 | SrcStrict <- strictness-                -> ASSERT(null pats)     -- A strict variable binding+                -> assert (null pats)     -- A strict variable binding                    (char '!'<>pprPrefixOcc fun, pats)                  | Prefix <- fixity@@ -1260,6 +1408,18 @@              LambdaExpr -> (char '\\', pats) +            -- We don't simply return (empty, pats) to avoid introducing an+            -- additional `nest 2` via the empty herald+            LamCaseAlt LamCases ->+              maybe (empty, []) (first $ pprParendLPat appPrec) (uncons pats)++            ArrowMatchCtxt (ArrowLamCaseAlt LamCases) ->+              maybe (empty, []) (first $ pprParendLPat appPrec) (uncons pats)++            ArrowMatchCtxt KappaExpr -> (char '\\', pats)++            ArrowMatchCtxt ProcExpr -> (text "proc", pats)+             _ -> case pats of                    []    -> (empty, [])                    [pat] -> (ppr pat, [])  -- No parens around the single pat in a case@@ -1357,19 +1517,17 @@ type instance XRecStmt         (GhcPass _) GhcRn b = NoExtField type instance XRecStmt         (GhcPass _) GhcTc b = RecStmtTc -type instance XXStmtLR         (GhcPass _) (GhcPass _) b = NoExtCon+type instance XXStmtLR         (GhcPass _) (GhcPass _) b = DataConCantHappen  type instance XParStmtBlock  (GhcPass pL) (GhcPass pR) = NoExtField-type instance XXParStmtBlock (GhcPass pL) (GhcPass pR) = NoExtCon+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 _) = NoExtCon--type instance ApplicativeArgStmCtxPass _ = GhcRn+type instance XXApplicativeArg    (GhcPass _) = DataConCantHappen  instance (Outputable (StmtLR (GhcPass idL) (GhcPass idL) (LHsExpr (GhcPass idL))),           Outputable (XXParStmtBlock (GhcPass idL) (GhcPass idR)))@@ -1474,7 +1632,7 @@ 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)]+  = sep [ text "then group", nest 2 (pprBy by), nest 2 (text "using" <+> ppr using)]  pprBy :: Outputable body => Maybe body -> SDoc pprBy Nothing  = empty@@ -1483,17 +1641,21 @@ pprDo :: (OutputableBndrId p, Outputable body,                  Anno (StmtLR (GhcPass p) (GhcPass p) body) ~ SrcSpanAnnA          )-      => HsStmtContext any -> [LStmt (GhcPass p) body] -> SDoc+      => 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 ArrowExpr     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-pprDo _             _     = panic "pprDo" -- PatGuard, ParStmtCxt +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@@ -1542,8 +1704,8 @@ type instance XUntypedSplice (GhcPass _) = EpAnn [AddEpAnn] type instance XQuasiQuote    (GhcPass _) = NoExtField type instance XSpliced       (GhcPass _) = NoExtField-type instance XXSplice       GhcPs       = NoExtCon-type instance XXSplice       GhcRn       = NoExtCon+type instance XXSplice       GhcPs       = DataConCantHappen+type instance XXSplice       GhcRn       = DataConCantHappen type instance XXSplice       GhcTc       = HsSplicedT  -- See Note [Running typed splices in the zonker]@@ -1561,6 +1723,9 @@   toConstr  a   = mkConstr (dataTypeOf a) "DelayedSplice" [] Data.Prefix   dataTypeOf a  = mkDataType "HsExpr.DelayedSplice" [toConstr a] +-- See Note [Pending Splices]+type SplicePointName = Name+ -- | Pending Renamer Splice data PendingRnSplice   = PendingRnSplice UntypedSpliceFlavour SplicePointName (LHsExpr GhcRn)@@ -1579,21 +1744,22 @@     [| f $(g x) |] looks like -    HsBracket (HsApp (HsVar "f") (HsSpliceE _ (g x)))+    HsUntypedBracket _ (HsApp (HsVar "f") (HsSpliceE _ (HsUntypedSplice sn (g x)))  which the renamer rewrites to -    HsRnBracketOut (HsApp (HsVar f) (HsSpliceE sn (g x)))-                   [PendingRnSplice UntypedExpSplice sn (g x)]+    HsUntypedBracket+        [PendingRnSplice UntypedExpSplice sn (g x)]+        (HsApp (HsVar f) (HsSpliceE _ (HsUntypedSplice 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+* Note that a nested splice, such as the `$(g x)` now appears twice:+  - In the PendingRnSplice: this is the version that will later be typechecked+  - In the HsSpliceE in the body of the bracket. This copy is used only for pretty printing.  There are four varieties of pending splices generated by the renamer, distinguished by their UntypedSpliceFlavour@@ -1624,13 +1790,6 @@    * 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@@ -1670,8 +1829,8 @@ pprSplice (HsSpliced _ _ thing)         = ppr thing pprSplice (XSplice x)                   = case ghcPass @p of #if __GLASGOW_HASKELL__ < 811-                                            GhcPs -> noExtCon x-                                            GhcRn -> noExtCon x+                                            GhcPs -> dataConCantHappen x+                                            GhcRn -> dataConCantHappen x #endif                                             GhcTc -> case x of                                                        HsSplicedT _ -> text "Unevaluated typed splice"@@ -1686,38 +1845,61 @@ ppr_splice herald n e trail     = herald <> whenPprDebug (brackets (ppr n)) <> ppr e <> trail -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 -instance OutputableBndrId p-          => Outputable (HsBracket (GhcPass p)) where-  ppr = pprHsBracket+type instance XExpBr  GhcPs       = NoExtField+type instance XPatBr  GhcPs       = NoExtField+type instance XDecBrL GhcPs       = NoExtField+type instance XDecBrG GhcPs       = NoExtField+type instance XTypBr  GhcPs       = NoExtField+type instance XVarBr  GhcPs       = NoExtField+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 -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 (unLoc n)-pprHsBracket (VarBr _ False n)-  = text "''" <> pprPrefixOcc (unLoc n)-pprHsBracket (TExpBr _ e)  = thTyBrackets (ppr e)+-- 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+#if __GLASGOW_HASKELL__ <= 900+          GhcPs -> dataConCantHappen b+          GhcRn -> dataConCantHappen b+#endif+          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 <+> ptext (sLit "||]")+thTyBrackets pp_body = text "[||" <+> pp_body <+> text "||]"  instance Outputable PendingRnSplice where   ppr (PendingRnSplice _ n e) = pprPendingSplice n e@@ -1725,6 +1907,10 @@ instance Outputable PendingTcSplice where   ppr (PendingTcSplice n e) = pprPendingSplice n e +ppr_with_pending_tc_splices :: SDoc -> [PendingTcSplice] -> SDoc+ppr_with_pending_tc_splices x [] = x+ppr_with_pending_tc_splices x ps = x $$ text "pending(tc)" <+> ppr ps+ {- ************************************************************************ *                                                                      *@@ -1753,23 +1939,30 @@ -}  instance OutputableBndrId p => Outputable (HsMatchContext (GhcPass p)) 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 (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 m@(FunRhs{})            = text "FunRhs" <+> ppr (mc_fun m) <+> ppr (mc_fixity m)+  ppr LambdaExpr              = text "LambdaExpr"+  ppr CaseAlt                 = text "CaseAlt"+  ppr (LamCaseAlt lc_variant) = text "LamCaseAlt" <+> ppr lc_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" +instance Outputable LamCaseVariant where+  ppr = text . \case+    LamCase  -> "LamCase"+    LamCases -> "LamCases"+ instance Outputable HsArrowMatchContext where-  ppr ProcExpr     = text "ProcExpr"-  ppr ArrowCaseAlt = text "ArrowCaseAlt"-  ppr KappaExpr    = text "KappaExpr"+  ppr ProcExpr                     = text "ProcExpr"+  ppr ArrowCaseAlt                 = text "ArrowCaseAlt"+  ppr (ArrowLamCaseAlt lc_variant) = parens $ text "ArrowLamCaseAlt" <+> ppr lc_variant+  ppr KappaExpr                    = text "KappaExpr"  ----------------- @@ -1780,32 +1973,37 @@ -- Used to generate the string for a *runtime* error message matchContextErrString :: OutputableBndrId p                       => HsMatchContext (GhcPass p) -> 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 (ArrowMatchCtxt c)         = matchArrowContextErrString c-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 m))        = prependQualified m (text "'do' block")-matchContextErrString (StmtCtxt ArrowExpr)         = text "'do' block"-matchContextErrString (StmtCtxt (MDoExpr m))       = prependQualified m (text "'mdo' block")-matchContextErrString (StmtCtxt ListComp)          = text "list comprehension"-matchContextErrString (StmtCtxt MonadComp)         = text "monad comprehension"+matchContextErrString (FunRhs{mc_fun=L _ fun})      = text "function" <+> ppr fun+matchContextErrString CaseAlt                       = text "case"+matchContextErrString (LamCaseAlt lc_variant)       = lamCaseKeyword lc_variant+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 (ArrowMatchCtxt c)            = matchArrowContextErrString c+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 (ArrowExpr))        = text "'do' block"+matchContextErrString (StmtCtxt (HsDoStmt flavour)) = matchDoContextErrString flavour  matchArrowContextErrString :: HsArrowMatchContext -> SDoc-matchArrowContextErrString ProcExpr     = text "proc"-matchArrowContextErrString ArrowCaseAlt = text "case"-matchArrowContextErrString KappaExpr    = text "kappa"+matchArrowContextErrString ProcExpr                     = text "proc"+matchArrowContextErrString ArrowCaseAlt                 = text "case"+matchArrowContextErrString (ArrowLamCaseAlt lc_variant) = lamCaseKeyword lc_variant+matchArrowContextErrString KappaExpr                    = text "kappa" +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)@@ -1814,9 +2012,10 @@  pprStmtInCtxt :: (OutputableBndrId idL,                   OutputableBndrId idR,+                  OutputableBndrId ctx,                   Outputable body,                  Anno (StmtLR (GhcPass idL) (GhcPass idR) body) ~ SrcSpanAnnA)-              => HsStmtContext (GhcPass idL)+              => HsStmtContext (GhcPass ctx)               -> StmtLR (GhcPass idL) (GhcPass idR) body               -> SDoc pprStmtInCtxt ctxt (LastStmt _ e _ _)@@ -1848,13 +2047,13 @@  type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsCmd (GhcPass pr))))]   = SrcSpanAnnL-type instance Anno (HsCmdTop (GhcPass p)) = SrcSpan+type instance Anno (HsCmdTop (GhcPass p)) = SrcAnn NoEpAnns type instance Anno [LocatedA (Match (GhcPass p) (LocatedA (HsExpr (GhcPass p))))] = SrcSpanAnnL type instance Anno [LocatedA (Match (GhcPass p) (LocatedA (HsCmd  (GhcPass p))))] = SrcSpanAnnL 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 (GRHS (GhcPass p) (LocatedA (HsExpr (GhcPass p)))) = SrcSpan-type instance Anno (GRHS (GhcPass p) (LocatedA (HsCmd  (GhcPass p)))) = SrcSpan+type instance Anno (GRHS (GhcPass p) (LocatedA (HsExpr (GhcPass p)))) = SrcAnn NoEpAnns+type instance Anno (GRHS (GhcPass p) (LocatedA (HsCmd  (GhcPass p)))) = SrcAnn NoEpAnns type instance Anno (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsExpr (GhcPass pr)))) = SrcSpanAnnA type instance Anno (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsCmd  (GhcPass pr)))) = SrcSpanAnnA @@ -1862,6 +2061,10 @@  type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsExpr (GhcPass pr))))] = SrcSpanAnnL type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsCmd  (GhcPass pr))))] = SrcSpanAnnL++type instance Anno (FieldLabelStrings (GhcPass p)) = SrcAnn NoEpAnns+type instance Anno (FieldLabelString) = SrcAnn NoEpAnns+type instance Anno (DotFieldOcc (GhcPass p)) = SrcAnn NoEpAnns  instance (Anno a ~ SrcSpanAnn' (EpAnn an))    => WrapXRec (GhcPass p) a where
GHC/Hs/Extension.hs view
@@ -113,12 +113,12 @@ --   wrapXRec = noLocA  {--Note [NoExtCon and strict fields]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Note [DataConCantHappen and strict fields]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Currently, any unused TTG extension constructor will generally look like the following: -  type instance XXHsDecl (GhcPass _) = NoExtCon+  type instance XXHsDecl (GhcPass _) = DataConCantHappen   data HsDecl p     = ...     | XHsDecl !(XXHsDecl p)@@ -130,17 +130,17 @@    ex :: HsDecl GhcPs -> HsDecl GhcRn   ...-  ex (XHsDecl nec) = noExtCon nec+  ex (XHsDecl nec) = dataConCantHappen nec  Because `p` equals GhcPs (i.e., GhcPass 'Parsed), XHsDecl's field has the type-NoExtCon. But since (1) the field is strict and (2) NoExtCon 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.+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 NoExtCon, make+Bottom line: if you add a TTG extension constructor that uses DataConCantHappen, make sure that any uses of it as a field are strict. -} @@ -229,3 +229,13 @@ pprIfTc :: forall p. IsPass p => (p ~ 'Typechecked => SDoc) -> SDoc pprIfTc pp = case ghcPass @p of GhcTc -> pp                                 _     -> empty++type instance Anno (HsToken tok) = TokenLocation++noHsTok :: GenLocated TokenLocation (HsToken tok)+noHsTok = L NoTokenLoc HsTok++type instance Anno (HsUniToken tok utok) = TokenLocation++noHsUniTok :: GenLocated TokenLocation (HsUniToken tok utok)+noHsUniTok = L NoTokenLoc HsNormalTok
GHC/Hs/ImpExp.hs view
@@ -19,18 +19,18 @@ import GHC.Prelude  import GHC.Unit.Module        ( ModuleName, IsBootInterface(..) )-import GHC.Hs.Doc             ( HsDocString )-import GHC.Types.SourceText   ( SourceText(..), StringLiteral(..), pprWithSourceText )+import GHC.Hs.Doc+import GHC.Types.SourceText   ( SourceText(..) ) import GHC.Types.FieldLabel   ( FieldLabel )  import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Data.FastString import GHC.Types.SrcLoc import Language.Haskell.Syntax.Extension import GHC.Hs.Extension import GHC.Parser.Annotation import GHC.Types.Name+import GHC.Types.PkgQual  import Data.Data import Data.Maybe@@ -51,7 +51,7 @@         --         --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnSemi' -        -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+        -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation type instance Anno (ImportDecl (GhcPass p)) = SrcSpanAnnA  -- | If/how an import is 'qualified'.@@ -86,7 +86,7 @@       ideclSourceSrc :: SourceText,                                  -- Note [Pragma source text] in GHC.Types.SourceText       ideclName      :: XRec pass ModuleName, -- ^ Module name.-      ideclPkgQual   :: Maybe StringLiteral,  -- ^ Package qualifier.+      ideclPkgQual   :: ImportDeclPkgQual pass,  -- ^ Package qualifier.       ideclSource    :: IsBootInterface,      -- ^ IsBoot <=> {-\# SOURCE \#-} import       ideclSafe      :: Bool,          -- ^ True => safe import       ideclQualified :: ImportDeclQualifiedStyle, -- ^ If/how the import is qualified.@@ -111,13 +111,18 @@      --    'GHC.Parser.Annotation.AnnClose' attached      --     to location in ideclHiding -     -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+     -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation +type family ImportDeclPkgQual pass+type instance ImportDeclPkgQual GhcPs = RawPkgQual+type instance ImportDeclPkgQual GhcRn = PkgQual+type instance ImportDeclPkgQual GhcTc = PkgQual+ type instance XCImportDecl  GhcPs = EpAnn EpAnnImportDecl type instance XCImportDecl  GhcRn = NoExtField type instance XCImportDecl  GhcTc = NoExtField -type instance XXImportDecl  (GhcPass _) = NoExtCon+type instance XXImportDecl  (GhcPass _) = DataConCantHappen  type instance Anno ModuleName = SrcSpanAnnA type instance Anno [LocatedA (IE (GhcPass p))] = SrcSpanAnnL@@ -142,7 +147,7 @@       ideclExt       = noAnn,       ideclSourceSrc = NoSourceText,       ideclName      = noLocA mn,-      ideclPkgQual   = Nothing,+      ideclPkgQual   = NoRawPkgQual,       ideclSource    = NotBoot,       ideclSafe      = False,       ideclImplicit  = False,@@ -152,7 +157,8 @@     }  instance (OutputableBndrId p-         , Outputable (Anno (IE (GhcPass p))))+         , Outputable (Anno (IE (GhcPass p)))+         , Outputable (ImportDeclPkgQual (GhcPass p)))        => Outputable (ImportDecl (GhcPass p)) where     ppr (ImportDecl { ideclSourceSrc = mSrcText, ideclName = mod'                     , ideclPkgQual = pkg@@ -160,15 +166,11 @@                     , 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])+                    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 True = text "(implicit)"          pp_qual QualifiedPre False = text "qualified" -- Prepositive qualifier/prepositive position.         pp_qual QualifiedPost True = text "qualified" -- Postpositive qualifier/postpositive position.@@ -217,7 +219,7 @@ -- - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnType', --         'GHC.Parser.Annotation.AnnPattern' type LIEWrappedName name = LocatedA (IEWrappedName name)--- For details on above see note [exact print annotations] in GHC.Parser.Annotation+-- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   -- | Located Import or Export@@ -226,7 +228,7 @@         --         --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnComma' -        -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+        -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation type instance Anno (IE (GhcPass p)) = SrcSpanAnnA  -- | Imported or exported entity.@@ -241,7 +243,7 @@         --  - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnPattern',         --             'GHC.Parser.Annotation.AnnType','GHC.Parser.Annotation.AnnVal' -        -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+        -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation         -- See Note [Located RdrNames] in GHC.Hs.Expr   | IEThingAll  (XIEThingAll pass) (LIEWrappedName (IdP pass))         -- ^ Imported or exported Thing with All imported or exported@@ -252,7 +254,7 @@         --       'GHC.Parser.Annotation.AnnDotdot','GHC.Parser.Annotation.AnnClose',         --                                 'GHC.Parser.Annotation.AnnType' -        -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+        -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation         -- See Note [Located RdrNames] in GHC.Hs.Expr    | IEThingWith (XIEThingWith pass)@@ -268,7 +270,7 @@         --                                   'GHC.Parser.Annotation.AnnComma',         --                                   'GHC.Parser.Annotation.AnnType' -        -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+        -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   | IEModuleContents  (XIEModuleContents pass) (XRec pass ModuleName)         -- ^ Imported or exported module contents         --@@ -276,9 +278,9 @@         --         -- - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnModule' -        -- For details on above see note [exact print annotations] in GHC.Parser.Annotation-  | IEGroup             (XIEGroup pass) Int HsDocString -- ^ Doc section heading-  | IEDoc               (XIEDoc pass) HsDocString       -- ^ Some documentation+        -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation+  | IEGroup             (XIEGroup pass) Int (LHsDoc pass) -- ^ Doc section heading+  | IEDoc               (XIEDoc pass) (LHsDoc pass)       -- ^ Some documentation   | IEDocNamed          (XIEDocNamed pass) String    -- ^ Reference to named doc   | XIE !(XXIE pass) @@ -301,7 +303,7 @@ type instance XIEGroup           (GhcPass _) = NoExtField type instance XIEDoc             (GhcPass _) = NoExtField type instance XIEDocNamed        (GhcPass _) = NoExtField-type instance XXIE               (GhcPass _) = NoExtCon+type instance XXIE               (GhcPass _) = DataConCantHappen  type instance Anno (LocatedA (IE (GhcPass p))) = SrcSpanAnnA
GHC/Hs/Instances.hs view
@@ -63,11 +63,10 @@ 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)@@ -278,9 +277,9 @@ deriving instance Data (FieldLabelStrings GhcRn) deriving instance Data (FieldLabelStrings GhcTc) -deriving instance Data (HsFieldLabel GhcPs)-deriving instance Data (HsFieldLabel GhcRn)-deriving instance Data (HsFieldLabel 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)@@ -368,6 +367,8 @@  deriving instance Data HsArrowMatchContext +deriving instance Data HsDoFlavour+ deriving instance Data (HsMatchContext GhcPs) deriving instance Data (HsMatchContext GhcRn) deriving instance Data (HsMatchContext GhcTc)@@ -382,11 +383,13 @@ deriving instance Data (HsSplicedThing GhcRn) deriving instance Data (HsSplicedThing GhcTc) --- 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 (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)@@ -415,6 +418,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 ------------------------------------ @@ -423,12 +429,9 @@ deriving instance Data (Pat GhcRn) deriving instance Data (Pat GhcTc) -deriving instance Data CoPat deriving instance Data ConPatTc -deriving instance Data ListPatTc--deriving instance (Data a, Data b) => Data (HsRecField' a b)+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)@@ -477,6 +480,11 @@ deriving instance Data (HsType GhcRn) deriving instance Data (HsType GhcTc) +-- deriving instance Data (HsLinearArrowTokens p)+deriving instance Data (HsLinearArrowTokens GhcPs)+deriving instance Data (HsLinearArrowTokens GhcRn)+deriving instance Data (HsLinearArrowTokens GhcTc)+ -- deriving instance (DataIdLR p p) => Data (HsArrow p) deriving instance Data (HsArrow GhcPs) deriving instance Data (HsArrow GhcRn)@@ -526,6 +534,7 @@ -- ---------------------------------------------------------------------  deriving instance Data XXExprGhcTc+deriving instance Data XXPatGhcTc  -- ---------------------------------------------------------------------
GHC/Hs/Lit.hs view
@@ -1,11 +1,11 @@-{-# LANGUAGE CPP                  #-} {-# LANGUAGE ConstraintKinds      #-}-{-# LANGUAGE DeriveDataTypeable   #-} {-# 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 @@ -21,8 +21,6 @@   , module GHC.Hs.Lit   ) where -#include "HsVersions.h"- import GHC.Prelude  import {-# SOURCE #-} GHC.Hs.Expr( pprExpr )@@ -32,11 +30,10 @@ import GHC.Types.SourceText import GHC.Core.Type import GHC.Utils.Outputable+import Language.Haskell.Syntax.Expr ( HsExpr ) import Language.Haskell.Syntax.Extension import GHC.Hs.Extension -import Data.Data hiding ( Fixity )- {- ************************************************************************ *                                                                      *@@ -58,22 +55,53 @@ type instance XHsRat        (GhcPass _) = NoExtField type instance XHsFloatPrim  (GhcPass _) = NoExtField type instance XHsDoublePrim (GhcPass _) = NoExtField-type instance XXLit         (GhcPass _) = NoExtCon+type instance XXLit         (GhcPass _) = DataConCantHappen +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+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 +type instance XXOverLit (GhcPass _) = DataConCantHappen+ overLitType :: HsOverLit GhcTc -> Type-overLitType (OverLit (OverLitTc _ ty) _ _) = ty+overLitType (OverLit OverLitTc{ ol_type = ty } _) = ty  -- | Convert a literal from one index type to another convertLit :: HsLit (GhcPass p1) -> HsLit (GhcPass p2)@@ -97,8 +125,8 @@ 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@@ -130,8 +158,8 @@ -- 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 (OverLit {ol_val=val, ol_ext=ext})+        = ppr val <+> (whenPprDebug (parens (pprXOverLit (ghcPass @p) ext)))  -- | pmPprHsLit pretty prints literals and is used when pretty printing pattern -- match warnings. All are printed the same (i.e., without hashes if they are
GHC/Hs/Pat.hs view
@@ -23,12 +23,12 @@         Pat(..), LPat,         EpAnnSumPat(..),         ConPatTc (..),-        CoPat (..),-        ListPatTc(..),         ConLikeP,+        HsPatExpansion(..),+        XXPatGhcTc(..),          HsConPatDetails, hsConPatArgs,-        HsRecFields(..), HsRecField'(..), LHsRecField',+        HsRecFields(..), HsFieldBind(..), LHsFieldBind,         HsRecField, LHsRecField,         HsRecUpdField, LHsRecUpdField,         hsRecFields, hsRecFieldSel, hsRecFieldId, hsRecFieldsArgs,@@ -39,7 +39,7 @@         isSimplePat,         looksLazyPatBind,         isBangedLPat,-        patNeedsParens, parenthesizePat,+        gParPat, patNeedsParens, parenthesizePat,         isIrrefutableHsPat,          collectEvVarsPat, collectEvVarsPats,@@ -51,7 +51,7 @@ import GHC.Prelude  import Language.Haskell.Syntax.Pat-import Language.Haskell.Syntax.Expr (HsExpr, SyntaxExpr)+import Language.Haskell.Syntax.Expr ( HsExpr )  import {-# SOURCE #-} GHC.Hs.Expr (pprLExpr, pprSplice) @@ -84,11 +84,6 @@ import Data.Data  -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@@ -103,18 +98,21 @@ type instance XAsPat   GhcRn = NoExtField type instance XAsPat   GhcTc = NoExtField -type instance XParPat  (GhcPass _) = EpAnn AnnParen+type instance XParPat (GhcPass _) = EpAnnCO  type instance XBangPat GhcPs = EpAnn [AddEpAnn] -- For '!' type instance XBangPat GhcRn = NoExtField type instance XBangPat GhcTc = 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 = EpAnn AnnList-type instance XListPat GhcRn = Maybe (SyntaxExpr GhcRn)-type instance XListPat GhcTc = ListPatTc+  -- 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 = EpAnn [AddEpAnn] type instance XTuplePat GhcRn = NoExtField@@ -129,10 +127,19 @@ type instance XConPat GhcTc = ConPatTc  type instance XViewPat GhcPs = EpAnn [AddEpAnn]-type instance XViewPat GhcRn = NoExtField+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 (GhcPass _) = NoExtField+type instance XSplicePat GhcPs = NoExtField+type instance XSplicePat GhcRn = NoExtField+type instance XSplicePat GhcTc = DataConCantHappen+ type instance XLitPat    (GhcPass _) = NoExtField  type instance XNPat GhcPs = EpAnn [AddEpAnn]@@ -147,16 +154,20 @@ type instance XSigPat GhcRn = NoExtField type instance XSigPat GhcTc = Type -type instance XXPat GhcPs = NoExtCon-type instance XXPat GhcRn = NoExtCon-type instance XXPat GhcTc = CoPat-  -- After typechecking, we add one extra constructor: CoPat+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 HsExpansion].+type instance XXPat GhcTc = XXPatGhcTc+  -- After typechecking, we add extra constructors: CoPat and HsExpansion.+  -- HsExpansion allows us to handle RebindableSyntax in pattern position:+  -- see "XXExpr GhcTc" for the counterpart in expressions.  type instance ConLikeP GhcPs = RdrName -- IdP GhcPs type instance ConLikeP GhcRn = Name    -- IdP GhcRn type instance ConLikeP GhcTc = ConLike -type instance XHsRecField _ = EpAnn [AddEpAnn]+type instance XHsFieldBind _ = EpAnn [AddEpAnn]  -- --------------------------------------------------------------------- @@ -170,6 +181,35 @@  -- --------------------------------------------------------------------- +-- | 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 HsExpansion].+  | ExpansionPat (Pat GhcRn) (Pat GhcTc)+++-- See Note [Rebindable syntax and HsExpansion].+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@@ -192,41 +232,23 @@     , -- | Bindings involving those dictionaries       cpt_binds :: TcEvBinds -    , -- ^ Extra wrapper to pass to the matcher+    , -- | Extra wrapper to pass to the matcher       -- Only relevant for pattern-synonyms;       --   ignored for data cons       cpt_wrap  :: HsWrapper     } --- | 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'.-data CoPat-  = 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-    }--hsRecFieldId :: HsRecField GhcTc arg -> Located Id+hsRecFieldId :: HsRecField GhcTc arg -> Id hsRecFieldId = hsRecFieldSel  hsRecUpdFieldRdr :: HsRecUpdField (GhcPass p) -> Located RdrName-hsRecUpdFieldRdr = fmap rdrNameAmbiguousFieldOcc . hsRecFieldLbl+hsRecUpdFieldRdr = fmap rdrNameAmbiguousFieldOcc . reLoc . hfbLHS -hsRecUpdFieldId :: HsRecField' (AmbiguousFieldOcc GhcTc) arg -> Located Id-hsRecUpdFieldId = fmap extFieldOcc . hsRecUpdFieldOcc+hsRecUpdFieldId :: HsFieldBind (LAmbiguousFieldOcc GhcTc) arg -> Located Id+hsRecUpdFieldId = fmap foExt . reLoc . hsRecUpdFieldOcc -hsRecUpdFieldOcc :: HsRecField' (AmbiguousFieldOcc GhcTc) arg -> LFieldOcc GhcTc-hsRecUpdFieldOcc = fmap unambiguousFieldOcc . hsRecFieldLbl+hsRecUpdFieldOcc :: HsFieldBind (LAmbiguousFieldOcc GhcTc) arg -> LFieldOcc GhcTc+hsRecUpdFieldOcc = fmap unambiguousFieldOcc . hfbLHS   {-@@ -240,6 +262,10 @@ instance OutputableBndrId p => Outputable (Pat (GhcPass p)) where     ppr = pprPat +-- See Note [Rebindable syntax and HsExpansion].+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 @@ -266,8 +292,7 @@   where     need_parens print_tc_elab pat       | GhcTc <- ghcPass @p-      , XPat ext <- pat-      , CoPat {} <- ext+      , XPat (CoPat {}) <- pat       = print_tc_elab        | otherwise@@ -285,7 +310,7 @@ 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 (ParPat _ _ pat _)      = parens (ppr pat) pprPat (LitPat _ s)             = ppr s pprPat (NPat _ l Nothing  _)    = ppr l pprPat (NPat _ l (Just _) _)    = char '-' <> ppr l@@ -330,14 +355,17 @@  pprPat (XPat ext) = case ghcPass @p of #if __GLASGOW_HASKELL__ < 811-  GhcPs -> noExtCon ext-  GhcRn -> noExtCon ext+  GhcPs -> dataConCantHappen ext #endif-  GhcTc -> pprHsWrapper co $ \parens ->-      if parens-      then pprParendPat appPrec pat-      else pprPat pat-    where CoPat co pat _ = ext+  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)))@@ -420,11 +448,11 @@ isBangedLPat = isBangedPat . unLoc  isBangedPat :: Pat (GhcPass p) -> Bool-isBangedPat (ParPat _ p) = isBangedLPat p+isBangedPat (ParPat _ _ p _) = isBangedLPat p isBangedPat (BangPat {}) = True isBangedPat _            = False -looksLazyPatBind :: HsBind (GhcPass p) -> Bool+looksLazyPatBind :: HsBind GhcTc -> Bool -- Returns True of anything *except* --     a StrictHsBind (as above) or --     a VarPat@@ -432,7 +460,7 @@ -- Looks through AbsBinds looksLazyPatBind (PatBind { pat_lhs = p })   = looksLazyLPat p-looksLazyPatBind (AbsBinds { abs_binds = binds })+looksLazyPatBind (XHsBindsLR (AbsBinds { abs_binds = binds }))   = anyBag (looksLazyPatBind . unLoc) binds looksLazyPatBind _   = False@@ -441,8 +469,8 @@ looksLazyLPat = looksLazyPat . unLoc  looksLazyPat :: Pat (GhcPass p) -> Bool-looksLazyPat (ParPat _ p)  = looksLazyLPat p-looksLazyPat (AsPat _ _ p) = looksLazyLPat p+looksLazyPat (ParPat _ _ p _)  = looksLazyLPat p+looksLazyPat (AsPat _ _ p)     = looksLazyLPat p looksLazyPat (BangPat {})  = False looksLazyPat (VarPat {})   = False looksLazyPat (WildPat {})  = False@@ -508,7 +536,7 @@       = isIrrefutableHsPat' False p'       | otherwise          = True     go (BangPat _ pat)     = goL pat-    go (ParPat _ pat)      = goL pat+    go (ParPat _ _ pat _)  = goL pat     go (AsPat _ _ pat)     = goL pat     go (ViewPat _ _ pat)   = goL pat     go (SigPat _ pat _)    = goL pat@@ -538,11 +566,13 @@      go (XPat ext)          = case ghcPass @p of #if __GLASGOW_HASKELL__ < 811-      GhcPs -> noExtCon ext-      GhcRn -> noExtCon ext+      GhcPs -> dataConCantHappen ext #endif-      GhcTc -> go pat-        where CoPat _ pat _ = ext+      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: --@@ -553,7 +583,7 @@ -- - x (variable) isSimplePat :: LPat (GhcPass x) -> Maybe (IdP (GhcPass x)) isSimplePat p = case unLoc p of-  ParPat _ x -> isSimplePat x+  ParPat _ _ x _ -> isSimplePat x   SigPat _ x _ -> isSimplePat x   LazyPat _ x -> isSimplePat x   BangPat _ x -> isSimplePat x@@ -586,22 +616,28 @@ -- | @'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+patNeedsParens p = go @p   where-    go :: Pat (GhcPass p) -> Bool+    -- 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 (SplicePat {})    = False     go (ConPat { pat_args = ds })                          = conPatNeedsParens p ds     go (SigPat {})       = p >= sigPrec     go (ViewPat {})      = True-    go (XPat ext)        = case ghcPass @p of+    go (XPat ext)        = case ghcPass @q of #if __GLASGOW_HASKELL__ < 901-      GhcPs -> noExtCon ext-      GhcRn -> noExtCon ext+      GhcPs -> dataConCantHappen ext #endif-      GhcTc -> go inner-        where CoPat _ inner _ = ext+      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@@ -628,6 +664,11 @@     go (InfixCon {})       = p >= opPrec -- type args should be empty in this case     go (RecCon {})         = False ++-- | Parenthesize a pattern without token information+gParPat :: LPat (GhcPass pass) -> Pat (GhcPass pass)+gParPat p = ParPat noAnn noHsTok p noHsTok+ -- | @'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@@ -635,7 +676,7 @@                 -> LPat (GhcPass p)                 -> LPat (GhcPass p) parenthesizePat p lpat@(L loc pat)-  | patNeedsParens p pat = L loc (ParPat noAnn lpat)+  | patNeedsParens p pat = L loc (gParPat lpat)   | otherwise            = lpat  {-@@ -654,7 +695,7 @@   case pat of     LazyPat _ p      -> collectEvVarsLPat p     AsPat _ _ p      -> collectEvVarsLPat p-    ParPat  _ p      -> collectEvVarsLPat p+    ParPat  _ _ p _  -> collectEvVarsLPat p     BangPat _ p      -> collectEvVarsLPat p     ListPat _ ps     -> unionManyBags $ map collectEvVarsLPat ps     TuplePat _ ps _  -> unionManyBags $ map collectEvVarsLPat ps@@ -670,7 +711,9 @@                                    $ map collectEvVarsLPat                                    $ hsConPatArgs args     SigPat  _ p _    -> collectEvVarsLPat p-    XPat (CoPat _ p _) -> collectEvVarsPat  p+    XPat ext -> case ext of+      CoPat _ p _      -> collectEvVarsPat p+      ExpansionPat _ p -> collectEvVarsPat p     _other_pat       -> emptyBag  {-@@ -682,14 +725,6 @@ -}  type instance Anno (Pat (GhcPass p)) = SrcSpanAnnA-type instance Anno (HsOverLit (GhcPass p)) = SrcSpan+type instance Anno (HsOverLit (GhcPass p)) = SrcAnn NoEpAnns type instance Anno ConLike = SrcSpanAnnN--type instance Anno (HsRecField' p arg) = SrcSpanAnnA-type instance Anno (HsRecField' (GhcPass p) (LocatedA (HsExpr (GhcPass p)))) = SrcSpanAnnA-type instance Anno (HsRecField  (GhcPass p) arg) = SrcSpanAnnA---- type instance Anno (HsRecUpdField p) = SrcSpanAnnA-type instance Anno (HsRecField' (AmbiguousFieldOcc p) (LocatedA (HsExpr p))) = SrcSpanAnnA--type instance Anno (AmbiguousFieldOcc GhcTc) = SrcSpanAnnA+type instance Anno (HsFieldBind lhs rhs) = SrcSpanAnnA
+ GHC/Hs/Syn/Type.hs view
@@ -0,0 +1,203 @@+-- | 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.Core.Utils+import GHC.Hs+import GHC.Tc.Types.Evidence+import GHC.Types.Id+import GHC.Types.SrcLoc+import GHC.Utils.Outputable+import GHC.Utils.Panic++{-+************************************************************************+*                                                                      *+       Extracting the type from HsSyn+*                                                                      *+************************************************************************++-}++hsLPatType :: LPat GhcTc -> Type+hsLPatType (L _ p) = hsPatType p++hsPatType :: Pat GhcTc -> Type+hsPatType (ParPat _ _ pat _)            = hsLPatType pat+hsPatType (WildPat ty)                  = ty+hsPatType (VarPat _ lvar)               = idType (unLoc lvar)+hsPatType (BangPat _ pat)               = hsLPatType pat+hsPatType (LazyPat _ pat)               = hsLPatType pat+hsPatType (LitPat _ lit)                = hsLitType lit+hsPatType (AsPat _ var _)               = idType (unLoc var)+hsPatType (ViewPat ty _ _)              = ty+hsPatType (ListPat ty _)                = mkListTy ty+hsPatType (TuplePat tys _ bx)           = mkTupleTy1 bx tys+                  -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make+hsPatType (SumPat tys _ _ _ )           = mkSumTy tys+hsPatType (ConPat { pat_con = lcon+                  , pat_con_ext = ConPatTc+                    { cpt_arg_tys = tys+                    }+                  })+                                        = conLikeResTy (unLoc lcon) tys+hsPatType (SigPat ty _ _)               = ty+hsPatType (NPat ty _ _ _)               = ty+hsPatType (NPlusKPat ty _ _ _ _ _)      = ty+hsPatType (XPat ext) =+  case ext of+    CoPat _ _ ty       -> ty+    ExpansionPat _ pat -> hsPatType pat+hsPatType (SplicePat v _)               = dataConCantHappen v++hsLitType :: HsLit (GhcPass p) -> Type+hsLitType (HsChar _ _)       = charTy+hsLitType (HsCharPrim _ _)   = charPrimTy+hsLitType (HsString _ _)     = stringTy+hsLitType (HsStringPrim _ _) = addrPrimTy+hsLitType (HsInt _ _)        = intTy+hsLitType (HsIntPrim _ _)    = intPrimTy+hsLitType (HsWordPrim _ _)   = wordPrimTy+hsLitType (HsInt64Prim _ _)  = int64PrimTy+hsLitType (HsWord64Prim _ _) = word64PrimTy+hsLitType (HsInteger _ _ ty) = ty+hsLitType (HsRat _ _ ty)     = ty+hsLitType (HsFloatPrim _ _)  = floatPrimTy+hsLitType (HsDoublePrim _ _) = doublePrimTy+++-- | Compute the 'Type' of an @'LHsExpr' 'GhcTc'@ in a pure fashion.+lhsExprType :: LHsExpr GhcTc -> Type+lhsExprType (L _ e) = hsExprType e++-- | Compute the 'Type' of an @'HsExpr' 'GhcTc'@ in a pure fashion.+hsExprType :: HsExpr GhcTc -> Type+hsExprType (HsVar _ (L _ id)) = idType id+hsExprType (HsUnboundVar (HER _ ty _) _) = ty+hsExprType (HsRecSel _ (FieldOcc id _)) = idType id+hsExprType (HsOverLabel v _) = dataConCantHappen v+hsExprType (HsIPVar v _) = dataConCantHappen v+hsExprType (HsOverLit _ lit) = overLitType lit+hsExprType (HsLit _ lit) = hsLitType lit+hsExprType (HsLam     _ (MG { mg_ext = match_group })) = matchGroupTcType match_group+hsExprType (HsLamCase _ _ (MG { mg_ext = match_group })) = matchGroupTcType match_group+hsExprType (HsApp _ f _) = funResultTy $ lhsExprType f+hsExprType (HsAppType x f _) = piResultTy (lhsExprType f) x+hsExprType (OpApp v _ _ _) = dataConCantHappen v+hsExprType (NegApp _ _ se) = syntaxExprType se+hsExprType (HsPar _ _ e _) = lhsExprType e+hsExprType (SectionL v _ _) = dataConCantHappen v+hsExprType (SectionR v _ _) = dataConCantHappen v+hsExprType (ExplicitTuple _ args box) = mkTupleTy box $ map hsTupArgType args+hsExprType (ExplicitSum alt_tys _ _ _) = mkSumTy alt_tys+hsExprType (HsCase _ _ (MG { mg_ext = match_group })) = mg_res_ty match_group+hsExprType (HsIf _ _ t _) = lhsExprType t+hsExprType (HsMultiIf ty _) = ty+hsExprType (HsLet _ _ _ _ body) = lhsExprType body+hsExprType (HsDo ty _ _) = ty+hsExprType (ExplicitList ty _) = mkListTy ty+hsExprType (RecordCon con_expr _ _) = hsExprType con_expr+hsExprType e@(RecordUpd (RecordUpdTc { rupd_cons = cons, rupd_out_tys = out_tys }) _ _) =+  case cons of+    con_like:_ -> conLikeResTy con_like out_tys+    []         -> pprPanic "hsExprType: RecordUpdTc with empty rupd_cons"+                           (ppr e)+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 _ ty _wrap _pending) _) = ty+hsExprType (HsUntypedBracket (HsBracketTc _ ty _wrap _pending) _) = ty+hsExprType e@(HsSpliceE{}) = pprPanic "hsExprType: Unexpected HsSpliceE"+                                      (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 (HsProc _ _ lcmd_top) = lhsCmdTopType lcmd_top+hsExprType (HsStatic (_, ty) _s) = ty+hsExprType (HsPragE _ _ e) = lhsExprType e+hsExprType (XExpr (WrapExpr (HsWrap wrap e))) = hsWrapperType wrap $ hsExprType e+hsExprType (XExpr (ExpansionExpr (HsExpanded _ tc_e))) = hsExprType tc_e+hsExprType (XExpr (ConLikeTc con _ _)) = conLikeType con+hsExprType (XExpr (HsTick _ e)) = lhsExprType e+hsExprType (XExpr (HsBinTick _ _ e)) = lhsExprType e++arithSeqInfoType :: ArithSeqInfo GhcTc -> Type+arithSeqInfoType asi = mkListTy $ case asi of+  From x           -> lhsExprType x+  FromThen x _     -> lhsExprType x+  FromTo x _       -> lhsExprType x+  FromThenTo x _ _ -> lhsExprType x++conLikeType :: ConLike -> Type+conLikeType (RealDataCon con)  = dataConNonlinearType con+conLikeType (PatSynCon patsyn) = case patSynBuilder patsyn of+    Just (_, ty, _) -> ty+    Nothing         -> pprPanic "conLikeType: Unidirectional pattern synonym in expression position"+                                (ppr patsyn)++hsTupArgType :: HsTupArg GhcTc -> Type+hsTupArgType (Present _ e)           = lhsExprType e+hsTupArgType (Missing (Scaled _ ty)) = ty+++-- | The PRType (ty, tas) is short for (piResultTys ty (reverse tas))+type PRType = (Type, [Type])++prTypeType :: PRType -> Type+prTypeType (ty, tys)+  | null tys  = ty+  | otherwise = piResultTys ty (reverse tys)++liftPRType :: (Type -> Type) -> PRType -> PRType+liftPRType f pty = (f (prTypeType pty), [])++hsWrapperType :: HsWrapper -> Type -> Type+hsWrapperType wrap ty = prTypeType $ go wrap (ty,[])+  where+    go WpHole              = id+    go (w1 `WpCompose` w2) = go w1 . go w2+    go (WpFun _ w2 (Scaled m exp_arg)) = liftPRType $ \t ->+      let act_res = funResultTy t+          exp_res = hsWrapperType w2 act_res+      in mkFunctionType m exp_arg exp_res+    go (WpCast co)        = liftPRType $ \_ -> coercionRKind co+    go (WpEvLam v)        = liftPRType $ mkInvisFunTyMany (idType v)+    go (WpEvApp _)        = liftPRType $ funResultTy+    go (WpTyLam tv)       = liftPRType $ mkForAllTy tv Inferred+    go (WpTyApp ta)       = \(ty,tas) -> (ty, ta:tas)+    go (WpLet _)          = id+    go (WpMultCoercion _) = id++lhsCmdTopType :: LHsCmdTop GhcTc -> Type+lhsCmdTopType (L _ (HsCmdTop (CmdTopTc _ ret_ty _) _)) = ret_ty++matchGroupTcType :: MatchGroupTc -> Type+matchGroupTcType (MatchGroupTc args res) = mkVisFunTys args res++syntaxExprType :: SyntaxExpr GhcTc -> Type+syntaxExprType (SyntaxExprTc e _ _) = hsExprType e+syntaxExprType NoSyntaxExprTc       = panic "syntaxExprType: Unexpected NoSyntaxExprTc"
GHC/Hs/Type.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}@@ -24,7 +24,9 @@         Mult, HsScaled(..),         hsMult, hsScaledThing,         HsArrow(..), arrowToHsType,+        HsLinearArrowTokens(..),         hsLinear, hsUnrestricted, isUnrestricted,+        pprHsArrow,          HsType(..), HsCoreTy, LHsType, HsKind, LHsKind,         HsForAllTelescope(..), EpAnnForallTy, HsTyVarBndr(..), LHsTyVarBndr,@@ -37,7 +39,7 @@         HsContext, LHsContext, fromMaybeContext,         HsTyLit(..),         HsIPName(..), hsIPNameFS,-        HsArg(..), numVisibleArgs,+        HsArg(..), numVisibleArgs, pprHsArgsApp,         LHsTypeArg, lhsTypeArgSrcSpan,         OutputableBndrFlag, @@ -51,7 +53,7 @@         HsConDetails(..), noTypeArgs,          FieldOcc(..), LFieldOcc, mkFieldOcc,-        AmbiguousFieldOcc(..), mkAmbiguousFieldOcc,+        AmbiguousFieldOcc(..), LAmbiguousFieldOcc, mkAmbiguousFieldOcc,         rdrNameAmbiguousFieldOcc, selectorAmbiguousFieldOcc,         unambiguousFieldOcc, ambiguousFieldOcc, @@ -85,8 +87,6 @@         hsTypeNeedsParens, parenthesizeHsType, parenthesizeHsContext     ) where -#include "HsVersions.h"- import GHC.Prelude  import Language.Haskell.Syntax.Type@@ -97,6 +97,7 @@ import GHC.Hs.Extension import GHC.Parser.Annotation +import GHC.Types.Fixity ( LexicalFixity(..) ) import GHC.Types.Id ( Id ) import GHC.Types.SourceText import GHC.Types.Name( Name, NamedThing(getName) )@@ -104,6 +105,7 @@ import GHC.Types.Var ( VarBndr ) import GHC.Core.TyCo.Rep ( Type(..) ) import GHC.Builtin.Types( manyDataConName, oneDataConName, mkTupleStr )+import GHC.Core.Ppr ( pprOccWithTick) import GHC.Core.Type import GHC.Hs.Doc import GHC.Types.Basic@@ -149,7 +151,7 @@ type instance XHsForAllInvis (GhcPass _) = EpAnnForallTy                                            -- Location of 'forall' and '.' -type instance XXHsForAllTelescope (GhcPass _) = NoExtCon+type instance XXHsForAllTelescope (GhcPass _) = DataConCantHappen  type EpAnnForallTy = EpAnn (AddEpAnn, AddEpAnn)   -- ^ Location of 'forall' and '->' for HsForAllVis@@ -163,7 +165,7 @@ type instance XHsQTvs GhcRn = HsQTvsRn type instance XHsQTvs GhcTc = HsQTvsRn -type instance XXLHsQTyVars  (GhcPass _) = NoExtCon+type instance XXLHsQTyVars  (GhcPass _) = DataConCantHappen  mkHsForAllVisTele ::EpAnnForallTy ->   [LHsTyVarBndr () (GhcPass p)] -> HsForAllTelescope (GhcPass p)@@ -192,22 +194,22 @@ type instance XHsOuterExplicit GhcRn _    = NoExtField type instance XHsOuterExplicit GhcTc flag = [VarBndr TyVar flag] -type instance XXHsOuterTyVarBndrs (GhcPass _) = NoExtCon+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 _) _ = NoExtCon+type instance XXHsWildCardBndrs (GhcPass _) _ = DataConCantHappen  type instance XHsPS GhcPs = EpAnn EpaLocation type instance XHsPS GhcRn = HsPSRn type instance XHsPS GhcTc = HsPSRn -type instance XXHsPatSigType (GhcPass _) = NoExtCon+type instance XXHsPatSigType (GhcPass _) = DataConCantHappen  type instance XHsSig (GhcPass _) = NoExtField-type instance XXHsSigType (GhcPass _) = NoExtCon+type instance XXHsSigType (GhcPass _) = DataConCantHappen  hsSigWcType :: forall p. UnXRec p => LHsSigWcType p -> LHsType p hsSigWcType = sig_body . unXRec @p . hswc_body@@ -262,7 +264,7 @@ type instance XUserTyVar    (GhcPass _) = EpAnn [AddEpAnn] type instance XKindedTyVar  (GhcPass _) = EpAnn [AddEpAnn] -type instance XXTyVarBndr   (GhcPass _) = NoExtCon+type instance XXTyVarBndr   (GhcPass _) = DataConCantHappen  -- | Return the attached flag hsTyVarBndrFlag :: HsTyVarBndr flag (GhcPass pass) -> flag@@ -287,11 +289,11 @@ type instance XQualTy          (GhcPass _) = NoExtField type instance XTyVar           (GhcPass _) = EpAnn [AddEpAnn] type instance XAppTy           (GhcPass _) = NoExtField-type instance XFunTy           (GhcPass _) = EpAnn TrailingAnn -- For the AnnRarrow or AnnLolly+type instance XFunTy           (GhcPass _) = EpAnnCO type instance XListTy          (GhcPass _) = EpAnn AnnParen type instance XTupleTy         (GhcPass _) = EpAnn AnnParen type instance XSumTy           (GhcPass _) = EpAnn AnnParen-type instance XOpTy            (GhcPass _) = NoExtField+type instance XOpTy            (GhcPass _) = EpAnn [AddEpAnn] type instance XParTy           (GhcPass _) = EpAnn AnnParen type instance XIParamTy        (GhcPass _) = EpAnn [AddEpAnn] type instance XStarTy          (GhcPass _) = NoExtField@@ -331,6 +333,12 @@ manyDataConHsTy :: HsType GhcRn manyDataConHsTy = HsTyVar noAnn NotPromoted (noLocA manyDataConName) +hsLinear :: a -> HsScaled (GhcPass p) a+hsLinear = HsScaled (HsLinearArrow (HsPct1 noHsTok noHsUniTok))++hsUnrestricted :: a -> HsScaled (GhcPass p) a+hsUnrestricted = HsScaled (HsUnrestrictedArrow noHsUniTok)+ isUnrestricted :: HsArrow GhcRn -> Bool isUnrestricted (arrowToHsType -> L _ (HsTyVar _ _ (L _ n))) = n == manyDataConName isUnrestricted _ = False@@ -340,8 +348,8 @@ -- multiplicity or a shorthand. arrowToHsType :: HsArrow GhcRn -> LHsType GhcRn arrowToHsType (HsUnrestrictedArrow _) = noLocA manyDataConHsTy-arrowToHsType (HsLinearArrow _ _) = noLocA oneDataConHsTy-arrowToHsType (HsExplicitMult _ _ p) = p+arrowToHsType (HsLinearArrow _) = noLocA oneDataConHsTy+arrowToHsType (HsExplicitMult _ p _) = p  instance       (OutputableBndrId pass) =>@@ -351,11 +359,11 @@ -- See #18846 pprHsArrow :: (OutputableBndrId pass) => HsArrow (GhcPass pass) -> SDoc pprHsArrow (HsUnrestrictedArrow _) = arrow-pprHsArrow (HsLinearArrow _ _) = lollipop-pprHsArrow (HsExplicitMult _ _ p) = (mulArrow (ppr p))+pprHsArrow (HsLinearArrow _) = lollipop+pprHsArrow (HsExplicitMult _ p _) = mulArrow (ppr p)  type instance XConDeclField  (GhcPass _) = EpAnn [AddEpAnn]-type instance XXConDeclField (GhcPass _) = NoExtCon+type instance XXConDeclField (GhcPass _) = DataConCantHappen  instance OutputableBndrId p        => Outputable (ConDeclField (GhcPass p)) where@@ -442,9 +450,10 @@ mkAnonWildCardTy = HsWildCardTy noExtField  mkHsOpTy :: (Anno (IdGhcP p) ~ SrcSpanAnnN)-         => LHsType (GhcPass p) -> LocatedN (IdP (GhcPass p))+         => PromotionFlag+         -> LHsType (GhcPass p) -> LocatedN (IdP (GhcPass p))          -> LHsType (GhcPass p) -> HsType (GhcPass p)-mkHsOpTy ty1 op ty2 = HsOpTy noExtField ty1 op ty2+mkHsOpTy prom ty1 op ty2 = HsOpTy noAnn prom ty1 op ty2  mkHsAppTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) mkHsAppTy t1 t2@@ -486,13 +495,12 @@           cs' = cs S.<> epAnnComments (ann l) S.<> epAnnComments an         in (anns', cs', args, res) -    go (L ll (HsFunTy (EpAnn _ an cs) mult x y))+    go (L ll (HsFunTy (EpAnn _ _ cs) mult x y))       | (anns, csy, args, res) <- splitHsFunType y       = (anns, csy S.<> epAnnComments (ann ll), HsScaled mult x':args, res)       where-        (L (SrcSpanAnn a l) t) = x-        an' = addTrailingAnnToA l an cs a-        x' = L (SrcSpanAnn an' l) t+        L l t = x+        x' = L (addCommentsToSrcAnn l cs) t      go other = ([], emptyComments, [], other) @@ -508,7 +516,7 @@     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 _ (HsOpTy _ _ _ ln _))       = Just ln     go (L _ (HsParTy _ t))             = go t     go (L _ (HsKindSig _ t _))         = go t     go _                               = Nothing@@ -664,7 +672,7 @@ -- 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 }))-                       = (ctxt, body)+                       = (Just ctxt, body) splitLHsQualTy_KP body = (Nothing, body)  -- | Decompose a type class instance type (of the form@@ -802,7 +810,7 @@ type instance XCFieldOcc GhcRn = Name type instance XCFieldOcc GhcTc = Id -type instance XXFieldOcc (GhcPass _) = NoExtCon+type instance XXFieldOcc (GhcPass _) = DataConCantHappen  mkFieldOcc :: LocatedN RdrName -> FieldOcc GhcPs mkFieldOcc rdr = FieldOcc noExtField rdr@@ -816,7 +824,7 @@ type instance XAmbiguous GhcRn = NoExtField type instance XAmbiguous GhcTc = Id -type instance XXAmbiguousFieldOcc (GhcPass _) = NoExtCon+type instance XXAmbiguousFieldOcc (GhcPass _) = DataConCantHappen  instance Outputable (AmbiguousFieldOcc (GhcPass p)) where   ppr = ppr . rdrNameAmbiguousFieldOcc@@ -825,6 +833,10 @@   pprInfixOcc  = pprInfixOcc . rdrNameAmbiguousFieldOcc   pprPrefixOcc = pprPrefixOcc . rdrNameAmbiguousFieldOcc +instance OutputableBndr (Located (AmbiguousFieldOcc (GhcPass p))) where+  pprInfixOcc  = pprInfixOcc . unLoc+  pprPrefixOcc = pprPrefixOcc . unLoc+ mkAmbiguousFieldOcc :: LocatedN RdrName -> AmbiguousFieldOcc GhcPs mkAmbiguousFieldOcc rdr = Unambiguous noExtField rdr @@ -852,46 +864,17 @@ -}  class OutputableBndrFlag flag p where-    pprTyVarBndr :: OutputableBndrId p-                 => HsTyVarBndr flag (GhcPass p) -> SDoc+    pprTyVarBndr :: OutputableBndrId p => HsTyVarBndr flag (GhcPass p) -> SDoc  instance OutputableBndrFlag () p where-    pprTyVarBndr (UserTyVar _ _ n) --     = pprIdP n-      = case ghcPass @p of-          GhcPs -> ppr n-          GhcRn -> ppr n-          GhcTc -> ppr n-    pprTyVarBndr (KindedTyVar _ _ n k) = parens $ hsep [ppr_n, dcolon, ppr k]-      where-        ppr_n = case ghcPass @p of-          GhcPs -> ppr n-          GhcRn -> ppr n-          GhcTc -> ppr n+    pprTyVarBndr (UserTyVar _ _ n)     = ppr n+    pprTyVarBndr (KindedTyVar _ _ n k) = parens $ hsep [ppr n, dcolon, ppr k]  instance OutputableBndrFlag Specificity p where-    pprTyVarBndr (UserTyVar _ SpecifiedSpec n) --     = pprIdP n-      = case ghcPass @p of-          GhcPs -> ppr n-          GhcRn -> ppr n-          GhcTc -> ppr n-    pprTyVarBndr (UserTyVar _ InferredSpec n)      = braces $ ppr_n-      where-        ppr_n = case ghcPass @p of-          GhcPs -> ppr n-          GhcRn -> ppr n-          GhcTc -> ppr n-    pprTyVarBndr (KindedTyVar _ SpecifiedSpec n k) = parens $ hsep [ppr_n, dcolon, ppr k]-      where-        ppr_n = case ghcPass @p of-          GhcPs -> ppr n-          GhcRn -> ppr n-          GhcTc -> ppr n-    pprTyVarBndr (KindedTyVar _ InferredSpec n k)  = braces $ hsep [ppr_n, dcolon, ppr k]-      where-        ppr_n = case ghcPass @p of-          GhcPs -> ppr n-          GhcRn -> ppr n-          GhcTc -> ppr n+    pprTyVarBndr (UserTyVar _ SpecifiedSpec n)     = ppr n+    pprTyVarBndr (UserTyVar _ InferredSpec n)      = braces $ ppr n+    pprTyVarBndr (KindedTyVar _ SpecifiedSpec n k) = parens $ hsep [ppr n, dcolon, ppr k]+    pprTyVarBndr (KindedTyVar _ InferredSpec n k)  = braces $ hsep [ppr n, dcolon, ppr k]  instance OutputableBndrId p => Outputable (HsSigType (GhcPass p)) where     ppr (HsSig { sig_bndrs = outer_bndrs, sig_body = body }) =@@ -979,15 +962,12 @@ pprLHsContext :: (OutputableBndrId p)               => Maybe (LHsContext (GhcPass p)) -> SDoc pprLHsContext Nothing = empty-pprLHsContext (Just lctxt)-  | null (unLoc lctxt) = empty-  | otherwise          = pprLHsContextAlways (Just lctxt)+pprLHsContext (Just lctxt) = pprLHsContextAlways lctxt  -- For use in a HsQualTy, which always gets printed if it exists. pprLHsContextAlways :: (OutputableBndrId p)-                    => Maybe (LHsContext (GhcPass p)) -> SDoc-pprLHsContextAlways Nothing = parens empty <+> darrow-pprLHsContextAlways (Just (L _ ctxt))+                    => LHsContext (GhcPass p) -> SDoc+pprLHsContextAlways (L _ ctxt)   = case ctxt of       []       -> parens empty             <+> darrow       [L _ ty] -> ppr_mono_ty ty           <+> darrow@@ -999,7 +979,7 @@   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+        = pprMaybeWithDoc doc (ppr_names ns <+> dcolon <+> ppr ty)      ppr_names :: [LFieldOcc (GhcPass p)] -> SDoc     ppr_names [n] = pprPrefixOcc n@@ -1034,12 +1014,10 @@ 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 _ mult ty1 ty2)   = ppr_fun_ty mult ty1 ty2+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)) = 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)`@@ -1077,10 +1055,9 @@   = 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)+ppr_mono_ty (HsOpTy _ prom ty1 (L _ op) ty2)   = sep [ ppr_mono_lty ty1-        , sep [pprInfixOcc op, ppr_mono_lty ty2 ] ]-+        , 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@@ -1088,10 +1065,7 @@   --    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+  = pprWithDoc doc $ ppr_mono_lty ty  ppr_mono_ty (XHsType t) = ppr t @@ -1175,7 +1149,7 @@      go (HsForAllTy{})        = False     go (HsQualTy{ hst_ctxt = ctxt, hst_body = body})-      | Just (L _ (c:_)) <- ctxt = goL c+      | (L _ (c:_)) <- ctxt = goL c       | otherwise            = goL body     go (HsBangTy{})          = False     go (HsRecTy{})           = False@@ -1184,7 +1158,7 @@     go (HsListTy{})          = False     go (HsTupleTy{})         = False     go (HsSumTy{})           = False-    go (HsOpTy _ t1 _ _)     = goL t1+    go (HsOpTy _ _ t1 _ _)   = goL t1     go (HsKindSig _ t _)     = goL t     go (HsIParamTy{})        = False     go (HsSpliceTy{})        = False@@ -1239,6 +1213,8 @@ type instance Anno (HsTyVarBndr _flag GhcTc) = SrcSpanAnnA  type instance Anno (HsOuterTyVarBndrs _ (GhcPass _)) = SrcSpanAnnA-type instance Anno HsIPName = SrcSpan+type instance Anno HsIPName = SrcAnn NoEpAnns type instance Anno (ConDeclField (GhcPass p)) = SrcSpanAnnA-type instance Anno (FieldOcc (GhcPass p)) = SrcSpan++type instance Anno (FieldOcc (GhcPass p)) = SrcAnn NoEpAnns+type instance Anno (AmbiguousFieldOcc (GhcPass p)) = SrcAnn NoEpAnns
GHC/Hs/Utils.hs view
@@ -21,16 +21,18 @@ -}  {-# LANGUAGE CPP #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}  {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -39,12 +41,12 @@   mkHsPar, mkHsApp, mkHsAppWith, mkHsApps, mkHsAppsWith,   mkHsAppType, mkHsAppTypes, mkHsCaseAlt,   mkSimpleMatch, unguardedGRHSs, unguardedRHS,-  mkMatchGroup, mkMatch, mkPrefixFunRhs, mkHsLam, mkHsIf,+  mkMatchGroup, mkLamCaseMatchGroup, mkMatch, mkPrefixFunRhs, mkHsLam, mkHsIf,   mkHsWrap, mkLHsWrap, mkHsWrapCo, mkHsWrapCoR, mkLHsWrapCo,   mkHsDictLet, mkHsLams,   mkHsOpApp, mkHsDo, mkHsDoAnns, mkHsComp, mkHsCompAnns, mkHsWrapPat, mkHsWrapPatCo,   mkLHsPar, mkHsCmdWrap, mkLHsCmdWrap,-  mkHsCmdIf,+  mkHsCmdIf, mkConLikeTc,    nlHsTyApp, nlHsTyApps, nlHsVar, nl_HsVar, nlHsDataCon,   nlHsLit, nlHsApp, nlHsApps, nlHsSyntaxApps,@@ -111,8 +113,6 @@   lStmtsImplicits, hsValBindsImplicits, lPatImplicits   ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Hs.Decls@@ -153,8 +153,6 @@ import Data.Either import Data.Function import Data.List ( partition, deleteBy )-import Data.Proxy-import Data.Data (Data)  {- ************************************************************************@@ -170,13 +168,13 @@  -- | @e => (e)@ mkHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)-mkHsPar e = L (getLoc e) (HsPar noAnn e)+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))))-                        ~ SrcSpan)-              => HsMatchContext (NoGhcTc (GhcPass p))+                        ~ SrcAnn NoEpAnns)+              => HsMatchContext (GhcPass p)               -> [LPat (GhcPass p)] -> LocatedA (body (GhcPass p))               -> LMatch (GhcPass p) (LocatedA (body (GhcPass p))) mkSimpleMatch ctxt pats rhs@@ -189,17 +187,17 @@                 (pat:_) -> combineSrcSpansA (getLoc pat) (getLoc rhs)  unguardedGRHSs :: Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))-                     ~ SrcSpan+                     ~ SrcAnn 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))))-                     ~ SrcSpan+                     ~ SrcAnn NoEpAnns              => EpAnn GrhsAnn -> SrcSpan -> LocatedA (body (GhcPass p))              -> [LGRHS (GhcPass p) (LocatedA (body (GhcPass p)))]-unguardedRHS an loc rhs = [L loc (GRHS an [] rhs)]+unguardedRHS an loc rhs = [L (noAnnSrcSpan loc) (GRHS an [] rhs)]  type AnnoBody p body   = ( XMG (GhcPass p) (LocatedA (body (GhcPass p))) ~ NoExtField@@ -215,6 +213,15 @@                                  , mg_alts = matches                                  , mg_origin = origin } +mkLamCaseMatchGroup :: AnnoBody p body+                    => Origin+                    -> LamCaseVariant+                    -> LocatedL [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))]+                    -> MatchGroup (GhcPass p) (LocatedA (body (GhcPass p)))+mkLamCaseMatchGroup origin lc_variant (L l matches)+  = mkMatchGroup origin (L l $ map fixCtxt matches)+  where fixCtxt (L a match) = L a match{m_ctxt = LamCaseAlt lc_variant}+ mkLocatedList :: Semigroup a   => [GenLocated (SrcAnn a) e2] -> LocatedAn an [GenLocated (SrcAnn a) e2] mkLocatedList [] = noLocA []@@ -267,7 +274,7 @@ -- |A simple case alternative with a single pattern, no binds, no guards; -- pre-typechecking mkHsCaseAlt :: (Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))-                     ~ SrcSpan,+                     ~ SrcAnn NoEpAnns,                  Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))                         ~ SrcSpanAnnA)             => LPat (GhcPass p) -> (LocatedA (body (GhcPass p)))@@ -286,17 +293,13 @@ -- | 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 le@(L loc e)-  | hsExprNeedsParens appPrec e = L loc (HsPar noAnn le)-  | otherwise                   = le+mkLHsPar = parenthesizeHsExpr appPrec  mkParPat :: IsPass p => LPat (GhcPass p) -> LPat (GhcPass p)-mkParPat lp@(L loc p)-  | patNeedsParens appPrec p = L loc (ParPat noAnn lp)-  | otherwise                = lp+mkParPat = parenthesizePat appPrec  nlParPat :: LPat (GhcPass name) -> LPat (GhcPass name)-nlParPat p = noLocA (ParPat noAnn p)+nlParPat p = noLocA (gParPat p)  ------------------------------- -- These are the bits of syntax that contain rebindable names@@ -305,17 +308,17 @@ mkHsIntegral   :: IntegralLit -> HsOverLit GhcPs mkHsFractional :: FractionalLit -> HsOverLit GhcPs mkHsIsString   :: SourceText -> FastString -> HsOverLit GhcPs-mkHsDo         :: HsStmtContext GhcRn -> LocatedL [ExprLStmt GhcPs] -> HsExpr GhcPs-mkHsDoAnns     :: HsStmtContext GhcRn -> LocatedL [ExprLStmt GhcPs] -> EpAnn AnnList -> HsExpr GhcPs-mkHsComp       :: HsStmtContext GhcRn -> [ExprLStmt GhcPs] -> LHsExpr GhcPs+mkHsDo         :: HsDoFlavour -> LocatedL [ExprLStmt GhcPs] -> HsExpr GhcPs+mkHsDoAnns     :: HsDoFlavour -> LocatedL [ExprLStmt GhcPs] -> EpAnn AnnList -> HsExpr GhcPs+mkHsComp       :: HsDoFlavour -> [ExprLStmt GhcPs] -> LHsExpr GhcPs                -> HsExpr GhcPs-mkHsCompAnns   :: HsStmtContext GhcRn -> [ExprLStmt GhcPs] -> LHsExpr GhcPs+mkHsCompAnns   :: HsDoFlavour -> [ExprLStmt GhcPs] -> LHsExpr GhcPs                -> EpAnn AnnList                -> HsExpr GhcPs -mkNPat      :: Located (HsOverLit GhcPs) -> Maybe (SyntaxExpr GhcPs) -> EpAnn [AddEpAnn]+mkNPat      :: LocatedAn NoEpAnns (HsOverLit GhcPs) -> Maybe (SyntaxExpr GhcPs) -> EpAnn [AddEpAnn]             -> Pat GhcPs-mkNPlusKPat :: LocatedN RdrName -> Located (HsOverLit GhcPs) -> EpAnn EpaLocation+mkNPlusKPat :: LocatedN RdrName -> LocatedAn NoEpAnns (HsOverLit GhcPs) -> EpAnn EpaLocation             -> Pat GhcPs  -- NB: The following functions all use noSyntaxExpr: the generated expressions@@ -351,9 +354,9 @@                  -> 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+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@@ -468,6 +471,8 @@ mkHsCharPrimLit :: Char -> HsLit (GhcPass p) mkHsCharPrimLit c = HsChar NoSourceText c +mkConLikeTc :: ConLike -> HsExpr GhcTc+mkConLikeTc con = XExpr (ConLikeTc con [] [])  {- ************************************************************************@@ -487,7 +492,7 @@  -- | NB: Only for 'LHsExpr' 'Id'. nlHsDataCon :: DataCon -> LHsExpr GhcTc-nlHsDataCon con = noLocA (HsConLikeOut noExtField (RealDataCon con))+nlHsDataCon con = noLocA (mkConLikeTc (RealDataCon con))  nlHsLit :: HsLit (GhcPass p) -> LHsExpr (GhcPass p) nlHsLit n = noLocA (HsLit noComments n)@@ -579,7 +584,7 @@ nlWildPatName :: LPat GhcRn nlWildPatName  = noLocA (WildPat noExtField ) -nlHsDo :: HsStmtContext GhcRn -> [LStmt GhcPs (LHsExpr GhcPs)]+nlHsDo :: HsDoFlavour -> [LStmt GhcPs (LHsExpr GhcPs)]        -> LHsExpr GhcPs nlHsDo ctxt stmts = noLocA (mkHsDo ctxt (noLocA stmts)) @@ -594,7 +599,7 @@  -- AZ:Is this used? nlHsLam match = noLocA (HsLam noExtField (mkMatchGroup Generated (noLocA [match])))-nlHsPar e     = noLocA (HsPar noAnn e)+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)@@ -607,24 +612,25 @@  nlHsAppTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) nlHsTyVar :: IsSrcSpanAnn p a-          => IdP (GhcPass p)                            -> LHsType (GhcPass p)+          => PromotionFlag -> 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 = noLocA (HsAppTy noExtField f (parenthesizeHsType appPrec t))-nlHsTyVar x   = noLocA (HsTyVar noAnn NotPromoted (noLocA x))-nlHsFunTy a b = noLocA (HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) (parenthesizeHsType funPrec a) b)+nlHsTyVar p x = noLocA (HsTyVar noAnn p (noLocA x))+nlHsFunTy a b = noLocA (HsFunTy noAnn (HsUnrestrictedArrow noHsUniTok) (parenthesizeHsType funPrec a) b) nlHsParTy t   = noLocA (HsParTy noAnn t)  nlHsTyConApp :: IsSrcSpanAnn p a-             => LexicalFixity -> IdP (GhcPass p)+             => PromotionFlag+             -> LexicalFixity -> IdP (GhcPass p)              -> [LHsTypeArg (GhcPass p)] -> LHsType (GhcPass p)-nlHsTyConApp fixity tycon tys+nlHsTyConApp prom fixity tycon tys   | Infix <- fixity   , HsValArg ty1 : HsValArg ty2 : rest <- tys-  = foldl' mk_app (noLocA $ HsOpTy noExtField ty1 (noLocA tycon) ty2) rest+  = foldl' mk_app (noLocA $ HsOpTy noAnn prom ty1 (noLocA tycon) ty2) rest   | otherwise-  = foldl' mk_app (nlHsTyVar tycon) tys+  = foldl' mk_app (nlHsTyVar prom tycon) tys   where     mk_app :: LHsType (GhcPass p) -> LHsTypeArg (GhcPass p) -> LHsType (GhcPass p)     mk_app fun@(L _ (HsOpTy {})) arg = mk_app (noLocA $ HsParTy noAnn fun) arg@@ -790,13 +796,9 @@ mkLHsWrap :: HsWrapper -> LHsExpr GhcTc -> LHsExpr GhcTc mkLHsWrap co_fn (L loc e) = L loc (mkHsWrap co_fn e) --- | Avoid @'HsWrap' co1 ('HsWrap' co2 _)@ and @'HsWrap' co1 ('HsPar' _ _)@--- See Note [Detecting forced eta expansion] in "GHC.HsToCore.Expr" mkHsWrap :: HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc-mkHsWrap co_fn e | isIdHsWrapper co_fn   = e-mkHsWrap co_fn (XExpr (WrapExpr (HsWrap co_fn' e))) = mkHsWrap (co_fn <.> co_fn') e-mkHsWrap co_fn (HsPar x (L l e))                = HsPar x (L l (mkHsWrap co_fn e))-mkHsWrap co_fn e                                = XExpr (WrapExpr $ HsWrap co_fn e)+mkHsWrap co_fn e | isIdHsWrapper co_fn = e+mkHsWrap co_fn e                       = XExpr (WrapExpr $ HsWrap co_fn e)  mkHsWrapCo :: TcCoercionN   -- A Nominal coercion  a ~N b            -> HsExpr GhcTc -> HsExpr GhcTc@@ -880,7 +882,7 @@ isInfixFunBind _ = False  -- |Return the 'SrcSpan' encompassing the contents of any enclosed binds-spanHsLocaLBinds :: (Data (HsLocalBinds (GhcPass p))) => HsLocalBinds (GhcPass p) -> SrcSpan+spanHsLocaLBinds :: HsLocalBinds (GhcPass p) -> SrcSpan spanHsLocaLBinds (EmptyLocalBinds _) = noSrcSpan spanHsLocaLBinds (HsValBinds _ (ValBinds _ bs sigs))   = foldr combineSrcSpans noSrcSpan (bsSpans ++ sigsSpans)@@ -917,7 +919,7 @@  ------------ mkMatch :: forall p. IsPass p-        => HsMatchContext (NoGhcTc (GhcPass p))+        => HsMatchContext (GhcPass p)         -> [LPat (GhcPass p)]         -> LHsExpr (GhcPass p)         -> HsLocalBinds (GhcPass p)@@ -925,13 +927,8 @@ mkMatch ctxt pats expr binds   = noLocA (Match { m_ext   = noAnn                   , m_ctxt  = ctxt-                  , m_pats  = map paren pats+                  , m_pats  = map mkParPat pats                   , m_grhss = GRHSs emptyComments (unguardedRHS noAnn noSrcSpan expr) binds })-  where-    paren :: LPat (GhcPass p) -> LPat (GhcPass p)-    paren lp@(L l p)-      | patNeedsParens appPrec p = L l (ParPat noAnn lp)-      | otherwise                = lp  {- ************************************************************************@@ -992,7 +989,7 @@ -- information, see Note [Strict binds checks] is GHC.HsToCore.Binds. isUnliftedHsBind :: HsBind GhcTc -> Bool  -- works only over typechecked binds isUnliftedHsBind bind-  | AbsBinds { abs_exports = exports, abs_sig = has_sig } <- bind+  | XHsBindsLR (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@@ -1004,10 +1001,12 @@   = any is_unlifted_id (collectHsBindBinders CollNoDictBinders bind)   where     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 (AbsBinds { abs_binds = binds })+isBangedHsBind (XHsBindsLR (AbsBinds { abs_binds = binds }))   = anyBag (isBangedHsBind . unLoc) binds isBangedHsBind (FunBind {fun_matches = matches})   | [L _ match] <- unLoc $ mg_alts matches@@ -1037,7 +1036,7 @@  collectHsValBinders :: CollectPass (GhcPass idL)                     => CollectFlag (GhcPass idL)-                    -> HsValBindsLR (GhcPass idL) (GhcPass idR)+                    -> HsValBindsLR (GhcPass idL) idR                     -> [IdP (GhcPass idL)] collectHsValBinders flag = collect_hs_val_binders False flag @@ -1064,7 +1063,7 @@ collect_hs_val_binders :: CollectPass (GhcPass idL)                        => Bool                        -> CollectFlag (GhcPass idL)-                       -> HsValBindsLR (GhcPass idL) (GhcPass idR)+                       -> HsValBindsLR (GhcPass idL) idR                        -> [IdP (GhcPass idL)] collect_hs_val_binders ps flag = \case     ValBinds _ binds _              -> collect_binds ps flag binds []@@ -1092,19 +1091,16 @@              -> HsBindLR p idR              -> [IdP p]              -> [IdP p]-collect_bind _ flag (PatBind { pat_lhs = p })           acc = collect_lpat flag p acc-collect_bind _ _ (FunBind { fun_id = f })            acc = unXRec @p 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 GHC.Tc.Utils.Zonk+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 _) 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'@@ -1124,14 +1120,14 @@ collectLStmtsBinders flag = concatMap (collectLStmtBinders flag)  collectStmtsBinders-  :: (CollectPass (GhcPass idL))+  :: CollectPass (GhcPass idL)   => CollectFlag (GhcPass idL)   -> [StmtLR (GhcPass idL) (GhcPass idR) body]   -> [IdP (GhcPass idL)] collectStmtsBinders flag = concatMap (collectStmtBinders flag)  collectLStmtBinders-  :: (CollectPass (GhcPass idL))+  :: CollectPass (GhcPass idL)   => CollectFlag (GhcPass idL)   -> LStmtLR (GhcPass idL) (GhcPass idR) body   -> [IdP (GhcPass idL)]@@ -1190,7 +1186,7 @@     -- | Collect evidence binders     CollWithDictBinders :: CollectFlag GhcTc -collect_lpat :: forall p. (CollectPass p)+collect_lpat :: forall p. CollectPass p              => CollectFlag p              -> LPat p              -> [IdP p]@@ -1209,7 +1205,7 @@   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+  ParPat _ _ pat _      -> collect_lpat flag pat bndrs   ListPat _ pats        -> foldr (collect_lpat flag) bndrs pats   TuplePat _ pats _     -> foldr (collect_lpat flag) bndrs pats   SumPat _ pat _ _      -> collect_lpat flag pat bndrs@@ -1217,7 +1213,7 @@   NPat {}               -> bndrs   NPlusKPat _ n _ _ _ _ -> unXRec @p n : bndrs   SigPat _ pat _        -> collect_lpat flag pat bndrs-  XPat ext              -> collectXXPat (Proxy @p) flag ext bndrs+  XPat ext              -> collectXXPat @p flag ext bndrs   SplicePat _ (HsSpliced _ _ (HsSplicedPat pat))                         -> collect_pat flag pat bndrs   SplicePat _ _         -> bndrs@@ -1244,15 +1240,30 @@ -- 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 :: Proxy p -> CollectFlag p -> XXPat p -> [IdP p] -> [IdP p]+  collectXXPat :: CollectFlag p -> XXPat p -> [IdP p] -> [IdP p]+  collectXXHsBindsLR :: forall pR. XXHsBindsLR p pR -> [IdP p] -> [IdP p]  instance IsPass p => CollectPass (GhcPass p) where-  collectXXPat _ flag ext =+  collectXXPat flag ext =     case ghcPass @p of-      GhcTc -> let CoPat _ pat _ = ext in collect_pat flag pat-      GhcRn -> noExtCon ext-      GhcPs -> noExtCon ext+      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.Utils.Zonk++ {- Note [Dictionary binders in ConPatOut] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1342,7 +1353,7 @@          foldMap (foldMap hsLInstDeclBinders . group_instds) tycl_decls)   where     getSelectorNames :: ([LocatedA Name], [LFieldOcc GhcRn]) -> [Name]-    getSelectorNames (ns, fs) = map unLoc ns ++ map (extFieldOcc . unLoc) fs+    getSelectorNames (ns, fs) = map unLoc ns ++ map (foExt . unLoc) fs  ------------------- hsLTyClDeclBinders :: IsPass p@@ -1482,7 +1493,7 @@      get_flds_gadt :: Seen p -> HsConDeclGADTDetails (GhcPass p)                   -> (Seen p, [LFieldOcc (GhcPass p)])-    get_flds_gadt remSeen (RecConGADT flds) = get_flds remSeen flds+    get_flds_gadt remSeen (RecConGADT flds _) = get_flds remSeen flds     get_flds_gadt remSeen _ = (remSeen, [])      get_flds :: Seen p -> LocatedL [LConDeclField (GhcPass p)]@@ -1491,7 +1502,7 @@        where           fld_names = remSeen (concatMap (cd_fld_names . unLoc) (unLoc flds))           remSeen' = foldr (.) remSeen-                               [deleteBy ((==) `on` unLoc . rdrNameFieldOcc . unLoc) v+                               [deleteBy ((==) `on` unLoc . foLabel . unLoc) v                                | v <- fld_names]  {-@@ -1584,7 +1595,7 @@     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 (ParPat _ _ pat _)   = hs_lpat pat     hs_pat (ListPat _ pats)     = hs_lpats pats     hs_pat (TuplePat _ pats _)  = hs_lpats pats @@ -1600,8 +1611,8 @@       [(err_loc, collectPatsBinders CollNoDictBinders implicit_pats) | Just{} <- [rec_dotdot fs] ]         ++ hs_lpats explicit_pats -      where implicit_pats = map (hsRecFieldArg . unLoc) implicit-            explicit_pats = map (hsRecFieldArg . unLoc) explicit+      where implicit_pats = map (hfbRHS . unLoc) implicit+            explicit_pats = map (hfbRHS . unLoc) explicit               (explicit, implicit) = partitionEithers [if pat_explicit then Left fld else Right fld
GHC/HsToCore.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP          #-}+ {-# LANGUAGE TypeFamilies #-}  {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}@@ -16,19 +16,19 @@     deSugar, deSugarExpr     ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Driver.Session import GHC.Driver.Config import GHC.Driver.Env import GHC.Driver.Backend+import GHC.Driver.Plugins  import GHC.Hs  import GHC.HsToCore.Usage import GHC.HsToCore.Monad+import GHC.HsToCore.Errors.Types import GHC.HsToCore.Expr import GHC.HsToCore.Binds import GHC.HsToCore.Foreign.Decl@@ -46,24 +46,25 @@ import GHC.Core.SimpleOpt ( simpleOptPgm, simpleOptExpr ) import GHC.Core.Utils import GHC.Core.Unfold.Make-import GHC.Core.Ppr import GHC.Core.Coercion import GHC.Core.DataCon ( dataConWrapId ) import GHC.Core.Make import GHC.Core.Rules import GHC.Core.Opt.Monad ( CoreToDo(..) ) import GHC.Core.Lint     ( endPassIO )+import GHC.Core.Ppr  import GHC.Builtin.Names import GHC.Builtin.Types.Prim import GHC.Builtin.Types  import GHC.Data.FastString+import GHC.Data.Maybe    ( expectJust ) import GHC.Data.OrdList  import GHC.Utils.Error import GHC.Utils.Outputable-import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Utils.Misc import GHC.Utils.Monad import GHC.Utils.Logger@@ -86,11 +87,10 @@ 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 Control.Monad( when )-import GHC.Driver.Plugins ( LoadedPlugin(..) )  {- ************************************************************************@@ -101,7 +101,7 @@ -}  -- | Main entry point to the desugarer.-deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages DecoratedSDoc, Maybe ModGuts)+deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages DsMessage, Maybe ModGuts) -- Can modify PCS by faulting in more declarations  deSugar hsc_env@@ -133,13 +133,14 @@                             tcg_insts        = insts,                             tcg_fam_insts    = fam_insts,                             tcg_hpc          = other_hpc_info,-                            tcg_complete_matches = complete_matches+                            tcg_complete_matches = complete_matches,+                            tcg_self_boot    = self_boot                             })    = do { let dflags = hsc_dflags hsc_env              logger = hsc_logger hsc_env              print_unqual = mkPrintUnqualified (hsc_unit_env hsc_env) rdr_env-        ; withTiming logger dflags+        ; withTiming logger                      (text "Desugar"<+>brackets (ppr mod))                      (const ()) $      do { -- Desugar the program@@ -149,7 +150,13 @@          ; (binds_cvr, ds_hpc_info, modBreaks)                          <- if not (isHsBootOrSig hsc_src)-                              then addTicksToBinds hsc_env mod mod_loc+                              then addTicksToBinds+                                       (CoverageConfig+                                        { coverageConfig_logger = hsc_logger hsc_env+                                        , coverageConfig_dynFlags = hsc_dflags hsc_env+                                        , coverageConfig_mInterp = hsc_interp hsc_env+                                        })+                                       mod mod_loc                                        export_set (typeEnvTyCons type_env) binds                               else return (binds, hpcInfo, Nothing)         ; (msgs, mb_res) <- initDs hsc_env tcg_env $@@ -160,7 +167,7 @@                           ; (ds_fords, foreign_prs) <- dsForeigns fords                           ; ds_rules <- mapMaybeM dsRule rules                           ; let hpc_init-                                  | gopt Opt_Hpc dflags = hpcInitCode (hsc_dflags hsc_env) mod ds_hpc_info+                                  | 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@@ -190,31 +197,35 @@                 = simpleOptPgm simpl_opts mod final_pgm rules_for_imps                          -- The simpleOptPgm gets rid of type                          -- bindings plus any stupid dead code-        ; dumpIfSet_dyn logger dflags Opt_D_dump_occur_anal "Occurrence analysis"+        ; putDumpFileMaybe logger Opt_D_dump_occur_anal "Occurrence analysis"             FormatCore (pprCoreBindings occ_anald_binds $$ pprRules ds_rules_for_imps )          ; endPassIO hsc_env print_unqual CoreDesugarOpt ds_binds ds_rules_for_imps          ; let used_names = mkUsedNames tcg_env-              pluginModules = map lpModule (hsc_plugins hsc_env)+              pluginModules = map lpModule (loadedPlugins (hsc_plugins hsc_env))               home_unit = hsc_home_unit hsc_env-        ; deps <- mkDependencies (homeUnitId home_unit)-                                 (map mi_module pluginModules) tcg_env+        ; let deps = mkDependencies home_unit+                                    (tcg_mod tcg_env)+                                    (tcg_imports tcg_env)+                                    (map mi_module pluginModules)          ; used_th <- readIORef tc_splice_used         ; dep_files <- readIORef dependent_files         ; safe_mode <- finalSafeMode dflags tcg_env+        ; (needed_mods, needed_pkgs) <- readIORef (tcg_th_needed_deps tcg_env)+         ; usages <- mkUsageInfo hsc_env mod (imp_mods imports) used_names-                      dep_files merged pluginModules+                      dep_files merged needed_mods needed_pkgs         -- id_mod /= mod when we are processing an hsig, but hsigs         -- never desugared and compiled (there's no code!)         -- Consequently, this should hold for any ModGuts that make         -- past desugaring. See Note [Identity versus semantic module].-        ; MASSERT( id_mod == mod )+        ; massert (id_mod == mod)          ; foreign_files <- readIORef th_foreign_files_var -        ; (doc_hdr, decl_docs, arg_docs) <- extractDocs tcg_env+        ; docs <- extractDocs dflags tcg_env          ; let mod_guts = ModGuts {                 mg_module       = mod,@@ -233,6 +244,7 @@                 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,@@ -243,9 +255,7 @@                 mg_safe_haskell = safe_mode,                 mg_trust_pkg    = imp_trust_own_pkg imports,                 mg_complete_matches = complete_matches,-                mg_doc_hdr      = doc_hdr,-                mg_decl_docs    = decl_docs,-                mg_arg_docs     = arg_docs+                mg_docs         = docs               }         ; return (msgs, Just mod_guts)         }}}}@@ -285,24 +295,35 @@ and Rec the rest. -} -deSugarExpr :: HscEnv -> LHsExpr GhcTc -> IO (Messages DecoratedSDoc, Maybe CoreExpr)+deSugarExpr :: HscEnv -> LHsExpr GhcTc -> IO (Messages DsMessage, Maybe CoreExpr) deSugarExpr hsc_env tc_expr = do-    let dflags = hsc_dflags hsc_env     let logger = hsc_logger hsc_env -    showPass logger dflags "Desugar"+    showPass logger "Desugar"      -- Do desugaring-    (msgs, mb_core_expr) <- runTcInteractive hsc_env $ initDsTc $-                                 dsLExpr tc_expr+    (tc_msgs, mb_result) <- runTcInteractive hsc_env $+                            initDsTc $+                            dsLExpr tc_expr +    massert (isEmptyMessages tc_msgs)  -- the type-checker isn't doing anything here++      -- mb_result is Nothing only when a failure happens in the type-checker,+      -- but mb_core_expr is Nothing when a failure happens in the desugarer+    let (ds_msgs, mb_core_expr) = expectJust "deSugarExpr" mb_result+     case mb_core_expr of        Nothing   -> return ()-       Just expr -> dumpIfSet_dyn logger dflags Opt_D_dump_ds "Desugared"+       Just expr -> putDumpFileMaybe logger Opt_D_dump_ds "Desugared"                     FormatCore (pprCoreExpr expr) -    return (msgs, mb_core_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)+ {- ************************************************************************ *                                                                      *@@ -419,7 +440,7 @@         -- and take the body apart into a (f args) form         ; dflags <- getDynFlags         ; case decomposeRuleLhs dflags bndrs'' lhs'' of {-                Left msg -> do { warnDs NoReason msg; return Nothing } ;+                Left msg -> do { diagnosticDs msg; return Nothing } ;                 Right (final_bndrs, fn_id, args) -> do          { let is_local = isLocalId fn_id@@ -437,8 +458,7 @@         ; rule <- dsMkUserRule this_mod is_local                          rule_name rule_act fn_name final_bndrs args                          final_rhs-        ; when (wopt Opt_WarnInlineRuleShadowing dflags) $-          warnRuleShadowing rule_name rule_act fn_id arg_ids+        ; warnRuleShadowing rule_name rule_act fn_id arg_ids          ; return (Just rule)         } } }@@ -455,26 +475,10 @@       | isLocalId lhs_id || canUnfold (idUnfolding lhs_id)                        -- If imported with no unfolding, no worries       , idInlineActivation lhs_id `competesWith` rule_act-      = warnDs (Reason Opt_WarnInlineRuleShadowing)-               (vcat [ hang (text "Rule" <+> pprRuleName rule_name-                               <+> text "may never fire")-                            2 (text "because" <+> quotes (ppr lhs_id)-                               <+> text "might inline first")-                     , text "Probable fix: add an INLINE[n] or NOINLINE[n] pragma for"-                       <+> quotes (ppr lhs_id)-                     , whenPprDebug (ppr (idInlineActivation lhs_id) $$ ppr rule_act) ])-+      = diagnosticDs (DsRuleMightInlineFirst rule_name lhs_id rule_act)       | check_rules_too       , bad_rule : _ <- get_bad_rules lhs_id-      = warnDs (Reason Opt_WarnInlineRuleShadowing)-               (vcat [ hang (text "Rule" <+> pprRuleName rule_name-                               <+> text "may never fire")-                            2 (text "because rule" <+> pprRuleName (ruleName bad_rule)-                               <+> text "for"<+> quotes (ppr lhs_id)-                               <+> text "might fire first")-                      , text "Probable fix: add phase [n] or [~n] to the competing rule"-                      , whenPprDebug (ppr bad_rule) ])-+      = diagnosticDs (DsAnotherRuleMightFireFirst rule_name (ruleName bad_rule) lhs_id)       | otherwise       = return () @@ -651,9 +655,9 @@             (x |> (GRefl :: a ~# (a |> TYPE co1)) ; co2)  It looks like we can write this in Haskell directly, but we can't:-the levity polymorphism checks defeat us. Note that `x` is a levity--polymorphic variable. So we must wire it in with a compulsory-unfolding, like other levity-polymorphic primops.+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@@ -686,8 +690,8 @@   = 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 )+       ; massert (getUnique magic_id == getUnique orig_id)+       ; massert (varType magic_id `eqType` varType orig_id)         ; return magic_pair }   | otherwise@@ -743,7 +747,7 @@              (scrut1, scrut1_ty, rr_cv_ty) = unsafe_equality runtimeRepTy                                                              runtimeRep1Ty                                                              runtimeRep2Ty-             (scrut2, scrut2_ty, ab_cv_ty) = unsafe_equality (tYPE runtimeRep2Ty)+             (scrut2, scrut2_ty, ab_cv_ty) = unsafe_equality (mkTYPEapp runtimeRep2Ty)                                                              (openAlphaTy `mkCastTy` alpha_co)                                                              openBetaTy @@ -758,10 +762,13 @@               info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma                                 `setUnfoldingInfo` mkCompulsoryUnfolding' rhs+                                `setArityInfo`     arity               ty = mkSpecForAllTys [ runtimeRep1TyVar, runtimeRep2TyVar                                   , openAlphaTyVar, openBetaTyVar ] $                   mkVisFunTyMany openAlphaTy openBetaTy++             arity = 1               id   = mkExportedVanillaId unsafeCoercePrimName ty `setIdInfo` info        ; return (id, old_expr) }
GHC/HsToCore/Arrows.hs view
@@ -1,5 +1,6 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE TupleSections #-}  {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -13,8 +14,6 @@  module GHC.HsToCore.Arrows ( dsProcExpr ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.HsToCore.Match@@ -22,18 +21,17 @@ import GHC.HsToCore.Monad  import GHC.Hs-import GHC.Tc.Utils.Zonk+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, dsLExprNoLP, dsLocalBinds,+import {-# SOURCE #-} GHC.HsToCore.Expr ( dsExpr, dsLExpr, dsLocalBinds,                                           dsSyntaxExpr )  import GHC.Tc.Utils.TcType-import GHC.Core.Type( splitPiTy ) import GHC.Core.Multiplicity import GHC.Tc.Types.Evidence import GHC.Core@@ -42,6 +40,7 @@ import GHC.Core.Make import GHC.HsToCore.Binds (dsHsWrapper) + import GHC.Types.Id import GHC.Core.ConLike import GHC.Builtin.Types@@ -52,7 +51,9 @@ 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 @@ -75,25 +76,6 @@              the_choice_id  = assocMaybe prs choiceAName              the_loop_id    = assocMaybe prs loopAName -           -- used as an argument in, e.g., do_premap-       ; check_lev_poly 3 the_arr_id--           -- used as an argument in, e.g., dsCmdStmt/BodyStmt-       ; check_lev_poly 5 the_compose_id--           -- used as an argument in, e.g., dsCmdStmt/BodyStmt-       ; check_lev_poly 4 the_first_id--           -- the result of the_app_id is used as an argument in, e.g.,-           -- dsCmd/HsCmdArrApp/HsHigherOrderApp-       ; check_lev_poly 2 the_app_id--           -- used as an argument in, e.g., HsCmdIf-       ; check_lev_poly 5 the_choice_id--           -- used as an argument in, e.g., RecStmt-       ; check_lev_poly 4 the_loop_id-        ; return (meth_binds, DsCmdEnv {                arr_id     = Var (unmaybe the_arr_id arrAName),                compose_id = Var (unmaybe the_compose_id composeAName),@@ -112,21 +94,6 @@     unmaybe Nothing name = pprPanic "mkCmdEnv" (text "Not found:" <+> ppr name)     unmaybe (Just id) _  = id -      -- returns the result type of a pi-type (that is, a forall or a function)-      -- Note that this result type may be ill-scoped.-    res_type :: Type -> Type-    res_type ty = res_ty-      where-        (_, res_ty) = splitPiTy ty--    check_lev_poly :: Int -- arity-                   -> Maybe Id -> DsM ()-    check_lev_poly _     Nothing = return ()-    check_lev_poly arity (Just id)-      = dsNoLevPoly (nTimes arity res_type (idType id))-          (text "In the result of the function" <+> quotes (ppr id))-- -- arr :: forall b c. (b -> c) -> a b c do_arr :: DsCmdEnv -> Type -> Type -> CoreExpr -> CoreExpr do_arr ids b_ty c_ty f = mkApps (arr_id ids) [Type b_ty, Type c_ty, f]@@ -368,7 +335,7 @@     let         (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty         (_a_ty, arg_ty) = tcSplitAppTy a_arg_ty-    core_arrow <- dsLExprNoLP arrow+    core_arrow <- dsLExpr arrow     core_arg   <- dsLExpr arg     stack_id   <- newSysLocalDs Many stack_ty     core_make_arg <- matchEnvStack env_ids stack_id core_arg@@ -424,7 +391,7 @@     (core_cmd, free_vars, env_ids')              <- dsfixCmd ids local_vars stack_ty' res_ty cmd     stack_id <- newSysLocalDs Many stack_ty-    arg_id <- newSysLocalDsNoLP Many arg_ty+    arg_id <- newSysLocalDs Many arg_ty     -- push the argument expression onto the stack     let         stack' = mkCorePairExpr (Var arg_id) (Var stack_id)@@ -449,7 +416,7 @@         env_ids   = dsCmdLam ids local_vars stack_ty res_ty pats body env_ids -dsCmd ids local_vars stack_ty res_ty (HsCmdPar _ cmd) env_ids+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@@ -502,6 +469,8 @@         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 @@ -528,74 +497,87 @@    bodies with |||. -} +dsCmd ids local_vars stack_ty res_ty (HsCmdCase _ exp match) env_ids = do+    stack_id <- newSysLocalDs Many stack_ty+    (match', core_choices)+      <- dsCases ids local_vars stack_id stack_ty res_ty match+    let MG{ mg_ext = MatchGroupTc _ sum_ty } = match'+        in_ty = envStackType env_ids stack_ty++    core_body <- dsExpr (HsCase noExtField exp match')++    core_matches <- matchEnvStack env_ids stack_id core_body+    return (do_premap ids in_ty sum_ty res_ty core_matches core_choices,+            exprFreeIdsDSet core_body `uniqDSetIntersectUniqSet` local_vars)++{-+\cases and \case are desugared analogously to a case command (see above).+For example++        \cases {p1 q1 -> c1; p2 q2 -> c2; p3 q3 -> c3 }++is translated to++        premap (\ ((xs), (e1, (e2,stk))) -> cases e1 e2 of+                  p1 q1 -> (Left (Left (xs1), stk))+                  p2 q2 -> Left ((Right (xs2), stk))+                  p3 q3 -> Right ((xs3), stk))+        ((c1 ||| c2) ||| c3)++(cases...of is hypothetical notation that works like case...of but with+multiple scrutinees)++-} dsCmd ids local_vars stack_ty res_ty-      (HsCmdCase _ exp (MG { mg_alts = L l matches-                           , mg_ext = MatchGroupTc arg_tys _-                           , mg_origin = origin }))+      (HsCmdLamCase _ lc_variant match@MG { mg_ext = MatchGroupTc {mg_arg_tys = arg_tys} } )       env_ids = do-    stack_id <- newSysLocalDs Many stack_ty+    arg_ids <- newSysLocalsDs arg_tys -    -- Extract and desugar the leaf commands in the case, building tuple-    -- expressions that will (after tagging) replace these leaves+    let match_ctxt = ArrowLamCaseAlt lc_variant+        pat_vars = mkVarSet arg_ids+        local_vars' = pat_vars `unionVarSet` local_vars+        (pat_tys, stack_ty') = splitTypeAt (length arg_tys) stack_ty -    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)+    -- construct and desugar a case expression with multiple scrutinees+    (core_body, free_vars, env_ids') <- trimInput \env_ids -> do+      stack_id <- newSysLocalDs Many stack_ty'+      (match', core_choices)+        <- dsCases ids local_vars' stack_id stack_ty' res_ty match -    branches <- mapM make_branch leaves-    either_con <- dsLookupTyCon eitherTyConName-    left_con <- dsLookupDataCon leftDataConName-    right_con <- dsLookupDataCon rightDataConName-    let-        left_id  = HsConLikeOut noExtField (RealDataCon left_con)-        right_id = HsConLikeOut noExtField (RealDataCon right_con)-        left_expr  ty1 ty2 e = noLocA $ HsApp noComments-                           (noLocA $ mkHsWrap (mkWpTyApps [ty1, ty2]) left_id ) e-        right_expr ty1 ty2 e = noLocA $ HsApp noComments-                           (noLocA $ mkHsWrap (mkWpTyApps [ty1, ty2]) right_id) e+      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 -        -- Prefix each tuple with a distinct series of Left's and Right's,-        -- in a balanced way, keeping track of the types.+      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') -        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) = foldb merge_branches branches+    param_ids <- mapM (newSysLocalDs Many) pat_tys+    stack_id' <- newSysLocalDs Many stack_ty' -        -- Replace the commands in the case with these tagged tuples,-        -- yielding a HsExpr Id we can feed to dsExpr.+    -- the expression is built from the inside out, so the actions+    -- are presented in reverse order -        (_, matches') = mapAccumL (replaceLeavesMatch res_ty) leaves' matches+    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--    core_body <- dsExpr (HsCase noExtField exp-                         (MG { mg_alts = L l matches'-                             , mg_ext = MatchGroupTc arg_tys sum_ty-                             , mg_origin = origin }))-        -- Note that we replace the HsCase result type by sum_ty,-        -- which is the type of matches'+        in_ty' = envStackType env_ids' stack_ty' -    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)+    -- bind the scrutinees to the parameters+    let match_code = bind_vars arg_ids (map Var param_ids) core_expr -dsCmd ids local_vars stack_ty res_ty-      (HsCmdLamCase _ mg@MG { mg_ext = MatchGroupTc [Scaled arg_mult arg_ty] _ }) env_ids = do-  arg_id <- newSysLocalDs arg_mult arg_ty-  let case_cmd  = noLocA $ HsCmdCase noExtField (nlHsVar arg_id) mg-  dsCmdLam ids local_vars stack_ty res_ty [nlVarPat arg_id] case_cmd env_ids+    -- 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 -- ----------------------------------@@ -603,7 +585,7 @@ -- --              ---> premap (\ ((xs),stk) -> let binds in ((ys),stk)) c -dsCmd ids local_vars stack_ty res_ty (HsCmdLet _ lbinds@binds body) env_ids = do+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@@ -629,12 +611,7 @@ -- --              ---> premap (\ (env,stk) -> env) c -dsCmd ids local_vars stack_ty res_ty do_block@(HsCmdDo stmts_ty-                                               (L loc stmts))-                                                                   env_ids = do-    putSrcSpanDsA loc $-      dsNoLevPoly stmts_ty-        (text "In the do-command:" <+> ppr do_block)+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@@ -704,9 +681,7 @@                 DIdSet,         -- subset of local vars that occur free                 [Id])           -- the same local vars as a list, fed back dsfixCmd ids local_vars stk_ty cmd_ty cmd-  = do { putSrcSpanDs (getLocA cmd) $ dsNoLevPoly cmd_ty-           (text "When desugaring the command:" <+> ppr cmd)-       ; trimInput (dsLCmd 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.@@ -723,7 +698,7 @@         (core_cmd, free_vars) <- build_arrow env_ids         return (core_cmd, free_vars, dVarSetElems free_vars)) --- Desugaring for both HsCmdLam and HsCmdLamCase.+-- Desugaring for both HsCmdLam -- -- D; ys |-a cmd : stk t' -- -----------------------------------------------@@ -747,7 +722,7 @@         (pat_tys, stack_ty') = splitTypeAt (length pats) stack_ty     (core_body, free_vars, env_ids')        <- dsfixCmd ids local_vars' stack_ty' res_ty body-    param_ids <- mapM (newSysLocalDsNoLP Many) pat_tys+    param_ids <- mapM (newSysLocalDs Many) pat_tys     stack_id' <- newSysLocalDs Many stack_ty'      -- the expression is built from the inside out, so the actions@@ -769,6 +744,82 @@     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 _+            , mg_origin = origin }) = do++  -- Extract and desugar the leaf commands in the case, building tuple+  -- expressions that will (after tagging) replace these leaves++  let leaves = concatMap leavesMatch matches+      make_branch (leaf, bound_vars) = do+          (core_leaf, _fvs, leaf_ids)+             <- dsfixCmd ids (bound_vars `unionVarSet` local_vars) stack_ty+                  res_ty leaf+          return ([mkHsEnvStackExpr leaf_ids stack_id],+                  envStackType leaf_ids stack_ty,+                  core_leaf)++  branches <- mapM make_branch leaves+  either_con <- dsLookupTyCon eitherTyConName+  left_con <- dsLookupDataCon leftDataConName+  right_con <- dsLookupDataCon rightDataConName+  void_ty <- mkTyConTy <$> dsLookupTyCon voidTyConName+  let+      left_id  = mkConLikeTc (RealDataCon left_con)+      right_id = mkConLikeTc (RealDataCon right_con)+      left_expr  ty1 ty2 e = noLocA $ HsApp noComments+                         (noLocA $ mkHsWrap (mkWpTyApps [ty1, ty2]) left_id ) e+      right_expr ty1 ty2 e = noLocA $ HsApp noComments+                         (noLocA $ mkHsWrap (mkWpTyApps [ty1, ty2]) right_id) e++      -- Prefix each tuple with a distinct series of Left's and Right's,+      -- in a balanced way, keeping track of the types.++      merge_branches :: ([LHsExpr GhcTc], Type, CoreExpr)+                    -> ([LHsExpr GhcTc], Type, CoreExpr)+                    -> ([LHsExpr GhcTc], Type, CoreExpr) -- AZ+      merge_branches (builds1, in_ty1, core_exp1)+                     (builds2, in_ty2, core_exp2)+        = (map (left_expr in_ty1 in_ty2) builds1 +++              map (right_expr in_ty1 in_ty2) builds2,+           mkTyConApp either_con [in_ty1, in_ty2],+           do_choice ids in_ty1 in_ty2 res_ty core_exp1 core_exp2)+  (leaves', sum_ty, core_choices) <- case nonEmpty branches of+    Just bs -> return $ foldb merge_branches bs+    -- when the case command has no alternatives, the sum type from+    -- Note [Desugaring HsCmdCase] becomes the empty sum type,+    -- i.e. Void. The choices then effectively become `arr absurd`,+    -- implemented as `arr \case {}`.+    Nothing -> ([], void_ty,) . do_arr ids void_ty res_ty <$>+      dsExpr (HsLamCase EpAnnNotUsed LamCase+        (MG { mg_alts = noLocA []+            , mg_ext = MatchGroupTc [Scaled Many void_ty] res_ty+            , mg_origin = Generated }))++      -- Replace the commands in the case with these tagged tuples,+      -- yielding a HsExpr Id we can feed to dsExpr.++  let (_, matches') = mapAccumL (replaceLeavesMatch res_ty) leaves' matches++  -- Note that we replace the MatchGroup result type by sum_ty,+  -- which is the type of matches'+  return (MG { mg_alts = L l matches'+             , mg_ext = MatchGroupTc arg_tys sum_ty+             , mg_origin = origin },+          core_choices)+ {- Translation of command judgements of the form @@ -793,9 +844,7 @@ -- --              ---> premap (\ (xs) -> ((xs), ())) c -dsCmdDo ids local_vars res_ty [L loc (LastStmt _ body _ _)] env_ids = do-    putSrcSpanDsA loc $ dsNoLevPoly res_ty-                         (text "In the command:" <+> ppr body)+dsCmdDo ids local_vars res_ty [L _ (LastStmt _ body _ _)] env_ids = do     (core_body, env_ids') <- dsLCmd ids local_vars unitTy res_ty body env_ids     let env_ty = mkBigCoreVarTupTy env_ids     env_var <- newSysLocalDs Many env_ty@@ -863,7 +912,6 @@         out_ty = mkBigCoreVarTupTy out_ids         before_c_ty = mkCorePairTy in_ty1 out_ty         after_c_ty = mkCorePairTy c_ty out_ty-    dsNoLevPoly c_ty empty -- I (Richard E, Dec '16) have no idea what to say here     snd_fn <- mkSndExpr c_ty out_ty     return (do_premap ids in_ty before_c_ty out_ty core_mux $                 do_compose ids before_c_ty after_c_ty out_ty@@ -908,10 +956,10 @@        out_ty = mkBigCoreVarTupTy out_ids        body_expr = coreCaseTuple uniqs env_id env_ids2 (mkBigCoreVarTup out_ids) -    fail_expr <- mkFailExpr (StmtCtxt (DoExpr Nothing)) out_ty+    fail_expr <- mkFailExpr (StmtCtxt (HsDoStmt (DoExpr Nothing))) out_ty     pat_id    <- selectSimpleMatchVarL Many pat     match_code-      <- matchSimply (Var pat_id) (StmtCtxt (DoExpr Nothing)) pat body_expr fail_expr+      <- matchSimply (Var pat_id) (StmtCtxt (HsDoStmt (DoExpr Nothing))) pat body_expr fail_expr     pair_id   <- newSysLocalDs Many after_c_ty     let         proj_expr = Lam pair_id (coreCasePair pair_id pat_id env_id match_code)@@ -1106,7 +1154,7 @@  dsfixCmdStmts ids local_vars out_ids stmts   = trimInput (dsCmdStmts ids local_vars out_ids stmts)-   -- TODO: Add levity polymorphism check for the resulting expression.+   -- TODO: Add representation polymorphism check for the resulting expression.    -- But I (Richard E.) don't know enough about arrows to do so.  dsCmdStmts@@ -1197,11 +1245,12 @@  -- Balanced fold of a non-empty list. -foldb :: (a -> a -> a) -> [a] -> a-foldb _ [] = error "foldb of empty list"-foldb _ [x] = x+foldb :: (a -> a -> a) -> NonEmpty a -> a+foldb _ (x:|[]) = x foldb f xs = foldb f (fold_pairs xs)   where-    fold_pairs [] = []-    fold_pairs [x] = [x]-    fold_pairs (x1:x2:xs) = f x1 x2:fold_pairs xs+    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
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} @@ -22,14 +22,19 @@    ) where -#include "HsVersions.h"- import GHC.Prelude +import GHC.Driver.Session+import GHC.Driver.Ppr+import GHC.Driver.Config+import qualified GHC.LanguageExtensions as LangExt+import GHC.Unit.Module+ import {-# SOURCE #-}   GHC.HsToCore.Expr  ( dsLExpr ) import {-# SOURCE #-}   GHC.HsToCore.Match ( matchWrapper )  import GHC.HsToCore.Monad+import GHC.HsToCore.Errors.Types import GHC.HsToCore.GuardedRHSs import GHC.HsToCore.Utils import GHC.HsToCore.Pmc ( addTyCs, pmcGRHSs )@@ -43,39 +48,41 @@ import GHC.Core.Opt.Arity     ( etaExpand ) import GHC.Core.Unfold.Make import GHC.Core.FVs-import GHC.Data.Graph.Directed import GHC.Core.Predicate--import GHC.Builtin.Names import GHC.Core.TyCon-import GHC.Tc.Types.Evidence-import GHC.Tc.Utils.TcType import GHC.Core.Type import GHC.Core.Coercion import GHC.Core.Multiplicity+import GHC.Core.Rules++import GHC.Builtin.Names import GHC.Builtin.Types ( naturalTy, typeSymbolKind, charTy )++import GHC.Tc.Types.Evidence+ import GHC.Types.Id import GHC.Types.Name import GHC.Types.Var.Set-import GHC.Core.Rules import GHC.Types.Var.Env import GHC.Types.Var( EvVar )-import GHC.Utils.Outputable-import GHC.Utils.Panic-import GHC.Unit.Module 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.Types.Basic-import GHC.Driver.Session-import GHC.Driver.Ppr-import GHC.Driver.Config import GHC.Data.FastString++import GHC.Utils.Constants (debugIsOn) import GHC.Utils.Misc-import GHC.Types.Unique.Set( nonDetEltsUniqSet ) import GHC.Utils.Monad-import qualified GHC.LanguageExtensions as LangExt+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Utils.Panic.Plain+import GHC.Utils.Trace+ import Control.Monad  {-**********************************************************************@@ -90,15 +97,15 @@ dsTopLHsBinds binds      -- see Note [Strict binds checks]   | not (isEmptyBag unlifted_binds) || not (isEmptyBag bang_binds)-  = do { mapBagM_ (top_level_err "bindings for unlifted types") unlifted_binds-       ; mapBagM_ (top_level_err "strict bindings")             bang_binds+  = do { mapBagM_ (top_level_err UnliftedTypeBinds) unlifted_binds+       ; mapBagM_ (top_level_err StrictBinds)       bang_binds        ; return nilOL }    | otherwise   = do { (force_vars, prs) <- dsLHsBinds binds        ; when debugIsOn $          do { xstrict <- xoptM LangExt.Strict-            ; MASSERT2( null force_vars || xstrict, ppr binds $$ ppr force_vars ) }+            ; massertPpr (null force_vars || xstrict) (ppr binds $$ ppr force_vars) }               -- with -XStrict, even top-level vars are listed as force vars.         ; return (toOL prs) }@@ -107,10 +114,9 @@     unlifted_binds = filterBag (isUnliftedHsBind . unLoc) binds     bang_binds     = filterBag (isBangedHsBind   . unLoc) binds -    top_level_err desc (L loc bind)+    top_level_err bindsType (L loc bind)       = putSrcSpanDs (locA loc) $-        errDs (hang (text "Top-level" <+> text desc <+> text "aren't allowed:")-                  2 (ppr bind))+        diagnosticDs (DsTopLevelBindsNotAllowed bindsType bind)   -- | Desugar all other kind of bindings, Ids of strict binds are returned to@@ -158,9 +164,7 @@                           -- addTyCs: Add type evidence to the refinement type                           --            predicate of the coverage checker                           -- See Note [Long-distance information] in "GHC.HsToCore.Pmc"-                          matchWrapper-                           (mkPrefixFunRhs (L loc (idName fun)))-                           Nothing matches+                          matchWrapper (mkPrefixFunRhs (L loc (idName fun))) Nothing matches          ; core_wrap <- dsHsWrapper co_fn         ; let body' = mkOptTickBox tick body@@ -195,10 +199,12 @@                            else []         ; return (force_var', sel_binds) } -dsHsBind dflags (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts-                          , abs_exports = exports-                          , abs_ev_binds = ev_binds-                          , abs_binds = binds, abs_sig = has_sig })+dsHsBind+  dflags+  (XHsBindsLR (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts+                        , abs_exports = exports+                        , abs_ev_binds = ev_binds+                        , abs_binds = binds, abs_sig = has_sig }))   = do { ds_binds <- addTyCs FromSource (listToBag dicts) $                      dsLHsBinds binds              -- addTyCs: push type constraints deeper@@ -214,7 +220,7 @@  ----------------------- dsAbsBinds :: DynFlags-           -> [TyVar] -> [EvVar] -> [ABExport GhcTc]+           -> [TyVar] -> [EvVar] -> [ABExport]            -> [CoreBind]                -- Desugared evidence bindings            -> ([Id], [(Id,CoreExpr)])   -- Desugared value bindings            -> Bool                      -- Single binding with signature@@ -226,6 +232,9 @@     -- 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@@ -259,26 +268,28 @@      -- Another common case: no tyvars, no dicts     -- In this case we can have a much simpler desugaring+    --    lcl_id{inl-prag} = rhs  -- Auxiliary binds+    --    gbl_id = lcl_id |> co   -- Main binds   | null tyvars, null dicts--  = do { let mk_bind (ABE { abe_wrap = wrap-                          , abe_poly = global-                          , abe_mono = local-                          , abe_prags = prags })-              = do { core_wrap <- dsHsWrapper wrap-                   ; return (makeCorePair dflags global-                                          (isDefaultMethod prags)-                                          0 (core_wrap (Var local))) }-       ; main_binds <- mapM mk_bind exports+  = do { let mk_main :: ABExport -> DsM (Id, CoreExpr)+             mk_main (ABE { abe_poly = gbl_id, abe_mono = lcl_id+                          , abe_wrap = wrap })+                     -- No SpecPrags (no dicts)+                     -- Can't be a default method (default methods are singletons)+               = do { core_wrap <- dsHsWrapper wrap+                    ; return ( gbl_id `setInlinePragma` defaultInlinePragma+                             , core_wrap (Var lcl_id)) } -       ; return (force_vars, flattenBinds ds_ev_binds ++ bind_prs ++ main_binds) }+       ; main_prs <- mapM mk_main exports+       ; return (force_vars, flattenBinds ds_ev_binds+                              ++ mk_aux_binds bind_prs ++ main_prs ) }      -- The general case     -- See Note [Desugaring AbsBinds]   | otherwise-  = do { let core_bind = Rec [ makeCorePair dflags (add_inline lcl_id) False 0 rhs-                              | (lcl_id, rhs) <- bind_prs ]+  = do { let aux_binds = Rec (mk_aux_binds bind_prs)                 -- Monomorphic recursion possible, hence Rec+              new_force_vars = get_new_force_vars force_vars              locals       = map abe_mono exports              all_locals   = locals ++ new_force_vars@@ -286,7 +297,7 @@              tup_ty       = exprType tup_expr        ; let poly_tup_rhs = mkLams tyvars $ mkLams dicts $                             mkCoreLets ds_ev_binds $-                            mkLet core_bind $+                            mkLet aux_binds $                             tup_expr         ; poly_tup_id <- newSysLocalDs Many (exprType poly_tup_rhs)@@ -320,19 +331,21 @@                 , (poly_tup_id, poly_tup_rhs) :                    concat export_binds_s) }   where+    mk_aux_binds :: [(Id,CoreExpr)] -> [(Id,CoreExpr)]+    mk_aux_binds bind_prs = [ makeCorePair dflags lcl_w_inline False 0 rhs+                            | (lcl_id, rhs) <- bind_prs+                            , let lcl_w_inline = lookupVarEnv inline_env lcl_id+                                                 `orElse` lcl_id ]+     inline_env :: IdEnv Id -- Maps a monomorphic local Id to one with-                             -- the inline pragma from the source-                             -- The type checker put the inline pragma-                             -- on the *global* Id, so we need to transfer it+                           -- the inline pragma from the source+                           -- The type checker put the inline pragma+                           -- on the *global* Id, so we need to transfer it     inline_env       = mkVarEnv [ (lcl_id, setInlinePragma lcl_id prag)                  | ABE { abe_mono = lcl_id, abe_poly = gbl_id } <- exports                  , let prag = idInlinePragma gbl_id ] -    add_inline :: Id -> Id    -- tran-    add_inline lcl_id = lookupVarEnv inline_env lcl_id-                        `orElse` lcl_id-     global_env :: IdEnv Id -- Maps local Id to its global exported Id     global_env =       mkVarEnv [ (local, global)@@ -347,7 +360,7 @@             [] lcls      -- find exports or make up new exports for force variables-    get_exports :: [Id] -> DsM ([Id], [ABExport GhcTc])+    get_exports :: [Id] -> DsM ([Id], [ABExport])     get_exports lcls =       foldM (\(glbls, exports) lcl ->               case lookupVarEnv global_env lcl of@@ -360,8 +373,7 @@     mk_export local =       do global <- newSysLocalDs Many                      (exprType (mkLams tyvars (mkLams dicts (Var local))))-         return (ABE { abe_ext   = noExtField-                     , abe_poly  = global+         return (ABE { abe_poly  = global                      , abe_mono  = local                      , abe_wrap  = WpHole                      , abe_prags = SpecPrags [] })@@ -384,10 +396,10 @@   | otherwise   = case inlinePragmaSpec inline_prag of           NoUserInlinePrag -> (gbl_id, rhs)-          NoInline         -> (gbl_id, rhs)-          Inlinable        -> (gbl_id `setIdUnfolding` inlinable_unf, rhs)-          Inline           -> inline_pair-+          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@@ -616,8 +628,8 @@ There are several checks around properly formed strict bindings. They all link to this Note. These checks must be here in the desugarer because we cannot know whether or not a type is unlifted until after zonking, due-to levity polymorphism. These checks all used to be handled in the typechecker-in checkStrictBinds (before Jan '17).+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 @@ -665,16 +677,14 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))   | isJust (isClassOpId_maybe poly_id)   = putSrcSpanDs loc $-    do { warnDs NoReason (text "Ignoring useless SPECIALISE pragma for class method selector"-                          <+> quotes (ppr poly_id))+    do { diagnosticDs (DsUselessSpecialiseForClassMethodSelector poly_id)        ; return Nothing  }  -- There is no point in trying to specialise a class op                             -- Moreover, classops don't (currently) have an inl_sat arity set                             -- (it would be Just 0) and that in turn makes makeCorePair bleat    | no_act_spec && isNeverActive rule_act   = putSrcSpanDs loc $-    do { warnDs NoReason (text "Ignoring useless SPECIALISE pragma for NOINLINE function:"-                          <+> quotes (ppr poly_id))+    do { diagnosticDs (DsUselessSpecialiseForNoInlineFunction poly_id)        ; return Nothing  }  -- Function is NOINLINE, and the specialisation inherits that                             -- See Note [Activation pragmas for SPECIALISE] @@ -699,7 +709,7 @@          --                         , text "ds_rhs:" <+> ppr ds_lhs ]) $          dflags <- getDynFlags        ; case decomposeRuleLhs dflags spec_bndrs ds_lhs of {-           Left msg -> do { warnDs NoReason msg; return Nothing } ;+           Left msg -> do { diagnosticDs msg; return Nothing } ;            Right (rule_bndrs, _fn, rule_lhs_args) -> do         { this_mod <- getModule@@ -720,7 +730,7 @@  -- Commented out: see Note [SPECIALISE on INLINE functions] --       ; when (isInlinePragma id_inl)---              (warnDs $ text "SPECIALISE pragma on INLINE function probably won't fire:"+--              (diagnosticDs $ text "SPECIALISE pragma on INLINE function probably won't fire:" --                        <+> quotes (ppr poly_name))         ; return (Just (unitOL (spec_id, spec_rhs), rule))@@ -757,8 +767,9 @@     -- no_act_spec is True if the user didn't write an explicit     -- phase specification in the SPECIALISE pragma     no_act_spec = case inlinePragmaSpec spec_inl of-                    NoInline -> isNeverActive  spec_prag_act-                    _        -> isAlwaysActive spec_prag_act+                    NoInline _   -> isNeverActive  spec_prag_act+                    Opaque _     -> isNeverActive  spec_prag_act+                    _            -> isAlwaysActive spec_prag_act     rule_act | no_act_spec = inlinePragmaActivation id_inl   -- Inherit              | otherwise   = spec_prag_act                   -- Specified by user @@ -767,14 +778,10 @@        -> Name -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> DsM CoreRule dsMkUserRule this_mod is_local name act fn bndrs args rhs = do     let rule = mkRule this_mod False is_local name act fn bndrs args rhs-    dflags <- getDynFlags-    when (isOrphan (ru_orphan rule) && wopt Opt_WarnOrphans dflags) $-        warnDs (Reason Opt_WarnOrphans) (ruleOrphWarn rule)+    when (isOrphan (ru_orphan rule)) $+        diagnosticDs (DsOrphanRule rule)     return rule -ruleOrphWarn :: CoreRule -> SDoc-ruleOrphWarn rule = text "Orphan rule:" <+> ppr rule- {- Note [SPECIALISE on INLINE functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We used to warn that using SPECIALISE for a function marked INLINE@@ -837,7 +844,7 @@ -}  decomposeRuleLhs :: DynFlags -> [Var] -> CoreExpr-                 -> Either SDoc ([Var], Id, [CoreExpr])+                 -> 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])@@ -847,10 +854,10 @@ decomposeRuleLhs dflags orig_bndrs orig_lhs   | not (null unbound)    -- Check for things unbound on LHS                           -- See Note [Unused spec binders]-  = Left (vcat (map dead_msg unbound))+  = Left (DsRuleBindersNotBound unbound orig_bndrs orig_lhs lhs2)   | Var funId <- fun2   , Just con <- isDataConId_maybe funId-  = Left (constructor_msg con) -- See Note [No RULES on datacons]+  = Left (DsRuleIgnoredDueToConstructor con) -- See Note [No RULES on datacons]   | Just (fn_id, args) <- decompose fun2 args2   , let extra_bndrs = mk_extra_bndrs fn_id args   = -- pprTrace "decomposeRuleLhs" (vcat [ text "orig_bndrs:" <+> ppr orig_bndrs@@ -862,7 +869,7 @@     Right (orig_bndrs ++ extra_bndrs, fn_id, args)    | otherwise-  = Left bad_shape_msg+  = Left (DsRuleLhsTooComplicated orig_lhs lhs2)  where    simpl_opts   = initSimpleOpts dflags    lhs1         = drop_dicts orig_lhs@@ -894,24 +901,6 @@     decompose _ _ = Nothing -   bad_shape_msg = hang (text "RULE left-hand side too complicated to desugar")-                      2 (vcat [ text "Optimised lhs:" <+> ppr lhs2-                              , text "Orig lhs:" <+> ppr orig_lhs])-   dead_msg bndr = hang (sep [ text "Forall'd" <+> pp_bndr bndr-                             , text "is not bound in RULE lhs"])-                      2 (vcat [ text "Orig bndrs:" <+> ppr orig_bndrs-                              , text "Orig lhs:" <+> ppr orig_lhs-                              , text "optimised lhs:" <+> ppr lhs2 ])-   pp_bndr bndr-    | isTyVar bndr = text "type variable" <+> quotes (ppr bndr)-    | isEvVar bndr = text "constraint"    <+> quotes (ppr (varType bndr))-    | otherwise    = text "variable"      <+> quotes (ppr bndr)--   constructor_msg con = vcat-     [ text "A constructor," <+> ppr con <>-         text ", appears as outermost match in RULE lhs."-     , text "This rule will be ignored." ]-    drop_dicts :: CoreExpr -> CoreExpr    drop_dicts e        = wrap_lets needed bnds body@@ -1130,28 +1119,25 @@                                    ; return (w1 . w2) }  -- See comments on WpFun in GHC.Tc.Types.Evidence for an explanation of what  -- the specification of this clause is-dsHsWrapper (WpFun c1 c2 (Scaled w t1) doc)-                              = do { x <- newSysLocalDsNoLP w t1+dsHsWrapper (WpFun c1 c2 (Scaled w t1))+                              = do { x <- newSysLocalDs w t1                                    ; w1 <- dsHsWrapper c1                                    ; w2 <- dsHsWrapper c2                                    ; let app f a = mkCoreAppDs (text "dsHsWrapper") f a                                          arg     = w1 (Var x)-                                   ; (_, ok) <- askNoErrsDs $ dsNoLevPolyExpr arg doc-                                   ; if ok-                                     then return (\e -> (Lam x (w2 (app e arg))))-                                     else return id }  -- this return is irrelevant-dsHsWrapper (WpCast co)       = ASSERT(coercionRole co == Representational)+                                   ; return (\e -> (Lam x (w2 (app e arg)))) }+dsHsWrapper (WpCast co)       = assert (coercionRole co == Representational) $                                 return $ \e -> mkCastDs e co dsHsWrapper (WpEvApp tm)      = do { core_tm <- dsEvTerm tm                                    ; return (\e -> App e core_tm) }   -- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify. dsHsWrapper (WpMultCoercion co) = do { when (not (isReflexiveCo co)) $-                                         errDs (text "Multiplicity coercions are currently not supported")+                                         diagnosticDs DsMultiplicityCoercionsNotSupported                                      ; return $ \e -> e } -------------------------------------- dsTcEvBinds_s :: [TcEvBinds] -> DsM [CoreBind] dsTcEvBinds_s []       = return []-dsTcEvBinds_s (b:rest) = ASSERT( null rest )  -- Zonker ensures null+dsTcEvBinds_s (b:rest) = assert (null rest) $  -- Zonker ensures null                          dsTcEvBinds b  dsTcEvBinds :: TcEvBinds -> DsM [CoreBind]@@ -1286,7 +1272,7 @@        ; 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)+                    --            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])
GHC/HsToCore/Coverage.hs view
@@ -9,14 +9,16 @@ (c) University of Glasgow, 2007 -} -module GHC.HsToCore.Coverage (addTicksToBinds, hpcInitCode) where+module GHC.HsToCore.Coverage+  ( CoverageConfig (..)+  , addTicksToBinds+  , hpcInitCode+  ) where  import GHC.Prelude as Prelude  import GHC.Driver.Session import GHC.Driver.Backend-import GHC.Driver.Ppr-import GHC.Driver.Env  import qualified GHC.Runtime.Interpreter as GHCi import GHCi.RemoteTypes@@ -33,6 +35,10 @@ import GHC.Data.FastString import GHC.Data.Bag +import GHC.Platform++import GHC.Runtime.Interpreter.Types+ import GHC.Utils.Misc import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic@@ -72,8 +78,17 @@ ************************************************************************ -} +data CoverageConfig = CoverageConfig+  { coverageConfig_logger   :: Logger++  -- FIXME: replace this with the specific fields of DynFlags we care about.+  , coverageConfig_dynFlags :: DynFlags++  , coverageConfig_mInterp  :: Maybe Interp+  }+ addTicksToBinds-        :: HscEnv+        :: CoverageConfig         -> Module         -> ModLocation          -- ... off the current module         -> NameSet              -- Exported Ids.  When we call addTicksToBinds,@@ -83,9 +98,13 @@         -> LHsBinds GhcTc         -> IO (LHsBinds GhcTc, HpcInfo, Maybe ModBreaks) -addTicksToBinds hsc_env mod mod_loc exports tyCons binds-  | let dflags = hsc_dflags hsc_env-        passes = coveragePasses dflags+addTicksToBinds (CoverageConfig+                 { coverageConfig_logger = logger+                 , coverageConfig_dynFlags = dflags+                 , coverageConfig_mInterp = m_interp+                 })+                mod mod_loc exports tyCons binds+  | let passes = coveragePasses dflags   , not (null passes)   , Just orig_file <- ml_hs_file mod_loc = do @@ -95,7 +114,7 @@             let env = TTE                       { fileName     = mkFastString orig_file2                       , declPath     = []-                      , tte_dflags   = dflags+                      , tte_countEntries = gopt Opt_ProfCountEntries dflags                       , exports      = exports                       , inlines      = emptyVarSet                       , inScope      = emptyVarSet@@ -121,10 +140,9 @@      let tickCount = tickBoxCount st          entries = reverse $ mixEntries st      hashNo <- writeMixEntries dflags mod tickCount entries orig_file2-     modBreaks <- mkModBreaks hsc_env mod tickCount entries+     modBreaks <- mkModBreaks m_interp dflags mod tickCount entries -     let logger = hsc_logger hsc_env-     dumpIfSet_dyn logger dflags Opt_D_dump_ticked "HPC" FormatHaskell+     putDumpFileMaybe logger Opt_D_dump_ticked "HPC" FormatHaskell        (pprLHsBinds binds1)       return (binds1, HpcInfo tickCount hashNo, modBreaks)@@ -144,12 +162,12 @@         _ -> orig_file  -mkModBreaks :: HscEnv -> Module -> Int -> [MixEntry_] -> IO (Maybe ModBreaks)-mkModBreaks hsc_env mod count entries-  | Just interp <- hsc_interp hsc_env-  , breakpointsEnabled (hsc_dflags hsc_env) = do+mkModBreaks :: Maybe Interp -> DynFlags -> Module -> Int -> [MixEntry_] -> IO (Maybe ModBreaks)+mkModBreaks m_interp dflags mod count entries+  | Just interp <- m_interp+  , breakpointsEnabled dflags = do     breakArray <- GHCi.newBreakArray interp (length entries)-    ccs <- mkCCSArray hsc_env mod count entries+    ccs <- mkCCSArray interp mod count entries     let            locsTicks  = listArray (0,count-1) [ span  | (span,_,_,_)  <- entries ]            varsTicks  = listArray (0,count-1) [ vars  | (_,_,vars,_)  <- entries ]@@ -164,21 +182,18 @@   | otherwise = return Nothing  mkCCSArray-  :: HscEnv -> Module -> Int -> [MixEntry_]+  :: Interp -> Module -> Int -> [MixEntry_]   -> IO (Array BreakIndex (RemotePtr GHC.Stack.CCS.CostCentre))-mkCCSArray hsc_env modul count entries =-  case hsc_interp hsc_env of-    Just interp | GHCi.interpreterProfiled interp -> do+mkCCSArray interp modul count entries+  | GHCi.interpreterProfiled interp = do       let module_str = moduleNameString (moduleName modul)       costcentres <- GHCi.mkCostCentres interp module_str (map mk_one entries)       return (listArray (0,count-1) costcentres)--    _ -> return (listArray (0,-1) [])+  | otherwise = return (listArray (0,-1) [])  where-    dflags = hsc_dflags hsc_env     mk_one (srcspan, decl_path, _, _) = (name, src)       where name = concat (intersperse "." decl_path)-            src = showSDoc dflags (ppr srcspan)+            src = renderWithContext defaultSDocContext (ppr srcspan)   writeMixEntries@@ -270,12 +285,13 @@ addTickLHsBinds = mapBagM addTickLHsBind  addTickLHsBind :: LHsBind GhcTc -> TM (LHsBind GhcTc)-addTickLHsBind (L pos bind@(AbsBinds { abs_binds   = binds,-                                       abs_exports = abs_exports })) =+addTickLHsBind (L pos (XHsBindsLR bind@(AbsBinds { abs_binds = binds+                                                 , abs_exports = abs_exports+                                                 }))) =   withEnv add_exports $     withEnv add_inlines $ do       binds' <- addTickLHsBinds binds-      return $ L pos $ bind { abs_binds = binds' }+      return $ L pos $ XHsBindsLR $ bind { abs_binds = binds' }   where    -- in AbsBinds, the Id on each binding is not the actual top-level    -- Id that we are defining, they are related by the abs_exports@@ -400,7 +416,7 @@   -- Note [inline sccs]---+-- ~~~~~~~~~~~~~~~~~~ -- The reason not to add ticks to INLINE functions is that this is -- sometimes handy for avoiding adding a tick to a particular function -- (see #6131)@@ -518,26 +534,21 @@ addTickHsExpr :: HsExpr GhcTc -> TM (HsExpr GhcTc) addTickHsExpr e@(HsVar _ (L _ id))  = do freeVar id; return e addTickHsExpr e@(HsUnboundVar {})   = return e-addTickHsExpr e@(HsRecFld _ (Ambiguous id _))   = do freeVar id; return e-addTickHsExpr e@(HsRecFld _ (Unambiguous id _)) = do freeVar id; return e+addTickHsExpr e@(HsRecSel _ (FieldOcc id _))   = do freeVar id; return e -addTickHsExpr e@(HsConLikeOut {}) = return e-  -- We used to do a freeVar on a pat-syn builder, but actually-  -- such builders are never in the inScope env, which-  -- doesn't include top level bindings-addTickHsExpr e@(HsIPVar {})     = return e-addTickHsExpr e@(HsOverLit {})   = return e-addTickHsExpr e@(HsOverLabel{})  = return e-addTickHsExpr e@(HsLit {})       = return e-addTickHsExpr (HsLam x mg)       = liftM (HsLam x)-                                         (addTickMatchGroup True mg)-addTickHsExpr (HsLamCase x mgs)  = liftM (HsLamCase x)-                                         (addTickMatchGroup True mgs)-addTickHsExpr (HsApp x e1 e2)    = liftM2 (HsApp x) (addTickLHsExprNever e1)-                                                    (addTickLHsExpr      e2)-addTickHsExpr (HsAppType x e ty) = liftM3 HsAppType (return x)-                                                    (addTickLHsExprNever e)-                                                    (return ty)+addTickHsExpr e@(HsIPVar {})            = return e+addTickHsExpr e@(HsOverLit {})          = return e+addTickHsExpr e@(HsOverLabel{})         = return e+addTickHsExpr e@(HsLit {})              = return e+addTickHsExpr (HsLam x mg)              = liftM (HsLam x)+                                                (addTickMatchGroup True mg)+addTickHsExpr (HsLamCase x lc_variant mgs) = liftM (HsLamCase x lc_variant)+                                                   (addTickMatchGroup True mgs)+addTickHsExpr (HsApp x e1 e2)          = liftM2 (HsApp x) (addTickLHsExprNever e1)+                                                          (addTickLHsExpr      e2)+addTickHsExpr (HsAppType x e ty)       = liftM3 HsAppType (return x)+                                                          (addTickLHsExprNever e)+                                                          (return ty) addTickHsExpr (OpApp fix e1 e2 e3) =         liftM4 OpApp                 (return fix)@@ -548,8 +559,9 @@         liftM2 (NegApp x)                 (addTickLHsExpr e)                 (addTickSyntaxExpr hpcSrcSpan neg)-addTickHsExpr (HsPar x e) =-        liftM (HsPar x) (addTickLHsExprEvalInner e)+addTickHsExpr (HsPar x lpar e rpar) = do+        e' <- addTickLHsExprEvalInner e+        return (HsPar x lpar e' rpar) addTickHsExpr (SectionL x e1 e2) =         liftM2 (SectionL x)                 (addTickLHsExpr e1)@@ -579,11 +591,11 @@   = do { let isOneOfMany = case alts of [_] -> False; _ -> True        ; alts' <- mapM (liftL $ addTickGRHS isOneOfMany False) alts        ; return $ HsMultiIf ty alts' }-addTickHsExpr (HsLet x binds e) =-        bindLocals (collectLocalBinders CollNoDictBinders binds) $-          liftM2 (HsLet x)-                  (addTickHsLocalBinds binds) -- to think about: !patterns.-                  (addTickLHsExprLetBody e)+addTickHsExpr (HsLet x tkLet binds tkIn e) =+        bindLocals (collectLocalBinders CollNoDictBinders binds) $ do+          binds' <- addTickHsLocalBinds binds -- to think about: !patterns.+          e' <- addTickLHsExprLetBody e+          return (HsLet x tkLet binds' tkIn e') addTickHsExpr (HsDo srcloc cxt (L l stmts))   = do { (stmts', _) <- addTickLStmts' forQual stmts (return ())        ; return (HsDo srcloc cxt (L l stmts')) }@@ -624,17 +636,10 @@                    addTickWit (Just fl) = do fl' <- addTickSyntaxExpr hpcSrcSpan fl                                              return (Just fl') --- We might encounter existing ticks (multiple Coverage passes)-addTickHsExpr (HsTick x t e) =-        liftM (HsTick x t) (addTickLHsExprNever e)-addTickHsExpr (HsBinTick x t0 t1 e) =-        liftM (HsBinTick x t0 t1) (addTickLHsExprNever e)- addTickHsExpr (HsPragE x p e) =         liftM (HsPragE x p) (addTickLHsExpr e)-addTickHsExpr e@(HsBracket     {})   = return e-addTickHsExpr e@(HsTcBracketOut  {}) = return e-addTickHsExpr e@(HsRnBracketOut  {}) = return e+addTickHsExpr e@(HsTypedBracket {})  = return e+addTickHsExpr e@(HsUntypedBracket{}) = return e addTickHsExpr e@(HsSpliceE  {})      = return e addTickHsExpr e@(HsGetField {})      = return e addTickHsExpr e@(HsProjection {})    = return e@@ -649,6 +654,17 @@         liftM (XExpr . ExpansionExpr . HsExpanded a) $               (addTickHsExpr b) +addTickHsExpr e@(XExpr (ConLikeTc {})) = return e+  -- We used to do a freeVar on a pat-syn builder, but actually+  -- such builders are never in the inScope env, which+  -- doesn't include top level bindings++-- We might encounter existing ticks (multiple Coverage passes)+addTickHsExpr (XExpr (HsTick t e)) =+        liftM (XExpr . HsTick t) (addTickLHsExprNever e)+addTickHsExpr (XExpr (HsBinTick t0 t1 e)) =+        liftM (XExpr . HsBinTick t0 t1) (addTickLHsExprNever e)+ addTickTupArg :: HsTupArg GhcTc -> TM (HsTupArg GhcTc) addTickTupArg (Present x e)  = do { e' <- addTickLHsExpr e                                   ; return (Present x e') }@@ -830,9 +846,8 @@  addTickIPBind :: IPBind GhcTc -> TM (IPBind GhcTc) addTickIPBind (IPBind x nm e) =-        liftM2 (IPBind x)-                (return nm)-                (addTickLHsExpr e)+        liftM (IPBind x nm)+               (addTickLHsExpr e)  -- There is no location here, so we might need to use a context location?? addTickSyntaxExpr :: SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc)@@ -869,23 +884,25 @@                 (return fix)                 (addTickLHsCmd c3) -}-addTickHsCmd (HsCmdPar x e) = liftM (HsCmdPar x) (addTickLHsCmd e)+addTickHsCmd (HsCmdPar x lpar e rpar) = do+        e' <- addTickLHsCmd e+        return (HsCmdPar x lpar e' rpar) addTickHsCmd (HsCmdCase x e mgs) =         liftM2 (HsCmdCase x)                 (addTickLHsExpr e)                 (addTickCmdMatchGroup mgs)-addTickHsCmd (HsCmdLamCase x mgs) =-        liftM (HsCmdLamCase x) (addTickCmdMatchGroup mgs)+addTickHsCmd (HsCmdLamCase x lc_variant mgs) =+        liftM (HsCmdLamCase x lc_variant) (addTickCmdMatchGroup mgs) addTickHsCmd (HsCmdIf x cnd e1 c2 c3) =         liftM3 (HsCmdIf x cnd)                 (addBinTickLHsExpr (BinBox CondBinBox) e1)                 (addTickLHsCmd c2)                 (addTickLHsCmd c3)-addTickHsCmd (HsCmdLet x binds c) =-        bindLocals (collectLocalBinders CollNoDictBinders binds) $-          liftM2 (HsCmdLet x)-                   (addTickHsLocalBinds binds) -- to think about: !patterns.-                   (addTickLHsCmd c)+addTickHsCmd (HsCmdLet x tkLet binds tkIn c) =+        bindLocals (collectLocalBinders CollNoDictBinders binds) $ do+          binds' <- addTickHsLocalBinds binds -- to think about: !patterns.+          c' <- addTickLHsCmd c+          return (HsCmdLet x tkLet binds' tkIn c') addTickHsCmd (HsCmdDo srcloc (L l stmts))   = do { (stmts', _) <- addTickLCmdStmts' stmts (return ())        ; return (HsCmdDo srcloc (L l stmts')) }@@ -992,11 +1009,11 @@   = do  { fields' <- mapM addTickHsRecField fields         ; return (HsRecFields fields' dd) } -addTickHsRecField :: LHsRecField' GhcTc id (LHsExpr GhcTc)-                  -> TM (LHsRecField' GhcTc id (LHsExpr GhcTc))-addTickHsRecField (L l (HsRecField x id expr pun))+addTickHsRecField :: LHsFieldBind GhcTc id (LHsExpr GhcTc)+                  -> TM (LHsFieldBind GhcTc id (LHsExpr GhcTc))+addTickHsRecField (L l (HsFieldBind x id expr pun))         = do { expr' <- addTickLHsExpr expr-             ; return (L l (HsRecField x id expr' pun)) }+             ; return (L l (HsFieldBind x id expr' pun)) }  addTickArithSeqInfo :: ArithSeqInfo GhcTc -> TM (ArithSeqInfo GhcTc) addTickArithSeqInfo (From e1) =@@ -1032,7 +1049,9 @@  data TickTransEnv = TTE { fileName     :: FastString                         , density      :: TickDensity-                        , tte_dflags   :: DynFlags+                        , tte_countEntries :: !Bool+                          -- ^ Whether the number of times functions are+                          -- entered should be counted.                         , exports      :: NameSet                         , inlines      :: VarSet                         , declPath     :: [String]@@ -1073,6 +1092,7 @@ noFVs = emptyOccEnv  -- Note [freevars]+-- ~~~~~~~~~~~~~~~ --   For breakpoints we want to collect the free variables of an --   expression for pinning on the HsTick.  We don't want to collect --   *all* free variables though: in particular there's no point pinning@@ -1101,9 +1121,6 @@                                        (r2,fv2,st2) ->                                           (r2, fv1 `plusOccEnv` fv2, st2) -instance HasDynFlags TM where-  getDynFlags = TM $ \ env st -> (tte_dflags env, noFVs, st)- -- | Get the next HPC cost centre index for a given centre name getCCIndexM :: FastString -> TM CostCentreIndex getCCIndexM n = TM $ \_ st -> let (idx, is') = getCCIndex n $@@ -1186,7 +1203,7 @@     (fvs, e) <- getFreeVars m     env <- getEnv     tickish <- mkTickish boxLabel countEntries topOnly pos fvs (declPath env)-    return (L (noAnnSrcSpan pos) (HsTick noExtField tickish (L (noAnnSrcSpan pos) e)))+    return (L (noAnnSrcSpan pos) (XExpr $ HsTick tickish $ L (noAnnSrcSpan pos) e))   ) (do     e <- m     return (L (noAnnSrcSpan pos) e)@@ -1212,7 +1229,7 @@           -> TM CoreTickish mkTickish boxLabel countEntries topOnly pos fvs decl_path = do -  let ids = filter (not . isUnliftedType . idType) $ occEnvElts fvs+  let ids = filter (not . mightBeUnliftedType . idType) $ nonDetOccEnvElts fvs           -- unlifted types cause two problems here:           --   * we can't bind them  at the GHCi prompt           --     (bindLocalsAtBreakpoint already filters them out),@@ -1224,7 +1241,6 @@       cc_name | topOnly   = head decl_path               | otherwise = concat (intersperse "." decl_path) -  dflags <- getDynFlags   env <- getEnv   case tickishType env of     HpcTicks -> HpcTick (this_mod env) <$> addMixEntry me@@ -1233,7 +1249,7 @@       let nm = mkFastString cc_name       flavour <- HpcCC <$> getCCIndexM nm       let cc = mkUserCC nm (this_mod env) pos flavour-          count = countEntries && gopt Opt_ProfCountEntries dflags+          count = countEntries && tte_countEntries env       return $ ProfNote cc count True{-scopes-}      Breakpoints -> Breakpoint noExtField <$> addMixEntry me <*> pure ids@@ -1259,14 +1275,14 @@                 -> TM (LHsExpr GhcTc) mkBinTickBoxHpc boxLabel pos e = do   env <- getEnv-  binTick <- HsBinTick noExtField+  binTick <- HsBinTick     <$> addMixEntry (pos,declPath env, [],boxLabel True)     <*> addMixEntry (pos,declPath env, [],boxLabel False)     <*> pure e   tick <- HpcTick (this_mod env)     <$> addMixEntry (pos,declPath env, [],ExpBox False)   let pos' = noAnnSrcSpan pos-  return $ L pos' $ HsTick noExtField tick (L pos' binTick)+  return $ L pos' $ XExpr $ HsTick tick (L pos' (XExpr binTick))  mkHpcPos :: SrcSpan -> HpcPos mkHpcPos pos@(RealSrcSpan s _)@@ -1324,27 +1340,21 @@  hs_hpc_module("Main",8,1150288664,_hpc_tickboxes_Main_hpc);} -} -hpcInitCode :: DynFlags -> Module -> HpcInfo -> CStub+hpcInitCode :: Platform -> Module -> HpcInfo -> CStub hpcInitCode _ _ (NoHpcInfo {}) = mempty-hpcInitCode dflags this_mod (HpcInfo tickCount hashNo)- = CStub $ vcat-    [ text "static void hpc_init_" <> ppr this_mod-         <> text "(void) __attribute__((constructor));"-    , text "static void hpc_init_" <> ppr this_mod <> text "(void)"-    , braces (vcat [-        text "extern StgWord64 " <> tickboxes <>-               text "[]" <> semi,-        text "hs_hpc_module" <>-          parens (hcat (punctuate comma [-              doubleQuotes full_name_str,-              int tickCount, -- really StgWord32-              int hashNo,    -- really StgWord32-              tickboxes-            ])) <> semi-       ])-    ]+hpcInitCode platform this_mod (HpcInfo tickCount hashNo)+ = initializerCStub platform fn_name decls body   where-    platform  = targetPlatform dflags+    fn_name = mkInitializerStubLabel this_mod "hpc"+    decls = text "extern StgWord64 " <> tickboxes <> text "[]" <> semi+    body = text "hs_hpc_module" <>+              parens (hcat (punctuate comma [+                  doubleQuotes full_name_str,+                  int tickCount, -- really StgWord32+                  int hashNo,    -- really StgWord32+                  tickboxes+                ])) <> semi+     tickboxes = pprCLabel platform CStyle (mkHpcTicksLabel $ this_mod)      module_name  = hcat (map (text.charToC) $ BS.unpack $
GHC/HsToCore/Docs.hs view
@@ -8,8 +8,6 @@ {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE BangPatterns #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}- module GHC.HsToCore.Docs where  import GHC.Prelude@@ -32,89 +30,237 @@ import Data.Bifunctor (first) import Data.IntMap (IntMap) import qualified Data.IntMap as IM-import Data.Map (Map)+import Data.Map.Strict (Map) import qualified Data.Map as M+import qualified Data.Set as Set import Data.Maybe import Data.Semigroup import GHC.IORef (readIORef)+import GHC.Unit.Types+import GHC.Hs+import GHC.Types.Avail+import GHC.Unit.Module+import qualified Data.List.NonEmpty as NonEmpty+import Data.List.NonEmpty (NonEmpty ((:|)))+import GHC.Unit.Module.Imported+import GHC.Driver.Session+import GHC.Types.TypeEnv+import GHC.Types.Id+import GHC.Types.Unique.Map  -- | Extract docs from renamer output. -- This is monadic since we need to be able to read documentation added from -- Template Haskell's @putDoc@, which is stored in 'tcg_th_docs'. extractDocs :: MonadIO m-            => TcGblEnv-            -> m (Maybe HsDocString, DeclDocMap, ArgDocMap)+            => DynFlags -> TcGblEnv+            -> m (Maybe Docs)             -- ^             -- 1. Module header             -- 2. Docs on top level declarations             -- 3. Docs on arguments-extractDocs TcGblEnv { tcg_semantic_mod = mod-                     , tcg_rn_decls = mb_rn_decls-                     , tcg_insts = insts-                     , tcg_fam_insts = fam_insts-                     , tcg_doc_hdr = mb_doc_hdr-                     , tcg_th_docs = th_docs_var-                     } = do+extractDocs dflags+      TcGblEnv { tcg_semantic_mod = semantic_mdl+               , tcg_mod = mdl+               , tcg_rn_decls = Just rn_decls+               , tcg_rn_exports = mb_rn_exports+               , tcg_exports = all_exports+               , tcg_imports = import_avails+               , tcg_insts = insts+               , tcg_fam_insts = fam_insts+               , tcg_doc_hdr = mb_doc_hdr+               , tcg_th_docs = th_docs_var+               , tcg_type_env = ty_env+               } = do     th_docs <- liftIO $ readIORef th_docs_var-    let doc_hdr = th_doc_hdr <|> (unLoc <$> mb_doc_hdr)-        ExtractedTHDocs-          th_doc_hdr-          (DeclDocMap th_doc_map)-          (ArgDocMap th_arg_map)-          (DeclDocMap th_inst_map) = extractTHDocs th_docs-    return-      ( doc_hdr-      , DeclDocMap (th_doc_map <> th_inst_map <> doc_map)-      , ArgDocMap (th_arg_map `unionArgMaps` arg_map)-      )+    let doc_hdr = (unLoc <$> mb_doc_hdr)+        ExtractedTHDocs th_hdr th_decl_docs th_arg_docs th_inst_docs = extractTHDocs th_docs+        mod_docs+         =  Docs+         { docs_mod_hdr = th_hdr <|> doc_hdr+         -- Left biased union (see #21220)+         , docs_decls = plusUniqMap_C (\a _ -> a)+                          ((:[]) <$> th_decl_docs `plusUniqMap` th_inst_docs)+                          -- These will not clash so safe to use plusUniqMap+                          doc_map+         , docs_args = th_arg_docs `unionArgMaps` arg_map+         , docs_structure = doc_structure+         , docs_named_chunks = named_chunks+         , docs_haddock_opts = haddockOptions dflags+         , docs_language = language_+         , docs_extensions = exts+         }+    pure (Just mod_docs)   where-    (doc_map, arg_map) = maybe (M.empty, M.empty)-                               (mkMaps local_insts)-                               mb_decls_with_docs-    mb_decls_with_docs = topDecls <$> mb_rn_decls-    local_insts = filter (nameIsLocalOrFrom mod)+    exts = extensionFlags dflags+    language_ = language dflags++    -- We need to lookup the Names for default methods, so we+    -- can put them in the correct map+    -- See Note [default method Name] in GHC.Iface.Recomp+    def_meths_env = mkOccEnv [(occ, nm)+                             | id <- typeEnvIds ty_env+                             , let nm = idName id+                                   occ = nameOccName nm+                             , isDefaultMethodOcc occ+                             ]++    (doc_map, arg_map) = mkMaps def_meths_env local_insts decls_with_docs+    decls_with_docs = topDecls rn_decls+    local_insts = filter (nameIsLocalOrFrom semantic_mdl)                          $ map getName insts ++ map getName fam_insts+    doc_structure = mkDocStructure mdl import_avails mb_rn_exports rn_decls+                                   all_exports def_meths_env+    named_chunks = getNamedChunks (isJust mb_rn_exports) rn_decls+extractDocs _ _ = pure Nothing +-- | If we have an explicit export list, we extract the documentation structure+-- from that.+-- Otherwise we use the renamed exports and declarations.+mkDocStructure :: Module                               -- ^ The current module+               -> ImportAvails                         -- ^ Imports+               -> Maybe [(LIE GhcRn, Avails)] -- ^ Explicit export list+               -> HsGroup GhcRn+               -> [AvailInfo]                          -- ^ All exports+               -> OccEnv Name                          -- ^ Default Methods+               -> DocStructure+mkDocStructure mdl import_avails (Just export_list) _ _ _ =+    mkDocStructureFromExportList mdl import_avails export_list+mkDocStructure _ _ Nothing rn_decls all_exports def_meths_env =+    mkDocStructureFromDecls def_meths_env all_exports rn_decls++-- TODO:+-- * Maybe remove items that export nothing?+-- * Combine sequences of DsiExports?+-- * Check the ordering of avails in DsiModExport+mkDocStructureFromExportList+  :: Module                         -- ^ The current module+  -> ImportAvails+  -> [(LIE GhcRn, Avails)] -- ^ Explicit export list+  -> DocStructure+mkDocStructureFromExportList mdl import_avails export_list =+    toDocStructure . first unLoc <$> export_list+  where+    toDocStructure :: (IE GhcRn, Avails) -> DocStructureItem+    toDocStructure = \case+      (IEModuleContents _ lmn, avails) -> moduleExport (unLoc lmn) avails+      (IEGroup _ level doc, _)         -> DsiSectionHeading level (unLoc doc)+      (IEDoc _ doc, _)                 -> DsiDocChunk (unLoc doc)+      (IEDocNamed _ name, _)           -> DsiNamedChunkRef name+      (_, avails)                      -> DsiExports (nubAvails avails)++    moduleExport :: ModuleName -- Alias+                 -> Avails+                 -> DocStructureItem+    moduleExport alias avails =+        DsiModExport (nubSortNE orig_names) (nubAvails avails)+      where+        orig_names = M.findWithDefault aliasErr alias aliasMap+        aliasErr = error $ "mkDocStructureFromExportList: "+                           ++ (moduleNameString . moduleName) mdl+                           ++ ": Can't find alias " ++ moduleNameString alias+        nubSortNE = NonEmpty.fromList .+                    Set.toList .+                    Set.fromList .+                    NonEmpty.toList++    -- Map from aliases to true module names.+    aliasMap :: Map ModuleName (NonEmpty ModuleName)+    aliasMap =+        M.fromListWith (<>) $+          (this_mdl_name, this_mdl_name :| [])+          : (flip concatMap (moduleEnvToList imported) $ \(mdl, imvs) ->+              [(imv_name imv, moduleName mdl :| []) | imv <- imvs])+      where+        this_mdl_name = moduleName mdl++    imported :: ModuleEnv [ImportedModsVal]+    imported = mapModuleEnv importedByUser (imp_mods import_avails)++-- | Figure out the documentation structure by correlating+-- the module exports with the located declarations.+mkDocStructureFromDecls :: OccEnv Name -- ^ The default method environment+                        -> [AvailInfo] -- ^ All exports, unordered+                        -> HsGroup GhcRn+                        -> DocStructure+mkDocStructureFromDecls env all_exports decls =+    map unLoc (sortLocated (docs ++ avails))+  where+    avails :: [Located DocStructureItem]+    avails = flip fmap all_exports $ \avail ->+      case M.lookup (availName avail) name_locs of+        Just loc -> L loc (DsiExports [avail])+        -- FIXME: This is just a workaround that we use when handling e.g.+        -- associated data families like in the html-test Instances.hs.+        Nothing -> noLoc (DsiExports [avail])+        -- Nothing -> panicDoc "mkDocStructureFromDecls: No loc found for"+        --                     (ppr avail)++    docs = mapMaybe structuralDoc (hs_docs decls)++    structuralDoc :: LDocDecl GhcRn+                  -> Maybe (Located DocStructureItem)+    structuralDoc = \case+      L loc (DocCommentNamed _name doc) ->+        -- TODO: Is this correct?+        -- NB: There is no export list where we could reference the named chunk.+        Just (L (locA loc) (DsiDocChunk (unLoc doc)))++      L loc (DocGroup level doc) ->+        Just (L (locA loc) (DsiSectionHeading level (unLoc doc)))++      _ -> Nothing++    name_locs = M.fromList (concatMap ldeclNames (ungroup decls))+    ldeclNames (L loc d) = zip (getMainDeclBinder env d) (repeat (locA loc))++-- | Extract named documentation chunks from the renamed declarations.+--+-- If there is no explicit export list, we simply return an empty map+-- since there would be no way to link to a named chunk.+getNamedChunks :: Bool -- ^ Do we have an explicit export list?+               -> HsGroup (GhcPass pass)+               -> Map String (HsDoc (GhcPass pass))+getNamedChunks True decls =+  M.fromList $ flip mapMaybe (unLoc <$> hs_docs decls) $ \case+    DocCommentNamed name doc -> Just (name, unLoc doc)+    _                        -> Nothing+getNamedChunks False _ = M.empty+ -- | Create decl and arg doc-maps by looping through the declarations. -- For each declaration, find its names, its subordinates, and its doc strings.-mkMaps :: [Name]-       -> [(LHsDecl GhcRn, [HsDocString])]-       -> (Map Name (HsDocString), Map Name (IntMap HsDocString))-mkMaps instances decls =-    ( f' (map (nubByName fst) decls')-    , f  (filterMapping (not . IM.null) args)+mkMaps :: OccEnv Name+       -> [Name]+       -> [(LHsDecl GhcRn, [HsDoc GhcRn])]+       -> (UniqMap Name [HsDoc GhcRn], UniqMap Name (IntMap (HsDoc GhcRn)))+mkMaps env instances decls =+    ( listsToMapWith (++) (map (nubByName fst) decls')+    , listsToMapWith (<>) (filterMapping (not . IM.null) args)     )   where     (decls', args) = unzip (map mappings decls) -    f :: (Ord a, Semigroup b) => [[(a, b)]] -> Map a b-    f = M.fromListWith (<>) . concat--    f' :: Ord a => [[(a, HsDocString)]] -> Map a HsDocString-    f' = M.fromListWith appendDocs . concat+    listsToMapWith f = listToUniqMap_C f . concat      filterMapping :: (b -> Bool) ->  [[(a, b)]] -> [[(a, b)]]     filterMapping p = map (filter (p . snd)) -    mappings :: (LHsDecl GhcRn, [HsDocString])-             -> ( [(Name, HsDocString)]-                , [(Name, IntMap HsDocString)]+    mappings :: (LHsDecl GhcRn, [HsDoc GhcRn])+             -> ( [(Name, [HsDoc GhcRn])]+                , [(Name, IntMap (HsDoc GhcRn))]                 )-    mappings (L (SrcSpanAnn _ (RealSrcSpan l _)) decl, docStrs) =+    mappings (L (SrcSpanAnn _ (RealSrcSpan l _)) decl, doc) =            (dm, am)       where-        doc = concatDocs docStrs         args = declTypeDocs decl -        subs :: [(Name, [HsDocString], IntMap HsDocString)]-        subs = subordinates instanceMap decl+        subs :: [(Name, [HsDoc GhcRn], IntMap (HsDoc GhcRn))]+        subs = subordinates env instanceMap decl -        (subDocs, subArgs) =-          unzip (map (\(_, strs, m) -> (concatDocs strs, m)) subs)+        (subNs, subDocs, subArgs) =+          unzip3 subs          ns = names l decl-        subNs = [ n | (n, _, _) <- subs ]-        dm = [(n, d) | (n, Just d) <- zip ns (repeat doc) ++ zip subNs subDocs]+        dm = [(n, d) | (n, d) <- zip ns (repeat doc) ++ zip subNs subDocs, not $ all (isEmptyDocString . hsDocString) d]         am = [(n, args) | n <- ns] ++ zip subNs subArgs     mappings (L (SrcSpanAnn _ (UnhelpfulSpan _)) _, _) = ([], []) @@ -124,7 +270,7 @@     names :: RealSrcSpan -> HsDecl GhcRn -> [Name]     names _ (InstD _ d) = maybeToList $ lookupSrcSpan (getInstLoc d) instanceMap     names l (DerivD {}) = maybeToList (M.lookup l instanceMap) -- See Note [1].-    names _ decl = getMainDeclBinder decl+    names _ decl = getMainDeclBinder env decl  {- Note [1]:@@ -135,27 +281,37 @@ user-written. This lets us relate Names (from ClsInsts) to comments (associated with InstDecls and DerivDecls). -}-getMainDeclBinder :: (Anno (IdGhcP p) ~ SrcSpanAnnN, CollectPass (GhcPass p))-                  => HsDecl (GhcPass p) -> [IdP (GhcPass p)]-getMainDeclBinder (TyClD _ d) = [tcdName d]-getMainDeclBinder (ValD _ d) =++getMainDeclBinder+  :: OccEnv Name -- ^ Default method environment for this module. See Note [default method Name] in GHC.Iface.Recomp+  -> HsDecl GhcRn -> [Name]+getMainDeclBinder _ (TyClD _ d) = [tcdName d]+getMainDeclBinder _ (ValD _ d) =   case collectHsBindBinders CollNoDictBinders d of     []       -> []     (name:_) -> [name]-getMainDeclBinder (SigD _ d) = sigNameNoLoc d-getMainDeclBinder (ForD _ (ForeignImport _ name _ _)) = [unLoc name]-getMainDeclBinder (ForD _ (ForeignExport _ _ _ _)) = []-getMainDeclBinder _ = []+getMainDeclBinder env (SigD _ d) = sigNameNoLoc env d+getMainDeclBinder _   (ForD _ (ForeignImport _ name _ _)) = [unLoc name]+getMainDeclBinder _   (ForD _ (ForeignExport _ _ _ _)) = []+getMainDeclBinder _ _ = []  -sigNameNoLoc :: forall pass. UnXRec pass => Sig pass -> [IdP pass]-sigNameNoLoc (TypeSig    _   ns _)         = map (unXRec @pass) ns-sigNameNoLoc (ClassOpSig _ _ ns _)         = map (unXRec @pass) ns-sigNameNoLoc (PatSynSig  _   ns _)         = map (unXRec @pass) ns-sigNameNoLoc (SpecSig    _   n _ _)        = [unXRec @pass n]-sigNameNoLoc (InlineSig  _   n _)          = [unXRec @pass n]-sigNameNoLoc (FixSig _ (FixitySig _ ns _)) = map (unXRec @pass) ns-sigNameNoLoc _                             = []+-- | The "OccEnv Name" is the default method environment for this module+-- Ultimately, the a special "defaultMethodOcc" name is used for+-- the signatures on bindings for default methods. Unfortunately, this+-- name isn't generated until typechecking, so it is not in the renamed AST.+-- We have to look it up from the 'OccEnv' parameter constructed from the typechecked+-- AST.+-- See also Note [default method Name] in GHC.Iface.Recomp+sigNameNoLoc :: forall a . (UnXRec a, HasOccName (IdP a)) => OccEnv (IdP a) -> Sig a -> [IdP a]+sigNameNoLoc _   (TypeSig    _   ns _)         = map (unXRec @a) ns+sigNameNoLoc _   (ClassOpSig _ False ns _)     = map (unXRec @a) ns+sigNameNoLoc env (ClassOpSig _ True  ns _)     = mapMaybe (lookupOccEnv env . mkDefaultMethodOcc . occName) $ map (unXRec @a) ns+sigNameNoLoc _   (PatSynSig  _   ns _)         = map (unXRec @a) ns+sigNameNoLoc _   (SpecSig    _   n _ _)        = [unXRec @a n]+sigNameNoLoc _   (InlineSig  _   n _)          = [unXRec @a n]+sigNameNoLoc _   (FixSig _ (FixitySig _ ns _)) = map (unXRec @a) ns+sigNameNoLoc _   _                             = []  -- Extract the source location where an instance is defined. This is used -- to correlate InstDecls with their Instance/CoAxiom Names, via the@@ -180,15 +336,21 @@ -- | Get all subordinate declarations inside a declaration, and their docs. -- A subordinate declaration is something like the associate type or data -- family of a type class.-subordinates :: Map RealSrcSpan Name+subordinates :: OccEnv Name -- ^ The default method environment+             -> Map RealSrcSpan Name              -> HsDecl GhcRn-             -> [(Name, [HsDocString], IntMap HsDocString)]-subordinates instMap decl = case decl of-  InstD _ (ClsInstD _ d) -> do-    DataFamInstDecl { dfid_eqn =-      FamEqn { feqn_tycon = L l _-             , feqn_rhs   = defn }} <- unLoc <$> cid_datafam_insts d-    [ (n, [], IM.empty) | Just n <- [lookupSrcSpan (locA l) instMap] ] ++ dataSubs defn+             -> [(Name, [HsDoc GhcRn], IntMap (HsDoc GhcRn))]+subordinates env instMap decl = case decl of+  InstD _ (ClsInstD _ d) -> let+    data_fams = do+      DataFamInstDecl { dfid_eqn =+        FamEqn { feqn_tycon = L l _+               , feqn_rhs   = defn }} <- unLoc <$> cid_datafam_insts d+      [ (n, [], IM.empty) | Just n <- [lookupSrcSpan (locA l) instMap] ] ++ dataSubs defn+    ty_fams = do+      TyFamInstDecl { tfid_eqn = FamEqn { feqn_tycon = L l _ } } <- unLoc <$> cid_tyfam_insts d+      [ (n, [], IM.empty) | Just n <- [lookupSrcSpan (locA l) instMap] ]+    in data_fams ++ ty_fams    InstD _ (DataFamInstD _ (DataFamInstDecl d))     -> dataSubs (feqn_rhs d)@@ -198,18 +360,18 @@   where     classSubs dd = [ (name, doc, declTypeDocs d)                    | (L _ d, doc) <- classDecls dd-                   , name <- getMainDeclBinder d, not (isValD d)+                   , name <- getMainDeclBinder env d, not (isValD d)                    ]     dataSubs :: HsDataDefn GhcRn-             -> [(Name, [HsDocString], IntMap HsDocString)]-    dataSubs dd = constrs ++ fields ++ derivs+             -> [(Name, [HsDoc GhcRn], IntMap (HsDoc GhcRn))]+    dataSubs dd = constrs ++ fields  ++ derivs       where         cons = map unLoc $ (dd_cons dd)         constrs = [ ( unLoc cname                     , maybeToList $ fmap unLoc $ con_doc c                     , conArgDocs c)                   | c <- cons, cname <- getConNames c ]-        fields  = [ (extFieldOcc n, maybeToList $ fmap unLoc doc, IM.empty)+        fields  = [ (foExt n, maybeToList $ fmap unLoc doc, IM.empty)                   | Just flds <- map getRecConArgs_maybe cons                   , (L _ (ConDeclField _ ns _ doc)) <- (unLoc flds)                   , (L _ n) <- ns ]@@ -220,13 +382,13 @@                                 dd_derivs dd                   , Just instName <- [lookupSrcSpan l instMap] ] -        extract_deriv_clause_tys :: LDerivClauseTys GhcRn -> [(SrcSpan, LHsDocString)]+        extract_deriv_clause_tys :: LDerivClauseTys GhcRn -> [(SrcSpan, LHsDoc GhcRn)]         extract_deriv_clause_tys (L _ dct) =           case dct of             DctSingle _ ty -> maybeToList $ extract_deriv_ty ty             DctMulti _ tys -> mapMaybe extract_deriv_ty tys -        extract_deriv_ty :: LHsSigType GhcRn -> Maybe (SrcSpan, LHsDocString)+        extract_deriv_ty :: LHsSigType GhcRn -> Maybe (SrcSpan, LHsDoc GhcRn)         extract_deriv_ty (L l (HsSig{sig_body = L _ ty})) =           case ty of             -- deriving (C a {- ^ Doc comment -})@@ -234,25 +396,25 @@             _               -> Nothing  -- | Extract constructor argument docs from inside constructor decls.-conArgDocs :: ConDecl GhcRn -> IntMap HsDocString+conArgDocs :: ConDecl GhcRn -> IntMap (HsDoc GhcRn) conArgDocs (ConDeclH98{con_args = args}) =   h98ConArgDocs args conArgDocs (ConDeclGADT{con_g_args = args, con_res_ty = res_ty}) =   gadtConArgDocs args (unLoc res_ty) -h98ConArgDocs :: HsConDeclH98Details GhcRn -> IntMap HsDocString+h98ConArgDocs :: HsConDeclH98Details GhcRn -> IntMap (HsDoc GhcRn) h98ConArgDocs con_args = case con_args of   PrefixCon _ args   -> con_arg_docs 0 $ map (unLoc . hsScaledThing) args   InfixCon arg1 arg2 -> con_arg_docs 0 [ unLoc (hsScaledThing arg1)                                        , unLoc (hsScaledThing arg2) ]   RecCon _           -> IM.empty -gadtConArgDocs :: HsConDeclGADTDetails GhcRn -> HsType GhcRn -> IntMap HsDocString+gadtConArgDocs :: HsConDeclGADTDetails GhcRn -> HsType GhcRn -> IntMap (HsDoc GhcRn) gadtConArgDocs con_args res_ty = case con_args of   PrefixConGADT args -> con_arg_docs 0 $ map (unLoc . hsScaledThing) args ++ [res_ty]-  RecConGADT _       -> con_arg_docs 1 [res_ty]+  RecConGADT _ _     -> con_arg_docs 1 [res_ty] -con_arg_docs :: Int -> [HsType GhcRn] -> IntMap HsDocString+con_arg_docs :: Int -> [HsType GhcRn] -> IntMap (HsDoc GhcRn) con_arg_docs n = IM.fromList . catMaybes . zipWith f [n..]   where     f n (HsDocTy _ _ lds) = Just (n, unLoc lds)@@ -265,7 +427,7 @@  -- | All the sub declarations of a class (that we handle), ordered by -- source location, with documentation attached if it exists.-classDecls :: TyClDecl GhcRn -> [(LHsDecl GhcRn, [HsDocString])]+classDecls :: TyClDecl GhcRn -> [(LHsDecl GhcRn, [HsDoc GhcRn])] classDecls class_ = filterDecls . collectDocs . sortLocatedA $ decls   where     decls = docs ++ defs ++ sigs ++ ats@@ -275,7 +437,7 @@     ats   = mkDecls tcdATs (TyClD noExtField . FamDecl noExtField) class_  -- | Extract function argument docs from inside top-level decls.-declTypeDocs :: HsDecl GhcRn -> IntMap (HsDocString)+declTypeDocs :: HsDecl GhcRn -> IntMap (HsDoc GhcRn) declTypeDocs = \case   SigD  _ (TypeSig _ _ ty)          -> sigTypeDocs (unLoc (dropWildCards ty))   SigD  _ (ClassOpSig _ _ _ ty)     -> sigTypeDocs (unLoc ty)@@ -296,7 +458,7 @@         y = f x  -- | Extract function argument docs from inside types.-typeDocs :: HsType GhcRn -> IntMap HsDocString+typeDocs :: HsType GhcRn -> IntMap (HsDoc GhcRn) typeDocs = go 0   where     go n = \case@@ -308,12 +470,12 @@       _                                     -> IM.empty  -- | Extract function argument docs from inside types.-sigTypeDocs :: HsSigType GhcRn -> IntMap HsDocString+sigTypeDocs :: HsSigType GhcRn -> IntMap (HsDoc GhcRn) sigTypeDocs (HsSig{sig_body = body}) = typeDocs (unLoc body)  -- | The top-level declarations of a module that we care about, -- ordered by source location, with documentation attached if it exists.-topDecls :: HsGroup GhcRn -> [(LHsDecl GhcRn, [HsDocString])]+topDecls :: HsGroup GhcRn -> [(LHsDecl GhcRn, [HsDoc GhcRn])] topDecls = filterClasses . filterDecls . collectDocs . sortLocatedA . ungroup  -- | Take all declarations except pragmas, infix decls, rules from an 'HsGroup'.@@ -340,14 +502,14 @@ -- | Collect docs and attach them to the right declarations. -- -- A declaration may have multiple doc strings attached to it.-collectDocs :: forall p. UnXRec p => [LHsDecl p] -> [(LHsDecl p, [HsDocString])]+collectDocs :: forall p. UnXRec p => [LHsDecl p] -> [(LHsDecl p, [HsDoc p])] -- ^ This is an example. collectDocs = go [] Nothing   where     go docs mprev decls = case (decls, mprev) of-      ((unXRec @p -> DocD _ (DocCommentNext s)) : ds, Nothing)   -> go (s:docs) Nothing ds-      ((unXRec @p -> DocD _ (DocCommentNext s)) : ds, Just prev) -> finished prev docs $ go [s] Nothing ds-      ((unXRec @p -> DocD _ (DocCommentPrev s)) : ds, mprev)     -> go (s:docs) mprev ds+      ((unXRec @p -> DocD _ (DocCommentNext s)) : ds, Nothing)   -> go (unLoc s:docs) Nothing ds+      ((unXRec @p -> DocD _ (DocCommentNext s)) : ds, Just prev) -> finished prev docs $ go [unLoc s] Nothing ds+      ((unXRec @p -> DocD _ (DocCommentPrev s)) : ds, mprev)     -> go (unLoc s:docs) mprev ds       (d                                  : ds, Nothing)   -> go docs (Just d) ds       (d                                  : ds, Just prev) -> finished prev docs $ go [] (Just d) ds       ([]                                     , Nothing)   -> []@@ -401,14 +563,15 @@ extractTHDocs docs =   -- Split up docs into separate maps for each 'DocLoc' type   ExtractedTHDocs-    docHeader-    (DeclDocMap (searchDocs decl))-    (ArgDocMap (searchDocs args))-    (DeclDocMap (searchDocs insts))+    { ethd_mod_header = docHeader+    , ethd_decl_docs  = searchDocs decl+    , ethd_arg_docs   = searchDocs args+    , ethd_inst_docs  = searchDocs insts+    }   where-    docHeader :: Maybe HsDocString+    docHeader :: Maybe (HsDoc GhcRn)     docHeader-      | ((_, s):_) <- filter isModDoc (M.toList docs) = Just (mkHsDocString s)+      | ((_, s):_) <- filter isModDoc (M.toList docs) = Just s       | otherwise = Nothing      isModDoc (ModuleDoc, _) = True@@ -417,38 +580,40 @@     -- Folds over the docs, applying 'f' as the accumulating function.     -- We use different accumulating functions to sift out the specific types of     -- documentation-    searchDocs :: Monoid a => (a -> (DocLoc, String) -> a) -> a-    searchDocs f = foldl' f mempty $ M.toList docs+    searchDocs :: (UniqMap Name a -> (DocLoc, HsDoc GhcRn) -> UniqMap Name a) -> UniqMap Name a+    searchDocs f = foldl' f emptyUniqMap $ M.toList docs      -- Pick out the declaration docs-    decl acc ((DeclDoc name), s) = M.insert name (mkHsDocString s) acc+    decl acc ((DeclDoc name), s) = addToUniqMap acc name s     decl acc _ = acc      -- Pick out the instance docs-    insts acc ((InstDoc name), s) = M.insert name (mkHsDocString s) acc+    insts acc ((InstDoc name), s) = addToUniqMap acc name s     insts acc _ = acc      -- Pick out the argument docs-    args :: Map Name (IntMap HsDocString)-         -> (DocLoc, String)-         -> Map Name (IntMap HsDocString)+    args :: UniqMap Name (IntMap (HsDoc GhcRn))+         -> (DocLoc, HsDoc GhcRn)+         -> UniqMap Name (IntMap (HsDoc GhcRn))     args acc ((ArgDoc name i), s) =       -- Insert the doc for the arg into the argument map for the function. This       -- means we have to search to see if an map already exists for the       -- function, and insert the new argument if it exists, or create a new map-      let ds = mkHsDocString s-       in M.insertWith (\_ m -> IM.insert i ds m) name (IM.singleton i ds) acc+       addToUniqMap_C (\_ m -> IM.insert i s m) acc name (IM.singleton i s)     args acc _ = acc  -- | Unions together two 'ArgDocMaps' (or ArgMaps in haddock-api), such that two -- maps with values for the same key merge the inner map as well. -- Left biased so @unionArgMaps a b@ prefers @a@ over @b@.-unionArgMaps :: Map Name (IntMap b)-             -> Map Name (IntMap b)-             -> Map Name (IntMap b)-unionArgMaps a b = M.foldlWithKey go b a++unionArgMaps :: forall b . UniqMap Name (IntMap b)+             -> UniqMap Name (IntMap b)+             -> UniqMap Name (IntMap b)+unionArgMaps a b = nonDetFoldUniqMap go b a   where-    go acc n newArgMap-      | Just oldArgMap <- M.lookup n acc =-          M.insert n (newArgMap `IM.union` oldArgMap) acc-      | otherwise = M.insert n newArgMap acc+    go :: (Name, IntMap b)+            -> UniqMap Name (IntMap b) -> UniqMap Name (IntMap b)+    go (n, newArgMap) acc+      | Just oldArgMap <- lookupUniqMap acc n =+          addToUniqMap acc n (newArgMap `IM.union` oldArgMap)+      | otherwise = addToUniqMap acc n newArgMap
+ GHC/HsToCore/Errors/Ppr.hs view
@@ -0,0 +1,319 @@+{-# LANGUAGE LambdaCase #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic DsMessage++module GHC.HsToCore.Errors.Ppr where++import GHC.Core.Predicate (isEvVar)+import GHC.Core.Type+import GHC.Driver.Flags+import GHC.Hs+import GHC.HsToCore.Errors.Types+import GHC.Prelude+import GHC.Types.Basic (pprRuleName)+import GHC.Types.Error+import GHC.Types.Id (idType)+import GHC.Types.SrcLoc+import GHC.Utils.Misc+import GHC.Utils.Outputable+import qualified GHC.LanguageExtensions as LangExt+import GHC.HsToCore.Pmc.Ppr+++instance Diagnostic DsMessage where+  diagnosticMessage = \case+    DsUnknownMessage m+      -> diagnosticMessage m+    DsEmptyEnumeration+      -> mkSimpleDecorated $ text "Enumeration is empty"+    DsIdentitiesFound conv_fn type_of_conv+      -> mkSimpleDecorated $+           vcat [ text "Call of" <+> ppr conv_fn <+> dcolon <+> ppr type_of_conv+                , nest 2 $ text "can probably be omitted"+                ]+    DsOverflowedLiterals i tc bounds _possiblyUsingNegativeLiterals+      -> let msg = case bounds of+               Nothing+                 -> vcat [ text "Literal" <+> integer i+                       <+> text "is negative but" <+> ppr tc+                       <+> text "only supports positive numbers"+                         ]+               Just (MinBound minB, MaxBound maxB)+                 -> vcat [ text "Literal" <+> integer i+                                 <+> text "is out of the" <+> ppr tc <+> text "range"+                                 <+> integer minB <> text ".." <> integer maxB+                         ]+         in mkSimpleDecorated msg+    DsRedundantBangPatterns ctx q+      -> mkSimpleDecorated $ pprEqn ctx q "has redundant bang"+    DsOverlappingPatterns ctx q+      -> mkSimpleDecorated $ pprEqn ctx q "is redundant"+    DsInaccessibleRhs ctx q+      -> mkSimpleDecorated $ pprEqn ctx q "has inaccessible right hand side"+    DsMaxPmCheckModelsReached limit+      -> mkSimpleDecorated $ vcat+           [ hang+               (text "Pattern match checker ran into -fmax-pmcheck-models="+                 <> int limit+                 <> text " limit, so")+               2+               (  bullet <+> text "Redundant clauses might not be reported at all"+               $$ bullet <+> text "Redundant clauses might be reported as inaccessible"+               $$ bullet <+> text "Patterns reported as unmatched might actually be matched")+           ]+    DsNonExhaustivePatterns kind _flag maxPatterns vars nablas+      -> mkSimpleDecorated $+           pprContext False kind (text "are non-exhaustive") $ \_ ->+             case vars of -- See #11245+                  [] -> text "Guards do not cover entire pattern space"+                  _  -> let us = map (\nabla -> pprUncovered nabla vars) nablas+                            pp_tys = pprQuotedList $ map idType vars+                        in  hang+                              (text "Patterns of type" <+> pp_tys <+> text "not matched:")+                              4+                              (vcat (take maxPatterns us) $$ dots maxPatterns us)+    DsTopLevelBindsNotAllowed bindsType bind+      -> let desc = case bindsType of+               UnliftedTypeBinds -> "bindings for unlifted types"+               StrictBinds       -> "strict bindings"+         in mkSimpleDecorated $+              hang (text "Top-level" <+> text desc <+> text "aren't allowed:") 2 (ppr bind)+    DsUselessSpecialiseForClassMethodSelector poly_id+      -> mkSimpleDecorated $+           text "Ignoring useless SPECIALISE pragma for NOINLINE function:" <+> quotes (ppr poly_id)+    DsUselessSpecialiseForNoInlineFunction poly_id+      -> mkSimpleDecorated $+          text "Ignoring useless SPECIALISE pragma for NOINLINE function:" <+> quotes (ppr poly_id)+    DsMultiplicityCoercionsNotSupported+      -> mkSimpleDecorated $ text "GHC bug #19517: GHC currently does not support programs using GADTs or type families to witness equality of multiplicities"+    DsOrphanRule rule+      -> mkSimpleDecorated $ text "Orphan rule:" <+> ppr rule+    DsRuleLhsTooComplicated orig_lhs lhs2+      -> mkSimpleDecorated $+           hang (text "RULE left-hand side too complicated to desugar")+                      2 (vcat [ text "Optimised lhs:" <+> ppr lhs2+                              , text "Orig lhs:" <+> ppr orig_lhs])+    DsRuleIgnoredDueToConstructor con+      -> mkSimpleDecorated $ vcat+           [ text "A constructor," <+> ppr con <>+               text ", appears as outermost match in RULE lhs."+           , text "This rule will be ignored." ]+    DsRuleBindersNotBound unbound orig_bndrs orig_lhs lhs2+      -> mkSimpleDecorated $ vcat (map pp_dead unbound)+         where+           pp_dead bndr =+             hang (sep [ text "Forall'd" <+> pp_bndr bndr+                       , text "is not bound in RULE lhs"])+                2 (vcat [ text "Orig bndrs:" <+> ppr orig_bndrs+                        , text "Orig lhs:" <+> ppr orig_lhs+                        , text "optimised lhs:" <+> ppr lhs2 ])++           pp_bndr b+            | isTyVar b = text "type variable" <+> quotes (ppr b)+            | isEvVar b = text "constraint"    <+> quotes (ppr (varType b))+            | otherwise = text "variable"      <+> quotes (ppr b)+    DsMultipleConForNewtype names+      -> mkSimpleDecorated $ text "Multiple constructors for newtype:" <+> pprQuotedList names+    DsLazyPatCantBindVarsOfUnliftedType unlifted_bndrs+      -> mkSimpleDecorated $+          hang (text "A lazy (~) pattern cannot bind variables of unlifted type." $$+                text "Unlifted variables:")+             2 (vcat (map (\id -> ppr id <+> dcolon <+> ppr (idType id)) unlifted_bndrs))+    DsNotYetHandledByTH reason+      -> case reason of+             ThAmbiguousRecordUpdates fld+               -> mkMsg "Ambiguous record updates" (ppr fld)+             ThAbstractClosedTypeFamily decl+               -> mkMsg "abstract closed type family" (ppr decl)+             ThForeignLabel cls+               -> mkMsg "Foreign label" (doubleQuotes (ppr cls))+             ThForeignExport decl+               -> mkMsg "Foreign export" (ppr decl)+             ThMinimalPragmas+               -> mkMsg "MINIMAL pragmas" empty+             ThSCCPragmas+               -> mkMsg "SCC pragmas" empty+             ThNoUserInline+               -> mkMsg "NOUSERINLINE" empty+             ThExoticFormOfType ty+               -> mkMsg "Exotic form of type" (ppr ty)+             ThAmbiguousRecordSelectors e+               -> mkMsg "Ambiguous record selectors" (ppr e)+             ThMonadComprehensionSyntax e+               -> mkMsg "monad comprehension and [: :]" (ppr e)+             ThCostCentres e+               -> mkMsg "Cost centres" (ppr e)+             ThExpressionForm e+               -> mkMsg "Expression form" (ppr e)+             ThExoticStatement other+               -> mkMsg "Exotic statement" (ppr other)+             ThExoticLiteral lit+               -> mkMsg "Exotic literal" (ppr lit)+             ThExoticPattern pat+               -> mkMsg "Exotic pattern" (ppr pat)+             ThGuardedLambdas m+               -> mkMsg "Guarded lambdas" (pprMatch m)+             ThNegativeOverloadedPatterns pat+               -> mkMsg "Negative overloaded patterns" (ppr pat)+             ThHaddockDocumentation+               -> mkMsg "Haddock documentation" empty+             ThWarningAndDeprecationPragmas decl+               -> mkMsg "WARNING and DEPRECATION pragmas" $+                    text "Pragma for declaration of" <+> ppr decl+             ThSplicesWithinDeclBrackets+               -> mkMsg "Splices within declaration brackets" empty+             ThNonLinearDataCon+               -> mkMsg "Non-linear fields in data constructors" empty+         where+           mkMsg what doc =+             mkSimpleDecorated $+               hang (text what <+> text "not (yet) handled by Template Haskell") 2 doc+    DsAggregatedViewExpressions views+      -> mkSimpleDecorated (vcat msgs)+         where+           msgs = map (\g -> text "Putting these view expressions into the same case:" <+> (ppr g)) views+    DsUnbangedStrictPatterns bind+      -> mkSimpleDecorated $+           hang (text "Pattern bindings containing unlifted types should use" $$+                 text "an outermost bang pattern:")+              2 (ppr bind)+    DsCannotMixPolyAndUnliftedBindings bind+      -> mkSimpleDecorated $+           hang (text "You can't mix polymorphic and unlifted bindings:")+              2 (ppr bind)+    DsWrongDoBind _rhs elt_ty+      -> mkSimpleDecorated $ badMonadBind elt_ty+    DsUnusedDoBind _rhs elt_ty+      -> mkSimpleDecorated $ badMonadBind elt_ty+    DsRecBindsNotAllowedForUnliftedTys binds+      -> mkSimpleDecorated $+           hang (text "Recursive bindings for unlifted types aren't allowed:")+              2 (vcat (map ppr binds))+    DsRuleMightInlineFirst rule_name lhs_id _+      -> mkSimpleDecorated $+           vcat [ hang (text "Rule" <+> pprRuleName rule_name+                          <+> text "may never fire")+                       2 (text "because" <+> quotes (ppr lhs_id)+                          <+> text "might inline first")+                ]+    DsAnotherRuleMightFireFirst rule_name bad_rule lhs_id+      -> mkSimpleDecorated $+           vcat [ hang (text "Rule" <+> pprRuleName rule_name+                          <+> text "may never fire")+                       2 (text "because rule" <+> pprRuleName bad_rule+                          <+> text "for"<+> quotes (ppr lhs_id)+                          <+> text "might fire first")+                ]++  diagnosticReason = \case+    DsUnknownMessage m          -> diagnosticReason m+    DsEmptyEnumeration          -> WarningWithFlag Opt_WarnEmptyEnumerations+    DsIdentitiesFound{}         -> WarningWithFlag Opt_WarnIdentities+    DsOverflowedLiterals{}      -> WarningWithFlag Opt_WarnOverflowedLiterals+    DsRedundantBangPatterns{}   -> WarningWithFlag Opt_WarnRedundantBangPatterns+    DsOverlappingPatterns{}     -> WarningWithFlag Opt_WarnOverlappingPatterns+    DsInaccessibleRhs{}         -> WarningWithFlag Opt_WarnOverlappingPatterns+    DsMaxPmCheckModelsReached{} -> WarningWithoutFlag+    DsNonExhaustivePatterns _ (ExhaustivityCheckType mb_flag) _ _ _+      -> maybe WarningWithoutFlag WarningWithFlag mb_flag+    DsTopLevelBindsNotAllowed{}                 -> ErrorWithoutFlag+    DsUselessSpecialiseForClassMethodSelector{} -> WarningWithoutFlag+    DsUselessSpecialiseForNoInlineFunction{}    -> WarningWithoutFlag+    DsMultiplicityCoercionsNotSupported{}       -> ErrorWithoutFlag+    DsOrphanRule{}                              -> WarningWithFlag Opt_WarnOrphans+    DsRuleLhsTooComplicated{}                   -> WarningWithoutFlag+    DsRuleIgnoredDueToConstructor{}             -> WarningWithoutFlag+    DsRuleBindersNotBound{}                     -> WarningWithoutFlag+    DsMultipleConForNewtype{}                   -> ErrorWithoutFlag+    DsLazyPatCantBindVarsOfUnliftedType{}       -> ErrorWithoutFlag+    DsNotYetHandledByTH{}                       -> ErrorWithoutFlag+    DsAggregatedViewExpressions{}               -> WarningWithoutFlag+    DsUnbangedStrictPatterns{}                  -> WarningWithFlag Opt_WarnUnbangedStrictPatterns+    DsCannotMixPolyAndUnliftedBindings{}        -> ErrorWithoutFlag+    DsWrongDoBind{}                             -> WarningWithFlag Opt_WarnWrongDoBind+    DsUnusedDoBind{}                            -> WarningWithFlag Opt_WarnUnusedDoBind+    DsRecBindsNotAllowedForUnliftedTys{}        -> ErrorWithoutFlag+    DsRuleMightInlineFirst{}                    -> WarningWithFlag Opt_WarnInlineRuleShadowing+    DsAnotherRuleMightFireFirst{}               -> WarningWithFlag Opt_WarnInlineRuleShadowing++  diagnosticHints  = \case+    DsUnknownMessage m          -> diagnosticHints m+    DsEmptyEnumeration          -> noHints+    DsIdentitiesFound{}         -> noHints+    DsOverflowedLiterals i _tc bounds usingNegLiterals+      -> case (bounds, usingNegLiterals) of+          (Just (MinBound minB, MaxBound _), NotUsingNegLiterals)+            | minB == -i -- Note [Suggest NegativeLiterals]+            , i > 0+            -> [ suggestExtensionWithInfo (text "If you are trying to write a large negative literal")+                                          LangExt.NegativeLiterals ]+          _ -> noHints+    DsRedundantBangPatterns{}                   -> noHints+    DsOverlappingPatterns{}                     -> noHints+    DsInaccessibleRhs{}                         -> noHints+    DsMaxPmCheckModelsReached{}                 -> [SuggestIncreaseMaxPmCheckModels]+    DsNonExhaustivePatterns{}                   -> noHints+    DsTopLevelBindsNotAllowed{}                 -> noHints+    DsUselessSpecialiseForClassMethodSelector{} -> noHints+    DsUselessSpecialiseForNoInlineFunction{}    -> noHints+    DsMultiplicityCoercionsNotSupported         -> noHints+    DsOrphanRule{}                              -> noHints+    DsRuleLhsTooComplicated{}                   -> noHints+    DsRuleIgnoredDueToConstructor{}             -> noHints+    DsRuleBindersNotBound{}                     -> noHints+    DsMultipleConForNewtype{}                   -> noHints+    DsLazyPatCantBindVarsOfUnliftedType{}       -> noHints+    DsNotYetHandledByTH{}                       -> noHints+    DsAggregatedViewExpressions{}               -> noHints+    DsUnbangedStrictPatterns{}                  -> noHints+    DsCannotMixPolyAndUnliftedBindings{}        -> [SuggestAddTypeSignatures UnnamedBinding]+    DsWrongDoBind rhs _                         -> [SuggestBindToWildcard rhs]+    DsUnusedDoBind rhs _                        -> [SuggestBindToWildcard rhs]+    DsRecBindsNotAllowedForUnliftedTys{}        -> noHints+    DsRuleMightInlineFirst _ lhs_id rule_act    -> [SuggestAddInlineOrNoInlinePragma lhs_id rule_act]+    DsAnotherRuleMightFireFirst _ bad_rule _    -> [SuggestAddPhaseToCompetingRule bad_rule]++{-+Note [Suggest NegativeLiterals]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If you write+  x :: Int8+  x = -128+it'll parse as (negate 128), and overflow.  In this case, suggest NegativeLiterals.+We get an erroneous suggestion for+  x = 128+but perhaps that does not matter too much.+-}++--+-- Helper functions+--++badMonadBind :: Type -> SDoc+badMonadBind elt_ty+  = hang (text "A do-notation statement discarded a result of type")+       2 (quotes (ppr elt_ty))++-- Print a single clause (for redundant/with-inaccessible-rhs)+pprEqn :: HsMatchContext GhcRn -> SDoc -> String -> SDoc+pprEqn ctx q txt = pprContext True ctx (text txt) $ \f ->+  f (q <+> matchSeparator ctx <+> text "...")++pprContext :: Bool -> HsMatchContext GhcRn -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc+pprContext singular kind msg rest_of_msg_fun+  = vcat [text txt <+> msg,+          sep [ text "In" <+> ppr_match <> char ':'+              , nest 4 (rest_of_msg_fun pref)]]+  where+    txt | singular  = "Pattern match"+        | otherwise = "Pattern match(es)"++    (ppr_match, pref)+        = case kind of+             FunRhs { mc_fun = L _ fun }+                  -> (pprMatchContext kind, \ pp -> ppr fun <+> pp)+             _    -> (pprMatchContext kind, \ pp -> pp)++dots :: Int -> [a] -> SDoc+dots maxPatterns qs+    | qs `lengthExceeds` maxPatterns = text "..."+    | otherwise                      = empty
+ GHC/HsToCore/Errors/Types.hs view
@@ -0,0 +1,189 @@+{-# LANGUAGE ExistentialQuantification #-}++module GHC.HsToCore.Errors.Types where++import Data.Typeable++import GHC.Prelude++import GHC.Core (CoreRule, CoreExpr, RuleName)+import GHC.Core.DataCon+import GHC.Core.Type+import GHC.Driver.Session+import GHC.Hs+import GHC.HsToCore.Pmc.Solver.Types+import GHC.Types.Basic (Activation)+import GHC.Types.Error+import GHC.Types.ForeignCall+import GHC.Types.Id+import GHC.Types.Name (Name)+import qualified GHC.LanguageExtensions as LangExt++newtype MinBound = MinBound Integer+newtype MaxBound = MaxBound Integer+type MaxUncoveredPatterns = Int+type MaxPmCheckModels = Int++-- | Diagnostics messages emitted during desugaring.+data DsMessage+  -- | Simply wraps a generic 'Diagnostic' message.+  = forall a. (Diagnostic a, Typeable a) => DsUnknownMessage a++    {-| DsEmptyEnumeration is a warning (controlled by the -Wempty-enumerations flag) that is+        emitted if an enumeration is empty.++        Example(s):++          main :: IO ()+          main = do+            let enum = [5 .. 3]+            print enum++          Here 'enum' would yield an empty list, because 5 is greater than 3.++        Test case(s):+          warnings/should_compile/T10930+          warnings/should_compile/T18402+          warnings/should_compile/T10930b+          numeric/should_compile/T10929+          numeric/should_compile/T7881+          deSugar/should_run/T18172++    -}+  | DsEmptyEnumeration++    {-| DsIdentitiesFound is a warning (controlled by the -Widentities flag) that is+        emitted on uses of Prelude numeric conversions that are probably the identity+        (and hence could be omitted).++        Example(s):++          main :: IO ()+          main = do+            let x = 10+            print $ conv 10++            where+              conv :: Int -> Int+              conv x = fromIntegral x++        Here calling 'conv' is essentially the identity function, and therefore can be omitted.++        Test case(s):+          deSugar/should_compile/T4488+    -}+  | DsIdentitiesFound !Id   -- The conversion function+                      !Type -- The type of conversion++  | DsOverflowedLiterals !Integer+                         !Name+                         !(Maybe (MinBound, MaxBound))+                         !NegLiteralExtEnabled++  -- FIXME(adn) Use a proper type instead of 'SDoc', but unfortunately+  -- 'SrcInfo' gives us an 'SDoc' to begin with.+  | DsRedundantBangPatterns !(HsMatchContext GhcRn) !SDoc++  -- FIXME(adn) Use a proper type instead of 'SDoc', but unfortunately+  -- 'SrcInfo' gives us an 'SDoc' to begin with.+  | DsOverlappingPatterns !(HsMatchContext GhcRn) !SDoc++  -- FIXME(adn) Use a proper type instead of 'SDoc'+  | DsInaccessibleRhs !(HsMatchContext GhcRn) !SDoc++  | DsMaxPmCheckModelsReached !MaxPmCheckModels++  | DsNonExhaustivePatterns !(HsMatchContext GhcRn)+                            !ExhaustivityCheckType+                            !MaxUncoveredPatterns+                            [Id]+                            [Nabla]++  | DsTopLevelBindsNotAllowed !BindsType !(HsBindLR GhcTc GhcTc)++  | DsUselessSpecialiseForClassMethodSelector !Id++  | DsUselessSpecialiseForNoInlineFunction !Id++  | DsMultiplicityCoercionsNotSupported++  | DsOrphanRule !CoreRule++  | DsRuleLhsTooComplicated !CoreExpr !CoreExpr++  | DsRuleIgnoredDueToConstructor !DataCon++  | DsRuleBindersNotBound ![Var]+                          -- ^ The list of unbound binders+                          ![Var]+                          -- ^ The original binders+                          !CoreExpr+                          -- ^ The original LHS+                          !CoreExpr+                          -- ^ The optimised LHS++  | DsMultipleConForNewtype [LocatedN Name]++  | DsLazyPatCantBindVarsOfUnliftedType [Var]++  | DsNotYetHandledByTH !ThRejectionReason++  | DsAggregatedViewExpressions [[LHsExpr GhcTc]]++  | DsUnbangedStrictPatterns !(HsBindLR GhcTc GhcTc)++  | DsCannotMixPolyAndUnliftedBindings !(HsBindLR GhcTc GhcTc)++  | DsWrongDoBind !(LHsExpr GhcTc) !Type++  | DsUnusedDoBind !(LHsExpr GhcTc) !Type++  | DsRecBindsNotAllowedForUnliftedTys ![LHsBindLR GhcTc GhcTc]++  | DsRuleMightInlineFirst !RuleName !Var !Activation++  | DsAnotherRuleMightFireFirst !RuleName+                                !RuleName -- the \"bad\" rule+                                !Var++-- The positional number of the argument for an expression (first, second, third, etc)+newtype DsArgNum = DsArgNum Int++-- | Why TemplateHaskell rejected the splice. Used in the 'DsNotYetHandledByTH'+-- constructor of a 'DsMessage'.+data ThRejectionReason+  = ThAmbiguousRecordUpdates !(HsRecUpdField GhcRn)+  | ThAbstractClosedTypeFamily !(LFamilyDecl GhcRn)+  | ThForeignLabel !CLabelString+  | ThForeignExport !(LForeignDecl GhcRn)+  | ThMinimalPragmas+  | ThSCCPragmas+  | ThNoUserInline+  | ThExoticFormOfType !(HsType GhcRn)+  | ThAmbiguousRecordSelectors !(HsExpr GhcRn)+  | ThMonadComprehensionSyntax !(HsExpr GhcRn)+  | ThCostCentres !(HsExpr GhcRn)+  | ThExpressionForm !(HsExpr GhcRn)+  | ThExoticStatement [Stmt GhcRn (LHsExpr GhcRn)]+  | ThExoticLiteral !(HsLit GhcRn)+  | ThExoticPattern !(Pat GhcRn)+  | ThGuardedLambdas !(Match GhcRn (LHsExpr GhcRn))+  | ThNegativeOverloadedPatterns !(Pat GhcRn)+  | ThHaddockDocumentation+  | ThWarningAndDeprecationPragmas [LIdP GhcRn]+  | ThSplicesWithinDeclBrackets+  | ThNonLinearDataCon++data NegLiteralExtEnabled+  = YesUsingNegLiterals+  | NotUsingNegLiterals++negLiteralExtEnabled :: DynFlags -> NegLiteralExtEnabled+negLiteralExtEnabled dflags =+ if (xopt LangExt.NegativeLiterals dflags) then YesUsingNegLiterals else NotUsingNegLiterals++newtype ExhaustivityCheckType = ExhaustivityCheckType (Maybe WarningFlag)++data BindsType+  = UnliftedTypeBinds+  | StrictBinds
GHC/HsToCore/Expr.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP          #-}+ {-# LANGUAGE TypeFamilies #-}  {-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}@@ -13,13 +13,11 @@ -}  module GHC.HsToCore.Expr-   ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds+   ( dsExpr, dsLExpr, dsLocalBinds    , dsValBinds, dsLit, dsSyntaxExpr    ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.HsToCore.Match@@ -31,6 +29,7 @@ import GHC.HsToCore.Arrows import GHC.HsToCore.Monad import GHC.HsToCore.Pmc ( addTyCs, pmcGRHSs )+import GHC.HsToCore.Errors.Types import GHC.Types.SourceText import GHC.Types.Name import GHC.Types.Name.Env@@ -44,8 +43,8 @@ import GHC.Tc.Types.Evidence import GHC.Tc.Utils.Monad import GHC.Core.Type+import GHC.Core.TyCo.Rep import GHC.Core.Multiplicity-import GHC.Core.Coercion( Coercion ) import GHC.Core import GHC.Core.Utils import GHC.Core.Make@@ -58,7 +57,6 @@ import GHC.Unit.Module import GHC.Core.ConLike import GHC.Core.DataCon-import GHC.Core.TyCo.Ppr( pprWithTYPE ) import GHC.Builtin.Types import GHC.Builtin.Names import GHC.Types.Basic@@ -69,9 +67,9 @@ import GHC.Data.Bag import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Core.PatSyn import Control.Monad-import Data.Void( absurd )  {- ************************************************************************@@ -104,7 +102,7 @@         ; foldrM ds_ip_bind inner ip_binds }   where     ds_ip_bind :: LIPBind GhcTc -> CoreExpr -> DsM CoreExpr-    ds_ip_bind (L _ (IPBind _ ~(Right n) e)) body+    ds_ip_bind (L _ (IPBind n _ e)) body       = do e' <- dsLExpr e            return (Let (NonRec n e') body) @@ -125,7 +123,7 @@   = putSrcSpanDs (locA loc) $      -- see Note [Strict binds checks] in GHC.HsToCore.Binds     if is_polymorphic bind-    then errDsCoreExpr (poly_bind_err bind)+    then errDsCoreExpr (DsCannotMixPolyAndUnliftedBindings bind)             -- data Ptr a = Ptr Addr#             -- f x = let p@(Ptr y) = ... in ...             -- Here the binding for 'p' is polymorphic, but does@@ -133,7 +131,7 @@             -- use a bang pattern.  #6078.      else do { when (looksLazyPatBind bind) $-              warnIfSetDs Opt_WarnUnbangedStrictPatterns (unlifted_must_be_bang bind)+              diagnosticDs (DsUnbangedStrictPatterns bind)         -- Complain about a binding that looks lazy         --    e.g.    let I# y = x in ...         -- Remember, in checkStrictBinds we are going to do strict@@ -144,35 +142,25 @@              ; dsUnliftedBind bind body }   where-    is_polymorphic (AbsBinds { abs_tvs = tvs, abs_ev_vars = evs })+    is_polymorphic (XHsBindsLR (AbsBinds { abs_tvs = tvs, abs_ev_vars = evs }))                      = not (null tvs && null evs)     is_polymorphic _ = False -    unlifted_must_be_bang bind-      = hang (text "Pattern bindings containing unlifted types should use" $$-              text "an outermost bang pattern:")-           2 (ppr bind) -    poly_bind_err bind-      = hang (text "You can't mix polymorphic and unlifted bindings:")-           2 (ppr bind) $$-        text "Probable fix: add a type signature"- ds_val_bind (is_rec, binds) _body   | anyBag (isUnliftedHsBind . unLoc) binds  -- see Note [Strict binds checks] in GHC.HsToCore.Binds-  = ASSERT( isRec is_rec )-    errDsCoreExpr $-    hang (text "Recursive bindings for unlifted types aren't allowed:")-       2 (vcat (map ppr (bagToList binds)))+  = assert (isRec is_rec )+    errDsCoreExpr $ DsRecBindsNotAllowedForUnliftedTys (bagToList binds)  -- Ordinary case for bindings; none should be unlifted ds_val_bind (is_rec, binds) body-  = do  { MASSERT( isRec is_rec || isSingletonBag binds )+  = do  { massert (isRec is_rec || isSingletonBag binds)                -- we should never produce a non-recursive list of multiple binds          ; (force_vars,prs) <- dsLHsBinds binds         ; let body' = foldr seqVar body force_vars-        ; ASSERT2( not (any (isUnliftedType . idType . fst) prs), ppr is_rec $$ ppr binds )+        ; assertPpr (not (any (isUnliftedType . idType . fst) prs)) (ppr is_rec $$ ppr binds) $+          -- NB: bindings have a fixed RuntimeRep, so it's OK to call isUnliftedType           case prs of             [] -> return body             _  -> return (Let (Rec prs) body') }@@ -189,10 +177,10 @@  ------------------ dsUnliftedBind :: HsBind GhcTc -> CoreExpr -> DsM CoreExpr-dsUnliftedBind (AbsBinds { abs_tvs = [], abs_ev_vars = []-               , abs_exports = exports-               , abs_ev_binds = ev_binds-               , abs_binds = lbinds }) body+dsUnliftedBind (XHsBindsLR (AbsBinds { abs_tvs = [], abs_ev_vars = []+                                     , abs_exports = exports+                                     , abs_ev_binds = ev_binds+                                     , abs_binds = lbinds })) body   = do { let body1 = foldr bind_export body exports              bind_export export b = bindNonRec (abe_poly export) (Var (abe_mono export)) b        ; body2 <- foldlM (\body lbind -> dsUnliftedBind (unLoc lbind) body)@@ -206,9 +194,8 @@                         , fun_tick = tick }) body                -- Can't be a bang pattern (that looks like a PatBind)                -- so must be simply unboxed-  = do { (args, rhs) <- matchWrapper (mkPrefixFunRhs (L l $ idName fun))-                                     Nothing matches-       ; MASSERT( null args ) -- Functions aren't lifted+  = do { (args, rhs) <- matchWrapper (mkPrefixFunRhs (L l $ idName fun)) Nothing matches+       ; massert (null args) -- Functions aren't unlifted        ; core_wrap <- dsHsWrapper co_fn  -- Can be non-identity (#21516)        ; let rhs' = core_wrap (mkOptTickBox tick rhs)        ; return (bindNonRec fun rhs' body) }@@ -244,41 +231,27 @@ -- function in GHC.Tc.Utils.Zonk: -- putSrcSpanDs loc $ do --   { core_expr <- dsExpr e---   ; MASSERT2( exprType core_expr `eqType` hsExprType e---             , ppr e <+> dcolon <+> ppr (hsExprType e) $$---                 ppr core_expr <+> dcolon <+> ppr (exprType core_expr) )+--   ; massertPpr (exprType core_expr `eqType` hsExprType e)+--                (ppr e <+> dcolon <+> ppr (hsExprType e) $$+--                 ppr core_expr <+> dcolon <+> ppr (exprType core_expr)) --   ; return core_expr } dsLExpr :: LHsExpr GhcTc -> DsM CoreExpr dsLExpr (L loc e) =   putSrcSpanDsA loc $ dsExpr e --- | Variant of 'dsLExpr' that ensures that the result is not levity--- polymorphic. This should be used when the resulting expression will--- be an argument to some other function.--- See Note [Levity polymorphism checking] in "GHC.HsToCore.Monad"--- See Note [Levity polymorphism invariants] in "GHC.Core"-dsLExprNoLP :: LHsExpr GhcTc -> DsM CoreExpr-dsLExprNoLP (L loc e)-  = putSrcSpanDsA loc $-    do { e' <- dsExpr e-       ; dsNoLevPolyExpr e' (text "In the type of expression:" <+> ppr e)-       ; return e' }- dsExpr :: HsExpr GhcTc -> DsM CoreExpr dsExpr (HsVar    _ (L _ id))           = dsHsVar id-dsExpr (HsRecFld _ (Unambiguous id _)) = dsHsVar id-dsExpr (HsRecFld _ (Ambiguous   id _)) = dsHsVar id+dsExpr (HsRecSel _ (FieldOcc id _))    = dsHsVar id dsExpr (HsUnboundVar (HER ref _ _) _)  = dsEvTerm =<< readMutVar ref         -- See Note [Holes] in GHC.Tc.Types.Constraint -dsExpr (HsPar _ e)            = dsLExpr e+dsExpr (HsPar _ _ e _)        = dsLExpr e dsExpr (ExprWithTySig _ e _)  = dsLExpr e -dsExpr (HsConLikeOut _ con)   = dsConLike con-dsExpr (HsIPVar {})           = panic "dsExpr: HsIPVar"+dsExpr (HsIPVar x _)          = dataConCantHappen x -dsExpr (HsGetField x _ _)     = absurd x-dsExpr (HsProjection x _)     = absurd x+dsExpr (HsGetField x _ _)     = dataConCantHappen x+dsExpr (HsProjection x _)     = dataConCantHappen x  dsExpr (HsLit _ lit)   = do { warnAboutOverflowedLit lit@@ -288,11 +261,29 @@   = do { warnAboutOverflowedOverLit lit        ; dsOverLit lit } -dsExpr e@(XExpr expansion)-  = case expansion of+dsExpr e@(XExpr ext_expr_tc)+  = case ext_expr_tc of       ExpansionExpr (HsExpanded _ b) -> dsExpr b       WrapExpr {}                    -> dsHsWrapped e+      ConLikeTc con tvs tys          -> dsConLike con tvs tys+      -- Hpc Support+      HsTick tickish e -> do+        e' <- dsLExpr e+        return (Tick tickish e') +      -- There is a problem here. The then and else branches+      -- have no free variables, so they are open to lifting.+      -- We need someway of stopping this.+      -- This will make no difference to binary coverage+      -- (did you go here: YES or NO), but will effect accurate+      -- tick counting.++      HsBinTick ixT ixF e -> do+        e2 <- dsLExpr e+        do { assert (exprType e2 `eqType` boolTy)+            mkBinaryTickBox ixT ixF e2+          }+ dsExpr (NegApp _ (L loc                     (HsOverLit _ lit@(OverLit { ol_val = HsIntegral i})))                 neg_expr)@@ -307,16 +298,15 @@        ; dsSyntaxExpr neg_expr [expr'] }  dsExpr (HsLam _ a_Match)-  = uncurry mkLams <$> matchWrapper LambdaExpr Nothing a_Match+  = uncurry mkCoreLams <$> matchWrapper LambdaExpr Nothing a_Match -dsExpr (HsLamCase _ matches)-  = do { ([discrim_var], matching_code) <- matchWrapper CaseAlt Nothing matches-       ; return $ Lam discrim_var matching_code }+dsExpr (HsLamCase _ lc_variant matches)+  = uncurry mkCoreLams <$> matchWrapper (LamCaseAlt lc_variant) Nothing matches  dsExpr e@(HsApp _ fun arg)   = do { fun' <- dsLExpr fun-       ; dsWhenNoErrs (dsLExprNoLP arg)-                      (\arg' -> mkCoreAppDs (text "HsApp" <+> ppr e) fun' arg') }+       ; arg' <- dsLExpr arg+       ; return $ mkCoreAppDs (text "HsApp" <+> ppr e) fun' arg' }  dsExpr e@(HsAppType {}) = dsHsWrapped e @@ -342,35 +332,33 @@   = do { let go (lam_vars, args) (Missing (Scaled mult ty))                     -- For every missing expression, we need                     -- another lambda in the desugaring.-               = do { lam_var <- newSysLocalDsNoLP mult ty+               = do { lam_var <- newSysLocalDs mult ty                     ; return (lam_var : lam_vars, Var lam_var : args) }              go (lam_vars, args) (Present _ expr)                     -- Expressions that are present don't generate                     -- lambdas, just arguments.-               = do { core_expr <- dsLExprNoLP expr+               = do { core_expr <- dsLExpr expr                     ; return (lam_vars, core_expr : args) } -       ; dsWhenNoErrs (foldM go ([], []) (reverse tup_args))+       ; (lam_vars, args) <- foldM go ([], []) (reverse tup_args)                 -- The reverse is because foldM goes left-to-right-                      (\(lam_vars, args) ->-                        mkCoreLams lam_vars $-                          mkCoreTupBoxity boxity args) }+       ; return $ mkCoreLams lam_vars (mkCoreTupBoxity boxity args) }                         -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make  dsExpr (ExplicitSum types alt arity expr)-  = dsWhenNoErrs (dsLExprNoLP expr) (mkCoreUbxSum arity alt types)+  = mkCoreUbxSum arity alt types <$> dsLExpr expr  dsExpr (HsPragE _ prag expr) =   ds_prag_expr prag expr  dsExpr (HsCase _ discrim matches)   = do { core_discrim <- dsLExpr discrim-       ; ([discrim_var], matching_code) <- matchWrapper CaseAlt (Just discrim) matches+       ; ([discrim_var], matching_code) <- matchWrapper CaseAlt (Just [discrim]) matches        ; return (bindNonRec discrim_var core_discrim matching_code) }  -- Pepe: The binds are in scope in the body but NOT in the binding group --       This is to avoid silliness in breakpoints-dsExpr (HsLet _ binds body) = do+dsExpr (HsLet _ _ binds _ body) = do     body' <- dsLExpr body     dsLocalBinds binds body' @@ -428,9 +416,9 @@     g = ... makeStatic loc f ... -} -dsExpr (HsStatic _ expr@(L loc _)) = do-    expr_ds <- dsLExprNoLP expr-    let ty = exprType expr_ds+dsExpr (HsStatic (_, whole_ty) expr@(L loc _)) = do+    expr_ds <- dsLExpr expr+    let (_, [ty]) = splitTyConApp whole_ty     makeStaticId <- dsLookupGlobalId makeStaticName      dflags <- getDynFlags@@ -483,8 +471,8 @@               mk_arg (arg_ty, fl)                = case findField (rec_flds rbinds) (flSelector fl) of-                   (rhs:rhss) -> ASSERT( null rhss )-                                 dsLExprNoLP rhs+                   (rhs:rhss) -> assert (null rhss)+                                 dsLExpr rhs                    []         -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (ppr (flLabel fl))              unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty Outputable.empty @@ -602,7 +590,7 @@   | null fields   = dsLExpr record_expr   | otherwise-  = ASSERT2( notNull cons_to_upd, ppr expr )+  = assertPpr (notNull cons_to_upd) (ppr expr) $      do  { record_expr' <- dsLExpr record_expr         ; field_binds' <- mapM ds_field fields@@ -615,7 +603,7 @@         -- constructor arguments.         ; alts <- mapM (mk_alt upd_fld_env) cons_to_upd         ; ([discrim_var], matching_code)-                <- matchWrapper RecUpd (Just record_expr) -- See Note [Scrutinee in Record updates]+                <- matchWrapper RecUpd (Just [record_expr]) -- See Note [Scrutinee in Record updates]                                       (MG { mg_alts = noLocA alts                                           , mg_ext = MatchGroupTc [unrestricted in_ty] out_ty                                           , mg_origin = FromSource@@ -632,7 +620,7 @@       -- else we shadow other uses of the record selector       -- Hence 'lcl_id'.  Cf #2735     ds_field (L _ rec_field)-      = do { rhs <- dsLExpr (hsRecFieldArg rec_field)+      = do { rhs <- dsLExpr (hfbRHS rec_field)            ; let fld_id = unLoc (hsRecUpdFieldId rec_field)            ; lcl_id <- newSysLocalDs (idMult fld_id) (idType fld_id)            ; return (idName fld_id, lcl_id, rhs) }@@ -678,7 +666,7 @@                  mk_val_arg fl pat_arg_id                      = nlHsVar (lookupNameEnv upd_fld_env (flSelector fl) `orElse` pat_arg_id) -                 inst_con = noLocA $ mkHsWrap wrap (HsConLikeOut noExtField con)+                 inst_con = noLocA $ mkHsWrap wrap (mkConLikeTc con)                         -- Reconstruct with the WrapId so that unpacking happens                  wrap = mkWpEvVarApps theta_vars                                <.>                         dict_req_wrap                                           <.>@@ -755,50 +743,28 @@ -- Here is where we desugar the Template Haskell brackets and escapes  -- Template Haskell stuff+-- See Note [The life cycle of a TH quotation] -dsExpr (HsRnBracketOut _ _ _)  = panic "dsExpr HsRnBracketOut"-dsExpr (HsTcBracketOut _ hs_wrapper x ps) = dsBracket hs_wrapper x ps-dsExpr (HsSpliceE _ s)         = pprPanic "dsExpr:splice" (ppr s)+dsExpr (HsTypedBracket   (HsBracketTc q _ hs_wrapper ps) _) = dsBracket hs_wrapper q ps+dsExpr (HsUntypedBracket (HsBracketTc q _ hs_wrapper ps) _) = dsBracket hs_wrapper q ps+dsExpr (HsSpliceE _ s) = pprPanic "dsExpr:splice" (ppr s)  -- Arrow notation extension dsExpr (HsProc _ pat cmd) = dsProcExpr pat cmd --- Hpc Support -dsExpr (HsTick _ tickish e) = do-  e' <- dsLExpr e-  return (Tick tickish e')---- There is a problem here. The then and else branches--- have no free variables, so they are open to lifting.--- We need someway of stopping this.--- This will make no difference to binary coverage--- (did you go here: YES or NO), but will effect accurate--- tick counting.--dsExpr (HsBinTick _ ixT ixF e) = do-  e2 <- dsLExpr e-  do { ASSERT(exprType e2 `eqType` boolTy)-       mkBinaryTickBox ixT ixF e2-     }-- -- HsSyn constructs that just shouldn't be here, because -- the renamer removed them.  See GHC.Rename.Expr. -- Note [Handling overloaded and rebindable constructs]-dsExpr (HsOverLabel x _) = absurd x-dsExpr (OpApp x _ _ _)   = absurd x-dsExpr (SectionL x _ _)  = absurd x-dsExpr (SectionR x _ _)  = absurd x---- HsSyn constructs that just shouldn't be here:-dsExpr (HsBracket   {}) = panic "dsExpr:HsBracket"-dsExpr (HsDo        {}) = panic "dsExpr:HsDo"+dsExpr (HsOverLabel x _) = dataConCantHappen x+dsExpr (OpApp x _ _ _)   = dataConCantHappen x+dsExpr (SectionL x _ _)  = dataConCantHappen x+dsExpr (SectionR x _ _)  = dataConCantHappen x  ds_prag_expr :: HsPragE GhcTc -> LHsExpr GhcTc -> DsM CoreExpr ds_prag_expr (HsPragSCC _ _ cc) expr = do     dflags <- getDynFlags-    if sccProfilingEnabled dflags+    if sccProfilingEnabled dflags && gopt Opt_ProfManualCcs dflags       then do         mod_name <- getModule         count <- goptM Opt_ProfCountEntries@@ -818,18 +784,13 @@        ; core_arg_wraps <- mapM dsHsWrapper arg_wraps        ; core_res_wrap  <- dsHsWrapper res_wrap        ; let wrapped_args = zipWithEqual "dsSyntaxExpr" ($) core_arg_wraps arg_exprs-       ; dsWhenNoErrs (zipWithM_ dsNoLevPolyExpr wrapped_args [ mk_doc n | n <- [1..] ])-                      (\_ -> core_res_wrap (mkCoreApps fun wrapped_args)) }-                      -- Use mkCoreApps instead of mkApps:-                      -- unboxed types are possible with RebindableSyntax (#19883)-  where-    mk_doc n = text "In the" <+> speakNth n <+> text "argument of" <+> quotes (ppr expr)+       ; return $ core_res_wrap (mkCoreApps fun wrapped_args) } dsSyntaxExpr NoSyntaxExprTc _ = panic "dsSyntaxExpr"  findField :: [LHsRecField GhcTc arg] -> Name -> [arg] findField rbinds sel-  = [hsRecFieldArg fld | L _ fld <- rbinds-                       , sel == idName (unLoc $ hsRecFieldId fld) ]+  = [hfbRHS fld | L _ fld <- rbinds+                       , sel == idName (hsRecFieldId fld) ]  {- %--------------------------------------------------------------------@@ -896,7 +857,7 @@ -- See Note [Desugaring explicit lists] dsExplicitList elt_ty xs   = do { dflags <- getDynFlags-       ; xs' <- mapM dsLExprNoLP xs+       ; xs' <- mapM dsLExpr xs        ; if xs' `lengthExceeds` maxBuildLength                 -- Don't generate builds if the list is very long.          || null xs'@@ -912,25 +873,25 @@  dsArithSeq :: PostTcExpr -> (ArithSeqInfo GhcTc) -> DsM CoreExpr dsArithSeq expr (From from)-  = App <$> dsExpr expr <*> dsLExprNoLP from+  = App <$> dsExpr expr <*> dsLExpr from dsArithSeq expr (FromTo from to)   = do fam_envs <- dsGetFamInstEnvs        dflags <- getDynFlags        warnAboutEmptyEnumerations fam_envs dflags from Nothing to        expr' <- dsExpr expr-       from' <- dsLExprNoLP from-       to'   <- dsLExprNoLP to+       from' <- dsLExpr from+       to'   <- dsLExpr to        return $ mkApps expr' [from', to'] dsArithSeq expr (FromThen from thn)-  = mkApps <$> dsExpr expr <*> mapM dsLExprNoLP [from, thn]+  = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn] dsArithSeq expr (FromThenTo from thn to)   = do fam_envs <- dsGetFamInstEnvs        dflags <- getDynFlags        warnAboutEmptyEnumerations fam_envs dflags from (Just thn) to        expr' <- dsExpr expr-       from' <- dsLExprNoLP from-       thn'  <- dsLExprNoLP thn-       to'   <- dsLExprNoLP to+       from' <- dsLExpr from+       thn'  <- dsLExpr thn+       to'   <- dsLExpr to        return $ mkApps expr' [from', thn', to']  {-@@ -939,7 +900,7 @@ Haskell 98 report: -} -dsDo :: HsStmtContext GhcRn -> [ExprLStmt GhcTc] -> DsM CoreExpr+dsDo :: HsDoFlavour -> [ExprLStmt GhcTc] -> DsM CoreExpr dsDo ctx stmts   = goL stmts   where@@ -947,7 +908,7 @@     goL ((L loc stmt):lstmts) = putSrcSpanDsA loc (go loc stmt lstmts)      go _ (LastStmt _ body _ _) stmts-      = ASSERT( null stmts ) dsLExpr body+      = assert (null stmts ) dsLExpr body         -- The 'return' op isn't used for 'do' expressions      go _ (BodyStmt _ rhs then_expr _) stmts@@ -964,7 +925,7 @@       = do  { body     <- goL stmts             ; rhs'     <- dsLExpr rhs             ; var   <- selectSimpleMatchVarL (xbstc_boundResultMult xbs) pat-            ; match <- matchSinglePatVar var Nothing (StmtCtxt ctx) pat+            ; match <- matchSinglePatVar var Nothing (StmtCtxt (HsDoStmt ctx)) pat                          (xbstc_boundResultType xbs) (cantFailMatchResult body)             ; match_code <- dsHandleMonadicFailure ctx pat match (xbstc_failOp xbs)             ; dsSyntaxExpr (xbstc_bindOp xbs) [rhs', Lam var match_code] }@@ -984,9 +945,8 @@            ; body' <- dsLExpr $ noLocA $ HsDo body_ty ctx (noLocA stmts)             ; let match_args (pat, fail_op) (vs,body)-                   = putSrcSpanDs (getLocA pat) $-                     do { var   <- selectSimpleMatchVarL Many pat-                        ; match <- matchSinglePatVar var Nothing (StmtCtxt ctx) pat+                   = do { var   <- selectSimpleMatchVarL Many pat+                        ; match <- matchSinglePatVar var Nothing (StmtCtxt (HsDoStmt ctx)) pat                                    body_ty (cantFailMatchResult body)                         ; match_code <- dsHandleMonadicFailure ctx pat match fail_op                         ; return (var:vs, match_code)@@ -1052,13 +1012,15 @@ -}  dsHsVar :: Id -> DsM CoreExpr+-- We could just call dsHsUnwrapped; but this is a short-cut+-- for the very common case of a variable with no wrapper. dsHsVar var-  = do { checkLevPolyFunction (ppr var) var (idType var)-       ; return (varToCoreExpr var) }   -- See Note [Desugaring vars]+  = return (varToCoreExpr var) -- See Note [Desugaring vars] -dsConLike :: ConLike -> DsM CoreExpr-dsConLike (RealDataCon dc) = dsHsVar (dataConWrapId dc)-dsConLike (PatSynCon ps)+dsHsConLike :: ConLike -> DsM CoreExpr+dsHsConLike (RealDataCon dc)+  = return (varToCoreExpr (dataConWrapId dc))+dsHsConLike (PatSynCon ps)   | Just (builder_name, _, add_void) <- patSynBuilder ps   = do { builder_id <- dsLookupGlobalId builder_name        ; return (if add_void@@ -1068,6 +1030,24 @@   | otherwise   = pprPanic "dsConLike" (ppr ps) +dsConLike :: ConLike -> [TcTyVar] -> [Scaled Type] -> DsM CoreExpr+-- This function desugars ConLikeTc+-- See Note [Typechecking data constructors] in GHC.Tc.Gen.Head+--     for what is going on here+dsConLike con tvs tys+  = do { ds_con <- dsHsConLike con+       ; ids    <- newSysLocalsDs tys+                   -- newSysLocalDs: /can/ be lev-poly; see+       ; return (mkLams tvs $+                 mkLams ids $+                 ds_con `mkTyApps` mkTyVarTys tvs+                        `mkVarApps` drop_stupid ids) }+  where++    drop_stupid = dropList (conLikeStupidTheta con)+    -- drop_stupid: see Note [Instantiating stupid theta]+    --              in GHC.Tc.Gen.Head+ {- ************************************************************************ *                                                                      *@@ -1088,8 +1068,7 @@             -- Warn about discarding non-() things in 'monadic' binding        ; if warn_unused && not (isUnitTy norm_elt_ty)-         then warnDs (Reason Opt_WarnUnusedDoBind)-                     (badMonadBind rhs elt_ty)+         then diagnosticDs (DsUnusedDoBind rhs elt_ty)          else             -- Warn about discarding m a things in 'monadic' binding of the same type,@@ -1098,136 +1077,42 @@                 case tcSplitAppTy_maybe norm_elt_ty of                       Just (elt_m_ty, _)                          | m_ty `eqType` topNormaliseType fam_inst_envs elt_m_ty-                         -> warnDs (Reason Opt_WarnWrongDoBind)-                                   (badMonadBind rhs elt_ty)+                         -> diagnosticDs (DsWrongDoBind rhs elt_ty)                       _ -> return () } }    | otherwise   -- RHS does have type of form (m ty), which is weird   = return ()   -- but at least this warning is irrelevant -badMonadBind :: LHsExpr GhcTc -> Type -> SDoc-badMonadBind rhs elt_ty-  = vcat [ hang (text "A do-notation statement discarded a result of type")-              2 (quotes (ppr elt_ty))-         , hang (text "Suppress this warning by saying")-              2 (quotes $ text "_ <-" <+> ppr rhs)-         ]- {- ************************************************************************ *                                                                      *-            Levity polymorphism checks+            dsHsWrapped *                                                                      * ************************************************************************--Note [Checking for levity-polymorphic functions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We cannot have levity polymorphic function arguments. See-Note [Levity polymorphism invariants] in GHC.Core. That is-checked by dsLExprNoLP.--But what about-  const True (unsafeCoerce# :: forall r1 r2 (a :: TYPE r1) (b :: TYPE r2). a -> b)--Since `unsafeCoerce#` has no binding, it has a compulsory unfolding.-But that compulsory unfolding is a levity-polymorphic lambda, which-is no good.  So we want to reject this.  On the other hand-  const True (unsafeCoerce# @LiftedRep @UnliftedRep)-is absolutely fine.--We have to collect all the type-instantiation and *then* check.  That-is what dsHsWrapped does.  Because we might have an HsVar without a-wrapper, we check in dsHsVar as well. typecheck/should_fail/T17021-triggers this case.--Note that if `f :: forall r (a :: Type r). blah`, then-   const True f-is absolutely fine.  Here `f` is a function, represented by a-pointer, and we can pass it to `const` (or anything else).  (See-#12708 for an example.)  It's only the Id.hasNoBinding functions-that are a problem.--Interestingly, this approach does not look to see whether the Id in-question will be eta expanded. The logic is this:-  * Either the Id in question is saturated or not.-  * If it is, then it surely can't have levity polymorphic arguments.-    If its wrapped type contains levity polymorphic arguments, reject.-  * If it's not, then it can't be eta expanded with levity polymorphic-    argument. If its wrapped type contains levity polymorphic arguments, reject.-So, either way, we're good to reject.- -}  ------------------------------ dsHsWrapped :: HsExpr GhcTc -> DsM CoreExpr--- Looks for a function 'f' wrapped in type applications (HsAppType)--- or wrappers (HsWrap), and checks that any hasNoBinding function--- is not levity polymorphic, *after* instantiation with those wrappers dsHsWrapped orig_hs_expr-  = go id orig_hs_expr+  = go idHsWrapper orig_hs_expr   where-    go wrap (XExpr (WrapExpr (HsWrap co_fn hs_e)))-       = do { wrap' <- dsHsWrapper co_fn-            ; addTyCs FromSource (hsWrapDictBinders co_fn) $-              go (wrap . wrap') hs_e }-    go wrap (HsConLikeOut _ (RealDataCon dc))-      = go_head wrap (dataConWrapId dc)-    go wrap (HsAppType ty hs_e _) = go_l (wrap . (\e -> App e (Type ty))) hs_e-    go wrap (HsPar _ hs_e)        = go_l wrap hs_e-    go wrap (HsVar _ (L _ var))   = go_head wrap var-    go wrap hs_e                  = do { e <- dsExpr hs_e; return (wrap e) }--    go_l wrap (L _ hs_e) = go wrap hs_e--    go_head wrap var-      = do { let wrapped_e  = wrap (Var var)-                 wrapped_ty = exprType wrapped_e--           ; checkLevPolyFunction (ppr orig_hs_expr) var wrapped_ty-             -- See Note [Checking for levity-polymorphic functions]-             -- Pass orig_hs_expr, so that the user can see entire-             -- expression with -fprint-typechecker-elaboration+    go wrap (HsPar _ _ (L _ hs_e) _)+       = go wrap hs_e+    go wrap1 (XExpr (WrapExpr (HsWrap wrap2 hs_e)))+       = go (wrap1 <.> wrap2) hs_e+    go wrap (HsAppType ty (L _ hs_e) _)+       = go (wrap <.> WpTyApp ty) hs_e +    go wrap (HsVar _ (L _ var))+      = do { wrap' <- dsHsWrapper wrap+           ; let expr = wrap' (varToCoreExpr var)+                 ty   = exprType expr            ; dflags <- getDynFlags-           ; warnAboutIdentities dflags var wrapped_ty--           ; return wrapped_e }----- | Takes a (pretty-printed) expression, a function, and its--- instantiated type.  If the function is a hasNoBinding op, and the--- type has levity-polymorphic arguments, issue an error.--- Note [Checking for levity-polymorphic functions]-checkLevPolyFunction :: SDoc -> Id -> Type -> DsM ()-checkLevPolyFunction pp_hs_expr var ty-  | let bad_tys = isBadLevPolyFunction var ty-  , not (null bad_tys)-  = errDs $ vcat-    [ hang (text "Cannot use function with levity-polymorphic arguments:")-         2 (pp_hs_expr <+> dcolon <+> pprWithTYPE ty)-    , ppUnlessOption sdocPrintTypecheckerElaboration $ vcat-        [ text "(Note that levity-polymorphic primops such as 'coerce' and unboxed tuples"-        , text "are eta-expanded internally because they must occur fully saturated."-        , text "Use -fprint-typechecker-elaboration to display the full expression.)"-        ]-    , hang (text "Levity-polymorphic arguments:")-         2 $ vcat $ map-           (\t -> pprWithTYPE t <+> dcolon <+> pprWithTYPE (typeKind t))-           bad_tys-    ]--checkLevPolyFunction _ _ _ = return ()+           ; warnAboutIdentities dflags var ty+           ; return expr } --- | Is this a hasNoBinding Id with a levity-polymorphic type?--- Returns the arguments that are levity polymorphic if they are bad;--- or an empty list otherwise--- Note [Checking for levity-polymorphic functions]-isBadLevPolyFunction :: Id -> Type -> [Type]-isBadLevPolyFunction id ty-  | hasNoBinding id-  = filter isTypeLevPoly arg_tys-  | otherwise-  = []-  where-    (binders, _) = splitPiTys ty-    arg_tys      = mapMaybe binderRelevantType_maybe binders+    go wrap hs_e+       = do { wrap' <- dsHsWrapper wrap+            ; addTyCs FromSource (hsWrapDictBinders wrap) $+              do { e <- dsExpr hs_e+                 ; return (wrap' e) } }
GHC/HsToCore/Expr.hs-boot view
@@ -5,6 +5,6 @@ import GHC.Hs.Extension ( GhcTc)  dsExpr  :: HsExpr GhcTc -> DsM CoreExpr-dsLExpr, dsLExprNoLP :: LHsExpr GhcTc -> DsM CoreExpr+dsLExpr :: LHsExpr GhcTc -> DsM CoreExpr dsSyntaxExpr :: SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr dsLocalBinds :: HsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr
GHC/HsToCore/Foreign/Call.hs view
@@ -6,8 +6,8 @@ Desugaring foreign calls -} -{-# LANGUAGE CPP #-} + {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}  module GHC.HsToCore.Foreign.Call@@ -19,8 +19,6 @@    ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Core@@ -46,8 +44,8 @@ import GHC.Builtin.Names import GHC.Driver.Session import GHC.Utils.Outputable-import GHC.Utils.Misc import GHC.Utils.Panic+import GHC.Utils.Panic.Plain  import Data.Maybe @@ -90,7 +88,7 @@  dsCCall :: CLabelString -- C routine to invoke         -> [CoreExpr]   -- Arguments (desugared)-                        -- Precondition: none have levity-polymorphic types+        -- Precondition: none have representation-polymorphic types         -> Safety       -- Safety of the call         -> Type         -- Type of the result: IO t         -> DsM CoreExpr -- Result, of type ???@@ -99,14 +97,13 @@   = do (unboxed_args, arg_wrappers) <- mapAndUnzipM unboxArg args        (ccall_result_ty, res_wrapper) <- boxResult result_ty        uniq <- newUnique-       dflags <- getDynFlags        let            target = StaticTarget NoSourceText lbl Nothing True            the_fcall    = CCall (CCallSpec target CCallConv may_gc)-           the_prim_app = mkFCall dflags uniq the_fcall unboxed_args ccall_result_ty+           the_prim_app = mkFCall uniq the_fcall unboxed_args ccall_result_ty        return (foldr ($) (res_wrapper the_prim_app) arg_wrappers) -mkFCall :: DynFlags -> Unique -> ForeignCall+mkFCall :: Unique -> ForeignCall         -> [CoreExpr]     -- Args         -> Type           -- Result type         -> CoreExpr@@ -119,17 +116,17 @@ -- Here we build a ccall thus --      (ccallid::(forall a b.  StablePtr (a -> b) -> Addr -> Char -> IO Addr)) --                      a b s x c-mkFCall dflags uniq the_fcall val_args res_ty-  = ASSERT( all isTyVar tyvars )  -- this must be true because the type is top-level+mkFCall uniq the_fcall val_args res_ty+  = assert (all isTyVar tyvars) $ -- this must be true because the type is top-level     mkApps (mkVarApps (Var the_fcall_id) tyvars) val_args   where     arg_tys = map exprType val_args     body_ty = (mkVisFunTysMany arg_tys res_ty)     tyvars  = tyCoVarsOfTypeWellScoped body_ty     ty      = mkInfForAllTys tyvars body_ty-    the_fcall_id = mkFCallId dflags uniq the_fcall ty+    the_fcall_id = mkFCallId uniq the_fcall ty -unboxArg :: CoreExpr                    -- The supplied argument, not levity-polymorphic+unboxArg :: CoreExpr                    -- The supplied argument, not representation-polymorphic          -> DsM (CoreExpr,              -- To pass as the actual argument                  CoreExpr -> CoreExpr   -- Wrapper to unbox the arg                 )@@ -137,7 +134,7 @@ --      (x#::Int#, \W. case x of I# x# -> W) -- where W is a CoreExpr that probably mentions x# --- always returns a non-levity-polymorphic expression+-- always returns a non-representation-polymorphic expression  unboxArg arg   -- Primitive types: nothing to unbox@@ -163,7 +160,7 @@   -- Data types with a single constructor, which has a single, primitive-typed arg   -- This deals with Int, Float etc; also Ptr, ForeignPtr   | is_product_type && data_con_arity == 1-  = ASSERT2(isUnliftedType data_con_arg_ty1, pprType arg_ty)+  = assertPpr (isUnliftedType data_con_arg_ty1) (pprType arg_ty) $                         -- Typechecker ensures this     do case_bndr <- newSysLocalDs Many arg_ty        prim_arg <- newSysLocalDs Many data_con_arg_ty1@@ -226,17 +223,10 @@         -- another case, and a coercion.)         -- The result is IO t, so wrap the result in an IO constructor   = do  { res <- resultWrapper io_res_ty-        ; let extra_result_tys-                = case res of-                     (Just ty,_)-                       | isUnboxedTupleType ty-                       -> let Just ls = tyConAppArgs_maybe ty in tail ls-                     _ -> []--              return_result state anss+        ; let return_result state anss                 = mkCoreUbxTup-                    (realWorldStatePrimTy : io_res_ty : extra_result_tys)-                    (state : anss)+                    [realWorldStatePrimTy, io_res_ty]+                    [state, anss]          ; (ccall_res_ty, the_alt) <- mk_alt return_result res @@ -268,11 +258,10 @@                                            [the_alt]        return (realWorldStatePrimTy `mkVisFunTyMany` ccall_res_ty, wrap)   where-    return_result _ [ans] = ans-    return_result _ _     = panic "return_result: expected single result"+    return_result _ ans = ans  -mk_alt :: (Expr Var -> [Expr Var] -> Expr Var)+mk_alt :: (Expr Var -> Expr Var -> Expr Var)        -> (Maybe Type, Expr Var -> Expr Var)        -> DsM (Type, CoreAlt) mk_alt return_result (Nothing, wrap_result)@@ -280,7 +269,7 @@        state_id <- newSysLocalDs Many realWorldStatePrimTy        let              the_rhs = return_result (Var state_id)-                                     [wrap_result (panic "boxResult")]+                                     (wrap_result (panic "boxResult"))               ccall_res_ty = mkTupleTy Unboxed [realWorldStatePrimTy]              the_alt      = Alt (DataAlt (tupleDataCon Unboxed 1)) [state_id] the_rhs@@ -289,12 +278,12 @@  mk_alt return_result (Just prim_res_ty, wrap_result)   = -- The ccall returns a non-() value-    ASSERT2( isPrimitiveType prim_res_ty, ppr prim_res_ty )+    assertPpr (isPrimitiveType prim_res_ty) (ppr prim_res_ty) $              -- True because resultWrapper ensures it is so     do { result_id <- newSysLocalDs Many prim_res_ty        ; state_id <- newSysLocalDs Many realWorldStatePrimTy        ; let the_rhs = return_result (Var state_id)-                                [wrap_result (Var result_id)]+                                (wrap_result (Var result_id))              ccall_res_ty = mkTupleTy Unboxed [realWorldStatePrimTy, prim_res_ty]              the_alt      = Alt (DataAlt (tupleDataCon Unboxed 2)) [state_id, result_id] the_rhs        ; return (ccall_res_ty, the_alt) }
GHC/HsToCore/Foreign/Decl.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} @@ -14,7 +14,6 @@  module GHC.HsToCore.Foreign.Decl ( dsForeigns ) where -#include "HsVersions.h" import GHC.Prelude  import GHC.Tc.Utils.Monad        -- temp@@ -23,6 +22,7 @@  import GHC.HsToCore.Foreign.Call import GHC.HsToCore.Monad+import GHC.HsToCore.Types (ds_next_wrapper_num)  import GHC.Hs import GHC.Core.DataCon@@ -43,6 +43,7 @@  import GHC.Cmm.Expr import GHC.Cmm.Utils+import GHC.Cmm.CLabel import GHC.Driver.Ppr import GHC.Types.ForeignCall import GHC.Builtin.Types@@ -56,8 +57,8 @@ import GHC.Driver.Config import GHC.Platform import GHC.Data.OrdList-import GHC.Utils.Misc import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Driver.Hooks import GHC.Utils.Encoding @@ -95,11 +96,12 @@   = return (NoStubs, nilOL) dsForeigns' fos = do     mod <- getModule+    platform <- targetPlatform <$> getDynFlags     fives <- mapM do_ldecl fos     let         (hs, cs, idss, bindss) = unzip4 fives         fe_ids = concat idss-        fe_init_code = foreignExportsInitialiser mod fe_ids+        fe_init_code = foreignExportsInitialiser platform mod fe_ids     --     return (ForeignStubs              (mconcat hs)@@ -173,7 +175,7 @@                  IsFunction              _ -> IsData    (resTy, foRhs) <- resultWrapper ty-   ASSERT(fromJust resTy `eqType` addrPrimTy)    -- typechecker ensures this+   assert (fromJust resTy `eqType` addrPrimTy) $    -- typechecker ensures this     let         rhs = foRhs (Lit (LitLabel cid stdcall_info fod))         rhs' = Cast rhs co@@ -218,7 +220,7 @@         (tv_bndrs, rho)      = tcSplitForAllTyVarBinders ty         (arg_tys, io_res_ty) = tcSplitFunTys rho -    args <- newSysLocalsDs arg_tys  -- no FFI levity-polymorphism+    args <- newSysLocalsDs arg_tys  -- no FFI representation polymorphism     (val_args, arg_wrappers) <- mapAndUnzipM unboxArg (map Var args)      let@@ -229,12 +231,12 @@     ccall_uniq <- newUnique     work_uniq  <- newUnique -    dflags <- getDynFlags     (fcall', cDoc) <-               case fcall of               CCall (CCallSpec (StaticTarget _ cName mUnitId isFun)                                CApiConv safety) ->-               do wrapperName <- mkWrapperName "ghc_wrapper" (unpackFS cName)+               do nextWrapperNum <- ds_next_wrapper_num <$> getGblEnv+                  wrapperName <- mkWrapperName nextWrapperNum "ghc_wrapper" (unpackFS cName)                   let fcall' = CCall (CCallSpec                                       (StaticTarget NoSourceText                                                     wrapperName mUnitId@@ -278,11 +280,12 @@                   return (fcall', c)               _ ->                   return (fcall, empty)+    dflags <- getDynFlags     let         -- Build the worker         worker_ty     = mkForAllTys tv_bndrs (mkVisFunTysMany (map idType work_arg_ids) ccall_result_ty)         tvs           = map binderVar tv_bndrs-        the_ccall_app = mkFCall dflags ccall_uniq fcall' val_args ccall_result_ty+        the_ccall_app = mkFCall ccall_uniq fcall' val_args ccall_result_ty         work_rhs      = mkLams tvs (mkLams work_arg_ids the_ccall_app)         work_id       = mkSysLocal (fsLit "$wccall") work_uniq Many worker_ty @@ -297,7 +300,7 @@                                                 simpl_opts                                                 wrap_rhs' -    return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs')], mempty, CStub cDoc)+    return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs')], mempty, CStub cDoc [] [])  {- ************************************************************************@@ -322,12 +325,11 @@         (tvs, fun_ty)        = tcSplitForAllInvisTyVars ty         (arg_tys, io_res_ty) = tcSplitFunTys fun_ty -    args <- newSysLocalsDs arg_tys  -- no FFI levity-polymorphism+    args <- newSysLocalsDs arg_tys  -- no FFI representation polymorphism      ccall_uniq <- newUnique-    dflags <- getDynFlags     let-        call_app = mkFCall dflags ccall_uniq fcall (map Var args) io_res_ty+        call_app = mkFCall ccall_uniq fcall (map Var args) io_res_ty         rhs      = mkLams tvs (mkLams args call_app)         rhs'     = Cast rhs co     return ([(fn_id, rhs')], mempty, mempty)@@ -526,7 +528,9 @@                    Int          -- total size of arguments                   ) mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc- = (header_bits, c_bits, type_string,+ = ( header_bits+   , CStub body [] []+   , type_string,     sum [ widthInBytes (typeWidth rep) | (_,_,_,rep) <- aug_arg_info] -- all the args          -- NB. the calculation here isn't strictly speaking correct.          -- We have a primitive Haskell type (eg. Int#, Double#), and@@ -646,7 +650,7 @@     -- finally, the whole darn thing-  c_bits = CStub $+  body =     space $$     extern_decl $$     fun_proto  $$@@ -662,9 +666,9 @@                 text "rts_apply" <> parens (                     cap <>                     text "(HaskellObj)"-                 <> ptext (if is_IO_res_ty-                                then (sLit "runIO_closure")-                                else (sLit "runNonIO_closure"))+                 <> (if is_IO_res_ty+                      then text "runIO_closure"+                      else text "runNonIO_closure")                  <> comma                  <> expr_to_run                 ) <+> comma@@ -682,9 +686,9 @@      , rbrace      ] --foreignExportsInitialiser :: Module -> [Id] -> CStub-foreignExportsInitialiser mod hs_fns =+foreignExportsInitialiser :: Platform -> Module -> [Id] -> CStub+foreignExportsInitialiser _        _   []     = mempty+foreignExportsInitialiser platform mod hs_fns =    -- Initialise foreign exports by registering a stable pointer from an    -- __attribute__((constructor)) function.    -- The alternative is to do this from stginit functions generated in@@ -695,21 +699,18 @@    -- (this is bad for big umbrella modules like Graphics.Rendering.OpenGL)    --    -- See Note [Tracking foreign exports] in rts/ForeignExports.c-   CStub $ vcat-    [ text "static struct ForeignExportsList" <+> list_symbol <+> equals+   initializerCStub platform fn_nm list_decl fn_body+  where+    fn_nm       = mkInitializerStubLabel mod "fexports"+    mod_str     = pprModuleName (moduleName mod)+    fn_body     = text "registerForeignExports" <> parens (char '&' <> list_symbol) <> semi+    list_symbol = text "stg_exports_" <> mod_str+    list_decl   = text "static struct ForeignExportsList" <+> list_symbol <+> equals          <+> braces (            text ".exports = " <+> export_list <> comma <+>            text ".n_entries = " <+> ppr (length hs_fns))          <> semi-    , text "static void " <> ctor_symbol <> text "(void)"-         <+> text " __attribute__((constructor));"-    , text "static void " <> ctor_symbol <> text "()"-    , braces (text "registerForeignExports" <> parens (char '&' <> list_symbol) <> semi)-    ]-  where-    mod_str = pprModuleName (moduleName mod)-    ctor_symbol = text "stginit_export_" <> mod_str-    list_symbol = text "stg_exports_" <> mod_str+     export_list = braces $ pprWithCommas closure_ptr hs_fns      closure_ptr :: Id -> SDoc@@ -817,8 +818,10 @@   | otherwise =   case splitDataProductType_maybe rep_ty of      Just (_, _, data_con, [Scaled _ prim_ty]) ->-        ASSERT(dataConSourceArity data_con == 1)-        ASSERT2(isUnliftedType prim_ty, ppr prim_ty)+        assert (dataConSourceArity data_con == 1) $+        assertPpr (isUnliftedType prim_ty) (ppr prim_ty)+          -- NB: it's OK to call isUnliftedType here, as we don't allow+          -- representation-polymorphic types in foreign import/export declarations         prim_ty      _other -> pprPanic "GHC.HsToCore.Foreign.Decl.getPrimTyOf" (ppr ty)   where
GHC/HsToCore/GuardedRHSs.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE CPP #-} + {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998@@ -10,8 +10,6 @@  module GHC.HsToCore.GuardedRHSs ( dsGuarded, dsGRHSs, isTrueLHsExpr ) where -#include "HsVersions.h"- import GHC.Prelude  import {-# SOURCE #-} GHC.HsToCore.Expr  ( dsLExpr, dsLocalBinds )@@ -30,6 +28,7 @@ import GHC.Types.SrcLoc import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Core.Multiplicity import Control.Monad ( zipWithM ) import Data.List.NonEmpty ( NonEmpty, toList )@@ -50,7 +49,8 @@ dsGuarded :: GRHSs GhcTc (LHsExpr GhcTc) -> Type -> NonEmpty Nablas -> DsM CoreExpr dsGuarded grhss rhs_ty rhss_nablas = do     match_result <- dsGRHSs PatBindRhs grhss rhs_ty rhss_nablas-    error_expr <- mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID rhs_ty empty+    error_expr <- mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID rhs_ty+                               (text "pattern binding")     extractMatchResult match_result error_expr  -- In contrast, @dsGRHSs@ produces a @MatchResult CoreExpr@.@@ -63,8 +63,8 @@                                        --   one for each GRHS.         -> DsM (MatchResult CoreExpr) dsGRHSs hs_ctx (GRHSs _ grhss binds) rhs_ty rhss_nablas-  = ASSERT( notNull grhss )-    do { match_results <- ASSERT( length grhss == length rhss_nablas )+  = assert (notNull grhss) $+    do { match_results <- assert (length grhss == length rhss_nablas) $                           zipWithM (dsGRHS hs_ctx rhs_ty) (toList rhss_nablas) grhss        ; nablas <- getPmNablas        -- We need to remember the Nablas from the particular match context we
GHC/HsToCore/ListComp.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP            #-}+ {-# LANGUAGE TypeFamilies   #-}  {-@@ -11,14 +11,12 @@  module GHC.HsToCore.ListComp ( dsListComp, dsMonadComp ) where -#include "HsVersions.h"- import GHC.Prelude -import {-# SOURCE #-} GHC.HsToCore.Expr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds, dsSyntaxExpr )+import {-# SOURCE #-} GHC.HsToCore.Expr ( dsExpr, dsLExpr, dsLocalBinds, dsSyntaxExpr )  import GHC.Hs-import GHC.Tc.Utils.Zonk+import GHC.Hs.Syn.Type import GHC.Core import GHC.Core.Make @@ -35,9 +33,9 @@ import GHC.Types.SrcLoc import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Tc.Utils.TcType import GHC.Data.List.SetOps( getNth )-import GHC.Utils.Misc  {- List comprehensions may be desugared in one of two ways: ``ordinary''@@ -140,9 +138,6 @@                 , Var unzip_fn'                 , inner_list_expr' ] -    dsNoLevPoly (tcFunResultTyN (length usingArgs') (exprType usingExpr'))-      (text "In the result of a" <+> quotes (text "using") <+> text "function:" <+> ppr using)-     -- Build a pattern that ensures the consumer binds into the NEW binders,     -- which hold lists rather than single values     let pat = mkBigLHsVarPatTupId to_bndrs  -- NB: no '!@@ -222,7 +217,7 @@  deListComp (LastStmt _ body _ _ : quals) list   =     -- Figure 7.4, SLPJ, p 135, rule C above-    ASSERT( null quals )+    assert (null quals) $     do { core_body <- dsLExpr body        ; return (mkConsExpr (exprType core_body) core_body list) } @@ -242,7 +237,7 @@     deBindComp pat inner_list_expr quals list  deListComp (BindStmt _ pat list1 : quals) core_list2 = do -- rule A' above-    core_list1 <- dsLExprNoLP list1+    core_list1 <- dsLExpr list1     deBindComp pat core_list1 quals core_list2  deListComp (ParStmt _ stmtss_w_bndrs _ _ : quals) list@@ -280,8 +275,8 @@     let res_ty = exprType core_list2         h_ty   = u1_ty `mkVisFunTyMany` res_ty -       -- no levity polymorphism here, as list comprehensions don't work-       -- with RebindableSyntax. NB: These are *not* monad comps.+       -- no representation polymorphism here, as list comprehensions+       -- don't work with RebindableSyntax. NB: These are *not* monad comps.     [h, u1, u2, u3] <- newSysLocalsDs $ map unrestricted [h_ty, u1_ty, u2_ty, u3_ty]      -- the "fail" value ...@@ -290,7 +285,7 @@         letrec_body = App (Var h) core_list1      rest_expr <- deListComp quals core_fail-    core_match <- matchSimply (Var u2) (StmtCtxt ListComp) pat rest_expr core_fail+    core_match <- matchSimply (Var u2) (StmtCtxt (HsDoStmt ListComp)) pat rest_expr core_fail      let         rhs = Lam u1 $@@ -329,8 +324,8 @@ dfListComp _ _ [] = panic "dfListComp"  dfListComp c_id n_id (LastStmt _ body _ _ : quals)-  = ASSERT( null quals )-    do { core_body <- dsLExprNoLP body+  = assert (null quals) $+    do { core_body <- dsLExpr body        ; return (mkApps (Var c_id) [core_body, Var n_id]) }          -- Non-last: must be a guard@@ -378,7 +373,7 @@     core_rest <- dfListComp c_id b quals      -- build the pattern match-    core_expr <- matchSimply (Var x) (StmtCtxt ListComp)+    core_expr <- matchSimply (Var x) (StmtCtxt (HsDoStmt ListComp))                 pat core_rest (Var b)      -- now build the outermost foldr, and return@@ -485,7 +480,7 @@ dsMcStmt :: ExprStmt GhcTc -> [ExprLStmt GhcTc] -> DsM CoreExpr  dsMcStmt (LastStmt _ body _ ret_op) stmts-  = ASSERT( null stmts )+  = assert (null stmts) $     do { body' <- dsLExpr body        ; dsSyntaxExpr ret_op [body'] } @@ -551,7 +546,7 @@        ; let tup_n_ty' = mkBigCoreVarTupTy to_bndrs         ; body        <- dsMcStmts stmts_rest-       ; n_tup_var'  <- newSysLocalDsNoLP Many n_tup_ty'+       ; n_tup_var'  <- newSysLocalDs Many n_tup_ty'        ; tup_n_var'  <- newSysLocalDs Many tup_n_ty'        ; tup_n_expr' <- mkMcUnzipM form fmap_op n_tup_var' from_bndr_tys        ; us          <- newUniqueSupply@@ -616,9 +611,9 @@ dsMcBindStmt pat rhs' bind_op fail_op res1_ty stmts   = do  { body     <- dsMcStmts stmts         ; var      <- selectSimpleMatchVarL Many pat-        ; match <- matchSinglePatVar var Nothing (StmtCtxt (DoExpr Nothing)) pat+        ; match <- matchSinglePatVar var Nothing (StmtCtxt (HsDoStmt (DoExpr Nothing))) pat                                   res1_ty (cantFailMatchResult body)-        ; match_code <- dsHandleMonadicFailure (MonadComp :: HsStmtContext GhcRn) pat match fail_op+        ; match_code <- dsHandleMonadicFailure MonadComp pat match fail_op         ; dsSyntaxExpr bind_op [rhs', Lam var match_code] }  -- Desugar nested monad comprehensions, for example in `then..` constructs@@ -649,7 +644,7 @@ mkMcUnzipM :: TransForm            -> HsExpr GhcTc      -- fmap            -> Id                -- Of type n (a,b,c)-           -> [Type]            -- [a,b,c]   (not levity-polymorphic)+           -> [Type]            -- [a,b,c]   (not representation-polymorphic)            -> DsM CoreExpr      -- Of type (n a, n b, n c) mkMcUnzipM ThenForm _ ys _   = return (Var ys) -- No unzipping to do
GHC/HsToCore/Match.hs view
@@ -1,7 +1,9 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE MonadComprehensions #-} {-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}  {-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}@@ -20,18 +22,16 @@    ) where -#include "HsVersions.h"- import GHC.Prelude import GHC.Platform -import {-#SOURCE#-} GHC.HsToCore.Expr (dsLExpr, dsSyntaxExpr)+import {-#SOURCE#-} GHC.HsToCore.Expr (dsExpr)  import GHC.Types.Basic ( Origin(..), isGenerated, Boxity(..) ) import GHC.Types.SourceText import GHC.Driver.Session import GHC.Hs-import GHC.Tc.Utils.Zonk+import GHC.Hs.Syn.Type import GHC.Tc.Types.Evidence import GHC.Tc.Utils.Monad import GHC.HsToCore.Pmc@@ -48,6 +48,7 @@ import GHC.Core.ConLike import GHC.Core.DataCon import GHC.Core.PatSyn+import GHC.HsToCore.Errors.Types import GHC.HsToCore.Match.Constructor import GHC.HsToCore.Match.Literal import GHC.Core.Type@@ -61,6 +62,7 @@ import GHC.Types.Name import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Data.FastString import GHC.Types.Unique import GHC.Types.Unique.DFM@@ -184,15 +186,15 @@       -> DsM (MatchResult CoreExpr) -- ^ Desugared result!  match [] ty eqns-  = ASSERT2( not (null eqns), ppr ty )+  = assertPpr (not (null eqns)) (ppr ty) $     return (foldr1 combineMatchResults match_results)   where-    match_results = [ ASSERT( null (eqn_pats eqn) )+    match_results = [ assert (null (eqn_pats eqn)) $                       eqn_rhs eqn                     | eqn <- eqns ]  match (v:vs) ty eqns    -- Eqns *can* be empty-  = ASSERT2( all (isInternalName . idName) vars, ppr vars )+  = assertPpr (all (isInternalName . idName) vars) (ppr vars) $     do  { dflags <- getDynFlags         ; let platform = targetPlatform dflags                 -- Tidy the first pattern, generating@@ -232,7 +234,6 @@             PgBang    -> matchBangs      vars ty (dropGroup eqns)             PgCo {}   -> matchCoercion   vars ty (dropGroup eqns)             PgView {} -> matchView       vars ty (dropGroup eqns)-            PgOverloadedList -> matchOverloadedList vars ty (dropGroup eqns)       where eqns' = NEL.toList eqns             ne l = case NEL.nonEmpty l of               Just nel -> nel@@ -248,13 +249,12 @@                                            case p of PgView e _ -> e:acc                                                      _ -> acc) [] group) eqns             maybeWarn [] = return ()-            maybeWarn l = warnDs NoReason (vcat l)+            maybeWarn l  = diagnosticDs (DsAggregatedViewExpressions l)         in-          maybeWarn $ (map (\g -> text "Putting these view expressions into the same case:" <+> (ppr g))-                       (filter (not . null) gs))+          maybeWarn $ filter (not . null) gs  matchEmpty :: MatchId -> Type -> DsM (NonEmpty (MatchResult CoreExpr))--- See Note [Empty case expressions]+-- See Note [Empty case alternatives] matchEmpty var res_ty   = return [MR_Fallible mk_seq]   where@@ -290,47 +290,43 @@   = do  { -- we could pass in the expr from the PgView,          -- but this needs to extract the pat anyway          -- to figure out the type of the fresh variable-         let ViewPat _ viewExpr (L _ pat) = firstPat eqn1+         let TcViewPat viewExpr pat = firstPat eqn1          -- do the rest of the compilation         ; let pat_ty' = hsPatType pat         ; var' <- newUniqueId var (idMult var) pat_ty'         ; match_result <- match (var':vars) ty $ NEL.toList $             decomposeFirstPat getViewPat <$> eqns          -- compile the view expressions-        ; viewExpr' <- dsLExpr viewExpr+        ; viewExpr' <- dsExpr viewExpr         ; return (mkViewMatchResult var'                     (mkCoreAppDs (text "matchView") viewExpr' (Var var))                     match_result) } -matchOverloadedList :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)-matchOverloadedList (var :| vars) ty (eqns@(eqn1 :| _))--- Since overloaded list patterns are treated as view patterns,--- the code is roughly the same as for matchView-  = do { let ListPat (ListPatTc elt_ty (Just (_,e))) _ = firstPat eqn1-       ; var' <- newUniqueId var (idMult var) (mkListTy elt_ty)  -- we construct the overall type by hand-       ; match_result <- match (var':vars) ty $ NEL.toList $-           decomposeFirstPat getOLPat <$> eqns -- getOLPat builds the pattern inside as a non-overloaded version of the overloaded list pattern-       ; e' <- dsSyntaxExpr e [Var var]-       ; return (mkViewMatchResult var' e' match_result)-       }- -- decompose the first pattern and leave the rest alone decomposeFirstPat :: (Pat GhcTc -> Pat GhcTc) -> EquationInfo -> EquationInfo decomposeFirstPat extractpat (eqn@(EqnInfo { eqn_pats = pat : pats }))         = eqn { eqn_pats = extractpat pat : pats} decomposeFirstPat _ _ = panic "decomposeFirstPat" -getCoPat, getBangPat, getViewPat, getOLPat :: Pat GhcTc -> Pat GhcTc+getCoPat, getBangPat, getViewPat :: Pat GhcTc -> Pat GhcTc getCoPat (XPat (CoPat _ pat _)) = pat getCoPat _                   = panic "getCoPat" getBangPat (BangPat _ pat  ) = unLoc pat getBangPat _                 = panic "getBangPat"-getViewPat (ViewPat _ _ pat) = unLoc pat+getViewPat (TcViewPat _ pat) = pat getViewPat _                 = panic "getViewPat"-getOLPat (ListPat (ListPatTc ty (Just _)) pats)-        = ListPat (ListPatTc ty Nothing)  pats-getOLPat _                   = panic "getOLPat" +-- | Use this pattern synonym to match on a 'ViewPat'.+--+-- N.B.: View patterns can occur inside HsExpansions.+pattern TcViewPat :: HsExpr GhcTc -> Pat GhcTc -> Pat GhcTc+pattern TcViewPat viewExpr pat <- (getTcViewPat -> (viewExpr, pat))++getTcViewPat :: Pat GhcTc -> (HsExpr GhcTc, Pat GhcTc)+getTcViewPat (ViewPat _ viewLExpr pat)  = (unLoc viewLExpr, unLoc pat)+getTcViewPat (XPat (ExpansionPat  _ p)) = getTcViewPat p+getTcViewPat p = pprPanic "getTcViewPat" (ppr p)+ {- Note [Empty case alternatives] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -347,7 +343,7 @@    error "empty case" or some such, because 'x' might be bound to (error "hello"), in which case we want to see that "hello" exception, not (error "empty case").-See also Note [Case elimination: lifted case] in GHC.Core.Opt.Simplify.+See also the "lifted case" discussion in Note [Case elimination] in GHC.Core.Opt.Simplify.   ************************************************************************@@ -422,7 +418,7 @@ -- It eliminates many pattern forms (as-patterns, variable patterns, -- list patterns, etc) and returns any created bindings in the wrapper. -tidy1 v o (ParPat _ pat)      = tidy1 v o (unLoc pat)+tidy1 v o (ParPat _ _ pat _)  = tidy1 v o (unLoc pat) tidy1 v o (SigPat _ pat _)    = tidy1 v o (unLoc pat) tidy1 _ _ (WildPat ty)        = return (idDsWrapper, WildPat ty) tidy1 v o (BangPat _ (L l p)) = tidy_bang_pat v o l p@@ -454,18 +450,16 @@     -- Doing this check during type-checking is unsatisfactory because we may     -- not fully know the zonked types yet. We sure do here.   = do  { let unlifted_bndrs = filter (isUnliftedType . idType) (collectPatBinders CollNoDictBinders pat)+            -- NB: the binders can't be representation-polymorphic, so we're OK to call isUnliftedType         ; unless (null unlifted_bndrs) $           putSrcSpanDs (getLocA pat) $-          errDs (hang (text "A lazy (~) pattern cannot bind variables of unlifted type." $$-                       text "Unlifted variables:")-                    2 (vcat (map (\id -> ppr id <+> dcolon <+> ppr (idType id))-                                 unlifted_bndrs)))+          diagnosticDs (DsLazyPatCantBindVarsOfUnliftedType unlifted_bndrs)          ; (_,sel_prs) <- mkSelectorBinds [] pat (Var v)         ; let sel_binds =  [NonRec b rhs | (b,rhs) <- sel_prs]         ; return (mkCoreLets sel_binds, WildPat (idType v)) } -tidy1 _ _ (ListPat (ListPatTc ty Nothing) pats )+tidy1 _ _ (ListPat ty pats)   = return (idDsWrapper, unLoc list_ConPat)   where     list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] [ty])@@ -518,7 +512,7 @@               -> DsM (DsWrapper, Pat GhcTc)  -- Discard par/sig under a bang-tidy_bang_pat v o _ (ParPat _ (L l p)) = tidy_bang_pat v o l p+tidy_bang_pat v o _ (ParPat _ _ (L l p) _) = tidy_bang_pat v o l p tidy_bang_pat v o _ (SigPat _ (L l p) _) = tidy_bang_pat v o l p  -- Push the bang-pattern inwards, in the hope that@@ -574,13 +568,13 @@ -- See Note [Bang patterns and newtypes] -- We are transforming   !(N p)   into   (N !p) push_bang_into_newtype_arg l _ty (PrefixCon ts (arg:args))-  = ASSERT( null args)+  = assert (null args) $     PrefixCon ts [L l (BangPat noExtField arg)] push_bang_into_newtype_arg l _ty (RecCon rf)   | HsRecFields { rec_flds = L lf fld : flds } <- rf-  , HsRecField { hsRecFieldArg = arg } <- fld-  = ASSERT( null flds)-    RecCon (rf { rec_flds = [L lf (fld { hsRecFieldArg+  , HsFieldBind { hfbRHS = arg } <- fld+  = assert (null flds) $+    RecCon (rf { rec_flds = [L lf (fld { hfbRHS                                            = L l (BangPat noExtField arg) })] }) push_bang_into_newtype_arg l ty (RecCon rf) -- If a user writes !(T {})   | HsRecFields { rec_flds = [] } <- rf@@ -714,15 +708,32 @@ \end{enumerate} -} +-- Note [matchWrapper scrutinees]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- There are three possible cases for matchWrapper's scrutinees argument:+--+-- 1. Nothing   Used for FunBind, HsLam, HsLamcase, where there is no explicit scrutinee+--              The MatchGroup may have matchGroupArity of 0 or more. Examples:+--                  f p1 q1 = ... -- matchGroupArity 2+--                  f p2 q2 = ...+--+--                  \cases | g1 -> ... -- matchGroupArity 0+--                         | g2 -> ...+--+-- 2. Just [e]  Used for HsCase, RecordUpd; exactly one scrutinee+--              The MatchGroup has matchGroupArity of exactly 1. Example:+--                  case e of p1 -> e1 -- matchGroupArity 1+--                            p2 -> e2+--+-- 3. Just es   Used for HsCmdLamCase; zero or more scrutinees+--              The MatchGroup has matchGroupArity of (length es). Example:+--                  \cases p1 q1 -> returnA -< ... -- matchGroupArity 2+--                         p2 q2 -> ...+ matchWrapper   :: HsMatchContext GhcRn              -- ^ For shadowing warning messages-  -> Maybe (LHsExpr GhcTc)             -- ^ Scrutinee. (Just scrut) for a case expr-                                       --      case scrut of { p1 -> e1 ... }-                                       --   (and in this case the MatchGroup will-                                       --    have all singleton patterns)-                                       --   Nothing for a function definition-                                       --      f p1 q1 = ...  -- No "scrutinee"-                                       --      f p2 q2 = ...  -- in this case+  -> Maybe [LHsExpr GhcTc]             -- ^ Scrutinee(s)+                                       -- see Note [matchWrapper scrutinees]   -> MatchGroup GhcTc (LHsExpr GhcTc)  -- ^ Matches being desugared   -> DsM ([Id], CoreExpr)              -- ^ Results (usually passed to 'match') @@ -750,14 +761,14 @@ JJQC 30-Nov-1997 -} -matchWrapper ctxt mb_scr (MG { mg_alts = L _ matches+matchWrapper ctxt scrs (MG { mg_alts = L _ matches                              , mg_ext = MatchGroupTc arg_tys rhs_ty                              , mg_origin = origin })   = do  { dflags <- getDynFlags         ; locn   <- getSrcSpanDs          ; new_vars    <- case matches of-                           []    -> newSysLocalsDsNoLP arg_tys+                           []    -> newSysLocalsDs arg_tys                            (m:_) ->                             selectMatchVars (zipWithEqual "matchWrapper"                                               (\a b -> (scaledMult a, unLoc b))@@ -768,7 +779,7 @@         -- @rhss_nablas@ is a flat list of covered Nablas for each RHS.         -- Each Match will split off one Nablas for its RHSs from this.         ; matches_nablas <- if isMatchContextPmChecked dflags origin ctxt-            then addHsScrutTmCs mb_scr new_vars $+            then addHsScrutTmCs (concat scrs) new_vars $                  -- See Note [Long-distance information]                  pmcMatches (DsMatchContext ctxt locn) new_vars matches             else pure (initNablasMatches matches)@@ -873,12 +884,12 @@                   -> HsMatchContext GhcRn -> LPat GhcTc                   -> Type -> MatchResult CoreExpr -> DsM (MatchResult CoreExpr) matchSinglePatVar var mb_scrut ctx pat ty match_result-  = ASSERT2( isInternalName (idName var), ppr var )+  = assertPpr (isInternalName (idName var)) (ppr var) $     do { dflags <- getDynFlags        ; locn   <- getSrcSpanDs        -- Pattern match check warnings        ; when (isMatchContextPmChecked dflags FromSource ctx) $-           addCoreScrutTmCs mb_scrut [var] $+           addCoreScrutTmCs (maybeToList mb_scrut) [var] $            pmcPatBind (DsMatchContext ctx locn) var (unLoc pat)         ; let eqn_info = EqnInfo { eqn_pats = [unLoc (decideBangHood dflags pat)]@@ -911,7 +922,6 @@   | PgView (LHsExpr GhcTc) -- view pattern (e -> p):                         -- the LHsExpr is the expression e            Type         -- the Type is the type of p (equivalently, the result type of e)-  | PgOverloadedList  {- Note [Don't use Literal for PgN] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1018,11 +1028,11 @@         -- Order is significant, match PgN after PgLit         -- If the exponents are small check for value equality rather than syntactic equality         -- This is implemented in the Eq instance for FractionalLit, we do this to avoid-        -- computing the value of excessivly large rationals.+        -- computing the value of excessively large rationals. sameGroup (PgOverS s1)  (PgOverS s2)  = s1==s2 sameGroup (PgNpK l1)    (PgNpK l2)    = l1==l2  -- See Note [Grouping overloaded literal patterns] sameGroup (PgCo t1)     (PgCo t2)     = t1 `eqType` t2-        -- CoPats are in the same goup only if the type of the+        -- CoPats are in the same group only if the type of the         -- enclosed pattern is the same. The patterns outside the CoPat         -- always have the same type, so this boils down to saying that         -- the two coercions are identical.@@ -1053,8 +1063,8 @@     exp :: HsExpr GhcTc -> HsExpr GhcTc -> Bool     -- real comparison is on HsExpr's     -- strip parens-    exp (HsPar _ (L _ e)) e'   = exp e e'-    exp e (HsPar _ (L _ e'))   = exp e e'+    exp (HsPar _ _ (L _ e) _) e' = exp e e'+    exp e (HsPar _ _ (L _ e') _) = exp e e'     -- because the expressions do not necessarily have the same type,     -- we have to compare the wrappers     exp (XExpr (WrapExpr (HsWrap h e))) (XExpr (WrapExpr (HsWrap  h' e'))) =@@ -1062,7 +1072,7 @@     exp (XExpr (ExpansionExpr (HsExpanded _ b))) (XExpr (ExpansionExpr (HsExpanded _ b'))) =       exp b b'     exp (HsVar _ i) (HsVar _ i') =  i == i'-    exp (HsConLikeOut _ c) (HsConLikeOut _ c') = c == c'+    exp (XExpr (ConLikeTc c _ _)) (XExpr (ConLikeTc c' _ _)) = c == c'     -- the instance for IPName derives using the id, so this works if the     -- above does     exp (HsIPVar _ i) (HsIPVar _ i') = i == i'@@ -1125,7 +1135,7 @@     --        equating different ways of writing a coercion)     wrap WpHole WpHole = True     wrap (WpCompose w1 w2) (WpCompose w1' w2') = wrap w1 w1' && wrap w2 w2'-    wrap (WpFun w1 w2 _ _) (WpFun w1' w2' _ _) = wrap w1 w1' && wrap w2 w2'+    wrap (WpFun w1 w2 _)   (WpFun w1' w2' _)   = wrap w1 w1' && wrap w2 w2'     wrap (WpCast co)       (WpCast co')        = co `eqCoercion` co'     wrap (WpEvApp et1)     (WpEvApp et2)       = et1 `ev_term` et2     wrap (WpTyApp t)       (WpTyApp t')        = eqType t t'@@ -1171,17 +1181,17 @@     (HsFractional f, is_neg)       | is_neg    -> PgN $! negateFractionalLit f       | otherwise -> PgN f-    (HsIsString _ s, _) -> ASSERT(isNothing mb_neg)+    (HsIsString _ s, _) -> assert (isNothing mb_neg) $                             PgOverS s patGroup _ (NPlusKPat _ _ (L _ (OverLit {ol_val=oval})) _ _ _) =   case oval of    HsIntegral i -> PgNpK (il_value i)    _ -> pprPanic "patGroup NPlusKPat" (ppr oval)-patGroup _ (XPat (CoPat _ p _))         = PgCo  (hsPatType p)-                                                    -- Type of innelexp pattern patGroup _ (ViewPat _ expr p)           = PgView expr (hsPatType (unLoc p))-patGroup _ (ListPat (ListPatTc _ (Just _)) _) = PgOverloadedList patGroup platform (LitPat _ lit)        = PgLit (hsLitKey platform lit)+patGroup platform (XPat ext) = case ext of+  CoPat _ p _      -> PgCo (hsPatType p) -- Type of innelexp pattern+  ExpansionPat _ p -> patGroup platform p patGroup _ pat                          = pprPanic "patGroup" (ppr pat)  {-
GHC/HsToCore/Match.hs-boot view
@@ -15,7 +15,7 @@  matchWrapper         :: HsMatchContext GhcRn-        -> Maybe (LHsExpr GhcTc)+        -> Maybe [LHsExpr GhcTc]         -> MatchGroup GhcTc (LHsExpr GhcTc)         -> DsM ([Id], CoreExpr)
GHC/HsToCore/Match/Constructor.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE TypeFamilies #-}  {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}@@ -13,8 +13,6 @@  module GHC.HsToCore.Match.Constructor ( matchConFamily, matchPatSyn ) where -#include "HsVersions.h"- import GHC.Prelude  import {-# SOURCE #-} GHC.HsToCore.Match ( match )@@ -36,6 +34,7 @@ import GHC.Types.SrcLoc import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import Control.Monad(liftM) import Data.List (groupBy) import Data.List.NonEmpty (NonEmpty(..))@@ -133,10 +132,10 @@                 -> NonEmpty EquationInfo                 -> DsM (CaseAlt ConLike) matchOneConLike vars ty mult (eqn1 :| eqns)   -- All eqns for a single constructor-  = do  { let inst_tys = ASSERT( all tcIsTcTyVar ex_tvs )+  = do  { let inst_tys = assert (all tcIsTcTyVar ex_tvs) $                            -- ex_tvs can only be tyvars as data types in source                            -- Haskell cannot mention covar yet (Aug 2018).-                         ASSERT( tvs1 `equalLength` ex_tvs )+                         assert (tvs1 `equalLength` ex_tvs) $                          arg_tys ++ mkTyVarTys tvs1                val_arg_tys = conLikeInstOrigArgTys con1 inst_tys@@ -147,7 +146,7 @@                           -> [(ConArgPats, EquationInfo)] -> DsM (MatchResult CoreExpr)               -- All members of the group have compatible ConArgPats               match_group arg_vars arg_eqn_prs-                = ASSERT( notNull arg_eqn_prs )+                = assert (notNull arg_eqn_prs) $                   do { (wraps, eqns') <- liftM unzip (mapM shift arg_eqn_prs)                      ; let group_arg_vars = select_arg_vars arg_vars arg_eqn_prs                      ; match_result <- match (group_arg_vars ++ vars) ty eqns'@@ -216,15 +215,15 @@       | RecCon flds <- arg_pats       , let rpats = rec_flds flds       , not (null rpats)     -- Treated specially; cf conArgPats-      = ASSERT2( fields1 `equalLength` arg_vars,-                 ppr con1 $$ ppr fields1 $$ ppr arg_vars )+      = assertPpr (fields1 `equalLength` arg_vars)+                  (ppr con1 $$ ppr fields1 $$ ppr arg_vars) $         map lookup_fld rpats       | otherwise       = arg_vars       where         fld_var_env = mkNameEnv $ zipEqual "get_arg_vars" fields1 arg_vars         lookup_fld (L _ rpat) = lookupNameEnv_NF fld_var_env-                                            (idName (unLoc (hsRecFieldId rpat)))+                                            (idName (hsRecFieldId rpat))     select_arg_vars _ [] = panic "matchOneCon/select_arg_vars []"  -----------------@@ -240,16 +239,17 @@             -> Bool same_fields flds1 flds2   = all2 (\(L _ f1) (L _ f2)-                          -> unLoc (hsRecFieldId f1) == unLoc (hsRecFieldId f2))+                          -> hsRecFieldId f1 == hsRecFieldId f2)          (rec_flds flds1) (rec_flds flds2)   ----------------- selectConMatchVars :: [Scaled Type] -> ConArgPats -> DsM [Id]-selectConMatchVars arg_tys con = case con of-                                   (RecCon {}) -> newSysLocalsDsNoLP arg_tys-                                   (PrefixCon _ ps) -> selectMatchVars (zipMults arg_tys ps)-                                   (InfixCon p1 p2) -> selectMatchVars (zipMults arg_tys [p1, p2])+selectConMatchVars arg_tys con+  = case con of+      RecCon {}      -> newSysLocalsDs arg_tys+      PrefixCon _ ps -> selectMatchVars (zipMults arg_tys ps)+      InfixCon p1 p2 -> selectMatchVars (zipMults arg_tys [p1, p2])   where     zipMults = zipWithEqual "selectConMatchVar" (\a b -> (scaledMult a, unLoc b)) @@ -264,7 +264,7 @@   | null rpats = map WildPat (map scaledThing arg_tys)         -- Important special case for C {}, which can be used for a         -- datacon that isn't declared to have fields at all-  | otherwise  = map (unLoc . hsRecFieldArg . unLoc) rpats+  | otherwise  = map (unLoc . hfbRHS . unLoc) rpats  {- Note [Record patterns]
GHC/HsToCore/Match/Literal.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP                 #-}+ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MultiWayIf          #-} {-# LANGUAGE TypeApplications    #-}@@ -24,14 +24,13 @@    ) where -#include "HsVersions.h"- import GHC.Prelude import GHC.Platform  import {-# SOURCE #-} GHC.HsToCore.Match ( match ) import {-# SOURCE #-} GHC.HsToCore.Expr  ( dsExpr, dsSyntaxExpr ) +import GHC.HsToCore.Errors.Types import GHC.HsToCore.Monad import GHC.HsToCore.Utils @@ -42,6 +41,7 @@ import GHC.Core import GHC.Core.Make import GHC.Core.TyCon+import GHC.Core.Reduction ( Reduction(..) ) import GHC.Core.DataCon import GHC.Tc.Utils.Zonk ( shortCutLit ) import GHC.Tc.Utils.TcType@@ -56,8 +56,8 @@ import GHC.Driver.Session import GHC.Utils.Misc import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Data.FastString-import qualified GHC.LanguageExtensions as LangExt import GHC.Core.FamInstEnv ( FamInstEnvs, normaliseType )  import Control.Monad@@ -108,7 +108,7 @@     HsDoublePrim _ fl -> return (Lit (LitDouble (rationalFromFractionalLit fl)))     HsChar _ c       -> return (mkCharExpr c)     HsString _ str   -> mkStringExprFS str-    HsInteger _ i _  -> return (mkIntegerExpr i)+    HsInteger _ i _  -> return (mkIntegerExpr platform i)     HsInt _ i        -> return (mkIntExpr platform (il_value i))     HsRat _ fl ty    -> dsFractionalLitToRational fl ty @@ -199,15 +199,17 @@ dsFractionalLitToRational fl@FL{ fl_signi = signi, fl_exp = exp, fl_exp_base = base } ty   -- We compute "small" rationals here and now   | abs exp <= 100-  = let !val   = rationalFromFractionalLit fl-        !num   = mkIntegerExpr (numerator val)-        !denom = mkIntegerExpr (denominator val)+  = do+    platform <- targetPlatform <$> getDynFlags+    let !val   = rationalFromFractionalLit fl+        !num   = mkIntegerExpr platform (numerator val)+        !denom = mkIntegerExpr platform (denominator val)         (ratio_data_con, integer_ty)             = case tcSplitTyConApp ty of-                    (tycon, [i_ty]) -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey)+                    (tycon, [i_ty]) -> assert (isIntegerTy i_ty && tycon `hasKey` ratioTyConKey)                                        (head (tyConDataCons tycon), i_ty)                     x -> pprPanic "dsLit" (ppr x)-    in return $! (mkCoreConApps ratio_data_con [Type integer_ty, num, denom])+    return $! (mkCoreConApps ratio_data_con [Type integer_ty, num, denom])   -- Large rationals will be computed at runtime.   | otherwise   = do@@ -216,22 +218,23 @@                              Base10 -> mkRationalBase10Name       mkRational <- dsLookupGlobalId mkRationalName       litR <- dsRational signi-      let litE = mkIntegerExpr exp+      platform <- targetPlatform <$> getDynFlags+      let litE = mkIntegerExpr platform exp       return (mkCoreApps (Var mkRational) [litR, litE])  dsRational :: Rational -> DsM CoreExpr dsRational (n :% d) = do+  platform <- targetPlatform <$> getDynFlags   dcn <- dsLookupDataCon ratioDataConName-  let cn = mkIntegerExpr n-  let dn = mkIntegerExpr d+  let cn = mkIntegerExpr platform n+  let dn = mkIntegerExpr platform d   return $ mkCoreConApps dcn [Type integerTy, cn, dn]   dsOverLit :: HsOverLit GhcTc -> DsM CoreExpr -- ^ Post-typechecker, the 'HsExpr' field of an 'OverLit' contains -- (an expression for) the literal value itself.-dsOverLit (OverLit { ol_val = val, ol_ext = OverLitTc rebindable ty-                   , ol_witness = witness }) = do+dsOverLit (OverLit { ol_val = val, ol_ext = OverLitTc rebindable witness ty }) = do   dflags <- getDynFlags   let platform = targetPlatform dflags   case shortCutLit platform val ty of@@ -264,10 +267,7 @@   , idName conv_fn `elem` conversionNames   , Just (_, arg_ty, res_ty) <- splitFunTy_maybe type_of_conv   , arg_ty `eqType` res_ty  -- So we are converting  ty -> ty-  = warnDs (Reason Opt_WarnIdentities)-           (vcat [ text "Call of" <+> ppr conv_fn <+> dcolon <+> ppr type_of_conv-                 , nest 2 $ text "can probably be omitted"-           ])+  = diagnosticDs (DsIdentitiesFound conv_fn type_of_conv) warnAboutIdentities _ _ _ = return ()  conversionNames :: [Name]@@ -348,37 +348,13 @@     checkPositive :: Integer -> Name -> DsM ()     checkPositive i tc       = when (i < 0) $-        warnDs (Reason Opt_WarnOverflowedLiterals)-               (vcat [ text "Literal" <+> integer i-                       <+> text "is negative but" <+> ppr tc-                       <+> ptext (sLit "only supports positive numbers")-                     ])+        diagnosticDs (DsOverflowedLiterals i tc Nothing (negLiteralExtEnabled dflags))      check i tc minB maxB       = when (i < minB || i > maxB) $-        warnDs (Reason Opt_WarnOverflowedLiterals)-               (vcat [ text "Literal" <+> integer i-                       <+> text "is out of the" <+> ppr tc <+> ptext (sLit "range")-                       <+> integer minB <> text ".." <> integer maxB-                     , sug ])+        diagnosticDs (DsOverflowedLiterals i tc bounds (negLiteralExtEnabled dflags))       where-        sug | minB == -i   -- Note [Suggest NegativeLiterals]-            , i > 0-            , not (xopt LangExt.NegativeLiterals dflags)-            = text "If you are trying to write a large negative literal, use NegativeLiterals"-            | otherwise = Outputable.empty--{--Note [Suggest NegativeLiterals]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If you write-  x :: Int8-  x = -128-it'll parse as (negate 128), and overflow.  In this case, suggest NegativeLiterals.-We get an erroneous suggestion for-  x = 128-but perhaps that does not matter too much.--}+        bounds = Just (MinBound minB, MaxBound maxB)  warnAboutEmptyEnumerations :: FamInstEnvs -> DynFlags -> LHsExpr GhcTc                            -> Maybe (LHsExpr GhcTc)@@ -441,19 +417,20 @@    | otherwise = return ()   where-    raiseWarning = warnDs (Reason Opt_WarnEmptyEnumerations) (text "Enumeration is empty")+    raiseWarning =+      diagnosticDs DsEmptyEnumeration  getLHsIntegralLit :: LHsExpr GhcTc -> Maybe (Integer, Type) -- ^ See if the expression is an 'Integral' literal. getLHsIntegralLit (L _ e) = go e   where-    go (HsPar _ e)            = getLHsIntegralLit e+    go (HsPar _ _ e _)        = getLHsIntegralLit e     go (HsOverLit _ over_lit) = getIntegralLit over_lit     go (HsLit _ lit)          = getSimpleIntegralLit lit      -- Remember to look through automatically-added tick-boxes! (#8384)-    go (HsTick _ _ e)         = getLHsIntegralLit e-    go (HsBinTick _ _ _ e)    = getLHsIntegralLit e+    go (XExpr (HsTick _ e))       = getLHsIntegralLit e+    go (XExpr (HsBinTick _ _ e))  = getLHsIntegralLit e      -- The literal might be wrapped in a case with -XOverloadedLists     go (XExpr (WrapExpr (HsWrap _ e))) = go e@@ -462,7 +439,7 @@ -- | If 'Integral', extract the value and type of the overloaded literal. -- See Note [Literals and the OverloadedLists extension] getIntegralLit :: HsOverLit GhcTc -> Maybe (Integer, Type)-getIntegralLit (OverLit { ol_val = HsIntegral i, ol_ext = OverLitTc _ ty })+getIntegralLit (OverLit { ol_val = HsIntegral i, ol_ext = OverLitTc { ol_type = ty } })   = Just (il_value i, ty) getIntegralLit _ = Nothing @@ -478,10 +455,10 @@  -- | Extract the Char if the expression is a Char literal. getLHsCharLit :: LHsExpr GhcTc -> Maybe Char-getLHsCharLit (L _ (HsPar _ e))            = getLHsCharLit e-getLHsCharLit (L _ (HsTick _ _ e))         = getLHsCharLit e-getLHsCharLit (L _ (HsBinTick _ _ _ e))    = getLHsCharLit e+getLHsCharLit (L _ (HsPar _ _ e _))        = getLHsCharLit e getLHsCharLit (L _ (HsLit _ (HsChar _ c))) = Just c+getLHsCharLit (L _ (XExpr (HsTick _ e)))         = getLHsCharLit e+getLHsCharLit (L _ (XExpr (HsBinTick _ _ e)))    = getLHsCharLit e getLHsCharLit _ = Nothing  -- | Convert a pair (Integer, Type) to (Integer, Name) after eventually@@ -493,7 +470,9 @@     | otherwise = Nothing   where     normaliseNominal :: FamInstEnvs -> Type -> Type-    normaliseNominal fam_envs ty = snd $ normaliseType fam_envs Nominal ty+    normaliseNominal fam_envs ty+      = reductionReducedType+      $ normaliseType fam_envs Nominal ty  -- | Convert a pair (Integer, Type) to (Integer, Name) without normalising -- the type@@ -527,9 +506,9 @@  tidyLitPat :: HsLit GhcTc -> Pat GhcTc -- Result has only the following HsLits:---      HsIntPrim, HsWordPrim, HsCharPrim, HsFloatPrim---      HsDoublePrim, HsStringPrim, HsString---  * HsInteger, HsRat, HsInt can't show up in LitPats+--      HsIntPrim, HsWordPrim, HsCharPrim, HsString+--  * HsInteger, HsRat, HsInt, as well as HsStringPrim,+--    HsFloatPrim and HsDoublePrim can't show up in LitPats --  * We get rid of HsChar right here tidyLitPat (HsChar src c) = unLoc (mkCharLitPat src c) tidyLitPat (HsString src s)@@ -545,7 +524,7 @@ tidyNPat :: HsOverLit GhcTc -> Maybe (SyntaxExpr GhcTc) -> SyntaxExpr GhcTc          -> Type          -> Pat GhcTc-tidyNPat (OverLit (OverLitTc False ty) val _) mb_neg _eq outer_ty+tidyNPat (OverLit (OverLitTc False _ ty) val) mb_neg _eq outer_ty         -- False: Take short cuts only if the literal is not using rebindable syntax         --         -- Once that is settled, look for cases where the type of the@@ -589,7 +568,7 @@                    _ -> Nothing  tidyNPat over_lit mb_neg eq outer_ty-  = NPat outer_ty (noLoc over_lit) mb_neg eq+  = NPat outer_ty (noLocA over_lit) mb_neg eq  {- ************************************************************************
GHC/HsToCore/Monad.hs view
@@ -19,8 +19,8 @@         foldlM, foldrM, whenGOptM, unsetGOptM, unsetWOptM, xoptM,         Applicative(..),(<$>), -        duplicateLocalDs, newSysLocalDsNoLP, newSysLocalDs,-        newSysLocalsDsNoLP, newSysLocalsDs, newUniqueId,+        duplicateLocalDs, newSysLocalDs,+        newSysLocalsDs, newUniqueId,         newFailLocalDs, newPredVarDs,         getSrcSpanDs, putSrcSpanDs, putSrcSpanDsA,         mkPrintUnqualifiedDs,@@ -40,17 +40,13 @@         dsGetCompleteMatches,          -- Warnings and errors-        DsWarning, warnDs, warnIfSetDs, errDs, errDsCoreExpr,+        DsWarning, diagnosticDs, errDsCoreExpr,         failWithDs, failDs, discardWarningsDs,-        askNoErrsDs,          -- Data types         DsMatchContext(..),         EquationInfo(..), MatchResult (..), runMatchResult, DsWrapper, idDsWrapper, -        -- Levity polymorphism-        dsNoLevPoly, dsNoLevPolyExpr, dsWhenNoErrs,-         -- Trace injection         pprRuntimeTrace     ) where@@ -60,16 +56,18 @@ import GHC.Driver.Env import GHC.Driver.Session import GHC.Driver.Ppr+import GHC.Driver.Config.Diagnostic  import GHC.Hs  import GHC.HsToCore.Types+import GHC.HsToCore.Errors.Types import GHC.HsToCore.Pmc.Solver.Types (Nablas, initNablas)  import GHC.Core.FamInstEnv import GHC.Core import GHC.Core.Make  ( unitExpr )-import GHC.Core.Utils ( exprType, isExprLevPoly )+import GHC.Core.Utils ( exprType ) import GHC.Core.DataCon import GHC.Core.ConLike import GHC.Core.TyCon@@ -79,7 +77,6 @@ import GHC.IfaceToCore  import GHC.Tc.Utils.Monad-import GHC.Tc.Utils.TcMType ( checkForLevPolyX, formatLevPolyErr )  import GHC.Builtin.Names @@ -105,11 +102,13 @@ import GHC.Types.TyThing import GHC.Types.Error +import GHC.Utils.Error import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Error+import qualified GHC.Data.Strict as Strict  import Data.IORef+import GHC.Driver.Env.KnotVars  {- ************************************************************************@@ -204,17 +203,22 @@         -- into a Doc.  -- | Run a 'DsM' action inside the 'TcM' monad.-initDsTc :: DsM a -> TcM a+initDsTc :: DsM a -> TcM (Messages DsMessage, Maybe a) initDsTc thing_inside   = do { tcg_env  <- getGblEnv-       ; msg_var  <- getErrsVar+       ; msg_var  <- liftIO $ newIORef emptyMessages        ; hsc_env  <- getTopEnv        ; envs     <- mkDsEnvsFromTcGbl hsc_env msg_var tcg_env-       ; setEnvs envs thing_inside+       ; e_result <- tryM $  -- need to tryM so that we don't discard+                             -- DsMessages+                     setEnvs envs thing_inside+       ; msgs     <- liftIO $ readIORef msg_var+       ; return (msgs, case e_result of Left _  -> Nothing+                                        Right x -> Just x)        }  -- | Run a 'DsM' action inside the 'IO' monad.-initDs :: HscEnv -> TcGblEnv -> DsM a -> IO (Messages DecoratedSDoc, Maybe a)+initDs :: HscEnv -> TcGblEnv -> DsM a -> IO (Messages DsMessage, Maybe a) initDs hsc_env tcg_env thing_inside   = do { msg_var <- newIORef emptyMessages        ; envs <- mkDsEnvsFromTcGbl hsc_env msg_var tcg_env@@ -223,7 +227,7 @@  -- | Build a set of desugarer environments derived from a 'TcGblEnv'. mkDsEnvsFromTcGbl :: MonadIO m-                  => HscEnv -> IORef (Messages DecoratedSDoc) -> TcGblEnv+                  => HscEnv -> IORef (Messages DsMessage) -> TcGblEnv                   -> m (DsGblEnv, DsLclEnv) mkDsEnvsFromTcGbl hsc_env msg_var tcg_env   = do { cc_st_var   <- liftIO $ newIORef newCostCentreState@@ -236,11 +240,13 @@              complete_matches = hptCompleteSigs hsc_env         -- from the home package                                 ++ tcg_complete_matches tcg_env -- from the current module                                 ++ eps_complete_matches eps     -- from imports+             -- re-use existing next_wrapper_num to ensure uniqueness+             next_wrapper_num_var = tcg_next_wrapper_num tcg_env        ; return $ mkDsEnvs unit_env this_mod rdr_env type_env fam_inst_env-                           msg_var cc_st_var complete_matches+                           msg_var cc_st_var next_wrapper_num_var complete_matches        } -runDs :: HscEnv -> (DsGblEnv, DsLclEnv) -> DsM a -> IO (Messages DecoratedSDoc, Maybe a)+runDs :: HscEnv -> (DsGblEnv, DsLclEnv) -> DsM a -> IO (Messages DsMessage, Maybe a) runDs hsc_env (ds_gbl, ds_lcl) thing_inside   = do { res    <- initTcRnIf 'd' hsc_env ds_gbl ds_lcl                               (tryM thing_inside)@@ -253,7 +259,7 @@        }  -- | Run a 'DsM' action in the context of an existing 'ModGuts'-initDsWithModGuts :: HscEnv -> ModGuts -> DsM a -> IO (Messages DecoratedSDoc, Maybe a)+initDsWithModGuts :: HscEnv -> ModGuts -> DsM a -> IO (Messages DsMessage, Maybe a) initDsWithModGuts hsc_env (ModGuts { mg_module = this_mod, mg_binds = binds                                    , mg_tcs = tycons, mg_fam_insts = fam_insts                                    , mg_patsyns = patsyns, mg_rdr_env = rdr_env@@ -261,6 +267,7 @@                                    , mg_complete_matches = local_complete_matches                           }) thing_inside   = do { cc_st_var   <- newIORef newCostCentreState+       ; next_wrapper_num <- newIORef emptyModuleEnv        ; msg_var <- newIORef emptyMessages        ; eps <- liftIO $ hscEPS hsc_env        ; let unit_env = hsc_unit_env hsc_env@@ -275,7 +282,7 @@               envs  = mkDsEnvs unit_env this_mod rdr_env type_env                               fam_inst_env msg_var cc_st_var-                              complete_matches+                              next_wrapper_num complete_matches        ; runDs hsc_env envs thing_inside        } @@ -313,12 +320,19 @@            Nothing  -> pprPanic "initTcDsForSolver" (vcat $ pprMsgEnvelopeBagWithLoc (getErrorMessages msgs)) }  mkDsEnvs :: UnitEnv -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv-         -> IORef (Messages DecoratedSDoc) -> IORef CostCentreState -> CompleteMatches+         -> IORef (Messages DsMessage) -> IORef CostCentreState+         -> IORef (ModuleEnv Int) -> CompleteMatches          -> (DsGblEnv, DsLclEnv) mkDsEnvs unit_env mod rdr_env type_env fam_inst_env msg_var cc_st_var-         complete_matches-  = let if_genv = IfGblEnv { if_doc       = text "mkDsEnvs",-                             if_rec_types = Just (mod, return type_env) }+         next_wrapper_num complete_matches+  = let if_genv = IfGblEnv { if_doc       = text "mkDsEnvs"+  -- Failing tests here are `ghci` and `T11985` if you get this wrong.+  -- this is very very "at a distance" because the reason for this check is that the type_env in interactive+  -- mode is the smushed together of all the interactive modules.+  -- See Note [Why is KnotVars not a ModuleEnv]+                             , if_rec_types = KnotVars [mod] (\that_mod -> if that_mod == mod || isInteractiveModule mod+                                                          then Just (return type_env)+                                                          else Nothing) }         if_lenv = mkIfLclEnv mod (text "GHC error in desugarer lookup in" <+> ppr mod)                              NotBoot         real_span = realSrcLocSpan (mkRealSrcLoc (moduleNameFS (moduleName mod)) 1 1)@@ -330,6 +344,7 @@                            , ds_msgs    = msg_var                            , ds_complete_matches = complete_matches                            , ds_cc_st   = cc_st_var+                           , ds_next_wrapper_num = next_wrapper_num                            }         lcl_env = DsLclEnv { dsl_meta    = emptyNameEnv                            , dsl_loc     = real_span@@ -350,49 +365,11 @@ functions are defined with it.  The difference in name-strings makes it easier to read debugging output. -Note [Levity polymorphism checking]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-According to the "Levity Polymorphism" paper (PLDI '17), levity-polymorphism is forbidden in precisely two places: in the type of a bound-term-level argument and in the type of an argument to a function. The paper-explains it more fully, but briefly: expressions in these contexts need to be-stored in registers, and it's hard (read, impossible) to store something-that's levity polymorphic.--We cannot check for bad levity polymorphism conveniently in the type checker,-because we can't tell, a priori, which levity metavariables will be solved.-At one point, I (Richard) thought we could check in the zonker, but it's hard-to know where precisely are the abstracted variables and the arguments. So-we check in the desugarer, the only place where we can see the Core code and-still report respectable syntax to the user. This covers the vast majority-of cases; see calls to GHC.HsToCore.Monad.dsNoLevPoly and friends.--Levity polymorphism is also prohibited in the types of binders, and the-desugarer checks for this in GHC-generated Ids. (The zonker handles-the user-writted ids in zonkIdBndr.) This is done in newSysLocalDsNoLP.-The newSysLocalDs variant is used in the vast majority of cases where-the binder is obviously not levity polymorphic, omitting the check.-It would be nice to ASSERT that there is no levity polymorphism here,-but we can't, because of the fixM in GHC.HsToCore.Arrows. It's all OK, though:-Core Lint will catch an error here.--However, the desugarer is the wrong place for certain checks. In particular,-the desugarer can't report a sensible error message if an HsWrapper is malformed.-After all, GHC itself produced the HsWrapper. So we store some message text-in the appropriate HsWrappers (e.g. WpFun) that we can print out in the-desugarer.--There are a few more checks in places where Core is generated outside the-desugarer. For example, in datatype and class declarations, where levity-polymorphism is checked for during validity checking. It would be nice to-have one central place for all this, but that doesn't seem possible while-still reporting nice error messages.- -}  -- Make a new Id with the same print name, but different type, and new unique newUniqueId :: Id -> Mult -> Type -> DsM Id-newUniqueId id = mk_local (occNameFS (nameOccName (idName id)))+newUniqueId id = mkSysLocalOrCoVarM (occNameFS (nameOccName (idName id)))  duplicateLocalDs :: Id -> DsM Id duplicateLocalDs old_local@@ -403,27 +380,13 @@ newPredVarDs  = mkSysLocalOrCoVarM (fsLit "ds") Many  -- like newSysLocalDs, but we allow covars -newSysLocalDsNoLP, newSysLocalDs, newFailLocalDs :: Mult -> Type -> DsM Id-newSysLocalDsNoLP  = mk_local (fsLit "ds")---- this variant should be used when the caller can be sure that the variable type--- is not levity-polymorphic. It is necessary when the type is knot-tied because--- of the fixM used in GHC.HsToCore.Arrows. See Note [Levity polymorphism checking]+newSysLocalDs, newFailLocalDs :: Mult -> Type -> DsM Id newSysLocalDs = mkSysLocalM (fsLit "ds") newFailLocalDs = mkSysLocalM (fsLit "fail")-  -- the fail variable is used only in a situation where we can tell that-  -- levity-polymorphism is impossible. -newSysLocalsDsNoLP, newSysLocalsDs :: [Scaled Type] -> DsM [Id]-newSysLocalsDsNoLP = mapM (\(Scaled w t) -> newSysLocalDsNoLP w t)+newSysLocalsDs :: [Scaled Type] -> DsM [Id] newSysLocalsDs = mapM (\(Scaled w t) -> newSysLocalDs w t) -mk_local :: FastString -> Mult -> Type -> DsM Id-mk_local fs w ty = do { dsNoLevPoly ty (text "When trying to create a variable of type:" <+>-                                        ppr ty)  -- could improve the msg with another-                                                 -- parameter indicating context-                      ; mkSysLocalOrCoVarM fs w ty }- {- We can also reach out and either set/grab location information from the @SrcSpan@ being carried around.@@ -443,7 +406,7 @@  getSrcSpanDs :: DsM SrcSpan getSrcSpanDs = do { env <- getLclEnv-                  ; return (RealSrcSpan (dsl_loc env) Nothing) }+                  ; return (RealSrcSpan (dsl_loc env) Strict.Nothing) }  putSrcSpanDs :: SrcSpan -> DsM a -> DsM a putSrcSpanDs (UnhelpfulSpan {}) thing_inside@@ -454,74 +417,32 @@ putSrcSpanDsA :: SrcSpanAnn' ann -> DsM a -> DsM a putSrcSpanDsA loc = putSrcSpanDs (locA loc) --- | Emit a warning for the current source location--- NB: Warns whether or not -Wxyz is set-warnDs :: WarnReason -> SDoc -> DsM ()-warnDs reason warn+-- | Emit a diagnostic for the current source location. In case the diagnostic is a warning,+-- the latter will be ignored and discarded if the relevant 'WarningFlag' is not set in the DynFlags.+-- See Note [Discarding Messages] in 'GHC.Types.Error'.+diagnosticDs :: DsMessage -> DsM ()+diagnosticDs dsMessage   = do { env <- getGblEnv        ; loc <- getSrcSpanDs-       ; let msg = makeIntoWarning reason $-                   mkWarnMsg loc (ds_unqual env) warn+       ; !diag_opts <- initDiagOpts <$> getDynFlags+       ; let msg = mkMsgEnvelope diag_opts loc (ds_unqual env) dsMessage        ; updMutVar (ds_msgs env) (\ msgs -> msg `addMessage` msgs) } --- | Emit a warning only if the correct WarnReason is set in the DynFlags-warnIfSetDs :: WarningFlag -> SDoc -> DsM ()-warnIfSetDs flag warn-  = whenWOptM flag $-    warnDs (Reason flag) warn--errDs :: SDoc -> DsM ()-errDs err-  = do  { env <- getGblEnv-        ; loc <- getSrcSpanDs-        ; let msg = mkMsgEnvelope loc (ds_unqual env) err-        ; updMutVar (ds_msgs env) (\ msgs -> msg `addMessage` msgs) }- -- | Issue an error, but return the expression for (), so that we can continue -- reporting errors.-errDsCoreExpr :: SDoc -> DsM CoreExpr-errDsCoreExpr err-  = do { errDs err+errDsCoreExpr :: DsMessage -> DsM CoreExpr+errDsCoreExpr msg+  = do { diagnosticDs msg        ; return unitExpr } -failWithDs :: SDoc -> DsM a-failWithDs err-  = do  { errDs err+failWithDs :: DsMessage -> DsM a+failWithDs msg+  = do  { diagnosticDs msg         ; failM }  failDs :: DsM a failDs = failM --- (askNoErrsDs m) runs m--- If m fails,---    then (askNoErrsDs m) fails--- If m succeeds with result r,---    then (askNoErrsDs m) succeeds with result (r, b),---         where b is True iff m generated no errors--- Regardless of success or failure,---   propagate any errors/warnings generated by m------ c.f. GHC.Tc.Utils.Monad.askNoErrs-askNoErrsDs :: DsM a -> DsM (a, Bool)-askNoErrsDs thing_inside- = do { errs_var <- newMutVar emptyMessages-      ; env <- getGblEnv-      ; mb_res <- tryM $  -- Be careful to catch exceptions-                          -- so that we propagate errors correctly-                          -- (#13642)-                  setGblEnv (env { ds_msgs = errs_var }) $-                  thing_inside--      -- Propagate errors-      ; msgs <- readMutVar errs_var-      ; updMutVar (ds_msgs env) (unionMessages msgs)--      -- And return-      ; case mb_res of-           Left _    -> failM-           Right res -> do { let errs_found = errorsFound msgs-                           ; return (res, not errs_found) } }- mkPrintUnqualifiedDs :: DsM PrintUnqualified mkPrintUnqualifiedDs = ds_unqual <$> getGblEnv @@ -586,33 +507,6 @@         ; writeTcRef (ds_msgs env) old_msgs          ; return result }---- | Fail with an error message if the type is levity polymorphic.-dsNoLevPoly :: Type -> SDoc -> DsM ()--- See Note [Levity polymorphism checking]-dsNoLevPoly ty doc = checkForLevPolyX failWithDs doc ty---- | Check an expression for levity polymorphism, failing if it is--- levity polymorphic.-dsNoLevPolyExpr :: CoreExpr -> SDoc -> DsM ()--- See Note [Levity polymorphism checking]-dsNoLevPolyExpr e doc-  | isExprLevPoly e = errDs (formatLevPolyErr (exprType e) $$ doc)-  | otherwise       = return ()---- | Runs the thing_inside. If there are no errors, then returns the expr--- given. Otherwise, returns unitExpr. This is useful for doing a bunch--- of levity polymorphism checks and then avoiding making a core App.--- (If we make a core App on a levity polymorphic argument, detecting how--- to handle the let/app invariant might call isUnliftedType, which panics--- on a levity polymorphic type.)--- See #12709 for an example of why this machinery is necessary.-dsWhenNoErrs :: DsM a -> (a -> CoreExpr) -> DsM CoreExpr-dsWhenNoErrs thing_inside mk_expr-  = do { (result, no_errs) <- askNoErrsDs thing_inside-       ; return $ if no_errs-                  then mk_expr result-                  else unitExpr }  -- | Inject a trace message into the compiled program. Whereas -- pprTrace prints out information *while compiling*, pprRuntimeTrace
GHC/HsToCore/Pmc.hs view
@@ -1,8 +1,9 @@-{-# LANGUAGE CPP               #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs             #-}-{-# LANGUAGE LambdaCase        #-} +{-# LANGUAGE FlexibleInstances  #-}+{-# LANGUAGE GADTs              #-}+{-# LANGUAGE LambdaCase         #-}+{-# LANGUAGE StandaloneDeriving #-}+ -- | This module coverage checks pattern matches. It finds -- --     * Uncovered patterns, certifying non-exhaustivity@@ -41,20 +42,17 @@         addTyCs, addCoreScrutTmCs, addHsScrutTmCs     ) where -#include "HsVersions.h"- import GHC.Prelude +import GHC.HsToCore.Errors.Types import GHC.HsToCore.Pmc.Types import GHC.HsToCore.Pmc.Utils import GHC.HsToCore.Pmc.Desugar import GHC.HsToCore.Pmc.Check import GHC.HsToCore.Pmc.Solver-import GHC.HsToCore.Pmc.Ppr import GHC.Types.Basic (Origin(..)) import GHC.Core (CoreExpr) import GHC.Driver.Session-import GHC.Driver.Env import GHC.Hs import GHC.Types.Id import GHC.Types.SrcLoc@@ -62,12 +60,12 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Types.Var (EvVar)-import GHC.Tc.Types import GHC.Tc.Utils.TcType (evVarPred)+import GHC.Tc.Utils.Monad (updTopFlags) import {-# SOURCE #-} GHC.HsToCore.Expr (dsLExpr) import GHC.HsToCore.Monad import GHC.Data.Bag-import GHC.Data.IOEnv (updEnv, unsafeInterleaveM)+import GHC.Data.IOEnv (unsafeInterleaveM) import GHC.Data.OrdList import GHC.Utils.Monad (mapMaybeM) @@ -97,10 +95,7 @@ -- is one concern, but also a lack of properly set up long-distance information -- might trigger warnings that we normally wouldn't emit. noCheckDs :: DsM a -> DsM a-noCheckDs k = do-  dflags <- getDynFlags-  let dflags' = foldl' wopt_unset dflags allPmCheckWarnings-  updEnv (\env -> env{env_top = (env_top env) {hsc_dflags = dflags'} }) k+noCheckDs = updTopFlags (\dflags -> foldl' wopt_unset dflags allPmCheckWarnings)  -- | Check a pattern binding (let, where) for exhaustiveness. pmcPatBind :: DsMatchContext -> Id -> Pat GhcTc -> DsM ()@@ -111,7 +106,7 @@   tracePm "pmcPatBind {" (vcat [ppr ctxt, ppr var, ppr p, ppr pat_bind, ppr missing])   result <- unCA (checkPatBind pat_bind) missing   tracePm "}: " (ppr (cr_uncov result))-  formatReportWarnings cirbsPatBind ctxt [var] result+  formatReportWarnings ReportPatBind ctxt [var] result pmcPatBind _ _ _ = pure ()  -- | Exhaustive for guard matches, is used for guards in pattern bindings and@@ -122,7 +117,7 @@   -> DsM (NonEmpty Nablas)        -- ^ Covered 'Nablas' for each RHS, for long                                   --   distance info pmcGRHSs hs_ctxt guards@(GRHSs _ grhss _) = do-  let combined_loc = foldl1 combineSrcSpans (map getLoc grhss)+  let combined_loc = foldl1 combineSrcSpans (map getLocA grhss)       ctxt = DsMatchContext hs_ctxt combined_loc   !missing <- getLdiNablas   matches  <- noCheckDs $ desugarGRHSs combined_loc empty guards@@ -132,7 +127,7 @@                                 (pprGRHSs hs_ctxt guards $$ ppr missing))   result <- unCA (checkGRHSs matches) missing   tracePm "}: " (ppr (cr_uncov result))-  formatReportWarnings cirbsGRHSs ctxt [] result+  formatReportWarnings ReportGRHSs ctxt [] result   return (ldiGRHSs (cr_ret result))  -- | Check a list of syntactic 'Match'es (part of case, functions, etc.), each@@ -156,7 +151,7 @@   -> [LMatch GhcTc (LHsExpr GhcTc)]  -- ^ List of matches   -> DsM [(Nablas, NonEmpty Nablas)] -- ^ One covered 'Nablas' per Match and                                      --   GRHS, for long distance info.-pmcMatches ctxt vars matches = do+pmcMatches ctxt vars matches = {-# SCC "pmcMatches" #-} do   -- We have to force @missing@ before printing out the trace message,   -- otherwise we get interleaved output from the solver. This function   -- should be strict in @missing@ anyway!@@ -172,13 +167,15 @@       empty_case <- noCheckDs $ desugarEmptyCase var       result <- unCA (checkEmptyCase empty_case) missing       tracePm "}: " (ppr (cr_uncov result))-      formatReportWarnings cirbsEmptyCase ctxt vars result+      formatReportWarnings ReportEmptyCase ctxt vars result       return []     Just matches -> do-      matches <- noCheckDs $ desugarMatches vars matches-      result <- unCA (checkMatchGroup matches) missing+      matches <- {-# SCC "desugarMatches" #-}+                 noCheckDs $ desugarMatches vars matches+      result  <- {-# SCC "checkMatchGroup" #-}+                 unCA (checkMatchGroup matches) missing       tracePm "}: " (ppr (cr_uncov result))-      formatReportWarnings cirbsMatchGroup ctxt vars result+      {-# SCC "formatReportWarnings" #-} formatReportWarnings ReportMatchGroup ctxt vars result       return (NE.toList (ldiMatchGroup (cr_ret result)))  {- Note [pmcPatBind only checks PatBindRhs]@@ -321,25 +318,45 @@ -- * Formatting and reporting warnings -- --- | Given a function that collects 'CIRB's, this function will emit warnings+-- | A datatype to accomodate the different call sites of+-- 'formatReportWarnings'. Used for extracting 'CIRB's from a concrete 'ann'+-- through 'collectInMode'. Since this is only possible for a couple of+-- well-known 'ann's, this is a GADT.+data FormatReportWarningsMode ann where+  ReportPatBind :: FormatReportWarningsMode (PmPatBind Post)+  ReportGRHSs   :: FormatReportWarningsMode (PmGRHSs Post)+  ReportMatchGroup:: FormatReportWarningsMode (PmMatchGroup Post)+  ReportEmptyCase:: FormatReportWarningsMode PmEmptyCase++deriving instance Eq (FormatReportWarningsMode ann)++-- | A function collecting 'CIRB's for each of the different+-- 'FormatReportWarningsMode's.+collectInMode :: FormatReportWarningsMode ann -> ann -> DsM CIRB+collectInMode ReportPatBind    = cirbsPatBind+collectInMode ReportGRHSs      = cirbsGRHSs+collectInMode ReportMatchGroup = cirbsMatchGroup+collectInMode ReportEmptyCase  = cirbsEmptyCase++-- | Given a 'FormatReportWarningsMode', this function will emit warnings -- for a 'CheckResult'.-formatReportWarnings :: (ann -> DsM CIRB) -> DsMatchContext -> [Id] -> CheckResult ann -> DsM ()-formatReportWarnings collect ctx vars cr@CheckResult { cr_ret = ann } = do-  cov_info <- collect ann+formatReportWarnings :: FormatReportWarningsMode ann -> DsMatchContext -> [Id] -> CheckResult ann -> DsM ()+formatReportWarnings report_mode ctx vars cr@CheckResult { cr_ret = ann } = do+  cov_info <- collectInMode report_mode ann   dflags <- getDynFlags-  reportWarnings dflags ctx vars cr{cr_ret=cov_info}+  reportWarnings dflags report_mode ctx vars cr{cr_ret=cov_info}  -- | Issue all the warnings -- (redundancy, inaccessibility, exhaustiveness, redundant bangs).-reportWarnings :: DynFlags -> DsMatchContext -> [Id] -> CheckResult CIRB -> DsM ()-reportWarnings dflags ctx@(DsMatchContext kind loc) vars+reportWarnings :: DynFlags -> FormatReportWarningsMode ann -> DsMatchContext -> [Id] -> CheckResult CIRB -> DsM ()+reportWarnings dflags report_mode (DsMatchContext kind loc) vars   CheckResult { cr_ret    = CIRB { cirb_inacc = inaccessible_rhss                                  , cirb_red   = redundant_rhss                                  , cirb_bangs = redundant_bangs }               , cr_uncov  = uncovered               , cr_approx = precision }   = when (flag_i || flag_u || flag_b) $ do-      unc_examples <- getNFirstUncovered vars (maxPatterns + 1) uncovered+      unc_examples <- getNFirstUncovered gen_mode vars (maxPatterns + 1) uncovered       let exists_r = flag_i && notNull redundant_rhss           exists_i = flag_i && notNull inaccessible_rhss           exists_u = flag_u && notNull unc_examples@@ -347,85 +364,39 @@           approx   = precision == Approximate        when (approx && (exists_u || exists_i)) $-        putSrcSpanDs loc (warnDs NoReason approx_msg)+        putSrcSpanDs loc (diagnosticDs (DsMaxPmCheckModelsReached (maxPmCheckModels dflags)))        when exists_b $ forM_ redundant_bangs $ \(SrcInfo (L l q)) ->-        putSrcSpanDs l (warnDs (Reason Opt_WarnRedundantBangPatterns)-                               (pprEqn q "has redundant bang"))+        putSrcSpanDs l (diagnosticDs (DsRedundantBangPatterns kind q))        when exists_r $ forM_ redundant_rhss $ \(SrcInfo (L l q)) ->-        putSrcSpanDs l (warnDs (Reason Opt_WarnOverlappingPatterns)-                               (pprEqn q "is redundant"))+        putSrcSpanDs l (diagnosticDs (DsOverlappingPatterns kind q))       when exists_i $ forM_ inaccessible_rhss $ \(SrcInfo (L l q)) ->-        putSrcSpanDs l (warnDs (Reason Opt_WarnOverlappingPatterns)-                               (pprEqn q "has inaccessible right hand side"))+        putSrcSpanDs l (diagnosticDs (DsInaccessibleRhs kind q)) -      when exists_u $ putSrcSpanDs loc $ warnDs flag_u_reason $-        pprEqns vars unc_examples+      when exists_u $+        putSrcSpanDs loc (diagnosticDs (DsNonExhaustivePatterns kind check_type maxPatterns vars unc_examples))   where     flag_i = overlapping dflags kind     flag_u = exhaustive dflags kind     flag_b = redundantBang dflags-    flag_u_reason = maybe NoReason Reason (exhaustiveWarningFlag kind)+    check_type = ExhaustivityCheckType (exhaustiveWarningFlag kind)+    gen_mode = case report_mode of -- See Note [Case split inhabiting patterns]+      ReportEmptyCase -> CaseSplitTopLevel+      _               -> MinimalCover      maxPatterns = maxUncoveredPatterns dflags -    -- Print a single clause (for redundant/with-inaccessible-rhs)-    pprEqn q txt = pprContext True ctx (text txt) $ \f ->-      f (q <+> matchSeparator kind <+> text "...")--    -- Print several clauses (for uncovered clauses)-    pprEqns vars nablas = pprContext False ctx (text "are non-exhaustive") $ \_ ->-      case vars of -- See #11245-           [] -> text "Guards do not cover entire pattern space"-           _  -> let us = map (\nabla -> pprUncovered nabla vars) nablas-                     pp_tys = pprQuotedList $ map idType vars-                 in  hang-                       (text "Patterns of type" <+> pp_tys <+> text "not matched:")-                       4-                       (vcat (take maxPatterns us) $$ dots maxPatterns us)--    approx_msg = vcat-      [ hang-          (text "Pattern match checker ran into -fmax-pmcheck-models="-            <> int (maxPmCheckModels dflags)-            <> text " limit, so")-          2-          (  bullet <+> text "Redundant clauses might not be reported at all"-          $$ bullet <+> text "Redundant clauses might be reported as inaccessible"-          $$ bullet <+> text "Patterns reported as unmatched might actually be matched")-      , text "Increase the limit or resolve the warnings to suppress this message." ]--getNFirstUncovered :: [Id] -> Int -> Nablas -> DsM [Nabla]-getNFirstUncovered vars n (MkNablas nablas) = go n (bagToList nablas)+getNFirstUncovered :: GenerateInhabitingPatternsMode -> [Id] -> Int -> Nablas -> DsM [Nabla]+getNFirstUncovered mode vars n (MkNablas nablas) = go n (bagToList nablas)   where     go 0 _              = pure []     go _ []             = pure []     go n (nabla:nablas) = do-      front <- generateInhabitingPatterns vars n nabla+      front <- generateInhabitingPatterns mode vars n nabla       back <- go (n - length front) nablas       pure (front ++ back) -dots :: Int -> [a] -> SDoc-dots maxPatterns qs-    | qs `lengthExceeds` maxPatterns = text "..."-    | otherwise                      = empty--pprContext :: Bool -> DsMatchContext -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc-pprContext singular (DsMatchContext kind _loc) msg rest_of_msg_fun-  = vcat [text txt <+> msg,-          sep [ text "In" <+> ppr_match <> char ':'-              , nest 4 (rest_of_msg_fun pref)]]-  where-    txt | singular  = "Pattern match"-        | otherwise = "Pattern match(es)"--    (ppr_match, pref)-        = case kind of-             FunRhs { mc_fun = L _ fun }-                  -> (pprMatchContext kind, \ pp -> ppr fun <+> pp)-             _    -> (pprMatchContext kind, \ pp -> pp)- -- -- * Adding external long-distance information --@@ -448,24 +419,25 @@               addPhiCtsNablas nablas (PhiTyCt . evVarPred <$> ev_vars))             m --- | Add equalities for the 'CoreExpr' scrutinee to the local 'DsM' environment--- when checking a case expression:+-- | Add equalities for the 'CoreExpr' scrutinees to the local 'DsM' environment,+-- e.g. when checking a case expression: --     case e of x { matches } -- When checking matches we record that (x ~ e) where x is the initial -- uncovered. All matches will have to satisfy this equality.-addCoreScrutTmCs :: Maybe CoreExpr -> [Id] -> DsM a -> DsM a-addCoreScrutTmCs Nothing    _   k = k-addCoreScrutTmCs (Just scr) [x] k =-  flip locallyExtendPmNablas k $ \nablas ->+-- This is also used for the Arrows \cases command, where these equalities have+-- to be added for multiple scrutinees rather than just one.+addCoreScrutTmCs :: [CoreExpr] -> [Id] -> DsM a -> DsM a+addCoreScrutTmCs []         _      k = k+addCoreScrutTmCs (scr:scrs) (x:xs) k =+  flip locallyExtendPmNablas (addCoreScrutTmCs scrs xs k) $ \nablas ->     addPhiCtsNablas nablas (unitBag (PhiCoreCt x scr))-addCoreScrutTmCs _   _   _ = panic "addCoreScrutTmCs: scrutinee, but more than one match id"+addCoreScrutTmCs _   _   _ = panic "addCoreScrutTmCs: numbers of scrutinees and match ids differ" --- | 'addCoreScrutTmCs', but desugars the 'LHsExpr' first.-addHsScrutTmCs :: Maybe (LHsExpr GhcTc) -> [Id] -> DsM a -> DsM a-addHsScrutTmCs Nothing    _    k = k-addHsScrutTmCs (Just scr) vars k = do-  scr_e <- dsLExpr scr-  addCoreScrutTmCs (Just scr_e) vars k+-- | 'addCoreScrutTmCs', but desugars the 'LHsExpr's first.+addHsScrutTmCs :: [LHsExpr GhcTc] -> [Id] -> DsM a -> DsM a+addHsScrutTmCs scrs vars k = do+  scr_es <- traverse dsLExpr scrs+  addCoreScrutTmCs scr_es vars k  {- Note [Long-distance information] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
GHC/HsToCore/Pmc/Check.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP               #-}+ {-# LANGUAGE DeriveFunctor     #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs             #-}@@ -21,8 +21,6 @@         CheckAction(..),         checkMatchGroup, checkGRHSs, checkPatBind, checkEmptyCase     ) where--#include "HsVersions.h"  import GHC.Prelude
GHC/HsToCore/Pmc/Desugar.hs view
@@ -1,7 +1,8 @@-{-# LANGUAGE CPP               #-}+ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs             #-} {-# LANGUAGE LambdaCase        #-}+{-# LANGUAGE DisambiguateRecordFields #-}  -- | Desugaring step of the -- [Lower Your Guards paper](https://dl.acm.org/doi/abs/10.1145/3408989).@@ -13,8 +14,6 @@       desugarPatBind, desugarGRHSs, desugarMatches, desugarEmptyCase     ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.HsToCore.Pmc.Types@@ -33,7 +32,6 @@ import GHC.Types.SrcLoc import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Misc import GHC.Core.DataCon import GHC.Types.Var (EvVar) import GHC.Core.Coercion@@ -76,7 +74,7 @@ -- where @b@ and @c@ are freshly allocated in @mkListGrds@ and @a@ is the match -- variable. mkListGrds :: Id -> [(Id, [PmGrd])] -> DsM [PmGrd]--- See Note [Order of guards matter] for why we need to intertwine guards+-- See Note [Order of guards matters] for why we need to intertwine guards -- on list elements. mkListGrds a []                  = pure [vanillaConGrd a nilDataCon []] mkListGrds a ((x, head_grds):xs) = do@@ -111,7 +109,7 @@ desugarPat x pat = case pat of   WildPat  _ty -> pure []   VarPat _ y   -> pure (mkPmLetVar (unLoc y) x)-  ParPat _ p   -> desugarLPat x p+  ParPat _ _ p _ -> desugarLPat x p   LazyPat _ _  -> pure [] -- like a wildcard   BangPat _ p@(L l p') ->     -- Add the bang in front of the list, because it will happen before any@@ -125,17 +123,38 @@    SigPat _ p _ty -> desugarLPat x p -  -- See Note [Desugar CoPats]-  -- Generally the translation is-  -- pat |> co   ===>   let y = x |> co, pat <- y  where y is a match var of pat-  XPat (CoPat wrapper p _ty)-    | isIdHsWrapper wrapper                   -> desugarPat x p-    | WpCast co <-  wrapper, isReflexiveCo co -> desugarPat x p-    | otherwise -> do-        (y, grds) <- desugarPatV p-        wrap_rhs_y <- dsHsWrapper wrapper-        pure (PmLet y (wrap_rhs_y (Var x)) : grds)+  XPat ext -> case ext of +    ExpansionPat orig expansion -> do+      dflags <- getDynFlags+      case orig of+        -- We add special logic for overloaded list patterns. When:+        --   - a ViewPat is the expansion of a ListPat,+        --   - RebindableSyntax is off,+        --   - the type of the pattern is the built-in list type,+        -- then we assume that the view function, 'toList', is the identity.+        -- This improves pattern-match overload checks, as this will allow+        -- the pattern match checker to directly inspect the inner pattern.+        -- See #14547, and Note [Desugaring overloaded list patterns] (Wrinkle).+        ListPat {}+          | ViewPat arg_ty _lexpr pat <- expansion+          , not (xopt LangExt.RebindableSyntax dflags)+          , Just _ <- splitListTyConApp_maybe arg_ty+          -> desugarLPat x pat++        _ -> desugarPat x expansion++    -- See Note [Desugar CoPats]+    -- Generally the translation is+    -- pat |> co   ===>   let y = x |> co, pat <- y  where y is a match var of pat+    CoPat wrapper p _ty+      | isIdHsWrapper wrapper                   -> desugarPat x p+      | WpCast co <-  wrapper, isReflexiveCo co -> desugarPat x p+      | otherwise -> do+          (y, grds) <- desugarPatV p+          wrap_rhs_y <- dsHsWrapper wrapper+          pure (PmLet y (wrap_rhs_y (Var x)) : grds)+   -- (n + k)  ===>   let b = x >= k, True <- b, let n = x-k   NPlusKPat _pat_ty (L _ n) k1 k2 ge minus -> do     b <- mkPmId boolTy@@ -152,37 +171,9 @@     pure $ PmLet y (App fun (Var x)) : grds    -- list-  ListPat (ListPatTc _elem_ty Nothing) ps ->+  ListPat _ ps ->     desugarListPat x ps -  -- overloaded list-  ListPat (ListPatTc elem_ty (Just (pat_ty, to_list))) pats -> do-    dflags <- getDynFlags-    case splitListTyConApp_maybe pat_ty of-      Just _e_ty-        | not (xopt LangExt.RebindableSyntax dflags)-        -- Just desugar it as a regular ListPat-        -> desugarListPat x pats-      _ -> do-        y <- mkPmId (mkListTy elem_ty)-        grds <- desugarListPat y pats-        rhs_y <- dsSyntaxExpr to_list [Var x]-        pure $ PmLet y rhs_y : grds--    -- (a) In the presence of RebindableSyntax, we don't know anything about-    --     `toList`, we should treat `ListPat` as any other view pattern.-    ---    -- (b) In the absence of RebindableSyntax,-    --     - If the pat_ty is `[a]`, then we treat the overloaded list pattern-    --       as ordinary list pattern. Although we can give an instance-    --       `IsList [Int]` (more specific than the default `IsList [a]`), in-    --       practice, we almost never do that. We assume the `to_list` is-    --       the `toList` from `instance IsList [a]`.-    ---    --     - Otherwise, we treat the `ListPat` as ordinary view pattern.-    ---    -- See #14547, especially comment#9 and comment#10.-   ConPat { pat_con     = L _ con          , pat_args    = ps          , pat_con_ext = ConPatTc@@ -203,7 +194,7 @@     dflags <- getDynFlags     let platform = targetPlatform dflags     pm_lit <- case olit of-      OverLit{ ol_val = val, ol_ext = OverLitTc rebindable _ }+      OverLit{ ol_val = val, ol_ext = OverLitTc { ol_rebindable = rebindable } }         | not rebindable         , Just expr <- shortCutLit platform val ty         -> coreExprAsPmLit <$> dsExpr expr@@ -290,7 +281,7 @@     -- LHsRecField     rec_field_ps fs = map (tagged_pat . unLoc) fs       where-        tagged_pat f = (lbl_to_index (getName (hsRecFieldId f)), hsRecFieldArg f)+        tagged_pat f = (lbl_to_index (getName (hsRecFieldId f)), hfbRHS f)         -- Unfortunately the label info is empty when the DataCon wasn't defined         -- with record field labels, hence we desugar to field index.         orig_lbls        = map flSelector $ conLikeFieldLabels con@@ -397,15 +388,17 @@       , GRHSs{grhssGRHSs = [L _ (GRHS _ _grds rhs)]} <- grhss = do           core_rhs <- dsLExpr rhs           return [PmLet x core_rhs]-    go (L _ AbsBinds{ abs_tvs = [], abs_ev_vars = []-                    , abs_exports=exports, abs_binds = binds }) = do+    go (L _ (XHsBindsLR (AbsBinds+                          { abs_tvs = [], abs_ev_vars = []+                          , abs_exports=exports, abs_binds = binds }))) = do       -- Typechecked HsLocalBinds are wrapped in AbsBinds, which carry       -- renamings. See Note [Long-distance information for HsLocalBinds]       -- for the details.-      let go_export :: ABExport GhcTc -> Maybe PmGrd+      let go_export :: ABExport -> Maybe PmGrd           go_export ABE{abe_poly = x, abe_mono = y, abe_wrap = wrap}             | isIdHsWrapper wrap-            = ASSERT2(idType x `eqType` idType y, ppr x $$ ppr (idType x) $$ ppr y $$ ppr (idType y))+            = assertPpr (idType x `eqType` idType y)+                        (ppr x $$ ppr (idType x) $$ ppr y $$ ppr (idType y)) $               Just $ PmLet x (Var y)             | otherwise             = Nothing
GHC/HsToCore/Pmc/Ppr.hs view
@@ -1,15 +1,13 @@-{-# LANGUAGE CPP #-} + {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}  -- | Provides factilities for pretty-printing 'Nabla's in a way appropriate for -- user facing pattern match warnings. module GHC.HsToCore.Pmc.Ppr (-        pprUncovered+      pprUncovered     ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Types.Basic@@ -21,13 +19,12 @@ import GHC.Builtin.Types import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import Control.Monad.Trans.RWS.CPS-import GHC.Utils.Misc import GHC.Data.Maybe import Data.List.NonEmpty (NonEmpty, nonEmpty, toList)  import GHC.HsToCore.Pmc.Types-import GHC.HsToCore.Pmc.Solver  -- | Pretty-print the guts of an uncovered value vector abstraction, i.e., its -- components and refutable shapes associated to any mentioned variables.@@ -203,8 +200,8 @@      go_con rev_pref (PmAltConLike (RealDataCon c)) es       | c == nilDataCon-      = ASSERT( null es ) Just (NilTerminated (reverse rev_pref))+      = assert (null es) $ Just (NilTerminated (reverse rev_pref))       | c == consDataCon-      = ASSERT( length es == 2 ) go_var (es !! 0 : rev_pref) (es !! 1)+      = assert (length es == 2) $ go_var (es !! 0 : rev_pref) (es !! 1)     go_con _ _ _       = Nothing
GHC/HsToCore/Pmc/Solver.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP                 #-}+ {-# LANGUAGE LambdaCase          #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns        #-}@@ -23,23 +23,20 @@ module GHC.HsToCore.Pmc.Solver (          Nabla, Nablas(..), initNablas,-        lookupRefuts, lookupSolution,          PhiCt(..), PhiCts,         addPhiCtNablas,         addPhiCtsNablas,          isInhabited,-        generateInhabitingPatterns+        generateInhabitingPatterns, GenerateInhabitingPatternsMode(..)      ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.HsToCore.Pmc.Types-import GHC.HsToCore.Pmc.Utils (tracePm, mkPmId)+import GHC.HsToCore.Pmc.Utils (tracePm, traceWhenFailPm, mkPmId)  import GHC.Driver.Session import GHC.Driver.Config@@ -47,7 +44,9 @@ import GHC.Utils.Misc import GHC.Utils.Monad (allM) import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Data.Bag+import GHC.Types.Basic (Levity(..)) import GHC.Types.CompleteMatch import GHC.Types.Unique.Set import GHC.Types.Unique.DSet@@ -72,6 +71,7 @@ import GHC.Core.PatSyn import GHC.Core.TyCon import GHC.Core.TyCon.RecWalk+import GHC.Builtin.Names import GHC.Builtin.Types import GHC.Builtin.Types.Prim (tYPETyCon) import GHC.Core.TyCo.Rep@@ -80,6 +80,7 @@ import GHC.Tc.Solver   (tcNormalise, tcCheckGivens, tcCheckWanteds) import GHC.Core.Unify    (tcMatchTy) import GHC.Core.Coercion+import GHC.Core.Reduction import GHC.HsToCore.Monad hiding (foldlM) import GHC.Tc.Instance.Family import GHC.Core.FamInstEnv@@ -96,6 +97,9 @@ import qualified Data.List.NonEmpty as NE import Data.Ord      (comparing) +import GHC.Utils.Trace+_ = pprTrace -- to silence unused import warnings+ -- -- * Main exports --@@ -143,7 +147,7 @@ -- Ex.: @vanillaCompleteMatchTC 'Maybe' ==> Just ("Maybe", {'Just','Nothing'})@ vanillaCompleteMatchTC :: TyCon -> Maybe CompleteMatch vanillaCompleteMatchTC tc =-  let -- | TYPE acts like an empty data type on the term-level (#14086), but+  let -- TYPE acts like an empty data type on the term-level (#14086), but       -- it is a PrimTyCon, so tyConDataCons_maybe returns Nothing. Hence a       -- special case.       mb_dcs | tc == tYPETyCon = Just []@@ -169,7 +173,7 @@ addTyConMatches :: TyCon -> ResidualCompleteMatches -> DsM ResidualCompleteMatches addTyConMatches tc rcm = add_tc_match <$> addCompleteMatches rcm   where-    -- | Add the vanilla COMPLETE set from the data defn, if any. But only if+    -- Add the vanilla COMPLETE set from the data defn, if any. But only if     -- it's not already present.     add_tc_match rcm       = rcm{rcm_vanilla = rcm_vanilla rcm <|> vanillaCompleteMatchTC tc}@@ -326,23 +330,23 @@ -- NB: Normalisation can potentially change kinds, if the head of the type -- is a type family with a variable result kind. I (Richard E) can't think -- of a way to cause trouble here, though.-pmTopNormaliseType (TySt _ inert) typ-  = do env <- dsGetFamInstEnvs-       tracePm "normalise" (ppr typ)-       -- Before proceeding, we chuck typ into the constraint solver, in case-       -- solving for given equalities may reduce typ some. See-       -- "Wrinkle: local equalities" in Note [Type normalisation].-       typ' <- initTcDsForSolver $ tcNormalise inert typ-       -- Now we look with topNormaliseTypeX through type and data family-       -- applications and newtypes, which tcNormalise does not do.-       -- See also 'TopNormaliseTypeResult'.-       pure $ case topNormaliseTypeX (stepper env) comb typ' of-         Nothing                -> NormalisedByConstraints typ'-         Just ((ty_f,tm_f), ty) -> HadRedexes src_ty newtype_dcs core_ty-           where-             src_ty = eq_src_ty ty (typ' : ty_f [ty])-             newtype_dcs = tm_f []-             core_ty = ty+pmTopNormaliseType (TySt _ inert) typ = {-# SCC "pmTopNormaliseType" #-} do+  env <- dsGetFamInstEnvs+  tracePm "normalise" (ppr typ)+  -- Before proceeding, we chuck typ into the constraint solver, in case+  -- solving for given equalities may reduce typ some. See+  -- "Wrinkle: local equalities" in Note [Type normalisation].+  typ' <- initTcDsForSolver $ tcNormalise inert typ+  -- Now we look with topNormaliseTypeX through type and data family+  -- applications and newtypes, which tcNormalise does not do.+  -- See also 'TopNormaliseTypeResult'.+  pure $ case topNormaliseTypeX (stepper env) comb typ' of+    Nothing                -> NormalisedByConstraints typ'+    Just ((ty_f,tm_f), ty) -> HadRedexes src_ty newtype_dcs core_ty+      where+        src_ty = eq_src_ty ty (typ' : ty_f [ty])+        newtype_dcs = tm_f []+        core_ty = ty   where     -- Find the first type in the sequence of rewrites that is a data type,     -- newtype, or a data family application (not the representation tycon!).@@ -378,8 +382,9 @@     tyFamStepper :: FamInstEnvs -> NormaliseStepper ([Type] -> [Type], a -> a)     tyFamStepper env rec_nts tc tys  -- Try to step a type/data family       = case topReduceTyFamApp_maybe env tc tys of-          Just (_, rhs, _) -> NS_Step rec_nts rhs ((rhs:), id)-          _                -> NS_Done+          Just (HetReduction (Reduction _ rhs) _)+            -> NS_Step rec_nts rhs ((rhs:), id)+          _ -> NS_Done  -- | Returns 'True' if the argument 'Type' is a fully saturated application of -- a closed type constructor.@@ -397,7 +402,7 @@   = case splitTyConApp_maybe ty of       Just (tc, ty_args)              | is_algebraic_like tc && not (isFamilyTyCon tc)-             -> ASSERT2( ty_args `lengthIs` tyConArity tc, ppr ty ) True+             -> assertPpr (ty_args `lengthIs` tyConArity tc) (ppr ty) True       _other -> False   where     -- This returns True for TyCons which /act like/ algebraic types.@@ -511,61 +516,9 @@ In order to avoid this pitfall, we need to normalise the type passed to pmTopNormaliseType, using the constraint solver to solve for any local equalities (such as i ~ Int) that may be in scope.--} --------------------------- * Looking up VarInfo--emptyRCM :: ResidualCompleteMatches-emptyRCM = RCM Nothing Nothing--emptyVarInfo :: Id -> VarInfo-emptyVarInfo x-  = VI-  { vi_id = x-  , vi_pos = []-  , vi_neg = emptyPmAltConSet-  -- Why not set IsNotBot for unlifted type here?-  -- Because we'd have to trigger an inhabitation test, which we can't.-  -- See case (4) in Note [Strict fields and variables of unlifted type]-  -- in GHC.HsToCore.Pmc.Solver-  , vi_bot = MaybeBot-  , vi_rcm = emptyRCM-  }--lookupVarInfo :: TmState -> Id -> VarInfo--- (lookupVarInfo tms x) tells what we know about 'x'-lookupVarInfo (TmSt env _ _) x = fromMaybe (emptyVarInfo x) (lookupUSDFM env x)---- | Like @lookupVarInfo ts x@, but @lookupVarInfo ts x = (y, vi)@ also looks--- through newtype constructors. We have @x ~ N1 (... (Nk y))@ such that the--- returned @y@ doesn't have a positive newtype constructor constraint--- associated with it (yet). The 'VarInfo' returned is that of @y@'s--- representative.------ Careful, this means that @idType x@ might be different to @idType y@, even--- modulo type normalisation!------ See also Note [Coverage checking Newtype matches].-lookupVarInfoNT :: TmState -> Id -> (Id, VarInfo)-lookupVarInfoNT ts x = case lookupVarInfo ts x of-  VI{ vi_pos = as_newtype -> Just y } -> lookupVarInfoNT ts y-  res                                 -> (x, res)-  where-    as_newtype = listToMaybe . mapMaybe go-    go PACA{paca_con = PmAltConLike (RealDataCon dc), paca_ids = [y]}-      | isNewDataCon dc = Just y-    go _                = Nothing--trvVarInfo :: Functor f => (VarInfo -> f (a, VarInfo)) -> Nabla -> Id -> f (a, Nabla)-trvVarInfo f nabla@MkNabla{ nabla_tm_st = ts@TmSt{ts_facts = env} } x-  = set_vi <$> f (lookupVarInfo ts x)-  where-    set_vi (a, vi') =-      (a, nabla{ nabla_tm_st = ts{ ts_facts = addToUSDFM env (vi_id vi') vi' } })--{- Note [Coverage checking Newtype matches]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Note [Coverage checking Newtype matches]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Newtypes have quite peculiar match semantics compared to ordinary DataCons. In a pattern-match, they behave like a irrefutable (lazy) match, but for inhabitation testing purposes (e.g. at construction sites), they behave rather like a DataCon@@ -592,28 +545,6 @@ where you can find the solution in a perhaps more digestible format. -} ---------------------------------------------------- * Exported utility functions querying 'Nabla'--lookupRefuts :: Nabla -> Id -> [PmAltCon]--- Unfortunately we need the extra bit of polymorphism and the unfortunate--- duplication of lookupVarInfo here.-lookupRefuts MkNabla{ nabla_tm_st = ts } x =-  pmAltConSetElems $ vi_neg $ lookupVarInfo ts x--isDataConSolution :: PmAltConApp -> Bool-isDataConSolution PACA{paca_con = PmAltConLike (RealDataCon _)} = True-isDataConSolution _                                             = False---- @lookupSolution nabla x@ picks a single solution ('vi_pos') of @x@ from--- possibly many, preferring 'RealDataCon' solutions whenever possible.-lookupSolution :: Nabla -> Id -> Maybe PmAltConApp-lookupSolution nabla x = case vi_pos (lookupVarInfo (nabla_tm_st nabla) x) of-  []                                         -> Nothing-  pos-    | Just sol <- find isDataConSolution pos -> Just sol-    | otherwise                              -> Just (head pos)- ------------------------- -- * Adding φ constraints --@@ -691,13 +622,16 @@  -- | Add some extra type constraints to the 'TyState'; return 'Nothing' if we -- find a contradiction (e.g. @Int ~ Bool@).+--+-- See Note [Pattern match warnings with insoluble Givens] in GHC.Tc.Solver. tyOracle :: TyState -> Bag PredType -> DsM (Maybe TyState) tyOracle ty_st@(TySt n inert) cts   | isEmptyBag cts   = pure (Just ty_st)   | otherwise-  = do { evs <- traverse nameTyCt cts-       ; tracePm "tyOracle" (ppr cts $$ ppr inert)+  = {-# SCC "tyOracle" #-}+    do { evs <- traverse nameTyCt cts+       ; tracePm "tyOracle" (ppr n $$ ppr cts $$ ppr inert)        ; mb_new_inert <- initTcDsForSolver $ tcCheckGivens inert evs          -- return the new inert set and increment the sequence number n        ; return (TySt (n+1) <$> mb_new_inert) }@@ -741,7 +675,7 @@ filterUnliftedFields :: PmAltCon -> [Id] -> [Id] filterUnliftedFields con args =   [ arg | (arg, bang) <- zipEqual "addPhiCt" args (pmAltConImplBangs con)-        , isBanged bang || isUnliftedType (idType arg) ]+        , isBanged bang || typeLevity_maybe (idType arg) == Just Unlifted ]  -- | Adds the constraint @x ~ ⊥@, e.g. that evaluation of a particular 'Id' @x@ -- surely diverges. Quite similar to 'addConCt', only that it only cares about@@ -752,11 +686,12 @@   case bot of     IsNotBot -> mzero      -- There was x ≁ ⊥. Contradiction!     IsBot    -> pure nabla -- There already is x ~ ⊥. Nothing left to do-    MaybeBot ->            -- We add x ~ ⊥+    MaybeBot               -- We add x ~ ⊥+      | Just Unlifted <- typeLevity_maybe (idType x)       -- Case (3) in Note [Strict fields and variables of unlifted type]-      if isUnliftedType (idType x)-        then mzero -- unlifted vars can never be ⊥-        else do+      -> mzero -- unlifted vars can never be ⊥+      | otherwise+      -> do           let vi' = vi{ vi_bot = IsBot }           pure nabla{ nabla_tm_st = ts{ts_facts = addToUSDFM env y vi' } } @@ -787,7 +722,7 @@     Just x  -> markDirty x nabla'     Nothing -> nabla'   where-    -- | Update `x`'s 'VarInfo' entry. Fail ('MaybeT') if contradiction,+    -- Update `x`'s 'VarInfo' entry. Fail ('MaybeT') if contradiction,     -- otherwise return updated entry and `Just x'` if `x` should be marked dirty,     -- where `x'` is the representative of `x`.     go :: VarInfo -> MaybeT DsM (Maybe Id, VarInfo)@@ -803,7 +738,7 @@             -- See Note [Completeness checking with required Thetas]             | hasRequiredTheta nalt  = neg             | otherwise              = extendPmAltConSet neg nalt-      MASSERT( isPmAltConMatchStrict nalt )+      massert (isPmAltConMatchStrict nalt)       let vi' = vi{ vi_neg = neg', vi_bot = IsNotBot }       -- 3. Make sure there's at least one other possible constructor       mb_rcm' <- lift (markMatched nalt rcm)@@ -844,8 +779,6 @@     Just (PACA _con other_tvs other_args) -> do       -- We must unify existentially bound ty vars and arguments!       let ty_cts = equateTys (map mkTyVarTy tvs) (map mkTyVarTy other_tvs)-      when (length args /= length other_args) $-        lift $ tracePm "error" (ppr x <+> ppr alt <+> ppr args <+> ppr other_args)       nabla' <- MaybeT $ addPhiCts nabla (listToBag ty_cts)       let add_var_ct nabla (a, b) = addVarCt nabla a b       foldlM add_var_ct nabla' $ zipEqual "addConCt" args other_args@@ -860,7 +793,7 @@             MaybeBot -> pure (nabla_with MaybeBot)             IsBot    -> addBotCt (nabla_with MaybeBot) y             IsNotBot -> addNotBotCt (nabla_with MaybeBot) y-        _ -> ASSERT( isPmAltConMatchStrict alt )+        _ -> assert (isPmAltConMatchStrict alt )              pure (nabla_with IsNotBot) -- strict match ==> not ⊥  equateTys :: [Type] -> [Type] -> [PhiCt]@@ -913,7 +846,7 @@   -- lift $ tracePm "addCoreCt" (ppr x <+> dcolon <+> ppr (idType x) $$ ppr e $$ ppr e')   execStateT (core_expr x e') nabla   where-    -- | Takes apart a 'CoreExpr' and tries to extract as much information about+    -- Takes apart a 'CoreExpr' and tries to extract as much information about     -- literals and constructor applications as possible.     core_expr :: Id -> CoreExpr -> StateT Nabla (MaybeT DsM) ()     -- TODO: Handle newtypes properly, by wrapping the expression in a DataCon@@ -954,7 +887,7 @@         -- up substituting inside a forall or lambda (i.e. seldom)         -- so using exprFreeVars seems fine.   See MR !1647. -    -- | The @e@ in @let x = e@ had no familiar form. But we can still see if+    -- The @e@ in @let x = e@ had no familiar form. But we can still see if     -- see if we already encountered a constraint @let y = e'@ with @e'@     -- semantically equivalent to @e@, in which case we may add the constraint     -- @x ~ y@.@@ -970,7 +903,7 @@       core_expr x e       pure x -    -- | Look at @let x = K taus theta es@ and generate the following+    -- Look at @let x = K taus theta es@ and generate the following     -- constraints (assuming universals were dropped from @taus@ before):     --   1. @x ≁ ⊥@ if 'K' is not a Newtype constructor.     --   2. @a_1 ~ tau_1, ..., a_n ~ tau_n@ for fresh @a_i@@@ -997,7 +930,7 @@       -- 4. @x ~ K as ys@       pm_alt_con_app x (PmAltConLike (RealDataCon dc)) ex_tvs arg_ids -    -- | Adds a literal constraint, i.e. @x ~ 42@.+    -- Adds a literal constraint, i.e. @x ~ 42@.     -- Also we assume that literal expressions won't diverge, so this     -- will add a @x ~/ ⊥@ constraint.     pm_lit :: Id -> PmLit -> StateT Nabla (MaybeT DsM) ()@@ -1005,7 +938,7 @@       modifyT $ \nabla -> addNotBotCt nabla x       pm_alt_con_app x (PmAltLit lit) [] [] -    -- | Adds the given constructor application as a solution for @x@.+    -- Adds the given constructor application as a solution for @x@.     pm_alt_con_app :: Id -> PmAltCon -> [TyVar] -> [Id] -> StateT Nabla (MaybeT DsM) ()     pm_alt_con_app x con tvs args = modifyT $ \nabla -> addConCt nabla x con tvs args @@ -1073,7 +1006,7 @@ oracle or doing inhabitation testing) contradictory. This implies a few invariants: * Whenever vi_pos overlaps with vi_neg according to 'eqPmAltCon', we refute.-  This is implied by the Note [Pos/Neg invariant].+  This is implied by the Note [The Pos/Neg invariant]. * Whenever vi_neg subsumes a COMPLETE set, we refute. We consult vi_rcm to   detect this, but we could just compare whole COMPLETE sets to vi_neg every   time, if it weren't for performance.@@ -1262,7 +1195,7 @@ -- The \(∇ ⊢ x inh\) judgment form in Figure 8 of the LYG paper. inhabitationTest :: Int -> TyState -> Nabla -> MaybeT DsM Nabla inhabitationTest 0     _         nabla             = pure nabla-inhabitationTest fuel  old_ty_st nabla@MkNabla{ nabla_tm_st = ts } = do+inhabitationTest fuel  old_ty_st nabla@MkNabla{ nabla_tm_st = ts } = {-# SCC "inhabitationTest" #-} do   -- lift $ tracePm "inhabitation test" $ vcat   --   [ ppr fuel   --   , ppr old_ty_st@@ -1315,11 +1248,12 @@ --     remain that do not statisfy it.  This lazy approach just --     avoids doing unnecessary work. instantiate :: Int -> Nabla -> VarInfo -> MaybeT DsM VarInfo-instantiate fuel nabla vi = instBot fuel nabla vi <|> instCompleteSets fuel nabla vi+instantiate fuel nabla vi = {-# SCC "instantiate" #-}+  (instBot fuel nabla vi <|> instCompleteSets fuel nabla vi)  -- | The \(⊢_{Bot}\) rule from the paper instBot :: Int -> Nabla -> VarInfo -> MaybeT DsM VarInfo-instBot _fuel nabla vi = do+instBot _fuel nabla vi = {-# SCC "instBot" #-} do   _nabla' <- addBotCt nabla (vi_id vi)   pure vi @@ -1353,7 +1287,7 @@ -- where all the attempted ConLike instantiations have been purged from the -- 'ResidualCompleteMatches', which functions as a cache. instCompleteSets :: Int -> Nabla -> VarInfo -> MaybeT DsM VarInfo-instCompleteSets fuel nabla vi = do+instCompleteSets fuel nabla vi = {-# SCC "instCompleteSets" #-} do   let x = vi_id vi   (rcm, nabla) <- lift (addNormalisedTypeMatches nabla x)   nabla <- foldM (\nabla cls -> instCompleteSet fuel nabla x cls) nabla (getRcm rcm)@@ -1384,7 +1318,7 @@   | not (completeMatchAppliesAtType (varType x) cs)   = pure nabla   | otherwise-  = go nabla (sorted_candidates cs)+  = {-# SCC "instCompleteSet" #-} go nabla (sorted_candidates cs)   where     vi = lookupVarInfo (nabla_tm_st nabla) x @@ -1423,23 +1357,26 @@ isDataConTriviallyInhabited dc   | isTyConTriviallyInhabited (dataConTyCon dc) = True isDataConTriviallyInhabited dc =-  null (dataConTheta dc) &&         -- (1)-  null (dataConImplBangs dc) &&     -- (2)-  null (dataConUnliftedFieldTys dc) -- (3)+  null (dataConTheta dc) &&                -- (1)+  null (dataConImplBangs dc) &&            -- (2)+  null (dataConMightBeUnliftedFieldTys dc) -- (3) -dataConUnliftedFieldTys :: DataCon -> [Type]-dataConUnliftedFieldTys =-  -- A levity polymorphic field requires an inhabitation test, hence compare to-  -- @Just True@-  filter ((== Just True) . isLiftedType_maybe) . map scaledThing . dataConOrigArgTys+dataConMightBeUnliftedFieldTys :: DataCon -> [Type]+dataConMightBeUnliftedFieldTys =+  filter mightBeUnliftedType . map scaledThing . dataConOrigArgTys  isTyConTriviallyInhabited :: TyCon -> Bool-isTyConTriviallyInhabited tc = elementOfUniqSet tc triviallyInhabitedTyCons+isTyConTriviallyInhabited tc = elementOfUniqSet (getUnique tc) triviallyInhabitedTyConKeys  -- | All these types are trivially inhabited-triviallyInhabitedTyCons :: UniqSet TyCon-triviallyInhabitedTyCons = mkUniqSet [-    charTyCon, doubleTyCon, floatTyCon, intTyCon, wordTyCon, word8TyCon+triviallyInhabitedTyConKeys :: UniqSet Unique+triviallyInhabitedTyConKeys = mkUniqSet [+    charTyConKey, doubleTyConKey, floatTyConKey,+    intTyConKey, int8TyConKey, int16TyConKey, int32TyConKey, int64TyConKey,+    intPrimTyConKey, int8PrimTyConKey, int16PrimTyConKey, int32PrimTyConKey, int64PrimTyConKey,+    wordTyConKey, word8TyConKey, word16TyConKey, word32TyConKey, word64TyConKey,+    wordPrimTyConKey, word8PrimTyConKey, word16PrimTyConKey, word32PrimTyConKey, word64PrimTyConKey,+    trTyConTyConKey   ]  compareConLikeTestability :: ConLike -> ConLike -> Ordering@@ -1464,16 +1401,19 @@     -- the unlikely bogus case of an unlifted field that has a bang.     unlifted_or_strict_fields :: DataCon -> Int     unlifted_or_strict_fields dc = fast_length (dataConImplBangs dc)-                                 + fast_length (dataConUnliftedFieldTys dc)+                                 + fast_length (dataConMightBeUnliftedFieldTys dc)  -- | @instCon fuel nabla (x::match_ty) K@ tries to instantiate @x@ to @K@ by -- adding the proper constructor constraint. -- -- See Note [Instantiating a ConLike]. instCon :: Int -> Nabla -> Id -> ConLike -> MaybeT DsM Nabla-instCon fuel nabla@MkNabla{nabla_ty_st = ty_st} x con = MaybeT $ do+instCon fuel nabla@MkNabla{nabla_ty_st = ty_st} x con = {-# SCC "instCon" #-} MaybeT $ do+  let hdr what = "instCon " ++ show fuel ++ " " ++ what   env <- dsGetFamInstEnvs   let match_ty = idType x+  tracePm (hdr "{") $+    ppr con <+> text "... <-" <+> ppr x <+> dcolon <+> ppr match_ty   norm_match_ty <- normaliseSourceTypeWHNF ty_st match_ty   mb_sigma_univ <- matchConLikeResTy env ty_st norm_match_ty con   case mb_sigma_univ of@@ -1490,28 +1430,45 @@       -- (4) Instantiate fresh term variables as arguments to the constructor       let field_tys' = substTys sigma_ex $ map scaledThing field_tys       arg_ids <- mapM mkPmId field_tys'-      tracePm "instCon" $ vcat+      tracePm (hdr "(cts)") $ vcat         [ ppr x <+> dcolon <+> ppr match_ty         , text "In WHNF:" <+> ppr (isSourceTypeInWHNF match_ty) <+> ppr norm_match_ty         , ppr con <+> dcolon <+> text "... ->" <+> ppr _con_res_ty         , ppr (map (\tv -> ppr tv <+> char '↦' <+> ppr (substTyVar sigma_univ tv)) _univ_tvs)         , ppr gammas         , ppr (map (\x -> ppr x <+> dcolon <+> ppr (idType x)) arg_ids)-        , ppr fuel         ]       -- (5) Finally add the new constructor constraint       runMaybeT $ do         -- Case (2) of Note [Strict fields and variables of unlifted type]         let alt = PmAltConLike con-        nabla' <- addPhiTmCt nabla (PhiConCt x alt ex_tvs gammas arg_ids)         let branching_factor = length $ filterUnliftedFields alt arg_ids+        let ct = PhiConCt x alt ex_tvs gammas arg_ids+        nabla1 <- traceWhenFailPm (hdr "(ct unsatisfiable) }") (ppr ct) $+                  addPhiTmCt nabla ct         -- See Note [Fuel for the inhabitation test]         let new_fuel               | branching_factor <= 1 = fuel               | otherwise             = min fuel 2-        inhabitationTest new_fuel (nabla_ty_st nabla) nabla'-    Nothing -> pure (Just nabla) -- Matching against match_ty failed. Inhabited!-                                 -- See Note [Instantiating a ConLike].+        lift $ tracePm (hdr "(ct satisfiable)") $ vcat+          [ ppr ct+          , ppr x <+> dcolon <+> ppr match_ty+          , text "In WHNF:" <+> ppr (isSourceTypeInWHNF match_ty) <+> ppr norm_match_ty+          , ppr con <+> dcolon <+> text "... ->" <+> ppr _con_res_ty+          , ppr (map (\tv -> ppr tv <+> char '↦' <+> ppr (substTyVar sigma_univ tv)) _univ_tvs)+          , ppr gammas+          , ppr (map (\x -> ppr x <+> dcolon <+> ppr (idType x)) arg_ids)+          , ppr branching_factor+          , ppr new_fuel+          ]+        nabla2 <- traceWhenFailPm (hdr "(inh test failed) }") (ppr nabla1) $+                  inhabitationTest new_fuel (nabla_ty_st nabla) nabla1+        lift $ tracePm (hdr "(inh test succeeded) }") (ppr nabla2)+        pure nabla2+    Nothing -> do+      tracePm (hdr "(match_ty not instance of res_ty) }") empty+      pure (Just nabla) -- Matching against match_ty failed. Inhabited!+                        -- See Note [Instantiating a ConLike].  -- | @matchConLikeResTy _ _ ty K@ tries to match @ty@ against the result -- type of @K@, @res_ty@. It returns a substitution @s@ for @K@'s universal@@ -1526,7 +1483,7 @@   if rep_tc == dataConTyCon dc     then Just (zipTCvSubst (dataConUnivTyVars dc) tc_args)     else Nothing-matchConLikeResTy _   (TySt _ inert) ty (PatSynCon ps) = runMaybeT $ do+matchConLikeResTy _   (TySt _ inert) ty (PatSynCon ps) = {-# SCC "matchConLikeResTy" #-} runMaybeT $ do   let (univ_tvs,req_theta,_,_,_,con_res_ty) = patSynSig ps   subst <- MaybeT $ pure $ tcMatchTy con_res_ty ty   guard $ all (`elemTCvSubst` subst) univ_tvs -- See the Note about T11336b@@ -1539,9 +1496,9 @@         then pure subst         else mzero -{- Note [Soundness and completeness]+{- Note [Soundness and Completeness] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Soundness and completeness of the pattern-match checker depends entirely on the+Soundness and completeness of the pattern-match checker depend entirely on the soundness and completeness of the inhabitation test.  Achieving both soundness and completeness at the same time is undecidable.@@ -1660,7 +1617,7 @@ currently isn't equipped to do.  In order to prevent endless instantiation attempts in @inhabitationTest@, we-use the fuel as an upper bound such attempts.+use the fuel as an upper bound on such attempts.  The same problem occurs with recursive newtypes, like in the following code: @@ -1798,8 +1755,8 @@ If matching /fails/, it trivially (and conservatively) reports "inhabited" by returning the unrefined input Nabla. After all, the match might have failed due to incomplete type information in Nabla.-(Type refinement from unpacking GADT constructors might monomorphise `match_ty`-so much that `res_ty` ultimately subsumes it.)+(Later type refinement from unpacking GADT constructors might monomorphise+`match_ty` so much that `res_ty` ultimately subsumes it.)  If matching /succeeds/, we get a substitution σ for the (universal) tyvars `us`. After applying σ, we get@@ -1833,38 +1790,53 @@ -- This is important for warnings. Roughly corresponds to G in Figure 6 of the -- LYG paper, with a few tweaks for better warning messages. +-- | See Note [Case split inhabiting patterns]+data GenerateInhabitingPatternsMode+  = CaseSplitTopLevel+  | MinimalCover+  deriving (Eq, Show)++instance Outputable GenerateInhabitingPatternsMode where+  ppr = text . show+ -- | @generateInhabitingPatterns vs n nabla@ returns a list of at most @n@ (but -- perhaps empty) refinements of @nabla@ that represent inhabited patterns. -- Negative information is only retained if literals are involved or for -- recursive GADTs.-generateInhabitingPatterns :: [Id] -> Int -> Nabla -> DsM [Nabla]+generateInhabitingPatterns :: GenerateInhabitingPatternsMode -> [Id] -> Int -> Nabla -> DsM [Nabla] -- See Note [Why inhabitationTest doesn't call generateInhabitingPatterns]-generateInhabitingPatterns _      0 _     = pure []-generateInhabitingPatterns []     _ nabla = pure [nabla]-generateInhabitingPatterns (x:xs) n nabla = do-  tracePm "generateInhabitingPatterns" (ppr n <+> ppr (x:xs) $$ ppr nabla)+generateInhabitingPatterns _    _      0 _     = pure []+generateInhabitingPatterns _    []     _ nabla = pure [nabla]+generateInhabitingPatterns mode (x:xs) n nabla = do+  tracePm "generateInhabitingPatterns" (ppr mode <+> ppr n <+> ppr (x:xs) $$ ppr nabla)   let VI _ pos neg _ _ = lookupVarInfo (nabla_tm_st nabla) x   case pos of     _:_ -> do-      -- All solutions must be valid at once. Try to find candidates for their-      -- fields. Example:-      --   f x@(Just _) True = case x of SomePatSyn _ -> ()-      -- after this clause, we want to report that-      --   * @f Nothing _@ is uncovered-      --   * @f x False@ is uncovered-      -- where @x@ will have two possibly compatible solutions, @Just y@ for-      -- some @y@ and @SomePatSyn z@ for some @z@. We must find evidence for @y@-      -- and @z@ that is valid at the same time. These constitute arg_vas below.+      -- Example for multiple solutions (must involve a PatSyn):+      --   f x@(Just _) True | SomePatSyn _ <- x = ...+      -- within the RHS, we know that+      --   * @x ~ Just y@ for some @y@+      --   * @x ~ SomePatSyn z@ for some @z@+      -- and both conditions have to hold /at the same time/. Hence we must+      -- find evidence for @y@ and @z@ that is valid at the same time. These+      -- constitute arg_vas below.       let arg_vas = concatMap paca_ids pos-      generateInhabitingPatterns (arg_vas ++ xs) n nabla+      generateInhabitingPatterns mode (arg_vas ++ xs) n nabla     []       -- When there are literals involved, just print negative info       -- instead of listing missed constructors       | notNull [ l | PmAltLit l <- pmAltConSetElems neg ]-      -> generateInhabitingPatterns xs n nabla-    [] -> try_instantiate x xs n nabla+      -> generateInhabitingPatterns mode xs n nabla+      -- When some constructors are impossible or when we don't care for a+      -- minimal cover (Note [Case split inhabiting patterns]), do a case split.+      | not (isEmptyPmAltConSet neg) || mode == CaseSplitTopLevel+      -> try_instantiate x xs n nabla+      -- Else don't do a case split on this var, just print a wildcard.+      -- But try splitting for the remaining vars, of course+      | otherwise+      -> generateInhabitingPatterns mode xs n nabla   where-    -- | Tries to instantiate a variable by possibly following the chain of+    -- Tries to instantiate a variable by possibly following the chain of     -- newtypes and then instantiating to all ConLikes of the wrapped type's     -- minimal residual COMPLETE set.     try_instantiate :: Id -> [Id] -> Int -> Nabla -> DsM [Nabla]@@ -1886,17 +1858,17 @@           case NE.nonEmpty (uniqDSetToList . cmConLikes <$> clss) of             Nothing ->               -- No COMPLETE sets ==> inhabited-              generateInhabitingPatterns xs n newty_nabla+              generateInhabitingPatterns mode xs n newty_nabla             Just clss -> do               -- Try each COMPLETE set, pick the one with the smallest number of               -- inhabitants               nablass' <- forM clss (instantiate_cons y rep_ty xs n newty_nabla)               let nablas' = minimumBy (comparing length) nablass'               if null nablas' && vi_bot vi /= IsNotBot-                then generateInhabitingPatterns xs n newty_nabla -- bot is still possible. Display a wildcard!+                then generateInhabitingPatterns mode xs n newty_nabla -- bot is still possible. Display a wildcard!                 else pure nablas' -    -- | Instantiates a chain of newtypes, beginning at @x@.+    -- Instantiates a chain of newtypes, beginning at @x@.     -- Turns @x nabla [T,U,V]@ to @(y, nabla')@, where @nabla'@ we has the fact     -- @x ~ T (U (V y))@.     instantiate_newtype_chain :: Id -> Nabla -> [(Type, DataCon, Type)] -> MaybeT DsM (Id, Nabla)@@ -1914,7 +1886,7 @@     instantiate_cons _ ty xs n nabla _       -- We don't want to expose users to GHC-specific constructors for Int etc.       | fmap (isTyConTriviallyInhabited . fst) (splitTyConApp_maybe ty) == Just True-      = generateInhabitingPatterns xs n nabla+      = generateInhabitingPatterns mode xs n nabla     instantiate_cons x ty xs n nabla (cl:cls) = do       -- The following line is where we call out to the inhabitationTest!       mb_nabla <- runMaybeT $ instCon 4 nabla x cl@@ -1929,7 +1901,7 @@         -- NB: We don't prepend arg_vars as we don't have any evidence on         -- them and we only want to split once on a data type. They are         -- inhabited, otherwise the inhabitation test would have refuted.-        Just nabla' -> generateInhabitingPatterns xs n nabla'+        Just nabla' -> generateInhabitingPatterns mode xs n nabla'       other_cons_nablas <- instantiate_cons x ty xs (n - length con_nablas) nabla cls       pure (con_nablas ++ other_cons_nablas) @@ -1955,7 +1927,7 @@   return applicable_cms  {- Note [Why inhabitationTest doesn't call generateInhabitingPatterns]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Why can't we define `inhabitationTest` (IT) in terms of `generateInhabitingPatterns` (GIP) as @@ -1975,4 +1947,36 @@ But we still need GIP to produce the Nablas as proxies for uncovered patterns that we display warnings for. It's fine to pay this price once at the end, but IT is called far more often than that.++Note [Case split inhabiting patterns]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we have an -XEmptyCase,+```hs+f :: Maybe a -> ()+f x = case x of {}+```+we want to show the different missing patterns {'Just _', 'Nothing'} to the user+instead of an uninformative wildcard pattern '_'.++But when we have a match as part of a function definition, such as+```hs+g :: (Bool, [a]) -> ()+g (_, []) = ()+```+we established in #20642 that we *do not* want to report P1={'(False, (_:_))',+'(True, (_:_))'} when we could just give the singleton set P2={'(_, (_:_))'}!+The latter set M is a "minimal cover" of the space of missing patterns S, in+that++1. The union of M is *exactly* S+2. The size of M is minimal under all such candidates.++In terms of 'g', P2 satisfies both (1) and (2). While P1 satisfies (1), it does+not satisfy (2). The set {'_'} satisfies (2), but it does not satisfy (1) as+it also covers the pattern '(_,[])' which is not part of the space of missing+patterns of 'g', so it would be a bad (too conservative) suggestion.++Note that for -XEmptyCase, we don't want to emit a minimal cover. We arrange+that by passing 'CaseSplitTopLevel' to 'generateInhabitingPatterns'. We detect+the -XEmptyCase case in 'reportWarnings' by looking for 'ReportEmptyCase'. -}
GHC/HsToCore/Pmc/Solver/Types.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE ApplicativeDo       #-}-{-# LANGUAGE CPP                 #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns        #-}+{-# LANGUAGE MultiWayIf          #-}  -- | Domain types used in "GHC.HsToCore.Pmc.Solver". -- The ultimate goal is to define 'Nabla', which models normalised refinement@@ -11,7 +12,11 @@         -- * Normalised refinement types         BotInfo(..), PmAltConApp(..), VarInfo(..), TmState(..), TyState(..),         Nabla(..), Nablas(..), initNablas,+        lookupRefuts, lookupSolution, +        -- ** Looking up 'VarInfo'+        lookupVarInfo, lookupVarInfoNT, trvVarInfo,+         -- ** Caching residual COMPLETE sets         CompleteMatch, ResidualCompleteMatches(..), getRcm, isRcmInitialised, @@ -32,11 +37,8 @@      ) where -#include "HsVersions.h"- import GHC.Prelude -import GHC.Utils.Misc import GHC.Data.Bag import GHC.Data.FastString import GHC.Types.Id@@ -47,7 +49,8 @@ import GHC.Core.DataCon import GHC.Core.ConLike import GHC.Utils.Outputable-import GHC.Utils.Panic+import GHC.Utils.Panic.Plain+import GHC.Utils.Misc (lastMaybe) import GHC.Data.List.SetOps (unionLists) import GHC.Data.Maybe import GHC.Core.Type@@ -59,7 +62,7 @@ import GHC.Builtin.Names import GHC.Builtin.Types import GHC.Builtin.Types.Prim-import GHC.Tc.Solver.Monad (InertSet, emptyInert)+import GHC.Tc.Solver.InertSet (InertSet, emptyInert) import GHC.Tc.Utils.TcType (isStringTy) import GHC.Types.CompleteMatch (CompleteMatch(..)) import GHC.Types.SourceText (SourceText(..), mkFractionalLit, FractionalLit@@ -276,6 +279,79 @@   -- formats as "[{Nothing,Just},{P,Q}]"   ppr rcm = ppr (getRcm rcm) +-----------------------+-- * Looking up VarInfo++emptyRCM :: ResidualCompleteMatches+emptyRCM = RCM Nothing Nothing++emptyVarInfo :: Id -> VarInfo+emptyVarInfo x+  = VI+  { vi_id = x+  , vi_pos = []+  , vi_neg = emptyPmAltConSet+  -- Why not set IsNotBot for unlifted type here?+  -- Because we'd have to trigger an inhabitation test, which we can't.+  -- See case (4) in Note [Strict fields and variables of unlifted type]+  -- in GHC.HsToCore.Pmc.Solver+  , vi_bot = MaybeBot+  , vi_rcm = emptyRCM+  }++lookupVarInfo :: TmState -> Id -> VarInfo+-- (lookupVarInfo tms x) tells what we know about 'x'+lookupVarInfo (TmSt env _ _) x = fromMaybe (emptyVarInfo x) (lookupUSDFM env x)++-- | Like @lookupVarInfo ts x@, but @lookupVarInfo ts x = (y, vi)@ also looks+-- through newtype constructors. We have @x ~ N1 (... (Nk y))@ such that the+-- returned @y@ doesn't have a positive newtype constructor constraint+-- associated with it (yet). The 'VarInfo' returned is that of @y@'s+-- representative.+--+-- Careful, this means that @idType x@ might be different to @idType y@, even+-- modulo type normalisation!+--+-- See also Note [Coverage checking Newtype matches] in GHC.HsToCore.Pmc.Solver.+lookupVarInfoNT :: TmState -> Id -> (Id, VarInfo)+lookupVarInfoNT ts x = case lookupVarInfo ts x of+  VI{ vi_pos = as_newtype -> Just y } -> lookupVarInfoNT ts y+  res                                 -> (x, res)+  where+    as_newtype = listToMaybe . mapMaybe go+    go PACA{paca_con = PmAltConLike (RealDataCon dc), paca_ids = [y]}+      | isNewDataCon dc = Just y+    go _                = Nothing++trvVarInfo :: Functor f => (VarInfo -> f (a, VarInfo)) -> Nabla -> Id -> f (a, Nabla)+trvVarInfo f nabla@MkNabla{ nabla_tm_st = ts@TmSt{ts_facts = env} } x+  = set_vi <$> f (lookupVarInfo ts x)+  where+    set_vi (a, vi') =+      (a, nabla{ nabla_tm_st = ts{ ts_facts = addToUSDFM env (vi_id vi') vi' } })++------------------------------------------------+-- * Exported utility functions querying 'Nabla'++lookupRefuts :: Nabla -> Id -> [PmAltCon]+-- Unfortunately we need the extra bit of polymorphism and the unfortunate+-- duplication of lookupVarInfo here.+lookupRefuts MkNabla{ nabla_tm_st = ts } x =+  pmAltConSetElems $ vi_neg $ lookupVarInfo ts x++isDataConSolution :: PmAltConApp -> Bool+isDataConSolution PACA{paca_con = PmAltConLike (RealDataCon _)} = True+isDataConSolution _                                             = False++-- @lookupSolution nabla x@ picks a single solution ('vi_pos') of @x@ from+-- possibly many, preferring 'RealDataCon' solutions whenever possible.+lookupSolution :: Nabla -> Id -> Maybe PmAltConApp+lookupSolution nabla x = case vi_pos (lookupVarInfo (nabla_tm_st nabla) x) of+  []                                         -> Nothing+  pos+    | Just sol <- find isDataConSolution pos -> Just sol+    | otherwise                              -> Just (head pos)+ -------------------------------------------------------------------------------- -- The rest is just providing an IR for (overloaded!) literals and AltCons that -- sits between Hs and Core. We need a reliable way to detect and determine@@ -431,13 +507,13 @@  -- | Type of a 'PmAltCon' pmAltConType :: PmAltCon -> [Type] -> Type-pmAltConType (PmAltLit lit)     _arg_tys = ASSERT( null _arg_tys ) pmLitType lit+pmAltConType (PmAltLit lit)     _arg_tys = assert (null _arg_tys ) $ pmLitType lit pmAltConType (PmAltConLike con) arg_tys  = conLikeResTy con arg_tys  -- | Is a match on this constructor forcing the match variable? -- True of data constructors, literals and pattern synonyms (#17357), but not of -- newtypes.--- See Note [Coverage checking Newtype matches] in "GHC.HsToCore.Pmc.Solver".+-- See Note [Coverage checking Newtype matches] in GHC.HsToCore.Pmc.Solver. isPmAltConMatchStrict :: PmAltCon -> Bool isPmAltConMatchStrict PmAltLit{}                      = True isPmAltConMatchStrict (PmAltConLike PatSynCon{})      = True -- #17357@@ -548,17 +624,24 @@     | Just dc <- isDataConWorkId_maybe x     , dc `elem` [intDataCon, wordDataCon, charDataCon, floatDataCon, doubleDataCon]     -> literalToPmLit (exprType e) l-  (Var x, [_ty, Lit n, Lit d])+  (Var x, [Lit (LitNumber _ l)])+    | Just (ty,l) <- bignum_lit_maybe x l+    -> Just (PmLit ty (PmLitInt l))+  (Var x, [_ty, n_arg, d_arg])     | Just dc <- isDataConWorkId_maybe x     , dataConName dc == ratioDataConName+    , Just (PmLit _ (PmLitInt n)) <- coreExprAsPmLit n_arg+    , Just (PmLit _ (PmLitInt d)) <- coreExprAsPmLit d_arg     -- HACK: just assume we have a literal double. This case only occurs for     --       overloaded lits anyway, so we immediately override type information-    -> literalToPmLit (exprType e) (mkLitDouble (litValue n % litValue d))+    -> literalToPmLit (exprType e) (mkLitDouble (n % d))+   (Var x, args)     -- See Note [Detecting overloaded literals with -XRebindableSyntax]     | is_rebound_name x fromIntegerName-    , [Lit l] <- dropWhile (not . is_lit) args-    -> literalToPmLit (literalType l) l >>= overloadPmLit (exprType e)+    , Just arg <- lastMaybe args+    , Just (_ty,l) <- bignum_conapp_maybe arg+    -> Just (PmLit integerTy (PmLitInt l)) >>= overloadPmLit (exprType e)   (Var x, args)     -- See Note [Detecting overloaded literals with -XRebindableSyntax]     -- fromRational <expr>@@ -572,16 +655,16 @@     -- See Note [Dealing with rationals with large exponents]     -- mkRationalBase* <rational> <exponent>     | Just exp_base <- is_larg_exp_ratio x-    , [r, Lit exp] <- dropWhile (not . is_ratio) args-    , (Var x, [_ty, Lit n, Lit d]) <- collectArgs r+    , [r, exp] <- dropWhile (not . is_ratio) args+    , (Var x, [_ty, n_arg, d_arg]) <- collectArgs r     , Just dc <- isDataConWorkId_maybe x     , dataConName dc == ratioDataConName+    , Just (PmLit _ (PmLitInt n)) <- coreExprAsPmLit n_arg+    , Just (PmLit _ (PmLitInt d)) <- coreExprAsPmLit d_arg+    , Just (_exp_ty,exp') <- bignum_conapp_maybe exp     -> do-      n' <- isLitValue_maybe n-      d' <- isLitValue_maybe d-      exp' <- isLitValue_maybe exp-      let rational = (abs n') :% d'-      let neg = if n' < 0 then 1 else 0+      let rational = (abs n) :% d+      let neg = if n < 0 then 1 else 0       let frac = mkFractionalLit NoSourceText False rational exp' exp_base       Just $ PmLit (exprType e) (PmLitOverRat neg frac) @@ -603,8 +686,20 @@    _ -> Nothing   where-    is_lit Lit{} = True-    is_lit _     = False+    bignum_conapp_maybe (App (Var x) (Lit (LitNumber _ l)))+      = bignum_lit_maybe x l+    bignum_conapp_maybe _ = Nothing++    bignum_lit_maybe x l+      | Just dc <- isDataConWorkId_maybe x+      = if | dc == integerISDataCon -> Just (integerTy,l)+           | dc == integerIPDataCon -> Just (integerTy,l)+           | dc == integerINDataCon -> Just (integerTy,negate l)+           | dc == naturalNSDataCon -> Just (naturalTy,l)+           | dc == naturalNBDataCon -> Just (naturalTy,l)+           | otherwise              -> Nothing+    bignum_lit_maybe _ _ = Nothing+     is_ratio (Type _) = False     is_ratio r       | Just (tc, _) <- splitTyConApp_maybe (exprType r)
GHC/HsToCore/Pmc/Types.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP                 #-}+ {-# LANGUAGE DeriveFunctor       #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns        #-}@@ -33,8 +33,6 @@         module GHC.HsToCore.Pmc.Solver.Types      ) where--#include "HsVersions.h"  import GHC.Prelude
GHC/HsToCore/Pmc/Utils.hs view
@@ -1,19 +1,17 @@-{-# LANGUAGE CPP                 #-}+ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-}  -- | Utility module for the pattern-match coverage checker. module GHC.HsToCore.Pmc.Utils ( -        tracePm, mkPmId,+        tracePm, traceWhenFailPm, mkPmId,         allPmCheckWarnings, overlapping, exhaustive, redundantBang,         exhaustiveWarningFlag,         isMatchContextPmChecked, needToRunPmCheck      ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Types.Basic (Origin(..), isGenerated)@@ -22,6 +20,7 @@ import GHC.Core.Type import GHC.Data.FastString import GHC.Data.IOEnv+import GHC.Data.Maybe import GHC.Types.Id import GHC.Types.Name import GHC.Types.Unique.Supply@@ -31,21 +30,30 @@ import GHC.Utils.Logger import GHC.HsToCore.Monad +import Control.Monad+ tracePm :: String -> SDoc -> DsM () tracePm herald doc = do-  dflags <- getDynFlags-  logger <- getLogger+  logger  <- getLogger   printer <- mkPrintUnqualifiedDs-  liftIO $ dumpIfSet_dyn_printer printer logger dflags+  liftIO $ putDumpFileMaybe' logger printer             Opt_D_dump_ec_trace "" FormatText (text herald $$ (nest 2 doc)) {-# INLINE tracePm #-}  -- see Note [INLINE conditional tracing utilities] +traceWhenFailPm :: String -> SDoc -> MaybeT DsM a -> MaybeT DsM a+traceWhenFailPm herald doc act = MaybeT $ do+  mb_a <- runMaybeT act+  when (isNothing mb_a) $ tracePm herald doc+  pure mb_a+{-# INLINE traceWhenFailPm #-}  -- see Note [INLINE conditional tracing utilities]+ -- | Generate a fresh `Id` of a given type mkPmId :: Type -> DsM Id mkPmId ty = getUniqueM >>= \unique ->   let occname = mkVarOccFS $ fsLit "pm"       name    = mkInternalName unique occname noSrcSpan   in  return (mkLocalIdOrCoVar name Many ty)+{-# NOINLINE mkPmId #-} -- We'll CPR deeply, that should be enough  -- | All warning flags that need to run the pattern match checker. allPmCheckWarnings :: [WarningFlag]@@ -74,26 +82,28 @@ -- via which 'WarningFlag' it's controlled. -- Returns 'Nothing' if check is not supported. exhaustiveWarningFlag :: HsMatchContext id -> Maybe WarningFlag-exhaustiveWarningFlag (FunRhs {})   = Just Opt_WarnIncompletePatterns-exhaustiveWarningFlag CaseAlt       = Just Opt_WarnIncompletePatterns-exhaustiveWarningFlag IfAlt         = Just Opt_WarnIncompletePatterns-exhaustiveWarningFlag LambdaExpr    = Just Opt_WarnIncompleteUniPatterns-exhaustiveWarningFlag PatBindRhs    = Just Opt_WarnIncompleteUniPatterns-exhaustiveWarningFlag PatBindGuards = Just Opt_WarnIncompletePatterns+exhaustiveWarningFlag FunRhs{}           = Just Opt_WarnIncompletePatterns+exhaustiveWarningFlag CaseAlt            = Just Opt_WarnIncompletePatterns+exhaustiveWarningFlag LamCaseAlt{}       = Just Opt_WarnIncompletePatterns+exhaustiveWarningFlag IfAlt              = Just Opt_WarnIncompletePatterns+exhaustiveWarningFlag LambdaExpr         = Just Opt_WarnIncompleteUniPatterns+exhaustiveWarningFlag PatBindRhs         = Just Opt_WarnIncompleteUniPatterns+exhaustiveWarningFlag PatBindGuards      = Just Opt_WarnIncompletePatterns exhaustiveWarningFlag (ArrowMatchCtxt c) = arrowMatchContextExhaustiveWarningFlag c-exhaustiveWarningFlag RecUpd        = Just Opt_WarnIncompletePatternsRecUpd-exhaustiveWarningFlag ThPatSplice   = Nothing-exhaustiveWarningFlag PatSyn        = Nothing-exhaustiveWarningFlag ThPatQuote    = Nothing+exhaustiveWarningFlag RecUpd             = Just Opt_WarnIncompletePatternsRecUpd+exhaustiveWarningFlag ThPatSplice        = Nothing+exhaustiveWarningFlag PatSyn             = Nothing+exhaustiveWarningFlag ThPatQuote         = Nothing -- Don't warn about incomplete patterns in list comprehensions, pattern guards -- etc. They are often *supposed* to be incomplete-exhaustiveWarningFlag (StmtCtxt {}) = Nothing+exhaustiveWarningFlag StmtCtxt{}         = Nothing  arrowMatchContextExhaustiveWarningFlag :: HsArrowMatchContext -> Maybe WarningFlag arrowMatchContextExhaustiveWarningFlag = \ case-  ProcExpr     -> Just Opt_WarnIncompleteUniPatterns-  ArrowCaseAlt -> Just Opt_WarnIncompletePatterns-  KappaExpr    -> Just Opt_WarnIncompleteUniPatterns+  ProcExpr          -> Just Opt_WarnIncompleteUniPatterns+  ArrowCaseAlt      -> Just Opt_WarnIncompletePatterns+  ArrowLamCaseAlt _ -> Just Opt_WarnIncompletePatterns+  KappaExpr         -> Just Opt_WarnIncompleteUniPatterns  -- | Check whether any part of pattern match checking is enabled for this -- 'HsMatchContext' (does not matter whether it is the redundancy check or the
GHC/HsToCore/Quote.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes    #-}-{-# LANGUAGE CPP                    #-}+ {-# LANGUAGE DataKinds              #-} {-# LANGUAGE FlexibleContexts       #-} {-# LANGUAGE FunctionalDependencies #-}@@ -29,13 +29,12 @@  module GHC.HsToCore.Quote( dsBracket ) where -#include "HsVersions.h"- import GHC.Prelude import GHC.Platform  import GHC.Driver.Session +import GHC.HsToCore.Errors.Types import {-# SOURCE #-} GHC.HsToCore.Expr ( dsExpr ) import GHC.HsToCore.Match.Literal import GHC.HsToCore.Monad@@ -65,6 +64,7 @@  import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Utils.Misc import GHC.Utils.Monad @@ -129,7 +129,7 @@                           mkInvisFunTyMany (mkClassPred cls (mkTyVarTys (binderVars tyvars)))                                            (mkClassPred monad_cls (mkTyVarTys (binderVars tyvars))) -      MASSERT2( idType monad_sel `eqType` expected_ty, ppr monad_sel $$ ppr expected_ty)+      massertPpr (idType monad_sel `eqType` expected_ty) (ppr monad_sel $$ ppr expected_ty)        let m_ty = Type m_var           -- Construct the contents of MetaWrappers@@ -158,7 +158,7 @@  ----------------------------------------------------------------------------- dsBracket :: Maybe QuoteWrapper -- ^ This is Nothing only when we are dealing with a VarBr-          -> HsBracket GhcRn+          -> HsQuote GhcRn      -- See Note [The life cycle of a TH quotation]           -> [PendingTcSplice]           -> DsM CoreExpr -- See Note [Desugaring Brackets]@@ -168,7 +168,6 @@  dsBracket wrap brack splices   = do_brack brack-   where     runOverloaded act = do       -- In the overloaded case we have to get given a wrapper, it is just@@ -177,7 +176,6 @@       mw <- mkMetaWrappers (expectJust "runOverloaded" wrap)       runReaderT (mapReaderT (dsExtendMetaEnv new_bit) act) mw -     new_bit = mkNameEnv [(n, DsSplice (unLoc e))                         | PendingTcSplice n e <- splices] @@ -186,9 +184,9 @@     do_brack (PatBr _ p)   = runOverloaded $ do { MkC p1  <- repTopP p   ; return p1 }     do_brack (TypBr _ t)   = runOverloaded $ do { MkC t1  <- repLTy t    ; return t1 }     do_brack (DecBrG _ gp) = runOverloaded $ do { MkC ds1 <- repTopDs gp ; return ds1 }-    do_brack (DecBrL {})   = panic "dsBracket: unexpected DecBrL"-    do_brack (TExpBr _ e)  = runOverloaded $ do { MkC e1  <- repLE e     ; return e1 }+    do_brack (DecBrL {})   = panic "dsUntypedBracket: unexpected DecBrL" + {- Note [Desugaring Brackets] ~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -286,7 +284,7 @@                         , hs_docs    = docs })  = do { let { bndrs  = hsScopedTvBinders valds                        ++ hsGroupBinders group-                       ++ map extFieldOcc (hsPatSynSelectors valds)+                       ++ map foExt (hsPatSynSelectors valds)             ; instds = tyclds >>= group_instds } ;         ss <- mkGenSyms bndrs ; @@ -306,7 +304,7 @@                      ; inst_ds  <- mapM repInstD instds                      ; deriv_ds <- mapM repStandaloneDerivD derivds                      ; fix_ds   <- mapM repLFixD fixds-                     ; _        <- mapM no_default_decl defds+                     ; def_ds   <- mapM repDefD defds                      ; for_ds   <- mapM repForD fords                      ; _        <- mapM no_warn (concatMap (wd_warnings . unLoc)                                                            warnds)@@ -320,6 +318,7 @@                                 val_ds ++ catMaybes tycl_ds ++ role_ds                                        ++ kisig_ds                                        ++ (concat fix_ds)+                                       ++ def_ds                                        ++ inst_ds ++ rule_ds ++ for_ds                                        ++ ann_ds ++ deriv_ds) }) ; @@ -332,15 +331,12 @@       }   where     no_splice (L loc _)-      = notHandledL (locA loc) "Splices within declaration brackets" empty-    no_default_decl (L loc decl)-      = notHandledL (locA loc) "Default declarations" (ppr decl)+      = notHandledL (locA loc) ThSplicesWithinDeclBrackets     no_warn :: LWarnDecl GhcRn -> MetaM a     no_warn (L loc (Warning _ thing _))-      = notHandledL (locA loc) "WARNING and DEPRECATION pragmas" $-                    text "Pragma for declaration of" <+> ppr thing+      = notHandledL (locA loc) (ThWarningAndDeprecationPragmas thing)     no_doc (L loc _)-      = notHandledL (locA loc) "Haddock documentation" empty+      = notHandledL (locA loc) ThHaddockDocumentation  hsScopedTvBinders :: HsValBinds GhcRn -> [Name] -- See Note [Scoped type variables in quotes]@@ -464,7 +460,7 @@                                               repFamilyDecl (L loc fam)  repTyClD (L loc (SynDecl { tcdLName = tc, tcdTyVars = tvs, tcdRhs = rhs }))-  = do { tc1 <- lookupLOcc tc           -- See note [Binders and occurrences]+  = do { tc1 <- lookupLOcc tc           -- See Note [Binders and occurrences]        ; dec <- addTyClTyVarBinds tvs $ \bndrs ->                 repSynDecl tc1 bndrs rhs        ; return (Just (locA loc, dec)) }@@ -472,7 +468,7 @@ repTyClD (L loc (DataDecl { tcdLName = tc                           , tcdTyVars = tvs                           , tcdDataDefn = defn }))-  = do { tc1 <- lookupLOcc tc           -- See note [Binders and occurrences]+  = do { tc1 <- lookupLOcc tc           -- See Note [Binders and occurrences]        ; dec <- addTyClTyVarBinds tvs $ \bndrs ->                 repDataDefn tc1 (Left bndrs) defn        ; return (Just (locA loc, dec)) }@@ -481,7 +477,7 @@                              tcdTyVars = tvs, tcdFDs = fds,                              tcdSigs = sigs, tcdMeths = meth_binds,                              tcdATs = ats, tcdATDefs = atds }))-  = do { cls1 <- lookupLOcc cls         -- See note [Binders and occurrences]+  = do { cls1 <- lookupLOcc cls         -- See Note [Binders and occurrences]        ; dec  <- addQTyVarBinds tvs $ \bndrs ->            do { cxt1   <- repLContext cxt           -- See Note [Scoped type variables in quotes]@@ -532,9 +528,7 @@                                    ; ksig' <- repMaybeLTy ksig                                    ; repNewtype cxt1 tc opts ksig' con'                                                 derivs1 }-           (NewType, _) -> lift $ failWithDs (text "Multiple constructors for newtype:"-                                       <+> pprQuotedList-                                       (getConNames $ unLoc $ head cons))+           (NewType, _) -> lift $ failWithDs (DsMultipleConForNewtype (getConNames $ unLoc $ head cons))            (DataType, _) -> do { ksig' <- repMaybeLTy ksig                                ; consL <- mapM repC cons                                ; cons1 <- coreListM conTyConName consL@@ -555,7 +549,7 @@                                       , fdTyVars    = tvs                                       , fdResultSig = L _ resultSig                                       , fdInjectivityAnn = injectivity }))-  = do { tc1 <- lookupLOcc tc           -- See note [Binders and occurrences]+  = do { tc1 <- lookupLOcc tc           -- See Note [Binders and occurrences]        ; let mkHsQTvs :: [LHsTyVarBndr () GhcRn] -> LHsQTyVars GhcRn              mkHsQTvs tvs = HsQTvs { hsq_ext = []                                    , hsq_explicit = tvs }@@ -566,7 +560,7 @@                 addTyClTyVarBinds resTyVar $ \_ ->            case info of              ClosedTypeFamily Nothing ->-                 notHandled "abstract closed type family" (ppr decl)+                 notHandled (ThAbstractClosedTypeFamily decl)              ClosedTypeFamily (Just eqns) ->                do { eqns1  <- mapM (repTyFamEqn . unLoc) eqns                   ; eqns2  <- coreListM tySynEqnTyConName eqns1@@ -698,7 +692,7 @@                     , feqn_pats = tys                     , feqn_fixity = fixity                     , feqn_rhs  = rhs })-  = do { tc <- lookupLOcc tc_name     -- See note [Binders and occurrences]+  = do { tc <- lookupLOcc tc_name     -- See Note [Binders and occurrences]        ; addHsOuterFamEqnTyVarBinds outer_bndrs $ \mb_exp_bndrs ->          do { tys1 <- case fixity of                         Prefix -> repTyArgs (repNamedTyCon tc) tys@@ -729,7 +723,7 @@                                              , feqn_pats  = tys                                              , feqn_fixity = fixity                                              , feqn_rhs   = defn }})-  = do { tc <- lookupLOcc tc_name         -- See note [Binders and occurrences]+  = do { tc <- lookupLOcc tc_name         -- See Note [Binders and occurrences]        ; addHsOuterFamEqnTyVarBinds outer_bndrs $ \mb_exp_bndrs ->          do { tys1 <- case fixity of                         Prefix -> repTyArgs (repNamedTyCon tc) tys@@ -757,7 +751,7 @@       return (locA loc, dec)  where     conv_cimportspec (CLabel cls)-      = notHandled "Foreign label" (doubleQuotes (ppr cls))+      = notHandled (ThForeignLabel cls)     conv_cimportspec (CFunction DynamicTarget) = return "dynamic"     conv_cimportspec (CFunction (StaticTarget _ fs _ True))                             = return (unpackFS fs)@@ -772,7 +766,7 @@     chStr = case mch of             Just (Header _ h) | not raw_cconv -> unpackFS h ++ " "             _ -> ""-repForD decl@(L _ ForeignExport{}) = notHandled "Foreign export" (ppr decl)+repForD decl@(L _ ForeignExport{}) = notHandled (ThForeignExport decl)  repCCallConv :: CCallConv -> MetaM (Core TH.Callconv) repCCallConv CCallConv          = rep2_nw cCallName []@@ -802,6 +796,12 @@                    ; return (loc,dec) }        ; mapM do_one names } +repDefD :: LDefaultDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))+repDefD (L loc (DefaultDecl _ tys)) = do { tys1 <- repLTys tys+                                         ; MkC tys2 <- coreListM typeTyConName tys1+                                         ; dec <- rep2 defaultDName [tys2]+                                         ; return (locA loc, dec)}+ repRuleD :: LRuleDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec)) repRuleD (L loc (HsRule { rd_name = n                         , rd_act = act@@ -999,8 +999,8 @@ rep_sig (L loc (SpecSig _ nm tys ispec))   = concatMapM (\t -> rep_specialise nm t ispec (locA loc)) tys rep_sig (L loc (SpecInstSig _ _ ty))  = rep_specialiseInst ty (locA loc)-rep_sig (L _   (MinimalSig {}))       = notHandled "MINIMAL pragmas" empty-rep_sig (L _   (SCCFunSig {}))        = notHandled "SCC pragmas" empty+rep_sig (L _   (MinimalSig {}))       = notHandled ThMinimalPragmas+rep_sig (L _   (SCCFunSig {}))        = notHandled ThSCCPragmas rep_sig (L loc (CompleteMatchSig _ _st cls mty))   = rep_complete_sig cls mty (locA loc) @@ -1084,7 +1084,14 @@            -> SrcSpan            -> MetaM [(SrcSpan, Core (M TH.Dec))] rep_inline nm ispec loc+  | Opaque {} <- inl_inline ispec   = do { nm1    <- lookupLOcc nm+       ; opq <- repPragOpaque nm1+       ; return [(loc, opq)]+       }++rep_inline nm ispec loc+  = do { nm1    <- lookupLOcc nm        ; inline <- repInline $ inl_inline ispec        ; rm     <- repRuleMatch $ inl_rule ispec        ; phases <- repPhases $ inl_act ispec@@ -1117,10 +1124,15 @@        ; return [(loc, pragma)] }  repInline :: InlineSpec -> MetaM (Core TH.Inline)-repInline NoInline         = dataCon noInlineDataConName-repInline Inline           = dataCon inlineDataConName-repInline Inlinable        = dataCon inlinableDataConName-repInline NoUserInlinePrag = notHandled "NOUSERINLINE" empty+repInline (NoInline          _ )   = dataCon noInlineDataConName+-- There is a mismatch between the TH and GHC representation because+-- OPAQUE pragmas can't have phase activation annotations (which is+-- enforced by the TH API), therefore they are desugared to OpaqueP rather than+-- InlineP, see special case in rep_inline.+repInline (Opaque            _ )   = panic "repInline: Opaque"+repInline (Inline            _ )   = dataCon inlineDataConName+repInline (Inlinable         _ )   = dataCon inlinableDataConName+repInline NoUserInlinePrag        = notHandled ThNoUserInline  repRuleMatch :: RuleMatchInfo -> MetaM (Core TH.RuleMatch) repRuleMatch ConLike = dataCon conLikeDataConName@@ -1393,7 +1405,7 @@ repTy (HsSumTy _ tys)       = do tys1 <- repLTys tys                                  tcon <- repUnboxedSumTyCon (length tys)                                  repTapps tcon tys1-repTy (HsOpTy _ ty1 n ty2)  = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1)+repTy (HsOpTy _ prom ty1 n ty2) = repLTy ((nlHsTyVar prom (unLoc n) `nlHsAppTy` ty1)                                    `nlHsAppTy` ty2) repTy (HsParTy _ t)         = repLTy t repTy (HsStarTy _ _) =  repTStar@@ -1418,10 +1430,12 @@                              t' <- repLTy t                              repTImplicitParam n' t' -repTy ty                      = notHandled "Exotic form of type" (ppr ty)+repTy ty                      = notHandled (ThExoticFormOfType ty)  repTyLit :: HsTyLit -> MetaM (Core (M TH.TyLit))-repTyLit (HsNumTy _ i) = rep2 numTyLitName [mkIntegerExpr i]+repTyLit (HsNumTy _ i) = do+                         platform <- getPlatform+                         rep2 numTyLitName [mkIntegerExpr platform i] repTyLit (HsStrTy _ s) = do { s' <- mkStringExprFS s                             ; rep2 strTyLitName [s']                             }@@ -1436,7 +1450,7 @@   k_ty <- wrapName kindTyConName   repMaybeT k_ty repLTy m -repRole :: Located (Maybe Role) -> MetaM (Core TH.Role)+repRole :: LocatedAn NoEpAnns (Maybe Role) -> MetaM (Core TH.Role) repRole (L _ (Just Nominal))          = rep2_nw nominalRName [] repRole (L _ (Just Representational)) = rep2_nw representationalRName [] repRole (L _ (Just Phantom))          = rep2_nw phantomRName []@@ -1488,9 +1502,7 @@ repE (HsIPVar _ n) = rep_implicit_param_name n >>= repImplicitParamVar repE (HsOverLabel _ s) = repOverLabel s -repE e@(HsRecFld _ f) = case f of-  Unambiguous x _ -> repE (HsVar noExtField (noLocA x))-  Ambiguous{}     -> notHandled "Ambiguous record selectors" (ppr e)+repE (HsRecSel _ (FieldOcc x _)) = repE (HsVar noExtField (noLocA x))          -- Remember, we're desugaring renamer output here, so         -- HsOverlit can definitely occur@@ -1498,10 +1510,14 @@ repE (HsLit _ l)     = do { a <- repLiteral l;           repLit a } repE (HsLam _ (MG { mg_alts = (L _ [m]) })) = repLambda m repE e@(HsLam _ (MG { mg_alts = (L _ _) })) = pprPanic "repE: HsLam with multiple alternatives" (ppr e)-repE (HsLamCase _ (MG { mg_alts = (L _ ms) }))+repE (HsLamCase _ LamCase (MG { mg_alts = (L _ ms) }))                    = do { ms' <- mapM repMatchTup ms                         ; core_ms <- coreListM matchTyConName ms'                         ; repLamCase core_ms }+repE (HsLamCase _ LamCases (MG { mg_alts = (L _ ms) }))+                   = do { ms' <- mapM repClauseTup ms+                        ; core_ms <- coreListM matchTyConName ms'+                        ; repLamCases core_ms } repE (HsApp _ x y)   = do {a <- repLE x; b <- repLE y; repApp a b} repE (HsAppType _ e t) = do { a <- repLE e                             ; s <- repLTy (hswc_body t)@@ -1516,7 +1532,7 @@                               a         <- repLE x                               negateVar <- lookupOcc negateName >>= repVar                               negateVar `repApp` a-repE (HsPar _ x)            = repLE x+repE (HsPar _ _ x _)        = repLE x repE (SectionL _ x y)       = do { a <- repLE x; b <- repLE y; repSectionL a b } repE (SectionR _ x y)       = do { a <- repLE x; b <- repLE y; repSectionR a b } repE (HsCase _ e (MG { mg_alts = (L _ ms) }))@@ -1533,7 +1549,7 @@   = do { (binds, alts') <- liftM unzip $ mapM repLGRHS alts        ; expr' <- repMultiIf (nonEmptyCoreList alts')        ; wrapGenSyms (concat binds) expr' }-repE (HsLet _ bs e)             = do { (ss,ds) <- repBinds bs+repE (HsLet _ _ bs _ e)         = do { (ss,ds) <- repBinds bs                                      ; e2 <- addBinds ss (repLE e)                                      ; z <- repLetE ds e2                                      ; wrapGenSyms ss z }@@ -1557,7 +1573,7 @@         wrapGenSyms ss e' }    | otherwise-  = notHandled "monad comprehension and [: :]" (ppr e)+  = notHandled (ThMonadComprehensionSyntax e)  repE (ExplicitList _ es) = do { xs <- repLEs es; repListExp xs } repE (ExplicitTuple _ es boxity) =@@ -1624,16 +1640,19 @@                                occ   <- occNameLit uv                                sname <- repNameS occ                                repUnboundVar sname-repE (HsGetField _ e (L _ (HsFieldLabel _ (L _ f)))) = do+repE (HsGetField _ e (L _ (DotFieldOcc _ (L _ f)))) = do   e1 <- repLE e   repGetField e1 f-repE (HsProjection _ xs) = repProjection (fmap (unLoc . hflLabel . unLoc) xs)+repE (HsProjection _ xs) = repProjection (fmap (unLoc . dfoLabel . unLoc) xs) repE (XExpr (HsExpanded orig_expr ds_expr))   = do { rebindable_on <- lift $ xoptM LangExt.RebindableSyntax        ; if rebindable_on  -- See Note [Quotation and rebindable syntax]          then repE ds_expr          else repE orig_expr }-repE e = notHandled "Expression form" (ppr e)+repE e@(HsPragE _ (HsPragSCC {}) _) = notHandled (ThCostCentres e)+repE e@(HsTypedBracket{})   = notHandled (ThExpressionForm e)+repE e@(HsUntypedBracket{}) = notHandled (ThExpressionForm e)+repE e@(HsProc{}) = notHandled (ThExpressionForm e)  {- Note [Quotation and rebindable syntax] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1712,19 +1731,19 @@   where     rep_fld :: LHsRecField GhcRn (LHsExpr GhcRn)             -> MetaM (Core (M TH.FieldExp))-    rep_fld (L _ fld) = do { fn <- lookupLOcc (hsRecFieldSel fld)-                           ; e  <- repLE (hsRecFieldArg fld)+    rep_fld (L _ fld) = do { fn <- lookupOcc (hsRecFieldSel fld)+                           ; e  <- repLE (hfbRHS fld)                            ; repFieldExp fn e }  repUpdFields :: [LHsRecUpdField GhcRn] -> MetaM (Core [M TH.FieldExp]) repUpdFields = repListM fieldExpTyConName rep_fld   where     rep_fld :: LHsRecUpdField GhcRn -> MetaM (Core (M TH.FieldExp))-    rep_fld (L l fld) = case unLoc (hsRecFieldLbl fld) of+    rep_fld (L l fld) = case unLoc (hfbLHS fld) of       Unambiguous sel_name _ -> do { fn <- lookupLOcc (L l sel_name)-                                   ; e  <- repLE (hsRecFieldArg fld)+                                   ; e  <- repLE (hfbRHS fld)                                    ; repFieldExp fn e }-      Ambiguous{}            -> notHandled "Ambiguous record updates" (ppr fld)+      Ambiguous{}            -> notHandled (ThAmbiguousRecordUpdates fld)   @@ -1800,12 +1819,12 @@        -- Bring all of binders in the recursive group into scope for the        -- whole group.        ; (ss1_other,rss) <- addBinds ss1 $ repSts (map unLoc (unLoc $ recS_stmts stmt))-       ; MASSERT(sort ss1 == sort ss1_other)+       ; massert (sort ss1 == sort ss1_other)        ; z <- repRecSt (nonEmptyCoreList rss)        ; (ss2,zs) <- addBinds ss1 (repSts ss)        ; return (ss1++ss2, z : zs) } repSts []    = return ([],[])-repSts other = notHandled "Exotic statement" (ppr other)+repSts other = notHandled (ThExoticStatement other)   -----------------------------------------------------------@@ -1838,11 +1857,8 @@         ; return (ss, core_list) }  rep_implicit_param_bind :: LIPBind GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))-rep_implicit_param_bind (L loc (IPBind _ ename (L _ rhs)))- = do { name <- case ename of-                    Left (L _ n) -> rep_implicit_param_name n-                    Right _ ->-                        panic "rep_implicit_param_bind: post typechecking"+rep_implicit_param_bind (L loc (IPBind _ (L _ n) (L _ rhs)))+ = do { name <- rep_implicit_param_name n       ; rhs' <- repE rhs       ; ipb <- repImplicitParamBind name rhs'       ; return (locA loc, ipb) }@@ -1908,7 +1924,6 @@         ; ans <- repVal patcore x empty_decls         ; return (srcLocSpan (getSrcLoc v), ans) } -rep_bind (L _ (AbsBinds {}))  = panic "rep_bind: AbsBinds" rep_bind (L loc (PatSynBind _ (PSB { psb_id   = syn                                    , psb_args = args                                    , psb_def  = pat@@ -1934,7 +1949,7 @@     mkGenArgSyms (InfixCon arg1 arg2) = mkGenSyms [unLoc arg1, unLoc arg2]     mkGenArgSyms (RecCon fields)       = do { let pats = map (unLoc . recordPatSynPatVar) fields-                 sels = map (extFieldOcc . recordPatSynField) fields+                 sels = map (foExt . recordPatSynField) fields            ; ss <- mkGenSyms sels            ; return $ replaceNames (zip sels pats) ss } @@ -1964,7 +1979,7 @@        ; arg2' <- lookupLOcc arg2        ; repInfixPatSynArgs arg1' arg2' } repPatSynArgs (RecCon fields)-  = do { sels' <- repList nameTyConName (lookupOcc . extFieldOcc) sels+  = do { sels' <- repList nameTyConName (lookupOcc . foExt) sels        ; repRecordPatSynArgs sels' }   where sels = map recordPatSynField fields @@ -2023,7 +2038,7 @@                 do { xs <- repLPs ps; body <- repLE e; repLam xs body })       ; wrapGenSyms ss lam } -repLambda (L _ m) = notHandled "Guarded lambdas" (pprMatch m)+repLambda (L _ m) = notHandled (ThGuardedLambdas m)   -----------------------------------------------------------------------------@@ -2048,12 +2063,8 @@ repP (BangPat _ p)      = do { p1 <- repLP p; repPbang p1 } repP (AsPat _ x p)      = do { x' <- lookupNBinder x; p1 <- repLP p                              ; repPaspat x' p1 }-repP (ParPat _ p)       = repLP p-repP (ListPat Nothing ps)  = do { qs <- repLPs ps; repPlist qs }-repP (ListPat (Just (SyntaxExprRn e)) ps) = do { p <- repP (ListPat Nothing ps)-                                               ; e' <- repE e-                                               ; repPview e' p}-repP (ListPat _ ps) = pprPanic "repP missing SyntaxExprRn" (ppr ps)+repP (ParPat _ _ p _)   = repLP p+repP (ListPat _ ps)     = do { qs <- repLPs ps; repPlist qs } repP (TuplePat _ ps boxed)   | isBoxed boxed       = do { qs <- repLPs ps; repPtup qs }   | otherwise           = do { qs <- repLPs ps; repPunboxedTup qs }@@ -2073,18 +2084,25 @@    }  where    rep_fld :: LHsRecField GhcRn (LPat GhcRn) -> MetaM (Core (M (TH.Name, TH.Pat)))-   rep_fld (L _ fld) = do { MkC v <- lookupLOcc (hsRecFieldSel fld)-                          ; MkC p <- repLP (hsRecFieldArg fld)+   rep_fld (L _ fld) = do { MkC v <- lookupOcc (hsRecFieldSel fld)+                          ; MkC p <- repLP (hfbRHS fld)                           ; rep2 fieldPatName [v,p] } repP (NPat _ (L _ l) Nothing _) = do { a <- repOverloadedLiteral l                                      ; repPlit a } repP (ViewPat _ e p) = do { e' <- repLE e; p' <- repLP p; repPview e' p' }-repP p@(NPat _ _ (Just _) _) = notHandled "Negative overloaded patterns" (ppr p)+repP p@(NPat _ (L _ l) (Just _) _)+  | OverLitRn rebindable _ <- ol_ext l+  , rebindable = notHandled (ThNegativeOverloadedPatterns p)+  | HsIntegral i <- ol_val l = do { a <- repOverloadedLiteral l{ol_val = HsIntegral (negateIntegralLit i)}+                                  ; repPlit a }+  | HsFractional i <- ol_val l = do { a <- repOverloadedLiteral l{ol_val = HsFractional (negateFractionalLit i)}+                                  ; repPlit a }+  | otherwise = notHandled (ThExoticPattern p) repP (SigPat _ p t) = do { p' <- repLP p                          ; t' <- repLTy (hsPatSigType t)                          ; repPsig p' t' } repP (SplicePat _ splice) = repSplice splice-repP other = notHandled "Exotic pattern" (ppr other)+repP other = notHandled (ThExoticPattern other)  ---------------------------------------------------------- -- Declaration ordering helpers@@ -2173,10 +2191,11 @@         ; rep2_nwDsM mk_varg [pkg,mod,occ] }   | otherwise   = do  { MkC occ <- nameLit name-        ; MkC uni <- coreIntegerLit (toInteger $ getKey (getUnique name))+        ; platform <- targetPlatform <$> getDynFlags+        ; let uni = mkIntegerExpr platform (toInteger $ getKey (getUnique name))         ; rep2_nwDsM mkNameLName [occ,uni] }   where-      mod = ASSERT( isExternalName name) nameModule name+      mod = assert (isExternalName name) nameModule name       name_mod = moduleNameString (moduleName mod)       name_pkg = unitString (moduleUnit mod)       name_occ = nameOccName name@@ -2355,6 +2374,9 @@ repLamCase :: Core [(M TH.Match)] -> MetaM (Core (M TH.Exp)) repLamCase (MkC ms) = rep2 lamCaseEName [ms] +repLamCases :: Core [(M TH.Clause)] -> MetaM (Core (M TH.Exp))+repLamCases (MkC ms) = rep2 lamCasesEName [ms]+ repTup :: Core [Maybe (M TH.Exp)] -> MetaM (Core (M TH.Exp)) repTup (MkC es) = rep2 tupEName [es] @@ -2591,6 +2613,9 @@ repPragInl (MkC nm) (MkC inline) (MkC rm) (MkC phases)   = rep2 pragInlDName [nm, inline, rm, phases] +repPragOpaque :: Core TH.Name -> MetaM (Core (M TH.Dec))+repPragOpaque (MkC nm) = rep2 pragOpaqueDName [nm]+ repPragSpec :: Core TH.Name -> Core (M TH.Type) -> Core TH.Phases             -> MetaM (Core (M TH.Dec)) repPragSpec (MkC nm) (MkC ty) (MkC phases)@@ -2672,6 +2697,7 @@              arg_tys <- repPrefixConArgs ps              rep2 normalCName [unC con', unC arg_tys]            InfixCon st1 st2 -> do+             verifyLinearFields [st1, st2]              arg1 <- repBangTy (hsScaledThing st1)              arg2 <- repBangTy (hsScaledThing st2)              rep2 infixCName [unC arg1, unC con', unC arg2]@@ -2690,16 +2716,32 @@              arg_tys <- repPrefixConArgs ps              res_ty' <- repLTy res_ty              rep2 gadtCName [ unC (nonEmptyCoreList cons'), unC arg_tys, unC res_ty']-           RecConGADT ips -> do+           RecConGADT ips _ -> do              arg_vtys <- repRecConArgs ips              res_ty'  <- repLTy res_ty              rep2 recGadtCName [unC (nonEmptyCoreList cons'), unC arg_vtys,                                 unC res_ty'] +-- TH currently only supports linear constructors.+-- We also accept the (->) arrow when -XLinearTypes is off, because this+-- denotes a linear field.+-- This check is not performed in repRecConArgs, since the GADT record+-- syntax currently does not have a way to mark fields as nonlinear.+verifyLinearFields :: [HsScaled GhcRn (LHsType GhcRn)] -> MetaM ()+verifyLinearFields ps = do+  linear <- lift $ xoptM LangExt.LinearTypes+  let allGood = all (\st -> case hsMult st of+                              HsUnrestrictedArrow _ -> not linear+                              HsLinearArrow _       -> True+                              _                     -> False) ps+  unless allGood $ notHandled ThNonLinearDataCon+ -- Desugar the arguments in a data constructor declared with prefix syntax. repPrefixConArgs :: [HsScaled GhcRn (LHsType GhcRn)]                  -> MetaM (Core [M TH.BangType])-repPrefixConArgs ps = repListM bangTypeTyConName repBangTy (map hsScaledThing ps)+repPrefixConArgs ps = do+  verifyLinearFields ps+  repListM bangTypeTyConName repBangTy (map hsScaledThing ps)  -- Desugar the arguments in a data constructor declared with record syntax. repRecConArgs :: LocatedL [LConDeclField GhcRn]@@ -2711,7 +2753,7 @@       rep_ip (L _ ip) = mapM (rep_one_ip (cd_fld_type ip)) (cd_fld_names ip)        rep_one_ip :: LBangType GhcRn -> LFieldOcc GhcRn -> MetaM (Core (M TH.VarBangType))-      rep_one_ip t n = do { MkC v  <- lookupOcc (extFieldOcc $ unLoc n)+      rep_one_ip t n = do { MkC v  <- lookupOcc (foExt $ unLoc n)                           ; MkC ty <- repBangTy  t                           ; rep2 varBangTypeName [v,ty] } @@ -2848,7 +2890,7 @@        lit_expr <- lift $ dsLit lit'        case mb_lit_name of           Just lit_name -> rep2_nw lit_name [lit_expr]-          Nothing -> notHandled "Exotic literal" (ppr lit)+          Nothing -> notHandled (ThExoticLiteral lit)   where     mb_lit_name = case lit of                  HsInteger _ _ _  -> Just integerLName@@ -3020,22 +3062,16 @@ coreIntLit i = do platform <- getPlatform                   return (MkC (mkIntExprInt platform i)) -coreIntegerLit :: MonadThings m => Integer -> m (Core Integer)-coreIntegerLit i = pure (MkC (mkIntegerExpr i))- coreVar :: Id -> Core TH.Name   -- The Id has type Name coreVar id = MkC (Var id)  ----------------- Failure ------------------------notHandledL :: SrcSpan -> String -> SDoc -> MetaM a-notHandledL loc what doc+notHandledL :: SrcSpan -> ThRejectionReason -> MetaM a+notHandledL loc reason   | isGoodSrcSpan loc-  = mapReaderT (putSrcSpanDs loc) $ notHandled what doc+  = mapReaderT (putSrcSpanDs loc) $ notHandled reason   | otherwise-  = notHandled what doc+  = notHandled reason -notHandled :: String -> SDoc -> MetaM a-notHandled what doc = lift $ failWithDs msg-  where-    msg = hang (text what <+> text "not (yet) handled by Template Haskell")-             2 doc+notHandled :: ThRejectionReason -> MetaM a+notHandled reason = lift $ failWithDs (DsNotYetHandledByTH reason)
GHC/HsToCore/Types.hs view
@@ -6,9 +6,12 @@         DsMetaEnv, DsMetaVal(..), CompleteMatches     ) where +import GHC.Prelude (Int)+ import Data.IORef  import GHC.Types.CostCentre.State+import GHC.Types.Error import GHC.Types.Name.Env import GHC.Types.SrcLoc import GHC.Types.Var@@ -16,9 +19,9 @@ import GHC.Hs (LForeignDecl, HsExpr, GhcTc) import GHC.Tc.Types (TcRnIf, IfGblEnv, IfLclEnv, CompleteMatches) import GHC.HsToCore.Pmc.Types (Nablas)+import GHC.HsToCore.Errors.Types import GHC.Core (CoreExpr) import GHC.Core.FamInstEnv-import GHC.Utils.Error import GHC.Utils.Outputable as Outputable import GHC.Unit.Module import GHC.Driver.Hooks (DsForeignsHook)@@ -47,13 +50,15 @@                                           -- constructors are in scope during                                           -- pattern-match satisfiability checking   , ds_unqual  :: PrintUnqualified-  , ds_msgs    :: IORef (Messages DecoratedSDoc) -- Warning messages+  , ds_msgs    :: IORef (Messages DsMessage) -- Diagnostic messages   , ds_if_env  :: (IfGblEnv, IfLclEnv)    -- Used for looking up global,                                           -- possibly-imported things   , ds_complete_matches :: CompleteMatches      -- Additional complete pattern matches   , ds_cc_st   :: IORef CostCentreState      -- Tracking indices for cost centre annotations+  , ds_next_wrapper_num :: IORef (ModuleEnv Int)+    -- ^ See Note [Generating fresh names for FFI wrappers]   }  instance ContainsModule DsGblEnv where@@ -65,7 +70,7 @@   { dsl_meta    :: DsMetaEnv   -- ^ Template Haskell bindings   , dsl_loc     :: RealSrcSpan -- ^ To put in pattern-matching error msgs   , dsl_nablas  :: Nablas-  -- ^ See Note [Note [Long-distance information] in "GHC.HsToCore.Pmc".+  -- ^ See Note [Long-distance information] in "GHC.HsToCore.Pmc".   -- The set of reaching values Nablas is augmented as we walk inwards, refined   -- through each pattern match in turn   }@@ -80,7 +85,7 @@                        -- The Id has type THSyntax.Var    | DsSplice (HsExpr GhcTc) -- These bindings are introduced by-                            -- the PendingSplices on a HsBracketOut+                            -- the PendingSplices on a Hs*Bracket  -- | Desugaring monad. See also 'TcM'. type DsM = TcRnIf DsGblEnv DsLclEnv
GHC/HsToCore/Usage.hs view
@@ -1,21 +1,17 @@-{-# LANGUAGE CPP #-} + {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}  module GHC.HsToCore.Usage (     -- * Dependency/fingerprinting code (used by GHC.Iface.Make)-    mkUsageInfo, mkUsedNames, mkDependencies+    mkUsageInfo, mkUsedNames,     ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Driver.Env import GHC.Driver.Session -import GHC.Platform-import GHC.Platform.Ways  import GHC.Tc.Types @@ -25,29 +21,26 @@ import GHC.Utils.Panic  import GHC.Types.Name-import GHC.Types.Name.Set+import GHC.Types.Name.Set ( NameSet, allUses ) import GHC.Types.Unique.Set-import GHC.Types.Unique.FM  import GHC.Unit import GHC.Unit.External-import GHC.Unit.State-import GHC.Unit.Finder import GHC.Unit.Module.Imported import GHC.Unit.Module.ModIface import GHC.Unit.Module.Deps  import GHC.Data.Maybe -import Control.Monad (filterM)-import Data.List (sort, sortBy, nub)-import Data.IORef+import Data.List (sortBy) import Data.Map (Map) import qualified Data.Map as Map-import qualified Data.Set as Set-import System.Directory-import System.FilePath +import GHC.Linker.Types+import GHC.Unit.Finder+import GHC.Types.Unique.DFM+import GHC.Driver.Plugins+ {- Note [Module self-dependency]    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -67,75 +60,29 @@  -} --- | Extract information from the rename and typecheck phases to produce--- a dependencies information for the module being compiled.------ The second argument is additional dependencies from plugins-mkDependencies :: UnitId -> [Module] -> TcGblEnv -> IO Dependencies-mkDependencies iuid pluginModules-          (TcGblEnv{ tcg_mod = mod,-                    tcg_imports = imports,-                    tcg_th_used = th_var-                  })- = do-      -- Template Haskell used?-      let (dep_plgins, ms) = unzip [ (moduleName mn, mn) | mn <- pluginModules ]-          plugin_dep_pkgs = filter (/= iuid) (map (toUnitId . moduleUnit) ms)-      th_used <- readIORef th_var-      let dep_mods = modDepsElts (delFromUFM (imp_dep_mods imports)-                                             (moduleName mod))-                -- M.hi-boot can be in the imp_dep_mods, but we must remove-                -- it before recording the modules on which this one depends!-                -- (We want to retain M.hi-boot in imp_dep_mods so that-                --  loadHiBootInterface can see if M's direct imports depend-                --  on M.hi-boot, and hence that we should do the hi-boot consistency-                --  check.)--          dep_orphs = filter (/= mod) (imp_orphs imports)-                -- We must also remove self-references from imp_orphs. See-                -- Note [Module self-dependency]--          raw_pkgs = foldr Set.insert (imp_dep_pkgs imports) plugin_dep_pkgs--          pkgs | th_used   = Set.insert thUnitId raw_pkgs-               | otherwise = raw_pkgs--          -- Set the packages required to be Safe according to Safe Haskell.-          -- See Note [Tracking Trust Transitively] in GHC.Rename.Names-          sorted_pkgs = sort (Set.toList pkgs)-          trust_pkgs  = imp_trust_pkgs imports-          dep_pkgs'   = map (\x -> (x, x `Set.member` trust_pkgs)) sorted_pkgs--      return Deps { dep_mods   = dep_mods,-                    dep_pkgs   = dep_pkgs',-                    dep_orphs  = dep_orphs,-                    dep_plgins = dep_plgins,-                    dep_finsts = sortBy stableModuleCmp (imp_finsts imports) }-                    -- sort to get into canonical order-                    -- NB. remember to use lexicographic ordering- mkUsedNames :: TcGblEnv -> NameSet mkUsedNames TcGblEnv{ tcg_dus = dus } = allUses dus  mkUsageInfo :: HscEnv -> Module -> ImportedMods -> NameSet -> [FilePath]-            -> [(Module, Fingerprint)] -> [ModIface] -> IO [Usage]-mkUsageInfo hsc_env this_mod dir_imp_mods used_names dependent_files merged-  pluginModules+            -> [(Module, Fingerprint)] -> [Linkable] -> PkgsLoaded -> IO [Usage]+mkUsageInfo hsc_env this_mod dir_imp_mods used_names dependent_files merged needed_links needed_pkgs   = do     eps <- hscEPS hsc_env     hashes <- mapM getFileHash dependent_files-    plugin_usages <- mapM (mkPluginUsage hsc_env) pluginModules+    -- Dependencies on object files due to TH and plugins+    object_usages <- mkObjectUsage (eps_PIT eps) hsc_env needed_links needed_pkgs     let mod_usages = mk_mod_usage_info (eps_PIT eps) hsc_env this_mod                                        dir_imp_mods used_names         usages = mod_usages ++ [ UsageFile { usg_file_path = f-                                           , usg_file_hash = hash }+                                           , usg_file_hash = hash+                                           , usg_file_label = Nothing }                                | (f, hash) <- zip dependent_files hashes ]                             ++ [ UsageMergedRequirement                                     { usg_mod = mod,                                       usg_mod_hash = hash                                     }                                | (mod, hash) <- merged ]-                            ++ concat plugin_usages+                            ++ object_usages     usages `seqList` return usages     -- seq the list of Usages returned: occasionally these     -- don't get evaluated for a while and we can end up hanging on to@@ -177,80 +124,63 @@     of the module and the implementation hashes of its dependencies, and then     compare implementation hashes for recompilation. Creation of implementation     hashes is however potentially expensive.++    A serious issue with the interface hash idea is that if you include an+    interface hash, that hash also needs to depend on the hash of its+    dependencies. Therefore, if any of the transitive dependencies of a modules+    gets updated then you need to recompile the module in case the interface+    hash has changed irrespective if the module uses TH or not.++    This is important to maintain the invariant that the information in the+    interface file is always up-to-date.+++    See #20790 (comment 3) -}-mkPluginUsage :: HscEnv -> ModIface -> IO [Usage]-mkPluginUsage hsc_env pluginModule-  = case lookupPluginModuleWithSuggestions pkgs pNm Nothing of-    LookupFound _ (pkg, _) -> do-    -- The plugin is from an external package:-    -- search for the library files containing the plugin.-      let searchPaths = collectLibraryDirs (ways dflags) [pkg]-          useDyn = WayDyn `elem` ways dflags-          suffix = if useDyn then platformSOExt platform else "a"-          libLocs = [ searchPath </> "lib" ++ libLoc <.> suffix-                    | searchPath <- searchPaths-                    , libLoc     <- unitHsLibs (ghcNameVersion dflags) (ways dflags) pkg-                    ]-          -- we also try to find plugin library files by adding WayDyn way,-          -- if it isn't already present (see trac #15492)-          paths =-            if useDyn-              then libLocs-              else-                let dflags'  = dflags { targetWays_ = addWay WayDyn (targetWays_ dflags) }-                    dlibLocs = [ searchPath </> platformHsSOName platform dlibLoc-                               | searchPath <- searchPaths-                               , dlibLoc    <- unitHsLibs (ghcNameVersion dflags') (ways dflags') pkg-                               ]-                in libLocs ++ dlibLocs-      files <- filterM doesFileExist paths-      case files of-        [] ->-          pprPanic-             ( "mkPluginUsage: missing plugin library, tried:\n"-              ++ unlines paths-             )-             (ppr pNm)-        _  -> mapM hashFile (nub files)-    _ -> do-      foundM <- findPluginModule hsc_env pNm-      case foundM of-      -- The plugin was built locally: look up the object file containing-      -- the `plugin` binder, and all object files belong to modules that are-      -- transitive dependencies of the plugin that belong to the same package.-        Found ml _ -> do-          pluginObject <- hashFile (ml_obj_file ml)-          depObjects   <- catMaybes <$> mapM lookupObjectFile deps-          return (nub (pluginObject : depObjects))-        _ -> pprPanic "mkPluginUsage: no object file found" (ppr pNm)++{-+Note [Object File Dependencies]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In addition to the Note [Plugin dependencies] above, for TH we also need to record+the hashes of object files that the TH code is required to load. These are+calculated by the loader in `getLinkDeps` and are accumulated in each individual+`TcGblEnv`, in `tcg_th_needed_deps`. We read this just before compute the UsageInfo+to inject the appropriate dependencies.+-}++-- | Find object files corresponding to the transitive closure of given home+-- modules and direct object files for pkg dependencies+mkObjectUsage :: PackageIfaceTable -> HscEnv -> [Linkable] -> PkgsLoaded -> IO [Usage]+mkObjectUsage pit hsc_env th_links_needed th_pkgs_needed = do+      let ls = ordNubOn linkableModule  (th_links_needed ++ plugins_links_needed)+          ds = concatMap loaded_pkg_hs_objs $ eltsUDFM (plusUDFM th_pkgs_needed plugin_pkgs_needed) -- TODO possibly record loaded_pkg_non_hs_objs as well+          (plugins_links_needed, plugin_pkgs_needed) = loadedPluginDeps $ hsc_plugins hsc_env+      concat <$> sequence (map linkableToUsage ls ++ map librarySpecToUsage ds)   where-    dflags   = hsc_dflags hsc_env-    platform = targetPlatform dflags-    pkgs     = hsc_units hsc_env-    pNm      = moduleName $ mi_module pluginModule-    pPkg     = moduleUnit $ mi_module pluginModule-    deps     = map gwib_mod $-      dep_mods $ mi_deps pluginModule+    linkableToUsage (LM _ m uls) = mapM (unlinkedToUsage m) uls -    -- Lookup object file for a plugin dependency,-    -- from the same package as the plugin.-    lookupObjectFile nm = do-      foundM <- findImportedModule hsc_env nm Nothing-      case foundM of-        Found ml m-          | moduleUnit m == pPkg -> Just <$> hashFile (ml_obj_file ml)-          | otherwise              -> return Nothing-        _ -> pprPanic "mkPluginUsage: no object for dependency"-                      (ppr pNm <+> ppr nm)+    msg m = moduleNameString (moduleName m) ++ "[TH] changed" -    hashFile f = do-      fExist <- doesFileExist f-      if fExist-         then do-            h <- getFileHash f-            return (UsageFile f h)-         else pprPanic "mkPluginUsage: file not found" (ppr pNm <+> text f)+    fing mmsg fn = UsageFile fn <$> lookupFileCache (hsc_FC hsc_env) fn <*> pure mmsg +    unlinkedToUsage m ul =+      case nameOfObject_maybe ul of+        Just fn -> fing (Just (msg m)) fn+        Nothing ->  do+          -- This should only happen for home package things but oneshot puts+          -- home package ifaces in the PIT.+          let miface = lookupIfaceByModule (hsc_HUG hsc_env) pit m+          case miface of+            Nothing -> pprPanic "mkObjectUsage" (ppr m)+            Just iface ->+              return $ UsageHomeModuleInterface (moduleName m) (mi_iface_hash (mi_final_exts iface))++    librarySpecToUsage :: LibrarySpec -> IO [Usage]+    librarySpecToUsage (Objects os) = traverse (fing Nothing) os+    librarySpecToUsage (Archive fn) = traverse (fing Nothing) [fn]+    librarySpecToUsage (DLLPath fn) = traverse (fing Nothing) [fn]+    librarySpecToUsage _ = return []+ mk_mod_usage_info :: PackageIfaceTable               -> HscEnv               -> Module@@ -260,7 +190,7 @@ mk_mod_usage_info pit hsc_env this_mod direct_imports used_names   = mapMaybe mkUsage usage_mods   where-    hpt = hsc_HPT hsc_env+    hpt = hsc_HUG hsc_env     dflags = hsc_dflags hsc_env     home_unit = hsc_home_unit hsc_env @@ -282,7 +212,7 @@         | isWiredInName name = mv_map  -- ignore wired-in names         | otherwise         = case nameModule_maybe name of-             Nothing  -> ASSERT2( isSystemName name, ppr name ) mv_map+             Nothing  -> assertPpr (isSystemName name) (ppr name) mv_map                 -- See Note [Internal used_names]               Just mod ->
GHC/HsToCore/Utils.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE TypeFamilies #-}@@ -45,15 +44,13 @@         isTrueLHsExpr     ) where -#include "HsVersions.h"- import GHC.Prelude  import {-# SOURCE #-} GHC.HsToCore.Match ( matchSimply ) import {-# SOURCE #-} GHC.HsToCore.Expr  ( dsLExpr, dsSyntaxExpr )  import GHC.Hs-import GHC.Tc.Utils.Zonk+import GHC.Hs.Syn.Type import GHC.Tc.Utils.TcType( tcSplitTyConApp ) import GHC.Core import GHC.HsToCore.Monad@@ -78,6 +75,7 @@ import GHC.Types.Name( isInternalName ) import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Types.SrcLoc import GHC.Types.Tickish import GHC.Utils.Misc@@ -133,10 +131,10 @@  selectMatchVar :: Mult -> Pat GhcTc -> DsM Id -- Postcondition: the returned Id has an Internal Name-selectMatchVar w (BangPat _ pat) = selectMatchVar w (unLoc pat)-selectMatchVar w (LazyPat _ pat) = selectMatchVar w (unLoc pat)-selectMatchVar w (ParPat _ pat)  = selectMatchVar w (unLoc pat)-selectMatchVar _w (VarPat _ var)  = return (localiseId (unLoc var))+selectMatchVar w (BangPat _ pat)    = selectMatchVar w (unLoc pat)+selectMatchVar w (LazyPat _ pat)    = selectMatchVar w (unLoc pat)+selectMatchVar w (ParPat _ _ pat _) = selectMatchVar w (unLoc pat)+selectMatchVar _w (VarPat _ var)    = return (localiseId (unLoc var))                                   -- Note [Localise pattern binders]                                   --                                   -- Remark: when the pattern is a variable (or@@ -144,8 +142,8 @@                                   -- multiplicity stored within the variable                                   -- itself. It's easier to pull it from the                                   -- variable, so we ignore the multiplicity.-selectMatchVar _w (AsPat _ var _) = ASSERT( isManyDataConTy _w ) (return (unLoc var))-selectMatchVar w other_pat     = newSysLocalDsNoLP w (hsPatType other_pat)+selectMatchVar _w (AsPat _ var _) = assert (isManyDataConTy _w ) (return (unLoc var))+selectMatchVar w other_pat        = newSysLocalDs w (hsPatType other_pat)  {- Note [Localise pattern binders] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -184,7 +182,7 @@ runs on the output of the desugarer, so all is well by the end of the desugaring pass. -See also Note [MatchIds] in GHC.HsToCore.Match+See also Note [Match Ids] in GHC.HsToCore.Match  ************************************************************************ *                                                                      *@@ -198,7 +196,7 @@ -}  firstPat :: EquationInfo -> Pat GhcTc-firstPat eqn = ASSERT( notNull (eqn_pats eqn) ) head (eqn_pats eqn)+firstPat eqn = assert (notNull (eqn_pats eqn)) $ head (eqn_pats eqn)  shiftEqns :: Functor f => f EquationInfo -> f EquationInfo -- Drop the first pattern in each equation@@ -283,7 +281,7 @@      sorted_alts = sortWith fst match_alts       -- Right order for a Case     mk_alt fail (lit, mr)-       = ASSERT( not (litIsLifted lit) )+       = assert (not (litIsLifted lit)) $          do body <- runMatchResult fail mr             return (Alt (LitAlt lit) [] body) @@ -299,7 +297,7 @@   -> MatchResult CoreExpr mkCoAlgCaseMatchResult var ty match_alts   | isNewtype  -- Newtype case; use a let-  = ASSERT( null match_alts_tail && null (tail arg_ids1) )+  = assert (null match_alts_tail && null (tail arg_ids1)) $     mkCoLetMatchResult (NonRec arg_id1 newtype_rhs) match_result1    | otherwise@@ -313,7 +311,7 @@     alt1@MkCaseAlt{ alt_bndrs = arg_ids1, alt_result = match_result1 } :| match_alts_tail       = match_alts     -- Stuff for newtype-    arg_id1       = ASSERT( notNull arg_ids1 ) head arg_ids1+    arg_id1       = assert (notNull arg_ids1) $ head arg_ids1     var_ty        = idType var     (tc, ty_args) = tcSplitTyConApp var_ty      -- Don't look through newtypes                                                 -- (not that splitTyConApp does, these days)@@ -406,11 +404,10 @@ mkErrorAppDs err_id ty msg = do     src_loc <- getSrcSpanDs     dflags <- getDynFlags-    let-        full_msg = showSDoc dflags (hcat [ppr src_loc, vbar, msg])-        core_msg = Lit (mkLitString full_msg)-        -- mkLitString returns a result of type String#-    return (mkApps (Var err_id) [Type (getRuntimeRep ty), Type ty, core_msg])+    let full_msg = showSDoc dflags (hcat [ppr src_loc, vbar, msg])+        fail_expr = mkRuntimeErrorApp err_id unitTy full_msg+    return $ mkWildCase fail_expr (unrestricted unitTy) ty []+    -- See Note [Incompleteness and linearity]  {- Note [Incompleteness and linearity]@@ -427,15 +424,15 @@ Instead, we use 'f x False = case error "Non-exhausive pattern..." :: () of {}'. This case expression accounts for linear variables by assigning bottom usage (See Note [Bottom as a usage] in GHC.Core.Multiplicity).-This is done in mkFailExpr.+This is done in mkErrorAppDs, called from mkFailExpr. We use '()' instead of the original return type ('a' in this case)-because there might be levity polymorphism, e.g. in+because there might be representation polymorphism, e.g. in  g :: forall (a :: TYPE r). (() -> a) %1 -> Bool -> a g x True = x ()  adding 'g x False = case error "Non-exhaustive pattern" :: a of {}'-would create an illegal levity-polymorphic case binder.+would create an illegal representation-polymorphic case binder. This is important for pattern synonym matchers, which often look like this 'g'.  Similarly, a hole@@ -459,9 +456,7 @@  mkFailExpr :: HsMatchContext GhcRn -> Type -> DsM CoreExpr mkFailExpr ctxt ty-  = do fail_expr <- mkErrorAppDs pAT_ERROR_ID unitTy (matchContextErrString ctxt)-       return $ mkWildCase fail_expr (unrestricted unitTy) ty []-       -- See Note [Incompleteness and linearity]+  = mkErrorAppDs pAT_ERROR_ID ty (matchContextErrString ctxt)  {- 'mkCoreAppDs' and 'mkCoreAppsDs' handle the special-case desugaring of 'seq'.@@ -530,14 +525,14 @@   3. (as described in #2409) -    The isLocalId ensures that we don't turn+    The isInternalName ensures that we don't turn             True `seq` e     into             case True of True { ... }     which stupidly tries to bind the datacon 'True'. -} --- NB: Make sure the argument is not levity polymorphic+-- NB: Make sure the argument is not representation-polymorphic mkCoreAppDs  :: SDoc -> CoreExpr -> CoreExpr -> CoreExpr mkCoreAppDs _ (Var f `App` Type _r `App` Type ty1 `App` Type ty2 `App` arg1) arg2   | f `hasKey` seqIdKey            -- Note [Desugaring seq], points (1) and (2)@@ -557,7 +552,7 @@  mkCoreAppDs s fun arg = mkCoreApp s fun arg  -- The rest is done in GHC.Core.Make --- NB: No argument can be levity polymorphic+-- NB: No argument can be representation-polymorphic mkCoreAppsDs :: SDoc -> CoreExpr -> [CoreExpr] -> CoreExpr mkCoreAppsDs s fun args = foldl' (mkCoreAppDs s) fun args @@ -744,7 +739,7 @@    | is_flat_prod_lpat pat'           -- Special case (B)   = do { let pat_ty = hsLPatType pat'-       ; val_var <- newSysLocalDsNoLP Many pat_ty+       ; val_var <- newSysLocalDs Many pat_ty         ; let mk_bind tick bndr_var                -- (mk_bind sv bv)  generates  bv = case sv of { pat -> bv }@@ -786,7 +781,7 @@  strip_bangs :: LPat (GhcPass p) -> LPat (GhcPass p) -- Remove outermost bangs and parens-strip_bangs (L _ (ParPat _ p))  = strip_bangs p+strip_bangs (L _ (ParPat _ _ p _))  = strip_bangs p strip_bangs (L _ (BangPat _ p)) = strip_bangs p strip_bangs lp                  = lp @@ -795,7 +790,7 @@ is_flat_prod_lpat = is_flat_prod_pat . unLoc  is_flat_prod_pat :: Pat GhcTc -> Bool-is_flat_prod_pat (ParPat _ p)          = is_flat_prod_lpat p+is_flat_prod_pat (ParPat _ _ p _)      = is_flat_prod_lpat p is_flat_prod_pat (TuplePat _ ps Boxed) = all is_triv_lpat ps is_flat_prod_pat (ConPat { pat_con  = L _ pcon                          , pat_args = ps})@@ -812,7 +807,7 @@ is_triv_pat :: Pat (GhcPass p) -> Bool is_triv_pat (VarPat {})  = True is_triv_pat (WildPat{})  = True-is_triv_pat (ParPat _ p) = is_triv_lpat p+is_triv_pat (ParPat _ _ p _) = is_triv_lpat p is_triv_pat _            = False  @@ -964,7 +959,7 @@ the tail call property.  For example, see #3403. -} -dsHandleMonadicFailure :: HsStmtContext GhcRn -> LPat GhcTc -> MatchResult CoreExpr -> FailOperator GhcTc -> DsM CoreExpr+dsHandleMonadicFailure :: HsDoFlavour -> LPat GhcTc -> MatchResult CoreExpr -> FailOperator GhcTc -> DsM CoreExpr     -- In a do expression, pattern-match failure just calls     -- the monadic 'fail' rather than throwing an exception dsHandleMonadicFailure ctx pat match m_fail_op =@@ -985,9 +980,9 @@       fail_expr <- dsSyntaxExpr fail_op [fail_msg]       body fail_expr -mk_fail_msg :: DynFlags -> HsStmtContext GhcRn -> LocatedA e -> String+mk_fail_msg :: DynFlags -> HsDoFlavour -> LocatedA e -> String mk_fail_msg dflags ctx pat-  = showPpr dflags $ text "Pattern match failure in" <+> pprStmtContext ctx+  = showPpr dflags $ text "Pattern match failure in" <+> pprHsDoFlavour ctx                    <+> text "at" <+> ppr (getLocA pat)  {- *********************************************************************@@ -1062,7 +1057,7 @@   where     go lp@(L l p)       = case p of-           ParPat x p    -> L l (ParPat x (go p))+           ParPat x lpar p rpar -> L l (ParPat x lpar (go p) rpar)            LazyPat _ lp' -> lp'            BangPat _ _   -> lp            _             -> L l (BangPat noExtField lp)@@ -1080,19 +1075,19 @@      || v `hasKey` getUnique trueDataConId                                               = Just return         -- trueDataConId doesn't have the same unique as trueDataCon-isTrueLHsExpr (L _ (HsConLikeOut _ con))+isTrueLHsExpr (L _ (XExpr (ConLikeTc con _ _)))   | con `hasKey` getUnique trueDataCon = Just return-isTrueLHsExpr (L _ (HsTick _ tickish e))+isTrueLHsExpr (L _ (XExpr (HsTick tickish e)))     | Just ticks <- isTrueLHsExpr e     = Just (\x -> do wrapped <- ticks x                      return (Tick tickish wrapped))    -- This encodes that the result is constant True for Hpc tick purposes;    -- which is specifically what isTrueLHsExpr is trying to find out.-isTrueLHsExpr (L _ (HsBinTick _ ixT _ e))+isTrueLHsExpr (L _ (XExpr (HsBinTick ixT _ e)))     | Just ticks <- isTrueLHsExpr e     = Just (\x -> do e <- ticks x                      this_mod <- getModule                      return (Tick (HpcTick this_mod ixT) e)) -isTrueLHsExpr (L _ (HsPar _ e))   = isTrueLHsExpr e-isTrueLHsExpr _                   = Nothing+isTrueLHsExpr (L _ (HsPar _ _ e _)) = isTrueLHsExpr e+isTrueLHsExpr _                     = Nothing
GHC/Iface/Binary.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE BinaryLiterals, CPP, ScopedTypeVariables, BangPatterns #-}+{-# LANGUAGE BinaryLiterals, ScopedTypeVariables, BangPatterns #-}  -- --  (c) The University of Glasgow 2002-2006@@ -13,7 +13,7 @@         -- * Public API for interface file serialisation         writeBinIface,         readBinIface,-        readBinIface_,+        readBinIfaceHeader,         getSymtabName,         getDictFastString,         CheckHiWay(..),@@ -29,46 +29,36 @@         putSymbolTable,         BinSymbolTable(..),         BinDictionary(..)-     ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Tc.Utils.Monad import GHC.Builtin.Utils   ( isKnownKeyName, lookupKnownKeyName )-import GHC.Iface.Env import GHC.Unit import GHC.Unit.Module.ModIface import GHC.Types.Name-import GHC.Driver.Session import GHC.Platform.Profile import GHC.Types.Unique.FM-import GHC.Types.Unique.Supply import GHC.Utils.Panic import GHC.Utils.Binary as Binary-import GHC.Types.SrcLoc import GHC.Data.FastMutInt import GHC.Types.Unique import GHC.Utils.Outputable import GHC.Types.Name.Cache+import GHC.Types.SrcLoc import GHC.Platform import GHC.Data.FastString import GHC.Settings.Constants-import GHC.Utils.Misc+import GHC.Utils.Fingerprint  import Data.Array-import Data.Array.ST+import Data.Array.IO import Data.Array.Unsafe import Data.Char import Data.Word import Data.IORef-import Data.Foldable import Control.Monad-import Control.Monad.ST-import Control.Monad.Trans.Class-import qualified Control.Monad.Trans.State.Strict as State  -- --------------------------------------------------------------------------- -- Reading and writing binary interface files@@ -81,20 +71,17 @@    = TraceBinIFace (SDoc -> IO ())    | QuietBinIFace --- | Read an interface file-readBinIface :: CheckHiWay -> TraceBinIFace -> FilePath-             -> TcRnIf a b ModIface-readBinIface checkHiWay traceBinIFaceReading hi_path = do-    ncu <- mkNameCacheUpdater-    dflags <- getDynFlags-    let profile = targetProfile dflags-    liftIO $ readBinIface_ profile checkHiWay traceBinIFaceReading hi_path ncu---- | Read an interface file in 'IO'.-readBinIface_ :: Profile -> CheckHiWay -> TraceBinIFace -> FilePath-              -> NameCacheUpdater-              -> IO ModIface-readBinIface_ profile checkHiWay traceBinIFace hi_path ncu = do+-- | Read an interface file header, checking the magic number, version, and+-- way. Returns the hash of the source file and a BinHandle which points at the+-- start of the rest of the interface file data.+readBinIfaceHeader+  :: Profile+  -> NameCache+  -> CheckHiWay+  -> TraceBinIFace+  -> FilePath+  -> IO (Fingerprint, BinHandle)+readBinIfaceHeader profile _name_cache checkHiWay traceBinIFace hi_path = do     let platform = profilePlatform profile          wantedGot :: String -> a -> a -> (a -> SDoc) -> IO ()@@ -135,21 +122,37 @@     when (checkHiWay == CheckHiWay) $         errorOnMismatch "mismatched interface file profile tag" tag check_tag +    src_hash <- get bh+    pure (src_hash, bh)++-- | Read an interface file.+readBinIface+  :: Profile+  -> NameCache+  -> CheckHiWay+  -> TraceBinIFace+  -> FilePath+  -> IO ModIface+readBinIface profile name_cache checkHiWay traceBinIface hi_path = do+    (src_hash, bh) <- readBinIfaceHeader profile name_cache checkHiWay traceBinIface hi_path+     extFields_p <- get bh -    mod_iface <- getWithUserData ncu bh+    mod_iface <- getWithUserData name_cache bh      seekBin bh extFields_p     extFields <- get bh -    return mod_iface{mi_ext_fields = extFields}-+    return mod_iface+      { mi_ext_fields = extFields+      , mi_src_hash = src_hash+      }  -- | This performs a get action after reading the dictionary and symbol -- table. It is necessary to run this before trying to deserialise any -- Names or FastStrings.-getWithUserData :: Binary a => NameCacheUpdater -> BinHandle -> IO a-getWithUserData ncu bh = do+getWithUserData :: Binary a => NameCache -> BinHandle -> IO a+getWithUserData name_cache bh = do     -- Read the dictionary     -- The next word in the file is a pointer to where the dictionary is     -- (probably at the end of the file)@@ -166,11 +169,11 @@         symtab_p <- Binary.get bh     -- Get the symtab ptr         data_p <- tellBin bh          -- Remember where we are now         seekBin bh symtab_p-        symtab <- getSymbolTable bh ncu+        symtab <- getSymbolTable bh name_cache         seekBin bh data_p             -- Back to where we were before          -- It is only now that we know how to get a Name-        return $ setUserData bh $ newReadState (getSymtabName ncu dict symtab)+        return $ setUserData bh $ newReadState (getSymtabName name_cache dict symtab)                                                (getDictFastString dict)      -- Read the interface file@@ -183,10 +186,11 @@     let platform = profilePlatform profile     put_ bh (binaryInterfaceMagic platform) -    -- The version and profile tag go next+    -- The version, profile tag, and source hash go next     put_ bh (show hiVersion)     let tag = profileBuildTag profile     put_  bh tag+    put_  bh (mi_src_hash mod_iface)      extFields_p_p <- tellBin bh     put_ bh extFields_p_p@@ -290,42 +294,31 @@       -- indices that array uses to create order     mapM_ (\n -> serialiseName bh n symtab) names -getSymbolTable :: BinHandle -> NameCacheUpdater -> IO SymbolTable-getSymbolTable bh ncu = do-    sz <- get bh-    od_names <- sequence (replicate sz (get bh))-    updateNameCache ncu $ \namecache ->-        runST $ flip State.evalStateT namecache $ do-            mut_arr <- lift $ newSTArray_ (0, sz-1)-            for_ (zip [0..] od_names) $ \(i, odn) -> do-                (nc, !n) <- State.gets $ \nc -> fromOnDiskName nc odn-                lift $ writeArray mut_arr i n-                State.put nc-            arr <- lift $ unsafeFreeze mut_arr-            namecache' <- State.get-            return (namecache', arr)-  where-    -- This binding is required because the type of newArray_ cannot be inferred-    newSTArray_ :: forall s. (Int, Int) -> ST s (STArray s Int Name)-    newSTArray_ = newArray_ -type OnDiskName = (Unit, ModuleName, OccName)--fromOnDiskName :: NameCache -> OnDiskName -> (NameCache, Name)-fromOnDiskName nc (pid, mod_name, occ) =-    let mod   = mkModule pid mod_name-        cache = nsNames nc-    in case lookupOrigNameCache cache  mod occ of-           Just name -> (nc, name)-           Nothing   ->-               let (uniq, us) = takeUniqFromSupply (nsUniqs nc)-                   name       = mkExternalName uniq mod occ noSrcSpan-                   new_cache  = extendNameCache cache mod occ name-               in ( nc{ nsUniqs = us, nsNames = new_cache }, name )+getSymbolTable :: BinHandle -> NameCache -> IO SymbolTable+getSymbolTable bh name_cache = do+    sz <- get bh :: IO Int+    -- create an array of Names for the symbols and add them to the NameCache+    updateNameCache' name_cache $ \cache0 -> do+        mut_arr <- newArray_ (0, sz-1) :: IO (IOArray Int Name)+        cache <- foldGet (fromIntegral sz) bh cache0 $ \i (uid, mod_name, occ) cache -> do+          let mod = mkModule uid mod_name+          case lookupOrigNameCache cache mod occ of+            Just name -> do+              writeArray mut_arr (fromIntegral i) name+              return cache+            Nothing   -> do+              uniq <- takeUniqFromNameCache name_cache+              let name      = mkExternalName uniq mod occ noSrcSpan+                  new_cache = extendOrigNameCache cache mod occ name+              writeArray mut_arr (fromIntegral i) name+              return new_cache+        arr <- unsafeFreeze mut_arr+        return (cache, arr)  serialiseName :: BinHandle -> Name -> UniqFM key (Int,Name) -> IO () serialiseName bh name _ = do-    let mod = ASSERT2( isExternalName name, ppr name ) nameModule name+    let mod = assertPpr (isExternalName name) (ppr name) (nameModule name)     put_ bh (moduleUnit mod, moduleName mod, nameOccName name)  @@ -354,7 +347,7 @@         bh name   | isKnownKeyName name   , let (c, u) = unpkUnique (nameUnique name) -- INVARIANT: (ord c) fits in 8 bits-  = -- ASSERT(u < 2^(22 :: Int))+  = -- assert (u < 2^(22 :: Int))     put_ bh (0x80000000              .|. (fromIntegral (ord c) `shiftL` 22)              .|. (fromIntegral u :: Word32))@@ -365,17 +358,17 @@          Just (off,_) -> put_ bh (fromIntegral off :: Word32)          Nothing -> do             off <- readFastMutInt symtab_next-            -- MASSERT(off < 2^(30 :: Int))+            -- massert (off < 2^(30 :: Int))             writeFastMutInt symtab_next (off+1)             writeIORef symtab_map_ref                 $! addToUFM symtab_map name (off,name)             put_ bh (fromIntegral off :: Word32)  -- See Note [Symbol table representation of names]-getSymtabName :: NameCacheUpdater+getSymtabName :: NameCache               -> Dictionary -> SymbolTable               -> BinHandle -> IO Name-getSymtabName _ncu _dict symtab bh = do+getSymtabName _name_cache _dict symtab bh = do     i :: Word32 <- get bh     case i .&. 0xC0000000 of       0x00000000 -> return $! symtab ! fromIntegral i
GHC/Iface/Env.hs view
@@ -1,12 +1,12 @@ -- (c) The University of Glasgow 2002-2006 -{-# LANGUAGE CPP, RankNTypes, BangPatterns #-}+{-# LANGUAGE RankNTypes #-}  module GHC.Iface.Env (         newGlobalBinder, newInteractiveBinder,         externaliseName,         lookupIfaceTop,-        lookupOrig, lookupOrigIO, lookupOrigNameCache, extendNameCache,+        lookupOrig, lookupNameCache, lookupOrigNameCache,         newIfaceName, newIfaceNames,         extendIfaceIdEnv, extendIfaceTyVarEnv,         tcIfaceLclId, tcIfaceTyVar, lookupIfaceVar,@@ -15,16 +15,16 @@          ifaceExportNames, +        trace_if, trace_hi_diffs,+         -- Name-cache stuff-        allocateGlobalBinder, updNameCacheTc, updNameCache,-        mkNameCacheUpdater, NameCacheUpdater(..),+        allocateGlobalBinder,    ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Driver.Env+import GHC.Driver.Session  import GHC.Tc.Utils.Monad import GHC.Core.Type@@ -45,8 +45,11 @@ import GHC.Types.SrcLoc  import GHC.Utils.Outputable+import GHC.Utils.Error+import GHC.Utils.Logger+ import Data.List     ( partition )-import Data.IORef+import Control.Monad  {- *********************************************************@@ -68,8 +71,8 @@ -- moment when we know its Module and SrcLoc in their full glory  newGlobalBinder mod occ loc-  = do { name <- updNameCacheTc mod occ $ \name_cache ->-                 allocateGlobalBinder name_cache mod occ loc+  = do { hsc_env <- getTopEnv+       ; name <- liftIO $ allocateGlobalBinder (hsc_NC hsc_env) mod occ loc        ; traceIf (text "newGlobalBinder" <+>                   (vcat [ ppr mod <+> ppr occ <+> ppr loc, ppr name]))        ; return name }@@ -77,18 +80,18 @@ newInteractiveBinder :: HscEnv -> OccName -> SrcSpan -> IO Name -- Works in the IO monad, and gets the Module -- from the interactive context-newInteractiveBinder hsc_env occ loc- = do { let mod = icInteractiveModule (hsc_IC hsc_env)-       ; updNameCacheIO hsc_env mod occ $ \name_cache ->-         allocateGlobalBinder name_cache mod occ loc }+newInteractiveBinder hsc_env occ loc = do+  let mod = icInteractiveModule (hsc_IC hsc_env)+  allocateGlobalBinder (hsc_NC hsc_env) mod occ loc  allocateGlobalBinder   :: NameCache   -> Module -> OccName -> SrcSpan-  -> (NameCache, Name)+  -> IO Name -- See Note [The Name Cache] in GHC.Types.Name.Cache-allocateGlobalBinder name_supply mod occ loc-  = case lookupOrigNameCache (nsNames name_supply) mod occ of+allocateGlobalBinder nc mod occ loc+  = updateNameCache nc mod occ $ \cache0 -> do+      case lookupOrigNameCache cache0 mod occ of         -- A hit in the cache!  We are at the binding site of the name.         -- This is the moment when we know the SrcLoc         -- of the Name, so we set this field in the Name we return.@@ -106,62 +109,26 @@         --            and their Module is correct.          Just name | isWiredInName name-                  -> (name_supply, name)+                  -> pure (cache0, name)                   | otherwise-                  -> (new_name_supply, name')+                  -> pure (new_cache, name')                   where-                    uniq            = nameUnique name-                    name'           = mkExternalName uniq mod occ loc-                                      -- name' is like name, but with the right SrcSpan-                    new_cache       = extendNameCache (nsNames name_supply) mod occ name'-                    new_name_supply = name_supply {nsNames = new_cache}+                    uniq      = nameUnique name+                    name'     = mkExternalName uniq mod occ loc+                                -- name' is like name, but with the right SrcSpan+                    new_cache = extendOrigNameCache cache0 mod occ name'          -- Miss in the cache!         -- Build a completely new Name, and put it in the cache-        _ -> (new_name_supply, name)-                  where-                    (uniq, us')     = takeUniqFromSupply (nsUniqs name_supply)-                    name            = mkExternalName uniq mod occ loc-                    new_cache       = extendNameCache (nsNames name_supply) mod occ name-                    new_name_supply = name_supply {nsUniqs = us', nsNames = new_cache}+        _ -> do+              uniq <- takeUniqFromNameCache nc+              let name      = mkExternalName uniq mod occ loc+              let new_cache = extendOrigNameCache cache0 mod occ name+              pure (new_cache, name)  ifaceExportNames :: [IfaceExport] -> TcRnIf gbl lcl [AvailInfo] ifaceExportNames exports = return exports --- | A function that atomically updates the name cache given a modifier--- function.  The second result of the modifier function will be the result--- of the IO action.-newtype NameCacheUpdater-      = NCU { updateNameCache :: forall c. (NameCache -> (NameCache, c)) -> IO c }--mkNameCacheUpdater :: TcRnIf a b NameCacheUpdater-mkNameCacheUpdater = do { hsc_env <- getTopEnv-                        ; let !ncRef = hsc_NC hsc_env-                        ; return (NCU (updNameCache ncRef)) }--updNameCacheTc :: Module -> OccName -> (NameCache -> (NameCache, c))-               -> TcRnIf a b c-updNameCacheTc mod occ upd_fn = do {-    hsc_env <- getTopEnv-  ; liftIO $ updNameCacheIO hsc_env mod occ upd_fn }---updNameCacheIO ::  HscEnv -> Module -> OccName-               -> (NameCache -> (NameCache, c))-               -> IO c-updNameCacheIO hsc_env mod occ upd_fn = do {--    -- First ensure that mod and occ are evaluated-    -- If not, chaos can ensue:-    --      we read the name-cache-    --      then pull on mod (say)-    --      which does some stuff that modifies the name cache-    -- This did happen, with tycon_mod in GHC.IfaceToCore.tcIfaceAlt (DataAlt..)--    mod `seq` occ `seq` return ()-  ; updNameCache (hsc_NC hsc_env) upd_fn }-- {- ************************************************************************ *                                                                      *@@ -174,32 +141,26 @@ -- Consider alternatively using 'lookupIfaceTop' if you're in the 'IfL' monad -- and 'Module' is simply that of the 'ModIface' you are typechecking. lookupOrig :: Module -> OccName -> TcRnIf a b Name-lookupOrig mod occ-  = do  { traceIf (text "lookup_orig" <+> ppr mod <+> ppr occ)--        ; updNameCacheTc mod occ $ lookupNameCache mod occ }--lookupOrigIO :: HscEnv -> Module -> OccName -> IO Name-lookupOrigIO hsc_env mod occ-  = updNameCacheIO hsc_env mod occ $ lookupNameCache mod occ+lookupOrig mod occ = do+  hsc_env <- getTopEnv+  traceIf (text "lookup_orig" <+> ppr mod <+> ppr occ)+  liftIO $ lookupNameCache (hsc_NC hsc_env) mod occ -lookupNameCache :: Module -> OccName -> NameCache -> (NameCache, Name)+lookupNameCache :: NameCache -> Module -> OccName -> IO Name -- Lookup up the (Module,OccName) in the NameCache -- If you find it, return it; if not, allocate a fresh original name and extend -- the NameCache. -- Reason: this may the first occurrence of (say) Foo.bar we have encountered. -- If we need to explore its value we will load Foo.hi; but meanwhile all we -- need is a Name for it.-lookupNameCache mod occ name_cache =-  case lookupOrigNameCache (nsNames name_cache) mod occ of {-    Just name -> (name_cache, name);-    Nothing   ->-        case takeUniqFromSupply (nsUniqs name_cache) of {-          (uniq, us) ->-              let-                name      = mkExternalName uniq mod occ noSrcSpan-                new_cache = extendNameCache (nsNames name_cache) mod occ name-              in (name_cache{ nsUniqs = us, nsNames = new_cache }, name) }}+lookupNameCache nc mod occ = updateNameCache nc mod occ $ \cache0 ->+  case lookupOrigNameCache cache0 mod occ of+    Just name -> pure (cache0, name)+    Nothing   -> do+      uniq <- takeUniqFromNameCache nc+      let name      = mkExternalName uniq mod occ noSrcSpan+      let new_cache = extendOrigNameCache cache0 mod occ name+      pure (new_cache, name)  externaliseName :: Module -> Name -> TcRnIf m n Name -- Take an Internal Name and make it an External one,@@ -209,10 +170,11 @@              loc = nameSrcSpan name              uniq = nameUnique name        ; occ `seq` return ()  -- c.f. seq in newGlobalBinder-       ; updNameCacheTc mod occ $ \ ns ->-         let name' = mkExternalName uniq mod occ loc-             ns'   = ns { nsNames = extendNameCache (nsNames ns) mod occ name' }-         in (ns', name') }+       ; hsc_env <- getTopEnv+       ; liftIO $ updateNameCache (hsc_NC hsc_env) mod occ $ \cache -> do+         let name'  = mkExternalName uniq mod occ loc+             cache' = extendOrigNameCache cache mod occ name'+         pure (cache', name') }  -- | Set the 'Module' of a 'Name'. setNameModule :: Maybe Module -> Name -> TcRnIf m n Name@@ -237,11 +199,11 @@         }  extendIfaceIdEnv :: [Id] -> IfL a -> IfL a-extendIfaceIdEnv ids thing_inside-  = do  { env <- getLclEnv-        ; let { id_env' = extendFsEnvList (if_id_env env) pairs-              ; pairs   = [(occNameFS (getOccName id), id) | id <- ids] }-        ; setLclEnv (env { if_id_env = id_env' }) thing_inside }+extendIfaceIdEnv ids+  = updLclEnv $ \env ->+    let { id_env' = extendFsEnvList (if_id_env env) pairs+        ; pairs   = [(occNameFS (getOccName id), id) | id <- ids] }+    in env { if_id_env = id_env' }   tcIfaceTyVar :: FastString -> IfL TyVar@@ -266,11 +228,11 @@         ; return (lookupFsEnv (if_tv_env lcl) occ) }  extendIfaceTyVarEnv :: [TyVar] -> IfL a -> IfL a-extendIfaceTyVarEnv tyvars thing_inside-  = do  { env <- getLclEnv-        ; let { tv_env' = extendFsEnvList (if_tv_env env) pairs-              ; pairs   = [(occNameFS (getOccName tv), tv) | tv <- tyvars] }-        ; setLclEnv (env { if_tv_env = tv_env' }) thing_inside }+extendIfaceTyVarEnv tyvars+  = updLclEnv $ \env ->+    let { tv_env' = extendFsEnvList (if_tv_env env) pairs+        ; pairs   = [(occNameFS (getOccName tv), tv) | tv <- tyvars] }+    in env { if_tv_env = tv_env' }  extendIfaceEnvs :: [TyCoVar] -> IfL a -> IfL a extendIfaceEnvs tcvs thing_inside@@ -304,19 +266,10 @@         ; return [ mkInternalName uniq occ noSrcSpan                  | (occ,uniq) <- occs `zip` uniqsFromSupply uniqs] } -{--Names in a NameCache are always stored as a Global, and have the SrcLoc-of their binding locations.--Actually that's not quite right.  When we first encounter the original-name, we might not be at its binding site (e.g. we are reading an-interface file); so we give it 'noSrcLoc' then.  Later, when we find-its binding site, we fix it up.--}--updNameCache :: IORef NameCache-             -> (NameCache -> (NameCache, c))  -- The updating function-             -> IO c-updNameCache ncRef upd_fn-  = atomicModifyIORef' ncRef upd_fn+trace_if :: Logger -> SDoc -> IO ()+{-# INLINE trace_if #-}+trace_if logger doc = when (logHasDumpFlag logger Opt_D_dump_if_trace) $ putMsg logger doc +trace_hi_diffs :: Logger -> SDoc -> IO ()+{-# INLINE trace_hi_diffs #-}+trace_hi_diffs logger doc = when (logHasDumpFlag logger Opt_D_dump_hi_diffs) $ putMsg logger doc
+ GHC/Iface/Errors.hs view
@@ -0,0 +1,335 @@++{-# LANGUAGE FlexibleContexts #-}++module GHC.Iface.Errors+  ( badIfaceFile+  , hiModuleNameMismatchWarn+  , homeModError+  , cannotFindInterface+  , cantFindInstalledErr+  , cannotFindModule+  , cantFindErr+  -- * Utility functions+  , mayShowLocations+  ) where++import GHC.Platform.Profile+import GHC.Platform.Ways+import GHC.Utils.Panic.Plain+import GHC.Driver.Session+import GHC.Driver.Env+import GHC.Driver.Errors.Types+import GHC.Data.Maybe+import GHC.Prelude+import GHC.Unit+import GHC.Unit.Env+import GHC.Unit.Finder.Types+import GHC.Utils.Outputable as Outputable+++badIfaceFile :: String -> SDoc -> SDoc+badIfaceFile file err+  = vcat [text "Bad interface file:" <+> text file,+          nest 4 err]++hiModuleNameMismatchWarn :: Module -> Module -> SDoc+hiModuleNameMismatchWarn requested_mod read_mod+ | moduleUnit requested_mod == moduleUnit read_mod =+    sep [text "Interface file contains module" <+> quotes (ppr read_mod) <> comma,+         text "but we were expecting module" <+> quotes (ppr requested_mod),+         sep [text "Probable cause: the source code which generated interface file",+             text "has an incompatible module name"+            ]+        ]+ | otherwise =+  -- ToDo: This will fail to have enough qualification when the package IDs+  -- are the same+  withPprStyle (mkUserStyle alwaysQualify AllTheWay) $+    -- we want the Modules below to be qualified with package names,+    -- so reset the PrintUnqualified setting.+    hsep [ text "Something is amiss; requested module "+         , ppr requested_mod+         , text "differs from name found in the interface file"+         , ppr read_mod+         , parens (text "if these names look the same, try again with -dppr-debug")+         ]++homeModError :: InstalledModule -> ModLocation -> SDoc+-- See Note [Home module load error]+homeModError mod location+  = text "attempting to use module " <> quotes (ppr mod)+    <> (case ml_hs_file location of+           Just file -> space <> parens (text file)+           Nothing   -> Outputable.empty)+    <+> text "which is not loaded"+++-- -----------------------------------------------------------------------------+-- Error messages++cannotFindInterface :: UnitState -> Maybe HomeUnit -> Profile -> ([FilePath] -> SDoc) -> ModuleName -> InstalledFindResult -> SDoc+cannotFindInterface = cantFindInstalledErr (text "Failed to load interface for")+                                           (text "Ambiguous interface for")++cantFindInstalledErr+    :: SDoc+    -> SDoc+    -> UnitState+    -> Maybe HomeUnit+    -> Profile+    -> ([FilePath] -> SDoc)+    -> ModuleName+    -> InstalledFindResult+    -> SDoc+cantFindInstalledErr cannot_find _ unit_state mhome_unit profile tried_these mod_name find_result+  = cannot_find <+> quotes (ppr mod_name)+    $$ more_info+  where+    build_tag  = waysBuildTag (profileWays profile)++    more_info+      = case find_result of+            InstalledNoPackage pkg+                -> text "no unit id matching" <+> quotes (ppr pkg) <+>+                   text "was found" $$ looks_like_srcpkgid pkg++            InstalledNotFound files mb_pkg+                | Just pkg <- mb_pkg+                , notHomeUnitId mhome_unit pkg+                -> not_found_in_package pkg files++                | null files+                -> text "It is not a module in the current program, or in any known package."++                | otherwise+                -> tried_these files++            _ -> panic "cantFindInstalledErr"++    looks_like_srcpkgid :: UnitId -> SDoc+    looks_like_srcpkgid pk+     -- Unsafely coerce a unit id (i.e. an installed package component+     -- identifier) into a PackageId and see if it means anything.+     | (pkg:pkgs) <- searchPackageId unit_state (PackageId (unitIdFS pk))+     = parens (text "This unit ID looks like the source package ID;" $$+       text "the real unit ID is" <+> quotes (ftext (unitIdFS (unitId pkg))) $$+       (if null pkgs then Outputable.empty+        else text "and" <+> int (length pkgs) <+> text "other candidates"))+     -- Todo: also check if it looks like a package name!+     | otherwise = Outputable.empty++    not_found_in_package pkg files+       | build_tag /= ""+       = let+            build = if build_tag == "p" then "profiling"+                                        else "\"" ++ build_tag ++ "\""+         in+         text "Perhaps you haven't installed the " <> text build <>+         text " libraries for package " <> quotes (ppr pkg) <> char '?' $$+         tried_these files++       | otherwise+       = text "There are files missing in the " <> quotes (ppr pkg) <>+         text " package," $$+         text "try running 'ghc-pkg check'." $$+         tried_these files++mayShowLocations :: DynFlags -> [FilePath] -> SDoc+mayShowLocations dflags files+    | null files = Outputable.empty+    | verbosity dflags < 3 =+          text "Use -v (or `:set -v` in ghci) " <>+              text "to see a list of the files searched for."+    | otherwise =+          hang (text "Locations searched:") 2 $ vcat (map text files)++cannotFindModule :: HscEnv -> ModuleName -> FindResult -> SDoc+cannotFindModule hsc_env = cannotFindModule'+    (hsc_dflags   hsc_env)+    (hsc_unit_env hsc_env)+    (targetProfile (hsc_dflags hsc_env))+++cannotFindModule' :: DynFlags -> UnitEnv -> Profile -> ModuleName -> FindResult -> SDoc+cannotFindModule' dflags unit_env profile mod res = pprWithUnitState (ue_units unit_env) $+  cantFindErr (checkBuildingCabalPackage dflags)+              cannotFindMsg+              (text "Ambiguous module name")+              unit_env+              profile+              (mayShowLocations dflags)+              mod+              res+  where+    cannotFindMsg =+      case res of+        NotFound { fr_mods_hidden = hidden_mods+                 , fr_pkgs_hidden = hidden_pkgs+                 , fr_unusables = unusables }+          | not (null hidden_mods && null hidden_pkgs && null unusables)+          -> text "Could not load module"+        _ -> text "Could not find module"++cantFindErr+    :: BuildingCabalPackage -- ^ Using Cabal?+    -> SDoc+    -> SDoc+    -> UnitEnv+    -> Profile+    -> ([FilePath] -> SDoc)+    -> ModuleName+    -> FindResult+    -> SDoc+cantFindErr _ _ multiple_found _ _ _ mod_name (FoundMultiple mods)+  | Just pkgs <- unambiguousPackages+  = hang (multiple_found <+> quotes (ppr mod_name) <> colon) 2 (+       sep [text "it was found in multiple packages:",+                hsep (map ppr pkgs) ]+    )+  | otherwise+  = hang (multiple_found <+> quotes (ppr mod_name) <> colon) 2 (+       vcat (map pprMod mods)+    )+  where+    unambiguousPackages = foldl' unambiguousPackage (Just []) mods+    unambiguousPackage (Just xs) (m, ModOrigin (Just _) _ _ _)+        = Just (moduleUnit m : xs)+    unambiguousPackage _ _ = Nothing++    pprMod (m, o) = text "it is bound as" <+> ppr m <+>+                                text "by" <+> pprOrigin m o+    pprOrigin _ ModHidden = panic "cantFindErr: bound by mod hidden"+    pprOrigin _ (ModUnusable _) = panic "cantFindErr: bound by mod unusable"+    pprOrigin m (ModOrigin e res _ f) = sep $ punctuate comma (+      if e == Just True+          then [text "package" <+> ppr (moduleUnit m)]+          else [] +++      map ((text "a reexport in package" <+>)+                .ppr.mkUnit) res +++      if f then [text "a package flag"] else []+      )++cantFindErr using_cabal cannot_find _ unit_env profile tried_these mod_name find_result+  = cannot_find <+> quotes (ppr mod_name)+    $$ more_info+  where+    mhome_unit = ue_homeUnit unit_env+    more_info+      = case find_result of+            NoPackage pkg+                -> text "no unit id matching" <+> quotes (ppr pkg) <+>+                   text "was found"++            NotFound { fr_paths = files, fr_pkg = mb_pkg+                     , fr_mods_hidden = mod_hiddens, fr_pkgs_hidden = pkg_hiddens+                     , fr_unusables = unusables, fr_suggestions = suggest }+                | Just pkg <- mb_pkg+                , Nothing <- mhome_unit           -- no home-unit+                -> not_found_in_package pkg files++                | Just pkg <- mb_pkg+                , Just home_unit <- mhome_unit    -- there is a home-unit but the+                , not (isHomeUnit home_unit pkg)  -- module isn't from it+                -> not_found_in_package pkg files++                | not (null suggest)+                -> pp_suggestions suggest $$ tried_these files++                | null files && null mod_hiddens &&+                  null pkg_hiddens && null unusables+                -> text "It is not a module in the current program, or in any known package."++                | otherwise+                -> vcat (map pkg_hidden pkg_hiddens) $$+                   vcat (map mod_hidden mod_hiddens) $$+                   vcat (map unusable unusables) $$+                   tried_these files++            _ -> panic "cantFindErr"++    build_tag = waysBuildTag (profileWays profile)++    not_found_in_package pkg files+       | build_tag /= ""+       = let+            build = if build_tag == "p" then "profiling"+                                        else "\"" ++ build_tag ++ "\""+         in+         text "Perhaps you haven't installed the " <> text build <>+         text " libraries for package " <> quotes (ppr pkg) <> char '?' $$+         tried_these files++       | otherwise+       = text "There are files missing in the " <> quotes (ppr pkg) <>+         text " package," $$+         text "try running 'ghc-pkg check'." $$+         tried_these files++    pkg_hidden :: Unit -> SDoc+    pkg_hidden uid =+        text "It is a member of the hidden package"+        <+> quotes (ppr uid)+        --FIXME: we don't really want to show the unit id here we should+        -- show the source package id or installed package id if it's ambiguous+        <> dot $$ pkg_hidden_hint uid++    pkg_hidden_hint uid+     | using_cabal == YesBuildingCabalPackage+        = let pkg = expectJust "pkg_hidden" (lookupUnit (ue_units unit_env) uid)+           in text "Perhaps you need to add" <+>+              quotes (ppr (unitPackageName pkg)) <+>+              text "to the build-depends in your .cabal file."+     | Just pkg <- lookupUnit (ue_units unit_env) uid+         = text "You can run" <+>+           quotes (text ":set -package " <> ppr (unitPackageName pkg)) <+>+           text "to expose it." $$+           text "(Note: this unloads all the modules in the current scope.)"+     | otherwise = Outputable.empty++    mod_hidden pkg =+        text "it is a hidden module in the package" <+> quotes (ppr pkg)++    unusable (pkg, reason)+      = text "It is a member of the package"+      <+> quotes (ppr pkg)+      $$ pprReason (text "which is") reason++    pp_suggestions :: [ModuleSuggestion] -> SDoc+    pp_suggestions sugs+      | null sugs = Outputable.empty+      | otherwise = hang (text "Perhaps you meant")+                       2 (vcat (map pp_sugg sugs))++    -- NB: Prefer the *original* location, and then reexports, and then+    -- package flags when making suggestions.  ToDo: if the original package+    -- also has a reexport, prefer that one+    pp_sugg (SuggestVisible m mod o) = ppr m <+> provenance o+      where provenance ModHidden = Outputable.empty+            provenance (ModUnusable _) = Outputable.empty+            provenance (ModOrigin{ fromOrigUnit = e,+                                   fromExposedReexport = res,+                                   fromPackageFlag = f })+              | Just True <- e+                 = parens (text "from" <+> ppr (moduleUnit mod))+              | f && moduleName mod == m+                 = parens (text "from" <+> ppr (moduleUnit mod))+              | (pkg:_) <- res+                 = parens (text "from" <+> ppr (mkUnit pkg)+                    <> comma <+> text "reexporting" <+> ppr mod)+              | f+                 = parens (text "defined via package flags to be"+                    <+> ppr mod)+              | otherwise = Outputable.empty+    pp_sugg (SuggestHidden m mod o) = ppr m <+> provenance o+      where provenance ModHidden =  Outputable.empty+            provenance (ModUnusable _) = Outputable.empty+            provenance (ModOrigin{ fromOrigUnit = e,+                                   fromHiddenReexport = rhs })+              | Just False <- e+                 = parens (text "needs flag -package-id"+                    <+> ppr (moduleUnit mod))+              | (pkg:_) <- rhs+                 = parens (text "needs flag -package-id"+                    <+> ppr (mkUnit pkg))+              | otherwise = Outputable.empty+
GHC/Iface/Ext/Ast.hs view
@@ -19,8 +19,6 @@ Main functions for .hie file generation -} -#include "HsVersions.h"- module GHC.Iface.Ext.Ast ( mkHieFile, mkHieFileWithSource, getCompressedAsts, enrichHie) where  import GHC.Utils.Outputable(ppr)@@ -32,24 +30,21 @@ import GHC.Types.Basic import GHC.Data.BooleanFormula import GHC.Core.Class             ( className, classSCSelIds )-import GHC.Core.Utils             ( exprType )-import GHC.Core.ConLike           ( conLikeName, ConLike(RealDataCon) )+import GHC.Core.ConLike           ( conLikeName ) import GHC.Core.TyCon             ( TyCon, tyConClass_maybe ) import GHC.Core.FVs import GHC.Core.DataCon           ( dataConNonlinearType ) import GHC.Types.FieldLabel import GHC.Hs-import GHC.Driver.Env-import GHC.Utils.Monad            ( concatMapM, liftIO )+import GHC.Hs.Syn.Type+import GHC.Utils.Monad            ( concatMapM, MonadIO(liftIO) ) import GHC.Types.Id               ( isDataConId_maybe ) import GHC.Types.Name             ( Name, nameSrcSpan, nameUnique ) import GHC.Types.Name.Env         ( NameEnv, emptyNameEnv, extendNameEnv, lookupNameEnv ) import GHC.Types.SrcLoc-import GHC.Tc.Utils.Zonk          ( hsLitType, hsPatType )-import GHC.Core.Type              ( mkVisFunTys, Type )+import GHC.Core.Type              ( Type ) import GHC.Core.Predicate import GHC.Core.InstEnv-import GHC.Builtin.Types          ( mkListTy, mkSumTy ) import GHC.Tc.Types import GHC.Tc.Types.Evidence import GHC.Types.Var              ( Id, Var, EvId, varName, varType, varUnique )@@ -57,9 +52,11 @@ import GHC.Builtin.Uniques import GHC.Iface.Make             ( mkIfaceExports ) import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Utils.Misc import GHC.Data.Maybe import GHC.Data.FastString+import qualified GHC.Data.Strict as Strict  import GHC.Iface.Ext.Types import GHC.Iface.Ext.Utils@@ -72,17 +69,16 @@ import qualified Data.Map as M import qualified Data.Set as S import Data.Data                  ( Data, Typeable )+import Data.Functor.Identity      ( Identity(..) ) import Data.Void                  ( Void, absurd ) import Control.Monad              ( forM_ ) import Control.Monad.Trans.State.Strict import Control.Monad.Trans.Reader import Control.Monad.Trans.Class  ( lift )-import GHC.HsToCore.Types-import GHC.HsToCore.Expr-import GHC.HsToCore.Monad+import Control.Applicative        ( (<|>) )  {- Note [Updating HieAst for changes in the GHC AST]-+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When updating the code in this file for changes in the GHC AST, you need to pay attention to the following things: @@ -175,9 +171,6 @@         [ toHie $ C Use (L mspan var)              -- Patch up var location since typechecker removes it         ]-      HsConLikeOut _ con ->-        [ toHie $ C Use $ L mspan $ conLikeName con-        ]       ...       HsApp _ a b ->         [ toHie a@@ -212,11 +205,12 @@ -- These synonyms match those defined in compiler/GHC.hs type RenamedSource     = ( HsGroup GhcRn, [LImportDecl GhcRn]                          , Maybe [(LIE GhcRn, Avails)]-                         , Maybe LHsDocString )+                         , Maybe (LHsDoc GhcRn) ) type TypecheckedSource = LHsBinds GhcTc   {- Note [Name Remapping]+   ~~~~~~~~~~~~~~~~~~~~~ The Typechecker introduces new names for mono names in AbsBinds. We don't care about the distinction between mono and poly bindings, so we replace all occurrences of the mono name with the poly name.@@ -273,23 +267,23 @@   addSubstitution mono poly hs =     hs{name_remapping = extendNameEnv (name_remapping hs) (varName mono) poly} -modifyState :: ModifyState (IdP p) => [ABExport p] -> HieState -> HieState+modifyState :: [ABExport] -> HieState -> HieState modifyState = foldr go id   where     go ABE{abe_poly=poly,abe_mono=mono} f       = addSubstitution mono poly . f-    go _ f = f -type HieM = ReaderT NodeOrigin (StateT HieState DsM)+type HieM = ReaderT NodeOrigin (State HieState)  -- | Construct an 'HieFile' from the outputs of the typechecker.-mkHieFile :: ModSummary+mkHieFile :: MonadIO m+          => ModSummary           -> TcGblEnv-          -> RenamedSource -> Hsc HieFile+          -> RenamedSource -> m HieFile mkHieFile ms ts rs = do   let src_file = expectJust "mkHieFile" (ml_hs_file $ ms_location ms)   src <- liftIO $ BS.readFile src_file-  mkHieFileWithSource src_file src ms ts rs+  pure $ mkHieFileWithSource src_file src ms ts rs  -- | Construct an 'HieFile' from the outputs of the typechecker but don't -- read the source file again from disk.@@ -297,16 +291,14 @@                     -> BS.ByteString                     -> ModSummary                     -> TcGblEnv-                    -> RenamedSource -> Hsc HieFile-mkHieFileWithSource src_file src ms ts rs = do+                    -> RenamedSource -> HieFile+mkHieFileWithSource src_file src ms ts rs =   let tc_binds = tcg_binds ts       top_ev_binds = tcg_ev_binds ts       insts = tcg_insts ts       tcs = tcg_tcs ts-  hsc_env <- Hsc $ \e w -> return (e, w)-  (_msgs, res) <- liftIO $ initDs hsc_env ts $ getCompressedAsts tc_binds rs top_ev_binds insts tcs-  let (asts',arr) = expectJust "mkHieFileWithSource" res-  return $ HieFile+      (asts',arr) = getCompressedAsts tc_binds rs top_ev_binds insts tcs in+  HieFile       { hie_hs_file = src_file       , hie_module = ms_mod ms       , hie_types = arr@@ -317,19 +309,20 @@       }  getCompressedAsts :: TypecheckedSource -> RenamedSource -> Bag EvBind -> [ClsInst] -> [TyCon]-  -> DsM (HieASTs TypeIndex, A.Array TypeIndex HieTypeFlat)-getCompressedAsts ts rs top_ev_binds insts tcs = do-  asts <- enrichHie ts rs top_ev_binds insts tcs-  return $ compressTypes asts+  -> (HieASTs TypeIndex, A.Array TypeIndex HieTypeFlat)+getCompressedAsts ts rs top_ev_binds insts tcs =+  let asts = enrichHie ts rs top_ev_binds insts tcs in+  compressTypes asts  enrichHie :: TypecheckedSource -> RenamedSource -> Bag EvBind -> [ClsInst] -> [TyCon]-  -> DsM (HieASTs Type)-enrichHie ts (hsGrp, imports, exports, _) ev_bs insts tcs =-  flip evalStateT initState $ flip runReaderT SourceInfo $ do+  -> HieASTs Type+enrichHie ts (hsGrp, imports, exports, docs) ev_bs insts tcs =+  runIdentity $ flip evalStateT initState $ flip runReaderT SourceInfo $ do     tasts <- toHie $ fmap (BC RegularBind ModuleScope) ts     rasts <- processGrp hsGrp     imps <- toHie $ filter (not . ideclImplicit . unLoc) imports     exps <- toHie $ fmap (map $ IEC Export . fst) exports+    docs <- toHie docs     -- Add Instance bindings     forM_ insts $ \i ->       addUnlocatedEvBind (is_dfun i) (EvidenceVarBind (EvInstBind False (is_cls_nm i)) ModuleScope Nothing)@@ -349,6 +342,7 @@           , rasts           , imps           , exps+          , docs           ]          modulify (HiePath file) xs' = do@@ -356,7 +350,7 @@           top_ev_asts :: [HieAST Type] <- do             let               l :: SrcSpanAnnA-              l = noAnnSrcSpan (RealSrcSpan (realSrcLocSpan $ mkRealSrcLoc file 1 1) Nothing)+              l = noAnnSrcSpan (RealSrcSpan (realSrcLocSpan $ mkRealSrcLoc file 1 1) Strict.Nothing)             toHie $ EvBindContext ModuleScope Nothing                   $ L l (EvBinds ev_bs) @@ -395,6 +389,7 @@       , toHie $ hs_warnds grp       , toHie $ hs_annds grp       , toHie $ hs_ruleds grp+      , toHie $ hs_docs grp       ]  getRealSpanA :: SrcSpanAnn' ann -> Maybe Span@@ -404,10 +399,9 @@ getRealSpan (RealSrcSpan sp _) = Just sp getRealSpan _ = Nothing -grhss_span :: (Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcSpan-              , Data (HsLocalBinds (GhcPass p)))+grhss_span :: (Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcAnn NoEpAnns)            => GRHSs (GhcPass p) (LocatedA (body (GhcPass p))) -> SrcSpan-grhss_span (GRHSs _ xs bs) = foldl' combineSrcSpans (spanHsLocaLBinds bs) (map getLoc xs)+grhss_span (GRHSs _ xs bs) = foldl' combineSrcSpans (spanHsLocaLBinds bs) (map getLocA xs)  bindingsOnly :: [Context Name] -> HieM [HieAST a] bindingsOnly [] = pure []@@ -424,6 +418,7 @@ concatM xs = concat <$> sequence xs  {- Note [Capturing Scopes and other non local information]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ toHie is a local transformation, but scopes of bindings cannot be known locally, hence we have to push the relevant info down into the binding nodes. We use the following types (*Context and *Scoped) to wrap things and@@ -468,6 +463,7 @@   deriving (Typeable, Data) -- Pattern Scope  {- Note [TyVar Scopes]+   ~~~~~~~~~~~~~~~~~~~ Due to -XScopedTypeVariables, type variables can be in scope quite far from their original binding. We resolve the scope of these type variables in a separate pass@@ -521,6 +517,7 @@   map (\(RS sc a)-> TVS tvScope sc a) $ listScopes rhsScope xs  {- Note [Scoping Rules for SigPat]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Explicitly quantified variables in pattern type signatures are not brought into scope in the rhs, but implicitly quantified variables are (HsWC and HsIB).@@ -689,7 +686,7 @@         (WpLet bs)      -> toHie $ EvBindContext (mkScopeA osp) (getRealSpanA osp) (L osp bs)         (WpCompose a b) -> concatM $           [toHie (L osp a), toHie (L osp b)]-        (WpFun a b _ _) -> concatM $+        (WpFun a b _)   -> concatM $           [toHie (L osp a), toHie (L osp b)]         (WpEvLam a) ->           toHie $ C (EvidenceVarBind EvWrapperBind (mkScopeA osp) (getRealSpanA osp))@@ -716,78 +713,81 @@ -- the expression. It is not yet possible to do this efficiently for all -- expression forms, so we skip filling in the type for those inputs. ----- 'HsApp', for example, doesn't have any type information available directly on--- the node. Our next recourse would be to desugar it into a 'CoreExpr' then--- query the type of that. Yet both the desugaring call and the type query both--- involve recursive calls to the function and argument! This is particularly--- problematic when you realize that the HIE traversal will eventually visit--- those nodes too and ask for their types again.------ Since the above is quite costly, we just skip cases where computing the--- expression's type is going to be expensive.------ See #16233+-- See Note [Computing the type of every node in the tree] instance HiePass p => HasType (LocatedA (HsExpr (GhcPass p))) where-  getTypeNode e@(L spn e') =+  getTypeNode (L spn e) =     case hiePass @p of-      HieRn -> makeNodeA e' spn-      HieTc ->-        -- Some expression forms have their type immediately available-        let tyOpt = case e' of-              HsUnboundVar (HER _ ty _) _ -> Just ty-              HsLit _ l -> Just (hsLitType l)-              HsOverLit _ o -> Just (overLitType o)+      HieRn -> fallback+      HieTc -> case computeType e of+          Just ty -> makeTypeNodeA e spn ty+          Nothing -> fallback+    where+      fallback :: HieM [HieAST Type]+      fallback = makeNodeA e spn -              HsConLikeOut _ (RealDataCon con) -> Just (dataConNonlinearType con)+      -- Skip computing the type of some expressions for performance reasons.+      --+      -- See impact on Haddock output (esp. missing type annotations or links)+      -- before skipping more kinds of expressions. See impact on Haddock+      -- performance before computing the types of more expressions.+      --+      -- See Note [Computing the type of every node in the tree]+      computeType :: HsExpr GhcTc -> Maybe Type+      computeType e = case e of+        HsApp{} -> Nothing+        HsAppType{} -> Nothing+        NegApp{} -> Nothing+        HsPar _ _ e _ -> computeLType e+        ExplicitTuple{} -> Nothing+        HsIf _ _ t f -> computeLType t <|> computeLType f+        HsLet _ _ _ _ body -> computeLType body+        RecordCon con_expr _ _ -> computeType con_expr+        ExprWithTySig _ e _ -> computeLType e+        HsPragE _ _ e -> computeLType e+        XExpr (ExpansionExpr (HsExpanded (HsGetField _ _ _) e)) -> Just (hsExprType e) -- for record-dot-syntax+        XExpr (ExpansionExpr (HsExpanded _ e)) -> computeType e+        XExpr (HsTick _ e) -> computeLType e+        XExpr (HsBinTick _ _ e) -> computeLType e+        e -> Just (hsExprType e) -              HsLam     _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy)-              HsLamCase _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy)-              HsCase _  _ (MG { mg_ext = groupTy }) -> Just (mg_res_ty groupTy)+      computeLType :: LHsExpr GhcTc -> Maybe Type+      computeLType (L _ e) = computeType e -              ExplicitList  ty _     -> Just (mkListTy ty)-              ExplicitSum   ty _ _ _ -> Just (mkSumTy ty)-              HsDo          ty _ _   -> Just ty-              HsMultiIf     ty _     -> Just ty+{- Note [Computing the type of every node in the tree]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In GHC.Iface.Ext.Ast we decorate every node in the AST with its+type, computed by `hsExprType` applied to that node.  So it's+important that `hsExprType` takes roughly constant time per node.+There are three cases to consider: -              _ -> Nothing+1. For many nodes (e.g. HsVar, HsDo, HsCase) it is easy to get their+   type -- e.g. it is stored in the node, or in sub-node thereof. -        in-        case tyOpt of-          Just t -> makeTypeNodeA e' spn t-          Nothing-            | skipDesugaring e' -> fallback-            | otherwise -> do-                (e, no_errs) <- lift $ lift $ discardWarningsDs $ askNoErrsDs $ dsLExpr e-                if no_errs-                  then makeTypeNodeA e' spn . exprType $ e-                  else fallback-        where-          fallback = makeNodeA e' spn+2. For some nodes (e.g. HsPar, HsTick, HsIf) the type of the node is+   the type of a child, so we can recurse, fast.  We don't expect the+   nesting to be very deep, so while this is theoretically non-linear,+   we don't expect it to be a problem in practice. -          matchGroupType :: MatchGroupTc -> Type-          matchGroupType (MatchGroupTc args res) = mkVisFunTys args res+3. A very few nodes (e.g. HsApp) are more troublesome because we need to+   take the type of a child, and then do some non-trivial processing.+   To be conservative on computation, we decline to decorate these+   nodes, using `fallback` instead. -          -- | Skip desugaring of these expressions for performance reasons.-          ---          -- See impact on Haddock output (esp. missing type annotations or links)-          -- before marking more things here as 'False'. See impact on Haddock-          -- performance before marking more things as 'True'.-          skipDesugaring :: HsExpr GhcTc -> Bool-          skipDesugaring e = case e of-            HsVar{}             -> False-            HsConLikeOut{}      -> False-            HsRecFld{}          -> False-            HsOverLabel{}       -> False-            HsIPVar{}           -> False-            XExpr (ExpansionExpr {}) -> False-            _                   -> True+The function `computeType e` returns `Just t` if we can find the type+of `e` cheaply, and `Nothing` otherwise.  The base `Nothing` cases+are the troublesome ones in (3) above. Hopefully we can ultimately+get rid of them all. +See #16233++-}+ data HiePassEv p where   HieRn :: HiePassEv 'Renamed   HieTc :: HiePassEv 'Typechecked -class ( IsPass p-      , HiePass (NoGhcTcPass p)+class ( HiePass (NoGhcTcPass p)+      , NoGhcTcPass p ~ 'Renamed       , ModifyState (IdGhcP p)       , Data (GRHS  (GhcPass p) (LocatedA (HsExpr (GhcPass p))))       , Data (Match (GhcPass p) (LocatedA (HsExpr (GhcPass p))))@@ -805,10 +805,6 @@       , Data (HsTupArg (GhcPass p))       , Data (IPBind (GhcPass p))       , ToHie (Context (Located (IdGhcP p)))-      , ToHie (RFContext (Located (AmbiguousFieldOcc (GhcPass p))))-      , ToHie (RFContext (Located (FieldOcc (GhcPass p))))-      , ToHie (TScoped (LHsWcType (GhcPass (NoGhcTcPass p))))-      , ToHie (TScoped (LHsSigWcType (GhcPass (NoGhcTcPass p))))       , Anno (IdGhcP p) ~ SrcSpanAnnN       )       => HiePass p where@@ -828,15 +824,13 @@     , Anno [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))]                    ~ SrcSpanAnnL     , Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))-                   ~ SrcSpan+                   ~ SrcAnn NoEpAnns     , Anno (StmtLR (GhcPass p) (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcSpanAnnA      , Data (body (GhcPass p))     , Data (Match (GhcPass p) (LocatedA (body (GhcPass p))))     , Data (GRHS  (GhcPass p) (LocatedA (body (GhcPass p))))     , Data (Stmt  (GhcPass p) (LocatedA (body (GhcPass p))))--    , IsPass p     )  instance HiePass p => ToHie (BindContext (LocatedA (HsBind (GhcPass p)))) where@@ -856,21 +850,27 @@       VarBind{var_rhs = expr} ->         [ toHie expr         ]-      AbsBinds{ abs_exports = xs, abs_binds = binds-              , abs_ev_binds = ev_binds-              , abs_ev_vars = ev_vars } ->-        [  lift (modify (modifyState xs)) >> -- Note [Name Remapping]-                (toHie $ fmap (BC context scope) binds)-        , toHie $ map (L span . abe_wrap) xs-        , toHie $-            map (EvBindContext (mkScopeA span) (getRealSpanA span)-                . L span) ev_binds-        , toHie $-            map (C (EvidenceVarBind EvSigBind-                                    (mkScopeA span)-                                    (getRealSpanA span))-                . L span) ev_vars-        ]+      XHsBindsLR ext -> case hiePass @p of+#if __GLASGOW_HASKELL__ < 811+        HieRn -> dataConCantHappen ext+#endif+        HieTc+          | AbsBinds{ abs_exports = xs, abs_binds = binds+                    , abs_ev_binds = ev_binds+                    , abs_ev_vars = ev_vars } <- ext+          ->+            [  lift (modify (modifyState xs)) >> -- Note [Name Remapping]+                    (toHie $ fmap (BC context scope) binds)+            , toHie $ map (L span . abe_wrap) xs+            , toHie $+                map (EvBindContext (mkScopeA span) (getRealSpanA span)+                    . L span) ev_binds+            , toHie $+                map (C (EvidenceVarBind EvSigBind+                                        (mkScopeA span)+                                        (getRealSpanA span))+                    . L span) ev_vars+            ]       PatSynBind _ psb ->         [ toHie $ L (locA span) psb -- PatSynBinds only occur at the top level         ]@@ -907,11 +907,11 @@             (InfixCon a b) -> combineScopes (mkLScopeN a) (mkLScopeN b)             (RecCon r) -> foldr go NoScope r           go (RecordPatSynField a b) c = combineScopes c-            $ combineScopes (mkLScopeN (rdrNameFieldOcc a)) (mkLScopeN b)+            $ combineScopes (mkLScopeN (foLabel a)) (mkLScopeN b)           detSpan = case detScope of             LocalScope a -> Just a             _ -> Nothing-          toBind (PrefixCon ts args) = ASSERT(null ts) PrefixCon ts $ map (C Use) args+          toBind (PrefixCon ts args) = assert (null ts) $ PrefixCon ts $ map (C Use) args           toBind (InfixCon a b) = InfixCon (C Use a) (C Use b)           toBind (RecCon r) = RecCon $ map (PSC detSpan) r @@ -925,20 +925,22 @@          , AnnoBody p body          , ToHie (LocatedA (body (GhcPass p)))          ) => ToHie (LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))) where-  toHie (L span m ) = concatM $ node : case m of+  toHie (L span m ) = concatM $ makeNodeA m span : case m of     Match{m_ctxt=mctx, m_pats = pats, m_grhss =  grhss } ->       [ toHie mctx       , let rhsScope = mkScope $ grhss_span grhss           in toHie $ patScopes Nothing rhsScope NoScope pats       , toHie grhss       ]-    where-      node = case hiePass @p of-        HieTc -> makeNodeA m span-        HieRn -> makeNodeA m span  instance HiePass p => ToHie (HsMatchContext (GhcPass p)) where-  toHie (FunRhs{mc_fun=name}) = toHie $ C MatchBind name+  toHie (FunRhs{mc_fun=name}) = toHie $ C MatchBind name'+    where+      -- See a paragraph about Haddock in #20415.+      name' :: LocatedN Name+      name' = case hiePass @p of+        HieRn -> name+        HieTc -> mapLoc varName name   toHie (StmtCtxt a) = toHie a   toHie _ = pure [] @@ -966,7 +968,7 @@                     lname         , toHie $ PS rsp scope pscope pat         ]-      ParPat _ pat ->+      ParPat _ _ pat _ ->         [ toHie $ PS rsp scope pscope pat         ]       BangPat _ pat ->@@ -1025,17 +1027,17 @@         ]       XPat e ->         case hiePass @p of-          HieTc ->-            let CoPat wrap pat _ = e-              in [ toHie $ L ospan wrap-                 , toHie $ PS rsp scope pscope $ (L ospan pat)-                 ]-#if __GLASGOW_HASKELL__ < 811-          HieRn -> []-#endif+          HieRn -> case e of+            HsPatExpanded _ p -> [ toHie $ PS rsp scope pscope (L ospan p) ]+          HieTc -> case e of+            CoPat wrap pat _ ->+              [ toHie $ L ospan wrap+              , toHie $ PS rsp scope pscope $ (L ospan pat)+              ]+            ExpansionPat _ p -> [ toHie $ PS rsp scope pscope (L ospan p) ]     where-      contextify :: a ~ LPat (GhcPass p) => HsConDetails (HsPatSigType (NoGhcTc (GhcPass p))) a (HsRecFields (GhcPass p) a)-                 -> HsConDetails (TScoped (HsPatSigType (NoGhcTc (GhcPass p)))) (PScoped a) (RContext (HsRecFields (GhcPass p) (PScoped a)))+      contextify :: a ~ LPat (GhcPass p) => HsConDetails (HsPatSigType GhcRn) a (HsRecFields (GhcPass p) a)+                 -> HsConDetails (TScoped (HsPatSigType GhcRn)) (PScoped a) (RContext (HsRecFields (GhcPass p) (PScoped a)))       contextify (PrefixCon tyargs args) = PrefixCon (tScopes scope argscope tyargs) (patScopes rsp scope pscope args)         where argscope = foldr combineScopes NoScope $ map mkLScopeA args       contextify (InfixCon a b) = InfixCon a' b'@@ -1043,10 +1045,10 @@       contextify (RecCon r) = RecCon $ RC RecFieldMatch $ contextify_rec r       contextify_rec (HsRecFields fds a) = HsRecFields (map go scoped_fds) a         where-          go :: RScoped (LocatedA (HsRecField' id a1))-                      -> LocatedA (HsRecField' id (PScoped a1)) -- AZ-          go (RS fscope (L spn (HsRecField x lbl pat pun))) =-            L spn $ HsRecField x lbl (PS rsp scope fscope pat) pun+          go :: RScoped (LocatedA (HsFieldBind id a1))+                      -> LocatedA (HsFieldBind id (PScoped a1)) -- AZ+          go (RS fscope (L spn (HsFieldBind x lbl pat pun))) =+            L spn $ HsFieldBind x lbl (PS rsp scope fscope pat) pun           scoped_fds = listScopes pscope fds  instance ToHie (TScoped (HsPatSigType GhcRn)) where@@ -1069,16 +1071,12 @@ instance ( ToHie (LocatedA (body (GhcPass p)))          , HiePass p          , AnnoBody p body-         ) => ToHie (Located (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))) where-  toHie (L span g) = concatM $ node : case g of+         ) => ToHie (LocatedAn NoEpAnns (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))) where+  toHie (L span g) = concatM $ makeNodeA g span : case g of     GRHS _ guards body ->       [ toHie $ listScopes (mkLScopeA body) guards       , toHie body       ]-    where-      node = case hiePass @p of-        HieRn -> makeNode g span-        HieTc -> makeNode g span  instance HiePass p => ToHie (LocatedA (HsExpr (GhcPass p))) where   toHie e@(L mspan oexpr) = concatM $ getTypeNode e : case oexpr of@@ -1087,11 +1085,8 @@              -- Patch up var location since typechecker removes it         ]       HsUnboundVar _ _ -> []  -- there is an unbound name here, but that causes trouble-      HsConLikeOut _ con ->-        [ toHie $ C Use $ L mspan $ conLikeName con-        ]-      HsRecFld _ fld ->-        [ toHie $ RFC RecFieldOcc Nothing (L (locA mspan) fld)+      HsRecSel _ fld ->+        [ toHie $ RFC RecFieldOcc Nothing (L (l2l mspan:: SrcAnn NoEpAnns) fld)         ]       HsOverLabel {} -> []       HsIPVar _ _ -> []@@ -1100,7 +1095,7 @@       HsLam _ mg ->         [ toHie mg         ]-      HsLamCase _ mg ->+      HsLamCase _ _ mg ->         [ toHie mg         ]       HsApp _ a b ->@@ -1119,7 +1114,7 @@       NegApp _ a _ ->         [ toHie a         ]-      HsPar _ a ->+      HsPar _ _ a _ ->         [ toHie a         ]       SectionL _ a b ->@@ -1148,7 +1143,7 @@       HsMultiIf _ grhss ->         [ toHie grhss         ]-      HsLet _ binds expr ->+      HsLet _ _ binds _ expr ->         [ toHie $ RS (mkLScopeA expr) binds         , toHie expr         ]@@ -1186,44 +1181,50 @@         [ toHie expr         ]       HsProc _ pat cmdtop ->-        [ toHie $ PS Nothing (mkLScope cmdtop) NoScope pat+        [ toHie $ PS Nothing (mkLScopeA cmdtop) NoScope pat         , toHie cmdtop         ]       HsStatic _ expr ->         [ toHie expr         ]-      HsTick _ _ expr ->-        [ toHie expr-        ]-      HsBinTick _ _ _ expr ->-        [ toHie expr-        ]-      HsBracket _ b ->-        [ toHie b-        ]-      HsRnBracketOut _ b p ->-        [ toHie b-        , toHie p-        ]-      HsTcBracketOut _ _wrap b p ->-        [ toHie b-        , toHie p-        ]+      HsTypedBracket xbracket b -> case hiePass @p of+        HieRn ->+          [ toHie b+          ]+        HieTc | HsBracketTc _ _ _ p <- xbracket ->+          [ toHie b+          , toHie p+          ]+      HsUntypedBracket xbracket b -> case hiePass @p of+        HieRn ->+            [ toHie b+            , toHie xbracket+            ]+        HieTc | HsBracketTc _ _ _ p <- xbracket ->+          [ toHie b+          , toHie p+          ]       HsSpliceE _ x ->         [ toHie $ L mspan x         ]       HsGetField {} -> []       HsProjection {} -> []       XExpr x-        | GhcTc <- ghcPass @p-        , WrapExpr (HsWrap w a) <- x-        -> [ toHie $ L mspan a-           , toHie (L mspan w)-           ]-        | GhcTc <- ghcPass @p-        , ExpansionExpr (HsExpanded _ b) <- x-        -> [ toHie (L mspan b)-           ]+        | HieTc <- hiePass @p+        -> case x of+             WrapExpr (HsWrap w a)+               -> [ toHie $ L mspan a+                  , toHie (L mspan w) ]+             ExpansionExpr (HsExpanded _ b)+               -> [ toHie (L mspan b) ]+             ConLikeTc con _ _+               -> [ toHie $ C Use $ L mspan $ conLikeName con ]+             HsTick _ expr+               -> [ toHie expr+                  ]+             HsBinTick _ _ expr+               -> [ toHie expr+                  ]         | otherwise -> []  -- NOTE: no longer have the location@@ -1292,7 +1293,6 @@                       valBinds         ] - scopeHsLocaLBinds :: HsLocalBinds (GhcPass p) -> Scope scopeHsLocaLBinds (HsValBinds _ (ValBinds _ bs sigs))   = foldr combineScopes NoScope (bsScope ++ sigsScope)@@ -1313,15 +1313,13 @@   = foldr combineScopes NoScope (map (mkScopeA . getLoc) bs) scopeHsLocaLBinds (EmptyLocalBinds _) = NoScope - instance HiePass p => ToHie (RScoped (LocatedA (IPBind (GhcPass p)))) where-  toHie (RS scope (L sp bind)) = concatM $ makeNodeA bind sp : case bind of-    IPBind _ (Left _) expr -> [toHie expr]-    IPBind _ (Right v) expr ->-      [ toHie $ C (EvidenceVarBind EvImplicitBind scope (getRealSpanA sp))-                  $ L sp v-      , toHie expr-      ]+  toHie (RS scope (L sp bind@(IPBind v _ expr))) = concatM $ makeNodeA bind sp : case hiePass @p of+    HieRn -> [toHie expr]+    HieTc -> [ toHie $ C (EvidenceVarBind EvImplicitBind scope (getRealSpanA sp))+                       $ L sp v+             , toHie expr+             ]  instance HiePass p => ToHie (RScoped (HsValBindsLR (GhcPass p) (GhcPass p))) where   toHie (RS sc v) = concatM $ case v of@@ -1341,44 +1339,33 @@          , HiePass p ) => ToHie (RContext (HsRecFields (GhcPass p) arg)) where   toHie (RC c (HsRecFields fields _)) = toHie $ map (RC c) fields -instance ( ToHie (RFContext (Located label))+instance ( ToHie (RFContext label)          , ToHie arg, HasLoc arg, Data arg          , Data label-         ) => ToHie (RContext (LocatedA (HsRecField' label arg))) where+         ) => ToHie (RContext (LocatedA (HsFieldBind label arg))) where   toHie (RC c (L span recfld)) = concatM $ makeNode recfld (locA span) : case recfld of-    HsRecField _ label expr _ ->+    HsFieldBind _ label expr _ ->       [ toHie $ RFC c (getRealSpan $ loc expr) label       , toHie expr       ] -instance ToHie (RFContext (Located (FieldOcc GhcRn))) where-  toHie (RFC c rhs (L nspan f)) = concatM $ case f of-    FieldOcc name _ ->-      [ toHie $ C (RecField c rhs) (L nspan name)-      ]--instance ToHie (RFContext (Located (FieldOcc GhcTc))) where+instance HiePass p => ToHie (RFContext (LocatedAn NoEpAnns (FieldOcc (GhcPass p)))) where   toHie (RFC c rhs (L nspan f)) = concatM $ case f of-    FieldOcc var _ ->-      [ toHie $ C (RecField c rhs) (L nspan var)-      ]--instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcRn))) where-  toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of-    Unambiguous name _ ->-      [ toHie $ C (RecField c rhs) $ L nspan name-      ]-    Ambiguous _name _ ->-      [ ]+    FieldOcc fld _ ->+      case hiePass @p of+        HieRn -> [toHie $ C (RecField c rhs) (L (locA nspan) fld)]+        HieTc -> [toHie $ C (RecField c rhs) (L (locA nspan) fld)] -instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcTc))) where+instance HiePass p => ToHie (RFContext (LocatedAn NoEpAnns (AmbiguousFieldOcc (GhcPass p)))) where   toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of-    Unambiguous var _ ->-      [ toHie $ C (RecField c rhs) (L nspan var)-      ]-    Ambiguous var _ ->-      [ toHie $ C (RecField c rhs) (L nspan var)-      ]+    Unambiguous fld _ ->+      case hiePass @p of+        HieRn -> [toHie $ C (RecField c rhs) $ L (locA nspan) fld]+        HieTc -> [toHie $ C (RecField c rhs) $ L (locA nspan) fld]+    Ambiguous fld _ ->+      case hiePass @p of+        HieRn -> []+        HieTc -> [ toHie $ C (RecField c rhs) (L (locA nspan) fld) ]  instance HiePass p => ToHie (RScoped (ApplicativeArg (GhcPass p))) where   toHie (RS sc (ApplicativeArgOne _ pat expr _)) = concatM@@ -1397,10 +1384,10 @@  instance ToHie (HsConDeclGADTDetails GhcRn) where   toHie (PrefixConGADT args) = toHie args-  toHie (RecConGADT rec) = toHie rec+  toHie (RecConGADT rec _) = toHie rec -instance HiePass p => ToHie (Located (HsCmdTop (GhcPass p))) where-  toHie (L span top) = concatM $ makeNode top span : case top of+instance HiePass p => ToHie (LocatedAn NoEpAnns (HsCmdTop (GhcPass p))) where+  toHie (L span top) = concatM $ makeNodeA top span : case top of     HsCmdTop _ cmd ->       [ toHie cmd       ]@@ -1422,14 +1409,14 @@       HsCmdLam _ mg ->         [ toHie mg         ]-      HsCmdPar _ a ->+      HsCmdPar _ _ a _ ->         [ toHie a         ]       HsCmdCase _ expr alts ->         [ toHie expr         , toHie alts         ]-      HsCmdLamCase _ alts ->+      HsCmdLamCase _ _ alts ->         [ toHie alts         ]       HsCmdIf _ _ a b c ->@@ -1437,7 +1424,7 @@         , toHie b         , toHie c         ]-      HsCmdLet _ binds cmd' ->+      HsCmdLet _ _ binds _ cmd' ->         [ toHie $ RS (mkLScopeA cmd') binds         , toHie cmd'         ]@@ -1479,7 +1466,7 @@           rhs_scope = sig_sc `combineScopes` con_sc `combineScopes` deriv_sc           sig_sc = maybe NoScope mkLScopeA $ dd_kindSig defn           con_sc = foldr combineScopes NoScope $ map mkLScopeA $ dd_cons defn-          deriv_sc = foldr combineScopes NoScope $ map mkLScope $ dd_derivs defn+          deriv_sc = foldr combineScopes NoScope $ map mkLScopeA $ dd_derivs defn       ClassDecl { tcdCtxt = context                 , tcdLName = name                 , tcdTyVars = vars@@ -1515,8 +1502,8 @@         ]         where           rhsSpan = sigSpan `combineScopes` injSpan-          sigSpan = mkScope $ getLoc sig-          injSpan = maybe NoScope (mkScope . getLoc) inj+          sigSpan = mkScope $ getLocA sig+          injSpan = maybe NoScope (mkScope . getLocA) inj  instance ToHie (FamilyInfo GhcRn) where   toHie (ClosedTypeFamily (Just eqns)) = concatM $@@ -1527,8 +1514,8 @@       go (L l ib) = TS (ResolvedScopes [mkScopeA l]) ib   toHie _ = pure [] -instance ToHie (RScoped (Located (FamilyResultSig GhcRn))) where-  toHie (RS sc (L span sig)) = concatM $ makeNode sig span : case sig of+instance ToHie (RScoped (LocatedAn NoEpAnns (FamilyResultSig GhcRn))) where+  toHie (RS sc (L span sig)) = concatM $ makeNodeA sig span : case sig of       NoSig _ ->         []       KindSig _ k ->@@ -1564,8 +1551,8 @@           patsScope = mkScope (loc pats)           rhsScope = mkScope (loc rhs) -instance ToHie (Located (InjectivityAnn GhcRn)) where-  toHie (L span ann) = concatM $ makeNode ann span : case ann of+instance ToHie (LocatedAn NoEpAnns (InjectivityAnn GhcRn)) where+  toHie (L span ann) = concatM $ makeNodeA ann span : case ann of       InjectivityAnn _ lhs rhs ->         [ toHie $ C Use lhs         , toHie $ map (C Use) rhs@@ -1579,16 +1566,16 @@     , toHie derivs     ] -instance ToHie (Located [Located (HsDerivingClause GhcRn)]) where+instance ToHie (Located [LocatedAn NoEpAnns (HsDerivingClause GhcRn)]) where   toHie (L span clauses) = concatM     [ locOnly span     , toHie clauses     ] -instance ToHie (Located (HsDerivingClause GhcRn)) where-  toHie (L span cl) = concatM $ makeNode cl span : case cl of+instance ToHie (LocatedAn NoEpAnns (HsDerivingClause GhcRn)) where+  toHie (L span cl) = concatM $ makeNodeA cl span : case cl of       HsDerivingClause _ strat dct ->-        [ toHie strat+        [ toHie (RS (mkLScopeA dct) <$> strat)         , toHie dct         ] @@ -1597,12 +1584,12 @@       DctSingle _ ty -> [ toHie $ TS (ResolvedScopes []) ty ]       DctMulti _ tys -> [ toHie $ map (TS (ResolvedScopes [])) tys ] -instance ToHie (Located (DerivStrategy GhcRn)) where-  toHie (L span strat) = concatM $ makeNode strat span : case strat of+instance ToHie (RScoped (LocatedAn NoEpAnns (DerivStrategy GhcRn))) where+  toHie (RS sc (L span strat)) = concatM $ makeNodeA strat span : case strat of       StockStrategy _ -> []       AnyclassStrategy _ -> []       NewtypeStrategy _ -> []-      ViaStrategy s -> [ toHie (TS (ResolvedScopes []) s) ]+      ViaStrategy s -> [ toHie (TS (ResolvedScopes [sc]) s) ]  instance ToHie (LocatedP OverlapMode) where   toHie (L span _) = locOnly (locA span)@@ -1613,7 +1600,8 @@ instance ToHie (LocatedA (ConDecl GhcRn)) where   toHie (L span decl) = concatM $ makeNode decl (locA span) : case decl of       ConDeclGADT { con_names = names, con_bndrs = L outer_bndrs_loc outer_bndrs-                  , con_mb_cxt = ctx, con_g_args = args, con_res_ty = typ } ->+                  , con_mb_cxt = ctx, con_g_args = args, con_res_ty = typ+                  , con_doc = doc} ->         [ toHie $ map (C (Decl ConDec $ getRealSpanA span)) names         , case outer_bndrs of             HsOuterImplicit{hso_ximplicit = imp_vars} ->@@ -1624,21 +1612,24 @@         , toHie ctx         , toHie args         , toHie typ+        , toHie doc         ]         where           rhsScope = combineScopes argsScope tyScope           ctxScope = maybe NoScope mkLScopeA ctx           argsScope = case args of             PrefixConGADT xs -> scaled_args_scope xs-            RecConGADT x     -> mkLScopeA x+            RecConGADT x _   -> mkLScopeA x           tyScope = mkLScopeA typ           resScope = ResolvedScopes [ctxScope, rhsScope]       ConDeclH98 { con_name = name, con_ex_tvs = qvars-                 , con_mb_cxt = ctx, con_args = dets } ->+                 , con_mb_cxt = ctx, con_args = dets+                 , con_doc = doc} ->         [ toHie $ C (Decl ConDec $ getRealSpan (locA span)) name         , toHie $ tvScopes (ResolvedScopes []) rhsScope qvars         , toHie ctx         , toHie dets+        , toHie doc         ]         where           rhsScope = combineScopes ctxScope argsScope@@ -1718,7 +1709,7 @@           ]         SCCFunSig _ _ name mtxt ->           [ toHie $ (C Use) name-          , maybe (pure []) (locOnly . getLoc) mtxt+          , maybe (pure []) (locOnly . getLocA) mtxt           ]         CompleteMatchSig _ _ (L ispan names) typ ->           [ locOnly ispan@@ -1778,7 +1769,7 @@       HsSumTy _ tys ->         [ toHie tys         ]-      HsOpTy _ a op b ->+      HsOpTy _ _prom a op b ->         [ toHie a         , toHie $ C Use op         , toHie b@@ -1797,8 +1788,9 @@       HsSpliceTy _ a ->         [ toHie $ L span a         ]-      HsDocTy _ a _ ->+      HsDocTy _ a doc ->         [ toHie a+        , toHie doc         ]       HsBangTy _ _ ty ->         [ toHie ty@@ -1849,9 +1841,10 @@  instance ToHie (LocatedA (ConDeclField GhcRn)) where   toHie (L span field) = concatM $ makeNode field (locA span) : case field of-      ConDeclField _ fields typ _ ->+      ConDeclField _ fields typ doc ->         [ toHie $ map (RFC RecFieldDecl (getRealSpan $ loc typ)) fields         , toHie typ+        , toHie doc         ]  instance ToHie (LHsExpr a) => ToHie (ArithSeqInfo a) where@@ -1876,7 +1869,7 @@         [ toHie splice         ] -instance ToHie (HsBracket a) where+instance ToHie (HsQuote a) where   toHie _ = pure []  instance ToHie PendingRnSplice where@@ -1900,8 +1893,8 @@         [ toHie f         ] -instance ToHie (Located HsIPName) where-  toHie (L span e) = makeNode e span+instance ToHie (LocatedAn NoEpAnns HsIPName) where+  toHie (L span e) = makeNodeA e span  instance HiePass p => ToHie (LocatedA (HsSplice (GhcPass p))) where   toHie (L span sp) = concatM $ makeNodeA sp span : case sp of@@ -1916,19 +1909,18 @@         ]       HsSpliced _ _ _ ->         []-      XSplice x -> case ghcPass @p of+      XSplice x -> case hiePass @p of #if __GLASGOW_HASKELL__ < 811-                     GhcPs -> noExtCon x-                     GhcRn -> noExtCon x+                     HieRn -> dataConCantHappen x #endif-                     GhcTc -> case x of+                     HieTc -> case x of                                 HsSplicedT _ -> []  instance ToHie (LocatedA (RoleAnnotDecl GhcRn)) where   toHie (L span annot) = concatM $ makeNodeA annot span : case annot of       RoleAnnotDecl _ var roles ->         [ toHie $ C Use var-        , concatMapM (locOnly . getLoc) roles+        , concatMapM (locOnly . getLocA) roles         ]  instance ToHie (LocatedA (InstDecl GhcRn)) where@@ -1976,7 +1968,7 @@   toHie (L span decl) = concatM $ makeNodeA decl span : case decl of       DerivDecl _ typ strat overlap ->         [ toHie $ TS (ResolvedScopes []) typ-        , toHie strat+        , toHie $ (RS (mkScopeA span) <$> strat)         , toHie overlap         ] @@ -2051,19 +2043,19 @@ instance ToHie (LocatedA (RuleDecl GhcRn)) where   toHie (L span r@(HsRule _ rname _ tybndrs bndrs exprA exprB)) = concatM         [ makeNodeA r span-        , locOnly $ getLoc rname+        , locOnly $ getLocA rname         , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs         , toHie $ map (RS $ mkScope (locA span)) bndrs         , toHie exprA         , toHie exprB         ]     where scope = bndrs_sc `combineScopes` exprA_sc `combineScopes` exprB_sc-          bndrs_sc = maybe NoScope mkLScope (listToMaybe bndrs)+          bndrs_sc = maybe NoScope mkLScopeA (listToMaybe bndrs)           exprA_sc = mkLScopeA exprA           exprB_sc = mkLScopeA exprB -instance ToHie (RScoped (Located (RuleBndr GhcRn))) where-  toHie (RS sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of+instance ToHie (RScoped (LocatedAn NoEpAnns (RuleBndr GhcRn))) where+  toHie (RS sc (L span bndr)) = concatM $ makeNodeA bndr span : case bndr of       RuleBndr _ var ->         [ toHie $ C (ValBind RegularBind sc Nothing) var         ]@@ -2106,8 +2098,8 @@       IEModuleContents _ n ->         [ toHie $ IEC c n         ]-      IEGroup _ _ _ -> []-      IEDoc _ _ -> []+      IEGroup _ _ d -> [toHie d]+      IEDoc _ d -> [toHie d]       IEDocNamed _ _ -> []  instance ToHie (IEContext (LIEWrappedName Name)) where@@ -2127,3 +2119,13 @@       [ makeNode lbl span       , toHie $ C (IEThing c) $ L span (flSelector lbl)       ]++instance ToHie (LocatedA (DocDecl GhcRn)) where+  toHie (L span d) = concatM $ makeNodeA d span : case d of+    DocCommentNext d -> [ toHie d ]+    DocCommentPrev d -> [ toHie d ]+    DocCommentNamed _ d -> [ toHie d ]+    DocGroup _ d -> [ toHie d ]++instance ToHie (LHsDoc GhcRn) where+  toHie (L span d@(WithHsDocIdentifiers _ ids)) = concatM $ makeNode d span : [toHie $ map (C Use) ids]
GHC/Iface/Ext/Binary.hs view
@@ -14,7 +14,6 @@    , HieFileResult(..)    , hieMagic    , hieNameOcc-   , NameCacheUpdater(..)    ) where @@ -31,19 +30,18 @@ import GHC.Utils.Panic import GHC.Builtin.Utils import GHC.Types.SrcLoc as SrcLoc-import GHC.Types.Unique.Supply    ( takeUniqFromSupply ) import GHC.Types.Unique import GHC.Types.Unique.FM-import GHC.Iface.Env (NameCacheUpdater(..)) -import qualified Data.Array as A+import qualified Data.Array        as A+import qualified Data.Array.IO     as A+import qualified Data.Array.Unsafe as A import Data.IORef import Data.ByteString            ( ByteString ) import qualified Data.ByteString  as BS import qualified Data.ByteString.Char8 as BSC-import Data.List                  ( mapAccumR ) import Data.Word                  ( Word8, Word32 )-import Control.Monad              ( replicateM, when )+import Control.Monad              ( replicateM, when, forM_ ) import System.Directory           ( createDirectoryIfMissing ) import System.FilePath            ( takeDirectory ) @@ -153,23 +151,23 @@ -- an existing `NameCache`. Allows you to specify -- which versions of hieFile to attempt to read. -- `Left` case returns the failing header versions.-readHieFileWithVersion :: (HieHeader -> Bool) -> NameCacheUpdater -> FilePath -> IO (Either HieHeader HieFileResult)-readHieFileWithVersion readVersion ncu file = do+readHieFileWithVersion :: (HieHeader -> Bool) -> NameCache -> FilePath -> IO (Either HieHeader HieFileResult)+readHieFileWithVersion readVersion name_cache file = do   bh0 <- readBinMem file    (hieVersion, ghcVersion) <- readHieFileHeader file bh0    if readVersion (hieVersion, ghcVersion)   then do-    hieFile <- readHieFileContents bh0 ncu+    hieFile <- readHieFileContents bh0 name_cache     return $ Right (HieFileResult hieVersion ghcVersion hieFile)   else return $ Left (hieVersion, ghcVersion)   -- | Read a `HieFile` from a `FilePath`. Can use -- an existing `NameCache`.-readHieFile :: NameCacheUpdater -> FilePath -> IO HieFileResult-readHieFile ncu file = do+readHieFile :: NameCache -> FilePath -> IO HieFileResult+readHieFile name_cache file = do    bh0 <- readBinMem file @@ -183,7 +181,7 @@                     , show hieVersion                     , "but got", show readHieVersion                     ]-  hieFile <- readHieFileContents bh0 ncu+  hieFile <- readHieFileContents bh0 name_cache   return $ HieFileResult hieVersion ghcVersion hieFile  readBinLine :: BinHandle -> IO ByteString@@ -218,8 +216,8 @@                         ]       return (readHieVersion, ghcVersion) -readHieFileContents :: BinHandle -> NameCacheUpdater -> IO HieFile-readHieFileContents bh0 ncu = do+readHieFileContents :: BinHandle -> NameCache -> IO HieFile+readHieFileContents bh0 name_cache = do   dict <- get_dictionary bh0   -- read the symbol table so we are capable of reading the actual data   bh1 <- do@@ -246,7 +244,7 @@       symtab_p <- get bh1       data_p'  <- tellBin bh1       seekBin bh1 symtab_p-      symtab <- getSymbolTable bh1 ncu+      symtab <- getSymbolTable bh1 name_cache       seekBin bh1 data_p'       return symtab @@ -270,14 +268,15 @@   let names = A.elems (A.array (0,next_off-1) (nonDetEltsUFM symtab))   mapM_ (putHieName bh) names -getSymbolTable :: BinHandle -> NameCacheUpdater -> IO SymbolTable-getSymbolTable bh ncu = do+getSymbolTable :: BinHandle -> NameCache -> IO SymbolTable+getSymbolTable bh name_cache = do   sz <- get bh-  od_names <- replicateM sz (getHieName bh)-  updateNameCache ncu $ \nc ->-    let arr = A.listArray (0,sz-1) names-        (nc', names) = mapAccumR fromHieName nc od_names-        in (nc',arr)+  mut_arr <- A.newArray_ (0, sz-1) :: IO (A.IOArray Int Name)+  forM_ [0..(sz-1)] $ \i -> do+    od_name <- getHieName bh+    name <- fromHieName name_cache od_name+    A.writeArray mut_arr i name+  A.unsafeFreeze mut_arr  getSymTabName :: SymbolTable -> BinHandle -> IO Name getSymTabName st bh = do@@ -312,24 +311,28 @@  -- ** Converting to and from `HieName`'s -fromHieName :: NameCache -> HieName -> (NameCache, Name)-fromHieName nc (ExternalName mod occ span) =-    let cache = nsNames nc-    in case lookupOrigNameCache cache mod occ of-         Just name -> (nc, name)-         Nothing ->-           let (uniq, us) = takeUniqFromSupply (nsUniqs nc)-               name       = mkExternalName uniq mod occ span-               new_cache  = extendNameCache cache mod occ name-           in ( nc{ nsUniqs = us, nsNames = new_cache }, name )-fromHieName nc (LocalName occ span) =-    let (uniq, us) = takeUniqFromSupply (nsUniqs nc)-        name       = mkInternalName uniq occ span-    in ( nc{ nsUniqs = us }, name )-fromHieName nc (KnownKeyName u) = case lookupKnownKeyName u of-    Nothing -> pprPanic "fromHieName:unknown known-key unique"-                        (ppr (unpkUnique u))-    Just n -> (nc, n)+fromHieName :: NameCache -> HieName -> IO Name+fromHieName nc hie_name = do++  case hie_name of+    ExternalName mod occ span -> updateNameCache nc mod occ $ \cache -> do+      case lookupOrigNameCache cache mod occ of+        Just name -> pure (cache, name)+        Nothing   -> do+          uniq <- takeUniqFromNameCache nc+          let name       = mkExternalName uniq mod occ span+              new_cache  = extendOrigNameCache cache mod occ name+          pure (new_cache, name)++    LocalName occ span -> do+      uniq <- takeUniqFromNameCache nc+      -- don't update the NameCache for local names+      pure $ mkInternalName uniq occ span++    KnownKeyName u -> case lookupKnownKeyName u of+      Nothing -> pprPanic "fromHieName:unknown known-key unique"+                          (ppr (unpkUnique u))+      Just n -> pure n  -- ** Reading and writing `HieName`'s
GHC/Iface/Ext/Types.hs view
@@ -155,6 +155,7 @@  -- | Roughly isomorphic to the original core 'Type'. newtype HieTypeFix = Roll (HieType (HieTypeFix))+  deriving Eq  instance Binary (HieType TypeIndex) where   put_ bh (HTyVarTy n) = do@@ -305,7 +306,7 @@  instance Ord NodeAnnotation where    compare (NodeAnnotation c0 t0) (NodeAnnotation c1 t1)-      = mconcat [uniqCompareFS c0 c1, uniqCompareFS t0 t1]+      = mconcat [lexicalCompareFS c0 c1, lexicalCompareFS t0 t1]  instance Outputable NodeAnnotation where    ppr (NodeAnnotation c t) = ppr (c,t)@@ -780,5 +781,5 @@   | isKnownKeyName name = KnownKeyName (nameUnique name)   | isExternalName name = ExternalName (nameModule name)                                        (nameOccName name)-                                       (removeBufSpan $ nameSrcSpan name)-  | otherwise = LocalName (nameOccName name) (removeBufSpan $ nameSrcSpan name)+                                       (nameSrcSpan name)+  | otherwise = LocalName (nameOccName name) (nameSrcSpan name)
GHC/Iface/Ext/Utils.hs view
@@ -26,6 +26,7 @@ import GHC.Types.Var import GHC.Types.Var.Env import GHC.Parser.Annotation+import qualified GHC.Data.Strict as Strict  import GHC.Iface.Ext.Types @@ -39,7 +40,7 @@ import Data.List                  (find) import Data.Traversable           ( for ) import Data.Coerce-import Control.Monad.Trans.State.Strict hiding (get)+import GHC.Utils.Monad.State.Strict hiding (get) import Control.Monad.Trans.Reader import qualified Data.Tree as Tree @@ -186,7 +187,7 @@ freshTypeIndex :: State HieTypeState TypeIndex freshTypeIndex = do   index <- gets freshIndex-  modify' $ \hts -> hts { freshIndex = index+1 }+  modify $ \hts -> hts { freshIndex = index+1 }   return index  compressTypes@@ -216,7 +217,7 @@   where     extendHTS t ht = do       i <- freshTypeIndex-      modify' $ \(HTS tm tt fi) ->+      modify $ \(HTS tm tt fi) ->         HTS (extendTypeMap tm t i) (IM.insert i ht tt) fi       return i @@ -295,8 +296,9 @@   -> Maybe Span getNameBindingInClass n sp asts = do   ast <- M.lookup (HiePath (srcSpanFile sp)) asts+  clsNode <- selectLargestContainedBy sp ast   getFirst $ foldMap First $ do-    child <- flattenAst ast+    child <- flattenAst clsNode     dets <- maybeToList       $ M.lookup (Right n) $ sourcedNodeIdents $ sourcedNodeInfo child     let binding = foldMap (First . getBindSiteFromContext) (identInfo dets)@@ -546,7 +548,7 @@ combineScopes NoScope x = x combineScopes x NoScope = x combineScopes (LocalScope a) (LocalScope b) =-  mkScope $ combineSrcSpans (RealSrcSpan a Nothing) (RealSrcSpan b Nothing)+  mkScope $ combineSrcSpans (RealSrcSpan a Strict.Nothing) (RealSrcSpan b Strict.Nothing)  mkSourcedNodeInfo :: NodeOrigin -> NodeInfo a -> SourcedNodeInfo a mkSourcedNodeInfo org ni = SourcedNodeInfo $ M.singleton org ni
GHC/Iface/Load.hs view
@@ -4,12 +4,13 @@  -} -{-# LANGUAGE CPP, BangPatterns, RecordWildCards, NondecreasingIndentation #-}+{-# LANGUAGE BangPatterns, NondecreasingIndentation #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE FlexibleContexts #-}  {-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE ViewPatterns #-}  -- | Loading interface files module GHC.Iface.Load (@@ -20,36 +21,33 @@         -- RnM/TcM functions         loadModuleInterface, loadModuleInterfaces,         loadSrcInterface, loadSrcInterface_maybe,-        loadInterfaceForName, loadInterfaceForNameMaybe, loadInterfaceForModule,+        loadInterfaceForName, loadInterfaceForModule,          -- IfM functions         loadInterface,         loadSysInterface, loadUserInterface, loadPluginInterface,         findAndReadIface, readIface, writeIface,-        initExternalPackageState,         moduleFreeHolesPrecise,         needWiredInHomeIface, loadWiredInHomeIface,          pprModIfaceSimple,         ifaceStats, pprModIface, showIface, -        cannotFindModule+        module Iface_Errors -- avoids boot files in Ppr modules    ) where -#include "HsVersions.h"- import GHC.Prelude-import GHC.Platform.Ways+ import GHC.Platform.Profile  import {-# SOURCE #-} GHC.IfaceToCore    ( tcIfaceDecls, tcIfaceRules, tcIfaceInst, tcIfaceFamInst    , tcIfaceAnnotations, tcIfaceCompleteMatches ) +import GHC.Driver.Config.Finder import GHC.Driver.Env+import GHC.Driver.Errors.Types import GHC.Driver.Session-import GHC.Driver.Backend-import GHC.Driver.Ppr import GHC.Driver.Hooks import GHC.Driver.Plugins @@ -57,15 +55,20 @@ import GHC.Iface.Ext.Fields import GHC.Iface.Binary import GHC.Iface.Rename+import GHC.Iface.Env+import GHC.Iface.Errors as Iface_Errors +import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad  import GHC.Utils.Binary   ( BinData(..) ) import GHC.Utils.Error import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic-import GHC.Utils.Misc+import GHC.Utils.Panic.Plain+import GHC.Utils.Constants (debugIsOn) import GHC.Utils.Logger+import GHC.Utils.Trace  import GHC.Settings.Constants @@ -81,6 +84,7 @@ import GHC.Types.Id.Make      ( seqId ) import GHC.Types.Annotations import GHC.Types.Name+import GHC.Types.Name.Cache import GHC.Types.Name.Env import GHC.Types.Avail import GHC.Types.Fixity@@ -90,10 +94,10 @@ import GHC.Types.SourceFile import GHC.Types.SafeHaskell import GHC.Types.TypeEnv-import GHC.Types.Unique.FM import GHC.Types.Unique.DSet import GHC.Types.SrcLoc import GHC.Types.TyThing+import GHC.Types.PkgQual  import GHC.Unit.External import GHC.Unit.Module@@ -107,13 +111,12 @@ import GHC.Unit.Env  import GHC.Data.Maybe-import GHC.Data.FastString  import Control.Monad-import Control.Exception import Data.Map ( toList ) import System.FilePath import System.Directory+import GHC.Driver.Env.KnotVars  {- ************************************************************************@@ -165,11 +168,12 @@ -- Get the TyThing for this Name from an interface file -- It's not a wired-in thing -- the caller caught that importDecl name-  = ASSERT( not (isWiredInName name) )-    do  { traceIf nd_doc+  = assert (not (isWiredInName name)) $+    do  { logger <- getLogger+        ; liftIO $ trace_if logger nd_doc          -- Load the interface, which should populate the PTE-        ; mb_iface <- ASSERT2( isExternalName name, ppr name )+        ; mb_iface <- assertPpr (isExternalName name) (ppr name) $                       loadInterface nd_doc (nameModule name) ImportBySystem         ; case mb_iface of {                 Failed err_msg  -> return (Failed err_msg) ;@@ -191,7 +195,7 @@                                 text "Use -ddump-if-trace to get an idea of which file caused the error"])     found_things_msg eps =         hang (text "Found the following declarations in" <+> ppr (nameModule name) <> colon)-           2 (vcat (map ppr $ filter is_interesting $ nameEnvElts $ eps_PTE eps))+           2 (vcat (map ppr $ filter is_interesting $ nonDetNameEnvElts $ eps_PTE eps))       where         is_interesting thing = nameModule name == nameModule (getName thing) @@ -240,8 +244,9 @@   = return ()   | otherwise   = do  { mod <- getModule-        ; traceIf (text "checkWiredInTyCon" <+> ppr tc_name $$ ppr mod)-        ; ASSERT( isExternalName tc_name )+        ; logger <- getLogger+        ; liftIO $ trace_if logger (text "checkWiredInTyCon" <+> ppr tc_name $$ ppr mod)+        ; assert (isExternalName tc_name )           when (mod /= nameModule tc_name)                (initIfaceTcRn (loadWiredInHomeIface tc_name))                 -- Don't look for (non-existent) Float.hi when@@ -264,7 +269,7 @@                 -- the HPT, so without the test we'll demand-load it into the PIT!                 -- C.f. the same test in checkWiredInTyCon above         ; let name = getName thing-        ; ASSERT2( isExternalName name, ppr name )+        ; assertPpr (isExternalName name) (ppr name) $           when (needWiredInHomeIface thing && mod /= nameModule name)                (loadWiredInHomeIface name) } @@ -289,20 +294,20 @@ loadSrcInterface :: SDoc                  -> ModuleName                  -> IsBootInterface     -- {-# SOURCE #-} ?-                 -> Maybe FastString    -- "package", if any+                 -> PkgQual             -- "package", if any                  -> RnM ModIface  loadSrcInterface doc mod want_boot maybe_pkg   = do { res <- loadSrcInterface_maybe doc mod want_boot maybe_pkg        ; case res of-           Failed err      -> failWithTc err+           Failed err      -> failWithTc (TcRnUnknownMessage $ mkPlainError noHints err)            Succeeded iface -> return iface }  -- | Like 'loadSrcInterface', but returns a 'MaybeErr'. loadSrcInterface_maybe :: SDoc                        -> ModuleName                        -> IsBootInterface     -- {-# SOURCE #-} ?-                       -> Maybe FastString    -- "package", if any+                       -> PkgQual             -- "package", if any                        -> RnM (MaybeErr SDoc ModIface)  loadSrcInterface_maybe doc mod want_boot maybe_pkg@@ -311,12 +316,12 @@   -- and create a ModLocation.  If successful, loadIface will read the   -- interface; it will call the Finder again, but the ModLocation will be   -- cached from the first search.-  = do { hsc_env <- getTopEnv-       ; res <- liftIO $ findImportedModule hsc_env mod maybe_pkg-       ; case res of+  = do hsc_env <- getTopEnv+       res <- liftIO $ findImportedModule hsc_env mod maybe_pkg+       case res of            Found _ mod -> initIfaceTcRn $ loadInterface doc mod (ImportByUser want_boot)            -- TODO: Make sure this error message is good-           err         -> return (Failed (cannotFindModule hsc_env mod err)) }+           err         -> return (Failed (cannotFindModule hsc_env mod err))  -- | Load interface directly for a fully qualified 'Module'.  (This is a fairly -- rare operation, but in particular it is used to load orphan modules@@ -340,19 +345,10 @@ loadInterfaceForName doc name   = do { when debugIsOn $  -- Check pre-condition          do { this_mod <- getModule-            ; MASSERT2( not (nameIsLocalOrFrom this_mod name), ppr name <+> parens doc ) }-      ; ASSERT2( isExternalName name, ppr name )+            ; massertPpr (not (nameIsLocalOrFrom this_mod name)) (ppr name <+> parens doc) }+      ; assertPpr (isExternalName name) (ppr name) $         initIfaceTcRn $ loadSysInterface doc (nameModule name) } --- | Only loads the interface for external non-local names.-loadInterfaceForNameMaybe :: SDoc -> Name -> TcRn (Maybe ModIface)-loadInterfaceForNameMaybe doc name-  = do { this_mod <- getModule-       ; if nameIsLocalOrFrom this_mod name || not (isExternalName name)-         then return Nothing-         else Just <$> (initIfaceTcRn $ loadSysInterface doc (nameModule name))-       }- -- | Loads the interface for a given Module. loadInterfaceForModule :: SDoc -> Module -> TcRn ModIface loadInterfaceForModule doc m@@ -360,7 +356,7 @@     -- Should not be called with this module     when debugIsOn $ do       this_mod <- getModule-      MASSERT2( this_mod /= m, ppr m <+> parens doc )+      massertPpr (this_mod /= m) (ppr m <+> parens doc)     initIfaceTcRn $ loadSysInterface doc m  {-@@ -380,7 +376,7 @@ -- See Note [Loading instances for wired-in things] loadWiredInHomeIface :: Name -> IfM lcl () loadWiredInHomeIface name-  = ASSERT( isWiredInName name )+  = assert (isWiredInName name) $     do _ <- loadSysInterface doc (nameModule name); return ()   where     doc = text "Need home interface for wired-in thing" <+> ppr name@@ -405,7 +401,10 @@ -- | A wrapper for 'loadInterface' that throws an exception if it fails loadInterfaceWithException :: SDoc -> Module -> WhereFrom -> IfM lcl ModIface loadInterfaceWithException doc mod_name where_from-  = withException (loadInterface doc mod_name where_from)+  = do+    dflags <- getDynFlags+    let ctx = initSDocContext dflags defaultUserStyle+    withException ctx (loadInterface doc mod_name where_from)  ------------------ loadInterface :: SDoc -> Module -> WhereFrom@@ -433,18 +432,17 @@   | otherwise   = do     logger <- getLogger-    dflags <- getDynFlags-    withTimingSilent logger dflags (text "loading interface") (pure ()) $ do+    withTimingSilent logger (text "loading interface") (pure ()) $ do         {       -- Read the state-          (eps,hpt) <- getEpsAndHpt+          (eps,hug) <- getEpsAndHug         ; gbl_env <- getGblEnv -        ; traceIf (text "Considering whether to load" <+> ppr mod <+> ppr from)+        ; liftIO $ trace_if logger (text "Considering whether to load" <+> ppr mod <+> ppr from)                  -- Check whether we have the interface already         ; hsc_env <- getTopEnv-        ; let home_unit = hsc_home_unit hsc_env-        ; case lookupIfaceByModule hpt (eps_PIT eps) mod of {+        ; let mhome_unit = ue_homeUnit (hsc_unit_env hsc_env)+        ; case lookupIfaceByModule hug (eps_PIT eps) mod of {             Just iface                 -> return (Succeeded iface) ;   -- Already loaded                         -- The (src_imp == mi_boot iface) test checks that the already-loaded@@ -453,9 +451,11 @@             _ -> do {          -- READ THE MODULE IN-        ; read_result <- case (wantHiBootFile home_unit eps mod from) of+        ; read_result <- case wantHiBootFile mhome_unit eps mod from of                            Failed err             -> return (Failed err)-                           Succeeded hi_boot_file -> computeInterface doc_str hi_boot_file mod+                           Succeeded hi_boot_file -> do+                             hsc_env <- getTopEnv+                             liftIO $ computeInterface hsc_env doc_str hi_boot_file mod         ; case read_result of {             Failed err -> do                 { let fake_iface = emptyFullModIface mod@@ -482,7 +482,7 @@         in         initIfaceLcl (mi_semantic_module iface) loc_doc (mi_boot iface) $ -        dontLeakTheHPT $ do+        dontLeakTheHUG $ do          --      Load the new ModIface into the External Package State         -- Even home-package interfaces loaded by loadInterface@@ -500,6 +500,14 @@         --     If we do loadExport first the wrong info gets into the cache (unless we         --      explicitly tag each export which seems a bit of a bore) +        -- Crucial assertion that checks if you are trying to load a HPT module into the EPS.+        -- If you start loading HPT modules into the EPS then you get strange errors about+        -- overlapping instances.+        ; massertPpr+              ((isOneShot (ghcMode (hsc_dflags hsc_env)))+                || moduleUnitId mod `notElem` hsc_all_home_unit_ids hsc_env+                || mod == gHC_PRIM)+                (text "Attempting to load home package interface into the EPS" $$ ppr hug $$ doc_str $$ ppr mod $$ ppr (moduleUnitId mod))         ; ignore_prags      <- goptM Opt_IgnoreInterfacePragmas         ; new_eps_decls     <- tcIfaceDecls ignore_prags (mi_decls iface)         ; new_eps_insts     <- mapM tcIfaceInst (mi_insts iface)@@ -517,14 +525,15 @@                               }                } -        ; let bad_boot = mi_boot iface == IsBoot && fmap fst (if_rec_types gbl_env) == Just mod+        ; let bad_boot = mi_boot iface == IsBoot+                          && isJust (lookupKnotVars (if_rec_types gbl_env) mod)                             -- Warn against an EPS-updating import                             -- of one's own boot file! (one-shot only)                             -- See Note [Loading your own hi-boot file] -        ; WARN( bad_boot, ppr mod )+        ; warnPprTrace bad_boot "loadInterface" (ppr mod) $           updateEps_  $ \ eps ->-           if elemModuleEnv mod (eps_PIT eps) || is_external_sig home_unit iface+           if elemModuleEnv mod (eps_PIT eps) || is_external_sig mhome_unit iface                 then eps            else if bad_boot                 -- See Note [Loading your own hi-boot file]@@ -559,7 +568,7 @@          ; -- invoke plugins with *full* interface, not final_iface, to ensure           -- that plugins have access to declarations, etc.-          res <- withPlugins hsc_env (\p -> interfaceLoadAction p) iface+          res <- withPlugins (hsc_plugins hsc_env) (\p -> interfaceLoadAction p) iface         ; return (Succeeded res)     }}}} @@ -613,54 +622,64 @@ home-package modules however, so it's safe for the HPT to be empty. -} -dontLeakTheHPT :: IfL a -> IfL a-dontLeakTheHPT thing_inside = do-  dflags <- getDynFlags+-- Note [GHC Heap Invariants]+dontLeakTheHUG :: IfL a -> IfL a+dontLeakTheHUG thing_inside = do+  env <- getTopEnv   let-    cleanTopEnv HscEnv{..} =+    inOneShot =+      isOneShot (ghcMode (hsc_dflags env))+    cleanGblEnv gbl_env+      | inOneShot = gbl_env+      | otherwise = gbl_env { if_rec_types = emptyKnotVars }+    cleanTopEnv hsc_env =+        let+         !maybe_type_vars | inOneShot = Just (hsc_type_env_vars env)+                          | otherwise = Nothing          -- wrinkle: when we're typechecking in --backpack mode, the          -- instantiation of a signature might reside in the HPT, so          -- this case breaks the assumption that EPS interfaces only-         -- refer to other EPS interfaces. We can detect when we're in-         -- typechecking-only mode by using backend==NoBackend, and-         -- in that case we don't empty the HPT.  (admittedly this is-         -- a bit of a hack, better suggestions welcome). A number of-         -- tests in testsuite/tests/backpack break without this+         -- refer to other EPS interfaces.+         -- As a temporary (MP Oct 2021 #20509) we only keep the HPT if it+         -- contains any hole modules.+         -- Quite a few tests in testsuite/tests/backpack break without this          -- tweak.+         old_unit_env = hsc_unit_env hsc_env          keepFor20509 hmi           | isHoleModule (mi_semantic_module (hm_iface hmi)) = True           | otherwise = False-         !hpt | backend hsc_dflags == NoBackend = if anyHpt keepFor20509 hsc_HPT then hsc_HPT-                                                                     else emptyHomePackageTable-              | otherwise = emptyHomePackageTable+         pruneHomeUnitEnv hme = hme { homeUnitEnv_hpt = emptyHomePackageTable }+         !unit_env+          = old_unit_env+             { ue_home_unit_graph = if anyHpt keepFor20509 (ue_hpt old_unit_env) then ue_home_unit_graph old_unit_env+                                                                                 else unitEnv_map pruneHomeUnitEnv (ue_home_unit_graph old_unit_env)+             }        in-       HscEnv {  hsc_targets      = panic "cleanTopEnv: hsc_targets"-              ,  hsc_mod_graph    = panic "cleanTopEnv: hsc_mod_graph"-              ,  hsc_IC           = panic "cleanTopEnv: hsc_IC"-              ,  hsc_HPT          = hpt-              , .. }--    cleanGblEnv gbl-      | ghcMode dflags == OneShot = gbl-      | otherwise = gbl { if_rec_types = Nothing }+       hsc_env {  hsc_targets      = panic "cleanTopEnv: hsc_targets"+               ,  hsc_mod_graph    = panic "cleanTopEnv: hsc_mod_graph"+               ,  hsc_IC           = panic "cleanTopEnv: hsc_IC"+               ,  hsc_type_env_vars = case maybe_type_vars of+                                          Just vars -> vars+                                          Nothing -> panic "cleanTopEnv: hsc_type_env_vars"+               ,  hsc_unit_env     = unit_env+               } -  updGblEnv cleanGblEnv $-    updTopEnv cleanTopEnv $ do-      !_ <- getTopEnv        -- force the updTopEnv-      !_ <- getGblEnv-      thing_inside+  updTopEnv cleanTopEnv $ updGblEnv cleanGblEnv $ do+  !_ <- getTopEnv        -- force the updTopEnv+  !_ <- getGblEnv+  thing_inside   -- | Returns @True@ if a 'ModIface' comes from an external package. -- In this case, we should NOT load it into the EPS; the entities -- should instead come from the local merged signature interface.-is_external_sig :: HomeUnit -> ModIface -> Bool-is_external_sig home_unit iface =+is_external_sig :: Maybe HomeUnit -> ModIface -> Bool+is_external_sig mhome_unit iface =     -- It's a signature iface...     mi_semantic_module iface /= mi_module iface &&     -- and it's not from the local package-    not (isHomeModule home_unit (mi_module iface))+    notHomeModuleMaybe mhome_unit (mi_module iface)  -- | This is an improved version of 'findAndReadIface' which can also -- handle the case when a user requests @p[A=<B>]:M@ but we only@@ -676,28 +695,28 @@ -- apply to the requirement itself; e.g., @p[A=<A>]:A@ does not require -- A.hi to be up-to-date (and indeed, we MUST NOT attempt to read A.hi, unless -- we are actually typechecking p.)-computeInterface ::-       SDoc -> IsBootInterface -> Module-    -> TcRnIf gbl lcl (MaybeErr SDoc (ModIface, FilePath))-computeInterface doc_str hi_boot_file mod0 = do-    MASSERT( not (isHoleModule mod0) )-    hsc_env <- getTopEnv-    let home_unit = hsc_home_unit hsc_env-    case getModuleInstantiation mod0 of-        (imod, Just indef) | isHomeUnitIndefinite home_unit -> do-            r <- findAndReadIface doc_str imod mod0 hi_boot_file-            case r of-                Succeeded (iface0, path) -> do-                    hsc_env <- getTopEnv-                    r <- liftIO $-                        rnModIface hsc_env (instUnitInsts (moduleUnit indef))-                                   Nothing iface0-                    case r of-                        Right x -> return (Succeeded (x, path))-                        Left errs -> liftIO . throwIO . mkSrcErr $ errs-                Failed err -> return (Failed err)-        (mod, _) ->-            findAndReadIface doc_str mod mod0 hi_boot_file+computeInterface+  :: HscEnv+  -> SDoc+  -> IsBootInterface+  -> Module+  -> IO (MaybeErr SDoc (ModIface, FilePath))+computeInterface hsc_env doc_str hi_boot_file mod0 = do+  massert (not (isHoleModule mod0))+  let mhome_unit  = hsc_home_unit_maybe hsc_env+  let find_iface m = findAndReadIface hsc_env doc_str+                                      m mod0 hi_boot_file+  case getModuleInstantiation mod0 of+      (imod, Just indef)+        | Just home_unit <- mhome_unit+        , isHomeUnitIndefinite home_unit ->+          find_iface imod >>= \case+            Succeeded (iface0, path) ->+              rnModIface hsc_env (instUnitInsts (moduleUnit indef)) Nothing iface0 >>= \case+                Right x   -> return (Succeeded (x, path))+                Left errs -> throwErrors (GhcTcRnMessage <$> errs)+            Failed err -> return (Failed err)+      (mod, _) -> find_iface mod  -- | Compute the signatures which must be compiled in order to -- load the interface for a 'Module'.  The output of this function@@ -716,10 +735,11 @@  | otherwise =    case getModuleInstantiation mod of     (imod, Just indef) -> do+        logger <- getLogger         let insts = instUnitInsts (moduleUnit indef)-        traceIf (text "Considering whether to load" <+> ppr mod <+>+        liftIO $ trace_if logger (text "Considering whether to load" <+> ppr mod <+>                  text "to compute precise free module holes")-        (eps, hpt) <- getEpsAndHpt+        (eps, hpt) <- getEpsAndHug         case tryEpsAndHpt eps hpt `firstJust` tryDepsCache eps imod insts of             Just r -> return (Succeeded r)             Nothing -> readAndCache imod insts@@ -732,7 +752,10 @@             Just ifhs  -> Just (renameFreeHoles ifhs insts)             _otherwise -> Nothing     readAndCache imod insts = do-        mb_iface <- findAndReadIface (text "moduleFreeHolesPrecise" <+> doc_str) imod mod NotBoot+        hsc_env <- getTopEnv+        mb_iface <- liftIO $ findAndReadIface hsc_env+                                              (text "moduleFreeHolesPrecise" <+> doc_str)+                                              imod mod NotBoot         case mb_iface of             Succeeded (iface, _) -> do                 let ifhs = mi_free_holes iface@@ -742,13 +765,13 @@                 return (Succeeded (renameFreeHoles ifhs insts))             Failed err -> return (Failed err) -wantHiBootFile :: HomeUnit -> ExternalPackageState -> Module -> WhereFrom+wantHiBootFile :: Maybe HomeUnit -> ExternalPackageState -> Module -> WhereFrom                -> MaybeErr SDoc IsBootInterface -- Figure out whether we want Foo.hi or Foo.hi-boot-wantHiBootFile home_unit eps mod from+wantHiBootFile mhome_unit eps mod from   = case from of        ImportByUser usr_boot-          | usr_boot == IsBoot && notHomeModule home_unit mod+          | usr_boot == IsBoot && notHomeModuleMaybe mhome_unit mod           -> Failed (badSourceImport mod)           | otherwise -> Succeeded usr_boot @@ -756,7 +779,7 @@           -> Succeeded NotBoot         ImportBySystem-          | notHomeModule home_unit mod+          | notHomeModuleMaybe mhome_unit mod           -> Succeeded NotBoot              -- If the module to be imported is not from this package              -- don't look it up in eps_is_boot, because that is keyed@@ -764,7 +787,7 @@              -- We never import boot modules from other packages!            | otherwise-          -> case lookupUFM (eps_is_boot eps) (moduleName mod) of+          -> case lookupInstalledModuleEnv (eps_is_boot eps) (toUnitId <$> mod) of                 Just (GWIB { gwib_isBoot = is_boot }) ->                   Succeeded is_boot                 Nothing ->@@ -775,7 +798,7 @@ badSourceImport :: Module -> SDoc badSourceImport mod   = hang (text "You cannot {-# SOURCE #-} import a module from another package")-       2 (text "but" <+> quotes (ppr mod) <+> ptext (sLit "is from package")+       2 (text "but" <+> quotes (ppr mod) <+> text "is from package"           <+> quotes (ppr (moduleUnit mod)))  -----------------------------------------------------@@ -821,24 +844,29 @@ See #8320. -} -findAndReadIface :: SDoc-                 -- The unique identifier of the on-disk module we're-                 -- looking for-                 -> InstalledModule-                 -- The *actual* module we're looking for.  We use-                 -- this to check the consistency of the requirements-                 -- of the module we read out.-                 -> Module-                 -> IsBootInterface     -- True  <=> Look for a .hi-boot file-                                        -- False <=> Look for .hi file-                 -> TcRnIf gbl lcl (MaybeErr SDoc (ModIface, FilePath))-        -- Nothing <=> file not found, or unreadable, or illegible-        -- Just x  <=> successfully found and parsed+findAndReadIface+  :: HscEnv+  -> SDoc            -- ^ Reason for loading the iface (used for tracing)+  -> InstalledModule -- ^ The unique identifier of the on-disk module we're looking for+  -> Module          -- ^ The *actual* module we're looking for.  We use+                     -- this to check the consistency of the requirements of the+                     -- module we read out.+  -> IsBootInterface -- ^ Looking for .hi-boot or .hi file+  -> IO (MaybeErr SDoc (ModIface, FilePath))+findAndReadIface hsc_env doc_str mod wanted_mod hi_boot_file = do -        -- It *doesn't* add an error to the monad, because-        -- sometimes it's ok to fail... see notes with loadInterface-findAndReadIface doc_str mod wanted_mod_with_insts hi_boot_file-  = do traceIf (sep [hsep [text "Reading",+  let profile = targetProfile dflags+      unit_state = hsc_units hsc_env+      fc         = hsc_FC hsc_env+      name_cache = hsc_NC hsc_env+      mhome_unit  = hsc_home_unit_maybe hsc_env+      dflags     = hsc_dflags hsc_env+      logger     = hsc_logger hsc_env+      hooks      = hsc_hooks hsc_env+      other_fopts = initFinderOpts . homeUnitEnv_dflags <$> (hsc_HUG hsc_env)+++  trace_if logger (sep [hsep [text "Reading",                            if hi_boot_file == IsBoot                              then text "[boot]"                              else Outputable.empty,@@ -846,151 +874,131 @@                            ppr mod <> semi],                      nest 4 (text "reason:" <+> doc_str)]) -       -- Check for GHC.Prim, and return its static interface-       -- See Note [GHC.Prim] in primops.txt.pp.-       -- TODO: make this check a function-       if mod `installedModuleEq` gHC_PRIM-           then do-               hooks <- getHooks-               let iface = case ghcPrimIfaceHook hooks of-                            Nothing -> ghcPrimIface-                            Just h  -> h-               return (Succeeded (iface, "<built in interface for GHC.Prim>"))-           else do-               dflags <- getDynFlags-               -- Look for the file-               hsc_env <- getTopEnv-               mb_found <- liftIO (findExactModule hsc_env mod)-               let home_unit  = hsc_home_unit hsc_env-               case mb_found of-                   InstalledFound loc mod -> do-                       -- Found file, so read it-                       let file_path = addBootSuffix_maybe hi_boot_file-                                                           (ml_hi_file loc)+  -- Check for GHC.Prim, and return its static interface+  -- See Note [GHC.Prim] in primops.txt.pp.+  -- TODO: make this check a function+  if mod `installedModuleEq` gHC_PRIM+      then do+          let iface = case ghcPrimIfaceHook hooks of+                       Nothing -> ghcPrimIface+                       Just h  -> h+          return (Succeeded (iface, "<built in interface for GHC.Prim>"))+      else do+          let fopts = initFinderOpts dflags+          -- Look for the file+          mb_found <- liftIO (findExactModule fc fopts other_fopts unit_state mhome_unit mod)+          case mb_found of+              InstalledFound (addBootSuffixLocn_maybe hi_boot_file -> loc) mod -> do+                  -- See Note [Home module load error]+                  case mhome_unit of+                    Just home_unit+                      | isHomeInstalledModule home_unit mod+                      , not (isOneShot (ghcMode dflags))+                      -> return (Failed (homeModError mod loc))+                    _ -> do+                        r <- read_file logger name_cache unit_state dflags wanted_mod (ml_hi_file loc)+                        case r of+                          Failed _+                            -> return r+                          Succeeded (iface,_fp)+                            -> do+                                r2 <- load_dynamic_too_maybe logger name_cache unit_state+                                                         (setDynamicNow dflags) wanted_mod+                                                         iface loc+                                case r2 of+                                  Failed sdoc -> return (Failed sdoc)+                                  Succeeded {} -> return r+              err -> do+                  trace_if logger (text "...not found")+                  return $ Failed $ cannotFindInterface+                                      unit_state+                                      mhome_unit+                                      profile+                                      (Iface_Errors.mayShowLocations dflags)+                                      (moduleName mod)+                                      err -                       -- See Note [Home module load error]-                       if isHomeInstalledModule home_unit mod &&-                          not (isOneShot (ghcMode dflags))-                           then return (Failed (homeModError mod loc))-                           else do r <- read_file file_path-                                   checkBuildDynamicToo r-                                   return r-                   err -> do-                       traceIf (text "...not found")-                       hsc_env <- getTopEnv-                       let profile = Profile (targetPlatform dflags) (ways dflags)-                       return $ Failed $ cannotFindInterface-                                           (hsc_unit_env hsc_env)-                                           profile-                                           (may_show_locations (hsc_dflags hsc_env))-                                           (moduleName mod)-                                           err-    where read_file file_path = do-              traceIf (text "readIFace" <+> text file_path)-              -- Figure out what is recorded in mi_module.  If this is-              -- a fully definite interface, it'll match exactly, but-              -- if it's indefinite, the inside will be uninstantiated!-              unit_state <- hsc_units <$> getTopEnv-              let wanted_mod =-                    case getModuleInstantiation wanted_mod_with_insts of-                        (_, Nothing) -> wanted_mod_with_insts-                        (_, Just indef_mod) ->-                          instModuleToModule unit_state-                            (uninstantiateInstantiatedModule indef_mod)-              read_result <- readIface wanted_mod file_path-              case read_result of-                Failed err -> return (Failed (badIfaceFile file_path err))-                Succeeded iface -> return (Succeeded (iface, file_path))-                            -- Don't forget to fill in the package name...+-- | Check if we need to try the dynamic interface for -dynamic-too+load_dynamic_too_maybe :: Logger -> NameCache -> UnitState -> DynFlags -> Module -> ModIface -> ModLocation -> IO (MaybeErr SDoc ())+load_dynamic_too_maybe logger name_cache unit_state dflags wanted_mod iface loc+  -- Indefinite interfaces are ALWAYS non-dynamic.+  | not (moduleIsDefinite (mi_module iface)) = return (Succeeded ())+  | gopt Opt_BuildDynamicToo dflags = load_dynamic_too logger name_cache unit_state dflags wanted_mod iface loc+  | otherwise = return (Succeeded ()) -          -- Indefinite interfaces are ALWAYS non-dynamic.-          checkBuildDynamicToo (Succeeded (iface, _filePath))-            | not (moduleIsDefinite (mi_module iface)) = return ()+load_dynamic_too :: Logger -> NameCache -> UnitState -> DynFlags -> Module -> ModIface -> ModLocation -> IO (MaybeErr SDoc ())+load_dynamic_too logger name_cache unit_state dflags wanted_mod iface loc = do+  read_file logger name_cache unit_state dflags wanted_mod (ml_dyn_hi_file loc) >>= \case+    Succeeded (dynIface, _)+     | mi_mod_hash (mi_final_exts iface) == mi_mod_hash (mi_final_exts dynIface)+     -> return (Succeeded ())+     | otherwise ->+        do return $ (Failed $ dynamicHashMismatchError wanted_mod loc)+    Failed err ->+        do return $ (Failed $ ((text "Failed to load dynamic interface file for" <+> ppr wanted_mod <> colon) $$ err)) -          checkBuildDynamicToo (Succeeded (iface, filePath)) = do-              let load_dynamic = do-                     dflags <- getDynFlags-                     let dynFilePath = addBootSuffix_maybe hi_boot_file-                                     $ replaceExtension filePath (hiSuf dflags)-                     r <- read_file dynFilePath-                     case r of-                         Succeeded (dynIface, _)-                          | mi_mod_hash (mi_final_exts iface) == mi_mod_hash (mi_final_exts dynIface) ->-                             return ()-                          | otherwise ->-                             do traceIf (text "Dynamic hash doesn't match")-                                setDynamicTooFailed dflags-                         Failed err ->-                             do traceIf (text "Failed to load dynamic interface file:" $$ err)-                                setDynamicTooFailed dflags -              dflags <- getDynFlags-              dynamicTooState dflags >>= \case-                DT_Dont   -> return ()-                DT_Failed -> return ()-                DT_Dyn    -> load_dynamic-                DT_OK     -> withDynamicNow load_dynamic+dynamicHashMismatchError :: Module -> ModLocation -> SDoc+dynamicHashMismatchError wanted_mod loc  =+  vcat [ text "Dynamic hash doesn't match for" <+> quotes (ppr wanted_mod)+       , text "Normal interface file from"  <+> text (ml_hi_file loc)+       , text "Dynamic interface file from" <+> text (ml_dyn_hi_file loc)+       , text "You probably need to recompile" <+> quotes (ppr wanted_mod) ] -          checkBuildDynamicToo _ = return () --- | Write interface file-writeIface :: Logger -> DynFlags -> FilePath -> ModIface -> IO ()-writeIface logger dflags hi_file_path new_iface-    = do createDirectoryIfMissing True (takeDirectory hi_file_path)-         let printer = TraceBinIFace (debugTraceMsg logger dflags 3)-             profile = targetProfile dflags-         writeBinIface profile printer hi_file_path new_iface+read_file :: Logger -> NameCache -> UnitState -> DynFlags -> Module -> FilePath -> IO (MaybeErr SDoc (ModIface, FilePath))+read_file logger name_cache unit_state dflags wanted_mod file_path = do+  trace_if logger (text "readIFace" <+> text file_path) --- @readIface@ tries just the one file.-readIface :: Module -> FilePath-          -> TcRnIf gbl lcl (MaybeErr SDoc ModIface)-        -- Failed err    <=> file not found, or unreadable, or illegible-        -- Succeeded iface <=> successfully found and parsed+  -- Figure out what is recorded in mi_module.  If this is+  -- a fully definite interface, it'll match exactly, but+  -- if it's indefinite, the inside will be uninstantiated!+  let wanted_mod' =+        case getModuleInstantiation wanted_mod of+            (_, Nothing) -> wanted_mod+            (_, Just indef_mod) ->+              instModuleToModule unit_state+                (uninstantiateInstantiatedModule indef_mod)+  read_result <- readIface dflags name_cache wanted_mod' file_path+  case read_result of+    Failed err -> return (Failed (badIfaceFile file_path err))+    Succeeded iface -> return (Succeeded (iface, file_path))+                -- Don't forget to fill in the package name... -readIface wanted_mod file_path-  = do  { res <- tryMostM $-                 readBinIface CheckHiWay QuietBinIFace file_path-        ; case res of-            Right iface-                -- NB: This check is NOT just a sanity check, it is-                -- critical for correctness of recompilation checking-                -- (it lets us tell when -this-unit-id has changed.)-                | wanted_mod == actual_mod-                                -> return (Succeeded iface)-                | otherwise     -> return (Failed err)-                where-                  actual_mod = mi_module iface-                  err = hiModuleNameMismatchWarn wanted_mod actual_mod -            Left exn    -> return (Failed (text (showException exn)))-    }+-- | Write interface file+writeIface :: Logger -> Profile -> FilePath -> ModIface -> IO ()+writeIface logger profile hi_file_path new_iface+    = do createDirectoryIfMissing True (takeDirectory hi_file_path)+         let printer = TraceBinIFace (debugTraceMsg logger 3)+         writeBinIface profile printer hi_file_path new_iface -{--*********************************************************-*                                                       *-        Wired-in interface for GHC.Prim-*                                                       *-*********************************************************--}+-- | @readIface@ tries just the one file.+--+-- Failed err    <=> file not found, or unreadable, or illegible+-- Succeeded iface <=> successfully found and parsed+readIface+  :: DynFlags+  -> NameCache+  -> Module+  -> FilePath+  -> IO (MaybeErr SDoc ModIface)+readIface dflags name_cache wanted_mod file_path = do+  let profile = targetProfile dflags+  res <- tryMost $ readBinIface profile name_cache CheckHiWay QuietBinIFace file_path+  case res of+    Right iface+        -- NB: This check is NOT just a sanity check, it is+        -- critical for correctness of recompilation checking+        -- (it lets us tell when -this-unit-id has changed.)+        | wanted_mod == actual_mod+                        -> return (Succeeded iface)+        | otherwise     -> return (Failed err)+        where+          actual_mod = mi_module iface+          err = hiModuleNameMismatchWarn wanted_mod actual_mod -initExternalPackageState :: ExternalPackageState-initExternalPackageState-  = EPS {-      eps_is_boot          = emptyUFM,-      eps_PIT              = emptyPackageIfaceTable,-      eps_free_holes       = emptyInstalledModuleEnv,-      eps_PTE              = emptyTypeEnv,-      eps_inst_env         = emptyInstEnv,-      eps_fam_inst_env     = emptyFamInstEnv,-      eps_rule_base        = mkRuleBase builtinRules,-        -- Initialise the EPS rule pool with the built-in rules-      eps_mod_fam_inst_env = emptyModuleEnv,-      eps_complete_matches = [],-      eps_ann_env          = emptyAnnEnv,-      eps_stats = EpsStats { n_ifaces_in = 0, n_decls_in = 0, n_decls_out = 0-                           , n_insts_in = 0, n_insts_out = 0-                           , n_rules_in = length builtinRules, n_rules_out = 0 }-    }+    Left exn    -> return (Failed (text (showException exn)))  {- *********************************************************@@ -1008,7 +1016,7 @@         mi_decls    = [],         mi_fixities = fixities,         mi_final_exts = (mi_final_exts empty_iface){ mi_fix_fn = mkIfaceFixCache fixities },-        mi_decl_docs = ghcPrimDeclDocs -- See Note [GHC.Prim Docs]+        mi_docs = Just ghcPrimDeclDocs -- See Note [GHC.Prim Docs]         }   where     empty_iface = emptyFullModIface gHC_PRIM@@ -1060,17 +1068,14 @@ -}  -- | Read binary interface, and print it out-showIface :: HscEnv -> FilePath -> IO ()-showIface hsc_env filename = do-   let dflags  = hsc_dflags hsc_env-   let logger  = hsc_logger hsc_env-       unit_state = hsc_units hsc_env-       printer = putLogMsg logger dflags NoReason SevOutput noSrcSpan . withPprStyle defaultDumpStyle+showIface :: Logger -> DynFlags -> UnitState -> NameCache -> FilePath -> IO ()+showIface logger dflags unit_state name_cache filename = do+   let profile = targetProfile dflags+       printer = logMsg logger MCOutput noSrcSpan . withPprStyle defaultDumpStyle     -- skip the hi way check; we don't want to worry about profiled vs.    -- non-profiled interfaces, for example.-   iface <- initTcRnIf 's' hsc_env () () $-       readBinIface IgnoreHiWay (TraceBinIFace printer) filename+   iface <- readBinIface profile name_cache IgnoreHiWay (TraceBinIFace printer) filename     let -- See Note [Name qualification with --show-iface]        qualifyImportedNames mod _@@ -1079,7 +1084,7 @@        print_unqual = QueryQualify qualifyImportedNames                                    neverQualifyModules                                    neverQualifyPackages-   putLogMsg logger dflags NoReason SevDump noSrcSpan+   logMsg logger MCDump noSrcSpan       $ withPprStyle (mkDumpStyle print_unqual)       $ pprModIface unit_state iface @@ -1110,6 +1115,7 @@         , nest 2 (text "opt_hash:" <+> ppr (mi_opt_hash exts))         , nest 2 (text "hpc_hash:" <+> ppr (mi_hpc_hash exts))         , nest 2 (text "plugin_hash:" <+> ppr (mi_plugin_hash exts))+        , nest 2 (text "src_hash:" <+> ppr (mi_src_hash iface))         , nest 2 (text "sig of:" <+> ppr (mi_sig_of iface))         , nest 2 (text "used TH splices:" <+> ppr (mi_used_th iface))         , nest 2 (text "where")@@ -1127,9 +1133,7 @@         , pprTrustInfo (mi_trust iface)         , pprTrustPkg (mi_trust_pkg iface)         , vcat (map ppr (mi_complete_matches iface))-        , text "module header:" $$ nest 2 (ppr (mi_doc_hdr iface))-        , text "declaration docs:" $$ nest 2 (ppr (mi_decl_docs iface))-        , text "arg docs:" $$ nest 2 (ppr (mi_arg_docs iface))+        , text "docs:" $$ nest 2 (ppr (mi_docs iface))         , text "extensible fields:" $$ nest 2 (pprExtensibleFields (mi_ext_fields iface))         ]   where@@ -1171,6 +1175,8 @@           ppr (usg_file_hash usage)] pprUsage usage@UsageMergedRequirement{}   = hsep [text "merged", ppr (usg_mod usage), ppr (usg_mod_hash usage)]+pprUsage usage@UsageHomeModuleInterface{}+  = hsep [text "implementation", ppr (usg_mod_name usage), ppr (usg_iface_hash usage)]  pprUsageImport :: Outputable a => Usage -> (Usage -> a) -> SDoc pprUsageImport usage usg_mod'@@ -1180,23 +1186,6 @@         safe | usg_safe usage = text "safe"              | otherwise      = text " -/ " --- | Pretty-print unit dependencies-pprDeps :: UnitState -> Dependencies -> SDoc-pprDeps unit_state (Deps { dep_mods = mods, dep_pkgs = pkgs, dep_orphs = orphs,-                           dep_finsts = finsts })-  = pprWithUnitState unit_state $-    vcat [text "module dependencies:" <+> fsep (map ppr_mod mods),-          text "package dependencies:" <+> fsep (map ppr_pkg pkgs),-          text "orphans:" <+> fsep (map ppr orphs),-          text "family instance modules:" <+> fsep (map ppr finsts)-        ]-  where-    ppr_mod (GWIB { gwib_mod = mod_name, gwib_isBoot = boot }) = ppr mod_name <+> ppr_boot boot-    ppr_pkg (pkg,trust_req)  = ppr pkg <>-                               (if trust_req then text "*" else Outputable.empty)-    ppr_boot IsBoot  = text "[boot]"-    ppr_boot NotBoot = Outputable.empty- pprFixities :: [(OccName, Fixity)] -> SDoc pprFixities []    = Outputable.empty pprFixities fixes = text "fixities" <+> pprWithCommas pprFix fixes@@ -1209,13 +1198,13 @@ pprTrustPkg :: Bool -> SDoc pprTrustPkg tpkg = text "require own pkg trusted:" <+> ppr tpkg -instance Outputable Warnings where+instance Outputable (Warnings pass) where     ppr = pprWarns -pprWarns :: Warnings -> SDoc+pprWarns :: Warnings pass -> SDoc pprWarns NoWarnings         = Outputable.empty pprWarns (WarnAll txt)  = text "Warn all" <+> ppr txt-pprWarns (WarnSome prs) = text "Warnings"+pprWarns (WarnSome prs) = text "Warnings:"                         <+> vcat (map pprWarning prs)     where pprWarning (name, txt) = ppr name <+> ppr txt @@ -1227,311 +1216,3 @@ pprExtensibleFields (ExtensibleFields fs) = vcat . map pprField $ toList fs   where     pprField (name, (BinData size _data)) = text name <+> text "-" <+> ppr size <+> text "bytes"--{--*********************************************************-*                                                       *-\subsection{Errors}-*                                                       *-*********************************************************--}--badIfaceFile :: String -> SDoc -> SDoc-badIfaceFile file err-  = vcat [text "Bad interface file:" <+> text file,-          nest 4 err]--hiModuleNameMismatchWarn :: Module -> Module -> SDoc-hiModuleNameMismatchWarn requested_mod read_mod- | moduleUnit requested_mod == moduleUnit read_mod =-    sep [text "Interface file contains module" <+> quotes (ppr read_mod) <> comma,-         text "but we were expecting module" <+> quotes (ppr requested_mod),-         sep [text "Probable cause: the source code which generated interface file",-             text "has an incompatible module name"-            ]-        ]- | otherwise =-  -- ToDo: This will fail to have enough qualification when the package IDs-  -- are the same-  withPprStyle (mkUserStyle alwaysQualify AllTheWay) $-    -- we want the Modules below to be qualified with package names,-    -- so reset the PrintUnqualified setting.-    hsep [ text "Something is amiss; requested module "-         , ppr requested_mod-         , text "differs from name found in the interface file"-         , ppr read_mod-         , parens (text "if these names look the same, try again with -dppr-debug")-         ]--homeModError :: InstalledModule -> ModLocation -> SDoc--- See Note [Home module load error]-homeModError mod location-  = text "attempting to use module " <> quotes (ppr mod)-    <> (case ml_hs_file location of-           Just file -> space <> parens (text file)-           Nothing   -> Outputable.empty)-    <+> text "which is not loaded"----- -------------------------------------------------------------------------------- Error messages--cannotFindInterface :: UnitEnv -> Profile -> ([FilePath] -> SDoc) -> ModuleName -> InstalledFindResult -> SDoc-cannotFindInterface = cantFindInstalledErr (sLit "Failed to load interface for")-                                           (sLit "Ambiguous interface for")--cantFindInstalledErr-    :: PtrString-    -> PtrString-    -> UnitEnv-    -> Profile-    -> ([FilePath] -> SDoc)-    -> ModuleName-    -> InstalledFindResult-    -> SDoc-cantFindInstalledErr cannot_find _ unit_env profile tried_these mod_name find_result-  = ptext cannot_find <+> quotes (ppr mod_name)-    $$ more_info-  where-    home_unit  = ue_home_unit unit_env-    unit_state = ue_units unit_env-    build_tag  = waysBuildTag (profileWays profile)--    more_info-      = case find_result of-            InstalledNoPackage pkg-                -> text "no unit id matching" <+> quotes (ppr pkg) <+>-                   text "was found" $$ looks_like_srcpkgid pkg--            InstalledNotFound files mb_pkg-                | Just pkg <- mb_pkg, not (isHomeUnitId home_unit pkg)-                -> not_found_in_package pkg files--                | null files-                -> text "It is not a module in the current program, or in any known package."--                | otherwise-                -> tried_these files--            _ -> panic "cantFindInstalledErr"--    looks_like_srcpkgid :: UnitId -> SDoc-    looks_like_srcpkgid pk-     -- Unsafely coerce a unit id (i.e. an installed package component-     -- identifier) into a PackageId and see if it means anything.-     | (pkg:pkgs) <- searchPackageId unit_state (PackageId (unitIdFS pk))-     = parens (text "This unit ID looks like the source package ID;" $$-       text "the real unit ID is" <+> quotes (ftext (unitIdFS (unitId pkg))) $$-       (if null pkgs then Outputable.empty-        else text "and" <+> int (length pkgs) <+> text "other candidates"))-     -- Todo: also check if it looks like a package name!-     | otherwise = Outputable.empty--    not_found_in_package pkg files-       | build_tag /= ""-       = let-            build = if build_tag == "p" then "profiling"-                                        else "\"" ++ build_tag ++ "\""-         in-         text "Perhaps you haven't installed the " <> text build <>-         text " libraries for package " <> quotes (ppr pkg) <> char '?' $$-         tried_these files--       | otherwise-       = text "There are files missing in the " <> quotes (ppr pkg) <>-         text " package," $$-         text "try running 'ghc-pkg check'." $$-         tried_these files--may_show_locations :: DynFlags -> [FilePath] -> SDoc-may_show_locations dflags files-    | null files = Outputable.empty-    | verbosity dflags < 3 =-          text "Use -v (or `:set -v` in ghci) " <>-              text "to see a list of the files searched for."-    | otherwise =-          hang (text "Locations searched:") 2 $ vcat (map text files)--cannotFindModule :: HscEnv -> ModuleName -> FindResult -> SDoc-cannotFindModule hsc_env = cannotFindModule'-    (hsc_dflags   hsc_env)-    (hsc_unit_env hsc_env)-    (targetProfile (hsc_dflags hsc_env))---cannotFindModule' :: DynFlags -> UnitEnv -> Profile -> ModuleName -> FindResult -> SDoc-cannotFindModule' dflags unit_env profile mod res = pprWithUnitState (ue_units unit_env) $-  cantFindErr (gopt Opt_BuildingCabalPackage dflags)-              (sLit cannotFindMsg)-              (sLit "Ambiguous module name")-              unit_env-              profile-              (may_show_locations dflags)-              mod-              res-  where-    cannotFindMsg =-      case res of-        NotFound { fr_mods_hidden = hidden_mods-                 , fr_pkgs_hidden = hidden_pkgs-                 , fr_unusables = unusables }-          | not (null hidden_mods && null hidden_pkgs && null unusables)-          -> "Could not load module"-        _ -> "Could not find module"--cantFindErr-    :: Bool -- ^ Using Cabal?-    -> PtrString-    -> PtrString-    -> UnitEnv-    -> Profile-    -> ([FilePath] -> SDoc)-    -> ModuleName-    -> FindResult-    -> SDoc-cantFindErr _ _ multiple_found _ _ _ mod_name (FoundMultiple mods)-  | Just pkgs <- unambiguousPackages-  = hang (ptext multiple_found <+> quotes (ppr mod_name) <> colon) 2 (-       sep [text "it was found in multiple packages:",-                hsep (map ppr pkgs) ]-    )-  | otherwise-  = hang (ptext multiple_found <+> quotes (ppr mod_name) <> colon) 2 (-       vcat (map pprMod mods)-    )-  where-    unambiguousPackages = foldl' unambiguousPackage (Just []) mods-    unambiguousPackage (Just xs) (m, ModOrigin (Just _) _ _ _)-        = Just (moduleUnit m : xs)-    unambiguousPackage _ _ = Nothing--    pprMod (m, o) = text "it is bound as" <+> ppr m <+>-                                text "by" <+> pprOrigin m o-    pprOrigin _ ModHidden = panic "cantFindErr: bound by mod hidden"-    pprOrigin _ (ModUnusable _) = panic "cantFindErr: bound by mod unusable"-    pprOrigin m (ModOrigin e res _ f) = sep $ punctuate comma (-      if e == Just True-          then [text "package" <+> ppr (moduleUnit m)]-          else [] ++-      map ((text "a reexport in package" <+>)-                .ppr.mkUnit) res ++-      if f then [text "a package flag"] else []-      )--cantFindErr using_cabal cannot_find _ unit_env profile tried_these mod_name find_result-  = ptext cannot_find <+> quotes (ppr mod_name)-    $$ more_info-  where-    home_unit  = ue_home_unit unit_env-    more_info-      = case find_result of-            NoPackage pkg-                -> text "no unit id matching" <+> quotes (ppr pkg) <+>-                   text "was found"--            NotFound { fr_paths = files, fr_pkg = mb_pkg-                     , fr_mods_hidden = mod_hiddens, fr_pkgs_hidden = pkg_hiddens-                     , fr_unusables = unusables, fr_suggestions = suggest }-                | Just pkg <- mb_pkg, not (isHomeUnit home_unit pkg)-                -> not_found_in_package pkg files--                | not (null suggest)-                -> pp_suggestions suggest $$ tried_these files--                | null files && null mod_hiddens &&-                  null pkg_hiddens && null unusables-                -> text "It is not a module in the current program, or in any known package."--                | otherwise-                -> vcat (map pkg_hidden pkg_hiddens) $$-                   vcat (map mod_hidden mod_hiddens) $$-                   vcat (map unusable unusables) $$-                   tried_these files--            _ -> panic "cantFindErr"--    build_tag = waysBuildTag (profileWays profile)--    not_found_in_package pkg files-       | build_tag /= ""-       = let-            build = if build_tag == "p" then "profiling"-                                        else "\"" ++ build_tag ++ "\""-         in-         text "Perhaps you haven't installed the " <> text build <>-         text " libraries for package " <> quotes (ppr pkg) <> char '?' $$-         tried_these files--       | otherwise-       = text "There are files missing in the " <> quotes (ppr pkg) <>-         text " package," $$-         text "try running 'ghc-pkg check'." $$-         tried_these files--    pkg_hidden :: Unit -> SDoc-    pkg_hidden uid =-        text "It is a member of the hidden package"-        <+> quotes (ppr uid)-        --FIXME: we don't really want to show the unit id here we should-        -- show the source package id or installed package id if it's ambiguous-        <> dot $$ pkg_hidden_hint uid--    pkg_hidden_hint uid-     | using_cabal-        = let pkg = expectJust "pkg_hidden" (lookupUnit (ue_units unit_env) uid)-           in text "Perhaps you need to add" <+>-              quotes (ppr (unitPackageName pkg)) <+>-              text "to the build-depends in your .cabal file."-     | Just pkg <- lookupUnit (ue_units unit_env) uid-         = text "You can run" <+>-           quotes (text ":set -package " <> ppr (unitPackageName pkg)) <+>-           text "to expose it." $$-           text "(Note: this unloads all the modules in the current scope.)"-     | otherwise = Outputable.empty--    mod_hidden pkg =-        text "it is a hidden module in the package" <+> quotes (ppr pkg)--    unusable (pkg, reason)-      = text "It is a member of the package"-      <+> quotes (ppr pkg)-      $$ pprReason (text "which is") reason--    pp_suggestions :: [ModuleSuggestion] -> SDoc-    pp_suggestions sugs-      | null sugs = Outputable.empty-      | otherwise = hang (text "Perhaps you meant")-                       2 (vcat (map pp_sugg sugs))--    -- NB: Prefer the *original* location, and then reexports, and then-    -- package flags when making suggestions.  ToDo: if the original package-    -- also has a reexport, prefer that one-    pp_sugg (SuggestVisible m mod o) = ppr m <+> provenance o-      where provenance ModHidden = Outputable.empty-            provenance (ModUnusable _) = Outputable.empty-            provenance (ModOrigin{ fromOrigUnit = e,-                                   fromExposedReexport = res,-                                   fromPackageFlag = f })-              | Just True <- e-                 = parens (text "from" <+> ppr (moduleUnit mod))-              | f && moduleName mod == m-                 = parens (text "from" <+> ppr (moduleUnit mod))-              | (pkg:_) <- res-                 = parens (text "from" <+> ppr (mkUnit pkg)-                    <> comma <+> text "reexporting" <+> ppr mod)-              | f-                 = parens (text "defined via package flags to be"-                    <+> ppr mod)-              | otherwise = Outputable.empty-    pp_sugg (SuggestHidden m mod o) = ppr m <+> provenance o-      where provenance ModHidden =  Outputable.empty-            provenance (ModUnusable _) = Outputable.empty-            provenance (ModOrigin{ fromOrigUnit = e,-                                   fromHiddenReexport = rhs })-              | Just False <- e-                 = parens (text "needs flag -package-id"-                    <+> ppr (moduleUnit mod))-              | (pkg:_) <- rhs-                 = parens (text "needs flag -package-id"-                    <+> ppr (mkUnit pkg))-              | otherwise = Outputable.empty
GHC/Iface/Make.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP                      #-}+ {-# LANGUAGE NondecreasingIndentation #-}  {-@@ -19,8 +19,6 @@    ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Hs@@ -48,13 +46,13 @@ import GHC.Core.Multiplicity import GHC.Core.InstEnv import GHC.Core.FamInstEnv+import GHC.Core.Ppr import GHC.Core.Unify( RoughMatchTc(..) )  import GHC.Driver.Env import GHC.Driver.Backend import GHC.Driver.Session-import GHC.Driver.Ppr-import GHC.Driver.Plugins (LoadedPlugin(..))+import GHC.Driver.Plugins  import GHC.Types.Id import GHC.Types.Fixity.Env@@ -77,20 +75,23 @@  import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Utils.Misc  hiding ( eqListBy ) import GHC.Utils.Logger+import GHC.Utils.Trace  import GHC.Data.FastString import GHC.Data.Maybe  import GHC.HsToCore.Docs-import GHC.HsToCore.Usage ( mkUsageInfo, mkUsedNames, mkDependencies )+import GHC.HsToCore.Usage ( mkUsageInfo, mkUsedNames )  import GHC.Unit import GHC.Unit.Module.Warnings import GHC.Unit.Module.ModIface import GHC.Unit.Module.ModDetails import GHC.Unit.Module.ModGuts+import GHC.Unit.Module.ModSummary import GHC.Unit.Module.Deps  import Data.Function@@ -98,6 +99,7 @@ import Data.Ord import Data.IORef + {- ************************************************************************ *                                                                      *@@ -108,9 +110,10 @@  mkPartialIface :: HscEnv                -> ModDetails+               -> ModSummary                -> ModGuts                -> PartialModIface-mkPartialIface hsc_env mod_details+mkPartialIface hsc_env mod_details mod_summary   ModGuts{ mg_module       = this_mod          , mg_hsc_src      = hsc_src          , mg_usages       = usages@@ -122,12 +125,10 @@          , mg_hpc_info     = hpc_info          , mg_safe_haskell = safe_mode          , mg_trust_pkg    = self_trust-         , mg_doc_hdr      = doc_hdr-         , mg_decl_docs    = decl_docs-         , mg_arg_docs     = arg_docs+         , mg_docs         = docs          }   = mkIface_ hsc_env this_mod hsc_src used_th deps rdr_env fix_env warns hpc_info self_trust-             safe_mode usages doc_hdr decl_docs arg_docs mod_details+             safe_mode usages docs mod_summary mod_details  -- | Fully instantiate an interface. Adds fingerprints and potentially code -- generator produced information.@@ -149,23 +150,26 @@      -- Debug printing     let unit_state = hsc_units hsc_env-    dumpIfSet_dyn (hsc_logger hsc_env) (hsc_dflags hsc_env) Opt_D_dump_hi "FINAL INTERFACE" FormatText+    putDumpFileMaybe (hsc_logger hsc_env) Opt_D_dump_hi "FINAL INTERFACE" FormatText       (pprModIface unit_state full_iface)      return full_iface  updateDecl :: [IfaceDecl] -> Maybe CgInfos -> [IfaceDecl] updateDecl decls Nothing = decls-updateDecl decls (Just CgInfos{ cgNonCafs = NonCaffySet non_cafs, cgLFInfos = lf_infos }) = map update_decl decls+updateDecl decls (Just CgInfos{ cgNonCafs = NonCaffySet non_cafs, cgLFInfos = lf_infos, cgTagSigs = tag_sigs })+  = map update_decl decls   where     update_decl (IfaceId nm ty details infos)       | let not_caffy = elemNameSet nm non_cafs       , let mb_lf_info = lookupNameEnv lf_infos nm-      , WARN( isNothing mb_lf_info, text "Name without LFInfo:" <+> ppr nm ) True+      , let sig = lookupNameEnv tag_sigs nm+      , warnPprTrace (isNothing mb_lf_info) "updateDecl" (text "Name without LFInfo:" <+> ppr nm) True         -- Only allocate a new IfaceId if we're going to update the infos-      , isJust mb_lf_info || not_caffy+      , isJust mb_lf_info || not_caffy || isJust sig       = IfaceId nm ty details $-          (if not_caffy then (HsNoCafRefs :) else id)+          (if not_caffy then (HsNoCafRefs :) else id) $+          (if isJust sig then (HsTagSig (fromJust sig):) else id) $           (case mb_lf_info of              Nothing -> infos -- LFInfos not available when building .cmm files              Just lf_info -> HsLFInfo (toIfaceLFInfo nm lf_info) : infos)@@ -179,9 +183,10 @@ mkIfaceTc :: HscEnv           -> SafeHaskellMode    -- The safe haskell mode           -> ModDetails         -- gotten from mkBootModDetails, probably+          -> ModSummary           -> TcGblEnv           -- Usages, deprecations, etc           -> IO ModIface-mkIfaceTc hsc_env safe_mode mod_details+mkIfaceTc hsc_env safe_mode mod_details mod_summary   tc_result@TcGblEnv{ tcg_mod = this_mod,                       tcg_src = hsc_src,                       tcg_imports = imports,@@ -195,13 +200,16 @@                     }   = do           let used_names = mkUsedNames tc_result-          let pluginModules = map lpModule (hsc_plugins hsc_env)+          let pluginModules = map lpModule (loadedPlugins (hsc_plugins hsc_env))           let home_unit = hsc_home_unit hsc_env-          deps <- mkDependencies (homeUnitId home_unit)-                    (map mi_module pluginModules) tc_result+          let deps = mkDependencies home_unit+                                    (tcg_mod tc_result)+                                    (tcg_imports tc_result)+                                    (map mi_module pluginModules)           let hpc_info = emptyHpcInfo other_hpc_info           used_th <- readIORef tc_splice_used           dep_files <- (readIORef dependent_files)+          (needed_links, needed_pkgs) <- readIORef (tcg_th_needed_deps tc_result)           -- Do NOT use semantic module here; this_mod in mkUsageInfo           -- is used solely to decide if we should record a dependency           -- or not.  When we instantiate a signature, the semantic@@ -210,35 +218,34 @@           -- module and does not need to be recorded as a dependency.           -- See Note [Identity versus semantic module]           usages <- mkUsageInfo hsc_env this_mod (imp_mods imports) used_names-                      dep_files merged pluginModules+                      dep_files merged needed_links needed_pkgs -          (doc_hdr', doc_map, arg_map) <- extractDocs tc_result+          docs <- extractDocs (ms_hspp_opts mod_summary) tc_result            let partial_iface = mkIface_ hsc_env                    this_mod hsc_src                    used_th deps rdr_env                    fix_env warns hpc_info                    (imp_trust_own_pkg imports) safe_mode usages-                   doc_hdr' doc_map arg_map+                   docs mod_summary                    mod_details            mkFullIface hsc_env partial_iface Nothing  mkIface_ :: HscEnv -> Module -> HscSource          -> Bool -> Dependencies -> GlobalRdrEnv-         -> NameEnv FixItem -> Warnings -> HpcInfo+         -> NameEnv FixItem -> Warnings GhcRn -> HpcInfo          -> Bool          -> SafeHaskellMode          -> [Usage]-         -> Maybe HsDocString-         -> DeclDocMap-         -> ArgDocMap+         -> Maybe Docs+         -> ModSummary          -> ModDetails          -> PartialModIface mkIface_ hsc_env          this_mod hsc_src used_th deps rdr_env fix_env src_warns          hpc_info pkg_trust_req safe_mode usages-         doc_hdr decl_docs arg_docs+         docs mod_summary          ModDetails{  md_insts     = insts,                       md_fam_insts = fam_insts,                       md_rules     = rules,@@ -271,13 +278,13 @@                       -- See Note [Identity versus semantic module]          fixities    = sortBy (comparing fst)-          [(occ,fix) | FixItem occ fix <- nameEnvElts fix_env]-          -- The order of fixities returned from nameEnvElts is not+          [(occ,fix) | FixItem occ fix <- nonDetNameEnvElts fix_env]+          -- The order of fixities returned from nonDetNameEnvElts is not           -- deterministic, so we sort by OccName to canonicalize it.           -- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM for more details.         warns       = src_warns         iface_rules = map coreRuleToIfaceRule rules-        iface_insts = map instanceToIfaceInst $ fixSafeInstances safe_mode insts+        iface_insts = map instanceToIfaceInst $ fixSafeInstances safe_mode (instEnvElts insts)         iface_fam_insts = map famInstToIfaceFamInst fam_insts         trust_info  = setSafeMode safe_mode         annotations = map mkIfaceAnnotation anns@@ -311,11 +318,11 @@           mi_trust       = trust_info,           mi_trust_pkg   = pkg_trust_req,           mi_complete_matches = icomplete_matches,-          mi_doc_hdr     = doc_hdr,-          mi_decl_docs   = decl_docs,-          mi_arg_docs    = arg_docs,+          mi_docs        = docs,           mi_final_exts  = (),-          mi_ext_fields  = emptyExtensibleFields }+          mi_ext_fields  = emptyExtensibleFields,+          mi_src_hash = ms_hs_hash mod_summary+          }   where      cmp_rule     = lexicalCompareFS `on` ifRuleName      -- Compare these lexicographically by OccName, *not* by unique,@@ -646,7 +653,7 @@         (env2, if_decl) = tyConToIfaceDecl env1 tc      toIfaceClassOp (sel_id, def_meth)-        = ASSERT( sel_tyvars == binderVars tc_binders )+        = assert (sel_tyvars == binderVars tc_binders) $           IfaceClassOp (getName sel_id)                        (tidyToIfaceType env1 op_ty)                        (fmap toDmSpec def_meth)@@ -689,11 +696,13 @@                              , is_cls_nm = cls_name, is_cls = cls                              , is_tcs = rough_tcs                              , is_orphan = orph })-  = ASSERT( cls_name == className cls )+  = assert (cls_name == className cls) $     IfaceClsInst { ifDFun     = idName dfun_id                  , ifOFlag    = oflag                  , ifInstCls  = cls_name-                 , ifInstTys  = ifaceRoughMatchTcs rough_tcs+                 , ifInstTys  = ifaceRoughMatchTcs $ tail rough_tcs+                   -- N.B. Drop the class name from the rough match template+                   --      It is put back by GHC.Core.InstEnv.mkImportedInstance                  , ifInstOrph = orph }  --------------------------@@ -707,7 +716,7 @@                  , ifFamInstOrph     = orph }   where     fam_decl = tyConName $ coAxiomTyCon axiom-    mod = ASSERT( isExternalName (coAxiomName axiom) )+    mod = assert (isExternalName (coAxiomName axiom)) $           nameModule (coAxiomName axiom)     is_local name = nameIsLocalOrFrom mod name @@ -721,14 +730,17 @@ ifaceRoughMatchTcs :: [RoughMatchTc] -> [Maybe IfaceTyCon] ifaceRoughMatchTcs tcs = map do_rough tcs   where-    do_rough OtherTc     = Nothing-    do_rough (KnownTc n) = Just (toIfaceTyCon_name n)+    do_rough RM_WildCard     = Nothing+    do_rough (RM_KnownTc n) = Just (toIfaceTyCon_name n)  -------------------------- coreRuleToIfaceRule :: CoreRule -> IfaceRule-coreRuleToIfaceRule (BuiltinRule { ru_fn = fn})-  = pprTrace "toHsRule: builtin" (ppr fn) $-    bogusIfaceRule fn+-- A plugin that installs a BuiltinRule in a CoreDoPluginPass should+-- ensure that there's another CoreDoPluginPass that removes the rule.+-- Otherwise a module using the plugin and compiled with -fno-omit-interface-pragmas+-- would cause panic when the rule is attempted to be written to the interface file.+coreRuleToIfaceRule rule@(BuiltinRule {})+  = pprPanic "toHsRule:" (pprRule rule)  coreRuleToIfaceRule (Rule { ru_name = name, ru_fn = fn,                             ru_act = act, ru_bndrs = bndrs,@@ -749,10 +761,3 @@     do_arg (Type ty)     = IfaceType (toIfaceType (deNoteType ty))     do_arg (Coercion co) = IfaceCo   (toIfaceCoercion co)     do_arg arg           = toIfaceExpr arg--bogusIfaceRule :: Name -> IfaceRule-bogusIfaceRule id_name-  = IfaceRule { ifRuleName = fsLit "bogus", ifActivation = NeverActive,-        ifRuleBndrs = [], ifRuleHead = id_name, ifRuleArgs = [],-        ifRuleRhs = IfaceExt id_name, ifRuleOrph = IsOrphan,-        ifRuleAuto = True }
GHC/Iface/Recomp.hs view
@@ -1,29 +1,37 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE LambdaCase #-}  -- | Module for detecting if recompilation is required module GHC.Iface.Recomp    ( checkOldIface    , RecompileRequired(..)+   , needsRecompileBecause+   , recompThen+   , MaybeValidated(..)+   , outOfDateItemBecause+   , RecompReason (..)+   , CompileReason(..)    , recompileRequired    , addFingerprints    ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Driver.Backend+import GHC.Driver.Config.Finder import GHC.Driver.Env import GHC.Driver.Session import GHC.Driver.Ppr-import GHC.Driver.Plugins ( PluginRecompile(..), PluginWithArgs(..), pluginRecompile', plugins )+import GHC.Driver.Plugins  import GHC.Iface.Syntax import GHC.Iface.Recomp.Binary import GHC.Iface.Load import GHC.Iface.Recomp.Flags+import GHC.Iface.Env  import GHC.Core import GHC.Tc.Utils.Monad@@ -31,15 +39,18 @@  import GHC.Data.Graph.Directed import GHC.Data.Maybe-import GHC.Data.FastString  import GHC.Utils.Error import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Utils.Outputable as Outputable import GHC.Utils.Misc as Utils hiding ( eqListBy ) import GHC.Utils.Binary import GHC.Utils.Fingerprint import GHC.Utils.Exception+import GHC.Utils.Logger+import GHC.Utils.Constants (debugIsOn)+import GHC.Utils.Trace  import GHC.Types.Annotations import GHC.Types.Name@@ -48,8 +59,6 @@ import GHC.Types.Unique import GHC.Types.Unique.Set import GHC.Types.Fixity.Env-import GHC.Types.SourceFile- import GHC.Unit.External import GHC.Unit.Finder import GHC.Unit.State@@ -61,15 +70,19 @@ import GHC.Unit.Module.Deps  import Control.Monad-import Data.Function-import Data.List (find, sortBy, sort)+import Data.List (sortBy, sort) import qualified Data.Map as Map import qualified Data.Set as Set import Data.Word (Word64)+import Data.Either  --Qualified import so we can define a Semigroup instance -- but it doesn't clash with Outputable.<> import qualified Data.Semigroup+import GHC.List (uncons)+import Data.Ord+import Data.Containers.ListUtils+import Data.Bifunctor  {-   -----------------------------------------------@@ -104,15 +117,45 @@ -}  data RecompileRequired+  -- | everything is up to date, recompilation is not required   = UpToDate-       -- ^ everything is up to date, recompilation is not required-  | MustCompile-       -- ^ The .hs file has been touched, or the .o/.hi file does not exist-  | RecompBecause String-       -- ^ The .o/.hi files are up to date, but something else has changed-       -- to force recompilation; the String says what (one-line summary)-   deriving Eq+  -- | Need to compile the module+  | NeedsRecompile !CompileReason+   deriving (Eq) +needsRecompileBecause :: RecompReason -> RecompileRequired+needsRecompileBecause = NeedsRecompile . RecompBecause++data MaybeValidated a+  -- | The item contained is validated to be up to date+  = UpToDateItem a+  -- | The item is are absent altogether or out of date, for the reason given.+  | OutOfDateItem+      !CompileReason+      -- ^ the reason we need to recompile.+      (Maybe a)+      -- ^ The old item, if it exists+  deriving (Functor)++outOfDateItemBecause :: RecompReason -> Maybe a -> MaybeValidated a+outOfDateItemBecause reason item = OutOfDateItem (RecompBecause reason) item++data CompileReason+  -- | The .hs file has been touched, or the .o/.hi file does not exist+  = MustCompile+  -- | The .o/.hi files are up to date, but something else has changed+  -- to force recompilation; the String says what (one-line summary)+  | RecompBecause !RecompReason+   deriving (Eq)++instance Outputable RecompileRequired where+  ppr UpToDate = text "UpToDate"+  ppr (NeedsRecompile reason) = ppr reason++instance Outputable CompileReason where+  ppr MustCompile = text "MustCompile"+  ppr (RecompBecause r) = text "RecompBecause" <+> ppr r+ instance Semigroup RecompileRequired where   UpToDate <> r = r   mc <> _       = mc@@ -120,94 +163,187 @@ instance Monoid RecompileRequired where   mempty = UpToDate +data RecompReason+  = UnitDepRemoved UnitId+  | ModulePackageChanged String+  | SourceFileChanged+  | ThisUnitIdChanged+  | ImpurePlugin+  | PluginsChanged+  | PluginFingerprintChanged+  | ModuleInstChanged+  | HieMissing+  | HieOutdated+  | SigsMergeChanged+  | ModuleChanged ModuleName+  | ModuleRemoved (UnitId, ModuleName)+  | ModuleAdded (UnitId, ModuleName)+  | ModuleChangedRaw ModuleName+  | ModuleChangedIface ModuleName+  | FileChanged FilePath+  | CustomReason String+  | FlagsChanged+  | OptimFlagsChanged+  | HpcFlagsChanged+  | MissingBytecode+  | MissingObjectFile+  | MissingDynObjectFile+  | MissingDynHiFile+  | MismatchedDynHiFile+  | ObjectsChanged+  | LibraryChanged+  deriving (Eq)++instance Outputable RecompReason where+  ppr = \case+    UnitDepRemoved uid       -> ppr uid <+> text "removed"+    ModulePackageChanged s   -> text s <+> text "package changed"+    SourceFileChanged        -> text "Source file changed"+    ThisUnitIdChanged        -> text "-this-unit-id changed"+    ImpurePlugin             -> text "Impure plugin forced recompilation"+    PluginsChanged           -> text "Plugins changed"+    PluginFingerprintChanged -> text "Plugin fingerprint changed"+    ModuleInstChanged        -> text "Implementing module changed"+    HieMissing               -> text "HIE file is missing"+    HieOutdated              -> text "HIE file is out of date"+    SigsMergeChanged         -> text "Signatures to merge in changed"+    ModuleChanged m          -> ppr m <+> text "changed"+    ModuleChangedRaw m       -> ppr m <+> text "changed (raw)"+    ModuleChangedIface m     -> ppr m <+> text "changed (interface)"+    ModuleRemoved (_uid, m)   -> ppr m <+> text "removed"+    ModuleAdded (_uid, m)     -> ppr m <+> text "added"+    FileChanged fp           -> text fp <+> text "changed"+    CustomReason s           -> text s+    FlagsChanged             -> text "Flags changed"+    OptimFlagsChanged        -> text "Optimisation flags changed"+    HpcFlagsChanged          -> text "HPC flags changed"+    MissingBytecode          -> text "Missing bytecode"+    MissingObjectFile        -> text "Missing object file"+    MissingDynObjectFile     -> text "Missing dynamic object file"+    MissingDynHiFile         -> text "Missing dynamic interface file"+    MismatchedDynHiFile     -> text "Mismatched dynamic interface file"+    ObjectsChanged          -> text "Objects changed"+    LibraryChanged          -> text "Library changed"+ recompileRequired :: RecompileRequired -> Bool recompileRequired UpToDate = False recompileRequired _ = True +recompThen :: Monad m => m RecompileRequired -> m RecompileRequired -> m RecompileRequired+recompThen ma mb = ma >>= \case+  UpToDate              -> mb+  rr@(NeedsRecompile _) -> pure rr++checkList :: Monad m => [m RecompileRequired] -> m RecompileRequired+checkList = \case+  []               -> return UpToDate+  (check : checks) -> check `recompThen` checkList checks++----------------------+ -- | Top level function to check if the version of an old interface file -- is equivalent to the current source file the user asked us to compile.--- If the same, we can avoid recompilation. We return a tuple where the--- first element is a bool saying if we should recompile the object file--- and the second is maybe the interface file, where Nothing means to--- rebuild the interface file and not use the existing one.+-- If the same, we can avoid recompilation.+--+-- We return on the outside whether the interface file is up to date, providing+-- evidence that is with a `ModIface`. In the case that it isn't, we may also+-- return a found or provided `ModIface`. Why we don't always return the old+-- one, if it exists, is unclear to me, except that I tried it and some tests+-- failed (see #18205). checkOldIface   :: HscEnv   -> ModSummary-  -> SourceModified   -> Maybe ModIface         -- Old interface from compilation manager, if any-  -> IO (RecompileRequired, Maybe ModIface)+  -> IO (MaybeValidated ModIface) -checkOldIface hsc_env mod_summary source_modified maybe_iface+checkOldIface hsc_env mod_summary maybe_iface   = do  let dflags = hsc_dflags hsc_env         let logger = hsc_logger hsc_env-        showPass logger dflags $+        showPass logger $             "Checking old interface for " ++               (showPpr dflags $ ms_mod mod_summary) ++               " (use -ddump-hi-diffs for more details)"         initIfaceCheck (text "checkOldIface") hsc_env $-            check_old_iface hsc_env mod_summary source_modified maybe_iface+            check_old_iface hsc_env mod_summary maybe_iface  check_old_iface   :: HscEnv   -> ModSummary-  -> SourceModified   -> Maybe ModIface-  -> IfG (RecompileRequired, Maybe ModIface)+  -> IfG (MaybeValidated ModIface) -check_old_iface hsc_env mod_summary src_modified maybe_iface+check_old_iface hsc_env mod_summary maybe_iface   = let dflags = hsc_dflags hsc_env+        logger = hsc_logger hsc_env         getIface =             case maybe_iface of                 Just _  -> do-                    traceIf (text "We already have the old interface for" <+>+                    trace_if logger (text "We already have the old interface for" <+>                       ppr (ms_mod mod_summary))                     return maybe_iface-                Nothing -> loadIface+                Nothing -> loadIface dflags (msHiFilePath mod_summary) -        loadIface = do-             let iface_path = msHiFilePath mod_summary-             read_result <- readIface (ms_mod mod_summary) iface_path+        loadIface read_dflags iface_path = do+             let ncu        = hsc_NC hsc_env+             read_result <- readIface read_dflags ncu (ms_mod mod_summary) iface_path              case read_result of                  Failed err -> do-                     traceIf (text "FYI: cannot read old interface file:" $$ nest 4 err)-                     traceHiDiffs (text "Old interface file was invalid:" $$ nest 4 err)+                     trace_if logger (text "FYI: cannot read old interface file:" $$ nest 4 err)+                     trace_hi_diffs logger (text "Old interface file was invalid:" $$ nest 4 err)                      return Nothing                  Succeeded iface -> do-                     traceIf (text "Read the interface file" <+> text iface_path)+                     trace_if logger (text "Read the interface file" <+> text iface_path)                      return $ Just iface+        check_dyn_hi :: ModIface+                  -> IfG (MaybeValidated ModIface)+                  -> IfG (MaybeValidated ModIface)+        check_dyn_hi normal_iface recomp_check | gopt Opt_BuildDynamicToo dflags = do+          res <- recomp_check+          case res of+            UpToDateItem _ -> do+              maybe_dyn_iface <- liftIO $ loadIface (setDynamicNow dflags) (msDynHiFilePath mod_summary)+              case maybe_dyn_iface of+                Nothing -> return $ outOfDateItemBecause MissingDynHiFile Nothing+                Just dyn_iface | mi_iface_hash (mi_final_exts dyn_iface)+                                    /= mi_iface_hash (mi_final_exts normal_iface)+                  -> return $ outOfDateItemBecause MismatchedDynHiFile Nothing+                Just {} -> return res+            _ -> return res+        check_dyn_hi _ recomp_check = recomp_check +         src_changed-            | gopt Opt_ForceRecomp (hsc_dflags hsc_env) = True-            | SourceModified <- src_modified = True+            | gopt Opt_ForceRecomp dflags    = True             | otherwise = False     in do         when src_changed $-            traceHiDiffs (nest 4 $ text "Source file changed or recompilation check turned off")+            liftIO $ trace_hi_diffs logger (nest 4 $ text "Recompilation check turned off")          case src_changed of             -- If the source has changed and we're in interactive mode,             -- avoid reading an interface; just return the one we might             -- have been supplied with.             True | not (backendProducesObject $ backend dflags) ->-                return (MustCompile, maybe_iface)+                return $ OutOfDateItem MustCompile maybe_iface              -- Try and read the old interface for the current module             -- from the .hi file left from the last time we compiled it             True -> do-                maybe_iface' <- getIface-                return (MustCompile, maybe_iface')+                maybe_iface' <- liftIO $ getIface+                return $ OutOfDateItem MustCompile maybe_iface'              False -> do-                maybe_iface' <- getIface+                maybe_iface' <- liftIO $ getIface                 case maybe_iface' of                     -- We can't retrieve the iface-                    Nothing    -> return (MustCompile, Nothing)+                    Nothing    -> return $ OutOfDateItem MustCompile Nothing                      -- We have got the old iface; check its versions                     -- even in the SourceUnmodifiedAndStable case we                     -- should check versions because some packages                     -- might have changed or gone away.-                    Just iface -> checkVersions hsc_env mod_summary iface+                    Just iface ->+                      check_dyn_hi iface $ checkVersions hsc_env mod_summary iface  -- | Check if a module is still the same 'version'. --@@ -223,32 +359,31 @@ checkVersions :: HscEnv               -> ModSummary               -> ModIface       -- Old interface-              -> IfG (RecompileRequired, Maybe ModIface)+              -> IfG (MaybeValidated ModIface) checkVersions hsc_env mod_summary iface-  = do { traceHiDiffs (text "Considering whether compilation is required for" <+>+  = do { liftIO $ trace_hi_diffs logger+                        (text "Considering whether compilation is required for" <+>                         ppr (mi_module iface) <> colon)         -- readIface will have verified that the UnitId matches,        -- but we ALSO must make sure the instantiation matches up.  See        -- test case bkpcabal04!+       ; hsc_env <- getTopEnv+       ; if mi_src_hash iface /= ms_hs_hash mod_summary+            then return $ outOfDateItemBecause SourceFileChanged Nothing else do {        ; if not (isHomeModule home_unit (mi_module iface))-            then return (RecompBecause "-this-unit-id changed", Nothing) else do {-       ; recomp <- checkFlagHash hsc_env iface-       ; if recompileRequired recomp then return (recomp, Nothing) else do {-       ; recomp <- checkOptimHash hsc_env iface-       ; if recompileRequired recomp then return (recomp, Nothing) else do {-       ; recomp <- checkHpcHash hsc_env iface-       ; if recompileRequired recomp then return (recomp, Nothing) else do {-       ; recomp <- checkMergedSignatures mod_summary iface-       ; if recompileRequired recomp then return (recomp, Nothing) else do {-       ; recomp <- checkHsig mod_summary iface-       ; if recompileRequired recomp then return (recomp, Nothing) else do {-       ; recomp <- checkHie mod_summary-       ; if recompileRequired recomp then return (recomp, Nothing) else do {+            then return $ outOfDateItemBecause ThisUnitIdChanged Nothing else do {+       ; recomp <- liftIO $ checkFlagHash hsc_env iface+                             `recompThen` checkOptimHash hsc_env iface+                             `recompThen` checkHpcHash hsc_env iface+                             `recompThen` checkMergedSignatures hsc_env mod_summary iface+                             `recompThen` checkHsig logger home_unit mod_summary iface+                             `recompThen` pure (checkHie dflags mod_summary)+       ; case recomp of (NeedsRecompile reason) -> return $ OutOfDateItem reason Nothing ; _ -> do {        ; recomp <- checkDependencies hsc_env mod_summary iface-       ; if recompileRequired recomp then return (recomp, Just iface) else do {-       ; recomp <- checkPlugins hsc_env iface-       ; if recompileRequired recomp then return (recomp, Nothing) else do {+       ; case recomp of (NeedsRecompile reason) -> return $ OutOfDateItem reason (Just iface) ; _ -> do {+       ; recomp <- checkPlugins (hsc_plugins hsc_env) iface+       ; case recomp of (NeedsRecompile reason) -> return $ OutOfDateItem reason Nothing ; _ -> do {          -- Source code unchanged and no errors yet... carry on@@ -260,46 +395,46 @@        -- It's just temporary because either the usage check will succeed        -- (in which case we are done with this module) or it'll fail (in which        -- case we'll compile the module from scratch anyhow).-       ---       -- We do this regardless of compilation mode, although in --make mode-       -- all the dependent modules should be in the HPT already, so it's-       -- quite redundant-       ; updateEps_ $ \eps  -> eps { eps_is_boot = mod_deps }-       ; recomp <- checkList [checkModUsage (homeUnitAsUnit home_unit) u++       when (isOneShot (ghcMode (hsc_dflags hsc_env))) $ do {+          ; updateEps_ $ \eps  -> eps { eps_is_boot = mkModDeps $ dep_boot_mods (mi_deps iface) }+       }+       ; recomp <- checkList [checkModUsage (hsc_FC hsc_env) (homeUnitAsUnit home_unit) u                              | u <- mi_usages iface]-       ; return (recomp, Just iface)-    }}}}}}}}}}+       ; case recomp of (NeedsRecompile reason) -> return $ OutOfDateItem reason (Just iface) ; _ -> do {+       ; return $ UpToDateItem iface+    }}}}}}}   where+    logger = hsc_logger hsc_env+    dflags = hsc_dflags hsc_env     home_unit = hsc_home_unit hsc_env-    -- This is a bit of a hack really-    mod_deps :: ModuleNameEnv ModuleNameWithIsBoot-    mod_deps = mkModDeps (dep_mods (mi_deps iface)) ++ -- | Check if any plugins are requesting recompilation-checkPlugins :: HscEnv -> ModIface -> IfG RecompileRequired-checkPlugins hsc_env iface = liftIO $ do-  new_fingerprint <- fingerprintPlugins hsc_env+checkPlugins :: Plugins -> ModIface -> IfG RecompileRequired+checkPlugins plugins iface = liftIO $ do+  recomp <- recompPlugins plugins+  let new_fingerprint = fingerprintPluginRecompile recomp   let old_fingerprint = mi_plugin_hash (mi_final_exts iface)-  pr <- mconcat <$> mapM pluginRecompile' (plugins hsc_env)-  return $-    pluginRecompileToRecompileRequired old_fingerprint new_fingerprint pr+  return $ pluginRecompileToRecompileRequired old_fingerprint new_fingerprint recomp -fingerprintPlugins :: HscEnv -> IO Fingerprint-fingerprintPlugins hsc_env =-  fingerprintPlugins' $ plugins hsc_env+recompPlugins :: Plugins -> IO PluginRecompile+recompPlugins plugins = mconcat <$> mapM pluginRecompile' (pluginsWithArgs plugins) -fingerprintPlugins' :: [PluginWithArgs] -> IO Fingerprint-fingerprintPlugins' plugins = do-  res <- mconcat <$> mapM pluginRecompile' plugins-  return $ case res of-      NoForceRecompile -> fingerprintString "NoForceRecompile"-      ForceRecompile   -> fingerprintString "ForceRecompile"-      -- is the chance of collision worth worrying about?-      -- An alternative is to fingerprintFingerprints [fingerprintString-      -- "maybeRecompile", fp]-      (MaybeRecompile fp) -> fp+fingerprintPlugins :: Plugins -> IO Fingerprint+fingerprintPlugins plugins = fingerprintPluginRecompile <$> recompPlugins plugins +fingerprintPluginRecompile :: PluginRecompile -> Fingerprint+fingerprintPluginRecompile recomp = case recomp of+  NoForceRecompile  -> fingerprintString "NoForceRecompile"+  ForceRecompile    -> fingerprintString "ForceRecompile"+  -- is the chance of collision worth worrying about?+  -- An alternative is to fingerprintFingerprints [fingerprintString+  -- "maybeRecompile", fp]+  MaybeRecompile fp -> fp + pluginRecompileToRecompileRequired     :: Fingerprint -> Fingerprint -> PluginRecompile -> RecompileRequired pluginRecompileToRecompileRequired old_fp new_fp pr@@ -314,7 +449,7 @@       -- when we have an impure plugin in the stack we have to unconditionally       -- recompile since it might integrate all sorts of crazy IO results into       -- its compilation output.-      ForceRecompile    -> RecompBecause "Impure plugin forced recompilation"+      ForceRecompile    -> needsRecompileBecause ImpurePlugin    | old_fp `elem` magic_fingerprints ||     new_fp `elem` magic_fingerprints@@ -326,17 +461,16 @@     -- For example when we go from ForceRecomp to NoForceRecomp     -- recompilation is triggered since the old impure plugins could have     -- changed the build output which is now back to normal.-    = RecompBecause "Plugins changed"+    = needsRecompileBecause PluginsChanged    | otherwise =-    let reason = "Plugin fingerprint changed" in     case pr of       -- even though a plugin is forcing recompilation the fingerprint changed       -- which would cause recompilation anyways so we report the fingerprint       -- change instead.-      ForceRecompile   -> RecompBecause reason+      ForceRecompile   -> needsRecompileBecause PluginFingerprintChanged -      _                -> RecompBecause reason+      _                -> needsRecompileBecause PluginFingerprintChanged   where    magic_fingerprints =@@ -347,89 +481,87 @@  -- | Check if an hsig file needs recompilation because its -- implementing module has changed.-checkHsig :: ModSummary -> ModIface -> IfG RecompileRequired-checkHsig mod_summary iface = do-    hsc_env <- getTopEnv-    let home_unit = hsc_home_unit hsc_env-        outer_mod = ms_mod mod_summary+checkHsig :: Logger -> HomeUnit -> ModSummary -> ModIface -> IO RecompileRequired+checkHsig logger home_unit mod_summary iface = do+    let outer_mod = ms_mod mod_summary         inner_mod = homeModuleNameInstantiation home_unit (moduleName outer_mod)-    MASSERT( isHomeModule home_unit outer_mod )+    massert (isHomeModule home_unit outer_mod)     case inner_mod == mi_semantic_module iface of-        True -> up_to_date (text "implementing module unchanged")-        False -> return (RecompBecause "implementing module changed")+        True -> up_to_date logger (text "implementing module unchanged")+        False -> return $ needsRecompileBecause ModuleInstChanged  -- | Check if @.hie@ file is out of date or missing.-checkHie :: ModSummary -> IfG RecompileRequired-checkHie mod_summary = do-    dflags <- getDynFlags+checkHie :: DynFlags -> ModSummary -> RecompileRequired+checkHie dflags mod_summary =     let hie_date_opt = ms_hie_date mod_summary-        hs_date = ms_hs_date mod_summary-    pure $ case gopt Opt_WriteHie dflags of-               False -> UpToDate-               True -> case hie_date_opt of-                           Nothing -> RecompBecause "HIE file is missing"-                           Just hie_date-                               | hie_date < hs_date-                               -> RecompBecause "HIE file is out of date"-                               | otherwise-                               -> UpToDate+        hi_date = ms_iface_date mod_summary+    in if not (gopt Opt_WriteHie dflags)+      then UpToDate+      else case (hie_date_opt, hi_date) of+             (Nothing, _) -> needsRecompileBecause HieMissing+             (Just hie_date, Just hi_date)+                 | hie_date < hi_date+                 -> needsRecompileBecause HieOutdated+             _ -> UpToDate  -- | Check the flags haven't changed-checkFlagHash :: HscEnv -> ModIface -> IfG RecompileRequired+checkFlagHash :: HscEnv -> ModIface -> IO RecompileRequired checkFlagHash hsc_env iface = do+    let logger   = hsc_logger hsc_env     let old_hash = mi_flag_hash (mi_final_exts iface)-    new_hash <- liftIO $ fingerprintDynFlags hsc_env-                                             (mi_module iface)-                                             putNameLiterally+    new_hash <- fingerprintDynFlags hsc_env (mi_module iface) putNameLiterally     case old_hash == new_hash of-        True  -> up_to_date (text "Module flags unchanged")-        False -> out_of_date_hash "flags changed"+        True  -> up_to_date logger (text "Module flags unchanged")+        False -> out_of_date_hash logger FlagsChanged                      (text "  Module flags have changed")                      old_hash new_hash  -- | Check the optimisation flags haven't changed-checkOptimHash :: HscEnv -> ModIface -> IfG RecompileRequired+checkOptimHash :: HscEnv -> ModIface -> IO RecompileRequired checkOptimHash hsc_env iface = do+    let logger   = hsc_logger hsc_env     let old_hash = mi_opt_hash (mi_final_exts iface)-    new_hash <- liftIO $ fingerprintOptFlags (hsc_dflags hsc_env)+    new_hash <- fingerprintOptFlags (hsc_dflags hsc_env)                                                putNameLiterally     if | old_hash == new_hash-         -> up_to_date (text "Optimisation flags unchanged")+         -> up_to_date logger (text "Optimisation flags unchanged")        | gopt Opt_IgnoreOptimChanges (hsc_dflags hsc_env)-         -> up_to_date (text "Optimisation flags changed; ignoring")+         -> up_to_date logger (text "Optimisation flags changed; ignoring")        | otherwise-         -> out_of_date_hash "Optimisation flags changed"+         -> out_of_date_hash logger OptimFlagsChanged                      (text "  Optimisation flags have changed")                      old_hash new_hash  -- | Check the HPC flags haven't changed-checkHpcHash :: HscEnv -> ModIface -> IfG RecompileRequired+checkHpcHash :: HscEnv -> ModIface -> IO RecompileRequired checkHpcHash hsc_env iface = do+    let logger   = hsc_logger hsc_env     let old_hash = mi_hpc_hash (mi_final_exts iface)-    new_hash <- liftIO $ fingerprintHpcFlags (hsc_dflags hsc_env)+    new_hash <- fingerprintHpcFlags (hsc_dflags hsc_env)                                                putNameLiterally     if | old_hash == new_hash-         -> up_to_date (text "HPC flags unchanged")+         -> up_to_date logger (text "HPC flags unchanged")        | gopt Opt_IgnoreHpcChanges (hsc_dflags hsc_env)-         -> up_to_date (text "HPC flags changed; ignoring")+         -> up_to_date logger (text "HPC flags changed; ignoring")        | otherwise-         -> out_of_date_hash "HPC flags changed"+         -> out_of_date_hash logger HpcFlagsChanged                      (text "  HPC flags have changed")                      old_hash new_hash  -- Check that the set of signatures we are merging in match. -- If the -unit-id flags change, this can change too.-checkMergedSignatures :: ModSummary -> ModIface -> IfG RecompileRequired-checkMergedSignatures mod_summary iface = do-    unit_state <- hsc_units <$> getTopEnv+checkMergedSignatures :: HscEnv -> ModSummary -> ModIface -> IO RecompileRequired+checkMergedSignatures hsc_env mod_summary iface = do+    let logger     = hsc_logger hsc_env+    let unit_state = hsc_units hsc_env     let old_merged = sort [ mod | UsageMergedRequirement{ usg_mod = mod } <- mi_usages iface ]         new_merged = case Map.lookup (ms_mod_name mod_summary)                                      (requirementContext unit_state) of                         Nothing -> []                         Just r -> sort $ map (instModuleToModule unit_state) r     if old_merged == new_merged-        then up_to_date (text "signatures to merge in unchanged" $$ ppr new_merged)-        else return (RecompBecause "signatures to merge in changed")+        then up_to_date logger (text "signatures to merge in unchanged" $$ ppr new_merged)+        else return $ needsRecompileBecause SigsMergeChanged  -- If the direct imports of this module are resolved to targets that -- are not among the dependencies of the previous interface file,@@ -440,130 +572,114 @@ --   - a new home module has been added that shadows a package module -- See bug #1372. ----- In addition, we also check if the union of dependencies of the imported--- modules has any difference to the previous set of dependencies. We would need--- to recompile in that case also since the `mi_deps` field of ModIface needs--- to be updated to match that information. This is one of the invariants--- of interface files (see https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance#interface-file-invariants).--- See bug #16511.------ Returns (RecompBecause <textual reason>) if recompilation is required.+-- Returns (RecompBecause <reason>) if recompilation is required. checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired checkDependencies hsc_env summary iface- =-   checkList $-     [ checkList (map dep_missing (ms_imps summary ++ ms_srcimps summary))-     , do-         (recomp, mnames_seen) <- runUntilRecompRequired $ map-           checkForNewHomeDependency-           (ms_home_imps summary)-         case recomp of-           UpToDate -> do-             let-               seen_home_deps = Set.unions $ map Set.fromList mnames_seen-             checkIfAllOldHomeDependenciesAreSeen seen_home_deps-           _ -> return recomp]+ = do+    res_normal <- classify_import (findImportedModule hsc_env) (ms_textual_imps summary ++ ms_srcimps summary)+    res_plugin <- classify_import (\mod _ -> findPluginModule fc fopts units mhome_unit mod) (ms_plugin_imps summary)+    case sequence (res_normal ++ res_plugin ++ [Right (fake_ghc_prim_import)| ms_ghc_prim_import summary]) of+      Left recomp -> return $ NeedsRecompile recomp+      Right es -> do+        let (hs, ps) = partitionEithers es+        liftIO $+          check_mods (sort hs) prev_dep_mods+          `recompThen`+            let allPkgDeps = sortBy (comparing snd) $ nubOrdOn snd (ps ++ implicit_deps ++ bkpk_units)+            in check_packages allPkgDeps prev_dep_pkgs  where-   prev_dep_mods = dep_mods (mi_deps iface)-   prev_dep_plgn = dep_plgins (mi_deps iface)-   prev_dep_pkgs = dep_pkgs (mi_deps iface)-   home_unit     = hsc_home_unit hsc_env -   dep_missing (mb_pkg, L _ mod) = do-     find_res <- liftIO $ findImportedModule hsc_env mod (mb_pkg)-     let reason = moduleNameString mod ++ " changed"-     case find_res of-        Found _ mod-          | isHomeUnit home_unit pkg-           -> if moduleName mod `notElem` map gwib_mod prev_dep_mods ++ prev_dep_plgn-                 then do traceHiDiffs $-                           text "imported module " <> quotes (ppr mod) <>-                           text " not among previous dependencies"-                         return (RecompBecause reason)-                 else-                         return UpToDate-          | otherwise-           -> if toUnitId pkg `notElem` (map fst prev_dep_pkgs)-                 then do traceHiDiffs $-                           text "imported module " <> quotes (ppr mod) <>-                           text " is from package " <> quotes (ppr pkg) <>-                           text ", which is not among previous dependencies"-                         return (RecompBecause reason)-                 else-                         return UpToDate-           where pkg = moduleUnit mod-        _otherwise  -> return (RecompBecause reason)+   classify_import :: (ModuleName -> t -> IO FindResult)+                      -> [(t, GenLocated l ModuleName)]+                    -> IfG+                       [Either+                          CompileReason (Either (UnitId, ModuleName) (String, UnitId))]+   classify_import find_import imports =+    liftIO $ traverse (\(mb_pkg, L _ mod) ->+           let reason = ModuleChanged mod+           in classify reason <$> find_import mod mb_pkg)+           imports+   dflags        = hsc_dflags hsc_env+   fopts         = initFinderOpts dflags+   logger        = hsc_logger hsc_env+   fc            = hsc_FC hsc_env+   mhome_unit    = hsc_home_unit_maybe hsc_env+   all_home_units = hsc_all_home_unit_ids hsc_env+   units         = hsc_units hsc_env+   prev_dep_mods = map (second gwib_mod) $ Set.toAscList $ dep_direct_mods (mi_deps iface)+   prev_dep_pkgs = Set.toAscList (Set.union (dep_direct_pkgs (mi_deps iface))+                                            (dep_plugin_pkgs (mi_deps iface)))+   bkpk_units    = map (("Signature",) . instUnitInstanceOf . moduleUnit) (requirementMerges units (moduleName (mi_module iface))) -   projectNonBootNames = map gwib_mod . filter ((== NotBoot) . gwib_isBoot)-   old_deps = Set.fromList-     $ projectNonBootNames prev_dep_mods-   isOldHomeDeps = flip Set.member old_deps-   checkForNewHomeDependency (L _ mname) = do-     let-       mod = mkHomeModule home_unit mname-       str_mname = moduleNameString mname-       reason = str_mname ++ " changed"-     -- We only want to look at home modules to check if any new home dependency-     -- pops in and thus here, skip modules that are not home. Checking-     -- membership in old home dependencies suffice because the `dep_missing`-     -- check already verified that all imported home modules are present there.-     if not (isOldHomeDeps mname)-       then return (UpToDate, [])-       else do-         mb_result <- getFromModIface "need mi_deps for" mod $ \imported_iface -> do-           let mnames = mname:(map gwib_mod $ filter ((== NotBoot) . gwib_isBoot) $-                 dep_mods $ mi_deps imported_iface)-           case find (not . isOldHomeDeps) mnames of-             Nothing -> return (UpToDate, mnames)-             Just new_dep_mname -> do-               traceHiDiffs $-                 text "imported home module " <> quotes (ppr mod) <>-                 text " has a new dependency " <> quotes (ppr new_dep_mname)-               return (RecompBecause reason, [])-         return $ fromMaybe (MustCompile, []) mb_result+   implicit_deps = map ("Implicit",) (implicitPackageDeps dflags) -   -- Performs all recompilation checks in the list until a check that yields-   -- recompile required is encountered. Returns the list of the results of-   -- all UpToDate checks.-   runUntilRecompRequired []             = return (UpToDate, [])-   runUntilRecompRequired (check:checks) = do-     (recompile, value) <- check-     if recompileRequired recompile-       then return (recompile, [])-       else do-         (recomp, values) <- runUntilRecompRequired checks-         return (recomp, value:values)+   -- GHC.Prim is very special and doesn't appear in ms_textual_imps but+   -- ghc-prim will appear in the package dependencies still. In order to not confuse+   -- the recompilation logic we need to not forget we imported GHC.Prim.+   fake_ghc_prim_import =  case mhome_unit of+                              Just home_unit+                                | homeUnitId home_unit == primUnitId+                                -> Left (primUnitId, mkModuleName "GHC.Prim")+                              _ -> Right ("GHC.Prim", primUnitId) -   checkIfAllOldHomeDependenciesAreSeen seen_deps = do-     let unseen_old_deps = Set.difference-          old_deps-          seen_deps-     if not (null unseen_old_deps)-       then do-         let missing_dep = Set.elemAt 0 unseen_old_deps-         traceHiDiffs $-           text "missing old home dependency " <> quotes (ppr missing_dep)-         return $ RecompBecause "missing old dependency"-       else return UpToDate -needInterface :: Module -> (ModIface -> IfG RecompileRequired)+   classify _ (Found _ mod)+    | (toUnitId $ moduleUnit mod) `elem` all_home_units = Right (Left ((toUnitId $ moduleUnit mod), moduleName mod))+    | otherwise = Right (Right (moduleNameString (moduleName mod), toUnitId $ moduleUnit mod))+   classify reason _ = Left (RecompBecause reason)++   check_mods :: [(UnitId, ModuleName)] -> [(UnitId, ModuleName)] -> IO RecompileRequired+   check_mods [] [] = return UpToDate+   check_mods [] (old:_) = do+     -- This case can happen when a module is change from HPT to package import+     trace_hi_diffs logger $+      text "module no longer" <+> quotes (ppr old) <+>+        text "in dependencies"++     return $ needsRecompileBecause $ ModuleRemoved old+   check_mods (new:news) olds+    | Just (old, olds') <- uncons olds+    , new == old = check_mods (dropWhile (== new) news) olds'+    | otherwise = do+        trace_hi_diffs logger $+           text "imported module " <> quotes (ppr new) <>+           text " not among previous dependencies"+        return $ needsRecompileBecause $ ModuleAdded new++   check_packages :: [(String, UnitId)] -> [UnitId] -> IO RecompileRequired+   check_packages [] [] = return UpToDate+   check_packages [] (old:_) = do+     trace_hi_diffs logger $+      text "package " <> quotes (ppr old) <>+        text "no longer in dependencies"+     return $ needsRecompileBecause $ UnitDepRemoved old+   check_packages (new:news) olds+    | Just (old, olds') <- uncons olds+    , snd new == old = check_packages (dropWhile ((== (snd new)) . snd) news) olds'+    | otherwise = do+        trace_hi_diffs logger $+         text "imported package " <> quotes (ppr new) <>+           text " not among previous dependencies"+        return $ needsRecompileBecause $ ModulePackageChanged $ fst new+++needInterface :: Module -> (ModIface -> IO RecompileRequired)              -> IfG RecompileRequired needInterface mod continue   = do-      mb_recomp <- getFromModIface+      mb_recomp <- tryGetModIface         "need version info for"         mod-        continue       case mb_recomp of-        Nothing -> return MustCompile-        Just recomp -> return recomp+        Nothing -> return $ NeedsRecompile MustCompile+        Just iface -> liftIO $ continue iface -getFromModIface :: String -> Module -> (ModIface -> IfG a)-              -> IfG (Maybe a)-getFromModIface doc_msg mod getter+tryGetModIface :: String -> Module -> IfG (Maybe ModIface)+tryGetModIface doc_msg mod   = do  -- Load the imported interface if possible+    logger <- getLogger     let doc_str = sep [text doc_msg, ppr mod]-    traceHiDiffs (text "Checking innterface for module" <+> ppr mod)+    liftIO $ trace_hi_diffs logger (text "Checking interface for module" <+> ppr mod)      mb_iface <- loadInterface doc_str mod ImportBySystem         -- Load the interface, but don't complain on failure;@@ -571,141 +687,159 @@      case mb_iface of       Failed _ -> do-        traceHiDiffs (sep [text "Couldn't load interface for module",-                           ppr mod])+        liftIO $ trace_hi_diffs logger (sep [text "Couldn't load interface for module", ppr mod])         return Nothing                   -- Couldn't find or parse a module mentioned in the                   -- old interface file.  Don't complain: it might                   -- just be that the current module doesn't need that                   -- import and it's been deleted-      Succeeded iface -> Just <$> getter iface+      Succeeded iface -> pure $ Just iface  -- | Given the usage information extracted from the old -- M.hi file for the module being compiled, figure out -- whether M needs to be recompiled.-checkModUsage :: Unit -> Usage -> IfG RecompileRequired-checkModUsage _this_pkg UsagePackageModule{+checkModUsage :: FinderCache -> Unit -> Usage -> IfG RecompileRequired+checkModUsage _ _this_pkg UsagePackageModule{                                 usg_mod = mod,-                                usg_mod_hash = old_mod_hash }-  = needInterface mod $ \iface -> do-    let reason = moduleNameString (moduleName mod) ++ " changed"-    checkModuleFingerprint reason old_mod_hash (mi_mod_hash (mi_final_exts iface))+                                usg_mod_hash = old_mod_hash } = do+  logger <- getLogger+  needInterface mod $ \iface -> do+    let reason = ModuleChanged (moduleName mod)+    checkModuleFingerprint logger reason old_mod_hash (mi_mod_hash (mi_final_exts iface))         -- We only track the ABI hash of package modules, rather than         -- individual entity usages, so if the ABI hash changes we must         -- recompile.  This is safe but may entail more recompilation when         -- a dependent package has changed. -checkModUsage _ UsageMergedRequirement{ usg_mod = mod, usg_mod_hash = old_mod_hash }-  = needInterface mod $ \iface -> do-    let reason = moduleNameString (moduleName mod) ++ " changed (raw)"-    checkModuleFingerprint reason old_mod_hash (mi_mod_hash (mi_final_exts iface))+checkModUsage _ _ UsageMergedRequirement{ usg_mod = mod, usg_mod_hash = old_mod_hash } = do+  logger <- getLogger+  needInterface mod $ \iface -> do+    let reason = ModuleChangedRaw (moduleName mod)+    checkModuleFingerprint logger reason old_mod_hash (mi_mod_hash (mi_final_exts iface))+checkModUsage _ this_pkg UsageHomeModuleInterface{ usg_mod_name = mod_name, usg_iface_hash = old_mod_hash } = do+  let mod = mkModule this_pkg mod_name+  logger <- getLogger+  needInterface mod $ \iface -> do+    let reason = ModuleChangedIface mod_name+    checkIfaceFingerprint logger reason old_mod_hash (mi_iface_hash (mi_final_exts iface)) -checkModUsage this_pkg UsageHomeModule{+checkModUsage _ this_pkg UsageHomeModule{                                 usg_mod_name = mod_name,                                 usg_mod_hash = old_mod_hash,                                 usg_exports = maybe_old_export_hash,                                 usg_entities = old_decl_hash }   = do     let mod = mkModule this_pkg mod_name+    logger <- getLogger     needInterface mod $ \iface -> do--       let-           new_mod_hash    = mi_mod_hash (mi_final_exts iface)-           new_decl_hash   = mi_hash_fn  (mi_final_exts iface)-           new_export_hash = mi_exp_hash (mi_final_exts iface)+     let+         new_mod_hash    = mi_mod_hash (mi_final_exts iface)+         new_decl_hash   = mi_hash_fn  (mi_final_exts iface)+         new_export_hash = mi_exp_hash (mi_final_exts iface) -           reason = moduleNameString mod_name ++ " changed"+         reason = ModuleChanged (moduleName mod) +     liftIO $ do            -- CHECK MODULE-       recompile <- checkModuleFingerprint reason old_mod_hash new_mod_hash+       recompile <- checkModuleFingerprint logger reason old_mod_hash new_mod_hash        if not (recompileRequired recompile)          then return UpToDate-         else-           -- CHECK EXPORT LIST-           checkMaybeHash reason maybe_old_export_hash new_export_hash-               (text "  Export list changed") $ do--                 -- CHECK ITEMS ONE BY ONE-                 recompile <- checkList [ checkEntityUsage reason new_decl_hash u-                                        | u <- old_decl_hash]-                 if recompileRequired recompile-                   then return recompile     -- This one failed, so just bail out now-                   else up_to_date (text "  Great!  The bits I use are up to date")-+         else checkList+           [ -- CHECK EXPORT LIST+             checkMaybeHash logger reason maybe_old_export_hash new_export_hash+               (text "  Export list changed")+           , -- CHECK ITEMS ONE BY ONE+             checkList [ checkEntityUsage logger reason new_decl_hash u+                       | u <- old_decl_hash]+           , up_to_date logger (text "  Great!  The bits I use are up to date")+           ] -checkModUsage _this_pkg UsageFile{ usg_file_path = file,-                                   usg_file_hash = old_hash } =+checkModUsage fc _this_pkg UsageFile{ usg_file_path = file,+                                   usg_file_hash = old_hash,+                                   usg_file_label = mlabel } =   liftIO $     handleIO handler $ do-      new_hash <- getFileHash file+      new_hash <- lookupFileCache fc file       if (old_hash /= new_hash)          then return recomp          else return UpToDate  where-   recomp  = RecompBecause (file ++ " changed")-   handler =-#if defined(DEBUG)-       \e -> pprTrace "UsageFile" (text (show e)) $ return recomp-#else-       \_ -> return recomp -- if we can't find the file, just recompile, don't fail-#endif+   reason = FileChanged file+   recomp  = needsRecompileBecause $ fromMaybe reason $ fmap CustomReason mlabel+   handler = if debugIsOn+      then \e -> pprTrace "UsageFile" (text (show e)) $ return recomp+      else \_ -> return recomp -- if we can't find the file, just recompile, don't fail  -------------------------checkModuleFingerprint :: String -> Fingerprint -> Fingerprint-                       -> IfG RecompileRequired-checkModuleFingerprint reason old_mod_hash new_mod_hash+checkModuleFingerprint+  :: Logger+  -> RecompReason+  -> Fingerprint+  -> Fingerprint+  -> IO RecompileRequired+checkModuleFingerprint logger reason old_mod_hash new_mod_hash   | new_mod_hash == old_mod_hash-  = up_to_date (text "Module fingerprint unchanged")+  = up_to_date logger (text "Module fingerprint unchanged")    | otherwise-  = out_of_date_hash reason (text "  Module fingerprint has changed")+  = out_of_date_hash logger reason (text "  Module fingerprint has changed")                      old_mod_hash new_mod_hash +checkIfaceFingerprint+  :: Logger+  -> RecompReason+  -> Fingerprint+  -> Fingerprint+  -> IO RecompileRequired+checkIfaceFingerprint logger reason old_mod_hash new_mod_hash+  | new_mod_hash == old_mod_hash+  = up_to_date logger (text "Iface fingerprint unchanged")++  | otherwise+  = out_of_date_hash logger reason (text "  Iface fingerprint has changed")+                     old_mod_hash new_mod_hash+ -------------------------checkMaybeHash :: String -> Maybe Fingerprint -> Fingerprint -> SDoc-               -> IfG RecompileRequired -> IfG RecompileRequired-checkMaybeHash reason maybe_old_hash new_hash doc continue+checkMaybeHash+  :: Logger+  -> RecompReason+  -> Maybe Fingerprint+  -> Fingerprint+  -> SDoc+  -> IO RecompileRequired+checkMaybeHash logger reason maybe_old_hash new_hash doc   | Just hash <- maybe_old_hash, hash /= new_hash-  = out_of_date_hash reason doc hash new_hash+  = out_of_date_hash logger reason doc hash new_hash   | otherwise-  = continue+  = return UpToDate  -------------------------checkEntityUsage :: String+checkEntityUsage :: Logger+                 -> RecompReason                  -> (OccName -> Maybe (OccName, Fingerprint))                  -> (OccName, Fingerprint)-                 -> IfG RecompileRequired-checkEntityUsage reason new_hash (name,old_hash)-  = case new_hash name of--        Nothing       ->        -- We used it before, but it ain't there now-                          out_of_date reason (sep [text "No longer exported:", ppr name])--        Just (_, new_hash)      -- It's there, but is it up to date?-          | new_hash == old_hash -> do traceHiDiffs (text "  Up to date" <+> ppr name <+> parens (ppr new_hash))-                                       return UpToDate-          | otherwise            -> out_of_date_hash reason (text "  Out of date:" <+> ppr name)-                                                     old_hash new_hash--up_to_date :: SDoc -> IfG RecompileRequired-up_to_date  msg = traceHiDiffs msg >> return UpToDate--out_of_date :: String -> SDoc -> IfG RecompileRequired-out_of_date reason msg = traceHiDiffs msg >> return (RecompBecause reason)+                 -> IO RecompileRequired+checkEntityUsage logger reason new_hash (name,old_hash) = do+  case new_hash name of+    -- We used it before, but it ain't there now+    Nothing       -> out_of_date logger reason (sep [text "No longer exported:", ppr name])+    -- It's there, but is it up to date?+    Just (_, new_hash)+      | new_hash == old_hash+      -> do trace_hi_diffs logger (text "  Up to date" <+> ppr name <+> parens (ppr new_hash))+            return UpToDate+      | otherwise+      -> out_of_date_hash logger reason (text "  Out of date:" <+> ppr name) old_hash new_hash -out_of_date_hash :: String -> SDoc -> Fingerprint -> Fingerprint -> IfG RecompileRequired-out_of_date_hash reason msg old_hash new_hash-  = out_of_date reason (hsep [msg, ppr old_hash, text "->", ppr new_hash])+up_to_date :: Logger -> SDoc -> IO RecompileRequired+up_to_date logger msg = trace_hi_diffs logger msg >> return UpToDate ------------------------checkList :: [IfG RecompileRequired] -> IfG RecompileRequired--- This helper is used in two places-checkList []             = return UpToDate-checkList (check:checks) = do recompile <- check-                              if recompileRequired recompile-                                then return recompile-                                else checkList checks+out_of_date :: Logger -> RecompReason -> SDoc -> IO RecompileRequired+out_of_date logger reason msg = trace_hi_diffs logger msg >> return (needsRecompileBecause reason) +out_of_date_hash :: Logger -> RecompReason -> SDoc -> Fingerprint -> Fingerprint -> IO RecompileRequired+out_of_date_hash logger reason msg old_hash new_hash+  = out_of_date logger reason (hsep [msg, ppr old_hash, text "->", ppr new_hash])  -- --------------------------------------------------------------------------- -- Compute fingerprints for the interface@@ -846,7 +980,7 @@                , let out = localOccs $ freeNamesDeclABI abi                ] -       name_module n = ASSERT2( isExternalName n, ppr n ) nameModule n+       name_module n = assertPpr (isExternalName n) (ppr n) (nameModule n)        localOccs =          map (getUnique . getParent . getOccName)                         -- NB: names always use semantic module, so@@ -889,7 +1023,7 @@           | isWiredInName name  =  putNameLiterally bh name            -- wired-in names don't have fingerprints           | otherwise-          = ASSERT2( isExternalName name, ppr name )+          = assertPpr (isExternalName name) (ppr name) $             let hash | nameModule name /= semantic_mod =  global_hash_fn name                      -- Get it from the REAL interface!!                      -- This will trigger when we compile an hsig file@@ -963,11 +1097,11 @@    (local_env, decls_w_hashes) <-        foldM fingerprint_group (emptyOccEnv, []) groups -   -- when calculating fingerprints, we always need to use canonical-   -- ordering for lists of things.  In particular, the mi_deps has various-   -- lists of modules and suchlike, so put these all in canonical order:+   -- when calculating fingerprints, we always need to use canonical ordering+   -- for lists of things. The mi_deps has various lists of modules and+   -- suchlike, which are stored in canonical order:    let sorted_deps :: Dependencies-       sorted_deps = sortDependencies (mi_deps iface0)+       sorted_deps = mi_deps iface0     -- The export hash of a module depends on the orphan hashes of the    -- orphan modules below us in the dependency tree.  This is the way@@ -1011,17 +1145,22 @@    orphan_hash <- computeFingerprint (mk_put_name local_env)                                      (map ifDFun orph_insts, orph_rules, orph_fis) +   -- Hash of the transitive things in dependencies+   dep_hash <- computeFingerprint putNameLiterally+                       (dep_sig_mods (mi_deps iface0),+                        dep_boot_mods (mi_deps iface0),+                        -- Trusted packages are like orphans+                        dep_trusted_pkgs (mi_deps iface0),+                       -- See Note [Export hash depends on non-orphan family instances]+                        dep_finsts (mi_deps iface0) )+    -- the export list hash doesn't depend on the fingerprints of    -- the Names it mentions, only the Names themselves, hence putNameLiterally.    export_hash <- computeFingerprint putNameLiterally                       (mi_exports iface0,                        orphan_hash,+                       dep_hash,                        dep_orphan_hashes,-                       dep_pkgs (mi_deps iface0),-                       -- See Note [Export hash depends on non-orphan family instances]-                       dep_finsts (mi_deps iface0),-                        -- dep_pkgs: see "Package Version Changes" on-                        -- wiki/commentary/compiler/recompilation-avoidance                        mi_trust iface0)                         -- Make sure change of Safe Haskell mode causes recomp. @@ -1068,7 +1207,7 @@     hpc_hash <- fingerprintHpcFlags dflags putNameLiterally -   plugin_hash <- fingerprintPlugins hsc_env+   plugin_hash <- fingerprintPlugins (hsc_plugins hsc_env)     -- the ABI hash depends on:    --   - decls@@ -1083,12 +1222,14 @@     -- The interface hash depends on:    --   - the ABI hash, plus+   --   - the source file hash,    --   - the module level annotations,    --   - usages    --   - deps (home and external packages, dependent files)    --   - hpc    iface_hash <- computeFingerprint putNameLiterally                       (mod_hash,+                       mi_src_hash iface0,                        ann_fn (mkVarOcc "module"),  -- See mkIfaceAnnCache                        mi_usages iface0,                        sorted_deps,@@ -1158,30 +1299,17 @@ -- to recompile C and everything else. getOrphanHashes :: HscEnv -> [Module] -> IO [Fingerprint] getOrphanHashes hsc_env mods = do-  eps <- hscEPS hsc_env   let-    hpt        = hsc_HPT hsc_env-    pit        = eps_PIT eps-    get_orph_hash mod =-          case lookupIfaceByModule hpt pit mod of-            Just iface -> return (mi_orphan_hash (mi_final_exts iface))-            Nothing    -> do -- similar to 'mkHashFun'-                iface <- initIfaceLoad hsc_env . withException+    dflags     = hsc_dflags hsc_env+    ctx        = initSDocContext dflags defaultUserStyle+    get_orph_hash mod = do+          iface <- initIfaceLoad hsc_env . withException ctx                             $ loadInterface (text "getOrphanHashes") mod ImportBySystem-                return (mi_orphan_hash (mi_final_exts iface))+          return (mi_orphan_hash (mi_final_exts iface)) -  --   mapM get_orph_hash mods  -sortDependencies :: Dependencies -> Dependencies-sortDependencies d- = Deps { dep_mods   = sortBy (lexicalCompareFS `on` (moduleNameFS . gwib_mod)) (dep_mods d),-          dep_pkgs   = sortBy (compare `on` fst) (dep_pkgs d),-          dep_orphs  = sortBy stableModuleCmp (dep_orphs d),-          dep_finsts = sortBy stableModuleCmp (dep_finsts d),-          dep_plgins = sortBy (lexicalCompareFS `on` moduleNameFS) (dep_plgins d) }- {- ************************************************************************ *                                                                      *@@ -1373,6 +1501,7 @@   {- Note [default method Name] (see also #15970)+   ~~~~~~~~~~~~~~~~~~~~~~~~~~  The Names for the default methods aren't available in Iface syntax. @@ -1454,12 +1583,14 @@   = lookup orig_mod   where       home_unit = hsc_home_unit hsc_env-      hpt = hsc_HPT hsc_env+      dflags = hsc_dflags hsc_env+      hpt = hsc_HUG hsc_env       pit = eps_PIT eps+      ctx = initSDocContext dflags defaultUserStyle       occ = nameOccName name       orig_mod = nameModule name       lookup mod = do-        MASSERT2( isExternalName name, ppr name )+        massertPpr (isExternalName name) (ppr name)         iface <- case lookupIfaceByModule hpt pit mod of                   Just iface -> return iface                   Nothing ->@@ -1467,12 +1598,19 @@                       -- requirements; we didn't do any /real/ typechecking                       -- so there's no guarantee everything is loaded.                       -- Kind of a heinous hack.-                      initIfaceLoad hsc_env . withException+                      initIfaceLoad hsc_env . withException ctx                           $ withoutDynamicNow-                            -- For some unknown reason, we need to reset the-                            -- dynamicNow bit, otherwise only dynamic-                            -- interfaces are looked up and some tests fail-                            -- (e.g. T16219).+                            -- If you try and load interfaces when dynamic-too+                            -- enabled then it attempts to load the dyn_hi and hi+                            -- interface files. Backpack doesn't really care about+                            -- dynamic object files as it isn't doing any code+                            -- generation so -dynamic-too is turned off.+                            -- Some tests fail without doing this (such as T16219),+                            -- but they fail because dyn_hi files are not found for+                            -- one of the dependencies (because they are deliberately turned off)+                            -- Why is this check turned off here? That is unclear but+                            -- just one of the many horrible hacks in the backpack+                            -- implementation.                           $ loadInterface (text "lookupVers2") mod ImportBySystem         return $ snd (mi_hash_fn (mi_final_exts iface) occ `orElse`                   pprPanic "lookupVers1" (ppr mod <+> ppr occ))
GHC/Iface/Recomp/Binary.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE CPP #-} + -- | Computing fingerprints of values serializeable with GHC's \"Binary\" module. module GHC.Iface.Recomp.Binary   ( -- * Computing fingerprints@@ -8,15 +8,12 @@   , putNameLiterally   ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Utils.Fingerprint import GHC.Utils.Binary import GHC.Types.Name import GHC.Utils.Panic.Plain-import GHC.Utils.Misc  fingerprintBinMem :: BinHandle -> IO Fingerprint fingerprintBinMem bh = withBinBuffer bh f@@ -43,6 +40,6 @@ -- | Used when we want to fingerprint a structure without depending on the -- fingerprints of external Names that it refers to. putNameLiterally :: BinHandle -> Name -> IO ()-putNameLiterally bh name = ASSERT( isExternalName name ) do+putNameLiterally bh name = assert (isExternalName name) $ do     put_ bh $! nameModule name     put_ bh $! nameOccName name
GHC/Iface/Recomp/Flags.hs view
@@ -28,27 +28,26 @@ -- the finger print on important fields in @DynFlags@ so that -- the recompilation checker can use this fingerprint. ----- NB: The 'Module' parameter is the 'Module' recorded by the--- *interface* file, not the actual 'Module' according to our--- 'DynFlags'.+-- NB: The 'Module' parameter is the 'Module' recorded by the *interface*+-- file, not the actual 'Module' according to our 'DynFlags'. fingerprintDynFlags :: HscEnv -> Module                     -> (BinHandle -> Name -> IO ())                     -> IO Fingerprint  fingerprintDynFlags hsc_env this_mod nameio =     let dflags@DynFlags{..} = hsc_dflags hsc_env-        mainis   = if mainModIs hsc_env == this_mod then Just mainFunIs else Nothing+        mainis   = if mainModIs (hsc_HUE hsc_env) == this_mod then Just mainFunIs else Nothing                       -- see #5878         -- pkgopts  = (homeUnit home_unit, sort $ packageFlags dflags)         safeHs   = setSafeMode safeHaskell         -- oflags   = sort $ filter filterOFlags $ flags dflags -        -- *all* the extension flags and the language+        -- all the extension flags and the language         lang = (fmap fromEnum language,                 map fromEnum $ EnumSet.toList extensionFlags)          -- avoid fingerprinting the absolute path to the directory of the source file-        -- see note [Implicit include paths]+        -- see Note [Implicit include paths]         includePathsMinusImplicit = includePaths { includePathsQuoteImplicit = [] }          -- -I, -D and -U flags affect CPP@@ -66,7 +65,7 @@          -- Ticky         ticky =-          map (`gopt` dflags) [Opt_Ticky, Opt_Ticky_Allocd, Opt_Ticky_LNE, Opt_Ticky_Dyn_Thunk]+          map (`gopt` dflags) [Opt_Ticky, Opt_Ticky_Allocd, Opt_Ticky_LNE, Opt_Ticky_Dyn_Thunk, Opt_Ticky_Tag]          flags = ((mainis, safeHs, lang, cpp), (paths, prof, ticky, debugLevel, callerCcFilters)) @@ -109,7 +108,7 @@   {- Note [path flags and recompilation]-+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ There are several flags that we deliberately omit from the recompilation check; here we explain why. @@ -140,7 +139,6 @@  {- Note [Ignoring some flag changes]    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~- Normally, --make tries to reuse only compilation products that are the same as those that would have been produced compiling from scratch. Sometimes, however, users would like to be more aggressive@@ -159,7 +157,6 @@  {- Note [Repeated -optP hashing]    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~- We invoke fingerprintDynFlags for each compiled module to include the hash of relevant DynFlags in the resulting interface file. -optP (preprocessor) flags are part of that hash.
GHC/Iface/Rename.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE CPP #-} + {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}  -- | This module implements interface renaming, which is@@ -14,8 +14,6 @@     tcRnModExports,     ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Driver.Env@@ -27,10 +25,10 @@ import {-# SOURCE #-} GHC.Iface.Load -- a bit vexing  import GHC.Unit-import GHC.Unit.State import GHC.Unit.Module.ModIface import GHC.Unit.Module.Deps +import GHC.Tc.Errors.Types import GHC.Types.SrcLoc import GHC.Types.Unique.FM import GHC.Types.Avail@@ -43,21 +41,20 @@  import GHC.Utils.Outputable import GHC.Utils.Misc+import GHC.Utils.Error import GHC.Utils.Fingerprint import GHC.Utils.Panic -import GHC.Data.Bag- import qualified Data.Traversable as T  import Data.IORef -tcRnMsgMaybe :: IO (Either ErrorMessages a) -> TcM a+tcRnMsgMaybe :: IO (Either (Messages TcRnMessage) a) -> TcM a tcRnMsgMaybe do_this = do     r <- liftIO $ do_this     case r of-        Left errs -> do-            addMessages (mkMessages errs)+        Left msgs -> do+            addMessages msgs             failM         Right x -> return x @@ -71,12 +68,13 @@     hsc_env <- getTopEnv     tcRnMsgMaybe $ rnModExports hsc_env x y -failWithRn :: SDoc -> ShIfM a-failWithRn doc = do+failWithRn :: TcRnMessage -> ShIfM a+failWithRn tcRnMessage = do     errs_var <- fmap sh_if_errs getGblEnv     errs <- readTcRef errs_var     -- TODO: maybe associate this with a source location?-    writeTcRef errs_var (errs `snocBag` mkPlainMsgEnvelope noSrcSpan doc)+    let msg = mkPlainErrorMsgEnvelope noSrcSpan tcRnMessage+    writeTcRef errs_var (msg `addMessage` errs)     failM  -- | What we have is a generalized ModIface, which corresponds to@@ -100,7 +98,7 @@ -- should be Foo.T; then we'll also rename this (this is used -- when loading an interface to merge it into a requirement.) rnModIface :: HscEnv -> [(ModuleName, Module)] -> Maybe NameShape-           -> ModIface -> IO (Either ErrorMessages ModIface)+           -> ModIface -> IO (Either (Messages TcRnMessage) ModIface) rnModIface hsc_env insts nsubst iface =     initRnIface hsc_env iface insts nsubst $ do         mod <- rnModule (mi_module iface)@@ -124,25 +122,24 @@  -- | Rename just the exports of a 'ModIface'.  Useful when we're doing -- shaping prior to signature merging.-rnModExports :: HscEnv -> [(ModuleName, Module)] -> ModIface -> IO (Either ErrorMessages [AvailInfo])+rnModExports :: HscEnv -> [(ModuleName, Module)] -> ModIface -> IO (Either (Messages TcRnMessage) [AvailInfo]) rnModExports hsc_env insts iface     = initRnIface hsc_env iface insts Nothing     $ mapM rnAvailInfo (mi_exports iface)  rnDependencies :: Rename Dependencies-rnDependencies deps = do-    orphs  <- rnDepModules dep_orphs deps-    finsts <- rnDepModules dep_finsts deps-    return deps { dep_orphs = orphs, dep_finsts = finsts }+rnDependencies deps0 = do+    deps1  <- dep_orphs_update deps0 (rnDepModules dep_orphs)+    dep_finsts_update deps1 (rnDepModules dep_finsts) -rnDepModules :: (Dependencies -> [Module]) -> Dependencies -> ShIfM [Module]-rnDepModules sel deps = do+rnDepModules :: (Dependencies -> [Module]) -> [Module] -> ShIfM [Module]+rnDepModules sel mods = do     hsc_env <- getTopEnv     hmap <- getHoleSubst     -- NB: It's not necessary to test if we're doing signature renaming,     -- because ModIface will never contain module reference for itself     -- in these dependencies.-    fmap (nubSort . concat) . T.forM (sel deps) $ \mod -> do+    fmap (nubSort . concat) . T.forM mods $ \mod -> do         -- For holes, its necessary to "see through" the instantiation         -- of the hole to get accurate family instance dependencies.         -- For example, if B imports <A>, and <A> is instantiated with@@ -184,9 +181,9 @@  -- | Run a computation in the 'ShIfM' monad. initRnIface :: HscEnv -> ModIface -> [(ModuleName, Module)] -> Maybe NameShape-            -> ShIfM a -> IO (Either ErrorMessages a)+            -> ShIfM a -> IO (Either (Messages TcRnMessage) a) initRnIface hsc_env iface insts nsubst do_this = do-    errs_var <- newIORef emptyBag+    errs_var <- newIORef emptyMessages     let hsubst = listToUFM insts         rn_mod = renameHoleModule (hsc_units hsc_env) hsubst         env = ShIfEnv {@@ -200,9 +197,9 @@     res <- initTcRnIf 'c' hsc_env env () $ tryM do_this     msgs <- readIORef errs_var     case res of-        Left _                          -> return (Left msgs)-        Right r | not (isEmptyBag msgs) -> return (Left msgs)-                | otherwise             -> return (Right r)+        Left _                               -> return (Left msgs)+        Right r | not (isEmptyMessages msgs) -> return (Left msgs)+                | otherwise                  -> return (Right r)  -- | Environment for 'ShIfM' monads. data ShIfEnv = ShIfEnv {@@ -220,8 +217,8 @@         -- we just load the target interface and look at the export         -- list to determine the renaming.         sh_if_shape :: Maybe NameShape,-        -- Mutable reference to keep track of errors (similar to 'tcl_errs')-        sh_if_errs :: IORef ErrorMessages+        -- Mutable reference to keep track of diagnostics (similar to 'tcl_errs')+        sh_if_errs :: IORef (Messages TcRnMessage)     }  getHoleSubst :: ShIfM ShHoleSubst@@ -248,7 +245,8 @@     ns' <- mapM rnGreName ns     case ns' of         [] -> panic "rnAvailInfoEmpty AvailInfo"-        (rep:rest) -> ASSERT2( all ((== childModule rep) . childModule) rest, ppr rep $$ hcat (map ppr rest) ) do+        (rep:rest) -> assertPpr (all ((== childModule rep) . childModule) rest)+                                (ppr rep $$ hcat (map ppr rest)) $ do                          n' <- setNameModule (Just (childModule rep)) n                          return (AvailTC n' ns')   where@@ -328,11 +326,8 @@                         -- TODO: This will give an unpleasant message if n'                         -- is a constructor; then we'll suggest adding T                         -- but it won't work.-                        Nothing -> failWithRn $ vcat [-                            text "The identifier" <+> ppr (occName n') <+>-                                text "does not exist in the local signature.",-                            parens (text "Try adding it to the export list of the hsig file.")-                            ]+                        Nothing ->+                          failWithRn $ TcRnIdNotExportedFromLocalSig n'                         Just n'' -> return n''        -- Fastpath: we are renaming p[H=<H>]:A.T, in which case the        -- export list is irrelevant.@@ -355,12 +350,8 @@                             $ loadSysInterface (text "rnIfaceGlobal") m''             let nsubst = mkNameShape (moduleName m) (mi_exports iface)             case maybeSubstNameShape nsubst n of-                Nothing -> failWithRn $ vcat [-                    text "The identifier" <+> ppr (occName n) <+>-                        -- NB: report m' because it's more user-friendly-                        text "does not exist in the signature for" <+> ppr m',-                    parens (text "Try adding it to the export list in that hsig file.")-                    ]+                -- NB: report m' because it's more user-friendly+                Nothing -> failWithRn $ TcRnIdNotExportedFromModuleSig n m'                 Just n' -> return n'  -- | Rename an implicit name, e.g., a DFun or coercion axiom.@@ -373,7 +364,7 @@     iface_semantic_mod <- fmap sh_if_semantic_module getGblEnv     let m = renameHoleModule unit_state hmap $ nameModule name     -- Doublecheck that this DFun/coercion axiom was, indeed, locally defined.-    MASSERT2( iface_semantic_mod == m, ppr iface_semantic_mod <+> ppr m )+    massertPpr (iface_semantic_mod == m) (ppr iface_semantic_mod <+> ppr m)     setNameModule (Just m) name  -- Note [rnIfaceNeverExported]
GHC/Iface/Syntax.hs view
@@ -3,7 +3,7 @@ (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 -} -{-# LANGUAGE CPP #-}+ {-# LANGUAGE LambdaCase #-}  module GHC.Iface.Syntax (@@ -41,8 +41,6 @@         AltPpr(..), ShowSub(..), ShowHowMuch(..), showToIface, showToHeader     ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Builtin.Names ( unrestrictedFunTyConKey, liftedTypeKindTyConKey )@@ -69,6 +67,7 @@ import GHC.Core.TyCon ( Role (..), Injectivity(..), tyConBndrVisArgFlag ) import GHC.Core.DataCon (SrcStrictness(..), SrcUnpackedness(..)) import GHC.Builtin.Types ( constraintKindTyConName )+import GHC.Stg.InferTags.TagSig  import GHC.Utils.Lexeme (isLexSym) import GHC.Utils.Fingerprint@@ -76,7 +75,7 @@ import GHC.Utils.Binary.Typeable () import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic-import GHC.Utils.Misc( dropList, filterByList, notNull, unzipWith, debugIsOn,+import GHC.Utils.Misc( dropList, filterByList, notNull, unzipWith,                        seqList, zipWithEqual )  import Control.Monad@@ -232,7 +231,7 @@                                      -- See Note [Storing compatibility] in GHC.Core.Coercion.Axiom  data IfaceConDecls-  = IfAbstractTyCon     -- c.f TyCon.AbstractTyCon+  = IfAbstractTyCon -- c.f TyCon.AbstractTyCon   | IfDataTyCon [IfaceConDecl] -- Data type decls   | IfNewTyCon  IfaceConDecl   -- Newtype decls @@ -346,14 +345,15 @@  data IfaceInfoItem   = HsArity         Arity-  | HsStrictness    StrictSig-  | HsCpr           CprSig+  | HsDmdSig        DmdSig+  | HsCprSig        CprSig   | HsInline        InlinePragma   | HsUnfold        Bool             -- True <=> isStrongLoopBreaker is true                     IfaceUnfolding   -- See Note [Expose recursive functions]   | HsNoCafRefs-  | HsLevity                         -- Present <=> never levity polymorphic+  | HsLevity                         -- Present <=> never representation-polymorphic   | HsLFInfo        IfaceLFInfo+  | HsTagSig        TagSig  -- NB: Specialisations and rules come in separately and are -- only later attached to the Id.  Partial reason: some are orphans.@@ -377,11 +377,12 @@  -- We only serialise the IdDetails of top-level Ids, and even then -- we only need a very limited selection.  Notably, none of the--- implicit ones are needed here, because they are not put it+-- implicit ones are needed here, because they are not put in -- interface files  data IfaceIdDetails   = IfVanillaId+  | IfWorkerLikeId [CbvMark]   | IfRecSelId (Either IfaceTyCon IfaceDecl) Bool   | IfDFunId @@ -454,9 +455,9 @@ -}  visibleIfConDecls :: IfaceConDecls -> [IfaceConDecl]-visibleIfConDecls IfAbstractTyCon  = []-visibleIfConDecls (IfDataTyCon cs) = cs-visibleIfConDecls (IfNewTyCon c)   = [c]+visibleIfConDecls (IfAbstractTyCon {}) = []+visibleIfConDecls (IfDataTyCon cs)     = cs+visibleIfConDecls (IfNewTyCon c)       = [c]  ifaceDeclImplicitBndrs :: IfaceDecl -> [OccName] --  *Excludes* the 'main' name, but *includes* the implicitly-bound names@@ -473,9 +474,9 @@  ifaceDeclImplicitBndrs (IfaceData {ifName = tc_name, ifCons = cons })   = case cons of-      IfAbstractTyCon -> []-      IfNewTyCon  cd  -> mkNewTyCoOcc (occName tc_name) : ifaceConDeclImplicitBndrs cd-      IfDataTyCon cds -> concatMap ifaceConDeclImplicitBndrs cds+      IfAbstractTyCon {} -> []+      IfNewTyCon  cd     -> mkNewTyCoOcc (occName tc_name) : ifaceConDeclImplicitBndrs cd+      IfDataTyCon cds    -> concatMap ifaceConDeclImplicitBndrs cds  ifaceDeclImplicitBndrs (IfaceClass { ifBody = IfAbstractClass })   = []@@ -659,7 +660,7 @@                                      , ifaxbLHS = pat_tys                                      , ifaxbRHS = rhs                                      , ifaxbIncomps = incomps })-  = ASSERT2( null _cvs, pp_tc $$ ppr _cvs )+  = assertPpr (null _cvs) (pp_tc $$ ppr _cvs) $     hang ppr_binders 2 (hang pp_lhs 2 (equals <+> ppr rhs))     $+$     nest 4 maybe_incomps@@ -808,7 +809,7 @@  pprIfaceDecl :: ShowSub -> IfaceDecl -> SDoc -- NB: pprIfaceDecl is also used for pretty-printing TyThings in GHCi---     See Note [Pretty-printing TyThings] in GHC.Types.TyThing.Ppr+--     See Note [Pretty printing via Iface syntax] in GHC.Types.TyThing.Ppr pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype,                              ifCtxt = context, ifResKind = kind,                              ifRoles = roles, ifCons = condecls,@@ -1027,19 +1028,26 @@ pprIfaceDecl _ (IfacePatSyn { ifName = name,                               ifPatUnivBndrs = univ_bndrs, ifPatExBndrs = ex_bndrs,                               ifPatProvCtxt = prov_ctxt, ifPatReqCtxt = req_ctxt,-                              ifPatArgs = arg_tys,+                              ifPatArgs = arg_tys, ifFieldLabels = pat_fldlbls,                               ifPatTy = pat_ty} )   = sdocWithContext mk_msg   where+    pat_keywrd = text "pattern"     mk_msg sdocCtx-      = hang (text "pattern" <+> pprPrefixOcc name)-           2 (dcolon <+> sep [univ_msg-                             , pprIfaceContextArr req_ctxt-                             , ppWhen insert_empty_ctxt $ parens empty <+> darrow-                             , ex_msg-                             , pprIfaceContextArr prov_ctxt-                             , pprIfaceType $ foldr (IfaceFunTy VisArg many_ty) pat_ty arg_tys ])+      = vcat [ ppr_pat_ty+             -- only print this for record pattern synonyms+             , if null pat_fldlbls then Outputable.empty+               else pat_keywrd <+> pprPrefixOcc name <+> pat_body]       where+        ppr_pat_ty =+          hang (pat_keywrd <+> pprPrefixOcc name)+            2 (dcolon <+> sep [univ_msg+                              , pprIfaceContextArr req_ctxt+                              , ppWhen insert_empty_ctxt $ parens empty <+> darrow+                              , ex_msg+                              , pprIfaceContextArr prov_ctxt+                              , pprIfaceType $ foldr (IfaceFunTy VisArg many_ty) pat_ty arg_tys ])+        pat_body = braces $ sep $ punctuate comma $ map ppr pat_fldlbls         univ_msg = pprUserIfaceForAll $ tyVarSpecToBinders univ_bndrs         ex_msg   = pprUserIfaceForAll $ tyVarSpecToBinders ex_bndrs @@ -1454,6 +1462,7 @@ ------------------ instance Outputable IfaceIdDetails where   ppr IfVanillaId       = Outputable.empty+  ppr (IfWorkerLikeId dmd) = text "StrWork" <> parens (ppr dmd)   ppr (IfRecSelId tc b) = text "RecSel" <+> ppr tc                           <+> if b                                 then text "<naughty>"@@ -1466,11 +1475,12 @@                               <> colon <+> ppr unf   ppr (HsInline prag)       = text "Inline:" <+> ppr prag   ppr (HsArity arity)       = text "Arity:" <+> int arity-  ppr (HsStrictness str)    = text "Strictness:" <+> ppr str-  ppr (HsCpr cpr)           = text "CPR:" <+> ppr cpr+  ppr (HsDmdSig str)        = text "Strictness:" <+> ppr str+  ppr (HsCprSig cpr)        = text "CPR:" <+> ppr cpr   ppr HsNoCafRefs           = text "HasNoCafRefs"   ppr HsLevity              = text "Never levity-polymorphic"   ppr (HsLFInfo lf_info)    = text "LambdaFormInfo:" <+> ppr lf_info+  ppr (HsTagSig tag_sig)    = text "TagSig:" <+> ppr tag_sig  instance Outputable IfaceJoinInfo where   ppr IfaceNotJoinPoint   = empty@@ -2218,37 +2228,41 @@ instance Binary IfaceIdDetails where     put_ bh IfVanillaId      = putByte bh 0     put_ bh (IfRecSelId a b) = putByte bh 1 >> put_ bh a >> put_ bh b-    put_ bh IfDFunId         = putByte bh 2+    put_ bh (IfWorkerLikeId dmds) = putByte bh 2 >> put_ bh dmds+    put_ bh IfDFunId         = putByte bh 3     get bh = do         h <- getByte bh         case h of             0 -> return IfVanillaId             1 -> do { a <- get bh; b <- get bh; return (IfRecSelId a b) }+            2 -> do { dmds <- get bh; return (IfWorkerLikeId dmds) }             _ -> return IfDFunId  instance Binary IfaceInfoItem where     put_ bh (HsArity aa)          = putByte bh 0 >> put_ bh aa-    put_ bh (HsStrictness ab)     = putByte bh 1 >> put_ bh ab+    put_ bh (HsDmdSig ab)         = putByte bh 1 >> put_ bh ab     put_ bh (HsUnfold lb ad)      = putByte bh 2 >> put_ bh lb >> put_ bh ad     put_ bh (HsInline ad)         = putByte bh 3 >> put_ bh ad     put_ bh HsNoCafRefs           = putByte bh 4     put_ bh HsLevity              = putByte bh 5-    put_ bh (HsCpr cpr)           = putByte bh 6 >> put_ bh cpr+    put_ bh (HsCprSig cpr)        = putByte bh 6 >> put_ bh cpr     put_ bh (HsLFInfo lf_info)    = putByte bh 7 >> put_ bh lf_info+    put_ bh (HsTagSig sig)        = putByte bh 8 >> put_ bh sig      get bh = do         h <- getByte bh         case h of             0 -> liftM HsArity $ get bh-            1 -> liftM HsStrictness $ get bh+            1 -> liftM HsDmdSig $ get bh             2 -> do lb <- get bh                     ad <- get bh                     return (HsUnfold lb ad)             3 -> liftM HsInline $ get bh             4 -> return HsNoCafRefs             5 -> return HsLevity-            6 -> HsCpr <$> get bh-            _ -> HsLFInfo <$> get bh+            6 -> HsCprSig <$> get bh+            7 -> HsLFInfo <$> get bh+            _ -> HsTagSig <$> get bh  instance Binary IfaceUnfolding where     put_ bh (IfCoreUnfold s e) = do@@ -2581,6 +2595,7 @@ instance NFData IfaceIdDetails where   rnf = \case     IfVanillaId -> ()+    IfWorkerLikeId dmds -> dmds `seqList` ()     IfRecSelId (Left tycon) b -> rnf tycon `seq` rnf b     IfRecSelId (Right decl) b -> rnf decl `seq` rnf b     IfDFunId -> ()@@ -2588,13 +2603,14 @@ instance NFData IfaceInfoItem where   rnf = \case     HsArity a -> rnf a-    HsStrictness str -> seqStrictSig str+    HsDmdSig str -> seqDmdSig str     HsInline p -> p `seq` () -- TODO: seq further?     HsUnfold b unf -> rnf b `seq` rnf unf     HsNoCafRefs -> ()     HsLevity -> ()-    HsCpr cpr -> cpr `seq` ()+    HsCprSig cpr -> cpr `seq` ()     HsLFInfo lf_info -> lf_info `seq` () -- TODO: seq further?+    HsTagSig sig -> sig `seq` ()  instance NFData IfaceUnfolding where   rnf = \case
GHC/Iface/Tidy.hs view
@@ -1,39 +1,33 @@-{-# LANGUAGE CPP           #-}+ {-# LANGUAGE DeriveFunctor #-}  {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+{-# LANGUAGE NamedFieldPuns #-}  {- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998--\section{Tidying up Core} -} -module GHC.Iface.Tidy (-       mkBootModDetailsTc, tidyProgram-   ) where--#include "HsVersions.h"+-- | Tidying up Core+module GHC.Iface.Tidy+  ( TidyOpts (..)+  , UnfoldingExposure (..)+  , tidyProgram+  , mkBootModDetailsTc+  )+where  import GHC.Prelude -import GHC.Driver.Session-import GHC.Driver.Backend-import GHC.Driver.Ppr-import GHC.Driver.Env- import GHC.Tc.Types+import GHC.Tc.Utils.Env  import GHC.Core import GHC.Core.Unfold import GHC.Core.Unfold.Make import GHC.Core.FVs import GHC.Core.Tidy-import GHC.Core.Opt.Monad-import GHC.Core.Stats   (coreBindsStats, CoreStats(..)) import GHC.Core.Seq     (seqBinds)-import GHC.Core.Lint-import GHC.Core.Rules import GHC.Core.Opt.Arity   ( exprArity, exprBotStrictness_maybe ) import GHC.Core.InstEnv import GHC.Core.Type     ( tidyTopType )@@ -44,12 +38,10 @@ import GHC.Iface.Tidy.StaticPtrTable import GHC.Iface.Env -import GHC.Tc.Utils.Env-import GHC.Tc.Utils.Monad- import GHC.Utils.Outputable import GHC.Utils.Misc( filterOut ) import GHC.Utils.Panic+import GHC.Utils.Trace import GHC.Utils.Logger as Logger import qualified GHC.Utils.Error as Err @@ -66,9 +58,7 @@ import GHC.Types.Name hiding (varName) import GHC.Types.Name.Set import GHC.Types.Name.Cache-import GHC.Types.Name.Ppr import GHC.Types.Avail-import GHC.Types.Unique.Supply import GHC.Types.Tickish import GHC.Types.TypeEnv @@ -82,7 +72,8 @@ import Control.Monad import Data.Function import Data.List        ( sortBy, mapAccumL )-import Data.IORef       ( atomicModifyIORef' )+import qualified Data.Set as S+import GHC.Types.CostCentre  {- Constructing the TypeEnv, Instances, Rules from which the@@ -150,8 +141,8 @@ -- We don't look at the bindings at all -- there aren't any -- for hs-boot files -mkBootModDetailsTc :: HscEnv -> TcGblEnv -> IO ModDetails-mkBootModDetailsTc hsc_env+mkBootModDetailsTc :: Logger -> TcGblEnv -> IO ModDetails+mkBootModDetailsTc logger         TcGblEnv{ tcg_exports          = exports,                   tcg_type_env         = type_env, -- just for the Ids                   tcg_tcs              = tcs,@@ -163,7 +154,7 @@                 }   = -- This timing isn't terribly useful since the result isn't forced, but     -- the message is useful to locating oneself in the compilation process.-    Err.withTiming logger dflags+    Err.withTiming logger                    (text "CoreTidy"<+>brackets (ppr this_mod))                    (const ()) $     return (ModDetails { md_types            = type_env'@@ -175,9 +166,6 @@                        , md_complete_matches = complete_matches                        })   where-    dflags = hsc_dflags hsc_env-    logger = hsc_logger hsc_env-     -- Find the LocalIds in the type env that are exported     -- Make them into GlobalIds, and tidy their types     --@@ -196,7 +184,7 @@     final_tcs  = filterOut isWiredIn tcs                  -- See Note [Drop wired-in things]     type_env'  = typeEnvFromEntities final_ids final_tcs pat_syns fam_insts-    insts'     = mkFinalClsInsts type_env' insts+    insts'     = mkFinalClsInsts type_env' $ mkInstEnv insts      -- Default methods have their export flag set (isExportedId),     -- but everything else doesn't (yet), because this is@@ -217,8 +205,8 @@       Just (AnId id') -> id'       _ -> pprPanic "lookup_final_id" (ppr id) -mkFinalClsInsts :: TypeEnv -> [ClsInst] -> [ClsInst]-mkFinalClsInsts env = map (updateClsInstDFun (lookupFinalId env))+mkFinalClsInsts :: TypeEnv -> InstEnv -> InstEnv+mkFinalClsInsts env = updateClsInstDFuns (lookupFinalId env)  globaliseAndTidyBootId :: Id -> Id -- For a LocalId with an External Name,@@ -307,8 +295,7 @@     [Even non-exported things need system-wide Uniques because the     byte-code generator builds a single Name->BCO symbol table.] -    We use the NameCache kept in the HscEnv as the-    source of such system-wide uniques.+    We use the given NameCache as the source of such system-wide uniques.      For external Ids, use the original-name cache in the NameCache     to ensure that the unique assigned is the same as the Id had@@ -352,145 +339,181 @@   load a compulsory unfolding -} -tidyProgram :: HscEnv -> ModGuts -> IO (CgGuts, ModDetails)-tidyProgram hsc_env  (ModGuts { mg_module           = mod-                              , mg_exports          = exports-                              , mg_rdr_env          = rdr_env-                              , mg_tcs              = tcs-                              , mg_insts            = cls_insts-                              , mg_fam_insts        = fam_insts-                              , mg_binds            = binds-                              , mg_patsyns          = patsyns-                              , mg_rules            = imp_rules-                              , mg_anns             = anns-                              , mg_complete_matches = complete_matches-                              , mg_deps             = deps-                              , mg_foreign          = foreign_stubs-                              , mg_foreign_files    = foreign_files-                              , mg_hpc_info         = hpc_info-                              , mg_modBreaks        = modBreaks-                              })+data UnfoldingExposure+  = ExposeNone -- ^ Don't expose unfoldings+  | ExposeSome -- ^ Only expose required unfoldings+  | ExposeAll  -- ^ Expose all unfoldings+  deriving (Show,Eq,Ord) -  = Err.withTiming logger dflags-                   (text "CoreTidy"<+>brackets (ppr mod))-                   (const ()) $-    do  { let { omit_prags = gopt Opt_OmitInterfacePragmas dflags-              ; expose_all = gopt Opt_ExposeAllUnfoldings  dflags-              ; print_unqual = mkPrintUnqualified (hsc_unit_env hsc_env) rdr_env-              ; implicit_binds = concatMap getImplicitBinds tcs-              }+data TidyOpts = TidyOpts+  { opt_name_cache        :: !NameCache+  , opt_collect_ccs       :: !Bool -- ^ Always true if we compile with -prof+  , opt_unfolding_opts    :: !UnfoldingOpts+  , opt_expose_unfoldings :: !UnfoldingExposure+      -- ^ Which unfoldings to expose+  , opt_trim_ids :: !Bool+      -- ^ trim off the arity, one-shot-ness, strictness etc which were+      -- retained for the benefit of the code generator+  , opt_expose_rules :: !Bool+      -- ^ Are rules exposed or not?+  , opt_static_ptr_opts :: !(Maybe StaticPtrOpts)+      -- ^ Options for generated static pointers, if enabled (/= Nothing).+  } -        ; (unfold_env, tidy_occ_env)-              <- chooseExternalIds hsc_env mod omit_prags expose_all-                                   binds implicit_binds imp_rules-        ; let { (trimmed_binds, trimmed_rules)-                    = findExternalRules omit_prags binds imp_rules unfold_env }+tidyProgram :: TidyOpts -> ModGuts -> IO (CgGuts, ModDetails)+tidyProgram opts (ModGuts { mg_module           = mod+                          , mg_exports          = exports+                          , mg_tcs              = tcs+                          , mg_insts            = cls_insts+                          , mg_fam_insts        = fam_insts+                          , mg_binds            = binds+                          , mg_patsyns          = patsyns+                          , mg_rules            = imp_rules+                          , mg_anns             = anns+                          , mg_complete_matches = complete_matches+                          , mg_deps             = deps+                          , mg_foreign          = foreign_stubs+                          , mg_foreign_files    = foreign_files+                          , mg_hpc_info         = hpc_info+                          , mg_modBreaks        = modBreaks+                          , mg_boot_exports     = boot_exports+                          }) = do -        ; let uf_opts = unfoldingOpts dflags-        ; (tidy_env, tidy_binds)-                 <- tidyTopBinds uf_opts unfold_env tidy_occ_env trimmed_binds+  let implicit_binds = concatMap getImplicitBinds tcs -          -- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable.-        ; (spt_entries, tidy_binds') <--             sptCreateStaticBinds hsc_env mod tidy_binds-        ; let { platform = targetPlatform (hsc_dflags hsc_env)-              ; spt_init_code = sptModuleInitCode platform mod spt_entries-              ; add_spt_init_code =-                  case backend dflags of-                    -- If we are compiling for the interpreter we will insert-                    -- any necessary SPT entries dynamically-                    Interpreter -> id-                    -- otherwise add a C stub to do so-                    _              -> (`appendStubC` spt_init_code)+  (unfold_env, tidy_occ_env) <- chooseExternalIds opts mod binds implicit_binds imp_rules+  let (trimmed_binds, trimmed_rules) = findExternalRules opts binds imp_rules unfold_env -              -- The completed type environment is gotten from-              --      a) the types and classes defined here (plus implicit things)-              --      b) adding Ids with correct IdInfo, including unfoldings,-              --              gotten from the bindings-              -- From (b) we keep only those Ids with External names;-              --          the CoreTidy pass makes sure these are all and only-              --          the externally-accessible ones-              -- This truncates the type environment to include only the-              -- exported Ids and things needed from them, which saves space-              ---              -- See Note [Don't attempt to trim data types]-              ; final_ids  = [ trimId omit_prags id-                             | id <- bindersOfBinds tidy_binds-                             , isExternalName (idName id)-                             , not (isWiredIn id)-                             ]   -- See Note [Drop wired-in things]+  let uf_opts = opt_unfolding_opts opts+  (tidy_env, tidy_binds) <- tidyTopBinds uf_opts unfold_env boot_exports tidy_occ_env trimmed_binds -              ; final_tcs      = filterOut isWiredIn tcs-                                 -- See Note [Drop wired-in things]-              ; tidy_type_env  = typeEnvFromEntities final_ids final_tcs patsyns fam_insts-              ; tidy_cls_insts = mkFinalClsInsts tidy_type_env cls_insts-              ; tidy_rules     = tidyRules tidy_env trimmed_rules+  -- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable.+  (spt_entries, mcstub, tidy_binds') <- case opt_static_ptr_opts opts of+    Nothing    -> pure ([], Nothing, tidy_binds)+    Just sopts -> sptCreateStaticBinds sopts mod tidy_binds -              ; -- See Note [Injecting implicit bindings]-                all_tidy_binds = implicit_binds ++ tidy_binds'+  let all_foreign_stubs = case mcstub of+        Nothing    -> foreign_stubs+        Just cstub -> foreign_stubs `appendStubC` cstub -              -- Get the TyCons to generate code for.  Careful!  We must use-              -- the untidied TyCons here, because we need-              --  (a) implicit TyCons arising from types and classes defined-              --      in this module-              --  (b) wired-in TyCons, which are normally removed from the-              --      TypeEnv we put in the ModDetails-              --  (c) Constructors even if they are not exported (the-              --      tidied TypeEnv has trimmed these away)-              ; alg_tycons = filter isAlgTyCon tcs-              }+      -- The completed type environment is gotten from+      --      a) the types and classes defined here (plus implicit things)+      --      b) adding Ids with correct IdInfo, including unfoldings,+      --              gotten from the bindings+      -- From (b) we keep only those Ids with External names;+      --          the CoreTidy pass makes sure these are all and only+      --          the externally-accessible ones+      -- This truncates the type environment to include only the+      -- exported Ids and things needed from them, which saves space+      --+      -- See Note [Don't attempt to trim data types]+      final_ids  = [ trimId (opt_trim_ids opts) id+                   | id <- bindersOfBinds tidy_binds+                   , isExternalName (idName id)+                   , not (isWiredIn id)+                   ]   -- See Note [Drop wired-in things] -        ; endPassIO hsc_env print_unqual CoreTidy all_tidy_binds tidy_rules+      final_tcs      = filterOut isWiredIn tcs+                       -- See Note [Drop wired-in things]+      tidy_type_env  = typeEnvFromEntities final_ids final_tcs patsyns fam_insts+      tidy_cls_insts = mkFinalClsInsts tidy_type_env $ mkInstEnv cls_insts+      tidy_rules     = tidyRules tidy_env trimmed_rules -          -- If the endPass didn't print the rules, but ddump-rules is-          -- on, print now-        ; unless (dopt Opt_D_dump_simpl dflags) $-            Logger.dumpIfSet_dyn logger dflags Opt_D_dump_rules-              (showSDoc dflags (ppr CoreTidy <+> text "rules"))-              FormatText-              (pprRulesForUser tidy_rules)+      -- See Note [Injecting implicit bindings]+      all_tidy_binds = implicit_binds ++ tidy_binds' -          -- Print one-line size info-        ; let cs = coreBindsStats tidy_binds-        ; Logger.dumpIfSet_dyn logger dflags Opt_D_dump_core_stats "Core Stats"-            FormatText-            (text "Tidy size (terms,types,coercions)"-             <+> ppr (moduleName mod) <> colon-             <+> int (cs_tm cs)-             <+> int (cs_ty cs)-             <+> int (cs_co cs) )+      -- Get the TyCons to generate code for.  Careful!  We must use+      -- the untidied TyCons here, because we need+      --  (a) implicit TyCons arising from types and classes defined+      --      in this module+      --  (b) wired-in TyCons, which are normally removed from the+      --      TypeEnv we put in the ModDetails+      --  (c) Constructors even if they are not exported (the+      --      tidied TypeEnv has trimmed these away)+      alg_tycons = filter isAlgTyCon tcs -        ; return (CgGuts { cg_module   = mod,-                           cg_tycons   = alg_tycons,-                           cg_binds    = all_tidy_binds,-                           cg_foreign  = add_spt_init_code foreign_stubs,-                           cg_foreign_files = foreign_files,-                           cg_dep_pkgs = map fst $ dep_pkgs deps,-                           cg_hpc_info = hpc_info,-                           cg_modBreaks = modBreaks,-                           cg_spt_entries = spt_entries },+      local_ccs+        | opt_collect_ccs opts+              = collectCostCentres mod all_tidy_binds tidy_rules+        | otherwise+              = S.empty -                   ModDetails { md_types            = tidy_type_env,-                                md_rules            = tidy_rules,-                                md_insts            = tidy_cls_insts,-                                md_fam_insts        = fam_insts,-                                md_exports          = exports,-                                md_anns             = anns,      -- are already tidy-                                md_complete_matches = complete_matches-                              })-        }+  return (CgGuts { cg_module        = mod+                 , cg_tycons        = alg_tycons+                 , cg_binds         = all_tidy_binds+                 , cg_ccs           = S.toList local_ccs+                 , cg_foreign       = all_foreign_stubs+                 , cg_foreign_files = foreign_files+                 , cg_dep_pkgs      = dep_direct_pkgs deps+                 , cg_hpc_info      = hpc_info+                 , cg_modBreaks     = modBreaks+                 , cg_spt_entries   = spt_entries+                 }+         , ModDetails { md_types            = tidy_type_env+                      , md_rules            = tidy_rules+                      , md_insts            = tidy_cls_insts+                      , md_fam_insts        = fam_insts+                      , md_exports          = exports+                      , md_anns             = anns      -- are already tidy+                      , md_complete_matches = complete_matches+                      }+         )+++------------------------------------------------------------------------------+-- Collecting cost centres+-- ---------------------------------------------------------------------------++-- | Collect cost centres defined in the current module, including those in+-- unfoldings.+collectCostCentres :: Module -> CoreProgram -> [CoreRule] -> S.Set CostCentre+collectCostCentres mod_name binds rules+  = {-# SCC collectCostCentres #-} foldl' go_bind (go_rules S.empty) binds   where-    dflags = hsc_dflags hsc_env-    logger = hsc_logger hsc_env+    go cs e = case e of+      Var{} -> cs+      Lit{} -> cs+      App e1 e2 -> go (go cs e1) e2+      Lam _ e -> go cs e+      Let b e -> go (go_bind cs b) e+      Case scrt _ _ alts -> go_alts (go cs scrt) alts+      Cast e _ -> go cs e+      Tick (ProfNote cc _ _) e ->+        go (if ccFromThisModule cc mod_name then S.insert cc cs else cs) e+      Tick _ e -> go cs e+      Type{} -> cs+      Coercion{} -> cs +    go_alts = foldl' (\cs (Alt _con _bndrs e) -> go cs e)++    go_bind :: S.Set CostCentre -> CoreBind -> S.Set CostCentre+    go_bind cs (NonRec b e) =+      go (do_binder cs b) e+    go_bind cs (Rec bs) =+      foldl' (\cs' (b, e) -> go (do_binder cs' b) e) cs bs++    do_binder cs b = maybe cs (go cs) (get_unf b)+++    -- Unfoldings may have cost centres that in the original definion are+    -- optimized away, see #5889.+    get_unf = maybeUnfoldingTemplate . realIdUnfolding++    -- Have to look at the RHS of rules as well, as these may contain ticks which+    -- don't appear anywhere else. See #19894+    go_rules cs = foldl' go cs (mapMaybe get_rhs rules)++    get_rhs Rule { ru_rhs } = Just ru_rhs+    get_rhs BuiltinRule {} = Nothing+ -------------------------- trimId :: Bool -> Id -> Id -- With -O0 we now trim off the arity, one-shot-ness, strictness -- etc which tidyTopIdInfo retains for the benefit of the code generator -- but which we don't want in the interface file or ModIface for -- downstream compilations-trimId omit_prags id-  | omit_prags, not (isImplicitId id)+trimId do_trim id+  | do_trim, not (isImplicitId id)   = id `setIdInfo`      vanillaIdInfo        `setIdUnfolding` idUnfolding id        -- We respect the final unfolding chosen by tidyTopIdInfo.@@ -621,21 +644,20 @@   --   -- Bool => expose unfolding or not. -chooseExternalIds :: HscEnv+chooseExternalIds :: TidyOpts                   -> Module-                  -> Bool -> Bool                   -> [CoreBind]                   -> [CoreBind]                   -> [CoreRule]                   -> IO (UnfoldEnv, TidyOccEnv)                   -- Step 1 from the notes above -chooseExternalIds hsc_env mod omit_prags expose_all binds implicit_binds imp_id_rules+chooseExternalIds opts mod binds implicit_binds imp_id_rules   = do { (unfold_env1,occ_env1) <- search init_work_list emptyVarEnv init_occ_env        ; let internal_ids = filter (not . (`elemVarEnv` unfold_env1)) binders        ; tidy_internal internal_ids unfold_env1 occ_env1 }  where-  nc_var = hsc_NC hsc_env+  name_cache = opt_name_cache opts    -- init_ext_ids is the initial list of Ids that should be   -- externalised.  It serves as the starting point for finding a@@ -649,11 +671,14 @@   init_ext_ids   = sortBy (compare `on` getOccName) $ filter is_external binders    -- An Id should be external if either (a) it is exported,-  -- (b) it appears in the RHS of a local rule for an imported Id, or-  -- See Note [Which rules to expose]-  is_external id = isExportedId id || id `elemVarSet` rule_rhs_vars+  -- (b) local rules are exposed and it appears in the RHS of a local rule for+  -- an imported Id, or See Note [Which rules to expose]+  is_external id+    | isExportedId id       = True+    | opt_expose_rules opts = id `elemVarSet` rule_rhs_vars+    | otherwise             = False -  rule_rhs_vars  = mapUnionVarSet ruleRhsFreeVars imp_id_rules+  rule_rhs_vars = mapUnionVarSet ruleRhsFreeVars imp_id_rules    binders          = map fst $ flattenBinds binds   implicit_binders = bindersOfBinds implicit_binds@@ -697,15 +722,15 @@   search ((idocc,referrer) : rest) unfold_env occ_env     | idocc `elemVarEnv` unfold_env = search rest unfold_env occ_env     | otherwise = do-      (occ_env', name') <- tidyTopName mod nc_var (Just referrer) occ_env idocc+      (occ_env', name') <- tidyTopName mod name_cache (Just referrer) occ_env idocc       let-          (new_ids, show_unfold) = addExternal omit_prags expose_all refined_id+          (new_ids, show_unfold) = addExternal opts refined_id                  -- 'idocc' is an *occurrence*, but we need to see the                 -- unfolding in the *definition*; so look up in binder_set           refined_id = case lookupVarSet binder_set idocc of                          Just id -> id-                         Nothing -> WARN( True, ppr idocc ) idocc+                         Nothing -> warnPprTrace True "chooseExternalIds" (ppr idocc) idocc            unfold_env' = extendVarEnv unfold_env idocc (name',show_unfold)           referrer' | isExportedId refined_id = refined_id@@ -717,13 +742,13 @@                 -> IO (UnfoldEnv, TidyOccEnv)   tidy_internal []       unfold_env occ_env = return (unfold_env,occ_env)   tidy_internal (id:ids) unfold_env occ_env = do-      (occ_env', name') <- tidyTopName mod nc_var Nothing occ_env id+      (occ_env', name') <- tidyTopName mod name_cache Nothing occ_env id       let unfold_env' = extendVarEnv unfold_env id (name',False)       tidy_internal ids unfold_env' occ_env' -addExternal :: Bool -> Bool -> Id -> ([Id], Bool)-addExternal omit_prags expose_all id-  | omit_prags+addExternal :: TidyOpts -> Id -> ([Id], Bool)+addExternal opts id+  | ExposeNone <- opt_expose_unfoldings opts   , not (isCompulsoryUnfolding unfolding)   = ([], False)  -- See Note [Always expose compulsory unfoldings]                  -- in GHC.HsToCore@@ -734,27 +759,38 @@   where     new_needed_ids = bndrFvsInOrder show_unfold id     idinfo         = idInfo id-    unfolding      = unfoldingInfo idinfo+    unfolding      = realUnfoldingInfo idinfo     show_unfold    = show_unfolding unfolding     never_active   = isNeverActive (inlinePragmaActivation (inlinePragInfo idinfo))     loop_breaker   = isStrongLoopBreaker (occInfo idinfo)-    bottoming_fn   = isDeadEndSig (strictnessInfo idinfo)+    bottoming_fn   = isDeadEndSig (dmdSigInfo idinfo)          -- Stuff to do with the Id's unfolding         -- We leave the unfolding there even if there is a worker         -- In GHCi the unfolding is used by importers      show_unfolding (CoreUnfolding { uf_src = src, uf_guidance = guidance })-       =  expose_all         -- 'expose_all' says to expose all-                             -- unfoldings willy-nilly+       = opt_expose_unfoldings opts == ExposeAll+            -- 'ExposeAll' says to expose all+            -- unfoldings willy-nilly         || isStableSource src     -- Always expose things whose                                  -- source is an inline rule -       || not (bottoming_fn      -- No need to inline bottom functions-           || never_active       -- Or ones that say not to-           || loop_breaker       -- Or that are loop breakers-           || neverUnfoldGuidance guidance)+       || not dont_inline+       where+         dont_inline+            | never_active = True   -- Will never inline+            | loop_breaker = True   -- Ditto+            | otherwise    = case guidance of+                                UnfWhen {}       -> False+                                UnfIfGoodArgs {} -> bottoming_fn+                                UnfNever {}      -> True+         -- bottoming_fn: don't inline bottoming functions, unless the+         -- RHS is very small or trivial (UnfWhen), in which case we+         -- may as well do so For example, a cast might cancel with+         -- the call site.+     show_unfolding (DFunUnfolding {}) = True     show_unfolding _                  = False @@ -848,7 +884,7 @@ -- For top-level bindings (call from addExternal, via bndrFvsInOrder) --       we say "True" if we are exposing that unfolding dffvLetBndr vanilla_unfold id-  = do { go_unf (unfoldingInfo idinfo)+  = do { go_unf (realUnfoldingInfo idinfo)        ; mapM_ go_rule (ruleInfoRules (ruleInfo idinfo)) }   where     idinfo = idInfo id@@ -931,13 +967,13 @@ This stuff is the only reason for the ru_auto field in a Rule. -} -findExternalRules :: Bool       -- Omit pragmas+findExternalRules :: TidyOpts                   -> [CoreBind]                   -> [CoreRule] -- Local rules for imported fns                   -> UnfoldEnv  -- Ids that are exported, so we need their rules                   -> ([CoreBind], [CoreRule]) -- See Note [Finding external rules]-findExternalRules omit_prags binds imp_id_rules unfold_env+findExternalRules opts binds imp_id_rules unfold_env   = (trimmed_binds, filter keep_rule all_rules)   where     imp_rules         = filter expose_rule imp_id_rules@@ -962,7 +998,7 @@         --      been discarded; see Note [Trimming auto-rules]      expose_rule rule-        | omit_prags = False+        | not (opt_expose_rules opts) = False         | otherwise  = all is_external_id (ruleLhsFreeIdsList rule)                 -- Don't expose a rule whose LHS mentions a locally-defined                 -- Id that is completely internal (i.e. not visible to an@@ -1024,9 +1060,9 @@ we intend to externalise it. -} -tidyTopName :: Module -> IORef NameCache -> Maybe Id -> TidyOccEnv+tidyTopName :: Module -> NameCache -> Maybe Id -> TidyOccEnv             -> Id -> IO (TidyOccEnv, Name)-tidyTopName mod nc_var maybe_ref occ_env id+tidyTopName mod name_cache maybe_ref occ_env id   | global && internal = return (occ_env, localiseName name)    | global && external = return (occ_env, name)@@ -1037,16 +1073,23 @@   -- Now we get to the real reason that all this is in the IO Monad:   -- we have to update the name cache in a nice atomic fashion -  | local  && internal = do { new_local_name <- atomicModifyIORef' nc_var mk_new_local-                            ; return (occ_env', new_local_name) }+  | local  && internal = do uniq <- takeUniqFromNameCache name_cache+                            let new_local_name = mkInternalName uniq occ' loc+                            return (occ_env', new_local_name)         -- Even local, internal names must get a unique occurrence, because         -- if we do -split-objs we externalise the name later, in the code generator         --         -- Similarly, we must make sure it has a system-wide Unique, because         -- the byte-code generator builds a system-wide Name->BCO symbol table -  | local  && external = do { new_external_name <- atomicModifyIORef' nc_var mk_new_external-                            ; return (occ_env', new_external_name) }+  | local  && external = do new_external_name <- allocateGlobalBinder name_cache mod occ' loc+                            return (occ_env', new_external_name)+        -- If we want to externalise a currently-local name, check+        -- whether we have already assigned a unique for it.+        -- If so, use it; if not, extend the table.+        -- All this is done by allocateGlobalBinder.+        -- This is needed when *re*-compiling a module in GHCi; we must+        -- use the same name for externally-visible things as we did before.    | otherwise = panic "tidyTopName"   where@@ -1080,18 +1123,7 @@      (occ_env', occ') = tidyOccName occ_env new_occ -    mk_new_local nc = (nc { nsUniqs = us }, mkInternalName uniq occ' loc)-                    where-                      (uniq, us) = takeUniqFromSupply (nsUniqs nc) -    mk_new_external nc = allocateGlobalBinder nc mod occ' loc-        -- If we want to externalise a currently-local name, check-        -- whether we have already assigned a unique for it.-        -- If so, use it; if not, extend the table.-        -- All this is done by allcoateGlobalBinder.-        -- This is needed when *re*-compiling a module in GHCi; we must-        -- use the same name for externally-visible things as we did before.- {- ************************************************************************ *                                                                      *@@ -1101,7 +1133,7 @@ -}  -- TopTidyEnv: when tidying we need to know---   * nc_var: The NameCache, containing a unique supply and any pre-ordained Names.+--   * name_cache: The NameCache, containing a unique supply and any pre-ordained Names. --        These may have arisen because the --        renamer read in an interface file mentioning M.$wf, say, --        and assigned it unique r77.  If, on this compilation, we've@@ -1116,39 +1148,41 @@  tidyTopBinds :: UnfoldingOpts              -> UnfoldEnv+             -> NameSet              -> TidyOccEnv              -> CoreProgram              -> IO (TidyEnv, CoreProgram) -tidyTopBinds uf_opts unfold_env init_occ_env binds+tidyTopBinds uf_opts unfold_env boot_exports init_occ_env binds   = do let result = tidy init_env binds        seqBinds (snd result) `seq` return result        -- This seqBinds avoids a spike in space usage (see #13564)   where     init_env = (init_occ_env, emptyVarEnv) -    tidy = mapAccumL (tidyTopBind uf_opts unfold_env)+    tidy = mapAccumL (tidyTopBind uf_opts unfold_env boot_exports)  ------------------------ tidyTopBind  :: UnfoldingOpts              -> UnfoldEnv+             -> NameSet              -> TidyEnv              -> CoreBind              -> (TidyEnv, CoreBind) -tidyTopBind uf_opts unfold_env+tidyTopBind uf_opts unfold_env boot_exports             (occ_env,subst1) (NonRec bndr rhs)   = (tidy_env2,  NonRec bndr' rhs')   where     Just (name',show_unfold) = lookupVarEnv unfold_env bndr-    (bndr', rhs') = tidyTopPair uf_opts show_unfold tidy_env2 name' (bndr, rhs)+    (bndr', rhs') = tidyTopPair uf_opts show_unfold boot_exports tidy_env2 name' (bndr, rhs)     subst2        = extendVarEnv subst1 bndr bndr'     tidy_env2     = (occ_env, subst2) -tidyTopBind uf_opts unfold_env (occ_env, subst1) (Rec prs)+tidyTopBind uf_opts unfold_env boot_exports (occ_env, subst1) (Rec prs)   = (tidy_env2, Rec prs')   where-    prs' = [ tidyTopPair uf_opts show_unfold tidy_env2 name' (id,rhs)+    prs' = [ tidyTopPair uf_opts show_unfold boot_exports tidy_env2 name' (id,rhs)            | (id,rhs) <- prs,              let (name',show_unfold) =                     expectJust "tidyTopBind" $ lookupVarEnv unfold_env id@@ -1162,6 +1196,7 @@ ----------------------------------------------------------- tidyTopPair :: UnfoldingOpts             -> Bool  -- show unfolding+            -> NameSet             -> TidyEnv  -- The TidyEnv is used to tidy the IdInfo                         -- It is knot-tied: don't look at it!             -> Name             -- New name@@ -1173,14 +1208,17 @@         -- group, a variable late in the group might be mentioned         -- in the IdInfo of one early in the group -tidyTopPair uf_opts show_unfold rhs_tidy_env name' (bndr, rhs)-  = (bndr1, rhs1)+tidyTopPair uf_opts show_unfold boot_exports rhs_tidy_env name' (bndr, rhs)+  = -- pprTrace "tidyTop" (ppr name' <+> ppr details <+> ppr rhs) $+    (bndr1, rhs1)+   where+    !cbv_bndr = tidyCbvInfoTop boot_exports bndr rhs     bndr1    = mkGlobalId details name' ty' idinfo'-    details  = idDetails bndr   -- Preserve the IdDetails-    ty'      = tidyTopType (idType bndr)+    details  = idDetails cbv_bndr -- Preserve the IdDetails+    ty'      = tidyTopType (idType cbv_bndr)     rhs1     = tidyExpr rhs_tidy_env rhs-    idinfo'  = tidyTopIdInfo uf_opts rhs_tidy_env name' rhs rhs1 (idInfo bndr)+    idinfo'  = tidyTopIdInfo uf_opts rhs_tidy_env name' rhs rhs1 (idInfo cbv_bndr)                              show_unfold  -- tidyTopIdInfo creates the final IdInfo for top-level@@ -1198,16 +1236,16 @@                         -- Arity and strictness info are enough;                         --      c.f. GHC.Core.Tidy.tidyLetBndr         `setArityInfo`      arity-        `setStrictnessInfo` final_sig-        `setCprInfo`        final_cpr-        `setUnfoldingInfo`  minimal_unfold_info  -- See note [Preserve evaluatedness]+        `setDmdSigInfo` final_sig+        `setCprSigInfo`        final_cpr+        `setUnfoldingInfo`  minimal_unfold_info  -- See Note [Preserve evaluatedness]                                                  -- in GHC.Core.Tidy    | otherwise           -- Externally-visible Ids get the whole lot   = vanillaIdInfo         `setArityInfo`         arity-        `setStrictnessInfo`    final_sig-        `setCprInfo`           final_cpr+        `setDmdSigInfo`    final_sig+        `setCprSigInfo`           final_cpr         `setOccInfo`           robust_occ_info         `setInlinePragInfo`    (inlinePragInfo idinfo)         `setUnfoldingInfo`     unfold_info@@ -1224,14 +1262,14 @@     --------- Strictness ------------     mb_bot_str = exprBotStrictness_maybe orig_rhs -    sig = strictnessInfo idinfo+    sig = dmdSigInfo idinfo     final_sig | not $ isTopSig sig-              = WARN( _bottom_hidden sig , ppr name ) sig+              = warnPprTrace (_bottom_hidden sig) "tidyTopIdInfo" (ppr name) sig               -- try a cheap-and-cheerful bottom analyser               | Just (_, nsig) <- mb_bot_str = nsig               | otherwise                    = sig -    cpr = cprInfo idinfo+    cpr = cprSigInfo idinfo     final_cpr | Just _ <- mb_bot_str               = mkCprSig arity botCpr               | otherwise@@ -1242,13 +1280,13 @@                                   Just (arity, _) -> not (isDeadEndAppSig id_sig arity)      --------- Unfolding -------------    unf_info = unfoldingInfo idinfo+    unf_info = realUnfoldingInfo idinfo     unfold_info       | isCompulsoryUnfolding unf_info || show_unfold       = tidyUnfolding rhs_tidy_env unf_info unf_from_rhs       | otherwise       = minimal_unfold_info-    minimal_unfold_info = zapUnfolding unf_info+    minimal_unfold_info = trimUnfolding unf_info     unf_from_rhs = mkFinalUnfolding uf_opts InlineRhs final_sig tidy_rhs     -- NB: do *not* expose the worker if show_unfold is off,     --     because that means this thing is a loop breaker or@@ -1262,7 +1300,7 @@     --    the function returns bottom     -- In this case, show_unfold will be false (we don't expose unfoldings     -- for bottoming functions), but we might still have a worker/wrapper-    -- split (see Note [Worker-wrapper for bottoming functions] in+    -- split (see Note [Worker/wrapper for bottoming functions] in     -- GHC.Core.Opt.WorkWrap)  @@ -1274,106 +1312,3 @@     -- it to the top level. So it seems more robust just to     -- fix it here.     arity = exprArity orig_rhs--{--************************************************************************-*                                                                      *-                  Old, dead, type-trimming code-*                                                                      *-************************************************************************--We used to try to "trim off" the constructors of data types that are-not exported, to reduce the size of interface files, at least without--O.  But that is not always possible: see the old Note [When we can't-trim types] below for exceptions.--Then (#7445) I realised that the TH problem arises for any data type-that we have deriving( Data ), because we can invoke-   Language.Haskell.TH.Quote.dataToExpQ-to get a TH Exp representation of a value built from that data type.-You don't even need {-# LANGUAGE TemplateHaskell #-}.--At this point I give up. The pain of trimming constructors just-doesn't seem worth the gain.  So I've dumped all the code, and am just-leaving it here at the end of the module in case something like this-is ever resurrected.---Note [When we can't trim types]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The basic idea of type trimming is to export algebraic data types-abstractly (without their data constructors) when compiling without--O, unless of course they are explicitly exported by the user.--We always export synonyms, because they can be mentioned in the type-of an exported Id.  We could do a full dependency analysis starting-from the explicit exports, but that's quite painful, and not done for-now.--But there are some times we can't do that, indicated by the 'no_trim_types' flag.--First, Template Haskell.  Consider (#2386) this-        module M(T, makeOne) where-          data T = Yay String-          makeOne = [| Yay "Yep" |]-Notice that T is exported abstractly, but makeOne effectively exports it too!-A module that splices in $(makeOne) will then look for a declaration of Yay,-so it'd better be there.  Hence, brutally but simply, we switch off type-constructor trimming if TH is enabled in this module.--Second, data kinds.  Consider (#5912)-     {-# LANGUAGE DataKinds #-}-     module M() where-     data UnaryTypeC a = UnaryDataC a-     type Bug = 'UnaryDataC-We always export synonyms, so Bug is exposed, and that means that-UnaryTypeC must be too, even though it's not explicitly exported.  In-effect, DataKinds means that we'd need to do a full dependency analysis-to see what data constructors are mentioned.  But we don't do that yet.--In these two cases we just switch off type trimming altogether.--mustExposeTyCon :: Bool         -- Type-trimming flag-                -> NameSet      -- Exports-                -> TyCon        -- The tycon-                -> Bool         -- Can its rep be hidden?--- We are compiling without -O, and thus trying to write as little as--- possible into the interface file.  But we must expose the details of--- any data types whose constructors or fields are exported-mustExposeTyCon no_trim_types exports tc-  | no_trim_types               -- See Note [When we can't trim types]-  = True--  | not (isAlgTyCon tc)         -- Always expose synonyms (otherwise we'd have to-                                -- figure out whether it was mentioned in the type-                                -- of any other exported thing)-  = True--  | isEnumerationTyCon tc       -- For an enumeration, exposing the constructors-  = True                        -- won't lead to the need for further exposure--  | isFamilyTyCon tc            -- Open type family-  = True--  -- Below here we just have data/newtype decls or family instances--  | null data_cons              -- Ditto if there are no data constructors-  = True                        -- (NB: empty data types do not count as enumerations-                                -- see Note [Enumeration types] in GHC.Core.TyCon--  | any exported_con data_cons  -- Expose rep if any datacon or field is exported-  = True--  | isNewTyCon tc && isFFITy (snd (newTyConRhs tc))-  = True   -- Expose the rep for newtypes if the rep is an FFI type.-           -- For a very annoying reason.  'Foreign import' is meant to-           -- be able to look through newtypes transparently, but it-           -- can only do that if it can "see" the newtype representation--  | otherwise-  = False-  where-    data_cons = tyConDataCons tc-    exported_con con = any (`elemNameSet` exports)-                           (dataConName con : dataConFieldLabels con)--}
GHC/Iface/Tidy/StaticPtrTable.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE ViewPatterns  #-}+{-# LANGUAGE ViewPatterns #-}  -- | Code generation for the Static Pointer Table --@@ -48,9 +48,11 @@ --  module GHC.Iface.Tidy.StaticPtrTable-    ( sptCreateStaticBinds-    , sptModuleInitCode-    ) where+  ( sptCreateStaticBinds+  , sptModuleInitCode+  , StaticPtrOpts (..)+  )+where  {- Note [Grand plan for static forms] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -126,37 +128,35 @@ import GHC.Prelude import GHC.Platform -import GHC.Driver.Session-import GHC.Driver.Env- import GHC.Core import GHC.Core.Utils (collectMakeStaticArgs) import GHC.Core.DataCon-import GHC.Core.Make (mkStringExprFSWith)+import GHC.Core.Make (mkStringExprFSWith,MkStringIds(..)) import GHC.Core.Type  import GHC.Cmm.CLabel  import GHC.Unit.Module import GHC.Utils.Outputable as Outputable-import GHC.Utils.Panic-import GHC.Builtin.Names-import GHC.Tc.Utils.Env (lookupGlobal)  import GHC.Linker.Types -import GHC.Types.Name import GHC.Types.Id-import GHC.Types.TyThing import GHC.Types.ForeignStubs+import GHC.Data.Maybe -import Control.Monad.Trans.Class (lift)-import Control.Monad.Trans.State+import Control.Monad.Trans.State.Strict import Data.List (intercalate)-import Data.Maybe import GHC.Fingerprint-import qualified GHC.LanguageExtensions as LangExt +data StaticPtrOpts = StaticPtrOpts+  { opt_platform                :: !Platform    -- ^ Target platform+  , opt_gen_cstub               :: !Bool        -- ^ Generate CStub or not+  , opt_mk_string               :: !MkStringIds -- ^ Ids for `unpackCString[Utf8]#`+  , opt_static_ptr_info_datacon :: !DataCon          -- ^ `StaticPtrInfo` datacon+  , opt_static_ptr_datacon      :: !DataCon          -- ^ `StaticPtr` datacon+  }+ -- | Replaces all bindings of the form -- -- > b = /\ ... -> makeStatic location value@@ -170,16 +170,13 @@ -- -- It also yields the C stub that inserts these bindings into the static -- pointer table.-sptCreateStaticBinds :: HscEnv -> Module -> CoreProgram-                     -> IO ([SptEntry], CoreProgram)-sptCreateStaticBinds hsc_env this_mod binds-    | not (xopt LangExt.StaticPointers dflags) =-      return ([], binds)-    | otherwise = do-      -- Make sure the required interface files are loaded.-      _ <- lookupGlobal hsc_env unpackCStringName+sptCreateStaticBinds :: StaticPtrOpts -> Module -> CoreProgram -> IO ([SptEntry], Maybe CStub, CoreProgram)+sptCreateStaticBinds opts this_mod binds = do       (fps, binds') <- evalStateT (go [] [] binds) 0-      return (fps, binds')+      let cstub+            | opt_gen_cstub opts = Just (sptModuleInitCode (opt_platform opts) this_mod fps)+            | otherwise          = Nothing+      return (fps, cstub, binds')   where     go fps bs xs = case xs of       []        -> return (reverse fps, reverse bs)@@ -187,9 +184,6 @@         (fps', bnd') <- replaceStaticBind bnd         go (reverse fps' ++ fps) (bnd' : bs) xs' -    dflags = hsc_dflags hsc_env-    platform = targetPlatform dflags-     -- Generates keys and replaces 'makeStatic' with 'StaticPtr'.     --     -- The 'Int' state is used to produce a different key for each binding.@@ -215,23 +209,20 @@     mkStaticBind t srcLoc e = do       i <- get       put (i + 1)-      staticPtrInfoDataCon <--        lift $ lookupDataConHscEnv staticPtrInfoDataConName+      let staticPtrInfoDataCon = opt_static_ptr_info_datacon opts       let fp@(Fingerprint w0 w1) = mkStaticPtrFingerprint i-      info <- mkConApp staticPtrInfoDataCon <$>-            (++[srcLoc]) <$>-            mapM (mkStringExprFSWith (lift . lookupIdHscEnv))-                 [ unitFS $ moduleUnit this_mod-                 , moduleNameFS $ moduleName this_mod-                 ]+      let mk_string_fs = mkStringExprFSWith (opt_mk_string opts)+      let info = mkConApp staticPtrInfoDataCon+                  [ mk_string_fs $ unitFS $ moduleUnit this_mod+                  , mk_string_fs $ moduleNameFS $ moduleName this_mod+                  , srcLoc+                  ] -      -- The module interface of GHC.StaticPtr should be loaded at least-      -- when looking up 'fromStatic' during type-checking.-      staticPtrDataCon <- lift $ lookupDataConHscEnv staticPtrDataConName+      let staticPtrDataCon = opt_static_ptr_datacon opts       return (fp, mkConApp staticPtrDataCon                                [ Type t-                               , mkWord64LitWordRep platform w0-                               , mkWord64LitWordRep platform w1+                               , mkWord64LitWord64 w0+                               , mkWord64LitWord64 w1                                , info                                , e ]) @@ -242,24 +233,6 @@         , show n         ] -    -- Choose either 'Word64#' or 'Word#' to represent the arguments of the-    -- 'Fingerprint' data constructor.-    mkWord64LitWordRep platform =-      case platformWordSize platform of-        PW4 -> mkWord64LitWord64-        PW8 -> mkWordLit platform . toInteger--    lookupIdHscEnv :: Name -> IO Id-    lookupIdHscEnv n = lookupType hsc_env n >>=-                         maybe (getError n) (return . tyThingId)--    lookupDataConHscEnv :: Name -> IO DataCon-    lookupDataConHscEnv n = lookupType hsc_env n >>=-                              maybe (getError n) (return . tyThingDataCon)--    getError n = pprPanic "sptCreateStaticBinds.get: not found" $-      text "Couldn't find" <+> ppr n- -- | @sptModuleInitCode module fps@ is a C stub to insert the static entries -- of @module@ into the static pointer table. --@@ -267,11 +240,12 @@ -- its fingerprint. sptModuleInitCode :: Platform -> Module -> [SptEntry] -> CStub sptModuleInitCode _        _        [] = mempty-sptModuleInitCode platform this_mod entries = CStub $ vcat-    [ text "static void hs_spt_init_" <> ppr this_mod-           <> text "(void) __attribute__((constructor));"-    , text "static void hs_spt_init_" <> ppr this_mod <> text "(void)"-    , braces $ vcat $+sptModuleInitCode platform this_mod entries =+    initializerCStub platform init_fn_nm empty init_fn_body `mappend`+    finalizerCStub platform fini_fn_nm empty fini_fn_body+  where+    init_fn_nm = mkInitializerStubLabel this_mod "spt"+    init_fn_body = vcat         [  text "static StgWord64 k" <> int i <> text "[2] = "            <> pprFingerprint fp <> semi         $$ text "extern StgPtr "@@ -285,17 +259,15 @@         <> semi         |  (i, SptEntry n fp) <- zip [0..] entries         ]-    , text "static void hs_spt_fini_" <> ppr this_mod-           <> text "(void) __attribute__((destructor));"-    , text "static void hs_spt_fini_" <> ppr this_mod <> text "(void)"-    , braces $ vcat $++    fini_fn_nm = mkFinalizerStubLabel this_mod "spt"+    fini_fn_body = vcat         [  text "StgWord64 k" <> int i <> text "[2] = "            <> pprFingerprint fp <> semi         $$ text "hs_spt_remove" <> parens (char 'k' <> int i) <> semi         | (i, (SptEntry _ fp)) <- zip [0..] entries         ]-    ]-  where+     pprFingerprint :: Fingerprint -> SDoc     pprFingerprint (Fingerprint w1 w2) =       braces $ hcat $ punctuate comma
GHC/Iface/Type.hs view
@@ -6,7 +6,7 @@ This module defines interface types and binders -} -{-# LANGUAGE CPP #-}+ {-# LANGUAGE FlexibleInstances #-}   -- FlexibleInstances for Binary (DefMethSpec IfaceType) {-# LANGUAGE BangPatterns #-}@@ -67,21 +67,20 @@         many_ty     ) where -#include "HsVersions.h"- import GHC.Prelude  import {-# SOURCE #-} GHC.Builtin.Types                                  ( coercibleTyCon, heqTyCon                                  , tupleTyConName                                  , manyDataConTyCon, oneDataConTyCon-                                 , liftedRepTyCon )-import {-# SOURCE #-} GHC.Core.Type ( isRuntimeRepTy, isMultiplicityTy )+                                 , liftedRepTyCon, liftedDataConTyCon )+import GHC.Core.Type ( isRuntimeRepTy, isMultiplicityTy, isLevityTy )  import GHC.Core.TyCon hiding ( pprPromotionQuote ) import GHC.Core.Coercion.Axiom import GHC.Types.Var import GHC.Builtin.Names+import {-# SOURCE #-} GHC.Builtin.Types ( liftedTypeKindTyConName ) import GHC.Types.Name import GHC.Types.Basic import GHC.Utils.Binary@@ -252,13 +251,13 @@ data IfaceTyConSort = IfaceNormalTyCon          -- ^ a regular tycon                      | IfaceTupleTyCon !Arity !TupleSort-                      -- ^ e.g. @(a, b, c)@ or @(#a, b, c#)@.+                      -- ^ a tuple, e.g. @(a, b, c)@ or @(#a, b, c#)@.                       -- The arity is the tuple width, not the tycon arity                       -- (which is twice the width in the case of unboxed                       -- tuples).                      | IfaceSumTyCon !Arity-                      -- ^ e.g. @(a | b | c)@+                      -- ^ an unboxed sum, e.g. @(# a | b | c #)@                      | IfaceEqualityTyCon                       -- ^ A heterogeneous equality TyCon@@ -821,8 +820,8 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Normally, we pretty-print `TYPE 'LiftedRep` as `Type` (or `*`) and `FUN 'Many` as `(->)`.-This way, error messages don't refer to levity polymorphism or linearity-if it is not necessary.+This way, error messages don't refer to representation polymorphism+or linearity if it is not necessary.  However, when printing the definition of Type or (->) with :info, this would give confusing output: `type (->) = (->)` (#18594).@@ -863,10 +862,8 @@           -- The above case is rare. (See Note [AnonTCB InvisArg] in GHC.Core.TyCon.)           -- Should we print these differently?         NamedTCB Required  -> ppr_bndr (UseBndrParens True)-        -- See Note [Explicit Case Statement for Specificity]-        NamedTCB (Invisible spec) -> case spec of-          SpecifiedSpec    -> char '@' <> ppr_bndr (UseBndrParens True)-          InferredSpec     -> char '@' <> braces (ppr_bndr (UseBndrParens False))+        NamedTCB Specified -> char '@' <> ppr_bndr (UseBndrParens True)+        NamedTCB Inferred  -> char '@' <> braces (ppr_bndr (UseBndrParens False))       where         ppr_bndr = pprIfaceTvBndr bndr suppress_sig @@ -929,9 +926,9 @@ ppr_ty ctxt_prec ty@(IfaceFunTy InvisArg _ _ _) = ppr_sigma ctxt_prec ty  ppr_ty _         (IfaceFreeTyVar tyvar) = ppr tyvar  -- This is the main reason for IfaceFreeTyVar!-ppr_ty _         (IfaceTyVar tyvar)     = ppr tyvar  -- See Note [TcTyVars in IfaceType]+ppr_ty _         (IfaceTyVar tyvar)     = ppr tyvar  -- See Note [Free tyvars in IfaceType] ppr_ty ctxt_prec (IfaceTyConApp tc tys) = pprTyTcApp ctxt_prec tc tys-ppr_ty ctxt_prec (IfaceTupleTy i p tys) = pprTuple ctxt_prec i p tys+ppr_ty ctxt_prec (IfaceTupleTy i p tys) = pprTuple ctxt_prec i p tys -- always fully saturated ppr_ty _         (IfaceLitTy n)         = pprIfaceTyLit n         -- Function types ppr_ty ctxt_prec (IfaceFunTy _ w ty1 ty2)  -- Should be VisArg@@ -1004,7 +1001,7 @@ Likewise, we default all Multiplicity variables to Many.  This is done in a pass right before pretty-printing-(defaultNonStandardVars, controlled by+(defaultIfaceTyVarsOfKind, controlled by -fprint-explicit-runtime-reps and -XLinearTypes)  This applies to /quantified/ variables like 'w' above.  What about@@ -1030,13 +1027,14 @@ (test T18357a). Therefore, we additionally test for isTyConableTyVar. -} --- | Default 'RuntimeRep' variables to 'LiftedRep', and 'Multiplicity'+-- | Default 'RuntimeRep' variables to 'LiftedRep',+--   'Levity' variables to 'Lifted', and 'Multiplicity' --   variables to 'Many'. For example: -- -- @ -- ($) :: forall (r :: GHC.Types.RuntimeRep) a (b :: TYPE r). --        (a -> b) -> a -> b--- Just :: forall (k :: Multiplicity) a. a # k -> Maybe a+-- Just :: forall (k :: Multiplicity) a. a % k -> Maybe a -- @ -- -- turns in to,@@ -1044,14 +1042,16 @@ -- @ ($) :: forall a (b :: *). (a -> b) -> a -> b @ -- @ Just :: forall a . a -> Maybe a @ ----- We do this to prevent RuntimeRep and Multiplicity variables from+-- We do this to prevent RuntimeRep, Levity and Multiplicity variables from -- incurring a significant syntactic overhead in otherwise simple -- type signatures (e.g. ($)). See Note [Defaulting RuntimeRep variables] -- and #11549 for further discussion.-defaultNonStandardVars :: Bool -> Bool -> IfaceType -> IfaceType-defaultNonStandardVars do_runtimereps do_multiplicities ty = go emptyFsEnv ty+defaultIfaceTyVarsOfKind :: Bool -- ^ default 'RuntimeRep'/'Levity' variables?+                         -> Bool -- ^ default 'Multiplicity' variables?+                         -> IfaceType -> IfaceType+defaultIfaceTyVarsOfKind def_rep def_mult ty = go emptyFsEnv ty   where-    go :: FastStringEnv IfaceType -- Set of enclosing forall-ed RuntimeRep/Multiplicity variables+    go :: FastStringEnv IfaceType -- Set of enclosing forall-ed RuntimeRep/Levity/Multiplicity variables        -> IfaceType        -> IfaceType     go subs (IfaceForAllTy (Bndr (IfaceTvBndr (var, var_kind)) argf) ty)@@ -1059,7 +1059,7 @@                                 -- or we get the mess in #13963      , Just substituted_ty <- check_substitution var_kind       = let subs' = extendFsEnv subs var substituted_ty-            -- Record that we should replace it with LiftedRep,+            -- Record that we should replace it with LiftedRep/Lifted/Many,             -- and recurse, discarding the forall         in go subs' ty @@ -1072,13 +1072,20 @@      go _ ty@(IfaceFreeTyVar tv)       -- See Note [Defaulting RuntimeRep variables], about free vars-      | do_runtimereps && GHC.Core.Type.isRuntimeRepTy (tyVarKind tv)+      | def_rep+      , GHC.Core.Type.isRuntimeRepTy (tyVarKind tv)       , isMetaTyVar tv       , isTyConableTyVar tv       = liftedRep_ty-      | do_multiplicities && GHC.Core.Type.isMultiplicityTy (tyVarKind tv)+      | def_rep+      , GHC.Core.Type.isLevityTy (tyVarKind tv)       , isMetaTyVar tv       , isTyConableTyVar tv+      = lifted_ty+      | def_mult+      , GHC.Core.Type.isMultiplicityTy (tyVarKind tv)+      , isMetaTyVar tv+      , isTyConableTyVar tv       = many_ty       | otherwise       = ty@@ -1114,8 +1121,15 @@      check_substitution :: IfaceType -> Maybe IfaceType     check_substitution (IfaceTyConApp tc _)-        | do_runtimereps, tc `ifaceTyConHasKey` runtimeRepTyConKey = Just liftedRep_ty-        | do_multiplicities, tc `ifaceTyConHasKey` multiplicityTyConKey = Just many_ty+        | def_rep+        , tc `ifaceTyConHasKey` runtimeRepTyConKey+        = Just liftedRep_ty+        | def_rep+        , tc `ifaceTyConHasKey` levityTyConKey+        = Just lifted_ty+        | def_mult+        , tc `ifaceTyConHasKey` multiplicityTyConKey+        = Just many_ty     check_substitution _ = Nothing  -- | The type ('BoxedRep 'Lifted), also known as LiftedRep.@@ -1127,6 +1141,14 @@     liftedRep = IfaceTyCon tc_name (mkIfaceTyConInfo NotPromoted IfaceNormalTyCon)       where tc_name = getName liftedRepTyCon +-- | The type 'Lifted :: Levity'.+lifted_ty :: IfaceType+lifted_ty =+    IfaceTyConApp (IfaceTyCon dc_name (mkIfaceTyConInfo IsPromoted IfaceNormalTyCon))+                  IA_Nil+  where dc_name = getName liftedDataConTyCon++-- | The type 'Many :: Multiplicity'. many_ty :: IfaceType many_ty =     IfaceTyConApp (IfaceTyCon dc_name (mkIfaceTyConInfo IsPromoted IfaceNormalTyCon))@@ -1138,10 +1160,10 @@   = sdocOption sdocPrintExplicitRuntimeReps $ \printExplicitRuntimeReps ->     sdocOption sdocLinearTypes $ \linearTypes ->     getPprStyle      $ \sty    ->-    let do_runtimerep = not printExplicitRuntimeReps-        do_multiplicity = not linearTypes+    let def_rep  = not printExplicitRuntimeReps+        def_mult = not linearTypes     in if userStyle sty-       then f (defaultNonStandardVars do_runtimerep do_multiplicity ty)+       then f (defaultIfaceTyVarsOfKind def_rep def_mult ty)        else f ty  instance Outputable IfaceAppArgs where@@ -1439,9 +1461,13 @@        , not debug        , arity == ifaceVisAppArgsLength tys        -> pprTuple ctxt_prec sort (ifaceTyConIsPromoted info) tys+           -- NB: pprTuple requires a saturated tuple.         | IfaceSumTyCon arity <- ifaceTyConSort info-       -> pprSum arity (ifaceTyConIsPromoted info) tys+       , not debug+       , arity == ifaceVisAppArgsLength tys+       -> pprSum (ifaceTyConIsPromoted info) tys+           -- NB: pprSum requires a saturated unboxed sum.         | tc `ifaceTyConHasKey` consDataConKey        , False <- print_kinds@@ -1478,7 +1504,7 @@  ppr_kind_type :: PprPrec -> SDoc ppr_kind_type ctxt_prec = sdocOption sdocStarIsType $ \case-   False -> text "Type"+   False -> pprPrefixOcc liftedTypeKindTyConName    True  -> maybeParen ctxt_prec starPrec $               unicodeSyntax (char '★') (char '*') @@ -1605,8 +1631,13 @@   | otherwise   = pprIfacePrefixApp ctxt_prec (parens (ppr tc)) (map (pp appPrec) tys) -pprSum :: Arity -> PromotionFlag -> IfaceAppArgs -> SDoc-pprSum _arity is_promoted args+-- | Pretty-print an unboxed sum type. The sum should be saturated:+-- as many visible arguments as the arity of the sum.+--+-- NB: this always strips off the invisible 'RuntimeRep' arguments,+-- even with `-fprint-explicit-runtime-reps` and `-fprint-explicit-kinds`.+pprSum :: PromotionFlag -> IfaceAppArgs -> SDoc+pprSum is_promoted args   =   -- drop the RuntimeRep vars.       -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon     let tys   = appArgsIfaceTypes args@@ -1614,6 +1645,12 @@     in pprPromotionQuoteI is_promoted        <> sumParens (pprWithBars (ppr_ty topPrec) args') +-- | Pretty-print a tuple type (boxed tuple, constraint tuple, unboxed tuple).+-- The tuple should be saturated: as many visible arguments as the arity of+-- the tuple.+--+-- NB: this always strips off the invisible 'RuntimeRep' arguments,+-- even with `-fprint-explicit-runtime-reps` and `-fprint-explicit-kinds`. pprTuple :: PprPrec -> TupleSort -> PromotionFlag -> IfaceAppArgs -> SDoc pprTuple ctxt_prec sort promoted args =   case promoted of@@ -1700,7 +1737,7 @@       = let (tvs, co'') = split_co co' in ((name,kind_co):tvs,co'')     split_co co' = ([], co') --- Why these three? See Note [TcTyVars in IfaceType]+-- Why these three? See Note [Free tyvars in IfaceType] ppr_co _ (IfaceFreeCoVar covar) = ppr covar ppr_co _ (IfaceCoVarCo covar)   = ppr covar ppr_co _ (IfaceHoleCo covar)    = braces (ppr covar)
GHC/Iface/Type.hs-boot view
@@ -5,7 +5,7 @@ where  -- Empty import to influence the compilation ordering.--- See note [Depend on GHC.Integer] in GHC.Base+-- See Note [Depend on GHC.Num.Integer] in GHC.Base import GHC.Base ()  data IfaceAppArgs
GHC/IfaceToCore.hs view
@@ -6,8 +6,9 @@ Type checking of type signatures in interface files -} -{-# LANGUAGE CPP #-}+ {-# LANGUAGE NondecreasingIndentation #-}+{-# LANGUAGE FlexibleContexts #-}  {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -24,8 +25,6 @@         tcIfaceOneShot  ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Driver.Env@@ -39,7 +38,9 @@ import GHC.Iface.Env  import GHC.StgToCmm.Types+import GHC.Runtime.Heap.Layout +import GHC.Tc.Errors.Types import GHC.Tc.TyCl.Build import GHC.Tc.Utils.Monad import GHC.Tc.Utils.TcType@@ -65,6 +66,7 @@ import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr ) import GHC.Core.Ppr +import GHC.Unit.Env import GHC.Unit.External import GHC.Unit.Module import GHC.Unit.Module.ModDetails@@ -74,6 +76,8 @@ import GHC.Utils.Outputable import GHC.Utils.Misc import GHC.Utils.Panic+import GHC.Utils.Panic.Plain+import GHC.Utils.Constants (debugIsOn) import GHC.Utils.Logger  import GHC.Data.Bag@@ -102,12 +106,14 @@ import GHC.Types.Id.Info import GHC.Types.Tickish import GHC.Types.TyThing+import GHC.Types.Error  import GHC.Fingerprint import qualified GHC.Data.BooleanFormula as BF  import Control.Monad import GHC.Parser.Annotation+import GHC.Driver.Env.KnotVars  {- This module takes@@ -156,7 +162,7 @@     internal TyCons to MATCH the ones that we just constructed     during typechecking: the knot is thus tied through if_rec_types. -    2) retypecheckLoop in GHC.Driver.Make: We are retypechecking a+    2) rehydrate in GHC.Driver.Make: We are rehydrating a     mutually recursive cluster of hi files, in order to ensure     that all of the references refer to each other correctly.     In this case, the knot is tied through the HPT passed in,@@ -215,7 +221,7 @@                          -- an example where this would cause non-termination.                          text "Type envt:" <+> ppr (map fst names_w_things)])         ; return $ ModDetails { md_types     = type_env-                              , md_insts     = insts+                              , md_insts     = mkInstEnv insts                               , md_fam_insts = fam_insts                               , md_rules     = rules                               , md_anns      = anns@@ -234,7 +240,7 @@  -- | Returns true if an 'IfaceDecl' is for @data T@ (an abstract data type) isAbstractIfaceDecl :: IfaceDecl -> Bool-isAbstractIfaceDecl IfaceData{ ifCons = IfAbstractTyCon } = True+isAbstractIfaceDecl IfaceData{ ifCons = IfAbstractTyCon {} } = True isAbstractIfaceDecl IfaceClass{ ifBody = IfAbstractClass } = True isAbstractIfaceDecl IfaceFamily{ ifFamFlav = IfaceAbstractClosedSynFamilyTyCon } = True isAbstractIfaceDecl _ = False@@ -254,7 +260,7 @@     | isAbstractIfaceDecl d2 = d1 `withRolesFrom` d2     | IfaceClass{ ifBody = IfConcreteClass { ifSigs = ops1, ifMinDef = bf1 } } <- d1     , IfaceClass{ ifBody = IfConcreteClass { ifSigs = ops2, ifMinDef = bf2 } } <- d2-    = let ops = nameEnvElts $+    = let ops = nonDetNameEnvElts $                   plusNameEnv_C mergeIfaceClassOp                     (mkNameEnv [ (n, op) | op@(IfaceClassOp n _ _) <- ops1 ])                     (mkNameEnv [ (n, op) | op@(IfaceClassOp n _ _) <- ops2 ])@@ -379,8 +385,8 @@ -- type synonym.  Perhaps this should be relaxed, where a type synonym -- in a signature is considered implemented by a data type declaration -- which matches the reference of the type synonym.-typecheckIfacesForMerging :: Module -> [ModIface] -> IORef TypeEnv -> IfM lcl (TypeEnv, [ModDetails])-typecheckIfacesForMerging mod ifaces tc_env_var =+typecheckIfacesForMerging :: Module -> [ModIface] -> (KnotVars (IORef TypeEnv)) -> IfM lcl (TypeEnv, [ModDetails])+typecheckIfacesForMerging mod ifaces tc_env_vars =   -- cannot be boot (False)   initIfaceLcl mod (text "typecheckIfacesForMerging") NotBoot $ do     ignore_prags <- goptM Opt_IgnoreInterfacePragmas@@ -400,9 +406,11 @@                         ::  OccEnv IfaceDecl     -- TODO: change tcIfaceDecls to accept w/o Fingerprint     names_w_things <- tcIfaceDecls ignore_prags (map (\x -> (fingerprint0, x))-                                                  (occEnvElts decl_env))+                                                  (nonDetOccEnvElts decl_env))     let global_type_env = mkNameEnv names_w_things-    writeMutVar tc_env_var global_type_env+    case lookupKnotVars tc_env_vars mod of+      Just tc_env_var -> writeMutVar tc_env_var global_type_env+      Nothing -> return ()      -- OK, now typecheck each ModIface using this environment     details <- forM ifaces $ \iface -> do@@ -421,7 +429,7 @@         exports   <- ifaceExportNames (mi_exports iface)         complete_matches <- tcIfaceCompleteMatches (mi_complete_matches iface)         return $ ModDetails { md_types     = type_env-                            , md_insts     = insts+                            , md_insts     = mkInstEnv insts                             , md_fam_insts = fam_insts                             , md_rules     = rules                             , md_anns      = anns@@ -460,7 +468,7 @@     exports   <- ifaceExportNames (mi_exports iface)     complete_matches <- tcIfaceCompleteMatches (mi_complete_matches iface)     return $ ModDetails { md_types     = type_env-                        , md_insts     = insts+                        , md_insts     = mkInstEnv insts                         , md_fam_insts = fam_insts                         , md_rules     = rules                         , md_anns      = anns@@ -532,8 +540,8 @@                 -- (it's been replaced by the mother module) so we can't check it.                 -- And that's fine, because if M's ModInfo is in the HPT, then                 -- it's been compiled once, and we don't need to check the boot iface-          then do { hpt <- getHpt-                 ; case lookupHpt hpt (moduleName mod) of+          then do { (_, hug) <- getEpsAndHug+                 ; case lookupHugByModule mod hug  of                       Just info | mi_boot (hm_iface info) == IsBoot                                 -> mkSelfBootInfo (hm_iface info) (hm_details info)                       _ -> return NoSelfBoot }@@ -543,7 +551,8 @@         -- Re #9245, we always check if there is an hi-boot interface         -- to check consistency against, rather than just when we notice         -- that an hi-boot is necessary due to a circular import.-        { read_result <- findAndReadIface+        { hsc_env <- getTopEnv+        ; read_result <- liftIO $ findAndReadIface hsc_env                                 need (fst (getModuleInstantiation mod)) mod                                 IsBoot  -- Hi-boot file @@ -560,14 +569,14 @@         -- a SOURCE import) or that our hi-boot file has mysteriously         -- disappeared.     do  { eps <- getEps-        ; case lookupUFM (eps_is_boot eps) (moduleName mod) of+        ; case lookupInstalledModuleEnv (eps_is_boot eps) (toUnitId <$> mod) of             -- The typical case             Nothing -> return NoSelfBoot             -- error cases             Just (GWIB { gwib_isBoot = is_boot }) -> case is_boot of-              IsBoot -> failWithTc (elaborate err)+              IsBoot -> failWithTc (TcRnUnknownMessage $ mkPlainError noHints (elaborate err))               -- The hi-boot file has mysteriously disappeared.-              NotBoot -> failWithTc moduleLoop+              NotBoot -> failWithTc (TcRnUnknownMessage $ mkPlainError noHints moduleLoop)               -- Someone below us imported us!               -- This is a loop with no hi-boot in the way     }}}}@@ -594,7 +603,7 @@        return $ SelfBoot { sb_mds = mds                          , sb_tcs = mkNameSet tcs }   where-    -- | Retuerns @True@ if, when you call 'tcIfaceDecl' on+    -- Retuerns @True@ if, when you call 'tcIfaceDecl' on     -- this 'IfaceDecl', an ATyCon would be returned.     -- NB: This code assumes that a TyCon cannot be implicit.     isIfaceTyCon IfaceId{}      = False@@ -1021,11 +1030,17 @@ tcIfaceDataCons :: Name -> TyCon -> [TyConBinder] -> IfaceConDecls -> IfL AlgTyConRhs tcIfaceDataCons tycon_name tycon tc_tybinders if_cons   = case if_cons of-        IfAbstractTyCon  -> return AbstractTyCon-        IfDataTyCon cons -> do  { data_cons  <- mapM tc_con_decl cons-                                ; return (mkDataTyConRhs data_cons) }-        IfNewTyCon  con  -> do  { data_con  <- tc_con_decl con-                                ; mkNewTyConRhs tycon_name tycon data_con }+        IfAbstractTyCon+          -> return AbstractTyCon+        IfDataTyCon cons+          -> do  { data_cons  <- mapM tc_con_decl cons+                 ; return $+                     mkLevPolyDataTyConRhs+                       (isFixedRuntimeRepKind $ tyConResKind tycon)+                       data_cons }+        IfNewTyCon con+          -> do  { data_con  <- tc_con_decl con+                 ; mkNewTyConRhs tycon_name tycon data_con }   where     univ_tvs :: [TyVar]     univ_tvs = binderVars tc_tybinders@@ -1088,15 +1103,15 @@          ; prom_rep_name <- newTyConRepName dc_name +        ; let bang_opts = FixedBangOpts stricts+            -- Pass the HsImplBangs (i.e. final decisions) to buildDataCon;+            -- it'll use these to guide the construction of a worker.+            -- See Note [Bangs on imported data constructors] in GHC.Types.Id.Make+         ; con <- buildDataCon (pprPanic "tcIfaceDataCons: FamInstEnvs" (ppr dc_name))+                       bang_opts                        dc_name is_infix prom_rep_name                        (map src_strict if_src_stricts)-                       (Just stricts)-                       -- Pass the HsImplBangs (i.e. final-                       -- decisions) to buildDataCon; it'll use-                       -- these to guide the construction of a-                       -- worker.-                       -- See Note [Bangs on imported data constructors] in GHC.Types.Id.Make                        lbl_names                        univ_tvs ex_tvs user_tv_bndrs                        eq_spec theta@@ -1150,8 +1165,8 @@ -}  tcRoughTyCon :: Maybe IfaceTyCon -> RoughMatchTc-tcRoughTyCon (Just tc) = KnownTc (ifaceTyConName tc)-tcRoughTyCon Nothing   = OtherTc+tcRoughTyCon (Just tc) = RM_KnownTc (ifaceTyConName tc)+tcRoughTyCon Nothing   = RM_WildCard  tcIfaceInst :: IfaceClsInst -> IfL ClsInst tcIfaceInst (IfaceClsInst { ifDFun = dfun_name, ifOFlag = oflag@@ -1213,7 +1228,7 @@                           Nothing   -> return ()                           Just errs -> do                             logger <- getLogger-                            liftIO $ displayLintResults logger dflags False doc+                            liftIO $ displayLintResults logger False doc                                                (pprCoreExpr rhs')                                                (emptyBag, errs) }                    ; return (bndrs', args', rhs') }@@ -1294,11 +1309,10 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We need to be lazy when type checking the interface, since these functions are called when the interface itself is being loaded, which means it is not in the-PIT yet. If we are not lazy enough, in certain cases we might recursively try to-load the same interface in an infinite loop.--For this reason, the forkM should be around as much of the computation as-possible.+PIT yet. In particular, the `tcIfaceTCon` must be inside the forkM, otherwise+we'll try to look it up the TyCon, find it's not there, and so initiate the+process (again) of loading the (very same) interface file. Result: infinite+loop. See #19744. -}  {-@@ -1458,8 +1472,7 @@ tcIfaceExpr (IfaceFCall cc ty) = do     ty' <- tcIfaceType ty     u <- newUnique-    dflags <- getDynFlags-    return (Var (mkFCallId dflags u cc ty'))+    return (Var (mkFCallId u cc ty'))  tcIfaceExpr (IfaceTuple sort args)   = do { args' <- mapM tcIfaceExpr args@@ -1564,12 +1577,12 @@            -> IfaceAlt            -> IfL CoreAlt tcIfaceAlt _ _ _ (IfaceAlt IfaceDefault names rhs)-  = ASSERT( null names ) do+  = assert (null names) $ do     rhs' <- tcIfaceExpr rhs     return (Alt DEFAULT [] rhs')  tcIfaceAlt _ _ _ (IfaceAlt (IfaceLitAlt lit) names rhs)-  = ASSERT( null names ) do+  = assert (null names) $ do     lit' <- tcIfaceLit lit     rhs' <- tcIfaceExpr rhs     return (Alt (LitAlt lit') [] rhs')@@ -1606,6 +1619,7 @@  tcIdDetails :: Type -> IfaceIdDetails -> IfL IdDetails tcIdDetails _  IfVanillaId = return VanillaId+tcIdDetails _  (IfWorkerLikeId dmds) = return $ WorkerLikeId dmds tcIdDetails ty IfDFunId   = return (DFunId (isNewTyCon (classTyCon cls)))   where@@ -1645,14 +1659,17 @@     tcPrag :: IdInfo -> IfaceInfoItem -> IfL IdInfo     tcPrag info HsNoCafRefs        = return (info `setCafInfo`   NoCafRefs)     tcPrag info (HsArity arity)    = return (info `setArityInfo` arity)-    tcPrag info (HsStrictness str) = return (info `setStrictnessInfo` str)-    tcPrag info (HsCpr cpr)        = return (info `setCprInfo` cpr)+    tcPrag info (HsDmdSig str)     = return (info `setDmdSigInfo` str)+    tcPrag info (HsCprSig cpr)     = return (info `setCprSigInfo` cpr)     tcPrag info (HsInline prag)    = return (info `setInlinePragInfo` prag)-    tcPrag info HsLevity           = return (info `setNeverLevPoly` ty)+    tcPrag info HsLevity           = return (info `setNeverRepPoly` ty)     tcPrag info (HsLFInfo lf_info) = do       lf_info <- tcLFInfo lf_info       return (info `setLFInfo` lf_info) +    tcPrag info (HsTagSig sig) = do+      return (info `setTagSig` sig)+         -- The next two are lazy, so they don't transitively suck stuff in     tcPrag info (HsUnfold lb if_unf)       = do { unf <- tcUnfolding toplvl name ty info if_unf@@ -1697,53 +1714,67 @@       return (LFUnknown fun_flag)  tcUnfolding :: TopLevelFlag -> Name -> Type -> IdInfo -> IfaceUnfolding -> IfL Unfolding+-- See Note [Lazily checking Unfoldings] tcUnfolding toplvl name _ info (IfCoreUnfold stable if_expr)   = do  { uf_opts <- unfoldingOpts <$> getDynFlags-        ; mb_expr <- tcPragExpr False toplvl name if_expr+        ; expr <- tcUnfoldingRhs False toplvl name if_expr         ; let unf_src | stable    = InlineStable                       | otherwise = InlineRhs-        ; return $ case mb_expr of-            Nothing -> NoUnfolding-            Just expr -> mkFinalUnfolding uf_opts unf_src strict_sig expr-        }+        ; return $ mkFinalUnfolding uf_opts unf_src strict_sig expr }   where     -- Strictness should occur before unfolding!-    strict_sig = strictnessInfo info+    strict_sig = dmdSigInfo info  tcUnfolding toplvl name _ _ (IfCompulsory if_expr)-  = do  { mb_expr <- tcPragExpr True toplvl name if_expr-        ; return (case mb_expr of-                    Nothing   -> NoUnfolding-                    Just expr -> mkCompulsoryUnfolding' expr) }+  = do  { expr <- tcUnfoldingRhs True toplvl name if_expr+        ; return $ mkCompulsoryUnfolding' expr }  tcUnfolding toplvl name _ _ (IfInlineRule arity unsat_ok boring_ok if_expr)-  = do  { mb_expr <- tcPragExpr False toplvl name if_expr-        ; return (case mb_expr of-                    Nothing   -> NoUnfolding-                    Just expr -> mkCoreUnfolding InlineStable True expr guidance )}+  = do  { expr <- tcUnfoldingRhs False toplvl name if_expr+        ; return $ mkCoreUnfolding InlineStable True expr guidance }   where     guidance = UnfWhen { ug_arity = arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok }  tcUnfolding _toplvl name dfun_ty _ (IfDFunUnfold bs ops)   = bindIfaceBndrs bs $ \ bs' ->-    do { mb_ops1 <- forkM_maybe doc $ mapM tcIfaceExpr ops-       ; return (case mb_ops1 of-                    Nothing   -> noUnfolding-                    Just ops1 -> mkDFunUnfolding bs' (classDataCon cls) ops1) }+    do { ops1 <- forkM doc $ mapM tcIfaceExpr ops+       ; return $ mkDFunUnfolding bs' (classDataCon cls) ops1 }   where     doc = text "Class ops for dfun" <+> ppr name     (_, _, cls, _) = tcSplitDFunTy dfun_ty -{--For unfoldings we try to do the job lazily, so that we never type check+{- Note [Lazily checking Unfoldings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For unfoldings, we try to do the job lazily, so that we never typecheck an unfolding that isn't going to be looked at.++The main idea is that if M.hi has a declaration+   f :: Int -> Int+   f = \x. ...A.g...   -- The unfolding for f++then we don't even want to /read/ A.hi unless f's unfolding is actually used; say,+if f is inlined. But we need to be careful. Even if we don't inline f, we might ask+hasNoBinding of it (Core Lint does this in GHC.Core.Lint.checkCanEtaExpand),+and hasNoBinding looks to see if f has a compulsory unfolding.+So the root Unfolding constructor must be visible: we want to be able to read the 'uf_src'+field which says whether it is a compulsory unfolding, without forcing the unfolding RHS+which is stored in 'uf_tmpl'. This matters for efficiency, but not only: if g's unfolding+mentions f, we must not look at the unfolding RHS for f, as this is precisely what we are+in the middle of checking (so looking at it would cause a loop).++Conclusion: `tcUnfolding` must return an `Unfolding` whose `uf_src` field is readable without+forcing the `uf_tmpl` field. In particular, all the functions used at the end of+`tcUnfolding` (such as `mkFinalUnfolding`, `mkCompulsoryUnfolding'`, `mkCoreUnfolding`) must be+lazy in `expr`.++Ticket #21139 -} -tcPragExpr :: Bool  -- Is this unfolding compulsory?-                    -- See Note [Checking for levity polymorphism] in GHC.Core.Lint-           -> TopLevelFlag -> Name -> IfaceExpr -> IfL (Maybe CoreExpr)-tcPragExpr is_compulsory toplvl name expr-  = forkM_maybe doc $ do+tcUnfoldingRhs :: Bool -- ^ Is this unfolding compulsory?+                       -- See Note [Checking for representation polymorphism] in GHC.Core.Lint+               -> TopLevelFlag -> Name -> IfaceExpr -> IfL CoreExpr+tcUnfoldingRhs is_compulsory toplvl name expr+  = forkM doc $ do     core_expr' <- tcIfaceExpr expr      -- Check for type consistency in the unfolding@@ -1756,7 +1787,7 @@         case lintUnfolding is_compulsory dflags noSrcLoc in_scope core_expr' of           Nothing   -> return ()           Just errs -> liftIO $-            displayLintResults logger dflags False doc+            displayLintResults logger False doc                                (pprCoreExpr core_expr') (emptyBag, errs)     return core_expr'   where@@ -1766,14 +1797,11 @@     get_in_scope :: IfL VarSet -- Totally disgusting; but just for linting     get_in_scope         = do { (gbl_env, lcl_env) <- getEnvs-             ; rec_ids <- case if_rec_types gbl_env of-                            Nothing -> return []-                            Just (_, get_env) -> do-                               { type_env <- setLclEnv () get_env-                               ; return (typeEnvIds type_env) }+             ; let type_envs = knotVarElems (if_rec_types gbl_env)+             ; top_level_vars <- concat <$> mapM (fmap typeEnvIds . setLclEnv ())  type_envs              ; return (bindingsVars (if_tv_env lcl_env) `unionVarSet`                        bindingsVars (if_id_env lcl_env) `unionVarSet`-                       mkVarSet rec_ids) }+                       mkVarSet top_level_vars) }      bindingsVars :: FastStringEnv Var -> VarSet     bindingsVars ufm = mkVarSet $ nonDetEltsUFM ufm@@ -1803,10 +1831,10 @@    | otherwise   = do  { env <- getGblEnv-        ; case if_rec_types env of {    -- Note [Tying the knot]-            Just (mod, get_type_env)-                | nameIsLocalOrFrom mod name-                -> do           -- It's defined in the module being compiled+        ; cur_mod <- if_mod <$> getLclEnv+        ; case lookupKnotVars (if_rec_types env) (fromMaybe cur_mod (nameModule_maybe name))  of     -- Note [Tying the knot]+            Just get_type_env+                -> do           -- It's defined in a module in the hs-boot loop                 { type_env <- setLclEnv () get_type_env         -- yuk                 ; case lookupNameEnv type_env name of                     Just thing -> return thing@@ -1814,7 +1842,7 @@                     Nothing   -> via_external                 } -          ; _ -> via_external }}+            _ -> via_external }   where     via_external =  do         { hsc_env <- getTopEnv@@ -1843,6 +1871,7 @@ --      * Note [DFun knot-tying] --      * Note [hsc_type_env_var hack] --      * Note [Knot-tying fallback on boot]+--      * Note [Hydrating Modules] -- -- There is also a wiki page on the subject, see: --@@ -1899,13 +1928,15 @@   tcIfaceCoAxiomRule :: IfLclName -> IfL CoAxiomRule--- Unlike CoAxioms, which arise form user 'type instance' declarations,--- there are a fixed set of CoAxiomRules,--- currently enumerated in typeNatCoAxiomRules+-- Unlike CoAxioms, which arise from user 'type instance' declarations,+-- there are a fixed set of CoAxiomRules:+--   - axioms for type-level literals (Nat and Symbol),+--     enumerated in typeNatCoAxiomRules tcIfaceCoAxiomRule n-  = case lookupUFM typeNatCoAxiomRules n of-        Just ax -> return ax-        _  -> pprPanic "tcIfaceCoAxiomRule" (ppr n)+  | Just ax <- lookupUFM typeNatCoAxiomRules n+  = return ax+  | otherwise+  = pprPanic "tcIfaceCoAxiomRule" (ppr n)  tcIfaceDataCon :: Name -> IfL DataCon tcIfaceDataCon name = do { thing <- tcIfaceGlobal name
GHC/Linker/Dynamic.hs view
@@ -8,8 +8,6 @@    ) where -#include "HsVersions.h"- import GHC.Prelude import GHC.Platform import GHC.Platform.Ways@@ -25,7 +23,6 @@ import GHC.Utils.Logger import GHC.Utils.TmpFs -import qualified Data.Set as Set import System.FilePath  linkDynLib :: Logger -> TmpFs -> DynFlags -> UnitEnv -> [String] -> [UnitId] -> IO ()@@ -47,7 +44,7 @@                = dflags0          verbFlags = getVerbFlags dflags-        o_file = outputFile dflags+        o_file = outputFile_ dflags      pkgs_with_rts <- mayThrowUnitErr (preloadUnitsInfo' unit_env dep_packages) @@ -57,7 +54,7 @@          | osElfTarget os || osMachOTarget os          , dynLibLoader dflags == SystemDependent          , -- Only if we want dynamic libraries-           WayDyn `Set.member` ways dflags+           ways dflags `hasWay` WayDyn            -- Only use RPath if we explicitly asked for it          , useXLinkerRPath dflags os             = ["-L" ++ l, "-Xlinker", "-rpath", "-Xlinker", l]@@ -200,7 +197,8 @@             -------------------------------------------------------------------              let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }-                unregisterised = platformUnregisterised (targetPlatform dflags)+                platform  = targetPlatform dflags+                unregisterised = platformUnregisterised platform             let bsymbolicFlag = -- we need symbolic linking to resolve                                 -- non-PIC intra-package-relocations for                                 -- performance (where symbolic linking works)@@ -209,7 +207,7 @@              runLink logger tmpfs dflags (                     map Option verbFlags-                 ++ libmLinkOpts+                 ++ libmLinkOpts platform                  ++ [ Option "-o"                     , FileOption "" output_fn                     ]@@ -227,13 +225,10 @@  -- | Some platforms require that we explicitly link against @libm@ if any -- math-y things are used (which we assume to include all programs). See #14022.-libmLinkOpts :: [Option]-libmLinkOpts =-#if defined(HAVE_LIBM)-  [Option "-lm"]-#else-  []-#endif+libmLinkOpts :: Platform -> [Option]+libmLinkOpts platform+  | platformHasLibm platform = [Option "-lm"]+  | otherwise                = []  {- Note [-Bsymbolic assumptions by GHC]
GHC/Linker/ExtraObj.hs view
@@ -25,7 +25,6 @@  import GHC.Unit import GHC.Unit.Env-import GHC.Unit.State  import GHC.Utils.Asm import GHC.Utils.Error@@ -50,8 +49,8 @@  mkExtraObj :: Logger -> TmpFs -> DynFlags -> UnitState -> Suffix -> String -> IO FilePath mkExtraObj logger tmpfs dflags unit_state extn xs- = do cFile <- newTempName logger tmpfs dflags TFL_CurrentModule extn-      oFile <- newTempName logger tmpfs dflags TFL_GhcSession "o"+ = do cFile <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule extn+      oFile <- newTempName logger tmpfs (tmpDir dflags) TFL_GhcSession "o"       writeFile cFile xs       ccInfo <- liftIO $ getCompilerInfo logger dflags       runCc Nothing logger tmpfs dflags@@ -90,7 +89,7 @@ mkExtraObjToLinkIntoBinary :: Logger -> TmpFs -> DynFlags -> UnitState -> IO (Maybe FilePath) mkExtraObjToLinkIntoBinary logger tmpfs dflags unit_state = do   when (gopt Opt_NoHsMain dflags && haveRtsOptsFlags dflags) $-     logInfo logger dflags $ withPprStyle defaultUserStyle+     logInfo logger $ withPprStyle defaultUserStyle          (text "Warning: -rtsopts and -with-rtsopts have no effect with -no-hs-main." $$           text "    Call hs_init_ghc() from your main() function to set these options.") @@ -238,11 +237,11 @@  | otherwise  = do    link_info <- getLinkInfo dflags unit_env pkg_deps-   debugTraceMsg logger dflags 3 $ text ("Link info: " ++ link_info)-   m_exe_link_info <- readElfNoteAsString logger dflags exe_file+   debugTraceMsg logger 3 $ text ("Link info: " ++ link_info)+   m_exe_link_info <- readElfNoteAsString logger exe_file                           ghcLinkInfoSectionName ghcLinkInfoNoteName    let sameLinkInfo = (Just link_info == m_exe_link_info)-   debugTraceMsg logger dflags 3 $ case m_exe_link_info of+   debugTraceMsg logger 3 $ case m_exe_link_info of      Nothing -> text "Exe link info: Not found"      Just s        | sameLinkInfo -> text ("Exe link info is the same")
GHC/Linker/Loader.hs view
@@ -1,5 +1,7 @@-{-# LANGUAGE CPP, TupleSections, RecordWildCards #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE TupleSections, RecordWildCards #-} {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE LambdaCase #-}  -- --  (c) The University of Glasgow 2002-2006@@ -14,6 +16,7 @@    , initLoaderState    , uninitializedLoader    , showLoaderState+   , getLoaderState    -- * Load & Unload    , loadExpr    , loadDecls@@ -26,13 +29,9 @@    , withExtendedLoadedEnv    , extendLoadedEnv    , deleteFromLoadedEnv-   -- * Misc-   , extendLoadedPkgs    ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Settings@@ -44,13 +43,15 @@ import GHC.Driver.Env import GHC.Driver.Session import GHC.Driver.Ppr+import GHC.Driver.Config+import GHC.Driver.Config.Diagnostic+import GHC.Driver.Config.Finder  import GHC.Tc.Utils.Monad  import GHC.Runtime.Interpreter import GHCi.RemoteTypes -import GHC.Iface.Load  import GHC.ByteCode.Linker import GHC.ByteCode.Asm@@ -63,10 +64,11 @@ import GHC.Types.Name.Env import GHC.Types.SrcLoc import GHC.Types.Unique.DSet+import GHC.Types.Unique.DFM  import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Misc+import GHC.Utils.Panic.Plain import GHC.Utils.Error import GHC.Utils.Logger import GHC.Utils.TmpFs@@ -76,14 +78,12 @@ import GHC.Unit.Module import GHC.Unit.Module.ModIface import GHC.Unit.Module.Deps-import GHC.Unit.Home import GHC.Unit.Home.ModInfo import GHC.Unit.State as Packages  import qualified GHC.Data.ShortText as ST import qualified GHC.Data.Maybe as Maybes import GHC.Data.FastString-import GHC.Data.List.SetOps  import GHC.Linker.MacOS import GHC.Linker.Dynamic@@ -93,8 +93,8 @@ import Control.Monad  import qualified Data.Set as Set+import qualified Data.Map as M import Data.Char (isSpace)-import Data.Function ((&)) import Data.IORef import Data.List (intercalate, isPrefixOf, isSuffixOf, nub, partition) import Data.Maybe@@ -112,6 +112,14 @@  import GHC.Utils.Exception +import GHC.Unit.Module.Graph+import GHC.Types.SourceFile+import GHC.Utils.Misc+import GHC.Iface.Load+import GHC.Unit.Home+import Data.Either+import Control.Applicative+ uninitialised :: a uninitialised = panic "Loader not initialised" @@ -126,13 +134,17 @@     (fmapFst pure . f . fromMaybe uninitialised)   where fmapFst f = fmap (\(x, y) -> (f x, y)) +getLoaderState :: Interp -> IO (Maybe LoaderState)+getLoaderState interp = readMVar (loader_state (interpLoader interp))++ emptyLoaderState :: LoaderState emptyLoaderState = LoaderState    { closure_env = emptyNameEnv    , itbl_env    = emptyNameEnv    , pkgs_loaded = init_pkgs-   , bcos_loaded = []-   , objs_loaded = []+   , bcos_loaded = emptyModuleEnv+   , objs_loaded = emptyModuleEnv    , temp_sos = []    }   -- Packages that don't need loading, because the compiler@@ -140,12 +152,7 @@   --   -- The linker's symbol table is populated with RTS symbols using an   -- explicit list.  See rts/Linker.c for details.-  where init_pkgs = [rtsUnitId]--extendLoadedPkgs :: Interp -> [UnitId] -> IO ()-extendLoadedPkgs interp pkgs =-  modifyLoaderState_ interp $ \s ->-      return s{ pkgs_loaded = pkgs ++ pkgs_loaded s }+  where init_pkgs = unitUDFM rtsUnitId (LoadedPkgInfo rtsUnitId [] [] emptyUniqDSet)  extendLoadedEnv :: Interp -> [(Name,ForeignHValue)] -> IO () extendLoadedEnv interp new_bindings =@@ -164,39 +171,39 @@ -- | Load the module containing the given Name and get its associated 'HValue'. -- -- Throws a 'ProgramError' if loading fails or the name cannot be found.-loadName :: Interp -> HscEnv -> Name -> IO ForeignHValue+loadName :: Interp -> HscEnv -> Name -> IO (ForeignHValue, [Linkable], PkgsLoaded) loadName interp hsc_env name = do   initLoaderState interp hsc_env   modifyLoaderState interp $ \pls0 -> do-    pls <- if not (isExternalName name)-       then return pls0+    (pls, links, pkgs) <- if not (isExternalName name)+       then return (pls0, [], emptyUDFM)        else do-         (pls', ok) <- loadDependencies interp hsc_env pls0 noSrcSpan-                          [nameModule name]+         (pls', ok, links, pkgs) <- loadDependencies interp hsc_env pls0 noSrcSpan+                                      [nameModule name]          if failed ok            then throwGhcExceptionIO (ProgramError "")-           else return pls'+           else return (pls', links, pkgs)      case lookupNameEnv (closure_env pls) name of-      Just (_,aa) -> return (pls,aa)-      Nothing     -> ASSERT2(isExternalName name, ppr name)+      Just (_,aa) -> return (pls,(aa, links, pkgs))+      Nothing     -> assertPpr (isExternalName name) (ppr name) $                      do let sym_to_find = nameToCLabel name "closure"                         m <- lookupClosure interp (unpackFS sym_to_find)                         r <- case m of                           Just hvref -> mkFinalizedHValue interp hvref                           Nothing -> linkFail "GHC.Linker.Loader.loadName"                                        (unpackFS sym_to_find)-                        return (pls,r)+                        return (pls,(r, links, pkgs))  loadDependencies   :: Interp   -> HscEnv   -> LoaderState-  -> SrcSpan -> [Module]-  -> IO (LoaderState, SuccessFlag)+  -> SrcSpan+  -> [Module]+  -> IO (LoaderState, SuccessFlag, [Linkable], PkgsLoaded) -- ^ returns the set of linkables required loadDependencies interp hsc_env pls span needed_mods = do --   initLoaderState (hsc_dflags hsc_env) dl-   let hpt = hsc_HPT hsc_env    let dflags = hsc_dflags hsc_env    -- The interpreter and dynamic linker can only handle object code built    -- the "normal" way, i.e. no non-std ways like profiling or ticky-ticky.@@ -205,12 +212,20 @@    maybe_normal_osuf <- checkNonStdWay dflags interp span     -- Find what packages and linkables are required-   (lnks, pkgs) <- getLinkDeps hsc_env hpt pls-                               maybe_normal_osuf span needed_mods+   (lnks, all_lnks, pkgs, this_pkgs_needed)+      <- getLinkDeps hsc_env pls+           maybe_normal_osuf span needed_mods     -- Link the packages and modules required    pls1 <- loadPackages' interp hsc_env pkgs pls-   loadModules interp hsc_env pls1 lnks+   (pls2, succ) <- loadModuleLinkables interp hsc_env pls1 lnks+   let this_pkgs_loaded = udfmRestrictKeys all_pkgs_loaded $ getUniqDSet trans_pkgs_needed+       all_pkgs_loaded = pkgs_loaded pls2+       trans_pkgs_needed = unionManyUniqDSets (this_pkgs_needed : [ loaded_pkg_trans_deps pkg+                                                                  | pkg_id <- uniqDSetToList this_pkgs_needed+                                                                  , Just pkg <- [lookupUDFM all_pkgs_loaded pkg_id]+                                                                  ])+   return (pls2, succ, all_lnks, this_pkgs_loaded)   -- | Temporarily extend the loaded env.@@ -243,9 +258,9 @@   ls <- readMVar (loader_state (interpLoader interp))   let docs = case ls of         Nothing  -> [ text "Loader not initialised"]-        Just pls -> [ text "Pkgs:" <+> ppr (pkgs_loaded pls)-                    , text "Objs:" <+> ppr (objs_loaded pls)-                    , text "BCOs:" <+> ppr (bcos_loaded pls)+        Just pls -> [ text "Pkgs:" <+> ppr (map loaded_pkg_uid $ eltsUDFM $ pkgs_loaded pls)+                    , text "Objs:" <+> ppr (moduleEnvElts $ objs_loaded pls)+                    , text "BCOs:" <+> ppr (moduleEnvElts $ bcos_loaded pls)                     ]    return $ withPprStyle defaultDumpStyle@@ -291,8 +306,9 @@   -- (a) initialise the C dynamic linker   initObjLinker interp +   -- (b) Load packages from the command-line (Note [preload packages])-  pls <- loadPackages' interp hsc_env (preloadUnits (hsc_units hsc_env)) pls0+  pls <- unitEnv_foldWithKey (\k u env -> k >>= \pls' -> loadPackages' interp (hscSetActiveUnitId u hsc_env) (preloadUnits (homeUnitEnv_units env)) pls') (return pls0) (hsc_HUG hsc_env)    -- steps (c), (d) and (e)   loadCmdLineLibs' interp hsc_env pls@@ -304,13 +320,33 @@   modifyLoaderState_ interp $ \pls ->     loadCmdLineLibs' interp hsc_env pls -loadCmdLineLibs'++loadCmdLineLibs' :: Interp -> HscEnv -> LoaderState -> IO LoaderState+loadCmdLineLibs' interp hsc_env pls = snd <$>+    foldM+      (\(done', pls') cur_uid ->  load done' cur_uid pls')+      (Set.empty, pls)+      (hsc_all_home_unit_ids hsc_env)++  where+    load :: Set.Set UnitId -> UnitId -> LoaderState -> IO (Set.Set UnitId, LoaderState)+    load done uid pls | uid `Set.member` done = return (done, pls)+    load done uid pls = do+      let hsc' = hscSetActiveUnitId uid hsc_env+      -- Load potential dependencies first+      (done', pls') <- foldM (\(done', pls') uid -> load done' uid pls') (done, pls)+                          (homeUnitDepends (hsc_units hsc'))+      pls'' <- loadCmdLineLibs'' interp hsc' pls'+      return $ (Set.insert uid done', pls'')++loadCmdLineLibs''   :: Interp   -> HscEnv   -> LoaderState   -> IO LoaderState-loadCmdLineLibs' interp hsc_env pls =+loadCmdLineLibs'' interp hsc_env pls =   do+       let dflags@(DynFlags { ldInputs = cmdline_ld_inputs                            , libraryPaths = lib_paths_base})             = hsc_dflags hsc_env@@ -334,16 +370,16 @@        lib_paths_env <- addEnvPaths "LIBRARY_PATH" lib_paths_base -      maybePutStrLn logger dflags "Search directories (user):"-      maybePutStr logger dflags (unlines $ map ("  "++) lib_paths_env)-      maybePutStrLn logger dflags "Search directories (gcc):"-      maybePutStr logger dflags (unlines $ map ("  "++) gcc_paths)+      maybePutStrLn logger "Search directories (user):"+      maybePutStr logger (unlines $ map ("  "++) lib_paths_env)+      maybePutStrLn logger "Search directories (gcc):"+      maybePutStr logger (unlines $ map ("  "++) gcc_paths)        libspecs         <- mapM (locateLib interp hsc_env False lib_paths_env gcc_paths) minus_ls        -- (d) Link .o files from the command-line-      classified_ld_inputs <- mapM (classifyLdInput logger dflags)+      classified_ld_inputs <- mapM (classifyLdInput logger platform)                                 [ f | FileOption _ f <- cmdline_ld_inputs ]        -- (e) Link any MacOS frameworks@@ -375,13 +411,13 @@            pls1 <- foldM (preloadLib interp hsc_env lib_paths framework_paths) pls                          merged_specs -           maybePutStr logger dflags "final link ... "+           maybePutStr logger "final link ... "            ok <- resolveObjs interp             -- DLLs are loaded, reset the search paths            mapM_ (removeLibrarySearchPath interp) $ reverse pathCache -           if succeeded ok then maybePutStrLn logger dflags "done"+           if succeeded ok then maybePutStrLn logger "done"            else throwGhcExceptionIO (ProgramError "linking extra libraries/objects failed")             return pls1@@ -400,7 +436,7 @@     go [] [] = []  {- Note [preload packages]-+   ~~~~~~~~~~~~~~~~~~~~~~~ Why do we need to preload packages from the command line?  This is an explanation copied from #2437: @@ -424,16 +460,15 @@ users? -} -classifyLdInput :: Logger -> DynFlags -> FilePath -> IO (Maybe LibrarySpec)-classifyLdInput logger dflags f+classifyLdInput :: Logger -> Platform -> FilePath -> IO (Maybe LibrarySpec)+classifyLdInput logger platform f   | isObjectFilename platform f = return (Just (Objects [f]))   | isDynLibFilename platform f = return (Just (DLLPath f))   | otherwise          = do-        putLogMsg logger dflags NoReason SevInfo noSrcSpan+        logMsg logger MCInfo noSrcSpan             $ withPprStyle defaultUserStyle             (text ("Warning: ignoring unrecognised input `" ++ f ++ "'"))         return Nothing-    where platform = targetPlatform dflags  preloadLib   :: Interp@@ -444,22 +479,22 @@   -> LibrarySpec   -> IO LoaderState preloadLib interp hsc_env lib_paths framework_paths pls lib_spec = do-  maybePutStr logger dflags ("Loading object " ++ showLS lib_spec ++ " ... ")+  maybePutStr logger ("Loading object " ++ showLS lib_spec ++ " ... ")   case lib_spec of     Objects static_ishs -> do       (b, pls1) <- preload_statics lib_paths static_ishs-      maybePutStrLn logger dflags (if b  then "done" else "not found")+      maybePutStrLn logger (if b  then "done" else "not found")       return pls1      Archive static_ish -> do       b <- preload_static_archive lib_paths static_ish-      maybePutStrLn logger dflags (if b  then "done" else "not found")+      maybePutStrLn logger (if b  then "done" else "not found")       return pls      DLL dll_unadorned -> do       maybe_errstr <- loadDLL interp (platformSOName platform dll_unadorned)       case maybe_errstr of-         Nothing -> maybePutStrLn logger dflags "done"+         Nothing -> maybePutStrLn logger "done"          Just mm | platformOS platform /= OSDarwin ->            preloadFailed mm lib_paths lib_spec          Just mm | otherwise -> do@@ -469,14 +504,14 @@            let libfile = ("lib" ++ dll_unadorned) <.> "so"            err2 <- loadDLL interp libfile            case err2 of-             Nothing -> maybePutStrLn logger dflags "done"+             Nothing -> maybePutStrLn logger "done"              Just _  -> preloadFailed mm lib_paths lib_spec       return pls      DLLPath dll_path -> do       do maybe_errstr <- loadDLL interp dll_path          case maybe_errstr of-            Nothing -> maybePutStrLn logger dflags "done"+            Nothing -> maybePutStrLn logger "done"             Just mm -> preloadFailed mm lib_paths lib_spec          return pls @@ -484,7 +519,7 @@       if platformUsesFrameworks (targetPlatform dflags)       then do maybe_errstr <- loadFramework interp framework_paths framework               case maybe_errstr of-                 Nothing -> maybePutStrLn logger dflags "done"+                 Nothing -> maybePutStrLn logger "done"                  Just mm -> preloadFailed mm framework_paths lib_spec               return pls       else throwGhcExceptionIO (ProgramError "preloadLib Framework")@@ -497,7 +532,7 @@      preloadFailed :: String -> [String] -> LibrarySpec -> IO ()     preloadFailed sys_errmsg paths spec-       = do maybePutStr logger dflags "failed.\n"+       = do maybePutStr logger "failed.\n"             throwGhcExceptionIO $               CmdLineError (                     "user specified .o/.so/.DLL could not be loaded ("@@ -553,7 +588,7 @@   -- Take lock for the actual work.   modifyLoaderState interp $ \pls0 -> do     -- Load the packages and modules required-    (pls, ok) <- loadDependencies interp hsc_env pls0 span needed_mods+    (pls, ok, _, _) <- loadDependencies interp hsc_env pls0 span needed_mods     if failed ok       then throwGhcExceptionIO (ProgramError "")       else do@@ -565,11 +600,11 @@         let nobreakarray = error "no break array"             bco_ix = mkNameEnv [(unlinkedBCOName root_ul_bco, 0)]         resolved <- linkBCO interp ie ce bco_ix nobreakarray root_ul_bco-        [root_hvref] <- createBCOs interp dflags [resolved]+        bco_opts <- initBCOOpts (hsc_dflags hsc_env)+        [root_hvref] <- createBCOs interp bco_opts [resolved]         fhv <- mkFinalizedHValue interp root_hvref         return (pls, fhv)   where-     dflags = hsc_dflags hsc_env      free_names = uniqDSetToList (bcoFreeNames root_ul_bco)       needed_mods :: [Module]@@ -583,21 +618,25 @@         -- by default, so we can safely ignore them here.  dieWith :: DynFlags -> SrcSpan -> SDoc -> IO a-dieWith dflags span msg = throwGhcExceptionIO (ProgramError (showSDoc dflags (mkLocMessage SevFatal span msg)))+dieWith dflags span msg = throwGhcExceptionIO (ProgramError (showSDoc dflags (mkLocMessage MCFatal span msg)))   checkNonStdWay :: DynFlags -> Interp -> SrcSpan -> IO (Maybe FilePath)-checkNonStdWay dflags interp srcspan+checkNonStdWay _dflags interp _srcspan   | ExternalInterp {} <- interpInstance interp = return Nothing     -- with -fexternal-interpreter we load the .o files, whatever way     -- they were built.  If they were built for a non-std way, then     -- we will use the appropriate variant of the iserv binary to load them. +-- #if-guard the following equations otherwise the pattern match checker will+-- complain that they are redundant.+#if defined(HAVE_INTERNAL_INTERPRETER)+checkNonStdWay dflags _interp srcspan   | hostFullWays == targetFullWays = return Nothing     -- Only if we are compiling with the same ways as GHC is built     -- with, can we dynamically load those object files. (see #3604) -  | objectSuf dflags == normalObjectSuffix && not (null targetFullWays)+  | objectSuf_ dflags == normalObjectSuffix && not (null targetFullWays)   = failNonStd dflags srcspan    | otherwise = return (Just (hostWayTag ++ "o"))@@ -607,52 +646,80 @@                   "" -> ""                   tag -> tag ++ "_" -normalObjectSuffix :: String-normalObjectSuffix = phaseInputExt StopLn+    normalObjectSuffix :: String+    normalObjectSuffix = phaseInputExt StopLn +data Way' = Normal | Prof | Dyn+ failNonStd :: DynFlags -> SrcSpan -> IO (Maybe FilePath) failNonStd dflags srcspan = dieWith dflags srcspan $-  text "Cannot load" <+> compWay <+>-     text "objects when GHC is built" <+> ghciWay $$+  text "Cannot load" <+> pprWay' compWay <+>+     text "objects when GHC is built" <+> pprWay' ghciWay $$   text "To fix this, either:" $$   text "  (1) Use -fexternal-interpreter, or" $$-  text "  (2) Build the program twice: once" <+>-                       ghciWay <> text ", and then" $$-  text "      with" <+> compWay <+>-     text "using -osuf to set a different object file suffix."+  buildTwiceMsg     where compWay-            | WayDyn `elem` ways dflags = text "-dynamic"-            | WayProf `elem` ways dflags = text "-prof"-            | otherwise = text "normal"+            | ways dflags `hasWay` WayDyn  = Dyn+            | ways dflags `hasWay` WayProf = Prof+            | otherwise = Normal           ghciWay-            | hostIsDynamic = text "with -dynamic"-            | hostIsProfiled = text "with -prof"-            | otherwise = text "the normal way"+            | hostIsDynamic = Dyn+            | hostIsProfiled = Prof+            | otherwise = Normal+          buildTwiceMsg = case (ghciWay, compWay) of+            (Normal, Dyn) -> dynamicTooMsg+            (Dyn, Normal) -> dynamicTooMsg+            _ ->+              text "  (2) Build the program twice: once" <+>+                pprWay' ghciWay <> text ", and then" $$+              text "      " <> pprWay' compWay <+>+                text "using -osuf to set a different object file suffix."+          dynamicTooMsg = text "  (2) Use -dynamic-too," <+>+            text "and use -osuf and -dynosuf to set object file suffixes as needed."+          pprWay' :: Way' -> SDoc+          pprWay' way = text $ case way of+            Normal -> "the normal way"+            Prof -> "with -prof"+            Dyn -> "with -dynamic"+#endif -getLinkDeps :: HscEnv -> HomePackageTable+getLinkDeps :: HscEnv             -> LoaderState-            -> Maybe FilePath                   -- replace object suffices?+            -> Maybe FilePath                   -- replace object suffixes?             -> SrcSpan                          -- for error messages             -> [Module]                         -- If you need these-            -> IO ([Linkable], [UnitId])     -- ... then link these first+            -> IO ([Linkable], [Linkable], [UnitId], UniqDSet UnitId)     -- ... then link these first+            -- The module and package dependencies for the needed modules are returned.+            -- See Note [Object File Dependencies] -- Fails with an IO exception if it can't find enough files -getLinkDeps hsc_env hpt pls replace_osuf span mods+getLinkDeps hsc_env pls replace_osuf span mods -- Find all the packages and linkables that a set of modules depends on  = do {         -- 1.  Find the dependent home-pkg-modules/packages from each iface         -- (omitting modules from the interactive package, which is already linked)-      ; (mods_s, pkgs_s) <- follow_deps (filterOut isInteractiveModule mods)-                                        emptyUniqDSet emptyUniqDSet;+      ; (mods_s, pkgs_s) <-+          -- Why two code paths here? There is a significant amount of repeated work+          -- performed calculating transitive dependencies+          -- if --make uses the oneShot code path (see MultiLayerModulesTH_* tests)+          if isOneShot (ghcMode dflags)+            then follow_deps (filterOut isInteractiveModule mods)+                              emptyUniqDSet emptyUniqDSet;+            else do+              (pkgs, mmods) <- unzip <$> mapM get_mod_info all_home_mods+              return (catMaybes mmods, unionManyUniqDSets (init_pkg_set : pkgs)) -      ; let {+      ; let         -- 2.  Exclude ones already linked         --      Main reason: avoid findModule calls in get_linkable-            mods_needed = mods_s `minusList` linked_mods     ;-            pkgs_needed = pkgs_s `minusList` pkgs_loaded pls ;+            (mods_needed, links_got) = partitionEithers (map split_mods mods_s)+            pkgs_needed = eltsUDFM $ getUniqDSet pkgs_s `minusUDFM` pkgs_loaded pls -            linked_mods = map (moduleName.linkableModule)-                                (objs_loaded pls ++ bcos_loaded pls)  }+            split_mods mod =+                let is_linked = findModuleLinkable_maybe (objs_loaded pls) mod <|> findModuleLinkable_maybe (bcos_loaded pls) mod+                in case is_linked of+                     Just linkable -> Right linkable+                     Nothing -> Left mod          -- 3.  For each dependent module, find its linkable         --     This will either be in the HPT or (in the case of one-shot@@ -660,21 +727,67 @@       ; let { osuf = objectSuf dflags }       ; lnks_needed <- mapM (get_linkable osuf) mods_needed -      ; return (lnks_needed, pkgs_needed) }+      ; return (lnks_needed, links_got ++ lnks_needed, pkgs_needed, pkgs_s) }   where     dflags = hsc_dflags hsc_env+    mod_graph = hsc_mod_graph hsc_env -        -- The ModIface contains the transitive closure of the module dependencies-        -- within the current package, *except* for boot modules: if we encounter-        -- a boot module, we have to find its real interface and discover the-        -- dependencies of that.  Hence we need to traverse the dependency-        -- tree recursively.  See bug #936, testcase ghci/prog007.+    -- This code is used in `--make` mode to calculate the home package and unit dependencies+    -- for a set of modules.+    --+    -- It is significantly more efficient to use the shared transitive dependency+    -- calculation than to compute the transitive dependency set in the same manner as oneShot mode.++    -- It is also a matter of correctness to use the module graph so that dependencies between home units+    -- is resolved correctly.+    make_deps_loop :: (UniqDSet UnitId, Set.Set NodeKey) -> [ModNodeKeyWithUid] -> (UniqDSet UnitId, Set.Set NodeKey)+    make_deps_loop found [] = found+    make_deps_loop found@(found_units, found_mods) (nk:nexts)+      | NodeKey_Module nk `Set.member` found_mods = make_deps_loop found nexts+      | otherwise =+        case M.lookup (NodeKey_Module nk) (mgTransDeps mod_graph) of+            Just trans_deps ->+              let deps = Set.insert (NodeKey_Module nk) trans_deps+                  -- See #936 and the ghci.prog007 test for why we have to continue traversing through+                  -- boot modules.+                  todo_boot_mods = [ModNodeKeyWithUid (GWIB mn NotBoot) uid | NodeKey_Module (ModNodeKeyWithUid (GWIB mn IsBoot) uid) <- Set.toList trans_deps]+              in make_deps_loop (found_units, deps `Set.union` found_mods) (todo_boot_mods ++ nexts)+            Nothing ->+              let (ModNodeKeyWithUid _ uid) = nk+              in make_deps_loop (addOneToUniqDSet found_units uid, found_mods) nexts++    mkNk m = ModNodeKeyWithUid (GWIB (moduleName m) NotBoot) (moduleUnitId m)+    (init_pkg_set, all_deps) = make_deps_loop (emptyUniqDSet, Set.empty) $ map mkNk (filterOut isInteractiveModule mods)++    all_home_mods = [with_uid | NodeKey_Module with_uid <- Set.toList all_deps]++    get_mod_info (ModNodeKeyWithUid gwib uid) =+      case lookupHug (hsc_HUG hsc_env) uid (gwib_mod gwib) of+        Just hmi ->+          let iface = (hm_iface hmi)+              mmod = case mi_hsc_src iface of+                      HsBootFile -> link_boot_mod_error (mi_module iface)+                      _ -> return $ Just (mi_module iface)++          in (mkUniqDSet $ Set.toList $ dep_direct_pkgs (mi_deps iface),) <$>  mmod+        Nothing ->+          let err = text "getLinkDeps: Home module not loaded" <+> ppr (gwib_mod gwib) <+> ppr uid+          in throwGhcExceptionIO (ProgramError (showSDoc dflags err))+++       -- This code is used in one-shot mode to traverse downwards through the HPT+       -- to find all link dependencies.+       -- The ModIface contains the transitive closure of the module dependencies+       -- within the current package, *except* for boot modules: if we encounter+       -- a boot module, we have to find its real interface and discover the+       -- dependencies of that.  Hence we need to traverse the dependency+       -- tree recursively.  See bug #936, testcase ghci/prog007.     follow_deps :: [Module]             -- modules to follow-                -> UniqDSet ModuleName         -- accum. module dependencies+                -> UniqDSet Module         -- accum. module dependencies                 -> UniqDSet UnitId          -- accum. package dependencies-                -> IO ([ModuleName], [UnitId]) -- result+                -> IO ([Module], UniqDSet UnitId) -- result     follow_deps []     acc_mods acc_pkgs-        = return (uniqDSetToList acc_mods, uniqDSetToList acc_pkgs)+        = return (uniqDSetToList acc_mods, acc_pkgs)     follow_deps (mod:mods) acc_mods acc_pkgs         = do           mb_iface <- initIfaceCheck (text "getLinkDeps") hsc_env $@@ -688,28 +801,32 @@           let             pkg = moduleUnit mod             deps  = mi_deps iface-            home_unit = hsc_home_unit hsc_env -            pkg_deps = dep_pkgs deps-            (boot_deps, mod_deps) = flip partitionWith (dep_mods deps) $-              \ (GWIB { gwib_mod = m, gwib_isBoot = is_boot }) ->-                m & case is_boot of-                  IsBoot -> Left-                  NotBoot -> Right+            pkg_deps = dep_direct_pkgs deps+            (boot_deps, mod_deps) = flip partitionWith (Set.toList (dep_direct_mods deps)) $+              \case+                (_, GWIB m IsBoot)  -> Left m+                (_, GWIB m NotBoot) -> Right m -            boot_deps' = filter (not . (`elementOfUniqDSet` acc_mods)) boot_deps-            acc_mods'  = addListToUniqDSet acc_mods (moduleName mod : mod_deps)-            acc_pkgs'  = addListToUniqDSet acc_pkgs $ map fst pkg_deps-          ---          if not (isHomeUnit home_unit pkg)-             then follow_deps mods acc_mods (addOneToUniqDSet acc_pkgs' (toUnitId pkg))-             else follow_deps (map (mkHomeModule home_unit) boot_deps' ++ mods)-                              acc_mods' acc_pkgs'+            mod_deps' = case hsc_home_unit_maybe hsc_env of+                          Nothing -> []+                          Just home_unit -> filter (not . (`elementOfUniqDSet` acc_mods)) (map (mkHomeModule home_unit) $ (boot_deps ++ mod_deps))+            acc_mods'  = case hsc_home_unit_maybe hsc_env of+                          Nothing -> acc_mods+                          Just home_unit -> addListToUniqDSet acc_mods (mod : map (mkHomeModule home_unit) mod_deps)+            acc_pkgs'  = addListToUniqDSet acc_pkgs (Set.toList pkg_deps)++          case hsc_home_unit_maybe hsc_env of+            Just home_unit | isHomeUnit home_unit pkg ->  follow_deps (mod_deps' ++ mods)+                                                                      acc_mods' acc_pkgs'+            _ ->  follow_deps mods acc_mods (addOneToUniqDSet acc_pkgs' (toUnitId pkg))         where-            msg = text "need to link module" <+> ppr mod <+>+           msg = text "need to link module" <+> ppr mod <+>                   text "due to use of Template Haskell"  ++    link_boot_mod_error :: Module -> IO a     link_boot_mod_error mod =         throwGhcExceptionIO (ProgramError (showSDoc dflags (             text "module" <+> ppr mod <+>@@ -725,16 +842,23 @@          -- This one is a build-system bug -    get_linkable osuf mod_name      -- A home-package module-        | Just mod_info <- lookupHpt hpt mod_name+    get_linkable osuf mod      -- A home-package module+        | Just mod_info <- lookupHugByModule mod (hsc_HUG hsc_env)         = adjust_linkable (Maybes.expectJust "getLinkDeps" (hm_linkable mod_info))         | otherwise         = do    -- It's not in the HPT because we are in one shot mode,                 -- so use the Finder to get a ModLocation...-             mb_stuff <- findHomeModule hsc_env mod_name-             case mb_stuff of+             case hsc_home_unit_maybe hsc_env of+              Nothing -> no_obj mod+              Just home_unit -> do++                let fc = hsc_FC hsc_env+                let dflags = hsc_dflags hsc_env+                let fopts = initFinderOpts dflags+                mb_stuff <- findHomeModule fc fopts home_unit (moduleName mod)+                case mb_stuff of                   Found loc mod -> found loc mod-                  _ -> no_obj mod_name+                  _ -> no_obj (moduleName mod)         where             found loc mod = do {                 -- ...and then find the linkable for it@@ -753,7 +877,7 @@                         return lnk              adjust_ul new_osuf (DotO file) = do-                MASSERT(osuf `isSuffixOf` file)+                massert (osuf `isSuffixOf` file)                 let file_base = fromJust (stripExtension osuf file)                     new_file = file_base <.> new_osuf                 ok <- doesFileExist new_file@@ -767,14 +891,13 @@             adjust_ul _ l@(BCOs {}) = return l  - {- **********************************************************************                Loading a Decls statement    ********************************************************************* -} -loadDecls :: Interp -> HscEnv -> SrcSpan -> CompiledByteCode -> IO [(Name, ForeignHValue)]+loadDecls :: Interp -> HscEnv -> SrcSpan -> CompiledByteCode -> IO ([(Name, ForeignHValue)], [Linkable], PkgsLoaded) loadDecls interp hsc_env span cbc@CompiledByteCode{..} = do     -- Initialise the linker (if it's not been done already)     initLoaderState interp hsc_env@@ -782,7 +905,7 @@     -- Take lock for the actual work.     modifyLoaderState interp $ \pls0 -> do       -- Link the packages and modules required-      (pls, ok) <- loadDependencies interp hsc_env pls0 span needed_mods+      (pls, ok, links_needed, units_needed) <- loadDependencies interp hsc_env pls0 span needed_mods       if failed ok         then throwGhcExceptionIO (ProgramError "")         else do@@ -791,13 +914,13 @@               ce = closure_env pls            -- Link the necessary packages and linkables-          new_bindings <- linkSomeBCOs dflags interp ie ce [cbc]+          bco_opts <- initBCOOpts (hsc_dflags hsc_env)+          new_bindings <- linkSomeBCOs bco_opts interp ie ce [cbc]           nms_fhvs <- makeForeignNamedHValueRefs interp new_bindings           let pls2 = pls { closure_env = extendClosureEnv ce nms_fhvs                          , itbl_env    = ie }-          return (pls2, nms_fhvs)+          return (pls2, (nms_fhvs, links_needed, units_needed))   where-    dflags = hsc_dflags hsc_env     free_names = uniqDSetToList $       foldr (unionUniqDSets . bcoFreeNames) emptyUniqDSet bc_bcos @@ -821,7 +944,7 @@ loadModule interp hsc_env mod = do   initLoaderState interp hsc_env   modifyLoaderState_ interp $ \pls -> do-    (pls', ok) <- loadDependencies interp hsc_env pls noSrcSpan [mod]+    (pls', ok, _, _) <- loadDependencies interp hsc_env pls noSrcSpan [mod]     if failed ok       then throwGhcExceptionIO (ProgramError "could not load module")       else return pls'@@ -834,13 +957,13 @@    ********************************************************************* -} -loadModules :: Interp -> HscEnv -> LoaderState -> [Linkable] -> IO (LoaderState, SuccessFlag)-loadModules interp hsc_env pls linkables+loadModuleLinkables :: Interp -> HscEnv -> LoaderState -> [Linkable] -> IO (LoaderState, SuccessFlag)+loadModuleLinkables interp hsc_env pls linkables   = mask_ $ do  -- don't want to be interrupted by ^C in here          let (objs, bcos) = partition isObjectLinkable                               (concatMap partitionLinkable linkables)-        let dflags = hsc_dflags hsc_env+        bco_opts <- initBCOOpts (hsc_dflags hsc_env)                  -- Load objects first; they can't depend on BCOs         (pls1, ok_flag) <- loadObjects interp hsc_env pls objs@@ -848,7 +971,7 @@         if failed ok_flag then                 return (pls1, Failed)           else do-                pls2 <- dynLinkBCOs dflags interp pls1 bcos+                pls2 <- dynLinkBCOs bco_opts interp pls1 bcos                 return (pls2, Succeeded)  @@ -864,14 +987,10 @@                            li {linkableUnlinked=li_uls_bco}]             _ -> [li] -findModuleLinkable_maybe :: [Linkable] -> Module -> Maybe Linkable-findModuleLinkable_maybe lis mod-   = case [LM time nm us | LM time nm us <- lis, nm == mod] of-        []   -> Nothing-        [li] -> Just li-        _    -> pprPanic "findModuleLinkable" (ppr mod)+findModuleLinkable_maybe :: LinkableSet -> Module -> Maybe Linkable+findModuleLinkable_maybe = lookupModuleEnv -linkableInSet :: Linkable -> [Linkable] -> Bool+linkableInSet :: Linkable -> LinkableSet -> Bool linkableInSet l objs_loaded =   case findModuleLinkable_maybe objs_loaded (linkableModule l) of         Nothing -> False@@ -929,7 +1048,7 @@     let minus_ls = [ lib | Option ('-':'l':lib) <- ldInputs dflags ]     let minus_big_ls = [ lib | Option ('-':'L':lib) <- ldInputs dflags ]     (soFile, libPath , libName) <--      newTempLibName logger tmpfs dflags TFL_CurrentModule (platformSOExt platform)+      newTempLibName logger tmpfs (tmpDir dflags) TFL_CurrentModule (platformSOExt platform)     let         dflags2 = dflags {                       -- We don't want the original ldInputs in@@ -975,7 +1094,7 @@     -- link all "loaded packages" so symbols in those can be resolved     -- Note: We are loading packages with local scope, so to see the     -- symbols in this link we must link all loaded packages again.-    linkDynLib logger tmpfs dflags2 unit_env objs pkgs_loaded+    linkDynLib logger tmpfs dflags2 unit_env objs (loaded_pkg_uid <$> eltsUDFM pkgs_loaded)      -- if we got this far, extend the lifetime of the library file     changeTempFilesLifetime tmpfs TFL_GhcSession [soFile]@@ -986,9 +1105,9 @@   where     msg = "GHC.Linker.Loader.dynLoadObjs: Loading temp shared object failed" -rmDupLinkables :: [Linkable]    -- Already loaded+rmDupLinkables :: LinkableSet    -- Already loaded                -> [Linkable]    -- New linkables-               -> ([Linkable],  -- New loaded set (including new ones)+               -> (LinkableSet,  -- New loaded set (including new ones)                    [Linkable])  -- New linkables (excluding dups) rmDupLinkables already ls   = go already [] ls@@ -996,7 +1115,7 @@     go already extras [] = (already, extras)     go already extras (l:ls)         | linkableInSet l already = go already     extras     ls-        | otherwise               = go (l:already) (l:extras) ls+        | otherwise               = go (extendModuleEnv already (linkableModule l) l) (l:extras) ls  {- ********************************************************************** @@ -1005,8 +1124,8 @@   ********************************************************************* -}  -dynLinkBCOs :: DynFlags -> Interp -> LoaderState -> [Linkable] -> IO LoaderState-dynLinkBCOs dflags interp pls bcos = do+dynLinkBCOs :: BCOOpts -> Interp -> LoaderState -> [Linkable] -> IO LoaderState+dynLinkBCOs bco_opts interp pls bcos = do          let (bcos_loaded', new_bcos) = rmDupLinkables (bcos_loaded pls) bcos             pls1                     = pls { bcos_loaded = bcos_loaded' }@@ -1021,7 +1140,7 @@             gce       = closure_env pls             final_ie  = foldr plusNameEnv (itbl_env pls) ies -        names_and_refs <- linkSomeBCOs dflags interp final_ie gce cbcs+        names_and_refs <- linkSomeBCOs bco_opts interp final_ie gce cbcs          -- We only want to add the external ones to the ClosureEnv         let (to_add, to_drop) = partition (isExternalName.fst) names_and_refs@@ -1035,7 +1154,7 @@                       itbl_env    = final_ie }  -- Link a bunch of BCOs and return references to their values-linkSomeBCOs :: DynFlags+linkSomeBCOs :: BCOOpts              -> Interp              -> ItblEnv              -> ClosureEnv@@ -1045,7 +1164,7 @@                         -- the incoming unlinked BCOs.  Each gives the                         -- value of the corresponding unlinked BCO -linkSomeBCOs dflags interp ie ce mods = foldr fun do_link mods []+linkSomeBCOs bco_opts interp ie ce mods = foldr fun do_link mods []  where   fun CompiledByteCode{..} inner accum =     case bc_breaks of@@ -1060,7 +1179,7 @@         bco_ix = mkNameEnv (zip names [0..])     resolved <- sequence [ linkBCO interp ie ce bco_ix breakarray bco                          | (breakarray, bco) <- flat ]-    hvrefs <- createBCOs interp dflags resolved+    hvrefs <- createBCOs interp bco_opts resolved     return (zip names hvrefs)  -- | Useful to apply to the result of 'linkSomeBCOs'@@ -1105,12 +1224,11 @@                  pls1 <- unload_wkr interp linkables pls                  return (pls1, pls1) -        let dflags = hsc_dflags hsc_env         let logger = hsc_logger hsc_env-        debugTraceMsg logger dflags 3 $-          text "unload: retaining objs" <+> ppr (objs_loaded new_pls)-        debugTraceMsg logger dflags 3 $-          text "unload: retaining bcos" <+> ppr (bcos_loaded new_pls)+        debugTraceMsg logger 3 $+          text "unload: retaining objs" <+> ppr (moduleEnvElts $ objs_loaded new_pls)+        debugTraceMsg logger 3 $+          text "unload: retaining bcos" <+> ppr (moduleEnvElts $ bcos_loaded new_pls)         return ()  unload_wkr@@ -1126,32 +1244,32 @@   -- we're unloading some code.  -fghci-leak-check with the tests in   -- testsuite/ghci can detect space leaks here. -  let (objs_to_keep, bcos_to_keep) = partition isObjectLinkable keep_linkables+  let (objs_to_keep', bcos_to_keep') = partition isObjectLinkable keep_linkables+      objs_to_keep = mkLinkableSet objs_to_keep'+      bcos_to_keep = mkLinkableSet bcos_to_keep'        discard keep l = not (linkableInSet l keep)        (objs_to_unload, remaining_objs_loaded) =-         partition (discard objs_to_keep) objs_loaded+         partitionModuleEnv (discard objs_to_keep) objs_loaded       (bcos_to_unload, remaining_bcos_loaded) =-         partition (discard bcos_to_keep) bcos_loaded+         partitionModuleEnv (discard bcos_to_keep) bcos_loaded -  mapM_ unloadObjs objs_to_unload-  mapM_ unloadObjs bcos_to_unload+      linkables_to_unload = moduleEnvElts objs_to_unload ++ moduleEnvElts bcos_to_unload +  mapM_ unloadObjs linkables_to_unload+   -- If we unloaded any object files at all, we need to purge the cache   -- of lookupSymbol results.-  when (not (null (objs_to_unload ++-                   filter (not . null . linkableObjs) bcos_to_unload))) $+  when (not (null (filter (not . null . linkableObjs) linkables_to_unload))) $     purgeLookupSymbolCache interp -  let !bcos_retained = mkModuleSet $ map linkableModule remaining_bcos_loaded--      -- Note that we want to remove all *local*+  let -- Note that we want to remove all *local*       -- (i.e. non-isExternal) names too (these are the       -- temporary bindings from the command line).       keep_name :: (Name, a) -> Bool       keep_name (n,_) = isExternalName n &&-                        nameModule n `elemModuleSet` bcos_retained+                        nameModule n `elemModuleEnv` remaining_bcos_loaded        itbl_env'     = filterNameEnv keep_name itbl_env       closure_env'  = filterNameEnv keep_name closure_env@@ -1165,10 +1283,7 @@   where     unloadObjs :: Linkable -> IO ()     unloadObjs lnk-        -- The RTS's PEi386 linker currently doesn't support unloading.-      | isWindowsHost = return ()--      | hostIsDynamic = return ()+      | interpreterDynamic interp = return ()         -- We don't do any cleanup when linking objects with the         -- dynamic linker.  Doing so introduces extra complexity for         -- not much benefit.@@ -1182,55 +1297,6 @@                 -- letting go of them (plus of course depopulating                 -- the symbol table which is done in the main body) -{- **********************************************************************--                Loading packages--  ********************************************************************* -}--data LibrarySpec-   = Objects [FilePath] -- Full path names of set of .o files, including trailing .o-                        -- We allow batched loading to ensure that cyclic symbol-                        -- references can be resolved (see #13786).-                        -- For dynamic objects only, try to find the object-                        -- file in all the directories specified in-                        -- v_Library_paths before giving up.--   | Archive FilePath   -- Full path name of a .a file, including trailing .a--   | DLL String         -- "Unadorned" name of a .DLL/.so-                        --  e.g.    On unix     "qt"  denotes "libqt.so"-                        --          On Windows  "burble"  denotes "burble.DLL" or "libburble.dll"-                        --  loadDLL is platform-specific and adds the lib/.so/.DLL-                        --  suffixes platform-dependently--   | DLLPath FilePath   -- Absolute or relative pathname to a dynamic library-                        -- (ends with .dll or .so).--   | Framework String   -- Only used for darwin, but does no harm--instance Outputable LibrarySpec where-  ppr (Objects objs) = text "Objects" <+> ppr objs-  ppr (Archive a) = text "Archive" <+> text a-  ppr (DLL s) = text "DLL" <+> text s-  ppr (DLLPath f) = text "DLLPath" <+> text f-  ppr (Framework s) = text "Framework" <+> text s---- If this package is already part of the GHCi binary, we'll already--- have the right DLLs for this package loaded, so don't try to--- load them again.------ But on Win32 we must load them 'again'; doing so is a harmless no-op--- as far as the loader is concerned, but it does initialise the list--- of DLL handles that rts/Linker.c maintains, and that in turn is--- used by lookupSymbol.  So we must call addDLL for each library--- just to get the DLL handle into the list.-partOfGHCi :: [PackageName]-partOfGHCi- | isWindowsHost || isDarwinHost = []- | otherwise = map (PackageName . mkFastString)-                   ["base", "template-haskell", "editline"]- showLS :: LibrarySpec -> String showLS (Objects nms)  = "(static) [" ++ intercalate ", " nms ++ "]" showLS (Archive nm)   = "(static archive) " ++ nm@@ -1262,28 +1328,34 @@ loadPackages' :: Interp -> HscEnv -> [UnitId] -> LoaderState -> IO LoaderState loadPackages' interp hsc_env new_pks pls = do     pkgs' <- link (pkgs_loaded pls) new_pks-    return $! pls { pkgs_loaded = pkgs' }+    return $! pls { pkgs_loaded = pkgs'+                  }   where-     link :: [UnitId] -> [UnitId] -> IO [UnitId]+     link :: PkgsLoaded -> [UnitId] -> IO PkgsLoaded      link pkgs new_pkgs =          foldM link_one pkgs new_pkgs       link_one pkgs new_pkg-        | new_pkg `elem` pkgs   -- Already linked+        | new_pkg `elemUDFM` pkgs   -- Already linked         = return pkgs          | Just pkg_cfg <- lookupUnitId (hsc_units hsc_env) new_pkg-        = do {  -- Link dependents first-               pkgs' <- link pkgs (unitDepends pkg_cfg)+        = do { let deps = unitDepends pkg_cfg+               -- Link dependents first+             ; pkgs' <- link pkgs deps                 -- Now link the package itself-             ; loadPackage interp hsc_env pkg_cfg-             ; return (new_pkg : pkgs') }+             ; (hs_cls, extra_cls) <- loadPackage interp hsc_env pkg_cfg+             ; let trans_deps = unionManyUniqDSets [ addOneToUniqDSet (loaded_pkg_trans_deps loaded_pkg_info) dep_pkg+                                                   | dep_pkg <- deps+                                                   , Just loaded_pkg_info <- pure (lookupUDFM pkgs' dep_pkg)+                                                   ]+             ; return (addToUDFM pkgs' new_pkg (LoadedPkgInfo new_pkg hs_cls extra_cls trans_deps)) }          | otherwise         = throwGhcExceptionIO (CmdLineError ("unknown package: " ++ unpackFS (unitIdFS new_pkg)))  -loadPackage :: Interp -> HscEnv -> UnitInfo -> IO ()+loadPackage :: Interp -> HscEnv -> UnitInfo -> IO ([LibrarySpec], [LibrarySpec]) loadPackage interp hsc_env pkg    = do         let dflags    = hsc_dflags hsc_env@@ -1326,7 +1398,9 @@          -- Complication: all the .so's must be loaded before any of the .o's.         let known_dlls = [ dll  | DLLPath dll    <- classifieds ]+#if defined(CAN_LOAD_DLL)             dlls       = [ dll  | DLL dll        <- classifieds ]+#endif             objs       = [ obj  | Objects objs    <- classifieds                                 , obj <- objs ]             archs      = [ arch | Archive arch   <- classifieds ]@@ -1337,19 +1411,17 @@         all_paths_env <- addEnvPaths "LD_LIBRARY_PATH" all_paths         pathCache <- mapM (addLibrarySearchPath interp) all_paths_env -        maybePutSDoc logger dflags+        maybePutSDoc logger             (text "Loading unit " <> pprUnitInfoForUser pkg <> text " ... ") -        -- See comments with partOfGHCi #if defined(CAN_LOAD_DLL)-        when (unitPackageName pkg `notElem` partOfGHCi) $ do-            loadFrameworks interp platform pkg-            -- See Note [Crash early load_dyn and locateLib]-            -- Crash early if can't load any of `known_dlls`-            mapM_ (load_dyn interp hsc_env True) known_dlls-            -- For remaining `dlls` crash early only when there is surely-            -- no package's DLL around ... (not is_dyn)-            mapM_ (load_dyn interp hsc_env (not is_dyn) . platformSOName platform) dlls+        loadFrameworks interp platform pkg+        -- See Note [Crash early load_dyn and locateLib]+        -- Crash early if can't load any of `known_dlls`+        mapM_ (load_dyn interp hsc_env True) known_dlls+        -- For remaining `dlls` crash early only when there is surely+        -- no package's DLL around ... (not is_dyn)+        mapM_ (load_dyn interp hsc_env (not is_dyn) . platformSOName platform) dlls #endif         -- After loading all the DLLs, we can load the static objects.         -- Ordering isn't important here, because we do one final link@@ -1357,7 +1429,7 @@         mapM_ (loadObj interp) objs         mapM_ (loadArchive interp) archs -        maybePutStr logger dflags "linking ... "+        maybePutStr logger "linking ... "         ok <- resolveObjs interp          -- DLLs are loaded, reset the search paths@@ -1367,7 +1439,9 @@         mapM_ (removeLibrarySearchPath interp) $ reverse pathCache          if succeeded ok-           then maybePutStrLn logger dflags "done."+           then do+             maybePutStrLn logger "done."+             return (hs_classifieds, extra_classifieds)            else let errmsg = text "unable to load unit `"                              <> pprUnitInfoForUser pkg <> text "'"                  in throwGhcExceptionIO (InstallationError (showSDoc dflags errmsg))@@ -1415,6 +1489,7 @@ restriction very easily. -} +#if defined(CAN_LOAD_DLL) -- we have already searched the filesystem; the strings passed to load_dyn -- can be passed directly to loadDLL.  They are either fully-qualified -- ("/usr/lib/libfoo.so"), or unqualified ("libfoo.so").  In the latter case,@@ -1428,12 +1503,12 @@       if crash_early         then cmdLineErrorIO err         else-          when (wopt Opt_WarnMissedExtraSharedLib dflags)-            $ putLogMsg logger dflags-                (Reason Opt_WarnMissedExtraSharedLib) SevWarning+          when (diag_wopt Opt_WarnMissedExtraSharedLib diag_opts)+            $ logMsg logger+                (mkMCDiagnostic diag_opts $ WarningWithFlag Opt_WarnMissedExtraSharedLib)                   noSrcSpan $ withPprStyle defaultUserStyle (note err)   where-    dflags = hsc_dflags hsc_env+    diag_opts = initDiagOpts (hsc_dflags hsc_env)     logger = hsc_logger hsc_env     note err = vcat $ map text       [ err@@ -1453,6 +1528,7 @@                     Nothing  -> return ()                     Just err -> cmdLineErrorIO ("can't load framework: "                                                 ++ fw ++ " (" ++ err ++ ")" )+#endif  -- Try to find an object file for a given library in the given paths. -- If it isn't present, we assume that addDLL in the RTS can find it,@@ -1468,7 +1544,7 @@   -> [FilePath]   -> String   -> IO LibrarySpec-locateLib interp hsc_env is_hs lib_dirs gcc_dirs lib+locateLib interp hsc_env is_hs lib_dirs gcc_dirs lib0   | not is_hs     -- For non-Haskell libraries (e.g. gmp, iconv):     --   first look in library-dirs for a dynamic library (on User paths only)@@ -1521,52 +1597,79 @@    where      dflags = hsc_dflags hsc_env      logger = hsc_logger hsc_env+     diag_opts = initDiagOpts dflags      dirs   = lib_dirs ++ gcc_dirs      gcc    = False      user   = True +     -- Emulate ld's behavior of treating $LIB in `-l:$LIB` as a literal file+     -- name+     (lib, verbatim) = case lib0 of+       ':' : rest -> (rest, True)+       other      -> (other, False)+      obj_file        | is_hs && loading_profiled_hs_libs = lib <.> "p_o"        | otherwise = lib <.> "o"      dyn_obj_file = lib <.> "dyn_o"-     arch_files = [ "lib" ++ lib ++ lib_tag <.> "a"-                  , lib <.> "a" -- native code has no lib_tag-                  , "lib" ++ lib, lib-                  ]+     arch_files+       | verbatim = [lib]+       | otherwise = [ "lib" ++ lib ++ lib_tag <.> "a"+                     , lib <.> "a" -- native code has no lib_tag+                     , "lib" ++ lib+                     , lib+                     ]      lib_tag = if is_hs && loading_profiled_hs_libs then "_p" else ""       loading_profiled_hs_libs = interpreterProfiled interp      loading_dynamic_hs_libs  = interpreterDynamic  interp -     import_libs  = [ lib <.> "lib"           , "lib" ++ lib <.> "lib"-                    , "lib" ++ lib <.> "dll.a", lib <.> "dll.a"-                    ]+     import_libs+       | verbatim = [lib]+       | otherwise = [ lib <.> "lib"+                     , "lib" ++ lib <.> "lib"+                     , "lib" ++ lib <.> "dll.a"+                     , lib <.> "dll.a"+                     ]       hs_dyn_lib_name = lib ++ dynLibSuffix (ghcNameVersion dflags)      hs_dyn_lib_file = platformHsSOName platform hs_dyn_lib_name +#if defined(CAN_LOAD_DLL)      so_name     = platformSOName platform lib      lib_so_name = "lib" ++ so_name-     dyn_lib_file = case (arch, os) of-                             (ArchX86_64, OSSolaris2) -> "64" </> so_name-                             _ -> so_name+     dyn_lib_file+       | verbatim && any (`isExtensionOf` lib) [".so", ".dylib", ".dll"]+       = lib +       | ArchX86_64 <- arch+       , OSSolaris2 <- os+       = "64" </> so_name++       | otherwise+        = so_name+#endif+      findObject    = liftM (fmap $ Objects . (:[]))  $ findFile dirs obj_file      findDynObject = liftM (fmap $ Objects . (:[]))  $ findFile dirs dyn_obj_file      findArchive   = let local name = liftM (fmap Archive) $ findFile dirs name                      in  apply (map local arch_files)      findHSDll     = liftM (fmap DLLPath) $ findFile dirs hs_dyn_lib_file+#if defined(CAN_LOAD_DLL)      findDll    re = let dirs' = if re == user then lib_dirs else gcc_dirs                      in liftM (fmap DLLPath) $ findFile dirs' dyn_lib_file      findSysDll    = fmap (fmap $ DLL . dropExtension . takeFileName) $                         findSystemLibrary interp so_name+#endif      tryGcc        = let search   = searchForLibUsingGcc logger dflags+#if defined(CAN_LOAD_DLL)                          dllpath  = liftM (fmap DLLPath)                          short    = dllpath $ search so_name lib_dirs                          full     = dllpath $ search lib_so_name lib_dirs+                         dlls     = [short, full]+#endif                          gcc name = liftM (fmap Archive) $ search name lib_dirs                          files    = import_libs ++ arch_files-                         dlls     = [short, full]                          archives = map gcc files                      in apply $ #if defined(CAN_LOAD_DLL)@@ -1590,10 +1693,11 @@       , not loading_dynamic_hs_libs       , interpreterProfiled interp       = do-          warningMsg logger dflags-            (text "Interpreter failed to load profiled static library" <+> text lib <> char '.' $$+          let diag = mkMCDiagnostic diag_opts WarningWithoutFlag+          logMsg logger diag noSrcSpan $ withPprStyle defaultErrStyle $+            text "Interpreter failed to load profiled static library" <+> text lib <> char '.' $$               text " \tTrying dynamic library instead. If this fails try to rebuild" <+>-              text "libraries with profiling support.")+              text "libraries with profiling support."           return (DLL lib)       | otherwise = return (DLL lib)      infixr `orElse`@@ -1607,7 +1711,9 @@                           else apply xs       platform = targetPlatform dflags+#if defined(CAN_LOAD_DLL)      arch = platformArch platform+#endif      os = platformOS platform  searchForLibUsingGcc :: Logger -> DynFlags -> String -> [FilePath] -> IO (Maybe FilePath)@@ -1724,17 +1830,16 @@    ********************************************************************* -} -maybePutSDoc :: Logger -> DynFlags -> SDoc -> IO ()-maybePutSDoc logger dflags s-    = when (verbosity dflags > 1) $-          putLogMsg logger dflags-              NoReason-              SevInteractive+maybePutSDoc :: Logger -> SDoc -> IO ()+maybePutSDoc logger s+    = when (logVerbAtLeast logger 2) $+          logMsg logger+              MCInteractive               noSrcSpan               $ withPprStyle defaultUserStyle s -maybePutStr :: Logger -> DynFlags -> String -> IO ()-maybePutStr logger dflags s = maybePutSDoc logger dflags (text s)+maybePutStr :: Logger -> String -> IO ()+maybePutStr logger s = maybePutSDoc logger (text s) -maybePutStrLn :: Logger -> DynFlags -> String -> IO ()-maybePutStrLn logger dflags s = maybePutSDoc logger dflags (text s <> text "\n")+maybePutStrLn :: Logger -> String -> IO ()+maybePutStrLn logger s = maybePutSDoc logger (text s <> text "\n")
GHC/Linker/Static.hs view
@@ -2,7 +2,6 @@    ( linkBinary    , linkBinary'    , linkStaticLib-   , exeFileName    ) where @@ -29,6 +28,7 @@ import GHC.Linker.Dynamic import GHC.Linker.ExtraObj import GHC.Linker.Windows+import GHC.Linker.Static.Utils  import GHC.Driver.Session @@ -73,7 +73,7 @@         unit_state = ue_units unit_env         toolSettings' = toolSettings dflags         verbFlags = getVerbFlags dflags-        output_fn = exeFileName platform staticLink (outputFile dflags)+        output_fn = exeFileName platform staticLink (outputFile_ dflags)      -- get the full list of packages to link with, by combining the     -- explicit packages with the auto packages and all of their@@ -89,7 +89,7 @@         get_pkg_lib_path_opts l          | osElfTarget (platformOS platform) &&            dynLibLoader dflags == SystemDependent &&-           WayDyn `elem` ways dflags+           ways dflags `hasWay` WayDyn             = let libpath = if gopt Opt_RelativeDynlibPaths dflags                             then "$ORIGIN" </>                                  (l `makeRelativeTo` full_output_fn)@@ -110,7 +110,7 @@               in ["-L" ++ l] ++ rpathlink ++ rpath          | osMachOTarget (platformOS platform) &&            dynLibLoader dflags == SystemDependent &&-           WayDyn `elem` ways dflags &&+           ways dflags `hasWay` WayDyn &&            useXLinkerRPath dflags (platformOS platform)             = let libpath = if gopt Opt_RelativeDynlibPaths dflags                             then "@loader_path" </>@@ -123,7 +123,7 @@       if gopt Opt_SingleLibFolder dflags       then do         libs <- getLibs dflags unit_env dep_units-        tmpDir <- newTempDir logger tmpfs dflags+        tmpDir <- newTempDir logger tmpfs (tmpDir dflags)         sequence_ [ copyFile lib (tmpDir </> basename)                   | (lib, basename) <- libs]         return [ "-L" ++ tmpDir ]@@ -197,12 +197,12 @@                       ++ [ GHC.SysTools.Option "-o"                          , GHC.SysTools.FileOption "" output_fn                          ]-                      ++ libmLinkOpts+                      ++ libmLinkOpts platform                       ++ map GHC.SysTools.Option (                          []                        -- See Note [No PIE when linking]-                      ++ picCCOpts dflags+                      ++ pieCCLDOpts dflags                        -- Permit the linker to auto link _symbol to _imp_symbol.                       -- This lets us link against DLLs without needing an "import library".@@ -278,7 +278,7 @@   let platform  = ue_platform unit_env       extra_ld_inputs = [ f | FileOption _ f <- ldInputs dflags ]       modules = o_files ++ extra_ld_inputs-      output_fn = exeFileName platform True (outputFile dflags)+      output_fn = exeFileName platform True (outputFile_ dflags)    full_output_fn <- if isAbsolute output_fn                     then return output_fn@@ -307,30 +307,3 @@    -- run ranlib over the archive. write*Ar does *not* create the symbol index.   runRanlib logger dflags [GHC.SysTools.FileOption "" output_fn]------ | Compute the output file name of a program.------ StaticLink boolean is used to indicate if the program is actually a static library--- (e.g., on iOS).------ Use the provided filename (if any), otherwise use "main.exe" (Windows),--- "a.out (otherwise without StaticLink set), "liba.a". In every case, add the--- extension if it is missing.-exeFileName :: Platform -> Bool -> Maybe FilePath -> FilePath-exeFileName platform staticLink output_fn-  | Just s <- output_fn =-      case platformOS platform of-          OSMinGW32 -> s <?.> "exe"-          _         -> if staticLink-                         then s <?.> "a"-                         else s-  | otherwise =-      if platformOS platform == OSMinGW32-      then "main.exe"-      else if staticLink-           then "liba.a"-           else "a.out"- where s <?.> ext | null (takeExtension s) = s <.> ext-                  | otherwise              = s
+ GHC/Linker/Static/Utils.hs view
@@ -0,0 +1,31 @@+module GHC.Linker.Static.Utils where++import GHC.Prelude+import GHC.Platform+import System.FilePath++-- | Compute the output file name of a program.+--+-- StaticLink boolean is used to indicate if the program is actually a static library+-- (e.g., on iOS).+--+-- Use the provided filename (if any), otherwise use "main.exe" (Windows),+-- "a.out (otherwise without StaticLink set), "liba.a". In every case, add the+-- extension if it is missing.+exeFileName :: Platform -> Bool -> Maybe FilePath -> FilePath+exeFileName platform staticLink output_fn+  | Just s <- output_fn =+      case platformOS platform of+          OSMinGW32 -> s <?.> "exe"+          _         -> if staticLink+                         then s <?.> "a"+                         else s+  | otherwise =+      if platformOS platform == OSMinGW32+      then "main.exe"+      else if staticLink+           then "liba.a"+           else "a.out"+ where s <?.> ext | null (takeExtension s) = s <.> ext+                  | otherwise              = s+
GHC/Linker/Types.hs view
@@ -11,14 +11,22 @@    , LoaderState (..)    , uninitializedLoader    , Linkable(..)+   , LinkableSet+   , mkLinkableSet+   , unionLinkableSet+   , ObjFile    , Unlinked(..)    , SptEntry(..)    , isObjectLinkable    , linkableObjs    , isObject    , nameOfObject+   , nameOfObject_maybe    , isInterpretable    , byteCodeOfObject+   , LibrarySpec(..)+   , LoadedPkgInfo(..)+   , PkgsLoaded    ) where @@ -37,6 +45,10 @@  import Control.Concurrent.MVar import Data.Time               ( UTCTime )+import Data.Maybe+import GHC.Unit.Module.Env+import GHC.Types.Unique.DSet+import GHC.Types.Unique.DFM   {- **********************************************************************@@ -71,16 +83,15 @@         -- module in the image is replaced, the itbl_env must be updated         -- appropriately. -    , bcos_loaded :: ![Linkable]+    , bcos_loaded :: !LinkableSet         -- ^ The currently loaded interpreted modules (home package) -    , objs_loaded :: ![Linkable]+    , objs_loaded :: !LinkableSet         -- ^ And the currently-loaded compiled modules (home package) -    , pkgs_loaded :: ![UnitId]+    , pkgs_loaded :: !PkgsLoaded         -- ^ The currently-loaded packages; always object code-        -- Held, as usual, in dependency order; though I am not sure if-        -- that is really important+        -- haskell libraries, system libraries, transitive dependencies      , temp_sos :: ![(FilePath, String)]         -- ^ We need to remember the name of previous temporary DLL/.so@@ -91,38 +102,65 @@ uninitializedLoader = Loader <$> newMVar Nothing  type ClosureEnv = NameEnv (Name, ForeignHValue)+type PkgsLoaded = UniqDFM UnitId LoadedPkgInfo +data LoadedPkgInfo+  = LoadedPkgInfo+  { loaded_pkg_uid         :: !UnitId+  , loaded_pkg_hs_objs     :: ![LibrarySpec]+  , loaded_pkg_non_hs_objs :: ![LibrarySpec]+  , loaded_pkg_trans_deps  :: UniqDSet UnitId+  }++instance Outputable LoadedPkgInfo where+  ppr (LoadedPkgInfo uid hs_objs non_hs_objs trans_deps) =+    vcat [ppr uid+         , ppr hs_objs+         , ppr non_hs_objs+         , ppr trans_deps ]++ -- | Information we can use to dynamically link modules into the compiler data Linkable = LM {-  linkableTime     :: UTCTime,          -- ^ Time at which this linkable was built+  linkableTime     :: !UTCTime,          -- ^ Time at which this linkable was built                                         -- (i.e. when the bytecodes were produced,                                         --       or the mod date on the files)-  linkableModule   :: Module,           -- ^ The linkable module itself+  linkableModule   :: !Module,           -- ^ The linkable module itself   linkableUnlinked :: [Unlinked]     -- ^ Those files and chunks of code we have yet to link.     --     -- INVARIANT: A valid linkable always has at least one 'Unlinked' item.-    -- If this list is empty, the Linkable represents a fake linkable, which-    -- is generated with no backend is used to avoid recompiling modules.-    ---    -- ToDo: Do items get removed from this list when they get linked?  } +type LinkableSet = ModuleEnv Linkable++mkLinkableSet :: [Linkable] -> LinkableSet+mkLinkableSet ls = mkModuleEnv [(linkableModule l, l) | l <- ls]++unionLinkableSet :: LinkableSet -> LinkableSet -> LinkableSet+unionLinkableSet = plusModuleEnv_C go+  where+    go l1 l2+      | linkableTime l1 > linkableTime l2 = l1+      | otherwise = l2+ instance Outputable Linkable where   ppr (LM when_made mod unlinkeds)      = (text "LinkableM" <+> parens (text (show when_made)) <+> ppr mod)        $$ nest 3 (ppr unlinkeds) +type ObjFile = FilePath+ -- | Objects which have yet to be linked by the compiler data Unlinked-  = DotO FilePath      -- ^ An object file (.o)+  = DotO ObjFile       -- ^ An object file (.o)   | DotA FilePath      -- ^ Static archive file (.a)   | DotDLL FilePath    -- ^ Dynamically linked library file (.so, .dll, .dylib)   | BCOs CompiledByteCode          [SptEntry]    -- ^ A byte-code object, lives only in memory. Also                        -- carries some static pointer table entries which                        -- should be loaded along with the BCOs.-                       -- See Note [Grant plan for static forms] in+                       -- See Note [Grand plan for static forms] in                        -- "GHC.Iface.Tidy.StaticPtrTable".  instance Outputable Unlinked where@@ -163,14 +201,51 @@ isInterpretable :: Unlinked -> Bool isInterpretable = not . isObject +nameOfObject_maybe :: Unlinked -> Maybe FilePath+nameOfObject_maybe (DotO fn)   = Just fn+nameOfObject_maybe (DotA fn)   = Just fn+nameOfObject_maybe (DotDLL fn) = Just fn+nameOfObject_maybe (BCOs {})   = Nothing+ -- | Retrieve the filename of the linkable if possible. Panic if it is a byte-code object nameOfObject :: Unlinked -> FilePath-nameOfObject (DotO fn)   = fn-nameOfObject (DotA fn)   = fn-nameOfObject (DotDLL fn) = fn-nameOfObject other       = pprPanic "nameOfObject" (ppr other)+nameOfObject o = fromMaybe (pprPanic "nameOfObject" (ppr o)) (nameOfObject_maybe o)  -- | Retrieve the compiled byte-code if possible. Panic if it is a file-based linkable byteCodeOfObject :: Unlinked -> CompiledByteCode byteCodeOfObject (BCOs bc _) = bc byteCodeOfObject other       = pprPanic "byteCodeOfObject" (ppr other)++{- **********************************************************************++                Loading packages++  ********************************************************************* -}++data LibrarySpec+   = Objects [FilePath] -- Full path names of set of .o files, including trailing .o+                        -- We allow batched loading to ensure that cyclic symbol+                        -- references can be resolved (see #13786).+                        -- For dynamic objects only, try to find the object+                        -- file in all the directories specified in+                        -- v_Library_paths before giving up.++   | Archive FilePath   -- Full path name of a .a file, including trailing .a++   | DLL String         -- "Unadorned" name of a .DLL/.so+                        --  e.g.    On unix     "qt"  denotes "libqt.so"+                        --          On Windows  "burble"  denotes "burble.DLL" or "libburble.dll"+                        --  loadDLL is platform-specific and adds the lib/.so/.DLL+                        --  suffixes platform-dependently++   | DLLPath FilePath   -- Absolute or relative pathname to a dynamic library+                        -- (ends with .dll or .so).++   | Framework String   -- Only used for darwin, but does no harm++instance Outputable LibrarySpec where+  ppr (Objects objs) = text "Objects" <+> ppr objs+  ppr (Archive a) = text "Archive" <+> text a+  ppr (DLL s) = text "DLL" <+> text s+  ppr (DLLPath f) = text "DLLPath" <+> text f+  ppr (Framework s) = text "Framework" <+> text s
GHC/Linker/Unit.hs view
@@ -50,7 +50,7 @@ -- | Either the 'unitLibraryDirs' or 'unitLibraryDynDirs' as appropriate for the way. libraryDirsForWay :: Ways -> UnitInfo -> [String] libraryDirsForWay ws-  | WayDyn `elem` ws = map ST.unpack . unitLibraryDynDirs+  | hasWay ws WayDyn = map ST.unpack . unitLibraryDynDirs   | otherwise        = map ST.unpack . unitLibraryDirs  getLibs :: DynFlags -> UnitEnv -> [UnitId] -> IO [(String,String)]
GHC/Linker/Windows.hs view
@@ -45,9 +45,9 @@    if not (gopt Opt_EmbedManifest dflags)       then return []       else do-         rc_filename <- newTempName logger tmpfs dflags TFL_CurrentModule "rc"+         rc_filename <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "rc"          rc_obj_filename <--           newTempName logger tmpfs dflags TFL_GhcSession (objectSuf dflags)+           newTempName logger tmpfs (tmpDir dflags) TFL_GhcSession (objectSuf dflags)           writeFile rc_filename $              "1 24 MOVEABLE PURE " ++ show manifest_filename ++ "\n"
GHC/Llvm.hs view
@@ -10,9 +10,6 @@ --  module GHC.Llvm (-        LlvmOpts (..),-        initLlvmOpts,-         -- * Modules, Functions and Blocks         LlvmModule(..),
GHC/Llvm/Ppr.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE LambdaCase #-}  --------------------------------------------------------------------------------@@ -30,8 +30,6 @@      ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Llvm.Syntax@@ -41,16 +39,17 @@ import Data.Int import Data.List ( intersperse ) import GHC.Utils.Outputable++import GHC.CmmToLlvm.Config import GHC.Utils.Panic import GHC.Types.Unique-import GHC.Data.FastString  -------------------------------------------------------------------------------- -- * Top Level Print functions --------------------------------------------------------------------------------  -- | Print out a whole LLVM module.-ppLlvmModule :: LlvmOpts -> LlvmModule -> SDoc+ppLlvmModule :: LlvmCgConfig -> LlvmModule -> SDoc ppLlvmModule opts (LlvmModule comments aliases meta globals decls funcs)   = ppLlvmComments comments $+$ newLine     $+$ ppLlvmAliases aliases $+$ newLine@@ -69,11 +68,11 @@   -- | Print out a list of global mutable variable definitions-ppLlvmGlobals :: LlvmOpts -> [LMGlobal] -> SDoc+ppLlvmGlobals :: LlvmCgConfig -> [LMGlobal] -> SDoc ppLlvmGlobals opts ls = vcat $ map (ppLlvmGlobal opts) ls  -- | Print out a global mutable variable definition-ppLlvmGlobal :: LlvmOpts -> LMGlobal -> SDoc+ppLlvmGlobal :: LlvmCgConfig -> LMGlobal -> SDoc ppLlvmGlobal opts (LMGlobal var@(LMGlobalVar _ _ link x a c) dat) =     let sect = case x of             Just x' -> text ", section" <+> doubleQuotes (ftext x')@@ -111,11 +110,11 @@   -- | Print out a list of LLVM metadata.-ppLlvmMetas :: LlvmOpts -> [MetaDecl] -> SDoc+ppLlvmMetas :: LlvmCgConfig -> [MetaDecl] -> SDoc ppLlvmMetas opts metas = vcat $ map (ppLlvmMeta opts) metas  -- | Print out an LLVM metadata definition.-ppLlvmMeta :: LlvmOpts -> MetaDecl -> SDoc+ppLlvmMeta :: LlvmCgConfig -> MetaDecl -> SDoc ppLlvmMeta opts (MetaUnnamed n m)   = ppr n <+> equals <+> ppMetaExpr opts m @@ -126,11 +125,11 @@   -- | Print out a list of function definitions.-ppLlvmFunctions :: LlvmOpts -> LlvmFunctions -> SDoc+ppLlvmFunctions :: LlvmCgConfig -> LlvmFunctions -> SDoc ppLlvmFunctions opts funcs = vcat $ map (ppLlvmFunction opts) funcs  -- | Print out a function definition.-ppLlvmFunction :: LlvmOpts -> LlvmFunction -> SDoc+ppLlvmFunction :: LlvmCgConfig -> LlvmFunction -> SDoc ppLlvmFunction opts fun =     let attrDoc = ppSpaceJoin (funcAttrs fun)         secDoc = case funcSect fun of@@ -151,9 +150,9 @@ ppLlvmFunctionHeader :: LlvmFunctionDecl -> [LMString] -> SDoc ppLlvmFunctionHeader (LlvmFunctionDecl n l c r varg p a) args   = let varg' = case varg of-                      VarArgs | null p    -> sLit "..."-                              | otherwise -> sLit ", ..."-                      _otherwise          -> sLit ""+                      VarArgs | null p    -> text "..."+                              | otherwise -> text ", ..."+                      _otherwise          -> text ""         align = case a of                      Just a' -> text " align " <> ppr a'                      Nothing -> empty@@ -161,7 +160,7 @@                                     <> ftext n)                     (zip p args)     in ppr l <+> ppr c <+> ppr r <+> char '@' <> ftext n <> lparen <>-        (hsep $ punctuate comma args') <> ptext varg' <> rparen <> align+        (hsep $ punctuate comma args') <> varg' <> rparen <> align  -- | Print out a list of function declaration. ppLlvmFunctionDecls :: LlvmFunctionDecls -> SDoc@@ -173,25 +172,25 @@ ppLlvmFunctionDecl :: LlvmFunctionDecl -> SDoc ppLlvmFunctionDecl (LlvmFunctionDecl n l c r varg p a)   = let varg' = case varg of-                      VarArgs | null p    -> sLit "..."-                              | otherwise -> sLit ", ..."-                      _otherwise          -> sLit ""+                      VarArgs | null p    -> text "..."+                              | otherwise -> text ", ..."+                      _otherwise          -> text ""         align = case a of                      Just a' -> text " align" <+> ppr a'                      Nothing -> empty         args = hcat $ intersperse (comma <> space) $                   map (\(t,a) -> ppr t <+> ppSpaceJoin a) p     in text "declare" <+> ppr l <+> ppr c <+> ppr r <+> char '@' <>-        ftext n <> lparen <> args <> ptext varg' <> rparen <> align $+$ newLine+        ftext n <> lparen <> args <> varg' <> rparen <> align $+$ newLine   -- | Print out a list of LLVM blocks.-ppLlvmBlocks :: LlvmOpts -> LlvmBlocks -> SDoc+ppLlvmBlocks :: LlvmCgConfig -> LlvmBlocks -> SDoc ppLlvmBlocks opts blocks = vcat $ map (ppLlvmBlock opts) blocks  -- | Print out an LLVM block. -- It must be part of a function definition.-ppLlvmBlock :: LlvmOpts -> LlvmBlock -> SDoc+ppLlvmBlock :: LlvmCgConfig -> LlvmBlock -> SDoc ppLlvmBlock opts (LlvmBlock blockId stmts) =   let isLabel (MkLabel _) = True       isLabel _           = False@@ -210,7 +209,7 @@   -- | Print out an LLVM statement.-ppLlvmStatement :: LlvmOpts -> LlvmStatement -> SDoc+ppLlvmStatement :: LlvmCgConfig -> LlvmStatement -> SDoc ppLlvmStatement opts stmt =   let ind = (text "  " <>)   in case stmt of@@ -231,7 +230,7 @@   -- | Print out an LLVM expression.-ppLlvmExpression :: LlvmOpts -> LlvmExpression -> SDoc+ppLlvmExpression :: LlvmCgConfig -> LlvmExpression -> SDoc ppLlvmExpression opts expr   = case expr of         Alloca     tp amount        -> ppAlloca opts tp amount@@ -253,7 +252,7 @@         Asm        asm c ty v se sk -> ppAsm opts asm c ty v se sk         MExpr      meta expr        -> ppMetaAnnotExpr opts meta expr -ppMetaExpr :: LlvmOpts -> MetaExpr -> SDoc+ppMetaExpr :: LlvmCgConfig -> MetaExpr -> SDoc ppMetaExpr opts = \case   MetaVar (LMLitVar (LMNullLit _)) -> text "null"   MetaStr    s                     -> char '!' <> doubleQuotes (ftext s)@@ -268,7 +267,7 @@  -- | Should always be a function pointer. So a global var of function type -- (since globals are always pointers) or a local var of pointer function type.-ppCall :: LlvmOpts -> LlvmCallType -> LlvmVar -> [MetaExpr] -> [LlvmFuncAttr] -> SDoc+ppCall :: LlvmCgConfig -> LlvmCallType -> LlvmVar -> [MetaExpr] -> [LlvmFuncAttr] -> SDoc ppCall opts ct fptr args attrs = case fptr of                            --     -- if local var function pointer, unwrap@@ -296,7 +295,7 @@                     <> fnty <+> ppName opts fptr <> lparen <+> ppValues                     <+> rparen <+> attrDoc -        ppCallParams :: LlvmOpts -> [[LlvmParamAttr]] -> [MetaExpr] -> SDoc+        ppCallParams :: LlvmCgConfig -> [[LlvmParamAttr]] -> [MetaExpr] -> SDoc         ppCallParams opts attrs args = hsep $ punctuate comma $ zipWith ppCallMetaExpr attrs args          where           -- Metadata needs to be marked as having the `metadata` type when used@@ -305,13 +304,13 @@           ppCallMetaExpr _ v             = text "metadata" <+> ppMetaExpr opts v  -ppMachOp :: LlvmOpts -> LlvmMachOp -> LlvmVar -> LlvmVar -> SDoc+ppMachOp :: LlvmCgConfig -> LlvmMachOp -> LlvmVar -> LlvmVar -> SDoc ppMachOp opts op left right =   (ppr op) <+> (ppr (getVarType left)) <+> ppName opts left         <> comma <+> ppName opts right  -ppCmpOp :: LlvmOpts -> LlvmCmpOp -> LlvmVar -> LlvmVar -> SDoc+ppCmpOp :: LlvmCgConfig -> LlvmCmpOp -> LlvmVar -> LlvmVar -> SDoc ppCmpOp opts op left right =   let cmpOp         | isInt (getVarType left) && isInt (getVarType right) = text "icmp"@@ -326,7 +325,7 @@         <+> ppName opts left <> comma <+> ppName opts right  -ppAssignment :: LlvmOpts -> LlvmVar -> SDoc -> SDoc+ppAssignment :: LlvmCgConfig -> LlvmVar -> SDoc -> SDoc ppAssignment opts var expr = ppName opts var <+> equals <+> expr  ppFence :: Bool -> LlvmSyncOrdering -> SDoc@@ -356,19 +355,19 @@ ppAtomicOp LAO_Umax = text "umax" ppAtomicOp LAO_Umin = text "umin" -ppAtomicRMW :: LlvmOpts -> LlvmAtomicOp -> LlvmVar -> LlvmVar -> LlvmSyncOrdering -> SDoc+ppAtomicRMW :: LlvmCgConfig -> LlvmAtomicOp -> LlvmVar -> LlvmVar -> LlvmSyncOrdering -> SDoc ppAtomicRMW opts aop tgt src ordering =   text "atomicrmw" <+> ppAtomicOp aop <+> ppVar opts tgt <> comma   <+> ppVar opts src <+> ppSyncOrdering ordering -ppCmpXChg :: LlvmOpts -> LlvmVar -> LlvmVar -> LlvmVar+ppCmpXChg :: LlvmCgConfig -> LlvmVar -> LlvmVar -> LlvmVar           -> LlvmSyncOrdering -> LlvmSyncOrdering -> SDoc ppCmpXChg opts addr old new s_ord f_ord =   text "cmpxchg" <+> ppVar opts addr <> comma <+> ppVar opts old <> comma <+> ppVar opts new   <+> ppSyncOrdering s_ord <+> ppSyncOrdering f_ord  -ppLoad :: LlvmOpts -> LlvmVar -> Maybe Int -> SDoc+ppLoad :: LlvmCgConfig -> LlvmVar -> LMAlign -> SDoc ppLoad opts var alignment =   text "load" <+> ppr derefType <> comma <+> ppVar opts var <> align   where@@ -378,9 +377,9 @@         Just n  -> text ", align" <+> ppr n         Nothing -> empty -ppALoad :: LlvmOpts -> LlvmSyncOrdering -> SingleThreaded -> LlvmVar -> SDoc+ppALoad :: LlvmCgConfig -> LlvmSyncOrdering -> SingleThreaded -> LlvmVar -> SDoc ppALoad opts ord st var =-  let alignment = (llvmWidthInBits (llvmOptsPlatform opts) $ getVarType var) `quot` 8+  let alignment = llvmWidthInBits (llvmCgPlatform opts) (getVarType var) `quot` 8       align     = text ", align" <+> ppr alignment       sThreaded | st        = text " singlethread"                 | otherwise = empty@@ -388,7 +387,7 @@   in text "load atomic" <+> ppr derefType <> comma <+> ppVar opts var <> sThreaded             <+> ppSyncOrdering ord <> align -ppStore :: LlvmOpts -> LlvmVar -> LlvmVar -> LMAlign -> SDoc+ppStore :: LlvmCgConfig -> LlvmVar -> LlvmVar -> LMAlign -> SDoc ppStore opts val dst alignment =     text "store" <+> ppVar opts val <> comma <+> ppVar opts dst <> align   where@@ -398,7 +397,7 @@         Nothing -> empty  -ppCast :: LlvmOpts -> LlvmCastOp -> LlvmVar -> LlvmType -> SDoc+ppCast :: LlvmCgConfig -> LlvmCastOp -> LlvmVar -> LlvmType -> SDoc ppCast opts op from to     =   ppr op     <+> ppr (getVarType from) <+> ppName opts from@@ -406,19 +405,19 @@     <+> ppr to  -ppMalloc :: LlvmOpts -> LlvmType -> Int -> SDoc+ppMalloc :: LlvmCgConfig -> LlvmType -> Int -> SDoc ppMalloc opts tp amount =   let amount' = LMLitVar $ LMIntLit (toInteger amount) i32   in text "malloc" <+> ppr tp <> comma <+> ppVar opts amount'  -ppAlloca :: LlvmOpts -> LlvmType -> Int -> SDoc+ppAlloca :: LlvmCgConfig -> LlvmType -> Int -> SDoc ppAlloca opts tp amount =   let amount' = LMLitVar $ LMIntLit (toInteger amount) i32   in text "alloca" <+> ppr tp <> comma <+> ppVar opts amount'  -ppGetElementPtr :: LlvmOpts -> Bool -> LlvmVar -> [LlvmVar] -> SDoc+ppGetElementPtr :: LlvmCgConfig -> Bool -> LlvmVar -> [LlvmVar] -> SDoc ppGetElementPtr opts inb ptr idx =   let indexes = comma <+> ppCommaJoin (map (ppVar opts) idx)       inbound = if inb then text "inbounds" else empty@@ -427,27 +426,27 @@                             <> indexes  -ppReturn :: LlvmOpts -> Maybe LlvmVar -> SDoc+ppReturn :: LlvmCgConfig -> Maybe LlvmVar -> SDoc ppReturn opts (Just var) = text "ret" <+> ppVar opts var ppReturn _    Nothing    = text "ret" <+> ppr LMVoid  -ppBranch :: LlvmOpts -> LlvmVar -> SDoc+ppBranch :: LlvmCgConfig -> LlvmVar -> SDoc ppBranch opts var = text "br" <+> ppVar opts var  -ppBranchIf :: LlvmOpts -> LlvmVar -> LlvmVar -> LlvmVar -> SDoc+ppBranchIf :: LlvmCgConfig -> LlvmVar -> LlvmVar -> LlvmVar -> SDoc ppBranchIf opts cond trueT falseT   = text "br" <+> ppVar opts cond <> comma <+> ppVar opts trueT <> comma <+> ppVar opts falseT  -ppPhi :: LlvmOpts -> LlvmType -> [(LlvmVar,LlvmVar)] -> SDoc+ppPhi :: LlvmCgConfig -> LlvmType -> [(LlvmVar,LlvmVar)] -> SDoc ppPhi opts tp preds =   let ppPreds (val, label) = brackets $ ppName opts val <> comma <+> ppName opts label   in text "phi" <+> ppr tp <+> hsep (punctuate comma $ map ppPreds preds)  -ppSwitch :: LlvmOpts -> LlvmVar -> LlvmVar -> [(LlvmVar,LlvmVar)] -> SDoc+ppSwitch :: LlvmCgConfig -> LlvmVar -> LlvmVar -> [(LlvmVar,LlvmVar)] -> SDoc ppSwitch opts scrut dflt targets =   let ppTarget  (val, lab) = ppVar opts val <> comma <+> ppVar opts lab       ppTargets  xs        = brackets $ vcat (map ppTarget xs)@@ -455,7 +454,7 @@         <+> ppTargets targets  -ppAsm :: LlvmOpts -> LMString -> LMString -> LlvmType -> [LlvmVar] -> Bool -> Bool -> SDoc+ppAsm :: LlvmCgConfig -> LMString -> LMString -> LlvmType -> [LlvmVar] -> Bool -> Bool -> SDoc ppAsm opts asm constraints rty vars sideeffect alignstack =   let asm'  = doubleQuotes $ ftext asm       cons  = doubleQuotes $ ftext constraints@@ -466,19 +465,19 @@   in text "call" <+> rty' <+> text "asm" <+> side <+> align <+> asm' <> comma         <+> cons <> vars' -ppExtract :: LlvmOpts -> LlvmVar -> LlvmVar -> SDoc+ppExtract :: LlvmCgConfig -> LlvmVar -> LlvmVar -> SDoc ppExtract opts vec idx =     text "extractelement"     <+> ppr (getVarType vec) <+> ppName opts vec <> comma     <+> ppVar opts idx -ppExtractV :: LlvmOpts -> LlvmVar -> Int -> SDoc+ppExtractV :: LlvmCgConfig -> LlvmVar -> Int -> SDoc ppExtractV opts struct idx =     text "extractvalue"     <+> ppr (getVarType struct) <+> ppName opts struct <> comma     <+> ppr idx -ppInsert :: LlvmOpts -> LlvmVar -> LlvmVar -> LlvmVar -> SDoc+ppInsert :: LlvmCgConfig -> LlvmVar -> LlvmVar -> LlvmVar -> SDoc ppInsert opts vec elt idx =     text "insertelement"     <+> ppr (getVarType vec) <+> ppName opts vec <> comma@@ -486,15 +485,15 @@     <+> ppVar opts idx  -ppMetaStatement :: LlvmOpts -> [MetaAnnot] -> LlvmStatement -> SDoc+ppMetaStatement :: LlvmCgConfig -> [MetaAnnot] -> LlvmStatement -> SDoc ppMetaStatement opts meta stmt =    ppLlvmStatement opts stmt <> ppMetaAnnots opts meta -ppMetaAnnotExpr :: LlvmOpts -> [MetaAnnot] -> LlvmExpression -> SDoc+ppMetaAnnotExpr :: LlvmCgConfig -> [MetaAnnot] -> LlvmExpression -> SDoc ppMetaAnnotExpr opts meta expr =    ppLlvmExpression opts expr <> ppMetaAnnots opts meta -ppMetaAnnots :: LlvmOpts -> [MetaAnnot] -> SDoc+ppMetaAnnots :: LlvmCgConfig -> [MetaAnnot] -> SDoc ppMetaAnnots opts meta = hcat $ map ppMeta meta   where     ppMeta (MetaAnnot name e)@@ -506,7 +505,7 @@  -- | Return the variable name or value of the 'LlvmVar' -- in Llvm IR textual representation (e.g. @\@x@, @%y@ or @42@).-ppName :: LlvmOpts -> LlvmVar -> SDoc+ppName :: LlvmCgConfig -> LlvmVar -> SDoc ppName opts v = case v of    LMGlobalVar {} -> char '@' <> ppPlainName opts v    LMLocalVar  {} -> char '%' <> ppPlainName opts v@@ -515,7 +514,7 @@  -- | Return the variable name or value of the 'LlvmVar' -- in a plain textual representation (e.g. @x@, @y@ or @42@).-ppPlainName :: LlvmOpts -> LlvmVar -> SDoc+ppPlainName :: LlvmCgConfig -> LlvmVar -> SDoc ppPlainName opts v = case v of    (LMGlobalVar x _ _ _ _ _) -> ftext x    (LMLocalVar  x LMLabel  ) -> text (show x)@@ -524,13 +523,13 @@    (LMLitVar    x          ) -> ppLit opts x  -- | Print a literal value. No type.-ppLit :: LlvmOpts -> LlvmLit -> SDoc+ppLit :: LlvmCgConfig -> LlvmLit -> SDoc ppLit opts l = case l of    (LMIntLit i (LMInt 32))  -> ppr (fromInteger i :: Int32)    (LMIntLit i (LMInt 64))  -> ppr (fromInteger i :: Int64)    (LMIntLit   i _       )  -> ppr ((fromInteger i)::Int)-   (LMFloatLit r LMFloat )  -> ppFloat (llvmOptsPlatform opts) $ narrowFp r-   (LMFloatLit r LMDouble)  -> ppDouble (llvmOptsPlatform opts) r+   (LMFloatLit r LMFloat )  -> ppFloat (llvmCgPlatform opts) $ narrowFp r+   (LMFloatLit r LMDouble)  -> ppDouble (llvmCgPlatform opts) r    f@(LMFloatLit _ _)       -> pprPanic "ppLit" (text "Can't print this float literal: " <> ppTypeLit opts f)    (LMVectorLit ls  )       -> char '<' <+> ppCommaJoin (map (ppTypeLit opts) ls) <+> char '>'    (LMNullLit _     )       -> text "null"@@ -542,27 +541,27 @@    -- common types) with values that are likely to cause a crash or test    -- failure.    (LMUndefLit t    )-      | llvmOptsFillUndefWithGarbage opts+      | llvmCgFillUndefWithGarbage opts       , Just lit <- garbageLit t   -> ppLit opts lit       | otherwise                  -> text "undef" -ppVar :: LlvmOpts -> LlvmVar -> SDoc+ppVar :: LlvmCgConfig -> LlvmVar -> SDoc ppVar = ppVar' [] -ppVar' :: [LlvmParamAttr] -> LlvmOpts -> LlvmVar -> SDoc+ppVar' :: [LlvmParamAttr] -> LlvmCgConfig -> LlvmVar -> SDoc ppVar' attrs opts v = case v of   LMLitVar x -> ppTypeLit' attrs opts x   x          -> ppr (getVarType x) <+> ppSpaceJoin attrs <+> ppName opts x -ppTypeLit :: LlvmOpts -> LlvmLit -> SDoc+ppTypeLit :: LlvmCgConfig -> LlvmLit -> SDoc ppTypeLit = ppTypeLit' [] -ppTypeLit' :: [LlvmParamAttr] -> LlvmOpts -> LlvmLit -> SDoc+ppTypeLit' :: [LlvmParamAttr] -> LlvmCgConfig -> LlvmLit -> SDoc ppTypeLit' attrs opts l = case l of   LMVectorLit {} -> ppLit opts l   _              -> ppr (getLitType l) <+> ppSpaceJoin attrs <+> ppLit opts l -ppStatic :: LlvmOpts -> LlvmStatic -> SDoc+ppStatic :: LlvmCgConfig -> LlvmStatic -> SDoc ppStatic opts st = case st of   LMComment       s -> text "; " <> ftext s   LMStaticLit   l   -> ppTypeLit opts l@@ -570,15 +569,16 @@   LMStaticStr   s t -> ppr t <> text " c\"" <> ftext s <> text "\\00\""   LMStaticArray d t -> ppr t <> text " [" <> ppCommaJoin (map (ppStatic opts) d) <> char ']'   LMStaticStruc d t -> ppr t <> text "<{" <> ppCommaJoin (map (ppStatic opts) d) <> text "}>"+  LMStaticStrucU d t -> ppr t <> text "{" <> ppCommaJoin (map (ppStatic opts) d) <> text "}"   LMStaticPointer v -> ppVar opts v   LMTrunc v t       -> ppr t <> text " trunc (" <> ppStatic opts v <> text " to " <> ppr t <> char ')'   LMBitc v t        -> ppr t <> text " bitcast (" <> ppStatic opts v <> text " to " <> ppr t <> char ')'   LMPtoI v t        -> ppr t <> text " ptrtoint (" <> ppStatic opts v <> text " to " <> ppr t <> char ')'-  LMAdd s1 s2       -> pprStaticArith opts s1 s2 (sLit "add") (sLit "fadd") "LMAdd"-  LMSub s1 s2       -> pprStaticArith opts s1 s2 (sLit "sub") (sLit "fsub") "LMSub"+  LMAdd s1 s2       -> pprStaticArith opts s1 s2 (text "add") (text "fadd") (text "LMAdd")+  LMSub s1 s2       -> pprStaticArith opts s1 s2 (text "sub") (text "fsub") (text "LMSub")  -pprSpecialStatic :: LlvmOpts -> LlvmStatic -> SDoc+pprSpecialStatic :: LlvmCgConfig -> LlvmStatic -> SDoc pprSpecialStatic opts stat = case stat of    LMBitc v t        -> ppr (pLower t)                         <> text ", bitcast ("@@ -589,15 +589,15 @@    _                 -> ppStatic opts stat  -pprStaticArith :: LlvmOpts -> LlvmStatic -> LlvmStatic -> PtrString -> PtrString-                  -> String -> SDoc+pprStaticArith :: LlvmCgConfig -> LlvmStatic -> LlvmStatic -> SDoc -> SDoc+                  -> SDoc -> SDoc pprStaticArith opts s1 s2 int_op float_op op_name =   let ty1 = getStatType s1       op  = if isFloat ty1 then float_op else int_op   in if ty1 == getStatType s2-     then ppr ty1 <+> ptext op <+> lparen <> ppStatic opts s1 <> comma <> ppStatic opts s2 <> rparen+     then ppr ty1 <+> op <+> lparen <> ppStatic opts s1 <> comma <> ppStatic opts s2 <> rparen      else pprPanic "pprStaticArith" $-            text op_name <> text " with different types! s1: " <> ppStatic opts s1+                 op_name <> text " with different types! s1: " <> ppStatic opts s1                          <> text", s2: " <> ppStatic opts s2
GHC/Llvm/Types.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP        #-}+ {-# LANGUAGE LambdaCase #-}  --------------------------------------------------------------------------------@@ -7,15 +7,12 @@  module GHC.Llvm.Types where -#include "HsVersions.h"- import GHC.Prelude  import Data.Char import Numeric  import GHC.Platform-import GHC.Driver.Session import GHC.Data.FastString import GHC.Utils.Outputable import GHC.Utils.Panic@@ -88,12 +85,12 @@ ppParams :: LlvmParameterListType -> [LlvmParameter] -> SDoc ppParams varg p   = let varg' = case varg of-          VarArgs | null args -> sLit "..."-                  | otherwise -> sLit ", ..."-          _otherwise          -> sLit ""+          VarArgs | null args -> text "..."+                  | otherwise -> text ", ..."+          _otherwise          -> text ""         -- by default we don't print param attributes         args = map fst p-    in ppCommaJoin args <> ptext varg'+    in ppCommaJoin args <> varg'  -- | An LLVM section definition. If Nothing then let LLVM decide the section type LMSection = Maybe LMString@@ -143,6 +140,7 @@   | LMStaticStr LMString LlvmType       -- ^ Defines a static 'LMString'   | LMStaticArray [LlvmStatic] LlvmType -- ^ A static array   | LMStaticStruc [LlvmStatic] LlvmType -- ^ A static structure type+  | LMStaticStrucU [LlvmStatic] LlvmType -- ^ A static structure type   | LMStaticPointer LlvmVar             -- ^ A pointer to other data    -- static expressions, could split out but leave@@ -158,21 +156,6 @@ -- ** Operations on LLVM Basic Types and Variables -- --- | LLVM code generator options-data LlvmOpts = LlvmOpts-   { llvmOptsPlatform             :: !Platform -- ^ Target platform-   , llvmOptsFillUndefWithGarbage :: !Bool     -- ^ Fill undefined literals with garbage values-   , llvmOptsSplitSections        :: !Bool     -- ^ Split sections-   }---- | Get LlvmOptions from DynFlags-initLlvmOpts :: DynFlags -> LlvmOpts-initLlvmOpts dflags = LlvmOpts-   { llvmOptsPlatform             = targetPlatform dflags-   , llvmOptsFillUndefWithGarbage = gopt Opt_LlvmFillUndefWithGarbage dflags-   , llvmOptsSplitSections        = gopt Opt_SplitSections dflags-   }- garbageLit :: LlvmType -> Maybe LlvmLit garbageLit t@(LMInt w)     = Just (LMIntLit (0xbbbbbbbbbbbbbbb0 `mod` (2^w)) t)   -- Use a value that looks like an untagged pointer, so we are more@@ -209,6 +192,7 @@ getStatType (LMStaticStr   _ t) = t getStatType (LMStaticArray _ t) = t getStatType (LMStaticStruc _ t) = t+getStatType (LMStaticStrucU _ t) = t getStatType (LMStaticPointer v) = getVarType v getStatType (LMTrunc       _ t) = t getStatType (LMBitc        _ t) = t
+ GHC/Parser.hs view
@@ -0,0 +1,13288 @@+{-# OPTIONS_GHC -w #-}+{-# OPTIONS -XMagicHash -XBangPatterns -XTypeSynonymInstances -XFlexibleInstances -cpp #-}+#if __GLASGOW_HASKELL__ >= 710+{-# OPTIONS_GHC -XPartialTypeSignatures #-}+#endif+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | This module provides the generated Happy parser for Haskell. It exports+-- a number of parsers which may be used in any library that uses the GHC API.+-- A common usage pattern is to initialize the parser state with a given string+-- and then parse that string:+--+-- @+--     runParser :: ParserOpts -> String -> P a -> ParseResult a+--     runParser opts str parser = unP parser parseState+--     where+--       filename = "\<interactive\>"+--       location = mkRealSrcLoc (mkFastString filename) 1 1+--       buffer = stringToStringBuffer str+--       parseState = initParserState opts buffer location+-- @+module GHC.Parser+   ( parseModule, parseSignature, parseImport, parseStatement, parseBackpack+   , parseDeclaration, parseExpression, parsePattern+   , parseTypeSignature+   , parseStmt, parseIdentifier+   , parseType, parseHeader+   , parseModuleNoHaddock+   )+where++-- base+import Control.Monad    ( unless, liftM, when, (<=<) )+import GHC.Exts+import Data.Maybe       ( maybeToList )+import Data.List.NonEmpty ( NonEmpty(..) )+import qualified Data.List.NonEmpty as NE+import qualified Prelude -- for happy-generated code++import GHC.Hs++import GHC.Driver.Backpack.Syntax++import GHC.Unit.Info+import GHC.Unit.Module+import GHC.Unit.Module.Warnings++import GHC.Data.OrdList+import GHC.Data.BooleanFormula ( BooleanFormula(..), LBooleanFormula, mkTrue )+import GHC.Data.FastString+import GHC.Data.Maybe          ( orElse )++import GHC.Utils.Outputable+import GHC.Utils.Error+import GHC.Utils.Misc          ( looksLikePackageName, fstOf3, sndOf3, thdOf3 )+import GHC.Utils.Panic+import GHC.Prelude+import qualified GHC.Data.Strict as Strict++import GHC.Types.Name.Reader+import GHC.Types.Name.Occurrence ( varName, dataName, tcClsName, tvName, occNameFS, mkVarOcc, occNameString)+import GHC.Types.SrcLoc+import GHC.Types.Basic+import GHC.Types.Error ( GhcHint(..) )+import GHC.Types.Fixity+import GHC.Types.ForeignCall+import GHC.Types.SourceFile+import GHC.Types.SourceText+import GHC.Types.PkgQual++import GHC.Core.Type    ( unrestrictedFunTyCon, Specificity(..) )+import GHC.Core.Class   ( FunDep )+import GHC.Core.DataCon ( DataCon, dataConName )++import GHC.Parser.PostProcess+import GHC.Parser.PostProcess.Haddock+import GHC.Parser.Lexer+import GHC.Parser.HaddockLex+import GHC.Parser.Annotation+import GHC.Parser.Errors.Types+import GHC.Parser.Errors.Ppr ()++import GHC.Builtin.Types ( unitTyCon, unitDataCon, sumTyCon,+                           tupleTyCon, tupleDataCon, nilDataCon,+                           unboxedUnitTyCon, unboxedUnitDataCon,+                           listTyCon_RDR, consDataCon_RDR)++import qualified Data.Semigroup as Semi+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.0++newtype HappyAbsSyn  = HappyAbsSyn HappyAny+#if __GLASGOW_HASKELL__ >= 607+type HappyAny = Happy_GHC_Exts.Any+#else+type HappyAny = forall a . a+#endif+newtype HappyWrap16 = HappyWrap16 (LocatedN RdrName)+happyIn16 :: (LocatedN RdrName) -> (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 ([LHsUnit PackageName])+happyIn17 :: ([LHsUnit PackageName]) -> (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 (OrdList (LHsUnit PackageName))+happyIn18 :: (OrdList (LHsUnit PackageName)) -> (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 (LHsUnit PackageName)+happyIn19 :: (LHsUnit PackageName) -> (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 (LHsUnitId PackageName)+happyIn20 :: (LHsUnitId PackageName) -> (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 (OrdList (LHsModuleSubst PackageName))+happyIn21 :: (OrdList (LHsModuleSubst PackageName)) -> (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 (LHsModuleSubst PackageName)+happyIn22 :: (LHsModuleSubst PackageName) -> (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 (LHsModuleId PackageName)+happyIn23 :: (LHsModuleId PackageName) -> (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 (Located PackageName)+happyIn24 :: (Located PackageName) -> (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 (Located FastString)+happyIn25 :: (Located FastString) -> (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 ([AddEpAnn])+happyIn26 :: ([AddEpAnn]) -> (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 (Located FastString)+happyIn27 :: (Located FastString) -> (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 (Maybe [LRenaming])+happyIn28 :: (Maybe [LRenaming]) -> (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 (OrdList LRenaming)+happyIn29 :: (OrdList LRenaming) -> (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 (LRenaming)+happyIn30 :: (LRenaming) -> (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 (OrdList (LHsUnitDecl PackageName))+happyIn31 :: (OrdList (LHsUnitDecl PackageName)) -> (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 (OrdList (LHsUnitDecl PackageName))+happyIn32 :: (OrdList (LHsUnitDecl PackageName)) -> (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 (LHsUnitDecl PackageName)+happyIn33 :: (LHsUnitDecl PackageName) -> (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 (Located HsModule)+happyIn34 :: (Located HsModule) -> (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 (Located HsModule)+happyIn35 :: (Located HsModule) -> (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 (())+happyIn36 :: (()) -> (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 (())+happyIn37 :: (()) -> (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 (LocatedP (WarningTxt GhcPs)))+happyIn38 :: (Maybe (LocatedP (WarningTxt GhcPs))) -> (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 ((AnnList+             ,([LImportDecl GhcPs], [LHsDecl GhcPs])+             ,LayoutInfo))+happyIn39 :: ((AnnList+             ,([LImportDecl GhcPs], [LHsDecl GhcPs])+             ,LayoutInfo)) -> (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 ((AnnList+             ,([LImportDecl GhcPs], [LHsDecl GhcPs])+             ,LayoutInfo))+happyIn40 :: ((AnnList+             ,([LImportDecl GhcPs], [LHsDecl GhcPs])+             ,LayoutInfo)) -> (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 (([TrailingAnn]+             ,([LImportDecl GhcPs], [LHsDecl GhcPs])))+happyIn41 :: (([TrailingAnn]+             ,([LImportDecl GhcPs], [LHsDecl GhcPs]))) -> (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 (([LImportDecl GhcPs], [LHsDecl GhcPs]))+happyIn42 :: (([LImportDecl GhcPs], [LHsDecl GhcPs])) -> (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 (Located HsModule)+happyIn43 :: (Located HsModule) -> (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 ([LImportDecl GhcPs])+happyIn44 :: ([LImportDecl GhcPs]) -> (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 ([LImportDecl GhcPs])+happyIn45 :: ([LImportDecl GhcPs]) -> (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 ([LImportDecl GhcPs])+happyIn46 :: ([LImportDecl GhcPs]) -> (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 ([LImportDecl GhcPs])+happyIn47 :: ([LImportDecl GhcPs]) -> (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 ((Maybe (LocatedL [LIE GhcPs])))+happyIn48 :: ((Maybe (LocatedL [LIE GhcPs]))) -> (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 (([AddEpAnn], OrdList (LIE GhcPs)))+happyIn49 :: (([AddEpAnn], OrdList (LIE GhcPs))) -> (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 (OrdList (LIE GhcPs))+happyIn50 :: (OrdList (LIE GhcPs)) -> (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 (OrdList (LIE GhcPs))+happyIn51 :: (OrdList (LIE GhcPs)) -> (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 (Located ([AddEpAnn],ImpExpSubSpec))+happyIn52 :: (Located ([AddEpAnn],ImpExpSubSpec)) -> (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 (([AddEpAnn], [LocatedA ImpExpQcSpec]))+happyIn53 :: (([AddEpAnn], [LocatedA ImpExpQcSpec])) -> (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 (([AddEpAnn], [LocatedA ImpExpQcSpec]))+happyIn54 :: (([AddEpAnn], [LocatedA ImpExpQcSpec])) -> (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 (Located ([AddEpAnn], LocatedA ImpExpQcSpec))+happyIn55 :: (Located ([AddEpAnn], LocatedA ImpExpQcSpec)) -> (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 (LocatedA ImpExpQcSpec)+happyIn56 :: (LocatedA ImpExpQcSpec) -> (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 (LocatedN RdrName)+happyIn57 :: (LocatedN RdrName) -> (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 (Located [TrailingAnn])+happyIn58 :: (Located [TrailingAnn]) -> (HappyAbsSyn )+happyIn58 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap58 x)+{-# INLINE happyIn58 #-}+happyOut58 :: (HappyAbsSyn ) -> HappyWrap58+happyOut58 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut58 #-}+newtype HappyWrap59 = HappyWrap59 ([TrailingAnn])+happyIn59 :: ([TrailingAnn]) -> (HappyAbsSyn )+happyIn59 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap59 x)+{-# INLINE happyIn59 #-}+happyOut59 :: (HappyAbsSyn ) -> HappyWrap59+happyOut59 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut59 #-}+newtype HappyWrap60 = HappyWrap60 ([LImportDecl GhcPs])+happyIn60 :: ([LImportDecl GhcPs]) -> (HappyAbsSyn )+happyIn60 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap60 x)+{-# INLINE happyIn60 #-}+happyOut60 :: (HappyAbsSyn ) -> HappyWrap60+happyOut60 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut60 #-}+newtype HappyWrap61 = HappyWrap61 ([LImportDecl GhcPs])+happyIn61 :: ([LImportDecl GhcPs]) -> (HappyAbsSyn )+happyIn61 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap61 x)+{-# INLINE happyIn61 #-}+happyOut61 :: (HappyAbsSyn ) -> HappyWrap61+happyOut61 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut61 #-}+newtype HappyWrap62 = HappyWrap62 (LImportDecl GhcPs)+happyIn62 :: (LImportDecl GhcPs) -> (HappyAbsSyn )+happyIn62 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap62 x)+{-# INLINE happyIn62 #-}+happyOut62 :: (HappyAbsSyn ) -> HappyWrap62+happyOut62 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut62 #-}+newtype HappyWrap63 = HappyWrap63 (((Maybe (EpaLocation,EpaLocation),SourceText),IsBootInterface))+happyIn63 :: (((Maybe (EpaLocation,EpaLocation),SourceText),IsBootInterface)) -> (HappyAbsSyn )+happyIn63 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap63 x)+{-# INLINE happyIn63 #-}+happyOut63 :: (HappyAbsSyn ) -> HappyWrap63+happyOut63 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut63 #-}+newtype HappyWrap64 = HappyWrap64 ((Maybe EpaLocation,Bool))+happyIn64 :: ((Maybe EpaLocation,Bool)) -> (HappyAbsSyn )+happyIn64 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap64 x)+{-# INLINE happyIn64 #-}+happyOut64 :: (HappyAbsSyn ) -> HappyWrap64+happyOut64 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut64 #-}+newtype HappyWrap65 = HappyWrap65 ((Maybe EpaLocation, RawPkgQual))+happyIn65 :: ((Maybe EpaLocation, RawPkgQual)) -> (HappyAbsSyn )+happyIn65 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap65 x)+{-# INLINE happyIn65 #-}+happyOut65 :: (HappyAbsSyn ) -> HappyWrap65+happyOut65 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut65 #-}+newtype HappyWrap66 = HappyWrap66 (Located (Maybe EpaLocation))+happyIn66 :: (Located (Maybe EpaLocation)) -> (HappyAbsSyn )+happyIn66 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap66 x)+{-# INLINE happyIn66 #-}+happyOut66 :: (HappyAbsSyn ) -> HappyWrap66+happyOut66 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut66 #-}+newtype HappyWrap67 = HappyWrap67 ((Maybe EpaLocation,Located (Maybe (LocatedA ModuleName))))+happyIn67 :: ((Maybe EpaLocation,Located (Maybe (LocatedA ModuleName)))) -> (HappyAbsSyn )+happyIn67 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap67 x)+{-# INLINE happyIn67 #-}+happyOut67 :: (HappyAbsSyn ) -> HappyWrap67+happyOut67 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut67 #-}+newtype HappyWrap68 = HappyWrap68 (Located (Maybe (Bool, LocatedL [LIE GhcPs])))+happyIn68 :: (Located (Maybe (Bool, LocatedL [LIE GhcPs]))) -> (HappyAbsSyn )+happyIn68 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap68 x)+{-# INLINE happyIn68 #-}+happyOut68 :: (HappyAbsSyn ) -> HappyWrap68+happyOut68 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut68 #-}+newtype HappyWrap69 = HappyWrap69 (Located (Bool, LocatedL [LIE GhcPs]))+happyIn69 :: (Located (Bool, LocatedL [LIE GhcPs])) -> (HappyAbsSyn )+happyIn69 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap69 x)+{-# INLINE happyIn69 #-}+happyOut69 :: (HappyAbsSyn ) -> HappyWrap69+happyOut69 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut69 #-}+newtype HappyWrap70 = HappyWrap70 (Maybe (Located (SourceText,Int)))+happyIn70 :: (Maybe (Located (SourceText,Int))) -> (HappyAbsSyn )+happyIn70 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap70 x)+{-# INLINE happyIn70 #-}+happyOut70 :: (HappyAbsSyn ) -> HappyWrap70+happyOut70 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut70 #-}+newtype HappyWrap71 = HappyWrap71 (Located FixityDirection)+happyIn71 :: (Located FixityDirection) -> (HappyAbsSyn )+happyIn71 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap71 x)+{-# INLINE happyIn71 #-}+happyOut71 :: (HappyAbsSyn ) -> HappyWrap71+happyOut71 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut71 #-}+newtype HappyWrap72 = HappyWrap72 (Located (OrdList (LocatedN RdrName)))+happyIn72 :: (Located (OrdList (LocatedN RdrName))) -> (HappyAbsSyn )+happyIn72 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap72 x)+{-# INLINE happyIn72 #-}+happyOut72 :: (HappyAbsSyn ) -> HappyWrap72+happyOut72 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut72 #-}+newtype HappyWrap73 = HappyWrap73 (OrdList (LHsDecl GhcPs))+happyIn73 :: (OrdList (LHsDecl GhcPs)) -> (HappyAbsSyn )+happyIn73 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap73 x)+{-# INLINE happyIn73 #-}+happyOut73 :: (HappyAbsSyn ) -> HappyWrap73+happyOut73 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut73 #-}+newtype HappyWrap74 = HappyWrap74 (OrdList (LHsDecl GhcPs))+happyIn74 :: (OrdList (LHsDecl GhcPs)) -> (HappyAbsSyn )+happyIn74 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap74 x)+{-# INLINE happyIn74 #-}+happyOut74 :: (HappyAbsSyn ) -> HappyWrap74+happyOut74 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut74 #-}+newtype HappyWrap75 = HappyWrap75 (OrdList (LHsDecl GhcPs))+happyIn75 :: (OrdList (LHsDecl GhcPs)) -> (HappyAbsSyn )+happyIn75 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap75 x)+{-# INLINE happyIn75 #-}+happyOut75 :: (HappyAbsSyn ) -> HappyWrap75+happyOut75 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut75 #-}+newtype HappyWrap76 = HappyWrap76 (OrdList (LHsDecl GhcPs))+happyIn76 :: (OrdList (LHsDecl GhcPs)) -> (HappyAbsSyn )+happyIn76 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap76 x)+{-# INLINE happyIn76 #-}+happyOut76 :: (HappyAbsSyn ) -> HappyWrap76+happyOut76 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut76 #-}+newtype HappyWrap77 = HappyWrap77 (LHsDecl GhcPs)+happyIn77 :: (LHsDecl GhcPs) -> (HappyAbsSyn )+happyIn77 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap77 x)+{-# INLINE happyIn77 #-}+happyOut77 :: (HappyAbsSyn ) -> HappyWrap77+happyOut77 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut77 #-}+newtype HappyWrap78 = HappyWrap78 (LHsDecl GhcPs)+happyIn78 :: (LHsDecl GhcPs) -> (HappyAbsSyn )+happyIn78 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap78 x)+{-# INLINE happyIn78 #-}+happyOut78 :: (HappyAbsSyn ) -> HappyWrap78+happyOut78 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut78 #-}+newtype HappyWrap79 = HappyWrap79 (LTyClDecl GhcPs)+happyIn79 :: (LTyClDecl GhcPs) -> (HappyAbsSyn )+happyIn79 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap79 x)+{-# INLINE happyIn79 #-}+happyOut79 :: (HappyAbsSyn ) -> HappyWrap79+happyOut79 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut79 #-}+newtype HappyWrap80 = HappyWrap80 (LTyClDecl GhcPs)+happyIn80 :: (LTyClDecl GhcPs) -> (HappyAbsSyn )+happyIn80 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap80 x)+{-# INLINE happyIn80 #-}+happyOut80 :: (HappyAbsSyn ) -> HappyWrap80+happyOut80 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut80 #-}+newtype HappyWrap81 = HappyWrap81 (LStandaloneKindSig GhcPs)+happyIn81 :: (LStandaloneKindSig GhcPs) -> (HappyAbsSyn )+happyIn81 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap81 x)+{-# INLINE happyIn81 #-}+happyOut81 :: (HappyAbsSyn ) -> HappyWrap81+happyOut81 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut81 #-}+newtype HappyWrap82 = HappyWrap82 (Located [LocatedN RdrName])+happyIn82 :: (Located [LocatedN RdrName]) -> (HappyAbsSyn )+happyIn82 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap82 x)+{-# INLINE happyIn82 #-}+happyOut82 :: (HappyAbsSyn ) -> HappyWrap82+happyOut82 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut82 #-}+newtype HappyWrap83 = HappyWrap83 (LInstDecl GhcPs)+happyIn83 :: (LInstDecl GhcPs) -> (HappyAbsSyn )+happyIn83 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap83 x)+{-# INLINE happyIn83 #-}+happyOut83 :: (HappyAbsSyn ) -> HappyWrap83+happyOut83 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut83 #-}+newtype HappyWrap84 = HappyWrap84 (Maybe (LocatedP OverlapMode))+happyIn84 :: (Maybe (LocatedP OverlapMode)) -> (HappyAbsSyn )+happyIn84 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap84 x)+{-# INLINE happyIn84 #-}+happyOut84 :: (HappyAbsSyn ) -> HappyWrap84+happyOut84 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut84 #-}+newtype HappyWrap85 = HappyWrap85 (LDerivStrategy GhcPs)+happyIn85 :: (LDerivStrategy GhcPs) -> (HappyAbsSyn )+happyIn85 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap85 x)+{-# INLINE happyIn85 #-}+happyOut85 :: (HappyAbsSyn ) -> HappyWrap85+happyOut85 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut85 #-}+newtype HappyWrap86 = HappyWrap86 (LDerivStrategy GhcPs)+happyIn86 :: (LDerivStrategy GhcPs) -> (HappyAbsSyn )+happyIn86 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap86 x)+{-# INLINE happyIn86 #-}+happyOut86 :: (HappyAbsSyn ) -> HappyWrap86+happyOut86 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut86 #-}+newtype HappyWrap87 = HappyWrap87 (Maybe (LDerivStrategy GhcPs))+happyIn87 :: (Maybe (LDerivStrategy GhcPs)) -> (HappyAbsSyn )+happyIn87 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap87 x)+{-# INLINE happyIn87 #-}+happyOut87 :: (HappyAbsSyn ) -> HappyWrap87+happyOut87 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut87 #-}+newtype HappyWrap88 = HappyWrap88 (Located ([AddEpAnn], Maybe (LInjectivityAnn GhcPs)))+happyIn88 :: (Located ([AddEpAnn], Maybe (LInjectivityAnn GhcPs))) -> (HappyAbsSyn )+happyIn88 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap88 x)+{-# INLINE happyIn88 #-}+happyOut88 :: (HappyAbsSyn ) -> HappyWrap88+happyOut88 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut88 #-}+newtype HappyWrap89 = HappyWrap89 (LInjectivityAnn GhcPs)+happyIn89 :: (LInjectivityAnn GhcPs) -> (HappyAbsSyn )+happyIn89 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap89 x)+{-# INLINE happyIn89 #-}+happyOut89 :: (HappyAbsSyn ) -> HappyWrap89+happyOut89 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut89 #-}+newtype HappyWrap90 = HappyWrap90 (Located [LocatedN RdrName])+happyIn90 :: (Located [LocatedN RdrName]) -> (HappyAbsSyn )+happyIn90 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap90 x)+{-# INLINE happyIn90 #-}+happyOut90 :: (HappyAbsSyn ) -> HappyWrap90+happyOut90 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut90 #-}+newtype HappyWrap91 = HappyWrap91 (Located ([AddEpAnn],FamilyInfo GhcPs))+happyIn91 :: (Located ([AddEpAnn],FamilyInfo GhcPs)) -> (HappyAbsSyn )+happyIn91 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap91 x)+{-# INLINE happyIn91 #-}+happyOut91 :: (HappyAbsSyn ) -> HappyWrap91+happyOut91 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut91 #-}+newtype HappyWrap92 = HappyWrap92 (Located ([AddEpAnn],Maybe [LTyFamInstEqn GhcPs]))+happyIn92 :: (Located ([AddEpAnn],Maybe [LTyFamInstEqn GhcPs])) -> (HappyAbsSyn )+happyIn92 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap92 x)+{-# INLINE happyIn92 #-}+happyOut92 :: (HappyAbsSyn ) -> HappyWrap92+happyOut92 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut92 #-}+newtype HappyWrap93 = HappyWrap93 (Located [LTyFamInstEqn GhcPs])+happyIn93 :: (Located [LTyFamInstEqn GhcPs]) -> (HappyAbsSyn )+happyIn93 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap93 x)+{-# INLINE happyIn93 #-}+happyOut93 :: (HappyAbsSyn ) -> HappyWrap93+happyOut93 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut93 #-}+newtype HappyWrap94 = HappyWrap94 (LTyFamInstEqn GhcPs)+happyIn94 :: (LTyFamInstEqn GhcPs) -> (HappyAbsSyn )+happyIn94 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap94 x)+{-# INLINE happyIn94 #-}+happyOut94 :: (HappyAbsSyn ) -> HappyWrap94+happyOut94 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut94 #-}+newtype HappyWrap95 = HappyWrap95 (LHsDecl GhcPs)+happyIn95 :: (LHsDecl GhcPs) -> (HappyAbsSyn )+happyIn95 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap95 x)+{-# INLINE happyIn95 #-}+happyOut95 :: (HappyAbsSyn ) -> HappyWrap95+happyOut95 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut95 #-}+newtype HappyWrap96 = HappyWrap96 ([AddEpAnn])+happyIn96 :: ([AddEpAnn]) -> (HappyAbsSyn )+happyIn96 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap96 x)+{-# INLINE happyIn96 #-}+happyOut96 :: (HappyAbsSyn ) -> HappyWrap96+happyOut96 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut96 #-}+newtype HappyWrap97 = HappyWrap97 ([AddEpAnn])+happyIn97 :: ([AddEpAnn]) -> (HappyAbsSyn )+happyIn97 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap97 x)+{-# INLINE happyIn97 #-}+happyOut97 :: (HappyAbsSyn ) -> HappyWrap97+happyOut97 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut97 #-}+newtype HappyWrap98 = HappyWrap98 (LInstDecl GhcPs)+happyIn98 :: (LInstDecl GhcPs) -> (HappyAbsSyn )+happyIn98 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap98 x)+{-# INLINE happyIn98 #-}+happyOut98 :: (HappyAbsSyn ) -> HappyWrap98+happyOut98 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut98 #-}+newtype HappyWrap99 = HappyWrap99 (Located (AddEpAnn, NewOrData))+happyIn99 :: (Located (AddEpAnn, NewOrData)) -> (HappyAbsSyn )+happyIn99 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap99 x)+{-# INLINE happyIn99 #-}+happyOut99 :: (HappyAbsSyn ) -> HappyWrap99+happyOut99 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut99 #-}+newtype HappyWrap100 = HappyWrap100 (Located ([AddEpAnn], Maybe (LHsKind GhcPs)))+happyIn100 :: (Located ([AddEpAnn], Maybe (LHsKind GhcPs))) -> (HappyAbsSyn )+happyIn100 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap100 x)+{-# INLINE happyIn100 #-}+happyOut100 :: (HappyAbsSyn ) -> HappyWrap100+happyOut100 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut100 #-}+newtype HappyWrap101 = HappyWrap101 (Located ([AddEpAnn], LFamilyResultSig GhcPs))+happyIn101 :: (Located ([AddEpAnn], LFamilyResultSig GhcPs)) -> (HappyAbsSyn )+happyIn101 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap101 x)+{-# INLINE happyIn101 #-}+happyOut101 :: (HappyAbsSyn ) -> HappyWrap101+happyOut101 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut101 #-}+newtype HappyWrap102 = HappyWrap102 (Located ([AddEpAnn], LFamilyResultSig GhcPs))+happyIn102 :: (Located ([AddEpAnn], LFamilyResultSig GhcPs)) -> (HappyAbsSyn )+happyIn102 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap102 x)+{-# INLINE happyIn102 #-}+happyOut102 :: (HappyAbsSyn ) -> HappyWrap102+happyOut102 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut102 #-}+newtype HappyWrap103 = HappyWrap103 (Located ([AddEpAnn], ( LFamilyResultSig GhcPs+                                            , Maybe (LInjectivityAnn GhcPs))))+happyIn103 :: (Located ([AddEpAnn], ( LFamilyResultSig GhcPs+                                            , Maybe (LInjectivityAnn GhcPs)))) -> (HappyAbsSyn )+happyIn103 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap103 x)+{-# INLINE happyIn103 #-}+happyOut103 :: (HappyAbsSyn ) -> HappyWrap103+happyOut103 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut103 #-}+newtype HappyWrap104 = HappyWrap104 (Located (Maybe (LHsContext GhcPs), LHsType GhcPs))+happyIn104 :: (Located (Maybe (LHsContext GhcPs), LHsType GhcPs)) -> (HappyAbsSyn )+happyIn104 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap104 x)+{-# INLINE happyIn104 #-}+happyOut104 :: (HappyAbsSyn ) -> HappyWrap104+happyOut104 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut104 #-}+newtype HappyWrap105 = HappyWrap105 (Located (Maybe (LHsContext GhcPs), HsOuterFamEqnTyVarBndrs GhcPs, LHsType GhcPs))+happyIn105 :: (Located (Maybe (LHsContext GhcPs), HsOuterFamEqnTyVarBndrs GhcPs, LHsType GhcPs)) -> (HappyAbsSyn )+happyIn105 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap105 x)+{-# INLINE happyIn105 #-}+happyOut105 :: (HappyAbsSyn ) -> HappyWrap105+happyOut105 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut105 #-}+newtype HappyWrap106 = HappyWrap106 (Maybe (LocatedP CType))+happyIn106 :: (Maybe (LocatedP CType)) -> (HappyAbsSyn )+happyIn106 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap106 x)+{-# INLINE happyIn106 #-}+happyOut106 :: (HappyAbsSyn ) -> HappyWrap106+happyOut106 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut106 #-}+newtype HappyWrap107 = HappyWrap107 (LDerivDecl GhcPs)+happyIn107 :: (LDerivDecl GhcPs) -> (HappyAbsSyn )+happyIn107 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap107 x)+{-# INLINE happyIn107 #-}+happyOut107 :: (HappyAbsSyn ) -> HappyWrap107+happyOut107 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut107 #-}+newtype HappyWrap108 = HappyWrap108 (LRoleAnnotDecl GhcPs)+happyIn108 :: (LRoleAnnotDecl GhcPs) -> (HappyAbsSyn )+happyIn108 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap108 x)+{-# INLINE happyIn108 #-}+happyOut108 :: (HappyAbsSyn ) -> HappyWrap108+happyOut108 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut108 #-}+newtype HappyWrap109 = HappyWrap109 (Located [Located (Maybe FastString)])+happyIn109 :: (Located [Located (Maybe FastString)]) -> (HappyAbsSyn )+happyIn109 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap109 x)+{-# INLINE happyIn109 #-}+happyOut109 :: (HappyAbsSyn ) -> HappyWrap109+happyOut109 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut109 #-}+newtype HappyWrap110 = HappyWrap110 (Located [Located (Maybe FastString)])+happyIn110 :: (Located [Located (Maybe FastString)]) -> (HappyAbsSyn )+happyIn110 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap110 x)+{-# INLINE happyIn110 #-}+happyOut110 :: (HappyAbsSyn ) -> HappyWrap110+happyOut110 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut110 #-}+newtype HappyWrap111 = HappyWrap111 (Located (Maybe FastString))+happyIn111 :: (Located (Maybe FastString)) -> (HappyAbsSyn )+happyIn111 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap111 x)+{-# INLINE happyIn111 #-}+happyOut111 :: (HappyAbsSyn ) -> HappyWrap111+happyOut111 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut111 #-}+newtype HappyWrap112 = HappyWrap112 (LHsDecl GhcPs)+happyIn112 :: (LHsDecl GhcPs) -> (HappyAbsSyn )+happyIn112 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap112 x)+{-# INLINE happyIn112 #-}+happyOut112 :: (HappyAbsSyn ) -> HappyWrap112+happyOut112 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut112 #-}+newtype HappyWrap113 = HappyWrap113 ((LocatedN RdrName, HsPatSynDetails GhcPs, [AddEpAnn]))+happyIn113 :: ((LocatedN RdrName, HsPatSynDetails GhcPs, [AddEpAnn])) -> (HappyAbsSyn )+happyIn113 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap113 x)+{-# INLINE happyIn113 #-}+happyOut113 :: (HappyAbsSyn ) -> HappyWrap113+happyOut113 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut113 #-}+newtype HappyWrap114 = HappyWrap114 ([LocatedN RdrName])+happyIn114 :: ([LocatedN RdrName]) -> (HappyAbsSyn )+happyIn114 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap114 x)+{-# INLINE happyIn114 #-}+happyOut114 :: (HappyAbsSyn ) -> HappyWrap114+happyOut114 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut114 #-}+newtype HappyWrap115 = HappyWrap115 ([RecordPatSynField GhcPs])+happyIn115 :: ([RecordPatSynField GhcPs]) -> (HappyAbsSyn )+happyIn115 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap115 x)+{-# INLINE happyIn115 #-}+happyOut115 :: (HappyAbsSyn ) -> HappyWrap115+happyOut115 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut115 #-}+newtype HappyWrap116 = HappyWrap116 (LocatedL (OrdList (LHsDecl GhcPs)))+happyIn116 :: (LocatedL (OrdList (LHsDecl GhcPs))) -> (HappyAbsSyn )+happyIn116 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap116 x)+{-# INLINE happyIn116 #-}+happyOut116 :: (HappyAbsSyn ) -> HappyWrap116+happyOut116 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut116 #-}+newtype HappyWrap117 = HappyWrap117 (LSig GhcPs)+happyIn117 :: (LSig GhcPs) -> (HappyAbsSyn )+happyIn117 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap117 x)+{-# INLINE happyIn117 #-}+happyOut117 :: (HappyAbsSyn ) -> HappyWrap117+happyOut117 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut117 #-}+newtype HappyWrap118 = HappyWrap118 (LocatedN RdrName)+happyIn118 :: (LocatedN RdrName) -> (HappyAbsSyn )+happyIn118 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap118 x)+{-# INLINE happyIn118 #-}+happyOut118 :: (HappyAbsSyn ) -> HappyWrap118+happyOut118 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut118 #-}+newtype HappyWrap119 = HappyWrap119 (LHsDecl GhcPs)+happyIn119 :: (LHsDecl GhcPs) -> (HappyAbsSyn )+happyIn119 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap119 x)+{-# INLINE happyIn119 #-}+happyOut119 :: (HappyAbsSyn ) -> HappyWrap119+happyOut119 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut119 #-}+newtype HappyWrap120 = HappyWrap120 (Located ([AddEpAnn],OrdList (LHsDecl GhcPs)))+happyIn120 :: (Located ([AddEpAnn],OrdList (LHsDecl GhcPs))) -> (HappyAbsSyn )+happyIn120 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap120 x)+{-# INLINE happyIn120 #-}+happyOut120 :: (HappyAbsSyn ) -> HappyWrap120+happyOut120 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut120 #-}+newtype HappyWrap121 = HappyWrap121 (Located ([AddEpAnn]+                     , OrdList (LHsDecl GhcPs)+                     , LayoutInfo))+happyIn121 :: (Located ([AddEpAnn]+                     , OrdList (LHsDecl GhcPs)+                     , LayoutInfo)) -> (HappyAbsSyn )+happyIn121 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap121 x)+{-# INLINE happyIn121 #-}+happyOut121 :: (HappyAbsSyn ) -> HappyWrap121+happyOut121 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut121 #-}+newtype HappyWrap122 = HappyWrap122 (Located ([AddEpAnn]+                       ,(OrdList (LHsDecl GhcPs))    -- Reversed+                       ,LayoutInfo))+happyIn122 :: (Located ([AddEpAnn]+                       ,(OrdList (LHsDecl GhcPs))    -- Reversed+                       ,LayoutInfo)) -> (HappyAbsSyn )+happyIn122 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap122 x)+{-# INLINE happyIn122 #-}+happyOut122 :: (HappyAbsSyn ) -> HappyWrap122+happyOut122 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut122 #-}+newtype HappyWrap123 = HappyWrap123 (Located (OrdList (LHsDecl GhcPs)))+happyIn123 :: (Located (OrdList (LHsDecl GhcPs))) -> (HappyAbsSyn )+happyIn123 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap123 x)+{-# INLINE happyIn123 #-}+happyOut123 :: (HappyAbsSyn ) -> HappyWrap123+happyOut123 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut123 #-}+newtype HappyWrap124 = HappyWrap124 (Located ([AddEpAnn],OrdList (LHsDecl GhcPs)))+happyIn124 :: (Located ([AddEpAnn],OrdList (LHsDecl GhcPs))) -> (HappyAbsSyn )+happyIn124 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap124 x)+{-# INLINE happyIn124 #-}+happyOut124 :: (HappyAbsSyn ) -> HappyWrap124+happyOut124 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut124 #-}+newtype HappyWrap125 = HappyWrap125 (Located ([AddEpAnn]+                     , OrdList (LHsDecl GhcPs)))+happyIn125 :: (Located ([AddEpAnn]+                     , OrdList (LHsDecl GhcPs))) -> (HappyAbsSyn )+happyIn125 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap125 x)+{-# INLINE happyIn125 #-}+happyOut125 :: (HappyAbsSyn ) -> HappyWrap125+happyOut125 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut125 #-}+newtype HappyWrap126 = HappyWrap126 (Located ([AddEpAnn]+                        , OrdList (LHsDecl GhcPs)))+happyIn126 :: (Located ([AddEpAnn]+                        , OrdList (LHsDecl GhcPs))) -> (HappyAbsSyn )+happyIn126 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap126 x)+{-# INLINE happyIn126 #-}+happyOut126 :: (HappyAbsSyn ) -> HappyWrap126+happyOut126 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut126 #-}+newtype HappyWrap127 = HappyWrap127 (Located ([TrailingAnn], OrdList (LHsDecl GhcPs)))+happyIn127 :: (Located ([TrailingAnn], OrdList (LHsDecl GhcPs))) -> (HappyAbsSyn )+happyIn127 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap127 x)+{-# INLINE happyIn127 #-}+happyOut127 :: (HappyAbsSyn ) -> HappyWrap127+happyOut127 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut127 #-}+newtype HappyWrap128 = HappyWrap128 (Located (AnnList,Located (OrdList (LHsDecl GhcPs))))+happyIn128 :: (Located (AnnList,Located (OrdList (LHsDecl GhcPs)))) -> (HappyAbsSyn )+happyIn128 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap128 x)+{-# INLINE happyIn128 #-}+happyOut128 :: (HappyAbsSyn ) -> HappyWrap128+happyOut128 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut128 #-}+newtype HappyWrap129 = HappyWrap129 (Located (HsLocalBinds GhcPs))+happyIn129 :: (Located (HsLocalBinds GhcPs)) -> (HappyAbsSyn )+happyIn129 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap129 x)+{-# INLINE happyIn129 #-}+happyOut129 :: (HappyAbsSyn ) -> HappyWrap129+happyOut129 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut129 #-}+newtype HappyWrap130 = HappyWrap130 (Maybe (Located (HsLocalBinds GhcPs, Maybe EpAnnComments )))+happyIn130 :: (Maybe (Located (HsLocalBinds GhcPs, Maybe EpAnnComments ))) -> (HappyAbsSyn )+happyIn130 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap130 x)+{-# INLINE happyIn130 #-}+happyOut130 :: (HappyAbsSyn ) -> HappyWrap130+happyOut130 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut130 #-}+newtype HappyWrap131 = HappyWrap131 ([LRuleDecl GhcPs])+happyIn131 :: ([LRuleDecl GhcPs]) -> (HappyAbsSyn )+happyIn131 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap131 x)+{-# INLINE happyIn131 #-}+happyOut131 :: (HappyAbsSyn ) -> HappyWrap131+happyOut131 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut131 #-}+newtype HappyWrap132 = HappyWrap132 (LRuleDecl GhcPs)+happyIn132 :: (LRuleDecl GhcPs) -> (HappyAbsSyn )+happyIn132 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap132 x)+{-# INLINE happyIn132 #-}+happyOut132 :: (HappyAbsSyn ) -> HappyWrap132+happyOut132 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut132 #-}+newtype HappyWrap133 = HappyWrap133 (([AddEpAnn],Maybe Activation))+happyIn133 :: (([AddEpAnn],Maybe Activation)) -> (HappyAbsSyn )+happyIn133 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap133 x)+{-# INLINE happyIn133 #-}+happyOut133 :: (HappyAbsSyn ) -> HappyWrap133+happyOut133 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut133 #-}+newtype HappyWrap134 = HappyWrap134 ([AddEpAnn])+happyIn134 :: ([AddEpAnn]) -> (HappyAbsSyn )+happyIn134 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap134 x)+{-# INLINE happyIn134 #-}+happyOut134 :: (HappyAbsSyn ) -> HappyWrap134+happyOut134 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut134 #-}+newtype HappyWrap135 = HappyWrap135 (([AddEpAnn]+                              ,Activation))+happyIn135 :: (([AddEpAnn]+                              ,Activation)) -> (HappyAbsSyn )+happyIn135 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap135 x)+{-# INLINE happyIn135 #-}+happyOut135 :: (HappyAbsSyn ) -> HappyWrap135+happyOut135 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut135 #-}+newtype HappyWrap136 = HappyWrap136 (([AddEpAnn] -> HsRuleAnn, Maybe [LHsTyVarBndr () GhcPs], [LRuleBndr GhcPs]))+happyIn136 :: (([AddEpAnn] -> HsRuleAnn, Maybe [LHsTyVarBndr () GhcPs], [LRuleBndr GhcPs])) -> (HappyAbsSyn )+happyIn136 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap136 x)+{-# INLINE happyIn136 #-}+happyOut136 :: (HappyAbsSyn ) -> HappyWrap136+happyOut136 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut136 #-}+newtype HappyWrap137 = HappyWrap137 ([LRuleTyTmVar])+happyIn137 :: ([LRuleTyTmVar]) -> (HappyAbsSyn )+happyIn137 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap137 x)+{-# INLINE happyIn137 #-}+happyOut137 :: (HappyAbsSyn ) -> HappyWrap137+happyOut137 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut137 #-}+newtype HappyWrap138 = HappyWrap138 (LRuleTyTmVar)+happyIn138 :: (LRuleTyTmVar) -> (HappyAbsSyn )+happyIn138 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap138 x)+{-# INLINE happyIn138 #-}+happyOut138 :: (HappyAbsSyn ) -> HappyWrap138+happyOut138 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut138 #-}+newtype HappyWrap139 = HappyWrap139 (OrdList (LWarnDecl GhcPs))+happyIn139 :: (OrdList (LWarnDecl GhcPs)) -> (HappyAbsSyn )+happyIn139 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap139 x)+{-# INLINE happyIn139 #-}+happyOut139 :: (HappyAbsSyn ) -> HappyWrap139+happyOut139 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut139 #-}+newtype HappyWrap140 = HappyWrap140 (OrdList (LWarnDecl GhcPs))+happyIn140 :: (OrdList (LWarnDecl GhcPs)) -> (HappyAbsSyn )+happyIn140 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap140 x)+{-# INLINE happyIn140 #-}+happyOut140 :: (HappyAbsSyn ) -> HappyWrap140+happyOut140 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut140 #-}+newtype HappyWrap141 = HappyWrap141 (OrdList (LWarnDecl GhcPs))+happyIn141 :: (OrdList (LWarnDecl GhcPs)) -> (HappyAbsSyn )+happyIn141 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap141 x)+{-# INLINE happyIn141 #-}+happyOut141 :: (HappyAbsSyn ) -> HappyWrap141+happyOut141 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut141 #-}+newtype HappyWrap142 = HappyWrap142 (OrdList (LWarnDecl GhcPs))+happyIn142 :: (OrdList (LWarnDecl GhcPs)) -> (HappyAbsSyn )+happyIn142 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap142 x)+{-# INLINE happyIn142 #-}+happyOut142 :: (HappyAbsSyn ) -> HappyWrap142+happyOut142 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut142 #-}+newtype HappyWrap143 = HappyWrap143 (Located ([AddEpAnn],[Located StringLiteral]))+happyIn143 :: (Located ([AddEpAnn],[Located StringLiteral])) -> (HappyAbsSyn )+happyIn143 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap143 x)+{-# INLINE happyIn143 #-}+happyOut143 :: (HappyAbsSyn ) -> HappyWrap143+happyOut143 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut143 #-}+newtype HappyWrap144 = HappyWrap144 (Located (OrdList (Located StringLiteral)))+happyIn144 :: (Located (OrdList (Located StringLiteral))) -> (HappyAbsSyn )+happyIn144 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap144 x)+{-# INLINE happyIn144 #-}+happyOut144 :: (HappyAbsSyn ) -> HappyWrap144+happyOut144 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut144 #-}+newtype HappyWrap145 = HappyWrap145 (LHsDecl GhcPs)+happyIn145 :: (LHsDecl GhcPs) -> (HappyAbsSyn )+happyIn145 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap145 x)+{-# INLINE happyIn145 #-}+happyOut145 :: (HappyAbsSyn ) -> HappyWrap145+happyOut145 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut145 #-}+newtype HappyWrap146 = HappyWrap146 (Located ([AddEpAnn],EpAnn [AddEpAnn] -> HsDecl GhcPs))+happyIn146 :: (Located ([AddEpAnn],EpAnn [AddEpAnn] -> HsDecl GhcPs)) -> (HappyAbsSyn )+happyIn146 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap146 x)+{-# INLINE happyIn146 #-}+happyOut146 :: (HappyAbsSyn ) -> HappyWrap146+happyOut146 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut146 #-}+newtype HappyWrap147 = HappyWrap147 (Located CCallConv)+happyIn147 :: (Located CCallConv) -> (HappyAbsSyn )+happyIn147 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap147 x)+{-# INLINE happyIn147 #-}+happyOut147 :: (HappyAbsSyn ) -> HappyWrap147+happyOut147 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut147 #-}+newtype HappyWrap148 = HappyWrap148 (Located Safety)+happyIn148 :: (Located Safety) -> (HappyAbsSyn )+happyIn148 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap148 x)+{-# INLINE happyIn148 #-}+happyOut148 :: (HappyAbsSyn ) -> HappyWrap148+happyOut148 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut148 #-}+newtype HappyWrap149 = HappyWrap149 (Located ([AddEpAnn]+                    ,(Located StringLiteral, LocatedN RdrName, LHsSigType GhcPs)))+happyIn149 :: (Located ([AddEpAnn]+                    ,(Located StringLiteral, LocatedN RdrName, LHsSigType GhcPs))) -> (HappyAbsSyn )+happyIn149 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap149 x)+{-# INLINE happyIn149 #-}+happyOut149 :: (HappyAbsSyn ) -> HappyWrap149+happyOut149 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut149 #-}+newtype HappyWrap150 = HappyWrap150 (Maybe (AddEpAnn, LHsType GhcPs))+happyIn150 :: (Maybe (AddEpAnn, LHsType GhcPs)) -> (HappyAbsSyn )+happyIn150 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap150 x)+{-# INLINE happyIn150 #-}+happyOut150 :: (HappyAbsSyn ) -> HappyWrap150+happyOut150 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut150 #-}+newtype HappyWrap151 = HappyWrap151 (([AddEpAnn], Maybe (LocatedN RdrName)))+happyIn151 :: (([AddEpAnn], Maybe (LocatedN RdrName))) -> (HappyAbsSyn )+happyIn151 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap151 x)+{-# INLINE happyIn151 #-}+happyOut151 :: (HappyAbsSyn ) -> HappyWrap151+happyOut151 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut151 #-}+newtype HappyWrap152 = HappyWrap152 (LHsSigType GhcPs)+happyIn152 :: (LHsSigType GhcPs) -> (HappyAbsSyn )+happyIn152 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap152 x)+{-# INLINE happyIn152 #-}+happyOut152 :: (HappyAbsSyn ) -> HappyWrap152+happyOut152 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut152 #-}+newtype HappyWrap153 = HappyWrap153 (LHsSigType GhcPs)+happyIn153 :: (LHsSigType GhcPs) -> (HappyAbsSyn )+happyIn153 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap153 x)+{-# INLINE happyIn153 #-}+happyOut153 :: (HappyAbsSyn ) -> HappyWrap153+happyOut153 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut153 #-}+newtype HappyWrap154 = HappyWrap154 (Located [LocatedN RdrName])+happyIn154 :: (Located [LocatedN RdrName]) -> (HappyAbsSyn )+happyIn154 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap154 x)+{-# INLINE happyIn154 #-}+happyOut154 :: (HappyAbsSyn ) -> HappyWrap154+happyOut154 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut154 #-}+newtype HappyWrap155 = HappyWrap155 (OrdList (LHsSigType GhcPs))+happyIn155 :: (OrdList (LHsSigType GhcPs)) -> (HappyAbsSyn )+happyIn155 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap155 x)+{-# INLINE happyIn155 #-}+happyOut155 :: (HappyAbsSyn ) -> HappyWrap155+happyOut155 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut155 #-}+newtype HappyWrap156 = HappyWrap156 (Located UnpackednessPragma)+happyIn156 :: (Located UnpackednessPragma) -> (HappyAbsSyn )+happyIn156 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap156 x)+{-# INLINE happyIn156 #-}+happyOut156 :: (HappyAbsSyn ) -> HappyWrap156+happyOut156 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut156 #-}+newtype HappyWrap157 = HappyWrap157 (Located (HsForAllTelescope GhcPs))+happyIn157 :: (Located (HsForAllTelescope GhcPs)) -> (HappyAbsSyn )+happyIn157 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap157 x)+{-# INLINE happyIn157 #-}+happyOut157 :: (HappyAbsSyn ) -> HappyWrap157+happyOut157 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut157 #-}+newtype HappyWrap158 = HappyWrap158 (LHsType GhcPs)+happyIn158 :: (LHsType GhcPs) -> (HappyAbsSyn )+happyIn158 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap158 x)+{-# INLINE happyIn158 #-}+happyOut158 :: (HappyAbsSyn ) -> HappyWrap158+happyOut158 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut158 #-}+newtype HappyWrap159 = HappyWrap159 (LHsType GhcPs)+happyIn159 :: (LHsType GhcPs) -> (HappyAbsSyn )+happyIn159 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap159 x)+{-# INLINE happyIn159 #-}+happyOut159 :: (HappyAbsSyn ) -> HappyWrap159+happyOut159 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut159 #-}+newtype HappyWrap160 = HappyWrap160 (LHsContext GhcPs)+happyIn160 :: (LHsContext GhcPs) -> (HappyAbsSyn )+happyIn160 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap160 x)+{-# INLINE happyIn160 #-}+happyOut160 :: (HappyAbsSyn ) -> HappyWrap160+happyOut160 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut160 #-}+newtype HappyWrap161 = HappyWrap161 (LHsType GhcPs)+happyIn161 :: (LHsType GhcPs) -> (HappyAbsSyn )+happyIn161 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap161 x)+{-# INLINE happyIn161 #-}+happyOut161 :: (HappyAbsSyn ) -> HappyWrap161+happyOut161 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut161 #-}+newtype HappyWrap162 = HappyWrap162 (Located (LHsUniToken "->" "\8594" GhcPs -> HsArrow GhcPs))+happyIn162 :: (Located (LHsUniToken "->" "\8594" GhcPs -> HsArrow GhcPs)) -> (HappyAbsSyn )+happyIn162 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap162 x)+{-# INLINE happyIn162 #-}+happyOut162 :: (HappyAbsSyn ) -> HappyWrap162+happyOut162 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut162 #-}+newtype HappyWrap163 = HappyWrap163 (LHsType GhcPs)+happyIn163 :: (LHsType GhcPs) -> (HappyAbsSyn )+happyIn163 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap163 x)+{-# INLINE happyIn163 #-}+happyOut163 :: (HappyAbsSyn ) -> HappyWrap163+happyOut163 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut163 #-}+newtype HappyWrap164 = HappyWrap164 (forall b. DisambTD b => PV (LocatedA b))+happyIn164 :: (forall b. DisambTD b => PV (LocatedA b)) -> (HappyAbsSyn )+happyIn164 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap164 x)+{-# INLINE happyIn164 #-}+happyOut164 :: (HappyAbsSyn ) -> HappyWrap164+happyOut164 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut164 #-}+newtype HappyWrap165 = HappyWrap165 (forall b. DisambTD b => PV (LocatedA b))+happyIn165 :: (forall b. DisambTD b => PV (LocatedA b)) -> (HappyAbsSyn )+happyIn165 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap165 x)+{-# INLINE happyIn165 #-}+happyOut165 :: (HappyAbsSyn ) -> HappyWrap165+happyOut165 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut165 #-}+newtype HappyWrap166 = HappyWrap166 (LHsType GhcPs)+happyIn166 :: (LHsType GhcPs) -> (HappyAbsSyn )+happyIn166 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap166 x)+{-# INLINE happyIn166 #-}+happyOut166 :: (HappyAbsSyn ) -> HappyWrap166+happyOut166 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut166 #-}+newtype HappyWrap167 = HappyWrap167 ((LocatedN RdrName, PromotionFlag))+happyIn167 :: ((LocatedN RdrName, PromotionFlag)) -> (HappyAbsSyn )+happyIn167 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap167 x)+{-# INLINE happyIn167 #-}+happyOut167 :: (HappyAbsSyn ) -> HappyWrap167+happyOut167 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut167 #-}+newtype HappyWrap168 = HappyWrap168 (LHsType GhcPs)+happyIn168 :: (LHsType GhcPs) -> (HappyAbsSyn )+happyIn168 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap168 x)+{-# INLINE happyIn168 #-}+happyOut168 :: (HappyAbsSyn ) -> HappyWrap168+happyOut168 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut168 #-}+newtype HappyWrap169 = HappyWrap169 (LHsSigType GhcPs)+happyIn169 :: (LHsSigType GhcPs) -> (HappyAbsSyn )+happyIn169 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap169 x)+{-# INLINE happyIn169 #-}+happyOut169 :: (HappyAbsSyn ) -> HappyWrap169+happyOut169 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut169 #-}+newtype HappyWrap170 = HappyWrap170 ([LHsSigType GhcPs])+happyIn170 :: ([LHsSigType GhcPs]) -> (HappyAbsSyn )+happyIn170 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap170 x)+{-# INLINE happyIn170 #-}+happyOut170 :: (HappyAbsSyn ) -> HappyWrap170+happyOut170 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut170 #-}+newtype HappyWrap171 = HappyWrap171 ([LHsType GhcPs])+happyIn171 :: ([LHsType GhcPs]) -> (HappyAbsSyn )+happyIn171 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap171 x)+{-# INLINE happyIn171 #-}+happyOut171 :: (HappyAbsSyn ) -> HappyWrap171+happyOut171 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut171 #-}+newtype HappyWrap172 = HappyWrap172 ([LHsType GhcPs])+happyIn172 :: ([LHsType GhcPs]) -> (HappyAbsSyn )+happyIn172 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap172 x)+{-# INLINE happyIn172 #-}+happyOut172 :: (HappyAbsSyn ) -> HappyWrap172+happyOut172 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut172 #-}+newtype HappyWrap173 = HappyWrap173 ([LHsType GhcPs])+happyIn173 :: ([LHsType GhcPs]) -> (HappyAbsSyn )+happyIn173 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap173 x)+{-# INLINE happyIn173 #-}+happyOut173 :: (HappyAbsSyn ) -> HappyWrap173+happyOut173 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut173 #-}+newtype HappyWrap174 = HappyWrap174 ([LHsTyVarBndr Specificity GhcPs])+happyIn174 :: ([LHsTyVarBndr Specificity GhcPs]) -> (HappyAbsSyn )+happyIn174 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap174 x)+{-# INLINE happyIn174 #-}+happyOut174 :: (HappyAbsSyn ) -> HappyWrap174+happyOut174 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut174 #-}+newtype HappyWrap175 = HappyWrap175 (LHsTyVarBndr Specificity GhcPs)+happyIn175 :: (LHsTyVarBndr Specificity GhcPs) -> (HappyAbsSyn )+happyIn175 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap175 x)+{-# INLINE happyIn175 #-}+happyOut175 :: (HappyAbsSyn ) -> HappyWrap175+happyOut175 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut175 #-}+newtype HappyWrap176 = HappyWrap176 (LHsTyVarBndr Specificity GhcPs)+happyIn176 :: (LHsTyVarBndr Specificity GhcPs) -> (HappyAbsSyn )+happyIn176 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap176 x)+{-# INLINE happyIn176 #-}+happyOut176 :: (HappyAbsSyn ) -> HappyWrap176+happyOut176 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut176 #-}+newtype HappyWrap177 = HappyWrap177 (Located ([AddEpAnn],[LHsFunDep GhcPs]))+happyIn177 :: (Located ([AddEpAnn],[LHsFunDep GhcPs])) -> (HappyAbsSyn )+happyIn177 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap177 x)+{-# INLINE happyIn177 #-}+happyOut177 :: (HappyAbsSyn ) -> HappyWrap177+happyOut177 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut177 #-}+newtype HappyWrap178 = HappyWrap178 (Located [LHsFunDep GhcPs])+happyIn178 :: (Located [LHsFunDep GhcPs]) -> (HappyAbsSyn )+happyIn178 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap178 x)+{-# INLINE happyIn178 #-}+happyOut178 :: (HappyAbsSyn ) -> HappyWrap178+happyOut178 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut178 #-}+newtype HappyWrap179 = HappyWrap179 (LHsFunDep GhcPs)+happyIn179 :: (LHsFunDep GhcPs) -> (HappyAbsSyn )+happyIn179 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap179 x)+{-# INLINE happyIn179 #-}+happyOut179 :: (HappyAbsSyn ) -> HappyWrap179+happyOut179 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut179 #-}+newtype HappyWrap180 = HappyWrap180 (Located [LocatedN RdrName])+happyIn180 :: (Located [LocatedN RdrName]) -> (HappyAbsSyn )+happyIn180 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap180 x)+{-# INLINE happyIn180 #-}+happyOut180 :: (HappyAbsSyn ) -> HappyWrap180+happyOut180 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut180 #-}+newtype HappyWrap181 = HappyWrap181 (LHsKind GhcPs)+happyIn181 :: (LHsKind GhcPs) -> (HappyAbsSyn )+happyIn181 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap181 x)+{-# INLINE happyIn181 #-}+happyOut181 :: (HappyAbsSyn ) -> HappyWrap181+happyOut181 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut181 #-}+newtype HappyWrap182 = HappyWrap182 (Located ([AddEpAnn]+                          ,[LConDecl GhcPs]))+happyIn182 :: (Located ([AddEpAnn]+                          ,[LConDecl GhcPs])) -> (HappyAbsSyn )+happyIn182 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap182 x)+{-# INLINE happyIn182 #-}+happyOut182 :: (HappyAbsSyn ) -> HappyWrap182+happyOut182 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut182 #-}+newtype HappyWrap183 = HappyWrap183 (Located [LConDecl GhcPs])+happyIn183 :: (Located [LConDecl GhcPs]) -> (HappyAbsSyn )+happyIn183 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap183 x)+{-# INLINE happyIn183 #-}+happyOut183 :: (HappyAbsSyn ) -> HappyWrap183+happyOut183 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut183 #-}+newtype HappyWrap184 = HappyWrap184 (LConDecl GhcPs)+happyIn184 :: (LConDecl GhcPs) -> (HappyAbsSyn )+happyIn184 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap184 x)+{-# INLINE happyIn184 #-}+happyOut184 :: (HappyAbsSyn ) -> HappyWrap184+happyOut184 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut184 #-}+newtype HappyWrap185 = HappyWrap185 (Located ([AddEpAnn],[LConDecl GhcPs]))+happyIn185 :: (Located ([AddEpAnn],[LConDecl GhcPs])) -> (HappyAbsSyn )+happyIn185 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap185 x)+{-# INLINE happyIn185 #-}+happyOut185 :: (HappyAbsSyn ) -> HappyWrap185+happyOut185 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut185 #-}+newtype HappyWrap186 = HappyWrap186 (Located [LConDecl GhcPs])+happyIn186 :: (Located [LConDecl GhcPs]) -> (HappyAbsSyn )+happyIn186 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap186 x)+{-# INLINE happyIn186 #-}+happyOut186 :: (HappyAbsSyn ) -> HappyWrap186+happyOut186 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut186 #-}+newtype HappyWrap187 = HappyWrap187 (LConDecl GhcPs)+happyIn187 :: (LConDecl GhcPs) -> (HappyAbsSyn )+happyIn187 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap187 x)+{-# INLINE happyIn187 #-}+happyOut187 :: (HappyAbsSyn ) -> HappyWrap187+happyOut187 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut187 #-}+newtype HappyWrap188 = HappyWrap188 (Located ([AddEpAnn], Maybe [LHsTyVarBndr Specificity GhcPs]))+happyIn188 :: (Located ([AddEpAnn], Maybe [LHsTyVarBndr Specificity GhcPs])) -> (HappyAbsSyn )+happyIn188 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap188 x)+{-# INLINE happyIn188 #-}+happyOut188 :: (HappyAbsSyn ) -> HappyWrap188+happyOut188 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut188 #-}+newtype HappyWrap189 = HappyWrap189 (Located (LocatedN RdrName, HsConDeclH98Details GhcPs))+happyIn189 :: (Located (LocatedN RdrName, HsConDeclH98Details GhcPs)) -> (HappyAbsSyn )+happyIn189 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap189 x)+{-# INLINE happyIn189 #-}+happyOut189 :: (HappyAbsSyn ) -> HappyWrap189+happyOut189 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut189 #-}+newtype HappyWrap190 = HappyWrap190 ([LConDeclField GhcPs])+happyIn190 :: ([LConDeclField GhcPs]) -> (HappyAbsSyn )+happyIn190 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap190 x)+{-# INLINE happyIn190 #-}+happyOut190 :: (HappyAbsSyn ) -> HappyWrap190+happyOut190 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut190 #-}+newtype HappyWrap191 = HappyWrap191 ([LConDeclField GhcPs])+happyIn191 :: ([LConDeclField GhcPs]) -> (HappyAbsSyn )+happyIn191 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap191 x)+{-# INLINE happyIn191 #-}+happyOut191 :: (HappyAbsSyn ) -> HappyWrap191+happyOut191 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut191 #-}+newtype HappyWrap192 = HappyWrap192 (LConDeclField GhcPs)+happyIn192 :: (LConDeclField GhcPs) -> (HappyAbsSyn )+happyIn192 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap192 x)+{-# INLINE happyIn192 #-}+happyOut192 :: (HappyAbsSyn ) -> HappyWrap192+happyOut192 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut192 #-}+newtype HappyWrap193 = HappyWrap193 (Located (HsDeriving GhcPs))+happyIn193 :: (Located (HsDeriving GhcPs)) -> (HappyAbsSyn )+happyIn193 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap193 x)+{-# INLINE happyIn193 #-}+happyOut193 :: (HappyAbsSyn ) -> HappyWrap193+happyOut193 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut193 #-}+newtype HappyWrap194 = HappyWrap194 (Located (HsDeriving GhcPs))+happyIn194 :: (Located (HsDeriving GhcPs)) -> (HappyAbsSyn )+happyIn194 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap194 x)+{-# INLINE happyIn194 #-}+happyOut194 :: (HappyAbsSyn ) -> HappyWrap194+happyOut194 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut194 #-}+newtype HappyWrap195 = HappyWrap195 (LHsDerivingClause GhcPs)+happyIn195 :: (LHsDerivingClause GhcPs) -> (HappyAbsSyn )+happyIn195 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap195 x)+{-# INLINE happyIn195 #-}+happyOut195 :: (HappyAbsSyn ) -> HappyWrap195+happyOut195 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut195 #-}+newtype HappyWrap196 = HappyWrap196 (LDerivClauseTys GhcPs)+happyIn196 :: (LDerivClauseTys GhcPs) -> (HappyAbsSyn )+happyIn196 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap196 x)+{-# INLINE happyIn196 #-}+happyOut196 :: (HappyAbsSyn ) -> HappyWrap196+happyOut196 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut196 #-}+newtype HappyWrap197 = HappyWrap197 (LHsDecl GhcPs)+happyIn197 :: (LHsDecl GhcPs) -> (HappyAbsSyn )+happyIn197 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap197 x)+{-# INLINE happyIn197 #-}+happyOut197 :: (HappyAbsSyn ) -> HappyWrap197+happyOut197 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut197 #-}+newtype HappyWrap198 = HappyWrap198 (LHsDecl GhcPs)+happyIn198 :: (LHsDecl GhcPs) -> (HappyAbsSyn )+happyIn198 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap198 x)+{-# INLINE happyIn198 #-}+happyOut198 :: (HappyAbsSyn ) -> HappyWrap198+happyOut198 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut198 #-}+newtype HappyWrap199 = HappyWrap199 (Located (GRHSs GhcPs (LHsExpr GhcPs)))+happyIn199 :: (Located (GRHSs GhcPs (LHsExpr GhcPs))) -> (HappyAbsSyn )+happyIn199 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap199 x)+{-# INLINE happyIn199 #-}+happyOut199 :: (HappyAbsSyn ) -> HappyWrap199+happyOut199 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut199 #-}+newtype HappyWrap200 = HappyWrap200 (Located [LGRHS GhcPs (LHsExpr GhcPs)])+happyIn200 :: (Located [LGRHS GhcPs (LHsExpr GhcPs)]) -> (HappyAbsSyn )+happyIn200 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap200 x)+{-# INLINE happyIn200 #-}+happyOut200 :: (HappyAbsSyn ) -> HappyWrap200+happyOut200 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut200 #-}+newtype HappyWrap201 = HappyWrap201 (LGRHS GhcPs (LHsExpr GhcPs))+happyIn201 :: (LGRHS GhcPs (LHsExpr GhcPs)) -> (HappyAbsSyn )+happyIn201 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap201 x)+{-# INLINE happyIn201 #-}+happyOut201 :: (HappyAbsSyn ) -> HappyWrap201+happyOut201 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut201 #-}+newtype HappyWrap202 = HappyWrap202 (LHsDecl GhcPs)+happyIn202 :: (LHsDecl GhcPs) -> (HappyAbsSyn )+happyIn202 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap202 x)+{-# INLINE happyIn202 #-}+happyOut202 :: (HappyAbsSyn ) -> HappyWrap202+happyOut202 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut202 #-}+newtype HappyWrap203 = HappyWrap203 (([AddEpAnn],Maybe Activation))+happyIn203 :: (([AddEpAnn],Maybe Activation)) -> (HappyAbsSyn )+happyIn203 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap203 x)+{-# INLINE happyIn203 #-}+happyOut203 :: (HappyAbsSyn ) -> HappyWrap203+happyOut203 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut203 #-}+newtype HappyWrap204 = HappyWrap204 (([AddEpAnn],Activation))+happyIn204 :: (([AddEpAnn],Activation)) -> (HappyAbsSyn )+happyIn204 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap204 x)+{-# INLINE happyIn204 #-}+happyOut204 :: (HappyAbsSyn ) -> HappyWrap204+happyOut204 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut204 #-}+newtype HappyWrap205 = HappyWrap205 (Located (HsSplice GhcPs))+happyIn205 :: (Located (HsSplice GhcPs)) -> (HappyAbsSyn )+happyIn205 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap205 x)+{-# INLINE happyIn205 #-}+happyOut205 :: (HappyAbsSyn ) -> HappyWrap205+happyOut205 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut205 #-}+newtype HappyWrap206 = HappyWrap206 (ECP)+happyIn206 :: (ECP) -> (HappyAbsSyn )+happyIn206 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap206 x)+{-# INLINE happyIn206 #-}+happyOut206 :: (HappyAbsSyn ) -> HappyWrap206+happyOut206 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut206 #-}+newtype HappyWrap207 = HappyWrap207 (ECP)+happyIn207 :: (ECP) -> (HappyAbsSyn )+happyIn207 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap207 x)+{-# INLINE happyIn207 #-}+happyOut207 :: (HappyAbsSyn ) -> HappyWrap207+happyOut207 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut207 #-}+newtype HappyWrap208 = HappyWrap208 (ECP)+happyIn208 :: (ECP) -> (HappyAbsSyn )+happyIn208 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap208 x)+{-# INLINE happyIn208 #-}+happyOut208 :: (HappyAbsSyn ) -> HappyWrap208+happyOut208 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut208 #-}+newtype HappyWrap209 = HappyWrap209 (ECP)+happyIn209 :: (ECP) -> (HappyAbsSyn )+happyIn209 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap209 x)+{-# INLINE happyIn209 #-}+happyOut209 :: (HappyAbsSyn ) -> HappyWrap209+happyOut209 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut209 #-}+newtype HappyWrap210 = HappyWrap210 ((Maybe EpaLocation,Bool))+happyIn210 :: ((Maybe EpaLocation,Bool)) -> (HappyAbsSyn )+happyIn210 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap210 x)+{-# INLINE happyIn210 #-}+happyOut210 :: (HappyAbsSyn ) -> HappyWrap210+happyOut210 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut210 #-}+newtype HappyWrap211 = HappyWrap211 (Located (HsPragE GhcPs))+happyIn211 :: (Located (HsPragE GhcPs)) -> (HappyAbsSyn )+happyIn211 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap211 x)+{-# INLINE happyIn211 #-}+happyOut211 :: (HappyAbsSyn ) -> HappyWrap211+happyOut211 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut211 #-}+newtype HappyWrap212 = HappyWrap212 (ECP)+happyIn212 :: (ECP) -> (HappyAbsSyn )+happyIn212 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap212 x)+{-# INLINE happyIn212 #-}+happyOut212 :: (HappyAbsSyn ) -> HappyWrap212+happyOut212 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut212 #-}+newtype HappyWrap213 = HappyWrap213 (ECP)+happyIn213 :: (ECP) -> (HappyAbsSyn )+happyIn213 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap213 x)+{-# INLINE happyIn213 #-}+happyOut213 :: (HappyAbsSyn ) -> HappyWrap213+happyOut213 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut213 #-}+newtype HappyWrap214 = HappyWrap214 (ECP)+happyIn214 :: (ECP) -> (HappyAbsSyn )+happyIn214 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap214 x)+{-# INLINE happyIn214 #-}+happyOut214 :: (HappyAbsSyn ) -> HappyWrap214+happyOut214 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut214 #-}+newtype HappyWrap215 = HappyWrap215 (ECP)+happyIn215 :: (ECP) -> (HappyAbsSyn )+happyIn215 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap215 x)+{-# INLINE happyIn215 #-}+happyOut215 :: (HappyAbsSyn ) -> HappyWrap215+happyOut215 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut215 #-}+newtype HappyWrap216 = HappyWrap216 (Located (NonEmpty (LocatedAn NoEpAnns (DotFieldOcc GhcPs))))+happyIn216 :: (Located (NonEmpty (LocatedAn NoEpAnns (DotFieldOcc GhcPs)))) -> (HappyAbsSyn )+happyIn216 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap216 x)+{-# INLINE happyIn216 #-}+happyOut216 :: (HappyAbsSyn ) -> HappyWrap216+happyOut216 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut216 #-}+newtype HappyWrap217 = HappyWrap217 (LHsExpr GhcPs)+happyIn217 :: (LHsExpr GhcPs) -> (HappyAbsSyn )+happyIn217 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap217 x)+{-# INLINE happyIn217 #-}+happyOut217 :: (HappyAbsSyn ) -> HappyWrap217+happyOut217 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut217 #-}+newtype HappyWrap218 = HappyWrap218 (Located (HsSplice GhcPs))+happyIn218 :: (Located (HsSplice GhcPs)) -> (HappyAbsSyn )+happyIn218 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap218 x)+{-# INLINE happyIn218 #-}+happyOut218 :: (HappyAbsSyn ) -> HappyWrap218+happyOut218 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut218 #-}+newtype HappyWrap219 = HappyWrap219 (Located (HsSplice GhcPs))+happyIn219 :: (Located (HsSplice GhcPs)) -> (HappyAbsSyn )+happyIn219 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap219 x)+{-# INLINE happyIn219 #-}+happyOut219 :: (HappyAbsSyn ) -> HappyWrap219+happyOut219 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut219 #-}+newtype HappyWrap220 = HappyWrap220 ([LHsCmdTop GhcPs])+happyIn220 :: ([LHsCmdTop GhcPs]) -> (HappyAbsSyn )+happyIn220 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap220 x)+{-# INLINE happyIn220 #-}+happyOut220 :: (HappyAbsSyn ) -> HappyWrap220+happyOut220 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut220 #-}+newtype HappyWrap221 = HappyWrap221 (LHsCmdTop GhcPs)+happyIn221 :: (LHsCmdTop GhcPs) -> (HappyAbsSyn )+happyIn221 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap221 x)+{-# INLINE happyIn221 #-}+happyOut221 :: (HappyAbsSyn ) -> HappyWrap221+happyOut221 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut221 #-}+newtype HappyWrap222 = HappyWrap222 (([AddEpAnn],[LHsDecl GhcPs]))+happyIn222 :: (([AddEpAnn],[LHsDecl GhcPs])) -> (HappyAbsSyn )+happyIn222 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap222 x)+{-# INLINE happyIn222 #-}+happyOut222 :: (HappyAbsSyn ) -> HappyWrap222+happyOut222 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut222 #-}+newtype HappyWrap223 = HappyWrap223 ([LHsDecl GhcPs])+happyIn223 :: ([LHsDecl GhcPs]) -> (HappyAbsSyn )+happyIn223 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap223 x)+{-# INLINE happyIn223 #-}+happyOut223 :: (HappyAbsSyn ) -> HappyWrap223+happyOut223 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut223 #-}+newtype HappyWrap224 = HappyWrap224 (ECP)+happyIn224 :: (ECP) -> (HappyAbsSyn )+happyIn224 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap224 x)+{-# INLINE happyIn224 #-}+happyOut224 :: (HappyAbsSyn ) -> HappyWrap224+happyOut224 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut224 #-}+newtype HappyWrap225 = HappyWrap225 (forall b. DisambECP b => PV (SumOrTuple b))+happyIn225 :: (forall b. DisambECP b => PV (SumOrTuple b)) -> (HappyAbsSyn )+happyIn225 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap225 x)+{-# INLINE happyIn225 #-}+happyOut225 :: (HappyAbsSyn ) -> HappyWrap225+happyOut225 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut225 #-}+newtype HappyWrap226 = HappyWrap226 (forall b. DisambECP b => PV (SrcSpan,[Either (EpAnn EpaLocation) (LocatedA b)]))+happyIn226 :: (forall b. DisambECP b => PV (SrcSpan,[Either (EpAnn EpaLocation) (LocatedA b)])) -> (HappyAbsSyn )+happyIn226 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap226 x)+{-# INLINE happyIn226 #-}+happyOut226 :: (HappyAbsSyn ) -> HappyWrap226+happyOut226 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut226 #-}+newtype HappyWrap227 = HappyWrap227 (forall b. DisambECP b => PV [Either (EpAnn EpaLocation) (LocatedA b)])+happyIn227 :: (forall b. DisambECP b => PV [Either (EpAnn EpaLocation) (LocatedA b)]) -> (HappyAbsSyn )+happyIn227 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap227 x)+{-# INLINE happyIn227 #-}+happyOut227 :: (HappyAbsSyn ) -> HappyWrap227+happyOut227 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut227 #-}+newtype HappyWrap228 = HappyWrap228 (forall b. DisambECP b => SrcSpan -> (AddEpAnn, AddEpAnn) -> PV (LocatedA b))+happyIn228 :: (forall b. DisambECP b => SrcSpan -> (AddEpAnn, AddEpAnn) -> PV (LocatedA b)) -> (HappyAbsSyn )+happyIn228 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap228 x)+{-# INLINE happyIn228 #-}+happyOut228 :: (HappyAbsSyn ) -> HappyWrap228+happyOut228 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut228 #-}+newtype HappyWrap229 = HappyWrap229 (forall b. DisambECP b => PV [LocatedA b])+happyIn229 :: (forall b. DisambECP b => PV [LocatedA b]) -> (HappyAbsSyn )+happyIn229 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap229 x)+{-# INLINE happyIn229 #-}+happyOut229 :: (HappyAbsSyn ) -> HappyWrap229+happyOut229 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut229 #-}+newtype HappyWrap230 = HappyWrap230 (Located [LStmt GhcPs (LHsExpr GhcPs)])+happyIn230 :: (Located [LStmt GhcPs (LHsExpr GhcPs)]) -> (HappyAbsSyn )+happyIn230 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap230 x)+{-# INLINE happyIn230 #-}+happyOut230 :: (HappyAbsSyn ) -> HappyWrap230+happyOut230 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut230 #-}+newtype HappyWrap231 = HappyWrap231 (Located [[LStmt GhcPs (LHsExpr GhcPs)]])+happyIn231 :: (Located [[LStmt GhcPs (LHsExpr GhcPs)]]) -> (HappyAbsSyn )+happyIn231 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap231 x)+{-# INLINE happyIn231 #-}+happyOut231 :: (HappyAbsSyn ) -> HappyWrap231+happyOut231 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut231 #-}+newtype HappyWrap232 = HappyWrap232 (Located [LStmt GhcPs (LHsExpr GhcPs)])+happyIn232 :: (Located [LStmt GhcPs (LHsExpr GhcPs)]) -> (HappyAbsSyn )+happyIn232 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap232 x)+{-# INLINE happyIn232 #-}+happyOut232 :: (HappyAbsSyn ) -> HappyWrap232+happyOut232 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut232 #-}+newtype HappyWrap233 = HappyWrap233 (Located (RealSrcSpan -> [LStmt GhcPs (LHsExpr GhcPs)] -> Stmt GhcPs (LHsExpr GhcPs)))+happyIn233 :: (Located (RealSrcSpan -> [LStmt GhcPs (LHsExpr GhcPs)] -> Stmt GhcPs (LHsExpr GhcPs))) -> (HappyAbsSyn )+happyIn233 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap233 x)+{-# INLINE happyIn233 #-}+happyOut233 :: (HappyAbsSyn ) -> HappyWrap233+happyOut233 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut233 #-}+newtype HappyWrap234 = HappyWrap234 (Located [LStmt GhcPs (LHsExpr GhcPs)])+happyIn234 :: (Located [LStmt GhcPs (LHsExpr GhcPs)]) -> (HappyAbsSyn )+happyIn234 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap234 x)+{-# INLINE happyIn234 #-}+happyOut234 :: (HappyAbsSyn ) -> HappyWrap234+happyOut234 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut234 #-}+newtype HappyWrap235 = HappyWrap235 (Located [LStmt GhcPs (LHsExpr GhcPs)])+happyIn235 :: (Located [LStmt GhcPs (LHsExpr GhcPs)]) -> (HappyAbsSyn )+happyIn235 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap235 x)+{-# INLINE happyIn235 #-}+happyOut235 :: (HappyAbsSyn ) -> HappyWrap235+happyOut235 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut235 #-}+newtype HappyWrap236 = HappyWrap236 (forall b. DisambECP b => PV (Located (GRHSs GhcPs (LocatedA b))))+happyIn236 :: (forall b. DisambECP b => PV (Located (GRHSs GhcPs (LocatedA b)))) -> (HappyAbsSyn )+happyIn236 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap236 x)+{-# INLINE happyIn236 #-}+happyOut236 :: (HappyAbsSyn ) -> HappyWrap236+happyOut236 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut236 #-}+newtype HappyWrap237 = HappyWrap237 (forall b. DisambECP b => PV (Located [LGRHS GhcPs (LocatedA b)]))+happyIn237 :: (forall b. DisambECP b => PV (Located [LGRHS GhcPs (LocatedA b)])) -> (HappyAbsSyn )+happyIn237 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap237 x)+{-# INLINE happyIn237 #-}+happyOut237 :: (HappyAbsSyn ) -> HappyWrap237+happyOut237 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut237 #-}+newtype HappyWrap238 = HappyWrap238 (forall b. DisambECP b => PV (Located [LGRHS GhcPs (LocatedA b)]))+happyIn238 :: (forall b. DisambECP b => PV (Located [LGRHS GhcPs (LocatedA b)])) -> (HappyAbsSyn )+happyIn238 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap238 x)+{-# INLINE happyIn238 #-}+happyOut238 :: (HappyAbsSyn ) -> HappyWrap238+happyOut238 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut238 #-}+newtype HappyWrap239 = HappyWrap239 (Located ([AddEpAnn],[LGRHS GhcPs (LHsExpr GhcPs)]))+happyIn239 :: (Located ([AddEpAnn],[LGRHS GhcPs (LHsExpr GhcPs)])) -> (HappyAbsSyn )+happyIn239 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap239 x)+{-# INLINE happyIn239 #-}+happyOut239 :: (HappyAbsSyn ) -> HappyWrap239+happyOut239 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut239 #-}+newtype HappyWrap240 = HappyWrap240 (forall b. DisambECP b => PV (LGRHS GhcPs (LocatedA b)))+happyIn240 :: (forall b. DisambECP b => PV (LGRHS GhcPs (LocatedA b))) -> (HappyAbsSyn )+happyIn240 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap240 x)+{-# INLINE happyIn240 #-}+happyOut240 :: (HappyAbsSyn ) -> HappyWrap240+happyOut240 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut240 #-}+newtype HappyWrap241 = HappyWrap241 (LPat GhcPs)+happyIn241 :: (LPat GhcPs) -> (HappyAbsSyn )+happyIn241 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap241 x)+{-# INLINE happyIn241 #-}+happyOut241 :: (HappyAbsSyn ) -> HappyWrap241+happyOut241 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut241 #-}+newtype HappyWrap242 = HappyWrap242 ([LPat GhcPs])+happyIn242 :: ([LPat GhcPs]) -> (HappyAbsSyn )+happyIn242 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap242 x)+{-# INLINE happyIn242 #-}+happyOut242 :: (HappyAbsSyn ) -> HappyWrap242+happyOut242 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut242 #-}+newtype HappyWrap243 = HappyWrap243 (LPat GhcPs)+happyIn243 :: (LPat GhcPs) -> (HappyAbsSyn )+happyIn243 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap243 x)+{-# INLINE happyIn243 #-}+happyOut243 :: (HappyAbsSyn ) -> HappyWrap243+happyOut243 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut243 #-}+newtype HappyWrap244 = HappyWrap244 (LPat GhcPs)+happyIn244 :: (LPat GhcPs) -> (HappyAbsSyn )+happyIn244 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap244 x)+{-# INLINE happyIn244 #-}+happyOut244 :: (HappyAbsSyn ) -> HappyWrap244+happyOut244 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut244 #-}+newtype HappyWrap245 = HappyWrap245 ([LPat GhcPs])+happyIn245 :: ([LPat GhcPs]) -> (HappyAbsSyn )+happyIn245 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap245 x)+{-# INLINE happyIn245 #-}+happyOut245 :: (HappyAbsSyn ) -> HappyWrap245+happyOut245 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut245 #-}+newtype HappyWrap246 = HappyWrap246 (forall b. DisambECP b => PV (LocatedL [LocatedA (Stmt GhcPs (LocatedA b))]))+happyIn246 :: (forall b. DisambECP b => PV (LocatedL [LocatedA (Stmt GhcPs (LocatedA b))])) -> (HappyAbsSyn )+happyIn246 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap246 x)+{-# INLINE happyIn246 #-}+happyOut246 :: (HappyAbsSyn ) -> HappyWrap246+happyOut246 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut246 #-}+newtype HappyWrap247 = HappyWrap247 (forall b. DisambECP b => PV (Located (OrdList AddEpAnn,[LStmt GhcPs (LocatedA b)])))+happyIn247 :: (forall b. DisambECP b => PV (Located (OrdList AddEpAnn,[LStmt GhcPs (LocatedA b)]))) -> (HappyAbsSyn )+happyIn247 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap247 x)+{-# INLINE happyIn247 #-}+happyOut247 :: (HappyAbsSyn ) -> HappyWrap247+happyOut247 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut247 #-}+newtype HappyWrap248 = HappyWrap248 (Maybe (LStmt GhcPs (LHsExpr GhcPs)))+happyIn248 :: (Maybe (LStmt GhcPs (LHsExpr GhcPs))) -> (HappyAbsSyn )+happyIn248 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap248 x)+{-# INLINE happyIn248 #-}+happyOut248 :: (HappyAbsSyn ) -> HappyWrap248+happyOut248 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut248 #-}+newtype HappyWrap249 = HappyWrap249 (LStmt GhcPs (LHsExpr GhcPs))+happyIn249 :: (LStmt GhcPs (LHsExpr GhcPs)) -> (HappyAbsSyn )+happyIn249 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap249 x)+{-# INLINE happyIn249 #-}+happyOut249 :: (HappyAbsSyn ) -> HappyWrap249+happyOut249 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut249 #-}+newtype HappyWrap250 = HappyWrap250 (forall b. DisambECP b => PV (LStmt GhcPs (LocatedA b)))+happyIn250 :: (forall b. DisambECP b => PV (LStmt GhcPs (LocatedA b))) -> (HappyAbsSyn )+happyIn250 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap250 x)+{-# INLINE happyIn250 #-}+happyOut250 :: (HappyAbsSyn ) -> HappyWrap250+happyOut250 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut250 #-}+newtype HappyWrap251 = HappyWrap251 (forall b. DisambECP b => PV (LStmt GhcPs (LocatedA b)))+happyIn251 :: (forall b. DisambECP b => PV (LStmt GhcPs (LocatedA b))) -> (HappyAbsSyn )+happyIn251 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap251 x)+{-# INLINE happyIn251 #-}+happyOut251 :: (HappyAbsSyn ) -> HappyWrap251+happyOut251 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut251 #-}+newtype HappyWrap252 = HappyWrap252 (forall b. DisambECP b => PV ([Fbind b], Maybe SrcSpan))+happyIn252 :: (forall b. DisambECP b => PV ([Fbind b], Maybe SrcSpan)) -> (HappyAbsSyn )+happyIn252 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap252 x)+{-# INLINE happyIn252 #-}+happyOut252 :: (HappyAbsSyn ) -> HappyWrap252+happyOut252 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut252 #-}+newtype HappyWrap253 = HappyWrap253 (forall b. DisambECP b => PV ([Fbind b], Maybe SrcSpan))+happyIn253 :: (forall b. DisambECP b => PV ([Fbind b], Maybe SrcSpan)) -> (HappyAbsSyn )+happyIn253 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap253 x)+{-# INLINE happyIn253 #-}+happyOut253 :: (HappyAbsSyn ) -> HappyWrap253+happyOut253 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut253 #-}+newtype HappyWrap254 = HappyWrap254 (forall b. DisambECP b => PV (Fbind b))+happyIn254 :: (forall b. DisambECP b => PV (Fbind b)) -> (HappyAbsSyn )+happyIn254 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap254 x)+{-# INLINE happyIn254 #-}+happyOut254 :: (HappyAbsSyn ) -> HappyWrap254+happyOut254 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut254 #-}+newtype HappyWrap255 = HappyWrap255 (Located [LocatedAn NoEpAnns (DotFieldOcc GhcPs)])+happyIn255 :: (Located [LocatedAn NoEpAnns (DotFieldOcc GhcPs)]) -> (HappyAbsSyn )+happyIn255 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap255 x)+{-# INLINE happyIn255 #-}+happyOut255 :: (HappyAbsSyn ) -> HappyWrap255+happyOut255 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut255 #-}+newtype HappyWrap256 = HappyWrap256 (Located [LIPBind GhcPs])+happyIn256 :: (Located [LIPBind GhcPs]) -> (HappyAbsSyn )+happyIn256 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap256 x)+{-# INLINE happyIn256 #-}+happyOut256 :: (HappyAbsSyn ) -> HappyWrap256+happyOut256 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut256 #-}+newtype HappyWrap257 = HappyWrap257 (LIPBind GhcPs)+happyIn257 :: (LIPBind GhcPs) -> (HappyAbsSyn )+happyIn257 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap257 x)+{-# INLINE happyIn257 #-}+happyOut257 :: (HappyAbsSyn ) -> HappyWrap257+happyOut257 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut257 #-}+newtype HappyWrap258 = HappyWrap258 (Located HsIPName)+happyIn258 :: (Located HsIPName) -> (HappyAbsSyn )+happyIn258 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap258 x)+{-# INLINE happyIn258 #-}+happyOut258 :: (HappyAbsSyn ) -> HappyWrap258+happyOut258 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut258 #-}+newtype HappyWrap259 = HappyWrap259 (Located FastString)+happyIn259 :: (Located FastString) -> (HappyAbsSyn )+happyIn259 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap259 x)+{-# INLINE happyIn259 #-}+happyOut259 :: (HappyAbsSyn ) -> HappyWrap259+happyOut259 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut259 #-}+newtype HappyWrap260 = HappyWrap260 (LBooleanFormula (LocatedN RdrName))+happyIn260 :: (LBooleanFormula (LocatedN RdrName)) -> (HappyAbsSyn )+happyIn260 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap260 x)+{-# INLINE happyIn260 #-}+happyOut260 :: (HappyAbsSyn ) -> HappyWrap260+happyOut260 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut260 #-}+newtype HappyWrap261 = HappyWrap261 (LBooleanFormula (LocatedN RdrName))+happyIn261 :: (LBooleanFormula (LocatedN RdrName)) -> (HappyAbsSyn )+happyIn261 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap261 x)+{-# INLINE happyIn261 #-}+happyOut261 :: (HappyAbsSyn ) -> HappyWrap261+happyOut261 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut261 #-}+newtype HappyWrap262 = HappyWrap262 (LBooleanFormula (LocatedN RdrName))+happyIn262 :: (LBooleanFormula (LocatedN RdrName)) -> (HappyAbsSyn )+happyIn262 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap262 x)+{-# INLINE happyIn262 #-}+happyOut262 :: (HappyAbsSyn ) -> HappyWrap262+happyOut262 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut262 #-}+newtype HappyWrap263 = HappyWrap263 ([LBooleanFormula (LocatedN RdrName)])+happyIn263 :: ([LBooleanFormula (LocatedN RdrName)]) -> (HappyAbsSyn )+happyIn263 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap263 x)+{-# INLINE happyIn263 #-}+happyOut263 :: (HappyAbsSyn ) -> HappyWrap263+happyOut263 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut263 #-}+newtype HappyWrap264 = HappyWrap264 (LBooleanFormula (LocatedN RdrName))+happyIn264 :: (LBooleanFormula (LocatedN RdrName)) -> (HappyAbsSyn )+happyIn264 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap264 x)+{-# INLINE happyIn264 #-}+happyOut264 :: (HappyAbsSyn ) -> HappyWrap264+happyOut264 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut264 #-}+newtype HappyWrap265 = HappyWrap265 (Located [LocatedN RdrName])+happyIn265 :: (Located [LocatedN RdrName]) -> (HappyAbsSyn )+happyIn265 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap265 x)+{-# INLINE happyIn265 #-}+happyOut265 :: (HappyAbsSyn ) -> HappyWrap265+happyOut265 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut265 #-}+newtype HappyWrap266 = HappyWrap266 (LocatedN RdrName)+happyIn266 :: (LocatedN RdrName) -> (HappyAbsSyn )+happyIn266 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap266 x)+{-# INLINE happyIn266 #-}+happyOut266 :: (HappyAbsSyn ) -> HappyWrap266+happyOut266 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut266 #-}+newtype HappyWrap267 = HappyWrap267 (LocatedN RdrName)+happyIn267 :: (LocatedN RdrName) -> (HappyAbsSyn )+happyIn267 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap267 x)+{-# INLINE happyIn267 #-}+happyOut267 :: (HappyAbsSyn ) -> HappyWrap267+happyOut267 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut267 #-}+newtype HappyWrap268 = HappyWrap268 (LocatedN RdrName)+happyIn268 :: (LocatedN RdrName) -> (HappyAbsSyn )+happyIn268 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap268 x)+{-# INLINE happyIn268 #-}+happyOut268 :: (HappyAbsSyn ) -> HappyWrap268+happyOut268 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut268 #-}+newtype HappyWrap269 = HappyWrap269 (LocatedN RdrName)+happyIn269 :: (LocatedN RdrName) -> (HappyAbsSyn )+happyIn269 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap269 x)+{-# INLINE happyIn269 #-}+happyOut269 :: (HappyAbsSyn ) -> HappyWrap269+happyOut269 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut269 #-}+newtype HappyWrap270 = HappyWrap270 (LocatedN RdrName)+happyIn270 :: (LocatedN RdrName) -> (HappyAbsSyn )+happyIn270 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap270 x)+{-# INLINE happyIn270 #-}+happyOut270 :: (HappyAbsSyn ) -> HappyWrap270+happyOut270 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut270 #-}+newtype HappyWrap271 = HappyWrap271 (Located [LocatedN RdrName])+happyIn271 :: (Located [LocatedN RdrName]) -> (HappyAbsSyn )+happyIn271 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap271 x)+{-# INLINE happyIn271 #-}+happyOut271 :: (HappyAbsSyn ) -> HappyWrap271+happyOut271 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut271 #-}+newtype HappyWrap272 = HappyWrap272 (Located [LocatedN RdrName])+happyIn272 :: (Located [LocatedN RdrName]) -> (HappyAbsSyn )+happyIn272 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap272 x)+{-# INLINE happyIn272 #-}+happyOut272 :: (HappyAbsSyn ) -> HappyWrap272+happyOut272 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut272 #-}+newtype HappyWrap273 = HappyWrap273 (LocatedN DataCon)+happyIn273 :: (LocatedN DataCon) -> (HappyAbsSyn )+happyIn273 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap273 x)+{-# INLINE happyIn273 #-}+happyOut273 :: (HappyAbsSyn ) -> HappyWrap273+happyOut273 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut273 #-}+newtype HappyWrap274 = HappyWrap274 (LocatedN DataCon)+happyIn274 :: (LocatedN DataCon) -> (HappyAbsSyn )+happyIn274 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap274 x)+{-# INLINE happyIn274 #-}+happyOut274 :: (HappyAbsSyn ) -> HappyWrap274+happyOut274 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut274 #-}+newtype HappyWrap275 = HappyWrap275 (LocatedN RdrName)+happyIn275 :: (LocatedN RdrName) -> (HappyAbsSyn )+happyIn275 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap275 x)+{-# INLINE happyIn275 #-}+happyOut275 :: (HappyAbsSyn ) -> HappyWrap275+happyOut275 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut275 #-}+newtype HappyWrap276 = HappyWrap276 (LocatedN RdrName)+happyIn276 :: (LocatedN RdrName) -> (HappyAbsSyn )+happyIn276 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap276 x)+{-# INLINE happyIn276 #-}+happyOut276 :: (HappyAbsSyn ) -> HappyWrap276+happyOut276 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut276 #-}+newtype HappyWrap277 = HappyWrap277 (LocatedN RdrName)+happyIn277 :: (LocatedN RdrName) -> (HappyAbsSyn )+happyIn277 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap277 x)+{-# INLINE happyIn277 #-}+happyOut277 :: (HappyAbsSyn ) -> HappyWrap277+happyOut277 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut277 #-}+newtype HappyWrap278 = HappyWrap278 (LocatedN RdrName)+happyIn278 :: (LocatedN RdrName) -> (HappyAbsSyn )+happyIn278 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap278 x)+{-# INLINE happyIn278 #-}+happyOut278 :: (HappyAbsSyn ) -> HappyWrap278+happyOut278 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut278 #-}+newtype HappyWrap279 = HappyWrap279 (LocatedN RdrName)+happyIn279 :: (LocatedN RdrName) -> (HappyAbsSyn )+happyIn279 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap279 x)+{-# INLINE happyIn279 #-}+happyOut279 :: (HappyAbsSyn ) -> HappyWrap279+happyOut279 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut279 #-}+newtype HappyWrap280 = HappyWrap280 (LocatedN RdrName)+happyIn280 :: (LocatedN RdrName) -> (HappyAbsSyn )+happyIn280 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap280 x)+{-# INLINE happyIn280 #-}+happyOut280 :: (HappyAbsSyn ) -> HappyWrap280+happyOut280 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut280 #-}+newtype HappyWrap281 = HappyWrap281 (LocatedN RdrName)+happyIn281 :: (LocatedN RdrName) -> (HappyAbsSyn )+happyIn281 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap281 x)+{-# INLINE happyIn281 #-}+happyOut281 :: (HappyAbsSyn ) -> HappyWrap281+happyOut281 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut281 #-}+newtype HappyWrap282 = HappyWrap282 (LocatedN RdrName)+happyIn282 :: (LocatedN RdrName) -> (HappyAbsSyn )+happyIn282 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap282 x)+{-# INLINE happyIn282 #-}+happyOut282 :: (HappyAbsSyn ) -> HappyWrap282+happyOut282 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut282 #-}+newtype HappyWrap283 = HappyWrap283 (LocatedN RdrName)+happyIn283 :: (LocatedN RdrName) -> (HappyAbsSyn )+happyIn283 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap283 x)+{-# INLINE happyIn283 #-}+happyOut283 :: (HappyAbsSyn ) -> HappyWrap283+happyOut283 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut283 #-}+newtype HappyWrap284 = HappyWrap284 (LocatedN RdrName)+happyIn284 :: (LocatedN RdrName) -> (HappyAbsSyn )+happyIn284 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap284 x)+{-# INLINE happyIn284 #-}+happyOut284 :: (HappyAbsSyn ) -> HappyWrap284+happyOut284 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut284 #-}+newtype HappyWrap285 = HappyWrap285 (LocatedN RdrName)+happyIn285 :: (LocatedN RdrName) -> (HappyAbsSyn )+happyIn285 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap285 x)+{-# INLINE happyIn285 #-}+happyOut285 :: (HappyAbsSyn ) -> HappyWrap285+happyOut285 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut285 #-}+newtype HappyWrap286 = HappyWrap286 (LocatedN RdrName)+happyIn286 :: (LocatedN RdrName) -> (HappyAbsSyn )+happyIn286 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap286 x)+{-# INLINE happyIn286 #-}+happyOut286 :: (HappyAbsSyn ) -> HappyWrap286+happyOut286 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut286 #-}+newtype HappyWrap287 = HappyWrap287 (LocatedN RdrName)+happyIn287 :: (LocatedN RdrName) -> (HappyAbsSyn )+happyIn287 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap287 x)+{-# INLINE happyIn287 #-}+happyOut287 :: (HappyAbsSyn ) -> HappyWrap287+happyOut287 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut287 #-}+newtype HappyWrap288 = HappyWrap288 (LocatedN RdrName)+happyIn288 :: (LocatedN RdrName) -> (HappyAbsSyn )+happyIn288 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap288 x)+{-# INLINE happyIn288 #-}+happyOut288 :: (HappyAbsSyn ) -> HappyWrap288+happyOut288 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut288 #-}+newtype HappyWrap289 = HappyWrap289 (forall b. DisambInfixOp b => PV (LocatedN b))+happyIn289 :: (forall b. DisambInfixOp b => PV (LocatedN b)) -> (HappyAbsSyn )+happyIn289 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap289 x)+{-# INLINE happyIn289 #-}+happyOut289 :: (HappyAbsSyn ) -> HappyWrap289+happyOut289 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut289 #-}+newtype HappyWrap290 = HappyWrap290 (forall b. DisambInfixOp b => PV (LocatedN b))+happyIn290 :: (forall b. DisambInfixOp b => PV (LocatedN b)) -> (HappyAbsSyn )+happyIn290 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap290 x)+{-# INLINE happyIn290 #-}+happyOut290 :: (HappyAbsSyn ) -> HappyWrap290+happyOut290 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut290 #-}+newtype HappyWrap291 = HappyWrap291 (forall b. DisambInfixOp b => PV (Located b))+happyIn291 :: (forall b. DisambInfixOp b => PV (Located b)) -> (HappyAbsSyn )+happyIn291 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap291 x)+{-# INLINE happyIn291 #-}+happyOut291 :: (HappyAbsSyn ) -> HappyWrap291+happyOut291 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut291 #-}+newtype HappyWrap292 = HappyWrap292 (LocatedN RdrName)+happyIn292 :: (LocatedN RdrName) -> (HappyAbsSyn )+happyIn292 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap292 x)+{-# INLINE happyIn292 #-}+happyOut292 :: (HappyAbsSyn ) -> HappyWrap292+happyOut292 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut292 #-}+newtype HappyWrap293 = HappyWrap293 (LocatedN RdrName)+happyIn293 :: (LocatedN RdrName) -> (HappyAbsSyn )+happyIn293 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap293 x)+{-# INLINE happyIn293 #-}+happyOut293 :: (HappyAbsSyn ) -> HappyWrap293+happyOut293 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut293 #-}+newtype HappyWrap294 = HappyWrap294 (LocatedN RdrName)+happyIn294 :: (LocatedN RdrName) -> (HappyAbsSyn )+happyIn294 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap294 x)+{-# INLINE happyIn294 #-}+happyOut294 :: (HappyAbsSyn ) -> HappyWrap294+happyOut294 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut294 #-}+newtype HappyWrap295 = HappyWrap295 (LocatedN RdrName)+happyIn295 :: (LocatedN RdrName) -> (HappyAbsSyn )+happyIn295 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap295 x)+{-# INLINE happyIn295 #-}+happyOut295 :: (HappyAbsSyn ) -> HappyWrap295+happyOut295 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut295 #-}+newtype HappyWrap296 = HappyWrap296 (LocatedN RdrName)+happyIn296 :: (LocatedN RdrName) -> (HappyAbsSyn )+happyIn296 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap296 x)+{-# INLINE happyIn296 #-}+happyOut296 :: (HappyAbsSyn ) -> HappyWrap296+happyOut296 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut296 #-}+newtype HappyWrap297 = HappyWrap297 (LocatedN RdrName)+happyIn297 :: (LocatedN RdrName) -> (HappyAbsSyn )+happyIn297 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap297 x)+{-# INLINE happyIn297 #-}+happyOut297 :: (HappyAbsSyn ) -> HappyWrap297+happyOut297 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut297 #-}+newtype HappyWrap298 = HappyWrap298 (LocatedN RdrName)+happyIn298 :: (LocatedN RdrName) -> (HappyAbsSyn )+happyIn298 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap298 x)+{-# INLINE happyIn298 #-}+happyOut298 :: (HappyAbsSyn ) -> HappyWrap298+happyOut298 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut298 #-}+newtype HappyWrap299 = HappyWrap299 (Located FastString)+happyIn299 :: (Located FastString) -> (HappyAbsSyn )+happyIn299 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap299 x)+{-# INLINE happyIn299 #-}+happyOut299 :: (HappyAbsSyn ) -> HappyWrap299+happyOut299 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut299 #-}+newtype HappyWrap300 = HappyWrap300 (LocatedN RdrName)+happyIn300 :: (LocatedN RdrName) -> (HappyAbsSyn )+happyIn300 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap300 x)+{-# INLINE happyIn300 #-}+happyOut300 :: (HappyAbsSyn ) -> HappyWrap300+happyOut300 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut300 #-}+newtype HappyWrap301 = HappyWrap301 (LocatedN RdrName)+happyIn301 :: (LocatedN RdrName) -> (HappyAbsSyn )+happyIn301 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap301 x)+{-# INLINE happyIn301 #-}+happyOut301 :: (HappyAbsSyn ) -> HappyWrap301+happyOut301 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut301 #-}+newtype HappyWrap302 = HappyWrap302 (LocatedN RdrName)+happyIn302 :: (LocatedN RdrName) -> (HappyAbsSyn )+happyIn302 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap302 x)+{-# INLINE happyIn302 #-}+happyOut302 :: (HappyAbsSyn ) -> HappyWrap302+happyOut302 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut302 #-}+newtype HappyWrap303 = HappyWrap303 (LocatedN RdrName)+happyIn303 :: (LocatedN RdrName) -> (HappyAbsSyn )+happyIn303 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap303 x)+{-# INLINE happyIn303 #-}+happyOut303 :: (HappyAbsSyn ) -> HappyWrap303+happyOut303 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut303 #-}+newtype HappyWrap304 = HappyWrap304 (LocatedN RdrName)+happyIn304 :: (LocatedN RdrName) -> (HappyAbsSyn )+happyIn304 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap304 x)+{-# INLINE happyIn304 #-}+happyOut304 :: (HappyAbsSyn ) -> HappyWrap304+happyOut304 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut304 #-}+newtype HappyWrap305 = HappyWrap305 (LocatedN RdrName)+happyIn305 :: (LocatedN RdrName) -> (HappyAbsSyn )+happyIn305 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap305 x)+{-# INLINE happyIn305 #-}+happyOut305 :: (HappyAbsSyn ) -> HappyWrap305+happyOut305 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut305 #-}+newtype HappyWrap306 = HappyWrap306 (LocatedN RdrName)+happyIn306 :: (LocatedN RdrName) -> (HappyAbsSyn )+happyIn306 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap306 x)+{-# INLINE happyIn306 #-}+happyOut306 :: (HappyAbsSyn ) -> HappyWrap306+happyOut306 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut306 #-}+newtype HappyWrap307 = HappyWrap307 (Located FastString)+happyIn307 :: (Located FastString) -> (HappyAbsSyn )+happyIn307 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap307 x)+{-# INLINE happyIn307 #-}+happyOut307 :: (HappyAbsSyn ) -> HappyWrap307+happyOut307 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut307 #-}+newtype HappyWrap308 = HappyWrap308 (Located FastString)+happyIn308 :: (Located FastString) -> (HappyAbsSyn )+happyIn308 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap308 x)+{-# INLINE happyIn308 #-}+happyOut308 :: (HappyAbsSyn ) -> HappyWrap308+happyOut308 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut308 #-}+newtype HappyWrap309 = HappyWrap309 (LocatedN RdrName)+happyIn309 :: (LocatedN RdrName) -> (HappyAbsSyn )+happyIn309 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap309 x)+{-# INLINE happyIn309 #-}+happyOut309 :: (HappyAbsSyn ) -> HappyWrap309+happyOut309 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut309 #-}+newtype HappyWrap310 = HappyWrap310 (LocatedN RdrName)+happyIn310 :: (LocatedN RdrName) -> (HappyAbsSyn )+happyIn310 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap310 x)+{-# INLINE happyIn310 #-}+happyOut310 :: (HappyAbsSyn ) -> HappyWrap310+happyOut310 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut310 #-}+newtype HappyWrap311 = HappyWrap311 (LocatedN RdrName)+happyIn311 :: (LocatedN RdrName) -> (HappyAbsSyn )+happyIn311 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap311 x)+{-# INLINE happyIn311 #-}+happyOut311 :: (HappyAbsSyn ) -> HappyWrap311+happyOut311 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut311 #-}+newtype HappyWrap312 = HappyWrap312 (LocatedN RdrName)+happyIn312 :: (LocatedN RdrName) -> (HappyAbsSyn )+happyIn312 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap312 x)+{-# INLINE happyIn312 #-}+happyOut312 :: (HappyAbsSyn ) -> HappyWrap312+happyOut312 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut312 #-}+newtype HappyWrap313 = HappyWrap313 (Located (HsLit GhcPs))+happyIn313 :: (Located (HsLit GhcPs)) -> (HappyAbsSyn )+happyIn313 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap313 x)+{-# INLINE happyIn313 #-}+happyOut313 :: (HappyAbsSyn ) -> HappyWrap313+happyOut313 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut313 #-}+newtype HappyWrap314 = HappyWrap314 (())+happyIn314 :: (()) -> (HappyAbsSyn )+happyIn314 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap314 x)+{-# INLINE happyIn314 #-}+happyOut314 :: (HappyAbsSyn ) -> HappyWrap314+happyOut314 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut314 #-}+newtype HappyWrap315 = HappyWrap315 (LocatedA ModuleName)+happyIn315 :: (LocatedA ModuleName) -> (HappyAbsSyn )+happyIn315 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap315 x)+{-# INLINE happyIn315 #-}+happyOut315 :: (HappyAbsSyn ) -> HappyWrap315+happyOut315 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut315 #-}+newtype HappyWrap316 = HappyWrap316 (([SrcSpan],Int))+happyIn316 :: (([SrcSpan],Int)) -> (HappyAbsSyn )+happyIn316 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap316 x)+{-# INLINE happyIn316 #-}+happyOut316 :: (HappyAbsSyn ) -> HappyWrap316+happyOut316 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut316 #-}+newtype HappyWrap317 = HappyWrap317 (([SrcSpan],Int))+happyIn317 :: (([SrcSpan],Int)) -> (HappyAbsSyn )+happyIn317 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap317 x)+{-# INLINE happyIn317 #-}+happyOut317 :: (HappyAbsSyn ) -> HappyWrap317+happyOut317 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut317 #-}+newtype HappyWrap318 = HappyWrap318 (([SrcSpan],Int))+happyIn318 :: (([SrcSpan],Int)) -> (HappyAbsSyn )+happyIn318 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap318 x)+{-# INLINE happyIn318 #-}+happyOut318 :: (HappyAbsSyn ) -> HappyWrap318+happyOut318 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut318 #-}+newtype HappyWrap319 = HappyWrap319 (forall b. DisambECP b => PV (LocatedL [LMatch GhcPs (LocatedA b)]))+happyIn319 :: (forall b. DisambECP b => PV (LocatedL [LMatch GhcPs (LocatedA b)])) -> (HappyAbsSyn )+happyIn319 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap319 x)+{-# INLINE happyIn319 #-}+happyOut319 :: (HappyAbsSyn ) -> HappyWrap319+happyOut319 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut319 #-}+newtype HappyWrap320 = HappyWrap320 (forall b. DisambECP b => PV (LocatedL [LMatch GhcPs (LocatedA b)]))+happyIn320 :: (forall b. DisambECP b => PV (LocatedL [LMatch GhcPs (LocatedA b)])) -> (HappyAbsSyn )+happyIn320 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap320 x)+{-# INLINE happyIn320 #-}+happyOut320 :: (HappyAbsSyn ) -> HappyWrap320+happyOut320 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut320 #-}+newtype HappyWrap321 = HappyWrap321 (ECP)+happyIn321 :: (ECP) -> (HappyAbsSyn )+happyIn321 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap321 x)+{-# INLINE happyIn321 #-}+happyOut321 :: (HappyAbsSyn ) -> HappyWrap321+happyOut321 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut321 #-}+newtype HappyWrap322 = HappyWrap322 (ECP)+happyIn322 :: (ECP) -> (HappyAbsSyn )+happyIn322 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap322 x)+{-# INLINE happyIn322 #-}+happyOut322 :: (HappyAbsSyn ) -> HappyWrap322+happyOut322 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut322 #-}+newtype HappyWrap323 = HappyWrap323 (forall b. DisambECP b => PV (Located ([AddEpAnn],[LMatch GhcPs (LocatedA b)])))+happyIn323 :: (forall b. DisambECP b => PV (Located ([AddEpAnn],[LMatch GhcPs (LocatedA b)]))) -> (HappyAbsSyn )+happyIn323 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap323 x)+{-# INLINE happyIn323 #-}+happyOut323 :: (HappyAbsSyn ) -> HappyWrap323+happyOut323 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut323 #-}+newtype HappyWrap324 = HappyWrap324 (forall b. DisambECP b => PV (Located ([AddEpAnn],[LMatch GhcPs (LocatedA b)])))+happyIn324 :: (forall b. DisambECP b => PV (Located ([AddEpAnn],[LMatch GhcPs (LocatedA b)]))) -> (HappyAbsSyn )+happyIn324 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap324 x)+{-# INLINE happyIn324 #-}+happyOut324 :: (HappyAbsSyn ) -> HappyWrap324+happyOut324 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut324 #-}+newtype HappyWrap325 = HappyWrap325 (forall b. DisambECP b => PV (Located ([AddEpAnn],[LMatch GhcPs (LocatedA b)])))+happyIn325 :: (forall b. DisambECP b => PV (Located ([AddEpAnn],[LMatch GhcPs (LocatedA b)]))) -> (HappyAbsSyn )+happyIn325 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap325 x)+{-# INLINE happyIn325 #-}+happyOut325 :: (HappyAbsSyn ) -> HappyWrap325+happyOut325 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut325 #-}+newtype HappyWrap326 = HappyWrap326 (forall b. DisambECP b => PV (Located ([AddEpAnn],[LMatch GhcPs (LocatedA b)])))+happyIn326 :: (forall b. DisambECP b => PV (Located ([AddEpAnn],[LMatch GhcPs (LocatedA b)]))) -> (HappyAbsSyn )+happyIn326 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap326 x)+{-# INLINE happyIn326 #-}+happyOut326 :: (HappyAbsSyn ) -> HappyWrap326+happyOut326 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut326 #-}+newtype HappyWrap327 = HappyWrap327 (forall b. DisambECP b => PV (LMatch GhcPs (LocatedA b)))+happyIn327 :: (forall b. DisambECP b => PV (LMatch GhcPs (LocatedA b))) -> (HappyAbsSyn )+happyIn327 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap327 x)+{-# INLINE happyIn327 #-}+happyOut327 :: (HappyAbsSyn ) -> HappyWrap327+happyOut327 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut327 #-}+newtype HappyWrap328 = HappyWrap328 (forall b. DisambECP b => PV (LMatch GhcPs (LocatedA b)))+happyIn328 :: (forall b. DisambECP b => PV (LMatch GhcPs (LocatedA b))) -> (HappyAbsSyn )+happyIn328 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap328 x)+{-# INLINE happyIn328 #-}+happyOut328 :: (HappyAbsSyn ) -> HappyWrap328+happyOut328 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut328 #-}+happyInTok :: ((Located Token)) -> (HappyAbsSyn )+happyInTok x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyInTok #-}+happyOutTok :: (HappyAbsSyn ) -> ((Located Token))+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\x00\x00\x00\x00\x00\x00\x00\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\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\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\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\x1c\x0c\x44\xf4\xff\x8f\x3f\x10\x00\x40\x80\x07\x00\xaa\x70\xe6\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7f\xf3\x55\xff\xff\xf2\xff\x9e\x41\x10\xe0\x01\x80\x2a\x9c\xf9\xff\x5f\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xc1\x40\x44\xff\xbf\xf8\x03\x01\x00\x04\x78\x00\xa0\x0a\x67\xfe\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x30\x10\xd1\xff\x2f\xfe\x40\x00\x00\x01\x1e\x00\xa8\xc2\x99\xff\xff\xf5\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\x1c\xcc\x45\xf4\xff\xcb\xff\x13\x04\x41\x80\x07\x00\xaa\x70\xe6\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x03\x11\xfd\xff\xe3\x0f\x04\x00\x10\xe0\x01\x80\x2a\x9c\xf9\xff\x5f\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x40\x00\x44\xff\x9f\xf0\x03\x00\x80\x80\x88\x10\xa0\x82\xfe\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\x30\x10\x00\xd1\xcf\x27\xfc\x00\x06\x20\x00\x2e\x84\xa8\xe0\x77\x3a\x00\x90\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x04\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x40\x00\x44\xff\x9f\xf0\x03\x00\x00\x00\x00\x00\x80\x00\x22\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x22\x04\x00\x00\x22\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x10\x00\xc1\xcf\x27\xfc\x00\x06\x20\x00\x2e\x84\xa8\xe0\x77\x38\x00\x90\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\x0c\x04\x40\xf4\xf3\x09\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x9d\x0e\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x06\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x10\x00\xc1\xcf\x27\xfc\x00\x06\x20\x00\x2e\xa4\xa8\xe0\x77\x38\x00\x90\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x01\x10\xfc\x7c\xc2\x0f\x00\x00\x00\x00\x00\x08\x02\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x01\x10\xfc\x7c\xc2\x0f\x00\x00\x00\xc0\x02\x88\x0a\x1c\x81\x03\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x40\x00\x04\x3f\x9f\xf0\x03\x00\x00\x00\xb0\x00\xa2\x02\x47\xe0\x00\x40\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x01\x10\xfd\x7f\xc2\x0f\x00\x00\x00\x00\x00\x00\x02\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\x00\x00\x00\x00\x00\x00\x00\xc0\x40\x00\x44\x3f\x9f\xf0\x03\x18\x80\x00\xb8\x10\xe2\x82\xdf\xe9\x00\x40\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\x00\x00\x00\x00\x00\x00\x00\x00\x30\x10\x00\xd1\xcf\x27\xfc\x00\x06\x20\x20\x2e\x84\xe8\xf0\x77\x3a\x00\x90\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\x0c\x04\x40\xf4\xf3\x09\x3f\x80\x01\x08\x82\x0b\x21\x6a\xfc\x9d\x0e\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x01\x10\xfc\x7c\xc2\x0f\x00\x00\x00\x00\x00\x00\x00\x18\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\x80\x40\x00\x44\xff\x9f\xf0\x03\x00\x80\x00\x88\x10\xa0\x82\x5e\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x40\x00\x44\xff\x9f\xf0\x03\x00\x00\x00\x00\x00\xa0\x0a\x67\xf8\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x20\x20\x22\x04\x40\x10\x66\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x02\x01\x10\xfd\x7f\xc2\x0f\x00\x00\x00\x00\x00\x00\x00\x98\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x01\x88\x1f\x00\x80\x98\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\x1c\x0c\x44\xf4\xff\x8b\x3f\x10\x00\x40\x80\x07\x00\xaa\x70\xe6\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x03\x11\xfd\xff\xc2\x0f\x00\x00\x10\xc0\x01\x82\x2a\x9c\xf9\xff\x5f\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\xc1\x40\x44\xff\xbf\xf8\x03\x01\x00\x04\x78\x00\xa0\x0a\x67\xfe\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x30\x10\xd1\xff\x2f\xfe\x40\x00\x00\x09\x1e\x80\xa8\xc2\x99\xff\xff\xf5\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\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\x00\x00\x07\x03\x11\xfd\xff\xc2\x0f\x00\x00\x10\xc0\x01\x80\x2a\x9c\xf9\xff\x5f\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\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x30\x10\xd1\xff\x2f\xfc\x00\x00\x00\x01\x1c\x00\xa8\xc2\x99\xff\xff\xf5\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\x20\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\x07\x03\x11\xfd\xff\xc2\x0f\x00\x00\x70\xc0\x01\x80\x2a\x9c\xf9\xff\x5f\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xc1\x40\x44\xff\xbf\xf8\x03\x00\x00\x04\x70\x00\xa0\x0a\x67\xfe\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x30\x10\xd1\xff\x2f\xfc\x00\x00\x00\x01\x1c\x00\xa8\xc2\x99\xff\xff\xf5\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\x1c\x0c\x44\xf4\xff\x0b\x3f\x00\x00\x40\x00\x07\x00\xaa\x70\xe6\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x03\x11\xfd\xff\xc2\x0f\x00\x00\x10\xc0\x01\x80\x2a\x9c\xf9\xff\x5f\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xc1\x40\x44\xff\xbf\xf8\x03\x01\x80\x04\xf8\x10\xe0\x8a\xff\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x30\x10\xd1\xff\x2f\xfe\x40\x00\x20\x09\x3e\x0c\xe8\xf2\xff\xff\xff\xf5\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\x1c\x0c\x44\xf4\xff\x8b\x3f\x10\x00\x48\x82\x0f\x01\xea\xfc\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x03\x11\xfd\xff\xc2\x0f\x00\x00\x10\xc0\x01\x80\x2a\x9c\xf9\xff\x5f\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x40\x00\x44\xff\x9f\xf0\x03\x00\x00\x00\x00\x00\xa0\x02\x66\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf4\xff\x8b\x3f\x10\x00\x40\x80\x07\x00\xaa\x70\xe6\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x03\x11\xfd\xff\xe2\x0f\x00\x00\x10\xe0\x01\x80\x2a\x9c\xf9\xff\x5f\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x40\x00\x44\x3f\x9f\xf0\x03\x18\x80\x00\xb8\x10\xa2\x82\xdf\xe9\x00\x40\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\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf4\xff\x8b\x3f\x10\x00\x40\x80\x07\x00\xaa\x70\xe6\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x01\x10\xfd\x7f\xc2\x0f\x00\x00\x00\x00\x00\x80\x2a\x9c\xe1\xff\x5f\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x40\x00\x04\x3f\x9f\xf0\x03\x00\x00\x00\x00\x00\xa0\x02\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x01\x88\x10\x00\x80\x98\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x0a\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x10\x00\xd1\xff\x27\xfc\x00\x00\x00\x00\x00\x00\x20\x80\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\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\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\x00\x00\x00\x00\x00\x80\x40\x00\x44\xff\x9f\xf0\x03\x00\x00\x00\x00\x00\x80\x00\x22\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x10\x00\xd1\xff\x27\xfc\x00\x00\x00\x00\x00\x00\xa8\x80\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\x2a\x40\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\x07\x03\x11\xfd\xff\xe2\x0f\x04\x00\x92\xe0\xc3\x80\x2e\xff\xff\xff\x5f\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x20\x42\x00\x00\x62\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x40\x00\x04\x3f\x9f\xf0\x03\x18\x80\x00\xb8\x10\xa2\x82\xdf\xe1\x00\x40\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\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\xc0\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x04\x42\xf0\xff\x09\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x1d\x0e\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\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\x80\x40\x00\x44\xff\x9f\xf0\x03\x00\x00\x00\x00\x00\xa0\x02\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\x00\x00\x00\x00\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\x08\x04\x40\xf4\xff\x09\x3f\x00\x00\x00\x00\x00\x00\x2a\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x01\x10\xfd\x7f\xc2\x0f\x00\x00\x00\x00\x00\x80\x0a\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\x00\x00\x00\x00\x00\x00\x00\x00\x80\x40\x80\x54\xff\x9f\xf0\x03\x00\x00\x00\x00\x00\xa0\x02\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x30\x10\xd1\xff\x2f\xfc\x00\x00\x00\x01\x1c\x00\xa8\xc2\x99\xff\xff\xf5\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x03\x11\xfd\xff\xc2\x0f\x00\x00\x10\xc0\x01\x80\x2a\x9c\xf9\xff\x5f\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\x00\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\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\x20\x00\x22\x04\x40\x10\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\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x08\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x10\x00\xd1\xff\x27\xfc\x00\x00\x00\x00\x00\x80\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\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\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x41\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x40\x00\x44\x3f\x9f\xf0\x03\x18\x80\x00\xb8\x10\xa2\x82\xdf\xe1\x00\x40\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\x00\x00\x00\x00\x00\x00\x00\x00\x30\x10\x00\xc1\xcf\x27\xfc\x00\x06\x20\x00\x2e\x84\xa8\xe0\x77\x38\x00\x90\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\x08\x40\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\x03\x01\x10\xfd\x7c\xc2\x0f\x60\x00\x02\xe0\x42\x88\x0a\x7e\xa7\x03\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\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\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x10\x00\xd1\xcf\x27\xfc\x00\x06\x20\x00\x2e\x84\xa8\xe0\x77\x3a\x00\x90\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\x0c\x04\x40\xf4\xf3\x09\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x9d\x0e\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x01\x10\xfc\x7c\xc2\x0f\x60\x00\x02\xe0\x42\x88\x0a\x7e\x87\x03\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x30\x10\xd1\xff\x2f\xfe\x40\x00\x00\x01\x1e\x00\xa8\xc2\x99\xff\xff\xf5\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\x00\x00\x00\x00\x00\x00\xc0\x40\x00\x44\x3f\x9f\xf0\x03\x18\x80\x00\xb8\x10\xa2\x82\xdf\xe9\x00\x40\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\x00\x00\x00\x00\x00\x00\x00\x00\x30\x10\x00\xd1\xff\x27\xfc\x00\x00\x00\x00\x00\x00\x00\x80\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x04\x40\xf0\xf3\x09\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x1d\x0e\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\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\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x80\xf8\x01\x00\x88\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x20\x00\x00\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x03\x11\xfd\xff\xe2\x0f\x00\x00\x10\xe0\x01\x80\x2a\x9c\xf9\xff\x5f\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x07\x03\x11\xfd\xff\xe2\x0f\x04\x00\x12\xe0\x43\x80\x2e\xff\xff\xff\x5f\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xc1\x40\x44\xff\xbf\xf8\x03\x01\x80\x24\xf8\x10\xa0\x8a\xff\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf4\xff\x8b\x3f\x00\x00\x40\x00\x07\x00\xaa\x70\xe6\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x01\x10\xfd\x7f\xc2\x0f\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x04\x40\xf4\xff\x09\x3f\x00\x00\x00\x00\x00\x00\x00\x60\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\x00\x00\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\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\x20\x00\x00\x00\x40\x10\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x40\x00\x44\xff\x9f\xf0\x03\x00\x80\x00\x88\x10\xa0\x43\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x08\x04\x40\xf4\xff\x09\x3f\x00\x00\x00\x00\x00\x00\x08\x20\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x08\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\x00\x00\x20\x10\x00\xd1\xff\x27\xfc\x00\x00\x00\x00\x00\x00\x20\x80\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\x00\x00\x00\x00\x00\x00\x00\x0c\x04\x40\xf4\xf3\x09\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x9d\x0e\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x40\x00\x44\xff\x9f\xf0\x03\x00\x00\x00\x00\x00\xa0\x02\x66\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xc1\x5c\x44\xff\xbf\xfc\x3f\x41\x10\x04\x78\x00\xa0\x0a\x67\xfe\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x30\x17\xd1\xff\x2f\xff\x4f\x10\x04\x01\x1e\x00\xa8\xc2\x99\xff\xff\xf5\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\x08\x04\x40\xf4\xff\x09\x3f\x00\x00\x00\x00\x00\x00\x08\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x01\x10\xfd\x7c\xc2\x0f\x60\x00\x02\xe0\x42\x88\x0a\x7e\xa7\x03\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x80\x88\x10\x00\x80\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x08\x88\x00\x01\x10\x84\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x10\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\x00\x00\x00\x00\x00\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x20\x42\x00\x00\x62\x06\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf4\xff\x8f\x3f\x10\x00\x40\x80\x07\x00\xaa\x70\xe6\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x03\x11\xfd\xff\xe3\x0f\x04\x00\x10\xe0\x01\x80\x2a\x9c\xf9\xff\x5f\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x20\x42\x00\x04\x61\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x30\x10\xd1\xff\x2f\xfe\x40\x00\x20\x01\x3e\x04\xa8\xf3\xff\xff\xff\xf5\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\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\x40\x20\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\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x03\x11\xfd\xff\xc2\x0f\x00\x00\x10\xc0\x01\x82\x2a\x9c\xf9\xff\x5f\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x30\x10\xd1\xff\x2f\xfc\x00\x00\x00\x01\x1c\x00\xa8\xc2\x99\xff\xff\xf5\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x28\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x20\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x03\x11\xfd\xff\xe2\x0f\x04\x00\x10\xe0\x01\x80\x2a\x9c\xf9\xff\x5f\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\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf4\xff\x0b\x3f\x00\x00\x40\x00\x07\x00\xaa\x70\xe6\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x03\x11\xfd\xff\xe2\x0f\x04\x00\x10\xe0\x01\x80\x2a\x9c\xf9\xff\x5f\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x40\x00\x44\xff\x9f\xf0\x03\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\x20\x10\x00\xd1\xff\x27\xfc\x00\x00\x10\x00\x00\x00\x20\x80\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x01\x10\xfc\x7c\xc2\x0f\x00\x00\x00\xc0\x02\x88\x0a\x1c\x81\x03\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x10\x00\xd1\xcf\x27\xfc\x00\x06\x20\x00\x2e\x84\xa8\xe0\x77\x3a\x00\x90\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\x1c\x0c\x44\xf4\xff\x8b\x3f\x10\x00\x40\x80\x07\x00\xaa\x70\xe6\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x03\x11\xfd\xff\xe2\x0f\x04\x00\x10\xe0\x01\x80\x2a\x9c\xf9\xff\x5f\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xc1\x40\x44\xff\xbf\xf8\x03\x01\x00\x04\x78\x00\xa0\x0a\x67\xfe\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x30\x10\xd1\xff\x2f\xfe\x40\x00\x00\x01\x1e\x00\xa8\xc2\x99\xff\xff\xf5\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\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x10\x00\xd1\xcf\x27\xfc\x00\x06\x20\x00\x2e\x84\xa8\xe0\x77\x3a\x00\x90\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\x0c\x04\x40\xf4\xf3\x09\x3f\x80\x01\x08\x80\x0b\x21\x3a\xfc\x9d\x0e\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x01\x10\xfd\x7f\xc2\x0f\x00\x00\x00\x00\x00\x00\x00\x18\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\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\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\x00\x00\x00\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\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\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\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\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x10\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x04\x40\xf4\xff\x09\x3f\x00\x00\x00\x00\x00\x00\x2a\x60\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x02\x01\x10\xfc\x7c\xc2\x0f\x00\x00\x00\x00\x00\x08\x02\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x04\x40\xf0\xf3\x09\x3f\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x01\x10\xfc\x7c\xc2\x0f\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\x00\x00\x00\x00\x00\x00\x00\xc0\x40\x00\x44\x3f\x9f\xf0\x03\x18\x80\x00\xb8\x10\xa2\x82\xdf\xe9\x00\x40\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\x00\x00\x00\x00\x00\x00\x00\x00\x30\x10\x00\xc1\xcf\x27\xfc\x00\x00\x00\x00\x2c\x80\xa8\xc0\x11\x38\x00\x90\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\x03\x01\x10\xfc\x7c\xc2\x0f\x60\x00\x02\xe0\x42\x88\x0a\x7e\x87\x03\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x10\x00\xc1\xcf\x27\xfc\x00\x00\x00\x00\x2c\x80\xa8\xc0\x11\x38\x00\x90\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x01\x10\xfd\x7c\xc2\x0f\x60\x00\x02\xe0\x42\x88\x0a\x7e\xa7\x03\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x40\x00\x44\x3f\x9f\xf0\x03\x18\x80\x00\xb8\x10\xa2\x82\xdf\xe9\x00\x40\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\x00\x00\x00\x00\x00\x00\x00\x00\x30\x10\x00\xc1\xcf\x27\xfc\x00\x00\x00\x00\x2c\x80\xa8\xc0\x11\x38\x00\x90\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\x0c\x04\x40\xf4\xf3\x09\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x9d\x0e\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x01\x10\xfd\x7c\xc2\x0f\x60\x00\x02\xe0\x42\x88\x0a\x7e\xa7\x03\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x40\x00\x04\x07\x9f\xf0\x03\x00\x00\x00\x00\x00\x00\x00\x06\x40\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\x04\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\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\x08\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x48\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x10\x00\xd1\xcf\x27\xfc\x00\x06\x20\x00\x2e\x84\xa8\xe0\x77\x3a\x00\x90\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x04\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x40\x00\x44\xff\x9f\xf0\x03\x00\x00\x00\x00\x00\x80\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x04\x40\xf4\xf3\x09\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x9d\x0e\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x01\x10\xfd\x7f\xc2\x0f\x00\x00\x00\x00\x00\x00\x02\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x10\x00\xd1\xcf\x27\xfc\x00\x06\x20\x00\x2e\x84\xa8\xe0\x77\x3a\x00\x90\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x01\x10\xfd\x7c\xc2\x0f\x60\x00\x02\xe0\x42\x88\x0a\x7e\xa7\x03\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x10\x00\xd1\xcf\x27\xfc\x00\x06\x20\x00\x2e\x84\xa8\xe0\x77\x3a\x00\x90\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\x0c\x04\x40\xf4\xf3\x09\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x9d\x0e\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\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\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf4\xff\x8b\x3f\x10\x00\x40\x80\x07\x00\xaa\x70\xe6\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x03\x11\xfd\xff\xe2\x0f\x04\x00\x10\xe0\x01\x80\x2a\x9c\xf9\xff\x5f\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x03\x11\xfd\xff\xc2\x0f\x00\x00\x10\xc0\x01\x90\xaa\x9c\xf9\xff\x5f\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\xc0\xc1\x40\x44\xff\xbf\xf0\x03\x00\x00\x04\x70\x00\xb0\x2a\x67\xfe\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf4\xff\x8b\x3f\x10\x00\x40\x80\x07\x40\xaa\x72\xe6\xff\x7f\x7d\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\x07\x03\x11\xfd\xff\xe2\x0f\x04\x00\x10\xe0\x01\xc0\xaa\x9c\xf9\xff\x5f\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xc1\x40\x44\xff\xbf\xf8\x03\x01\x00\x04\x78\x00\xa0\x0a\x67\xfe\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf4\xff\x8b\x3f\x10\x00\x48\x80\x0f\x01\xaa\xf8\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\xc1\x40\x44\xff\xbf\xf8\x03\x01\x00\x04\x78\x00\xa0\x0a\x67\xfe\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x30\x10\xd3\xff\x2f\xfe\x40\x00\x00\x01\x1e\x00\xa8\xc2\x99\xff\xff\xf5\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\x1c\x0c\x44\xf4\xff\x8b\x3f\x10\x00\x48\x80\x0f\x01\xaa\xf8\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\xc1\x40\x44\xff\xbf\xf8\x03\x01\x80\x04\xf8\x10\xa0\xca\xff\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x03\x11\xfd\xff\xc2\x0f\x00\x00\x10\xc0\x01\x80\x6a\x9c\xf9\xff\x5f\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\x00\x00\x10\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7f\xf3\x55\xff\xff\xf2\xff\x9e\x41\x10\xe0\x01\x80\x2a\x9c\xf9\xff\x5f\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\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x10\x00\xd1\xff\x27\xfc\x00\x00\x00\x00\x00\x00\x00\x80\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x40\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\x04\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x01\x88\x10\x00\x80\x98\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\x00\x00\x00\x00\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\x00\x00\x00\x00\x10\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\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\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\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\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\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\x08\x04\x40\xf4\xff\x09\x3f\x00\x00\x00\x00\x00\x00\x2a\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x01\x10\xfd\x7f\xc2\x0f\x00\x00\x00\x00\x00\x80\x0a\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2a\x40\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\x80\x0a\x10\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\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x22\x04\x00\x20\x66\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x40\x00\x44\xff\x9f\xf0\x03\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf4\xff\x8b\x3f\x10\x00\x40\x80\x07\x00\xaa\x70\xe6\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x03\x11\xfd\xff\xe2\x0f\x04\x00\x12\xe0\x43\x80\x2a\xfe\xff\xff\x5f\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\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\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\x30\x10\x00\xd1\xcf\x27\xfc\x00\x06\x20\x00\x2e\x84\xa8\xe0\x77\x38\x00\x90\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\x30\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf4\xff\x8b\x3f\x10\x00\x40\x80\x07\x00\xaa\x70\xe6\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x03\x11\xfd\xff\xe2\x0f\x04\x00\x10\xe0\x01\x80\x2a\x9c\xf9\xff\x5f\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xc1\x40\x44\xff\xbf\xf8\x03\x01\x00\x04\x78\x00\xa0\x0a\x67\xfe\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x10\x00\xc1\xcf\x27\xfc\x00\x06\x20\x00\x2e\x84\xa8\xe0\x77\x38\x00\x90\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\xc0\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x08\x10\x00\x00\x98\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\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x40\x00\x04\x3f\x9f\xf0\x03\x00\x00\x00\x00\x00\x82\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\x30\x10\x00\xd1\xcf\x27\xfc\x00\x06\x20\x00\x2e\x84\xa8\xe0\x77\x3a\x00\x90\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\x0c\x04\x40\xf4\xf3\x09\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x9d\x0e\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\x00\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\x10\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\x80\x40\x00\x44\xff\x9f\xf0\x03\x00\x00\x00\x00\x00\x80\x00\x02\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x04\x40\xf4\xff\x09\x3f\x00\x00\x00\x00\x00\x00\x08\x20\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\x02\x01\x10\xfd\x7f\xc2\x0f\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x10\x00\xd1\xcf\x27\xfc\x00\x06\x20\x00\x2e\x84\xa8\xe0\x77\x3a\x00\x90\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\x02\x01\x10\xfd\x7f\xc2\x0f\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\x00\x00\x00\x00\x00\x00\x00\x80\x40\x00\x44\xff\x9f\xf0\x03\x00\x00\x00\x00\x00\x80\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\x70\x30\x10\xd1\xff\x2f\xfe\x40\x00\x00\x01\x1e\x00\xa8\xc2\x99\xff\xff\xf5\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\x1c\x0c\x44\xf4\xff\x8b\x3f\x10\x00\x40\x80\x07\x00\xaa\x70\xe6\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x02\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x40\x00\x44\xff\x9f\xf0\x03\x00\x00\x00\x00\x00\xa0\x02\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x10\x00\xd1\xff\x27\xfc\x00\x00\x00\x00\x00\x00\xa8\x80\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x40\x00\x44\xff\x9f\xf0\x03\x00\x00\x00\x00\x00\xa0\x02\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf4\xff\x0b\x3f\x00\x00\x40\x00\x07\x00\xaa\x70\xe6\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x20\x40\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\xcd\x57\xfd\xff\xcb\xff\x7b\x06\x41\x80\x07\x00\xaa\x70\xe6\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x40\x80\x54\xff\x9f\xf4\x03\x00\x00\x00\x00\x00\x80\x40\x66\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\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\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\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\xc0\xc1\x40\x44\xff\xbf\xf8\x03\x00\x00\x04\x78\x00\xa0\x0a\x67\xfe\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x10\x00\xd1\xff\x27\xfc\x00\x00\x00\x00\x00\x00\x20\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x04\x40\xf4\xff\x09\x3f\x00\x00\x00\x00\x00\x00\x08\x20\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x40\x00\x44\xff\x9f\xf0\x03\x00\x00\x00\x00\x00\x80\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x04\x40\xf4\xf3\x09\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x9d\x0e\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x40\x00\x44\x3f\x9f\xf0\x03\x18\x80\x00\xb8\x10\xa2\x82\xdf\xe9\x00\x40\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\x00\x00\x00\x00\x00\x00\x00\x00\x20\x10\x00\xc1\xcf\x27\xfc\x00\x00\x00\x00\x00\x80\x20\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x10\x00\xd1\xcf\x27\xfc\x00\x06\x20\x00\x2e\x84\xa8\xe0\x77\x3a\x00\x90\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\x0c\x04\x40\xf4\xf3\x09\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x9d\x0e\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x10\x00\xd1\xcf\x27\xfc\x00\x06\x20\x00\x2e\x84\xa8\xe0\x77\x3a\x00\x90\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x40\x00\x04\x3f\x9f\xf0\x03\x00\x00\x80\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\xc0\x40\x00\x44\x3f\x9f\xf0\x03\x18\x80\x00\xb8\x10\xa2\x82\xdf\xe9\x00\x40\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x10\x00\xc1\xcf\x27\xfc\x00\x00\x00\x00\x00\x80\x20\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x04\x40\xf4\xf3\x09\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x9d\x0e\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x30\x10\x00\xd1\xcf\x27\xfc\x00\x06\x20\x00\x2e\x84\xa8\xe0\x77\x3a\x00\x90\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\xc1\x5c\x44\xff\xbf\xfc\x3f\x41\x10\x04\x78\x00\xa0\x0a\x67\xfe\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x30\x10\xd1\xff\x2f\xfe\x40\x00\x00\x01\x1e\x00\xa8\xc2\x99\xff\xff\xf5\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\x00\x00\x00\x00\x00\x00\xc0\x40\x00\x44\x3f\x9f\xf0\x03\x18\x80\x00\xb8\x10\xa2\x82\xdf\xe9\x00\x40\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x20\x22\x04\x00\x20\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf4\xff\x8f\x3f\x10\x00\x40\x80\x07\x00\xaa\x70\xe6\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\xc1\x40\x44\xff\xbf\xf8\x03\x01\x00\x04\x78\x00\xa0\x0a\x67\xfe\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x28\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf4\xff\x8b\x3f\x10\x00\x40\x80\x07\x00\xaa\x72\xe6\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x28\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf4\xff\x0b\x3f\x00\x00\x40\x00\x07\x00\xaa\x72\xe6\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x03\x11\xfd\xff\xe2\x0f\x04\x00\x10\xe0\x01\x80\x2a\x9c\xf9\xff\x5f\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xc1\x40\x44\xff\xbf\xf8\x03\x01\x00\x04\x78\x00\xa0\x0a\x67\xfe\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x30\x10\xd1\xff\x2f\xfe\x40\x00\x00\x01\x1e\x00\xa8\xc2\x99\xff\xff\xf5\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\x00\x00\x00\x00\x00\x00\x80\x40\x00\x44\xff\x9f\xf0\x03\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\x70\x30\x10\xd1\xff\x2f\xfe\x40\x00\x20\x01\x3e\x04\xa8\xe2\xff\xff\xff\xf5\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\x08\x04\x40\xf4\xff\x09\x3f\x00\x00\x04\x00\x00\x00\x08\x20\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x10\x00\xd1\xcf\x27\xfc\x00\x06\x20\x00\x2e\x84\xa8\xe0\x77\x3a\x00\x90\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x40\x00\x44\x3f\x9f\xf0\x03\x18\x80\x00\xb8\x10\xa2\x82\xdf\xe9\x00\x40\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x04\x40\xf4\xf3\x09\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x9d\x0e\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x40\x00\x04\x07\x9f\xf0\x03\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x00\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\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\xc1\x40\x44\xff\xbf\xf0\x03\x00\x00\x04\x70\x00\xa0\x0a\x67\xfe\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x30\x10\xd1\xff\x2f\xfe\x40\x00\x00\x01\x1e\x00\xa8\xc2\x99\xff\xff\xf5\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\x00\x00\x00\x00\x00\x00\xc0\xc1\x40\x44\xff\xbf\xf8\x03\x01\x00\x04\x78\x00\xa0\x0a\x67\xfe\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x70\x30\x10\xd3\xff\x2f\xfe\x40\x00\x00\x01\x1e\x00\xa8\xc2\x99\xff\xff\xf5\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\x1c\x0c\xc4\xf4\xff\x8b\x3f\x10\x00\x40\x80\x07\x00\xaa\x70\xe6\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x03\x11\xfd\xff\xe2\x0f\x04\x00\x10\xe0\x01\x80\x2a\x9c\xf9\xff\x5f\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x03\x01\x10\xfc\x7c\xc2\x0f\x60\x00\x02\xe0\x42\x88\x0a\x7e\x87\x03\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x40\x00\x04\x3f\x9f\xf0\x03\x18\x80\x00\xb8\x10\xa2\x82\xdf\xe1\x00\x40\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\x00\x00\x00\x00\x00\x00\x00\x00\x20\x10\x00\xc1\xcf\x27\xfc\x00\x00\x00\x00\x00\x80\x20\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x03\x00\x00\x00\x00\x00\x00\x08\x40\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\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\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x03\x11\xfd\xff\xe2\x0f\x04\x00\x10\xe0\x01\x80\x2a\x9c\xf9\xff\x5f\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x33\x17\xd5\xff\x2f\xff\x4f\x10\x04\x01\x1e\x00\xa8\xc2\x99\xff\xff\xf5\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\xdc\xcc\x45\xf5\xff\xcb\xff\x13\x04\x41\x80\x07\x00\xaa\x70\xe6\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\xcc\x55\xf5\xff\xcb\xff\x13\x04\x41\x80\x07\x00\xaa\x70\xe6\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x73\x55\xfd\xff\xf2\xff\x04\x41\x10\xe0\x01\x80\x2a\x9c\xf9\xff\x5f\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x40\x00\x04\x3f\x9f\xf0\x03\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x04\x40\xf0\xf3\x09\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x1d\x0e\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\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\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\x40\x00\x44\x3f\x9f\xf0\x03\x18\x80\x00\xb8\x10\xa2\x82\xdf\xe9\x00\x40\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x01\x10\xfd\x7f\xc2\x0f\x00\x00\x00\x00\x00\x00\x02\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x80\x40\x00\x44\xff\x9f\xf0\x03\x00\x00\x00\x00\x00\x80\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x04\x40\xf4\xff\x09\x3f\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x20\x42\x00\x00\x62\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x80\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\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\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x02\x10\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\xa0\x02\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x22\x04\x00\x00\x66\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x28\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x01\x50\xfd\x7f\xc2\x0f\x00\x00\x01\x00\x00\x00\x02\x98\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\x80\x40\x80\x54\xff\x9f\xf4\x03\x00\x00\x00\x00\x00\x80\x00\x66\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf4\xff\x8b\x3f\x10\x00\x40\x80\x07\x00\xaa\x70\xe6\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x1c\xcc\x45\xf4\xff\xcb\xff\x13\x04\x41\x80\x07\x00\xaa\x70\xe6\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x73\x11\xfd\xff\xf2\xff\x04\x41\x10\xe0\x01\x80\x2a\x9c\xf9\xff\x5f\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x04\x40\xf4\xf3\x09\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x9d\x0e\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x28\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x40\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x10\x00\xc1\xcf\x27\xfc\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x10\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x03\x11\xfd\xff\xe2\x0f\x00\x00\x10\xe0\x01\x80\x2a\x9c\xf9\xff\x5f\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x40\x20\x44\x7f\x9f\xf0\x03\x18\x80\x00\xb8\x10\xa2\x82\xdf\xe1\x00\x40\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x40\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x40\x00\x44\x3f\x9f\xf0\x03\x18\x80\x00\xb8\x10\xa2\x83\xdf\xe9\x00\x40\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x01\x10\xfc\x7c\xc2\x0f\x60\x00\x02\xe0\x42\x88\x0a\x7e\x87\x03\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x04\x40\xf4\xf3\x09\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x9d\x0e\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x03\x11\xfd\xff\xe2\x0f\x04\x00\x10\xe0\x01\x80\x2a\x9c\xf9\xff\x5f\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xc1\x40\x44\xff\xbf\xf8\x03\x01\x00\x04\x78\x00\xa0\x0a\x67\xfe\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x30\x10\xd1\xff\x2f\xfe\x40\x00\x00\x01\x1e\x00\xa8\xc2\x99\xff\xff\xf5\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x03\x11\xfd\xff\xe2\x0f\x04\x00\x12\xe0\x43\x80\x2a\xfe\xff\xff\x5f\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x40\x00\x44\xff\x9f\xf0\x03\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x10\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x80\x40\x00\x04\x07\x9f\xf0\x03\x00\x00\x00\x00\x00\x00\x00\x06\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\x01\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x40\x00\x04\x07\x9f\xf0\x03\x00\x00\x00\x00\x00\x00\x00\x06\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\x80\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\x40\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf4\xff\x8b\x3f\x10\x00\x40\x80\x07\x00\xaa\x70\xe6\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x01\x10\xfc\x7c\xc2\x0f\x60\x00\x02\xe0\x42\x88\x0a\x7e\x87\x03\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x02\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\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\x37\x73\x51\xfd\xff\xf2\xff\x04\x41\x10\xe0\x01\x80\x2a\x9c\xf9\xff\x5f\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x04\x40\xf4\xf3\x09\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x1d\x0e\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x01\x10\xfc\x7c\xc2\x0f\x60\x00\x02\xe0\x42\x88\x0a\x7e\x87\x03\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x01\x88\x10\x00\x80\x98\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\x30\x10\x00\xc1\xcf\x27\xfc\x00\x06\x20\x00\x2e\x84\xa8\xe0\x77\x38\x00\x90\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x31\x57\xd5\xff\x2f\xff\x4f\x10\x04\x01\x1e\x00\xa8\xc2\x99\xff\xff\xf5\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\x0c\x04\x40\xf4\xf3\x09\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x1d\x0e\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x01\x10\xfd\x7c\xc2\x0f\x60\x00\x03\xe0\x42\x88\x0a\x7e\x87\x03\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x40\x00\x44\x3f\x9f\xf0\x03\x18\xc0\x00\xb8\x10\xa2\x82\xdf\xe1\x00\x40\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\x00\x00\x00\x00\x00\x00\x00\x00\x20\x10\x00\xc1\xcf\x27\xfc\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\x00\x00\x00\x00\x0c\x04\x40\xf4\xf3\x09\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x9d\x0e\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\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x10\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\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\x00\x00\x00\x00\x00\x00\x00\x00\x08\x04\x40\xf4\xff\x09\x3f\x00\x00\x00\x00\x00\x00\x08\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x01\x10\xfd\x7c\xc2\x0f\x60\x00\x02\xe0\x42\x88\x0a\x7e\xa7\x03\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x01\x50\xfd\x7f\xc2\x0f\x00\x00\x01\x00\x00\x00\x02\x98\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\x10\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\x00\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\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\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x40\x00\x04\x3f\x9f\xf0\x03\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\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\x00\x00\x00\x00\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\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\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\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\x00\x00\x00\x00\x00\x01\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\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\x03\x01\x10\xfd\x7c\xc2\x0f\x60\x00\x02\xe0\x42\x88\x0a\x7e\x87\x03\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x03\x01\x10\xfd\x7c\xc2\x0f\x60\x00\x02\xe0\x42\x88\x0a\x7e\xa7\x03\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x01\x10\xfd\x7c\xc2\x0f\x60\x00\x02\xe0\x42\x88\x0a\x7e\xa7\x03\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x40\x00\x44\x3f\x9f\xf0\x03\x18\x80\x00\xb8\x10\xa2\x82\xdf\xe9\x00\x40\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x01\x10\xfd\x7c\xc2\x0f\x60\x00\x02\xe0\x42\x88\x0a\x7e\xa7\x03\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x04\x40\xf0\xf3\x09\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x1d\x0e\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x03\x11\xfd\xff\xe2\x0f\x04\x00\x10\xe0\x01\x80\x2a\x9c\xf9\xff\x5f\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x80\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\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\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x40\x00\x44\x3f\x9f\xf0\x03\x18\x80\x00\xb8\x10\xa2\x82\xdf\xe9\x00\x40\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x01\x10\xfd\x7c\xc2\x0f\x60\x00\x02\xe2\x42\x88\x0e\x7f\xa7\x03\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x04\x40\xf0\xf3\x09\x3f\x00\x00\x00\x00\x00\x00\x08\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x40\x00\x44\x3f\x9f\xf0\x03\x18\x80\x00\xb8\x10\xa2\x82\xdf\xe1\x00\x40\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x04\x48\xf5\xff\x49\x3f\x00\x00\x00\x00\x00\x00\x08\x64\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x20\x10\x20\xd5\xff\x27\xfd\x00\x00\x00\x00\x00\x00\x20\x90\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\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\x08\x04\x40\xf0\xf3\x09\x3f\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x00\x00\x08\x04\x40\x70\xf0\x09\x3f\x00\x00\x00\x00\x00\x00\x00\xe0\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\x10\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\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x80\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\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\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\x00\x00\x00\x00\x00\x00\x00\x00\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_parseModuleNoHaddock","%start_parseSignature","%start_parseImport","%start_parseStatement","%start_parseDeclaration","%start_parseExpression","%start_parsePattern","%start_parseTypeSignature","%start_parseStmt","%start_parseIdentifier","%start_parseType","%start_parseBackpack","%start_parseHeader","identifier","backpack","units","unit","unitid","msubsts","msubst","moduleid","pkgname","litpkgname_segment","HYPHEN","litpkgname","mayberns","rns","rn","unitbody","unitdecls","unitdecl","signature","module","missing_module_keyword","implicit_top","maybemodwarning","body","body2","top","top1","header","header_body","header_body2","header_top","header_top_importdecls","maybeexports","exportlist","exportlist1","export","export_subspec","qcnames","qcnames1","qcname_ext_w_wildcard","qcname_ext","qcname","semis1","semis","importdecls","importdecls_semi","importdecl","maybe_src","maybe_safe","maybe_pkg","optqualified","maybeas","maybeimpspec","impspec","prec","infix","ops","topdecls","topdecls_semi","topdecls_cs","topdecls_cs_semi","topdecl_cs","topdecl","cl_decl","ty_decl","standalone_kind_sig","sks_vars","inst_decl","overlap_pragma","deriv_strategy_no_via","deriv_strategy_via","deriv_standalone_strategy","opt_injective_info","injectivity_cond","inj_varids","where_type_family","ty_fam_inst_eqn_list","ty_fam_inst_eqns","ty_fam_inst_eqn","at_decl_cls","opt_family","opt_instance","at_decl_inst","data_or_newtype","opt_kind_sig","opt_datafam_kind_sig","opt_tyfam_kind_sig","opt_at_kind_inj_sig","tycl_hdr","datafam_inst_hdr","capi_ctype","stand_alone_deriving","role_annot","maybe_roles","roles","role","pattern_synonym_decl","pattern_synonym_lhs","vars0","cvars1","where_decls","pattern_synonym_sig","qvarcon","decl_cls","decls_cls","decllist_cls","where_cls","decl_inst","decls_inst","decllist_inst","where_inst","decls","decllist","binds","wherebinds","rules","rule","rule_activation","rule_activation_marker","rule_explicit_activation","rule_foralls","rule_vars","rule_var","warnings","warning","deprecations","deprecation","strings","stringlist","annotation","fdecl","callconv","safety","fspec","opt_sig","opt_tyconsig","sigktype","sigtype","sig_vars","sigtypes1","unpackedness","forall_telescope","ktype","ctype","context","type","mult","btype","infixtype","ftype","tyarg","tyop","atype","inst_type","deriv_types","comma_types0","comma_types1","bar_types2","tv_bndrs","tv_bndr","tv_bndr_no_braces","fds","fds1","fd","varids0","kind","gadt_constrlist","gadt_constrs","gadt_constr","constrs","constrs1","constr","forall","constr_stuff","fielddecls","fielddecls1","fielddecl","maybe_derivings","derivings","deriving","deriv_clause_types","decl_no_th","decl","rhs","gdrhs","gdrh","sigdecl","activation","explicit_activation","quasiquote","exp","infixexp","exp10p","exp10","optSemi","prag_e","fexp","aexp","aexp1","aexp2","projection","splice_exp","splice_untyped","splice_typed","cmdargs","acmd","cvtopbody","cvtopdecls0","texp","tup_exprs","commas_tup_tail","tup_tail","list","lexps","flattenedpquals","pquals","squals","transformqual","guardquals","guardquals1","alt_rhs","ralt","gdpats","ifgdpats","gdpat","pat","pats1","bindpat","apat","apats","stmtlist","stmts","maybe_stmt","e_stmt","stmt","qual","fbinds","fbinds1","fbind","fieldToUpdate","dbinds","dbind","ipvar","overloaded_label","name_boolformula_opt","name_boolformula","name_boolformula_and","name_boolformula_and_list","name_boolformula_atom","namelist","name_var","qcon_nowiredlist","qcon","gen_qcon","con","con_list","qcon_list","sysdcon_nolist","sysdcon","conop","qconop","gtycon","ntgtycon","oqtycon","oqtycon_no_varcon","qtyconop","qtycon","tycon","qtyconsym","tyconsym","otycon","op","varop","qop","qopm","hole_op","qvarop","qvaropm","tyvar","tyvarop","tyvarid","var","qvar","field","qvarid","varid","qvarsym","qvarsym_no_minus","qvarsym1","varsym","varsym_no_minus","special_id","special_sym","qconid","conid","qconsym","consym","literal","close","modid","commas","bars0","bars","altslist__apats__","altslist__pats1__","exp_prag__exp__","exp_prag__exp10p__","alts__apats__","alts__pats1__","alts1__apats__","alts1__pats1__","alt__apats__","alt__pats1__","'_'","'as'","'case'","'class'","'data'","'default'","'deriving'","'else'","'hiding'","'if'","'import'","'in'","'infix'","'infixl'","'infixr'","'instance'","'let'","'module'","'newtype'","'of'","'qualified'","'then'","'type'","'where'","'forall'","'foreign'","'export'","'label'","'dynamic'","'safe'","'interruptible'","'unsafe'","'family'","'role'","'stdcall'","'ccall'","'capi'","'prim'","'javascript'","'proc'","'rec'","'group'","'by'","'using'","'pattern'","'static'","'stock'","'anyclass'","'via'","'unit'","'signature'","'dependency'","'{-# INLINE'","'{-# OPAQUE'","'{-# SPECIALISE'","'{-# SPECIALISE_INLINE'","'{-# SOURCE'","'{-# RULES'","'{-# SCC'","'{-# DEPRECATED'","'{-# WARNING'","'{-# UNPACK'","'{-# NOUNPACK'","'{-# ANN'","'{-# MINIMAL'","'{-# CTYPE'","'{-# OVERLAPPING'","'{-# OVERLAPPABLE'","'{-# OVERLAPS'","'{-# INCOHERENT'","'{-# COMPLETE'","'#-}'","'..'","':'","'::'","'='","'\\\\'","'lcase'","'lcases'","'|'","'<-'","'->'","'->.'","TIGHT_INFIX_AT","'=>'","'-'","PREFIX_TILDE","PREFIX_BANG","PREFIX_MINUS","'*'","'-<'","'>-'","'-<<'","'>>-'","'.'","PREFIX_PROJ","TIGHT_INFIX_PROJ","PREFIX_AT","PREFIX_PERCENT","'{'","'}'","vocurly","vccurly","'['","']'","'('","')'","'(#'","'#)'","'(|'","'|)'","';'","','","'`'","SIMPLEQUOTE","VARID","CONID","VARSYM","CONSYM","QVARID","QCONID","QVARSYM","QCONSYM","DO","MDO","IPDUPVARID","LABELVARID","CHAR","STRING","INTEGER","RATIONAL","PRIMCHAR","PRIMSTRING","PRIMINTEGER","PRIMWORD","PRIMFLOAT","PRIMDOUBLE","'[|'","'[p|'","'[t|'","'[d|'","'|]'","'[||'","'||]'","PREFIX_DOLLAR","PREFIX_DOLLAR_DOLLAR","TH_TY_QUOTE","TH_QUASIQUOTE","TH_QQUASIQUOTE","%eof"]+        bit_start = st Prelude.* 478+        bit_end = (st Prelude.+ 1) Prelude.* 478+        read_bit = readArrayBit happyExpList+        bits = Prelude.map read_bit [bit_start..bit_end Prelude.- 1]+        bits_indexed = Prelude.zip bits [0..477]+        token_strs_expected = Prelude.concatMap f bits_indexed+        f (Prelude.False, _) = []+        f (Prelude.True, nr) = [token_strs Prelude.!! nr]++happyActOffsets :: HappyAddr+happyActOffsets = HappyA# "\x46\x00\x37\x00\x67\x00\xbb\x29\xed\x1c\xa4\x2c\xa4\x2c\xe9\x23\xbb\x29\xa6\x48\x93\x3f\x54\x00\x41\x00\x1f\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\x52\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc8\x02\x00\x00\x00\x00\x00\x00\xdc\x00\x00\x00\x2d\x03\x2d\x03\x00\x00\xa4\x00\x7f\x01\x7f\x01\x04\x45\x93\x3f\x5b\x01\xc7\x01\xea\x01\x00\x00\xdc\x18\x00\x00\x17\x17\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x17\x00\x00\x45\x18\x00\x00\x00\x00\x00\x00\x00\x00\x15\x61\x00\x00\x00\x00\x00\x00\x43\x02\x7a\x02\x00\x00\x00\x00\x7f\x45\x7f\x45\x00\x00\x00\x00\x55\x60\x9c\x3d\x94\x3b\x16\x3c\x9e\x39\x0d\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\x3a\x00\x00\x00\x00\x5e\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\x90\x02\x3c\x06\x49\x00\x10\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xce\x02\x73\x19\x00\x00\xa4\x2c\x0a\x1a\x00\x00\x3f\x02\x00\x00\x00\x00\x00\x00\xe4\x02\xfc\x02\x00\x00\x00\x00\xe9\x15\x00\x00\x00\x00\xdc\x02\x00\x00\x00\x00\x00\x00\xa4\x2c\x91\x28\xeb\x02\x72\x39\xf2\x02\x72\x39\x99\x00\xe1\x31\xb3\x37\x72\x39\x72\x39\x72\x39\xd2\x26\x6b\x20\xbf\x22\x72\x39\xe5\x49\xf2\x02\xf2\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x2c\x76\x32\x93\x3f\x8a\x03\xa4\x2c\xff\x3a\x80\x16\xef\x02\x00\x00\x13\x03\xf3\x07\x42\x03\x53\x03\x00\x00\x00\x00\x00\x00\x95\x03\xd0\x03\x11\x4a\x1f\x4c\x72\x4b\xae\x4b\x1f\x4c\x81\x5e\xfe\x03\x6b\x20\x00\x00\x44\x03\x44\x03\x44\x03\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc4\x08\x04\x45\xbc\x03\x7c\x03\xfb\x02\xd5\x06\x00\x00\x17\x3e\xa3\x01\xde\x5e\x70\x03\x0a\x5f\x0a\x5f\x55\x5e\x66\x03\x00\x00\x66\x03\xdc\x03\x89\x03\x5a\x03\x89\x03\x00\x00\x00\x00\x5a\x03\x00\x00\xc7\x03\xc5\x03\x9c\x02\x00\x00\x00\x00\x52\x00\x9c\x02\x24\x04\x03\x04\x72\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x72\x39\x14\x01\xc6\x02\x85\x00\x00\x00\xfc\xff\xf6\x03\xcf\x00\x00\x00\xfc\xff\x34\x01\x00\x00\x0b\x33\x11\x02\x1c\x60\x0c\x04\x15\x00\x88\x01\x00\x00\xf4\x04\xf4\x04\x83\x00\x3a\x04\x97\x02\xbf\x00\x95\x42\x04\x45\x4a\x02\x93\x3f\x54\x04\x59\x04\x5f\x04\x71\x04\x00\x00\xc7\x04\x00\x00\x00\x00\x00\x00\x93\x3f\x93\x3f\x04\x45\x96\x04\x9f\x04\x00\x00\x99\x03\x00\x00\xa4\x2c\x00\x00\x00\x00\x93\x3f\x2b\x3b\x04\x45\xbb\x04\x7f\x04\xb2\x04\x32\x47\x84\x01\xc4\x01\xa1\x04\x00\x00\xa0\x33\x00\x00\x00\x00\x00\x00\xb1\x04\xb8\x04\xc0\x04\xc3\x04\x7e\x24\x67\x27\x00\x00\xb3\x37\x92\x4d\x00\x00\x00\x00\x2b\x3b\xc5\x04\xee\x04\xd2\x00\xfd\x04\x00\x00\xf2\x04\x00\x00\xd9\x04\x00\x00\x53\x4c\x0d\x00\x1f\x4c\x00\x00\x65\x00\x1f\x4c\x93\x3f\x1d\x05\x73\x4a\xdd\x04\x00\x00\x55\x05\x13\x25\x13\x25\x55\x60\x93\x3f\xf1\x04\x00\x00\x00\x00\x00\x00\x00\x00\x04\x05\xe2\x04\xb5\x01\x00\x00\x00\x00\xf9\x04\x00\x05\x00\x00\x00\x00\x05\x05\x39\x07\x08\x05\x00\x00\xbb\x29\xbb\x29\x00\x00\x00\x00\x00\x00\x64\x06\x00\x00\xe4\x01\x36\x05\x00\x00\x00\x00\xa8\x25\x00\x00\x44\x05\x10\x00\x49\x05\x4f\x05\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x1a\x00\x00\x72\x39\x65\x05\xa2\x03\xb4\x03\x9b\x05\x9f\x05\x00\x00\x00\x00\x9d\x05\xfe\x05\xac\x05\x2f\x00\x00\x00\x00\x00\x39\x2d\xbd\x05\x18\x06\x72\x39\xce\x2d\x92\x4d\xea\x4b\x00\x00\x7f\x45\x00\x00\x93\x3f\xce\x2d\xce\x2d\xce\x2d\xce\x2d\xbe\x05\xe9\x05\xc0\x03\xee\x05\xfc\x05\xa5\x00\xff\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x93\x3f\x1a\x3d\x46\x4b\xed\x05\x04\x06\xfa\xff\xba\x05\xf5\x05\xe5\x03\x8d\x00\x00\x00\x2c\x03\x07\x3a\x47\x03\x03\x06\x00\x00\xfd\xff\x00\x00\x48\x01\x1a\x06\x00\x00\x26\x06\x00\x00\x1d\x02\x00\x00\xe4\x4a\x00\x00\x00\x00\x00\x00\x3e\x02\x15\x61\x00\x00\x00\x00\x75\x61\x75\x61\x93\x3f\x7f\x45\x00\x00\x04\x45\x00\x00\x7f\x45\x3a\x06\x93\x3f\x93\x3f\x7f\x45\x93\x3f\x93\x3f\x00\x00\x00\x00\xc0\x01\x00\x00\x61\x34\x39\x00\x00\x00\x2d\x06\x9c\x02\x9c\x02\x00\x00\x42\x06\xfc\xff\xfc\xff\x42\x06\x00\x00\x00\x00\xbe\x06\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x06\xba\x06\x7d\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\x93\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x8b\x06\x43\x01\x00\x00\x00\x00\x00\x00\x76\x06\x55\x60\x00\x00\x93\x3f\x55\x60\x00\x00\x93\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x93\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x93\x3f\x93\x3f\x00\x00\x00\x00\x6a\x06\x72\x06\x80\x06\x88\x06\x8a\x06\x93\x06\x98\x06\x9c\x06\x9f\x06\x9d\x06\xab\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\xc6\x06\x00\x00\xbc\x06\xe3\x06\xd4\x06\xd9\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd7\x03\x9c\x01\xec\x06\xd1\x06\x00\x00\x00\x00\x00\x00\x2b\x07\x00\x00\xce\x2d\xce\x2d\x00\x00\x00\x00\x00\x00\x35\x34\xce\x1b\x00\x00\x26\x29\x38\x1b\xce\x2d\x00\x00\xfc\x27\x00\x00\xce\x2d\x50\x2a\xfc\x27\x00\x00\xd2\x06\x00\x00\x00\x00\x00\x00\x54\x23\xf4\x06\x00\x00\x48\x38\x7e\x00\x00\x00\xc9\x02\x00\x00\x00\x00\x00\x00\x00\x00\xed\x1c\x52\x00\xe2\x06\x00\x00\x00\x00\x00\x00\xda\x06\x00\x00\xdc\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf0\x5f\x00\x00\x00\x00\x5a\x01\x82\x00\x00\x00\x00\x00\x70\x0a\x00\x00\x00\x21\x95\x21\x59\x01\x00\x00\x2a\x22\xe9\x02\x07\x03\xd0\x03\x02\x07\x00\x00\x00\x00\x00\x00\x00\x00\x03\x07\x05\x07\xd3\x06\x00\x00\x00\x00\xea\x06\x09\x07\x00\x00\x0e\x07\xf2\x06\xf5\x06\x67\x5f\x67\x5f\x00\x00\x0f\x07\x50\x04\x09\x05\xed\x06\xf0\x06\x00\x00\x16\x07\xf8\x06\x57\x07\x00\x00\x00\x00\x92\x4d\x00\x00\xce\x2d\xfc\x27\x33\x00\x12\x43\x05\x04\x15\x04\x00\x00\x00\x00\xce\x2d\x00\x00\x00\x00\x6b\x00\x00\x00\xce\x2d\x63\x2e\x04\x45\x52\x07\x00\x00\x20\x07\x01\x07\x00\x00\x00\x00\x22\x07\xd5\x06\x00\x00\x00\x00\x00\x00\x00\x00\x56\x07\x2b\x00\xfa\x01\x45\x04\x00\x00\x25\x07\x15\x61\x93\x3f\x93\x3f\x4a\x02\xab\x45\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x46\x92\x4d\xfd\x06\x93\x3f\x00\x00\x92\x4d\x55\x60\xf8\x2e\xf8\x2e\xca\x34\x00\x00\x9d\x01\x00\x00\xff\x06\x00\x00\x04\x07\x00\x00\x00\x00\x93\x5f\x93\x5f\x00\x00\x00\x00\x93\x5f\x00\x00\x72\x39\x3e\x01\x2d\x07\x2e\x07\x00\x00\x64\x07\x00\x00\x18\x07\x00\x00\x18\x07\x00\x00\x00\x00\x7b\x07\x00\x00\x1a\x07\x00\x00\xed\x1c\x73\x07\x7c\x49\x76\x07\x10\x07\x00\x00\x00\x00\x00\x00\x27\x07\x48\x07\x00\x00\x00\x00\x00\x00\x29\x01\x00\x00\x00\x00\x81\x01\x30\x07\x5f\x35\x81\x60\x7d\x07\x00\x00\x31\x07\x2a\x07\x00\x00\x00\x00\x32\x07\x00\x00\x40\x46\x00\x00\x5a\x07\x5b\x07\x5c\x07\x5d\x07\xb5\x60\x00\x00\x00\x00\x00\x00\x00\x00\x3e\x07\x93\x3f\x59\x07\x93\x3f\x15\x61\x00\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x33\x04\x93\x3f\x93\x3f\x00\x00\x00\x00\x93\x3f\x3b\x07\x00\x00\x07\x4e\x00\x00\x5a\x04\x00\x00\x5e\x07\x96\x07\x00\x00\x00\x00\x6d\x04\x00\x00\x9a\x07\xae\x07\x93\x3f\x9e\x07\x93\x04\x65\x07\x00\x00\x15\x61\x00\x00\x71\x07\x00\x00\x00\x00\x00\x00\x6b\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x93\x3f\x00\x00\x55\x07\x93\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x44\x07\x00\x00\x3d\x26\xf8\x2e\x00\x00\x00\x00\x93\x3f\xf1\x04\x00\x00\x00\x00\x5f\x07\x00\x00\xe5\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x02\x00\x00\x00\x00\x00\x00\x05\x01\x00\x00\x00\x00\x8d\x2f\x00\x00\x00\x00\x00\x00\x00\x00\x2b\x04\x00\x00\x52\x00\x60\x07\x00\x00\x7a\x2b\x61\x07\x00\x00\x2b\x04\x00\x00\x52\x00\x63\x07\x00\x00\xdd\x38\x66\x07\x00\x00\x00\x00\x00\x00\x22\x30\xb7\x30\x4c\x31\x00\x00\x00\x00\x92\x4d\xfc\x27\xea\x4b\x00\x00\x00\x00\x93\x3f\x00\x00\x00\x00\x75\x07\x00\x00\x69\x07\x6f\x07\x00\x00\x00\x00\x00\x00\x00\x00\x93\x3f\x00\x00\x93\x3f\x00\x00\x1f\x5e\x00\x00\x00\x00\x00\x00\xfa\x04\x00\x00\xb4\x07\x98\x07\x99\x07\xc6\x07\x80\x05\x00\x00\x00\x00\x80\x05\x00\x00\xf7\x01\xf7\x01\x00\x00\x77\x07\x7e\x07\x00\x00\x00\x00\x79\x07\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x7a\x07\x00\x00\x00\x00\xf4\x35\x00\x00\x00\x00\xcd\x07\x9c\x07\x4c\x31\x00\x00\x00\x00\x4c\x31\x00\x00\x00\x00\xc3\x07\x82\x1d\x0f\x2c\x0f\x2c\x4c\x31\x00\x00\x80\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x07\x81\x07\xad\x07\x00\x00\xaf\x07\x00\x00\x9b\x07\x04\x45\xe0\x07\xf2\x07\xab\x07\x00\x00\x04\x45\x15\x61\x00\x00\x00\x00\xf5\x07\x00\x00\xa2\x02\xf5\x07\x96\x05\x00\x00\x00\x00\x4c\x31\x00\x00\x17\x1e\x17\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xac\x1e\xac\x1e\x00\x00\x00\x00\x00\x00\xe5\x07\x75\x61\x00\x00\x04\x45\xb5\x07\x93\x3f\x00\x00\x00\x00\xb5\x60\x00\x00\x00\x00\x99\x05\xa0\x07\xe1\x60\x00\x00\x92\x4d\xc5\x05\x00\x00\x00\x00\x9f\x07\x00\x00\x83\x07\x00\x00\x00\x00\x07\x04\x00\x00\x9e\x05\xa2\x07\x90\x07\x00\x00\xa4\x07\x00\x00\x00\x00\x00\x00\x00\x00\x07\x04\x4a\x02\x09\x05\x95\x07\x00\x00\x9e\x05\xa3\x07\x00\x00\xa9\x07\x00\x00\xa9\x07\x00\x00\x00\x00\x00\x00\xb0\x07\xb1\x07\xb3\x07\x00\x00\x00\x00\x00\x00\x00\x00\xa6\x4a\xa8\x49\x00\x00\x00\x00\x05\x08\x00\x00\x00\x00\x4c\x31\xd4\x07\x00\x00\x89\x36\x3d\x26\x3d\x26\x00\x00\x00\x00\x93\x3f\xda\x07\x00\x00\xd8\x07\x00\x00\xa1\x05\x00\x00\x1d\x08\x00\x00\x5c\x01\x00\x00\x00\x00\x1d\x08\x08\x03\x00\x00\x75\x61\x00\x00\x00\x00\x63\x01\x00\x00\x0f\x08\x1e\x37\x94\x3e\x09\x03\x00\x00\x0a\x05\x0a\x05\x00\x00\xd0\x02\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x11\x3f\x00\x00\xd5\x07\xe6\x07\x00\x00\xea\x07\x00\x00\x27\x08\x00\x00\x33\x08\x00\x00\x04\x45\x00\x00\x00\x00\x93\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x31\x4c\x31\x4c\x31\x00\x00\x00\x00\x00\x00\x00\x00\x39\x08\xfc\x27\x92\x4d\x00\x00\x00\x00\x00\x00\x66\x01\x00\x00\x0c\x08\x07\x04\x74\x38\x1e\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf7\x01\xdc\x07\xdf\x07\x09\x39\xcb\x04\x07\x04\x00\x00\x00\x00\x00\x00\x4c\x31\x00\x00\x00\x00\x1c\x08\x00\x00\xf6\x07\x00\x00\x00\x00\x00\x00\x04\x45\x00\x00\xd9\x07\xe1\x07\x00\x00\x00\x00\x00\x00\x52\x00\xde\x07\xd0\x03\xee\x07\x00\x00\x41\x1f\x00\x00\xc8\x04\x8f\x43\x04\x45\xcb\x0d\x04\x45\x00\x00\x00\x00\x00\x00\xd6\x1f\x8f\x43\x00\x00\x00\x00\x14\x08\x00\x00\x15\x40\x92\x40\x75\x61\x0f\x41\x00\x00\x69\x01\x21\x03\xe1\x60\x0f\x41\x00\x00\x58\x08\x00\x00\xf4\x07\xec\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x52\x00\xfb\x07\x00\x00\x00\x00\xa6\x4a\x00\x00\x29\x00\x07\x04\xf7\x07\x02\x08\x00\x00\x00\x00\x00\x00\x75\x61\x00\x00\x7d\x01\x00\x00\x52\x00\x28\x03\xfe\x07\x0c\x44\x00\x00\x00\x00\x19\x08\x0f\x41\x06\x05\x00\x00\x00\x00\x0f\x41\x91\x41\x00\x00\x00\x00\x1b\x08\x0a\x05\x00\x00\x00\x00\x13\x42\x00\x00\x00\x00\x04\x45\x4c\x31\x00\x00\x62\x05\xfd\x07\x00\x00\x07\x04\x00\x00\x07\x04\x00\x00\x54\x03\x00\x00\x66\x08\x2b\x02\x00\x00\x93\x00\x53\x08\x06\x08\x00\x00\x00\x00\x00\x00\x00\x00\x13\x42\x1f\x08\x64\x1c\x98\x3c\x00\x00\x00\x00\x41\x61\x00\x00\x00\x00\x81\x05\x00\x00\x00\x00\x89\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x08\x7c\x49\x00\x00\x01\x08\x7c\x49\x00\x00\x5a\x08\x6c\x08\x82\x3a\x75\x61\x00\x00\x5c\x08\xbc\x05\xab\x14\x07\x04\x00\x00\x07\x04\x07\x04\x00\x00\x07\x04\x00\x00\x00\x00\x00\x00\x04\x08\x2b\x08\x00\x00\x07\x04\x00\x00\xbc\x05\x00\x00\x00\x00\x6f\x08\x15\x08\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x08\x07\x04\x00\x00\x00\x00\x00\x00\x00\x00"#++happyGotoOffsets :: HappyAddr+happyGotoOffsets = HappyA# "\xe3\x02\x65\x08\x54\x08\x3a\x52\x7c\x01\xda\x55\x08\x55\x35\x06\x82\x52\x01\x00\x92\x0e\x8e\x01\x1b\x03\x51\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\x11\x04\x00\x00\x00\x00\x9a\x02\x00\x00\x00\x00\x62\x07\x6d\x07\x9e\x02\x00\x00\xdd\x05\xf0\x05\xf1\x13\x3d\x03\x00\x00\x00\x00\x00\x00\x00\x00\xfa\x07\x00\x00\x69\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\x9d\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa7\x03\x17\x04\x00\x00\x00\x00\x94\xff\xc6\x0e\x68\x08\x21\x08\xbd\x00\x3c\x0b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xeb\x05\x58\x07\x98\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x99\x0b\x00\x00\x20\x56\xa6\x62\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x66\x56\xec\x53\x86\x05\xdf\x62\xa1\x07\xf0\x62\x00\x00\xe4\x61\x5c\x62\x29\x63\x62\x63\x73\x63\xc3\x4d\x64\x4c\x4e\x4d\xac\x63\x0f\x0c\xb6\x07\xbc\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xac\x56\xf2\x60\xd9\x0e\xb7\x07\xf2\x56\xe0\x64\x72\x04\x50\x08\x00\x00\x00\x00\x99\x0b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa6\x05\x79\x00\x78\x05\x78\x03\xb5\x05\xe7\x05\x8e\x04\x88\x0e\xde\x01\xd9\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa6\x01\x2c\x07\x00\x00\x00\x00\xf7\x05\x5f\x08\x00\x00\x04\x01\x17\x08\xa5\xff\xe1\x05\x89\x00\x62\x01\x61\x03\x00\x00\x00\x00\x00\x00\x75\x08\x00\x00\x7c\x07\x00\x00\x4f\x00\x00\x00\x88\x07\x97\x01\x00\x00\xec\x01\x8f\x08\x00\x00\x00\x00\x7f\x07\x90\x08\x78\x08\x00\x00\xe5\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf6\x63\x6f\x02\x08\x06\x00\x00\x00\x00\x3b\x08\x00\x00\x00\x00\x00\x00\x3c\x08\x00\x00\x00\x00\xe0\x04\x00\x00\xc5\xff\x00\x00\x62\xff\xa6\x03\x00\x00\x3d\x08\x3e\x08\x00\x00\x00\x00\x2d\x08\x00\x00\x7a\x04\x82\x12\x65\x03\xa8\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x09\xe1\x0c\x95\x12\x22\x08\x00\x00\x00\x00\x38\x04\x00\x00\xdb\x4b\x00\x00\x00\x00\x44\x0b\x98\x02\x72\x07\x6a\x08\x00\x00\x00\x00\xd2\x0d\x00\x00\x82\xff\x00\x00\x00\x00\x03\x61\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x32\x4e\x10\x4f\x00\x00\x5c\x62\xba\x01\x00\x00\x00\x00\xaa\x03\x00\x00\x3f\x08\x02\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x22\x31\x00\x00\x68\x05\x00\x00\x4c\x08\x82\x05\x0c\x0a\x00\x00\x84\x00\x00\x00\x00\x00\x00\x00\xe6\x02\x5c\x03\xf6\xff\x88\x0b\xf0\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x01\x16\x05\x00\x00\x00\x00\x00\x00\x00\x00\xfb\xff\x0f\x00\x00\x00\x29\x0e\x00\x00\x00\x00\xca\x52\x12\x53\x00\x00\x00\x00\x00\x00\xeb\x05\xf9\x07\x82\xff\x00\x00\x00\x00\x00\x00\x32\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2f\x64\x00\x00\xf5\x61\x00\x00\x97\x07\x9d\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x08\x81\xff\x00\x00\x00\x00\x59\x53\x6a\x05\x00\x00\x68\x64\x38\x57\x01\x03\x0d\x04\x00\x00\xe3\x04\x00\x00\x26\x11\x7e\x57\xc4\x57\x0a\x58\x50\x58\x00\x00\x00\x00\x00\x00\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\x0c\x55\x08\x9e\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\x78\x04\x00\x00\xdb\x04\x00\x00\x00\x00\x00\x00\x00\x00\x95\x00\x00\x00\x00\x00\x53\x01\xf5\x01\x39\x11\x2b\x05\x00\x00\x35\x14\x00\x00\x8e\x05\x00\x00\x7d\x11\x90\x11\x69\x06\xd4\x11\x2f\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x18\x00\xaa\x07\x00\x00\x85\x02\xb2\x08\xbd\x08\x00\x00\xb5\x08\x57\x08\x59\x08\xb7\x08\x00\x00\x00\x00\xab\x08\x00\x00\x00\x00\x00\x00\x00\x00\xda\x08\x00\x00\xd5\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\xe7\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x00\x00\x2b\x12\x42\x02\x00\x00\x28\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x48\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8f\x0d\xd5\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbe\x07\x11\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x96\x58\xdc\x58\x00\x00\x00\x00\x00\x00\x22\x47\xdb\x46\x00\x00\x06\x46\xbc\x45\x22\x59\x00\x00\x7f\x4f\x00\x00\x68\x59\xaa\x51\xee\x4f\x00\x00\x5f\xff\x00\x00\x00\x00\x00\x00\xa1\x4e\x00\x00\x00\x00\x6d\x62\xc5\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x27\x02\xc8\x07\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\x02\x00\x00\x00\x00\x00\x00\xc9\x07\x00\x00\x00\x00\xa6\x01\x00\x00\x00\x00\x00\x00\xd0\x07\x00\x00\x00\x00\x00\x00\x00\x00\x1f\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\x9b\x08\x17\x14\x00\x00\x00\x00\xca\x04\xdf\x02\x00\x00\x00\x00\x00\x00\x7b\x05\x00\x00\x29\x0e\x00\x00\x00\x00\xc8\x03\x00\x00\xdb\x4b\x5d\x50\x00\x00\x94\x07\xe6\xff\x00\x00\x00\x00\x00\x00\x1e\x4c\x00\x00\x00\x00\x13\x00\x00\x00\xae\x59\xa0\x53\xd9\x12\x76\x08\x19\x05\xa9\x08\x00\x00\x00\x00\x00\x00\x00\x00\xac\x08\x00\x00\x00\x00\x00\x00\x00\x00\x93\x08\xdb\x05\xa8\x05\xad\x08\x00\x00\x00\x00\x26\x01\x73\x0f\xee\x09\x82\x03\x8f\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa6\xff\xc1\x02\xe7\x07\x9b\x0b\x00\x00\xce\xff\xde\xff\x4e\x55\x94\x55\x8a\x08\x00\x00\x8e\x08\x00\x00\x9d\x08\x00\x00\x87\x08\x00\x00\x00\x00\xe1\x00\xf1\x02\x00\x00\x00\x00\x90\x01\x00\x00\x79\x64\x0b\x08\x00\x00\x00\x00\x00\x00\xe7\x08\x00\x00\xfb\x08\x00\x00\xfc\x08\x00\x00\x00\x00\xca\x02\x00\x00\xf3\x08\x00\x00\x31\x01\x00\x00\x24\x00\x00\x00\xef\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\x6e\x61\xa1\xff\xc0\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8b\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x86\x0f\xd9\x08\xca\x0f\x98\x01\x00\x00\xc7\x08\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x08\x44\x0a\xdd\x0f\x00\x00\x00\x00\x21\x10\x00\x00\x00\x00\x1c\x02\x00\x00\xc6\x08\x00\x00\x00\x00\xbe\x08\x00\x00\x00\x00\x48\x06\x00\x00\x8b\x08\x14\x05\x34\x10\xd0\x05\xec\xff\x00\x00\x00\x00\x49\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\xa8\x0a\x00\x00\x00\x00\xe0\x0a\x00\x00\x00\x00\x00\x00\x00\x00\xf4\x05\x00\x00\x23\x06\xf4\x59\x00\x00\x00\x00\xdf\x0b\x5a\x02\x00\x00\x00\x00\x09\x09\x00\x00\x34\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\x3a\x5a\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x04\x00\x00\x0a\x08\x00\x00\x00\x00\x4f\x46\x00\x00\x00\x00\x69\x05\x00\x00\x12\x08\x00\x00\x00\x00\x68\x47\x00\x00\x00\x00\x00\x00\x00\x00\x80\x5a\xc2\x54\xc6\x5a\x00\x00\x00\x00\xe5\x00\xcc\x50\xda\x02\x00\x00\x00\x00\xf7\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x78\x10\x00\x00\x8b\x10\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x26\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x21\x09\x00\x00\x00\x00\x24\x09\x00\x00\xe0\x06\xe7\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\x7f\x08\x00\x00\x00\x00\x97\x47\x00\x00\x00\x00\xd0\x08\x63\x08\x0c\x5b\x00\x00\x00\x00\x98\x46\x00\x00\x00\x00\x00\x00\x00\x00\xf1\x51\x7b\x54\x52\x5b\x00\x00\x00\x00\x00\x00\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\x12\x9f\x08\x0a\x06\x00\x00\x00\x00\x95\x0a\x77\x01\x00\x00\x00\x00\x95\x08\x00\x00\xc8\xff\x0f\x06\x00\x00\x00\x00\x00\x00\x98\x5b\x00\x00\xd9\x03\x23\x04\x00\x00\xa2\x08\x6d\x06\x00\x00\x00\x00\x00\x00\x00\x00\xd3\xff\x9d\x02\x00\x00\x00\x00\x00\x00\xfe\x08\xbe\xff\x00\x00\x30\x13\x00\x00\xf2\x0b\x00\x00\x00\x00\xeb\xff\x00\x00\x00\x00\x00\x00\x00\x00\xb4\xff\x00\x00\xf0\x02\x29\x0e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x08\x00\x00\x33\x09\x00\x00\x00\x00\x00\x00\x28\x09\x00\x00\x00\x00\x00\x00\x00\x00\x23\x08\xa9\x03\xaa\x01\x6f\x05\x00\x00\x39\x09\x27\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x21\x02\x59\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x50\x00\x44\x00\x00\x00\x00\x00\x20\x09\x00\x00\x00\x00\xde\x5b\x00\x00\x00\x00\x00\x00\x64\x05\xae\x05\x00\x00\x00\x00\x36\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x07\x09\x00\x00\x03\x09\x00\x00\x2c\x08\x00\x00\x00\x00\x04\x09\x00\x00\x00\x00\x1c\x02\x00\x00\x00\x00\x2e\x08\x00\x00\x0d\x09\x7f\x61\x46\x05\x00\x00\x00\x00\x0f\x01\xab\x01\x00\x00\x97\xff\x11\x09\x00\x00\x00\x00\x00\x00\x00\x00\x17\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8d\x06\x00\x00\x13\x06\x00\x00\xff\x07\x00\x00\x00\x00\xf3\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x24\x5c\x6a\x5c\xb0\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x51\xe6\x03\x00\x00\x00\x00\x00\x00\x2f\x08\x00\x00\x34\x09\x3a\x08\x0e\x00\x00\x00\x00\x00\xf6\x02\x29\x03\x00\x00\x00\x00\x00\x00\x00\x00\x53\x09\x5a\x09\x00\x00\x14\x00\x51\x09\x45\x08\x00\x00\x00\x00\x00\x00\xf6\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xde\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x08\x00\x00\xbf\x01\x00\x00\x00\x00\xef\x04\x00\x00\x12\x09\x71\x06\x43\x13\x29\x0e\x87\x13\x00\x00\x00\x00\x00\x00\xa5\x04\xd0\x06\x00\x00\x00\x00\x0e\x09\x00\x00\x7e\x02\x9f\x03\xc1\xff\xcf\x10\x00\x00\x51\x08\x00\x00\xbd\xff\x3e\x12\x00\x00\x47\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x08\x00\x00\x00\x00\x00\x00\x48\x00\x00\x00\xe8\x06\x64\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x48\x02\x00\x00\x6e\x08\x00\x00\x70\x08\x00\x00\x00\x00\xc4\x07\x00\x00\x00\x00\x2d\x09\x49\x0c\x2c\x09\x00\x00\x00\x00\xe2\x10\x2b\x0e\x00\x00\x00\x00\x00\x00\xd9\x01\x00\x00\x00\x00\x3e\x09\x00\x00\x00\x00\x9a\x13\x3c\x5d\x00\x00\x6e\x09\x76\x09\x00\x00\xff\xff\x00\x00\xf5\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7b\x09\x00\x00\x00\x00\x00\x00\x00\x00\x8d\x0c\x00\x00\x00\x00\xf9\x08\x00\x00\x00\x00\x6e\xff\x00\x00\x00\x00\x06\x00\x00\x00\x00\x00\x0b\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x00\x00\x00\x00\x3a\x00\x00\x00\xf8\x08\x1b\x06\x00\x00\xc0\xff\x00\x00\x00\x00\x8a\x09\x08\x00\x77\x08\x00\x00\x02\x00\x7a\x08\x00\x00\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7e\x08\x00\x00\x96\x09\x00\x00\x00\x00\x70\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x85\x08\x00\x00\x00\x00\x00\x00\x00\x00"#++happyAdjustOffset :: Happy_GHC_Exts.Int# -> Happy_GHC_Exts.Int#+happyAdjustOffset off = off++happyDefActions :: HappyAddr+happyDefActions = HappyA# "\xc0\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8e\xfd\x00\x00\x00\x00\xbf\xff\xc0\xff\x00\x00\xf2\xff\x1b\xfd\x17\xfd\x14\xfd\x04\xfd\x02\xfd\x03\xfd\x10\xfd\x01\xfd\x00\xfd\xff\xfc\x12\xfd\x11\xfd\x13\xfd\x0f\xfd\x0e\xfd\xfe\xfc\xfd\xfc\xfc\xfc\xfb\xfc\xfa\xfc\xf9\xfc\xf8\xfc\xf7\xfc\xf6\xfc\xf5\xfc\xf3\xfc\xf4\xfc\x00\x00\x15\xfd\x16\xfd\x8f\xff\x00\x00\xb1\xff\x00\x00\x00\x00\x8f\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9b\xfe\x00\x00\x96\xfe\x94\xfe\x8f\xfe\x8e\xfe\x8a\xfe\x8b\xfe\x74\xfe\x73\xfe\x00\x00\x81\xfe\x4f\xfd\x85\xfe\x49\xfd\x40\xfd\x43\xfd\x3c\xfd\x80\xfe\x84\xfe\x24\xfd\x21\xfd\x6a\xfe\x5f\xfe\x1f\xfd\x1e\xfd\x20\xfd\x00\x00\x00\x00\x39\xfd\x38\xfd\x00\x00\x00\x00\x7f\xfe\x37\xfd\x42\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x22\xfd\x3f\xfd\x3a\xfd\x3b\xfd\x41\xfd\x3d\xfd\x3e\xfd\x78\xfd\x6c\xfe\x6b\xfe\x6d\xfe\x00\x00\x18\xfe\x17\xfe\x00\x00\xf1\xff\x67\xfd\x58\xfd\x66\xfd\xef\xff\xf0\xff\x28\xfd\x0c\xfd\x0d\xfd\x08\xfd\x05\xfd\x65\xfd\xf0\xfc\x54\xfd\xed\xfc\xea\xfc\xed\xff\x07\xfd\xf1\xfc\xf2\xfc\x00\x00\x00\x00\x00\x00\x00\x00\xee\xfc\x06\xfd\xeb\xfc\xef\xfc\x09\xfd\xec\xfc\xd5\xfd\x89\xfd\x11\xfe\x0f\xfe\x00\x00\x0a\xfe\x02\xfe\xf3\xfd\xf0\xfd\xe1\xfd\xe0\xfd\x00\x00\x00\x00\x8f\xfd\x8c\xfd\xed\xfd\xec\xfd\xee\xfd\xef\xfd\xeb\xfd\x10\xfe\xe2\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x96\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x77\xfd\xe9\xfc\xe8\xfc\xea\xfd\xe9\xfd\xe5\xfc\xe4\xfc\xe7\xfc\xe6\xfc\xe3\xfc\xe2\xfc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\xfd\x7c\xff\x26\xfe\x00\x00\x00\x00\x00\x00\x17\xfd\x7a\xff\x79\xff\x78\xff\x00\x00\x00\x00\x1c\xfe\x00\x00\x1c\xfe\x1c\xfe\x00\x00\x75\xfd\x00\x00\x00\x00\x9b\xfd\x00\x00\x00\x00\x00\x00\x6e\xff\x6d\xff\x6c\xff\x6b\xff\x14\xff\x6a\xff\x69\xff\x31\xfe\x63\xff\x62\xff\x33\xfe\x61\xff\x00\x00\x28\xff\x00\x00\x46\xff\x4f\xff\x27\xff\x00\x00\x00\x00\x00\x00\xd9\xfe\xc1\xfe\xc6\xfe\x00\x00\x00\x00\x8d\xfd\x00\x00\x89\xff\x00\x00\x00\x00\x00\x00\x8f\xff\xc1\xff\x00\x00\x8f\xff\x00\x00\x8c\xff\xbc\xff\xdf\xfc\xde\xfc\x00\x00\xbc\xff\x87\xff\x00\x00\x00\x00\x6a\xfd\x61\xfd\x6b\xfd\x1d\xfd\x63\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xc7\xfe\x00\x00\x6d\xfd\x00\x00\xc2\xfe\x00\x00\x00\x00\xda\xfe\xd7\xfe\x00\x00\x60\xfd\x00\x00\x00\x00\x00\x00\x67\xff\x00\x00\x00\x00\x00\x00\x00\x00\x94\xfe\x4f\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x47\xff\x00\x00\x48\xff\x4a\xff\x49\xff\x00\x00\x65\xfe\x00\x00\x59\xfe\x00\x00\x1b\xff\x00\x00\x2e\xfd\x00\x00\x2d\xfd\x2f\xfd\x00\x00\x00\x00\x00\x00\x14\xff\x00\x00\xc6\xfd\x11\xfe\x00\x00\x00\x00\x00\x00\x2b\xfd\x00\x00\x2a\xfd\x2c\xfd\x26\xfd\x0a\xfd\x00\x00\x0b\xfd\x54\xfd\x00\x00\x00\x00\xd8\xfc\x07\xfd\x00\x00\x5c\xfd\xdc\xfc\x00\x00\x5e\xfd\xa8\xfe\x00\x00\x00\x00\x76\xfd\x74\xfd\x72\xfd\x71\xfd\x6e\xfd\x00\x00\x00\x00\x00\x00\x1b\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\xfd\xe1\xfe\x00\x00\xe4\xfe\xe4\xfe\x00\x00\x00\x00\x00\x00\x7b\xff\xdc\xfd\x52\xfd\xdd\xfd\x00\x00\x00\x00\x00\x00\xce\xfd\xef\xfd\x00\x00\x00\x00\x73\xff\x73\xff\x00\x00\x00\x00\x00\x00\xf5\xfd\x90\xfd\x90\xfd\xf6\xfd\xde\xfd\xdf\xfd\x00\x00\xcc\xfd\x00\x00\x00\x00\x0a\xfd\x0b\xfd\x00\x00\x5a\xfd\x00\x00\xba\xfd\x00\x00\xb9\xfd\x57\xfd\xfe\xfd\xff\xfd\x00\xfe\x0b\xfe\x98\xfd\x96\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\xfe\x8b\xfd\x00\x00\x88\xfd\x08\xfe\x00\x00\xf8\xfd\x9f\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x86\xfd\x05\xfe\x00\x00\xcf\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\xcf\xfd\x72\xfe\x69\xfd\x68\xfd\x83\xfe\x82\xfe\x6f\xfe\x31\xfd\x65\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x64\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x79\xfe\x00\x00\x43\xfd\x00\x00\x00\x00\x7b\xfe\x00\x00\x4a\xfd\x00\x00\x00\x00\x41\xfe\x3f\xfe\xa2\xfe\x00\x00\x7d\xfe\x00\x00\x7e\xfe\x9e\xfe\x9f\xfe\x00\x00\x5f\xfe\x5e\xfe\x5b\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x89\xfe\x00\x00\x87\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x99\xfe\x8c\xfe\x00\x00\xe8\xff\x00\x00\x00\x00\xae\xff\x8c\xff\xbc\xff\xbc\xff\xad\xff\xa8\xff\x00\x00\x00\x00\xa8\xff\xac\xff\xaa\xff\xab\xff\x90\xff\xec\xff\xe0\xfc\xe1\xfc\xe9\xff\x00\x00\xd5\xff\xdc\xff\xd9\xff\xdb\xff\xda\xff\xdd\xff\xeb\xff\x52\xfe\x9a\xfe\x98\xfe\x90\xfe\x91\xfe\x93\xfe\x00\x00\x88\xfe\x8d\xfe\x86\xfe\x97\xfe\x00\x00\x00\x00\x60\xfe\x9c\xfe\x9d\xfe\x00\x00\x00\x00\x7c\xfe\x00\x00\x00\x00\x76\xfe\x00\x00\x4b\xfd\x4e\xfd\xdd\xfc\x48\xfd\x75\xfe\x00\x00\xd9\xfc\x4c\xfd\x4d\xfd\x77\xfe\x78\xfe\x00\x00\x00\x00\x23\xfd\x42\xfd\x00\x00\x00\x00\x39\xfd\x38\xfd\x7f\xfe\x37\xfd\x3a\xfd\x3b\xfd\x3e\xfd\x64\xfe\x00\x00\x66\xfe\xee\xff\x5b\xfd\x64\xfd\x19\xfd\x59\xfd\x53\xfd\x27\xfd\x12\xfe\x13\xfe\x14\xfe\x15\xfe\x16\xfe\x04\xfe\x00\x00\x87\xfd\x84\xfd\x81\xfd\x00\x00\x17\xfd\x83\xfd\xf1\xfd\x18\xfd\x8a\xfd\x01\xfe\x00\x00\x00\x00\x00\x00\xa6\xfd\xa4\xfd\xa0\xfd\x9d\xfd\x00\x00\x09\xfe\x00\x00\x00\x00\x07\xfe\x06\xfe\xfa\xfd\x96\xfd\x00\x00\xfb\xfd\x00\x00\x00\x00\x00\x00\x97\xfd\x00\x00\xe3\xfd\xb8\xfd\x00\x00\x00\x00\x1a\xfd\xbc\xfd\xc1\xfd\xe4\xfd\xc2\xfd\xbb\xfd\xc0\xfd\xe5\xfd\x00\x00\x00\x00\x91\xfd\x00\x00\xda\xfd\xd7\xfd\xd8\xfd\xc7\xfd\xc8\xfd\x00\x00\x00\x00\xd6\xfd\xd9\xfd\x50\xfd\x00\x00\x51\xfd\x27\xfe\x33\xfd\x76\xff\x34\xfd\x56\xfd\x32\xfd\x00\x00\x29\xfe\xa4\xfe\x00\x00\x00\x00\x30\xfe\xe5\xfe\xaa\xfe\x2f\xfe\xd1\xfd\xd0\xfd\x00\x00\x7a\xfd\xed\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xfd\xfe\xfe\xfe\x23\xfe\x69\xfe\x00\x00\x00\x00\x00\x00\xd5\xfe\xd4\xfe\x00\x00\x00\x00\x22\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1d\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd2\xfd\xda\xfc\x1a\xfd\xc4\xfd\xe7\xfd\xe8\xfd\x00\x00\xe6\xfd\xc5\xfd\x00\x00\x00\x00\x00\x00\x26\xff\xa4\xfe\x0e\xfe\x0d\xfe\x00\x00\x0c\xfe\x32\xfe\xdd\xfe\x2b\xfe\x00\x00\x00\x00\x00\x00\xf2\xfe\x54\xfe\x24\xff\x00\x00\x4b\xff\xa6\xfe\xa4\xfe\x4f\xff\x50\xff\x51\xff\x53\xff\x52\xff\xe8\xfe\x11\xff\x00\x00\x22\xff\x56\xff\x00\x00\x5f\xfe\x00\x00\x00\x00\x00\x00\x00\x00\xb4\xfe\xb3\xfe\xb2\xfe\xb1\xfe\xb0\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x08\xff\x05\xff\x00\x00\x00\x00\x00\x00\xce\xfe\xd6\xfe\x00\x00\x64\xff\xdb\xfe\xc0\xfe\xbb\xfe\xbf\xfe\x66\xff\xc3\xfe\x00\x00\xc5\xfe\x65\xff\xc8\xfe\x36\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x8a\xff\x83\xff\x88\xff\xa8\xff\xb8\xff\xa8\xff\xb7\xff\xb4\xff\x70\xff\xb9\xff\x8e\xff\xb5\xff\xb6\xff\x00\x00\xa6\xff\x00\x00\x85\xff\x84\xff\xba\xfe\xb8\xfe\x00\x00\x00\x00\xc9\xfe\x6c\xfd\xc4\xfe\x00\x00\xbc\xfe\xdc\xfe\x00\x00\x00\x00\x00\x00\xcc\xfe\x0a\xff\x0b\xff\x00\x00\x03\xff\x04\xff\xff\xfe\x00\x00\x07\xff\x00\x00\xb6\xfe\x00\x00\xae\xfe\xad\xfe\xaf\xfe\x00\x00\xb5\xfe\x59\xff\x5a\xff\x5f\xff\x00\x00\x00\x00\x45\xff\x00\x00\x00\x00\x12\xff\x10\xff\x0f\xff\x0c\xff\x0d\xff\x57\xff\x00\x00\x00\x00\x00\x00\x68\xff\x5b\xff\x00\x00\x58\xfe\x56\xfe\x00\x00\x60\xff\x00\x00\x1c\xff\x00\x00\xdd\xfe\x2d\xfe\x2c\xfe\x00\x00\xce\xfc\x4f\xfe\x3d\xfe\x00\x00\x44\xfe\x26\xff\x00\x00\x17\xff\x5f\xfe\x15\xff\x00\x00\xc3\xfd\xd3\xfd\xbf\xfd\xdb\xfc\x29\xfd\x25\xfd\x5d\xfd\xa7\xfe\x25\xfe\x73\xfd\x70\xfd\x62\xfd\x6f\xfd\x21\xfe\x00\x00\x1a\xfe\x00\x00\x00\x00\x1e\xfe\x24\xfe\x5f\xfd\xe0\xfe\x7b\xfd\xe3\xfe\xe6\xfe\x00\x00\xdf\xfe\xe2\xfe\x00\x00\x00\x00\xca\xfd\xc9\xfd\x75\xff\x95\xfd\x92\xfd\x94\xfd\xcb\xfd\xcd\xfd\xd4\xfd\xbe\xfd\xbd\xfd\xc6\xfd\xb2\xfd\xb4\xfd\xb1\xfd\xaf\xfd\xac\xfd\xab\xfd\x00\x00\xb6\xfd\xb3\xfd\xfd\xfd\x9a\xfd\x00\x00\xd0\xfc\x00\x00\xcb\xfc\xc4\xfc\x00\x00\x00\x00\xd1\xfc\x00\x00\xd4\xfc\x00\x00\xcd\xfc\xc7\xfc\x96\xfd\x00\x00\xd5\xfc\xf4\xfd\xfc\xfd\x00\x00\x00\x00\x00\x00\x9e\xfd\xf7\xfd\x00\x00\x00\x00\x00\x00\xf2\xfd\x70\xfe\x00\x00\x30\xfd\x63\xfe\x62\xfe\x61\xfe\x00\x00\x00\x00\xa3\xfe\x3e\xfe\x40\xfe\x1c\xfd\x00\x00\x5d\xfe\x00\x00\x92\xfe\x00\x00\xd8\xff\xd7\xff\xd6\xff\x00\x00\xea\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbe\xff\xbd\xff\x00\x00\xe7\xff\x00\x00\x00\x00\xd4\xff\x00\x00\x00\x00\x6e\xfe\x7a\xfe\x00\x00\x85\xfd\x82\xfd\x7f\xfd\x7d\xfd\x9c\xfd\xa5\xfd\x08\xfe\xd7\xfc\xcc\xfc\xc8\xfc\xd6\xfc\xc3\xfc\xdd\xfe\xa1\xfd\x00\x00\xd3\xfc\xca\xfc\xc5\xfc\xd2\xfc\xc2\xfc\xaa\xfd\xf9\xfc\x00\x00\x00\x00\xb7\xfd\x93\xfd\x74\xff\x91\xff\x77\xff\x28\xfe\x79\xfd\xe7\xfe\x7c\xfd\x00\x00\xa1\xfe\x00\x00\x19\xfe\x00\x00\x16\xff\x00\x00\x00\x00\x4f\xfe\x3d\xfe\x4a\xfe\x48\xfe\x00\x00\x5f\xfe\x25\xff\x5d\xff\x3c\xfe\x3a\xfe\x00\x00\x3d\xfe\x00\x00\xde\xfe\x2e\xfe\x00\x00\xf3\xfe\xf6\xfe\xf6\xfe\x53\xfe\x54\xfe\x54\xfe\x23\xff\xa5\xfe\x13\xff\xe9\xfe\xec\xfe\xec\xfe\x0e\xff\x20\xff\x21\xff\x40\xff\x00\x00\x35\xff\x00\x00\x00\x00\x00\x00\xb7\xfe\x55\xfd\x00\x00\x06\xff\x09\xff\x00\x00\x00\x00\xcc\xfe\xcb\xfe\x00\x00\x00\x00\xd3\xfe\xd1\xfe\x00\x00\xbe\xfe\x00\x00\xb9\xfe\x35\xfd\x00\x00\x86\xff\x00\x00\x00\x00\xa7\xff\xa2\xff\x9e\xff\x96\xff\x93\xff\x47\xfd\x94\xff\x00\x00\x00\x00\x00\x00\x00\x00\xa4\xff\x00\x00\x72\xff\x6f\xff\x8d\xff\x92\xff\x71\xff\xc2\xff\x8f\xff\x8f\xff\x00\x00\x00\x00\x00\x00\x9f\xff\x95\xff\xa0\xff\xa1\xff\x9c\xff\xa5\xff\xa9\xff\xc3\xff\x83\xff\xbd\xfe\xd2\xfe\x00\x00\x00\x00\xcd\xfe\xcf\xfe\xe4\xfe\xe4\xfe\x02\xff\xab\xfe\x00\x00\x00\x00\x44\xff\x00\x00\x5e\xff\x00\x00\xf1\xfe\x2d\xff\xed\xfe\x00\x00\xf0\xfe\x28\xff\x2d\xff\x00\x00\x57\xfe\x55\xfe\xfc\xfe\xf7\xfe\x00\x00\xfb\xfe\x2f\xff\x00\x00\x00\x00\x00\x00\x2a\xfe\x4c\xfe\x4c\xfe\x5c\xff\x00\x00\x39\xfe\x36\xfe\x4c\xff\x4e\xff\x4d\xff\x00\x00\x3b\xfe\x00\x00\x00\x00\x95\xfe\x43\xfe\x46\xfe\x44\xfe\x55\xff\x3d\xfe\x18\xff\x00\x00\x1f\xfe\x20\xfe\x00\x00\xb5\xfd\xae\xfd\xad\xfd\xb0\xfd\x00\x00\x00\x00\x00\x00\xc6\xfc\xa2\xfd\xa3\xfd\xc9\xfc\x00\x00\x00\x00\x00\x00\x71\xfe\x5c\xfe\x5a\xfe\x00\x00\xc8\xff\x89\xff\x00\x00\x00\x00\x00\x00\xb2\xff\x8f\xff\x8f\xff\xb3\xff\xaf\xff\xb0\xff\xcc\xff\xc9\xff\xd3\xff\xe6\xff\xf3\xfc\xbc\xff\x00\x00\xcb\xff\x7e\xfd\x80\xfd\x00\x00\xa9\xfd\xa8\xfd\x00\x00\xa0\xfe\x00\x00\x19\xff\x54\xff\x49\xfe\x00\x00\x45\xfe\x68\xfe\x00\x00\x35\xfe\x37\xfe\x38\xfe\x00\x00\x4d\xfe\x00\x00\x00\x00\xf5\xfe\xf8\xfe\x31\xff\x1f\xff\x00\x00\x00\x00\x00\x00\x00\x00\x2e\xff\xf4\xfe\xeb\xfe\xee\xfe\x00\x00\x2c\xff\xea\xfe\x14\xff\x3f\xff\x37\xff\x37\xff\x00\x00\x00\x00\xac\xfe\x00\x00\x00\x00\xcc\xfe\x00\x00\xd8\xfe\x81\xff\xa3\xff\x00\x00\x9b\xff\x99\xff\x98\xff\x97\xff\x46\xfd\x45\xfd\x44\xfd\x00\x00\x00\x00\xbb\xff\xba\xff\x00\x00\x9d\xff\x7f\xff\x00\x00\x00\x00\x00\x00\x01\xff\x00\xff\x36\xff\x43\xff\x41\xff\x00\x00\x38\xff\x00\x00\x00\x00\x00\x00\x00\x00\x2b\xff\xef\xfe\x24\xff\x00\x00\x1f\xff\x30\xff\x33\xff\x00\x00\x00\x00\xf9\xfe\x51\xfe\x00\x00\x4c\xfe\x50\xfe\x34\xfe\x00\x00\x43\xfe\x47\xfe\x00\x00\x00\x00\xf9\xfd\xbc\xff\xa8\xff\xc4\xff\x00\x00\xc5\xff\x00\x00\xca\xff\x00\x00\xcf\xff\xcd\xff\x00\x00\xe2\xff\x00\x00\x00\x00\xa8\xff\xa7\xfd\x1a\xff\x67\xfe\x4e\xfe\x00\x00\x00\x00\x80\xfe\x00\x00\x1e\xff\x32\xff\x00\x00\xfa\xfe\x34\xff\x26\xff\x3c\xff\x3e\xff\x39\xff\x3b\xff\x3d\xff\x42\xff\xd0\xfe\xca\xfe\x82\xff\x8b\xff\x80\xff\x00\x00\xa6\xff\x9a\xff\x00\x00\xa6\xff\x3a\xff\x4f\xfe\x3d\xfe\x80\xfe\x00\x00\x4b\xfe\x00\x00\x00\x00\x00\x00\x00\x00\xe5\xff\xe3\xff\x00\x00\xd2\xff\xd0\xff\xd1\xff\xce\xff\xe4\xff\x00\x00\x00\x00\xe1\xff\x00\x00\xc6\xff\x00\x00\x1d\xff\x2a\xff\x3d\xfe\x00\x00\x7e\xff\x7d\xff\x29\xff\xc7\xff\x00\x00\x00\x00\xe0\xff\xde\xff\xdf\xff"#++happyCheck :: HappyAddr+happyCheck = HappyA# "\xff\xff\x00\x00\x0d\x00\x0e\x00\x05\x00\x06\x00\x61\x00\x49\x00\x06\x00\x49\x00\x37\x00\x4a\x00\x04\x00\x45\x00\xa0\x00\x07\x00\x08\x00\x09\x00\x04\x00\x0b\x00\x85\x00\x0e\x00\x08\x00\x09\x00\x04\x00\x0b\x00\x79\x00\x7a\x00\x08\x00\x09\x00\x8a\x00\x0b\x00\x08\x00\x09\x00\x09\x00\x0b\x00\x0b\x00\x52\x00\x53\x00\x62\x00\x38\x00\x85\x00\x84\x00\x85\x00\x01\x00\x79\x00\x7a\x00\x00\x00\x62\x00\xd2\x00\x09\x00\x60\x00\x39\x00\x3a\x00\x79\x00\x7a\x00\x65\x00\x00\x00\x54\x00\x9e\x00\x9f\x00\xa0\x00\x6b\x00\x6c\x00\x54\x00\x63\x00\xae\x00\xaf\x00\xb0\x00\x21\x00\x22\x00\x23\x00\x39\x00\x3a\x00\x50\x00\xb4\x00\x28\x00\x29\x00\x63\x00\x21\x00\x22\x00\x23\x00\x00\x00\x12\x00\xd2\x00\x48\x00\x28\x00\x29\x00\x12\x00\x49\x00\x54\x00\x21\x00\x22\x00\x23\x00\x4c\x00\x4a\x00\x50\x00\xe0\x00\x28\x00\x29\x00\x68\x00\x03\x01\x69\x00\x23\x00\x19\x00\x10\x00\x33\x00\x71\x00\x28\x00\x29\x00\x71\x00\x27\x00\x28\x00\x29\x00\x0b\x00\x61\x00\x33\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2b\x00\x48\x00\xb4\x00\x81\x00\x00\x00\x50\x00\x8a\x00\x71\x00\x00\x00\x18\x00\x16\x01\x72\x00\x18\x01\x72\x00\xb5\x00\xb6\x00\x28\x01\x2c\x01\x77\x00\xba\x00\x81\x00\xa9\x00\xbd\x00\x23\x01\xbf\x00\x6a\x00\xc1\x00\xa9\x00\x67\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\x42\x00\xc9\x00\xca\x00\xcb\x00\x74\x00\x67\x00\x0a\x01\x0b\x01\xfe\x00\xff\x00\x64\x00\x01\x01\x02\x01\x19\x01\x70\x00\x64\x00\x2a\x01\x1d\x01\x19\x01\x2c\x01\xa9\x00\x2e\x01\x1d\x01\x23\x01\x16\x01\x81\x00\x18\x01\x6d\x00\x23\x01\x64\x00\x67\x00\x71\x00\x50\x00\x57\x00\x19\x01\x1d\x01\x19\x01\x23\x01\x1d\x01\x1d\x01\x1d\x01\x23\x01\xf2\x00\xf3\x00\x23\x01\x23\x01\x23\x01\xcf\x00\x26\x01\xb9\x00\x48\x00\x4b\x00\xfc\x00\xfd\x00\x1d\x01\x0a\x01\x0b\x01\x01\x01\x02\x01\x18\x01\x23\x01\x18\x01\x18\x01\x1d\x01\x76\x00\x00\x00\x50\x00\xcf\x00\x4c\x00\x23\x01\x23\x01\x1d\x01\x23\x01\x23\x01\x67\x00\x8a\x00\x82\x00\x23\x01\x67\x00\x66\x00\x1d\x01\x19\x01\x1a\x01\x70\x00\x1c\x01\x1d\x01\x23\x01\x70\x00\x03\x01\x71\x00\x70\x00\x23\x01\x19\x01\x25\x01\x26\x01\x6d\x00\x1d\x01\x29\x01\xfc\x00\xfd\x00\x0f\x01\x10\x01\x23\x01\x01\x01\x02\x01\x19\x01\x04\x01\x7d\x00\x7e\x00\x1d\x01\x76\x00\x4b\x00\xaf\x00\xb0\x00\x74\x00\x23\x01\x19\x01\x6b\x00\x21\x01\x22\x01\x1d\x01\x24\x01\x14\x01\x71\x00\x48\x00\x28\x01\x23\x01\x81\x00\x1a\x01\x4a\x00\x1c\x01\x1d\x01\x1e\x01\x2b\x01\x20\x01\x21\x01\x22\x01\x23\x01\x24\x01\x25\x01\x26\x01\x27\x01\x28\x01\x2b\x01\x23\x01\x08\x01\x2b\x01\x0a\x01\x0b\x01\x71\x00\x23\x01\x2b\x01\x9e\x00\x9f\x00\xa0\x00\x08\x01\x23\x01\x0a\x01\x0b\x01\x96\x00\x23\x01\x23\x01\x6b\x00\x1a\x01\x70\x00\x1c\x01\x1d\x01\x08\x01\x71\x00\x0a\x01\x0b\x01\x42\x00\x23\x01\x1a\x01\x77\x00\x1c\x01\x1d\x01\x08\x01\x7b\x00\x0a\x01\x0b\x01\x08\x01\x23\x01\x0a\x01\x0b\x01\x1a\x01\x50\x00\x1c\x01\x1d\x01\x08\x01\x00\x00\x0a\x01\x0b\x01\x00\x00\x23\x01\x1a\x01\x7e\x00\x1c\x01\x1d\x01\x1a\x01\x00\x00\x1c\x01\x1d\x01\x00\x00\x23\x01\x37\x00\x00\x00\x1a\x01\x23\x01\x1c\x01\x1d\x01\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x23\x01\x43\x00\x19\x01\x71\x00\xfe\x00\xff\x00\x1d\x01\x01\x01\x02\x01\x48\x00\x00\x00\x6a\x00\x23\x01\xfc\x00\xfd\x00\xf9\x00\xfa\x00\x53\x00\x01\x01\x02\x01\xfe\x00\x4a\x00\x75\x00\x01\x01\x02\x01\x5b\x00\x5c\x00\x4b\x00\x01\x00\x8c\x00\x60\x00\x69\x00\x4b\x00\x56\x00\x91\x00\x65\x00\x93\x00\x94\x00\x95\x00\x71\x00\x97\x00\x98\x00\x5f\x00\x1a\x01\x26\x01\x1c\x01\x1d\x01\x19\x01\x15\x00\x70\x00\x4b\x00\x1d\x01\x23\x01\x65\x00\x25\x01\x26\x01\x16\x01\x23\x01\x18\x01\x0b\x00\x26\x01\x19\x00\x32\x00\x81\x00\x37\x00\x76\x00\x77\x00\xa7\x00\xa8\x00\x23\x01\x71\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x1b\x00\x43\x00\x67\x00\xbd\x00\x2b\x00\x67\x00\x9e\x00\x9f\x00\xa0\x00\x0a\x01\x0b\x01\x70\x00\x67\x00\x71\x00\x70\x00\x67\x00\xca\x00\x53\x00\x67\x00\xc2\x00\x4a\x00\x70\x00\xef\x00\x18\x01\x70\x00\x5b\x00\x5c\x00\x70\x00\xf9\x00\xfa\x00\x60\x00\x7b\x00\x7c\x00\xfe\x00\x23\x01\x65\x00\x01\x01\x02\x01\x67\x00\x61\x00\xb5\x00\x9e\x00\x9f\x00\xa0\x00\x69\x00\xba\x00\x50\x00\x70\x00\xbd\x00\x6b\x00\xbf\x00\x96\x00\xc1\x00\x6b\x00\x57\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\x71\x00\x19\x01\xca\x00\xcb\x00\x81\x00\x1d\x01\x77\x00\x1b\x01\x65\x00\x1d\x01\x82\x00\x23\x01\x50\x00\x1a\x00\x26\x01\x23\x01\x12\x00\x06\x01\x07\x01\x7c\x00\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x4b\x00\x76\x00\x50\x00\x9e\x00\x9f\x00\xa0\x00\x2c\x00\x2d\x00\x16\x01\x17\x01\x18\x01\xfe\x00\xff\x00\x82\x00\x01\x01\x02\x01\x6d\x00\xf2\x00\xf3\x00\x65\x00\x71\x00\x23\x01\x0c\x01\x0d\x01\x33\x00\x34\x00\x86\x00\xfc\x00\xfd\x00\x6b\x00\x70\x00\xb5\x00\x01\x01\x02\x01\x50\x00\x71\x00\xba\x00\x9f\x00\xa0\x00\xbd\x00\x19\x00\xbf\x00\x16\x01\xc1\x00\x18\x01\x55\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\x4a\x00\x26\x01\xca\x00\xcb\x00\x2c\x01\x23\x01\x19\x01\x1a\x01\x2b\x00\x1c\x01\x1d\x01\x49\x00\x56\x00\x6d\x00\xa7\x00\xa8\x00\x23\x01\x71\x00\x25\x01\x26\x01\x52\x00\x5f\x00\x29\x01\xf9\x00\xfa\x00\x4c\x00\x37\x00\x16\x01\xfe\x00\x18\x01\x51\x00\x01\x01\x02\x01\x3e\x00\x3f\x00\x40\x00\x41\x00\x16\x01\x43\x00\x18\x01\x23\x01\xc2\x00\xf2\x00\xf3\x00\x76\x00\x77\x00\x19\x00\x56\x00\x7a\x00\x7b\x00\x23\x01\x5a\x00\xfc\x00\xfd\x00\x53\x00\x19\x01\x5f\x00\x01\x01\x02\x01\x1d\x01\xa7\x00\xa8\x00\x5b\x00\x5c\x00\x2b\x00\x23\x01\x4b\x00\x60\x00\x26\x01\xf9\x00\xfa\x00\x48\x00\x65\x00\x16\x01\xfe\x00\x18\x01\x52\x00\x01\x01\x02\x01\x76\x00\x69\x00\x19\x01\x1a\x01\x00\x00\x1c\x01\x1d\x01\x23\x01\xc2\x00\x71\x00\x5f\x00\x07\x00\x23\x01\x61\x00\x25\x01\x26\x01\x64\x00\x1f\x00\x29\x01\xfc\x00\xfd\x00\x81\x00\x19\x01\x04\x01\x01\x01\x02\x01\x1d\x01\x16\x01\x18\x00\x18\x01\x2c\x00\x2d\x00\x23\x01\x6a\x00\x13\x00\x26\x01\x11\x01\x1e\x00\x13\x01\x14\x01\x23\x01\x1e\x00\xfe\x00\xff\x00\x75\x00\x01\x01\x02\x01\x48\x00\x79\x00\x1e\x01\x2b\x00\x20\x01\x21\x01\x22\x01\x2b\x00\x24\x01\x4d\x00\x4e\x00\x27\x01\x28\x01\x25\x01\x26\x01\x2f\x00\x30\x00\x56\x00\x37\x00\x1b\x01\x59\x00\x1d\x01\x3c\x00\x3d\x00\xfc\x00\xfd\x00\xb5\x00\x23\x01\x00\x01\x01\x01\x02\x01\xba\x00\x4b\x00\x4c\x00\xbd\x00\x26\x01\xbf\x00\x50\x00\xc1\x00\x52\x00\x53\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\x52\x00\x53\x00\xca\x00\xcb\x00\x76\x00\x96\x00\x8c\x00\x13\x00\x14\x00\x2e\x00\x69\x00\x63\x00\x18\x00\x65\x00\x60\x00\x67\x00\x96\x00\x97\x00\x98\x00\x65\x00\x25\x01\x26\x01\x3b\x00\x3c\x00\x70\x00\x6b\x00\x6c\x00\x8c\x00\x16\x01\x6a\x00\x18\x01\x13\x00\x91\x00\x4a\x00\x93\x00\x94\x00\x95\x00\x1e\x00\x97\x00\x98\x00\x75\x00\x23\x01\xf2\x00\xf3\x00\x79\x00\x56\x00\x37\x00\x56\x00\x51\x00\x5a\x00\x2b\x00\x5a\x00\xfc\x00\xfd\x00\x5f\x00\xbd\x00\x5f\x00\x01\x01\x02\x01\x2f\x00\x30\x00\x31\x00\x96\x00\x65\x00\x14\x00\x54\x00\x6b\x00\x16\x01\xca\x00\x18\x01\x51\x00\x1b\x00\x71\x00\x1d\x00\x70\x00\x6a\x00\xbd\x00\x76\x00\x77\x00\x76\x00\x23\x01\x19\x01\x1a\x01\x7a\x00\x1c\x01\x1d\x01\x75\x00\x60\x00\x1e\x00\xca\x00\x79\x00\x23\x01\x65\x00\x25\x01\x26\x01\x65\x00\x64\x00\x29\x01\x66\x00\xb5\x00\xb6\x00\x2b\x00\x6f\x00\x64\x00\xba\x00\x66\x00\x70\x00\xbd\x00\x19\x01\xbf\x00\x03\x01\xc1\x00\x1d\x01\x18\x01\xc4\x00\xc5\x00\xc6\x00\xc7\x00\x23\x01\xc9\x00\xca\x00\xcb\x00\x0f\x01\x10\x01\x23\x01\x65\x00\x65\x00\x65\x00\x06\x01\x07\x01\x82\x00\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x70\x00\x70\x00\x70\x00\x0b\x01\x21\x01\x22\x01\x0e\x01\x24\x01\x16\x01\x17\x01\x18\x01\x28\x01\x65\x00\x06\x01\x07\x01\x65\x00\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x23\x01\x65\x00\x70\x00\xf2\x00\xf3\x00\x70\x00\x96\x00\x37\x00\x16\x01\x17\x01\x18\x01\x6b\x00\x70\x00\xfc\x00\xfd\x00\xb5\x00\xb6\x00\x71\x00\x01\x01\x02\x01\xba\x00\x23\x01\x75\x00\xbd\x00\x19\x01\xbf\x00\x79\x00\xc1\x00\x1d\x01\x96\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\x23\x01\xc9\x00\xca\x00\xcb\x00\x6b\x00\x71\x00\x1c\x01\x1d\x01\x19\x01\x1a\x01\x71\x00\x1c\x01\x1d\x01\x23\x01\x60\x00\x25\x01\x26\x01\x6b\x00\x23\x01\x65\x00\x25\x01\x26\x01\x71\x00\x71\x00\x29\x01\xed\x00\xee\x00\x8c\x00\x8d\x00\x6f\x00\x8f\x00\x90\x00\x91\x00\x75\x00\x93\x00\x94\x00\x95\x00\x79\x00\x97\x00\x98\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\x96\x00\xfc\x00\xfd\x00\x21\x00\x1d\x01\x00\x01\x01\x01\x02\x01\xfc\x00\xfd\x00\x23\x01\x4c\x00\x6a\x00\x01\x01\x02\x01\x50\x00\xf9\x00\xfa\x00\x4d\x00\x4e\x00\x64\x00\xfe\x00\x66\x00\x81\x00\x01\x01\x02\x01\x1a\x01\x1b\x01\x1c\x01\x1d\x01\x1d\x01\x64\x00\xbd\x00\x66\x00\x96\x00\x23\x01\x23\x01\x19\x01\x1a\x01\x26\x01\x1c\x01\x1d\x01\x25\x01\x26\x01\x64\x00\xca\x00\x66\x00\x23\x01\x19\x01\x25\x01\x26\x01\x1d\x01\x1d\x01\x29\x01\x37\x00\xb5\x00\xb6\x00\x23\x01\x23\x01\x39\x00\xba\x00\x26\x01\x64\x00\xbd\x00\x66\x00\xbf\x00\x1b\x01\xc1\x00\x1d\x01\x96\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\x23\x01\xc9\x00\xca\x00\xcb\x00\x4f\x00\x27\x01\x28\x01\x8c\x00\x65\x00\x6d\x00\x2c\x01\xf2\x00\x91\x00\x71\x00\x93\x00\x94\x00\x95\x00\x70\x00\x97\x00\x98\x00\x68\x00\x60\x00\x6a\x00\x64\x00\x6c\x00\x66\x00\x65\x00\x98\x00\x67\x00\x68\x00\x1e\x00\x06\x01\x07\x01\x75\x00\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x48\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\x4b\x00\x4c\x00\x6d\x00\x16\x01\x17\x01\x18\x01\x71\x00\x4b\x00\xfc\x00\xfd\x00\x37\x00\xfa\x00\xbd\x00\x01\x01\x02\x01\xfe\x00\x23\x01\x4c\x00\x01\x01\x02\x01\xbd\x00\x50\x00\x68\x00\x71\x00\x6a\x00\xca\x00\x6c\x00\x1a\x01\x07\x01\x1c\x01\x1d\x01\x0a\x01\x0b\x01\xca\x00\x4f\x00\x75\x00\x23\x01\x19\x01\x1a\x01\x79\x00\x1c\x01\x1d\x01\x19\x01\x50\x00\x75\x00\x52\x00\x1d\x01\x23\x01\x79\x00\x25\x01\x26\x01\x60\x00\x23\x01\x29\x01\x4c\x00\x26\x01\x65\x00\x07\x01\x67\x00\x68\x00\x0a\x01\x0b\x01\xb5\x00\xb6\x00\x4b\x00\x4c\x00\x1a\x01\xba\x00\x1c\x01\x1d\x01\xbd\x00\x64\x00\xbf\x00\x66\x00\xc1\x00\x23\x01\x48\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\x48\x00\xc9\x00\xca\x00\xcb\x00\x06\x01\x07\x01\x48\x00\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x06\x01\x07\x01\x98\x00\x07\x01\x0a\x01\x0b\x01\x0a\x01\x0b\x01\x16\x01\x17\x01\x18\x01\x68\x00\x48\x00\x6a\x00\x1d\x01\x6c\x00\x16\x01\x64\x00\x18\x01\x66\x00\x23\x01\x23\x01\x25\x01\x26\x01\x75\x00\x1c\x01\x1d\x01\x4e\x00\x79\x00\x23\x01\xf2\x00\xf3\x00\x23\x01\x28\x01\x25\x01\x26\x01\x64\x00\x2c\x01\x66\x00\xbd\x00\xfc\x00\xfd\x00\x10\x00\xb5\x00\xb6\x00\x01\x01\x02\x01\x37\x00\xba\x00\x4b\x00\x4c\x00\xbd\x00\xca\x00\xbf\x00\x1b\x01\xc1\x00\x1d\x01\x50\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\x23\x01\xc9\x00\xca\x00\xcb\x00\xb7\x00\xb8\x00\xb9\x00\x19\x01\x1a\x01\x55\x00\x1c\x01\x1d\x01\x52\x00\x53\x00\xec\x00\xed\x00\xee\x00\x23\x01\x42\x00\x25\x01\x26\x01\x81\x00\x1b\x01\x29\x01\x1d\x01\x52\x00\x60\x00\x8c\x00\x3c\x00\x3d\x00\x23\x01\x65\x00\x91\x00\x6b\x00\x93\x00\x94\x00\x95\x00\x6b\x00\x97\x00\x98\x00\x4b\x00\x4c\x00\xf2\x00\xf3\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x6b\x00\x06\x01\x07\x01\xfc\x00\xfd\x00\x0a\x01\x0b\x01\x6b\x00\x01\x01\x02\x01\x37\x00\x1a\x01\x1b\x01\x1c\x01\x1d\x01\x6b\x00\x4a\x00\x16\x01\x6b\x00\x18\x01\x23\x01\x20\x01\x21\x01\x22\x01\x52\x00\x24\x01\x71\x00\xbd\x00\x56\x00\x4b\x00\x23\x01\x4a\x00\x19\x01\x1a\x01\x4f\x00\x1c\x01\x1d\x01\x5f\x00\x50\x00\x52\x00\xca\x00\x48\x00\x23\x01\x56\x00\x25\x01\x26\x01\x71\x00\x5a\x00\x29\x01\x6b\x00\x71\x00\x60\x00\x5f\x00\x4b\x00\x4c\x00\x71\x00\x65\x00\x75\x00\x67\x00\x77\x00\x76\x00\x77\x00\xb5\x00\xb6\x00\x7a\x00\x7b\x00\x64\x00\xba\x00\x66\x00\x0c\x00\xbd\x00\x72\x00\xbf\x00\x48\x00\xc1\x00\x76\x00\x77\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\x69\x00\xc9\x00\xca\x00\xcb\x00\x68\x00\x68\x00\x6a\x00\x6a\x00\x6c\x00\x6c\x00\x05\x01\x06\x01\x07\x01\x70\x00\x98\x00\x0a\x01\x0b\x01\x75\x00\x75\x00\x06\x01\x07\x01\x79\x00\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x16\x01\x90\x00\x18\x01\xdc\x00\xdd\x00\xde\x00\x8e\x00\xe0\x00\x16\x01\x17\x01\x18\x01\x8e\x00\x4e\x00\x23\x01\x8e\x00\xf2\x00\xf3\x00\x21\x01\x22\x01\x37\x00\x24\x01\x23\x01\x3c\x00\x3d\x00\xbd\x00\xfc\x00\xfd\x00\x6d\x00\xb5\x00\xb6\x00\x01\x01\x02\x01\x1a\x01\xba\x00\x1c\x01\x1d\x01\xbd\x00\xca\x00\xbf\x00\x6b\x00\xc1\x00\x23\x01\x69\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\x52\x00\xc9\x00\xca\x00\xcb\x00\xa2\x00\xa3\x00\xa4\x00\x19\x01\x1a\x01\x71\x00\x1c\x01\x1d\x01\x98\x00\x60\x00\xb1\x00\xb2\x00\xb3\x00\x23\x01\x65\x00\x25\x01\x26\x01\x4b\x00\x4c\x00\x29\x01\x05\x01\x06\x01\x07\x01\x8c\x00\x6f\x00\x0a\x01\x0b\x01\xfb\x00\x91\x00\xfd\x00\x93\x00\x94\x00\x95\x00\x01\x01\x97\x00\x98\x00\x02\x00\x03\x00\xf2\x00\xf3\x00\x48\x00\x64\x00\x37\x00\x66\x00\x48\x00\xbd\x00\x06\x01\x07\x01\xfc\x00\xfd\x00\x0a\x01\x0b\x01\x52\x00\x01\x01\x02\x01\x02\x00\x03\x00\x19\x01\xca\x00\x70\x00\x71\x00\x1d\x01\x16\x01\x64\x00\x18\x01\x66\x00\x64\x00\x23\x01\x66\x00\x25\x01\x26\x01\x64\x00\xbd\x00\x66\x00\x64\x00\x23\x01\x66\x00\x19\x01\x1a\x01\x0c\x00\x1c\x01\x1d\x01\x50\x00\x60\x00\x4a\x00\xca\x00\x4c\x00\x23\x01\x65\x00\x25\x01\x26\x01\x70\x00\x71\x00\x29\x01\xb5\x00\xb6\x00\x56\x00\x70\x00\x6f\x00\xba\x00\x5a\x00\x64\x00\xbd\x00\x66\x00\xbf\x00\x5f\x00\xc1\x00\x98\x00\x6d\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\x14\x00\xc9\x00\xca\x00\xcb\x00\x72\x00\x06\x01\x07\x01\xbb\x00\xbc\x00\x0a\x01\x0b\x01\x72\x00\x5d\x00\x5e\x00\x5f\x00\x76\x00\x77\x00\x46\x00\x47\x00\x7a\x00\x7b\x00\x16\x01\x2c\x01\x18\x01\x2e\x01\xdc\x00\xdd\x00\xde\x00\xde\x00\xe0\x00\xe0\x00\xbd\x00\x06\x01\x07\x01\x23\x01\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x73\x00\x74\x00\xf2\x00\xf3\x00\xca\x00\x6b\x00\x37\x00\x72\x00\x16\x01\x17\x01\x18\x01\x72\x00\xfc\x00\xfd\x00\x6d\x00\xb5\x00\xb6\x00\x01\x01\x02\x01\x6b\x00\xba\x00\x23\x01\x6b\x00\xbd\x00\x37\x00\xbf\x00\x6b\x00\xc1\x00\xbb\x00\xbc\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\x72\x00\xc9\x00\xca\x00\xcb\x00\xaa\x00\xab\x00\xac\x00\x19\x01\x1a\x01\x65\x00\x1c\x01\x1d\x01\x1a\x01\x60\x00\x1c\x01\x1d\x01\x4a\x00\x23\x01\x65\x00\x25\x01\x26\x01\x23\x01\x52\x00\x29\x01\x52\x00\x20\x01\x21\x01\x22\x01\x56\x00\x24\x01\x06\x01\x07\x01\x5a\x00\x71\x00\x0a\x01\x0b\x01\x65\x00\x5f\x00\x1a\x01\x70\x00\x1c\x01\x1d\x01\xf2\x00\xf3\x00\xbb\x00\xbc\x00\x16\x01\x23\x01\x18\x01\x6b\x00\x2d\x01\x2e\x01\xfc\x00\xfd\x00\x6a\x00\x71\x00\x4a\x00\x01\x01\x02\x01\x23\x01\x76\x00\x77\x00\x0c\x01\x0d\x01\x7a\x00\x7b\x00\x70\x00\x71\x00\x56\x00\xb1\x00\xb2\x00\xb3\x00\x5a\x00\x4e\x00\xb1\x00\xb2\x00\xb3\x00\x5f\x00\xb1\x00\xb2\x00\xb3\x00\x19\x01\x1a\x01\x0b\x00\x1c\x01\x1d\x01\xb1\x00\xb2\x00\xb3\x00\x6b\x00\x32\x00\x23\x01\x18\x00\x25\x01\x26\x01\x71\x00\x4b\x00\x29\x01\xb5\x00\xb6\x00\x76\x00\x77\x00\x72\x00\xba\x00\x7a\x00\x7b\x00\xbd\x00\x6b\x00\xbf\x00\x71\x00\xc1\x00\xf1\x00\xf2\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\x6b\x00\xc9\x00\xca\x00\xcb\x00\xba\x00\x10\x00\x11\x00\xbd\x00\x6b\x00\xbf\x00\x6b\x00\xc1\x00\x10\x00\x11\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\x8c\x00\x6b\x00\xca\x00\xcb\x00\x98\x00\x91\x00\x6b\x00\x93\x00\x94\x00\x95\x00\x6b\x00\x97\x00\x98\x00\x6b\x00\x20\x01\x21\x01\x22\x01\x71\x00\x24\x01\xa3\x00\xa4\x00\x27\x01\x28\x01\x69\x00\xf2\x00\xf3\x00\x2c\x01\x43\x00\x44\x00\x45\x00\x46\x00\x34\x00\x35\x00\x4e\x00\xfc\x00\xfd\x00\xb1\x00\xb2\x00\xb3\x00\x01\x01\x02\x01\xbd\x00\xf2\x00\xf3\x00\x21\x01\x22\x01\x65\x00\x24\x01\x71\x00\xbd\x00\x4c\x00\x28\x01\xfc\x00\xfd\x00\xca\x00\x2c\x01\x61\x00\x01\x01\x02\x01\xab\x00\xac\x00\x61\x00\xca\x00\x19\x01\x1a\x01\x52\x00\x1c\x01\x1d\x01\x16\x00\x71\x00\x71\x00\x50\x00\x6b\x00\x23\x01\x65\x00\x25\x01\x26\x01\x48\x00\x48\x00\x29\x01\x71\x00\x19\x01\x1a\x01\x4b\x00\x1c\x01\x1d\x01\x69\x00\x4b\x00\x82\x00\x48\x00\x48\x00\x23\x01\x4e\x00\x25\x01\x26\x01\x8c\x00\x6b\x00\x29\x01\x72\x00\x6b\x00\x91\x00\x72\x00\x93\x00\x94\x00\x95\x00\x50\x00\x97\x00\x98\x00\x71\x00\x18\x00\x4b\x00\x6b\x00\x4b\x00\x18\x00\x06\x01\x07\x01\x4c\x00\x75\x00\x0a\x01\x0b\x01\x48\x00\x48\x00\x06\x01\x07\x01\x15\x00\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x16\x01\x81\x00\x18\x01\x6a\x00\x4a\x00\x58\x00\x81\x00\x0b\x00\x16\x01\x17\x01\x18\x01\x70\x00\x18\x00\x23\x01\xbd\x00\x18\x00\x56\x00\x48\x00\x81\x00\x6b\x00\x5a\x00\x23\x01\x18\x00\x65\x00\x8c\x00\x5f\x00\x69\x00\xca\x00\x71\x00\x91\x00\x5f\x00\x93\x00\x94\x00\x95\x00\x4a\x00\x97\x00\x98\x00\x72\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x50\x00\x4c\x00\x72\x00\x71\x00\x56\x00\x18\x00\x76\x00\x77\x00\x5a\x00\x18\x00\x7a\x00\x7b\x00\x07\x00\x5f\x00\x19\x00\x8c\x00\x48\x00\x55\x00\x50\x00\x90\x00\x91\x00\x69\x00\x93\x00\x94\x00\x95\x00\x7e\x00\x97\x00\x98\x00\x50\x00\x65\x00\x8e\x00\xbd\x00\x72\x00\x58\x00\x65\x00\x18\x00\x76\x00\x77\x00\x70\x00\x70\x00\x7a\x00\x7b\x00\x70\x00\x6b\x00\xca\x00\x06\x01\x07\x01\x69\x00\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x18\x00\x4a\x00\x48\x00\x48\x00\x6b\x00\x65\x00\x6b\x00\x18\x00\x16\x01\x17\x01\x18\x01\xbd\x00\x70\x00\x56\x00\x50\x00\x59\x00\x2b\x00\x5a\x00\x70\x00\x4c\x00\x71\x00\x23\x01\x5f\x00\x48\x00\xca\x00\x48\x00\x18\x00\x07\x00\x5f\x00\x50\x00\x07\x00\x18\x00\x8c\x00\x5f\x00\x4b\x00\x71\x00\x90\x00\x91\x00\x81\x00\x93\x00\x94\x00\x95\x00\x69\x00\x97\x00\x98\x00\x76\x00\x77\x00\x6b\x00\x6a\x00\x7a\x00\x7b\x00\x06\x01\x07\x01\x70\x00\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x70\x00\x15\x00\x6b\x00\x6b\x00\x59\x00\x6b\x00\x4b\x00\x8c\x00\x16\x01\x17\x01\x18\x01\x90\x00\x91\x00\x4c\x00\x93\x00\x94\x00\x95\x00\x52\x00\x97\x00\x98\x00\x10\x00\x23\x01\xbd\x00\x21\x00\x31\x00\x06\x01\x07\x01\x5f\x00\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x07\x00\x55\x00\xca\x00\x4a\x00\x4b\x00\x55\x00\x19\x00\x08\x00\x16\x01\x17\x01\x18\x01\x39\x00\x6a\x00\x68\x00\x2c\x00\x56\x00\x71\x00\x55\x00\x6b\x00\x5a\x00\x70\x00\x23\x01\x8c\x00\xbd\x00\x5f\x00\x65\x00\x90\x00\x91\x00\x42\x00\x93\x00\x94\x00\x95\x00\x02\x00\x97\x00\x98\x00\x71\x00\xca\x00\x6b\x00\x65\x00\x5f\x00\x6b\x00\x65\x00\x4b\x00\x72\x00\x4b\x00\x6a\x00\x02\x00\x76\x00\x77\x00\x18\x00\x6b\x00\x7a\x00\x7b\x00\x50\x00\x6a\x00\x6a\x00\x18\x00\x07\x00\x18\x00\x4a\x00\x07\x00\x12\x00\x06\x01\x07\x01\x76\x00\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x6b\x00\xbd\x00\x2e\x00\x76\x00\x2c\x01\xce\x00\x36\x00\xe6\x00\x16\x01\x17\x01\x18\x01\x8c\x00\x92\x00\x2b\x01\xca\x00\x90\x00\x91\x00\x5a\x00\x93\x00\x94\x00\x95\x00\x23\x01\x97\x00\x98\x00\x2b\x01\x82\x00\x06\x01\x07\x01\xe6\x00\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xe6\x00\x44\x00\x2f\x00\x16\x00\x16\x00\x2b\x01\x30\x00\x2a\x01\x16\x01\x17\x01\x18\x01\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x2b\x01\x93\x00\x94\x00\x95\x00\x23\x01\x97\x00\x98\x00\x7f\x00\x7f\x00\xbd\x00\x9c\x00\x9d\x00\x92\x00\x83\x00\x83\x00\x76\x00\xa1\x00\x5a\x00\xcc\x00\x87\x00\x30\x01\x16\x00\xca\x00\x06\x01\x07\x01\x2f\x01\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xc2\x00\x16\x00\x2a\x01\x20\x00\x7f\x00\x20\x00\x7f\x00\x2e\x00\x16\x01\x17\x01\x18\x01\x03\x00\xbd\x00\x0a\x00\x6a\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x23\x01\x93\x00\x94\x00\x95\x00\xca\x00\x97\x00\x98\x00\x30\x01\x2a\x01\x44\x00\xe0\x00\x2a\x01\x2a\x01\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x2a\x01\x93\x00\x94\x00\x95\x00\x55\x00\x97\x00\x98\x00\x6e\x00\x78\x00\x56\x00\x76\x00\x06\x01\x07\x01\x80\x00\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x26\x01\x4a\x00\x4b\x00\x4c\x00\x74\x00\xbd\x00\xf2\x00\x50\x00\x16\x01\x17\x01\x18\x01\x0d\x01\x32\x00\x56\x00\x20\x00\x20\x00\x2a\x00\x5a\x00\xca\x00\x31\x00\x48\x00\x23\x01\x5f\x00\x64\x00\xbd\x00\x5f\x00\x06\x01\x07\x01\x6d\x00\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x69\x00\x72\x00\xa6\x00\xca\x00\x2a\x00\x2a\x01\x0f\x00\x72\x00\x16\x01\x17\x01\x18\x01\x76\x00\x77\x00\x2a\x01\x1c\x00\x7a\x00\x7b\x00\x1c\x00\xc2\x00\x72\x00\xe0\x00\x23\x01\xa6\x00\xa4\x00\xf2\x00\xb3\x00\x4b\x00\x17\x00\x2b\x01\x24\x00\x2c\x01\x2b\x01\x2e\x01\x17\x00\x2a\x00\x32\x00\x4c\x00\x51\x00\x51\x00\x2a\x01\x46\x00\x2a\x01\x2a\x01\xf2\x00\x06\x01\x07\x01\x50\x00\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x2f\x00\x11\x00\x2b\x01\x0c\x00\x16\x00\x5a\x00\x57\x00\x2a\x01\x16\x01\x17\x01\x18\x01\x06\x01\x07\x01\x2b\x01\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x21\x01\x22\x01\x23\x01\x24\x01\x33\x00\x2a\x01\x27\x01\x28\x01\x16\x01\x17\x01\x18\x01\x2c\x01\x55\x00\x57\x00\x16\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x23\x01\x93\x00\x94\x00\x95\x00\x2b\x01\x97\x00\x98\x00\xf7\x00\xf8\x00\x2c\x01\xfa\x00\x20\x00\x2a\x01\x2a\x01\xfe\x00\x2a\x01\x20\x00\x01\x01\x02\x01\xa6\x00\x88\x00\x89\x00\x17\x00\x2b\x01\x8c\x00\x8d\x00\x2b\x01\x8f\x00\x90\x00\x91\x00\x2b\x01\x93\x00\x94\x00\x95\x00\x17\x00\x97\x00\x98\x00\x2b\x01\x9a\x00\xff\xff\xff\xff\x19\x01\xff\xff\xbd\x00\xff\xff\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\xff\xff\x26\x01\xff\xff\xca\x00\xff\xff\xff\xff\x88\x00\x89\x00\xff\xff\xff\xff\x8c\x00\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xbd\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\xff\xff\xff\xff\xff\xff\x88\x00\x89\x00\xff\xff\xff\xff\x8c\x00\x8d\x00\xf2\x00\x8f\x00\x90\x00\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\xff\xff\xff\xff\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xff\xff\xca\x00\xf2\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x01\x17\x01\x18\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\x23\x01\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x2c\x01\xff\xff\xca\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x01\x17\x01\x18\x01\xf2\x00\x89\x00\xff\xff\xff\xff\x8c\x00\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\x23\x01\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\x99\x00\xff\xff\xff\xff\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xff\xff\xff\xff\xff\xff\xf2\x00\xff\xff\xff\xff\xff\xff\xff\xff\x16\x01\x17\x01\x18\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x06\x01\x07\x01\xbd\x00\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\x16\x01\x17\x01\x18\x01\x88\x00\x89\x00\xff\xff\xff\xff\x8c\x00\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\x23\x01\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x89\x00\xff\xff\xff\xff\x8c\x00\x8d\x00\xf2\x00\x8f\x00\x90\x00\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\x99\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\xff\xff\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xff\xff\xff\xff\xca\x00\xff\xff\x4a\x00\x4b\x00\xff\xff\xff\xff\x16\x01\x17\x01\x18\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\xff\xff\xbd\x00\x5a\x00\x23\x01\xff\xff\x89\x00\xff\xff\x5f\x00\x8c\x00\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xca\x00\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\x99\x00\xff\xff\xff\xff\xf2\x00\xff\xff\x72\x00\xff\xff\xff\xff\xff\xff\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xff\xff\xff\xff\xf2\x00\xff\xff\xff\xff\xbd\x00\xff\xff\xff\xff\x16\x01\x17\x01\x18\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\xff\xff\xff\xff\x23\x01\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8c\x00\x16\x01\x17\x01\x18\x01\x90\x00\xff\xff\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\x23\x01\xff\xff\x89\x00\xff\xff\x8b\x00\x8c\x00\x8d\x00\xf2\x00\x8f\x00\x90\x00\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xad\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xbd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x01\x17\x01\x18\x01\xff\xff\xff\xff\xca\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\x23\x01\xff\xff\x89\x00\xff\xff\x8b\x00\x8c\x00\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xca\x00\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xff\xff\x89\x00\xff\xff\x8b\x00\x8c\x00\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\x06\x01\x07\x01\xbd\x00\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\x16\x01\x17\x01\x18\x01\x06\x01\x07\x01\xbd\x00\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xff\xff\xff\xff\x23\x01\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\x16\x01\x17\x01\x18\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x89\x00\xff\xff\xff\xff\x8c\x00\x8d\x00\xf2\x00\x8f\x00\x90\x00\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x01\x17\x01\x18\x01\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xbd\x00\xff\xff\x23\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x01\x17\x01\x18\x01\xff\xff\xff\xff\xca\x00\xff\xff\xff\xff\x89\x00\xff\xff\xff\xff\x8c\x00\x8d\x00\x23\x01\x8f\x00\x90\x00\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xff\xff\x89\x00\xff\xff\xff\xff\x8c\x00\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xf2\x00\xfb\x00\xff\xff\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\xff\xff\xff\xff\x04\x01\xff\xff\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\xff\xff\xff\xff\xff\xff\x06\x01\x07\x01\x10\x01\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xca\x00\xff\xff\xff\xff\x19\x01\xff\xff\xff\xff\xbd\x00\x1d\x01\x16\x01\x17\x01\x18\x01\x21\x01\x22\x01\x23\x01\x24\x01\x25\x01\x26\x01\x27\x01\x28\x01\xca\x00\xff\xff\x23\x01\x89\x00\xff\xff\xff\xff\x8c\x00\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xf2\x00\x89\x00\xff\xff\xff\xff\x8c\x00\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xf2\x00\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbd\x00\x04\x01\x16\x01\x17\x01\x18\x01\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xca\x00\x11\x01\x23\x01\x13\x01\x14\x01\xff\xff\xbd\x00\xff\xff\x16\x01\x17\x01\x18\x01\xff\xff\xff\xff\xff\xff\x1e\x01\xff\xff\x20\x01\x21\x01\x22\x01\xca\x00\x24\x01\x23\x01\x89\x00\x27\x01\x28\x01\x8c\x00\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xf2\x00\x89\x00\xff\xff\xff\xff\x8c\x00\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xf2\x00\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\x16\x01\x17\x01\x18\x01\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xca\x00\xff\xff\x23\x01\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\x16\x01\x17\x01\x18\x01\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xff\xff\xca\x00\xff\xff\x23\x01\x89\x00\xff\xff\xff\xff\x8c\x00\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xf2\x00\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\x16\x01\x17\x01\x18\x01\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xca\x00\xff\xff\x23\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x01\x17\x01\x18\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\x9b\x00\x9c\x00\xff\xff\xf2\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\x9b\x00\x9c\x00\xff\xff\xff\xff\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\xff\xff\xff\xff\xff\xff\x16\x01\x17\x01\x18\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xbd\x00\xff\xff\xff\xff\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xca\x00\x97\x00\x98\x00\xff\xff\xff\xff\xff\xff\x9c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xff\xff\x9c\x00\xbd\x00\xf2\x00\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xff\xff\xff\xff\xff\xff\xca\x00\xff\xff\xff\xff\xff\xff\xff\xff\x16\x01\x17\x01\x18\x01\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xff\xff\xff\xff\x23\x01\xbd\x00\xff\xff\xff\xff\xff\xff\xff\xff\x16\x01\x17\x01\x18\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\xff\xff\xff\xff\x4a\x00\x4b\x00\x23\x01\xff\xff\xff\xff\xf2\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x56\x00\x93\x00\x94\x00\x95\x00\x5a\x00\x97\x00\x98\x00\xff\xff\xff\xff\x5f\x00\xff\xff\x9d\x00\xff\xff\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xff\xff\xff\xff\x72\x00\x16\x01\x17\x01\x18\x01\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xbd\x00\xff\xff\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xff\xff\xff\xff\xff\xff\xca\x00\xff\xff\xff\xff\xff\xff\xff\xff\x16\x01\x17\x01\x18\x01\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\x23\x01\x97\x00\x98\x00\xff\xff\xff\xff\xff\xff\x9c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xff\xff\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xbd\x00\x9c\x00\xff\xff\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xff\xff\xff\xff\xca\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x01\x17\x01\x18\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\xbd\x00\xff\xff\xff\xff\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xca\x00\x97\x00\x98\x00\xff\xff\xff\xff\xff\xff\xf2\x00\xff\xff\xff\xff\xff\xff\xa0\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x04\x01\xff\xff\xff\xff\xff\xff\xff\xff\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x11\x01\xff\xff\x13\x01\x14\x01\xff\xff\xbd\x00\xf2\x00\xff\xff\x16\x01\x17\x01\x18\x01\xff\xff\xff\xff\x1e\x01\xff\xff\x20\x01\x21\x01\x22\x01\xca\x00\x24\x01\xff\xff\x23\x01\x27\x01\x28\x01\xff\xff\xff\xff\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x01\x17\x01\x18\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\xff\xff\xf2\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\x04\x01\xff\xff\xff\xff\xff\xff\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xff\xff\x11\x01\xff\xff\x13\x01\x14\x01\xff\xff\xff\xff\xff\xff\x16\x01\x17\x01\x18\x01\xff\xff\xff\xff\xff\xff\x1e\x01\xff\xff\x20\x01\x21\x01\x22\x01\xff\xff\x24\x01\x23\x01\xbd\x00\x27\x01\x28\x01\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xca\x00\x97\x00\x98\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xff\xff\xfa\x00\xbd\x00\xf2\x00\xff\xff\xfe\x00\xff\xff\xff\xff\x01\x01\x02\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xff\xff\x19\x01\xff\xff\xca\x00\xff\xff\x1d\x01\xff\xff\xff\xff\x16\x01\x17\x01\x18\x01\x23\x01\xff\xff\xff\xff\x26\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\xff\xff\xf2\x00\xff\xff\xff\xff\x8c\x00\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xff\xff\xf2\x00\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xa5\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x01\x17\x01\x18\x01\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xff\xff\xff\xff\x23\x01\xff\xff\xff\xff\xbd\x00\xff\xff\xff\xff\x16\x01\x17\x01\x18\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\xff\xff\xff\xff\x23\x01\xff\xff\xff\xff\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xf2\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\xff\xff\xff\xff\xff\xff\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xca\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\x16\x01\x17\x01\x18\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\xff\xff\x23\x01\xff\xff\xff\xff\xff\xff\x8c\x00\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xf2\x00\xff\xff\xff\xff\xff\xff\x8c\x00\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xa5\x00\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xf2\x00\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xff\xff\xa5\x00\xff\xff\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\x16\x01\x17\x01\x18\x01\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xca\x00\xff\xff\x23\x01\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\x16\x01\x17\x01\x18\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\xff\xff\x23\x01\xff\xff\xff\xff\xff\xff\x8c\x00\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xf2\x00\xff\xff\xff\xff\xff\xff\x8c\x00\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xa5\x00\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xf2\x00\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xff\xff\xa5\x00\xff\xff\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\x16\x01\x17\x01\x18\x01\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xca\x00\xff\xff\x23\x01\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\x16\x01\x17\x01\x18\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\xff\xff\x23\x01\xff\xff\xff\xff\xff\xff\x8c\x00\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xf2\x00\xff\xff\xff\xff\xff\xff\x8c\x00\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xa5\x00\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xf2\x00\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xff\xff\xa5\x00\xff\xff\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\x16\x01\x17\x01\x18\x01\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xca\x00\xff\xff\x23\x01\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\x16\x01\x17\x01\x18\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\xff\xff\x23\x01\xff\xff\xff\xff\xff\xff\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xf2\x00\xff\xff\xff\xff\xff\xff\x8c\x00\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xf2\x00\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xff\xff\xa5\x00\xff\xff\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\x16\x01\x17\x01\x18\x01\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xca\x00\xff\xff\x23\x01\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\x16\x01\x17\x01\x18\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\xff\xff\x23\x01\xff\xff\xff\xff\xff\xff\x8c\x00\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xf2\x00\xff\xff\xff\xff\xff\xff\x8c\x00\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xf2\x00\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\x16\x01\x17\x01\x18\x01\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xca\x00\xff\xff\x23\x01\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\x16\x01\x17\x01\x18\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\xff\xff\x23\x01\xff\xff\xff\xff\xff\xff\x8c\x00\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xf2\x00\xff\xff\xff\xff\xff\xff\x8c\x00\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xf2\x00\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\x16\x01\x17\x01\x18\x01\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xca\x00\xff\xff\x23\x01\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\x16\x01\x17\x01\x18\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\xff\xff\x23\x01\xff\xff\xff\xff\xff\xff\x8c\x00\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xf2\x00\xff\xff\xff\xff\xff\xff\x8c\x00\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xf2\x00\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\x16\x01\x17\x01\x18\x01\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xca\x00\xff\xff\x23\x01\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\x16\x01\x17\x01\x18\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\xff\xff\x23\x01\xff\xff\xff\xff\xff\xff\x8c\x00\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xf2\x00\xff\xff\xff\xff\xff\xff\x8c\x00\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xf2\x00\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\x16\x01\x17\x01\x18\x01\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xca\x00\xff\xff\x23\x01\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\x16\x01\x17\x01\x18\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\xff\xff\x23\x01\xff\xff\xff\xff\xff\xff\x8c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xf2\x00\xff\xff\xff\xff\xff\xff\x8c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xf2\x00\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\x16\x01\x17\x01\x18\x01\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xca\x00\xff\xff\x23\x01\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\x16\x01\x17\x01\x18\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\xff\xff\x23\x01\xff\xff\xff\xff\xff\xff\x8c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xff\xff\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\x16\x01\x17\x01\x18\x01\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xca\x00\xff\xff\x23\x01\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\x16\x01\x17\x01\x18\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\xff\xff\x23\x01\xff\xff\xff\xff\xff\xff\x8c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xff\xff\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\x16\x01\x17\x01\x18\x01\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xca\x00\xff\xff\x23\x01\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\x16\x01\x17\x01\x18\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\xff\xff\x23\x01\xff\xff\xff\xff\xff\xff\x8c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xff\xff\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\x16\x01\x17\x01\x18\x01\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xca\x00\xff\xff\x23\x01\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\x16\x01\x17\x01\x18\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\xff\xff\x23\x01\xff\xff\xff\xff\xff\xff\x8c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xad\x00\xff\xff\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\x16\x01\x17\x01\x18\x01\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xca\x00\xff\xff\x23\x01\xff\xff\xff\xff\x02\x00\xbd\x00\xff\xff\x16\x01\x17\x01\x18\x01\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\xff\xff\x23\x01\xff\xff\xff\xff\x15\x00\x8c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\x16\x01\x17\x01\x18\x01\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xca\x00\xff\xff\x23\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x01\x17\x01\x18\x01\xff\xff\xff\xff\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xff\xff\xfa\x00\xff\xff\xff\xff\x23\x01\xfe\x00\xff\xff\xff\xff\x01\x01\x02\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\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\x19\x01\xff\xff\xff\xff\xff\xff\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\x06\x01\x07\x01\x26\x01\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x01\x17\x01\x18\x01\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\x23\x01\x07\x00\x08\x00\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x10\x00\x11\x00\xff\xff\xff\xff\x14\x00\x15\x00\x16\x00\xff\xff\x18\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\xff\xff\xff\xff\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\xff\xff\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\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\x00\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\x08\x00\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x10\x00\x11\x00\xff\xff\xff\xff\x14\x00\x15\x00\x16\x00\xff\xff\x18\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\xff\xff\xff\xff\x50\x00\x51\x00\x52\x00\x53\x00\xff\xff\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\xff\xff\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\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\x00\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\x08\x00\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x10\x00\x11\x00\xff\xff\xff\xff\x14\x00\x15\x00\x16\x00\xff\xff\x18\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\xff\xff\xff\xff\x50\x00\x51\x00\x52\x00\x53\x00\xff\xff\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\xff\xff\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\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\x00\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\x08\x00\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x10\x00\x11\x00\xff\xff\xff\xff\x14\x00\x15\x00\x16\x00\xff\xff\x18\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\xff\xff\xff\xff\x50\x00\x51\x00\x52\x00\x53\x00\xff\xff\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\xff\xff\xff\xff\x62\x00\x63\x00\x64\x00\x65\x00\xff\xff\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\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\x00\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\x08\x00\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x10\x00\x11\x00\xff\xff\xff\xff\x14\x00\x15\x00\x16\x00\xff\xff\x18\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\xff\xff\xff\xff\x50\x00\x51\x00\x52\x00\x53\x00\xff\xff\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\xff\xff\xff\xff\x62\x00\x63\x00\x64\x00\x65\x00\xff\xff\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\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\x00\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\x08\x00\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x10\x00\x11\x00\xff\xff\xff\xff\x14\x00\x15\x00\x16\x00\xff\xff\x18\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\xff\xff\xff\xff\x50\x00\x51\x00\x52\x00\x53\x00\xff\xff\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\xff\xff\xff\xff\x62\x00\x63\x00\x64\x00\x65\x00\xff\xff\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\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\x00\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\x08\x00\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x10\x00\x11\x00\xff\xff\xff\xff\x14\x00\x15\x00\x16\x00\xff\xff\x18\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\xff\xff\xff\xff\x50\x00\x51\x00\x52\x00\x53\x00\xff\xff\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\xff\xff\xff\xff\x62\x00\x63\x00\xff\xff\x65\x00\xff\xff\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\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\x00\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\x14\x00\x15\x00\x16\x00\xff\xff\x18\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\xff\xff\xff\xff\x50\x00\x51\x00\x52\x00\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\xff\xff\xff\xff\x62\x00\xff\xff\xff\xff\x65\x00\xff\xff\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\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\x00\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\x14\x00\x15\x00\x16\x00\xff\xff\x18\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\xff\xff\xff\xff\x50\x00\x51\x00\x52\x00\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\xff\xff\xff\xff\x62\x00\xff\xff\xff\xff\x65\x00\xff\xff\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\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\x00\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\x14\x00\x15\x00\x16\x00\xff\xff\x18\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\xff\xff\xff\xff\x50\x00\x51\x00\x52\x00\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\xff\xff\xff\xff\x62\x00\xff\xff\xff\xff\x65\x00\xff\xff\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\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\x00\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\x56\x00\x57\x00\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x67\x00\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x00\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\x50\x00\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\x57\x00\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x67\x00\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x00\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\x4b\x00\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\x52\x00\x53\x00\xff\xff\x55\x00\x56\x00\x57\x00\x58\x00\xff\xff\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\x62\x00\x63\x00\x64\x00\x65\x00\xff\xff\x67\x00\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\x70\x00\xff\xff\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\xff\xff\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x91\x00\x09\x00\x0a\x00\x94\x00\x95\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\xff\xff\x13\x00\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x47\x00\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\x56\x00\x57\x00\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\x4b\x00\xff\xff\x4d\x00\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\x54\x00\xff\xff\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\xff\xff\x61\x00\x62\x00\xff\xff\x64\x00\xff\xff\xff\xff\xff\xff\x68\x00\x69\x00\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\x06\x00\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\x0d\x00\x0e\x00\x0f\x00\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\xff\xff\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x47\x00\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\x56\x00\x57\x00\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\x0d\x00\x0e\x00\x0f\x00\xff\xff\x11\x00\xff\xff\x13\x00\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\xff\xff\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x47\x00\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\x56\x00\x57\x00\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\x06\x00\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\x0d\x00\x0e\x00\x0f\x00\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\xff\xff\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x47\x00\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\x56\x00\x57\x00\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\x0d\x00\x0e\x00\x0f\x00\xff\xff\x11\x00\xff\xff\x13\x00\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\xff\xff\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x47\x00\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\x56\x00\x57\x00\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\x6b\x00\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\x4b\x00\x4c\x00\x4d\x00\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\xff\xff\x64\x00\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\x4b\x00\x4c\x00\x4d\x00\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\xff\xff\x64\x00\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\x4b\x00\x4c\x00\x4d\x00\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\xff\xff\x64\x00\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\x6d\x00\x6e\x00\xff\xff\xff\xff\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\xff\xff\xff\xff\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\x0d\x00\x0e\x00\x0f\x00\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\xff\xff\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x47\x00\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\x56\x00\x57\x00\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\x6b\x00\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\x0d\x00\x0e\x00\x0f\x00\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\xff\xff\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x47\x00\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\x56\x00\x57\x00\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\x6d\x00\x6e\x00\xff\xff\xff\xff\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\x0d\x00\x0e\x00\x0f\x00\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\xff\xff\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x47\x00\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\x56\x00\x57\x00\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\x69\x00\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x64\x00\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\x56\x00\x57\x00\x58\x00\x59\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\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\x56\x00\x57\x00\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\x16\x00\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\x56\x00\x57\x00\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\x56\x00\x57\x00\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\x56\x00\x57\x00\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\x16\x00\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\x56\x00\x57\x00\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\x56\x00\x57\x00\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\x56\x00\x57\x00\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\x56\x00\x57\x00\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\x56\x00\x57\x00\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\x56\x00\x57\x00\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\x56\x00\x57\x00\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\x56\x00\x57\x00\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\x56\x00\x57\x00\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\x56\x00\x57\x00\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xff\xff\xfa\x00\xff\xff\xff\xff\xff\xff\xfe\x00\xff\xff\xff\xff\x01\x01\x02\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\x4e\x00\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x57\x00\x58\x00\x59\x00\x19\x01\xff\xff\xff\xff\xff\xff\x1d\x01\xff\xff\xff\xff\xff\xff\x21\x01\x22\x01\x23\x01\x24\x01\xff\xff\x26\x01\x68\x00\x28\x01\x6a\x00\xff\xff\x6c\x00\x2c\x01\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\x56\x00\x57\x00\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\x56\x00\x57\x00\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\x56\x00\x57\x00\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x02\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x57\x00\x58\x00\x59\x00\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\x74\x00\x75\x00\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\x81\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\x56\x00\x57\x00\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\x56\x00\x57\x00\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\x50\x00\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\x57\x00\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\x56\x00\x57\x00\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\x56\x00\x57\x00\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\x57\x00\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x02\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x57\x00\x58\x00\x59\x00\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\x6f\x00\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\x74\x00\x75\x00\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\x81\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x02\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x57\x00\x58\x00\x59\x00\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\x74\x00\x75\x00\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\x81\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x02\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x4d\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x57\x00\x58\x00\x59\x00\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\x74\x00\x75\x00\xff\xff\xff\xff\xff\xff\x79\x00\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\x4b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\x53\x00\xff\xff\x55\x00\x56\x00\x57\x00\x58\x00\xff\xff\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\x62\x00\x63\x00\x64\x00\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\x6b\x00\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\xff\xff\x79\x00\x7a\x00\x7b\x00\x01\x00\x02\x00\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\x91\x00\xff\xff\xff\xff\x94\x00\x95\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\x4b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\x53\x00\xff\xff\x55\x00\x56\x00\x57\x00\x58\x00\xff\xff\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\x62\x00\x63\x00\x64\x00\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\x6b\x00\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\xff\xff\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\x01\x00\x02\x00\x80\x00\x81\x00\x82\x00\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x91\x00\x15\x00\xff\xff\x94\x00\x95\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\x01\x00\x02\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\xff\xff\xff\xff\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\xff\xff\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x64\x00\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\x6b\x00\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\xff\xff\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\xff\xff\x80\x00\x81\x00\x82\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x91\x00\xff\xff\xff\xff\x94\x00\x95\x00\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\xff\xff\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x64\x00\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\x6d\x00\xff\xff\xff\xff\xff\xff\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\xff\xff\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\xff\xff\x80\x00\x81\x00\x82\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x91\x00\xff\xff\xff\xff\x94\x00\x95\x00\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\xff\xff\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x64\x00\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\x6b\x00\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\xff\xff\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\xff\xff\x80\x00\x81\x00\x82\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x91\x00\xff\xff\xff\xff\x94\x00\x95\x00\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\xff\xff\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x64\x00\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\x6b\x00\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\xff\xff\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\xff\xff\x80\x00\x81\x00\x82\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x91\x00\xff\xff\xff\xff\x94\x00\x95\x00\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\xff\xff\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x64\x00\xff\xff\xff\xff\xff\xff\x68\x00\x69\x00\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\xff\xff\x79\x00\x7a\x00\x7b\x00\x01\x00\x02\x00\x7e\x00\xff\xff\x80\x00\x81\x00\x82\x00\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x10\x00\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\x91\x00\xff\xff\xff\xff\x94\x00\x95\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\xff\xff\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x64\x00\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\xff\xff\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\x01\x00\x02\x00\x80\x00\x81\x00\x82\x00\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x10\x00\xff\xff\xff\xff\xff\xff\x91\x00\x15\x00\xff\xff\x94\x00\x95\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\xff\xff\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x64\x00\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\xff\xff\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\x01\x00\x02\x00\x80\x00\x81\x00\x82\x00\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x91\x00\x15\x00\xff\xff\x94\x00\x95\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\xff\xff\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x64\x00\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\x6b\x00\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\xff\xff\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\xff\xff\x80\x00\x81\x00\x82\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x91\x00\xff\xff\xff\xff\x94\x00\x95\x00\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\xff\xff\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x64\x00\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\xff\xff\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\xff\xff\x80\x00\x81\x00\x82\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x91\x00\xff\xff\xff\xff\x94\x00\x95\x00\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\x4a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\xff\xff\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x64\x00\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\xff\xff\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\x01\x00\x02\x00\x80\x00\x81\x00\x82\x00\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x91\x00\x15\x00\xff\xff\x94\x00\x95\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\x4a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\xff\xff\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x64\x00\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\xff\xff\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\x01\x00\x02\x00\x80\x00\x81\x00\x82\x00\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x91\x00\x15\x00\xff\xff\x94\x00\x95\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\xff\xff\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x64\x00\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\xff\xff\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\xff\xff\x80\x00\x81\x00\x82\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x91\x00\xff\xff\xff\xff\x94\x00\x95\x00\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\xff\xff\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x64\x00\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\xff\xff\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\xff\xff\x80\x00\x81\x00\x82\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x91\x00\xff\xff\xff\xff\x94\x00\x95\x00\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\xff\xff\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x64\x00\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\xff\xff\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\xff\xff\x80\x00\x81\x00\x82\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x91\x00\xff\xff\xff\xff\x94\x00\x95\x00\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\xff\xff\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x64\x00\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\xff\xff\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\x01\x00\x02\x00\x80\x00\x81\x00\x82\x00\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x91\x00\x15\x00\xff\xff\x94\x00\x95\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\xff\xff\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x64\x00\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\xff\xff\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\x01\x00\x02\x00\x80\x00\x81\x00\x82\x00\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x91\x00\x15\x00\xff\xff\x94\x00\x95\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\xff\xff\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x64\x00\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\xff\xff\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\x01\x00\x02\x00\x80\x00\x81\x00\x82\x00\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x91\x00\x15\x00\xff\xff\x94\x00\x95\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\xff\xff\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x64\x00\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\xff\xff\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\x01\x00\x02\x00\x80\x00\x81\x00\x82\x00\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x91\x00\x15\x00\xff\xff\x94\x00\x95\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\xff\xff\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x64\x00\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\xff\xff\x79\x00\x7a\x00\x7b\x00\x01\x00\x02\x00\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\x91\x00\xff\xff\xff\xff\x94\x00\x95\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\xff\xff\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x64\x00\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\xff\xff\x79\x00\x7a\x00\x7b\x00\x01\x00\x02\x00\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\x91\x00\xff\xff\xff\xff\x94\x00\x95\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x02\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x57\x00\x58\x00\xff\xff\x5a\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\x64\x00\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\xff\xff\x79\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x91\x00\xff\xff\xff\xff\x94\x00\x95\x00\x6a\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\x74\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\x81\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x02\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\x6a\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\x74\x00\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\xe1\x00\xe2\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xff\xff\xff\xff\x81\x00\xff\xff\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\x2a\x01\xe1\x00\xe2\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x01\xff\xff\xff\xff\x34\x01\xff\xff\x36\x01\xff\xff\x38\x01\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xff\xff\xff\xff\xff\xff\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xe1\x00\xe2\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x01\xff\xff\xff\xff\x34\x01\xff\xff\x36\x01\xff\xff\x38\x01\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xff\xff\xff\xff\xff\xff\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xe1\x00\xe2\x00\x49\x00\x4a\x00\x4b\x00\xff\xff\xff\xff\x31\x01\xff\xff\x50\x00\x34\x01\x52\x00\x36\x01\xff\xff\x38\x01\x56\x00\xff\xff\xf2\x00\xf3\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\x65\x00\xbd\x00\x01\x01\x02\x01\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xc5\x00\xc6\x00\xc7\x00\x71\x00\x72\x00\xca\x00\xcb\x00\xff\xff\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xe4\x00\xe5\x00\x29\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x01\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\x38\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xff\xff\xbd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\x2a\x01\xe4\x00\xe5\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x33\x01\xff\xff\x35\x01\xff\xff\x37\x01\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xbd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xe4\x00\xe5\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbd\x00\x33\x01\xff\xff\x35\x01\xff\xff\x37\x01\xf2\x00\xf3\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe4\x00\xe5\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xff\xff\x33\x01\xff\xff\x35\x01\xff\xff\x37\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\x15\x00\x25\x01\x26\x01\xff\xff\x19\x00\x29\x01\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x37\x01\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\xff\xff\xff\xff\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\x02\x00\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\x72\x00\xff\xff\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\xff\xff\xff\xff\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\x72\x00\xff\xff\x74\x00\x75\x00\x76\x00\x77\x00\x09\x00\x79\x00\xff\xff\x7b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\x2d\x00\x02\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\x2d\x00\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x71\x00\x09\x00\xff\xff\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\x6a\x00\x02\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x09\x00\xff\xff\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\x09\x00\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\xff\xff\x15\x00\x78\x00\x79\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\x09\x00\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\x6a\x00\xff\xff\x02\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x09\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\x09\x00\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\xff\xff\x15\x00\xff\xff\x79\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x02\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x10\x00\xff\xff\x74\x00\x75\x00\xff\xff\x15\x00\x78\x00\x79\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\x74\x00\x75\x00\xff\xff\xff\xff\xff\xff\x79\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\x68\x00\xff\xff\x6a\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\x74\x00\xff\xff\xff\xff\xff\xff\x78\x00\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\x68\x00\xff\xff\x6a\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\x02\x00\x74\x00\xff\xff\xff\xff\xff\xff\x78\x00\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x6a\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\x74\x00\xff\xff\xff\xff\xff\xff\x78\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\x6a\x00\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\x78\x00\xbd\x00\xff\xff\xff\xff\xc0\x00\xc1\x00\x4a\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\x56\x00\xff\xff\xff\xff\xff\xff\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\x6b\x00\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x71\x00\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xbd\x00\x01\x01\x02\x01\xc0\x00\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x01\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xff\xff\x04\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x01\x13\x01\xff\xff\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\x1f\x01\x20\x01\x21\x01\x22\x01\x23\x01\x24\x01\x25\x01\x26\x01\x27\x01\x28\x01\x29\x01\xff\xff\xff\xff\x2c\x01\xff\xff\x2e\x01\xff\xff\x02\x00\x31\x01\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\x09\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\x15\x00\xff\xff\xd0\x00\xd1\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xff\xff\x04\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x01\x13\x01\xff\xff\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\x1f\x01\x20\x01\x21\x01\x22\x01\x23\x01\x24\x01\x25\x01\x26\x01\x27\x01\x28\x01\x29\x01\xff\xff\xff\xff\x2c\x01\x74\x00\x2e\x01\xff\xff\x02\x00\x31\x01\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\x09\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\x15\x00\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xff\xff\x04\x01\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\x12\x01\x13\x01\xff\xff\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\x1f\x01\x20\x01\xff\xff\x22\x01\x23\x01\x24\x01\x25\x01\x26\x01\x27\x01\x28\x01\x29\x01\xff\xff\xff\xff\x2c\x01\x74\x00\x2e\x01\xff\xff\xff\xff\x31\x01\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xd0\x00\xff\xff\xff\xff\xff\xff\xd4\x00\xd5\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xff\xff\x04\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x01\x13\x01\xff\xff\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\x1f\x01\x20\x01\xff\xff\x22\x01\x23\x01\x24\x01\x25\x01\x26\x01\x27\x01\x28\x01\x29\x01\xff\xff\xff\xff\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\x31\x01\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xd0\x00\xff\xff\xff\xff\xd3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xff\xff\x04\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x01\x13\x01\xff\xff\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\x1f\x01\x20\x01\xff\xff\x22\x01\x23\x01\x24\x01\x25\x01\x26\x01\x27\x01\x28\x01\x29\x01\xff\xff\xff\xff\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\x31\x01\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xd0\x00\xff\xff\xff\xff\xd3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xff\xff\x04\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x01\x13\x01\xff\xff\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\x1f\x01\x20\x01\xff\xff\x22\x01\x23\x01\x24\x01\x25\x01\x26\x01\x27\x01\x28\x01\x29\x01\xff\xff\xff\xff\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\x31\x01\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xd0\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xff\xff\x04\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x01\x13\x01\xff\xff\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\x1f\x01\x20\x01\xff\xff\x22\x01\x23\x01\x24\x01\x25\x01\x26\x01\x27\x01\x28\x01\x29\x01\xff\xff\xff\xff\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\x31\x01\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xd0\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xff\xff\x04\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x01\x13\x01\xff\xff\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\x1f\x01\x20\x01\xff\xff\x22\x01\x23\x01\x24\x01\x25\x01\x26\x01\x27\x01\x28\x01\x29\x01\xff\xff\xff\xff\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\x31\x01\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xd0\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xff\xff\x04\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x01\x13\x01\xff\xff\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\x1f\x01\x20\x01\xff\xff\x22\x01\x23\x01\x24\x01\x25\x01\x26\x01\x27\x01\x28\x01\x29\x01\xff\xff\xff\xff\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\x31\x01\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xd0\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xff\xff\x04\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x01\x13\x01\xff\xff\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\x1f\x01\x20\x01\xff\xff\x22\x01\x23\x01\x24\x01\x25\x01\x26\x01\x27\x01\x28\x01\x29\x01\xff\xff\xff\xff\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\x31\x01\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xd0\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xff\xff\x04\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x01\x13\x01\xff\xff\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\x1f\x01\x20\x01\xff\xff\x22\x01\x23\x01\x24\x01\x25\x01\x26\x01\x27\x01\x28\x01\x29\x01\xff\xff\xff\xff\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\x31\x01\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xd0\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xff\xff\x04\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x01\x13\x01\xff\xff\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\x1f\x01\x20\x01\xff\xff\x22\x01\x23\x01\x24\x01\x25\x01\x26\x01\x27\x01\x28\x01\x29\x01\xff\xff\xff\xff\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\x31\x01\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xeb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xff\xff\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xd7\x00\xd8\x00\xd9\x00\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xe3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x01\xeb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xff\xff\xff\xff\xff\xff\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xff\xff\xe3\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x01\xe9\x00\xea\x00\xeb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xff\xff\xff\xff\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xe3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xe8\x00\x31\x01\xea\x00\xeb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xff\xff\xff\xff\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xe3\x00\xff\xff\xff\xff\xff\xff\xe7\x00\xff\xff\x31\x01\xea\x00\xeb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xff\xff\xff\xff\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xe3\x00\xff\xff\xff\xff\xff\xff\xe7\x00\xff\xff\x31\x01\xea\x00\xeb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xff\xff\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xda\x00\xdb\x00\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xe3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x01\xeb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xff\xff\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xda\x00\xdb\x00\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xe3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x01\xeb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xde\x00\xdf\x00\xe0\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xff\xff\xff\xff\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xe3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x01\xea\x00\xeb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xff\xff\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xd9\x00\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xe3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x01\xeb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xff\xff\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xe3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x01\xeb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xe1\x00\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xe1\x00\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xe1\x00\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x01\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\x1b\x00\x1c\x00\x1d\x00\x01\x01\x02\x01\xff\xff\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\x1a\x01\x02\x00\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\x12\x00\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\x31\x01\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x02\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x74\x00\x75\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x02\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x74\x00\x75\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x02\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x74\x00\x75\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x02\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\xff\xff\xff\xff\x4c\x00\xff\xff\x15\x00\xff\xff\xff\xff\x51\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x64\x00\xff\xff\xff\xff\x02\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x09\x00\xff\xff\xff\xff\x71\x00\xff\xff\xff\xff\x74\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x6a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x02\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x09\x00\x6a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x6a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x02\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x09\x00\x6a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\x02\x00\xff\xff\x64\x00\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x6a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\x6a\x00\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\xbf\x00\xff\xff\xc1\x00\xff\xff\x74\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xbd\x00\xff\xff\xbf\x00\xff\xff\xc1\x00\xff\xff\xff\xff\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\x74\x00\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xbd\x00\x29\x01\xbf\x00\xff\xff\xc1\x00\xff\xff\xff\xff\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xbd\x00\xff\xff\xbf\x00\xff\xff\xc1\x00\xff\xff\xff\xff\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xbd\x00\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xbd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe4\x00\xe5\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xe4\x00\xe5\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xbd\x00\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xbd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xcd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xf2\x00\xf3\x00\xff\xff\xff\xff\xbd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xc5\x00\xc6\x00\xc7\x00\x01\x01\x02\x01\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xbd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xc5\x00\xc6\x00\xc7\x00\x01\x01\x02\x01\xca\x00\xcb\x00\xff\xff\xff\xff\xbd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xf2\x00\xf3\x00\xff\xff\xff\xff\xbd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xc5\x00\xc6\x00\xc7\x00\x01\x01\x02\x01\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xbd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xc5\x00\xc6\x00\xc7\x00\x01\x01\x02\x01\xca\x00\xcb\x00\xff\xff\xff\xff\xbd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xf2\x00\xf3\x00\xff\xff\xff\xff\xbd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xc5\x00\xc6\x00\xc7\x00\x01\x01\x02\x01\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xbd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xc5\x00\xc6\x00\xc7\x00\x01\x01\x02\x01\xca\x00\xcb\x00\xff\xff\xff\xff\xbd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xf2\x00\xf3\x00\xff\xff\xff\xff\xbd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xc5\x00\xc6\x00\xc7\x00\x01\x01\x02\x01\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xbd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xc5\x00\xc6\x00\xc7\x00\x01\x01\x02\x01\xca\x00\xcb\x00\xff\xff\xff\xff\xbd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xf2\x00\xf3\x00\xff\xff\xff\xff\xbd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xc7\x00\x01\x01\x02\x01\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xbd\x00\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xf2\x00\xf3\x00\xff\xff\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\x70\x00\x39\x05\x3a\x05\x3c\x05\x3d\x05\x21\x01\x79\x04\x70\x05\x77\x05\xca\x00\x15\x05\x72\x05\x93\x04\x46\x05\x73\x05\xc8\x04\x15\x02\xc7\x04\x16\x02\x46\x03\x6e\x05\xc8\x04\x15\x02\x34\x05\x16\x02\x3c\x04\x3d\x04\xc8\x04\x15\x02\xe0\x01\x16\x02\x14\x02\x15\x02\x15\x02\x16\x02\xe2\x03\x7d\x04\x7e\x04\xff\x02\x98\x02\x36\x04\x3f\x03\x40\x03\x53\x03\x71\x04\x3d\x04\x12\x02\x3b\x03\x99\x03\x5b\x05\xe8\x00\x8f\x02\x90\x02\x11\x05\x3d\x04\xcb\x00\x12\x02\x67\x03\xeb\x01\xec\x01\xed\x01\x7f\x04\x84\x04\x11\x04\x39\x03\xe1\x01\xe2\x01\xe3\x01\x4b\x04\x4c\x04\x4d\x04\x8f\x02\x90\x02\x3f\x02\xde\x04\x4e\x04\x4f\x04\x75\x04\x5d\x05\x4c\x04\x4d\x04\x12\x02\x31\x00\x84\x02\xbc\x02\x4e\x04\x4f\x04\x04\x01\x7e\x02\x60\x05\x7a\x05\x4c\x04\x4d\x04\xb5\x04\x81\x00\x7f\x02\x6b\x02\x4e\x04\x4f\x04\x0b\x03\xfc\x02\x32\x02\xff\x04\x0a\x01\x49\x01\x00\x01\x40\x02\x4e\x04\x4f\x04\x33\x02\x5c\x05\x03\x05\x4f\x04\xfe\x00\xb6\x04\x32\x00\x00\x05\x01\x05\x02\x05\x03\x05\x4f\x04\x06\x01\x70\x03\x94\x04\x0c\x03\x12\x02\xb1\x01\xa1\x02\x80\x02\x12\x02\x66\x03\xee\x01\x63\x03\x4d\x00\xfe\x02\xa3\x02\x81\x04\x9c\x02\x85\x02\x8c\x00\xeb\x00\xbd\x02\x68\x03\x8f\x00\x4e\x00\xa5\x02\x5c\x05\x92\x00\x12\x04\x13\x02\x94\x00\x95\x00\x96\x00\x97\x00\x4a\x01\xa6\x02\xa7\x02\xa8\x02\x54\x03\x13\x02\x95\x04\x48\x00\x22\x01\x23\x01\x33\x00\x73\x00\x10\x01\x41\x03\x14\x02\x05\x01\x6c\x02\x12\x01\xe4\x01\x85\x02\x61\x05\x86\x02\x12\x01\x11\x00\xee\x01\x71\x03\x4d\x00\x98\x01\x11\x00\x36\x00\x13\x02\x5f\x01\xde\x02\xb8\x02\x41\x03\x3e\x04\x41\x03\x4e\x00\x12\x01\x24\x01\x12\x01\x11\x00\x9e\x00\x9f\x00\x11\x00\x11\x00\x11\x00\x92\x02\x13\x01\x64\x03\x11\x03\xf4\x02\xa0\x00\x72\x00\x3e\x04\x95\x04\x48\x00\x73\x00\x74\x00\x7a\x04\x11\x00\x7a\x04\x16\x05\x3e\x04\xb9\x02\xff\xff\x3a\x02\x91\x02\x68\x05\x11\x00\x4e\x00\x00\x03\x4e\x00\x4e\x00\x13\x02\xe0\x01\xba\x02\x11\x00\x13\x02\xaf\x02\x00\x03\xce\x00\xa1\x00\x94\x03\x0f\x00\xcf\x00\x11\x00\x8a\x03\x99\x02\xf5\x02\x12\x03\x11\x00\x3a\x03\x7c\x00\x7d\x00\x3b\x02\x12\x01\xa2\x00\x71\x00\x72\x00\x9a\x02\x9b\x02\x11\x00\x73\x00\x74\x00\x3a\x03\x75\x00\x1b\x01\x1c\x01\x12\x01\x69\x05\x58\xff\xcb\x03\xe3\x01\xa7\x01\x11\x00\xe4\x01\x50\x02\xcd\x01\x7a\x00\x12\x01\x7b\x00\x76\x00\x36\x02\x0d\x03\x9c\x02\x11\x00\xa8\x01\x0e\x00\x81\x00\x0f\x00\x10\x00\x77\x00\x3b\x05\x78\x00\x79\x00\x7a\x00\x11\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x3e\x05\x17\x02\x50\x04\x3e\x05\x51\x04\x48\x00\x58\xff\x17\x02\x3b\x05\x29\x02\xec\x01\xed\x01\x50\x04\x17\x02\x51\x04\x48\x00\xff\xff\x17\x02\x17\x02\x5e\x01\x52\x04\x0e\x03\x0f\x00\x10\x00\x50\x04\x5f\x01\x51\x04\x48\x00\x29\x01\x11\x00\x52\x04\x8c\x00\x0f\x00\x10\x00\x50\x04\x8f\x00\x51\x04\x48\x00\x50\x04\x11\x00\x51\x04\x48\x00\x52\x04\xff\x03\x0f\x00\x10\x00\x50\x04\x12\x02\x51\x04\x48\x00\x12\x02\x11\x00\x52\x04\x2f\x03\x0f\x00\x10\x00\x52\x04\x12\x02\x0f\x00\x10\x00\x12\x02\x11\x00\xca\x00\x12\x02\x52\x04\x11\x00\x0f\x00\x10\x00\x59\x04\x5a\x04\xe1\x00\xe2\x00\xe3\x00\x11\x00\xe4\x00\xe4\x01\x00\x04\x72\x01\x23\x01\x12\x01\x73\x00\x10\x01\x08\x03\x12\x02\x15\x03\x11\x00\xb0\x02\x72\x00\x1d\x01\x1a\x01\xe5\x00\x73\x00\x74\x00\x0f\x01\x57\x00\x64\x00\x73\x00\x10\x01\xe6\x00\xe7\x00\xce\x03\x33\x00\x36\x00\xe8\x00\x45\x04\x30\x02\x58\x00\x2a\x01\xcb\x00\x2b\x01\x3d\x00\x3e\x00\x46\x04\x3f\x00\x40\x00\x5c\x00\xb1\x02\x13\x01\x0f\x00\x10\x00\x11\x01\x34\x00\x09\x03\x8e\x03\x12\x01\x11\x00\xcf\x03\x7c\x00\x7d\x00\xee\x01\x11\x00\x4d\x00\x28\x01\x13\x01\x05\x01\x02\x02\xe9\x00\xca\x00\x65\x00\x66\x00\xe2\x04\xe0\x04\x4e\x00\x31\x02\xe0\x00\xe1\x00\xe2\x00\xe3\x00\x29\x01\xe4\x00\x13\x02\x41\x00\x06\x01\x13\x02\x4a\x03\xec\x01\xed\x01\xd1\x01\x48\x00\x88\x03\x13\x02\x31\x02\xef\x04\x13\x02\x42\x00\xe5\x00\x13\x02\xe1\x04\x81\x00\xe5\x04\xea\x03\xd2\x01\xc7\x04\xe6\x00\xe7\x00\x8a\x03\x1d\x01\x1a\x01\xe8\x00\x17\x01\x18\x01\x0f\x01\x4e\x00\xcb\x00\x73\x00\x10\x01\x13\x02\xce\x02\xea\x00\x0f\x04\xec\x01\xed\x01\x43\x04\xeb\x00\xb1\x01\x52\x05\x8f\x00\xcf\x02\xec\x00\xff\xff\x92\x00\x5e\x01\xb8\x02\x94\x00\x95\x00\x96\x00\x97\x00\x5f\x01\x11\x01\x98\x00\x99\x00\xe9\x00\x12\x01\x8c\x00\xeb\x03\xbc\x03\x63\x02\x44\x04\x11\x00\x5b\x01\x1d\x03\x13\x01\x11\x00\xbc\x04\x44\x00\x2c\x01\x2d\x03\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\xfd\x01\xb9\x02\x5b\x01\x9b\x04\xec\x01\xed\x01\x1e\x03\x1f\x03\x4b\x00\x4c\x00\x4d\x00\x72\x01\x85\x03\x35\x03\x73\x00\x10\x01\x96\x02\x9e\x00\x9f\x00\x1c\x02\x5f\x01\x4e\x00\x96\x02\x4a\x00\xbd\x04\xbe\x04\x40\x01\xa0\x00\x72\x00\xcd\x02\x14\x02\xea\x00\x73\x00\x74\x00\x5b\x01\x5f\x01\xeb\x00\x2e\x04\xed\x01\x8f\x00\x09\x05\xec\x00\xee\x01\x92\x00\x4d\x00\xfc\x01\x94\x00\x95\x00\x96\x00\x97\x00\x57\x00\x13\x01\x98\x00\x99\x00\xdb\x01\x4e\x00\xce\x00\xa1\x00\x06\x01\x0f\x00\xcf\x00\x01\x04\x58\x00\x88\x02\xdf\x04\xe0\x04\x11\x00\x5f\x01\x7c\x00\x7d\x00\xd1\x02\x5c\x00\xa2\x00\x19\x01\x1a\x01\x03\x03\xca\x00\xee\x01\x0f\x01\x4d\x00\x04\x03\x73\x00\x10\x01\x91\x03\xe1\x00\xe2\x00\xe3\x00\x28\x02\xe4\x00\x4d\x00\x4e\x00\xe1\x04\x9e\x00\x9f\x00\x65\x00\x66\x00\x08\x05\x83\x00\x68\x00\x69\x00\x4e\x00\x84\x00\xa0\x00\x72\x00\xe5\x00\x11\x01\x85\x00\x73\x00\x74\x00\x12\x01\x44\x05\xe0\x04\xe6\x00\xe7\x00\x06\x01\x11\x00\xf2\x01\xe8\x00\x13\x01\x19\x01\x1a\x01\xeb\x01\xcb\x00\xee\x01\x0f\x01\x4d\x00\x2b\x02\x73\x00\x10\x01\x8b\x00\x6a\x05\xce\x00\xa1\x00\x94\xfe\x0f\x00\xcf\x00\x4e\x00\xe1\x04\x6b\x05\x2c\x02\x94\xfe\x11\x00\xb6\x01\x7c\x00\x7d\x00\xb7\x01\x0c\x02\xa2\x00\x64\x04\x72\x00\xe9\x00\x11\x01\x41\x01\x73\x00\x74\x00\x12\x01\xee\x01\x94\xfe\x4d\x00\x0d\x02\x0e\x02\x11\x00\xee\x02\x97\x04\x13\x01\x42\x01\x07\x02\x43\x01\x44\x01\x4e\x00\x03\x02\x72\x01\x28\x05\x64\x00\x73\x00\x10\x01\xea\x01\x67\x00\x77\x00\x04\x02\x78\x00\x79\x00\x7a\x00\x04\x02\x7b\x00\x1a\x05\x18\x05\x7e\x00\x7f\x00\x7c\x00\x7d\x00\x98\x04\x99\x04\xd3\x03\xca\x00\xc7\x02\xd4\x03\x63\x02\x0a\x02\x0b\x02\x60\x01\x72\x00\xea\x00\x11\x00\x61\x01\x73\x00\x74\x00\xeb\x00\x94\xfe\x94\xfe\x8f\x00\x13\x01\xec\x00\x94\xfe\x92\x00\xf9\x01\xfa\x01\x94\x00\x95\x00\x96\x00\x97\x00\x7d\x04\x7e\x04\x98\x00\x99\x00\xd5\x03\xff\xff\xf2\x01\x00\x01\x01\x01\x21\x03\x9d\x01\xfb\x01\x02\x01\x94\xfe\xe8\x00\x94\xfe\xf3\x01\xf4\x01\xf5\x01\xcb\x00\x7c\x00\x7d\x00\x22\x03\x23\x03\x94\xfe\x7f\x04\x80\x04\x36\x00\x27\x02\x9a\x04\x4d\x00\x38\x01\xf0\x02\x81\x00\x2b\x01\x3d\x00\x3e\x00\xc4\x04\x3f\x00\x40\x00\x64\x00\x4e\x00\x9e\x00\x9f\x00\x67\x00\x83\x00\xca\x00\x83\x00\x99\xfd\x84\x00\x04\x02\x84\x00\xa0\x00\x72\x00\x85\x00\x41\x00\x85\x00\x73\x00\x74\x00\x39\x01\x3a\x01\x3b\x01\x94\xfe\x93\x03\x2d\x00\xb4\x01\x5e\x01\x24\x04\x42\x00\x4d\x00\xb5\x01\x2e\x00\x5f\x01\x2f\x00\x94\x03\x9a\x04\x41\x00\x8b\x00\x8c\x00\x8b\x00\x4e\x00\xce\x00\xa1\x00\x8e\x00\x0f\x00\xcf\x00\x64\x00\xe8\x00\xc3\x04\x42\x00\x67\x00\x11\x00\xcb\x00\x7c\x00\x7d\x00\x89\x03\x76\x01\xa2\x00\x77\x01\xa3\x02\x81\x04\x04\x02\xac\x02\x8c\x01\xeb\x00\x8d\x01\x8a\x03\x8f\x00\xc9\x03\xa5\x02\x99\x02\x92\x00\x12\x01\x54\x05\x94\x00\x95\x00\x96\x00\x97\x00\x11\x00\xa6\x02\xa7\x02\xa8\x02\x04\x04\x9b\x02\x4e\x00\x87\x03\xee\x04\xe4\x04\x44\x00\x45\x00\x7b\x01\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x88\x03\xef\x04\xe5\x04\x12\x03\xcd\x01\x7a\x00\x13\x03\x7b\x00\x4b\x00\x4c\x00\x4d\x00\x9c\x02\xc6\x04\x44\x00\x45\x00\x13\x05\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4e\x00\x51\x05\xc7\x04\x9e\x00\x9f\x00\x8a\x03\xff\xff\xca\x00\x4b\x00\x4c\x00\x4d\x00\x38\x02\x52\x05\xa0\x00\x72\x00\xa3\x02\xa4\x02\x39\x02\x73\x00\x74\x00\xeb\x00\x4e\x00\x09\x01\x8f\x00\x34\x04\xa5\x02\x0a\x01\x92\x00\x12\x01\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x11\x00\xa6\x02\xa7\x02\xa8\x02\x35\x02\x78\x01\xbf\x01\x10\x00\xce\x00\xa1\x00\x36\x02\x0f\x00\xcf\x00\x11\x00\xe8\x00\xc0\x01\x7d\x00\x6d\x05\x11\x00\xcb\x00\x7c\x00\x7d\x00\x1d\xfd\x6e\x05\xa2\x00\xe8\x03\x5d\x02\x36\x00\x37\x00\xa2\x02\xfd\x01\x3a\x00\x3b\x00\x09\x01\x3c\x00\x3d\x00\x3e\x00\x0a\x01\x3f\x00\x40\x00\xad\x02\xaa\x02\xab\x02\x9f\x00\xff\xff\x60\x01\x72\x00\x3d\x01\x3e\x03\x77\x03\x73\x00\x74\x00\xa0\x00\x72\x00\x11\x00\xdd\x02\x3c\x01\x73\x00\x74\x00\xde\x02\x2e\x03\x1a\x01\x17\x05\x18\x05\x86\x01\x0f\x01\x87\x01\x21\x01\x73\x00\x10\x01\x5e\x02\x5f\x02\x0f\x00\x60\x02\x42\x02\x76\x01\x41\x00\x77\x01\xff\xff\x11\x00\x11\x00\xce\x00\xa1\x00\x3d\x03\x0f\x00\xcf\x00\x7c\x00\x7d\x00\x78\x02\x42\x00\x79\x02\x11\x00\x11\x01\x7c\x00\x7d\x00\x70\x04\x12\x01\xa2\x00\xca\x00\xa3\x02\xa4\x02\x11\x00\x11\x00\x0e\x01\xeb\x00\x13\x01\x75\x02\x8f\x00\x76\x02\xa5\x02\x62\x02\x92\x00\x63\x02\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x11\x00\xa6\x02\xa7\x02\xa8\x02\x87\x04\xc3\x01\x7f\x00\x36\x00\x21\x03\x53\x02\xc4\x01\x43\x00\xf0\x02\x36\x02\x2b\x01\x3d\x00\x3e\x00\x10\x02\x3f\x00\x40\x00\x86\x00\xe8\x00\x26\x01\x78\x02\x88\x00\x79\x02\xcb\x00\xe8\x01\x88\x04\x8e\x04\x1a\x03\x44\x00\x45\x00\x8a\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x18\x03\xa9\x02\xaa\x02\xab\x02\x9f\x00\x6a\x03\x6b\x03\x3c\x02\x4b\x00\x4c\x00\x4d\x00\x36\x02\xff\x02\xa0\x00\x72\x00\xca\x00\x0e\x01\x41\x00\x73\x00\x74\x00\x0f\x01\x4e\x00\xa9\xfe\x73\x00\x10\x01\x41\x00\xa9\xfe\x86\x00\x0f\x03\x63\x01\x42\x00\x88\x00\x0e\x00\xec\x02\x0f\x00\x10\x00\x47\x00\x48\x00\x42\x00\x87\x04\x8a\x00\x11\x00\xce\x00\xa1\x00\x8d\x00\x0f\x00\xcf\x00\x11\x01\xb1\x01\x09\x01\xf7\x03\x12\x01\x11\x00\x0a\x01\x7c\x00\x7d\x00\xe8\x00\x11\x00\xa2\x00\xf3\x02\x13\x01\xcb\x00\x47\x03\x88\x04\x89\x04\x47\x00\x48\x00\xa3\x02\x8a\x04\x4e\x03\x4f\x03\x70\x01\xeb\x00\x0f\x00\x10\x00\x8f\x00\x2c\x04\xa5\x02\x2d\x04\x92\x00\x11\x00\xeb\x02\x94\x00\x95\x00\x96\x00\x97\x00\xea\x02\xa6\x02\xa7\x02\xa8\x02\x44\x00\x45\x00\xe9\x02\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x44\x00\x45\x00\xe6\x01\x65\x04\x47\x00\x48\x00\x47\x00\x48\x00\x4b\x00\x4c\x00\x4d\x00\x7f\x01\xe8\x02\x80\x01\x42\x02\x81\x01\x4b\x00\x23\x04\x4d\x00\x24\x04\x11\x00\x4e\x00\xc0\x01\x7d\x00\x64\x00\xc5\x02\x10\x00\xef\x02\x67\x00\x4e\x00\x9e\x00\x9f\x00\x11\x00\xbe\x02\xc0\x01\x7d\x00\x76\x01\xc4\x01\x77\x01\x41\x00\xa0\x00\x72\x00\xe7\x02\xa3\x02\x8a\x04\x73\x00\x74\x00\xca\x00\xeb\x00\x6a\x03\x6b\x03\x8f\x00\x42\x00\xa5\x02\x72\x03\x92\x00\x63\x02\xe1\x02\x94\x00\x95\x00\x96\x00\x97\x00\x11\x00\xa6\x02\xa7\x02\xa8\x02\xd9\x02\xda\x02\xdb\x02\xce\x00\xa1\x00\xdf\x02\x0f\x00\xcf\x00\x7d\x04\x7e\x04\x5b\x02\x5c\x02\x5d\x02\x11\x00\x4a\x01\x7c\x00\x7d\x00\xd2\x02\xcd\x04\xa2\x00\x63\x02\xd1\x02\xe8\x00\x36\x00\x0a\x02\x0b\x02\x11\x00\xcb\x00\xf0\x02\xcc\x02\x2b\x01\x3d\x00\x3e\x00\x1e\x05\x3f\x00\x40\x00\x25\x05\x26\x05\x9e\x00\x9f\x00\xf7\x02\xf8\x02\xf9\x02\xfa\x02\xfb\x02\x52\x02\x44\x00\x45\x00\xa0\x00\x72\x00\x47\x00\x48\x00\xca\x02\x73\x00\x74\x00\xca\x00\x5e\x02\x5f\x02\x0f\x00\x60\x02\x08\xfd\x57\x00\x4b\x00\x51\x02\x4d\x00\x11\x00\xc2\x01\x98\x01\x7a\x00\xdd\x01\x7b\x00\xc5\x02\x41\x00\x58\x00\xc4\x02\x4e\x00\x81\x00\xce\x00\xa1\x00\x87\x04\x0f\x00\xcf\x00\x5c\x00\xc1\x02\x9e\x02\x42\x00\xc2\x02\x11\x00\x83\x00\x7c\x00\x7d\x00\xc0\x02\x84\x00\xa2\x00\x98\x02\xaf\x02\xe8\x00\x85\x00\x25\x05\x4c\x05\x5f\x01\xcb\x00\x04\x03\x26\x05\x05\x03\x65\x00\x66\x00\xa3\x02\x81\x04\x68\x00\x69\x00\xe1\x03\xeb\x00\xe2\x03\x70\x02\x8f\x00\x9f\x02\xa5\x02\xb3\x02\x92\x00\x8b\x00\x8c\x00\x94\x00\x95\x00\x96\x00\x97\x00\xe0\x01\xa6\x02\xa7\x02\xa8\x02\x86\x00\x08\xfe\x63\x01\x08\xfe\x88\x00\x08\xfe\x7b\x01\x7c\x01\x45\x00\x6f\x02\x5a\x02\x47\x00\x48\x00\x8a\x00\x08\xfe\x44\x00\x45\x00\x8d\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x7d\x01\x95\x02\x4d\x00\xfb\x03\xf4\x03\xf5\x03\x94\x02\xaf\x01\x4b\x00\x4c\x00\x4d\x00\x8f\x02\xe5\x04\x4e\x00\x8d\x02\x9e\x00\x9f\x00\x2c\x02\x7a\x00\xca\x00\x7b\x00\x4e\x00\x0a\x02\x0b\x02\x41\x00\xa0\x00\x72\x00\x84\x02\xa3\x02\x8a\x04\x73\x00\x74\x00\x6a\x01\xeb\x00\x0f\x00\x10\x00\x8f\x00\x42\x00\xa5\x02\x81\x02\x92\x00\x11\x00\x7d\x02\x94\x00\x95\x00\x96\x00\x97\x00\x7a\x02\xa6\x02\xa7\x02\xa8\x02\x5b\x03\x5c\x03\x5d\x03\xce\x00\xa1\x00\x7c\x02\x0f\x00\xcf\x00\x25\x02\xe8\x00\x18\x04\x19\x04\x1a\x04\x11\x00\xcb\x00\x7c\x00\x7d\x00\x6a\x03\x6b\x03\xa2\x00\x78\x03\x7c\x01\x45\x00\x36\x00\xfa\x04\x47\x00\x48\x00\xc7\x01\xe6\x04\xc8\x01\x2b\x01\x3d\x00\x3e\x00\xc9\x01\x3f\x00\x40\x00\x02\x02\x00\x02\x9e\x00\x9f\x00\x73\x02\xc1\x04\xca\x00\xc2\x04\x72\x02\x41\x00\x44\x00\x45\x00\xa0\x00\x72\x00\x47\x00\x48\x00\x71\x02\x73\x00\x74\x00\xff\x01\x00\x02\xcc\x01\x42\x00\x73\x01\xab\x01\x12\x01\x4b\x00\x91\x04\x4d\x00\x92\x04\x74\x04\x11\x00\x75\x04\x7c\x00\x7d\x00\x60\x04\x41\x00\x61\x04\xf5\x04\x4e\x00\xf6\x04\xce\x00\xa1\x00\x70\x02\x0f\x00\xcf\x00\xb1\x01\xe8\x00\x81\x00\x42\x00\x70\x04\x11\x00\xcb\x00\x7c\x00\x7d\x00\x73\x01\x74\x01\xa2\x00\xa3\x02\xa4\x02\x83\x00\x6f\x02\xf9\x04\xeb\x00\x84\x00\x60\x04\x8f\x00\x61\x04\xa5\x02\x85\x00\x92\x00\x23\x02\x3e\x02\x94\x00\x95\x00\x96\x00\x97\x00\x67\x02\xa6\x02\xa7\x02\xa8\x02\x55\x02\x44\x00\x45\x00\x71\x01\x6c\x01\x47\x00\x48\x00\x47\x01\x4f\x03\x50\x03\x51\x03\x8b\x00\x8c\x00\x35\x01\x36\x01\x8e\x00\x8f\x00\x4b\x00\xd6\x01\x4d\x00\xd7\x01\xf3\x03\xf4\x03\xf5\x03\x67\x02\xaf\x01\xaf\x01\x41\x00\x44\x00\x45\x00\x4e\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x1e\x01\x1f\x01\x9e\x00\x9f\x00\x42\x00\x52\x02\xca\x00\x54\x02\x4b\x00\x4c\x00\x4d\x00\x42\x02\xa0\x00\x72\x00\x3d\x02\xa3\x02\xa4\x02\x73\x00\x74\x00\x51\x02\xeb\x00\x4e\x00\x4f\x02\x8f\x00\xca\x00\xa5\x02\x34\x02\x92\x00\x6e\x01\x6c\x01\x94\x00\x95\x00\x96\x00\x97\x00\x41\x02\xa6\x02\xa7\x02\xa8\x02\x13\x04\x14\x04\x15\x04\xce\x00\xa1\x00\x2f\x02\x0f\x00\xcf\x00\xba\x02\xe8\x00\x0f\x00\x10\x00\x81\x00\x11\x00\xcb\x00\x7c\x00\x7d\x00\x11\x00\x23\x02\xa2\x00\xc6\x01\xc2\x01\x98\x01\x7a\x00\x83\x00\x7b\x00\x44\x00\x45\x00\x84\x00\x2e\x02\x47\x00\x48\x00\xcb\x00\x85\x00\xb5\x02\x10\x02\x0f\x00\x10\x00\x9e\x00\x9f\x00\x6b\x01\x6c\x01\x4b\x00\x11\x00\x4d\x00\x5e\x01\x73\x03\x74\x03\xa0\x00\x72\x00\x26\x03\x5f\x01\x81\x00\x73\x00\x74\x00\x4e\x00\x8b\x00\x8c\x00\x96\x02\x4a\x00\x8e\x00\x8f\x00\x73\x01\x1e\x04\x83\x00\xa1\x04\x19\x04\x1a\x04\x84\x00\x22\x05\x92\x04\x19\x04\x1a\x04\x85\x00\xd6\x04\x19\x04\x1a\x04\xce\x00\xa1\x00\xfe\x00\x0f\x00\xcf\x00\x78\x05\x19\x04\x1a\x04\x5e\x01\x02\x02\x11\x00\xd6\x03\x7c\x00\x7d\x00\x5f\x01\xd0\x03\xa2\x00\xa3\x02\x07\x04\x8b\x00\x8c\x00\xc4\x03\xeb\x00\x8e\x00\x8f\x00\x8f\x00\xcd\x03\xa5\x02\xc3\x03\x92\x00\x08\x04\x09\x04\x94\x00\x95\x00\x96\x00\x97\x00\xea\xfc\xa6\x02\xa7\x02\xa8\x02\xcc\x00\xbe\x04\xba\x04\x8f\x00\x07\xfd\xcd\x00\xf1\xfc\x92\x00\xb9\x04\xba\x04\x94\x00\x95\x00\x96\x00\x97\x00\x36\x00\xf2\xfc\x98\x00\x99\x00\x1f\x02\xf0\x02\x06\xfd\x2b\x01\x3d\x00\x3e\x00\xeb\xfc\x3f\x00\x40\x00\xec\xfc\xc2\x01\x98\x01\x7a\x00\x40\x02\x7b\x00\x85\x04\x5d\x03\xc3\x01\x7f\x00\xc2\x03\x9e\x00\x9f\x00\xc4\x01\x32\x01\x33\x01\x34\x01\x35\x01\x58\x05\x59\x05\x1d\x05\xa0\x00\x72\x00\x7d\x05\x19\x04\x1a\x04\x73\x00\x74\x00\x41\x00\x9e\x00\x9f\x00\x2c\x02\x7a\x00\xc1\x03\x7b\x00\xc0\x03\x41\x00\xbf\x03\xbe\x02\xa0\x00\x72\x00\x42\x00\xc4\x01\xbe\x03\x73\x00\x74\x00\xd7\x04\x15\x04\x18\xfd\x42\x00\xce\x00\xa1\x00\xbb\x03\x0f\x00\xcf\x00\xb9\x03\xba\x03\x5f\x01\x3a\x02\x37\x02\x11\x00\x90\x03\x7c\x00\x7d\x00\x85\x03\x84\x03\xa2\x00\x8f\x03\xce\x00\xa1\x00\x83\x03\x0f\x00\xcf\x00\x81\x03\x80\x03\x82\x03\x7f\x03\x7a\x03\x11\x00\x5f\x05\x7c\x00\x7d\x00\x36\x00\x7e\x03\xa2\x00\x77\x03\x7d\x03\xf0\x02\x76\x03\x2b\x01\x3d\x00\x3e\x00\x5b\x01\x3f\x00\x40\x00\x1c\xfd\x60\x03\x5b\x03\x59\x03\x58\x03\x56\x03\x44\x00\x45\x00\x4c\x03\x8a\x00\x47\x00\x48\x00\x2b\x03\x2a\x03\x44\x00\x45\x00\x29\x03\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x21\x01\x4d\x00\x26\x03\x81\x00\x3d\x01\x32\x03\xfe\x00\x4b\x00\x4c\x00\x4d\x00\x04\x04\x59\x04\x4e\x00\x41\x00\x4b\x04\x83\x00\x47\x04\x4a\x04\x48\x04\x84\x00\x4e\x00\x3c\x04\x3a\x04\x36\x00\x85\x00\x42\x04\x42\x00\x39\x04\xf0\x02\x34\x04\x2b\x01\x3d\x00\x3e\x00\x81\x00\x3f\x00\x40\x00\x38\x04\x36\x04\x12\xfd\x11\xfd\x13\xfd\x32\x04\x21\x04\x47\x01\x27\x04\x83\x00\x66\x03\x8b\x00\x8c\x00\x84\x00\x1e\x04\x8e\x00\x8f\x00\x1c\x04\x85\x00\x17\x04\x36\x00\x0f\x04\x11\x04\x3a\x02\x3e\x01\x3f\x01\x0d\x04\x3c\x00\x3d\x00\x3e\x00\x6a\x00\x3f\x00\x40\x00\x3f\x02\xf8\x03\x8e\x02\x41\x00\x47\x01\xd3\x02\xf0\x03\xdf\x03\x8b\x00\x8c\x00\x04\x04\xfa\x03\x8e\x00\x8f\x00\xf2\x03\xe7\x03\x42\x00\x44\x00\x45\x00\xe6\x03\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\xdc\x03\x62\x04\xde\x03\xdd\x03\xb9\x04\xb8\x04\xb7\x04\x66\x03\x4b\x00\x4c\x00\x4d\x00\x41\x00\x6f\x02\x83\x00\xb1\x01\x6b\x03\xaf\x04\x84\x00\x5d\x04\x8b\x03\xa8\x04\x4e\x00\x85\x00\xa7\x04\x42\x00\xa6\x04\x1e\x04\x1c\x04\xa5\x04\xa1\x04\x1c\x04\x7d\x04\x36\x00\x73\x04\x78\x04\x6a\x04\x3e\x01\x3f\x01\x6e\x04\x3c\x00\x3d\x00\x3e\x00\x6f\x04\x3f\x00\x40\x00\x8b\x00\x63\x04\x6b\x04\x69\x04\x8e\x00\x64\x04\x44\x00\x45\x00\x04\x04\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x5d\x04\x29\x03\x08\x05\x07\x05\x4e\x05\x06\x05\xfd\x04\x36\x00\x4b\x00\x4c\x00\x4d\x00\x6c\x03\x6d\x03\xf8\x04\x3c\x00\x3d\x00\x3e\x00\xf7\x04\x3f\x00\x40\x00\xf1\x04\x4e\x00\x41\x00\xec\x04\x3b\x01\x44\x00\x45\x00\xda\x04\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x1c\x04\xd9\x04\x42\x00\x81\x00\x79\x01\x8f\xfe\x17\x04\xd0\x04\x4b\x00\x4c\x00\x4d\x00\x0e\x01\x38\x05\x36\x05\x31\x05\x83\x00\x2d\x05\x30\x05\x2c\x05\x84\x00\x2a\x05\x4e\x00\x36\x00\x41\x00\x85\x00\x28\x05\x6c\x03\x6d\x03\x4a\x01\x3c\x00\x3d\x00\x3e\x00\x10\x05\x3f\x00\x40\x00\x0d\x05\x42\x00\x0e\x05\x0b\x05\x56\x05\x57\x05\x50\x05\x5b\x03\x47\x01\x46\x05\x26\x03\x6c\x05\x8b\x00\x8c\x00\x67\x05\x7c\x05\x8e\x00\x8f\x00\x64\x05\x26\x03\x5f\x05\x1e\x04\x1c\x04\x77\x05\x81\x05\x1c\x04\xfe\x00\x44\x00\x45\x00\x82\x05\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x7d\x05\x41\x00\xfc\x00\x84\x05\xc1\x01\x84\x01\x79\x01\xa9\x01\x4b\x00\x4c\x00\x4d\x00\x36\x00\xf7\x01\x06\x02\x42\x00\xd4\x04\xd5\x04\x47\x01\x3c\x00\x3d\x00\x3e\x00\x4e\x00\x3f\x00\x40\x00\x05\x02\x26\x01\x44\x00\x45\x00\x8d\x01\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x8a\x01\x30\x01\x0c\x01\x1c\x03\x1a\x03\x0b\x01\x18\x03\x1b\x03\x4b\x00\x4c\x00\x4d\x00\x36\x00\x37\x00\xd3\x01\x39\x00\x3a\x00\x3b\x00\x07\x01\x3c\x00\x3d\x00\x3e\x00\x4e\x00\x3f\x00\x40\x00\x0f\x03\x09\x03\x41\x00\xd4\x01\xd5\x01\xf7\x01\xfb\x02\xf5\x02\xb6\x02\xdf\x02\xd2\x02\x88\x02\xc2\x02\x76\x02\x0b\x02\x42\x00\x44\x00\x45\x00\x73\x02\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x6d\x02\x08\x02\x10\x02\xda\x03\xd9\x03\xd7\x03\xd8\x03\x21\x03\x4b\x00\x4c\x00\x4d\x00\xd6\x03\x41\x00\xd1\x03\x5e\x03\x36\x00\x37\x00\x43\x02\x39\x00\x3a\x00\x3b\x00\x4e\x00\x3c\x00\x3d\x00\x3e\x00\x42\x00\x3f\x00\x40\x00\xbc\x03\x94\x03\x56\x03\x6b\x02\x90\x03\x8c\x03\x36\x00\x37\x00\xd9\x01\x39\x00\x3a\x00\x3b\x00\x8b\x03\x3c\x00\x3d\x00\x3e\x00\x59\x03\x3f\x00\x40\x00\x54\x03\x35\x03\x4c\x03\x33\x03\x44\x00\x45\x00\x30\x03\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x3d\x03\x81\x00\x46\x01\xaa\xfe\x32\x03\x41\x00\x43\x00\xaa\xfe\x4b\x00\x4c\x00\x4d\x00\x2b\x03\x27\x03\x83\x00\x26\x03\x24\x03\x5b\x04\x84\x00\x42\x00\x48\x04\x30\x04\x4e\x00\x85\x00\x3a\x04\x41\x00\x2d\x04\x44\x00\x45\x00\x2a\x04\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x21\x04\x1f\x04\x1c\x04\x42\x00\x02\x04\xfa\x03\xdf\x03\x47\x01\x4b\x00\x4c\x00\x4d\x00\x8b\x00\x8c\x00\xf2\x03\xc2\x04\x8e\x00\x8f\x00\xbf\x04\xb3\x04\xb1\x04\x6b\x02\x4e\x00\xa2\x04\x86\x04\x43\x00\x9a\x04\x7b\x04\x6b\x04\x6c\x04\x67\x04\xd6\x01\x66\x04\xd7\x01\x5e\x04\x5d\x04\xfe\x04\xf3\x04\xf2\x04\xef\x04\xf1\x04\xdd\x04\xec\x04\xcc\x04\x43\x00\x44\x00\x45\x00\xea\x04\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\xcb\x04\x38\x05\xca\x04\x36\x05\x33\x05\x1c\x05\x23\x05\x2a\x05\x4b\x00\x4c\x00\x4d\x00\x44\x00\x45\x00\x32\x05\x46\x00\x47\x00\x48\x00\xda\x01\x4a\x00\x2c\x02\x7a\x00\x4e\x00\x7b\x00\x0e\x05\x13\x05\xc3\x01\x7f\x00\x4b\x00\x4c\x00\x4d\x00\xc4\x01\x4d\x05\x4a\x05\x40\x05\x36\x00\x37\x00\xd9\x01\x39\x00\x3a\x00\x3b\x00\x4e\x00\x3c\x00\x3d\x00\x3e\x00\x57\x05\x3f\x00\x40\x00\x7b\x03\x67\x01\xdb\x01\x68\x01\x3f\x05\x0b\x05\x53\x05\x0f\x01\x52\x05\x65\x05\x73\x00\x10\x01\x79\x05\xda\x04\xe4\x02\x75\x05\x71\x05\x36\x00\x37\x00\x6f\x05\xe5\x02\x3a\x00\x3b\x00\x7f\x05\x3c\x00\x3d\x00\x3e\x00\x7e\x05\x3f\x00\x40\x00\x82\x05\xdb\x04\x00\x00\x00\x00\x11\x01\x00\x00\x41\x00\x00\x00\x12\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x00\x00\x13\x01\x00\x00\x42\x00\x00\x00\x00\x00\xda\x04\xe4\x02\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\xe5\x02\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x41\x00\x3f\x00\x40\x00\x00\x00\x43\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\xe3\x02\xe4\x02\x00\x00\x00\x00\x36\x00\x37\x00\x43\x00\xe5\x02\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\xda\x01\x4a\x00\x00\x00\x42\x00\x43\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x62\x05\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x4e\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\xdb\x01\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x43\x00\xb3\x02\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\xa0\x02\x3a\x00\x3b\x00\x4e\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\xeb\x02\x00\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x43\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\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\x44\x00\x45\x00\x41\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x4b\x00\x4c\x00\x4d\x00\x48\x03\xe4\x02\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\xe5\x02\x3a\x00\x3b\x00\x4e\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\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\xb3\x02\x00\x00\x00\x00\x36\x00\x37\x00\x43\x00\xa0\x02\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\xb4\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x00\x00\x42\x00\x00\x00\x81\x00\x46\x01\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x83\x00\x00\x00\x00\x00\x41\x00\x84\x00\x4e\x00\x00\x00\xb3\x02\x00\x00\x85\x00\x36\x00\x37\x00\x00\x00\xa0\x02\x3a\x00\x3b\x00\x42\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x29\x04\x00\x00\x00\x00\x43\x00\x00\x00\x47\x01\x00\x00\x00\x00\x00\x00\x8b\x00\x8c\x00\x00\x00\x00\x00\x8e\x00\x8f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x00\x00\x43\x00\x00\x00\x00\x00\x41\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x4e\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x4b\x00\x4c\x00\x4d\x00\x9c\x04\x00\x00\x00\x00\x9d\x04\x9e\x04\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x4e\x00\x00\x00\x0a\x04\x00\x00\x0d\x04\x36\x00\x37\x00\x43\x00\xa0\x02\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x9f\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x4e\x00\x00\x00\x0a\x04\x00\x00\x0b\x04\x36\x00\x37\x00\x00\x00\xa0\x02\x3a\x00\x3b\x00\x42\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x00\x00\x0a\x04\x00\x00\xd3\x04\x36\x00\x37\x00\x00\x00\xa0\x02\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\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\x43\x00\x44\x00\x45\x00\x41\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x4b\x00\x4c\x00\x4d\x00\x44\x00\x45\x00\x41\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x4b\x00\x4c\x00\x4d\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\x9f\x02\x00\x00\x00\x00\x36\x00\x37\x00\x43\x00\xd4\x02\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x41\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x9f\x02\x00\x00\x00\x00\x36\x00\x37\x00\x4e\x00\xa0\x02\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x00\x00\x3c\x03\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\xa0\x02\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x43\x00\xc7\x01\x00\x00\xc8\x01\x00\x00\x00\x00\x00\x00\xc9\x01\x00\x00\x00\x00\xca\x01\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\xcb\x01\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x42\x00\x00\x00\x00\x00\xcc\x01\x00\x00\x00\x00\x41\x00\x12\x01\x4b\x00\x4c\x00\x4d\x00\xcd\x01\x7a\x00\x11\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x42\x00\x00\x00\x4e\x00\x05\x04\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\xa0\x02\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x43\x00\x76\x04\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\xa0\x02\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x43\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x41\x01\x4b\x00\x4c\x00\x4d\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x42\x00\x42\x01\x4e\x00\x43\x01\x44\x01\x00\x00\x41\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x77\x00\x00\x00\x78\x00\x79\x00\x7a\x00\x42\x00\x7b\x00\x4e\x00\xf8\x04\x7e\x00\x7f\x00\x36\x00\x37\x00\x00\x00\xa0\x02\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x43\x00\x4c\x05\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\xa0\x02\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x43\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x42\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x8e\x01\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x42\x00\x00\x00\x4e\x00\x64\x05\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\xa0\x02\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x43\x00\x8f\x01\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x42\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x36\x00\x37\x00\x4b\x02\x39\x00\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\xe2\x02\x4d\x02\x00\x00\x43\x00\x36\x00\x37\x00\x4b\x02\x39\x00\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x4c\x02\x4d\x02\x00\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x41\x00\x00\x00\x00\x00\x36\x00\x37\x00\x4b\x02\x39\x00\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x42\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x00\x00\xc8\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\x43\x00\x36\x00\x37\x00\x4b\x02\x39\x00\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x00\x00\xc7\x03\x41\x00\x43\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x00\x00\x4e\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x81\x00\x21\x05\x4e\x00\x00\x00\x00\x00\x43\x00\x36\x00\x37\x00\xc5\x03\x39\x00\x3a\x00\x3b\x00\x83\x00\x3c\x00\x3d\x00\x3e\x00\x84\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x85\x00\x00\x00\xc6\x03\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x00\x00\x00\x00\x47\x01\x4b\x00\x4c\x00\x4d\x00\x8b\x00\x8c\x00\x00\x00\x00\x00\x8e\x00\x8f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x41\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x36\x00\x37\x00\x4b\x02\x39\x00\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x4e\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x00\x00\xc4\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\x43\x00\x00\x00\x36\x00\x37\x00\x4b\x02\x39\x00\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x41\x00\xe7\x03\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\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\x41\x00\x00\x00\x00\x00\x36\x00\x37\x00\x32\x04\x39\x00\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x42\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x00\x00\x43\x00\x00\x00\x00\x00\x00\x00\x46\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x01\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\xcf\x02\x00\x00\x43\x01\x44\x01\x00\x00\x41\x00\x43\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x77\x00\x00\x00\x78\x00\x79\x00\x7a\x00\x42\x00\x7b\x00\x00\x00\x4e\x00\x7e\x00\x7f\x00\x00\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\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\x43\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x41\x01\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x42\x01\x00\x00\x43\x01\x44\x01\x00\x00\x00\x00\x00\x00\x47\x05\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x77\x00\x00\x00\x78\x00\x79\x00\x7a\x00\x00\x00\x7b\x00\x4e\x00\x41\x00\x7e\x00\x7f\x00\x36\x00\x37\x00\xde\x01\x39\x00\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x42\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x87\x01\x39\x00\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x63\x01\x64\x01\x65\x01\x66\x01\x67\x01\x00\x00\x68\x01\x41\x00\x43\x00\x00\x00\x0f\x01\x00\x00\x00\x00\x73\x00\x10\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x11\x01\x00\x00\x42\x00\x00\x00\x12\x01\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x11\x00\x00\x00\x00\x00\x13\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x43\x00\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\x1c\x02\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x00\x00\x43\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x1d\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x41\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x36\x00\x37\x00\x49\x03\x39\x00\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x32\x04\x39\x00\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x43\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\x1c\x02\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x43\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\x1c\x02\x3a\x00\x3b\x00\x2f\x04\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x43\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x28\x04\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x42\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\x1c\x02\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x43\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\x1c\x02\x3a\x00\x3b\x00\x27\x04\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x43\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x17\x04\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x42\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\x1c\x02\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x43\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\x1c\x02\x3a\x00\x3b\x00\xe4\x03\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x43\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\xe3\x03\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x42\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x14\x05\x39\x00\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x43\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\x1c\x02\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x43\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x49\x05\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x42\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\x59\x02\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x43\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\x26\x02\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x43\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x42\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\x21\x02\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x43\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\x20\x02\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x43\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x42\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\x1e\x02\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x43\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\xd0\x03\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x43\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x42\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\xca\x03\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x43\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\x10\x05\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x43\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x42\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x36\x00\x00\x00\x00\x00\x00\x00\x00\x00\xee\x02\x00\x00\x2b\x01\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x43\x00\x00\x00\x00\x00\x00\x00\x36\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe1\x02\x00\x00\x2b\x01\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x43\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x42\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x36\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x03\x00\x00\x2b\x01\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x04\x00\x00\x2b\x01\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x42\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x36\x00\x00\x00\x00\x00\x00\x00\x00\x00\x78\x04\x00\x00\x2b\x01\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x00\x00\x00\x00\x00\x00\x00\x00\x21\x05\x00\x00\x2b\x01\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x42\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x36\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x05\x00\x00\x2b\x01\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x05\x00\x00\x2b\x01\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x42\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x36\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2d\x05\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfe\x01\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x2e\x05\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x42\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x13\x00\x41\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x15\x00\x36\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x18\x00\x19\x00\x24\x02\x3e\x00\x00\x00\x3f\x00\x40\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x42\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x7a\x03\x65\x01\x66\x01\x67\x01\x00\x00\x68\x01\x00\x00\x00\x00\x4e\x00\x0f\x01\x00\x00\x00\x00\x73\x00\x10\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\x02\x1a\x02\x75\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1b\x02\x00\x00\x00\x00\x00\x00\x11\x01\x00\x00\x00\x00\x00\x00\x12\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x44\x00\x45\x00\x13\x01\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\x00\x00\x00\x00\x4e\x00\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf9\xfc\xf9\xfc\x00\x00\x00\x00\xf9\xfc\xf9\xfc\xf9\xfc\x00\x00\xf9\xfc\xf9\xfc\x00\x00\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\x00\x00\xf9\xfc\xf9\xfc\xf9\xfc\x00\x00\x00\x00\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf9\xfc\xf9\xfc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\x00\x00\x00\x00\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\x00\x00\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\x00\x00\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xed\xfd\xed\xfd\xed\xfd\xed\xfd\x00\x00\x00\x00\x00\x00\xed\xfd\xed\xfd\xed\xfd\xed\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xed\xfd\xed\xfd\x00\x00\x00\x00\xed\xfd\xed\xfd\xed\xfd\x00\x00\xed\xfd\xed\xfd\x00\x00\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\x00\x00\xed\xfd\xed\xfd\xed\xfd\x00\x00\x00\x00\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xed\xfd\xed\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\x00\x00\x00\x00\xed\xfd\xed\xfd\xed\xfd\xed\xfd\x00\x00\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\x00\x00\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\x00\x00\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xdb\xfd\xdb\xfd\x13\x00\xdb\xfd\x00\x00\x00\x00\x00\x00\xdb\xfd\xdb\xfd\x14\x00\xdb\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\xfd\xdb\xfd\x00\x00\x00\x00\xdb\xfd\x15\x00\xdb\xfd\x00\x00\xdb\xfd\xdb\xfd\x00\x00\x17\x00\x18\x00\x19\x00\x52\x00\x53\x00\x54\x00\xdb\xfd\xdb\xfd\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xdb\xfd\x00\x00\x24\x00\xdb\xfd\xdb\xfd\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\xfd\xdb\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\x00\x00\x00\x00\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\x00\x00\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\x00\x00\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\x00\x00\xdb\xfd\x7f\x01\xdb\xfd\x80\x01\xdb\xfd\x81\x01\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\x63\x00\x64\x00\xdb\xfd\xdb\xfd\xdb\xfd\x67\x00\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\x8e\xfe\x50\x00\x13\x00\x8e\xfe\x00\x00\x00\x00\x00\x00\x8e\xfe\x8e\xfe\x14\x00\x8e\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8e\xfe\x8e\xfe\x00\x00\x00\x00\x8e\xfe\x15\x00\x8e\xfe\x00\x00\x8e\xfe\x8e\xfe\x00\x00\x17\x00\x18\x00\x19\x00\x52\x00\x53\x00\x54\x00\x8e\xfe\x8e\xfe\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x8e\xfe\x00\x00\x24\x00\x8e\xfe\x8e\xfe\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8e\xfe\x8e\xfe\x57\x00\x8e\xfe\x8e\xfe\x8e\xfe\x00\x00\x00\x00\x8e\xfe\x8e\xfe\x8e\xfe\x8e\xfe\x00\x00\x8e\xfe\x58\x00\x59\x00\x5a\x00\x8e\xfe\x5b\x00\x8e\xfe\x8e\xfe\x8e\xfe\x8e\xfe\x5c\x00\x00\x00\x00\x00\xf7\x01\x8e\xfe\x5d\x00\x8e\xfe\x00\x00\x8e\xfe\x5e\x00\x8e\xfe\x5f\x00\x8e\xfe\x60\x00\x8e\xfe\x8e\xfe\x8e\xfe\x8e\xfe\x8e\xfe\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x8e\xfe\x67\x00\x68\x00\x69\x00\x8e\xfe\x8e\xfe\x8e\xfe\x8e\xfe\x6b\x00\x6c\x00\x6d\x00\x8e\xfe\x8e\xfe\x8e\xfe\x8e\xfe\x8e\xfe\x8e\xfe\x8e\xfe\x8e\xfe\x8e\xfe\x8e\xfe\x8e\xfe\x8e\xfe\x8e\xfe\x8e\xfe\x6e\x00\x8e\xfe\x8e\xfe\x6f\x00\x70\x00\x8e\xfe\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x00\x00\x00\x00\x00\x00\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\xfd\x43\xfd\x00\x00\x00\x00\x43\xfd\x43\xfd\x43\xfd\x00\x00\x43\xfd\x43\xfd\x00\x00\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x00\x00\x43\xfd\x43\xfd\x43\xfd\x00\x00\x00\x00\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\xfd\x43\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x00\x00\x00\x00\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x00\x00\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x00\x00\x00\x00\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x00\x00\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x00\x00\x00\x00\x00\x00\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\xfe\x80\xfe\x00\x00\x00\x00\x80\xfe\x80\xfe\x80\xfe\x00\x00\x80\xfe\x80\xfe\x00\x00\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x00\x00\x80\xfe\x80\xfe\x80\xfe\x00\x00\x00\x00\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\xfe\x80\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x00\x00\x00\x00\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x00\x00\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x00\x00\x00\x00\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x00\x00\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x00\x00\x00\x00\x00\x00\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x94\xfe\x94\xfe\x00\x00\x00\x00\x94\xfe\x94\xfe\x94\xfe\x00\x00\x94\xfe\x94\xfe\x00\x00\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x00\x00\x94\xfe\x94\xfe\x94\xfe\x00\x00\x00\x00\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x00\x00\x00\x00\x94\xfe\x94\xfe\xf9\x01\xfa\x01\x00\x00\x95\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x00\x00\x00\x00\x94\xfe\xfb\x01\x00\x00\x94\xfe\x00\x00\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x11\xfe\x11\xfe\x11\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\xfe\x00\x00\x00\x00\x11\xfe\x11\xfe\x11\xfe\x00\x00\x11\xfe\x11\xfe\x00\x00\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x00\x00\x11\xfe\x11\xfe\x11\xfe\x00\x00\x00\x00\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\xfe\x11\xfe\x81\x00\xbb\x01\x11\xfe\x11\xfe\x00\x00\x00\x00\x11\xfe\x11\xfe\x11\xfe\x00\x00\x00\x00\x00\x00\x83\x00\x11\xfe\x11\xfe\x11\xfe\x84\x00\xbc\x01\xbd\x01\xbe\x01\xbf\x01\x85\x00\x00\x00\x00\x00\x11\xfe\x00\x00\x00\x00\x11\xfe\x00\x00\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x47\x01\x11\xfe\x11\xfe\x11\xfe\x8b\x00\x8c\x00\x11\xfe\x11\xfe\x8e\x00\x8f\x00\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x0a\xfe\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\xfe\x14\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\x00\x00\x00\x00\x00\x0a\xfe\x15\x00\x0a\xfe\x00\x00\x0a\xfe\x16\x00\x00\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\xa9\x00\x00\x00\x24\x00\x0a\xfe\x0a\xfe\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\xfe\x0a\xfe\x0a\xfe\x0a\xfe\x0a\xfe\xad\x00\x00\x00\x00\x00\x0a\xfe\x0a\xfe\x0a\xfe\x00\x00\x00\x00\x00\x00\x0a\xfe\xaf\x00\xb0\x00\xb1\x00\x0a\xfe\x0a\xfe\x0a\xfe\x0a\xfe\x0a\xfe\x0a\xfe\x00\x00\x00\x00\xb9\x01\x00\x00\x00\x00\x0a\xfe\x00\x00\x0a\xfe\xb2\x00\x0a\xfe\xb3\x00\x0a\xfe\xb4\x00\x0a\xfe\xb5\x00\x0a\xfe\x0a\xfe\x0a\xfe\x0a\xfe\xb6\x00\x2c\x00\x8a\x00\x0a\xfe\x0a\xfe\x2d\x00\x8d\x00\x0a\xfe\x0a\xfe\xb7\x00\xb8\x00\x6a\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\x0a\xfe\xc8\x00\x0a\xfe\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\x0a\xfe\x0b\xfe\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\xfe\x14\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\x00\x00\x00\x00\x00\x0b\xfe\x15\x00\x0b\xfe\x00\x00\x0b\xfe\x16\x00\x00\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\xa9\x00\x00\x00\x24\x00\x0b\xfe\x0b\xfe\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\xfe\x0b\xfe\x0b\xfe\x0b\xfe\x0b\xfe\xad\x00\x00\x00\x00\x00\x0b\xfe\x0b\xfe\x0b\xfe\x00\x00\x00\x00\x00\x00\x0b\xfe\xaf\x00\xb0\x00\xb1\x00\x0b\xfe\x0b\xfe\x0b\xfe\x0b\xfe\x0b\xfe\x0b\xfe\x00\x00\x00\x00\xb9\x01\x00\x00\x00\x00\x0b\xfe\x00\x00\x0b\xfe\xb2\x00\x0b\xfe\xb3\x00\x0b\xfe\xb4\x00\x0b\xfe\xb5\x00\x0b\xfe\x0b\xfe\x0b\xfe\x0b\xfe\xb6\x00\x2c\x00\x8a\x00\x0b\xfe\x0b\xfe\x2d\x00\x8d\x00\x0b\xfe\x0b\xfe\xb7\x00\xb8\x00\x6a\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\x0b\xfe\xc8\x00\x0b\xfe\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\x0b\xfe\x12\x02\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\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\xa9\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xab\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\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\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\x00\x00\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\x02\xb2\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\xac\x03\x00\x00\x00\x00\xb6\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\xb7\x00\xb8\x00\x6a\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\x12\x02\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\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\xa9\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x96\xfd\x00\x00\x96\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\xb0\x00\xb1\x00\x00\x00\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\x02\xb2\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\xb4\x03\x00\x00\x00\x00\xb6\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\xb7\x00\xb8\x00\x6a\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\x80\xfe\x80\xfe\x80\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x00\x00\x00\x00\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x00\x00\x00\x00\x80\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\xfe\x80\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\xfe\x80\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x5b\xfe\x00\x00\x80\xfe\x80\xfe\x00\x00\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x00\x00\x80\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x80\xfe\x00\x00\x00\x00\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x00\x00\x80\xfe\x80\xfe\x00\x00\x80\xfe\x00\x00\x80\xfe\x00\x00\x00\x00\x00\x00\x80\xfe\x00\x00\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x00\x00\x80\xfe\x80\xfe\x80\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x80\xfe\x80\xfe\x80\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x13\x00\xa6\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\x80\xfe\x14\x00\xa7\x00\x80\xfe\x80\xfe\xd1\x00\xd2\x00\xd3\x00\xf2\x00\xd4\x00\x00\x00\xf3\x00\x00\x00\x15\x00\x00\x00\xf4\x00\x00\x00\x16\x00\xf5\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\xa9\x00\x00\x00\x24\x00\x00\x00\x00\x00\xf6\x00\xab\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\x00\x00\xf7\x00\xda\x00\xf8\x00\xf9\x00\x00\x00\x00\x00\xfa\x00\xdb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdc\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\x00\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\x00\x00\x00\x00\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\xdd\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\xb7\x00\xb8\x00\x6a\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xf9\xfc\xf9\xfc\xf9\xfc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf9\xfc\xf9\xfc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf9\xfc\x00\x00\x00\x00\x00\x00\xf9\xfc\x00\x00\x00\x00\x00\x00\xf9\xfc\x00\x00\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\x00\x00\xf9\xfc\xad\x04\xae\x04\x00\x00\x00\x00\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf9\xfc\xf9\xfc\x00\x00\xf9\xfc\x00\x00\x00\x00\xf9\xfc\x00\x00\x00\x00\x00\x00\xf9\xfc\x00\x00\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\x00\x00\xf9\xfc\xf9\xfc\x00\x00\xf9\xfc\x00\x00\x00\x00\x00\x00\xf9\xfc\xf9\xfc\xf9\xfc\x00\x00\xf9\xfc\x00\x00\xf9\xfc\x00\x00\x00\x00\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\x00\x00\xf9\xfc\x00\x00\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xa5\x00\x13\x00\xa6\x00\x00\x00\x8c\x04\x8d\x04\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\xd1\x00\xd2\x00\xd3\x00\x00\x00\xd4\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x8e\x04\x00\x00\x16\x00\x00\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\xa9\x00\x00\x00\x24\x00\x00\x00\x00\x00\xf6\x00\xab\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\x00\x00\x00\x00\xda\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdc\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\x00\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\x00\x00\x00\x00\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\xdd\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\xb7\x00\xb8\x00\x6a\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xa5\x00\x13\x00\xa6\x00\x00\x00\x83\x04\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\xd1\x00\xd2\x00\xd3\x00\x00\x00\xd4\x00\x00\x00\xf3\x00\x00\x00\x15\x00\x00\x00\x84\x04\x00\x00\x16\x00\x00\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\xa9\x00\x00\x00\x24\x00\x00\x00\x00\x00\xf6\x00\xab\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\x00\x00\x00\x00\xda\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdc\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\x00\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\x00\x00\x00\x00\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\xdd\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\xb7\x00\xb8\x00\x6a\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xa5\x00\x13\x00\xa6\x00\x00\x00\x8c\x04\x8d\x04\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\xd1\x00\xd2\x00\xd3\x00\x00\x00\xd4\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x8e\x04\x00\x00\x16\x00\x00\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\xa9\x00\x00\x00\x24\x00\x00\x00\x00\x00\xf6\x00\xab\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\x00\x00\x00\x00\xda\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdc\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\x00\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\x00\x00\x00\x00\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\xdd\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\xb7\x00\xb8\x00\x6a\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xa5\x00\x13\x00\xa6\x00\x00\x00\x83\x04\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\xd1\x00\xd2\x00\xd3\x00\x00\x00\xd4\x00\x00\x00\xf3\x00\x00\x00\x15\x00\x00\x00\x84\x04\x00\x00\x16\x00\x00\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\xa9\x00\x00\x00\x24\x00\x00\x00\x00\x00\xf6\x00\xab\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\x00\x00\x00\x00\xda\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdc\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\x00\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\x00\x00\x00\x00\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\xdd\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\xb7\x00\xb8\x00\x6a\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\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\xa9\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xab\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\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\x81\x00\x00\x00\x00\x00\xad\x00\x00\x00\x00\x00\x5b\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x01\xaf\x00\xb0\x00\xb1\x00\x84\x00\x00\x00\x00\x00\x00\x00\x00\x00\x85\x00\x5d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\xb3\x00\x5e\x01\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x5f\x01\x60\x01\xb6\x00\x2c\x00\x8a\x00\x8b\x00\x8c\x00\x2d\x00\x8d\x00\x8e\x00\x8f\x00\xb7\x00\xb8\x00\x6a\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xe1\xfd\xe1\xfd\xe1\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe1\xfd\xe1\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe1\xfd\x00\x00\x00\x00\x00\x00\xe1\xfd\x00\x00\x00\x00\x00\x00\xe1\xfd\x00\x00\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\x00\x00\xe1\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\x00\x00\x00\x00\xe1\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xe1\xfd\x00\x00\xe1\xfd\xe1\xfd\x00\x00\xe1\xfd\x00\x00\x00\x00\x00\x00\xe1\xfd\x00\x00\xe1\xfd\x00\x00\xe1\xfd\x00\x00\xe1\xfd\x00\x00\x00\x00\x00\x00\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\x00\x00\xe1\xfd\x00\x00\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\xe0\xfd\xe0\xfd\xe0\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xfd\xe0\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xfd\x00\x00\x00\x00\x00\x00\xe0\xfd\x00\x00\x00\x00\x00\x00\xe0\xfd\x00\x00\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\x00\x00\xe0\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\xfd\xe0\xfd\xe0\xfd\xe0\xfd\x00\x00\x00\x00\xe0\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xfd\x00\x00\xe0\xfd\xe0\xfd\x00\x00\xe0\xfd\x00\x00\x00\x00\x00\x00\xe0\xfd\x00\x00\xe0\xfd\x00\x00\xe0\xfd\x00\x00\xe0\xfd\x00\x00\x00\x00\x00\x00\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\x00\x00\xe0\xfd\x00\x00\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xed\xfd\xed\xfd\xed\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xed\xfd\xed\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xed\xfd\x00\x00\x00\x00\x00\x00\xed\xfd\x00\x00\x00\x00\x00\x00\xed\xfd\x00\x00\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\x00\x00\xed\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\xfd\xed\xfd\x8b\x03\xed\xfd\x00\x00\x00\x00\xed\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xed\xfd\x00\x00\xed\xfd\xed\xfd\x00\x00\xed\xfd\x00\x00\x00\x00\x00\x00\xed\xfd\x00\x00\xed\xfd\x00\x00\xed\xfd\x00\x00\xed\xfd\x00\x00\x00\x00\x00\x00\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\x00\x00\xed\xfd\x00\x00\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\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\xa9\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xab\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\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\x81\x00\x00\x00\x00\x00\xad\x00\x00\x00\x00\x00\x5b\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\x84\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\xb2\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x98\x01\xb5\x00\x00\x00\x00\x00\x5f\x01\x60\x01\xb6\x00\x2c\x00\x8a\x00\x8b\x00\x8c\x00\x2d\x00\x8d\x00\x8e\x00\x8f\x00\xb7\x00\xb8\x00\x6a\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\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\xa9\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xab\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\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\x81\x00\x00\x00\x00\x00\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\x84\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\xb2\x00\x00\x00\xb3\x00\xbb\xfd\xb4\x00\xbb\xfd\xb5\x00\x00\x00\x00\x00\x36\x02\x60\x01\xb6\x00\x2c\x00\x8a\x00\x8b\x00\x8c\x00\x2d\x00\x8d\x00\x8e\x00\x8f\x00\xb7\x00\xb8\x00\x6a\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\xd1\x00\xd2\x00\xd3\x00\x00\x00\xd4\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\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\xa9\x00\x00\x00\x24\x00\x00\x00\x00\x00\xd5\x00\xab\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\x00\x00\x00\x00\xda\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdc\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\x00\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\x00\x00\x00\x00\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\xdd\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\xb7\x00\xb8\x00\x6a\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\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\xa9\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xab\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\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\x81\x00\x00\x00\x00\x00\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\x84\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\xb2\x00\x00\x00\xb3\x00\x50\x02\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x36\x02\x60\x01\xb6\x00\x2c\x00\x8a\x00\x8b\x00\x8c\x00\x2d\x00\x8d\x00\x8e\x00\x8f\x00\xb7\x00\xb8\x00\x6a\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\xd1\x00\xd2\x00\xd3\x00\x00\x00\xd4\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\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\xa9\x00\x00\x00\x24\x00\x00\x00\x00\x00\xf6\x00\xab\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\x00\x00\x00\x00\xda\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdc\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\x00\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\x00\x00\x00\x00\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\xdd\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\xb7\x00\xb8\x00\x6a\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\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\xa9\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xab\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\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\x81\x00\x00\x00\x00\x00\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\x84\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\xb2\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x53\x02\xb5\x00\x00\x00\x00\x00\x36\x02\x60\x01\xb6\x00\x2c\x00\x8a\x00\x8b\x00\x8c\x00\x2d\x00\x8d\x00\x8e\x00\x8f\x00\xb7\x00\xb8\x00\x6a\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\xd1\x00\xd2\x00\xd3\x00\x00\x00\xd4\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\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\xa9\x00\x00\x00\x24\x00\x00\x00\x00\x00\xf6\x00\xab\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\x00\x00\x00\x00\xda\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdc\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\x00\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\x00\x00\x00\x00\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\xdd\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\xb7\x00\xb8\x00\x6a\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\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\xa9\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xab\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\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\x81\x00\x00\x00\x00\x00\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\x84\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\xb2\x00\x9d\x01\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x60\x01\xb6\x00\x2c\x00\x8a\x00\x8b\x00\x8c\x00\x2d\x00\x8d\x00\x8e\x00\x8f\x00\xb7\x00\xb8\x00\x6a\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\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\xa9\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xab\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\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\x81\x00\x00\x00\x00\x00\xad\x00\x00\x00\x00\x00\x3a\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\x84\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\xb2\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x60\x01\xb6\x00\x2c\x00\x8a\x00\x8b\x00\x8c\x00\x2d\x00\x8d\x00\x8e\x00\x8f\x00\xb7\x00\xb8\x00\x6a\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\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\xa9\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xab\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\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\x81\x00\x00\x00\x00\x00\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\x84\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\xb2\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x60\x01\xb6\x00\x2c\x00\x8a\x00\x8b\x00\x8c\x00\x2d\x00\x8d\x00\x8e\x00\x8f\x00\xb7\x00\xb8\x00\x6a\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\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\xa9\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xab\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\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\xad\x00\x00\x00\x00\x00\xb1\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x01\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\xb7\x00\xb8\x00\x6a\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\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\xa9\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xab\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\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\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x03\x00\x00\x00\x00\xb2\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\xac\x03\x00\x00\x00\x00\xb6\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\xb7\x00\xb8\x00\x6a\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\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\xa9\x00\xaa\x00\x24\x00\x00\x00\x00\x00\x00\x00\xab\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\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\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\x00\x00\x00\x00\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\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\xb7\x00\xb8\x00\x6a\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x15\x00\xa2\x03\x00\x00\x00\x00\x16\x00\x00\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\xa9\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xab\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\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\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\x00\x00\x00\x00\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\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\xb7\x00\xb8\x00\x6a\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\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\xa9\x00\xaa\x00\x24\x00\x00\x00\x00\x00\x00\x00\xab\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\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\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\x00\x00\x00\x00\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\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\xb7\x00\xb8\x00\x6a\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\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\xa9\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xab\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\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\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\x00\x00\x00\x00\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\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\xac\x03\x00\x00\x00\x00\xb6\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\xb7\x00\xb8\x00\x6a\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x15\x00\xa2\x03\x00\x00\x00\x00\x16\x00\x00\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\xa9\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xab\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\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\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\x00\x00\x00\x00\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\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\xb7\x00\xb8\x00\x6a\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\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\xa9\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xab\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\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\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\x00\x00\x00\x00\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\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\xb7\x00\xb8\x00\x6a\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\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\xa9\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xab\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\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\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\x00\x00\x00\x00\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\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\xb7\x00\xb8\x00\x6a\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\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\xa9\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xab\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\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\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\x00\x00\x00\x00\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\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\xb7\x00\xb8\x00\x6a\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\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\xa9\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xab\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\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\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\x00\x00\x00\x00\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\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\xb7\x00\xb8\x00\x6a\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\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\xa9\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xab\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\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\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\x00\x00\x00\x00\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\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\xb7\x00\xb8\x00\x6a\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\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\xa9\x00\x00\x00\xfe\x03\x00\x00\x00\x00\x00\x00\xab\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\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\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\x00\x00\x00\x00\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\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\xb7\x00\xb8\x00\x6a\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\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\xa9\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xab\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\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\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\x00\x00\x00\x00\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\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\xb7\x00\xb8\x00\x6a\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\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\xa9\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xab\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\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\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\x00\x00\x00\x00\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\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\xb7\x00\xb8\x00\x6a\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\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\xa9\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xab\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\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\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\x00\x00\x00\x00\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\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\xb7\x00\xb8\x00\x6a\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\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\xa9\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\xbd\x02\x65\x01\x66\x01\x67\x01\x00\x00\x68\x01\x00\x00\x00\x00\x00\x00\x0f\x01\x00\x00\x00\x00\x73\x00\x10\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xad\x00\xa5\x01\xa6\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\xb0\x00\xb1\x00\x11\x01\x00\x00\x00\x00\x00\x00\x12\x01\x00\x00\x00\x00\x00\x00\x2c\x02\x7a\x00\x11\x00\x7b\x00\x00\x00\x13\x01\xb2\x00\xbe\x02\xb3\x00\x00\x00\xb4\x00\xc4\x01\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\xb7\x00\xb8\x00\x6a\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\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\xa9\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xab\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\x00\x00\x00\x00\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\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\xb7\x00\xb8\x00\x6a\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xd7\xfe\xd7\xfe\xd7\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd7\xfe\xd7\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd7\xfe\x00\x00\x00\x00\x00\x00\xd7\xfe\x00\x00\x00\x00\x00\x00\xd7\xfe\x00\x00\xd7\xfe\xd7\xfe\xd7\xfe\xd7\xfe\xd7\xfe\xd7\xfe\xd7\xfe\xd7\xfe\xd7\xfe\xd7\xfe\xd7\xfe\xd7\xfe\xd7\xfe\xd7\xfe\x00\x00\xd7\xfe\x00\x00\x00\x00\x00\x00\xd7\xfe\xd7\xfe\xd7\xfe\xd7\xfe\xd7\xfe\xd7\xfe\xd7\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd7\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd7\xfe\xd7\xfe\xd7\xfe\xd7\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x03\x00\x00\xd7\xfe\x00\x00\xd7\xfe\x00\x00\xd7\xfe\x00\x00\x00\x00\x00\x00\x00\x00\xd7\xfe\xd7\xfe\xd7\xfe\x00\x00\x00\x00\xd7\xfe\xd7\xfe\x00\x00\x00\x00\xd7\xfe\xd7\xfe\xd7\xfe\xd7\xfe\xd7\xfe\xd7\xfe\xd7\xfe\xd7\xfe\xd7\xfe\xd7\xfe\xd7\xfe\xd7\xfe\xd7\xfe\xd7\xfe\xd7\xfe\xd7\xfe\xd7\xfe\xd7\xfe\x00\x00\xd7\xfe\x00\x00\xd7\xfe\xd7\xfe\xd7\xfe\xd7\xfe\xd7\xfe\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\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\xa9\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xab\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\x00\x00\x00\x00\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\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\xb7\x00\xb8\x00\x6a\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\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\xa9\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x13\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x18\x00\x19\x00\x00\x00\x00\x00\x00\x00\xad\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\xaf\x00\xb0\x00\xb1\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x03\x00\x00\x00\x00\xb2\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\xb4\x03\x00\x00\x00\x00\xb6\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\xb7\x00\xb8\x00\x6a\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xce\xfe\xce\xfe\xce\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xce\xfe\xce\xfe\x19\x02\x1a\x02\x00\x00\x00\x00\x00\x00\x00\x00\xce\xfe\x00\x00\x00\x00\x00\x00\xce\xfe\x00\x00\x00\x00\x1b\x02\x37\x03\x00\x00\xce\xfe\xce\xfe\xce\xfe\xce\xfe\xce\xfe\xce\xfe\xce\xfe\xce\xfe\xce\xfe\xce\xfe\xce\xfe\xce\xfe\xce\xfe\xce\xfe\x00\x00\xce\xfe\x00\x00\x00\x00\x00\x00\xce\xfe\xce\xfe\xce\xfe\xce\xfe\xce\xfe\xce\xfe\xce\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xce\xfe\xce\xfe\xce\xfe\xce\xfe\x00\x00\x00\x00\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\xfe\x00\x00\xce\xfe\x00\x00\xce\xfe\x00\x00\xce\xfe\x00\x00\x00\x00\x00\x00\x00\x00\xce\xfe\xce\xfe\xce\xfe\x00\x00\x00\x00\xce\xfe\xce\xfe\x00\x00\x00\x00\xce\xfe\xce\xfe\xce\xfe\xce\xfe\xce\xfe\xce\xfe\xce\xfe\xce\xfe\xce\xfe\xce\xfe\xce\xfe\xce\xfe\xce\xfe\xce\xfe\xce\xfe\xce\xfe\xce\xfe\xce\xfe\x00\x00\xce\xfe\x00\x00\xce\xfe\xce\xfe\xce\xfe\xce\xfe\xce\xfe\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\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\xa9\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xab\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\x00\x00\x00\x00\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\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\xb7\x00\xb8\x00\x6a\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\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\xa9\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x96\xfd\x00\x00\x96\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\xb0\x00\xb1\x00\x00\x00\x00\x00\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\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\xb7\x00\xb8\x00\x6a\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xcf\xfe\xcf\xfe\xcf\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcf\xfe\xcf\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcf\xfe\x00\x00\x00\x00\x00\x00\xcf\xfe\x00\x00\x00\x00\x00\x00\xfc\x04\x00\x00\xcf\xfe\xcf\xfe\xcf\xfe\xcf\xfe\xcf\xfe\xcf\xfe\xcf\xfe\xcf\xfe\xcf\xfe\xcf\xfe\xcf\xfe\xcf\xfe\xcf\xfe\xcf\xfe\x00\x00\xcf\xfe\x00\x00\x00\x00\x00\x00\xcf\xfe\xcf\xfe\xcf\xfe\xcf\xfe\xcf\xfe\xcf\xfe\xcf\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcf\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcf\xfe\xcf\xfe\xcf\xfe\xcf\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcf\xfe\x00\x00\xcf\xfe\x00\x00\xcf\xfe\x00\x00\xcf\xfe\x00\x00\x00\x00\x00\x00\x00\x00\xcf\xfe\xcf\xfe\xcf\xfe\x00\x00\x00\x00\xcf\xfe\xcf\xfe\x00\x00\x00\x00\xcf\xfe\xcf\xfe\xcf\xfe\xcf\xfe\xcf\xfe\xcf\xfe\xcf\xfe\xcf\xfe\xcf\xfe\xcf\xfe\xcf\xfe\xcf\xfe\xcf\xfe\xcf\xfe\xcf\xfe\xcf\xfe\xcf\xfe\xcf\xfe\x00\x00\xcf\xfe\x00\x00\xcf\xfe\xcf\xfe\xcf\xfe\xcf\xfe\xcf\xfe\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\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\xa9\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xab\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\x00\x00\x00\x00\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\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\xb7\x00\xb8\x00\x6a\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\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\xa9\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xab\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\xaf\x00\xb0\x00\xb1\x00\x00\x00\x00\x00\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\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\xb7\x00\xb8\x00\x6a\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\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\xa9\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x13\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x18\x00\x19\x00\x00\x00\x00\x00\x00\x00\xad\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\xaf\x00\xb0\x00\xb1\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\xca\x04\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x98\x03\x00\x00\x00\x00\x00\x00\xb6\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\xb7\x00\xb8\x00\x6a\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x19\x02\x1a\x02\x00\x00\x00\x00\x00\x00\x00\x00\xd4\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x1b\x02\x16\x00\x00\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\xa9\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x13\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x18\x00\x19\x00\x00\x00\x00\x00\x00\x00\xad\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\xaf\x00\xb0\x00\xb1\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\xb4\x03\x00\x00\x00\x00\xb6\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\xb7\x00\xb8\x00\x6a\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x19\x02\x1a\x02\x00\x00\x00\x00\x00\x00\x00\x00\xd4\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x1b\x02\x16\x00\x00\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\xa9\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x13\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x18\x00\x19\x00\x52\x00\x53\x00\x54\x00\xad\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\xaf\x00\xb0\x00\xb1\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\xb7\x00\xb8\x00\x6a\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\x43\xfd\x43\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\xfd\x00\x00\x63\x00\x64\x00\x00\x00\x00\x00\x00\x00\x67\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x00\x00\x00\x00\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x00\x00\x00\x00\x43\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\xfd\x43\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\xfd\x43\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\xfd\x43\xfd\x00\x00\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x00\x00\x43\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x43\xfd\x00\x00\x00\x00\x43\xfd\x43\xfd\x43\xfd\x00\x00\x00\x00\x00\x00\x43\xfd\x00\x00\x43\xfd\x37\x02\x43\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x00\x00\x43\xfd\x43\xfd\x43\xfd\x80\xfe\x80\xfe\x00\x00\x00\x00\x43\xfd\x43\xfd\x43\xfd\x00\x00\x80\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\xfe\x43\xfd\x00\x00\x00\x00\x43\xfd\x43\xfd\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x00\x00\x00\x00\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x00\x00\x00\x00\x80\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\xfe\x80\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\xfe\xd0\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\xfe\x80\xfe\x00\x00\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x00\x00\x80\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x80\xfe\x00\x00\x00\x00\x80\xfe\x80\xfe\x80\xfe\x00\x00\x00\x00\x00\x00\x80\xfe\x00\x00\x80\xfe\x80\xfe\x80\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x00\x00\x80\xfe\x80\xfe\x80\xfe\x00\x00\x00\x00\xa5\x00\x13\x00\x80\xfe\x80\xfe\x80\xfe\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\xfe\x15\x00\x00\x00\x80\xfe\x80\xfe\x16\x00\x00\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\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\xc7\x02\x13\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\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\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\x50\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x51\x00\x00\x00\x17\x00\x18\x00\x19\x00\x52\x00\x53\x00\x54\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\xdd\x01\x00\x00\x00\x00\x00\x00\x58\x00\x59\x00\x5a\x00\x00\x00\x5b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x5f\x00\xde\x01\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5f\x01\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x00\x00\x67\x00\x68\x00\x69\x00\x00\x00\x00\x00\x6a\x00\x00\x00\x6b\x00\x6c\x00\x6d\x00\x50\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x00\x00\x6f\x00\x70\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x51\x00\x00\x00\x17\x00\x18\x00\x19\x00\x52\x00\x53\x00\x54\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x59\x00\x5a\x00\x00\x00\x5b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x5f\x00\x00\x00\x60\x00\xd9\x01\x00\x00\x00\x00\x00\x00\x5f\x01\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x00\x00\x67\x00\x68\x00\x69\x00\x00\x00\x00\x00\x6a\x00\x00\x00\x6b\x00\x6c\x00\x6d\x00\x50\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x00\x00\x6f\x00\x70\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x51\x00\x00\x00\x17\x00\x18\x00\x19\x00\x52\x00\x53\x00\x54\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\xdd\x01\x00\x00\x00\x00\x00\x00\x58\x00\x59\x00\x5a\x00\x00\x00\x5b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x5f\x00\xde\x01\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5f\x01\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x00\x00\x67\x00\x68\x00\x69\x00\x00\x00\x00\x00\x6a\x00\x00\x00\x6b\x00\x6c\x00\x6d\x00\x50\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x00\x00\x6f\x00\x70\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x51\x00\x00\x00\x17\x00\x18\x00\x19\x00\x52\x00\x53\x00\x54\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x45\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x46\x02\x59\x00\x5a\x00\x00\x00\x47\x02\x00\x00\x00\x00\x00\x00\x00\x00\x48\x02\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x5f\x00\x5e\x01\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5f\x01\x61\x00\x62\x00\x63\x00\x64\x00\x49\x02\x4a\x02\x00\x00\x67\x00\x68\x00\x4b\x02\x00\x00\x00\x00\x6a\x00\x00\x00\x6b\x00\x6c\x00\x6d\x00\x50\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x00\x00\x6f\x00\x70\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x51\x00\x00\x00\x17\x00\x18\x00\x19\x00\x52\x00\x53\x00\x54\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x58\x00\x59\x00\x5a\x00\x00\x00\x5b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x5e\x00\xe0\x01\x5f\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x00\x00\x67\x00\x68\x00\x69\x00\x50\x00\x13\x00\x6a\x00\x00\x00\x6b\x00\x6c\x00\x6d\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x01\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x6e\x00\x00\x00\x00\x00\x6f\x00\x70\x00\x17\x00\x18\x00\x19\x00\x52\x00\x53\x00\x54\x00\x2f\x01\x30\x01\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x58\x00\x59\x00\x5a\x00\x00\x00\x5b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x00\x00\x67\x00\x68\x00\x69\x00\x00\x00\x00\x00\x50\x00\x13\x00\x6b\x00\x6c\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe8\x04\x00\x00\x00\x00\x00\x00\x6e\x00\x15\x00\x00\x00\x6f\x00\x70\x00\xf2\x02\x00\x00\x17\x00\x18\x00\x19\x00\x52\x00\x53\x00\x54\x00\xe9\x04\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x58\x00\x59\x00\x5a\x00\x00\x00\x5b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x00\x00\x67\x00\x68\x00\x69\x00\x00\x00\x00\x00\x50\x00\x13\x00\x6b\x00\x6c\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x15\x00\x00\x00\x6f\x00\x70\x00\x51\x00\x00\x00\x17\x00\x18\x00\x19\x00\x52\x00\x53\x00\x54\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x58\x00\x59\x00\x5a\x00\x00\x00\x5b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x5f\x00\xdd\x04\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x00\x00\x67\x00\x68\x00\x69\x00\x00\x00\x00\x00\x6a\x00\x00\x00\x6b\x00\x6c\x00\x6d\x00\x50\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x00\x00\x6f\x00\x70\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x51\x00\x00\x00\x17\x00\x18\x00\x19\x00\x52\x00\x53\x00\x54\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x58\x00\x59\x00\x5a\x00\x00\x00\x5b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x00\x00\x67\x00\x68\x00\x69\x00\x00\x00\x00\x00\x6a\x00\x00\x00\x6b\x00\x6c\x00\x6d\x00\x50\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x00\x00\x6f\x00\x70\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\xf2\x02\x00\x00\x17\x00\x18\x00\x19\x00\x52\x00\x53\x00\x54\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x05\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x59\x00\x5a\x00\x00\x00\x5b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x00\x00\x67\x00\x68\x00\x69\x00\x00\x00\x00\x00\x50\x00\x13\x00\x6b\x00\x6c\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x15\x00\x00\x00\x6f\x00\x70\x00\xf2\x02\x00\x00\x17\x00\x18\x00\x19\x00\x52\x00\x53\x00\x54\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x05\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x59\x00\x5a\x00\x00\x00\x5b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x00\x00\x67\x00\x68\x00\x69\x00\x00\x00\x00\x00\x50\x00\x13\x00\x6b\x00\x6c\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x15\x00\x00\x00\x6f\x00\x70\x00\x51\x00\x00\x00\x17\x00\x18\x00\x19\x00\x52\x00\x53\x00\x54\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x58\x00\x59\x00\x5a\x00\x00\x00\x5b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x00\x00\x67\x00\x68\x00\x69\x00\x00\x00\x00\x00\x6a\x00\x00\x00\x6b\x00\x6c\x00\x6d\x00\x50\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x00\x00\x6f\x00\x70\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x51\x00\x00\x00\x17\x00\x18\x00\x19\x00\x52\x00\x53\x00\x54\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x58\x00\x59\x00\x5a\x00\x00\x00\x5b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x49\x05\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x00\x00\x67\x00\x68\x00\x69\x00\x00\x00\x00\x00\x6a\x00\x00\x00\x6b\x00\x6c\x00\x6d\x00\x50\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x00\x00\x6f\x00\x70\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x51\x00\x00\x00\x17\x00\x18\x00\x19\x00\x52\x00\x53\x00\x54\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x58\x00\x59\x00\x5a\x00\x00\x00\x5b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x00\x00\x67\x00\x68\x00\x69\x00\x00\x00\x00\x00\x6a\x00\x00\x00\x6b\x00\x6c\x00\x6d\x00\x50\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x00\x00\x6f\x00\x70\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\xf2\x02\x00\x00\x17\x00\x18\x00\x19\x00\x52\x00\x53\x00\x54\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x58\x00\x59\x00\x5a\x00\x00\x00\x5b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x00\x00\x67\x00\x68\x00\x69\x00\x00\x00\x00\x00\x50\x00\x13\x00\x6b\x00\x6c\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x15\x00\x00\x00\x6f\x00\x70\x00\x6f\x03\x00\x00\x17\x00\x18\x00\x19\x00\x52\x00\x53\x00\x54\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x58\x00\x59\x00\x5a\x00\x00\x00\x5b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x00\x00\x67\x00\x68\x00\x69\x00\x00\x00\x00\x00\x50\x00\x13\x00\x6b\x00\x6c\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x15\x00\x00\x00\x6f\x00\x70\x00\xf2\x02\x00\x00\x17\x00\x18\x00\x19\x00\x52\x00\x53\x00\x54\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x58\x00\x59\x00\x5a\x00\x00\x00\x5b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x00\x00\x67\x00\x68\x00\x69\x00\x00\x00\x00\x00\x50\x00\x13\x00\x6b\x00\x6c\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x15\x00\x00\x00\x6f\x00\x70\x00\x6f\x03\x00\x00\x17\x00\x18\x00\x19\x00\x52\x00\x53\x00\x54\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x58\x00\x59\x00\x5a\x00\x00\x00\x5b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x00\x00\x67\x00\x68\x00\x69\x00\x00\x00\x00\x00\x50\x00\x13\x00\x6b\x00\x6c\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x15\x00\x00\x00\x6f\x00\x70\x00\xf2\x02\x00\x00\x17\x00\x18\x00\x19\x00\x52\x00\x53\x00\x54\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x58\x00\x59\x00\x5a\x00\x00\x00\x5b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x00\x00\x67\x00\x68\x00\x69\x00\x50\x00\x13\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x6d\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x6e\x00\x00\x00\x00\x00\x6f\x00\x70\x00\x17\x00\x18\x00\x19\x00\x52\x00\x53\x00\x54\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x58\x00\x59\x00\x5a\x00\x00\x00\x5b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x00\x00\x67\x00\x68\x00\x69\x00\x50\x00\x13\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x6d\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x6e\x00\x00\x00\x00\x00\x6f\x00\x70\x00\x17\x00\x18\x00\x19\x00\x52\x00\x53\x00\x54\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x13\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\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\x00\x00\x00\x00\x24\x00\x59\x00\x5a\x00\x00\x00\x5b\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe8\x01\x63\x00\x64\x00\x00\x00\x00\x00\x00\x00\x67\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x00\x00\x6f\x00\x70\x00\xe6\x01\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x2c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x46\x03\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x43\x03\x44\x03\x45\x03\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x13\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\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\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8f\x00\xdd\x00\x91\x00\x00\x00\x92\x00\xe6\x01\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x2c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x46\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x03\xa6\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe6\x01\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x00\x00\x46\x03\x00\x00\x8f\x00\xdd\x00\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\xa7\x03\xa5\x03\xa6\x03\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\xa8\x03\x00\x00\xa9\x03\x00\x00\xaa\x03\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x00\x00\x00\x00\x8f\x00\xdd\x00\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\xa5\x03\xa6\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\xac\x03\x00\x00\xa9\x03\x00\x00\xaa\x03\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x00\x00\x00\x00\x8f\x00\xdd\x00\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\xa5\x03\xa6\x03\x11\xfe\x81\x00\xbb\x01\x00\x00\x00\x00\xa3\x00\x00\x00\x11\xfe\xf8\x03\x11\xfe\xa9\x03\x00\x00\xaa\x03\x83\x00\x00\x00\x9e\x00\x9f\x00\x84\x00\xbc\x01\xbd\x01\xbe\x01\xbf\x01\x85\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x11\xfe\x8f\x00\x73\x00\x74\x00\x11\xfe\x00\x00\x11\xfe\x00\x00\x11\xfe\xa1\x01\x96\x00\x97\x00\x11\xfe\x47\x01\x98\x00\x99\x00\x00\x00\x8b\x00\x8c\x00\x00\x00\x00\x00\x8e\x00\x8f\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\xa2\x01\xae\x03\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\xaf\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x8f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x01\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\xaf\x03\xa2\x01\xae\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb0\x03\x00\x00\xb1\x03\x00\x00\xb2\x03\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x01\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\xa2\x01\xae\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8f\x00\xb4\x03\x00\x00\xb1\x03\x00\x00\xb2\x03\x9e\x00\x9f\x00\xa1\x01\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\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\xa2\x01\xae\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\xf0\x03\x00\x00\xb1\x03\x00\x00\xb2\x03\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\x14\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x15\x00\x7c\x00\x7d\x00\x00\x00\x16\x00\xa2\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\xb2\x04\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x82\x00\x00\x00\x00\x00\x00\x00\x83\x00\x00\x00\x00\x00\x00\x00\x84\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\x86\x00\x13\x00\x87\x00\x00\x00\x88\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x89\x00\x00\x00\x2c\x00\x8a\x00\x8b\x00\x8c\x00\x2d\x00\x8d\x00\x8e\x00\x8f\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\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\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x83\x00\x00\x00\x00\x00\x00\x00\x84\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\xcf\x01\x00\x00\xd0\x01\x00\x00\x88\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\xd1\x01\x00\x00\x2c\x00\x8a\x00\x8b\x00\x8c\x00\x14\x00\x8d\x00\x00\x00\x8f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x04\x00\x00\x00\x00\x15\x00\x00\x00\x55\x04\x00\x00\x16\x00\x00\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\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x56\x04\x13\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x04\x00\x00\x00\x00\x15\x00\x00\x00\x55\x04\x00\x00\x16\x00\x00\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\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x56\x04\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x04\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x04\x14\x00\x00\x00\x2c\x00\x64\x00\x00\x00\x00\x00\x2d\x00\x67\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\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\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x57\x04\x1c\xfe\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x1c\xfe\x00\x00\x2c\x00\x64\x00\x00\x00\x00\x00\x2d\x00\x67\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\xfe\x00\x00\x00\x00\x00\x00\x1c\xfe\x00\x00\x1c\xfe\x1c\xfe\x1c\xfe\x1c\xfe\x1c\xfe\x1c\xfe\x1c\xfe\x1c\xfe\x1c\xfe\x1c\xfe\x1c\xfe\x1c\xfe\x1c\xfe\x00\x00\x00\x00\x1c\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x1c\xfe\x1c\xfe\x1c\xfe\x1c\xfe\x1c\xfe\x1c\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x86\x00\x00\x00\x91\x01\x00\x00\x88\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\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\x00\x00\x00\x00\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\x6e\x01\x00\x00\x1c\xfe\x14\x00\x1c\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\xfe\x1c\xfe\x00\x00\x15\x00\x1c\xfe\x1c\xfe\x00\x00\x16\x00\x00\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\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x55\x04\x00\x00\x16\x00\x00\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\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x86\x00\x00\x00\x91\x01\x00\x00\x88\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x14\x00\x00\x00\x05\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\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\x00\x00\x00\x00\x24\x00\x00\x00\x57\x04\x00\x00\x13\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x14\x00\x2c\x00\x64\x00\x00\x00\x00\x00\x2d\x00\x67\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\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\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\xcf\x01\x00\x00\xd0\x01\x14\x00\x88\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x8a\x00\x00\x00\x15\x00\x00\x00\x8d\x00\x00\x00\x16\x00\x00\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\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x1c\xfe\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x1c\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x01\x00\x00\x2c\x00\x8a\x00\x00\x00\x1c\xfe\x2d\x00\x8d\x00\x00\x00\x1c\xfe\x00\x00\x1c\xfe\x1c\xfe\x1c\xfe\x1c\xfe\x1c\xfe\x1c\xfe\x1c\xfe\x1c\xfe\x1c\xfe\x1c\xfe\x1c\xfe\x1c\xfe\x1c\xfe\x00\x00\x00\x00\x1c\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x1c\xfe\x1c\xfe\x1c\xfe\x1c\xfe\x1c\xfe\x1c\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\xfe\x00\x00\x00\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x00\x00\x8d\x00\x00\x00\x00\x00\x00\x00\x1c\xfe\x00\x00\x00\x00\x00\x00\x1c\xfe\x00\x00\x1c\xfe\x1c\xfe\x1c\xfe\x1c\xfe\x1c\xfe\x1c\xfe\x1c\xfe\x1c\xfe\x1c\xfe\x1c\xfe\x1c\xfe\x1c\xfe\x1c\xfe\x00\x00\x00\x00\x1c\xfe\x00\x00\x6e\x01\x00\x00\x1c\xfe\x1c\xfe\x1c\xfe\x1c\xfe\x1c\xfe\x1c\xfe\x1c\xfe\x00\x00\x00\x00\x00\x00\x1c\xfe\x00\x00\x00\x00\x00\x00\x1c\xfe\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\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\x00\x00\x00\x00\x24\x00\x00\x00\x6e\x01\x00\x00\x1c\xfe\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x13\x00\x1c\xfe\x00\x00\x00\x00\x00\x00\x1c\xfe\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x62\x02\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\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\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x2c\x00\x00\x00\x00\x00\x00\x00\x2d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\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\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x00\x00\x00\x00\x00\x00\x2d\x00\x8f\x00\x00\x00\x00\x00\xd5\x02\xd6\x02\x81\x00\xd7\x02\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x83\x00\x00\x00\x00\x00\x00\x00\x84\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\x86\x00\x00\x00\x6a\x01\x5e\x01\x88\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5f\x01\x00\x00\x00\x00\x2c\x00\x8a\x00\x8b\x00\x8c\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x8f\x00\x73\x00\x74\x00\x66\x03\xd6\x02\x00\x00\xd7\x02\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\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\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd8\x02\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\x4a\x01\x4b\x01\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x4c\x01\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4d\x01\x4e\x01\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd8\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x4f\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\x50\x01\x51\x01\x00\x00\x52\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x53\x01\x54\x01\x98\x01\x56\x01\x11\x00\x7b\x00\x7c\x00\x7d\x00\x57\x01\x7f\x00\xa2\x00\x00\x00\x00\x00\x58\x01\x00\x00\x59\x01\x00\x00\x13\x00\xa3\x00\x8f\x00\x4a\x01\x4b\x01\x00\x00\x92\x00\x14\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x4c\x01\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x15\x00\x00\x00\x4d\x01\x4e\x01\x16\x00\x00\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\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x4f\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\x50\x01\x51\x01\x00\x00\x52\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x53\x01\x54\x01\x55\x01\x56\x01\x11\x00\x7b\x00\x7c\x00\x7d\x00\x57\x01\x7f\x00\xa2\x00\x00\x00\x00\x00\x58\x01\x2c\x00\x59\x01\x00\x00\x13\x00\xa3\x00\x8f\x00\x4a\x01\x4b\x01\x00\x00\x92\x00\x14\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x15\x00\x00\x00\x92\x01\x93\x01\x00\x00\x00\x00\x17\x00\x18\x00\x19\x00\x52\x00\x53\x00\x54\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x4f\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x26\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x50\x01\x51\x01\x00\x00\x52\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x53\x01\x94\x01\x00\x00\x95\x01\x11\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xa2\x00\x00\x00\x00\x00\x96\x01\x63\x00\x59\x01\x00\x00\x00\x00\xa3\x00\x8f\x00\x4a\x01\x4b\x01\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x99\x01\x00\x00\x00\x00\x00\x00\x9a\x01\x9b\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\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x4f\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\x50\x01\x51\x01\x00\x00\x52\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x53\x01\x94\x01\x00\x00\x95\x01\x11\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xa2\x00\x00\x00\x00\x00\x8f\x00\x4a\x01\x4b\x01\x00\x00\x92\x00\xa3\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x02\x00\x00\x00\x00\x82\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x4f\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\x50\x01\x51\x01\x00\x00\x52\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x53\x01\x94\x01\x00\x00\x95\x01\x11\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xa2\x00\x00\x00\x00\x00\x8f\x00\x4a\x01\x4b\x01\x00\x00\x92\x00\xa3\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x02\x00\x00\x00\x00\x98\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\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x4f\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\x50\x01\x51\x01\x00\x00\x52\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x53\x01\x94\x01\x00\x00\x95\x01\x11\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xa2\x00\x00\x00\x00\x00\x8f\x00\x4a\x01\x4b\x01\x00\x00\x92\x00\xa3\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc8\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x4f\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\x50\x01\x51\x01\x00\x00\x52\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x53\x01\x94\x01\x00\x00\x95\x01\x11\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xa2\x00\x00\x00\x00\x00\x8f\x00\x4a\x01\x4b\x01\x00\x00\x92\x00\xa3\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\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\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x4f\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\x50\x01\x51\x01\x00\x00\x52\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x53\x01\x94\x01\x00\x00\x95\x01\x11\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xa2\x00\x00\x00\x00\x00\x8f\x00\x9a\x03\x4b\x01\x00\x00\x92\x00\xa3\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9b\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\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x4f\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\x50\x01\x51\x01\x00\x00\x52\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x53\x01\x94\x01\x00\x00\x95\x01\x11\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xa2\x00\x00\x00\x00\x00\x8f\x00\x4a\x01\x4b\x01\x00\x00\x92\x00\xa3\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x71\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\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x4f\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\x50\x01\x51\x01\x00\x00\x52\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x53\x01\x94\x01\x00\x00\x95\x01\x11\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xa2\x00\x00\x00\x00\x00\x8f\x00\x4a\x01\x4b\x01\x00\x00\x92\x00\xa3\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe9\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\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x4f\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\x50\x01\x51\x01\x00\x00\x52\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x53\x01\x94\x01\x00\x00\x95\x01\x11\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xa2\x00\x00\x00\x00\x00\x8f\x00\x4a\x01\x4b\x01\x00\x00\x92\x00\xa3\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\xce\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\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x4f\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\x50\x01\x51\x01\x00\x00\x52\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x53\x01\x94\x01\x00\x00\x95\x01\x11\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xa2\x00\x00\x00\x00\x00\x8f\x00\x90\x00\x91\x00\x00\x00\x92\x00\xa3\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x03\x9d\x03\x9e\x03\x9f\x03\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\x00\x00\x00\x00\xa0\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x8f\x00\x90\x00\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\xab\x04\x9e\x03\x9f\x03\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\xa0\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x00\x00\x00\x00\x8f\x00\x90\x00\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x00\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\xfa\x00\xfb\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x00\x00\x8f\x00\x90\x00\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9b\x00\xa3\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x00\x00\x8f\x00\x90\x00\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x8b\x02\x00\x00\xa3\x00\x8a\x02\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x00\x00\x8f\x00\x90\x00\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x89\x02\x00\x00\xa3\x00\x8a\x02\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x8f\x00\x90\x00\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x68\x02\x69\x02\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x6a\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x8f\x00\x90\x00\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x61\x03\x69\x02\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x6a\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8f\x00\xac\x01\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\xad\x01\xae\x01\xaf\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x00\x00\x8f\x00\x90\x00\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x01\x04\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x8f\x00\x90\x00\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\xa9\x04\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\xaa\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x8f\x00\x90\x00\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\xed\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\xdd\x00\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\xde\x00\x00\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\xdd\x00\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x38\x03\x00\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\xdd\x00\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x37\x03\x00\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\xdf\x00\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\xb9\x01\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\xb2\x01\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\x89\x01\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\x83\x01\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\x64\x02\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\x58\x02\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\x57\x02\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\x56\x02\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\x55\x02\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\xb7\x03\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\xb6\x03\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\xa4\x03\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\xa2\x03\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\x62\x03\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\x06\x04\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\xfc\x03\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\xee\x03\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\xec\x03\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\xb0\x04\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\xa8\x04\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\x8f\x04\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\xfd\x04\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\xd2\x04\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\xd1\x04\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\xd0\x04\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\x31\x05\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\x41\x05\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x17\x00\x18\x00\x19\x00\x73\x00\x74\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\xa1\x00\x13\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x15\x01\x00\x00\x00\x00\x15\x00\x00\x00\x16\x01\xa3\x00\x16\x00\x00\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\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x13\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\x02\x1a\x02\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\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\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x86\x00\x00\x00\x17\x01\x00\x00\x88\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\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\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x86\x00\x00\x00\x6a\x01\x00\x00\x88\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x2c\x00\x8a\x00\x16\x00\x00\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\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x13\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\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\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x86\x00\x00\x00\x26\x01\x00\x00\x88\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\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\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x86\x00\x00\x00\x17\x01\x00\x00\x88\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x2c\x00\x8a\x00\x16\x00\x00\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\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x13\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\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\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x86\x00\x00\x00\x6a\x01\x00\x00\x88\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\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\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x86\x00\x00\x00\x17\x01\x00\x00\x88\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x2c\x00\x8a\x00\x16\x00\x00\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\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x13\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\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\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\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\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x05\xff\x00\x00\x15\x00\x00\x00\x00\x00\x05\xff\x16\x00\x00\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\x00\x00\x00\x00\x24\x00\x02\x03\x00\x00\x00\x00\x13\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x14\x00\x00\x00\x00\x00\xaf\x02\x00\x00\x00\x00\x2c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\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\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xe6\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\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\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x13\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x14\x00\x40\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\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\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xe6\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x18\x00\x19\x00\x52\x00\x53\x00\x54\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x13\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x14\x00\x40\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x18\x00\x19\x00\x52\x00\x53\x00\x54\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x13\x00\x00\x00\xf0\x01\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xf1\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x63\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x18\x00\x19\x00\x52\x00\x53\x00\x54\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\xf1\x01\x00\x00\x00\x00\x00\x00\x8f\x00\x00\x00\x88\x01\x00\x00\x92\x00\x00\x00\x63\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x8f\x00\x00\x00\xca\x02\x00\x00\x92\x00\x00\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x8f\x00\xa2\x00\x40\x04\x00\x00\x92\x00\x00\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x8f\x00\x00\x00\xe9\x04\x00\x00\x92\x00\x00\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8f\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\xa1\x01\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x8f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x01\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x01\xa3\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\x9e\x00\x9f\x00\x00\x00\xa2\x01\x7a\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x8f\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\xa0\x01\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x8f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x95\x03\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x96\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\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x8f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\xb7\x01\x96\x00\x97\x00\x73\x00\x74\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x8f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\xaa\x01\x96\x00\x97\x00\x73\x00\x74\x00\x98\x00\x99\x00\x00\x00\x00\x00\x8f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa8\x01\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x8f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x9f\x01\x96\x00\x97\x00\x73\x00\x74\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x8f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x9e\x01\x96\x00\x97\x00\x73\x00\x74\x00\x98\x00\x99\x00\x00\x00\x00\x00\x8f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9d\x01\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x8f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x91\x01\x96\x00\x97\x00\x73\x00\x74\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x8f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x16\x03\x96\x00\x97\x00\x73\x00\x74\x00\x98\x00\x99\x00\x00\x00\x00\x00\x8f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x03\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x8f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\xb7\x01\x96\x00\x97\x00\x73\x00\x74\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x8f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x65\x02\x96\x00\x97\x00\x73\x00\x74\x00\x98\x00\x99\x00\x00\x00\x00\x00\x8f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x03\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x8f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\xc6\x01\x73\x00\x74\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x8f\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x81\x01\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\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\x00\x00\x00\x00\x82\x01\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\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\x00\x00\x00\x00\x82\x01\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\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\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 (13, 829) [+	(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),+	(182 , happyReduce_182),+	(183 , happyReduce_183),+	(184 , happyReduce_184),+	(185 , happyReduce_185),+	(186 , happyReduce_186),+	(187 , happyReduce_187),+	(188 , happyReduce_188),+	(189 , happyReduce_189),+	(190 , happyReduce_190),+	(191 , happyReduce_191),+	(192 , happyReduce_192),+	(193 , happyReduce_193),+	(194 , happyReduce_194),+	(195 , happyReduce_195),+	(196 , happyReduce_196),+	(197 , happyReduce_197),+	(198 , happyReduce_198),+	(199 , happyReduce_199),+	(200 , happyReduce_200),+	(201 , happyReduce_201),+	(202 , happyReduce_202),+	(203 , happyReduce_203),+	(204 , happyReduce_204),+	(205 , happyReduce_205),+	(206 , happyReduce_206),+	(207 , happyReduce_207),+	(208 , happyReduce_208),+	(209 , happyReduce_209),+	(210 , happyReduce_210),+	(211 , happyReduce_211),+	(212 , happyReduce_212),+	(213 , happyReduce_213),+	(214 , happyReduce_214),+	(215 , happyReduce_215),+	(216 , happyReduce_216),+	(217 , happyReduce_217),+	(218 , happyReduce_218),+	(219 , happyReduce_219),+	(220 , happyReduce_220),+	(221 , happyReduce_221),+	(222 , happyReduce_222),+	(223 , happyReduce_223),+	(224 , happyReduce_224),+	(225 , happyReduce_225),+	(226 , happyReduce_226),+	(227 , happyReduce_227),+	(228 , happyReduce_228),+	(229 , happyReduce_229),+	(230 , happyReduce_230),+	(231 , happyReduce_231),+	(232 , happyReduce_232),+	(233 , happyReduce_233),+	(234 , happyReduce_234),+	(235 , happyReduce_235),+	(236 , happyReduce_236),+	(237 , happyReduce_237),+	(238 , happyReduce_238),+	(239 , happyReduce_239),+	(240 , happyReduce_240),+	(241 , happyReduce_241),+	(242 , happyReduce_242),+	(243 , happyReduce_243),+	(244 , happyReduce_244),+	(245 , happyReduce_245),+	(246 , happyReduce_246),+	(247 , happyReduce_247),+	(248 , happyReduce_248),+	(249 , happyReduce_249),+	(250 , happyReduce_250),+	(251 , happyReduce_251),+	(252 , happyReduce_252),+	(253 , happyReduce_253),+	(254 , happyReduce_254),+	(255 , happyReduce_255),+	(256 , happyReduce_256),+	(257 , happyReduce_257),+	(258 , happyReduce_258),+	(259 , happyReduce_259),+	(260 , happyReduce_260),+	(261 , happyReduce_261),+	(262 , happyReduce_262),+	(263 , happyReduce_263),+	(264 , happyReduce_264),+	(265 , happyReduce_265),+	(266 , happyReduce_266),+	(267 , happyReduce_267),+	(268 , happyReduce_268),+	(269 , happyReduce_269),+	(270 , happyReduce_270),+	(271 , happyReduce_271),+	(272 , happyReduce_272),+	(273 , happyReduce_273),+	(274 , happyReduce_274),+	(275 , happyReduce_275),+	(276 , happyReduce_276),+	(277 , happyReduce_277),+	(278 , happyReduce_278),+	(279 , happyReduce_279),+	(280 , happyReduce_280),+	(281 , happyReduce_281),+	(282 , happyReduce_282),+	(283 , happyReduce_283),+	(284 , happyReduce_284),+	(285 , happyReduce_285),+	(286 , happyReduce_286),+	(287 , happyReduce_287),+	(288 , happyReduce_288),+	(289 , happyReduce_289),+	(290 , happyReduce_290),+	(291 , happyReduce_291),+	(292 , happyReduce_292),+	(293 , happyReduce_293),+	(294 , happyReduce_294),+	(295 , happyReduce_295),+	(296 , happyReduce_296),+	(297 , happyReduce_297),+	(298 , happyReduce_298),+	(299 , happyReduce_299),+	(300 , happyReduce_300),+	(301 , happyReduce_301),+	(302 , happyReduce_302),+	(303 , happyReduce_303),+	(304 , happyReduce_304),+	(305 , happyReduce_305),+	(306 , happyReduce_306),+	(307 , happyReduce_307),+	(308 , happyReduce_308),+	(309 , happyReduce_309),+	(310 , happyReduce_310),+	(311 , happyReduce_311),+	(312 , happyReduce_312),+	(313 , happyReduce_313),+	(314 , happyReduce_314),+	(315 , happyReduce_315),+	(316 , happyReduce_316),+	(317 , happyReduce_317),+	(318 , happyReduce_318),+	(319 , happyReduce_319),+	(320 , happyReduce_320),+	(321 , happyReduce_321),+	(322 , happyReduce_322),+	(323 , happyReduce_323),+	(324 , happyReduce_324),+	(325 , happyReduce_325),+	(326 , happyReduce_326),+	(327 , happyReduce_327),+	(328 , happyReduce_328),+	(329 , happyReduce_329),+	(330 , happyReduce_330),+	(331 , happyReduce_331),+	(332 , happyReduce_332),+	(333 , happyReduce_333),+	(334 , happyReduce_334),+	(335 , happyReduce_335),+	(336 , happyReduce_336),+	(337 , happyReduce_337),+	(338 , happyReduce_338),+	(339 , happyReduce_339),+	(340 , happyReduce_340),+	(341 , happyReduce_341),+	(342 , happyReduce_342),+	(343 , happyReduce_343),+	(344 , happyReduce_344),+	(345 , happyReduce_345),+	(346 , happyReduce_346),+	(347 , happyReduce_347),+	(348 , happyReduce_348),+	(349 , happyReduce_349),+	(350 , happyReduce_350),+	(351 , happyReduce_351),+	(352 , happyReduce_352),+	(353 , happyReduce_353),+	(354 , happyReduce_354),+	(355 , happyReduce_355),+	(356 , happyReduce_356),+	(357 , happyReduce_357),+	(358 , happyReduce_358),+	(359 , happyReduce_359),+	(360 , happyReduce_360),+	(361 , happyReduce_361),+	(362 , happyReduce_362),+	(363 , happyReduce_363),+	(364 , happyReduce_364),+	(365 , happyReduce_365),+	(366 , happyReduce_366),+	(367 , happyReduce_367),+	(368 , happyReduce_368),+	(369 , happyReduce_369),+	(370 , happyReduce_370),+	(371 , happyReduce_371),+	(372 , happyReduce_372),+	(373 , happyReduce_373),+	(374 , happyReduce_374),+	(375 , happyReduce_375),+	(376 , happyReduce_376),+	(377 , happyReduce_377),+	(378 , happyReduce_378),+	(379 , happyReduce_379),+	(380 , happyReduce_380),+	(381 , happyReduce_381),+	(382 , happyReduce_382),+	(383 , happyReduce_383),+	(384 , happyReduce_384),+	(385 , happyReduce_385),+	(386 , happyReduce_386),+	(387 , happyReduce_387),+	(388 , happyReduce_388),+	(389 , happyReduce_389),+	(390 , happyReduce_390),+	(391 , happyReduce_391),+	(392 , happyReduce_392),+	(393 , happyReduce_393),+	(394 , happyReduce_394),+	(395 , happyReduce_395),+	(396 , happyReduce_396),+	(397 , happyReduce_397),+	(398 , happyReduce_398),+	(399 , happyReduce_399),+	(400 , happyReduce_400),+	(401 , happyReduce_401),+	(402 , happyReduce_402),+	(403 , happyReduce_403),+	(404 , happyReduce_404),+	(405 , happyReduce_405),+	(406 , happyReduce_406),+	(407 , happyReduce_407),+	(408 , happyReduce_408),+	(409 , happyReduce_409),+	(410 , happyReduce_410),+	(411 , happyReduce_411),+	(412 , happyReduce_412),+	(413 , happyReduce_413),+	(414 , happyReduce_414),+	(415 , happyReduce_415),+	(416 , happyReduce_416),+	(417 , happyReduce_417),+	(418 , happyReduce_418),+	(419 , happyReduce_419),+	(420 , happyReduce_420),+	(421 , happyReduce_421),+	(422 , happyReduce_422),+	(423 , happyReduce_423),+	(424 , happyReduce_424),+	(425 , happyReduce_425),+	(426 , happyReduce_426),+	(427 , happyReduce_427),+	(428 , happyReduce_428),+	(429 , happyReduce_429),+	(430 , happyReduce_430),+	(431 , happyReduce_431),+	(432 , happyReduce_432),+	(433 , happyReduce_433),+	(434 , happyReduce_434),+	(435 , happyReduce_435),+	(436 , happyReduce_436),+	(437 , happyReduce_437),+	(438 , happyReduce_438),+	(439 , happyReduce_439),+	(440 , happyReduce_440),+	(441 , happyReduce_441),+	(442 , happyReduce_442),+	(443 , happyReduce_443),+	(444 , happyReduce_444),+	(445 , happyReduce_445),+	(446 , happyReduce_446),+	(447 , happyReduce_447),+	(448 , happyReduce_448),+	(449 , happyReduce_449),+	(450 , happyReduce_450),+	(451 , happyReduce_451),+	(452 , happyReduce_452),+	(453 , happyReduce_453),+	(454 , happyReduce_454),+	(455 , happyReduce_455),+	(456 , happyReduce_456),+	(457 , happyReduce_457),+	(458 , happyReduce_458),+	(459 , happyReduce_459),+	(460 , happyReduce_460),+	(461 , happyReduce_461),+	(462 , happyReduce_462),+	(463 , happyReduce_463),+	(464 , happyReduce_464),+	(465 , happyReduce_465),+	(466 , happyReduce_466),+	(467 , happyReduce_467),+	(468 , happyReduce_468),+	(469 , happyReduce_469),+	(470 , happyReduce_470),+	(471 , happyReduce_471),+	(472 , happyReduce_472),+	(473 , happyReduce_473),+	(474 , happyReduce_474),+	(475 , happyReduce_475),+	(476 , happyReduce_476),+	(477 , happyReduce_477),+	(478 , happyReduce_478),+	(479 , happyReduce_479),+	(480 , happyReduce_480),+	(481 , happyReduce_481),+	(482 , happyReduce_482),+	(483 , happyReduce_483),+	(484 , happyReduce_484),+	(485 , happyReduce_485),+	(486 , happyReduce_486),+	(487 , happyReduce_487),+	(488 , happyReduce_488),+	(489 , happyReduce_489),+	(490 , happyReduce_490),+	(491 , happyReduce_491),+	(492 , happyReduce_492),+	(493 , happyReduce_493),+	(494 , happyReduce_494),+	(495 , happyReduce_495),+	(496 , happyReduce_496),+	(497 , happyReduce_497),+	(498 , happyReduce_498),+	(499 , happyReduce_499),+	(500 , happyReduce_500),+	(501 , happyReduce_501),+	(502 , happyReduce_502),+	(503 , happyReduce_503),+	(504 , happyReduce_504),+	(505 , happyReduce_505),+	(506 , happyReduce_506),+	(507 , happyReduce_507),+	(508 , happyReduce_508),+	(509 , happyReduce_509),+	(510 , happyReduce_510),+	(511 , happyReduce_511),+	(512 , happyReduce_512),+	(513 , happyReduce_513),+	(514 , happyReduce_514),+	(515 , happyReduce_515),+	(516 , happyReduce_516),+	(517 , happyReduce_517),+	(518 , happyReduce_518),+	(519 , happyReduce_519),+	(520 , happyReduce_520),+	(521 , happyReduce_521),+	(522 , happyReduce_522),+	(523 , happyReduce_523),+	(524 , happyReduce_524),+	(525 , happyReduce_525),+	(526 , happyReduce_526),+	(527 , happyReduce_527),+	(528 , happyReduce_528),+	(529 , happyReduce_529),+	(530 , happyReduce_530),+	(531 , happyReduce_531),+	(532 , happyReduce_532),+	(533 , happyReduce_533),+	(534 , happyReduce_534),+	(535 , happyReduce_535),+	(536 , happyReduce_536),+	(537 , happyReduce_537),+	(538 , happyReduce_538),+	(539 , happyReduce_539),+	(540 , happyReduce_540),+	(541 , happyReduce_541),+	(542 , happyReduce_542),+	(543 , happyReduce_543),+	(544 , happyReduce_544),+	(545 , happyReduce_545),+	(546 , happyReduce_546),+	(547 , happyReduce_547),+	(548 , happyReduce_548),+	(549 , happyReduce_549),+	(550 , happyReduce_550),+	(551 , happyReduce_551),+	(552 , happyReduce_552),+	(553 , happyReduce_553),+	(554 , happyReduce_554),+	(555 , happyReduce_555),+	(556 , happyReduce_556),+	(557 , happyReduce_557),+	(558 , happyReduce_558),+	(559 , happyReduce_559),+	(560 , happyReduce_560),+	(561 , happyReduce_561),+	(562 , happyReduce_562),+	(563 , happyReduce_563),+	(564 , happyReduce_564),+	(565 , happyReduce_565),+	(566 , happyReduce_566),+	(567 , happyReduce_567),+	(568 , happyReduce_568),+	(569 , happyReduce_569),+	(570 , happyReduce_570),+	(571 , happyReduce_571),+	(572 , happyReduce_572),+	(573 , happyReduce_573),+	(574 , happyReduce_574),+	(575 , happyReduce_575),+	(576 , happyReduce_576),+	(577 , happyReduce_577),+	(578 , happyReduce_578),+	(579 , happyReduce_579),+	(580 , happyReduce_580),+	(581 , happyReduce_581),+	(582 , happyReduce_582),+	(583 , happyReduce_583),+	(584 , happyReduce_584),+	(585 , happyReduce_585),+	(586 , happyReduce_586),+	(587 , happyReduce_587),+	(588 , happyReduce_588),+	(589 , happyReduce_589),+	(590 , happyReduce_590),+	(591 , happyReduce_591),+	(592 , happyReduce_592),+	(593 , happyReduce_593),+	(594 , happyReduce_594),+	(595 , happyReduce_595),+	(596 , happyReduce_596),+	(597 , happyReduce_597),+	(598 , happyReduce_598),+	(599 , happyReduce_599),+	(600 , happyReduce_600),+	(601 , happyReduce_601),+	(602 , happyReduce_602),+	(603 , happyReduce_603),+	(604 , happyReduce_604),+	(605 , happyReduce_605),+	(606 , happyReduce_606),+	(607 , happyReduce_607),+	(608 , happyReduce_608),+	(609 , happyReduce_609),+	(610 , happyReduce_610),+	(611 , happyReduce_611),+	(612 , happyReduce_612),+	(613 , happyReduce_613),+	(614 , happyReduce_614),+	(615 , happyReduce_615),+	(616 , happyReduce_616),+	(617 , happyReduce_617),+	(618 , happyReduce_618),+	(619 , happyReduce_619),+	(620 , happyReduce_620),+	(621 , happyReduce_621),+	(622 , happyReduce_622),+	(623 , happyReduce_623),+	(624 , happyReduce_624),+	(625 , happyReduce_625),+	(626 , happyReduce_626),+	(627 , happyReduce_627),+	(628 , happyReduce_628),+	(629 , happyReduce_629),+	(630 , happyReduce_630),+	(631 , happyReduce_631),+	(632 , happyReduce_632),+	(633 , happyReduce_633),+	(634 , happyReduce_634),+	(635 , happyReduce_635),+	(636 , happyReduce_636),+	(637 , happyReduce_637),+	(638 , happyReduce_638),+	(639 , happyReduce_639),+	(640 , happyReduce_640),+	(641 , happyReduce_641),+	(642 , happyReduce_642),+	(643 , happyReduce_643),+	(644 , happyReduce_644),+	(645 , happyReduce_645),+	(646 , happyReduce_646),+	(647 , happyReduce_647),+	(648 , happyReduce_648),+	(649 , happyReduce_649),+	(650 , happyReduce_650),+	(651 , happyReduce_651),+	(652 , happyReduce_652),+	(653 , happyReduce_653),+	(654 , happyReduce_654),+	(655 , happyReduce_655),+	(656 , happyReduce_656),+	(657 , happyReduce_657),+	(658 , happyReduce_658),+	(659 , happyReduce_659),+	(660 , happyReduce_660),+	(661 , happyReduce_661),+	(662 , happyReduce_662),+	(663 , happyReduce_663),+	(664 , happyReduce_664),+	(665 , happyReduce_665),+	(666 , happyReduce_666),+	(667 , happyReduce_667),+	(668 , happyReduce_668),+	(669 , happyReduce_669),+	(670 , happyReduce_670),+	(671 , happyReduce_671),+	(672 , happyReduce_672),+	(673 , happyReduce_673),+	(674 , happyReduce_674),+	(675 , happyReduce_675),+	(676 , happyReduce_676),+	(677 , happyReduce_677),+	(678 , happyReduce_678),+	(679 , happyReduce_679),+	(680 , happyReduce_680),+	(681 , happyReduce_681),+	(682 , happyReduce_682),+	(683 , happyReduce_683),+	(684 , happyReduce_684),+	(685 , happyReduce_685),+	(686 , happyReduce_686),+	(687 , happyReduce_687),+	(688 , happyReduce_688),+	(689 , happyReduce_689),+	(690 , happyReduce_690),+	(691 , happyReduce_691),+	(692 , happyReduce_692),+	(693 , happyReduce_693),+	(694 , happyReduce_694),+	(695 , happyReduce_695),+	(696 , happyReduce_696),+	(697 , happyReduce_697),+	(698 , happyReduce_698),+	(699 , happyReduce_699),+	(700 , happyReduce_700),+	(701 , happyReduce_701),+	(702 , happyReduce_702),+	(703 , happyReduce_703),+	(704 , happyReduce_704),+	(705 , happyReduce_705),+	(706 , happyReduce_706),+	(707 , happyReduce_707),+	(708 , happyReduce_708),+	(709 , happyReduce_709),+	(710 , happyReduce_710),+	(711 , happyReduce_711),+	(712 , happyReduce_712),+	(713 , happyReduce_713),+	(714 , happyReduce_714),+	(715 , happyReduce_715),+	(716 , happyReduce_716),+	(717 , happyReduce_717),+	(718 , happyReduce_718),+	(719 , happyReduce_719),+	(720 , happyReduce_720),+	(721 , happyReduce_721),+	(722 , happyReduce_722),+	(723 , happyReduce_723),+	(724 , happyReduce_724),+	(725 , happyReduce_725),+	(726 , happyReduce_726),+	(727 , happyReduce_727),+	(728 , happyReduce_728),+	(729 , happyReduce_729),+	(730 , happyReduce_730),+	(731 , happyReduce_731),+	(732 , happyReduce_732),+	(733 , happyReduce_733),+	(734 , happyReduce_734),+	(735 , happyReduce_735),+	(736 , happyReduce_736),+	(737 , happyReduce_737),+	(738 , happyReduce_738),+	(739 , happyReduce_739),+	(740 , happyReduce_740),+	(741 , happyReduce_741),+	(742 , happyReduce_742),+	(743 , happyReduce_743),+	(744 , happyReduce_744),+	(745 , happyReduce_745),+	(746 , happyReduce_746),+	(747 , happyReduce_747),+	(748 , happyReduce_748),+	(749 , happyReduce_749),+	(750 , happyReduce_750),+	(751 , happyReduce_751),+	(752 , happyReduce_752),+	(753 , happyReduce_753),+	(754 , happyReduce_754),+	(755 , happyReduce_755),+	(756 , happyReduce_756),+	(757 , happyReduce_757),+	(758 , happyReduce_758),+	(759 , happyReduce_759),+	(760 , happyReduce_760),+	(761 , happyReduce_761),+	(762 , happyReduce_762),+	(763 , happyReduce_763),+	(764 , happyReduce_764),+	(765 , happyReduce_765),+	(766 , happyReduce_766),+	(767 , happyReduce_767),+	(768 , happyReduce_768),+	(769 , happyReduce_769),+	(770 , happyReduce_770),+	(771 , happyReduce_771),+	(772 , happyReduce_772),+	(773 , happyReduce_773),+	(774 , happyReduce_774),+	(775 , happyReduce_775),+	(776 , happyReduce_776),+	(777 , happyReduce_777),+	(778 , happyReduce_778),+	(779 , happyReduce_779),+	(780 , happyReduce_780),+	(781 , happyReduce_781),+	(782 , happyReduce_782),+	(783 , happyReduce_783),+	(784 , happyReduce_784),+	(785 , happyReduce_785),+	(786 , happyReduce_786),+	(787 , happyReduce_787),+	(788 , happyReduce_788),+	(789 , happyReduce_789),+	(790 , happyReduce_790),+	(791 , happyReduce_791),+	(792 , happyReduce_792),+	(793 , happyReduce_793),+	(794 , happyReduce_794),+	(795 , happyReduce_795),+	(796 , happyReduce_796),+	(797 , happyReduce_797),+	(798 , happyReduce_798),+	(799 , happyReduce_799),+	(800 , happyReduce_800),+	(801 , happyReduce_801),+	(802 , happyReduce_802),+	(803 , happyReduce_803),+	(804 , happyReduce_804),+	(805 , happyReduce_805),+	(806 , happyReduce_806),+	(807 , happyReduce_807),+	(808 , happyReduce_808),+	(809 , happyReduce_809),+	(810 , happyReduce_810),+	(811 , happyReduce_811),+	(812 , happyReduce_812),+	(813 , happyReduce_813),+	(814 , happyReduce_814),+	(815 , happyReduce_815),+	(816 , happyReduce_816),+	(817 , happyReduce_817),+	(818 , happyReduce_818),+	(819 , happyReduce_819),+	(820 , happyReduce_820),+	(821 , happyReduce_821),+	(822 , happyReduce_822),+	(823 , happyReduce_823),+	(824 , happyReduce_824),+	(825 , happyReduce_825),+	(826 , happyReduce_826),+	(827 , happyReduce_827),+	(828 , happyReduce_828),+	(829 , happyReduce_829)+	]++happy_n_terms = 151 :: Prelude.Int+happy_n_nonterms = 313 :: Prelude.Int++happyReduce_13 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_13 = happySpecReduce_1  0# happyReduction_13+happyReduction_13 happy_x_1+	 =  case happyOut298 happy_x_1 of { (HappyWrap298 happy_var_1) -> +	happyIn16+		 (happy_var_1+	)}++happyReduce_14 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_14 = happySpecReduce_1  0# happyReduction_14+happyReduction_14 happy_x_1+	 =  case happyOut268 happy_x_1 of { (HappyWrap268 happy_var_1) -> +	happyIn16+		 (happy_var_1+	)}++happyReduce_15 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_15 = happySpecReduce_1  0# happyReduction_15+happyReduction_15 happy_x_1+	 =  case happyOut292 happy_x_1 of { (HappyWrap292 happy_var_1) -> +	happyIn16+		 (happy_var_1+	)}++happyReduce_16 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_16 = happySpecReduce_1  0# happyReduction_16+happyReduction_16 happy_x_1+	 =  case happyOut276 happy_x_1 of { (HappyWrap276 happy_var_1) -> +	happyIn16+		 (happy_var_1+	)}++happyReduce_17 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_17 = happyMonadReduce 3# 0# happyReduction_17+happyReduction_17 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	( amsrn (sLL happy_var_1 happy_var_3 $ getRdrName unrestrictedFunTyCon)+                                 (NameAnn NameParens (glAA happy_var_1) (glAA happy_var_2) (glAA happy_var_3) []))}}})+	) (\r -> happyReturn (happyIn16 r))++happyReduce_18 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_18 = happyMonadReduce 1# 0# happyReduction_18+happyReduction_18 (happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	( amsrn (sLL happy_var_1 happy_var_1 $ getRdrName unrestrictedFunTyCon)+                                 (NameAnnRArrow (glAA happy_var_1) []))})+	) (\r -> happyReturn (happyIn16 r))++happyReduce_19 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_19 = happySpecReduce_3  1# happyReduction_19+happyReduction_19 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut18 happy_x_2 of { (HappyWrap18 happy_var_2) -> +	happyIn17+		 (fromOL happy_var_2+	)}++happyReduce_20 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_20 = happySpecReduce_3  1# happyReduction_20+happyReduction_20 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut18 happy_x_2 of { (HappyWrap18 happy_var_2) -> +	happyIn17+		 (fromOL happy_var_2+	)}++happyReduce_21 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_21 = happySpecReduce_3  2# happyReduction_21+happyReduction_21 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut18 happy_x_1 of { (HappyWrap18 happy_var_1) -> +	case happyOut19 happy_x_3 of { (HappyWrap19 happy_var_3) -> +	happyIn18+		 (happy_var_1 `appOL` unitOL happy_var_3+	)}}++happyReduce_22 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_22 = happySpecReduce_2  2# happyReduction_22+happyReduction_22 happy_x_2+	happy_x_1+	 =  case happyOut18 happy_x_1 of { (HappyWrap18 happy_var_1) -> +	happyIn18+		 (happy_var_1+	)}++happyReduce_23 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_23 = happySpecReduce_1  2# happyReduction_23+happyReduction_23 happy_x_1+	 =  case happyOut19 happy_x_1 of { (HappyWrap19 happy_var_1) -> +	happyIn18+		 (unitOL happy_var_1+	)}++happyReduce_24 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_24 = happyReduce 4# 3# happyReduction_24+happyReduction_24 (happy_x_4 `HappyStk`+	happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest)+	 = case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut24 happy_x_2 of { (HappyWrap24 happy_var_2) -> +	case happyOut31 happy_x_4 of { (HappyWrap31 happy_var_4) -> +	happyIn19+		 (sL1 happy_var_1 $ HsUnit { hsunitName = happy_var_2+                              , hsunitBody = fromOL happy_var_4 }+	) `HappyStk` happyRest}}}++happyReduce_25 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_25 = happySpecReduce_1  4# happyReduction_25+happyReduction_25 happy_x_1+	 =  case happyOut24 happy_x_1 of { (HappyWrap24 happy_var_1) -> +	happyIn20+		 (sL1 happy_var_1 $ HsUnitId happy_var_1 []+	)}++happyReduce_26 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_26 = happyReduce 4# 4# happyReduction_26+happyReduction_26 (happy_x_4 `HappyStk`+	happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest)+	 = case happyOut24 happy_x_1 of { (HappyWrap24 happy_var_1) -> +	case happyOut21 happy_x_3 of { (HappyWrap21 happy_var_3) -> +	case happyOutTok happy_x_4 of { happy_var_4 -> +	happyIn20+		 (sLL happy_var_1 happy_var_4 $ HsUnitId happy_var_1 (fromOL happy_var_3)+	) `HappyStk` happyRest}}}++happyReduce_27 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_27 = happySpecReduce_3  5# happyReduction_27+happyReduction_27 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut21 happy_x_1 of { (HappyWrap21 happy_var_1) -> +	case happyOut22 happy_x_3 of { (HappyWrap22 happy_var_3) -> +	happyIn21+		 (happy_var_1 `appOL` unitOL happy_var_3+	)}}++happyReduce_28 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_28 = happySpecReduce_2  5# happyReduction_28+happyReduction_28 happy_x_2+	happy_x_1+	 =  case happyOut21 happy_x_1 of { (HappyWrap21 happy_var_1) -> +	happyIn21+		 (happy_var_1+	)}++happyReduce_29 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_29 = happySpecReduce_1  5# happyReduction_29+happyReduction_29 happy_x_1+	 =  case happyOut22 happy_x_1 of { (HappyWrap22 happy_var_1) -> +	happyIn21+		 (unitOL happy_var_1+	)}++happyReduce_30 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_30 = happySpecReduce_3  6# happyReduction_30+happyReduction_30 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut315 happy_x_1 of { (HappyWrap315 happy_var_1) -> +	case happyOut23 happy_x_3 of { (HappyWrap23 happy_var_3) -> +	happyIn22+		 (sLL (reLoc happy_var_1) happy_var_3 $ (reLoc happy_var_1, happy_var_3)+	)}}++happyReduce_31 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_31 = happyReduce 4# 6# happyReduction_31+happyReduction_31 (happy_x_4 `HappyStk`+	happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest)+	 = case happyOut315 happy_x_1 of { (HappyWrap315 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut315 happy_x_3 of { (HappyWrap315 happy_var_3) -> +	case happyOutTok happy_x_4 of { happy_var_4 -> +	happyIn22+		 (sLL (reLoc happy_var_1) happy_var_4 $ (reLoc happy_var_1, sLL happy_var_2 happy_var_4 $ HsModuleVar (reLoc happy_var_3))+	) `HappyStk` happyRest}}}}++happyReduce_32 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_32 = happySpecReduce_3  7# happyReduction_32+happyReduction_32 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut315 happy_x_2 of { (HappyWrap315 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	happyIn23+		 (sLL happy_var_1 happy_var_3 $ HsModuleVar (reLoc happy_var_2)+	)}}}++happyReduce_33 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_33 = happySpecReduce_3  7# happyReduction_33+happyReduction_33 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut20 happy_x_1 of { (HappyWrap20 happy_var_1) -> +	case happyOut315 happy_x_3 of { (HappyWrap315 happy_var_3) -> +	happyIn23+		 (sLL happy_var_1 (reLoc happy_var_3) $ HsModuleId happy_var_1 (reLoc happy_var_3)+	)}}++happyReduce_34 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_34 = happySpecReduce_1  8# happyReduction_34+happyReduction_34 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn24+		 (sL1 happy_var_1 $ PackageName (getSTRING happy_var_1)+	)}++happyReduce_35 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_35 = happySpecReduce_1  8# happyReduction_35+happyReduction_35 happy_x_1+	 =  case happyOut27 happy_x_1 of { (HappyWrap27 happy_var_1) -> +	happyIn24+		 (sL1 happy_var_1 $ PackageName (unLoc happy_var_1)+	)}++happyReduce_36 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_36 = happySpecReduce_1  9# happyReduction_36+happyReduction_36 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn25+		 (sL1 happy_var_1 $ getVARID happy_var_1+	)}++happyReduce_37 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_37 = happySpecReduce_1  9# happyReduction_37+happyReduction_37 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn25+		 (sL1 happy_var_1 $ getCONID happy_var_1+	)}++happyReduce_38 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_38 = happySpecReduce_1  9# happyReduction_38+happyReduction_38 happy_x_1+	 =  case happyOut307 happy_x_1 of { (HappyWrap307 happy_var_1) -> +	happyIn25+		 (happy_var_1+	)}++happyReduce_39 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_39 = happySpecReduce_1  10# happyReduction_39+happyReduction_39 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn26+		 ([mj AnnMinus happy_var_1 ]+	)}++happyReduce_40 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_40 = happySpecReduce_1  10# happyReduction_40+happyReduction_40 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn26+		 ([mj AnnMinus happy_var_1 ]+	)}++happyReduce_41 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_41 = happyMonadReduce 1# 10# happyReduction_41+happyReduction_41 (happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	( if (getVARSYM happy_var_1 == fsLit "-")+                   then return [mj AnnMinus happy_var_1]+                   else do { addError $ mkPlainErrorMsgEnvelope (getLoc happy_var_1) $ PsErrExpectedHyphen+                           ; return [] })})+	) (\r -> happyReturn (happyIn26 r))++happyReduce_42 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_42 = happySpecReduce_1  11# happyReduction_42+happyReduction_42 happy_x_1+	 =  case happyOut25 happy_x_1 of { (HappyWrap25 happy_var_1) -> +	happyIn27+		 (happy_var_1+	)}++happyReduce_43 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_43 = happySpecReduce_3  11# happyReduction_43+happyReduction_43 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut25 happy_x_1 of { (HappyWrap25 happy_var_1) -> +	case happyOut27 happy_x_3 of { (HappyWrap27 happy_var_3) -> +	happyIn27+		 (sLL happy_var_1 happy_var_3 $ appendFS (unLoc happy_var_1) (consFS '-' (unLoc happy_var_3))+	)}}++happyReduce_44 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_44 = happySpecReduce_0  12# happyReduction_44+happyReduction_44  =  happyIn28+		 (Nothing+	)++happyReduce_45 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_45 = happySpecReduce_3  12# happyReduction_45+happyReduction_45 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut29 happy_x_2 of { (HappyWrap29 happy_var_2) -> +	happyIn28+		 (Just (fromOL happy_var_2)+	)}++happyReduce_46 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_46 = happySpecReduce_3  13# happyReduction_46+happyReduction_46 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut29 happy_x_1 of { (HappyWrap29 happy_var_1) -> +	case happyOut30 happy_x_3 of { (HappyWrap30 happy_var_3) -> +	happyIn29+		 (happy_var_1 `appOL` unitOL happy_var_3+	)}}++happyReduce_47 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_47 = happySpecReduce_2  13# happyReduction_47+happyReduction_47 happy_x_2+	happy_x_1+	 =  case happyOut29 happy_x_1 of { (HappyWrap29 happy_var_1) -> +	happyIn29+		 (happy_var_1+	)}++happyReduce_48 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_48 = happySpecReduce_1  13# happyReduction_48+happyReduction_48 happy_x_1+	 =  case happyOut30 happy_x_1 of { (HappyWrap30 happy_var_1) -> +	happyIn29+		 (unitOL happy_var_1+	)}++happyReduce_49 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_49 = happySpecReduce_3  14# happyReduction_49+happyReduction_49 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut315 happy_x_1 of { (HappyWrap315 happy_var_1) -> +	case happyOut315 happy_x_3 of { (HappyWrap315 happy_var_3) -> +	happyIn30+		 (sLL (reLoc happy_var_1) (reLoc happy_var_3) $ Renaming (reLoc happy_var_1) (Just (reLoc happy_var_3))+	)}}++happyReduce_50 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_50 = happySpecReduce_1  14# happyReduction_50+happyReduction_50 happy_x_1+	 =  case happyOut315 happy_x_1 of { (HappyWrap315 happy_var_1) -> +	happyIn30+		 (sL1 (reLoc happy_var_1)            $ Renaming (reLoc happy_var_1) Nothing+	)}++happyReduce_51 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_51 = happySpecReduce_3  15# happyReduction_51+happyReduction_51 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut32 happy_x_2 of { (HappyWrap32 happy_var_2) -> +	happyIn31+		 (happy_var_2+	)}++happyReduce_52 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_52 = happySpecReduce_3  15# happyReduction_52+happyReduction_52 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut32 happy_x_2 of { (HappyWrap32 happy_var_2) -> +	happyIn31+		 (happy_var_2+	)}++happyReduce_53 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_53 = happySpecReduce_3  16# happyReduction_53+happyReduction_53 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut32 happy_x_1 of { (HappyWrap32 happy_var_1) -> +	case happyOut33 happy_x_3 of { (HappyWrap33 happy_var_3) -> +	happyIn32+		 (happy_var_1 `appOL` unitOL happy_var_3+	)}}++happyReduce_54 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_54 = happySpecReduce_2  16# happyReduction_54+happyReduction_54 happy_x_2+	happy_x_1+	 =  case happyOut32 happy_x_1 of { (HappyWrap32 happy_var_1) -> +	happyIn32+		 (happy_var_1+	)}++happyReduce_55 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_55 = happySpecReduce_1  16# happyReduction_55+happyReduction_55 happy_x_1+	 =  case happyOut33 happy_x_1 of { (HappyWrap33 happy_var_1) -> +	happyIn32+		 (unitOL happy_var_1+	)}++happyReduce_56 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_56 = happyReduce 7# 17# happyReduction_56+happyReduction_56 (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 happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut63 happy_x_2 of { (HappyWrap63 happy_var_2) -> +	case happyOut315 happy_x_3 of { (HappyWrap315 happy_var_3) -> +	case happyOut38 happy_x_4 of { (HappyWrap38 happy_var_4) -> +	case happyOut48 happy_x_5 of { (HappyWrap48 happy_var_5) -> +	case happyOut39 happy_x_7 of { (HappyWrap39 happy_var_7) -> +	happyIn33+		 (sL1 happy_var_1 $ DeclD+                 (case snd happy_var_2 of+                   NotBoot -> HsSrcFile+                   IsBoot  -> HsBootFile)+                 (reLoc happy_var_3)+                 (sL1 happy_var_1 (HsModule noAnn (thdOf3 happy_var_7) (Just happy_var_3) happy_var_5 (fst $ sndOf3 happy_var_7) (snd $ sndOf3 happy_var_7) happy_var_4 Nothing))+	) `HappyStk` happyRest}}}}}}++happyReduce_57 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_57 = happyReduce 6# 17# 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 happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut315 happy_x_2 of { (HappyWrap315 happy_var_2) -> +	case happyOut38 happy_x_3 of { (HappyWrap38 happy_var_3) -> +	case happyOut48 happy_x_4 of { (HappyWrap48 happy_var_4) -> +	case happyOut39 happy_x_6 of { (HappyWrap39 happy_var_6) -> +	happyIn33+		 (sL1 happy_var_1 $ DeclD+                 HsigFile+                 (reLoc happy_var_2)+                 (sL1 happy_var_1 (HsModule noAnn (thdOf3 happy_var_6) (Just happy_var_2) happy_var_4 (fst $ sndOf3 happy_var_6) (snd $ sndOf3 happy_var_6) happy_var_3 Nothing))+	) `HappyStk` happyRest}}}}}++happyReduce_58 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_58 = happySpecReduce_3  17# happyReduction_58+happyReduction_58 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut20 happy_x_2 of { (HappyWrap20 happy_var_2) -> +	case happyOut28 happy_x_3 of { (HappyWrap28 happy_var_3) -> +	happyIn33+		 (sL1 happy_var_1 $ IncludeD (IncludeDecl { idUnitId = happy_var_2+                                              , idModRenaming = happy_var_3+                                              , idSignatureInclude = False })+	)}}}++happyReduce_59 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_59 = happySpecReduce_3  17# happyReduction_59+happyReduction_59 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut20 happy_x_3 of { (HappyWrap20 happy_var_3) -> +	happyIn33+		 (sL1 happy_var_1 $ IncludeD (IncludeDecl { idUnitId = happy_var_3+                                              , idModRenaming = Nothing+                                              , idSignatureInclude = True })+	)}}++happyReduce_60 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_60 = happyMonadReduce 6# 18# happyReduction_60+happyReduction_60 (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_1 of { happy_var_1 -> +	case happyOut315 happy_x_2 of { (HappyWrap315 happy_var_2) -> +	case happyOut38 happy_x_3 of { (HappyWrap38 happy_var_3) -> +	case happyOut48 happy_x_4 of { (HappyWrap48 happy_var_4) -> +	case happyOutTok happy_x_5 of { happy_var_5 -> +	case happyOut39 happy_x_6 of { (HappyWrap39 happy_var_6) -> +	( fileSrcSpan >>= \ loc ->+                acs (\cs-> (L loc (HsModule (EpAnn (spanAsAnchor loc) (AnnsModule [mj AnnSignature happy_var_1, mj AnnWhere happy_var_5] (fstOf3 happy_var_6)) cs)+                              (thdOf3 happy_var_6) (Just happy_var_2) happy_var_4 (fst $ sndOf3 happy_var_6)+                              (snd $ sndOf3 happy_var_6) happy_var_3 Nothing))+                    ))}}}}}})+	) (\r -> happyReturn (happyIn34 r))++happyReduce_61 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_61 = happyMonadReduce 6# 19# happyReduction_61+happyReduction_61 (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_1 of { happy_var_1 -> +	case happyOut315 happy_x_2 of { (HappyWrap315 happy_var_2) -> +	case happyOut38 happy_x_3 of { (HappyWrap38 happy_var_3) -> +	case happyOut48 happy_x_4 of { (HappyWrap48 happy_var_4) -> +	case happyOutTok happy_x_5 of { happy_var_5 -> +	case happyOut39 happy_x_6 of { (HappyWrap39 happy_var_6) -> +	( fileSrcSpan >>= \ loc ->+                acsFinal (\cs -> (L loc (HsModule (EpAnn (spanAsAnchor loc) (AnnsModule [mj AnnModule happy_var_1, mj AnnWhere happy_var_5] (fstOf3 happy_var_6)) cs)+                               (thdOf3 happy_var_6) (Just happy_var_2) happy_var_4 (fst $ sndOf3 happy_var_6)+                              (snd $ sndOf3 happy_var_6) happy_var_3 Nothing)+                    )))}}}}}})+	) (\r -> happyReturn (happyIn35 r))++happyReduce_62 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_62 = happyMonadReduce 1# 19# happyReduction_62+happyReduction_62 (happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut40 happy_x_1 of { (HappyWrap40 happy_var_1) -> +	( fileSrcSpan >>= \ loc ->+                   acsFinal (\cs -> (L loc (HsModule (EpAnn (spanAsAnchor loc) (AnnsModule [] (fstOf3 happy_var_1)) cs)+                                (thdOf3 happy_var_1) Nothing Nothing+                               (fst $ sndOf3 happy_var_1) (snd $ sndOf3 happy_var_1) Nothing Nothing))))})+	) (\r -> happyReturn (happyIn35 r))++happyReduce_63 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_63 = happyMonadReduce 0# 20# happyReduction_63+happyReduction_63 (happyRest) tk+	 = happyThen ((( pushModuleContext))+	) (\r -> happyReturn (happyIn36 r))++happyReduce_64 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_64 = happyMonadReduce 0# 21# happyReduction_64+happyReduction_64 (happyRest) tk+	 = happyThen ((( pushModuleContext))+	) (\r -> happyReturn (happyIn37 r))++happyReduce_65 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_65 = happyMonadReduce 3# 22# happyReduction_65+happyReduction_65 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut143 happy_x_2 of { (HappyWrap143 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	( fmap Just $ amsrp (sLL happy_var_1 happy_var_3 $ DeprecatedTxt (sL1 happy_var_1 $ getDEPRECATED_PRAGs happy_var_1) (map stringLiteralToHsDocWst $ snd $ unLoc happy_var_2))+                              (AnnPragma (mo happy_var_1) (mc happy_var_3) (fst $ unLoc happy_var_2)))}}})+	) (\r -> happyReturn (happyIn38 r))++happyReduce_66 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_66 = happyMonadReduce 3# 22# happyReduction_66+happyReduction_66 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut143 happy_x_2 of { (HappyWrap143 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	( fmap Just $ amsrp (sLL happy_var_1 happy_var_3 $ WarningTxt (sL1 happy_var_1 $ getWARNING_PRAGs happy_var_1) (map stringLiteralToHsDocWst $ snd $ unLoc happy_var_2))+                                 (AnnPragma (mo happy_var_1) (mc happy_var_3) (fst $ unLoc happy_var_2)))}}})+	) (\r -> happyReturn (happyIn38 r))++happyReduce_67 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_67 = happySpecReduce_0  22# happyReduction_67+happyReduction_67  =  happyIn38+		 (Nothing+	)++happyReduce_68 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_68 = happySpecReduce_3  23# happyReduction_68+happyReduction_68 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut41 happy_x_2 of { (HappyWrap41 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	happyIn39+		 ((AnnList Nothing (Just $ moc happy_var_1) (Just $ mcc happy_var_3) [] (fst happy_var_2)+                                         , snd happy_var_2, ExplicitBraces)+	)}}}++happyReduce_69 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_69 = happySpecReduce_3  23# happyReduction_69+happyReduction_69 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut41 happy_x_2 of { (HappyWrap41 happy_var_2) -> +	happyIn39+		 ((AnnList Nothing Nothing Nothing [] (fst happy_var_2)+                                         , snd happy_var_2, VirtualBraces (getVOCURLY happy_var_1))+	)}}++happyReduce_70 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_70 = happySpecReduce_3  24# happyReduction_70+happyReduction_70 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut41 happy_x_2 of { (HappyWrap41 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	happyIn40+		 ((AnnList Nothing (Just $ moc happy_var_1) (Just $ mcc happy_var_3) [] (fst happy_var_2)+                                                  , snd happy_var_2, ExplicitBraces)+	)}}}++happyReduce_71 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_71 = happySpecReduce_3  24# happyReduction_71+happyReduction_71 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut41 happy_x_2 of { (HappyWrap41 happy_var_2) -> +	happyIn40+		 ((AnnList Nothing Nothing Nothing [] [], snd happy_var_2, VirtualBraces leftmostColumn)+	)}++happyReduce_72 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_72 = happySpecReduce_2  25# happyReduction_72+happyReduction_72 happy_x_2+	happy_x_1+	 =  case happyOut59 happy_x_1 of { (HappyWrap59 happy_var_1) -> +	case happyOut42 happy_x_2 of { (HappyWrap42 happy_var_2) -> +	happyIn41+		 ((reverse happy_var_1, happy_var_2)+	)}}++happyReduce_73 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_73 = happySpecReduce_2  26# happyReduction_73+happyReduction_73 happy_x_2+	happy_x_1+	 =  case happyOut61 happy_x_1 of { (HappyWrap61 happy_var_1) -> +	case happyOut76 happy_x_2 of { (HappyWrap76 happy_var_2) -> +	happyIn42+		 ((reverse happy_var_1, cvTopDecls happy_var_2)+	)}}++happyReduce_74 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_74 = happySpecReduce_2  26# happyReduction_74+happyReduction_74 happy_x_2+	happy_x_1+	 =  case happyOut61 happy_x_1 of { (HappyWrap61 happy_var_1) -> +	case happyOut75 happy_x_2 of { (HappyWrap75 happy_var_2) -> +	happyIn42+		 ((reverse happy_var_1, cvTopDecls happy_var_2)+	)}}++happyReduce_75 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_75 = happySpecReduce_1  26# happyReduction_75+happyReduction_75 happy_x_1+	 =  case happyOut60 happy_x_1 of { (HappyWrap60 happy_var_1) -> +	happyIn42+		 ((reverse happy_var_1, [])+	)}++happyReduce_76 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_76 = happyMonadReduce 6# 27# happyReduction_76+happyReduction_76 (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_1 of { happy_var_1 -> +	case happyOut315 happy_x_2 of { (HappyWrap315 happy_var_2) -> +	case happyOut38 happy_x_3 of { (HappyWrap38 happy_var_3) -> +	case happyOut48 happy_x_4 of { (HappyWrap48 happy_var_4) -> +	case happyOutTok happy_x_5 of { happy_var_5 -> +	case happyOut44 happy_x_6 of { (HappyWrap44 happy_var_6) -> +	( fileSrcSpan >>= \ loc ->+                   acs (\cs -> (L loc (HsModule (EpAnn (spanAsAnchor loc) (AnnsModule [mj AnnModule happy_var_1,mj AnnWhere happy_var_5] (AnnList Nothing Nothing Nothing [] [])) cs)+                              NoLayoutInfo (Just happy_var_2) happy_var_4 happy_var_6 [] happy_var_3 Nothing+                          ))))}}}}}})+	) (\r -> happyReturn (happyIn43 r))++happyReduce_77 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_77 = happyMonadReduce 6# 27# happyReduction_77+happyReduction_77 (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_1 of { happy_var_1 -> +	case happyOut315 happy_x_2 of { (HappyWrap315 happy_var_2) -> +	case happyOut38 happy_x_3 of { (HappyWrap38 happy_var_3) -> +	case happyOut48 happy_x_4 of { (HappyWrap48 happy_var_4) -> +	case happyOutTok happy_x_5 of { happy_var_5 -> +	case happyOut44 happy_x_6 of { (HappyWrap44 happy_var_6) -> +	( fileSrcSpan >>= \ loc ->+                   acs (\cs -> (L loc (HsModule (EpAnn (spanAsAnchor loc) (AnnsModule [mj AnnModule happy_var_1,mj AnnWhere happy_var_5] (AnnList Nothing Nothing Nothing [] [])) cs)+                           NoLayoutInfo (Just happy_var_2) happy_var_4 happy_var_6 [] happy_var_3 Nothing+                          ))))}}}}}})+	) (\r -> happyReturn (happyIn43 r))++happyReduce_78 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_78 = happyMonadReduce 1# 27# happyReduction_78+happyReduction_78 (happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut45 happy_x_1 of { (HappyWrap45 happy_var_1) -> +	( fileSrcSpan >>= \ loc ->+                   return (L loc (HsModule noAnn NoLayoutInfo Nothing Nothing happy_var_1 [] Nothing+                          Nothing)))})+	) (\r -> happyReturn (happyIn43 r))++happyReduce_79 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_79 = happySpecReduce_2  28# happyReduction_79+happyReduction_79 happy_x_2+	happy_x_1+	 =  case happyOut46 happy_x_2 of { (HappyWrap46 happy_var_2) -> +	happyIn44+		 (happy_var_2+	)}++happyReduce_80 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_80 = happySpecReduce_2  28# happyReduction_80+happyReduction_80 happy_x_2+	happy_x_1+	 =  case happyOut46 happy_x_2 of { (HappyWrap46 happy_var_2) -> +	happyIn44+		 (happy_var_2+	)}++happyReduce_81 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_81 = happySpecReduce_2  29# happyReduction_81+happyReduction_81 happy_x_2+	happy_x_1+	 =  case happyOut46 happy_x_2 of { (HappyWrap46 happy_var_2) -> +	happyIn45+		 (happy_var_2+	)}++happyReduce_82 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_82 = happySpecReduce_2  29# happyReduction_82+happyReduction_82 happy_x_2+	happy_x_1+	 =  case happyOut46 happy_x_2 of { (HappyWrap46 happy_var_2) -> +	happyIn45+		 (happy_var_2+	)}++happyReduce_83 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_83 = happySpecReduce_2  30# happyReduction_83+happyReduction_83 happy_x_2+	happy_x_1+	 =  case happyOut47 happy_x_2 of { (HappyWrap47 happy_var_2) -> +	happyIn46+		 (happy_var_2+	)}++happyReduce_84 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_84 = happySpecReduce_1  31# happyReduction_84+happyReduction_84 happy_x_1+	 =  case happyOut61 happy_x_1 of { (HappyWrap61 happy_var_1) -> +	happyIn47+		 (happy_var_1+	)}++happyReduce_85 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_85 = happySpecReduce_1  31# happyReduction_85+happyReduction_85 happy_x_1+	 =  case happyOut60 happy_x_1 of { (HappyWrap60 happy_var_1) -> +	happyIn47+		 (happy_var_1+	)}++happyReduce_86 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_86 = happyMonadReduce 3# 32# happyReduction_86+happyReduction_86 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut49 happy_x_2 of { (HappyWrap49 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	( fmap Just $ amsrl (sLL happy_var_1 happy_var_3 (fromOL $ snd happy_var_2))+                                        (AnnList Nothing (Just $ mop happy_var_1) (Just $ mcp happy_var_3) (fst happy_var_2) []))}}})+	) (\r -> happyReturn (happyIn48 r))++happyReduce_87 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_87 = happySpecReduce_0  32# happyReduction_87+happyReduction_87  =  happyIn48+		 (Nothing+	)++happyReduce_88 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_88 = happySpecReduce_1  33# happyReduction_88+happyReduction_88 happy_x_1+	 =  case happyOut50 happy_x_1 of { (HappyWrap50 happy_var_1) -> +	happyIn49+		 (([], happy_var_1)+	)}++happyReduce_89 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_89 = happySpecReduce_0  33# happyReduction_89+happyReduction_89  =  happyIn49+		 (([], nilOL)+	)++happyReduce_90 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_90 = happyMonadReduce 2# 33# happyReduction_90+happyReduction_90 (happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut50 happy_x_1 of { (HappyWrap50 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	( case happy_var_1 of+                               SnocOL hs t -> do+                                 t' <- addTrailingCommaA t (gl happy_var_2)+                                 return ([], snocOL hs t'))}})+	) (\r -> happyReturn (happyIn49 r))++happyReduce_91 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_91 = happySpecReduce_1  33# happyReduction_91+happyReduction_91 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn49+		 (([mj AnnComma happy_var_1], nilOL)+	)}++happyReduce_92 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_92 = happyMonadReduce 3# 34# happyReduction_92+happyReduction_92 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut50 happy_x_1 of { (HappyWrap50 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut51 happy_x_3 of { (HappyWrap51 happy_var_3) -> +	( let ls = happy_var_1+                             in if isNilOL ls+                                  then return (ls `appOL` happy_var_3)+                                  else case ls of+                                         SnocOL hs t -> do+                                           t' <- addTrailingCommaA t (gl happy_var_2)+                                           return (snocOL hs t' `appOL` happy_var_3))}}})+	) (\r -> happyReturn (happyIn50 r))++happyReduce_93 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_93 = happySpecReduce_1  34# happyReduction_93+happyReduction_93 happy_x_1+	 =  case happyOut51 happy_x_1 of { (HappyWrap51 happy_var_1) -> +	happyIn50+		 (happy_var_1+	)}++happyReduce_94 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_94 = happyMonadReduce 2# 35# happyReduction_94+happyReduction_94 (happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut56 happy_x_1 of { (HappyWrap56 happy_var_1) -> +	case happyOut52 happy_x_2 of { (HappyWrap52 happy_var_2) -> +	( mkModuleImpExp (fst $ unLoc happy_var_2) happy_var_1 (snd $ unLoc happy_var_2)+                                          >>= \ie -> fmap (unitOL . reLocA) (return (sLL (reLoc happy_var_1) happy_var_2 ie)))}})+	) (\r -> happyReturn (happyIn51 r))++happyReduce_95 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_95 = happyMonadReduce 2# 35# happyReduction_95+happyReduction_95 (happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut315 happy_x_2 of { (HappyWrap315 happy_var_2) -> +	( fmap (unitOL . reLocA) (acs (\cs -> sLL happy_var_1 (reLoc happy_var_2) (IEModuleContents (EpAnn (glR happy_var_1) [mj AnnModule happy_var_1] cs) happy_var_2))))}})+	) (\r -> happyReturn (happyIn51 r))++happyReduce_96 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_96 = happySpecReduce_2  35# happyReduction_96+happyReduction_96 happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut268 happy_x_2 of { (HappyWrap268 happy_var_2) -> +	happyIn51+		 (unitOL (reLocA (sLL happy_var_1 (reLocN happy_var_2)+                                              (IEVar noExtField (sLLa happy_var_1 (reLocN happy_var_2) (IEPattern (glAA happy_var_1) happy_var_2)))))+	)}}++happyReduce_97 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_97 = happySpecReduce_0  36# happyReduction_97+happyReduction_97  =  happyIn52+		 (sL0 ([],ImpExpAbs)+	)++happyReduce_98 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_98 = happyMonadReduce 3# 36# happyReduction_98+happyReduction_98 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut53 happy_x_2 of { (HappyWrap53 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	( mkImpExpSubSpec (reverse (snd happy_var_2))+                                      >>= \(as,ie) -> return $ sLL happy_var_1 happy_var_3+                                            (as ++ [mop happy_var_1,mcp happy_var_3] ++ fst happy_var_2, ie))}}})+	) (\r -> happyReturn (happyIn52 r))++happyReduce_99 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_99 = happySpecReduce_0  37# happyReduction_99+happyReduction_99  =  happyIn53+		 (([],[])+	)++happyReduce_100 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_100 = happySpecReduce_1  37# happyReduction_100+happyReduction_100 happy_x_1+	 =  case happyOut54 happy_x_1 of { (HappyWrap54 happy_var_1) -> +	happyIn53+		 (happy_var_1+	)}++happyReduce_101 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_101 = happyMonadReduce 3# 38# happyReduction_101+happyReduction_101 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut54 happy_x_1 of { (HappyWrap54 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut55 happy_x_3 of { (HappyWrap55 happy_var_3) -> +	( case (snd happy_var_1) of+                                                    (l@(L la ImpExpQcWildcard):t) ->+                                                       do { l' <- addTrailingCommaA l (gl happy_var_2)+                                                          ; return ([mj AnnDotdot (reLoc l),+                                                                     mj AnnComma happy_var_2]+                                                                   ,(snd (unLoc happy_var_3)  : l' : t)) }+                                                    (l:t) ->+                                                       do { l' <- addTrailingCommaA l (gl happy_var_2)+                                                          ; return (fst happy_var_1 ++ fst (unLoc happy_var_3)+                                                                   , snd (unLoc happy_var_3) : l' : t)})}}})+	) (\r -> happyReturn (happyIn54 r))++happyReduce_102 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_102 = happySpecReduce_1  38# happyReduction_102+happyReduction_102 happy_x_1+	 =  case happyOut55 happy_x_1 of { (HappyWrap55 happy_var_1) -> +	happyIn54+		 ((fst (unLoc happy_var_1),[snd (unLoc happy_var_1)])+	)}++happyReduce_103 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_103 = happySpecReduce_1  39# happyReduction_103+happyReduction_103 happy_x_1+	 =  case happyOut56 happy_x_1 of { (HappyWrap56 happy_var_1) -> +	happyIn55+		 (sL1A happy_var_1 ([],happy_var_1)+	)}++happyReduce_104 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_104 = happySpecReduce_1  39# happyReduction_104+happyReduction_104 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn55+		 (sL1  happy_var_1 ([mj AnnDotdot happy_var_1], sL1a happy_var_1 ImpExpQcWildcard)+	)}++happyReduce_105 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_105 = happySpecReduce_1  40# happyReduction_105+happyReduction_105 happy_x_1+	 =  case happyOut57 happy_x_1 of { (HappyWrap57 happy_var_1) -> +	happyIn56+		 (reLocA $ sL1N happy_var_1 (ImpExpQcName happy_var_1)+	)}++happyReduce_106 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_106 = happyMonadReduce 2# 40# happyReduction_106+happyReduction_106 (happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut279 happy_x_2 of { (HappyWrap279 happy_var_2) -> +	( do { n <- mkTypeImpExp happy_var_2+                                          ; return $ sLLa happy_var_1 (reLocN happy_var_2) (ImpExpQcType (glAA happy_var_1) n) })}})+	) (\r -> happyReturn (happyIn56 r))++happyReduce_107 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_107 = happySpecReduce_1  41# happyReduction_107+happyReduction_107 happy_x_1+	 =  case happyOut298 happy_x_1 of { (HappyWrap298 happy_var_1) -> +	happyIn57+		 (happy_var_1+	)}++happyReduce_108 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_108 = happySpecReduce_1  41# happyReduction_108+happyReduction_108 happy_x_1+	 =  case happyOut280 happy_x_1 of { (HappyWrap280 happy_var_1) -> +	happyIn57+		 (happy_var_1+	)}++happyReduce_109 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_109 = happySpecReduce_2  42# happyReduction_109+happyReduction_109 happy_x_2+	happy_x_1+	 =  case happyOut58 happy_x_1 of { (HappyWrap58 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	happyIn58+		 (sLL happy_var_1 happy_var_2 $ if isZeroWidthSpan (gl happy_var_2) then (unLoc happy_var_1) else (AddSemiAnn (glAA happy_var_2) : (unLoc happy_var_1))+	)}}++happyReduce_110 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_110 = happySpecReduce_1  42# happyReduction_110+happyReduction_110 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn58+		 (sL1 happy_var_1 $ msemi happy_var_1+	)}++happyReduce_111 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_111 = happySpecReduce_2  43# happyReduction_111+happyReduction_111 happy_x_2+	happy_x_1+	 =  case happyOut59 happy_x_1 of { (HappyWrap59 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	happyIn59+		 (if isZeroWidthSpan (gl happy_var_2) then happy_var_1 else (AddSemiAnn (glAA happy_var_2) : happy_var_1)+	)}}++happyReduce_112 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_112 = happySpecReduce_0  43# happyReduction_112+happyReduction_112  =  happyIn59+		 ([]+	)++happyReduce_113 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_113 = happySpecReduce_2  44# happyReduction_113+happyReduction_113 happy_x_2+	happy_x_1+	 =  case happyOut61 happy_x_1 of { (HappyWrap61 happy_var_1) -> +	case happyOut62 happy_x_2 of { (HappyWrap62 happy_var_2) -> +	happyIn60+		 (happy_var_2 : happy_var_1+	)}}++happyReduce_114 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_114 = happyMonadReduce 3# 45# happyReduction_114+happyReduction_114 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut61 happy_x_1 of { (HappyWrap61 happy_var_1) -> +	case happyOut62 happy_x_2 of { (HappyWrap62 happy_var_2) -> +	case happyOut58 happy_x_3 of { (HappyWrap58 happy_var_3) -> +	( do { i <- amsAl happy_var_2 (comb2 (reLoc happy_var_2) happy_var_3) (reverse $ unLoc happy_var_3)+                                      ; return (i : happy_var_1)})}}})+	) (\r -> happyReturn (happyIn61 r))++happyReduce_115 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_115 = happySpecReduce_0  45# happyReduction_115+happyReduction_115  =  happyIn61+		 ([]+	)++happyReduce_116 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_116 = happyMonadReduce 9# 46# happyReduction_116+happyReduction_116 (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_1 of { happy_var_1 -> +	case happyOut63 happy_x_2 of { (HappyWrap63 happy_var_2) -> +	case happyOut64 happy_x_3 of { (HappyWrap64 happy_var_3) -> +	case happyOut66 happy_x_4 of { (HappyWrap66 happy_var_4) -> +	case happyOut65 happy_x_5 of { (HappyWrap65 happy_var_5) -> +	case happyOut315 happy_x_6 of { (HappyWrap315 happy_var_6) -> +	case happyOut66 happy_x_7 of { (HappyWrap66 happy_var_7) -> +	case happyOut67 happy_x_8 of { (HappyWrap67 happy_var_8) -> +	case happyOut68 happy_x_9 of { (HappyWrap68 happy_var_9) -> +	( do {+                  ; let { ; mPreQual = unLoc happy_var_4+                          ; mPostQual = unLoc happy_var_7 }+                  ; checkImportDecl mPreQual mPostQual+                  ; let anns+                         = EpAnnImportDecl+                             { importDeclAnnImport    = glAA happy_var_1+                             , importDeclAnnPragma    = fst $ fst happy_var_2+                             , importDeclAnnSafe      = fst happy_var_3+                             , importDeclAnnQualified = fst $ importDeclQualifiedStyle mPreQual mPostQual+                             , importDeclAnnPackage   = fst happy_var_5+                             , importDeclAnnAs        = fst happy_var_8+                             }+                  ; fmap reLocA $ acs (\cs -> L (comb5 happy_var_1 (reLoc happy_var_6) happy_var_7 (snd happy_var_8) happy_var_9) $+                      ImportDecl { ideclExt = EpAnn (glR happy_var_1) anns cs+                                  , ideclSourceSrc = snd $ fst happy_var_2+                                  , ideclName = happy_var_6, ideclPkgQual = snd happy_var_5+                                  , ideclSource = snd happy_var_2, ideclSafe = snd happy_var_3+                                  , ideclQualified = snd $ importDeclQualifiedStyle mPreQual mPostQual+                                  , ideclImplicit = False+                                  , ideclAs = unLoc (snd happy_var_8)+                                  , ideclHiding = unLoc happy_var_9 })+                  })}}}}}}}}})+	) (\r -> happyReturn (happyIn62 r))++happyReduce_117 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_117 = happySpecReduce_2  47# happyReduction_117+happyReduction_117 happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	happyIn63+		 (((Just (glAA happy_var_1,glAA happy_var_2),getSOURCE_PRAGs happy_var_1)+                                      , IsBoot)+	)}}++happyReduce_118 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_118 = happySpecReduce_0  47# happyReduction_118+happyReduction_118  =  happyIn63+		 (((Nothing,NoSourceText),NotBoot)+	)++happyReduce_119 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_119 = happySpecReduce_1  48# happyReduction_119+happyReduction_119 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn64+		 ((Just (glAA happy_var_1),True)+	)}++happyReduce_120 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_120 = happySpecReduce_0  48# happyReduction_120+happyReduction_120  =  happyIn64+		 ((Nothing,      False)+	)++happyReduce_121 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_121 = happyMonadReduce 1# 49# happyReduction_121+happyReduction_121 (happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	( do { let { pkgFS = getSTRING happy_var_1 }+                        ; unless (looksLikePackageName (unpackFS pkgFS)) $+                             addError $ mkPlainErrorMsgEnvelope (getLoc happy_var_1) $+                               (PsErrInvalidPackageName pkgFS)+                        ; return (Just (glAA happy_var_1), RawPkgQual (StringLiteral (getSTRINGs happy_var_1) pkgFS Nothing)) })})+	) (\r -> happyReturn (happyIn65 r))++happyReduce_122 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_122 = happySpecReduce_0  49# happyReduction_122+happyReduction_122  =  happyIn65+		 ((Nothing,NoRawPkgQual)+	)++happyReduce_123 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_123 = happySpecReduce_1  50# happyReduction_123+happyReduction_123 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn66+		 (sL1 happy_var_1 (Just (glAA happy_var_1))+	)}++happyReduce_124 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_124 = happySpecReduce_0  50# happyReduction_124+happyReduction_124  =  happyIn66+		 (noLoc Nothing+	)++happyReduce_125 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_125 = happySpecReduce_2  51# happyReduction_125+happyReduction_125 happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut315 happy_x_2 of { (HappyWrap315 happy_var_2) -> +	happyIn67+		 ((Just (glAA happy_var_1)+                                                 ,sLL happy_var_1 (reLoc happy_var_2) (Just happy_var_2))+	)}}++happyReduce_126 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_126 = happySpecReduce_0  51# happyReduction_126+happyReduction_126  =  happyIn67+		 ((Nothing,noLoc Nothing)+	)++happyReduce_127 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_127 = happyMonadReduce 1# 52# happyReduction_127+happyReduction_127 (happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut69 happy_x_1 of { (HappyWrap69 happy_var_1) -> +	( let (b, ie) = unLoc happy_var_1 in+                                       checkImportSpec ie+                                        >>= \checkedIe ->+                                          return (L (gl happy_var_1) (Just (b, checkedIe))))})+	) (\r -> happyReturn (happyIn68 r))++happyReduce_128 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_128 = happySpecReduce_0  52# happyReduction_128+happyReduction_128  =  happyIn68+		 (noLoc Nothing+	)++happyReduce_129 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_129 = happyMonadReduce 3# 53# happyReduction_129+happyReduction_129 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut49 happy_x_2 of { (HappyWrap49 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	( do { es <- amsrl (sLL happy_var_1 happy_var_3 $ fromOL $ snd happy_var_2)+                                                               (AnnList Nothing (Just $ mop happy_var_1) (Just $ mcp happy_var_3) (fst happy_var_2) [])+                                                  ; return $ sLL happy_var_1 happy_var_3 (False, es)})}}})+	) (\r -> happyReturn (happyIn69 r))++happyReduce_130 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_130 = happyMonadReduce 4# 53# happyReduction_130+happyReduction_130 (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 { happy_var_1 -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut49 happy_x_3 of { (HappyWrap49 happy_var_3) -> +	case happyOutTok happy_x_4 of { happy_var_4 -> +	( do { es <- amsrl (sLL happy_var_1 happy_var_4 $ fromOL $ snd happy_var_3)+                                                               (AnnList Nothing (Just $ mop happy_var_2) (Just $ mcp happy_var_4) (mj AnnHiding happy_var_1:fst happy_var_3) [])+                                                  ; return $ sLL happy_var_1 happy_var_4 (True, es)})}}}})+	) (\r -> happyReturn (happyIn69 r))++happyReduce_131 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_131 = happySpecReduce_0  54# happyReduction_131+happyReduction_131  =  happyIn70+		 (Nothing+	)++happyReduce_132 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_132 = happySpecReduce_1  54# happyReduction_132+happyReduction_132 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn70+		 (Just (sL1 happy_var_1 (getINTEGERs happy_var_1,fromInteger (il_value (getINTEGER happy_var_1))))+	)}++happyReduce_133 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_133 = happySpecReduce_1  55# happyReduction_133+happyReduction_133 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn71+		 (sL1 happy_var_1 InfixN+	)}++happyReduce_134 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_134 = happySpecReduce_1  55# happyReduction_134+happyReduction_134 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn71+		 (sL1 happy_var_1 InfixL+	)}++happyReduce_135 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_135 = happySpecReduce_1  55# happyReduction_135+happyReduction_135 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn71+		 (sL1 happy_var_1 InfixR+	)}++happyReduce_136 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_136 = happyMonadReduce 3# 56# happyReduction_136+happyReduction_136 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut72 happy_x_1 of { (HappyWrap72 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut287 happy_x_3 of { (HappyWrap287 happy_var_3) -> +	( case (unLoc happy_var_1) of+                                SnocOL hs t -> do+                                  t' <- addTrailingCommaN t (gl happy_var_2)+                                  return (sLL happy_var_1 (reLocN happy_var_3) (snocOL hs t' `appOL` unitOL happy_var_3)))}}})+	) (\r -> happyReturn (happyIn72 r))++happyReduce_137 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_137 = happySpecReduce_1  56# happyReduction_137+happyReduction_137 happy_x_1+	 =  case happyOut287 happy_x_1 of { (HappyWrap287 happy_var_1) -> +	happyIn72+		 (sL1N happy_var_1 (unitOL happy_var_1)+	)}++happyReduce_138 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_138 = happySpecReduce_2  57# happyReduction_138+happyReduction_138 happy_x_2+	happy_x_1+	 =  case happyOut74 happy_x_1 of { (HappyWrap74 happy_var_1) -> +	case happyOut78 happy_x_2 of { (HappyWrap78 happy_var_2) -> +	happyIn73+		 (happy_var_1 `snocOL` happy_var_2+	)}}++happyReduce_139 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_139 = happyMonadReduce 3# 58# happyReduction_139+happyReduction_139 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut74 happy_x_1 of { (HappyWrap74 happy_var_1) -> +	case happyOut78 happy_x_2 of { (HappyWrap78 happy_var_2) -> +	case happyOut58 happy_x_3 of { (HappyWrap58 happy_var_3) -> +	( do { t <- amsAl happy_var_2 (comb2 (reLoc happy_var_2) happy_var_3) (reverse $ unLoc happy_var_3)+                                             ; return (happy_var_1 `snocOL` t) })}}})+	) (\r -> happyReturn (happyIn74 r))++happyReduce_140 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_140 = happySpecReduce_0  58# happyReduction_140+happyReduction_140  =  happyIn74+		 (nilOL+	)++happyReduce_141 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_141 = happySpecReduce_2  59# happyReduction_141+happyReduction_141 happy_x_2+	happy_x_1+	 =  case happyOut76 happy_x_1 of { (HappyWrap76 happy_var_1) -> +	case happyOut77 happy_x_2 of { (HappyWrap77 happy_var_2) -> +	happyIn75+		 (happy_var_1 `snocOL` happy_var_2+	)}}++happyReduce_142 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_142 = happyMonadReduce 3# 60# happyReduction_142+happyReduction_142 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut76 happy_x_1 of { (HappyWrap76 happy_var_1) -> +	case happyOut77 happy_x_2 of { (HappyWrap77 happy_var_2) -> +	case happyOut58 happy_x_3 of { (HappyWrap58 happy_var_3) -> +	( do { t <- amsAl happy_var_2 (comb2 (reLoc happy_var_2) happy_var_3) (reverse $ unLoc happy_var_3)+                                                   ; return (happy_var_1 `snocOL` t) })}}})+	) (\r -> happyReturn (happyIn76 r))++happyReduce_143 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_143 = happySpecReduce_0  60# happyReduction_143+happyReduction_143  =  happyIn76+		 (nilOL+	)++happyReduce_144 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_144 = happyMonadReduce 1# 61# happyReduction_144+happyReduction_144 (happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut78 happy_x_1 of { (HappyWrap78 happy_var_1) -> +	( commentsPA happy_var_1)})+	) (\r -> happyReturn (happyIn77 r))++happyReduce_145 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_145 = happySpecReduce_1  62# happyReduction_145+happyReduction_145 happy_x_1+	 =  case happyOut79 happy_x_1 of { (HappyWrap79 happy_var_1) -> +	happyIn78+		 (sL1 happy_var_1 (TyClD noExtField (unLoc happy_var_1))+	)}++happyReduce_146 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_146 = happySpecReduce_1  62# happyReduction_146+happyReduction_146 happy_x_1+	 =  case happyOut80 happy_x_1 of { (HappyWrap80 happy_var_1) -> +	happyIn78+		 (sL1 happy_var_1 (TyClD noExtField (unLoc happy_var_1))+	)}++happyReduce_147 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_147 = happySpecReduce_1  62# happyReduction_147+happyReduction_147 happy_x_1+	 =  case happyOut81 happy_x_1 of { (HappyWrap81 happy_var_1) -> +	happyIn78+		 (sL1 happy_var_1 (KindSigD noExtField (unLoc happy_var_1))+	)}++happyReduce_148 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_148 = happySpecReduce_1  62# happyReduction_148+happyReduction_148 happy_x_1+	 =  case happyOut83 happy_x_1 of { (HappyWrap83 happy_var_1) -> +	happyIn78+		 (sL1 happy_var_1 (InstD noExtField (unLoc happy_var_1))+	)}++happyReduce_149 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_149 = happySpecReduce_1  62# happyReduction_149+happyReduction_149 happy_x_1+	 =  case happyOut107 happy_x_1 of { (HappyWrap107 happy_var_1) -> +	happyIn78+		 (sL1 happy_var_1 (DerivD noExtField (unLoc happy_var_1))+	)}++happyReduce_150 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_150 = happySpecReduce_1  62# happyReduction_150+happyReduction_150 happy_x_1+	 =  case happyOut108 happy_x_1 of { (HappyWrap108 happy_var_1) -> +	happyIn78+		 (sL1 happy_var_1 (RoleAnnotD noExtField (unLoc happy_var_1))+	)}++happyReduce_151 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_151 = happyMonadReduce 4# 62# happyReduction_151+happyReduction_151 (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 { happy_var_1 -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut171 happy_x_3 of { (HappyWrap171 happy_var_3) -> +	case happyOutTok happy_x_4 of { happy_var_4 -> +	( acsA (\cs -> sLL happy_var_1 happy_var_4+                                                    (DefD noExtField (DefaultDecl (EpAnn (glR happy_var_1) [mj AnnDefault happy_var_1,mop happy_var_2,mcp happy_var_4] cs) happy_var_3))))}}}})+	) (\r -> happyReturn (happyIn78 r))++happyReduce_152 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_152 = happyMonadReduce 2# 62# happyReduction_152+happyReduction_152 (happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut146 happy_x_2 of { (HappyWrap146 happy_var_2) -> +	( acsA (\cs -> sLL happy_var_1 happy_var_2 ((snd $ unLoc happy_var_2) (EpAnn (glR happy_var_1) (mj AnnForeign happy_var_1:(fst $ unLoc happy_var_2)) cs))))}})+	) (\r -> happyReturn (happyIn78 r))++happyReduce_153 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_153 = happyMonadReduce 3# 62# happyReduction_153+happyReduction_153 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut141 happy_x_2 of { (HappyWrap141 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	( acsA (\cs -> sLL happy_var_1 happy_var_3 $ WarningD noExtField (Warnings (EpAnn (glR happy_var_1) [mo happy_var_1,mc happy_var_3] cs) (getDEPRECATED_PRAGs happy_var_1) (fromOL happy_var_2))))}}})+	) (\r -> happyReturn (happyIn78 r))++happyReduce_154 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_154 = happyMonadReduce 3# 62# happyReduction_154+happyReduction_154 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut139 happy_x_2 of { (HappyWrap139 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	( acsA (\cs -> sLL happy_var_1 happy_var_3 $ WarningD noExtField (Warnings (EpAnn (glR happy_var_1) [mo happy_var_1,mc happy_var_3] cs) (getWARNING_PRAGs happy_var_1) (fromOL happy_var_2))))}}})+	) (\r -> happyReturn (happyIn78 r))++happyReduce_155 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_155 = happyMonadReduce 3# 62# happyReduction_155+happyReduction_155 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut131 happy_x_2 of { (HappyWrap131 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	( acsA (\cs -> sLL happy_var_1 happy_var_3 $ RuleD noExtField (HsRules (EpAnn (glR happy_var_1) [mo happy_var_1,mc happy_var_3] cs) (getRULES_PRAGs happy_var_1) (reverse happy_var_2))))}}})+	) (\r -> happyReturn (happyIn78 r))++happyReduce_156 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_156 = happySpecReduce_1  62# happyReduction_156+happyReduction_156 happy_x_1+	 =  case happyOut145 happy_x_1 of { (HappyWrap145 happy_var_1) -> +	happyIn78+		 (happy_var_1+	)}++happyReduce_157 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_157 = happySpecReduce_1  62# happyReduction_157+happyReduction_157 happy_x_1+	 =  case happyOut197 happy_x_1 of { (HappyWrap197 happy_var_1) -> +	happyIn78+		 (happy_var_1+	)}++happyReduce_158 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_158 = happyMonadReduce 1# 62# happyReduction_158+happyReduction_158 (happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut207 happy_x_1 of { (HappyWrap207 happy_var_1) -> +	( runPV (unECP happy_var_1) >>= \ happy_var_1 ->+                                                    do { d <- mkSpliceDecl happy_var_1+                                                       ; commentsPA d })})+	) (\r -> happyReturn (happyIn78 r))++happyReduce_159 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_159 = happyMonadReduce 4# 63# happyReduction_159+happyReduction_159 (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 { happy_var_1 -> +	case happyOut104 happy_x_2 of { (HappyWrap104 happy_var_2) -> +	case happyOut177 happy_x_3 of { (HappyWrap177 happy_var_3) -> +	case happyOut122 happy_x_4 of { (HappyWrap122 happy_var_4) -> +	( (mkClassDecl (comb4 happy_var_1 happy_var_2 happy_var_3 happy_var_4) happy_var_2 happy_var_3 (sndOf3 $ unLoc happy_var_4) (thdOf3 $ unLoc happy_var_4))+                        (mj AnnClass happy_var_1:(fst $ unLoc happy_var_3)++(fstOf3 $ unLoc happy_var_4)))}}}})+	) (\r -> happyReturn (happyIn79 r))++happyReduce_160 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_160 = happyMonadReduce 4# 64# happyReduction_160+happyReduction_160 (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 { happy_var_1 -> +	case happyOut161 happy_x_2 of { (HappyWrap161 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	case happyOut158 happy_x_4 of { (HappyWrap158 happy_var_4) -> +	( mkTySynonym (comb2A happy_var_1 happy_var_4) happy_var_2 happy_var_4 [mj AnnType happy_var_1,mj AnnEqual happy_var_3])}}}})+	) (\r -> happyReturn (happyIn80 r))++happyReduce_161 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_161 = happyMonadReduce 6# 64# happyReduction_161+happyReduction_161 (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_1 of { happy_var_1 -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut161 happy_x_3 of { (HappyWrap161 happy_var_3) -> +	case happyOut102 happy_x_4 of { (HappyWrap102 happy_var_4) -> +	case happyOut88 happy_x_5 of { (HappyWrap88 happy_var_5) -> +	case happyOut91 happy_x_6 of { (HappyWrap91 happy_var_6) -> +	( mkFamDecl (comb5 happy_var_1 (reLoc happy_var_3) happy_var_4 happy_var_5 happy_var_6) (snd $ unLoc happy_var_6) TopLevel happy_var_3+                                   (snd $ unLoc happy_var_4) (snd $ unLoc happy_var_5)+                           (mj AnnType happy_var_1:mj AnnFamily happy_var_2:(fst $ unLoc happy_var_4)+                           ++ (fst $ unLoc happy_var_5) ++ (fst $ unLoc happy_var_6)))}}}}}})+	) (\r -> happyReturn (happyIn80 r))++happyReduce_162 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_162 = happyMonadReduce 5# 64# happyReduction_162+happyReduction_162 (happy_x_5 `HappyStk`+	happy_x_4 `HappyStk`+	happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut99 happy_x_1 of { (HappyWrap99 happy_var_1) -> +	case happyOut106 happy_x_2 of { (HappyWrap106 happy_var_2) -> +	case happyOut104 happy_x_3 of { (HappyWrap104 happy_var_3) -> +	case happyOut185 happy_x_4 of { (HappyWrap185 happy_var_4) -> +	case happyOut193 happy_x_5 of { (HappyWrap193 happy_var_5) -> +	( mkTyData (comb4 happy_var_1 happy_var_3 happy_var_4 happy_var_5) (snd $ unLoc happy_var_1) happy_var_2 happy_var_3+                           Nothing (reverse (snd $ unLoc happy_var_4))+                                   (fmap reverse happy_var_5)+                           ((fst $ unLoc happy_var_1):(fst $ unLoc happy_var_4)))}}}}})+	) (\r -> happyReturn (happyIn80 r))++happyReduce_163 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_163 = happyMonadReduce 6# 64# happyReduction_163+happyReduction_163 (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 happyOut99 happy_x_1 of { (HappyWrap99 happy_var_1) -> +	case happyOut106 happy_x_2 of { (HappyWrap106 happy_var_2) -> +	case happyOut104 happy_x_3 of { (HappyWrap104 happy_var_3) -> +	case happyOut100 happy_x_4 of { (HappyWrap100 happy_var_4) -> +	case happyOut182 happy_x_5 of { (HappyWrap182 happy_var_5) -> +	case happyOut193 happy_x_6 of { (HappyWrap193 happy_var_6) -> +	( mkTyData (comb4 happy_var_1 happy_var_3 happy_var_5 happy_var_6) (snd $ unLoc happy_var_1) happy_var_2 happy_var_3+                            (snd $ unLoc happy_var_4) (snd $ unLoc happy_var_5)+                            (fmap reverse happy_var_6)+                            ((fst $ unLoc happy_var_1):(fst $ unLoc happy_var_4)++(fst $ unLoc happy_var_5)))}}}}}})+	) (\r -> happyReturn (happyIn80 r))++happyReduce_164 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_164 = happyMonadReduce 4# 64# happyReduction_164+happyReduction_164 (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 { happy_var_1 -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut161 happy_x_3 of { (HappyWrap161 happy_var_3) -> +	case happyOut101 happy_x_4 of { (HappyWrap101 happy_var_4) -> +	( mkFamDecl (comb3 happy_var_1 happy_var_2 happy_var_4) DataFamily TopLevel happy_var_3+                                   (snd $ unLoc happy_var_4) Nothing+                          (mj AnnData happy_var_1:mj AnnFamily happy_var_2:(fst $ unLoc happy_var_4)))}}}})+	) (\r -> happyReturn (happyIn80 r))++happyReduce_165 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_165 = happyMonadReduce 4# 65# happyReduction_165+happyReduction_165 (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 { happy_var_1 -> +	case happyOut82 happy_x_2 of { (HappyWrap82 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	case happyOut152 happy_x_4 of { (HappyWrap152 happy_var_4) -> +	( mkStandaloneKindSig (comb2A happy_var_1 happy_var_4) (L (gl happy_var_2) $ unLoc happy_var_2) happy_var_4+               [mj AnnType happy_var_1,mu AnnDcolon happy_var_3])}}}})+	) (\r -> happyReturn (happyIn81 r))++happyReduce_166 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_166 = happyMonadReduce 3# 66# happyReduction_166+happyReduction_166 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut82 happy_x_1 of { (HappyWrap82 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut279 happy_x_3 of { (HappyWrap279 happy_var_3) -> +	( case unLoc happy_var_1 of+           (h:t) -> do+             h' <- addTrailingCommaN h (gl happy_var_2)+             return (sLL happy_var_1 (reLocN happy_var_3) (happy_var_3 : h' : t)))}}})+	) (\r -> happyReturn (happyIn82 r))++happyReduce_167 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_167 = happySpecReduce_1  66# happyReduction_167+happyReduction_167 happy_x_1+	 =  case happyOut279 happy_x_1 of { (HappyWrap279 happy_var_1) -> +	happyIn82+		 (sL1N happy_var_1 [happy_var_1]+	)}++happyReduce_168 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_168 = happyMonadReduce 4# 67# happyReduction_168+happyReduction_168 (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 { happy_var_1 -> +	case happyOut84 happy_x_2 of { (HappyWrap84 happy_var_2) -> +	case happyOut169 happy_x_3 of { (HappyWrap169 happy_var_3) -> +	case happyOut126 happy_x_4 of { (HappyWrap126 happy_var_4) -> +	( do { (binds, sigs, _, ats, adts, _) <- cvBindsAndSigs (snd $ unLoc happy_var_4)+             ; let anns = (mj AnnInstance happy_var_1 : (fst $ unLoc happy_var_4))+             ; let cid cs = ClsInstDecl+                                     { cid_ext = (EpAnn (glR happy_var_1) anns cs, NoAnnSortKey)+                                     , cid_poly_ty = happy_var_3, cid_binds = binds+                                     , cid_sigs = mkClassOpSigs sigs+                                     , cid_tyfam_insts = ats+                                     , cid_overlap_mode = happy_var_2+                                     , cid_datafam_insts = adts }+             ; acsA (\cs -> L (comb3 happy_var_1 (reLoc happy_var_3) happy_var_4)+                             (ClsInstD { cid_d_ext = noExtField, cid_inst = cid cs }))+                   })}}}})+	) (\r -> happyReturn (happyIn83 r))++happyReduce_169 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_169 = happyMonadReduce 3# 67# happyReduction_169+happyReduction_169 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut94 happy_x_3 of { (HappyWrap94 happy_var_3) -> +	( mkTyFamInst (comb2A happy_var_1 happy_var_3) (unLoc happy_var_3)+                        (mj AnnType happy_var_1:mj AnnInstance happy_var_2:[]))}}})+	) (\r -> happyReturn (happyIn83 r))++happyReduce_170 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_170 = happyMonadReduce 6# 67# happyReduction_170+happyReduction_170 (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 happyOut99 happy_x_1 of { (HappyWrap99 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut106 happy_x_3 of { (HappyWrap106 happy_var_3) -> +	case happyOut105 happy_x_4 of { (HappyWrap105 happy_var_4) -> +	case happyOut185 happy_x_5 of { (HappyWrap185 happy_var_5) -> +	case happyOut193 happy_x_6 of { (HappyWrap193 happy_var_6) -> +	( mkDataFamInst (comb4 happy_var_1 happy_var_4 happy_var_5 happy_var_6) (snd $ unLoc happy_var_1) happy_var_3 (unLoc happy_var_4)+                                      Nothing (reverse (snd  $ unLoc happy_var_5))+                                              (fmap reverse happy_var_6)+                      ((fst $ unLoc happy_var_1):mj AnnInstance happy_var_2:(fst $ unLoc happy_var_5)))}}}}}})+	) (\r -> happyReturn (happyIn83 r))++happyReduce_171 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_171 = happyMonadReduce 7# 67# happyReduction_171+happyReduction_171 (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 happyOut99 happy_x_1 of { (HappyWrap99 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut106 happy_x_3 of { (HappyWrap106 happy_var_3) -> +	case happyOut105 happy_x_4 of { (HappyWrap105 happy_var_4) -> +	case happyOut100 happy_x_5 of { (HappyWrap100 happy_var_5) -> +	case happyOut182 happy_x_6 of { (HappyWrap182 happy_var_6) -> +	case happyOut193 happy_x_7 of { (HappyWrap193 happy_var_7) -> +	( mkDataFamInst (comb4 happy_var_1 happy_var_4 happy_var_6 happy_var_7) (snd $ unLoc happy_var_1) happy_var_3 (unLoc happy_var_4)+                                   (snd $ unLoc happy_var_5) (snd $ unLoc happy_var_6)+                                   (fmap reverse happy_var_7)+                     ((fst $ unLoc happy_var_1):mj AnnInstance happy_var_2+                       :(fst $ unLoc happy_var_5)++(fst $ unLoc happy_var_6)))}}}}}}})+	) (\r -> happyReturn (happyIn83 r))++happyReduce_172 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_172 = happyMonadReduce 2# 68# happyReduction_172+happyReduction_172 (happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	( fmap Just $ amsrp (sLL happy_var_1 happy_var_2 (Overlappable (getOVERLAPPABLE_PRAGs happy_var_1)))+                                       (AnnPragma (mo happy_var_1) (mc happy_var_2) []))}})+	) (\r -> happyReturn (happyIn84 r))++happyReduce_173 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_173 = happyMonadReduce 2# 68# happyReduction_173+happyReduction_173 (happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	( fmap Just $ amsrp (sLL happy_var_1 happy_var_2 (Overlapping (getOVERLAPPING_PRAGs happy_var_1)))+                                       (AnnPragma (mo happy_var_1) (mc happy_var_2) []))}})+	) (\r -> happyReturn (happyIn84 r))++happyReduce_174 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_174 = happyMonadReduce 2# 68# happyReduction_174+happyReduction_174 (happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	( fmap Just $ amsrp (sLL happy_var_1 happy_var_2 (Overlaps (getOVERLAPS_PRAGs happy_var_1)))+                                       (AnnPragma (mo happy_var_1) (mc happy_var_2) []))}})+	) (\r -> happyReturn (happyIn84 r))++happyReduce_175 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_175 = happyMonadReduce 2# 68# happyReduction_175+happyReduction_175 (happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	( fmap Just $ amsrp (sLL happy_var_1 happy_var_2 (Incoherent (getINCOHERENT_PRAGs happy_var_1)))+                                       (AnnPragma (mo happy_var_1) (mc happy_var_2) []))}})+	) (\r -> happyReturn (happyIn84 r))++happyReduce_176 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_176 = happySpecReduce_0  68# happyReduction_176+happyReduction_176  =  happyIn84+		 (Nothing+	)++happyReduce_177 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_177 = happyMonadReduce 1# 69# happyReduction_177+happyReduction_177 (happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	( acsA (\cs -> sL1 happy_var_1 (StockStrategy (EpAnn (glR happy_var_1) [mj AnnStock happy_var_1] cs))))})+	) (\r -> happyReturn (happyIn85 r))++happyReduce_178 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_178 = happyMonadReduce 1# 69# happyReduction_178+happyReduction_178 (happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	( acsA (\cs -> sL1 happy_var_1 (AnyclassStrategy (EpAnn (glR happy_var_1) [mj AnnAnyclass happy_var_1] cs))))})+	) (\r -> happyReturn (happyIn85 r))++happyReduce_179 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_179 = happyMonadReduce 1# 69# happyReduction_179+happyReduction_179 (happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	( acsA (\cs -> sL1 happy_var_1 (NewtypeStrategy (EpAnn (glR happy_var_1) [mj AnnNewtype happy_var_1] cs))))})+	) (\r -> happyReturn (happyIn85 r))++happyReduce_180 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_180 = happyMonadReduce 2# 70# happyReduction_180+happyReduction_180 (happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut152 happy_x_2 of { (HappyWrap152 happy_var_2) -> +	( acsA (\cs -> sLLlA happy_var_1 happy_var_2 (ViaStrategy (XViaStrategyPs (EpAnn (glR happy_var_1) [mj AnnVia happy_var_1] cs)+                                                                           happy_var_2))))}})+	) (\r -> happyReturn (happyIn86 r))++happyReduce_181 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_181 = happyMonadReduce 1# 71# happyReduction_181+happyReduction_181 (happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	( fmap Just $ acsA (\cs -> sL1 happy_var_1 (StockStrategy (EpAnn (glR happy_var_1) [mj AnnStock happy_var_1] cs))))})+	) (\r -> happyReturn (happyIn87 r))++happyReduce_182 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_182 = happyMonadReduce 1# 71# happyReduction_182+happyReduction_182 (happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	( fmap Just $ acsA (\cs -> sL1 happy_var_1 (AnyclassStrategy (EpAnn (glR happy_var_1) [mj AnnAnyclass happy_var_1] cs))))})+	) (\r -> happyReturn (happyIn87 r))++happyReduce_183 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_183 = happyMonadReduce 1# 71# happyReduction_183+happyReduction_183 (happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	( fmap Just $ acsA (\cs -> sL1 happy_var_1 (NewtypeStrategy (EpAnn (glR happy_var_1) [mj AnnNewtype happy_var_1] cs))))})+	) (\r -> happyReturn (happyIn87 r))++happyReduce_184 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_184 = happySpecReduce_1  71# happyReduction_184+happyReduction_184 happy_x_1+	 =  case happyOut86 happy_x_1 of { (HappyWrap86 happy_var_1) -> +	happyIn87+		 (Just happy_var_1+	)}++happyReduce_185 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_185 = happySpecReduce_0  71# happyReduction_185+happyReduction_185  =  happyIn87+		 (Nothing+	)++happyReduce_186 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_186 = happySpecReduce_0  72# happyReduction_186+happyReduction_186  =  happyIn88+		 (noLoc ([], Nothing)+	)++happyReduce_187 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_187 = happySpecReduce_2  72# happyReduction_187+happyReduction_187 happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut89 happy_x_2 of { (HappyWrap89 happy_var_2) -> +	happyIn88+		 (sLL happy_var_1 (reLoc happy_var_2) ([mj AnnVbar happy_var_1]+                                                , Just (happy_var_2))+	)}}++happyReduce_188 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_188 = happyMonadReduce 3# 73# happyReduction_188+happyReduction_188 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut296 happy_x_1 of { (HappyWrap296 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut90 happy_x_3 of { (HappyWrap90 happy_var_3) -> +	( acsA (\cs -> sLL (reLocN happy_var_1) happy_var_3 (InjectivityAnn (EpAnn (glNR happy_var_1) [mu AnnRarrow happy_var_2] cs) happy_var_1 (reverse (unLoc happy_var_3)))))}}})+	) (\r -> happyReturn (happyIn89 r))++happyReduce_189 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_189 = happySpecReduce_2  74# happyReduction_189+happyReduction_189 happy_x_2+	happy_x_1+	 =  case happyOut90 happy_x_1 of { (HappyWrap90 happy_var_1) -> +	case happyOut296 happy_x_2 of { (HappyWrap296 happy_var_2) -> +	happyIn90+		 (sLL happy_var_1 (reLocN happy_var_2) (happy_var_2 : unLoc happy_var_1)+	)}}++happyReduce_190 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_190 = happySpecReduce_1  74# happyReduction_190+happyReduction_190 happy_x_1+	 =  case happyOut296 happy_x_1 of { (HappyWrap296 happy_var_1) -> +	happyIn90+		 (sL1N  happy_var_1 [happy_var_1]+	)}++happyReduce_191 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_191 = happySpecReduce_0  75# happyReduction_191+happyReduction_191  =  happyIn91+		 (noLoc ([],OpenTypeFamily)+	)++happyReduce_192 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_192 = happySpecReduce_2  75# happyReduction_192+happyReduction_192 happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut92 happy_x_2 of { (HappyWrap92 happy_var_2) -> +	happyIn91+		 (sLL happy_var_1 happy_var_2 (mj AnnWhere happy_var_1:(fst $ unLoc happy_var_2)+                    ,ClosedTypeFamily (fmap reverse $ snd $ unLoc happy_var_2))+	)}}++happyReduce_193 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_193 = happySpecReduce_3  76# happyReduction_193+happyReduction_193 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut93 happy_x_2 of { (HappyWrap93 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	happyIn92+		 (sLL happy_var_1 happy_var_3 ([moc happy_var_1,mcc happy_var_3]+                                                ,Just (unLoc happy_var_2))+	)}}}++happyReduce_194 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_194 = happySpecReduce_3  76# happyReduction_194+happyReduction_194 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut93 happy_x_2 of { (HappyWrap93 happy_var_2) -> +	happyIn92+		 (let (L loc _) = happy_var_2 in+                                             L loc ([],Just (unLoc happy_var_2))+	)}++happyReduce_195 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_195 = happySpecReduce_3  76# happyReduction_195+happyReduction_195 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	happyIn92+		 (sLL happy_var_1 happy_var_3 ([moc happy_var_1,mj AnnDotdot happy_var_2+                                                 ,mcc happy_var_3],Nothing)+	)}}}++happyReduce_196 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_196 = happySpecReduce_3  76# happyReduction_196+happyReduction_196 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_2 of { happy_var_2 -> +	happyIn92+		 (let (L loc _) = happy_var_2 in+                                             L loc ([mj AnnDotdot happy_var_2],Nothing)+	)}++happyReduce_197 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_197 = happyMonadReduce 3# 77# happyReduction_197+happyReduction_197 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut93 happy_x_1 of { (HappyWrap93 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut94 happy_x_3 of { (HappyWrap94 happy_var_3) -> +	( let (L loc eqn) = happy_var_3 in+                                         case unLoc happy_var_1 of+                                           [] -> return (sLLlA happy_var_1 happy_var_3 (L loc eqn : unLoc happy_var_1))+                                           (h:t) -> do+                                             h' <- addTrailingSemiA h (gl happy_var_2)+                                             return (sLLlA happy_var_1 happy_var_3 (happy_var_3 : h' : t)))}}})+	) (\r -> happyReturn (happyIn93 r))++happyReduce_198 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_198 = happyMonadReduce 2# 77# happyReduction_198+happyReduction_198 (happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut93 happy_x_1 of { (HappyWrap93 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	( case unLoc happy_var_1 of+                                           [] -> return (sLL happy_var_1 happy_var_2 (unLoc happy_var_1))+                                           (h:t) -> do+                                             h' <- addTrailingSemiA h (gl happy_var_2)+                                             return (sLL happy_var_1 happy_var_2  (h':t)))}})+	) (\r -> happyReturn (happyIn93 r))++happyReduce_199 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_199 = happySpecReduce_1  77# happyReduction_199+happyReduction_199 happy_x_1+	 =  case happyOut94 happy_x_1 of { (HappyWrap94 happy_var_1) -> +	happyIn93+		 (sLLAA happy_var_1 happy_var_1 [happy_var_1]+	)}++happyReduce_200 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_200 = happySpecReduce_0  77# happyReduction_200+happyReduction_200  =  happyIn93+		 (noLoc []+	)++happyReduce_201 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_201 = happyMonadReduce 6# 78# happyReduction_201+happyReduction_201 (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_1 of { happy_var_1 -> +	case happyOut174 happy_x_2 of { (HappyWrap174 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	case happyOut161 happy_x_4 of { (HappyWrap161 happy_var_4) -> +	case happyOutTok happy_x_5 of { happy_var_5 -> +	case happyOut158 happy_x_6 of { (HappyWrap158 happy_var_6) -> +	( do { hintExplicitForall happy_var_1+                    ; tvbs <- fromSpecTyVarBndrs happy_var_2+                    ; let loc = comb2A happy_var_1 happy_var_6+                    ; cs <- getCommentsFor loc+                    ; mkTyFamInstEqn loc (mkHsOuterExplicit (EpAnn (glR happy_var_1) (mu AnnForall happy_var_1, mj AnnDot happy_var_3) cs) tvbs) happy_var_4 happy_var_6 [mj AnnEqual happy_var_5] })}}}}}})+	) (\r -> happyReturn (happyIn94 r))++happyReduce_202 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_202 = happyMonadReduce 3# 78# happyReduction_202+happyReduction_202 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut161 happy_x_1 of { (HappyWrap161 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut158 happy_x_3 of { (HappyWrap158 happy_var_3) -> +	( mkTyFamInstEqn (comb2A (reLoc happy_var_1) happy_var_3) mkHsOuterImplicit happy_var_1 happy_var_3 (mj AnnEqual happy_var_2:[]))}}})+	) (\r -> happyReturn (happyIn94 r))++happyReduce_203 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_203 = happyMonadReduce 4# 79# happyReduction_203+happyReduction_203 (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 { happy_var_1 -> +	case happyOut96 happy_x_2 of { (HappyWrap96 happy_var_2) -> +	case happyOut161 happy_x_3 of { (HappyWrap161 happy_var_3) -> +	case happyOut101 happy_x_4 of { (HappyWrap101 happy_var_4) -> +	( liftM mkTyClD (mkFamDecl (comb3 happy_var_1 (reLoc happy_var_3) happy_var_4) DataFamily NotTopLevel happy_var_3+                                                  (snd $ unLoc happy_var_4) Nothing+                        (mj AnnData happy_var_1:happy_var_2++(fst $ unLoc happy_var_4))))}}}})+	) (\r -> happyReturn (happyIn95 r))++happyReduce_204 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_204 = happyMonadReduce 3# 79# happyReduction_204+happyReduction_204 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut161 happy_x_2 of { (HappyWrap161 happy_var_2) -> +	case happyOut103 happy_x_3 of { (HappyWrap103 happy_var_3) -> +	( liftM mkTyClD+                        (mkFamDecl (comb3 happy_var_1 (reLoc happy_var_2) happy_var_3) OpenTypeFamily NotTopLevel happy_var_2+                                   (fst . snd $ unLoc happy_var_3)+                                   (snd . snd $ unLoc happy_var_3)+                         (mj AnnType happy_var_1:(fst $ unLoc happy_var_3)) ))}}})+	) (\r -> happyReturn (happyIn95 r))++happyReduce_205 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_205 = happyMonadReduce 4# 79# happyReduction_205+happyReduction_205 (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 { happy_var_1 -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut161 happy_x_3 of { (HappyWrap161 happy_var_3) -> +	case happyOut103 happy_x_4 of { (HappyWrap103 happy_var_4) -> +	( liftM mkTyClD+                        (mkFamDecl (comb3 happy_var_1 (reLoc happy_var_3) happy_var_4) OpenTypeFamily NotTopLevel happy_var_3+                                   (fst . snd $ unLoc happy_var_4)+                                   (snd . snd $ unLoc happy_var_4)+                         (mj AnnType happy_var_1:mj AnnFamily happy_var_2:(fst $ unLoc happy_var_4))))}}}})+	) (\r -> happyReturn (happyIn95 r))++happyReduce_206 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_206 = happyMonadReduce 2# 79# happyReduction_206+happyReduction_206 (happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut94 happy_x_2 of { (HappyWrap94 happy_var_2) -> +	( liftM mkInstD (mkTyFamInst (comb2A happy_var_1 happy_var_2) (unLoc happy_var_2)+                          [mj AnnType happy_var_1]))}})+	) (\r -> happyReturn (happyIn95 r))++happyReduce_207 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_207 = happyMonadReduce 3# 79# happyReduction_207+happyReduction_207 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut94 happy_x_3 of { (HappyWrap94 happy_var_3) -> +	( liftM mkInstD (mkTyFamInst (comb2A happy_var_1 happy_var_3) (unLoc happy_var_3)+                              (mj AnnType happy_var_1:mj AnnInstance happy_var_2:[]) ))}}})+	) (\r -> happyReturn (happyIn95 r))++happyReduce_208 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_208 = happySpecReduce_0  80# happyReduction_208+happyReduction_208  =  happyIn96+		 ([]+	)++happyReduce_209 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_209 = happySpecReduce_1  80# happyReduction_209+happyReduction_209 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn96+		 ([mj AnnFamily happy_var_1]+	)}++happyReduce_210 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_210 = happySpecReduce_0  81# happyReduction_210+happyReduction_210  =  happyIn97+		 ([]+	)++happyReduce_211 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_211 = happySpecReduce_1  81# happyReduction_211+happyReduction_211 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn97+		 ([mj AnnInstance happy_var_1]+	)}++happyReduce_212 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_212 = happyMonadReduce 3# 82# happyReduction_212+happyReduction_212 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut97 happy_x_2 of { (HappyWrap97 happy_var_2) -> +	case happyOut94 happy_x_3 of { (HappyWrap94 happy_var_3) -> +	( mkTyFamInst (comb2A happy_var_1 happy_var_3) (unLoc happy_var_3)+                          (mj AnnType happy_var_1:happy_var_2))}}})+	) (\r -> happyReturn (happyIn98 r))++happyReduce_213 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_213 = happyMonadReduce 6# 82# happyReduction_213+happyReduction_213 (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 happyOut99 happy_x_1 of { (HappyWrap99 happy_var_1) -> +	case happyOut97 happy_x_2 of { (HappyWrap97 happy_var_2) -> +	case happyOut106 happy_x_3 of { (HappyWrap106 happy_var_3) -> +	case happyOut105 happy_x_4 of { (HappyWrap105 happy_var_4) -> +	case happyOut185 happy_x_5 of { (HappyWrap185 happy_var_5) -> +	case happyOut193 happy_x_6 of { (HappyWrap193 happy_var_6) -> +	( mkDataFamInst (comb4 happy_var_1 happy_var_4 happy_var_5 happy_var_6) (snd $ unLoc happy_var_1) happy_var_3 (unLoc happy_var_4)+                                    Nothing (reverse (snd $ unLoc happy_var_5))+                                            (fmap reverse happy_var_6)+                        ((fst $ unLoc happy_var_1):happy_var_2++(fst $ unLoc happy_var_5)))}}}}}})+	) (\r -> happyReturn (happyIn98 r))++happyReduce_214 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_214 = happyMonadReduce 7# 82# happyReduction_214+happyReduction_214 (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 happyOut99 happy_x_1 of { (HappyWrap99 happy_var_1) -> +	case happyOut97 happy_x_2 of { (HappyWrap97 happy_var_2) -> +	case happyOut106 happy_x_3 of { (HappyWrap106 happy_var_3) -> +	case happyOut105 happy_x_4 of { (HappyWrap105 happy_var_4) -> +	case happyOut100 happy_x_5 of { (HappyWrap100 happy_var_5) -> +	case happyOut182 happy_x_6 of { (HappyWrap182 happy_var_6) -> +	case happyOut193 happy_x_7 of { (HappyWrap193 happy_var_7) -> +	( mkDataFamInst (comb4 happy_var_1 happy_var_4 happy_var_6 happy_var_7) (snd $ unLoc happy_var_1) happy_var_3+                                (unLoc happy_var_4) (snd $ unLoc happy_var_5) (snd $ unLoc happy_var_6)+                                (fmap reverse happy_var_7)+                        ((fst $ unLoc happy_var_1):happy_var_2++(fst $ unLoc happy_var_5)++(fst $ unLoc happy_var_6)))}}}}}}})+	) (\r -> happyReturn (happyIn98 r))++happyReduce_215 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_215 = happySpecReduce_1  83# happyReduction_215+happyReduction_215 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn99+		 (sL1 happy_var_1 (mj AnnData    happy_var_1,DataType)+	)}++happyReduce_216 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_216 = happySpecReduce_1  83# happyReduction_216+happyReduction_216 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn99+		 (sL1 happy_var_1 (mj AnnNewtype happy_var_1,NewType)+	)}++happyReduce_217 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_217 = happySpecReduce_0  84# happyReduction_217+happyReduction_217  =  happyIn100+		 (noLoc     ([]               , Nothing)+	)++happyReduce_218 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_218 = happySpecReduce_2  84# happyReduction_218+happyReduction_218 happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut181 happy_x_2 of { (HappyWrap181 happy_var_2) -> +	happyIn100+		 (sLL happy_var_1 (reLoc happy_var_2) ([mu AnnDcolon happy_var_1], Just happy_var_2)+	)}}++happyReduce_219 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_219 = happySpecReduce_0  85# happyReduction_219+happyReduction_219  =  happyIn101+		 (noLoc     ([]               , noLocA (NoSig noExtField)         )+	)++happyReduce_220 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_220 = happySpecReduce_2  85# happyReduction_220+happyReduction_220 happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut181 happy_x_2 of { (HappyWrap181 happy_var_2) -> +	happyIn101+		 (sLL happy_var_1 (reLoc happy_var_2) ([mu AnnDcolon happy_var_1], sLLa happy_var_1 (reLoc happy_var_2) (KindSig noExtField happy_var_2))+	)}}++happyReduce_221 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_221 = happySpecReduce_0  86# happyReduction_221+happyReduction_221  =  happyIn102+		 (noLoc     ([]               , noLocA     (NoSig    noExtField)   )+	)++happyReduce_222 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_222 = happySpecReduce_2  86# happyReduction_222+happyReduction_222 happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut181 happy_x_2 of { (HappyWrap181 happy_var_2) -> +	happyIn102+		 (sLL happy_var_1 (reLoc happy_var_2) ([mu AnnDcolon happy_var_1], sLLa happy_var_1 (reLoc happy_var_2) (KindSig  noExtField happy_var_2))+	)}}++happyReduce_223 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_223 = happyMonadReduce 2# 86# happyReduction_223+happyReduction_223 (happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut175 happy_x_2 of { (HappyWrap175 happy_var_2) -> +	( do { tvb <- fromSpecTyVarBndr happy_var_2+                             ; return $ sLL happy_var_1 (reLoc happy_var_2) ([mj AnnEqual happy_var_1], sLLa happy_var_1 (reLoc happy_var_2) (TyVarSig noExtField tvb))})}})+	) (\r -> happyReturn (happyIn102 r))++happyReduce_224 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_224 = happySpecReduce_0  87# happyReduction_224+happyReduction_224  =  happyIn103+		 (noLoc ([], (noLocA (NoSig noExtField), Nothing))+	)++happyReduce_225 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_225 = happySpecReduce_2  87# happyReduction_225+happyReduction_225 happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut181 happy_x_2 of { (HappyWrap181 happy_var_2) -> +	happyIn103+		 (sLL happy_var_1 (reLoc happy_var_2) ( [mu AnnDcolon happy_var_1]+                                 , (sL1a (reLoc happy_var_2) (KindSig noExtField happy_var_2), Nothing))+	)}}++happyReduce_226 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_226 = happyMonadReduce 4# 87# happyReduction_226+happyReduction_226 (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 { happy_var_1 -> +	case happyOut176 happy_x_2 of { (HappyWrap176 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	case happyOut89 happy_x_4 of { (HappyWrap89 happy_var_4) -> +	( do { tvb <- fromSpecTyVarBndr happy_var_2+                      ; return $ sLL happy_var_1 (reLoc happy_var_4) ([mj AnnEqual happy_var_1, mj AnnVbar happy_var_3]+                                           , (sLLa happy_var_1 (reLoc happy_var_2) (TyVarSig noExtField tvb), Just happy_var_4))})}}}})+	) (\r -> happyReturn (happyIn103 r))++happyReduce_227 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_227 = happyMonadReduce 3# 88# happyReduction_227+happyReduction_227 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut160 happy_x_1 of { (HappyWrap160 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut161 happy_x_3 of { (HappyWrap161 happy_var_3) -> +	( acs (\cs -> (sLLAA happy_var_1 happy_var_3 (Just (addTrailingDarrowC happy_var_1 happy_var_2 cs), happy_var_3))))}}})+	) (\r -> happyReturn (happyIn104 r))++happyReduce_228 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_228 = happySpecReduce_1  88# happyReduction_228+happyReduction_228 happy_x_1+	 =  case happyOut161 happy_x_1 of { (HappyWrap161 happy_var_1) -> +	happyIn104+		 (sL1A happy_var_1 (Nothing, happy_var_1)+	)}++happyReduce_229 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_229 = happyMonadReduce 6# 89# happyReduction_229+happyReduction_229 (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_1 of { happy_var_1 -> +	case happyOut174 happy_x_2 of { (HappyWrap174 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	case happyOut160 happy_x_4 of { (HappyWrap160 happy_var_4) -> +	case happyOutTok happy_x_5 of { happy_var_5 -> +	case happyOut161 happy_x_6 of { (HappyWrap161 happy_var_6) -> +	( hintExplicitForall happy_var_1+                                                       >> fromSpecTyVarBndrs happy_var_2+                                                         >>= \tvbs ->+                                                             (acs (\cs -> (sLL happy_var_1 (reLoc happy_var_6)+                                                                                  (Just ( addTrailingDarrowC happy_var_4 happy_var_5 cs)+                                                                                        , mkHsOuterExplicit (EpAnn (glR happy_var_1) (mu AnnForall happy_var_1, mj AnnDot happy_var_3) emptyComments) tvbs, happy_var_6)))))}}}}}})+	) (\r -> happyReturn (happyIn105 r))++happyReduce_230 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_230 = happyMonadReduce 4# 89# happyReduction_230+happyReduction_230 (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 { happy_var_1 -> +	case happyOut174 happy_x_2 of { (HappyWrap174 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	case happyOut161 happy_x_4 of { (HappyWrap161 happy_var_4) -> +	( do { hintExplicitForall happy_var_1+                                             ; tvbs <- fromSpecTyVarBndrs happy_var_2+                                             ; let loc = comb2 happy_var_1 (reLoc happy_var_4)+                                             ; cs <- getCommentsFor loc+                                             ; return (sL loc (Nothing, mkHsOuterExplicit (EpAnn (glR happy_var_1) (mu AnnForall happy_var_1, mj AnnDot happy_var_3) cs) tvbs, happy_var_4))+                                       })}}}})+	) (\r -> happyReturn (happyIn105 r))++happyReduce_231 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_231 = happyMonadReduce 3# 89# happyReduction_231+happyReduction_231 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut160 happy_x_1 of { (HappyWrap160 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut161 happy_x_3 of { (HappyWrap161 happy_var_3) -> +	( acs (\cs -> (sLLAA happy_var_1 happy_var_3(Just (addTrailingDarrowC happy_var_1 happy_var_2 cs), mkHsOuterImplicit, happy_var_3))))}}})+	) (\r -> happyReturn (happyIn105 r))++happyReduce_232 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_232 = happySpecReduce_1  89# happyReduction_232+happyReduction_232 happy_x_1+	 =  case happyOut161 happy_x_1 of { (HappyWrap161 happy_var_1) -> +	happyIn105+		 (sL1A happy_var_1 (Nothing, mkHsOuterImplicit, happy_var_1)+	)}++happyReduce_233 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_233 = happyMonadReduce 4# 90# happyReduction_233+happyReduction_233 (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 { happy_var_1 -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	case happyOutTok happy_x_4 of { happy_var_4 -> +	( fmap Just $ amsrp (sLL happy_var_1 happy_var_4 (CType (getCTYPEs happy_var_1) (Just (Header (getSTRINGs happy_var_2) (getSTRING happy_var_2)))+                                        (getSTRINGs happy_var_3,getSTRING happy_var_3)))+                              (AnnPragma (mo happy_var_1) (mc happy_var_4) [mj AnnHeader happy_var_2,mj AnnVal happy_var_3]))}}}})+	) (\r -> happyReturn (happyIn106 r))++happyReduce_234 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_234 = happyMonadReduce 3# 90# happyReduction_234+happyReduction_234 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	( fmap Just $ amsrp (sLL happy_var_1 happy_var_3 (CType (getCTYPEs happy_var_1) Nothing (getSTRINGs happy_var_2, getSTRING happy_var_2)))+                              (AnnPragma (mo happy_var_1) (mc happy_var_3) [mj AnnVal happy_var_2]))}}})+	) (\r -> happyReturn (happyIn106 r))++happyReduce_235 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_235 = happySpecReduce_0  90# happyReduction_235+happyReduction_235  =  happyIn106+		 (Nothing+	)++happyReduce_236 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_236 = happyMonadReduce 5# 91# happyReduction_236+happyReduction_236 (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 { happy_var_1 -> +	case happyOut87 happy_x_2 of { (HappyWrap87 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	case happyOut84 happy_x_4 of { (HappyWrap84 happy_var_4) -> +	case happyOut169 happy_x_5 of { (HappyWrap169 happy_var_5) -> +	( do { let { err = text "in the stand-alone deriving instance"+                                    <> colon <+> quotes (ppr happy_var_5) }+                      ; acsA (\cs -> sLL happy_var_1 (reLoc happy_var_5)+                                 (DerivDecl (EpAnn (glR happy_var_1) [mj AnnDeriving happy_var_1, mj AnnInstance happy_var_3] cs) (mkHsWildCardBndrs happy_var_5) happy_var_2 happy_var_4)) })}}}}})+	) (\r -> happyReturn (happyIn107 r))++happyReduce_237 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_237 = happyMonadReduce 4# 92# happyReduction_237+happyReduction_237 (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 { happy_var_1 -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut279 happy_x_3 of { (HappyWrap279 happy_var_3) -> +	case happyOut109 happy_x_4 of { (HappyWrap109 happy_var_4) -> +	( mkRoleAnnotDecl (comb3N happy_var_1 happy_var_4 happy_var_3) happy_var_3 (reverse (unLoc happy_var_4))+                   [mj AnnType happy_var_1,mj AnnRole happy_var_2])}}}})+	) (\r -> happyReturn (happyIn108 r))++happyReduce_238 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_238 = happySpecReduce_0  93# happyReduction_238+happyReduction_238  =  happyIn109+		 (noLoc []+	)++happyReduce_239 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_239 = happySpecReduce_1  93# happyReduction_239+happyReduction_239 happy_x_1+	 =  case happyOut110 happy_x_1 of { (HappyWrap110 happy_var_1) -> +	happyIn109+		 (happy_var_1+	)}++happyReduce_240 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_240 = happySpecReduce_1  94# happyReduction_240+happyReduction_240 happy_x_1+	 =  case happyOut111 happy_x_1 of { (HappyWrap111 happy_var_1) -> +	happyIn110+		 (sLL happy_var_1 happy_var_1 [happy_var_1]+	)}++happyReduce_241 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_241 = happySpecReduce_2  94# happyReduction_241+happyReduction_241 happy_x_2+	happy_x_1+	 =  case happyOut110 happy_x_1 of { (HappyWrap110 happy_var_1) -> +	case happyOut111 happy_x_2 of { (HappyWrap111 happy_var_2) -> +	happyIn110+		 (sLL happy_var_1 happy_var_2 $ happy_var_2 : unLoc happy_var_1+	)}}++happyReduce_242 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_242 = happySpecReduce_1  95# happyReduction_242+happyReduction_242 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn111+		 (sL1 happy_var_1 $ Just $ getVARID happy_var_1+	)}++happyReduce_243 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_243 = happySpecReduce_1  95# happyReduction_243+happyReduction_243 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn111+		 (sL1 happy_var_1 Nothing+	)}++happyReduce_244 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_244 = happyMonadReduce 4# 96# happyReduction_244+happyReduction_244 (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 { happy_var_1 -> +	case happyOut113 happy_x_2 of { (HappyWrap113 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	case happyOut241 happy_x_4 of { (HappyWrap241 happy_var_4) -> +	(      let (name, args, as ) = happy_var_2 in+                 acsA (\cs -> sLL happy_var_1 (reLoc happy_var_4) . ValD noExtField $ mkPatSynBind name args happy_var_4+                                                    ImplicitBidirectional+                      (EpAnn (glR happy_var_1) (as ++ [mj AnnPattern happy_var_1, mj AnnEqual happy_var_3]) cs)))}}}})+	) (\r -> happyReturn (happyIn112 r))++happyReduce_245 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_245 = happyMonadReduce 4# 96# happyReduction_245+happyReduction_245 (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 { happy_var_1 -> +	case happyOut113 happy_x_2 of { (HappyWrap113 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	case happyOut241 happy_x_4 of { (HappyWrap241 happy_var_4) -> +	(    let (name, args, as) = happy_var_2 in+               acsA (\cs -> sLL happy_var_1 (reLoc happy_var_4) . ValD noExtField $ mkPatSynBind name args happy_var_4 Unidirectional+                       (EpAnn (glR happy_var_1) (as ++ [mj AnnPattern happy_var_1,mu AnnLarrow happy_var_3]) cs)))}}}})+	) (\r -> happyReturn (happyIn112 r))++happyReduce_246 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_246 = happyMonadReduce 5# 96# happyReduction_246+happyReduction_246 (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 { happy_var_1 -> +	case happyOut113 happy_x_2 of { (HappyWrap113 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	case happyOut241 happy_x_4 of { (HappyWrap241 happy_var_4) -> +	case happyOut116 happy_x_5 of { (HappyWrap116 happy_var_5) -> +	( do { let (name, args, as) = happy_var_2+                  ; mg <- mkPatSynMatchGroup name happy_var_5+                  ; acsA (\cs -> sLL happy_var_1 (reLoc happy_var_5) . ValD noExtField $+                           mkPatSynBind name args happy_var_4 (ExplicitBidirectional mg)+                            (EpAnn (glR happy_var_1) (as ++ [mj AnnPattern happy_var_1,mu AnnLarrow happy_var_3]) cs))+                   })}}}}})+	) (\r -> happyReturn (happyIn112 r))++happyReduce_247 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_247 = happySpecReduce_2  97# happyReduction_247+happyReduction_247 happy_x_2+	happy_x_1+	 =  case happyOut270 happy_x_1 of { (HappyWrap270 happy_var_1) -> +	case happyOut114 happy_x_2 of { (HappyWrap114 happy_var_2) -> +	happyIn113+		 ((happy_var_1, PrefixCon noTypeArgs happy_var_2, [])+	)}}++happyReduce_248 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_248 = happySpecReduce_3  97# happyReduction_248+happyReduction_248 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut301 happy_x_1 of { (HappyWrap301 happy_var_1) -> +	case happyOut275 happy_x_2 of { (HappyWrap275 happy_var_2) -> +	case happyOut301 happy_x_3 of { (HappyWrap301 happy_var_3) -> +	happyIn113+		 ((happy_var_2, InfixCon happy_var_1 happy_var_3, [])+	)}}}++happyReduce_249 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_249 = happyReduce 4# 97# happyReduction_249+happyReduction_249 (happy_x_4 `HappyStk`+	happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest)+	 = case happyOut270 happy_x_1 of { (HappyWrap270 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut115 happy_x_3 of { (HappyWrap115 happy_var_3) -> +	case happyOutTok happy_x_4 of { happy_var_4 -> +	happyIn113+		 ((happy_var_1, RecCon happy_var_3, [moc happy_var_2, mcc happy_var_4] )+	) `HappyStk` happyRest}}}}++happyReduce_250 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_250 = happySpecReduce_0  98# happyReduction_250+happyReduction_250  =  happyIn114+		 ([]+	)++happyReduce_251 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_251 = happySpecReduce_2  98# happyReduction_251+happyReduction_251 happy_x_2+	happy_x_1+	 =  case happyOut301 happy_x_1 of { (HappyWrap301 happy_var_1) -> +	case happyOut114 happy_x_2 of { (HappyWrap114 happy_var_2) -> +	happyIn114+		 (happy_var_1 : happy_var_2+	)}}++happyReduce_252 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_252 = happySpecReduce_1  99# happyReduction_252+happyReduction_252 happy_x_1+	 =  case happyOut297 happy_x_1 of { (HappyWrap297 happy_var_1) -> +	happyIn115+		 ([RecordPatSynField (mkFieldOcc happy_var_1) happy_var_1]+	)}++happyReduce_253 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_253 = happyMonadReduce 3# 99# happyReduction_253+happyReduction_253 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut297 happy_x_1 of { (HappyWrap297 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut115 happy_x_3 of { (HappyWrap115 happy_var_3) -> +	( do { h <- addTrailingCommaN happy_var_1 (gl happy_var_2)+                                            ; return ((RecordPatSynField (mkFieldOcc h) h) : happy_var_3 )})}}})+	) (\r -> happyReturn (happyIn115 r))++happyReduce_254 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_254 = happyMonadReduce 4# 100# happyReduction_254+happyReduction_254 (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 { happy_var_1 -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut127 happy_x_3 of { (HappyWrap127 happy_var_3) -> +	case happyOutTok happy_x_4 of { happy_var_4 -> +	( amsrl (sLL happy_var_1 happy_var_4 (snd $ unLoc happy_var_3))+                                              (AnnList (Just $ glR happy_var_3) (Just $ moc happy_var_2) (Just $ mcc happy_var_4) [mj AnnWhere happy_var_1] (fst $ unLoc happy_var_3)))}}}})+	) (\r -> happyReturn (happyIn116 r))++happyReduce_255 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_255 = happyMonadReduce 4# 100# happyReduction_255+happyReduction_255 (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 { happy_var_1 -> +	case happyOut127 happy_x_3 of { (HappyWrap127 happy_var_3) -> +	( amsrl (sLL happy_var_1 happy_var_3 (snd $ unLoc happy_var_3))+                                              (AnnList (Just $ glR happy_var_3) Nothing Nothing [mj AnnWhere happy_var_1] (fst $ unLoc happy_var_3)))}})+	) (\r -> happyReturn (happyIn116 r))++happyReduce_256 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_256 = happyMonadReduce 4# 101# happyReduction_256+happyReduction_256 (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 { happy_var_1 -> +	case happyOut271 happy_x_2 of { (HappyWrap271 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	case happyOut153 happy_x_4 of { (HappyWrap153 happy_var_4) -> +	( acsA (\cs -> sLL happy_var_1 (reLoc happy_var_4)+                                $ PatSynSig (EpAnn (glR happy_var_1) (AnnSig (mu AnnDcolon happy_var_3) [mj AnnPattern happy_var_1]) cs)+                                  (unLoc happy_var_2) happy_var_4))}}}})+	) (\r -> happyReturn (happyIn117 r))++happyReduce_257 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_257 = happySpecReduce_1  102# happyReduction_257+happyReduction_257 happy_x_1+	 =  case happyOut298 happy_x_1 of { (HappyWrap298 happy_var_1) -> +	happyIn118+		 (happy_var_1+	)}++happyReduce_258 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_258 = happySpecReduce_1  102# happyReduction_258+happyReduction_258 happy_x_1+	 =  case happyOut268 happy_x_1 of { (HappyWrap268 happy_var_1) -> +	happyIn118+		 (happy_var_1+	)}++happyReduce_259 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_259 = happySpecReduce_1  103# happyReduction_259+happyReduction_259 happy_x_1+	 =  case happyOut95 happy_x_1 of { (HappyWrap95 happy_var_1) -> +	happyIn119+		 (happy_var_1+	)}++happyReduce_260 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_260 = happySpecReduce_1  103# happyReduction_260+happyReduction_260 happy_x_1+	 =  case happyOut198 happy_x_1 of { (HappyWrap198 happy_var_1) -> +	happyIn119+		 (happy_var_1+	)}++happyReduce_261 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_261 = happyMonadReduce 4# 103# happyReduction_261+happyReduction_261 (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 { happy_var_1 -> +	case happyOut207 happy_x_2 of { (HappyWrap207 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	case happyOut153 happy_x_4 of { (HappyWrap153 happy_var_4) -> +	( runPV (unECP happy_var_2) >>= \ happy_var_2 ->+                       do { v <- checkValSigLhs happy_var_2+                          ; let err = text "in default signature" <> colon <+>+                                      quotes (ppr happy_var_2)+                          ; acsA (\cs -> sLL happy_var_1 (reLoc happy_var_4) $ SigD noExtField $ ClassOpSig (EpAnn (glR happy_var_1) (AnnSig (mu AnnDcolon happy_var_3) [mj AnnDefault happy_var_1]) cs) True [v] happy_var_4) })}}}})+	) (\r -> happyReturn (happyIn119 r))++happyReduce_262 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_262 = happyMonadReduce 3# 104# happyReduction_262+happyReduction_262 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut120 happy_x_1 of { (HappyWrap120 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut119 happy_x_3 of { (HappyWrap119 happy_var_3) -> +	( if isNilOL (snd $ unLoc happy_var_1)+                                             then return (sLLlA happy_var_1 happy_var_3 ((fst $ unLoc happy_var_1) ++ (mz AnnSemi happy_var_2)+                                                                    , unitOL happy_var_3))+                                            else case (snd $ unLoc happy_var_1) of+                                              SnocOL hs t -> do+                                                 t' <- addTrailingSemiA t (gl happy_var_2)+                                                 return (sLLlA happy_var_1 happy_var_3 (fst $ unLoc happy_var_1+                                                                , snocOL hs t' `appOL` unitOL happy_var_3)))}}})+	) (\r -> happyReturn (happyIn120 r))++happyReduce_263 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_263 = happyMonadReduce 2# 104# happyReduction_263+happyReduction_263 (happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut120 happy_x_1 of { (HappyWrap120 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	( if isNilOL (snd $ unLoc happy_var_1)+                                             then return (sLL happy_var_1 happy_var_2 ( (fst $ unLoc happy_var_1) ++ (mz AnnSemi happy_var_2)+                                                                                   ,snd $ unLoc happy_var_1))+                                             else case (snd $ unLoc happy_var_1) of+                                               SnocOL hs t -> do+                                                  t' <- addTrailingSemiA t (gl happy_var_2)+                                                  return (sLL happy_var_1 happy_var_2 (fst $ unLoc happy_var_1+                                                                 , snocOL hs t')))}})+	) (\r -> happyReturn (happyIn120 r))++happyReduce_264 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_264 = happySpecReduce_1  104# happyReduction_264+happyReduction_264 happy_x_1+	 =  case happyOut119 happy_x_1 of { (HappyWrap119 happy_var_1) -> +	happyIn120+		 (sL1A happy_var_1 ([], unitOL happy_var_1)+	)}++happyReduce_265 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_265 = happySpecReduce_0  104# happyReduction_265+happyReduction_265  =  happyIn120+		 (noLoc ([],nilOL)+	)++happyReduce_266 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_266 = happySpecReduce_3  105# happyReduction_266+happyReduction_266 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut120 happy_x_2 of { (HappyWrap120 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	happyIn121+		 (sLL happy_var_1 happy_var_3 (moc happy_var_1:mcc happy_var_3:(fst $ unLoc happy_var_2)+                                             ,snd $ unLoc happy_var_2, ExplicitBraces)+	)}}}++happyReduce_267 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_267 = happySpecReduce_3  105# happyReduction_267+happyReduction_267 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut120 happy_x_2 of { (HappyWrap120 happy_var_2) -> +	happyIn121+		 (let { L l (anns, decls) = happy_var_2 }+                                           in L l (anns, decls, VirtualBraces (getVOCURLY happy_var_1))+	)}}++happyReduce_268 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_268 = happySpecReduce_2  106# happyReduction_268+happyReduction_268 happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut121 happy_x_2 of { (HappyWrap121 happy_var_2) -> +	happyIn122+		 (sLL happy_var_1 happy_var_2 (mj AnnWhere happy_var_1:(fstOf3 $ unLoc happy_var_2)+                                             ,sndOf3 $ unLoc happy_var_2,thdOf3 $ unLoc happy_var_2)+	)}}++happyReduce_269 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_269 = happySpecReduce_0  106# happyReduction_269+happyReduction_269  =  happyIn122+		 (noLoc ([],nilOL,NoLayoutInfo)+	)++happyReduce_270 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_270 = happySpecReduce_1  107# happyReduction_270+happyReduction_270 happy_x_1+	 =  case happyOut98 happy_x_1 of { (HappyWrap98 happy_var_1) -> +	happyIn123+		 (sL1A happy_var_1 (unitOL (sL1 happy_var_1 (InstD noExtField (unLoc happy_var_1))))+	)}++happyReduce_271 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_271 = happySpecReduce_1  107# happyReduction_271+happyReduction_271 happy_x_1+	 =  case happyOut198 happy_x_1 of { (HappyWrap198 happy_var_1) -> +	happyIn123+		 (sL1A happy_var_1 (unitOL happy_var_1)+	)}++happyReduce_272 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_272 = happyMonadReduce 3# 108# happyReduction_272+happyReduction_272 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut124 happy_x_1 of { (HappyWrap124 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut123 happy_x_3 of { (HappyWrap123 happy_var_3) -> +	( if isNilOL (snd $ unLoc happy_var_1)+                                             then return (sLL happy_var_1 happy_var_3 ((fst $ unLoc happy_var_1) ++ (mz AnnSemi happy_var_2)+                                                                    , unLoc happy_var_3))+                                             else case (snd $ unLoc happy_var_1) of+                                               SnocOL hs t -> do+                                                  t' <- addTrailingSemiA t (gl happy_var_2)+                                                  return (sLL happy_var_1 happy_var_3 (fst $ unLoc happy_var_1+                                                                 , snocOL hs t' `appOL` unLoc happy_var_3)))}}})+	) (\r -> happyReturn (happyIn124 r))++happyReduce_273 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_273 = happyMonadReduce 2# 108# happyReduction_273+happyReduction_273 (happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut124 happy_x_1 of { (HappyWrap124 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	( if isNilOL (snd $ unLoc happy_var_1)+                                             then return (sLL happy_var_1 happy_var_2 ((fst $ unLoc happy_var_1) ++ (mz AnnSemi happy_var_2)+                                                                                   ,snd $ unLoc happy_var_1))+                                             else case (snd $ unLoc happy_var_1) of+                                               SnocOL hs t -> do+                                                  t' <- addTrailingSemiA t (gl happy_var_2)+                                                  return (sLL happy_var_1 happy_var_2 (fst $ unLoc happy_var_1+                                                                 , snocOL hs t')))}})+	) (\r -> happyReturn (happyIn124 r))++happyReduce_274 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_274 = happySpecReduce_1  108# happyReduction_274+happyReduction_274 happy_x_1+	 =  case happyOut123 happy_x_1 of { (HappyWrap123 happy_var_1) -> +	happyIn124+		 (sL1 happy_var_1 ([],unLoc happy_var_1)+	)}++happyReduce_275 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_275 = happySpecReduce_0  108# happyReduction_275+happyReduction_275  =  happyIn124+		 (noLoc ([],nilOL)+	)++happyReduce_276 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_276 = happySpecReduce_3  109# happyReduction_276+happyReduction_276 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut124 happy_x_2 of { (HappyWrap124 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	happyIn125+		 (sLL happy_var_1 happy_var_3 (moc happy_var_1:mcc happy_var_3:(fst $ unLoc happy_var_2),snd $ unLoc happy_var_2)+	)}}}++happyReduce_277 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_277 = happySpecReduce_3  109# happyReduction_277+happyReduction_277 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut124 happy_x_2 of { (HappyWrap124 happy_var_2) -> +	happyIn125+		 (L (gl happy_var_2) (unLoc happy_var_2)+	)}++happyReduce_278 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_278 = happySpecReduce_2  110# happyReduction_278+happyReduction_278 happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut125 happy_x_2 of { (HappyWrap125 happy_var_2) -> +	happyIn126+		 (sLL happy_var_1 happy_var_2 (mj AnnWhere happy_var_1:(fst $ unLoc happy_var_2)+                                             ,(snd $ unLoc happy_var_2))+	)}}++happyReduce_279 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_279 = happySpecReduce_0  110# happyReduction_279+happyReduction_279  =  happyIn126+		 (noLoc ([],nilOL)+	)++happyReduce_280 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_280 = happyMonadReduce 3# 111# happyReduction_280+happyReduction_280 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut127 happy_x_1 of { (HappyWrap127 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut198 happy_x_3 of { (HappyWrap198 happy_var_3) -> +	( if isNilOL (snd $ unLoc happy_var_1)+                                 then return (sLLlA happy_var_1 happy_var_3 ((fst $ unLoc happy_var_1) ++ (msemi happy_var_2)+                                                        , unitOL happy_var_3))+                                 else case (snd $ unLoc happy_var_1) of+                                   SnocOL hs t -> do+                                      t' <- addTrailingSemiA t (gl happy_var_2)+                                      let { this = unitOL happy_var_3;+                                            rest = snocOL hs t';+                                            these = rest `appOL` this }+                                      return (rest `seq` this `seq` these `seq`+                                                 (sLLlA happy_var_1 happy_var_3 (fst $ unLoc happy_var_1, these))))}}})+	) (\r -> happyReturn (happyIn127 r))++happyReduce_281 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_281 = happyMonadReduce 2# 111# happyReduction_281+happyReduction_281 (happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut127 happy_x_1 of { (HappyWrap127 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	( if isNilOL (snd $ unLoc happy_var_1)+                                  then return (sLL happy_var_1 happy_var_2 (((fst $ unLoc happy_var_1) ++ (msemi happy_var_2)+                                                          ,snd $ unLoc happy_var_1)))+                                  else case (snd $ unLoc happy_var_1) of+                                    SnocOL hs t -> do+                                       t' <- addTrailingSemiA t (gl happy_var_2)+                                       return (sLL happy_var_1 happy_var_2 (fst $ unLoc happy_var_1+                                                      , snocOL hs t')))}})+	) (\r -> happyReturn (happyIn127 r))++happyReduce_282 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_282 = happySpecReduce_1  111# happyReduction_282+happyReduction_282 happy_x_1+	 =  case happyOut198 happy_x_1 of { (HappyWrap198 happy_var_1) -> +	happyIn127+		 (sL1A happy_var_1 ([], unitOL happy_var_1)+	)}++happyReduce_283 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_283 = happySpecReduce_0  111# happyReduction_283+happyReduction_283  =  happyIn127+		 (noLoc ([],nilOL)+	)++happyReduce_284 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_284 = happySpecReduce_3  112# happyReduction_284+happyReduction_284 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut127 happy_x_2 of { (HappyWrap127 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	happyIn128+		 (sLL happy_var_1 happy_var_3 (AnnList (Just $ glR happy_var_2) (Just $ moc happy_var_1) (Just $ mcc happy_var_3) [] (fst $ unLoc happy_var_2)+                                                   ,sL1 happy_var_2 $ snd $ unLoc happy_var_2)+	)}}}++happyReduce_285 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_285 = happySpecReduce_3  112# happyReduction_285+happyReduction_285 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut127 happy_x_2 of { (HappyWrap127 happy_var_2) -> +	happyIn128+		 (L (gl happy_var_2) (AnnList (Just $ glR happy_var_2) Nothing Nothing [] (fst $ unLoc happy_var_2)+                                                   ,sL1 happy_var_2 $ snd $ unLoc happy_var_2)+	)}++happyReduce_286 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_286 = happyMonadReduce 1# 113# happyReduction_286+happyReduction_286 (happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut128 happy_x_1 of { (HappyWrap128 happy_var_1) -> +	( do { val_binds <- cvBindGroup (unLoc $ snd $ unLoc happy_var_1)+                                  ; cs <- getCommentsFor (gl happy_var_1)+                                  ; return (sL1 happy_var_1 $ HsValBinds (fixValbindsAnn $ EpAnn (glR happy_var_1) (fst $ unLoc happy_var_1) cs) val_binds)})})+	) (\r -> happyReturn (happyIn129 r))++happyReduce_287 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_287 = happyMonadReduce 3# 113# happyReduction_287+happyReduction_287 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut256 happy_x_2 of { (HappyWrap256 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	( acs (\cs -> (L (comb3 happy_var_1 happy_var_2 happy_var_3)+                                             $ HsIPBinds (EpAnn (glR happy_var_1) (AnnList (Just$ glR happy_var_2) (Just $ moc happy_var_1) (Just $ mcc happy_var_3) [] []) cs) (IPBinds noExtField (reverse $ unLoc happy_var_2)))))}}})+	) (\r -> happyReturn (happyIn129 r))++happyReduce_288 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_288 = happyMonadReduce 3# 113# happyReduction_288+happyReduction_288 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut256 happy_x_2 of { (HappyWrap256 happy_var_2) -> +	( acs (\cs -> (L (gl happy_var_2)+                                             $ HsIPBinds (EpAnn (glR happy_var_1) (AnnList (Just $ glR happy_var_2) Nothing Nothing [] []) cs) (IPBinds noExtField (reverse $ unLoc happy_var_2)))))}})+	) (\r -> happyReturn (happyIn129 r))++happyReduce_289 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_289 = happyMonadReduce 2# 114# happyReduction_289+happyReduction_289 (happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut129 happy_x_2 of { (HappyWrap129 happy_var_2) -> +	( do { r <- acs (\cs ->+                                                (sLL happy_var_1 happy_var_2 (annBinds (mj AnnWhere happy_var_1) cs (unLoc happy_var_2))))+                                              ; return $ Just r})}})+	) (\r -> happyReturn (happyIn130 r))++happyReduce_290 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_290 = happySpecReduce_0  114# happyReduction_290+happyReduction_290  =  happyIn130+		 (Nothing+	)++happyReduce_291 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_291 = happyMonadReduce 3# 115# happyReduction_291+happyReduction_291 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut131 happy_x_1 of { (HappyWrap131 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut132 happy_x_3 of { (HappyWrap132 happy_var_3) -> +	( case happy_var_1 of+                                            [] -> return (happy_var_3:happy_var_1)+                                            (h:t) -> do+                                              h' <- addTrailingSemiA h (gl happy_var_2)+                                              return (happy_var_3:h':t))}}})+	) (\r -> happyReturn (happyIn131 r))++happyReduce_292 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_292 = happyMonadReduce 2# 115# happyReduction_292+happyReduction_292 (happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut131 happy_x_1 of { (HappyWrap131 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	( case happy_var_1 of+                                            [] -> return happy_var_1+                                            (h:t) -> do+                                              h' <- addTrailingSemiA h (gl happy_var_2)+                                              return (h':t))}})+	) (\r -> happyReturn (happyIn131 r))++happyReduce_293 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_293 = happySpecReduce_1  115# happyReduction_293+happyReduction_293 happy_x_1+	 =  case happyOut132 happy_x_1 of { (HappyWrap132 happy_var_1) -> +	happyIn131+		 ([happy_var_1]+	)}++happyReduce_294 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_294 = happySpecReduce_0  115# happyReduction_294+happyReduction_294  =  happyIn131+		 ([]+	)++happyReduce_295 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_295 = happyMonadReduce 6# 116# happyReduction_295+happyReduction_295 (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_1 of { happy_var_1 -> +	case happyOut133 happy_x_2 of { (HappyWrap133 happy_var_2) -> +	case happyOut136 happy_x_3 of { (HappyWrap136 happy_var_3) -> +	case happyOut207 happy_x_4 of { (HappyWrap207 happy_var_4) -> +	case happyOutTok happy_x_5 of { happy_var_5 -> +	case happyOut206 happy_x_6 of { (HappyWrap206 happy_var_6) -> +	(runPV (unECP happy_var_4) >>= \ happy_var_4 ->+           runPV (unECP happy_var_6) >>= \ happy_var_6 ->+           acsA (\cs -> (sLLlA happy_var_1 happy_var_6 $ HsRule+                                   { rd_ext = EpAnn (glR happy_var_1) ((fstOf3 happy_var_3) (mj AnnEqual happy_var_5 : (fst happy_var_2))) cs+                                   , rd_name = L (noAnnSrcSpan $ gl happy_var_1) (getSTRINGs happy_var_1, getSTRING happy_var_1)+                                   , rd_act = (snd happy_var_2) `orElse` AlwaysActive+                                   , rd_tyvs = sndOf3 happy_var_3, rd_tmvs = thdOf3 happy_var_3+                                   , rd_lhs = happy_var_4, rd_rhs = happy_var_6 })))}}}}}})+	) (\r -> happyReturn (happyIn132 r))++happyReduce_296 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_296 = happySpecReduce_0  117# happyReduction_296+happyReduction_296  =  happyIn133+		 (([],Nothing)+	)++happyReduce_297 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_297 = happySpecReduce_1  117# happyReduction_297+happyReduction_297 happy_x_1+	 =  case happyOut135 happy_x_1 of { (HappyWrap135 happy_var_1) -> +	happyIn133+		 ((fst happy_var_1,Just (snd happy_var_1))+	)}++happyReduce_298 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_298 = happySpecReduce_1  118# happyReduction_298+happyReduction_298 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn134+		 ([mj AnnTilde happy_var_1]+	)}++happyReduce_299 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_299 = happyMonadReduce 1# 118# happyReduction_299+happyReduction_299 (happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	( if (getVARSYM happy_var_1 == fsLit "~")+                   then return [mj AnnTilde happy_var_1]+                   else do { addError $ mkPlainErrorMsgEnvelope (getLoc happy_var_1) $+                               PsErrInvalidRuleActivationMarker+                           ; return [] })})+	) (\r -> happyReturn (happyIn134 r))++happyReduce_300 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_300 = happySpecReduce_3  119# happyReduction_300+happyReduction_300 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	happyIn135+		 (([mos happy_var_1,mj AnnVal happy_var_2,mcs happy_var_3]+                                  ,ActiveAfter  (getINTEGERs happy_var_2) (fromInteger (il_value (getINTEGER happy_var_2))))+	)}}}++happyReduce_301 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_301 = happyReduce 4# 119# happyReduction_301+happyReduction_301 (happy_x_4 `HappyStk`+	happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest)+	 = case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut134 happy_x_2 of { (HappyWrap134 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	case happyOutTok happy_x_4 of { happy_var_4 -> +	happyIn135+		 ((happy_var_2++[mos happy_var_1,mj AnnVal happy_var_3,mcs happy_var_4]+                                  ,ActiveBefore (getINTEGERs happy_var_3) (fromInteger (il_value (getINTEGER happy_var_3))))+	) `HappyStk` happyRest}}}}++happyReduce_302 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_302 = happySpecReduce_3  119# happyReduction_302+happyReduction_302 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut134 happy_x_2 of { (HappyWrap134 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	happyIn135+		 ((happy_var_2++[mos happy_var_1,mcs happy_var_3]+                                  ,NeverActive)+	)}}}++happyReduce_303 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_303 = happyMonadReduce 6# 120# happyReduction_303+happyReduction_303 (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_1 of { happy_var_1 -> +	case happyOut137 happy_x_2 of { (HappyWrap137 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	case happyOutTok happy_x_4 of { happy_var_4 -> +	case happyOut137 happy_x_5 of { (HappyWrap137 happy_var_5) -> +	case happyOutTok happy_x_6 of { happy_var_6 -> +	( let tyvs = mkRuleTyVarBndrs happy_var_2+                                                              in hintExplicitForall happy_var_1+                                                              >> checkRuleTyVarBndrNames (mkRuleTyVarBndrs happy_var_2)+                                                              >> return (\anns -> HsRuleAnn+                                                                          (Just (mu AnnForall happy_var_1,mj AnnDot happy_var_3))+                                                                          (Just (mu AnnForall happy_var_4,mj AnnDot happy_var_6))+                                                                          anns,+                                                                         Just (mkRuleTyVarBndrs happy_var_2), mkRuleBndrs happy_var_5))}}}}}})+	) (\r -> happyReturn (happyIn136 r))++happyReduce_304 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_304 = happySpecReduce_3  120# happyReduction_304+happyReduction_304 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut137 happy_x_2 of { (HappyWrap137 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	happyIn136+		 ((\anns -> HsRuleAnn Nothing (Just (mu AnnForall happy_var_1,mj AnnDot happy_var_3)) anns,+                                                              Nothing, mkRuleBndrs happy_var_2)+	)}}}++happyReduce_305 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_305 = happySpecReduce_0  120# happyReduction_305+happyReduction_305  =  happyIn136+		 ((\anns -> HsRuleAnn Nothing Nothing anns, Nothing, [])+	)++happyReduce_306 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_306 = happySpecReduce_2  121# happyReduction_306+happyReduction_306 happy_x_2+	happy_x_1+	 =  case happyOut138 happy_x_1 of { (HappyWrap138 happy_var_1) -> +	case happyOut137 happy_x_2 of { (HappyWrap137 happy_var_2) -> +	happyIn137+		 (happy_var_1 : happy_var_2+	)}}++happyReduce_307 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_307 = happySpecReduce_0  121# happyReduction_307+happyReduction_307  =  happyIn137+		 ([]+	)++happyReduce_308 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_308 = happySpecReduce_1  122# happyReduction_308+happyReduction_308 happy_x_1+	 =  case happyOut301 happy_x_1 of { (HappyWrap301 happy_var_1) -> +	happyIn138+		 (sL1l happy_var_1 (RuleTyTmVar noAnn happy_var_1 Nothing)+	)}++happyReduce_309 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_309 = happyMonadReduce 5# 122# happyReduction_309+happyReduction_309 (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 { happy_var_1 -> +	case happyOut301 happy_x_2 of { (HappyWrap301 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	case happyOut159 happy_x_4 of { (HappyWrap159 happy_var_4) -> +	case happyOutTok happy_x_5 of { happy_var_5 -> +	( acsA (\cs -> sLL happy_var_1 happy_var_5 (RuleTyTmVar (EpAnn (glR happy_var_1) [mop happy_var_1,mu AnnDcolon happy_var_3,mcp happy_var_5] cs) happy_var_2 (Just happy_var_4))))}}}}})+	) (\r -> happyReturn (happyIn138 r))++happyReduce_310 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_310 = happyMonadReduce 3# 123# happyReduction_310+happyReduction_310 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut139 happy_x_1 of { (HappyWrap139 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut140 happy_x_3 of { (HappyWrap140 happy_var_3) -> +	( if isNilOL happy_var_1+                                           then return (happy_var_1 `appOL` happy_var_3)+                                           else case happy_var_1 of+                                             SnocOL hs t -> do+                                              t' <- addTrailingSemiA t (gl happy_var_2)+                                              return (snocOL hs t' `appOL` happy_var_3))}}})+	) (\r -> happyReturn (happyIn139 r))++happyReduce_311 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_311 = happyMonadReduce 2# 123# happyReduction_311+happyReduction_311 (happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut139 happy_x_1 of { (HappyWrap139 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	( if isNilOL happy_var_1+                                           then return happy_var_1+                                           else case happy_var_1 of+                                             SnocOL hs t -> do+                                              t' <- addTrailingSemiA t (gl happy_var_2)+                                              return (snocOL hs t'))}})+	) (\r -> happyReturn (happyIn139 r))++happyReduce_312 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_312 = happySpecReduce_1  123# happyReduction_312+happyReduction_312 happy_x_1+	 =  case happyOut140 happy_x_1 of { (HappyWrap140 happy_var_1) -> +	happyIn139+		 (happy_var_1+	)}++happyReduce_313 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_313 = happySpecReduce_0  123# happyReduction_313+happyReduction_313  =  happyIn139+		 (nilOL+	)++happyReduce_314 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_314 = happyMonadReduce 2# 124# happyReduction_314+happyReduction_314 (happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut265 happy_x_1 of { (HappyWrap265 happy_var_1) -> +	case happyOut143 happy_x_2 of { (HappyWrap143 happy_var_2) -> +	( fmap unitOL $ acsA (\cs -> sLL happy_var_1 happy_var_2+                     (Warning (EpAnn (glR happy_var_1) (fst $ unLoc happy_var_2) cs) (unLoc happy_var_1)+                              (WarningTxt (noLoc NoSourceText) $ map stringLiteralToHsDocWst $ snd $ unLoc happy_var_2))))}})+	) (\r -> happyReturn (happyIn140 r))++happyReduce_315 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_315 = happyMonadReduce 3# 125# happyReduction_315+happyReduction_315 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut141 happy_x_1 of { (HappyWrap141 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut142 happy_x_3 of { (HappyWrap142 happy_var_3) -> +	( if isNilOL happy_var_1+                                           then return (happy_var_1 `appOL` happy_var_3)+                                           else case happy_var_1 of+                                             SnocOL hs t -> do+                                              t' <- addTrailingSemiA t (gl happy_var_2)+                                              return (snocOL hs t' `appOL` happy_var_3))}}})+	) (\r -> happyReturn (happyIn141 r))++happyReduce_316 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_316 = happyMonadReduce 2# 125# happyReduction_316+happyReduction_316 (happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut141 happy_x_1 of { (HappyWrap141 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	( if isNilOL happy_var_1+                                           then return happy_var_1+                                           else case happy_var_1 of+                                             SnocOL hs t -> do+                                              t' <- addTrailingSemiA t (gl happy_var_2)+                                              return (snocOL hs t'))}})+	) (\r -> happyReturn (happyIn141 r))++happyReduce_317 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_317 = happySpecReduce_1  125# happyReduction_317+happyReduction_317 happy_x_1+	 =  case happyOut142 happy_x_1 of { (HappyWrap142 happy_var_1) -> +	happyIn141+		 (happy_var_1+	)}++happyReduce_318 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_318 = happySpecReduce_0  125# happyReduction_318+happyReduction_318  =  happyIn141+		 (nilOL+	)++happyReduce_319 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_319 = happyMonadReduce 2# 126# happyReduction_319+happyReduction_319 (happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut265 happy_x_1 of { (HappyWrap265 happy_var_1) -> +	case happyOut143 happy_x_2 of { (HappyWrap143 happy_var_2) -> +	( fmap unitOL $ acsA (\cs -> sLL happy_var_1 happy_var_2 $ (Warning (EpAnn (glR happy_var_1) (fst $ unLoc happy_var_2) cs) (unLoc happy_var_1)+                                          (DeprecatedTxt (noLoc NoSourceText) $ map stringLiteralToHsDocWst $ snd $ unLoc happy_var_2))))}})+	) (\r -> happyReturn (happyIn142 r))++happyReduce_320 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_320 = happySpecReduce_1  127# happyReduction_320+happyReduction_320 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn143+		 (sL1 happy_var_1 ([],[L (gl happy_var_1) (getStringLiteral happy_var_1)])+	)}++happyReduce_321 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_321 = happySpecReduce_3  127# happyReduction_321+happyReduction_321 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut144 happy_x_2 of { (HappyWrap144 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	happyIn143+		 (sLL happy_var_1 happy_var_3 $ ([mos happy_var_1,mcs happy_var_3],fromOL (unLoc happy_var_2))+	)}}}++happyReduce_322 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_322 = happyMonadReduce 3# 128# happyReduction_322+happyReduction_322 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut144 happy_x_1 of { (HappyWrap144 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	( if isNilOL (unLoc happy_var_1)+                                then return (sLL happy_var_1 happy_var_3 (unLoc happy_var_1 `snocOL`+                                                  (L (gl happy_var_3) (getStringLiteral happy_var_3))))+                                else case (unLoc happy_var_1) of+                                   SnocOL hs t -> do+                                     let { t' = addTrailingCommaS t (glAA happy_var_2) }+                                     return (sLL happy_var_1 happy_var_3 (snocOL hs t' `snocOL`+                                                  (L (gl happy_var_3) (getStringLiteral happy_var_3)))))}}})+	) (\r -> happyReturn (happyIn144 r))++happyReduce_323 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_323 = happySpecReduce_1  128# happyReduction_323+happyReduction_323 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn144+		 (sLL happy_var_1 happy_var_1 (unitOL (L (gl happy_var_1) (getStringLiteral happy_var_1)))+	)}++happyReduce_324 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_324 = happySpecReduce_0  128# happyReduction_324+happyReduction_324  =  happyIn144+		 (noLoc nilOL+	)++happyReduce_325 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_325 = happyMonadReduce 4# 129# happyReduction_325+happyReduction_325 (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 { happy_var_1 -> +	case happyOut266 happy_x_2 of { (HappyWrap266 happy_var_2) -> +	case happyOut213 happy_x_3 of { (HappyWrap213 happy_var_3) -> +	case happyOutTok happy_x_4 of { happy_var_4 -> +	( runPV (unECP happy_var_3) >>= \ happy_var_3 ->+                                            acsA (\cs -> sLL happy_var_1 happy_var_4 (AnnD noExtField $ HsAnnotation+                                            (EpAnn (glR happy_var_1) (AnnPragma (mo happy_var_1) (mc happy_var_4) []) cs)+                                            (getANN_PRAGs happy_var_1)+                                            (ValueAnnProvenance happy_var_2) happy_var_3)))}}}})+	) (\r -> happyReturn (happyIn145 r))++happyReduce_326 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_326 = happyMonadReduce 5# 129# happyReduction_326+happyReduction_326 (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 { happy_var_1 -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut286 happy_x_3 of { (HappyWrap286 happy_var_3) -> +	case happyOut213 happy_x_4 of { (HappyWrap213 happy_var_4) -> +	case happyOutTok happy_x_5 of { happy_var_5 -> +	( runPV (unECP happy_var_4) >>= \ happy_var_4 ->+                                            acsA (\cs -> sLL happy_var_1 happy_var_5 (AnnD noExtField $ HsAnnotation+                                            (EpAnn (glR happy_var_1) (AnnPragma (mo happy_var_1) (mc happy_var_5) [mj AnnType happy_var_2]) cs)+                                            (getANN_PRAGs happy_var_1)+                                            (TypeAnnProvenance happy_var_3) happy_var_4)))}}}}})+	) (\r -> happyReturn (happyIn145 r))++happyReduce_327 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_327 = happyMonadReduce 4# 129# happyReduction_327+happyReduction_327 (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 { happy_var_1 -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut213 happy_x_3 of { (HappyWrap213 happy_var_3) -> +	case happyOutTok happy_x_4 of { happy_var_4 -> +	( runPV (unECP happy_var_3) >>= \ happy_var_3 ->+                                            acsA (\cs -> sLL happy_var_1 happy_var_4 (AnnD noExtField $ HsAnnotation+                                                (EpAnn (glR happy_var_1) (AnnPragma (mo happy_var_1) (mc happy_var_4) [mj AnnModule happy_var_2]) cs)+                                                (getANN_PRAGs happy_var_1)+                                                 ModuleAnnProvenance happy_var_3)))}}}})+	) (\r -> happyReturn (happyIn145 r))++happyReduce_328 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_328 = happyMonadReduce 4# 130# happyReduction_328+happyReduction_328 (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 { happy_var_1 -> +	case happyOut147 happy_x_2 of { (HappyWrap147 happy_var_2) -> +	case happyOut148 happy_x_3 of { (HappyWrap148 happy_var_3) -> +	case happyOut149 happy_x_4 of { (HappyWrap149 happy_var_4) -> +	( mkImport happy_var_2 happy_var_3 (snd $ unLoc happy_var_4) >>= \i ->+                 return (sLL happy_var_1 happy_var_4 (mj AnnImport happy_var_1 : (fst $ unLoc happy_var_4),i)))}}}})+	) (\r -> happyReturn (happyIn146 r))++happyReduce_329 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_329 = happyMonadReduce 3# 130# happyReduction_329+happyReduction_329 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut147 happy_x_2 of { (HappyWrap147 happy_var_2) -> +	case happyOut149 happy_x_3 of { (HappyWrap149 happy_var_3) -> +	( do { d <- mkImport happy_var_2 (noLoc PlaySafe) (snd $ unLoc happy_var_3);+                    return (sLL happy_var_1 happy_var_3 (mj AnnImport happy_var_1 : (fst $ unLoc happy_var_3),d)) })}}})+	) (\r -> happyReturn (happyIn146 r))++happyReduce_330 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_330 = happyMonadReduce 3# 130# happyReduction_330+happyReduction_330 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut147 happy_x_2 of { (HappyWrap147 happy_var_2) -> +	case happyOut149 happy_x_3 of { (HappyWrap149 happy_var_3) -> +	( mkExport happy_var_2 (snd $ unLoc happy_var_3) >>= \i ->+                  return (sLL happy_var_1 happy_var_3 (mj AnnExport happy_var_1 : (fst $ unLoc happy_var_3),i) ))}}})+	) (\r -> happyReturn (happyIn146 r))++happyReduce_331 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_331 = happySpecReduce_1  131# happyReduction_331+happyReduction_331 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn147+		 (sLL happy_var_1 happy_var_1 StdCallConv+	)}++happyReduce_332 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_332 = happySpecReduce_1  131# happyReduction_332+happyReduction_332 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn147+		 (sLL happy_var_1 happy_var_1 CCallConv+	)}++happyReduce_333 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_333 = happySpecReduce_1  131# happyReduction_333+happyReduction_333 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn147+		 (sLL happy_var_1 happy_var_1 CApiConv+	)}++happyReduce_334 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_334 = happySpecReduce_1  131# happyReduction_334+happyReduction_334 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn147+		 (sLL happy_var_1 happy_var_1 PrimCallConv+	)}++happyReduce_335 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_335 = happySpecReduce_1  131# happyReduction_335+happyReduction_335 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn147+		 (sLL happy_var_1 happy_var_1 JavaScriptCallConv+	)}++happyReduce_336 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_336 = happySpecReduce_1  132# happyReduction_336+happyReduction_336 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn148+		 (sLL happy_var_1 happy_var_1 PlayRisky+	)}++happyReduce_337 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_337 = happySpecReduce_1  132# happyReduction_337+happyReduction_337 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn148+		 (sLL happy_var_1 happy_var_1 PlaySafe+	)}++happyReduce_338 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_338 = happySpecReduce_1  132# happyReduction_338+happyReduction_338 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn148+		 (sLL happy_var_1 happy_var_1 PlayInterruptible+	)}++happyReduce_339 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_339 = happyReduce 4# 133# happyReduction_339+happyReduction_339 (happy_x_4 `HappyStk`+	happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest)+	 = case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut297 happy_x_2 of { (HappyWrap297 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	case happyOut153 happy_x_4 of { (HappyWrap153 happy_var_4) -> +	happyIn149+		 (sLL happy_var_1 (reLoc happy_var_4) ([mu AnnDcolon happy_var_3]+                                             ,(L (getLoc happy_var_1)+                                                    (getStringLiteral happy_var_1), happy_var_2, happy_var_4))+	) `HappyStk` happyRest}}}}++happyReduce_340 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_340 = happySpecReduce_3  133# happyReduction_340+happyReduction_340 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut297 happy_x_1 of { (HappyWrap297 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut153 happy_x_3 of { (HappyWrap153 happy_var_3) -> +	happyIn149+		 (sLL (reLocN happy_var_1) (reLoc happy_var_3) ([mu AnnDcolon happy_var_2]+                                             ,(noLoc (StringLiteral NoSourceText nilFS Nothing), happy_var_1, happy_var_3))+	)}}}++happyReduce_341 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_341 = happySpecReduce_0  134# happyReduction_341+happyReduction_341  =  happyIn150+		 (Nothing+	)++happyReduce_342 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_342 = happySpecReduce_2  134# happyReduction_342+happyReduction_342 happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut159 happy_x_2 of { (HappyWrap159 happy_var_2) -> +	happyIn150+		 (Just (mu AnnDcolon happy_var_1, happy_var_2)+	)}}++happyReduce_343 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_343 = happySpecReduce_0  135# happyReduction_343+happyReduction_343  =  happyIn151+		 (([], Nothing)+	)++happyReduce_344 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_344 = happySpecReduce_2  135# happyReduction_344+happyReduction_344 happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut277 happy_x_2 of { (HappyWrap277 happy_var_2) -> +	happyIn151+		 (([mu AnnDcolon happy_var_1], Just happy_var_2)+	)}}++happyReduce_345 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_345 = happySpecReduce_1  136# happyReduction_345+happyReduction_345 happy_x_1+	 =  case happyOut153 happy_x_1 of { (HappyWrap153 happy_var_1) -> +	happyIn152+		 (happy_var_1+	)}++happyReduce_346 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_346 = happyMonadReduce 3# 136# happyReduction_346+happyReduction_346 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut159 happy_x_1 of { (HappyWrap159 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut181 happy_x_3 of { (HappyWrap181 happy_var_3) -> +	( acsA (\cs -> sLLAA happy_var_1 happy_var_3 $ mkHsImplicitSigType $+                                               sLLa  (reLoc happy_var_1) (reLoc happy_var_3) $ HsKindSig (EpAnn (glAR happy_var_1) [mu AnnDcolon happy_var_2] cs) happy_var_1 happy_var_3))}}})+	) (\r -> happyReturn (happyIn152 r))++happyReduce_347 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_347 = happySpecReduce_1  137# happyReduction_347+happyReduction_347 happy_x_1+	 =  case happyOut159 happy_x_1 of { (HappyWrap159 happy_var_1) -> +	happyIn153+		 (hsTypeToHsSigType happy_var_1+	)}++happyReduce_348 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_348 = happyMonadReduce 3# 138# happyReduction_348+happyReduction_348 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut154 happy_x_1 of { (HappyWrap154 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut297 happy_x_3 of { (HappyWrap297 happy_var_3) -> +	( case unLoc happy_var_1 of+                                           [] -> return (sLL happy_var_1 (reLocN happy_var_3) (happy_var_3 : unLoc happy_var_1))+                                           (h:t) -> do+                                             h' <- addTrailingCommaN h (gl happy_var_2)+                                             return (sLL happy_var_1 (reLocN happy_var_3) (happy_var_3 : h' : t)))}}})+	) (\r -> happyReturn (happyIn154 r))++happyReduce_349 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_349 = happySpecReduce_1  138# happyReduction_349+happyReduction_349 happy_x_1+	 =  case happyOut297 happy_x_1 of { (HappyWrap297 happy_var_1) -> +	happyIn154+		 (sL1N happy_var_1 [happy_var_1]+	)}++happyReduce_350 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_350 = happySpecReduce_1  139# happyReduction_350+happyReduction_350 happy_x_1+	 =  case happyOut153 happy_x_1 of { (HappyWrap153 happy_var_1) -> +	happyIn155+		 (unitOL happy_var_1+	)}++happyReduce_351 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_351 = happyMonadReduce 3# 139# happyReduction_351+happyReduction_351 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut153 happy_x_1 of { (HappyWrap153 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut155 happy_x_3 of { (HappyWrap155 happy_var_3) -> +	( do { st <- addTrailingCommaA happy_var_1 (gl happy_var_2)+                                   ; return $ unitOL st `appOL` happy_var_3 })}}})+	) (\r -> happyReturn (happyIn155 r))++happyReduce_352 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_352 = happySpecReduce_2  140# happyReduction_352+happyReduction_352 happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	happyIn156+		 (sLL happy_var_1 happy_var_2 (UnpackednessPragma [mo happy_var_1, mc happy_var_2] (getUNPACK_PRAGs happy_var_1) SrcUnpack)+	)}}++happyReduce_353 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_353 = happySpecReduce_2  140# happyReduction_353+happyReduction_353 happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	happyIn156+		 (sLL happy_var_1 happy_var_2 (UnpackednessPragma [mo happy_var_1, mc happy_var_2] (getNOUNPACK_PRAGs happy_var_1) SrcNoUnpack)+	)}}++happyReduce_354 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_354 = happyMonadReduce 3# 141# happyReduction_354+happyReduction_354 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut174 happy_x_2 of { (HappyWrap174 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	( do { hintExplicitForall happy_var_1+                                       ; acs (\cs -> (sLL happy_var_1 happy_var_3 $+                                           mkHsForAllInvisTele (EpAnn (glR happy_var_1) (mu AnnForall happy_var_1,mu AnnDot happy_var_3) cs) happy_var_2 )) })}}})+	) (\r -> happyReturn (happyIn157 r))++happyReduce_355 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_355 = happyMonadReduce 3# 141# happyReduction_355+happyReduction_355 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut174 happy_x_2 of { (HappyWrap174 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	( do { hintExplicitForall happy_var_1+                                       ; req_tvbs <- fromSpecTyVarBndrs happy_var_2+                                       ; acs (\cs -> (sLL happy_var_1 happy_var_3 $+                                           mkHsForAllVisTele (EpAnn (glR happy_var_1) (mu AnnForall happy_var_1,mu AnnRarrow happy_var_3) cs) req_tvbs )) })}}})+	) (\r -> happyReturn (happyIn157 r))++happyReduce_356 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_356 = happySpecReduce_1  142# happyReduction_356+happyReduction_356 happy_x_1+	 =  case happyOut159 happy_x_1 of { (HappyWrap159 happy_var_1) -> +	happyIn158+		 (happy_var_1+	)}++happyReduce_357 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_357 = happyMonadReduce 3# 142# happyReduction_357+happyReduction_357 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut159 happy_x_1 of { (HappyWrap159 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut181 happy_x_3 of { (HappyWrap181 happy_var_3) -> +	( acsA (\cs -> sLLAA happy_var_1 happy_var_3 $ HsKindSig (EpAnn (glAR happy_var_1) [mu AnnDcolon happy_var_2] cs) happy_var_1 happy_var_3))}}})+	) (\r -> happyReturn (happyIn158 r))++happyReduce_358 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_358 = happySpecReduce_2  143# happyReduction_358+happyReduction_358 happy_x_2+	happy_x_1+	 =  case happyOut157 happy_x_1 of { (HappyWrap157 happy_var_1) -> +	case happyOut159 happy_x_2 of { (HappyWrap159 happy_var_2) -> +	happyIn159+		 (reLocA $ sLL happy_var_1 (reLoc happy_var_2) $+                                              HsForAllTy { hst_tele = unLoc happy_var_1+                                                         , hst_xforall = noExtField+                                                         , hst_body = happy_var_2 }+	)}}++happyReduce_359 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_359 = happyMonadReduce 3# 143# happyReduction_359+happyReduction_359 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut160 happy_x_1 of { (HappyWrap160 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut159 happy_x_3 of { (HappyWrap159 happy_var_3) -> +	( acsA (\cs -> (sLL (reLoc happy_var_1) (reLoc happy_var_3) $+                                            HsQualTy { hst_ctxt = addTrailingDarrowC happy_var_1 happy_var_2 cs+                                                     , hst_xqual = NoExtField+                                                     , hst_body = happy_var_3 })))}}})+	) (\r -> happyReturn (happyIn159 r))++happyReduce_360 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_360 = happyMonadReduce 3# 143# happyReduction_360+happyReduction_360 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut258 happy_x_1 of { (HappyWrap258 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut159 happy_x_3 of { (HappyWrap159 happy_var_3) -> +	( acsA (\cs -> sLL happy_var_1 (reLoc happy_var_3) (HsIParamTy (EpAnn (glR happy_var_1) [mu AnnDcolon happy_var_2] cs) (reLocA happy_var_1) happy_var_3)))}}})+	) (\r -> happyReturn (happyIn159 r))++happyReduce_361 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_361 = happySpecReduce_1  143# happyReduction_361+happyReduction_361 happy_x_1+	 =  case happyOut161 happy_x_1 of { (HappyWrap161 happy_var_1) -> +	happyIn159+		 (happy_var_1+	)}++happyReduce_362 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_362 = happyMonadReduce 1# 144# happyReduction_362+happyReduction_362 (happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut163 happy_x_1 of { (HappyWrap163 happy_var_1) -> +	( checkContext happy_var_1)})+	) (\r -> happyReturn (happyIn160 r))++happyReduce_363 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_363 = happySpecReduce_1  145# happyReduction_363+happyReduction_363 happy_x_1+	 =  case happyOut163 happy_x_1 of { (HappyWrap163 happy_var_1) -> +	happyIn161+		 (happy_var_1+	)}++happyReduce_364 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_364 = happyMonadReduce 3# 145# happyReduction_364+happyReduction_364 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut163 happy_x_1 of { (HappyWrap163 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut159 happy_x_3 of { (HappyWrap159 happy_var_3) -> +	( acsA (\cs -> sLL (reLoc happy_var_1) (reLoc happy_var_3)+                                            $ HsFunTy (EpAnn (glAR happy_var_1) NoEpAnns cs) (HsUnrestrictedArrow (hsUniTok happy_var_2)) happy_var_1 happy_var_3))}}})+	) (\r -> happyReturn (happyIn161 r))++happyReduce_365 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_365 = happyMonadReduce 4# 145# happyReduction_365+happyReduction_365 (happy_x_4 `HappyStk`+	happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut163 happy_x_1 of { (HappyWrap163 happy_var_1) -> +	case happyOut162 happy_x_2 of { (HappyWrap162 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	case happyOut159 happy_x_4 of { (HappyWrap159 happy_var_4) -> +	( hintLinear (getLoc happy_var_2)+                                       >> let arr = (unLoc happy_var_2) (hsUniTok happy_var_3)+                                          in acsA (\cs -> sLL (reLoc happy_var_1) (reLoc happy_var_4)+                                           $ HsFunTy (EpAnn (glAR happy_var_1) NoEpAnns cs) arr happy_var_1 happy_var_4))}}}})+	) (\r -> happyReturn (happyIn161 r))++happyReduce_366 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_366 = happyMonadReduce 3# 145# happyReduction_366+happyReduction_366 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut163 happy_x_1 of { (HappyWrap163 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut159 happy_x_3 of { (HappyWrap159 happy_var_3) -> +	( hintLinear (getLoc happy_var_2) >>+                                          acsA (\cs -> sLL (reLoc happy_var_1) (reLoc happy_var_3)+                                            $ HsFunTy (EpAnn (glAR happy_var_1) NoEpAnns cs) (HsLinearArrow (HsLolly (hsTok happy_var_2))) happy_var_1 happy_var_3))}}})+	) (\r -> happyReturn (happyIn161 r))++happyReduce_367 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_367 = happySpecReduce_2  146# happyReduction_367+happyReduction_367 happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut168 happy_x_2 of { (HappyWrap168 happy_var_2) -> +	happyIn162+		 (sLL happy_var_1 (reLoc happy_var_2) (mkMultTy (hsTok happy_var_1) happy_var_2)+	)}}++happyReduce_368 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_368 = happyMonadReduce 1# 147# happyReduction_368+happyReduction_368 (happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut164 happy_x_1 of { (HappyWrap164 happy_var_1) -> +	( runPV happy_var_1)})+	) (\r -> happyReturn (happyIn163 r))++happyReduce_369 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_369 = happySpecReduce_1  148# happyReduction_369+happyReduction_369 happy_x_1+	 =  case happyOut165 happy_x_1 of { (HappyWrap165 happy_var_1) -> +	happyIn164+		 (happy_var_1+	)}++happyReduce_370 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_370 = happySpecReduce_3  148# happyReduction_370+happyReduction_370 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut165 happy_x_1 of { (HappyWrap165 happy_var_1) -> +	case happyOut167 happy_x_2 of { (HappyWrap167 happy_var_2) -> +	case happyOut164 happy_x_3 of { (HappyWrap164 happy_var_3) -> +	happyIn164+		 (happy_var_1 >>= \ happy_var_1 ->+                                          happy_var_3 >>= \ happy_var_3 ->+                                          do { let (op, prom) = happy_var_2+                                             ; when (looksLikeMult happy_var_1 op happy_var_3) $ hintLinear (getLocA op)+                                             ; mkHsOpTyPV prom happy_var_1 op happy_var_3 }+	)}}}++happyReduce_371 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_371 = happySpecReduce_2  148# happyReduction_371+happyReduction_371 happy_x_2+	happy_x_1+	 =  case happyOut156 happy_x_1 of { (HappyWrap156 happy_var_1) -> +	case happyOut164 happy_x_2 of { (HappyWrap164 happy_var_2) -> +	happyIn164+		 (happy_var_2 >>= \ happy_var_2 ->+                                          mkUnpackednessPV happy_var_1 happy_var_2+	)}}++happyReduce_372 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_372 = happySpecReduce_1  149# happyReduction_372+happyReduction_372 happy_x_1+	 =  case happyOut168 happy_x_1 of { (HappyWrap168 happy_var_1) -> +	happyIn165+		 (mkHsAppTyHeadPV happy_var_1+	)}++happyReduce_373 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_373 = happySpecReduce_1  149# happyReduction_373+happyReduction_373 happy_x_1+	 =  case happyOut167 happy_x_1 of { (HappyWrap167 happy_var_1) -> +	happyIn165+		 (failOpFewArgs (fst happy_var_1)+	)}++happyReduce_374 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_374 = happySpecReduce_2  149# happyReduction_374+happyReduction_374 happy_x_2+	happy_x_1+	 =  case happyOut165 happy_x_1 of { (HappyWrap165 happy_var_1) -> +	case happyOut166 happy_x_2 of { (HappyWrap166 happy_var_2) -> +	happyIn165+		 (happy_var_1 >>= \ happy_var_1 ->+                                          mkHsAppTyPV happy_var_1 happy_var_2+	)}}++happyReduce_375 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_375 = happySpecReduce_3  149# happyReduction_375+happyReduction_375 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut165 happy_x_1 of { (HappyWrap165 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut168 happy_x_3 of { (HappyWrap168 happy_var_3) -> +	happyIn165+		 (happy_var_1 >>= \ happy_var_1 ->+                                          mkHsAppKindTyPV happy_var_1 (getLoc happy_var_2) happy_var_3+	)}}}++happyReduce_376 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_376 = happySpecReduce_1  150# happyReduction_376+happyReduction_376 happy_x_1+	 =  case happyOut168 happy_x_1 of { (HappyWrap168 happy_var_1) -> +	happyIn166+		 (happy_var_1+	)}++happyReduce_377 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_377 = happyMonadReduce 2# 150# happyReduction_377+happyReduction_377 (happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut156 happy_x_1 of { (HappyWrap156 happy_var_1) -> +	case happyOut168 happy_x_2 of { (HappyWrap168 happy_var_2) -> +	( addUnpackednessP happy_var_1 happy_var_2)}})+	) (\r -> happyReturn (happyIn166 r))++happyReduce_378 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_378 = happySpecReduce_1  151# happyReduction_378+happyReduction_378 happy_x_1+	 =  case happyOut281 happy_x_1 of { (HappyWrap281 happy_var_1) -> +	happyIn167+		 ((happy_var_1, NotPromoted)+	)}++happyReduce_379 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_379 = happySpecReduce_1  151# happyReduction_379+happyReduction_379 happy_x_1+	 =  case happyOut295 happy_x_1 of { (HappyWrap295 happy_var_1) -> +	happyIn167+		 ((happy_var_1, NotPromoted)+	)}++happyReduce_380 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_380 = happyMonadReduce 2# 151# happyReduction_380+happyReduction_380 (happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut276 happy_x_2 of { (HappyWrap276 happy_var_2) -> +	( do { op <- amsrn (sLL happy_var_1 (reLoc happy_var_2) (unLoc happy_var_2))+                                                            (NameAnnQuote (glAA happy_var_1) (gl happy_var_2) [])+                                              ; return (op, IsPromoted) })}})+	) (\r -> happyReturn (happyIn167 r))++happyReduce_381 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_381 = happyMonadReduce 2# 151# happyReduction_381+happyReduction_381 (happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut288 happy_x_2 of { (HappyWrap288 happy_var_2) -> +	( do { op <- amsrn (sLL happy_var_1 (reLoc happy_var_2) (unLoc happy_var_2))+                                                            (NameAnnQuote (glAA happy_var_1) (gl happy_var_2) [])+                                              ; return (op, IsPromoted) })}})+	) (\r -> happyReturn (happyIn167 r))++happyReduce_382 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_382 = happyMonadReduce 1# 152# happyReduction_382+happyReduction_382 (happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut278 happy_x_1 of { (HappyWrap278 happy_var_1) -> +	( acsa (\cs -> sL1a (reLocN happy_var_1) (HsTyVar (EpAnn (glNR happy_var_1) [] cs) NotPromoted happy_var_1)))})+	) (\r -> happyReturn (happyIn168 r))++happyReduce_383 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_383 = happyMonadReduce 1# 152# happyReduction_383+happyReduction_383 (happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut294 happy_x_1 of { (HappyWrap294 happy_var_1) -> +	( acsa (\cs -> sL1a (reLocN happy_var_1) (HsTyVar (EpAnn (glNR happy_var_1) [] cs) NotPromoted happy_var_1)))})+	) (\r -> happyReturn (happyIn168 r))++happyReduce_384 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_384 = happyMonadReduce 1# 152# happyReduction_384+happyReduction_384 (happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	( do { warnStarIsType (getLoc happy_var_1)+                                               ; return $ reLocA $ sL1 happy_var_1 (HsStarTy noExtField (isUnicode happy_var_1)) })})+	) (\r -> happyReturn (happyIn168 r))++happyReduce_385 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_385 = happyMonadReduce 2# 152# happyReduction_385+happyReduction_385 (happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut168 happy_x_2 of { (HappyWrap168 happy_var_2) -> +	( acsA (\cs -> sLLlA happy_var_1 happy_var_2 (mkBangTy (EpAnn (glR happy_var_1) [mj AnnTilde happy_var_1] cs) SrcLazy happy_var_2)))}})+	) (\r -> happyReturn (happyIn168 r))++happyReduce_386 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_386 = happyMonadReduce 2# 152# happyReduction_386+happyReduction_386 (happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut168 happy_x_2 of { (HappyWrap168 happy_var_2) -> +	( acsA (\cs -> sLLlA happy_var_1 happy_var_2 (mkBangTy (EpAnn (glR happy_var_1) [mj AnnBang happy_var_1] cs) SrcStrict happy_var_2)))}})+	) (\r -> happyReturn (happyIn168 r))++happyReduce_387 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_387 = happyMonadReduce 3# 152# happyReduction_387+happyReduction_387 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut190 happy_x_2 of { (HappyWrap190 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	( do { decls <- acsA (\cs -> (sLL happy_var_1 happy_var_3 $ HsRecTy (EpAnn (glR happy_var_1) (AnnList (Just $ listAsAnchor happy_var_2) (Just $ moc happy_var_1) (Just $ mcc happy_var_3) [] []) cs) happy_var_2))+                                               ; checkRecordSyntax decls })}}})+	) (\r -> happyReturn (happyIn168 r))++happyReduce_388 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_388 = happyMonadReduce 2# 152# happyReduction_388+happyReduction_388 (happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	( acsA (\cs -> sLL happy_var_1 happy_var_2 $ HsTupleTy (EpAnn (glR happy_var_1) (AnnParen AnnParens (glAA happy_var_1) (glAA happy_var_2)) cs)+                                                    HsBoxedOrConstraintTuple []))}})+	) (\r -> happyReturn (happyIn168 r))++happyReduce_389 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_389 = happyMonadReduce 5# 152# happyReduction_389+happyReduction_389 (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 { happy_var_1 -> +	case happyOut158 happy_x_2 of { (HappyWrap158 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	case happyOut172 happy_x_4 of { (HappyWrap172 happy_var_4) -> +	case happyOutTok happy_x_5 of { happy_var_5 -> +	( do { h <- addTrailingCommaA happy_var_2 (gl happy_var_3)+                                               ; acsA (\cs -> sLL happy_var_1 happy_var_5 $ HsTupleTy (EpAnn (glR happy_var_1) (AnnParen AnnParens (glAA happy_var_1) (glAA happy_var_5)) cs)+                                                        HsBoxedOrConstraintTuple (h : happy_var_4)) })}}}}})+	) (\r -> happyReturn (happyIn168 r))++happyReduce_390 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_390 = happyMonadReduce 2# 152# happyReduction_390+happyReduction_390 (happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	( acsA (\cs -> sLL happy_var_1 happy_var_2 $ HsTupleTy (EpAnn (glR happy_var_1) (AnnParen AnnParensHash (glAA happy_var_1) (glAA happy_var_2)) cs) HsUnboxedTuple []))}})+	) (\r -> happyReturn (happyIn168 r))++happyReduce_391 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_391 = happyMonadReduce 3# 152# happyReduction_391+happyReduction_391 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut172 happy_x_2 of { (HappyWrap172 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	( acsA (\cs -> sLL happy_var_1 happy_var_3 $ HsTupleTy (EpAnn (glR happy_var_1) (AnnParen AnnParensHash (glAA happy_var_1) (glAA happy_var_3)) cs) HsUnboxedTuple happy_var_2))}}})+	) (\r -> happyReturn (happyIn168 r))++happyReduce_392 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_392 = happyMonadReduce 3# 152# happyReduction_392+happyReduction_392 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut173 happy_x_2 of { (HappyWrap173 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	( acsA (\cs -> sLL happy_var_1 happy_var_3 $ HsSumTy (EpAnn (glR happy_var_1) (AnnParen AnnParensHash (glAA happy_var_1) (glAA happy_var_3)) cs) happy_var_2))}}})+	) (\r -> happyReturn (happyIn168 r))++happyReduce_393 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_393 = happyMonadReduce 3# 152# happyReduction_393+happyReduction_393 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut158 happy_x_2 of { (HappyWrap158 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	( acsA (\cs -> sLL happy_var_1 happy_var_3 $ HsListTy (EpAnn (glR happy_var_1) (AnnParen AnnParensSquare (glAA happy_var_1) (glAA happy_var_3)) cs) happy_var_2))}}})+	) (\r -> happyReturn (happyIn168 r))++happyReduce_394 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_394 = happyMonadReduce 3# 152# happyReduction_394+happyReduction_394 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut158 happy_x_2 of { (HappyWrap158 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	( acsA (\cs -> sLL happy_var_1 happy_var_3 $ HsParTy  (EpAnn (glR happy_var_1) (AnnParen AnnParens       (glAA happy_var_1) (glAA happy_var_3)) cs) happy_var_2))}}})+	) (\r -> happyReturn (happyIn168 r))++happyReduce_395 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_395 = happySpecReduce_1  152# happyReduction_395+happyReduction_395 happy_x_1+	 =  case happyOut205 happy_x_1 of { (HappyWrap205 happy_var_1) -> +	happyIn168+		 (mapLocA (HsSpliceTy noExtField) happy_var_1+	)}++happyReduce_396 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_396 = happySpecReduce_1  152# happyReduction_396+happyReduction_396 happy_x_1+	 =  case happyOut218 happy_x_1 of { (HappyWrap218 happy_var_1) -> +	happyIn168+		 (mapLocA (HsSpliceTy noExtField) happy_var_1+	)}++happyReduce_397 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_397 = happyMonadReduce 2# 152# happyReduction_397+happyReduction_397 (happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut267 happy_x_2 of { (HappyWrap267 happy_var_2) -> +	( acsA (\cs -> sLL happy_var_1 (reLocN happy_var_2) $ HsTyVar (EpAnn (glR happy_var_1) [mj AnnSimpleQuote happy_var_1,mjN AnnName happy_var_2] cs) IsPromoted happy_var_2))}})+	) (\r -> happyReturn (happyIn168 r))++happyReduce_398 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_398 = happyMonadReduce 6# 152# happyReduction_398+happyReduction_398 (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_1 of { happy_var_1 -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut158 happy_x_3 of { (HappyWrap158 happy_var_3) -> +	case happyOutTok happy_x_4 of { happy_var_4 -> +	case happyOut172 happy_x_5 of { (HappyWrap172 happy_var_5) -> +	case happyOutTok happy_x_6 of { happy_var_6 -> +	( do { h <- addTrailingCommaA happy_var_3 (gl happy_var_4)+                                   ; acsA (\cs -> sLL happy_var_1 happy_var_6 $ HsExplicitTupleTy (EpAnn (glR happy_var_1) [mj AnnSimpleQuote happy_var_1,mop happy_var_2,mcp happy_var_6] cs) (h : happy_var_5)) })}}}}}})+	) (\r -> happyReturn (happyIn168 r))++happyReduce_399 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_399 = happyMonadReduce 4# 152# happyReduction_399+happyReduction_399 (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 { happy_var_1 -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut171 happy_x_3 of { (HappyWrap171 happy_var_3) -> +	case happyOutTok happy_x_4 of { happy_var_4 -> +	( acsA (\cs -> sLL happy_var_1 happy_var_4 $ HsExplicitListTy (EpAnn (glR happy_var_1) [mj AnnSimpleQuote happy_var_1,mos happy_var_2,mcs happy_var_4] cs) IsPromoted happy_var_3))}}}})+	) (\r -> happyReturn (happyIn168 r))++happyReduce_400 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_400 = happyMonadReduce 2# 152# happyReduction_400+happyReduction_400 (happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut297 happy_x_2 of { (HappyWrap297 happy_var_2) -> +	( acsA (\cs -> sLL happy_var_1 (reLocN happy_var_2) $ HsTyVar (EpAnn (glR happy_var_1) [mj AnnSimpleQuote happy_var_1,mjN AnnName happy_var_2] cs) IsPromoted happy_var_2))}})+	) (\r -> happyReturn (happyIn168 r))++happyReduce_401 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_401 = happyMonadReduce 5# 152# happyReduction_401+happyReduction_401 (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 { happy_var_1 -> +	case happyOut158 happy_x_2 of { (HappyWrap158 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	case happyOut172 happy_x_4 of { (HappyWrap172 happy_var_4) -> +	case happyOutTok happy_x_5 of { happy_var_5 -> +	( do { h <- addTrailingCommaA happy_var_2 (gl happy_var_3)+                                                ; acsA (\cs -> sLL happy_var_1 happy_var_5 $ HsExplicitListTy (EpAnn (glR happy_var_1) [mos happy_var_1,mcs happy_var_5] cs) NotPromoted (h:happy_var_4)) })}}}}})+	) (\r -> happyReturn (happyIn168 r))++happyReduce_402 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_402 = happySpecReduce_1  152# happyReduction_402+happyReduction_402 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn168+		 (reLocA $ sLL happy_var_1 happy_var_1 $ HsTyLit noExtField $ HsNumTy (getINTEGERs happy_var_1)+                                                           (il_value (getINTEGER happy_var_1))+	)}++happyReduce_403 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_403 = happySpecReduce_1  152# happyReduction_403+happyReduction_403 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn168+		 (reLocA $ sLL happy_var_1 happy_var_1 $ HsTyLit noExtField $ HsCharTy (getCHARs happy_var_1)+                                                                        (getCHAR happy_var_1)+	)}++happyReduce_404 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_404 = happySpecReduce_1  152# happyReduction_404+happyReduction_404 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn168+		 (reLocA $ sLL happy_var_1 happy_var_1 $ HsTyLit noExtField $ HsStrTy (getSTRINGs happy_var_1)+                                                                     (getSTRING  happy_var_1)+	)}++happyReduce_405 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_405 = happySpecReduce_1  152# happyReduction_405+happyReduction_405 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn168+		 (reLocA $ sL1 happy_var_1 $ mkAnonWildCardTy+	)}++happyReduce_406 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_406 = happySpecReduce_1  153# happyReduction_406+happyReduction_406 happy_x_1+	 =  case happyOut153 happy_x_1 of { (HappyWrap153 happy_var_1) -> +	happyIn169+		 (happy_var_1+	)}++happyReduce_407 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_407 = happySpecReduce_1  154# happyReduction_407+happyReduction_407 happy_x_1+	 =  case happyOut152 happy_x_1 of { (HappyWrap152 happy_var_1) -> +	happyIn170+		 ([happy_var_1]+	)}++happyReduce_408 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_408 = happyMonadReduce 3# 154# happyReduction_408+happyReduction_408 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut152 happy_x_1 of { (HappyWrap152 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut170 happy_x_3 of { (HappyWrap170 happy_var_3) -> +	( do { h <- addTrailingCommaA happy_var_1 (gl happy_var_2)+                                           ; return (h : happy_var_3) })}}})+	) (\r -> happyReturn (happyIn170 r))++happyReduce_409 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_409 = happySpecReduce_1  155# happyReduction_409+happyReduction_409 happy_x_1+	 =  case happyOut172 happy_x_1 of { (HappyWrap172 happy_var_1) -> +	happyIn171+		 (happy_var_1+	)}++happyReduce_410 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_410 = happySpecReduce_0  155# happyReduction_410+happyReduction_410  =  happyIn171+		 ([]+	)++happyReduce_411 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_411 = happySpecReduce_1  156# happyReduction_411+happyReduction_411 happy_x_1+	 =  case happyOut158 happy_x_1 of { (HappyWrap158 happy_var_1) -> +	happyIn172+		 ([happy_var_1]+	)}++happyReduce_412 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_412 = happyMonadReduce 3# 156# happyReduction_412+happyReduction_412 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut158 happy_x_1 of { (HappyWrap158 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut172 happy_x_3 of { (HappyWrap172 happy_var_3) -> +	( do { h <- addTrailingCommaA happy_var_1 (gl happy_var_2)+                                             ; return (h : happy_var_3) })}}})+	) (\r -> happyReturn (happyIn172 r))++happyReduce_413 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_413 = happyMonadReduce 3# 157# happyReduction_413+happyReduction_413 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut158 happy_x_1 of { (HappyWrap158 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut158 happy_x_3 of { (HappyWrap158 happy_var_3) -> +	( do { h <- addTrailingVbarA happy_var_1 (gl happy_var_2)+                                             ; return [h,happy_var_3] })}}})+	) (\r -> happyReturn (happyIn173 r))++happyReduce_414 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_414 = happyMonadReduce 3# 157# happyReduction_414+happyReduction_414 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut158 happy_x_1 of { (HappyWrap158 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut173 happy_x_3 of { (HappyWrap173 happy_var_3) -> +	( do { h <- addTrailingVbarA happy_var_1 (gl happy_var_2)+                                             ; return (h : happy_var_3) })}}})+	) (\r -> happyReturn (happyIn173 r))++happyReduce_415 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_415 = happySpecReduce_2  158# happyReduction_415+happyReduction_415 happy_x_2+	happy_x_1+	 =  case happyOut175 happy_x_1 of { (HappyWrap175 happy_var_1) -> +	case happyOut174 happy_x_2 of { (HappyWrap174 happy_var_2) -> +	happyIn174+		 (happy_var_1 : happy_var_2+	)}}++happyReduce_416 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_416 = happySpecReduce_0  158# happyReduction_416+happyReduction_416  =  happyIn174+		 ([]+	)++happyReduce_417 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_417 = happySpecReduce_1  159# happyReduction_417+happyReduction_417 happy_x_1+	 =  case happyOut176 happy_x_1 of { (HappyWrap176 happy_var_1) -> +	happyIn175+		 (happy_var_1+	)}++happyReduce_418 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_418 = happyMonadReduce 3# 159# happyReduction_418+happyReduction_418 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut294 happy_x_2 of { (HappyWrap294 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	( acsA (\cs -> sLL happy_var_1 happy_var_3 (UserTyVar (EpAnn (glR happy_var_1) [moc happy_var_1, mcc happy_var_3] cs) InferredSpec happy_var_2)))}}})+	) (\r -> happyReturn (happyIn175 r))++happyReduce_419 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_419 = happyMonadReduce 5# 159# happyReduction_419+happyReduction_419 (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 { happy_var_1 -> +	case happyOut294 happy_x_2 of { (HappyWrap294 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	case happyOut181 happy_x_4 of { (HappyWrap181 happy_var_4) -> +	case happyOutTok happy_x_5 of { happy_var_5 -> +	( acsA (\cs -> sLL happy_var_1 happy_var_5 (KindedTyVar (EpAnn (glR happy_var_1) [moc happy_var_1,mu AnnDcolon happy_var_3 ,mcc happy_var_5] cs) InferredSpec happy_var_2 happy_var_4)))}}}}})+	) (\r -> happyReturn (happyIn175 r))++happyReduce_420 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_420 = happyMonadReduce 1# 160# happyReduction_420+happyReduction_420 (happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut294 happy_x_1 of { (HappyWrap294 happy_var_1) -> +	( acsA (\cs -> (sL1 (reLocN happy_var_1) (UserTyVar (EpAnn (glNR happy_var_1) [] cs) SpecifiedSpec happy_var_1))))})+	) (\r -> happyReturn (happyIn176 r))++happyReduce_421 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_421 = happyMonadReduce 5# 160# happyReduction_421+happyReduction_421 (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 { happy_var_1 -> +	case happyOut294 happy_x_2 of { (HappyWrap294 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	case happyOut181 happy_x_4 of { (HappyWrap181 happy_var_4) -> +	case happyOutTok happy_x_5 of { happy_var_5 -> +	( acsA (\cs -> (sLL happy_var_1 happy_var_5 (KindedTyVar (EpAnn (glR happy_var_1) [mop happy_var_1,mu AnnDcolon happy_var_3 ,mcp happy_var_5] cs) SpecifiedSpec happy_var_2 happy_var_4))))}}}}})+	) (\r -> happyReturn (happyIn176 r))++happyReduce_422 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_422 = happySpecReduce_0  161# happyReduction_422+happyReduction_422  =  happyIn177+		 (noLoc ([],[])+	)++happyReduce_423 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_423 = happySpecReduce_2  161# happyReduction_423+happyReduction_423 happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut178 happy_x_2 of { (HappyWrap178 happy_var_2) -> +	happyIn177+		 ((sLL happy_var_1 happy_var_2 ([mj AnnVbar happy_var_1]+                                                 ,reverse (unLoc happy_var_2)))+	)}}++happyReduce_424 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_424 = happyMonadReduce 3# 162# happyReduction_424+happyReduction_424 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut178 happy_x_1 of { (HappyWrap178 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut179 happy_x_3 of { (HappyWrap179 happy_var_3) -> +	(+                           do { let (h:t) = unLoc happy_var_1 -- Safe from fds1 rules+                              ; h' <- addTrailingCommaA h (gl happy_var_2)+                              ; return (sLLlA happy_var_1 happy_var_3 (happy_var_3 : h' : t)) })}}})+	) (\r -> happyReturn (happyIn178 r))++happyReduce_425 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_425 = happySpecReduce_1  162# happyReduction_425+happyReduction_425 happy_x_1+	 =  case happyOut179 happy_x_1 of { (HappyWrap179 happy_var_1) -> +	happyIn178+		 (sL1A happy_var_1 [happy_var_1]+	)}++happyReduce_426 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_426 = happyMonadReduce 3# 163# happyReduction_426+happyReduction_426 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut180 happy_x_1 of { (HappyWrap180 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut180 happy_x_3 of { (HappyWrap180 happy_var_3) -> +	( acsA (\cs -> L (comb3 happy_var_1 happy_var_2 happy_var_3)+                                       (FunDep (EpAnn (glR happy_var_1) [mu AnnRarrow happy_var_2] cs)+                                               (reverse (unLoc happy_var_1))+                                               (reverse (unLoc happy_var_3)))))}}})+	) (\r -> happyReturn (happyIn179 r))++happyReduce_427 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_427 = happySpecReduce_0  164# happyReduction_427+happyReduction_427  =  happyIn180+		 (noLoc []+	)++happyReduce_428 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_428 = happySpecReduce_2  164# happyReduction_428+happyReduction_428 happy_x_2+	happy_x_1+	 =  case happyOut180 happy_x_1 of { (HappyWrap180 happy_var_1) -> +	case happyOut294 happy_x_2 of { (HappyWrap294 happy_var_2) -> +	happyIn180+		 (sLL happy_var_1 (reLocN happy_var_2) (happy_var_2 : (unLoc happy_var_1))+	)}}++happyReduce_429 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_429 = happySpecReduce_1  165# happyReduction_429+happyReduction_429 happy_x_1+	 =  case happyOut159 happy_x_1 of { (HappyWrap159 happy_var_1) -> +	happyIn181+		 (happy_var_1+	)}++happyReduce_430 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_430 = happyMonadReduce 4# 166# happyReduction_430+happyReduction_430 (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 { happy_var_1 -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut183 happy_x_3 of { (HappyWrap183 happy_var_3) -> +	case happyOutTok happy_x_4 of { happy_var_4 -> +	( checkEmptyGADTs $+                                                      L (comb2 happy_var_1 happy_var_3)+                                                        ([mj AnnWhere happy_var_1+                                                         ,moc happy_var_2+                                                         ,mcc happy_var_4]+                                                        , unLoc happy_var_3))}}}})+	) (\r -> happyReturn (happyIn182 r))++happyReduce_431 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_431 = happyMonadReduce 4# 166# happyReduction_431+happyReduction_431 (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 { happy_var_1 -> +	case happyOut183 happy_x_3 of { (HappyWrap183 happy_var_3) -> +	( checkEmptyGADTs $+                                                      L (comb2 happy_var_1 happy_var_3)+                                                        ([mj AnnWhere happy_var_1]+                                                        , unLoc happy_var_3))}})+	) (\r -> happyReturn (happyIn182 r))++happyReduce_432 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_432 = happySpecReduce_0  166# happyReduction_432+happyReduction_432  =  happyIn182+		 (noLoc ([],[])+	)++happyReduce_433 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_433 = happyMonadReduce 3# 167# happyReduction_433+happyReduction_433 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut184 happy_x_1 of { (HappyWrap184 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut183 happy_x_3 of { (HappyWrap183 happy_var_3) -> +	( do { h <- addTrailingSemiA happy_var_1 (gl happy_var_2)+                        ; return (L (comb2 (reLoc happy_var_1) happy_var_3) (h : unLoc happy_var_3)) })}}})+	) (\r -> happyReturn (happyIn183 r))++happyReduce_434 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_434 = happySpecReduce_1  167# happyReduction_434+happyReduction_434 happy_x_1+	 =  case happyOut184 happy_x_1 of { (HappyWrap184 happy_var_1) -> +	happyIn183+		 (L (glA happy_var_1) [happy_var_1]+	)}++happyReduce_435 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_435 = happySpecReduce_0  167# happyReduction_435+happyReduction_435  =  happyIn183+		 (noLoc []+	)++happyReduce_436 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_436 = happyMonadReduce 4# 168# happyReduction_436+happyReduction_436 (happy_x_4 `HappyStk`+	happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut271 happy_x_2 of { (HappyWrap271 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	case happyOut153 happy_x_4 of { (HappyWrap153 happy_var_4) -> +	( mkGadtDecl (comb2A happy_var_2 happy_var_4) (unLoc happy_var_2) happy_var_4 [mu AnnDcolon happy_var_3])}}})+	) (\r -> happyReturn (happyIn184 r))++happyReduce_437 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_437 = happySpecReduce_2  169# happyReduction_437+happyReduction_437 happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut186 happy_x_2 of { (HappyWrap186 happy_var_2) -> +	happyIn185+		 (sLL happy_var_1 happy_var_2 ([mj AnnEqual happy_var_1],unLoc happy_var_2)+	)}}++happyReduce_438 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_438 = happyMonadReduce 3# 170# happyReduction_438+happyReduction_438 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut186 happy_x_1 of { (HappyWrap186 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut187 happy_x_3 of { (HappyWrap187 happy_var_3) -> +	( do { let (h:t) = unLoc happy_var_1+                  ; h' <- addTrailingVbarA h (gl happy_var_2)+                  ; return (sLLlA happy_var_1 happy_var_3 (happy_var_3 : h' : t)) })}}})+	) (\r -> happyReturn (happyIn186 r))++happyReduce_439 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_439 = happySpecReduce_1  170# happyReduction_439+happyReduction_439 happy_x_1+	 =  case happyOut187 happy_x_1 of { (HappyWrap187 happy_var_1) -> +	happyIn186+		 (sL1A happy_var_1 [happy_var_1]+	)}++happyReduce_440 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_440 = happyMonadReduce 4# 171# happyReduction_440+happyReduction_440 (happy_x_4 `HappyStk`+	happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut188 happy_x_1 of { (HappyWrap188 happy_var_1) -> +	case happyOut160 happy_x_2 of { (HappyWrap160 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	case happyOut189 happy_x_4 of { (HappyWrap189 happy_var_4) -> +	( acsA (\cs -> let (con,details) = unLoc happy_var_4 in+                  (L (comb4 happy_var_1 (reLoc happy_var_2) happy_var_3 happy_var_4) (mkConDeclH98+                                                       (EpAnn (spanAsAnchor (comb4 happy_var_1 (reLoc happy_var_2) happy_var_3 happy_var_4))+                                                                    (mu AnnDarrow happy_var_3:(fst $ unLoc happy_var_1)) cs)+                                                       con+                                                       (snd $ unLoc happy_var_1)+                                                       (Just happy_var_2)+                                                       details))))}}}})+	) (\r -> happyReturn (happyIn187 r))++happyReduce_441 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_441 = happyMonadReduce 2# 171# happyReduction_441+happyReduction_441 (happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut188 happy_x_1 of { (HappyWrap188 happy_var_1) -> +	case happyOut189 happy_x_2 of { (HappyWrap189 happy_var_2) -> +	( acsA (\cs -> let (con,details) = unLoc happy_var_2 in+                  (L (comb2 happy_var_1 happy_var_2) (mkConDeclH98 (EpAnn (spanAsAnchor (comb2 happy_var_1 happy_var_2)) (fst $ unLoc happy_var_1) cs)+                                                      con+                                                      (snd $ unLoc happy_var_1)+                                                      Nothing   -- No context+                                                      details))))}})+	) (\r -> happyReturn (happyIn187 r))++happyReduce_442 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_442 = happySpecReduce_3  172# happyReduction_442+happyReduction_442 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut174 happy_x_2 of { (HappyWrap174 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	happyIn188+		 (sLL happy_var_1 happy_var_3 ([mu AnnForall happy_var_1,mj AnnDot happy_var_3], Just happy_var_2)+	)}}}++happyReduce_443 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_443 = happySpecReduce_0  172# happyReduction_443+happyReduction_443  =  happyIn188+		 (noLoc ([], Nothing)+	)++happyReduce_444 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_444 = happyMonadReduce 1# 173# happyReduction_444+happyReduction_444 (happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut164 happy_x_1 of { (HappyWrap164 happy_var_1) -> +	( fmap (reLoc. (mapLoc (\b -> (dataConBuilderCon b,+                                                          dataConBuilderDetails b))))+                                     (runPV happy_var_1))})+	) (\r -> happyReturn (happyIn189 r))++happyReduce_445 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_445 = happySpecReduce_0  174# happyReduction_445+happyReduction_445  =  happyIn190+		 ([]+	)++happyReduce_446 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_446 = happySpecReduce_1  174# happyReduction_446+happyReduction_446 happy_x_1+	 =  case happyOut191 happy_x_1 of { (HappyWrap191 happy_var_1) -> +	happyIn190+		 (happy_var_1+	)}++happyReduce_447 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_447 = happyMonadReduce 3# 175# happyReduction_447+happyReduction_447 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut192 happy_x_1 of { (HappyWrap192 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut191 happy_x_3 of { (HappyWrap191 happy_var_3) -> +	( do { h <- addTrailingCommaA happy_var_1 (gl happy_var_2)+                  ; return (h : happy_var_3) })}}})+	) (\r -> happyReturn (happyIn191 r))++happyReduce_448 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_448 = happySpecReduce_1  175# happyReduction_448+happyReduction_448 happy_x_1+	 =  case happyOut192 happy_x_1 of { (HappyWrap192 happy_var_1) -> +	happyIn191+		 ([happy_var_1]+	)}++happyReduce_449 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_449 = happyMonadReduce 3# 176# happyReduction_449+happyReduction_449 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut154 happy_x_1 of { (HappyWrap154 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut159 happy_x_3 of { (HappyWrap159 happy_var_3) -> +	( acsA (\cs -> L (comb2 happy_var_1 (reLoc happy_var_3))+                      (ConDeclField (EpAnn (glR happy_var_1) [mu AnnDcolon happy_var_2] cs)+                                    (reverse (map (\ln@(L l n) -> L (l2l l) $ FieldOcc noExtField ln) (unLoc happy_var_1))) happy_var_3 Nothing)))}}})+	) (\r -> happyReturn (happyIn192 r))++happyReduce_450 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_450 = happySpecReduce_0  177# happyReduction_450+happyReduction_450  =  happyIn193+		 (noLoc []+	)++happyReduce_451 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_451 = happySpecReduce_1  177# happyReduction_451+happyReduction_451 happy_x_1+	 =  case happyOut194 happy_x_1 of { (HappyWrap194 happy_var_1) -> +	happyIn193+		 (happy_var_1+	)}++happyReduce_452 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_452 = happySpecReduce_2  178# happyReduction_452+happyReduction_452 happy_x_2+	happy_x_1+	 =  case happyOut194 happy_x_1 of { (HappyWrap194 happy_var_1) -> +	case happyOut195 happy_x_2 of { (HappyWrap195 happy_var_2) -> +	happyIn194+		 (sLL happy_var_1 (reLoc happy_var_2) (happy_var_2 : unLoc happy_var_1)+	)}}++happyReduce_453 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_453 = happySpecReduce_1  178# happyReduction_453+happyReduction_453 happy_x_1+	 =  case happyOut195 happy_x_1 of { (HappyWrap195 happy_var_1) -> +	happyIn194+		 (sL1 (reLoc happy_var_1) [happy_var_1]+	)}++happyReduce_454 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_454 = happyMonadReduce 2# 179# happyReduction_454+happyReduction_454 (happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut196 happy_x_2 of { (HappyWrap196 happy_var_2) -> +	( let { full_loc = comb2A happy_var_1 happy_var_2 }+                 in acsA (\cs -> L full_loc $ HsDerivingClause (EpAnn (glR happy_var_1) [mj AnnDeriving happy_var_1] cs) Nothing happy_var_2))}})+	) (\r -> happyReturn (happyIn195 r))++happyReduce_455 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_455 = happyMonadReduce 3# 179# happyReduction_455+happyReduction_455 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut85 happy_x_2 of { (HappyWrap85 happy_var_2) -> +	case happyOut196 happy_x_3 of { (HappyWrap196 happy_var_3) -> +	( let { full_loc = comb2A happy_var_1 happy_var_3 }+                 in acsA (\cs -> L full_loc $ HsDerivingClause (EpAnn (glR happy_var_1) [mj AnnDeriving happy_var_1] cs) (Just happy_var_2) happy_var_3))}}})+	) (\r -> happyReturn (happyIn195 r))++happyReduce_456 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_456 = happyMonadReduce 3# 179# happyReduction_456+happyReduction_456 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut196 happy_x_2 of { (HappyWrap196 happy_var_2) -> +	case happyOut86 happy_x_3 of { (HappyWrap86 happy_var_3) -> +	( let { full_loc = comb2 happy_var_1 (reLoc happy_var_3) }+                 in acsA (\cs -> L full_loc $ HsDerivingClause (EpAnn (glR happy_var_1) [mj AnnDeriving happy_var_1] cs) (Just happy_var_3) happy_var_2))}}})+	) (\r -> happyReturn (happyIn195 r))++happyReduce_457 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_457 = happySpecReduce_1  180# happyReduction_457+happyReduction_457 happy_x_1+	 =  case happyOut282 happy_x_1 of { (HappyWrap282 happy_var_1) -> +	happyIn196+		 (let { tc = sL1 (reLocL happy_var_1) $ mkHsImplicitSigType $+                                           sL1 (reLocL happy_var_1) $ HsTyVar noAnn NotPromoted happy_var_1 } in+                                sL1 (reLocC happy_var_1) (DctSingle noExtField tc)+	)}++happyReduce_458 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_458 = happyMonadReduce 2# 180# happyReduction_458+happyReduction_458 (happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	( amsrc (sLL happy_var_1 happy_var_2 (DctMulti noExtField []))+                                       (AnnContext Nothing [glAA happy_var_1] [glAA happy_var_2]))}})+	) (\r -> happyReturn (happyIn196 r))++happyReduce_459 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_459 = happyMonadReduce 3# 180# happyReduction_459+happyReduction_459 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut170 happy_x_2 of { (HappyWrap170 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	( amsrc (sLL happy_var_1 happy_var_3 (DctMulti noExtField happy_var_2))+                                       (AnnContext Nothing [glAA happy_var_1] [glAA happy_var_3]))}}})+	) (\r -> happyReturn (happyIn196 r))++happyReduce_460 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_460 = happySpecReduce_1  181# happyReduction_460+happyReduction_460 happy_x_1+	 =  case happyOut202 happy_x_1 of { (HappyWrap202 happy_var_1) -> +	happyIn197+		 (happy_var_1+	)}++happyReduce_461 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_461 = happyMonadReduce 3# 181# happyReduction_461+happyReduction_461 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut207 happy_x_1 of { (HappyWrap207 happy_var_1) -> +	case happyOut150 happy_x_2 of { (HappyWrap150 happy_var_2) -> +	case happyOut199 happy_x_3 of { (HappyWrap199 happy_var_3) -> +	( runPV (unECP happy_var_1) >>= \ happy_var_1 ->+                                       do { let { l = comb2Al happy_var_1 happy_var_3 }+                                          ; r <- checkValDef l happy_var_1 happy_var_2 happy_var_3;+                                        -- Depending upon what the pattern looks like we might get either+                                        -- a FunBind or PatBind back from checkValDef. See Note+                                        -- [FunBind vs PatBind]+                                          ; cs <- getCommentsFor l+                                          ; return $! (sL (commentsA l cs) $ ValD noExtField r) })}}})+	) (\r -> happyReturn (happyIn197 r))++happyReduce_462 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_462 = happySpecReduce_1  181# happyReduction_462+happyReduction_462 happy_x_1+	 =  case happyOut112 happy_x_1 of { (HappyWrap112 happy_var_1) -> +	happyIn197+		 (happy_var_1+	)}++happyReduce_463 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_463 = happySpecReduce_1  182# happyReduction_463+happyReduction_463 happy_x_1+	 =  case happyOut197 happy_x_1 of { (HappyWrap197 happy_var_1) -> +	happyIn198+		 (happy_var_1+	)}++happyReduce_464 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_464 = happyMonadReduce 1# 182# happyReduction_464+happyReduction_464 (happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut217 happy_x_1 of { (HappyWrap217 happy_var_1) -> +	( mkSpliceDecl happy_var_1)})+	) (\r -> happyReturn (happyIn198 r))++happyReduce_465 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_465 = happyMonadReduce 3# 183# happyReduction_465+happyReduction_465 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut206 happy_x_2 of { (HappyWrap206 happy_var_2) -> +	case happyOut130 happy_x_3 of { (HappyWrap130 happy_var_3) -> +	( runPV (unECP happy_var_2) >>= \ happy_var_2 ->+                                  do { let L l (bs, csw) = adaptWhereBinds happy_var_3+                                     ; let loc = (comb3 happy_var_1 (reLoc happy_var_2) (L l bs))+                                     ; acs (\cs ->+                                       sL loc (GRHSs csw (unguardedRHS (EpAnn (anc $ rs loc) (GrhsAnn Nothing (mj AnnEqual happy_var_1)) cs) loc happy_var_2)+                                                      bs)) })}}})+	) (\r -> happyReturn (happyIn199 r))++happyReduce_466 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_466 = happyMonadReduce 2# 183# happyReduction_466+happyReduction_466 (happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut200 happy_x_1 of { (HappyWrap200 happy_var_1) -> +	case happyOut130 happy_x_2 of { (HappyWrap130 happy_var_2) -> +	( do { let {L l (bs, csw) = adaptWhereBinds happy_var_2}+                                      ; acs (\cs -> sL (comb2 happy_var_1 (L l bs))+                                                (GRHSs (cs Semi.<> csw) (reverse (unLoc happy_var_1)) bs)) })}})+	) (\r -> happyReturn (happyIn199 r))++happyReduce_467 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_467 = happySpecReduce_2  184# happyReduction_467+happyReduction_467 happy_x_2+	happy_x_1+	 =  case happyOut200 happy_x_1 of { (HappyWrap200 happy_var_1) -> +	case happyOut201 happy_x_2 of { (HappyWrap201 happy_var_2) -> +	happyIn200+		 (sLL happy_var_1 (reLoc happy_var_2) (happy_var_2 : unLoc happy_var_1)+	)}}++happyReduce_468 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_468 = happySpecReduce_1  184# happyReduction_468+happyReduction_468 happy_x_1+	 =  case happyOut201 happy_x_1 of { (HappyWrap201 happy_var_1) -> +	happyIn200+		 (sL1 (reLoc happy_var_1) [happy_var_1]+	)}++happyReduce_469 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_469 = happyMonadReduce 4# 185# happyReduction_469+happyReduction_469 (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 { happy_var_1 -> +	case happyOut234 happy_x_2 of { (HappyWrap234 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	case happyOut206 happy_x_4 of { (HappyWrap206 happy_var_4) -> +	( runPV (unECP happy_var_4) >>= \ happy_var_4 ->+                                     acsA (\cs -> sL (comb2A happy_var_1 happy_var_4) $ GRHS (EpAnn (glR happy_var_1) (GrhsAnn (Just $ glAA happy_var_1) (mj AnnEqual happy_var_3)) cs) (unLoc happy_var_2) happy_var_4))}}}})+	) (\r -> happyReturn (happyIn201 r))++happyReduce_470 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_470 = happyMonadReduce 3# 186# happyReduction_470+happyReduction_470 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut207 happy_x_1 of { (HappyWrap207 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut153 happy_x_3 of { (HappyWrap153 happy_var_3) -> +	( do { happy_var_1 <- runPV (unECP happy_var_1)+                              ; v <- checkValSigLhs happy_var_1+                              ; acsA (\cs -> (sLLAl happy_var_1 (reLoc happy_var_3) $ SigD noExtField $+                                  TypeSig (EpAnn (glAR happy_var_1) (AnnSig (mu AnnDcolon happy_var_2) []) cs) [v] (mkHsWildCardBndrs happy_var_3)))})}}})+	) (\r -> happyReturn (happyIn202 r))++happyReduce_471 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_471 = happyMonadReduce 5# 186# happyReduction_471+happyReduction_471 (happy_x_5 `HappyStk`+	happy_x_4 `HappyStk`+	happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut297 happy_x_1 of { (HappyWrap297 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut154 happy_x_3 of { (HappyWrap154 happy_var_3) -> +	case happyOutTok happy_x_4 of { happy_var_4 -> +	case happyOut153 happy_x_5 of { (HappyWrap153 happy_var_5) -> +	( do { v <- addTrailingCommaN happy_var_1 (gl happy_var_2)+                 ; let sig cs = TypeSig (EpAnn (glNR happy_var_1) (AnnSig (mu AnnDcolon happy_var_4) []) cs) (v : reverse (unLoc happy_var_3))+                                      (mkHsWildCardBndrs happy_var_5)+                 ; acsA (\cs -> sLL (reLocN happy_var_1) (reLoc happy_var_5) $ SigD noExtField (sig cs) ) })}}}}})+	) (\r -> happyReturn (happyIn202 r))++happyReduce_472 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_472 = happyMonadReduce 3# 186# happyReduction_472+happyReduction_472 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut71 happy_x_1 of { (HappyWrap71 happy_var_1) -> +	case happyOut70 happy_x_2 of { (HappyWrap70 happy_var_2) -> +	case happyOut72 happy_x_3 of { (HappyWrap72 happy_var_3) -> +	( do { mbPrecAnn <- traverse (\l2 -> do { checkPrecP l2 happy_var_3+                                                      ; pure (mj AnnVal l2) })+                                       happy_var_2+                   ; let (fixText, fixPrec) = case happy_var_2 of+                                                -- If an explicit precedence isn't supplied,+                                                -- it defaults to maxPrecedence+                                                Nothing -> (NoSourceText, maxPrecedence)+                                                Just l2 -> (fst $ unLoc l2, snd $ unLoc l2)+                   ; acsA (\cs -> sLL happy_var_1 happy_var_3 $ SigD noExtField+                            (FixSig (EpAnn (glR happy_var_1) (mj AnnInfix happy_var_1 : maybeToList mbPrecAnn) cs) (FixitySig noExtField (fromOL $ unLoc happy_var_3)+                                    (Fixity fixText fixPrec (unLoc happy_var_1)))))+                   })}}})+	) (\r -> happyReturn (happyIn202 r))++happyReduce_473 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_473 = happySpecReduce_1  186# happyReduction_473+happyReduction_473 happy_x_1+	 =  case happyOut117 happy_x_1 of { (HappyWrap117 happy_var_1) -> +	happyIn202+		 (sL1 happy_var_1 . SigD noExtField . unLoc $ happy_var_1+	)}++happyReduce_474 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_474 = happyMonadReduce 4# 186# happyReduction_474+happyReduction_474 (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 { happy_var_1 -> +	case happyOut272 happy_x_2 of { (HappyWrap272 happy_var_2) -> +	case happyOut151 happy_x_3 of { (HappyWrap151 happy_var_3) -> +	case happyOutTok happy_x_4 of { happy_var_4 -> +	( let (dcolon, tc) = happy_var_3+                   in acsA+                       (\cs -> sLL happy_var_1 happy_var_4+                         (SigD noExtField (CompleteMatchSig (EpAnn (glR happy_var_1) ([ mo happy_var_1 ] ++ dcolon ++ [mc happy_var_4]) cs) (getCOMPLETE_PRAGs happy_var_1) happy_var_2 tc))))}}}})+	) (\r -> happyReturn (happyIn202 r))++happyReduce_475 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_475 = happyMonadReduce 4# 186# happyReduction_475+happyReduction_475 (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 { happy_var_1 -> +	case happyOut203 happy_x_2 of { (HappyWrap203 happy_var_2) -> +	case happyOut118 happy_x_3 of { (HappyWrap118 happy_var_3) -> +	case happyOutTok happy_x_4 of { happy_var_4 -> +	( acsA (\cs -> (sLL happy_var_1 happy_var_4 $ SigD noExtField (InlineSig (EpAnn (glR happy_var_1) ((mo happy_var_1:fst happy_var_2) ++ [mc happy_var_4]) cs) happy_var_3+                            (mkInlinePragma (getINLINE_PRAGs happy_var_1) (getINLINE happy_var_1)+                                            (snd happy_var_2))))))}}}})+	) (\r -> happyReturn (happyIn202 r))++happyReduce_476 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_476 = happyMonadReduce 3# 186# happyReduction_476+happyReduction_476 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut298 happy_x_2 of { (HappyWrap298 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	( acsA (\cs -> (sLL happy_var_1 happy_var_3 $ SigD noExtField (InlineSig (EpAnn (glR happy_var_1) [mo happy_var_1, mc happy_var_3] cs) happy_var_2+                            (mkOpaquePragma (getOPAQUE_PRAGs happy_var_1))))))}}})+	) (\r -> happyReturn (happyIn202 r))++happyReduce_477 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_477 = happyMonadReduce 3# 186# happyReduction_477+happyReduction_477 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut298 happy_x_2 of { (HappyWrap298 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	( acsA (\cs -> sLL happy_var_1 happy_var_3 (SigD noExtField (SCCFunSig (EpAnn (glR happy_var_1) [mo happy_var_1, mc happy_var_3] cs) (getSCC_PRAGs happy_var_1) happy_var_2 Nothing))))}}})+	) (\r -> happyReturn (happyIn202 r))++happyReduce_478 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_478 = happyMonadReduce 4# 186# happyReduction_478+happyReduction_478 (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 { happy_var_1 -> +	case happyOut298 happy_x_2 of { (HappyWrap298 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	case happyOutTok happy_x_4 of { happy_var_4 -> +	( do { scc <- getSCC happy_var_3+                ; let str_lit = StringLiteral (getSTRINGs happy_var_3) scc Nothing+                ; acsA (\cs -> sLL happy_var_1 happy_var_4 (SigD noExtField (SCCFunSig (EpAnn (glR happy_var_1) [mo happy_var_1, mc happy_var_4] cs) (getSCC_PRAGs happy_var_1) happy_var_2 (Just ( sL1a happy_var_3 str_lit))))) })}}}})+	) (\r -> happyReturn (happyIn202 r))++happyReduce_479 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_479 = happyMonadReduce 6# 186# happyReduction_479+happyReduction_479 (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_1 of { happy_var_1 -> +	case happyOut203 happy_x_2 of { (HappyWrap203 happy_var_2) -> +	case happyOut298 happy_x_3 of { (HappyWrap298 happy_var_3) -> +	case happyOutTok happy_x_4 of { happy_var_4 -> +	case happyOut155 happy_x_5 of { (HappyWrap155 happy_var_5) -> +	case happyOutTok happy_x_6 of { happy_var_6 -> +	( acsA (\cs ->+                 let inl_prag = mkInlinePragma (getSPEC_PRAGs happy_var_1)+                                             (NoUserInlinePrag, FunLike) (snd happy_var_2)+                  in sLL happy_var_1 happy_var_6 $ SigD noExtField (SpecSig (EpAnn (glR happy_var_1) (mo happy_var_1:mu AnnDcolon happy_var_4:mc happy_var_6:(fst happy_var_2)) cs) happy_var_3 (fromOL happy_var_5) inl_prag)))}}}}}})+	) (\r -> happyReturn (happyIn202 r))++happyReduce_480 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_480 = happyMonadReduce 6# 186# happyReduction_480+happyReduction_480 (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_1 of { happy_var_1 -> +	case happyOut203 happy_x_2 of { (HappyWrap203 happy_var_2) -> +	case happyOut298 happy_x_3 of { (HappyWrap298 happy_var_3) -> +	case happyOutTok happy_x_4 of { happy_var_4 -> +	case happyOut155 happy_x_5 of { (HappyWrap155 happy_var_5) -> +	case happyOutTok happy_x_6 of { happy_var_6 -> +	( acsA (\cs -> sLL happy_var_1 happy_var_6 $ SigD noExtField (SpecSig (EpAnn (glR happy_var_1) (mo happy_var_1:mu AnnDcolon happy_var_4:mc happy_var_6:(fst happy_var_2)) cs) happy_var_3 (fromOL happy_var_5)+                               (mkInlinePragma (getSPEC_INLINE_PRAGs happy_var_1)+                                               (getSPEC_INLINE happy_var_1) (snd happy_var_2)))))}}}}}})+	) (\r -> happyReturn (happyIn202 r))++happyReduce_481 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_481 = happyMonadReduce 4# 186# happyReduction_481+happyReduction_481 (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 { happy_var_1 -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut169 happy_x_3 of { (HappyWrap169 happy_var_3) -> +	case happyOutTok happy_x_4 of { happy_var_4 -> +	( acsA (\cs -> sLL happy_var_1 happy_var_4+                                  $ SigD noExtField (SpecInstSig (EpAnn (glR happy_var_1) [mo happy_var_1,mj AnnInstance happy_var_2,mc happy_var_4] cs) (getSPEC_PRAGs happy_var_1) happy_var_3)))}}}})+	) (\r -> happyReturn (happyIn202 r))++happyReduce_482 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_482 = happyMonadReduce 3# 186# happyReduction_482+happyReduction_482 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut260 happy_x_2 of { (HappyWrap260 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	( acsA (\cs -> sLL happy_var_1 happy_var_3 $ SigD noExtField (MinimalSig (EpAnn (glR happy_var_1) [mo happy_var_1,mc happy_var_3] cs) (getMINIMAL_PRAGs happy_var_1) happy_var_2)))}}})+	) (\r -> happyReturn (happyIn202 r))++happyReduce_483 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_483 = happySpecReduce_0  187# happyReduction_483+happyReduction_483  =  happyIn203+		 (([],Nothing)+	)++happyReduce_484 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_484 = happySpecReduce_1  187# happyReduction_484+happyReduction_484 happy_x_1+	 =  case happyOut204 happy_x_1 of { (HappyWrap204 happy_var_1) -> +	happyIn203+		 ((fst happy_var_1,Just (snd happy_var_1))+	)}++happyReduce_485 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_485 = happySpecReduce_3  188# happyReduction_485+happyReduction_485 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	happyIn204+		 (([mj AnnOpenS happy_var_1,mj AnnVal happy_var_2,mj AnnCloseS happy_var_3]+                                  ,ActiveAfter  (getINTEGERs happy_var_2) (fromInteger (il_value (getINTEGER happy_var_2))))+	)}}}++happyReduce_486 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_486 = happyReduce 4# 188# happyReduction_486+happyReduction_486 (happy_x_4 `HappyStk`+	happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest)+	 = case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut134 happy_x_2 of { (HappyWrap134 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	case happyOutTok happy_x_4 of { happy_var_4 -> +	happyIn204+		 ((happy_var_2++[mj AnnOpenS happy_var_1,mj AnnVal happy_var_3,mj AnnCloseS happy_var_4]+                                  ,ActiveBefore (getINTEGERs happy_var_3) (fromInteger (il_value (getINTEGER happy_var_3))))+	) `HappyStk` happyRest}}}}++happyReduce_487 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_487 = happySpecReduce_1  189# happyReduction_487+happyReduction_487 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn205+		 (let { loc = getLoc happy_var_1+                                ; ITquasiQuote (quoter, quote, quoteSpan) = unLoc happy_var_1+                                ; quoterId = mkUnqual varName quoter }+                            in sL1 happy_var_1 (mkHsQuasiQuote quoterId (mkSrcSpanPs quoteSpan) quote)+	)}++happyReduce_488 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_488 = happySpecReduce_1  189# happyReduction_488+happyReduction_488 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn205+		 (let { loc = getLoc happy_var_1+                                ; ITqQuasiQuote (qual, quoter, quote, quoteSpan) = unLoc happy_var_1+                                ; quoterId = mkQual varName (qual, quoter) }+                            in sL1 happy_var_1 (mkHsQuasiQuote quoterId (mkSrcSpanPs quoteSpan) quote)+	)}++happyReduce_489 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_489 = happySpecReduce_3  190# happyReduction_489+happyReduction_489 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut207 happy_x_1 of { (HappyWrap207 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut159 happy_x_3 of { (HappyWrap159 happy_var_3) -> +	happyIn206+		 (ECP $+                                   unECP happy_var_1 >>= \ happy_var_1 ->+                                   rejectPragmaPV happy_var_1 >>+                                   mkHsTySigPV (noAnnSrcSpan $ comb2Al happy_var_1 (reLoc happy_var_3)) happy_var_1 happy_var_3+                                          [(mu AnnDcolon happy_var_2)]+	)}}}++happyReduce_490 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_490 = happyMonadReduce 3# 190# happyReduction_490+happyReduction_490 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut207 happy_x_1 of { (HappyWrap207 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut206 happy_x_3 of { (HappyWrap206 happy_var_3) -> +	( runPV (unECP happy_var_1) >>= \ happy_var_1 ->+                                   runPV (unECP happy_var_3) >>= \ happy_var_3 ->+                                   fmap ecpFromCmd $+                                   acsA (\cs -> sLLAA happy_var_1 happy_var_3 $ HsCmdArrApp (EpAnn (glAR happy_var_1) (mu Annlarrowtail happy_var_2) cs) happy_var_1 happy_var_3+                                                        HsFirstOrderApp True))}}})+	) (\r -> happyReturn (happyIn206 r))++happyReduce_491 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_491 = happyMonadReduce 3# 190# happyReduction_491+happyReduction_491 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut207 happy_x_1 of { (HappyWrap207 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut206 happy_x_3 of { (HappyWrap206 happy_var_3) -> +	( runPV (unECP happy_var_1) >>= \ happy_var_1 ->+                                   runPV (unECP happy_var_3) >>= \ happy_var_3 ->+                                   fmap ecpFromCmd $+                                   acsA (\cs -> sLLAA happy_var_1 happy_var_3 $ HsCmdArrApp (EpAnn (glAR happy_var_1) (mu Annrarrowtail happy_var_2) cs) happy_var_3 happy_var_1+                                                      HsFirstOrderApp False))}}})+	) (\r -> happyReturn (happyIn206 r))++happyReduce_492 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_492 = happyMonadReduce 3# 190# happyReduction_492+happyReduction_492 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut207 happy_x_1 of { (HappyWrap207 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut206 happy_x_3 of { (HappyWrap206 happy_var_3) -> +	( runPV (unECP happy_var_1) >>= \ happy_var_1 ->+                                   runPV (unECP happy_var_3) >>= \ happy_var_3 ->+                                   fmap ecpFromCmd $+                                   acsA (\cs -> sLLAA happy_var_1 happy_var_3 $ HsCmdArrApp (EpAnn (glAR happy_var_1) (mu AnnLarrowtail happy_var_2) cs) happy_var_1 happy_var_3+                                                      HsHigherOrderApp True))}}})+	) (\r -> happyReturn (happyIn206 r))++happyReduce_493 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_493 = happyMonadReduce 3# 190# happyReduction_493+happyReduction_493 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut207 happy_x_1 of { (HappyWrap207 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut206 happy_x_3 of { (HappyWrap206 happy_var_3) -> +	( runPV (unECP happy_var_1) >>= \ happy_var_1 ->+                                   runPV (unECP happy_var_3) >>= \ happy_var_3 ->+                                   fmap ecpFromCmd $+                                   acsA (\cs -> sLLAA happy_var_1 happy_var_3 $ HsCmdArrApp (EpAnn (glAR happy_var_1) (mu AnnRarrowtail happy_var_2) cs) happy_var_3 happy_var_1+                                                      HsHigherOrderApp False))}}})+	) (\r -> happyReturn (happyIn206 r))++happyReduce_494 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_494 = happySpecReduce_1  190# happyReduction_494+happyReduction_494 happy_x_1+	 =  case happyOut207 happy_x_1 of { (HappyWrap207 happy_var_1) -> +	happyIn206+		 (happy_var_1+	)}++happyReduce_495 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_495 = happySpecReduce_1  190# happyReduction_495+happyReduction_495 happy_x_1+	 =  case happyOut321 happy_x_1 of { (HappyWrap321 happy_var_1) -> +	happyIn206+		 (happy_var_1+	)}++happyReduce_496 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_496 = happySpecReduce_1  191# happyReduction_496+happyReduction_496 happy_x_1+	 =  case happyOut209 happy_x_1 of { (HappyWrap209 happy_var_1) -> +	happyIn207+		 (happy_var_1+	)}++happyReduce_497 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_497 = happySpecReduce_3  191# happyReduction_497+happyReduction_497 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut207 happy_x_1 of { (HappyWrap207 happy_var_1) -> +	case happyOut289 happy_x_2 of { (HappyWrap289 happy_var_2) -> +	case happyOut208 happy_x_3 of { (HappyWrap208 happy_var_3) -> +	happyIn207+		 (ECP $+                                 superInfixOp $+                                 happy_var_2 >>= \ happy_var_2 ->+                                 unECP happy_var_1 >>= \ happy_var_1 ->+                                 unECP happy_var_3 >>= \ happy_var_3 ->+                                 rejectPragmaPV happy_var_1 >>+                                 (mkHsOpAppPV (comb2A (reLoc happy_var_1) happy_var_3) happy_var_1 happy_var_2 happy_var_3)+	)}}}++happyReduce_498 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_498 = happySpecReduce_1  192# happyReduction_498+happyReduction_498 happy_x_1+	 =  case happyOut209 happy_x_1 of { (HappyWrap209 happy_var_1) -> +	happyIn208+		 (happy_var_1+	)}++happyReduce_499 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_499 = happySpecReduce_1  192# happyReduction_499+happyReduction_499 happy_x_1+	 =  case happyOut322 happy_x_1 of { (HappyWrap322 happy_var_1) -> +	happyIn208+		 (happy_var_1+	)}++happyReduce_500 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_500 = happySpecReduce_2  193# happyReduction_500+happyReduction_500 happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut212 happy_x_2 of { (HappyWrap212 happy_var_2) -> +	happyIn209+		 (ECP $+                                           unECP happy_var_2 >>= \ happy_var_2 ->+                                           mkHsNegAppPV (comb2A happy_var_1 happy_var_2) happy_var_2+                                                 [mj AnnMinus happy_var_1]+	)}}++happyReduce_501 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_501 = happySpecReduce_1  193# happyReduction_501+happyReduction_501 happy_x_1+	 =  case happyOut212 happy_x_1 of { (HappyWrap212 happy_var_1) -> +	happyIn209+		 (happy_var_1+	)}++happyReduce_502 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_502 = happySpecReduce_1  194# happyReduction_502+happyReduction_502 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn210+		 ((msemim happy_var_1,True)+	)}++happyReduce_503 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_503 = happySpecReduce_0  194# happyReduction_503+happyReduction_503  =  happyIn210+		 ((Nothing,False)+	)++happyReduce_504 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_504 = happyMonadReduce 3# 195# happyReduction_504+happyReduction_504 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	( do { scc <- getSCC happy_var_2+                                          ; acs (\cs -> (sLL happy_var_1 happy_var_3+                                             (HsPragSCC+                                                (EpAnn (glR happy_var_1) (AnnPragma (mo happy_var_1) (mc happy_var_3) [mj AnnValStr happy_var_2]) cs)+                                                (getSCC_PRAGs happy_var_1)+                                                (StringLiteral (getSTRINGs happy_var_2) scc Nothing))))})}}})+	) (\r -> happyReturn (happyIn211 r))++happyReduce_505 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_505 = happyMonadReduce 3# 195# happyReduction_505+happyReduction_505 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	( acs (\cs -> (sLL happy_var_1 happy_var_3+                                             (HsPragSCC+                                               (EpAnn (glR happy_var_1) (AnnPragma (mo happy_var_1) (mc happy_var_3) [mj AnnVal happy_var_2]) cs)+                                               (getSCC_PRAGs happy_var_1)+                                               (StringLiteral NoSourceText (getVARID happy_var_2) Nothing)))))}}})+	) (\r -> happyReturn (happyIn211 r))++happyReduce_506 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_506 = happySpecReduce_2  196# happyReduction_506+happyReduction_506 happy_x_2+	happy_x_1+	 =  case happyOut212 happy_x_1 of { (HappyWrap212 happy_var_1) -> +	case happyOut213 happy_x_2 of { (HappyWrap213 happy_var_2) -> +	happyIn212+		 (ECP $+                                          superFunArg $+                                          unECP happy_var_1 >>= \ happy_var_1 ->+                                          unECP happy_var_2 >>= \ happy_var_2 ->+                                          mkHsAppPV (noAnnSrcSpan $ comb2A (reLoc happy_var_1) happy_var_2) happy_var_1 happy_var_2+	)}}++happyReduce_507 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_507 = happySpecReduce_3  196# happyReduction_507+happyReduction_507 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut212 happy_x_1 of { (HappyWrap212 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut168 happy_x_3 of { (HappyWrap168 happy_var_3) -> +	happyIn212+		 (ECP $+                                        unECP happy_var_1 >>= \ happy_var_1 ->+                                        mkHsAppTypePV (noAnnSrcSpan $ comb2 (reLoc happy_var_1) (reLoc happy_var_3)) happy_var_1 (getLoc happy_var_2) happy_var_3+	)}}}++happyReduce_508 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_508 = happyMonadReduce 2# 196# happyReduction_508+happyReduction_508 (happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut213 happy_x_2 of { (HappyWrap213 happy_var_2) -> +	( runPV (unECP happy_var_2) >>= \ happy_var_2 ->+                                        fmap ecpFromExp $+                                        acsA (\cs -> sLL happy_var_1 (reLoc happy_var_2) $ HsStatic (EpAnn (glR happy_var_1) [mj AnnStatic happy_var_1] cs) happy_var_2))}})+	) (\r -> happyReturn (happyIn212 r))++happyReduce_509 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_509 = happySpecReduce_1  196# happyReduction_509+happyReduction_509 happy_x_1+	 =  case happyOut213 happy_x_1 of { (HappyWrap213 happy_var_1) -> +	happyIn212+		 (happy_var_1+	)}++happyReduce_510 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_510 = happySpecReduce_3  197# happyReduction_510+happyReduction_510 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut298 happy_x_1 of { (HappyWrap298 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut213 happy_x_3 of { (HappyWrap213 happy_var_3) -> +	happyIn213+		 (ECP $+                                   unECP happy_var_3 >>= \ happy_var_3 ->+                                     mkHsAsPatPV (comb2 (reLocN happy_var_1) (reLoc happy_var_3)) happy_var_1 happy_var_3 [mj AnnAt happy_var_2]+	)}}}++happyReduce_511 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_511 = happySpecReduce_2  197# happyReduction_511+happyReduction_511 happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut213 happy_x_2 of { (HappyWrap213 happy_var_2) -> +	happyIn213+		 (ECP $+                                   unECP happy_var_2 >>= \ happy_var_2 ->+                                   mkHsLazyPatPV (comb2 happy_var_1 (reLoc happy_var_2)) happy_var_2 [mj AnnTilde happy_var_1]+	)}}++happyReduce_512 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_512 = happySpecReduce_2  197# happyReduction_512+happyReduction_512 happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut213 happy_x_2 of { (HappyWrap213 happy_var_2) -> +	happyIn213+		 (ECP $+                                   unECP happy_var_2 >>= \ happy_var_2 ->+                                   mkHsBangPatPV (comb2 happy_var_1 (reLoc happy_var_2)) happy_var_2 [mj AnnBang happy_var_1]+	)}}++happyReduce_513 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_513 = happySpecReduce_2  197# happyReduction_513+happyReduction_513 happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut213 happy_x_2 of { (HappyWrap213 happy_var_2) -> +	happyIn213+		 (ECP $+                                   unECP happy_var_2 >>= \ happy_var_2 ->+                                   mkHsNegAppPV (comb2A happy_var_1 happy_var_2) happy_var_2 [mj AnnMinus happy_var_1]+	)}}++happyReduce_514 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_514 = happyReduce 4# 197# happyReduction_514+happyReduction_514 (happy_x_4 `HappyStk`+	happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest)+	 = case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut245 happy_x_2 of { (HappyWrap245 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	case happyOut206 happy_x_4 of { (HappyWrap206 happy_var_4) -> +	happyIn213+		 (ECP $+                      unECP happy_var_4 >>= \ happy_var_4 ->+                      mkHsLamPV (comb2 happy_var_1 (reLoc happy_var_4)) (\cs -> mkMatchGroup FromSource+                            (reLocA $ sLLlA happy_var_1 happy_var_4+                            [reLocA $ sLLlA happy_var_1 happy_var_4+                                         $ Match { m_ext = EpAnn (glR happy_var_1) [mj AnnLam happy_var_1] cs+                                                 , m_ctxt = LambdaExpr+                                                 , m_pats = happy_var_2+                                                 , m_grhss = unguardedGRHSs (comb2 happy_var_3 (reLoc happy_var_4)) happy_var_4 (EpAnn (glR happy_var_3) (GrhsAnn Nothing (mu AnnRarrow happy_var_3)) emptyComments) }]))+	) `HappyStk` happyRest}}}}++happyReduce_515 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_515 = happyReduce 4# 197# happyReduction_515+happyReduction_515 (happy_x_4 `HappyStk`+	happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest)+	 = case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut129 happy_x_2 of { (HappyWrap129 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	case happyOut206 happy_x_4 of { (HappyWrap206 happy_var_4) -> +	happyIn213+		 (ECP $+                                           unECP happy_var_4 >>= \ happy_var_4 ->+                                           mkHsLetPV (comb2A happy_var_1 happy_var_4) (hsTok happy_var_1) (unLoc happy_var_2) (hsTok happy_var_3) happy_var_4+	) `HappyStk` happyRest}}}}++happyReduce_516 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_516 = happySpecReduce_3  197# happyReduction_516+happyReduction_516 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut320 happy_x_3 of { (HappyWrap320 happy_var_3) -> +	happyIn213+		 (ECP $ happy_var_3 >>= \ happy_var_3 ->+                 mkHsLamCasePV (comb2 happy_var_1 (reLoc happy_var_3)) LamCase happy_var_3 [mj AnnLam happy_var_1,mj AnnCase happy_var_2]+	)}}}++happyReduce_517 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_517 = happySpecReduce_3  197# happyReduction_517+happyReduction_517 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut319 happy_x_3 of { (HappyWrap319 happy_var_3) -> +	happyIn213+		 (ECP $ happy_var_3 >>= \ happy_var_3 ->+                 mkHsLamCasePV (comb2 happy_var_1 (reLoc happy_var_3)) LamCases happy_var_3 [mj AnnLam happy_var_1,mj AnnCases happy_var_2]+	)}}}++happyReduce_518 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_518 = happyMonadReduce 8# 197# happyReduction_518+happyReduction_518 (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_1 of { happy_var_1 -> +	case happyOut206 happy_x_2 of { (HappyWrap206 happy_var_2) -> +	case happyOut210 happy_x_3 of { (HappyWrap210 happy_var_3) -> +	case happyOutTok happy_x_4 of { happy_var_4 -> +	case happyOut206 happy_x_5 of { (HappyWrap206 happy_var_5) -> +	case happyOut210 happy_x_6 of { (HappyWrap210 happy_var_6) -> +	case happyOutTok happy_x_7 of { happy_var_7 -> +	case happyOut206 happy_x_8 of { (HappyWrap206 happy_var_8) -> +	( runPV (unECP happy_var_2) >>= \ (happy_var_2 :: LHsExpr GhcPs) ->+                            return $ ECP $+                              unECP happy_var_5 >>= \ happy_var_5 ->+                              unECP happy_var_8 >>= \ happy_var_8 ->+                              mkHsIfPV (comb2A happy_var_1 happy_var_8) happy_var_2 (snd happy_var_3) happy_var_5 (snd happy_var_6) happy_var_8+                                    (AnnsIf+                                      { aiIf = glAA happy_var_1+                                      , aiThen = glAA happy_var_4+                                      , aiElse = glAA happy_var_7+                                      , aiThenSemi = fst happy_var_3+                                      , aiElseSemi = fst happy_var_6}))}}}}}}}})+	) (\r -> happyReturn (happyIn213 r))++happyReduce_519 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_519 = happyMonadReduce 2# 197# happyReduction_519+happyReduction_519 (happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut239 happy_x_2 of { (HappyWrap239 happy_var_2) -> +	( hintMultiWayIf (getLoc happy_var_1) >>= \_ ->+                                           fmap ecpFromExp $+                                           acsA (\cs -> sLL happy_var_1 happy_var_2 $ HsMultiIf (EpAnn (glR happy_var_1) (mj AnnIf happy_var_1:(fst $ unLoc happy_var_2)) cs)+                                                     (reverse $ snd $ unLoc happy_var_2)))}})+	) (\r -> happyReturn (happyIn213 r))++happyReduce_520 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_520 = happyMonadReduce 4# 197# happyReduction_520+happyReduction_520 (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 { happy_var_1 -> +	case happyOut206 happy_x_2 of { (HappyWrap206 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	case happyOut320 happy_x_4 of { (HappyWrap320 happy_var_4) -> +	( runPV (unECP happy_var_2) >>= \ (happy_var_2 :: LHsExpr GhcPs) ->+                                             return $ ECP $+                                               happy_var_4 >>= \ happy_var_4 ->+                                               mkHsCasePV (comb3 happy_var_1 happy_var_3 (reLoc happy_var_4)) happy_var_2 happy_var_4+                                                    (EpAnnHsCase (glAA happy_var_1) (glAA happy_var_3) []))}}}})+	) (\r -> happyReturn (happyIn213 r))++happyReduce_521 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_521 = happyMonadReduce 2# 197# happyReduction_521+happyReduction_521 (happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut246 happy_x_2 of { (HappyWrap246 happy_var_2) -> +	( do+                                      hintQualifiedDo happy_var_1+                                      return $ ECP $+                                        happy_var_2 >>= \ happy_var_2 ->+                                        mkHsDoPV (comb2A happy_var_1 happy_var_2)+                                                 (fmap mkModuleNameFS (getDO happy_var_1))+                                                 happy_var_2+                                                 (AnnList (Just $ glAR happy_var_2) Nothing Nothing [mj AnnDo happy_var_1] []))}})+	) (\r -> happyReturn (happyIn213 r))++happyReduce_522 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_522 = happyMonadReduce 2# 197# happyReduction_522+happyReduction_522 (happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut246 happy_x_2 of { (HappyWrap246 happy_var_2) -> +	( hintQualifiedDo happy_var_1 >> runPV happy_var_2 >>= \ happy_var_2 ->+                                       fmap ecpFromExp $+                                       acsA (\cs -> L (comb2A happy_var_1 happy_var_2)+                                              (mkHsDoAnns (MDoExpr $+                                                          fmap mkModuleNameFS (getMDO happy_var_1))+                                                          happy_var_2+                                           (EpAnn (glR happy_var_1) (AnnList (Just $ glAR happy_var_2) Nothing Nothing [mj AnnMdo happy_var_1] []) cs) )))}})+	) (\r -> happyReturn (happyIn213 r))++happyReduce_523 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_523 = happyMonadReduce 4# 197# happyReduction_523+happyReduction_523 (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 { happy_var_1 -> +	case happyOut213 happy_x_2 of { (HappyWrap213 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	case happyOut206 happy_x_4 of { (HappyWrap206 happy_var_4) -> +	( (checkPattern <=< runPV) (unECP happy_var_2) >>= \ p ->+                           runPV (unECP happy_var_4) >>= \ happy_var_4@cmd ->+                           fmap ecpFromExp $+                           acsA (\cs -> sLLlA happy_var_1 happy_var_4 $ HsProc (EpAnn (glR happy_var_1) [mj AnnProc happy_var_1,mu AnnRarrow happy_var_3] cs) p (sLLa happy_var_1 (reLoc happy_var_4) $ HsCmdTop noExtField cmd)))}}}})+	) (\r -> happyReturn (happyIn213 r))++happyReduce_524 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_524 = happySpecReduce_1  197# happyReduction_524+happyReduction_524 happy_x_1+	 =  case happyOut214 happy_x_1 of { (HappyWrap214 happy_var_1) -> +	happyIn213+		 (happy_var_1+	)}++happyReduce_525 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_525 = happyReduce 4# 198# happyReduction_525+happyReduction_525 (happy_x_4 `HappyStk`+	happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest)+	 = case happyOut214 happy_x_1 of { (HappyWrap214 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut252 happy_x_3 of { (HappyWrap252 happy_var_3) -> +	case happyOutTok happy_x_4 of { happy_var_4 -> +	happyIn214+		 (ECP $+                                   getBit OverloadedRecordUpdateBit >>= \ overloaded ->+                                   unECP happy_var_1 >>= \ happy_var_1 ->+                                   happy_var_3 >>= \ happy_var_3 ->+                                   mkHsRecordPV overloaded (comb2 (reLoc happy_var_1) happy_var_4) (comb2 happy_var_2 happy_var_4) happy_var_1 happy_var_3+                                        [moc happy_var_2,mcc happy_var_4]+	) `HappyStk` happyRest}}}}++happyReduce_526 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_526 = happyMonadReduce 3# 198# happyReduction_526+happyReduction_526 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut214 happy_x_1 of { (HappyWrap214 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut299 happy_x_3 of { (HappyWrap299 happy_var_3) -> +	( runPV (unECP happy_var_1) >>= \ happy_var_1 ->+               fmap ecpFromExp $ acsa (\cs ->+                 let fl = sLLa happy_var_2 happy_var_3 (DotFieldOcc ((EpAnn (glR happy_var_2) (AnnFieldLabel (Just $ glAA happy_var_2)) emptyComments)) (reLocA happy_var_3)) in+                 mkRdrGetField (noAnnSrcSpan $ comb2 (reLoc happy_var_1) happy_var_3) happy_var_1 fl (EpAnn (glAR happy_var_1) NoEpAnns cs)))}}})+	) (\r -> happyReturn (happyIn214 r))++happyReduce_527 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_527 = happySpecReduce_1  198# happyReduction_527+happyReduction_527 happy_x_1+	 =  case happyOut215 happy_x_1 of { (HappyWrap215 happy_var_1) -> +	happyIn214+		 (happy_var_1+	)}++happyReduce_528 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_528 = happySpecReduce_1  199# happyReduction_528+happyReduction_528 happy_x_1+	 =  case happyOut298 happy_x_1 of { (HappyWrap298 happy_var_1) -> +	happyIn215+		 (ECP $ mkHsVarPV $! happy_var_1+	)}++happyReduce_529 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_529 = happySpecReduce_1  199# happyReduction_529+happyReduction_529 happy_x_1+	 =  case happyOut268 happy_x_1 of { (HappyWrap268 happy_var_1) -> +	happyIn215+		 (ECP $ mkHsVarPV $! happy_var_1+	)}++happyReduce_530 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_530 = happyMonadReduce 1# 199# happyReduction_530+happyReduction_530 (happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut258 happy_x_1 of { (HappyWrap258 happy_var_1) -> +	( acsExpr (\cs -> sL1a happy_var_1 (HsIPVar (comment (glRR happy_var_1) cs) $! unLoc happy_var_1)))})+	) (\r -> happyReturn (happyIn215 r))++happyReduce_531 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_531 = happyMonadReduce 1# 199# happyReduction_531+happyReduction_531 (happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut259 happy_x_1 of { (HappyWrap259 happy_var_1) -> +	( acsExpr (\cs -> sL1a happy_var_1 (HsOverLabel (comment (glRR happy_var_1) cs) $! unLoc happy_var_1)))})+	) (\r -> happyReturn (happyIn215 r))++happyReduce_532 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_532 = happySpecReduce_1  199# happyReduction_532+happyReduction_532 happy_x_1+	 =  case happyOut313 happy_x_1 of { (HappyWrap313 happy_var_1) -> +	happyIn215+		 (ECP $ pvA (mkHsLitPV $! happy_var_1)+	)}++happyReduce_533 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_533 = happySpecReduce_1  199# happyReduction_533+happyReduction_533 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn215+		 (ECP $ mkHsOverLitPV (sL1a happy_var_1 $ mkHsIntegral   (getINTEGER  happy_var_1))+	)}++happyReduce_534 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_534 = happySpecReduce_1  199# happyReduction_534+happyReduction_534 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn215+		 (ECP $ mkHsOverLitPV (sL1a happy_var_1 $ mkHsFractional (getRATIONAL happy_var_1))+	)}++happyReduce_535 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_535 = happySpecReduce_3  199# happyReduction_535+happyReduction_535 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut224 happy_x_2 of { (HappyWrap224 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	happyIn215+		 (ECP $+                                           unECP happy_var_2 >>= \ happy_var_2 ->+                                           mkHsParPV (comb2 happy_var_1 happy_var_3) (hsTok happy_var_1) happy_var_2 (hsTok happy_var_3)+	)}}}++happyReduce_536 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_536 = happySpecReduce_3  199# happyReduction_536+happyReduction_536 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut225 happy_x_2 of { (HappyWrap225 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	happyIn215+		 (ECP $+                                           happy_var_2 >>= \ happy_var_2 ->+                                           mkSumOrTuplePV (noAnnSrcSpan $ comb2 happy_var_1 happy_var_3) Boxed happy_var_2+                                                [mop happy_var_1,mcp happy_var_3]+	)}}}++happyReduce_537 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_537 = happySpecReduce_3  199# happyReduction_537+happyReduction_537 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut216 happy_x_2 of { (HappyWrap216 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	happyIn215+		 (ECP $+                                            acsA (\cs -> sLL happy_var_1 happy_var_3 $ mkRdrProjection (NE.reverse (unLoc happy_var_2)) (EpAnn (glR happy_var_1) (AnnProjection (glAA happy_var_1) (glAA happy_var_3)) cs))+                                            >>= ecpFromExp'+	)}}}++happyReduce_538 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_538 = happySpecReduce_3  199# happyReduction_538+happyReduction_538 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut224 happy_x_2 of { (HappyWrap224 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	happyIn215+		 (ECP $+                                           unECP happy_var_2 >>= \ happy_var_2 ->+                                           mkSumOrTuplePV (noAnnSrcSpan $ comb2 happy_var_1 happy_var_3) Unboxed (Tuple [Right happy_var_2])+                                                 [moh happy_var_1,mch happy_var_3]+	)}}}++happyReduce_539 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_539 = happySpecReduce_3  199# happyReduction_539+happyReduction_539 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut225 happy_x_2 of { (HappyWrap225 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	happyIn215+		 (ECP $+                                           happy_var_2 >>= \ happy_var_2 ->+                                           mkSumOrTuplePV (noAnnSrcSpan $ comb2 happy_var_1 happy_var_3) Unboxed happy_var_2+                                                [moh happy_var_1,mch happy_var_3]+	)}}}++happyReduce_540 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_540 = happySpecReduce_3  199# happyReduction_540+happyReduction_540 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut228 happy_x_2 of { (HappyWrap228 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	happyIn215+		 (ECP $ happy_var_2 (comb2 happy_var_1 happy_var_3) (mos happy_var_1,mcs happy_var_3)+	)}}}++happyReduce_541 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_541 = happySpecReduce_1  199# happyReduction_541+happyReduction_541 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn215+		 (ECP $ pvA $ mkHsWildCardPV (getLoc happy_var_1)+	)}++happyReduce_542 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_542 = happySpecReduce_1  199# happyReduction_542+happyReduction_542 happy_x_1+	 =  case happyOut218 happy_x_1 of { (HappyWrap218 happy_var_1) -> +	happyIn215+		 (ECP $ pvA $ mkHsSplicePV happy_var_1+	)}++happyReduce_543 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_543 = happySpecReduce_1  199# happyReduction_543+happyReduction_543 happy_x_1+	 =  case happyOut219 happy_x_1 of { (HappyWrap219 happy_var_1) -> +	happyIn215+		 (ecpFromExp $ mapLoc (HsSpliceE noAnn) (reLocA happy_var_1)+	)}++happyReduce_544 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_544 = happyMonadReduce 2# 199# happyReduction_544+happyReduction_544 (happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut298 happy_x_2 of { (HappyWrap298 happy_var_2) -> +	( fmap ecpFromExp $ acsA (\cs -> sLL happy_var_1 (reLocN happy_var_2) $ HsUntypedBracket (EpAnn (glR happy_var_1) [mj AnnSimpleQuote happy_var_1] cs) (VarBr noExtField True  happy_var_2)))}})+	) (\r -> happyReturn (happyIn215 r))++happyReduce_545 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_545 = happyMonadReduce 2# 199# happyReduction_545+happyReduction_545 (happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut268 happy_x_2 of { (HappyWrap268 happy_var_2) -> +	( fmap ecpFromExp $ acsA (\cs -> sLL happy_var_1 (reLocN happy_var_2) $ HsUntypedBracket (EpAnn (glR happy_var_1) [mj AnnSimpleQuote happy_var_1] cs) (VarBr noExtField True  happy_var_2)))}})+	) (\r -> happyReturn (happyIn215 r))++happyReduce_546 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_546 = happyMonadReduce 2# 199# happyReduction_546+happyReduction_546 (happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut294 happy_x_2 of { (HappyWrap294 happy_var_2) -> +	( fmap ecpFromExp $ acsA (\cs -> sLL happy_var_1 (reLocN happy_var_2) $ HsUntypedBracket (EpAnn (glR happy_var_1) [mj AnnThTyQuote happy_var_1  ] cs) (VarBr noExtField False happy_var_2)))}})+	) (\r -> happyReturn (happyIn215 r))++happyReduce_547 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_547 = happyMonadReduce 2# 199# happyReduction_547+happyReduction_547 (happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut277 happy_x_2 of { (HappyWrap277 happy_var_2) -> +	( fmap ecpFromExp $ acsA (\cs -> sLL happy_var_1 (reLocN happy_var_2) $ HsUntypedBracket (EpAnn (glR happy_var_1) [mj AnnThTyQuote happy_var_1  ] cs) (VarBr noExtField False happy_var_2)))}})+	) (\r -> happyReturn (happyIn215 r))++happyReduce_548 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_548 = happyMonadReduce 1# 199# happyReduction_548+happyReduction_548 (happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	( reportEmptyDoubleQuotes (getLoc happy_var_1))})+	) (\r -> happyReturn (happyIn215 r))++happyReduce_549 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_549 = happyMonadReduce 3# 199# happyReduction_549+happyReduction_549 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut206 happy_x_2 of { (HappyWrap206 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	( runPV (unECP happy_var_2) >>= \ happy_var_2 ->+                                 fmap ecpFromExp $+                                 acsA (\cs -> sLL happy_var_1 happy_var_3 $ HsUntypedBracket (EpAnn (glR happy_var_1) (if (hasE happy_var_1) then [mj AnnOpenE happy_var_1, mu AnnCloseQ happy_var_3]+                                                                                         else [mu AnnOpenEQ happy_var_1,mu AnnCloseQ happy_var_3]) cs) (ExpBr noExtField happy_var_2)))}}})+	) (\r -> happyReturn (happyIn215 r))++happyReduce_550 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_550 = happyMonadReduce 3# 199# happyReduction_550+happyReduction_550 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut206 happy_x_2 of { (HappyWrap206 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	( runPV (unECP happy_var_2) >>= \ happy_var_2 ->+                                 fmap ecpFromExp $+                                 acsA (\cs -> sLL happy_var_1 happy_var_3 $ HsTypedBracket (EpAnn (glR happy_var_1) (if (hasE happy_var_1) then [mj AnnOpenE happy_var_1,mc happy_var_3] else [mo happy_var_1,mc happy_var_3]) cs) happy_var_2))}}})+	) (\r -> happyReturn (happyIn215 r))++happyReduce_551 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_551 = happyMonadReduce 3# 199# happyReduction_551+happyReduction_551 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut158 happy_x_2 of { (HappyWrap158 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	( fmap ecpFromExp $+                                 acsA (\cs -> sLL happy_var_1 happy_var_3 $ HsUntypedBracket (EpAnn (glR happy_var_1) [mo happy_var_1,mu AnnCloseQ happy_var_3] cs) (TypBr noExtField happy_var_2)))}}})+	) (\r -> happyReturn (happyIn215 r))++happyReduce_552 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_552 = happyMonadReduce 3# 199# happyReduction_552+happyReduction_552 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut207 happy_x_2 of { (HappyWrap207 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	( (checkPattern <=< runPV) (unECP happy_var_2) >>= \p ->+                                      fmap ecpFromExp $+                                      acsA (\cs -> sLL happy_var_1 happy_var_3 $ HsUntypedBracket (EpAnn (glR happy_var_1) [mo happy_var_1,mu AnnCloseQ happy_var_3] cs) (PatBr noExtField p)))}}})+	) (\r -> happyReturn (happyIn215 r))++happyReduce_553 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_553 = happyMonadReduce 3# 199# happyReduction_553+happyReduction_553 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut222 happy_x_2 of { (HappyWrap222 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	( fmap ecpFromExp $+                                  acsA (\cs -> sLL happy_var_1 happy_var_3 $ HsUntypedBracket (EpAnn (glR happy_var_1) (mo happy_var_1:mu AnnCloseQ happy_var_3:fst happy_var_2) cs) (DecBrL noExtField (snd happy_var_2))))}}})+	) (\r -> happyReturn (happyIn215 r))++happyReduce_554 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_554 = happySpecReduce_1  199# happyReduction_554+happyReduction_554 happy_x_1+	 =  case happyOut205 happy_x_1 of { (HappyWrap205 happy_var_1) -> +	happyIn215+		 (ECP $ pvA $ mkHsSplicePV happy_var_1+	)}++happyReduce_555 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_555 = happyMonadReduce 4# 199# happyReduction_555+happyReduction_555 (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 { happy_var_1 -> +	case happyOut213 happy_x_2 of { (HappyWrap213 happy_var_2) -> +	case happyOut220 happy_x_3 of { (HappyWrap220 happy_var_3) -> +	case happyOutTok happy_x_4 of { happy_var_4 -> +	( runPV (unECP happy_var_2) >>= \ happy_var_2 ->+                                      fmap ecpFromCmd $+                                      acsA (\cs -> sLL happy_var_1 happy_var_4 $ HsCmdArrForm (EpAnn (glR happy_var_1) (AnnList (Just $ glR happy_var_1) (Just $ mu AnnOpenB happy_var_1) (Just $ mu AnnCloseB happy_var_4) [] []) cs) happy_var_2 Prefix+                                                           Nothing (reverse happy_var_3)))}}}})+	) (\r -> happyReturn (happyIn215 r))++happyReduce_556 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_556 = happyMonadReduce 3# 200# happyReduction_556+happyReduction_556 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut216 happy_x_1 of { (HappyWrap216 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut299 happy_x_3 of { (HappyWrap299 happy_var_3) -> +	( acs (\cs -> sLL happy_var_1 happy_var_3 ((sLLa happy_var_2 happy_var_3 $ DotFieldOcc (EpAnn (glR happy_var_1) (AnnFieldLabel (Just $ glAA happy_var_2)) cs) (reLocA happy_var_3)) `NE.cons` unLoc happy_var_1)))}}})+	) (\r -> happyReturn (happyIn216 r))++happyReduce_557 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_557 = happyMonadReduce 2# 200# happyReduction_557+happyReduction_557 (happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut299 happy_x_2 of { (HappyWrap299 happy_var_2) -> +	( acs (\cs -> sLL happy_var_1 happy_var_2 ((sLLa happy_var_1 happy_var_2 $ DotFieldOcc (EpAnn (glR happy_var_1) (AnnFieldLabel (Just $ glAA happy_var_1)) cs) (reLocA happy_var_2)) :| [])))}})+	) (\r -> happyReturn (happyIn216 r))++happyReduce_558 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_558 = happySpecReduce_1  201# happyReduction_558+happyReduction_558 happy_x_1+	 =  case happyOut218 happy_x_1 of { (HappyWrap218 happy_var_1) -> +	happyIn217+		 (mapLoc (HsSpliceE noAnn) (reLocA happy_var_1)+	)}++happyReduce_559 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_559 = happySpecReduce_1  201# happyReduction_559+happyReduction_559 happy_x_1+	 =  case happyOut219 happy_x_1 of { (HappyWrap219 happy_var_1) -> +	happyIn217+		 (mapLoc (HsSpliceE noAnn) (reLocA happy_var_1)+	)}++happyReduce_560 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_560 = happyMonadReduce 2# 202# happyReduction_560+happyReduction_560 (happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut215 happy_x_2 of { (HappyWrap215 happy_var_2) -> +	( runPV (unECP happy_var_2) >>= \ happy_var_2 ->+                                   acs (\cs -> sLLlA happy_var_1 happy_var_2 $ mkUntypedSplice (EpAnn (glR happy_var_1) [mj AnnDollar happy_var_1] cs) DollarSplice happy_var_2))}})+	) (\r -> happyReturn (happyIn218 r))++happyReduce_561 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_561 = happyMonadReduce 2# 203# happyReduction_561+happyReduction_561 (happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut215 happy_x_2 of { (HappyWrap215 happy_var_2) -> +	( runPV (unECP happy_var_2) >>= \ happy_var_2 ->+                                   acs (\cs -> sLLlA happy_var_1 happy_var_2 $ mkTypedSplice (EpAnn (glR happy_var_1) [mj AnnDollarDollar happy_var_1] cs) DollarSplice happy_var_2))}})+	) (\r -> happyReturn (happyIn219 r))++happyReduce_562 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_562 = happySpecReduce_2  204# happyReduction_562+happyReduction_562 happy_x_2+	happy_x_1+	 =  case happyOut220 happy_x_1 of { (HappyWrap220 happy_var_1) -> +	case happyOut221 happy_x_2 of { (HappyWrap221 happy_var_2) -> +	happyIn220+		 (happy_var_2 : happy_var_1+	)}}++happyReduce_563 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_563 = happySpecReduce_0  204# happyReduction_563+happyReduction_563  =  happyIn220+		 ([]+	)++happyReduce_564 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_564 = happyMonadReduce 1# 205# happyReduction_564+happyReduction_564 (happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut213 happy_x_1 of { (HappyWrap213 happy_var_1) -> +	( runPV (unECP happy_var_1) >>= \ (cmd :: LHsCmd GhcPs) ->+                                   runPV (checkCmdBlockArguments cmd) >>= \ _ ->+                                   return (sL1a (reLoc cmd) $ HsCmdTop noExtField cmd))})+	) (\r -> happyReturn (happyIn221 r))++happyReduce_565 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_565 = happySpecReduce_3  206# happyReduction_565+happyReduction_565 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut223 happy_x_2 of { (HappyWrap223 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	happyIn222+		 (([mj AnnOpenC happy_var_1+                                                  ,mj AnnCloseC happy_var_3],happy_var_2)+	)}}}++happyReduce_566 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_566 = happySpecReduce_3  206# happyReduction_566+happyReduction_566 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut223 happy_x_2 of { (HappyWrap223 happy_var_2) -> +	happyIn222+		 (([],happy_var_2)+	)}++happyReduce_567 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_567 = happySpecReduce_1  207# happyReduction_567+happyReduction_567 happy_x_1+	 =  case happyOut74 happy_x_1 of { (HappyWrap74 happy_var_1) -> +	happyIn223+		 (cvTopDecls happy_var_1+	)}++happyReduce_568 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_568 = happySpecReduce_1  207# happyReduction_568+happyReduction_568 happy_x_1+	 =  case happyOut73 happy_x_1 of { (HappyWrap73 happy_var_1) -> +	happyIn223+		 (cvTopDecls happy_var_1+	)}++happyReduce_569 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_569 = happySpecReduce_1  208# happyReduction_569+happyReduction_569 happy_x_1+	 =  case happyOut206 happy_x_1 of { (HappyWrap206 happy_var_1) -> +	happyIn224+		 (happy_var_1+	)}++happyReduce_570 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_570 = happyMonadReduce 2# 208# happyReduction_570+happyReduction_570 (happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut207 happy_x_1 of { (HappyWrap207 happy_var_1) -> +	case happyOut289 happy_x_2 of { (HappyWrap289 happy_var_2) -> +	( runPV (unECP happy_var_1) >>= \ happy_var_1 ->+                                runPV (rejectPragmaPV happy_var_1) >>+                                runPV happy_var_2 >>= \ happy_var_2 ->+                                return $ ecpFromExp $+                                reLocA $ sLL (reLoc happy_var_1) (reLocN happy_var_2) $ SectionL noAnn happy_var_1 (n2l happy_var_2))}})+	) (\r -> happyReturn (happyIn224 r))++happyReduce_571 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_571 = happySpecReduce_2  208# happyReduction_571+happyReduction_571 happy_x_2+	happy_x_1+	 =  case happyOut290 happy_x_1 of { (HappyWrap290 happy_var_1) -> +	case happyOut207 happy_x_2 of { (HappyWrap207 happy_var_2) -> +	happyIn224+		 (ECP $+                                superInfixOp $+                                unECP happy_var_2 >>= \ happy_var_2 ->+                                happy_var_1 >>= \ happy_var_1 ->+                                pvA $ mkHsSectionR_PV (comb2 (reLocN happy_var_1) (reLoc happy_var_2)) (n2l happy_var_1) happy_var_2+	)}}++happyReduce_572 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_572 = happySpecReduce_3  208# happyReduction_572+happyReduction_572 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut206 happy_x_1 of { (HappyWrap206 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut224 happy_x_3 of { (HappyWrap224 happy_var_3) -> +	happyIn224+		 (ECP $+                             unECP happy_var_1 >>= \ happy_var_1 ->+                             unECP happy_var_3 >>= \ happy_var_3 ->+                             mkHsViewPatPV (comb2 (reLoc happy_var_1) (reLoc happy_var_3)) happy_var_1 happy_var_3 [mu AnnRarrow happy_var_2]+	)}}}++happyReduce_573 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_573 = happySpecReduce_2  209# happyReduction_573+happyReduction_573 happy_x_2+	happy_x_1+	 =  case happyOut224 happy_x_1 of { (HappyWrap224 happy_var_1) -> +	case happyOut226 happy_x_2 of { (HappyWrap226 happy_var_2) -> +	happyIn225+		 (unECP happy_var_1 >>= \ happy_var_1 ->+                             happy_var_2 >>= \ happy_var_2 ->+                             do { t <- amsA happy_var_1 [AddCommaAnn (EpaSpan $ rs $ fst happy_var_2)]+                                ; return (Tuple (Right t : snd happy_var_2)) }+	)}}++happyReduce_574 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_574 = happySpecReduce_2  209# happyReduction_574+happyReduction_574 happy_x_2+	happy_x_1+	 =  case happyOut316 happy_x_1 of { (HappyWrap316 happy_var_1) -> +	case happyOut227 happy_x_2 of { (HappyWrap227 happy_var_2) -> +	happyIn225+		 (happy_var_2 >>= \ happy_var_2 ->+                   do { let {cos = map (\ll -> (Left (EpAnn (anc $ rs ll) (EpaSpan $ rs ll) emptyComments))) (fst happy_var_1) }+                      ; return (Tuple (cos ++ happy_var_2)) }+	)}}++happyReduce_575 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_575 = happySpecReduce_2  209# happyReduction_575+happyReduction_575 happy_x_2+	happy_x_1+	 =  case happyOut224 happy_x_1 of { (HappyWrap224 happy_var_1) -> +	case happyOut318 happy_x_2 of { (HappyWrap318 happy_var_2) -> +	happyIn225+		 (unECP happy_var_1 >>= \ happy_var_1 -> return $+                            (Sum 1  (snd happy_var_2 + 1) happy_var_1 [] (map (EpaSpan . realSrcSpan) $ fst happy_var_2))+	)}}++happyReduce_576 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_576 = happySpecReduce_3  209# happyReduction_576+happyReduction_576 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut318 happy_x_1 of { (HappyWrap318 happy_var_1) -> +	case happyOut224 happy_x_2 of { (HappyWrap224 happy_var_2) -> +	case happyOut317 happy_x_3 of { (HappyWrap317 happy_var_3) -> +	happyIn225+		 (unECP happy_var_2 >>= \ happy_var_2 -> return $+                  (Sum (snd happy_var_1 + 1) (snd happy_var_1 + snd happy_var_3 + 1) happy_var_2+                    (map (EpaSpan . realSrcSpan) $ fst happy_var_1)+                    (map (EpaSpan . realSrcSpan) $ fst happy_var_3))+	)}}}++happyReduce_577 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_577 = happySpecReduce_2  210# happyReduction_577+happyReduction_577 happy_x_2+	happy_x_1+	 =  case happyOut316 happy_x_1 of { (HappyWrap316 happy_var_1) -> +	case happyOut227 happy_x_2 of { (HappyWrap227 happy_var_2) -> +	happyIn226+		 (happy_var_2 >>= \ happy_var_2 ->+          do { let {cos = map (\l -> (Left (EpAnn (anc $ rs l) (EpaSpan $ rs l) emptyComments))) (tail $ fst happy_var_1) }+             ; return ((head $ fst happy_var_1, cos ++ happy_var_2)) }+	)}}++happyReduce_578 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_578 = happySpecReduce_2  211# happyReduction_578+happyReduction_578 happy_x_2+	happy_x_1+	 =  case happyOut224 happy_x_1 of { (HappyWrap224 happy_var_1) -> +	case happyOut226 happy_x_2 of { (HappyWrap226 happy_var_2) -> +	happyIn227+		 (unECP happy_var_1 >>= \ happy_var_1 ->+                                   happy_var_2 >>= \ happy_var_2 ->+                                   do { t <- amsA happy_var_1 [AddCommaAnn (EpaSpan $ rs $ fst happy_var_2)]+                                      ; return (Right t : snd happy_var_2) }+	)}}++happyReduce_579 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_579 = happySpecReduce_1  211# happyReduction_579+happyReduction_579 happy_x_1+	 =  case happyOut224 happy_x_1 of { (HappyWrap224 happy_var_1) -> +	happyIn227+		 (unECP happy_var_1 >>= \ happy_var_1 ->+                                   return [Right happy_var_1]+	)}++happyReduce_580 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_580 = happySpecReduce_0  211# happyReduction_580+happyReduction_580  =  happyIn227+		 (return [Left noAnn]+	)++happyReduce_581 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_581 = happySpecReduce_1  212# happyReduction_581+happyReduction_581 happy_x_1+	 =  case happyOut224 happy_x_1 of { (HappyWrap224 happy_var_1) -> +	happyIn228+		 (\loc (ao,ac) -> unECP happy_var_1 >>= \ happy_var_1 ->+                            mkHsExplicitListPV loc [happy_var_1] (AnnList Nothing (Just ao) (Just ac) [] [])+	)}++happyReduce_582 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_582 = happySpecReduce_1  212# happyReduction_582+happyReduction_582 happy_x_1+	 =  case happyOut229 happy_x_1 of { (HappyWrap229 happy_var_1) -> +	happyIn228+		 (\loc (ao,ac) -> happy_var_1 >>= \ happy_var_1 ->+                            mkHsExplicitListPV loc (reverse happy_var_1) (AnnList Nothing (Just ao) (Just ac) [] [])+	)}++happyReduce_583 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_583 = happySpecReduce_2  212# happyReduction_583+happyReduction_583 happy_x_2+	happy_x_1+	 =  case happyOut224 happy_x_1 of { (HappyWrap224 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	happyIn228+		 (\loc (ao,ac) -> unECP happy_var_1 >>= \ happy_var_1 ->+                                  acsA (\cs -> L loc $ ArithSeq (EpAnn (spanAsAnchor loc) [ao,mj AnnDotdot happy_var_2,ac] cs) Nothing (From happy_var_1))+                                      >>= ecpFromExp'+	)}}++happyReduce_584 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_584 = happyReduce 4# 212# happyReduction_584+happyReduction_584 (happy_x_4 `HappyStk`+	happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest)+	 = case happyOut224 happy_x_1 of { (HappyWrap224 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut206 happy_x_3 of { (HappyWrap206 happy_var_3) -> +	case happyOutTok happy_x_4 of { happy_var_4 -> +	happyIn228+		 (\loc (ao,ac) ->+                                   unECP happy_var_1 >>= \ happy_var_1 ->+                                   unECP happy_var_3 >>= \ happy_var_3 ->+                                   acsA (\cs -> L loc $ ArithSeq (EpAnn (spanAsAnchor loc) [ao,mj AnnComma happy_var_2,mj AnnDotdot happy_var_4,ac] cs) Nothing (FromThen happy_var_1 happy_var_3))+                                       >>= ecpFromExp'+	) `HappyStk` happyRest}}}}++happyReduce_585 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_585 = happySpecReduce_3  212# happyReduction_585+happyReduction_585 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut224 happy_x_1 of { (HappyWrap224 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut206 happy_x_3 of { (HappyWrap206 happy_var_3) -> +	happyIn228+		 (\loc (ao,ac) ->+                                   unECP happy_var_1 >>= \ happy_var_1 ->+                                   unECP happy_var_3 >>= \ happy_var_3 ->+                                   acsA (\cs -> L loc $ ArithSeq (EpAnn (spanAsAnchor loc) [ao,mj AnnDotdot happy_var_2,ac] cs) Nothing (FromTo happy_var_1 happy_var_3))+                                       >>= ecpFromExp'+	)}}}++happyReduce_586 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_586 = happyReduce 5# 212# happyReduction_586+happyReduction_586 (happy_x_5 `HappyStk`+	happy_x_4 `HappyStk`+	happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest)+	 = case happyOut224 happy_x_1 of { (HappyWrap224 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut206 happy_x_3 of { (HappyWrap206 happy_var_3) -> +	case happyOutTok happy_x_4 of { happy_var_4 -> +	case happyOut206 happy_x_5 of { (HappyWrap206 happy_var_5) -> +	happyIn228+		 (\loc (ao,ac) ->+                                   unECP happy_var_1 >>= \ happy_var_1 ->+                                   unECP happy_var_3 >>= \ happy_var_3 ->+                                   unECP happy_var_5 >>= \ happy_var_5 ->+                                   acsA (\cs -> L loc $ ArithSeq (EpAnn (spanAsAnchor loc) [ao,mj AnnComma happy_var_2,mj AnnDotdot happy_var_4,ac] cs) Nothing (FromThenTo happy_var_1 happy_var_3 happy_var_5))+                                       >>= ecpFromExp'+	) `HappyStk` happyRest}}}}}++happyReduce_587 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_587 = happySpecReduce_3  212# happyReduction_587+happyReduction_587 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut224 happy_x_1 of { (HappyWrap224 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut230 happy_x_3 of { (HappyWrap230 happy_var_3) -> +	happyIn228+		 (\loc (ao,ac) ->+                checkMonadComp >>= \ ctxt ->+                unECP happy_var_1 >>= \ happy_var_1 -> do { t <- addTrailingVbarA happy_var_1 (gl happy_var_2)+                ; acsA (\cs -> L loc $ mkHsCompAnns ctxt (unLoc happy_var_3) t (EpAnn (spanAsAnchor loc) (AnnList Nothing (Just ao) (Just ac) [] []) cs))+                    >>= ecpFromExp' }+	)}}}++happyReduce_588 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_588 = happySpecReduce_3  213# happyReduction_588+happyReduction_588 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut229 happy_x_1 of { (HappyWrap229 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut224 happy_x_3 of { (HappyWrap224 happy_var_3) -> +	happyIn229+		 (happy_var_1 >>= \ happy_var_1 ->+                                     unECP happy_var_3 >>= \ happy_var_3 ->+                                     case happy_var_1 of+                                       (h:t) -> do+                                         h' <- addTrailingCommaA h (gl happy_var_2)+                                         return (((:) $! happy_var_3) $! (h':t))+	)}}}++happyReduce_589 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_589 = happySpecReduce_3  213# happyReduction_589+happyReduction_589 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut224 happy_x_1 of { (HappyWrap224 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut224 happy_x_3 of { (HappyWrap224 happy_var_3) -> +	happyIn229+		 (unECP happy_var_1 >>= \ happy_var_1 ->+                                      unECP happy_var_3 >>= \ happy_var_3 ->+                                      do { h <- addTrailingCommaA happy_var_1 (gl happy_var_2)+                                         ; return [happy_var_3,h] }+	)}}}++happyReduce_590 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_590 = happySpecReduce_1  214# happyReduction_590+happyReduction_590 happy_x_1+	 =  case happyOut231 happy_x_1 of { (HappyWrap231 happy_var_1) -> +	happyIn230+		 (case (unLoc happy_var_1) of+                    [qs] -> sL1 happy_var_1 qs+                    -- We just had one thing in our "parallel" list so+                    -- we simply return that thing directly++                    qss -> sL1 happy_var_1 [sL1a happy_var_1 $ ParStmt noExtField [ParStmtBlock noExtField qs [] noSyntaxExpr |+                                            qs <- qss]+                                            noExpr noSyntaxExpr]+                    -- We actually found some actual parallel lists so+                    -- we wrap them into as a ParStmt+	)}++happyReduce_591 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_591 = happyMonadReduce 3# 215# happyReduction_591+happyReduction_591 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut232 happy_x_1 of { (HappyWrap232 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut231 happy_x_3 of { (HappyWrap231 happy_var_3) -> +	( case unLoc happy_var_1 of+                          (h:t) -> do+                            h' <- addTrailingVbarA h (gl happy_var_2)+                            return (sLL happy_var_1 happy_var_3 (reverse (h':t) : unLoc happy_var_3)))}}})+	) (\r -> happyReturn (happyIn231 r))++happyReduce_592 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_592 = happySpecReduce_1  215# happyReduction_592+happyReduction_592 happy_x_1+	 =  case happyOut232 happy_x_1 of { (HappyWrap232 happy_var_1) -> +	happyIn231+		 (L (getLoc happy_var_1) [reverse (unLoc happy_var_1)]+	)}++happyReduce_593 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_593 = happyMonadReduce 3# 216# happyReduction_593+happyReduction_593 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut232 happy_x_1 of { (HappyWrap232 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut233 happy_x_3 of { (HappyWrap233 happy_var_3) -> +	( case unLoc happy_var_1 of+                  (h:t) -> do+                    h' <- addTrailingCommaA h (gl happy_var_2)+                    return (sLL happy_var_1 happy_var_3 [sLLa happy_var_1 happy_var_3 ((unLoc happy_var_3) (glRR happy_var_1) (reverse (h':t)))]))}}})+	) (\r -> happyReturn (happyIn232 r))++happyReduce_594 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_594 = happyMonadReduce 3# 216# happyReduction_594+happyReduction_594 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut232 happy_x_1 of { (HappyWrap232 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut251 happy_x_3 of { (HappyWrap251 happy_var_3) -> +	( runPV happy_var_3 >>= \ happy_var_3 ->+                case unLoc happy_var_1 of+                  (h:t) -> do+                    h' <- addTrailingCommaA h (gl happy_var_2)+                    return (sLL happy_var_1 (reLoc happy_var_3) (happy_var_3 : (h':t))))}}})+	) (\r -> happyReturn (happyIn232 r))++happyReduce_595 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_595 = happyMonadReduce 1# 216# happyReduction_595+happyReduction_595 (happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut233 happy_x_1 of { (HappyWrap233 happy_var_1) -> +	( return (sLL happy_var_1 happy_var_1 [L (getLocAnn happy_var_1) ((unLoc happy_var_1) (glRR happy_var_1) [])]))})+	) (\r -> happyReturn (happyIn232 r))++happyReduce_596 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_596 = happyMonadReduce 1# 216# happyReduction_596+happyReduction_596 (happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut251 happy_x_1 of { (HappyWrap251 happy_var_1) -> +	( runPV happy_var_1 >>= \ happy_var_1 ->+                                            return $ sL1A happy_var_1 [happy_var_1])})+	) (\r -> happyReturn (happyIn232 r))++happyReduce_597 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_597 = happyMonadReduce 2# 217# happyReduction_597+happyReduction_597 (happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut206 happy_x_2 of { (HappyWrap206 happy_var_2) -> +	( runPV (unECP happy_var_2) >>= \ happy_var_2 ->+                                 acs (\cs->+                                 sLLlA happy_var_1 happy_var_2 (\r ss -> (mkTransformStmt (EpAnn (anc r) [mj AnnThen happy_var_1] cs) ss happy_var_2))))}})+	) (\r -> happyReturn (happyIn233 r))++happyReduce_598 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_598 = happyMonadReduce 4# 217# happyReduction_598+happyReduction_598 (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 { happy_var_1 -> +	case happyOut206 happy_x_2 of { (HappyWrap206 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	case happyOut206 happy_x_4 of { (HappyWrap206 happy_var_4) -> +	( runPV (unECP happy_var_2) >>= \ happy_var_2 ->+                                 runPV (unECP happy_var_4) >>= \ happy_var_4 ->+                                 acs (\cs -> sLLlA happy_var_1 happy_var_4 (+                                                     \r ss -> (mkTransformByStmt (EpAnn (anc r) [mj AnnThen happy_var_1,mj AnnBy happy_var_3] cs) ss happy_var_2 happy_var_4))))}}}})+	) (\r -> happyReturn (happyIn233 r))++happyReduce_599 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_599 = happyMonadReduce 4# 217# happyReduction_599+happyReduction_599 (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 { happy_var_1 -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	case happyOut206 happy_x_4 of { (HappyWrap206 happy_var_4) -> +	( runPV (unECP happy_var_4) >>= \ happy_var_4 ->+               acs (\cs -> sLLlA happy_var_1 happy_var_4 (+                                   \r ss -> (mkGroupUsingStmt (EpAnn (anc r) [mj AnnThen happy_var_1,mj AnnGroup happy_var_2,mj AnnUsing happy_var_3] cs) ss happy_var_4))))}}}})+	) (\r -> happyReturn (happyIn233 r))++happyReduce_600 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_600 = happyMonadReduce 6# 217# happyReduction_600+happyReduction_600 (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_1 of { happy_var_1 -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	case happyOut206 happy_x_4 of { (HappyWrap206 happy_var_4) -> +	case happyOutTok happy_x_5 of { happy_var_5 -> +	case happyOut206 happy_x_6 of { (HappyWrap206 happy_var_6) -> +	( runPV (unECP happy_var_4) >>= \ happy_var_4 ->+               runPV (unECP happy_var_6) >>= \ happy_var_6 ->+               acs (\cs -> sLLlA happy_var_1 happy_var_6 (+                                   \r ss -> (mkGroupByUsingStmt (EpAnn (anc r) [mj AnnThen happy_var_1,mj AnnGroup happy_var_2,mj AnnBy happy_var_3,mj AnnUsing happy_var_5] cs) ss happy_var_4 happy_var_6))))}}}}}})+	) (\r -> happyReturn (happyIn233 r))++happyReduce_601 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_601 = happySpecReduce_1  218# happyReduction_601+happyReduction_601 happy_x_1+	 =  case happyOut235 happy_x_1 of { (HappyWrap235 happy_var_1) -> +	happyIn234+		 (L (getLoc happy_var_1) (reverse (unLoc happy_var_1))+	)}++happyReduce_602 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_602 = happyMonadReduce 3# 219# happyReduction_602+happyReduction_602 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut235 happy_x_1 of { (HappyWrap235 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut251 happy_x_3 of { (HappyWrap251 happy_var_3) -> +	( runPV happy_var_3 >>= \ happy_var_3 ->+                               case unLoc happy_var_1 of+                                 (h:t) -> do+                                   h' <- addTrailingCommaA h (gl happy_var_2)+                                   return (sLL happy_var_1 (reLoc happy_var_3) (happy_var_3 : (h':t))))}}})+	) (\r -> happyReturn (happyIn235 r))++happyReduce_603 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_603 = happyMonadReduce 1# 219# happyReduction_603+happyReduction_603 (happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut251 happy_x_1 of { (HappyWrap251 happy_var_1) -> +	( runPV happy_var_1 >>= \ happy_var_1 ->+                               return $ sL1A happy_var_1 [happy_var_1])})+	) (\r -> happyReturn (happyIn235 r))++happyReduce_604 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_604 = happySpecReduce_2  220# happyReduction_604+happyReduction_604 happy_x_2+	happy_x_1+	 =  case happyOut237 happy_x_1 of { (HappyWrap237 happy_var_1) -> +	case happyOut130 happy_x_2 of { (HappyWrap130 happy_var_2) -> +	happyIn236+		 (happy_var_1 >>= \alt ->+                                      do { let {L l (bs, csw) = adaptWhereBinds happy_var_2}+                                         ; acs (\cs -> sLL alt (L l bs) (GRHSs (cs Semi.<> csw) (unLoc alt) bs)) }+	)}}++happyReduce_605 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_605 = happySpecReduce_2  221# happyReduction_605+happyReduction_605 happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut206 happy_x_2 of { (HappyWrap206 happy_var_2) -> +	happyIn237+		 (unECP happy_var_2 >>= \ happy_var_2 ->+                                acs (\cs -> sLLlA happy_var_1 happy_var_2 (unguardedRHS (EpAnn (glR happy_var_1) (GrhsAnn Nothing (mu AnnRarrow happy_var_1)) cs) (comb2 happy_var_1 (reLoc happy_var_2)) happy_var_2))+	)}}++happyReduce_606 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_606 = happySpecReduce_1  221# happyReduction_606+happyReduction_606 happy_x_1+	 =  case happyOut238 happy_x_1 of { (HappyWrap238 happy_var_1) -> +	happyIn237+		 (happy_var_1 >>= \gdpats ->+                                return $ sL1 gdpats (reverse (unLoc gdpats))+	)}++happyReduce_607 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_607 = happySpecReduce_2  222# happyReduction_607+happyReduction_607 happy_x_2+	happy_x_1+	 =  case happyOut238 happy_x_1 of { (HappyWrap238 happy_var_1) -> +	case happyOut240 happy_x_2 of { (HappyWrap240 happy_var_2) -> +	happyIn238+		 (happy_var_1 >>= \gdpats ->+                         happy_var_2 >>= \gdpat ->+                         return $ sLL gdpats (reLoc gdpat) (gdpat : unLoc gdpats)+	)}}++happyReduce_608 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_608 = happySpecReduce_1  222# happyReduction_608+happyReduction_608 happy_x_1+	 =  case happyOut240 happy_x_1 of { (HappyWrap240 happy_var_1) -> +	happyIn238+		 (happy_var_1 >>= \gdpat -> return $ sL1A gdpat [gdpat]+	)}++happyReduce_609 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_609 = happyMonadReduce 3# 223# happyReduction_609+happyReduction_609 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut238 happy_x_2 of { (HappyWrap238 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	( runPV happy_var_2 >>= \ happy_var_2 ->+                                             return $ sLL happy_var_1 happy_var_3 ([moc happy_var_1,mcc happy_var_3],unLoc happy_var_2))}}})+	) (\r -> happyReturn (happyIn239 r))++happyReduce_610 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_610 = happyMonadReduce 2# 223# happyReduction_610+happyReduction_610 (happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut238 happy_x_1 of { (HappyWrap238 happy_var_1) -> +	( runPV happy_var_1 >>= \ happy_var_1 ->+                                             return $ sL1 happy_var_1 ([],unLoc happy_var_1))})+	) (\r -> happyReturn (happyIn239 r))++happyReduce_611 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_611 = happyReduce 4# 224# happyReduction_611+happyReduction_611 (happy_x_4 `HappyStk`+	happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest)+	 = case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut234 happy_x_2 of { (HappyWrap234 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	case happyOut206 happy_x_4 of { (HappyWrap206 happy_var_4) -> +	happyIn240+		 (unECP happy_var_4 >>= \ happy_var_4 ->+                                     acsA (\cs -> sL (comb2A happy_var_1 happy_var_4) $ GRHS (EpAnn (glR happy_var_1) (GrhsAnn (Just $ glAA happy_var_1) (mu AnnRarrow happy_var_3)) cs) (unLoc happy_var_2) happy_var_4)+	) `HappyStk` happyRest}}}}++happyReduce_612 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_612 = happyMonadReduce 1# 225# happyReduction_612+happyReduction_612 (happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut206 happy_x_1 of { (HappyWrap206 happy_var_1) -> +	( (checkPattern <=< runPV) (unECP happy_var_1))})+	) (\r -> happyReturn (happyIn241 r))++happyReduce_613 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_613 = happySpecReduce_1  226# happyReduction_613+happyReduction_613 happy_x_1+	 =  case happyOut241 happy_x_1 of { (HappyWrap241 happy_var_1) -> +	happyIn242+		 ([ happy_var_1 ]+	)}++happyReduce_614 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_614 = happyMonadReduce 1# 227# happyReduction_614+happyReduction_614 (happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut206 happy_x_1 of { (HappyWrap206 happy_var_1) -> +	( -- See Note [Parser-Validator Details] in GHC.Parser.PostProcess+                             checkPattern_details incompleteDoBlock+                                              (unECP happy_var_1))})+	) (\r -> happyReturn (happyIn243 r))++happyReduce_615 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_615 = happyMonadReduce 1# 228# happyReduction_615+happyReduction_615 (happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut213 happy_x_1 of { (HappyWrap213 happy_var_1) -> +	( (checkPattern <=< runPV) (unECP happy_var_1))})+	) (\r -> happyReturn (happyIn244 r))++happyReduce_616 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_616 = happySpecReduce_2  229# happyReduction_616+happyReduction_616 happy_x_2+	happy_x_1+	 =  case happyOut244 happy_x_1 of { (HappyWrap244 happy_var_1) -> +	case happyOut245 happy_x_2 of { (HappyWrap245 happy_var_2) -> +	happyIn245+		 (happy_var_1 : happy_var_2+	)}}++happyReduce_617 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_617 = happySpecReduce_0  229# happyReduction_617+happyReduction_617  =  happyIn245+		 ([]+	)++happyReduce_618 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_618 = happySpecReduce_3  230# happyReduction_618+happyReduction_618 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut247 happy_x_2 of { (HappyWrap247 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	happyIn246+		 (happy_var_2 >>= \ happy_var_2 -> amsrl+                                          (sLL happy_var_1 happy_var_3 (reverse $ snd $ unLoc happy_var_2)) (AnnList (Just $ glR happy_var_2) (Just $ moc happy_var_1) (Just $ mcc happy_var_3) (fromOL $ fst $ unLoc happy_var_2) [])+	)}}}++happyReduce_619 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_619 = happySpecReduce_3  230# happyReduction_619+happyReduction_619 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut247 happy_x_2 of { (HappyWrap247 happy_var_2) -> +	happyIn246+		 (happy_var_2 >>= \ happy_var_2 -> amsrl+                                          (L (gl happy_var_2) (reverse $ snd $ unLoc happy_var_2)) (AnnList (Just $ glR happy_var_2) Nothing Nothing (fromOL $ fst $ unLoc happy_var_2) [])+	)}++happyReduce_620 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_620 = happySpecReduce_3  231# happyReduction_620+happyReduction_620 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut247 happy_x_1 of { (HappyWrap247 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut250 happy_x_3 of { (HappyWrap250 happy_var_3) -> +	happyIn247+		 (happy_var_1 >>= \ happy_var_1 ->+                            happy_var_3 >>= \ (happy_var_3 :: LStmt GhcPs (LocatedA b)) ->+                            case (snd $ unLoc happy_var_1) of+                              [] -> return (sLL happy_var_1 (reLoc happy_var_3) ((fst $ unLoc happy_var_1) `snocOL` (mj AnnSemi happy_var_2)+                                                     ,happy_var_3   : (snd $ unLoc happy_var_1)))+                              (h:t) -> do+                               { h' <- addTrailingSemiA h (gl happy_var_2)+                               ; return $ sLL happy_var_1 (reLoc happy_var_3) (fst $ unLoc happy_var_1,happy_var_3 :(h':t)) }+	)}}}++happyReduce_621 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_621 = happySpecReduce_2  231# happyReduction_621+happyReduction_621 happy_x_2+	happy_x_1+	 =  case happyOut247 happy_x_1 of { (HappyWrap247 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	happyIn247+		 (happy_var_1 >>= \ happy_var_1 ->+                           case (snd $ unLoc happy_var_1) of+                             [] -> return (sLL happy_var_1 happy_var_2 ((fst $ unLoc happy_var_1) `snocOL` (mj AnnSemi happy_var_2),snd $ unLoc happy_var_1))+                             (h:t) -> do+                               { h' <- addTrailingSemiA h (gl happy_var_2)+                               ; return $ sL1 happy_var_1 (fst $ unLoc happy_var_1,h':t) }+	)}}++happyReduce_622 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_622 = happySpecReduce_1  231# happyReduction_622+happyReduction_622 happy_x_1+	 =  case happyOut250 happy_x_1 of { (HappyWrap250 happy_var_1) -> +	happyIn247+		 (happy_var_1 >>= \ happy_var_1 ->+                                   return $ sL1A happy_var_1 (nilOL,[happy_var_1])+	)}++happyReduce_623 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_623 = happySpecReduce_0  231# happyReduction_623+happyReduction_623  =  happyIn247+		 (return $ noLoc (nilOL,[])+	)++happyReduce_624 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_624 = happyMonadReduce 1# 232# happyReduction_624+happyReduction_624 (happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut250 happy_x_1 of { (HappyWrap250 happy_var_1) -> +	( fmap Just (runPV happy_var_1))})+	) (\r -> happyReturn (happyIn248 r))++happyReduce_625 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_625 = happySpecReduce_0  232# happyReduction_625+happyReduction_625  =  happyIn248+		 (Nothing+	)++happyReduce_626 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_626 = happyMonadReduce 1# 233# happyReduction_626+happyReduction_626 (happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut250 happy_x_1 of { (HappyWrap250 happy_var_1) -> +	( runPV happy_var_1)})+	) (\r -> happyReturn (happyIn249 r))++happyReduce_627 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_627 = happySpecReduce_1  234# happyReduction_627+happyReduction_627 happy_x_1+	 =  case happyOut251 happy_x_1 of { (HappyWrap251 happy_var_1) -> +	happyIn250+		 (happy_var_1+	)}++happyReduce_628 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_628 = happySpecReduce_2  234# happyReduction_628+happyReduction_628 happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut246 happy_x_2 of { (HappyWrap246 happy_var_2) -> +	happyIn250+		 (happy_var_2 >>= \ happy_var_2 ->+                                           acsA (\cs -> (sLL happy_var_1 (reLoc happy_var_2) $ mkRecStmt+                                                 (EpAnn (glR happy_var_1) (hsDoAnn happy_var_1 happy_var_2 AnnRec) cs)+                                                  happy_var_2))+	)}}++happyReduce_629 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_629 = happySpecReduce_3  235# happyReduction_629+happyReduction_629 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut243 happy_x_1 of { (HappyWrap243 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut206 happy_x_3 of { (HappyWrap206 happy_var_3) -> +	happyIn251+		 (unECP happy_var_3 >>= \ happy_var_3 ->+                                           acsA (\cs -> sLLlA (reLoc happy_var_1) happy_var_3+                                            $ mkPsBindStmt (EpAnn (glAR happy_var_1) [mu AnnLarrow happy_var_2] cs) happy_var_1 happy_var_3)+	)}}}++happyReduce_630 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_630 = happySpecReduce_1  235# happyReduction_630+happyReduction_630 happy_x_1+	 =  case happyOut206 happy_x_1 of { (HappyWrap206 happy_var_1) -> +	happyIn251+		 (unECP happy_var_1 >>= \ happy_var_1 ->+                                           return $ sL1 happy_var_1 $ mkBodyStmt happy_var_1+	)}++happyReduce_631 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_631 = happySpecReduce_2  235# happyReduction_631+happyReduction_631 happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut129 happy_x_2 of { (HappyWrap129 happy_var_2) -> +	happyIn251+		 (acsA (\cs -> (sLL happy_var_1 happy_var_2+                                                $ mkLetStmt (EpAnn (glR happy_var_1) [mj AnnLet happy_var_1] cs) (unLoc happy_var_2)))+	)}}++happyReduce_632 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_632 = happySpecReduce_1  236# happyReduction_632+happyReduction_632 happy_x_1+	 =  case happyOut253 happy_x_1 of { (HappyWrap253 happy_var_1) -> +	happyIn252+		 (happy_var_1+	)}++happyReduce_633 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_633 = happySpecReduce_0  236# happyReduction_633+happyReduction_633  =  happyIn252+		 (return ([], Nothing)+	)++happyReduce_634 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_634 = happySpecReduce_3  237# happyReduction_634+happyReduction_634 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut254 happy_x_1 of { (HappyWrap254 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut253 happy_x_3 of { (HappyWrap253 happy_var_3) -> +	happyIn253+		 (happy_var_1 >>= \ happy_var_1 ->+                   happy_var_3 >>= \ happy_var_3 -> do+                   h <- addTrailingCommaFBind happy_var_1 (gl happy_var_2)+                   return (case happy_var_3 of (flds, dd) -> (h : flds, dd))+	)}}}++happyReduce_635 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_635 = happySpecReduce_1  237# happyReduction_635+happyReduction_635 happy_x_1+	 =  case happyOut254 happy_x_1 of { (HappyWrap254 happy_var_1) -> +	happyIn253+		 (happy_var_1 >>= \ happy_var_1 ->+                                          return ([happy_var_1], Nothing)+	)}++happyReduce_636 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_636 = happySpecReduce_1  237# happyReduction_636+happyReduction_636 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn253+		 (return ([],   Just (getLoc happy_var_1))+	)}++happyReduce_637 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_637 = happySpecReduce_3  238# happyReduction_637+happyReduction_637 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut298 happy_x_1 of { (HappyWrap298 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut224 happy_x_3 of { (HappyWrap224 happy_var_3) -> +	happyIn254+		 (unECP happy_var_3 >>= \ happy_var_3 ->+                           fmap Left $ acsA (\cs -> sLL (reLocN happy_var_1) (reLoc happy_var_3) $ HsFieldBind (EpAnn (glNR happy_var_1) [mj AnnEqual happy_var_2] cs) (sL1l happy_var_1 $ mkFieldOcc happy_var_1) happy_var_3 False)+	)}}}++happyReduce_638 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_638 = happySpecReduce_1  238# happyReduction_638+happyReduction_638 happy_x_1+	 =  case happyOut298 happy_x_1 of { (HappyWrap298 happy_var_1) -> +	happyIn254+		 (placeHolderPunRhs >>= \rhs ->+                          fmap Left $ acsa (\cs -> sL1a (reLocN happy_var_1) $ HsFieldBind (EpAnn (glNR happy_var_1) [] cs) (sL1l happy_var_1 $ mkFieldOcc happy_var_1) rhs True)+	)}++happyReduce_639 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_639 = happyReduce 5# 238# happyReduction_639+happyReduction_639 (happy_x_5 `HappyStk`+	happy_x_4 `HappyStk`+	happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest)+	 = case happyOut299 happy_x_1 of { (HappyWrap299 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut255 happy_x_3 of { (HappyWrap255 happy_var_3) -> +	case happyOutTok happy_x_4 of { happy_var_4 -> +	case happyOut224 happy_x_5 of { (HappyWrap224 happy_var_5) -> +	happyIn254+		 (do+                            let top = sL1a happy_var_1 $ DotFieldOcc noAnn (reLocA happy_var_1)+                                ((L lf (DotFieldOcc _ f)):t) = reverse (unLoc happy_var_3)+                                lf' = comb2 happy_var_2 (reLoc $ L lf ())+                                fields = top : L (noAnnSrcSpan lf') (DotFieldOcc (EpAnn (spanAsAnchor lf') (AnnFieldLabel (Just $ glAA happy_var_2)) emptyComments) f) : t+                                final = last fields+                                l = comb2 happy_var_1 happy_var_3+                                isPun = False+                            happy_var_5 <- unECP happy_var_5+                            fmap Right $ mkHsProjUpdatePV (comb2 happy_var_1 (reLoc happy_var_5)) (L l fields) happy_var_5 isPun+                                            [mj AnnEqual happy_var_4]+	) `HappyStk` happyRest}}}}}++happyReduce_640 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_640 = happySpecReduce_3  238# happyReduction_640+happyReduction_640 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut299 happy_x_1 of { (HappyWrap299 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut255 happy_x_3 of { (HappyWrap255 happy_var_3) -> +	happyIn254+		 (do+                            let top =  sL1a happy_var_1 $ DotFieldOcc noAnn (reLocA happy_var_1)+                                ((L lf (DotFieldOcc _ f)):t) = reverse (unLoc happy_var_3)+                                lf' = comb2 happy_var_2 (reLoc $ L lf ())+                                fields = top : L (noAnnSrcSpan lf') (DotFieldOcc (EpAnn (spanAsAnchor lf') (AnnFieldLabel (Just $ glAA happy_var_2)) emptyComments) f) : t+                                final = last fields+                                l = comb2 happy_var_1 happy_var_3+                                isPun = True+                            var <- mkHsVarPV (L (noAnnSrcSpan $ getLocA final) (mkRdrUnqual . mkVarOcc . unpackFS . unLoc . dfoLabel . unLoc $ final))+                            fmap Right $ mkHsProjUpdatePV l (L l fields) var isPun []+	)}}}++happyReduce_641 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_641 = happyMonadReduce 3# 239# happyReduction_641+happyReduction_641 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut255 happy_x_1 of { (HappyWrap255 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut299 happy_x_3 of { (HappyWrap299 happy_var_3) -> +	( getCommentsFor (getLoc happy_var_3) >>= \cs ->+                                                     return (sLL happy_var_1 happy_var_3 ((sLLa happy_var_2 happy_var_3 (DotFieldOcc (EpAnn (glR happy_var_2) (AnnFieldLabel $ Just $ glAA happy_var_2) cs) (reLocA happy_var_3))) : unLoc happy_var_1)))}}})+	) (\r -> happyReturn (happyIn255 r))++happyReduce_642 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_642 = happyMonadReduce 1# 239# happyReduction_642+happyReduction_642 (happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut299 happy_x_1 of { (HappyWrap299 happy_var_1) -> +	( getCommentsFor (getLoc happy_var_1) >>= \cs ->+                        return (sL1 happy_var_1 [sL1a happy_var_1 (DotFieldOcc (EpAnn (glR happy_var_1) (AnnFieldLabel Nothing) cs) (reLocA happy_var_1))]))})+	) (\r -> happyReturn (happyIn255 r))++happyReduce_643 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_643 = happyMonadReduce 3# 240# happyReduction_643+happyReduction_643 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut256 happy_x_1 of { (HappyWrap256 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut257 happy_x_3 of { (HappyWrap257 happy_var_3) -> +	( case unLoc happy_var_1 of+                           (h:t) -> do+                             h' <- addTrailingSemiA h (gl happy_var_2)+                             return (let { this = happy_var_3; rest = h':t }+                                in rest `seq` this `seq` sLL happy_var_1 (reLoc happy_var_3) (this : rest)))}}})+	) (\r -> happyReturn (happyIn256 r))++happyReduce_644 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_644 = happyMonadReduce 2# 240# happyReduction_644+happyReduction_644 (happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut256 happy_x_1 of { (HappyWrap256 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	( case unLoc happy_var_1 of+                           (h:t) -> do+                             h' <- addTrailingSemiA h (gl happy_var_2)+                             return (sLL happy_var_1 happy_var_2 (h':t)))}})+	) (\r -> happyReturn (happyIn256 r))++happyReduce_645 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_645 = happySpecReduce_1  240# happyReduction_645+happyReduction_645 happy_x_1+	 =  case happyOut257 happy_x_1 of { (HappyWrap257 happy_var_1) -> +	happyIn256+		 (let this = happy_var_1 in this `seq` (sL1 (reLoc happy_var_1) [this])+	)}++happyReduce_646 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_646 = happyMonadReduce 3# 241# happyReduction_646+happyReduction_646 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut258 happy_x_1 of { (HappyWrap258 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut206 happy_x_3 of { (HappyWrap206 happy_var_3) -> +	( runPV (unECP happy_var_3) >>= \ happy_var_3 ->+                                          acsA (\cs -> sLLlA happy_var_1 happy_var_3 (IPBind (EpAnn (glR happy_var_1) [mj AnnEqual happy_var_2] cs) (reLocA happy_var_1) happy_var_3)))}}})+	) (\r -> happyReturn (happyIn257 r))++happyReduce_647 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_647 = happySpecReduce_1  242# happyReduction_647+happyReduction_647 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn258+		 (sL1 happy_var_1 (HsIPName (getIPDUPVARID happy_var_1))+	)}++happyReduce_648 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_648 = happySpecReduce_1  243# happyReduction_648+happyReduction_648 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn259+		 (sL1 happy_var_1 (getLABELVARID happy_var_1)+	)}++happyReduce_649 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_649 = happySpecReduce_1  244# happyReduction_649+happyReduction_649 happy_x_1+	 =  case happyOut261 happy_x_1 of { (HappyWrap261 happy_var_1) -> +	happyIn260+		 (happy_var_1+	)}++happyReduce_650 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_650 = happySpecReduce_0  244# happyReduction_650+happyReduction_650  =  happyIn260+		 (noLocA mkTrue+	)++happyReduce_651 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_651 = happySpecReduce_1  245# happyReduction_651+happyReduction_651 happy_x_1+	 =  case happyOut262 happy_x_1 of { (HappyWrap262 happy_var_1) -> +	happyIn261+		 (happy_var_1+	)}++happyReduce_652 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_652 = happyMonadReduce 3# 245# happyReduction_652+happyReduction_652 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut262 happy_x_1 of { (HappyWrap262 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut261 happy_x_3 of { (HappyWrap261 happy_var_3) -> +	( do { h <- addTrailingVbarL happy_var_1 (gl happy_var_2)+                                 ; return (reLocA $ sLLAA happy_var_1 happy_var_3 (Or [h,happy_var_3])) })}}})+	) (\r -> happyReturn (happyIn261 r))++happyReduce_653 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_653 = happySpecReduce_1  246# happyReduction_653+happyReduction_653 happy_x_1+	 =  case happyOut263 happy_x_1 of { (HappyWrap263 happy_var_1) -> +	happyIn262+		 (reLocA $ sLLAA (head happy_var_1) (last happy_var_1) (And (happy_var_1))+	)}++happyReduce_654 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_654 = happySpecReduce_1  247# happyReduction_654+happyReduction_654 happy_x_1+	 =  case happyOut264 happy_x_1 of { (HappyWrap264 happy_var_1) -> +	happyIn263+		 ([happy_var_1]+	)}++happyReduce_655 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_655 = happyMonadReduce 3# 247# happyReduction_655+happyReduction_655 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut264 happy_x_1 of { (HappyWrap264 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut263 happy_x_3 of { (HappyWrap263 happy_var_3) -> +	( do { h <- addTrailingCommaL happy_var_1 (gl happy_var_2)+                  ; return (h : happy_var_3) })}}})+	) (\r -> happyReturn (happyIn263 r))++happyReduce_656 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_656 = happyMonadReduce 3# 248# happyReduction_656+happyReduction_656 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut261 happy_x_2 of { (HappyWrap261 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	( amsrl (sLL happy_var_1 happy_var_3 (Parens happy_var_2))+                                      (AnnList Nothing (Just (mop happy_var_1)) (Just (mcp happy_var_3)) [] []))}}})+	) (\r -> happyReturn (happyIn264 r))++happyReduce_657 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_657 = happySpecReduce_1  248# happyReduction_657+happyReduction_657 happy_x_1+	 =  case happyOut266 happy_x_1 of { (HappyWrap266 happy_var_1) -> +	happyIn264+		 (reLocA $ sL1N happy_var_1 (Var happy_var_1)+	)}++happyReduce_658 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_658 = happySpecReduce_1  249# happyReduction_658+happyReduction_658 happy_x_1+	 =  case happyOut266 happy_x_1 of { (HappyWrap266 happy_var_1) -> +	happyIn265+		 (sL1N happy_var_1 [happy_var_1]+	)}++happyReduce_659 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_659 = happyMonadReduce 3# 249# happyReduction_659+happyReduction_659 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut266 happy_x_1 of { (HappyWrap266 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut265 happy_x_3 of { (HappyWrap265 happy_var_3) -> +	( do { h <- addTrailingCommaN happy_var_1 (gl happy_var_2)+                                       ; return (sLL (reLocN happy_var_1) happy_var_3 (h : unLoc happy_var_3)) })}}})+	) (\r -> happyReturn (happyIn265 r))++happyReduce_660 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_660 = happySpecReduce_1  250# happyReduction_660+happyReduction_660 happy_x_1+	 =  case happyOut297 happy_x_1 of { (HappyWrap297 happy_var_1) -> +	happyIn266+		 (happy_var_1+	)}++happyReduce_661 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_661 = happySpecReduce_1  250# happyReduction_661+happyReduction_661 happy_x_1+	 =  case happyOut270 happy_x_1 of { (HappyWrap270 happy_var_1) -> +	happyIn266+		 (happy_var_1+	)}++happyReduce_662 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_662 = happySpecReduce_1  251# happyReduction_662+happyReduction_662 happy_x_1+	 =  case happyOut269 happy_x_1 of { (HappyWrap269 happy_var_1) -> +	happyIn267+		 (happy_var_1+	)}++happyReduce_663 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_663 = happySpecReduce_1  251# happyReduction_663+happyReduction_663 happy_x_1+	 =  case happyOut273 happy_x_1 of { (HappyWrap273 happy_var_1) -> +	happyIn267+		 (L (getLoc happy_var_1) $ nameRdrName (dataConName (unLoc happy_var_1))+	)}++happyReduce_664 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_664 = happySpecReduce_1  252# happyReduction_664+happyReduction_664 happy_x_1+	 =  case happyOut269 happy_x_1 of { (HappyWrap269 happy_var_1) -> +	happyIn268+		 (happy_var_1+	)}++happyReduce_665 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_665 = happySpecReduce_1  252# happyReduction_665+happyReduction_665 happy_x_1+	 =  case happyOut274 happy_x_1 of { (HappyWrap274 happy_var_1) -> +	happyIn268+		 (L (getLoc happy_var_1) $ nameRdrName (dataConName (unLoc happy_var_1))+	)}++happyReduce_666 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_666 = happySpecReduce_1  253# happyReduction_666+happyReduction_666 happy_x_1+	 =  case happyOut309 happy_x_1 of { (HappyWrap309 happy_var_1) -> +	happyIn269+		 (happy_var_1+	)}++happyReduce_667 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_667 = happyMonadReduce 3# 253# happyReduction_667+happyReduction_667 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut311 happy_x_2 of { (HappyWrap311 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	( amsrn (sLL happy_var_1 happy_var_3 (unLoc happy_var_2))+                                   (NameAnn NameParens (glAA happy_var_1) (glNRR happy_var_2) (glAA happy_var_3) []))}}})+	) (\r -> happyReturn (happyIn269 r))++happyReduce_668 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_668 = happySpecReduce_1  254# happyReduction_668+happyReduction_668 happy_x_1+	 =  case happyOut310 happy_x_1 of { (HappyWrap310 happy_var_1) -> +	happyIn270+		 (happy_var_1+	)}++happyReduce_669 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_669 = happyMonadReduce 3# 254# happyReduction_669+happyReduction_669 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut312 happy_x_2 of { (HappyWrap312 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	( amsrn (sLL happy_var_1 happy_var_3 (unLoc happy_var_2))+                                         (NameAnn NameParens (glAA happy_var_1) (glNRR happy_var_2) (glAA happy_var_3) []))}}})+	) (\r -> happyReturn (happyIn270 r))++happyReduce_670 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_670 = happySpecReduce_1  254# happyReduction_670+happyReduction_670 happy_x_1+	 =  case happyOut274 happy_x_1 of { (HappyWrap274 happy_var_1) -> +	happyIn270+		 (L (getLoc happy_var_1) $ nameRdrName (dataConName (unLoc happy_var_1))+	)}++happyReduce_671 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_671 = happySpecReduce_1  255# happyReduction_671+happyReduction_671 happy_x_1+	 =  case happyOut270 happy_x_1 of { (HappyWrap270 happy_var_1) -> +	happyIn271+		 (sL1N happy_var_1 [happy_var_1]+	)}++happyReduce_672 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_672 = happyMonadReduce 3# 255# happyReduction_672+happyReduction_672 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut270 happy_x_1 of { (HappyWrap270 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut271 happy_x_3 of { (HappyWrap271 happy_var_3) -> +	( do { h <- addTrailingCommaN happy_var_1 (gl happy_var_2)+                                      ; return (sLL (reLocN happy_var_1) happy_var_3 (h : unLoc happy_var_3)) })}}})+	) (\r -> happyReturn (happyIn271 r))++happyReduce_673 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_673 = happySpecReduce_1  256# happyReduction_673+happyReduction_673 happy_x_1+	 =  case happyOut268 happy_x_1 of { (HappyWrap268 happy_var_1) -> +	happyIn272+		 (sL1N happy_var_1 [happy_var_1]+	)}++happyReduce_674 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_674 = happyMonadReduce 3# 256# happyReduction_674+happyReduction_674 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut268 happy_x_1 of { (HappyWrap268 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut272 happy_x_3 of { (HappyWrap272 happy_var_3) -> +	( do { h <- addTrailingCommaN happy_var_1 (gl happy_var_2)+                                        ; return (sLL (reLocN happy_var_1) happy_var_3 (h : unLoc happy_var_3)) })}}})+	) (\r -> happyReturn (happyIn272 r))++happyReduce_675 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_675 = happyMonadReduce 2# 257# happyReduction_675+happyReduction_675 (happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	( amsrn (sLL happy_var_1 happy_var_2 unitDataCon) (NameAnnOnly NameParens (glAA happy_var_1) (glAA happy_var_2) []))}})+	) (\r -> happyReturn (happyIn273 r))++happyReduce_676 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_676 = happyMonadReduce 3# 257# happyReduction_676+happyReduction_676 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut316 happy_x_2 of { (HappyWrap316 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	( amsrn (sLL happy_var_1 happy_var_3 $ tupleDataCon Boxed (snd happy_var_2 + 1))+                                       (NameAnnCommas NameParens (glAA happy_var_1) (map (EpaSpan . realSrcSpan) (fst happy_var_2)) (glAA happy_var_3) []))}}})+	) (\r -> happyReturn (happyIn273 r))++happyReduce_677 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_677 = happyMonadReduce 2# 257# happyReduction_677+happyReduction_677 (happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	( amsrn (sLL happy_var_1 happy_var_2 $ unboxedUnitDataCon) (NameAnnOnly NameParensHash (glAA happy_var_1) (glAA happy_var_2) []))}})+	) (\r -> happyReturn (happyIn273 r))++happyReduce_678 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_678 = happyMonadReduce 3# 257# happyReduction_678+happyReduction_678 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut316 happy_x_2 of { (HappyWrap316 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	( amsrn (sLL happy_var_1 happy_var_3 $ tupleDataCon Unboxed (snd happy_var_2 + 1))+                                       (NameAnnCommas NameParensHash (glAA happy_var_1) (map (EpaSpan . realSrcSpan) (fst happy_var_2)) (glAA happy_var_3) []))}}})+	) (\r -> happyReturn (happyIn273 r))++happyReduce_679 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_679 = happySpecReduce_1  258# happyReduction_679+happyReduction_679 happy_x_1+	 =  case happyOut273 happy_x_1 of { (HappyWrap273 happy_var_1) -> +	happyIn274+		 (happy_var_1+	)}++happyReduce_680 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_680 = happyMonadReduce 2# 258# happyReduction_680+happyReduction_680 (happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	( amsrn (sLL happy_var_1 happy_var_2 nilDataCon) (NameAnnOnly NameSquare (glAA happy_var_1) (glAA happy_var_2) []))}})+	) (\r -> happyReturn (happyIn274 r))++happyReduce_681 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_681 = happySpecReduce_1  259# happyReduction_681+happyReduction_681 happy_x_1+	 =  case happyOut312 happy_x_1 of { (HappyWrap312 happy_var_1) -> +	happyIn275+		 (happy_var_1+	)}++happyReduce_682 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_682 = happyMonadReduce 3# 259# happyReduction_682+happyReduction_682 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut310 happy_x_2 of { (HappyWrap310 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	( amsrn (sLL happy_var_1 happy_var_3 (unLoc happy_var_2))+                                           (NameAnn NameBackquotes (glAA happy_var_1) (glNRR happy_var_2) (glAA happy_var_3) []))}}})+	) (\r -> happyReturn (happyIn275 r))++happyReduce_683 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_683 = happySpecReduce_1  260# happyReduction_683+happyReduction_683 happy_x_1+	 =  case happyOut311 happy_x_1 of { (HappyWrap311 happy_var_1) -> +	happyIn276+		 (happy_var_1+	)}++happyReduce_684 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_684 = happyMonadReduce 3# 260# happyReduction_684+happyReduction_684 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut309 happy_x_2 of { (HappyWrap309 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	( amsrn (sLL happy_var_1 happy_var_3 (unLoc happy_var_2))+                                           (NameAnn NameBackquotes (glAA happy_var_1) (glNRR happy_var_2) (glAA happy_var_3) []))}}})+	) (\r -> happyReturn (happyIn276 r))++happyReduce_685 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_685 = happySpecReduce_1  261# happyReduction_685+happyReduction_685 happy_x_1+	 =  case happyOut278 happy_x_1 of { (HappyWrap278 happy_var_1) -> +	happyIn277+		 (happy_var_1+	)}++happyReduce_686 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_686 = happyMonadReduce 2# 261# happyReduction_686+happyReduction_686 (happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	( amsrn (sLL happy_var_1 happy_var_2 $ getRdrName unitTyCon)+                                                 (NameAnnOnly NameParens (glAA happy_var_1) (glAA happy_var_2) []))}})+	) (\r -> happyReturn (happyIn277 r))++happyReduce_687 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_687 = happyMonadReduce 2# 261# happyReduction_687+happyReduction_687 (happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	( amsrn (sLL happy_var_1 happy_var_2 $ getRdrName unboxedUnitTyCon)+                                                 (NameAnnOnly NameParensHash (glAA happy_var_1) (glAA happy_var_2) []))}})+	) (\r -> happyReturn (happyIn277 r))++happyReduce_688 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_688 = happySpecReduce_1  262# happyReduction_688+happyReduction_688 happy_x_1+	 =  case happyOut279 happy_x_1 of { (HappyWrap279 happy_var_1) -> +	happyIn278+		 (happy_var_1+	)}++happyReduce_689 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_689 = happyMonadReduce 3# 262# happyReduction_689+happyReduction_689 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut316 happy_x_2 of { (HappyWrap316 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	( amsrn (sLL happy_var_1 happy_var_3 $ getRdrName (tupleTyCon Boxed+                                                        (snd happy_var_2 + 1)))+                                       (NameAnnCommas NameParens (glAA happy_var_1) (map (EpaSpan . realSrcSpan) (fst happy_var_2)) (glAA happy_var_3) []))}}})+	) (\r -> happyReturn (happyIn278 r))++happyReduce_690 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_690 = happyMonadReduce 3# 262# happyReduction_690+happyReduction_690 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut316 happy_x_2 of { (HappyWrap316 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	( amsrn (sLL happy_var_1 happy_var_3 $ getRdrName (tupleTyCon Unboxed+                                                        (snd happy_var_2 + 1)))+                                       (NameAnnCommas NameParensHash (glAA happy_var_1) (map (EpaSpan . realSrcSpan) (fst happy_var_2)) (glAA happy_var_3) []))}}})+	) (\r -> happyReturn (happyIn278 r))++happyReduce_691 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_691 = happyMonadReduce 3# 262# happyReduction_691+happyReduction_691 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut318 happy_x_2 of { (HappyWrap318 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	( amsrn (sLL happy_var_1 happy_var_3 $ getRdrName (sumTyCon (snd happy_var_2 + 1)))+                                       (NameAnnBars NameParensHash (glAA happy_var_1) (map (EpaSpan . realSrcSpan) (fst happy_var_2)) (glAA happy_var_3) []))}}})+	) (\r -> happyReturn (happyIn278 r))++happyReduce_692 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_692 = happyMonadReduce 3# 262# happyReduction_692+happyReduction_692 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	( amsrn (sLL happy_var_1 happy_var_3 $ getRdrName unrestrictedFunTyCon)+                                       (NameAnn NameParens (glAA happy_var_1) (glAA happy_var_2) (glAA happy_var_3) []))}}})+	) (\r -> happyReturn (happyIn278 r))++happyReduce_693 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_693 = happyMonadReduce 2# 262# happyReduction_693+happyReduction_693 (happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	( amsrn (sLL happy_var_1 happy_var_2 $ listTyCon_RDR)+                                       (NameAnnOnly NameSquare (glAA happy_var_1) (glAA happy_var_2) []))}})+	) (\r -> happyReturn (happyIn278 r))++happyReduce_694 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_694 = happySpecReduce_1  263# happyReduction_694+happyReduction_694 happy_x_1+	 =  case happyOut282 happy_x_1 of { (HappyWrap282 happy_var_1) -> +	happyIn279+		 (happy_var_1+	)}++happyReduce_695 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_695 = happyMonadReduce 3# 263# happyReduction_695+happyReduction_695 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut284 happy_x_2 of { (HappyWrap284 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	( amsrn (sLL happy_var_1 happy_var_3 (unLoc happy_var_2))+                                                  (NameAnn NameParens (glAA happy_var_1) (glNRR happy_var_2) (glAA happy_var_3) []))}}})+	) (\r -> happyReturn (happyIn279 r))++happyReduce_696 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_696 = happySpecReduce_1  264# happyReduction_696+happyReduction_696 happy_x_1+	 =  case happyOut282 happy_x_1 of { (HappyWrap282 happy_var_1) -> +	happyIn280+		 (happy_var_1+	)}++happyReduce_697 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_697 = happyMonadReduce 3# 264# happyReduction_697+happyReduction_697 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	( let { name :: Located RdrName+                                    ; name = sL1 happy_var_2 $! mkQual tcClsName (getQCONSYM happy_var_2) }+                                in amsrn (sLL happy_var_1 happy_var_3 (unLoc name)) (NameAnn NameParens (glAA happy_var_1) (glAA happy_var_2) (glAA happy_var_3) []))}}})+	) (\r -> happyReturn (happyIn280 r))++happyReduce_698 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_698 = happyMonadReduce 3# 264# happyReduction_698+happyReduction_698 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	( let { name :: Located RdrName+                                    ; name = sL1 happy_var_2 $! mkUnqual tcClsName (getCONSYM happy_var_2) }+                                in amsrn (sLL happy_var_1 happy_var_3 (unLoc name)) (NameAnn NameParens (glAA happy_var_1) (glAA happy_var_2) (glAA happy_var_3) []))}}})+	) (\r -> happyReturn (happyIn280 r))++happyReduce_699 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_699 = happyMonadReduce 3# 264# happyReduction_699+happyReduction_699 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	( let { name :: Located RdrName+                                    ; name = sL1 happy_var_2 $! consDataCon_RDR }+                                in amsrn (sLL happy_var_1 happy_var_3 (unLoc name)) (NameAnn NameParens (glAA happy_var_1) (glAA happy_var_2) (glAA happy_var_3) []))}}})+	) (\r -> happyReturn (happyIn280 r))++happyReduce_700 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_700 = happySpecReduce_1  265# happyReduction_700+happyReduction_700 happy_x_1+	 =  case happyOut284 happy_x_1 of { (HappyWrap284 happy_var_1) -> +	happyIn281+		 (happy_var_1+	)}++happyReduce_701 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_701 = happyMonadReduce 3# 265# happyReduction_701+happyReduction_701 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut282 happy_x_2 of { (HappyWrap282 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	( amsrn (sLL happy_var_1 happy_var_3 (unLoc happy_var_2))+                                                 (NameAnn NameBackquotes (glAA happy_var_1) (glNRR happy_var_2) (glAA happy_var_3) []))}}})+	) (\r -> happyReturn (happyIn281 r))++happyReduce_702 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_702 = happySpecReduce_1  266# happyReduction_702+happyReduction_702 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn282+		 (sL1n happy_var_1 $! mkQual tcClsName (getQCONID happy_var_1)+	)}++happyReduce_703 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_703 = happySpecReduce_1  266# happyReduction_703+happyReduction_703 happy_x_1+	 =  case happyOut283 happy_x_1 of { (HappyWrap283 happy_var_1) -> +	happyIn282+		 (happy_var_1+	)}++happyReduce_704 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_704 = happySpecReduce_1  267# happyReduction_704+happyReduction_704 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn283+		 (sL1n happy_var_1 $! mkUnqual tcClsName (getCONID happy_var_1)+	)}++happyReduce_705 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_705 = happySpecReduce_1  268# happyReduction_705+happyReduction_705 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn284+		 (sL1n happy_var_1 $! mkQual tcClsName (getQCONSYM happy_var_1)+	)}++happyReduce_706 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_706 = happySpecReduce_1  268# happyReduction_706+happyReduction_706 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn284+		 (sL1n happy_var_1 $! mkQual tcClsName (getQVARSYM happy_var_1)+	)}++happyReduce_707 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_707 = happySpecReduce_1  268# happyReduction_707+happyReduction_707 happy_x_1+	 =  case happyOut285 happy_x_1 of { (HappyWrap285 happy_var_1) -> +	happyIn284+		 (happy_var_1+	)}++happyReduce_708 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_708 = happySpecReduce_1  269# happyReduction_708+happyReduction_708 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn285+		 (sL1n happy_var_1 $! mkUnqual tcClsName (getCONSYM happy_var_1)+	)}++happyReduce_709 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_709 = happySpecReduce_1  269# happyReduction_709+happyReduction_709 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn285+		 (sL1n happy_var_1 $! mkUnqual tcClsName (getVARSYM happy_var_1)+	)}++happyReduce_710 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_710 = happySpecReduce_1  269# happyReduction_710+happyReduction_710 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn285+		 (sL1n happy_var_1 $! consDataCon_RDR+	)}++happyReduce_711 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_711 = happySpecReduce_1  269# happyReduction_711+happyReduction_711 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn285+		 (sL1n happy_var_1 $! mkUnqual tcClsName (fsLit "-")+	)}++happyReduce_712 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_712 = happySpecReduce_1  269# happyReduction_712+happyReduction_712 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn285+		 (sL1n happy_var_1 $! mkUnqual tcClsName (fsLit ".")+	)}++happyReduce_713 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_713 = happySpecReduce_1  270# happyReduction_713+happyReduction_713 happy_x_1+	 =  case happyOut283 happy_x_1 of { (HappyWrap283 happy_var_1) -> +	happyIn286+		 (happy_var_1+	)}++happyReduce_714 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_714 = happyMonadReduce 3# 270# happyReduction_714+happyReduction_714 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut285 happy_x_2 of { (HappyWrap285 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	( amsrn (sLL happy_var_1 happy_var_3 (unLoc happy_var_2))+                                         (NameAnn NameParens (glAA happy_var_1) (glNRR happy_var_2) (glAA happy_var_3) []))}}})+	) (\r -> happyReturn (happyIn286 r))++happyReduce_715 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_715 = happySpecReduce_1  271# happyReduction_715+happyReduction_715 happy_x_1+	 =  case happyOut288 happy_x_1 of { (HappyWrap288 happy_var_1) -> +	happyIn287+		 (happy_var_1+	)}++happyReduce_716 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_716 = happySpecReduce_1  271# happyReduction_716+happyReduction_716 happy_x_1+	 =  case happyOut275 happy_x_1 of { (HappyWrap275 happy_var_1) -> +	happyIn287+		 (happy_var_1+	)}++happyReduce_717 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_717 = happySpecReduce_1  271# happyReduction_717+happyReduction_717 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn287+		 (sL1n happy_var_1 $ getRdrName unrestrictedFunTyCon+	)}++happyReduce_718 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_718 = happySpecReduce_1  272# happyReduction_718+happyReduction_718 happy_x_1+	 =  case happyOut305 happy_x_1 of { (HappyWrap305 happy_var_1) -> +	happyIn288+		 (happy_var_1+	)}++happyReduce_719 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_719 = happyMonadReduce 3# 272# happyReduction_719+happyReduction_719 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut301 happy_x_2 of { (HappyWrap301 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	( amsrn (sLL happy_var_1 happy_var_3 (unLoc happy_var_2))+                                           (NameAnn NameBackquotes (glAA happy_var_1) (glNRR happy_var_2) (glAA happy_var_3) []))}}})+	) (\r -> happyReturn (happyIn288 r))++happyReduce_720 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_720 = happySpecReduce_1  273# happyReduction_720+happyReduction_720 happy_x_1+	 =  case happyOut292 happy_x_1 of { (HappyWrap292 happy_var_1) -> +	happyIn289+		 (mkHsVarOpPV happy_var_1+	)}++happyReduce_721 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_721 = happySpecReduce_1  273# happyReduction_721+happyReduction_721 happy_x_1+	 =  case happyOut276 happy_x_1 of { (HappyWrap276 happy_var_1) -> +	happyIn289+		 (mkHsConOpPV happy_var_1+	)}++happyReduce_722 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_722 = happySpecReduce_1  273# happyReduction_722+happyReduction_722 happy_x_1+	 =  case happyOut291 happy_x_1 of { (HappyWrap291 happy_var_1) -> +	happyIn289+		 (pvN happy_var_1+	)}++happyReduce_723 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_723 = happySpecReduce_1  274# happyReduction_723+happyReduction_723 happy_x_1+	 =  case happyOut293 happy_x_1 of { (HappyWrap293 happy_var_1) -> +	happyIn290+		 (mkHsVarOpPV happy_var_1+	)}++happyReduce_724 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_724 = happySpecReduce_1  274# happyReduction_724+happyReduction_724 happy_x_1+	 =  case happyOut276 happy_x_1 of { (HappyWrap276 happy_var_1) -> +	happyIn290+		 (mkHsConOpPV happy_var_1+	)}++happyReduce_725 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_725 = happySpecReduce_1  274# happyReduction_725+happyReduction_725 happy_x_1+	 =  case happyOut291 happy_x_1 of { (HappyWrap291 happy_var_1) -> +	happyIn290+		 (pvN happy_var_1+	)}++happyReduce_726 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_726 = happySpecReduce_3  275# happyReduction_726+happyReduction_726 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	happyIn291+		 (mkHsInfixHolePV (comb2 happy_var_1 happy_var_3)+                                         (\cs -> EpAnn (glR happy_var_1) (EpAnnUnboundVar (glAA happy_var_1, glAA happy_var_3) (glAA happy_var_2)) cs)+	)}}}++happyReduce_727 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_727 = happySpecReduce_1  276# happyReduction_727+happyReduction_727 happy_x_1+	 =  case happyOut302 happy_x_1 of { (HappyWrap302 happy_var_1) -> +	happyIn292+		 (happy_var_1+	)}++happyReduce_728 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_728 = happyMonadReduce 3# 276# happyReduction_728+happyReduction_728 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut300 happy_x_2 of { (HappyWrap300 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	( amsrn (sLL happy_var_1 happy_var_3 (unLoc happy_var_2))+                                           (NameAnn NameBackquotes (glAA happy_var_1) (glNRR happy_var_2) (glAA happy_var_3) []))}}})+	) (\r -> happyReturn (happyIn292 r))++happyReduce_729 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_729 = happySpecReduce_1  277# happyReduction_729+happyReduction_729 happy_x_1+	 =  case happyOut303 happy_x_1 of { (HappyWrap303 happy_var_1) -> +	happyIn293+		 (happy_var_1+	)}++happyReduce_730 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_730 = happyMonadReduce 3# 277# happyReduction_730+happyReduction_730 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut300 happy_x_2 of { (HappyWrap300 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	( amsrn (sLL happy_var_1 happy_var_3 (unLoc happy_var_2))+                                           (NameAnn NameBackquotes (glAA happy_var_1) (glNRR happy_var_2) (glAA happy_var_3) []))}}})+	) (\r -> happyReturn (happyIn293 r))++happyReduce_731 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_731 = happySpecReduce_1  278# happyReduction_731+happyReduction_731 happy_x_1+	 =  case happyOut296 happy_x_1 of { (HappyWrap296 happy_var_1) -> +	happyIn294+		 (happy_var_1+	)}++happyReduce_732 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_732 = happyMonadReduce 3# 279# happyReduction_732+happyReduction_732 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut296 happy_x_2 of { (HappyWrap296 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	( amsrn (sLL happy_var_1 happy_var_3 (unLoc happy_var_2))+                                           (NameAnn NameBackquotes (glAA happy_var_1) (glNRR happy_var_2) (glAA happy_var_3) []))}}})+	) (\r -> happyReturn (happyIn295 r))++happyReduce_733 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_733 = happySpecReduce_1  280# happyReduction_733+happyReduction_733 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn296+		 (sL1n happy_var_1 $! mkUnqual tvName (getVARID happy_var_1)+	)}++happyReduce_734 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_734 = happySpecReduce_1  280# happyReduction_734+happyReduction_734 happy_x_1+	 =  case happyOut307 happy_x_1 of { (HappyWrap307 happy_var_1) -> +	happyIn296+		 (sL1n happy_var_1 $! mkUnqual tvName (unLoc happy_var_1)+	)}++happyReduce_735 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_735 = happySpecReduce_1  280# happyReduction_735+happyReduction_735 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn296+		 (sL1n happy_var_1 $! mkUnqual tvName (fsLit "unsafe")+	)}++happyReduce_736 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_736 = happySpecReduce_1  280# happyReduction_736+happyReduction_736 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn296+		 (sL1n happy_var_1 $! mkUnqual tvName (fsLit "safe")+	)}++happyReduce_737 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_737 = happySpecReduce_1  280# happyReduction_737+happyReduction_737 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn296+		 (sL1n happy_var_1 $! mkUnqual tvName (fsLit "interruptible")+	)}++happyReduce_738 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_738 = happySpecReduce_1  281# happyReduction_738+happyReduction_738 happy_x_1+	 =  case happyOut301 happy_x_1 of { (HappyWrap301 happy_var_1) -> +	happyIn297+		 (happy_var_1+	)}++happyReduce_739 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_739 = happyMonadReduce 3# 281# happyReduction_739+happyReduction_739 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut305 happy_x_2 of { (HappyWrap305 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	( amsrn (sLL happy_var_1 happy_var_3 (unLoc happy_var_2))+                                   (NameAnn NameParens (glAA happy_var_1) (glNRR happy_var_2) (glAA happy_var_3) []))}}})+	) (\r -> happyReturn (happyIn297 r))++happyReduce_740 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_740 = happySpecReduce_1  282# happyReduction_740+happyReduction_740 happy_x_1+	 =  case happyOut300 happy_x_1 of { (HappyWrap300 happy_var_1) -> +	happyIn298+		 (happy_var_1+	)}++happyReduce_741 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_741 = happyMonadReduce 3# 282# happyReduction_741+happyReduction_741 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut305 happy_x_2 of { (HappyWrap305 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	( amsrn (sLL happy_var_1 happy_var_3 (unLoc happy_var_2))+                                   (NameAnn NameParens (glAA happy_var_1) (glNRR happy_var_2) (glAA happy_var_3) []))}}})+	) (\r -> happyReturn (happyIn298 r))++happyReduce_742 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_742 = happyMonadReduce 3# 282# happyReduction_742+happyReduction_742 (happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut304 happy_x_2 of { (HappyWrap304 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	( amsrn (sLL happy_var_1 happy_var_3 (unLoc happy_var_2))+                                   (NameAnn NameParens (glAA happy_var_1) (glNRR happy_var_2) (glAA happy_var_3) []))}}})+	) (\r -> happyReturn (happyIn298 r))++happyReduce_743 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_743 = happySpecReduce_1  283# happyReduction_743+happyReduction_743 happy_x_1+	 =  case happyOut301 happy_x_1 of { (HappyWrap301 happy_var_1) -> +	happyIn299+		 (reLocN $ fmap (occNameFS . rdrNameOcc) happy_var_1+	)}++happyReduce_744 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_744 = happySpecReduce_1  284# happyReduction_744+happyReduction_744 happy_x_1+	 =  case happyOut301 happy_x_1 of { (HappyWrap301 happy_var_1) -> +	happyIn300+		 (happy_var_1+	)}++happyReduce_745 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_745 = happySpecReduce_1  284# happyReduction_745+happyReduction_745 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn300+		 (sL1n happy_var_1 $! mkQual varName (getQVARID happy_var_1)+	)}++happyReduce_746 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_746 = happySpecReduce_1  285# happyReduction_746+happyReduction_746 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn301+		 (sL1n happy_var_1 $! mkUnqual varName (getVARID happy_var_1)+	)}++happyReduce_747 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_747 = happySpecReduce_1  285# happyReduction_747+happyReduction_747 happy_x_1+	 =  case happyOut307 happy_x_1 of { (HappyWrap307 happy_var_1) -> +	happyIn301+		 (sL1n happy_var_1 $! mkUnqual varName (unLoc happy_var_1)+	)}++happyReduce_748 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_748 = happySpecReduce_1  285# happyReduction_748+happyReduction_748 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn301+		 (sL1n happy_var_1 $! mkUnqual varName (fsLit "unsafe")+	)}++happyReduce_749 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_749 = happySpecReduce_1  285# happyReduction_749+happyReduction_749 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn301+		 (sL1n happy_var_1 $! mkUnqual varName (fsLit "safe")+	)}++happyReduce_750 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_750 = happySpecReduce_1  285# happyReduction_750+happyReduction_750 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn301+		 (sL1n happy_var_1 $! mkUnqual varName (fsLit "interruptible")+	)}++happyReduce_751 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_751 = happySpecReduce_1  285# happyReduction_751+happyReduction_751 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn301+		 (sL1n happy_var_1 $! mkUnqual varName (fsLit "forall")+	)}++happyReduce_752 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_752 = happySpecReduce_1  285# happyReduction_752+happyReduction_752 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn301+		 (sL1n happy_var_1 $! mkUnqual varName (fsLit "family")+	)}++happyReduce_753 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_753 = happySpecReduce_1  285# happyReduction_753+happyReduction_753 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn301+		 (sL1n happy_var_1 $! mkUnqual varName (fsLit "role")+	)}++happyReduce_754 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_754 = happySpecReduce_1  286# happyReduction_754+happyReduction_754 happy_x_1+	 =  case happyOut305 happy_x_1 of { (HappyWrap305 happy_var_1) -> +	happyIn302+		 (happy_var_1+	)}++happyReduce_755 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_755 = happySpecReduce_1  286# happyReduction_755+happyReduction_755 happy_x_1+	 =  case happyOut304 happy_x_1 of { (HappyWrap304 happy_var_1) -> +	happyIn302+		 (happy_var_1+	)}++happyReduce_756 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_756 = happySpecReduce_1  287# happyReduction_756+happyReduction_756 happy_x_1+	 =  case happyOut306 happy_x_1 of { (HappyWrap306 happy_var_1) -> +	happyIn303+		 (happy_var_1+	)}++happyReduce_757 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_757 = happySpecReduce_1  287# happyReduction_757+happyReduction_757 happy_x_1+	 =  case happyOut304 happy_x_1 of { (HappyWrap304 happy_var_1) -> +	happyIn303+		 (happy_var_1+	)}++happyReduce_758 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_758 = happySpecReduce_1  288# happyReduction_758+happyReduction_758 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn304+		 (sL1n happy_var_1 $ mkQual varName (getQVARSYM happy_var_1)+	)}++happyReduce_759 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_759 = happySpecReduce_1  289# happyReduction_759+happyReduction_759 happy_x_1+	 =  case happyOut306 happy_x_1 of { (HappyWrap306 happy_var_1) -> +	happyIn305+		 (happy_var_1+	)}++happyReduce_760 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_760 = happySpecReduce_1  289# happyReduction_760+happyReduction_760 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn305+		 (sL1n happy_var_1 $ mkUnqual varName (fsLit "-")+	)}++happyReduce_761 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_761 = happySpecReduce_1  290# happyReduction_761+happyReduction_761 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn306+		 (sL1n happy_var_1 $ mkUnqual varName (getVARSYM happy_var_1)+	)}++happyReduce_762 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_762 = happySpecReduce_1  290# happyReduction_762+happyReduction_762 happy_x_1+	 =  case happyOut308 happy_x_1 of { (HappyWrap308 happy_var_1) -> +	happyIn306+		 (sL1n happy_var_1 $ mkUnqual varName (unLoc happy_var_1)+	)}++happyReduce_763 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_763 = happySpecReduce_1  291# happyReduction_763+happyReduction_763 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn307+		 (sL1 happy_var_1 (fsLit "as")+	)}++happyReduce_764 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_764 = happySpecReduce_1  291# happyReduction_764+happyReduction_764 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn307+		 (sL1 happy_var_1 (fsLit "qualified")+	)}++happyReduce_765 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_765 = happySpecReduce_1  291# happyReduction_765+happyReduction_765 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn307+		 (sL1 happy_var_1 (fsLit "hiding")+	)}++happyReduce_766 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_766 = happySpecReduce_1  291# happyReduction_766+happyReduction_766 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn307+		 (sL1 happy_var_1 (fsLit "export")+	)}++happyReduce_767 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_767 = happySpecReduce_1  291# happyReduction_767+happyReduction_767 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn307+		 (sL1 happy_var_1 (fsLit "label")+	)}++happyReduce_768 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_768 = happySpecReduce_1  291# happyReduction_768+happyReduction_768 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn307+		 (sL1 happy_var_1 (fsLit "dynamic")+	)}++happyReduce_769 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_769 = happySpecReduce_1  291# happyReduction_769+happyReduction_769 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn307+		 (sL1 happy_var_1 (fsLit "stdcall")+	)}++happyReduce_770 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_770 = happySpecReduce_1  291# happyReduction_770+happyReduction_770 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn307+		 (sL1 happy_var_1 (fsLit "ccall")+	)}++happyReduce_771 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_771 = happySpecReduce_1  291# happyReduction_771+happyReduction_771 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn307+		 (sL1 happy_var_1 (fsLit "capi")+	)}++happyReduce_772 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_772 = happySpecReduce_1  291# happyReduction_772+happyReduction_772 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn307+		 (sL1 happy_var_1 (fsLit "prim")+	)}++happyReduce_773 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_773 = happySpecReduce_1  291# happyReduction_773+happyReduction_773 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn307+		 (sL1 happy_var_1 (fsLit "javascript")+	)}++happyReduce_774 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_774 = happySpecReduce_1  291# happyReduction_774+happyReduction_774 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn307+		 (sL1 happy_var_1 (fsLit "group")+	)}++happyReduce_775 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_775 = happySpecReduce_1  291# happyReduction_775+happyReduction_775 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn307+		 (sL1 happy_var_1 (fsLit "stock")+	)}++happyReduce_776 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_776 = happySpecReduce_1  291# happyReduction_776+happyReduction_776 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn307+		 (sL1 happy_var_1 (fsLit "anyclass")+	)}++happyReduce_777 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_777 = happySpecReduce_1  291# happyReduction_777+happyReduction_777 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn307+		 (sL1 happy_var_1 (fsLit "via")+	)}++happyReduce_778 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_778 = happySpecReduce_1  291# happyReduction_778+happyReduction_778 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn307+		 (sL1 happy_var_1 (fsLit "unit")+	)}++happyReduce_779 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_779 = happySpecReduce_1  291# happyReduction_779+happyReduction_779 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn307+		 (sL1 happy_var_1 (fsLit "dependency")+	)}++happyReduce_780 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_780 = happySpecReduce_1  291# happyReduction_780+happyReduction_780 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn307+		 (sL1 happy_var_1 (fsLit "signature")+	)}++happyReduce_781 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_781 = happySpecReduce_1  292# happyReduction_781+happyReduction_781 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn308+		 (sL1 happy_var_1 (fsLit ".")+	)}++happyReduce_782 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_782 = happySpecReduce_1  292# happyReduction_782+happyReduction_782 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn308+		 (sL1 happy_var_1 (fsLit (starSym (isUnicode happy_var_1)))+	)}++happyReduce_783 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_783 = happySpecReduce_1  293# happyReduction_783+happyReduction_783 happy_x_1+	 =  case happyOut310 happy_x_1 of { (HappyWrap310 happy_var_1) -> +	happyIn309+		 (happy_var_1+	)}++happyReduce_784 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_784 = happySpecReduce_1  293# happyReduction_784+happyReduction_784 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn309+		 (sL1n happy_var_1 $! mkQual dataName (getQCONID happy_var_1)+	)}++happyReduce_785 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_785 = happySpecReduce_1  294# happyReduction_785+happyReduction_785 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn310+		 (sL1n happy_var_1 $ mkUnqual dataName (getCONID happy_var_1)+	)}++happyReduce_786 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_786 = happySpecReduce_1  295# happyReduction_786+happyReduction_786 happy_x_1+	 =  case happyOut312 happy_x_1 of { (HappyWrap312 happy_var_1) -> +	happyIn311+		 (happy_var_1+	)}++happyReduce_787 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_787 = happySpecReduce_1  295# happyReduction_787+happyReduction_787 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn311+		 (sL1n happy_var_1 $ mkQual dataName (getQCONSYM happy_var_1)+	)}++happyReduce_788 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_788 = happySpecReduce_1  296# happyReduction_788+happyReduction_788 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn312+		 (sL1n happy_var_1 $ mkUnqual dataName (getCONSYM happy_var_1)+	)}++happyReduce_789 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_789 = happySpecReduce_1  296# happyReduction_789+happyReduction_789 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn312+		 (sL1n happy_var_1 $ consDataCon_RDR+	)}++happyReduce_790 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_790 = happySpecReduce_1  297# happyReduction_790+happyReduction_790 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn313+		 (sL1 happy_var_1 $ HsChar       (getCHARs happy_var_1) $ getCHAR happy_var_1+	)}++happyReduce_791 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_791 = happySpecReduce_1  297# happyReduction_791+happyReduction_791 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn313+		 (sL1 happy_var_1 $ HsString     (getSTRINGs happy_var_1)+                                                    $ getSTRING happy_var_1+	)}++happyReduce_792 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_792 = happySpecReduce_1  297# happyReduction_792+happyReduction_792 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn313+		 (sL1 happy_var_1 $ HsIntPrim    (getPRIMINTEGERs happy_var_1)+                                                    $ getPRIMINTEGER happy_var_1+	)}++happyReduce_793 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_793 = happySpecReduce_1  297# happyReduction_793+happyReduction_793 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn313+		 (sL1 happy_var_1 $ HsWordPrim   (getPRIMWORDs happy_var_1)+                                                    $ getPRIMWORD happy_var_1+	)}++happyReduce_794 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_794 = happySpecReduce_1  297# happyReduction_794+happyReduction_794 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn313+		 (sL1 happy_var_1 $ HsCharPrim   (getPRIMCHARs happy_var_1)+                                                    $ getPRIMCHAR happy_var_1+	)}++happyReduce_795 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_795 = happySpecReduce_1  297# happyReduction_795+happyReduction_795 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn313+		 (sL1 happy_var_1 $ HsStringPrim (getPRIMSTRINGs happy_var_1)+                                                    $ getPRIMSTRING happy_var_1+	)}++happyReduce_796 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_796 = happySpecReduce_1  297# happyReduction_796+happyReduction_796 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn313+		 (sL1 happy_var_1 $ HsFloatPrim  noExtField $ getPRIMFLOAT happy_var_1+	)}++happyReduce_797 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_797 = happySpecReduce_1  297# happyReduction_797+happyReduction_797 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn313+		 (sL1 happy_var_1 $ HsDoublePrim noExtField $ getPRIMDOUBLE happy_var_1+	)}++happyReduce_798 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_798 = happySpecReduce_1  298# happyReduction_798+happyReduction_798 happy_x_1+	 =  happyIn314+		 (()+	)++happyReduce_799 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_799 = happyMonadReduce 1# 298# happyReduction_799+happyReduction_799 (happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((( popContext))+	) (\r -> happyReturn (happyIn314 r))++happyReduce_800 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_800 = happySpecReduce_1  299# happyReduction_800+happyReduction_800 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn315+		 (sL1a happy_var_1 $ mkModuleNameFS (getCONID happy_var_1)+	)}++happyReduce_801 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_801 = happySpecReduce_1  299# happyReduction_801+happyReduction_801 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn315+		 (sL1a happy_var_1 $ let (mod,c) = getQCONID happy_var_1 in+                                  mkModuleNameFS+                                   (mkFastString+                                     (unpackFS mod ++ '.':unpackFS c))+	)}++happyReduce_802 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_802 = happySpecReduce_2  300# happyReduction_802+happyReduction_802 happy_x_2+	happy_x_1+	 =  case happyOut316 happy_x_1 of { (HappyWrap316 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	happyIn316+		 (((fst happy_var_1)++[gl happy_var_2],snd happy_var_1 + 1)+	)}}++happyReduce_803 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_803 = happySpecReduce_1  300# happyReduction_803+happyReduction_803 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn316+		 (([gl happy_var_1],1)+	)}++happyReduce_804 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_804 = happySpecReduce_1  301# happyReduction_804+happyReduction_804 happy_x_1+	 =  case happyOut318 happy_x_1 of { (HappyWrap318 happy_var_1) -> +	happyIn317+		 (happy_var_1+	)}++happyReduce_805 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_805 = happySpecReduce_0  301# happyReduction_805+happyReduction_805  =  happyIn317+		 (([], 0)+	)++happyReduce_806 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_806 = happySpecReduce_2  302# happyReduction_806+happyReduction_806 happy_x_2+	happy_x_1+	 =  case happyOut318 happy_x_1 of { (HappyWrap318 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	happyIn318+		 (((fst happy_var_1)++[gl happy_var_2],snd happy_var_1 + 1)+	)}}++happyReduce_807 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_807 = happySpecReduce_1  302# happyReduction_807+happyReduction_807 happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	happyIn318+		 (([gl happy_var_1],1)+	)}++happyReduce_808 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_808 = happySpecReduce_3  303# happyReduction_808+happyReduction_808 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut323 happy_x_2 of { (HappyWrap323 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	happyIn319+		 (happy_var_2 >>= \ happy_var_2 -> amsrl+                                           (sLL happy_var_1 happy_var_3 (reverse (snd $ unLoc happy_var_2)))+                                           (AnnList (Just $ glR happy_var_2) (Just $ moc happy_var_1) (Just $ mcc happy_var_3) (fst $ unLoc happy_var_2) [])+	)}}}++happyReduce_809 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_809 = happySpecReduce_3  303# happyReduction_809+happyReduction_809 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut323 happy_x_2 of { (HappyWrap323 happy_var_2) -> +	happyIn319+		 (happy_var_2 >>= \ happy_var_2 -> amsrl+                                           (L (getLoc happy_var_2) (reverse (snd $ unLoc happy_var_2)))+                                           (AnnList (Just $ glR happy_var_2) Nothing Nothing (fst $ unLoc happy_var_2) [])+	)}++happyReduce_810 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_810 = happySpecReduce_2  303# happyReduction_810+happyReduction_810 happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	happyIn319+		 (amsrl (sLL happy_var_1 happy_var_2 []) (AnnList Nothing (Just $ moc happy_var_1) (Just $ mcc happy_var_2) [] [])+	)}}++happyReduce_811 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_811 = happySpecReduce_2  303# happyReduction_811+happyReduction_811 happy_x_2+	happy_x_1+	 =  happyIn319+		 (return $ noLocA []+	)++happyReduce_812 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_812 = happySpecReduce_3  304# happyReduction_812+happyReduction_812 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut324 happy_x_2 of { (HappyWrap324 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	happyIn320+		 (happy_var_2 >>= \ happy_var_2 -> amsrl+                                           (sLL happy_var_1 happy_var_3 (reverse (snd $ unLoc happy_var_2)))+                                           (AnnList (Just $ glR happy_var_2) (Just $ moc happy_var_1) (Just $ mcc happy_var_3) (fst $ unLoc happy_var_2) [])+	)}}}++happyReduce_813 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_813 = happySpecReduce_3  304# happyReduction_813+happyReduction_813 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut324 happy_x_2 of { (HappyWrap324 happy_var_2) -> +	happyIn320+		 (happy_var_2 >>= \ happy_var_2 -> amsrl+                                           (L (getLoc happy_var_2) (reverse (snd $ unLoc happy_var_2)))+                                           (AnnList (Just $ glR happy_var_2) Nothing Nothing (fst $ unLoc happy_var_2) [])+	)}++happyReduce_814 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_814 = happySpecReduce_2  304# happyReduction_814+happyReduction_814 happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	happyIn320+		 (amsrl (sLL happy_var_1 happy_var_2 []) (AnnList Nothing (Just $ moc happy_var_1) (Just $ mcc happy_var_2) [] [])+	)}}++happyReduce_815 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_815 = happySpecReduce_2  304# happyReduction_815+happyReduction_815 happy_x_2+	happy_x_1+	 =  happyIn320+		 (return $ noLocA []+	)++happyReduce_816 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_816 = happyMonadReduce 2# 305# happyReduction_816+happyReduction_816 (happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut211 happy_x_1 of { (HappyWrap211 happy_var_1) -> +	case happyOut206 happy_x_2 of { (HappyWrap206 happy_var_2) -> +	( runPV (unECP happy_var_2) >>= \ happy_var_2 ->+         fmap ecpFromExp $+         return $ (reLocA $ sLLlA happy_var_1 happy_var_2 $ HsPragE noExtField (unLoc happy_var_1) happy_var_2))}})+	) (\r -> happyReturn (happyIn321 r))++happyReduce_817 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_817 = happyMonadReduce 2# 306# happyReduction_817+happyReduction_817 (happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut211 happy_x_1 of { (HappyWrap211 happy_var_1) -> +	case happyOut208 happy_x_2 of { (HappyWrap208 happy_var_2) -> +	( runPV (unECP happy_var_2) >>= \ happy_var_2 ->+         fmap ecpFromExp $+         return $ (reLocA $ sLLlA happy_var_1 happy_var_2 $ HsPragE noExtField (unLoc happy_var_1) happy_var_2))}})+	) (\r -> happyReturn (happyIn322 r))++happyReduce_818 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_818 = happySpecReduce_1  307# happyReduction_818+happyReduction_818 happy_x_1+	 =  case happyOut325 happy_x_1 of { (HappyWrap325 happy_var_1) -> +	happyIn323+		 (happy_var_1 >>= \ happy_var_1 -> return $+                                     sL1 happy_var_1 (fst $ unLoc happy_var_1,snd $ unLoc happy_var_1)+	)}++happyReduce_819 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_819 = happySpecReduce_2  307# happyReduction_819+happyReduction_819 happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut323 happy_x_2 of { (HappyWrap323 happy_var_2) -> +	happyIn323+		 (happy_var_2 >>= \ happy_var_2 -> return $+                                     sLL happy_var_1 happy_var_2 (((mz AnnSemi happy_var_1) ++ (fst $ unLoc happy_var_2) )+                                               ,snd $ unLoc happy_var_2)+	)}}++happyReduce_820 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_820 = happySpecReduce_1  308# happyReduction_820+happyReduction_820 happy_x_1+	 =  case happyOut326 happy_x_1 of { (HappyWrap326 happy_var_1) -> +	happyIn324+		 (happy_var_1 >>= \ happy_var_1 -> return $+                                     sL1 happy_var_1 (fst $ unLoc happy_var_1,snd $ unLoc happy_var_1)+	)}++happyReduce_821 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_821 = happySpecReduce_2  308# happyReduction_821+happyReduction_821 happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut324 happy_x_2 of { (HappyWrap324 happy_var_2) -> +	happyIn324+		 (happy_var_2 >>= \ happy_var_2 -> return $+                                     sLL happy_var_1 happy_var_2 (((mz AnnSemi happy_var_1) ++ (fst $ unLoc happy_var_2) )+                                               ,snd $ unLoc happy_var_2)+	)}}++happyReduce_822 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_822 = happySpecReduce_3  309# happyReduction_822+happyReduction_822 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut325 happy_x_1 of { (HappyWrap325 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut327 happy_x_3 of { (HappyWrap327 happy_var_3) -> +	happyIn325+		 (happy_var_1 >>= \ happy_var_1 ->+                                        happy_var_3 >>= \ happy_var_3 ->+                                          case snd $ unLoc happy_var_1 of+                                            [] -> return (sLL happy_var_1 (reLoc happy_var_3) ((fst $ unLoc happy_var_1) ++ (mz AnnSemi happy_var_2)+                                                                            ,[happy_var_3]))+                                            (h:t) -> do+                                              h' <- addTrailingSemiA h (gl happy_var_2)+                                              return (sLL happy_var_1 (reLoc happy_var_3) (fst $ unLoc happy_var_1,happy_var_3 : h' : t))+	)}}}++happyReduce_823 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_823 = happySpecReduce_2  309# happyReduction_823+happyReduction_823 happy_x_2+	happy_x_1+	 =  case happyOut325 happy_x_1 of { (HappyWrap325 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	happyIn325+		 (happy_var_1 >>= \ happy_var_1 ->+                                         case snd $ unLoc happy_var_1 of+                                           [] -> return (sLL happy_var_1 happy_var_2 ((fst $ unLoc happy_var_1) ++ (mz AnnSemi happy_var_2)+                                                                           ,[]))+                                           (h:t) -> do+                                             h' <- addTrailingSemiA h (gl happy_var_2)+                                             return (sLL happy_var_1 happy_var_2 (fst $ unLoc happy_var_1, h' : t))+	)}}++happyReduce_824 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_824 = happySpecReduce_1  309# happyReduction_824+happyReduction_824 happy_x_1+	 =  case happyOut327 happy_x_1 of { (HappyWrap327 happy_var_1) -> +	happyIn325+		 (happy_var_1 >>= \ happy_var_1 -> return $ sL1 (reLoc happy_var_1) ([],[happy_var_1])+	)}++happyReduce_825 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_825 = happySpecReduce_3  310# happyReduction_825+happyReduction_825 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut326 happy_x_1 of { (HappyWrap326 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut328 happy_x_3 of { (HappyWrap328 happy_var_3) -> +	happyIn326+		 (happy_var_1 >>= \ happy_var_1 ->+                                        happy_var_3 >>= \ happy_var_3 ->+                                          case snd $ unLoc happy_var_1 of+                                            [] -> return (sLL happy_var_1 (reLoc happy_var_3) ((fst $ unLoc happy_var_1) ++ (mz AnnSemi happy_var_2)+                                                                            ,[happy_var_3]))+                                            (h:t) -> do+                                              h' <- addTrailingSemiA h (gl happy_var_2)+                                              return (sLL happy_var_1 (reLoc happy_var_3) (fst $ unLoc happy_var_1,happy_var_3 : h' : t))+	)}}}++happyReduce_826 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_826 = happySpecReduce_2  310# happyReduction_826+happyReduction_826 happy_x_2+	happy_x_1+	 =  case happyOut326 happy_x_1 of { (HappyWrap326 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	happyIn326+		 (happy_var_1 >>= \ happy_var_1 ->+                                         case snd $ unLoc happy_var_1 of+                                           [] -> return (sLL happy_var_1 happy_var_2 ((fst $ unLoc happy_var_1) ++ (mz AnnSemi happy_var_2)+                                                                           ,[]))+                                           (h:t) -> do+                                             h' <- addTrailingSemiA h (gl happy_var_2)+                                             return (sLL happy_var_1 happy_var_2 (fst $ unLoc happy_var_1, h' : t))+	)}}++happyReduce_827 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_827 = happySpecReduce_1  310# happyReduction_827+happyReduction_827 happy_x_1+	 =  case happyOut328 happy_x_1 of { (HappyWrap328 happy_var_1) -> +	happyIn326+		 (happy_var_1 >>= \ happy_var_1 -> return $ sL1 (reLoc happy_var_1) ([],[happy_var_1])+	)}++happyReduce_828 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_828 = happySpecReduce_2  311# happyReduction_828+happyReduction_828 happy_x_2+	happy_x_1+	 =  case happyOut245 happy_x_1 of { (HappyWrap245 happy_var_1) -> +	case happyOut236 happy_x_2 of { (HappyWrap236 happy_var_2) -> +	happyIn327+		 (happy_var_2 >>= \ happy_var_2 ->+                         acsA (\cs -> sLLAsl happy_var_1 happy_var_2+                                         (Match { m_ext = EpAnn (listAsAnchor happy_var_1) [] cs+                                                , m_ctxt = CaseAlt -- for \case and \cases, this will be changed during post-processing+                                                , m_pats = happy_var_1+                                                , m_grhss = unLoc happy_var_2 }))+	)}}++happyReduce_829 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )+happyReduce_829 = happySpecReduce_2  312# happyReduction_829+happyReduction_829 happy_x_2+	happy_x_1+	 =  case happyOut242 happy_x_1 of { (HappyWrap242 happy_var_1) -> +	case happyOut236 happy_x_2 of { (HappyWrap236 happy_var_2) -> +	happyIn328+		 (happy_var_2 >>= \ happy_var_2 ->+                         acsA (\cs -> sLLAsl happy_var_1 happy_var_2+                                         (Match { m_ext = EpAnn (listAsAnchor happy_var_1) [] cs+                                                , m_ctxt = CaseAlt -- for \case and \cases, this will be changed during post-processing+                                                , m_pats = happy_var_1+                                                , m_grhss = unLoc happy_var_2 }))+	)}}++happyNewToken action sts stk+	= (lexer True)(\tk -> +	let cont i = happyDoAction i tk action sts stk in+	case tk of {+	L _ ITeof -> happyDoAction 150# tk action sts stk;+	L _ ITunderscore -> cont 1#;+	L _ ITas -> cont 2#;+	L _ ITcase -> cont 3#;+	L _ ITclass -> cont 4#;+	L _ ITdata -> cont 5#;+	L _ ITdefault -> cont 6#;+	L _ ITderiving -> cont 7#;+	L _ ITelse -> cont 8#;+	L _ IThiding -> cont 9#;+	L _ ITif -> cont 10#;+	L _ ITimport -> cont 11#;+	L _ ITin -> cont 12#;+	L _ ITinfix -> cont 13#;+	L _ ITinfixl -> cont 14#;+	L _ ITinfixr -> cont 15#;+	L _ ITinstance -> cont 16#;+	L _ ITlet -> cont 17#;+	L _ ITmodule -> cont 18#;+	L _ ITnewtype -> cont 19#;+	L _ ITof -> cont 20#;+	L _ ITqualified -> cont 21#;+	L _ ITthen -> cont 22#;+	L _ ITtype -> cont 23#;+	L _ ITwhere -> cont 24#;+	L _ (ITforall _) -> cont 25#;+	L _ ITforeign -> cont 26#;+	L _ ITexport -> cont 27#;+	L _ ITlabel -> cont 28#;+	L _ ITdynamic -> cont 29#;+	L _ ITsafe -> cont 30#;+	L _ ITinterruptible -> cont 31#;+	L _ ITunsafe -> cont 32#;+	L _ ITfamily -> cont 33#;+	L _ ITrole -> cont 34#;+	L _ ITstdcallconv -> cont 35#;+	L _ ITccallconv -> cont 36#;+	L _ ITcapiconv -> cont 37#;+	L _ ITprimcallconv -> cont 38#;+	L _ ITjavascriptcallconv -> cont 39#;+	L _ ITproc -> cont 40#;+	L _ ITrec -> cont 41#;+	L _ ITgroup -> cont 42#;+	L _ ITby -> cont 43#;+	L _ ITusing -> cont 44#;+	L _ ITpattern -> cont 45#;+	L _ ITstatic -> cont 46#;+	L _ ITstock -> cont 47#;+	L _ ITanyclass -> cont 48#;+	L _ ITvia -> cont 49#;+	L _ ITunit -> cont 50#;+	L _ ITsignature -> cont 51#;+	L _ ITdependency -> cont 52#;+	L _ (ITinline_prag _ _ _) -> cont 53#;+	L _ (ITopaque_prag _) -> cont 54#;+	L _ (ITspec_prag _) -> cont 55#;+	L _ (ITspec_inline_prag _ _) -> cont 56#;+	L _ (ITsource_prag _) -> cont 57#;+	L _ (ITrules_prag _) -> cont 58#;+	L _ (ITscc_prag _) -> cont 59#;+	L _ (ITdeprecated_prag _) -> cont 60#;+	L _ (ITwarning_prag _) -> cont 61#;+	L _ (ITunpack_prag _) -> cont 62#;+	L _ (ITnounpack_prag _) -> cont 63#;+	L _ (ITann_prag _) -> cont 64#;+	L _ (ITminimal_prag _) -> cont 65#;+	L _ (ITctype _) -> cont 66#;+	L _ (IToverlapping_prag _) -> cont 67#;+	L _ (IToverlappable_prag _) -> cont 68#;+	L _ (IToverlaps_prag _) -> cont 69#;+	L _ (ITincoherent_prag _) -> cont 70#;+	L _ (ITcomplete_prag _) -> cont 71#;+	L _ ITclose_prag -> cont 72#;+	L _ ITdotdot -> cont 73#;+	L _ ITcolon -> cont 74#;+	L _ (ITdcolon _) -> cont 75#;+	L _ ITequal -> cont 76#;+	L _ ITlam -> cont 77#;+	L _ ITlcase -> cont 78#;+	L _ ITlcases -> cont 79#;+	L _ ITvbar -> cont 80#;+	L _ (ITlarrow _) -> cont 81#;+	L _ (ITrarrow _) -> cont 82#;+	L _ ITlolly -> cont 83#;+	L _ ITat -> cont 84#;+	L _ (ITdarrow _) -> cont 85#;+	L _ ITminus -> cont 86#;+	L _ ITtilde -> cont 87#;+	L _ ITbang -> cont 88#;+	L _ ITprefixminus -> cont 89#;+	L _ (ITstar _) -> cont 90#;+	L _ (ITlarrowtail _) -> cont 91#;+	L _ (ITrarrowtail _) -> cont 92#;+	L _ (ITLarrowtail _) -> cont 93#;+	L _ (ITRarrowtail _) -> cont 94#;+	L _ ITdot -> cont 95#;+	L _ (ITproj True) -> cont 96#;+	L _ (ITproj False) -> cont 97#;+	L _ ITtypeApp -> cont 98#;+	L _ ITpercent -> cont 99#;+	L _ ITocurly -> cont 100#;+	L _ ITccurly -> cont 101#;+	L _ ITvocurly -> cont 102#;+	L _ ITvccurly -> cont 103#;+	L _ ITobrack -> cont 104#;+	L _ ITcbrack -> cont 105#;+	L _ IToparen -> cont 106#;+	L _ ITcparen -> cont 107#;+	L _ IToubxparen -> cont 108#;+	L _ ITcubxparen -> cont 109#;+	L _ (IToparenbar _) -> cont 110#;+	L _ (ITcparenbar _) -> cont 111#;+	L _ ITsemi -> cont 112#;+	L _ ITcomma -> cont 113#;+	L _ ITbackquote -> cont 114#;+	L _ ITsimpleQuote -> cont 115#;+	L _ (ITvarid    _) -> cont 116#;+	L _ (ITconid    _) -> cont 117#;+	L _ (ITvarsym   _) -> cont 118#;+	L _ (ITconsym   _) -> cont 119#;+	L _ (ITqvarid   _) -> cont 120#;+	L _ (ITqconid   _) -> cont 121#;+	L _ (ITqvarsym  _) -> cont 122#;+	L _ (ITqconsym  _) -> cont 123#;+	L _ (ITdo  _) -> cont 124#;+	L _ (ITmdo _) -> cont 125#;+	L _ (ITdupipvarid   _) -> cont 126#;+	L _ (ITlabelvarid   _) -> cont 127#;+	L _ (ITchar   _ _) -> cont 128#;+	L _ (ITstring _ _) -> cont 129#;+	L _ (ITinteger _) -> cont 130#;+	L _ (ITrational _) -> cont 131#;+	L _ (ITprimchar   _ _) -> cont 132#;+	L _ (ITprimstring _ _) -> cont 133#;+	L _ (ITprimint    _ _) -> cont 134#;+	L _ (ITprimword   _ _) -> cont 135#;+	L _ (ITprimfloat  _) -> cont 136#;+	L _ (ITprimdouble _) -> cont 137#;+	L _ (ITopenExpQuote _ _) -> cont 138#;+	L _ ITopenPatQuote -> cont 139#;+	L _ ITopenTypQuote -> cont 140#;+	L _ ITopenDecQuote -> cont 141#;+	L _ (ITcloseQuote _) -> cont 142#;+	L _ (ITopenTExpQuote _) -> cont 143#;+	L _ ITcloseTExpQuote -> cont 144#;+	L _ ITdollar -> cont 145#;+	L _ ITdollardollar -> cont 146#;+	L _ ITtyQuote -> cont 147#;+	L _ (ITquasiQuote _) -> cont 148#;+	L _ (ITqQuasiQuote _) -> cont 149#;+	_ -> happyError' (tk, [])+	})++happyError_ explist 150# tk = happyError' (tk, explist)+happyError_ explist _ tk = happyError' (tk, explist)++happyThen :: () => P a -> (a -> P b) -> P b+happyThen = (>>=)+happyReturn :: () => a -> P a+happyReturn = (return)+happyParse :: () => Happy_GHC_Exts.Int# -> P (HappyAbsSyn )++happyNewToken :: () => Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )++happyDoAction :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )++happyReduceArr :: () => Happy_Data_Array.Array Prelude.Int (Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ))++happyThen1 :: () => P a -> (a -> P b) -> P b+happyThen1 = happyThen+happyReturn1 :: () => a -> P a+happyReturn1 = happyReturn+happyError' :: () => (((Located Token)), [Prelude.String]) -> P a+happyError' tk = (\(tokens, explist) -> happyError) tk+parseModuleNoHaddock = happySomeParser where+ happySomeParser = happyThen (happyParse 0#) (\x -> happyReturn (let {(HappyWrap35 x') = happyOut35 x} in x'))++parseSignature = happySomeParser where+ happySomeParser = happyThen (happyParse 1#) (\x -> happyReturn (let {(HappyWrap34 x') = happyOut34 x} in x'))++parseImport = happySomeParser where+ happySomeParser = happyThen (happyParse 2#) (\x -> happyReturn (let {(HappyWrap62 x') = happyOut62 x} in x'))++parseStatement = happySomeParser where+ happySomeParser = happyThen (happyParse 3#) (\x -> happyReturn (let {(HappyWrap249 x') = happyOut249 x} in x'))++parseDeclaration = happySomeParser where+ happySomeParser = happyThen (happyParse 4#) (\x -> happyReturn (let {(HappyWrap78 x') = happyOut78 x} in x'))++parseExpression = happySomeParser where+ happySomeParser = happyThen (happyParse 5#) (\x -> happyReturn (let {(HappyWrap206 x') = happyOut206 x} in x'))++parsePattern = happySomeParser where+ happySomeParser = happyThen (happyParse 6#) (\x -> happyReturn (let {(HappyWrap241 x') = happyOut241 x} in x'))++parseTypeSignature = happySomeParser where+ happySomeParser = happyThen (happyParse 7#) (\x -> happyReturn (let {(HappyWrap202 x') = happyOut202 x} in x'))++parseStmt = happySomeParser where+ happySomeParser = happyThen (happyParse 8#) (\x -> happyReturn (let {(HappyWrap248 x') = happyOut248 x} in x'))++parseIdentifier = happySomeParser where+ happySomeParser = happyThen (happyParse 9#) (\x -> happyReturn (let {(HappyWrap16 x') = happyOut16 x} in x'))++parseType = happySomeParser where+ happySomeParser = happyThen (happyParse 10#) (\x -> happyReturn (let {(HappyWrap158 x') = happyOut158 x} in x'))++parseBackpack = happySomeParser where+ happySomeParser = happyThen (happyParse 11#) (\x -> happyReturn (let {(HappyWrap17 x') = happyOut17 x} in x'))++parseHeader = happySomeParser where+ happySomeParser = happyThen (happyParse 12#) (\x -> happyReturn (let {(HappyWrap43 x') = happyOut43 x} in x'))++happySeq = happyDoSeq+++happyError :: P a+happyError = srcParseFail++getVARID        (L _ (ITvarid    x)) = x+getCONID        (L _ (ITconid    x)) = x+getVARSYM       (L _ (ITvarsym   x)) = x+getCONSYM       (L _ (ITconsym   x)) = x+getDO           (L _ (ITdo      x)) = x+getMDO          (L _ (ITmdo     x)) = x+getQVARID       (L _ (ITqvarid   x)) = x+getQCONID       (L _ (ITqconid   x)) = x+getQVARSYM      (L _ (ITqvarsym  x)) = x+getQCONSYM      (L _ (ITqconsym  x)) = x+getIPDUPVARID   (L _ (ITdupipvarid   x)) = x+getLABELVARID   (L _ (ITlabelvarid   x)) = x+getCHAR         (L _ (ITchar   _ x)) = x+getSTRING       (L _ (ITstring _ x)) = x+getINTEGER      (L _ (ITinteger x))  = x+getRATIONAL     (L _ (ITrational x)) = x+getPRIMCHAR     (L _ (ITprimchar _ x)) = x+getPRIMSTRING   (L _ (ITprimstring _ x)) = x+getPRIMINTEGER  (L _ (ITprimint  _ x)) = x+getPRIMWORD     (L _ (ITprimword _ x)) = x+getPRIMFLOAT    (L _ (ITprimfloat x)) = x+getPRIMDOUBLE   (L _ (ITprimdouble x)) = x+getINLINE       (L _ (ITinline_prag _ inl conl)) = (inl,conl)+getSPEC_INLINE  (L _ (ITspec_inline_prag src True))  = (Inline src,FunLike)+getSPEC_INLINE  (L _ (ITspec_inline_prag src False)) = (NoInline src,FunLike)+getCOMPLETE_PRAGs (L _ (ITcomplete_prag x)) = x+getVOCURLY      (L (RealSrcSpan l _) ITvocurly) = srcSpanStartCol l++getINTEGERs     (L _ (ITinteger (IL src _ _))) = src+getCHARs        (L _ (ITchar       src _)) = src+getSTRINGs      (L _ (ITstring     src _)) = src+getPRIMCHARs    (L _ (ITprimchar   src _)) = src+getPRIMSTRINGs  (L _ (ITprimstring src _)) = src+getPRIMINTEGERs (L _ (ITprimint    src _)) = src+getPRIMWORDs    (L _ (ITprimword   src _)) = src++-- See Note [Pragma source text] in "GHC.Types.Basic" for the following+getINLINE_PRAGs       (L _ (ITinline_prag       _ inl _)) = inlineSpecSource inl+getOPAQUE_PRAGs       (L _ (ITopaque_prag       src))     = src+getSPEC_PRAGs         (L _ (ITspec_prag         src))     = src+getSPEC_INLINE_PRAGs  (L _ (ITspec_inline_prag  src _))   = src+getSOURCE_PRAGs       (L _ (ITsource_prag       src)) = src+getRULES_PRAGs        (L _ (ITrules_prag        src)) = src+getWARNING_PRAGs      (L _ (ITwarning_prag      src)) = src+getDEPRECATED_PRAGs   (L _ (ITdeprecated_prag   src)) = src+getSCC_PRAGs          (L _ (ITscc_prag          src)) = src+getUNPACK_PRAGs       (L _ (ITunpack_prag       src)) = src+getNOUNPACK_PRAGs     (L _ (ITnounpack_prag     src)) = src+getANN_PRAGs          (L _ (ITann_prag          src)) = src+getMINIMAL_PRAGs      (L _ (ITminimal_prag      src)) = src+getOVERLAPPABLE_PRAGs (L _ (IToverlappable_prag src)) = src+getOVERLAPPING_PRAGs  (L _ (IToverlapping_prag  src)) = src+getOVERLAPS_PRAGs     (L _ (IToverlaps_prag     src)) = src+getINCOHERENT_PRAGs   (L _ (ITincoherent_prag   src)) = src+getCTYPEs             (L _ (ITctype             src)) = src++getStringLiteral l = StringLiteral (getSTRINGs l) (getSTRING l) Nothing++isUnicode :: Located Token -> Bool+isUnicode (L _ (ITforall         iu)) = iu == UnicodeSyntax+isUnicode (L _ (ITdarrow         iu)) = iu == UnicodeSyntax+isUnicode (L _ (ITdcolon         iu)) = iu == UnicodeSyntax+isUnicode (L _ (ITlarrow         iu)) = iu == UnicodeSyntax+isUnicode (L _ (ITrarrow         iu)) = iu == UnicodeSyntax+isUnicode (L _ (ITlarrowtail     iu)) = iu == UnicodeSyntax+isUnicode (L _ (ITrarrowtail     iu)) = iu == UnicodeSyntax+isUnicode (L _ (ITLarrowtail     iu)) = iu == UnicodeSyntax+isUnicode (L _ (ITRarrowtail     iu)) = iu == UnicodeSyntax+isUnicode (L _ (IToparenbar      iu)) = iu == UnicodeSyntax+isUnicode (L _ (ITcparenbar      iu)) = iu == UnicodeSyntax+isUnicode (L _ (ITopenExpQuote _ iu)) = iu == UnicodeSyntax+isUnicode (L _ (ITcloseQuote     iu)) = iu == UnicodeSyntax+isUnicode (L _ (ITstar           iu)) = iu == UnicodeSyntax+isUnicode (L _ ITlolly)               = True+isUnicode _                           = False++hasE :: Located Token -> Bool+hasE (L _ (ITopenExpQuote HasE _)) = True+hasE (L _ (ITopenTExpQuote HasE))  = True+hasE _                             = False++getSCC :: Located Token -> P FastString+getSCC lt = do let s = getSTRING lt+               -- We probably actually want to be more restrictive than this+               if ' ' `elem` unpackFS s+                   then addFatalError $ mkPlainErrorMsgEnvelope (getLoc lt) $ PsErrSpaceInSCC+                   else return s++stringLiteralToHsDocWst :: Located StringLiteral -> Located (WithHsDocIdentifiers StringLiteral GhcPs)+stringLiteralToHsDocWst  = lexStringLiteral parseIdentifier++-- Utilities for combining source spans+comb2 :: Located a -> Located b -> SrcSpan+comb2 a b = a `seq` b `seq` combineLocs a b++-- Utilities for combining source spans+comb2A :: Located a -> LocatedAn t b -> SrcSpan+comb2A a b = a `seq` b `seq` combineLocs a (reLoc b)++comb2N :: Located a -> LocatedN b -> SrcSpan+comb2N a b = a `seq` b `seq` combineLocs a (reLocN b)++comb2Al :: LocatedAn t a -> Located b -> SrcSpan+comb2Al a b = a `seq` b `seq` combineLocs (reLoc a) b++comb3 :: Located a -> Located b -> Located c -> SrcSpan+comb3 a b c = a `seq` b `seq` c `seq`+    combineSrcSpans (getLoc a) (combineSrcSpans (getLoc b) (getLoc c))++comb3A :: Located a -> Located b -> LocatedAn t c -> SrcSpan+comb3A a b c = a `seq` b `seq` c `seq`+    combineSrcSpans (getLoc a) (combineSrcSpans (getLoc b) (getLocA c))++comb3N :: Located a -> Located b -> LocatedN c -> SrcSpan+comb3N a b c = a `seq` b `seq` c `seq`+    combineSrcSpans (getLoc a) (combineSrcSpans (getLoc b) (getLocA c))++comb4 :: Located a -> Located b -> Located c -> Located d -> SrcSpan+comb4 a b c d = a `seq` b `seq` c `seq` d `seq`+    (combineSrcSpans (getLoc a) $ combineSrcSpans (getLoc b) $+                combineSrcSpans (getLoc c) (getLoc d))++comb5 :: Located a -> Located b -> Located c -> Located d -> Located e -> SrcSpan+comb5 a b c d e = a `seq` b `seq` c `seq` d `seq` e `seq`+    (combineSrcSpans (getLoc a) $ combineSrcSpans (getLoc b) $+       combineSrcSpans (getLoc c) $ combineSrcSpans (getLoc d) (getLoc e))++-- strict constructor version:+{-# INLINE sL #-}+sL :: l -> a -> GenLocated l a+sL loc a = loc `seq` a `seq` L loc a++-- See Note [Adding location info] for how these utility functions are used++-- replaced last 3 CPP macros in this file+{-# INLINE sL0 #-}+sL0 :: a -> Located a+sL0 = L noSrcSpan       -- #define L0   L noSrcSpan++{-# INLINE sL1 #-}+sL1 :: GenLocated l a -> b -> GenLocated l b+sL1 x = sL (getLoc x)   -- #define sL1   sL (getLoc $1)++{-# INLINE sL1A #-}+sL1A :: LocatedAn t a -> b -> Located b+sL1A x = sL (getLocA x)   -- #define sL1   sL (getLoc $1)++{-# INLINE sL1N #-}+sL1N :: LocatedN a -> b -> Located b+sL1N x = sL (getLocA x)   -- #define sL1   sL (getLoc $1)++{-# INLINE sL1a #-}+sL1a :: Located a -> b -> LocatedAn t b+sL1a x = sL (noAnnSrcSpan $ getLoc x)   -- #define sL1   sL (getLoc $1)++{-# INLINE sL1l #-}+sL1l :: LocatedAn t a -> b -> LocatedAn u b+sL1l x = sL (l2l $ getLoc x)   -- #define sL1   sL (getLoc $1)++{-# INLINE sL1n #-}+sL1n :: Located a -> b -> LocatedN b+sL1n x = L (noAnnSrcSpan $ getLoc x)   -- #define sL1   sL (getLoc $1)++{-# INLINE sLL #-}+sLL :: Located a -> Located b -> c -> Located c+sLL x y = sL (comb2 x y) -- #define LL   sL (comb2 $1 $>)++{-# INLINE sLLa #-}+sLLa :: Located a -> Located b -> c -> LocatedAn t c+sLLa x y = sL (noAnnSrcSpan $ comb2 x y) -- #define LL   sL (comb2 $1 $>)++{-# INLINE sLLlA #-}+sLLlA :: Located a -> LocatedAn t b -> c -> Located c+sLLlA x y = sL (comb2A x y) -- #define LL   sL (comb2 $1 $>)++{-# INLINE sLLAl #-}+sLLAl :: LocatedAn t a -> Located b -> c -> Located c+sLLAl x y = sL (comb2A y x) -- #define LL   sL (comb2 $1 $>)++{-# INLINE sLLAsl #-}+sLLAsl :: [LocatedAn t a] -> Located b -> c -> Located c+sLLAsl [] = sL1+sLLAsl (x:_) = sLLAl x++{-# INLINE sLLAA #-}+sLLAA :: LocatedAn t a -> LocatedAn u b -> c -> Located c+sLLAA x y = sL (comb2 (reLoc y) (reLoc x)) -- #define LL   sL (comb2 $1 $>)+++{- Note [Adding location info]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~++This is done using the three functions below, sL0, sL1+and sLL.  Note that these functions were mechanically+converted from the three macros that used to exist before,+namely L0, L1 and LL.++They each add a SrcSpan to their argument.++   sL0  adds 'noSrcSpan', used for empty productions+     -- This doesn't seem to work anymore -=chak++   sL1  for a production with a single token on the lhs.  Grabs the SrcSpan+        from that token.++   sLL  for a production with >1 token on the lhs.  Makes up a SrcSpan from+        the first and last tokens.++These suffice for the majority of cases.  However, we must be+especially careful with empty productions: sLL won't work if the first+or last token on the lhs can represent an empty span.  In these cases,+we have to calculate the span using more of the tokens from the lhs, eg.++        | 'newtype' tycl_hdr '=' newconstr deriving+                { L (comb3 $1 $4 $5)+                    (mkTyData NewType (unLoc $2) $4 (unLoc $5)) }++We provide comb3 and comb4 functions which are useful in such cases.++Be careful: there's no checking that you actually got this right, the+only symptom will be that the SrcSpans of your syntax will be+incorrect.++-}++-- Make a source location for the file.  We're a bit lazy here and just+-- make a point SrcSpan at line 1, column 0.  Strictly speaking we should+-- try to find the span of the whole file (ToDo).+fileSrcSpan :: P SrcSpan+fileSrcSpan = do+  l <- getRealSrcLoc;+  let loc = mkSrcLoc (srcLocFile l) 1 1;+  return (mkSrcSpan loc loc)++-- Hint about linear types+hintLinear :: MonadP m => SrcSpan -> m ()+hintLinear span = do+  linearEnabled <- getBit LinearTypesBit+  unless linearEnabled $ addError $ mkPlainErrorMsgEnvelope span $ PsErrLinearFunction++-- Does this look like (a %m)?+looksLikeMult :: LHsType GhcPs -> LocatedN RdrName -> LHsType GhcPs -> Bool+looksLikeMult ty1 l_op ty2+  | Unqual op_name <- unLoc l_op+  , occNameFS op_name == fsLit "%"+  , Strict.Just ty1_pos <- getBufSpan (getLocA ty1)+  , Strict.Just pct_pos <- getBufSpan (getLocA l_op)+  , Strict.Just ty2_pos <- getBufSpan (getLocA ty2)+  , bufSpanEnd ty1_pos /= bufSpanStart pct_pos+  , bufSpanEnd pct_pos == bufSpanStart ty2_pos+  = True+  | otherwise = False++-- Hint about the MultiWayIf extension+hintMultiWayIf :: SrcSpan -> P ()+hintMultiWayIf span = do+  mwiEnabled <- getBit MultiWayIfBit+  unless mwiEnabled $ addError $ mkPlainErrorMsgEnvelope span PsErrMultiWayIf++-- Hint about explicit-forall+hintExplicitForall :: Located Token -> P ()+hintExplicitForall tok = do+    forall   <- getBit ExplicitForallBit+    rulePrag <- getBit InRulePragBit+    unless (forall || rulePrag) $ addError $ mkPlainErrorMsgEnvelope (getLoc tok) $+      (PsErrExplicitForall (isUnicode tok))++-- Hint about qualified-do+hintQualifiedDo :: Located Token -> P ()+hintQualifiedDo tok = do+    qualifiedDo   <- getBit QualifiedDoBit+    case maybeQDoDoc of+      Just qdoDoc | not qualifiedDo ->+        addError $ mkPlainErrorMsgEnvelope (getLoc tok) $+          (PsErrIllegalQualifiedDo qdoDoc)+      _ -> return ()+  where+    maybeQDoDoc = case unLoc tok of+      ITdo (Just m) -> Just $ ftext m <> text ".do"+      ITmdo (Just m) -> Just $ ftext m <> text ".mdo"+      t -> Nothing++-- When two single quotes don't followed by tyvar or gtycon, we report the+-- error as empty character literal, or TH quote that missing proper type+-- variable or constructor. See #13450.+reportEmptyDoubleQuotes :: SrcSpan -> P a+reportEmptyDoubleQuotes span = do+    thQuotes <- getBit ThQuotesBit+    addFatalError $ mkPlainErrorMsgEnvelope span $ PsErrEmptyDoubleQuotes thQuotes++{-+%************************************************************************+%*                                                                      *+        Helper functions for generating annotations in the parser+%*                                                                      *+%************************************************************************++For the general principles of the following routines, see Note [exact print annotations]+in GHC.Parser.Annotation++-}++-- |Construct an AddEpAnn from the annotation keyword and the location+-- of the keyword itself+mj :: AnnKeywordId -> Located e -> AddEpAnn+mj a l = AddEpAnn a (EpaSpan $ rs $ gl l)++mjN :: AnnKeywordId -> LocatedN e -> AddEpAnn+mjN a l = AddEpAnn a (EpaSpan $ rs $ glN l)++-- |Construct an AddEpAnn from the annotation keyword and the location+-- of the keyword itself, provided the span is not zero width+mz :: AnnKeywordId -> Located e -> [AddEpAnn]+mz a l = if isZeroWidthSpan (gl l) then [] else [AddEpAnn a (EpaSpan $ rs $ gl l)]++msemi :: Located e -> [TrailingAnn]+msemi l = if isZeroWidthSpan (gl l) then [] else [AddSemiAnn (EpaSpan $ rs $ gl l)]++msemim :: Located e -> Maybe EpaLocation+msemim l = if isZeroWidthSpan (gl l) then Nothing else Just (EpaSpan $ rs $ gl l)++-- |Construct an AddEpAnn from the annotation keyword and the Located Token. If+-- the token has a unicode equivalent and this has been used, provide the+-- unicode variant of the annotation.+mu :: AnnKeywordId -> Located Token -> AddEpAnn+mu a lt@(L l t) = AddEpAnn (toUnicodeAnn a lt) (EpaSpan $ rs l)++-- | If the 'Token' is using its unicode variant return the unicode variant of+--   the annotation+toUnicodeAnn :: AnnKeywordId -> Located Token -> AnnKeywordId+toUnicodeAnn a t = if isUnicode t then unicodeAnn a else a++toUnicode :: Located Token -> IsUnicodeSyntax+toUnicode t = if isUnicode t then UnicodeSyntax else NormalSyntax++gl :: GenLocated l a -> l+gl = getLoc++glA :: LocatedAn t a -> SrcSpan+glA = getLocA++glN :: LocatedN a -> SrcSpan+glN = getLocA++glR :: Located a -> Anchor+glR la = Anchor (realSrcSpan $ getLoc la) UnchangedAnchor++glAA :: Located a -> EpaLocation+glAA = EpaSpan <$> realSrcSpan . getLoc++glRR :: Located a -> RealSrcSpan+glRR = realSrcSpan . getLoc++glAR :: LocatedAn t a -> Anchor+glAR la = Anchor (realSrcSpan $ getLocA la) UnchangedAnchor++glNR :: LocatedN a -> Anchor+glNR ln = Anchor (realSrcSpan $ getLocA ln) UnchangedAnchor++glNRR :: LocatedN a -> EpaLocation+glNRR = EpaSpan <$> realSrcSpan . getLocA++anc :: RealSrcSpan -> Anchor+anc r = Anchor r UnchangedAnchor++acs :: MonadP m => (EpAnnComments -> Located a) -> m (Located a)+acs a = do+  let (L l _) = a emptyComments+  cs <- getCommentsFor l+  return (a cs)++-- Called at the very end to pick up the EOF position, as well as any comments not allocated yet.+acsFinal :: (EpAnnComments -> Located a) -> P (Located a)+acsFinal a = do+  let (L l _) = a emptyComments+  cs <- getCommentsFor l+  csf <- getFinalCommentsFor l+  meof <- getEofPos+  let ce = case meof of+             Strict.Nothing  -> EpaComments []+             Strict.Just (pos `Strict.And` gap) ->+               EpaCommentsBalanced [] [L (realSpanAsAnchor pos) (EpaComment EpaEofComment gap)]+  return (a (cs Semi.<> csf Semi.<> ce))++acsa :: MonadP m => (EpAnnComments -> LocatedAn t a) -> m (LocatedAn t a)+acsa a = do+  let (L l _) = a emptyComments+  cs <- getCommentsFor (locA l)+  return (a cs)++acsA :: MonadP m => (EpAnnComments -> Located a) -> m (LocatedAn t a)+acsA a = reLocA <$> acs a++acsExpr :: (EpAnnComments -> LHsExpr GhcPs) -> P ECP+acsExpr a = do { expr :: (LHsExpr GhcPs) <- runPV $ acsa a+               ; return (ecpFromExp $ expr) }++amsA :: MonadP m => LocatedA a -> [TrailingAnn] -> m (LocatedA a)+amsA (L l a) bs = do+  cs <- getCommentsFor (locA l)+  return (L (addAnnsA l bs cs) a)++amsAl :: MonadP m => LocatedA a -> SrcSpan -> [TrailingAnn] -> m (LocatedA a)+amsAl (L l a) loc bs = do+  cs <- getCommentsFor loc+  return (L (addAnnsA l bs cs) a)++amsrc :: MonadP m => Located a -> AnnContext -> m (LocatedC a)+amsrc a@(L l _) bs = do+  cs <- getCommentsFor l+  return (reAnnC bs cs a)++amsrl :: MonadP m => Located a -> AnnList -> m (LocatedL a)+amsrl a@(L l _) bs = do+  cs <- getCommentsFor l+  return (reAnnL bs cs a)++amsrp :: MonadP m => Located a -> AnnPragma -> m (LocatedP a)+amsrp a@(L l _) bs = do+  cs <- getCommentsFor l+  return (reAnnL bs cs a)++amsrn :: MonadP m => Located a -> NameAnn -> m (LocatedN a)+amsrn (L l a) an = do+  cs <- getCommentsFor l+  let ann = (EpAnn (spanAsAnchor l) an cs)+  return (L (SrcSpanAnn ann l) a)++-- |Synonyms for AddEpAnn versions of AnnOpen and AnnClose+mo,mc :: Located Token -> AddEpAnn+mo ll = mj AnnOpen ll+mc ll = mj AnnClose ll++moc,mcc :: Located Token -> AddEpAnn+moc ll = mj AnnOpenC ll+mcc ll = mj AnnCloseC ll++mop,mcp :: Located Token -> AddEpAnn+mop ll = mj AnnOpenP ll+mcp ll = mj AnnCloseP ll++moh,mch :: Located Token -> AddEpAnn+moh ll = mj AnnOpenPH ll+mch ll = mj AnnClosePH ll++mos,mcs :: Located Token -> AddEpAnn+mos ll = mj AnnOpenS ll+mcs ll = mj AnnCloseS ll++pvA :: MonadP m => m (Located a) -> m (LocatedAn t a)+pvA a = do { av <- a+           ; return (reLocA av) }++pvN :: MonadP m => m (Located a) -> m (LocatedN a)+pvN a = do { (L l av) <- a+           ; return (L (noAnnSrcSpan l) av) }++pvL :: MonadP m => m (LocatedAn t a) -> m (Located a)+pvL a = do { av <- a+           ; return (reLoc av) }++-- | Parse a Haskell module with Haddock comments.+-- This is done in two steps:+--+-- * 'parseModuleNoHaddock' to build the AST+-- * 'addHaddockToModule' to insert Haddock comments into it+--+-- This is the only parser entry point that deals with Haddock comments.+-- The other entry points ('parseDeclaration', 'parseExpression', etc) do+-- not insert them into the AST.+parseModule :: P (Located HsModule)+parseModule = parseModuleNoHaddock >>= addHaddockToModule++commentsA :: (Monoid ann) => SrcSpan -> EpAnnComments -> SrcSpanAnn' (EpAnn ann)+commentsA loc cs = SrcSpanAnn (EpAnn (Anchor (rs loc) UnchangedAnchor) mempty cs) loc++-- | Instead of getting the *enclosed* comments, this includes the+-- *preceding* ones.  It is used at the top level to get comments+-- between top level declarations.+commentsPA :: (Monoid ann) => LocatedAn ann a -> P (LocatedAn ann a)+commentsPA la@(L l a) = do+  cs <- getPriorCommentsFor (getLocA la)+  return (L (addCommentsToSrcAnn l cs) a)++rs :: SrcSpan -> RealSrcSpan+rs (RealSrcSpan l _) = l+rs _ = panic "Parser should only have RealSrcSpan"++hsDoAnn :: Located a -> LocatedAn t b -> AnnKeywordId -> AnnList+hsDoAnn (L l _) (L ll _) kw+  = AnnList (Just $ spanAsAnchor (locA ll)) Nothing Nothing [AddEpAnn kw (EpaSpan $ rs l)] []++listAsAnchor :: [LocatedAn t a] -> Anchor+listAsAnchor [] = spanAsAnchor noSrcSpan+listAsAnchor (L l _:_) = spanAsAnchor (locA l)++hsTok :: Located Token -> LHsToken tok GhcPs+hsTok (L l _) = L (mkTokenLocation l) HsTok++hsUniTok :: Located Token -> LHsUniToken tok utok GhcPs+hsUniTok t@(L l _) =+  L (mkTokenLocation l)+    (if isUnicode t then HsUnicodeTok else HsNormalTok)++-- -------------------------------------++addTrailingCommaFBind :: MonadP m => Fbind b -> SrcSpan -> m (Fbind b)+addTrailingCommaFBind (Left b)  l = fmap Left  (addTrailingCommaA b l)+addTrailingCommaFBind (Right b) l = fmap Right (addTrailingCommaA b l)++addTrailingVbarA :: MonadP m => LocatedA a -> SrcSpan -> m (LocatedA a)+addTrailingVbarA  la span = addTrailingAnnA la span AddVbarAnn++addTrailingSemiA :: MonadP m => LocatedA a -> SrcSpan -> m (LocatedA a)+addTrailingSemiA  la span = addTrailingAnnA la span AddSemiAnn++addTrailingCommaA :: MonadP m => LocatedA a -> SrcSpan -> m (LocatedA a)+addTrailingCommaA  la span = addTrailingAnnA la span AddCommaAnn++addTrailingAnnA :: MonadP m => LocatedA a -> SrcSpan -> (EpaLocation -> TrailingAnn) -> m (LocatedA a)+addTrailingAnnA (L (SrcSpanAnn anns l) a) ss ta = do+  -- cs <- getCommentsFor l+  let cs = emptyComments+  -- AZ:TODO: generalise updating comments into an annotation+  let+    anns' = if isZeroWidthSpan ss+              then anns+              else addTrailingAnnToA l (ta (EpaSpan $ rs ss)) cs anns+  return (L (SrcSpanAnn anns' l) a)++-- -------------------------------------++addTrailingVbarL :: MonadP m => LocatedL a -> SrcSpan -> m (LocatedL a)+addTrailingVbarL  la span = addTrailingAnnL la (AddVbarAnn (EpaSpan $ rs span))++addTrailingCommaL :: MonadP m => LocatedL a -> SrcSpan -> m (LocatedL a)+addTrailingCommaL  la span = addTrailingAnnL la (AddCommaAnn (EpaSpan $ rs span))++addTrailingAnnL :: MonadP m => LocatedL a -> TrailingAnn -> m (LocatedL a)+addTrailingAnnL (L (SrcSpanAnn anns l) a) ta = do+  cs <- getCommentsFor l+  let anns' = addTrailingAnnToL l ta cs anns+  return (L (SrcSpanAnn anns' l) a)++-- -------------------------------------++-- Mostly use to add AnnComma, special case it to NOP if adding a zero-width annotation+addTrailingCommaN :: MonadP m => LocatedN a -> SrcSpan -> m (LocatedN a)+addTrailingCommaN (L (SrcSpanAnn anns l) a) span = do+  -- cs <- getCommentsFor l+  let cs = emptyComments+  -- AZ:TODO: generalise updating comments into an annotation+  let anns' = if isZeroWidthSpan span+                then anns+                else addTrailingCommaToN l anns (EpaSpan $ rs span)+  return (L (SrcSpanAnn anns' l) a)++addTrailingCommaS :: Located StringLiteral -> EpaLocation -> Located StringLiteral+addTrailingCommaS (L l sl) span = L l (sl { sl_tc = Just (epaLocationRealSrcSpan span) })++-- -------------------------------------++addTrailingDarrowC :: LocatedC a -> Located Token -> EpAnnComments -> LocatedC a+addTrailingDarrowC (L (SrcSpanAnn EpAnnNotUsed l) a) lt cs =+  let+    u = if (isUnicode lt) then UnicodeSyntax else NormalSyntax+  in L (SrcSpanAnn (EpAnn (spanAsAnchor l) (AnnContext (Just (u,glAA lt)) [] []) cs) l) a+addTrailingDarrowC (L (SrcSpanAnn (EpAnn lr (AnnContext _ o c) csc) l) a) lt cs =+  let+    u = if (isUnicode lt) then UnicodeSyntax else NormalSyntax+  in L (SrcSpanAnn (EpAnn lr (AnnContext (Just (u,glAA lt)) o c) (cs Semi.<> csc)) l) a++-- -------------------------------------++-- We need a location for the where binds, when computing the SrcSpan+-- for the AST element using them.  Where there is a span, we return+-- it, else noLoc, which is ignored in the comb2 call.+adaptWhereBinds :: Maybe (Located (HsLocalBinds GhcPs, Maybe EpAnnComments))+                ->        Located (HsLocalBinds GhcPs,       EpAnnComments)+adaptWhereBinds Nothing = noLoc (EmptyLocalBinds noExtField, emptyComments)+adaptWhereBinds (Just (L l (b, mc))) = L l (b, maybe emptyComments id mc)+{-# 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/Parser.hs-boot view
@@ -0,0 +1,7 @@+module GHC.Parser where++import GHC.Types.Name.Reader (RdrName)+import GHC.Parser.Lexer (P)+import GHC.Parser.Annotation (LocatedN)++parseIdentifier :: P (LocatedN RdrName)
− GHC/Parser.y 
@@ -1,4441 +0,0 @@---                                                              -*-haskell-*---- ------------------------------------------------------------------------------ (c) The University of Glasgow 1997-2003------- The GHC grammar.------ Author(s): Simon Marlow, Sven Panne 1997, 1998, 1999--- -----------------------------------------------------------------------------{-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE ScopedTypeVariables #-}---- | This module provides the generated Happy parser for Haskell. It exports--- a number of parsers which may be used in any library that uses the GHC API.--- A common usage pattern is to initialize the parser state with a given string--- and then parse that string:------ @---     runParser :: ParserOpts -> String -> P a -> ParseResult a---     runParser opts str parser = unP parser parseState---     where---       filename = "\<interactive\>"---       location = mkRealSrcLoc (mkFastString filename) 1 1---       buffer = stringToStringBuffer str---       parseState = initParserState opts buffer location--- @-module GHC.Parser-   ( parseModule, parseSignature, parseImport, parseStatement, parseBackpack-   , parseDeclaration, parseExpression, parsePattern-   , parseTypeSignature-   , parseStmt, parseIdentifier-   , parseType, parseHeader-   , parseModuleNoHaddock-   )-where---- base-import Control.Monad    ( unless, liftM, when, (<=<) )-import GHC.Exts-import Data.Maybe       ( maybeToList )-import Data.List.NonEmpty ( NonEmpty((:|)) )-import qualified Data.List.NonEmpty as NE-import qualified Prelude -- for happy-generated code--import GHC.Prelude--import GHC.Hs--import GHC.Driver.Backpack.Syntax--import GHC.Unit.Info-import GHC.Unit.Module-import GHC.Unit.Module.Warnings--import GHC.Data.OrdList-import GHC.Data.BooleanFormula ( BooleanFormula(..), LBooleanFormula, mkTrue )-import GHC.Data.FastString-import GHC.Data.Maybe          ( orElse )--import GHC.Utils.Outputable-import GHC.Utils.Misc          ( looksLikePackageName, fstOf3, sndOf3, thdOf3 )-import GHC.Utils.Panic-import GHC.Prelude--import GHC.Types.Name.Reader-import GHC.Types.Name.Occurrence ( varName, dataName, tcClsName, tvName, occNameFS, mkVarOcc, occNameString)-import GHC.Types.SrcLoc-import GHC.Types.Basic-import GHC.Types.Fixity-import GHC.Types.ForeignCall-import GHC.Types.SourceFile-import GHC.Types.SourceText--import GHC.Core.Type    ( unrestrictedFunTyCon, Specificity(..) )-import GHC.Core.Class   ( FunDep )-import GHC.Core.DataCon ( DataCon, dataConName )--import GHC.Parser.PostProcess-import GHC.Parser.PostProcess.Haddock-import GHC.Parser.Lexer-import GHC.Parser.Annotation-import GHC.Parser.Errors--import GHC.Builtin.Types ( unitTyCon, unitDataCon, tupleTyCon, tupleDataCon, nilDataCon,-                           unboxedUnitTyCon, unboxedUnitDataCon,-                           listTyCon_RDR, consDataCon_RDR, eqTyCon_RDR)--import qualified Data.Semigroup as Semi-}--%expect 0 -- shift/reduce conflicts--{- Note [shift/reduce conflicts]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The 'happy' tool turns this grammar into an efficient parser that follows the-shift-reduce parsing model. There's a parse stack that contains items parsed so-far (both terminals and non-terminals). Every next token produced by the lexer-results in one of two actions:--  SHIFT:    push the token onto the parse stack--  REDUCE:   pop a few items off the parse stack and combine them-            with a function (reduction rule)--However, sometimes it's unclear which of the two actions to take.-Consider this code example:--    if x then y else f z--There are two ways to parse it:--    (if x then y else f) z-    if x then y else (f z)--How is this determined? At some point, the parser gets to the following state:--  parse stack:  'if' exp 'then' exp 'else' "f"-  next token:   "z"--Scenario A (simplified):--  1. REDUCE, parse stack: 'if' exp 'then' exp 'else' exp-             next token:  "z"-        (Note that "f" reduced to exp here)--  2. REDUCE, parse stack: exp-             next token:  "z"--  3. SHIFT,  parse stack: exp "z"-             next token:  ...--  4. REDUCE, parse stack: exp-             next token:  ...--  This way we get:  (if x then y else f) z--Scenario B (simplified):--  1. SHIFT,  parse stack: 'if' exp 'then' exp 'else' "f" "z"-             next token:  ...--  2. REDUCE, parse stack: 'if' exp 'then' exp 'else' exp-             next token:  ...--  3. REDUCE, parse stack: exp-             next token:  ...--  This way we get:  if x then y else (f z)--The end result is determined by the chosen action. When Happy detects this, it-reports a shift/reduce conflict. At the top of the file, we have the following-directive:--  %expect 0--It means that we expect no unresolved shift/reduce conflicts in this grammar.-If you modify the grammar and get shift/reduce conflicts, follow the steps-below to resolve them.--STEP ONE-  is to figure out what causes the conflict.-  That's where the -i flag comes in handy:--      happy -agc --strict compiler/GHC/Parser.y -idetailed-info--  By analysing the output of this command, in a new file `detailed-info`, you-  can figure out which reduction rule causes the issue. At the top of the-  generated report, you will see a line like this:--      state 147 contains 67 shift/reduce conflicts.--  Scroll down to section State 147 (in your case it could be a different-  state). The start of the section lists the reduction rules that can fire-  and shows their context:--        exp10 -> fexp .                 (rule 492)-        fexp -> fexp . aexp             (rule 498)-        fexp -> fexp . PREFIX_AT atype  (rule 499)--  And then, for every token, it tells you the parsing action:--        ']'            reduce using rule 492-        '::'           reduce using rule 492-        '('            shift, and enter state 178-        QVARID         shift, and enter state 44-        DO             shift, and enter state 182-        ...--  But if you look closer, some of these tokens also have another parsing action-  in parentheses:--        QVARID    shift, and enter state 44-                   (reduce using rule 492)--  That's how you know rule 492 is causing trouble.-  Scroll back to the top to see what this rule is:--        -----------------------------------        Grammar-        -----------------------------------        ...-        ...-        exp10 -> fexp                (492)-        optSemi -> ';'               (493)-        ...-        ...--  Hence the shift/reduce conflict is caused by this parser production:--        exp10 :: { ECP }-                : '-' fexp    { ... }-                | fexp        { ... }    -- problematic rule--STEP TWO-  is to mark the problematic rule with the %shift pragma. This signals to-  'happy' that any shift/reduce conflicts involving this rule must be resolved-  in favor of a shift. There's currently no dedicated pragma to resolve in-  favor of the reduce.--STEP THREE-  is to add a dedicated Note for this specific conflict, as is done for all-  other conflicts below.--}--{- Note [%shift: rule_activation -> {- empty -}]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Context:-    rule -> STRING . rule_activation rule_foralls infixexp '=' exp--Example:-    {-# RULES "name" [0] f = rhs #-}--Ambiguity:-    If we reduced, then we'd get an empty activation rule, and [0] would be-    parsed as part of the left-hand side expression.--    We shift, so [0] is parsed as an activation rule.--}--{- Note [%shift: rule_foralls -> 'forall' rule_vars '.']-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Context:-    rule_foralls -> 'forall' rule_vars '.' . 'forall' rule_vars '.'-    rule_foralls -> 'forall' rule_vars '.' .--Example:-    {-# RULES "name" forall a1. forall a2. lhs = rhs #-}--Ambiguity:-    Same as in Note [%shift: rule_foralls -> {- empty -}]-    but for the second 'forall'.--}--{- Note [%shift: rule_foralls -> {- empty -}]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Context:-    rule -> STRING rule_activation . rule_foralls infixexp '=' exp--Example:-    {-# RULES "name" forall a1. lhs = rhs #-}--Ambiguity:-    If we reduced, then we would get an empty rule_foralls; the 'forall', being-    a valid term-level identifier, would be parsed as part of the left-hand-    side expression.--    We shift, so the 'forall' is parsed as part of rule_foralls.--}--{- Note [%shift: type -> btype]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Context:-    context -> btype .-    type -> btype .-    type -> btype . '->' ctype-    type -> btype . '->.' ctype--Example:-    a :: Maybe Integer -> Bool--Ambiguity:-    If we reduced, we would get:   (a :: Maybe Integer) -> Bool-    We shift to get this instead:  a :: (Maybe Integer -> Bool)--}--{- Note [%shift: infixtype -> ftype]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Context:-    infixtype -> ftype .-    infixtype -> ftype . tyop infixtype-    ftype -> ftype . tyarg-    ftype -> ftype . PREFIX_AT tyarg--Example:-    a :: Maybe Integer--Ambiguity:-    If we reduced, we would get:    (a :: Maybe) Integer-    We shift to get this instead:   a :: (Maybe Integer)--}--{- Note [%shift: atype -> tyvar]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Context:-    atype -> tyvar .-    tv_bndr_no_braces -> '(' tyvar . '::' kind ')'--Example:-    class C a where type D a = (a :: Type ...--Ambiguity:-    If we reduced, we could specify a default for an associated type like this:--      class C a where type D a-                      type D a = (a :: Type)--    But we shift in order to allow injectivity signatures like this:--      class C a where type D a = (r :: Type) | r -> a--}--{- Note [%shift: exp -> infixexp]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Context:-    exp -> infixexp . '::' sigtype-    exp -> infixexp . '-<' exp-    exp -> infixexp . '>-' exp-    exp -> infixexp . '-<<' exp-    exp -> infixexp . '>>-' exp-    exp -> infixexp .-    infixexp -> infixexp . qop exp10p--Examples:-    1) if x then y else z -< e-    2) if x then y else z :: T-    3) if x then y else z + 1   -- (NB: '+' is in VARSYM)--Ambiguity:-    If we reduced, we would get:--      1) (if x then y else z) -< e-      2) (if x then y else z) :: T-      3) (if x then y else z) + 1--    We shift to get this instead:--      1) if x then y else (z -< e)-      2) if x then y else (z :: T)-      3) if x then y else (z + 1)--}--{- Note [%shift: exp10 -> '-' fexp]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Context:-    exp10 -> '-' fexp .-    fexp -> fexp . aexp-    fexp -> fexp . PREFIX_AT atype--Examples & Ambiguity:-    Same as in Note [%shift: exp10 -> fexp],-    but with a '-' in front.--}--{- Note [%shift: exp10 -> fexp]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Context:-    exp10 -> fexp .-    fexp -> fexp . aexp-    fexp -> fexp . PREFIX_AT atype--Examples:-    1) if x then y else f z-    2) if x then y else f @z--Ambiguity:-    If we reduced, we would get:--      1) (if x then y else f) z-      2) (if x then y else f) @z--    We shift to get this instead:--      1) if x then y else (f z)-      2) if x then y else (f @z)--}--{- Note [%shift: aexp2 -> ipvar]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Context:-    aexp2 -> ipvar .-    dbind -> ipvar . '=' exp--Example:-    let ?x = ...--Ambiguity:-    If we reduced, ?x would be parsed as the LHS of a normal binding,-    eventually producing an error.--    We shift, so it is parsed as the LHS of an implicit binding.--}--{- Note [%shift: aexp2 -> TH_TY_QUOTE]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Context:-    aexp2 -> TH_TY_QUOTE . tyvar-    aexp2 -> TH_TY_QUOTE . gtycon-    aexp2 -> TH_TY_QUOTE .--Examples:-    1) x = ''-    2) x = ''a-    3) x = ''T--Ambiguity:-    If we reduced, the '' would result in reportEmptyDoubleQuotes even when-    followed by a type variable or a type constructor. But the only reason-    this reduction rule exists is to improve error messages.--    Naturally, we shift instead, so that ''a and ''T work as expected.--}--{- Note [%shift: tup_tail -> {- empty -}]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Context:-    tup_exprs -> commas . tup_tail-    sysdcon_nolist -> '(' commas . ')'-    sysdcon_nolist -> '(#' commas . '#)'-    commas -> commas . ','--Example:-    (,,)--Ambiguity:-    A tuple section with no components is indistinguishable from the Haskell98-    data constructor for a tuple.--    If we reduced, (,,) would be parsed as a tuple section.-    We shift, so (,,) is parsed as a data constructor.--    This is preferable because we want to accept (,,) without -XTupleSections.-    See also Note [ExplicitTuple] in GHC.Hs.Expr.--}--{- Note [%shift: qtyconop -> qtyconsym]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Context:-    oqtycon -> '(' qtyconsym . ')'-    qtyconop -> qtyconsym .--Example:-    foo :: (:%)--Ambiguity:-    If we reduced, (:%) would be parsed as a parenthehsized infix type-    expression without arguments, resulting in the 'failOpFewArgs' error.--    We shift, so it is parsed as a type constructor.--}--{- Note [%shift: special_id -> 'group']-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Context:-    transformqual -> 'then' 'group' . 'using' exp-    transformqual -> 'then' 'group' . 'by' exp 'using' exp-    special_id -> 'group' .--Example:-    [ ... | then group by dept using groupWith-          , then take 5 ]--Ambiguity:-    If we reduced, 'group' would be parsed as a term-level identifier, just as-    'take' in the other clause.--    We shift, so it is parsed as part of the 'group by' clause introduced by-    the -XTransformListComp extension.--}--{- Note [%shift: activation -> {- empty -}]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Context:-    sigdecl -> '{-# INLINE' . activation qvarcon '#-}'-    activation -> {- empty -}-    activation -> explicit_activation--Example:--    {-# INLINE [0] Something #-}--Ambiguity:-    We don't know whether the '[' is the start of the activation or the beginning-    of the [] data constructor.-    We parse this as having '[0]' activation for inlining 'Something', rather than-    empty activation and inlining '[0] Something'.--}--{- Note [Parser API Annotations]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-A lot of the productions are now cluttered with calls to-aa,am,acs,acsA etc.--These are helper functions to make sure that the locations of the-various keywords such as do / let / in are captured for use by tools-that want to do source to source conversions, such as refactorers or-structured editors.--The helper functions are defined at the bottom of this file.--See-  https://gitlab.haskell.org/ghc/ghc/wikis/api-annotations and-  https://gitlab.haskell.org/ghc/ghc/wikis/ghc-ast-annotations-for some background.---}--{- Note [Parsing lists]-~~~~~~~~~~~~~~~~~~~~~~~-You might be wondering why we spend so much effort encoding our lists this-way:--importdecls-        : importdecls ';' importdecl-        | importdecls ';'-        | importdecl-        | {- empty -}--This might seem like an awfully roundabout way to declare a list; plus, to add-insult to injury you have to reverse the results at the end.  The answer is that-left recursion prevents us from running out of stack space when parsing long-sequences.  See: https://www.haskell.org/happy/doc/html/sec-sequences.html for-more guidance.--By adding/removing branches, you can affect what lists are accepted.  Here-are the most common patterns, rewritten as regular expressions for clarity:--    -- Equivalent to: ';'* (x ';'+)* x?  (can be empty, permits leading/trailing semis)-    xs : xs ';' x-       | xs ';'-       | x-       | {- empty -}--    -- Equivalent to x (';' x)* ';'*  (non-empty, permits trailing semis)-    xs : xs ';' x-       | xs ';'-       | x--    -- Equivalent to ';'* alts (';' alts)* ';'* (non-empty, permits leading/trailing semis)-    alts : alts1-         | ';' alts-    alts1 : alts1 ';' alt-          | alts1 ';'-          | alt--    -- Equivalent to x (',' x)+ (non-empty, no trailing semis)-    xs : x-       | x ',' xs--}--%token- '_'            { L _ ITunderscore }            -- Haskell keywords- 'as'           { L _ ITas }- 'case'         { L _ ITcase }- 'class'        { L _ ITclass }- 'data'         { L _ ITdata }- 'default'      { L _ ITdefault }- 'deriving'     { L _ ITderiving }- 'else'         { L _ ITelse }- 'hiding'       { L _ IThiding }- 'if'           { L _ ITif }- 'import'       { L _ ITimport }- 'in'           { L _ ITin }- 'infix'        { L _ ITinfix }- 'infixl'       { L _ ITinfixl }- 'infixr'       { L _ ITinfixr }- 'instance'     { L _ ITinstance }- 'let'          { L _ ITlet }- 'module'       { L _ ITmodule }- 'newtype'      { L _ ITnewtype }- 'of'           { L _ ITof }- 'qualified'    { L _ ITqualified }- 'then'         { L _ ITthen }- 'type'         { L _ ITtype }- 'where'        { L _ ITwhere }-- 'forall'       { L _ (ITforall _) }                -- GHC extension keywords- 'foreign'      { L _ ITforeign }- 'export'       { L _ ITexport }- 'label'        { L _ ITlabel }- 'dynamic'      { L _ ITdynamic }- 'safe'         { L _ ITsafe }- 'interruptible' { L _ ITinterruptible }- 'unsafe'       { L _ ITunsafe }- 'family'       { L _ ITfamily }- 'role'         { L _ ITrole }- 'stdcall'      { L _ ITstdcallconv }- 'ccall'        { L _ ITccallconv }- 'capi'         { L _ ITcapiconv }- 'prim'         { L _ ITprimcallconv }- 'javascript'   { L _ ITjavascriptcallconv }- 'proc'         { L _ ITproc }          -- for arrow notation extension- 'rec'          { L _ ITrec }           -- for arrow notation extension- 'group'    { L _ ITgroup }     -- for list transform extension- 'by'       { L _ ITby }        -- for list transform extension- 'using'    { L _ ITusing }     -- for list transform extension- 'pattern'      { L _ ITpattern } -- for pattern synonyms- 'static'       { L _ ITstatic }  -- for static pointers extension- 'stock'        { L _ ITstock }    -- for DerivingStrategies extension- 'anyclass'     { L _ ITanyclass } -- for DerivingStrategies extension- 'via'          { L _ ITvia }      -- for DerivingStrategies extension-- 'unit'         { L _ ITunit }- 'signature'    { L _ ITsignature }- 'dependency'   { L _ ITdependency }-- '{-# INLINE'             { L _ (ITinline_prag _ _ _) } -- INLINE or INLINABLE- '{-# SPECIALISE'         { L _ (ITspec_prag _) }- '{-# SPECIALISE_INLINE'  { L _ (ITspec_inline_prag _ _) }- '{-# SOURCE'             { L _ (ITsource_prag _) }- '{-# RULES'              { L _ (ITrules_prag _) }- '{-# SCC'                { L _ (ITscc_prag _)}- '{-# DEPRECATED'         { L _ (ITdeprecated_prag _) }- '{-# WARNING'            { L _ (ITwarning_prag _) }- '{-# UNPACK'             { L _ (ITunpack_prag _) }- '{-# NOUNPACK'           { L _ (ITnounpack_prag _) }- '{-# ANN'                { L _ (ITann_prag _) }- '{-# MINIMAL'            { L _ (ITminimal_prag _) }- '{-# CTYPE'              { L _ (ITctype _) }- '{-# OVERLAPPING'        { L _ (IToverlapping_prag _) }- '{-# OVERLAPPABLE'       { L _ (IToverlappable_prag _) }- '{-# OVERLAPS'           { L _ (IToverlaps_prag _) }- '{-# INCOHERENT'         { L _ (ITincoherent_prag _) }- '{-# COMPLETE'           { L _ (ITcomplete_prag _)   }- '#-}'                    { L _ ITclose_prag }-- '..'           { L _ ITdotdot }                        -- reserved symbols- ':'            { L _ ITcolon }- '::'           { L _ (ITdcolon _) }- '='            { L _ ITequal }- '\\'           { L _ ITlam }- 'lcase'        { L _ ITlcase }- '|'            { L _ ITvbar }- '<-'           { L _ (ITlarrow _) }- '->'           { L _ (ITrarrow _) }- '->.'          { L _ ITlolly }- TIGHT_INFIX_AT { L _ ITat }- '=>'           { L _ (ITdarrow _) }- '-'            { L _ ITminus }- PREFIX_TILDE   { L _ ITtilde }- PREFIX_BANG    { L _ ITbang }- PREFIX_MINUS   { L _ ITprefixminus }- '*'            { L _ (ITstar _) }- '-<'           { L _ (ITlarrowtail _) }            -- for arrow notation- '>-'           { L _ (ITrarrowtail _) }            -- for arrow notation- '-<<'          { L _ (ITLarrowtail _) }            -- for arrow notation- '>>-'          { L _ (ITRarrowtail _) }            -- for arrow notation- '.'            { L _ ITdot }- PREFIX_PROJ    { L _ (ITproj True) }               -- RecordDotSyntax- TIGHT_INFIX_PROJ { L _ (ITproj False) }            -- RecordDotSyntax- PREFIX_AT      { L _ ITtypeApp }- PREFIX_PERCENT { L _ ITpercent }                   -- for linear types-- '{'            { L _ ITocurly }                        -- special symbols- '}'            { L _ ITccurly }- vocurly        { L _ ITvocurly } -- virtual open curly (from layout)- vccurly        { L _ ITvccurly } -- virtual close curly (from layout)- '['            { L _ ITobrack }- ']'            { L _ ITcbrack }- '('            { L _ IToparen }- ')'            { L _ ITcparen }- '(#'           { L _ IToubxparen }- '#)'           { L _ ITcubxparen }- '(|'           { L _ (IToparenbar _) }- '|)'           { L _ (ITcparenbar _) }- ';'            { L _ ITsemi }- ','            { L _ ITcomma }- '`'            { L _ ITbackquote }- SIMPLEQUOTE    { L _ ITsimpleQuote      }     -- 'x-- VARID          { L _ (ITvarid    _) }          -- identifiers- CONID          { L _ (ITconid    _) }- VARSYM         { L _ (ITvarsym   _) }- CONSYM         { L _ (ITconsym   _) }- QVARID         { L _ (ITqvarid   _) }- QCONID         { L _ (ITqconid   _) }- QVARSYM        { L _ (ITqvarsym  _) }- QCONSYM        { L _ (ITqconsym  _) }--- -- QualifiedDo- DO             { L _ (ITdo  _) }- MDO            { L _ (ITmdo _) }-- IPDUPVARID     { L _ (ITdupipvarid   _) }              -- GHC extension- LABELVARID     { L _ (ITlabelvarid   _) }-- CHAR           { L _ (ITchar   _ _) }- STRING         { L _ (ITstring _ _) }- INTEGER        { L _ (ITinteger _) }- RATIONAL       { L _ (ITrational _) }-- PRIMCHAR       { L _ (ITprimchar   _ _) }- PRIMSTRING     { L _ (ITprimstring _ _) }- PRIMINTEGER    { L _ (ITprimint    _ _) }- PRIMWORD       { L _ (ITprimword   _ _) }- PRIMFLOAT      { L _ (ITprimfloat  _) }- PRIMDOUBLE     { L _ (ITprimdouble _) }---- Template Haskell-'[|'            { L _ (ITopenExpQuote _ _) }-'[p|'           { L _ ITopenPatQuote  }-'[t|'           { L _ ITopenTypQuote  }-'[d|'           { L _ ITopenDecQuote  }-'|]'            { L _ (ITcloseQuote _) }-'[||'           { L _ (ITopenTExpQuote _) }-'||]'           { L _ ITcloseTExpQuote  }-PREFIX_DOLLAR   { L _ ITdollar }-PREFIX_DOLLAR_DOLLAR { L _ ITdollardollar }-TH_TY_QUOTE     { L _ ITtyQuote       }      -- ''T-TH_QUASIQUOTE   { L _ (ITquasiQuote _) }-TH_QQUASIQUOTE  { L _ (ITqQuasiQuote _) }--%monad { P } { >>= } { return }-%lexer { (lexer True) } { L _ ITeof }-  -- Replace 'lexer' above with 'lexerDbg'-  -- to dump the tokens fed to the parser.-%tokentype { (Located Token) }---- Exported parsers-%name parseModuleNoHaddock module-%name parseSignature signature-%name parseImport importdecl-%name parseStatement e_stmt-%name parseDeclaration topdecl-%name parseExpression exp-%name parsePattern pat-%name parseTypeSignature sigdecl-%name parseStmt   maybe_stmt-%name parseIdentifier  identifier-%name parseType ktype-%name parseBackpack backpack-%partial parseHeader header-%%---------------------------------------------------------------------------------- Identifiers; one of the entry points-identifier :: { LocatedN RdrName }-        : qvar                          { $1 }-        | qcon                          { $1 }-        | qvarop                        { $1 }-        | qconop                        { $1 }-    | '(' '->' ')'      {% amsrn (sLL $1 $> $ getRdrName unrestrictedFunTyCon)-                                 (NameAnn NameParens (glAA $1) (glAA $2) (glAA $3) []) }-    | '->'              {% amsrn (sLL $1 $> $ getRdrName unrestrictedFunTyCon)-                                 (NameAnnRArrow (glAA $1) []) }---------------------------------------------------------------------------------- Backpack stuff--backpack :: { [LHsUnit PackageName] }-         : implicit_top units close { fromOL $2 }-         | '{' units '}'            { fromOL $2 }--units :: { OrdList (LHsUnit PackageName) }-         : units ';' unit { $1 `appOL` unitOL $3 }-         | units ';'      { $1 }-         | unit           { unitOL $1 }--unit :: { LHsUnit PackageName }-        : 'unit' pkgname 'where' unitbody-            { sL1 $1 $ HsUnit { hsunitName = $2-                              , hsunitBody = fromOL $4 } }--unitid :: { LHsUnitId PackageName }-        : pkgname                  { sL1 $1 $ HsUnitId $1 [] }-        | pkgname '[' msubsts ']'  { sLL $1 $> $ HsUnitId $1 (fromOL $3) }--msubsts :: { OrdList (LHsModuleSubst PackageName) }-        : msubsts ',' msubst { $1 `appOL` unitOL $3 }-        | msubsts ','        { $1 }-        | msubst             { unitOL $1 }--msubst :: { LHsModuleSubst PackageName }-        : modid '=' moduleid { sLL (reLoc $1) $> $ (reLoc $1, $3) }-        | modid VARSYM modid VARSYM { sLL (reLoc $1) $> $ (reLoc $1, sLL $2 $> $ HsModuleVar (reLoc $3)) }--moduleid :: { LHsModuleId PackageName }-          : VARSYM modid VARSYM { sLL $1 $> $ HsModuleVar (reLoc $2) }-          | unitid ':' modid    { sLL $1 (reLoc $>) $ HsModuleId $1 (reLoc $3) }--pkgname :: { Located PackageName }-        : STRING     { sL1 $1 $ PackageName (getSTRING $1) }-        | litpkgname { sL1 $1 $ PackageName (unLoc $1) }--litpkgname_segment :: { Located FastString }-        : VARID  { sL1 $1 $ getVARID $1 }-        | CONID  { sL1 $1 $ getCONID $1 }-        | special_id { $1 }---- Parse a minus sign regardless of whether -XLexicalNegation is turned on or off.--- See Note [Minus tokens] in GHC.Parser.Lexer-HYPHEN :: { [AddEpAnn] }-      : '-'          { [mj AnnMinus $1 ] }-      | PREFIX_MINUS { [mj AnnMinus $1 ] }-      | VARSYM  {% if (getVARSYM $1 == fsLit "-")-                   then return [mj AnnMinus $1]-                   else do { addError $ PsError PsErrExpectedHyphen [] (getLoc $1)-                           ; return [] } }---litpkgname :: { Located FastString }-        : litpkgname_segment { $1 }-        -- a bit of a hack, means p - b is parsed same as p-b, enough for now.-        | litpkgname_segment HYPHEN litpkgname  { sLL $1 $> $ appendFS (unLoc $1) (consFS '-' (unLoc $3)) }--mayberns :: { Maybe [LRenaming] }-        : {- empty -} { Nothing }-        | '(' rns ')' { Just (fromOL $2) }--rns :: { OrdList LRenaming }-        : rns ',' rn { $1 `appOL` unitOL $3 }-        | rns ','    { $1 }-        | rn         { unitOL $1 }--rn :: { LRenaming }-        : modid 'as' modid { sLL (reLoc $1) (reLoc $>) $ Renaming (reLoc $1) (Just (reLoc $3)) }-        | modid            { sL1 (reLoc $1)            $ Renaming (reLoc $1) Nothing }--unitbody :: { OrdList (LHsUnitDecl PackageName) }-        : '{'     unitdecls '}'   { $2 }-        | vocurly unitdecls close { $2 }--unitdecls :: { OrdList (LHsUnitDecl PackageName) }-        : unitdecls ';' unitdecl { $1 `appOL` unitOL $3 }-        | unitdecls ';'         { $1 }-        | unitdecl              { unitOL $1 }--unitdecl :: { LHsUnitDecl PackageName }-        : 'module' maybe_src modid maybemodwarning maybeexports 'where' body-             -- XXX not accurate-             { sL1 $1 $ DeclD-                 (case snd $2 of-                   NotBoot -> HsSrcFile-                   IsBoot  -> HsBootFile)-                 (reLoc $3)-                 (Just $ sL1 $1 (HsModule noAnn (thdOf3 $7) (Just $3) $5 (fst $ sndOf3 $7) (snd $ sndOf3 $7) $4 Nothing)) }-        | 'signature' modid maybemodwarning maybeexports 'where' body-             { sL1 $1 $ DeclD-                 HsigFile-                 (reLoc $2)-                 (Just $ sL1 $1 (HsModule noAnn (thdOf3 $6) (Just $2) $4 (fst $ sndOf3 $6) (snd $ sndOf3 $6) $3 Nothing)) }-        | 'module' maybe_src modid-             { sL1 $1 $ DeclD (case snd $2 of-                   NotBoot -> HsSrcFile-                   IsBoot  -> HsBootFile) (reLoc $3) Nothing }-        | 'signature' modid-             { sL1 $1 $ DeclD HsigFile (reLoc $2) Nothing }-        | 'dependency' unitid mayberns-             { sL1 $1 $ IncludeD (IncludeDecl { idUnitId = $2-                                              , idModRenaming = $3-                                              , idSignatureInclude = False }) }-        | 'dependency' 'signature' unitid-             { sL1 $1 $ IncludeD (IncludeDecl { idUnitId = $3-                                              , idModRenaming = Nothing-                                              , idSignatureInclude = True }) }---------------------------------------------------------------------------------- Module Header---- The place for module deprecation is really too restrictive, but if it--- was allowed at its natural place just before 'module', we get an ugly--- s/r conflict with the second alternative. Another solution would be the--- introduction of a new pragma DEPRECATED_MODULE, but this is not very nice,--- either, and DEPRECATED is only expected to be used by people who really--- know what they are doing. :-)--signature :: { Located HsModule }-       : 'signature' modid maybemodwarning maybeexports 'where' body-             {% fileSrcSpan >>= \ loc ->-                acs (\cs-> (L loc (HsModule (EpAnn (spanAsAnchor loc) (AnnsModule [mj AnnSignature $1, mj AnnWhere $5] (fstOf3 $6)) cs)-                              (thdOf3 $6) (Just $2) $4 (fst $ sndOf3 $6)-                              (snd $ sndOf3 $6) $3 Nothing))-                    ) }--module :: { Located HsModule }-       : 'module' modid maybemodwarning maybeexports 'where' body-             {% fileSrcSpan >>= \ loc ->-                acsFinal (\cs -> (L loc (HsModule (EpAnn (spanAsAnchor loc) (AnnsModule [mj AnnModule $1, mj AnnWhere $5] (fstOf3 $6)) cs)-                               (thdOf3 $6) (Just $2) $4 (fst $ sndOf3 $6)-                              (snd $ sndOf3 $6) $3 Nothing)-                    )) }-        | body2-                {% fileSrcSpan >>= \ loc ->-                   acsFinal (\cs -> (L loc (HsModule (EpAnn (spanAsAnchor loc) (AnnsModule [] (fstOf3 $1)) cs)-                                (thdOf3 $1) Nothing Nothing-                               (fst $ sndOf3 $1) (snd $ sndOf3 $1) Nothing Nothing))) }--missing_module_keyword :: { () }-        : {- empty -}                           {% pushModuleContext }--implicit_top :: { () }-        : {- empty -}                           {% pushModuleContext }--maybemodwarning :: { Maybe (LocatedP WarningTxt) }-    : '{-# DEPRECATED' strings '#-}'-                      {% fmap Just $ amsrp (sLL $1 $> $ DeprecatedTxt (sL1 $1 $ getDEPRECATED_PRAGs $1) (snd $ unLoc $2))-                              (AnnPragma (mo $1) (mc $3) (fst $ unLoc $2)) }-    | '{-# WARNING' strings '#-}'-                         {% fmap Just $ amsrp (sLL $1 $> $ WarningTxt (sL1 $1 $ getWARNING_PRAGs $1) (snd $ unLoc $2))-                                 (AnnPragma (mo $1) (mc $3) (fst $ unLoc $2))}-    |  {- empty -}                  { Nothing }--body    :: { (AnnList-             ,([LImportDecl GhcPs], [LHsDecl GhcPs])-             ,LayoutInfo) }-        :  '{'            top '}'      { (AnnList Nothing (Just $ moc $1) (Just $ mcc $3) [] (fst $2)-                                         , snd $2, ExplicitBraces) }-        |      vocurly    top close    { (AnnList Nothing Nothing Nothing [] (fst $2)-                                         , snd $2, VirtualBraces (getVOCURLY $1)) }--body2   :: { (AnnList-             ,([LImportDecl GhcPs], [LHsDecl GhcPs])-             ,LayoutInfo) }-        :  '{' top '}'                          { (AnnList Nothing (Just $ moc $1) (Just $ mcc $3) [] (fst $2)-                                                  , snd $2, ExplicitBraces) }-        |  missing_module_keyword top close     { (AnnList Nothing Nothing Nothing [] [], snd $2, VirtualBraces leftmostColumn) }---top     :: { ([TrailingAnn]-             ,([LImportDecl GhcPs], [LHsDecl GhcPs])) }-        : semis top1                            { (reverse $1, $2) }--top1    :: { ([LImportDecl GhcPs], [LHsDecl GhcPs]) }-        : importdecls_semi topdecls_cs_semi        { (reverse $1, cvTopDecls $2) }-        | importdecls_semi topdecls_cs             { (reverse $1, cvTopDecls $2) }-        | importdecls                              { (reverse $1, []) }---------------------------------------------------------------------------------- Module declaration & imports only--header  :: { Located HsModule }-        : 'module' modid maybemodwarning maybeexports 'where' header_body-                {% fileSrcSpan >>= \ loc ->-                   acs (\cs -> (L loc (HsModule (EpAnn (spanAsAnchor loc) (AnnsModule [mj AnnModule $1,mj AnnWhere $5] (AnnList Nothing Nothing Nothing [] [])) cs)-                              NoLayoutInfo (Just $2) $4 $6 [] $3 Nothing-                          ))) }-        | 'signature' modid maybemodwarning maybeexports 'where' header_body-                {% fileSrcSpan >>= \ loc ->-                   acs (\cs -> (L loc (HsModule (EpAnn (spanAsAnchor loc) (AnnsModule [mj AnnModule $1,mj AnnWhere $5] (AnnList Nothing Nothing Nothing [] [])) cs)-                           NoLayoutInfo (Just $2) $4 $6 [] $3 Nothing-                          ))) }-        | header_body2-                {% fileSrcSpan >>= \ loc ->-                   return (L loc (HsModule noAnn NoLayoutInfo Nothing Nothing $1 [] Nothing-                          Nothing)) }--header_body :: { [LImportDecl GhcPs] }-        :  '{'            header_top            { $2 }-        |      vocurly    header_top            { $2 }--header_body2 :: { [LImportDecl GhcPs] }-        :  '{' header_top                       { $2 }-        |  missing_module_keyword header_top    { $2 }--header_top :: { [LImportDecl GhcPs] }-        :  semis header_top_importdecls         { $2 }--header_top_importdecls :: { [LImportDecl GhcPs] }-        :  importdecls_semi                     { $1 }-        |  importdecls                          { $1 }---------------------------------------------------------------------------------- The Export List--maybeexports :: { (Maybe (LocatedL [LIE GhcPs])) }-        :  '(' exportlist ')'       {% fmap Just $ amsrl (sLL $1 $> (fromOL $ snd $2))-                                        (AnnList Nothing (Just $ mop $1) (Just $ mcp $3) (fst $2) []) }-        |  {- empty -}              { Nothing }--exportlist :: { ([AddEpAnn], OrdList (LIE GhcPs)) }-        : exportlist1     { ([], $1) }-        | {- empty -}     { ([], nilOL) }--        -- trailing comma:-        | exportlist1 ',' {% case $1 of-                               SnocOL hs t -> do-                                 t' <- addTrailingCommaA t (gl $2)-                                 return ([], snocOL hs t')}-        | ','             { ([mj AnnComma $1], nilOL) }--exportlist1 :: { OrdList (LIE GhcPs) }-        : exportlist1 ',' export-                          {% let ls = $1-                             in if isNilOL ls-                                  then return (ls `appOL` $3)-                                  else case ls of-                                         SnocOL hs t -> do-                                           t' <- addTrailingCommaA t (gl $2)-                                           return (snocOL hs t' `appOL` $3)}-        | export          { $1 }---   -- No longer allow things like [] and (,,,) to be exported-   -- They are built in syntax, always available-export  :: { OrdList (LIE GhcPs) }-        : qcname_ext export_subspec  {% mkModuleImpExp (fst $ unLoc $2) $1 (snd $ unLoc $2)-                                          >>= \ie -> fmap (unitOL . reLocA) (return (sLL (reLoc $1) $> ie)) }-        |  'module' modid            {% fmap (unitOL . reLocA) (acs (\cs -> sLL $1 (reLoc $>) (IEModuleContents (EpAnn (glR $1) [mj AnnModule $1] cs) $2))) }-        |  'pattern' qcon            { unitOL (reLocA (sLL $1 (reLocN $>)-                                              (IEVar noExtField (sLLa $1 (reLocN $>) (IEPattern (glAA $1) $2))))) }--export_subspec :: { Located ([AddEpAnn],ImpExpSubSpec) }-        : {- empty -}             { sL0 ([],ImpExpAbs) }-        | '(' qcnames ')'         {% mkImpExpSubSpec (reverse (snd $2))-                                      >>= \(as,ie) -> return $ sLL $1 $>-                                            (as ++ [mop $1,mcp $3] ++ fst $2, ie) }--qcnames :: { ([AddEpAnn], [LocatedA ImpExpQcSpec]) }-  : {- empty -}                   { ([],[]) }-  | qcnames1                      { $1 }--qcnames1 :: { ([AddEpAnn], [LocatedA ImpExpQcSpec]) }     -- A reversed list-        :  qcnames1 ',' qcname_ext_w_wildcard  {% case (snd $1) of-                                                    (l@(L la ImpExpQcWildcard):t) ->-                                                       do { l' <- addTrailingCommaA l (gl $2)-                                                          ; return ([mj AnnDotdot (reLoc l),-                                                                     mj AnnComma $2]-                                                                   ,(snd (unLoc $3)  : l' : t)) }-                                                    (l:t) ->-                                                       do { l' <- addTrailingCommaA l (gl $2)-                                                          ; return (fst $1 ++ fst (unLoc $3)-                                                                   , snd (unLoc $3) : l' : t)} }--        -- Annotations re-added in mkImpExpSubSpec-        |  qcname_ext_w_wildcard                   { (fst (unLoc $1),[snd (unLoc $1)]) }---- Variable, data constructor or wildcard--- or tagged type constructor-qcname_ext_w_wildcard :: { Located ([AddEpAnn], LocatedA ImpExpQcSpec) }-        :  qcname_ext               { sL1A $1 ([],$1) }-        |  '..'                     { sL1  $1 ([mj AnnDotdot $1], sL1a $1 ImpExpQcWildcard)  }--qcname_ext :: { LocatedA ImpExpQcSpec }-        :  qcname                   { reLocA $ sL1N $1 (ImpExpQcName $1) }-        |  'type' oqtycon           {% do { n <- mkTypeImpExp $2-                                          ; return $ sLLa $1 (reLocN $>) (ImpExpQcType (glAA $1) n) }}--qcname  :: { LocatedN RdrName }  -- Variable or type constructor-        :  qvar                 { $1 } -- Things which look like functions-                                       -- Note: This includes record selectors but-                                       -- also (-.->), see #11432-        |  oqtycon_no_varcon    { $1 } -- see Note [Type constructors in export list]---------------------------------------------------------------------------------- Import Declarations---- importdecls and topdecls must contain at least one declaration;--- top handles the fact that these may be optional.---- One or more semicolons-semis1  :: { Located [TrailingAnn] }-semis1  : semis1 ';'  { sLL $1 $> $ if isZeroWidthSpan (gl $2) then (unLoc $1) else (AddSemiAnn (glAA $2) : (unLoc $1)) }-        | ';'         { sL1 $1 $ msemi $1 }---- Zero or more semicolons-semis   :: { [TrailingAnn] }-semis   : semis ';'   { if isZeroWidthSpan (gl $2) then $1 else (AddSemiAnn (glAA $2) : $1) }-        | {- empty -} { [] }---- No trailing semicolons, non-empty-importdecls :: { [LImportDecl GhcPs] }-importdecls-        : importdecls_semi importdecl-                                { $2 : $1 }---- May have trailing semicolons, can be empty-importdecls_semi :: { [LImportDecl GhcPs] }-importdecls_semi-        : importdecls_semi importdecl semis1-                                {% do { i <- amsAl $2 (comb2 (reLoc $2) $3) (reverse $ unLoc $3)-                                      ; return (i : $1)} }-        | {- empty -}           { [] }--importdecl :: { LImportDecl GhcPs }-        : 'import' maybe_src maybe_safe optqualified maybe_pkg modid optqualified maybeas maybeimpspec-                {% do {-                  ; let { ; mPreQual = unLoc $4-                          ; mPostQual = unLoc $7 }-                  ; checkImportDecl mPreQual mPostQual-                  ; let anns-                         = EpAnnImportDecl-                             { importDeclAnnImport    = glAA $1-                             , importDeclAnnPragma    = fst $ fst $2-                             , importDeclAnnSafe      = fst $3-                             , importDeclAnnQualified = fst $ importDeclQualifiedStyle mPreQual mPostQual-                             , importDeclAnnPackage   = fst $5-                             , importDeclAnnAs        = fst $8-                             }-                  ; fmap reLocA $ acs (\cs -> L (comb5 $1 (reLoc $6) $7 (snd $8) $9) $-                      ImportDecl { ideclExt = EpAnn (glR $1) anns cs-                                  , ideclSourceSrc = snd $ fst $2-                                  , ideclName = $6, ideclPkgQual = snd $5-                                  , ideclSource = snd $2, ideclSafe = snd $3-                                  , ideclQualified = snd $ importDeclQualifiedStyle mPreQual mPostQual-                                  , ideclImplicit = False-                                  , ideclAs = unLoc (snd $8)-                                  , ideclHiding = unLoc $9 })-                  }-                }---maybe_src :: { ((Maybe (EpaLocation,EpaLocation),SourceText),IsBootInterface) }-        : '{-# SOURCE' '#-}'        { ((Just (glAA $1,glAA $2),getSOURCE_PRAGs $1)-                                      , IsBoot) }-        | {- empty -}               { ((Nothing,NoSourceText),NotBoot) }--maybe_safe :: { (Maybe EpaLocation,Bool) }-        : 'safe'                                { (Just (glAA $1),True) }-        | {- empty -}                           { (Nothing,      False) }--maybe_pkg :: { (Maybe EpaLocation,Maybe StringLiteral) }-        : STRING  {% do { let { pkgFS = getSTRING $1 }-                        ; unless (looksLikePackageName (unpackFS pkgFS)) $-                             addError $ PsError (PsErrInvalidPackageName pkgFS) [] (getLoc $1)-                        ; return (Just (glAA $1), Just (StringLiteral (getSTRINGs $1) pkgFS Nothing)) } }-        | {- empty -}                           { (Nothing,Nothing) }--optqualified :: { Located (Maybe EpaLocation) }-        : 'qualified'                           { sL1 $1 (Just (glAA $1)) }-        | {- empty -}                           { noLoc Nothing }--maybeas :: { (Maybe EpaLocation,Located (Maybe (LocatedA ModuleName))) }-        : 'as' modid                           { (Just (glAA $1)-                                                 ,sLL $1 (reLoc $>) (Just $2)) }-        | {- empty -}                          { (Nothing,noLoc Nothing) }--maybeimpspec :: { Located (Maybe (Bool, LocatedL [LIE GhcPs])) }-        : impspec                  {% let (b, ie) = unLoc $1 in-                                       checkImportSpec ie-                                        >>= \checkedIe ->-                                          return (L (gl $1) (Just (b, checkedIe)))  }-        | {- empty -}              { noLoc Nothing }--impspec :: { Located (Bool, LocatedL [LIE GhcPs]) }-        :  '(' exportlist ')'               {% do { es <- amsrl (sLL $1 $> $ fromOL $ snd $2)-                                                               (AnnList Nothing (Just $ mop $1) (Just $ mcp $3) (fst $2) [])-                                                  ; return $ sLL $1 $> (False, es)} }-        |  'hiding' '(' exportlist ')'      {% do { es <- amsrl (sLL $1 $> $ fromOL $ snd $3)-                                                               (AnnList Nothing (Just $ mop $2) (Just $ mcp $4) (mj AnnHiding $1:fst $3) [])-                                                  ; return $ sLL $1 $> (True, es)} }---------------------------------------------------------------------------------- Fixity Declarations--prec    :: { Maybe (Located (SourceText,Int)) }-        : {- empty -}           { Nothing }-        | INTEGER-                 { Just (sL1 $1 (getINTEGERs $1,fromInteger (il_value (getINTEGER $1)))) }--infix   :: { Located FixityDirection }-        : 'infix'                               { sL1 $1 InfixN  }-        | 'infixl'                              { sL1 $1 InfixL  }-        | 'infixr'                              { sL1 $1 InfixR }--ops     :: { Located (OrdList (LocatedN RdrName)) }-        : ops ',' op       {% case (unLoc $1) of-                                SnocOL hs t -> do-                                  t' <- addTrailingCommaN t (gl $2)-                                  return (sLL $1 (reLocN $>) (snocOL hs t' `appOL` unitOL $3)) }-        | op               { sL1N $1 (unitOL $1) }---------------------------------------------------------------------------------- Top-Level Declarations---- No trailing semicolons, non-empty-topdecls :: { OrdList (LHsDecl GhcPs) }-        : topdecls_semi topdecl        { $1 `snocOL` $2 }---- May have trailing semicolons, can be empty-topdecls_semi :: { OrdList (LHsDecl GhcPs) }-        : topdecls_semi topdecl semis1 {% do { t <- amsAl $2 (comb2 (reLoc $2) $3) (reverse $ unLoc $3)-                                             ; return ($1 `snocOL` t) }}-        | {- empty -}                  { nilOL }----------------------------------------------------------------------------------- Each topdecl accumulates prior comments--- No trailing semicolons, non-empty-topdecls_cs :: { OrdList (LHsDecl GhcPs) }-        : topdecls_cs_semi topdecl_cs        { $1 `snocOL` $2 }---- May have trailing semicolons, can be empty-topdecls_cs_semi :: { OrdList (LHsDecl GhcPs) }-        : topdecls_cs_semi topdecl_cs semis1 {% do { t <- amsAl $2 (comb2 (reLoc $2) $3) (reverse $ unLoc $3)-                                                   ; return ($1 `snocOL` t) }}-        | {- empty -}                  { nilOL }---- Each topdecl accumulates prior comments-topdecl_cs :: { LHsDecl GhcPs }-topdecl_cs : topdecl {% commentsPA $1 }--------------------------------------------------------------------------------topdecl :: { LHsDecl GhcPs }-        : cl_decl                               { sL1 $1 (TyClD noExtField (unLoc $1)) }-        | ty_decl                               { sL1 $1 (TyClD noExtField (unLoc $1)) }-        | standalone_kind_sig                   { sL1 $1 (KindSigD noExtField (unLoc $1)) }-        | inst_decl                             { sL1 $1 (InstD noExtField (unLoc $1)) }-        | stand_alone_deriving                  { sL1 $1 (DerivD noExtField (unLoc $1)) }-        | role_annot                            { sL1 $1 (RoleAnnotD noExtField (unLoc $1)) }-        | 'default' '(' comma_types0 ')'        {% acsA (\cs -> sLL $1 $>-                                                    (DefD noExtField (DefaultDecl (EpAnn (glR $1) [mj AnnDefault $1,mop $2,mcp $4] cs) $3))) }-        | 'foreign' fdecl                       {% acsA (\cs -> sLL $1 $> ((snd $ unLoc $2) (EpAnn (glR $1) (mj AnnForeign $1:(fst $ unLoc $2)) cs))) }-        | '{-# DEPRECATED' deprecations '#-}'   {% acsA (\cs -> sLL $1 $> $ WarningD noExtField (Warnings (EpAnn (glR $1) [mo $1,mc $3] cs) (getDEPRECATED_PRAGs $1) (fromOL $2))) }-        | '{-# WARNING' warnings '#-}'          {% acsA (\cs -> sLL $1 $> $ WarningD noExtField (Warnings (EpAnn (glR $1) [mo $1,mc $3] cs) (getWARNING_PRAGs $1) (fromOL $2))) }-        | '{-# RULES' rules '#-}'               {% acsA (\cs -> sLL $1 $> $ RuleD noExtField (HsRules (EpAnn (glR $1) [mo $1,mc $3] cs) (getRULES_PRAGs $1) (reverse $2))) }-        | annotation { $1 }-        | decl_no_th                            { $1 }--        -- Template Haskell Extension-        -- The $(..) form is one possible form of infixexp-        -- but we treat an arbitrary expression just as if-        -- it had a $(..) wrapped around it-        | infixexp                              {% runPV (unECP $1) >>= \ $1 ->-                                                    do { d <- mkSpliceDecl $1-                                                       ; commentsPA d }}---- Type classes----cl_decl :: { LTyClDecl GhcPs }-        : 'class' tycl_hdr fds where_cls-                {% (mkClassDecl (comb4 $1 $2 $3 $4) $2 $3 (sndOf3 $ unLoc $4) (thdOf3 $ unLoc $4))-                        (mj AnnClass $1:(fst $ unLoc $3)++(fstOf3 $ unLoc $4)) }---- Type declarations (toplevel)----ty_decl :: { LTyClDecl GhcPs }-           -- ordinary type synonyms-        : 'type' type '=' ktype-                -- Note ktype, not sigtype, on the right of '='-                -- We allow an explicit for-all but we don't insert one-                -- in   type Foo a = (b,b)-                -- Instead we just say b is out of scope-                ---                -- Note the use of type for the head; this allows-                -- infix type constructors to be declared-                {% mkTySynonym (comb2A $1 $4) $2 $4 [mj AnnType $1,mj AnnEqual $3] }--           -- type family declarations-        | 'type' 'family' type opt_tyfam_kind_sig opt_injective_info-                          where_type_family-                -- Note the use of type for the head; this allows-                -- infix type constructors to be declared-                {% mkFamDecl (comb5 $1 (reLoc $3) $4 $5 $6) (snd $ unLoc $6) TopLevel $3-                                   (snd $ unLoc $4) (snd $ unLoc $5)-                           (mj AnnType $1:mj AnnFamily $2:(fst $ unLoc $4)-                           ++ (fst $ unLoc $5) ++ (fst $ unLoc $6))  }--          -- ordinary data type or newtype declaration-        | data_or_newtype capi_ctype tycl_hdr constrs maybe_derivings-                {% mkTyData (comb4 $1 $3 $4 $5) (snd $ unLoc $1) $2 $3-                           Nothing (reverse (snd $ unLoc $4))-                                   (fmap reverse $5)-                           ((fst $ unLoc $1):(fst $ unLoc $4)) }-                                   -- We need the location on tycl_hdr in case-                                   -- constrs and deriving are both empty--          -- ordinary GADT declaration-        | data_or_newtype capi_ctype tycl_hdr opt_kind_sig-                 gadt_constrlist-                 maybe_derivings-            {% mkTyData (comb4 $1 $3 $5 $6) (snd $ unLoc $1) $2 $3-                            (snd $ unLoc $4) (snd $ unLoc $5)-                            (fmap reverse $6)-                            ((fst $ unLoc $1):(fst $ unLoc $4)++(fst $ unLoc $5)) }-                                   -- We need the location on tycl_hdr in case-                                   -- constrs and deriving are both empty--          -- data/newtype family-        | 'data' 'family' type opt_datafam_kind_sig-                {% mkFamDecl (comb3 $1 $2 $4) DataFamily TopLevel $3-                                   (snd $ unLoc $4) Nothing-                          (mj AnnData $1:mj AnnFamily $2:(fst $ unLoc $4)) }---- standalone kind signature-standalone_kind_sig :: { LStandaloneKindSig GhcPs }-  : 'type' sks_vars '::' sigktype-      {% mkStandaloneKindSig (comb2A $1 $4) (L (gl $2) $ unLoc $2) $4-               [mj AnnType $1,mu AnnDcolon $3]}---- See also: sig_vars-sks_vars :: { Located [LocatedN RdrName] }  -- Returned in reverse order-  : sks_vars ',' oqtycon-      {% case unLoc $1 of-           (h:t) -> do-             h' <- addTrailingCommaN h (gl $2)-             return (sLL $1 (reLocN $>) ($3 : h' : t)) }-  | oqtycon { sL1N $1 [$1] }--inst_decl :: { LInstDecl GhcPs }-        : 'instance' overlap_pragma inst_type where_inst-       {% do { (binds, sigs, _, ats, adts, _) <- cvBindsAndSigs (snd $ unLoc $4)-             ; let anns = (mj AnnInstance $1 : (fst $ unLoc $4))-             ; let cid cs = ClsInstDecl-                                     { cid_ext = (EpAnn (glR $1) anns cs, NoAnnSortKey)-                                     , cid_poly_ty = $3, cid_binds = binds-                                     , cid_sigs = mkClassOpSigs sigs-                                     , cid_tyfam_insts = ats-                                     , cid_overlap_mode = $2-                                     , cid_datafam_insts = adts }-             ; acsA (\cs -> L (comb3 $1 (reLoc $3) $4)-                             (ClsInstD { cid_d_ext = noExtField, cid_inst = cid cs }))-                   } }--           -- type instance declarations-        | 'type' 'instance' ty_fam_inst_eqn-                {% mkTyFamInst (comb2A $1 $3) (unLoc $3)-                        (mj AnnType $1:mj AnnInstance $2:[]) }--          -- data/newtype instance declaration-        | data_or_newtype 'instance' capi_ctype datafam_inst_hdr constrs-                          maybe_derivings-            {% mkDataFamInst (comb4 $1 $4 $5 $6) (snd $ unLoc $1) $3 (unLoc $4)-                                      Nothing (reverse (snd  $ unLoc $5))-                                              (fmap reverse $6)-                      ((fst $ unLoc $1):mj AnnInstance $2:(fst $ unLoc $5)) }--          -- GADT instance declaration-        | data_or_newtype 'instance' capi_ctype datafam_inst_hdr opt_kind_sig-                 gadt_constrlist-                 maybe_derivings-            {% mkDataFamInst (comb4 $1 $4 $6 $7) (snd $ unLoc $1) $3 (unLoc $4)-                                   (snd $ unLoc $5) (snd $ unLoc $6)-                                   (fmap reverse $7)-                     ((fst $ unLoc $1):mj AnnInstance $2-                       :(fst $ unLoc $5)++(fst $ unLoc $6)) }--overlap_pragma :: { Maybe (LocatedP OverlapMode) }-  : '{-# OVERLAPPABLE'    '#-}' {% fmap Just $ amsrp (sLL $1 $> (Overlappable (getOVERLAPPABLE_PRAGs $1)))-                                       (AnnPragma (mo $1) (mc $2) []) }-  | '{-# OVERLAPPING'     '#-}' {% fmap Just $ amsrp (sLL $1 $> (Overlapping (getOVERLAPPING_PRAGs $1)))-                                       (AnnPragma (mo $1) (mc $2) []) }-  | '{-# OVERLAPS'        '#-}' {% fmap Just $ amsrp (sLL $1 $> (Overlaps (getOVERLAPS_PRAGs $1)))-                                       (AnnPragma (mo $1) (mc $2) []) }-  | '{-# INCOHERENT'      '#-}' {% fmap Just $ amsrp (sLL $1 $> (Incoherent (getINCOHERENT_PRAGs $1)))-                                       (AnnPragma (mo $1) (mc $2) []) }-  | {- empty -}                 { Nothing }--deriv_strategy_no_via :: { LDerivStrategy GhcPs }-  : 'stock'                     {% acs (\cs -> sL1 $1 (StockStrategy (EpAnn (glR $1) [mj AnnStock $1] cs))) }-  | 'anyclass'                  {% acs (\cs -> sL1 $1 (AnyclassStrategy (EpAnn (glR $1) [mj AnnAnyclass $1] cs))) }-  | 'newtype'                   {% acs (\cs -> sL1 $1 (NewtypeStrategy (EpAnn (glR $1) [mj AnnNewtype $1] cs))) }--deriv_strategy_via :: { LDerivStrategy GhcPs }-  : 'via' sigktype          {% acs (\cs -> sLLlA $1 $> (ViaStrategy (XViaStrategyPs (EpAnn (glR $1) [mj AnnVia $1] cs)-                                                                           $2))) }--deriv_standalone_strategy :: { Maybe (LDerivStrategy GhcPs) }-  : 'stock'                     {% fmap Just $ acs (\cs -> sL1 $1 (StockStrategy (EpAnn (glR $1) [mj AnnStock $1] cs))) }-  | 'anyclass'                  {% fmap Just $ acs (\cs -> sL1 $1 (AnyclassStrategy (EpAnn (glR $1) [mj AnnAnyclass $1] cs))) }-  | 'newtype'                   {% fmap Just $ acs (\cs -> sL1 $1 (NewtypeStrategy (EpAnn (glR $1) [mj AnnNewtype $1] cs))) }-  | deriv_strategy_via          { Just $1 }-  | {- empty -}                 { Nothing }---- Injective type families--opt_injective_info :: { Located ([AddEpAnn], Maybe (LInjectivityAnn GhcPs)) }-        : {- empty -}               { noLoc ([], Nothing) }-        | '|' injectivity_cond      { sLL $1 $> ([mj AnnVbar $1]-                                                , Just ($2)) }--injectivity_cond :: { LInjectivityAnn GhcPs }-        : tyvarid '->' inj_varids-           {% acs (\cs -> sLL (reLocN $1) $> (InjectivityAnn (EpAnn (glNR $1) [mu AnnRarrow $2] cs) $1 (reverse (unLoc $3)))) }--inj_varids :: { Located [LocatedN RdrName] }-        : inj_varids tyvarid  { sLL $1 (reLocN $>) ($2 : unLoc $1) }-        | tyvarid             { sL1N  $1 [$1]               }---- Closed type families--where_type_family :: { Located ([AddEpAnn],FamilyInfo GhcPs) }-        : {- empty -}                      { noLoc ([],OpenTypeFamily) }-        | 'where' ty_fam_inst_eqn_list-               { sLL $1 $> (mj AnnWhere $1:(fst $ unLoc $2)-                    ,ClosedTypeFamily (fmap reverse $ snd $ unLoc $2)) }--ty_fam_inst_eqn_list :: { Located ([AddEpAnn],Maybe [LTyFamInstEqn GhcPs]) }-        :     '{' ty_fam_inst_eqns '}'     { sLL $1 $> ([moc $1,mcc $3]-                                                ,Just (unLoc $2)) }-        | vocurly ty_fam_inst_eqns close   { let (L loc _) = $2 in-                                             L loc ([],Just (unLoc $2)) }-        |     '{' '..' '}'                 { sLL $1 $> ([moc $1,mj AnnDotdot $2-                                                 ,mcc $3],Nothing) }-        | vocurly '..' close               { let (L loc _) = $2 in-                                             L loc ([mj AnnDotdot $2],Nothing) }--ty_fam_inst_eqns :: { Located [LTyFamInstEqn GhcPs] }-        : ty_fam_inst_eqns ';' ty_fam_inst_eqn-                                      {% let (L loc eqn) = $3 in-                                         case unLoc $1 of-                                           [] -> return (sLLlA $1 $> (L loc eqn : unLoc $1))-                                           (h:t) -> do-                                             h' <- addTrailingSemiA h (gl $2)-                                             return (sLLlA $1 $> ($3 : h' : t)) }-        | ty_fam_inst_eqns ';'        {% case unLoc $1 of-                                           [] -> return (sLL $1 $> (unLoc $1))-                                           (h:t) -> do-                                             h' <- addTrailingSemiA h (gl $2)-                                             return (sLL $1 $>  (h':t)) }-        | ty_fam_inst_eqn             { sLLAA $1 $> [$1] }-        | {- empty -}                 { noLoc [] }--ty_fam_inst_eqn :: { LTyFamInstEqn GhcPs }-        : 'forall' tv_bndrs '.' type '=' ktype-              {% do { hintExplicitForall $1-                    ; tvbs <- fromSpecTyVarBndrs $2-                    ; let loc = comb2A $1 $>-                    ; cs <- getCommentsFor loc-                    ; mkTyFamInstEqn loc (mkHsOuterExplicit (EpAnn (glR $1) (mu AnnForall $1, mj AnnDot $3) cs) tvbs) $4 $6 [mj AnnEqual $5] }}-        | type '=' ktype-              {% mkTyFamInstEqn (comb2A (reLoc $1) $>) mkHsOuterImplicit $1 $3 (mj AnnEqual $2:[]) }-              -- Note the use of type for the head; this allows-              -- infix type constructors and type patterns---- Associated type family declarations------ * They have a different syntax than on the toplevel (no family special---   identifier).------ * They also need to be separate from instances; otherwise, data family---   declarations without a kind signature cause parsing conflicts with empty---   data declarations.----at_decl_cls :: { LHsDecl GhcPs }-        :  -- data family declarations, with optional 'family' keyword-          'data' opt_family type opt_datafam_kind_sig-                {% liftM mkTyClD (mkFamDecl (comb3 $1 (reLoc $3) $4) DataFamily NotTopLevel $3-                                                  (snd $ unLoc $4) Nothing-                        (mj AnnData $1:$2++(fst $ unLoc $4))) }--           -- type family declarations, with optional 'family' keyword-           -- (can't use opt_instance because you get shift/reduce errors-        | 'type' type opt_at_kind_inj_sig-               {% liftM mkTyClD-                        (mkFamDecl (comb3 $1 (reLoc $2) $3) OpenTypeFamily NotTopLevel $2-                                   (fst . snd $ unLoc $3)-                                   (snd . snd $ unLoc $3)-                         (mj AnnType $1:(fst $ unLoc $3)) )}-        | 'type' 'family' type opt_at_kind_inj_sig-               {% liftM mkTyClD-                        (mkFamDecl (comb3 $1 (reLoc $3) $4) OpenTypeFamily NotTopLevel $3-                                   (fst . snd $ unLoc $4)-                                   (snd . snd $ unLoc $4)-                         (mj AnnType $1:mj AnnFamily $2:(fst $ unLoc $4)))}--           -- default type instances, with optional 'instance' keyword-        | 'type' ty_fam_inst_eqn-                {% liftM mkInstD (mkTyFamInst (comb2A $1 $2) (unLoc $2)-                          [mj AnnType $1]) }-        | 'type' 'instance' ty_fam_inst_eqn-                {% liftM mkInstD (mkTyFamInst (comb2A $1 $3) (unLoc $3)-                              (mj AnnType $1:mj AnnInstance $2:[]) )}--opt_family   :: { [AddEpAnn] }-              : {- empty -}   { [] }-              | 'family'      { [mj AnnFamily $1] }--opt_instance :: { [AddEpAnn] }-              : {- empty -} { [] }-              | 'instance'  { [mj AnnInstance $1] }---- Associated type instances----at_decl_inst :: { LInstDecl GhcPs }-           -- type instance declarations, with optional 'instance' keyword-        : 'type' opt_instance ty_fam_inst_eqn-                -- Note the use of type for the head; this allows-                -- infix type constructors and type patterns-                {% mkTyFamInst (comb2A $1 $3) (unLoc $3)-                          (mj AnnType $1:$2) }--        -- data/newtype instance declaration, with optional 'instance' keyword-        | data_or_newtype opt_instance capi_ctype datafam_inst_hdr constrs maybe_derivings-               {% mkDataFamInst (comb4 $1 $4 $5 $6) (snd $ unLoc $1) $3 (unLoc $4)-                                    Nothing (reverse (snd $ unLoc $5))-                                            (fmap reverse $6)-                        ((fst $ unLoc $1):$2++(fst $ unLoc $5)) }--        -- GADT instance declaration, with optional 'instance' keyword-        | data_or_newtype opt_instance capi_ctype datafam_inst_hdr opt_kind_sig-                 gadt_constrlist-                 maybe_derivings-                {% mkDataFamInst (comb4 $1 $4 $6 $7) (snd $ unLoc $1) $3-                                (unLoc $4) (snd $ unLoc $5) (snd $ unLoc $6)-                                (fmap reverse $7)-                        ((fst $ unLoc $1):$2++(fst $ unLoc $5)++(fst $ unLoc $6)) }--data_or_newtype :: { Located (AddEpAnn, NewOrData) }-        : 'data'        { sL1 $1 (mj AnnData    $1,DataType) }-        | 'newtype'     { sL1 $1 (mj AnnNewtype $1,NewType) }---- Family result/return kind signatures--opt_kind_sig :: { Located ([AddEpAnn], Maybe (LHsKind GhcPs)) }-        :               { noLoc     ([]               , Nothing) }-        | '::' kind     { sLL $1 (reLoc $>) ([mu AnnDcolon $1], Just $2) }--opt_datafam_kind_sig :: { Located ([AddEpAnn], LFamilyResultSig GhcPs) }-        :               { noLoc     ([]               , noLoc (NoSig noExtField)         )}-        | '::' kind     { sLL $1 (reLoc $>) ([mu AnnDcolon $1], sLL $1 (reLoc $>) (KindSig noExtField $2))}--opt_tyfam_kind_sig :: { Located ([AddEpAnn], LFamilyResultSig GhcPs) }-        :              { noLoc     ([]               , noLoc     (NoSig    noExtField)   )}-        | '::' kind    { sLL $1 (reLoc $>) ([mu AnnDcolon $1], sLL $1 (reLoc $>) (KindSig  noExtField $2))}-        | '='  tv_bndr {% do { tvb <- fromSpecTyVarBndr $2-                             ; return $ sLL $1 (reLoc $>) ([mj AnnEqual $1], sLL $1 (reLoc $>) (TyVarSig noExtField tvb))} }--opt_at_kind_inj_sig :: { Located ([AddEpAnn], ( LFamilyResultSig GhcPs-                                            , Maybe (LInjectivityAnn GhcPs)))}-        :            { noLoc ([], (noLoc (NoSig noExtField), Nothing)) }-        | '::' kind  { sLL $1 (reLoc $>) ( [mu AnnDcolon $1]-                                 , (sL1A $> (KindSig noExtField $2), Nothing)) }-        | '='  tv_bndr_no_braces '|' injectivity_cond-                {% do { tvb <- fromSpecTyVarBndr $2-                      ; return $ sLL $1 $> ([mj AnnEqual $1, mj AnnVbar $3]-                                           , (sLL $1 (reLoc $2) (TyVarSig noExtField tvb), Just $4))} }---- tycl_hdr parses the header of a class or data type decl,--- which takes the form---      T a b---      Eq a => T a---      (Eq a, Ord b) => T a b---      T Int [a]                       -- for associated types--- Rather a lot of inlining here, else we get reduce/reduce errors-tycl_hdr :: { Located (Maybe (LHsContext GhcPs), LHsType GhcPs) }-        : context '=>' type         {% acs (\cs -> (sLLAA $1 $> (Just (addTrailingDarrowC $1 $2 cs), $3))) }-        | type                      { sL1A $1 (Nothing, $1) }--datafam_inst_hdr :: { Located (Maybe (LHsContext GhcPs), HsOuterFamEqnTyVarBndrs GhcPs, LHsType GhcPs) }-        : 'forall' tv_bndrs '.' context '=>' type   {% hintExplicitForall $1-                                                       >> fromSpecTyVarBndrs $2-                                                         >>= \tvbs ->-                                                             (acs (\cs -> (sLL $1 (reLoc $>)-                                                                                  (Just ( addTrailingDarrowC $4 $5 cs)-                                                                                        , mkHsOuterExplicit (EpAnn (glR $1) (mu AnnForall $1, mj AnnDot $3) emptyComments) tvbs, $6))))-                                                    }-        | 'forall' tv_bndrs '.' type   {% do { hintExplicitForall $1-                                             ; tvbs <- fromSpecTyVarBndrs $2-                                             ; let loc = comb2 $1 (reLoc $>)-                                             ; cs <- getCommentsFor loc-                                             ; return (sL loc (Nothing, mkHsOuterExplicit (EpAnn (glR $1) (mu AnnForall $1, mj AnnDot $3) cs) tvbs, $4))-                                       } }-        | context '=>' type         {% acs (\cs -> (sLLAA $1 $>(Just (addTrailingDarrowC $1 $2 cs), mkHsOuterImplicit, $3))) }-        | type                      { sL1A $1 (Nothing, mkHsOuterImplicit, $1) }---capi_ctype :: { Maybe (LocatedP CType) }-capi_ctype : '{-# CTYPE' STRING STRING '#-}'-                       {% fmap Just $ amsrp (sLL $1 $> (CType (getCTYPEs $1) (Just (Header (getSTRINGs $2) (getSTRING $2)))-                                        (getSTRINGs $3,getSTRING $3)))-                              (AnnPragma (mo $1) (mc $4) [mj AnnHeader $2,mj AnnVal $3]) }--           | '{-# CTYPE'        STRING '#-}'-                       {% fmap Just $ amsrp (sLL $1 $> (CType (getCTYPEs $1) Nothing (getSTRINGs $2, getSTRING $2)))-                              (AnnPragma (mo $1) (mc $3) [mj AnnVal $2]) }--           |           { Nothing }---------------------------------------------------------------------------------- Stand-alone deriving---- Glasgow extension: stand-alone deriving declarations-stand_alone_deriving :: { LDerivDecl GhcPs }-  : 'deriving' deriv_standalone_strategy 'instance' overlap_pragma inst_type-                {% do { let { err = text "in the stand-alone deriving instance"-                                    <> colon <+> quotes (ppr $5) }-                      ; acsA (\cs -> sLL $1 (reLoc $>)-                                 (DerivDecl (EpAnn (glR $1) [mj AnnDeriving $1, mj AnnInstance $3] cs) (mkHsWildCardBndrs $5) $2 $4)) }}---------------------------------------------------------------------------------- Role annotations--role_annot :: { LRoleAnnotDecl GhcPs }-role_annot : 'type' 'role' oqtycon maybe_roles-          {% mkRoleAnnotDecl (comb3N $1 $4 $3) $3 (reverse (unLoc $4))-                   [mj AnnType $1,mj AnnRole $2] }---- Reversed!-maybe_roles :: { Located [Located (Maybe FastString)] }-maybe_roles : {- empty -}    { noLoc [] }-            | roles          { $1 }--roles :: { Located [Located (Maybe FastString)] }-roles : role             { sLL $1 $> [$1] }-      | roles role       { sLL $1 $> $ $2 : unLoc $1 }---- read it in as a varid for better error messages-role :: { Located (Maybe FastString) }-role : VARID             { sL1 $1 $ Just $ getVARID $1 }-     | '_'               { sL1 $1 Nothing }---- Pattern synonyms---- Glasgow extension: pattern synonyms-pattern_synonym_decl :: { LHsDecl GhcPs }-        : 'pattern' pattern_synonym_lhs '=' pat-         {%      let (name, args, as ) = $2 in-                 acsA (\cs -> sLL $1 (reLoc $>) . ValD noExtField $ mkPatSynBind name args $4-                                                    ImplicitBidirectional-                      (EpAnn (glR $1) (as ++ [mj AnnPattern $1, mj AnnEqual $3]) cs)) }--        | 'pattern' pattern_synonym_lhs '<-' pat-         {%    let (name, args, as) = $2 in-               acsA (\cs -> sLL $1 (reLoc $>) . ValD noExtField $ mkPatSynBind name args $4 Unidirectional-                       (EpAnn (glR $1) (as ++ [mj AnnPattern $1,mu AnnLarrow $3]) cs)) }--        | 'pattern' pattern_synonym_lhs '<-' pat where_decls-            {% do { let (name, args, as) = $2-                  ; mg <- mkPatSynMatchGroup name $5-                  ; acsA (\cs -> sLL $1 (reLoc $>) . ValD noExtField $-                           mkPatSynBind name args $4 (ExplicitBidirectional mg)-                            (EpAnn (glR $1) (as ++ [mj AnnPattern $1,mu AnnLarrow $3]) cs))-                   }}--pattern_synonym_lhs :: { (LocatedN RdrName, HsPatSynDetails GhcPs, [AddEpAnn]) }-        : con vars0 { ($1, PrefixCon noTypeArgs $2, []) }-        | varid conop varid { ($2, InfixCon $1 $3, []) }-        | con '{' cvars1 '}' { ($1, RecCon $3, [moc $2, mcc $4] ) }--vars0 :: { [LocatedN RdrName] }-        : {- empty -}                 { [] }-        | varid vars0                 { $1 : $2 }--cvars1 :: { [RecordPatSynField GhcPs] }-       : var                          { [RecordPatSynField (mkFieldOcc $1) $1] }-       | var ',' cvars1               {% do { h <- addTrailingCommaN $1 (gl $2)-                                            ; return ((RecordPatSynField (mkFieldOcc h) h) : $3 )}}--where_decls :: { LocatedL (OrdList (LHsDecl GhcPs)) }-        : 'where' '{' decls '}'       {% amsrl (sLL $1 $> (snd $ unLoc $3))-                                              (AnnList (Just $ glR $3) (Just $ moc $2) (Just $ mcc $4) [mj AnnWhere $1] (fst $ unLoc $3)) }-        | 'where' vocurly decls close {% amsrl (sLL $1 $3 (snd $ unLoc $3))-                                              (AnnList (Just $ glR $3) Nothing Nothing [mj AnnWhere $1] (fst $ unLoc $3))}--pattern_synonym_sig :: { LSig GhcPs }-        : 'pattern' con_list '::' sigtype-                   {% acsA (\cs -> sLL $1 (reLoc $>)-                                $ PatSynSig (EpAnn (glR $1) (AnnSig (mu AnnDcolon $3) [mj AnnPattern $1]) cs)-                                  (unLoc $2) $4) }--qvarcon :: { LocatedN RdrName }-        : qvar                          { $1 }-        | qcon                          { $1 }---------------------------------------------------------------------------------- Nested declarations---- Declaration in class bodies----decl_cls  :: { LHsDecl GhcPs }-decl_cls  : at_decl_cls                 { $1 }-          | decl                        { $1 }--          -- A 'default' signature used with the generic-programming extension-          | 'default' infixexp '::' sigtype-                    {% runPV (unECP $2) >>= \ $2 ->-                       do { v <- checkValSigLhs $2-                          ; let err = text "in default signature" <> colon <+>-                                      quotes (ppr $2)-                          ; acsA (\cs -> sLL $1 (reLoc $>) $ SigD noExtField $ ClassOpSig (EpAnn (glR $1) (AnnSig (mu AnnDcolon $3) [mj AnnDefault $1]) cs) True [v] $4) }}--decls_cls :: { Located ([AddEpAnn],OrdList (LHsDecl GhcPs)) }  -- Reversed-          : decls_cls ';' decl_cls      {% if isNilOL (snd $ unLoc $1)-                                             then return (sLLlA $1 $> ((fst $ unLoc $1) ++ (mz AnnSemi $2)-                                                                    , unitOL $3))-                                            else case (snd $ unLoc $1) of-                                              SnocOL hs t -> do-                                                 t' <- addTrailingSemiA t (gl $2)-                                                 return (sLLlA $1 $> (fst $ unLoc $1-                                                                , snocOL hs t' `appOL` unitOL $3)) }-          | decls_cls ';'               {% if isNilOL (snd $ unLoc $1)-                                             then return (sLL $1 $> ( (fst $ unLoc $1) ++ (mz AnnSemi $2)-                                                                                   ,snd $ unLoc $1))-                                             else case (snd $ unLoc $1) of-                                               SnocOL hs t -> do-                                                  t' <- addTrailingSemiA t (gl $2)-                                                  return (sLL $1 $> (fst $ unLoc $1-                                                                 , snocOL hs t')) }-          | decl_cls                    { sL1A $1 ([], unitOL $1) }-          | {- empty -}                 { noLoc ([],nilOL) }--decllist_cls-        :: { Located ([AddEpAnn]-                     , OrdList (LHsDecl GhcPs)-                     , LayoutInfo) }      -- Reversed-        : '{'         decls_cls '}'     { sLL $1 $> (moc $1:mcc $3:(fst $ unLoc $2)-                                             ,snd $ unLoc $2, ExplicitBraces) }-        |     vocurly decls_cls close   { let { L l (anns, decls) = $2 }-                                           in L l (anns, decls, VirtualBraces (getVOCURLY $1)) }---- Class body----where_cls :: { Located ([AddEpAnn]-                       ,(OrdList (LHsDecl GhcPs))    -- Reversed-                       ,LayoutInfo) }-                                -- No implicit parameters-                                -- May have type declarations-        : 'where' decllist_cls          { sLL $1 $> (mj AnnWhere $1:(fstOf3 $ unLoc $2)-                                             ,sndOf3 $ unLoc $2,thdOf3 $ unLoc $2) }-        | {- empty -}                   { noLoc ([],nilOL,NoLayoutInfo) }---- Declarations in instance bodies----decl_inst  :: { Located (OrdList (LHsDecl GhcPs)) }-decl_inst  : at_decl_inst               { sL1A $1 (unitOL (sL1 $1 (InstD noExtField (unLoc $1)))) }-           | decl                       { sL1A $1 (unitOL $1) }--decls_inst :: { Located ([AddEpAnn],OrdList (LHsDecl GhcPs)) }   -- Reversed-           : decls_inst ';' decl_inst   {% if isNilOL (snd $ unLoc $1)-                                             then return (sLL $1 $> ((fst $ unLoc $1) ++ (mz AnnSemi $2)-                                                                    , unLoc $3))-                                             else case (snd $ unLoc $1) of-                                               SnocOL hs t -> do-                                                  t' <- addTrailingSemiA t (gl $2)-                                                  return (sLL $1 $> (fst $ unLoc $1-                                                                 , snocOL hs t' `appOL` unLoc $3)) }-           | decls_inst ';'             {% if isNilOL (snd $ unLoc $1)-                                             then return (sLL $1 $> ((fst $ unLoc $1) ++ (mz AnnSemi $2)-                                                                                   ,snd $ unLoc $1))-                                             else case (snd $ unLoc $1) of-                                               SnocOL hs t -> do-                                                  t' <- addTrailingSemiA t (gl $2)-                                                  return (sLL $1 $> (fst $ unLoc $1-                                                                 , snocOL hs t')) }-           | decl_inst                  { sL1 $1 ([],unLoc $1) }-           | {- empty -}                { noLoc ([],nilOL) }--decllist_inst-        :: { Located ([AddEpAnn]-                     , OrdList (LHsDecl GhcPs)) }      -- Reversed-        : '{'         decls_inst '}'    { sLL $1 $> (moc $1:mcc $3:(fst $ unLoc $2),snd $ unLoc $2) }-        |     vocurly decls_inst close  { L (gl $2) (unLoc $2) }---- Instance body----where_inst :: { Located ([AddEpAnn]-                        , OrdList (LHsDecl GhcPs)) }   -- Reversed-                                -- No implicit parameters-                                -- May have type declarations-        : 'where' decllist_inst         { sLL $1 $> (mj AnnWhere $1:(fst $ unLoc $2)-                                             ,(snd $ unLoc $2)) }-        | {- empty -}                   { noLoc ([],nilOL) }---- Declarations in binding groups other than classes and instances----decls   :: { Located ([TrailingAnn], OrdList (LHsDecl GhcPs)) }-        : decls ';' decl    {% if isNilOL (snd $ unLoc $1)-                                 then return (sLLlA $1 $> ((fst $ unLoc $1) ++ (msemi $2)-                                                        , unitOL $3))-                                 else case (snd $ unLoc $1) of-                                   SnocOL hs t -> do-                                      t' <- addTrailingSemiA t (gl $2)-                                      let { this = unitOL $3;-                                            rest = snocOL hs t';-                                            these = rest `appOL` this }-                                      return (rest `seq` this `seq` these `seq`-                                                 (sLLlA $1 $> (fst $ unLoc $1, these))) }-        | decls ';'          {% if isNilOL (snd $ unLoc $1)-                                  then return (sLL $1 $> (((fst $ unLoc $1) ++ (msemi $2)-                                                          ,snd $ unLoc $1)))-                                  else case (snd $ unLoc $1) of-                                    SnocOL hs t -> do-                                       t' <- addTrailingSemiA t (gl $2)-                                       return (sLL $1 $> (fst $ unLoc $1-                                                      , snocOL hs t')) }-        | decl                          { sL1A $1 ([], unitOL $1) }-        | {- empty -}                   { noLoc ([],nilOL) }--decllist :: { Located (AnnList,Located (OrdList (LHsDecl GhcPs))) }-        : '{'            decls '}'     { sLL $1 $> (AnnList (Just $ glR $2) (Just $ moc $1) (Just $ mcc $3) [] (fst $ unLoc $2)-                                                   ,sL1 $2 $ snd $ unLoc $2) }-        |     vocurly    decls close   { L (gl $2) (AnnList (Just $ glR $2) Nothing Nothing [] (fst $ unLoc $2)-                                                   ,sL1 $2 $ snd $ unLoc $2) }---- Binding groups other than those of class and instance declarations----binds   ::  { Located (HsLocalBinds GhcPs) }-                                         -- May have implicit parameters-                                                -- No type declarations-        : decllist          {% do { val_binds <- cvBindGroup (unLoc $ snd $ unLoc $1)-                                  ; cs <- getCommentsFor (gl $1)-                                  ; return (sL1 $1 $ HsValBinds (EpAnn (glR $1) (fst $ unLoc $1) cs) val_binds)} }--        | '{'            dbinds '}'     {% acs (\cs -> (L (comb3 $1 $2 $3)-                                             $ HsIPBinds (EpAnn (glR $1) (AnnList (Just$ glR $2) (Just $ moc $1) (Just $ mcc $3) [] []) cs) (IPBinds noExtField (reverse $ unLoc $2)))) }--        |     vocurly    dbinds close   {% acs (\cs -> (L (gl $2)-                                             $ HsIPBinds (EpAnn (glR $1) (AnnList (Just $ glR $2) Nothing Nothing [] []) cs) (IPBinds noExtField (reverse $ unLoc $2)))) }---wherebinds :: { Maybe (Located (HsLocalBinds GhcPs, Maybe EpAnnComments )) }-                                                -- May have implicit parameters-                                                -- No type declarations-        : 'where' binds                 {% do { r <- acs (\cs ->-                                                (sLL $1 $> (annBinds (mj AnnWhere $1) cs (unLoc $2))))-                                              ; return $ Just r} }-        | {- empty -}                   { Nothing }---------------------------------------------------------------------------------- Transformation Rules--rules   :: { [LRuleDecl GhcPs] } -- Reversed-        :  rules ';' rule              {% case $1 of-                                            [] -> return ($3:$1)-                                            (h:t) -> do-                                              h' <- addTrailingSemiA h (gl $2)-                                              return ($3:h':t) }-        |  rules ';'                   {% case $1 of-                                            [] -> return $1-                                            (h:t) -> do-                                              h' <- addTrailingSemiA h (gl $2)-                                              return (h':t) }-        |  rule                        { [$1] }-        |  {- empty -}                 { [] }--rule    :: { LRuleDecl GhcPs }-        : STRING rule_activation rule_foralls infixexp '=' exp-         {%runPV (unECP $4) >>= \ $4 ->-           runPV (unECP $6) >>= \ $6 ->-           acsA (\cs -> (sLLlA $1 $> $ HsRule-                                   { rd_ext = EpAnn (glR $1) ((fstOf3 $3) (mj AnnEqual $5 : (fst $2))) cs-                                   , rd_name = L (gl $1) (getSTRINGs $1, getSTRING $1)-                                   , rd_act = (snd $2) `orElse` AlwaysActive-                                   , rd_tyvs = sndOf3 $3, rd_tmvs = thdOf3 $3-                                   , rd_lhs = $4, rd_rhs = $6 })) }---- Rules can be specified to be NeverActive, unlike inline/specialize pragmas-rule_activation :: { ([AddEpAnn],Maybe Activation) }-        -- See Note [%shift: rule_activation -> {- empty -}]-        : {- empty -} %shift                    { ([],Nothing) }-        | rule_explicit_activation              { (fst $1,Just (snd $1)) }---- This production is used to parse the tilde syntax in pragmas such as---   * {-# INLINE[~2] ... #-}---   * {-# SPECIALISE [~ 001] ... #-}---   * {-# RULES ... [~0] ... g #-}--- Note that it can be written either---   without a space [~1]  (the PREFIX_TILDE case), or---   with    a space [~ 1] (the VARSYM case).--- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer-rule_activation_marker :: { [AddEpAnn] }-      : PREFIX_TILDE { [mj AnnTilde $1] }-      | VARSYM  {% if (getVARSYM $1 == fsLit "~")-                   then return [mj AnnTilde $1]-                   else do { addError $ PsError PsErrInvalidRuleActivationMarker [] (getLoc $1)-                           ; return [] } }--rule_explicit_activation :: { ([AddEpAnn]-                              ,Activation) }  -- In brackets-        : '[' INTEGER ']'       { ([mos $1,mj AnnVal $2,mcs $3]-                                  ,ActiveAfter  (getINTEGERs $2) (fromInteger (il_value (getINTEGER $2)))) }-        | '[' rule_activation_marker INTEGER ']'-                                { ($2++[mos $1,mj AnnVal $3,mcs $4]-                                  ,ActiveBefore (getINTEGERs $3) (fromInteger (il_value (getINTEGER $3)))) }-        | '[' rule_activation_marker ']'-                                { ($2++[mos $1,mcs $3]-                                  ,NeverActive) }--rule_foralls :: { ([AddEpAnn] -> HsRuleAnn, Maybe [LHsTyVarBndr () GhcPs], [LRuleBndr GhcPs]) }-        : 'forall' rule_vars '.' 'forall' rule_vars '.'    {% let tyvs = mkRuleTyVarBndrs $2-                                                              in hintExplicitForall $1-                                                              >> checkRuleTyVarBndrNames (mkRuleTyVarBndrs $2)-                                                              >> return (\anns -> HsRuleAnn-                                                                          (Just (mu AnnForall $1,mj AnnDot $3))-                                                                          (Just (mu AnnForall $4,mj AnnDot $6))-                                                                          anns,-                                                                         Just (mkRuleTyVarBndrs $2), mkRuleBndrs $5) }--        -- See Note [%shift: rule_foralls -> 'forall' rule_vars '.']-        | 'forall' rule_vars '.' %shift                    { (\anns -> HsRuleAnn Nothing (Just (mu AnnForall $1,mj AnnDot $3)) anns,-                                                              Nothing, mkRuleBndrs $2) }-        -- See Note [%shift: rule_foralls -> {- empty -}]-        | {- empty -}            %shift                    { (\anns -> HsRuleAnn Nothing Nothing anns, Nothing, []) }--rule_vars :: { [LRuleTyTmVar] }-        : rule_var rule_vars                    { $1 : $2 }-        | {- empty -}                           { [] }--rule_var :: { LRuleTyTmVar }-        : varid                         { sL1N $1 (RuleTyTmVar noAnn $1 Nothing) }-        | '(' varid '::' ctype ')'      {% acs (\cs -> sLL $1 $> (RuleTyTmVar (EpAnn (glR $1) [mop $1,mu AnnDcolon $3,mcp $5] cs) $2 (Just $4))) }--{- Note [Parsing explicit foralls in Rules]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We really want the above definition of rule_foralls to be:--  rule_foralls : 'forall' tv_bndrs '.' 'forall' rule_vars '.'-               | 'forall' rule_vars '.'-               | {- empty -}--where rule_vars (term variables) can be named "forall", "family", or "role",-but tv_vars (type variables) cannot be. However, such a definition results-in a reduce/reduce conflict. For example, when parsing:-> {-# RULE "name" forall a ... #-}-before the '...' it is impossible to determine whether we should be in the-first or second case of the above.--This is resolved by using rule_vars (which is more general) for both, and-ensuring that type-level quantified variables do not have the names "forall",-"family", or "role" in the function 'checkRuleTyVarBndrNames' in-GHC.Parser.PostProcess.-Thus, whenever the definition of tyvarid (used for tv_bndrs) is changed relative-to varid (used for rule_vars), 'checkRuleTyVarBndrNames' must be updated.--}---------------------------------------------------------------------------------- Warnings and deprecations (c.f. rules)--warnings :: { OrdList (LWarnDecl GhcPs) }-        : warnings ';' warning         {% if isNilOL $1-                                           then return ($1 `appOL` $3)-                                           else case $1 of-                                             SnocOL hs t -> do-                                              t' <- addTrailingSemiA t (gl $2)-                                              return (snocOL hs t' `appOL` $3) }-        | warnings ';'                 {% if isNilOL $1-                                           then return $1-                                           else case $1 of-                                             SnocOL hs t -> do-                                              t' <- addTrailingSemiA t (gl $2)-                                              return (snocOL hs t') }-        | warning                      { $1 }-        | {- empty -}                  { nilOL }---- SUP: TEMPORARY HACK, not checking for `module Foo'-warning :: { OrdList (LWarnDecl GhcPs) }-        : namelist strings-                {% fmap unitOL $ acsA (\cs -> sLL $1 $>-                     (Warning (EpAnn (glR $1) (fst $ unLoc $2) cs) (unLoc $1)-                              (WarningTxt (noLoc NoSourceText) $ snd $ unLoc $2))) }--deprecations :: { OrdList (LWarnDecl GhcPs) }-        : deprecations ';' deprecation-                                       {% if isNilOL $1-                                           then return ($1 `appOL` $3)-                                           else case $1 of-                                             SnocOL hs t -> do-                                              t' <- addTrailingSemiA t (gl $2)-                                              return (snocOL hs t' `appOL` $3) }-        | deprecations ';'             {% if isNilOL $1-                                           then return $1-                                           else case $1 of-                                             SnocOL hs t -> do-                                              t' <- addTrailingSemiA t (gl $2)-                                              return (snocOL hs t') }-        | deprecation                  { $1 }-        | {- empty -}                  { nilOL }---- SUP: TEMPORARY HACK, not checking for `module Foo'-deprecation :: { OrdList (LWarnDecl GhcPs) }-        : namelist strings-             {% fmap unitOL $ acsA (\cs -> sLL $1 $> $ (Warning (EpAnn (glR $1) (fst $ unLoc $2) cs) (unLoc $1)-                                          (DeprecatedTxt (noLoc NoSourceText) $ snd $ unLoc $2))) }--strings :: { Located ([AddEpAnn],[Located StringLiteral]) }-    : STRING { sL1 $1 ([],[L (gl $1) (getStringLiteral $1)]) }-    | '[' stringlist ']' { sLL $1 $> $ ([mos $1,mcs $3],fromOL (unLoc $2)) }--stringlist :: { Located (OrdList (Located StringLiteral)) }-    : stringlist ',' STRING {% if isNilOL (unLoc $1)-                                then return (sLL $1 $> (unLoc $1 `snocOL`-                                                  (L (gl $3) (getStringLiteral $3))))-                                else case (unLoc $1) of-                                   SnocOL hs t -> do-                                     let { t' = addTrailingCommaS t (glAA $2) }-                                     return (sLL $1 $> (snocOL hs t' `snocOL`-                                                  (L (gl $3) (getStringLiteral $3))))--}-    | STRING                { sLL $1 $> (unitOL (L (gl $1) (getStringLiteral $1))) }-    | {- empty -}           { noLoc nilOL }---------------------------------------------------------------------------------- Annotations-annotation :: { LHsDecl GhcPs }-    : '{-# ANN' name_var aexp '#-}'      {% runPV (unECP $3) >>= \ $3 ->-                                            acsA (\cs -> sLL $1 $> (AnnD noExtField $ HsAnnotation-                                            (EpAnn (glR $1) (AnnPragma (mo $1) (mc $4) []) cs)-                                            (getANN_PRAGs $1)-                                            (ValueAnnProvenance $2) $3)) }--    | '{-# ANN' 'type' otycon aexp '#-}' {% runPV (unECP $4) >>= \ $4 ->-                                            acsA (\cs -> sLL $1 $> (AnnD noExtField $ HsAnnotation-                                            (EpAnn (glR $1) (AnnPragma (mo $1) (mc $5) [mj AnnType $2]) cs)-                                            (getANN_PRAGs $1)-                                            (TypeAnnProvenance $3) $4)) }--    | '{-# ANN' 'module' aexp '#-}'      {% runPV (unECP $3) >>= \ $3 ->-                                            acsA (\cs -> sLL $1 $> (AnnD noExtField $ HsAnnotation-                                                (EpAnn (glR $1) (AnnPragma (mo $1) (mc $4) [mj AnnModule $2]) cs)-                                                (getANN_PRAGs $1)-                                                 ModuleAnnProvenance $3)) }---------------------------------------------------------------------------------- Foreign import and export declarations--fdecl :: { Located ([AddEpAnn],EpAnn [AddEpAnn] -> HsDecl GhcPs) }-fdecl : 'import' callconv safety fspec-               {% mkImport $2 $3 (snd $ unLoc $4) >>= \i ->-                 return (sLL $1 $> (mj AnnImport $1 : (fst $ unLoc $4),i))  }-      | 'import' callconv        fspec-               {% do { d <- mkImport $2 (noLoc PlaySafe) (snd $ unLoc $3);-                    return (sLL $1 $> (mj AnnImport $1 : (fst $ unLoc $3),d)) }}-      | 'export' callconv fspec-               {% mkExport $2 (snd $ unLoc $3) >>= \i ->-                  return (sLL $1 $> (mj AnnExport $1 : (fst $ unLoc $3),i) ) }--callconv :: { Located CCallConv }-          : 'stdcall'                   { sLL $1 $> StdCallConv }-          | 'ccall'                     { sLL $1 $> CCallConv   }-          | 'capi'                      { sLL $1 $> CApiConv    }-          | 'prim'                      { sLL $1 $> PrimCallConv}-          | 'javascript'                { sLL $1 $> JavaScriptCallConv }--safety :: { Located Safety }-        : 'unsafe'                      { sLL $1 $> PlayRisky }-        | 'safe'                        { sLL $1 $> PlaySafe }-        | 'interruptible'               { sLL $1 $> PlayInterruptible }--fspec :: { Located ([AddEpAnn]-                    ,(Located StringLiteral, LocatedN RdrName, LHsSigType GhcPs)) }-       : STRING var '::' sigtype        { sLL $1 (reLoc $>) ([mu AnnDcolon $3]-                                             ,(L (getLoc $1)-                                                    (getStringLiteral $1), $2, $4)) }-       |        var '::' sigtype        { sLL (reLocN $1) (reLoc $>) ([mu AnnDcolon $2]-                                             ,(noLoc (StringLiteral NoSourceText nilFS Nothing), $1, $3)) }-         -- if the entity string is missing, it defaults to the empty string;-         -- the meaning of an empty entity string depends on the calling-         -- convention---------------------------------------------------------------------------------- Type signatures--opt_sig :: { Maybe (AddEpAnn, LHsType GhcPs) }-        : {- empty -}                   { Nothing }-        | '::' ctype                    { Just (mu AnnDcolon $1, $2) }--opt_tyconsig :: { ([AddEpAnn], Maybe (LocatedN RdrName)) }-             : {- empty -}              { ([], Nothing) }-             | '::' gtycon              { ([mu AnnDcolon $1], Just $2) }---- Like ktype, but for types that obey the forall-or-nothing rule.--- See Note [forall-or-nothing rule] in GHC.Hs.Type.-sigktype :: { LHsSigType GhcPs }-        : sigtype              { $1 }-        | ctype '::' kind      {% acsA (\cs -> sLLAA $1 $> $ mkHsImplicitSigType $-                                               sLLa  (reLoc $1) (reLoc $>) $ HsKindSig (EpAnn (glAR $1) [mu AnnDcolon $2] cs) $1 $3) }---- Like ctype, but for types that obey the forall-or-nothing rule.--- See Note [forall-or-nothing rule] in GHC.Hs.Type. To avoid duplicating the--- logic in ctype here, we simply reuse the ctype production and perform--- surgery on the LHsType it returns to turn it into an LHsSigType.-sigtype :: { LHsSigType GhcPs }-        : ctype                            { hsTypeToHsSigType $1 }--sig_vars :: { Located [LocatedN RdrName] }    -- Returned in reversed order-         : sig_vars ',' var           {% case unLoc $1 of-                                           [] -> return (sLL $1 (reLocN $>) ($3 : unLoc $1))-                                           (h:t) -> do-                                             h' <- addTrailingCommaN h (gl $2)-                                             return (sLL $1 (reLocN $>) ($3 : h' : t)) }-         | var                        { sL1N $1 [$1] }--sigtypes1 :: { OrdList (LHsSigType GhcPs) }-   : sigtype                 { unitOL $1 }-   | sigtype ',' sigtypes1   {% do { st <- addTrailingCommaA $1 (gl $2)-                                   ; return $ unitOL st `appOL` $3 } }--------------------------------------------------------------------------------- Types--unpackedness :: { Located UnpackednessPragma }-        : '{-# UNPACK' '#-}'   { sLL $1 $> (UnpackednessPragma [mo $1, mc $2] (getUNPACK_PRAGs $1) SrcUnpack) }-        | '{-# NOUNPACK' '#-}' { sLL $1 $> (UnpackednessPragma [mo $1, mc $2] (getNOUNPACK_PRAGs $1) SrcNoUnpack) }--forall_telescope :: { Located (HsForAllTelescope GhcPs) }-        : 'forall' tv_bndrs '.'  {% do { hintExplicitForall $1-                                       ; acs (\cs -> (sLL $1 $> $-                                           mkHsForAllInvisTele (EpAnn (glR $1) (mu AnnForall $1,mu AnnDot $3) cs) $2 )) }}-        | 'forall' tv_bndrs '->' {% do { hintExplicitForall $1-                                       ; req_tvbs <- fromSpecTyVarBndrs $2-                                       ; acs (\cs -> (sLL $1 $> $-                                           mkHsForAllVisTele (EpAnn (glR $1) (mu AnnForall $1,mu AnnRarrow $3) cs) req_tvbs )) }}---- A ktype is a ctype, possibly with a kind annotation-ktype :: { LHsType GhcPs }-        : ctype                { $1 }-        | ctype '::' kind      {% acsA (\cs -> sLLAA $1 $> $ HsKindSig (EpAnn (glAR $1) [mu AnnDcolon $2] cs) $1 $3) }---- A ctype is a for-all type-ctype   :: { LHsType GhcPs }-        : forall_telescope ctype      { reLocA $ sLL $1 (reLoc $>) $-                                              HsForAllTy { hst_tele = unLoc $1-                                                         , hst_xforall = noExtField-                                                         , hst_body = $2 } }-        | context '=>' ctype          {% acsA (\cs -> (sLL (reLoc $1) (reLoc $>) $-                                            HsQualTy { hst_ctxt = Just (addTrailingDarrowC $1 $2 cs)-                                                     , hst_xqual = NoExtField-                                                     , hst_body = $3 })) }--        | ipvar '::' type             {% acsA (\cs -> sLL $1 (reLoc $>) (HsIParamTy (EpAnn (glR $1) [mu AnnDcolon $2] cs) $1 $3)) }-        | type                        { $1 }--------------------------- Notes for 'context'--- We parse a context as a btype so that we don't get reduce/reduce--- errors in ctype.  The basic problem is that---      (Eq a, Ord a)--- looks so much like a tuple type.  We can't tell until we find the =>--context :: { LHsContext GhcPs }-        :  btype                        {% checkContext $1 }--{- Note [GADT decl discards annotations]-~~~~~~~~~~~~~~~~~~~~~-The type production for--    btype `->` ctype--add the AnnRarrow annotation twice, in different places.--This is because if the type is processed as usual, it belongs on the annotations-for the type as a whole.--But if the type is passed to mkGadtDecl, it discards the top level SrcSpan, and-the top-level annotation will be disconnected. Hence for this specific case it-is connected to the first type too.--}--type :: { LHsType GhcPs }-        -- See Note [%shift: type -> btype]-        : btype %shift                 { $1 }-        | btype '->' ctype             {% acsA (\cs -> sLL (reLoc $1) (reLoc $>)-                                            $ HsFunTy (EpAnn (glAR $1) (mau $2) cs) (HsUnrestrictedArrow (toUnicode $2)) $1 $3) }--        | btype mult '->' ctype        {% hintLinear (getLoc $2)-                                       >> let arr = (unLoc $2) (toUnicode $3)-                                          in acsA (\cs -> sLL (reLoc $1) (reLoc $>)-                                           $ HsFunTy (EpAnn (glAR $1) (mau $3) cs) arr $1 $4) }--        | btype '->.' ctype            {% hintLinear (getLoc $2) >>-                                          acsA (\cs -> sLL (reLoc $1) (reLoc $>)-                                            $ HsFunTy (EpAnn (glAR $1) (mlu $2) cs) (HsLinearArrow UnicodeSyntax Nothing) $1 $3) }-                                              -- [mu AnnLollyU $2] }--mult :: { Located (IsUnicodeSyntax -> HsArrow GhcPs) }-        : PREFIX_PERCENT atype          { sLL $1 (reLoc $>) (\u -> mkMultTy u $1 $2) }--btype :: { LHsType GhcPs }-        : infixtype                     {% runPV $1 }--infixtype :: { forall b. DisambTD b => PV (LocatedA b) }-        -- See Note [%shift: infixtype -> ftype]-        : ftype %shift                  { $1 }-        | ftype tyop infixtype          { $1 >>= \ $1 ->-                                          $3 >>= \ $3 ->-                                          do { when (looksLikeMult $1 $2 $3) $ hintLinear (getLocA $2)-                                             ; mkHsOpTyPV $1 $2 $3 } }-        | unpackedness infixtype        { $2 >>= \ $2 ->-                                          mkUnpackednessPV $1 $2 }--ftype :: { forall b. DisambTD b => PV (LocatedA b) }-        : atype                         { mkHsAppTyHeadPV $1 }-        | tyop                          { failOpFewArgs $1 }-        | ftype tyarg                   { $1 >>= \ $1 ->-                                          mkHsAppTyPV $1 $2 }-        | ftype PREFIX_AT atype         { $1 >>= \ $1 ->-                                          mkHsAppKindTyPV $1 (getLoc $2) $3 }--tyarg :: { LHsType GhcPs }-        : atype                         { $1 }-        | unpackedness atype            {% addUnpackednessP $1 $2 }--tyop :: { LocatedN RdrName }-        : qtyconop                      { $1 }-        | tyvarop                       { $1 }-        | SIMPLEQUOTE qconop            {% amsrn (sLL $1 (reLoc $>) (unLoc $2))-                                                 (NameAnnQuote (glAA $1) (gl $2) []) }-        | SIMPLEQUOTE varop             {% amsrn (sLL $1 (reLoc $>) (unLoc $2))-                                                 (NameAnnQuote (glAA $1) (gl $2) []) }--atype :: { LHsType GhcPs }-        : ntgtycon                       {% acsa (\cs -> sL1a (reLocN $1) (HsTyVar (EpAnn (glNR $1) [] cs) NotPromoted $1)) }      -- Not including unit tuples-        -- See Note [%shift: atype -> tyvar]-        | tyvar %shift                   {% acsa (\cs -> sL1a (reLocN $1) (HsTyVar (EpAnn (glNR $1) [] cs) NotPromoted $1)) }      -- (See Note [Unit tuples])-        | '*'                            {% do { warnStarIsType (getLoc $1)-                                               ; return $ reLocA $ sL1 $1 (HsStarTy noExtField (isUnicode $1)) } }--        -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer-        | PREFIX_TILDE atype             {% acsA (\cs -> sLLlA $1 $> (mkBangTy (EpAnn (glR $1) [mj AnnTilde $1] cs) SrcLazy $2)) }-        | PREFIX_BANG  atype             {% acsA (\cs -> sLLlA $1 $> (mkBangTy (EpAnn (glR $1) [mj AnnBang $1] cs) SrcStrict $2)) }--        | '{' fielddecls '}'             {% do { decls <- acsA (\cs -> (sLL $1 $> $ HsRecTy (EpAnn (glR $1) (AnnList (Just $ listAsAnchor $2) (Just $ moc $1) (Just $ mcc $3) [] []) cs) $2))-                                               ; checkRecordSyntax decls }}-                                                        -- Constructor sigs only-        | '(' ')'                        {% acsA (\cs -> sLL $1 $> $ HsTupleTy (EpAnn (glR $1) (AnnParen AnnParens (glAA $1) (glAA $2)) cs)-                                                    HsBoxedOrConstraintTuple []) }-        | '(' ktype ',' comma_types1 ')' {% do { h <- addTrailingCommaA $2 (gl $3)-                                               ; acsA (\cs -> sLL $1 $> $ HsTupleTy (EpAnn (glR $1) (AnnParen AnnParens (glAA $1) (glAA $5)) cs)-                                                        HsBoxedOrConstraintTuple (h : $4)) }}-        | '(#' '#)'                   {% acsA (\cs -> sLL $1 $> $ HsTupleTy (EpAnn (glR $1) (AnnParen AnnParensHash (glAA $1) (glAA $2)) cs) HsUnboxedTuple []) }-        | '(#' comma_types1 '#)'      {% acsA (\cs -> sLL $1 $> $ HsTupleTy (EpAnn (glR $1) (AnnParen AnnParensHash (glAA $1) (glAA $3)) cs) HsUnboxedTuple $2) }-        | '(#' bar_types2 '#)'        {% acsA (\cs -> sLL $1 $> $ HsSumTy (EpAnn (glR $1) (AnnParen AnnParensHash (glAA $1) (glAA $3)) cs) $2) }-        | '[' ktype ']'               {% acsA (\cs -> sLL $1 $> $ HsListTy (EpAnn (glR $1) (AnnParen AnnParensSquare (glAA $1) (glAA $3)) cs) $2) }-        | '(' ktype ')'               {% acsA (\cs -> sLL $1 $> $ HsParTy  (EpAnn (glR $1) (AnnParen AnnParens       (glAA $1) (glAA $3)) cs) $2) }-        | quasiquote                  { mapLocA (HsSpliceTy noExtField) $1 }-        | splice_untyped              { mapLocA (HsSpliceTy noExtField) $1 }-                                      -- see Note [Promotion] for the followings-        | SIMPLEQUOTE qcon_nowiredlist {% acsA (\cs -> sLL $1 (reLocN $>) $ HsTyVar (EpAnn (glR $1) [mj AnnSimpleQuote $1,mjN AnnName $2] cs) IsPromoted $2) }-        | SIMPLEQUOTE  '(' ktype ',' comma_types1 ')'-                             {% do { h <- addTrailingCommaA $3 (gl $4)-                                   ; acsA (\cs -> sLL $1 $> $ HsExplicitTupleTy (EpAnn (glR $1) [mj AnnSimpleQuote $1,mop $2,mcp $6] cs) (h : $5)) }}-        | SIMPLEQUOTE  '[' comma_types0 ']'     {% acsA (\cs -> sLL $1 $> $ HsExplicitListTy (EpAnn (glR $1) [mj AnnSimpleQuote $1,mos $2,mcs $4] cs) IsPromoted $3) }-        | SIMPLEQUOTE var                       {% acsA (\cs -> sLL $1 (reLocN $>) $ HsTyVar (EpAnn (glR $1) [mj AnnSimpleQuote $1,mjN AnnName $2] cs) IsPromoted $2) }--        -- Two or more [ty, ty, ty] must be a promoted list type, just as-        -- if you had written '[ty, ty, ty]-        -- (One means a list type, zero means the list type constructor,-        -- so you have to quote those.)-        | '[' ktype ',' comma_types1 ']'  {% do { h <- addTrailingCommaA $2 (gl $3)-                                                ; acsA (\cs -> sLL $1 $> $ HsExplicitListTy (EpAnn (glR $1) [mos $1,mcs $5] cs) NotPromoted (h:$4)) }}-        | INTEGER              { reLocA $ sLL $1 $> $ HsTyLit noExtField $ HsNumTy (getINTEGERs $1)-                                                           (il_value (getINTEGER $1)) }-        | CHAR                 { reLocA $ sLL $1 $> $ HsTyLit noExtField $ HsCharTy (getCHARs $1)-                                                                        (getCHAR $1) }-        | STRING               { reLocA $ sLL $1 $> $ HsTyLit noExtField $ HsStrTy (getSTRINGs $1)-                                                                     (getSTRING  $1) }-        | '_'                  { reLocA $ sL1 $1 $ mkAnonWildCardTy }---- An inst_type is what occurs in the head of an instance decl---      e.g.  (Foo a, Gaz b) => Wibble a b--- It's kept as a single type for convenience.-inst_type :: { LHsSigType GhcPs }-        : sigtype                       { $1 }--deriv_types :: { [LHsSigType GhcPs] }-        : sigktype                      { [$1] }--        | sigktype ',' deriv_types      {% do { h <- addTrailingCommaA $1 (gl $2)-                                           ; return (h : $3) } }--comma_types0  :: { [LHsType GhcPs] }  -- Zero or more:  ty,ty,ty-        : comma_types1                  { $1 }-        | {- empty -}                   { [] }--comma_types1    :: { [LHsType GhcPs] }  -- One or more:  ty,ty,ty-        : ktype                        { [$1] }-        | ktype  ',' comma_types1      {% do { h <- addTrailingCommaA $1 (gl $2)-                                             ; return (h : $3) }}--bar_types2    :: { [LHsType GhcPs] }  -- Two or more:  ty|ty|ty-        : ktype  '|' ktype             {% do { h <- addTrailingVbarA $1 (gl $2)-                                             ; return [h,$3] }}-        | ktype  '|' bar_types2        {% do { h <- addTrailingVbarA $1 (gl $2)-                                             ; return (h : $3) }}--tv_bndrs :: { [LHsTyVarBndr Specificity GhcPs] }-         : tv_bndr tv_bndrs             { $1 : $2 }-         | {- empty -}                  { [] }--tv_bndr :: { LHsTyVarBndr Specificity GhcPs }-        : tv_bndr_no_braces             { $1 }-        | '{' tyvar '}'                 {% acsA (\cs -> sLL $1 $> (UserTyVar (EpAnn (glR $1) [moc $1, mcc $3] cs) InferredSpec $2)) }-        | '{' tyvar '::' kind '}'       {% acsA (\cs -> sLL $1 $> (KindedTyVar (EpAnn (glR $1) [moc $1,mu AnnDcolon $3 ,mcc $5] cs) InferredSpec $2 $4)) }--tv_bndr_no_braces :: { LHsTyVarBndr Specificity GhcPs }-        : tyvar                         {% acsA (\cs -> (sL1 (reLocN $1) (UserTyVar (EpAnn (glNR $1) [] cs) SpecifiedSpec $1))) }-        | '(' tyvar '::' kind ')'       {% acsA (\cs -> (sLL $1 $> (KindedTyVar (EpAnn (glR $1) [mop $1,mu AnnDcolon $3 ,mcp $5] cs) SpecifiedSpec $2 $4))) }--fds :: { Located ([AddEpAnn],[LHsFunDep GhcPs]) }-        : {- empty -}                   { noLoc ([],[]) }-        | '|' fds1                      { (sLL $1 $> ([mj AnnVbar $1]-                                                 ,reverse (unLoc $2))) }--fds1 :: { Located [LHsFunDep GhcPs] }-        : fds1 ',' fd   {%-                           do { let (h:t) = unLoc $1 -- Safe from fds1 rules-                              ; h' <- addTrailingCommaA h (gl $2)-                              ; return (sLLlA $1 $> ($3 : h' : t)) }}-        | fd            { sL1A $1 [$1] }--fd :: { LHsFunDep GhcPs }-        : varids0 '->' varids0  {% acsA (\cs -> L (comb3 $1 $2 $3)-                                       (FunDep (EpAnn (glR $1) [mu AnnRarrow $2] cs)-                                               (reverse (unLoc $1))-                                               (reverse (unLoc $3)))) }--varids0 :: { Located [LocatedN RdrName] }-        : {- empty -}                   { noLoc [] }-        | varids0 tyvar                 { sLL $1 (reLocN $>) ($2 : (unLoc $1)) }---------------------------------------------------------------------------------- Kinds--kind :: { LHsKind GhcPs }-        : ctype                  { $1 }--{- Note [Promotion]-   ~~~~~~~~~~~~~~~~--- Syntax of promoted qualified names-We write 'Nat.Zero instead of Nat.'Zero when dealing with qualified-names. Moreover ticks are only allowed in types, not in kinds, for a-few reasons:-  1. we don't need quotes since we cannot define names in kinds-  2. if one day we merge types and kinds, tick would mean look in DataName-  3. we don't have a kind namespace anyway--- Name resolution-When the user write Zero instead of 'Zero in types, we parse it a-HsTyVar ("Zero", TcClsName) instead of HsTyVar ("Zero", DataName). We-deal with this in the renamer. If a HsTyVar ("Zero", TcClsName) is not-bounded in the type level, then we look for it in the term level (we-change its namespace to DataName, see Note [Demotion] in GHC.Types.Names.OccName).-And both become a HsTyVar ("Zero", DataName) after the renamer.---}----------------------------------------------------------------------------------- Datatype declarations--gadt_constrlist :: { Located ([AddEpAnn]-                          ,[LConDecl GhcPs]) } -- Returned in order--        : 'where' '{'        gadt_constrs '}'    {% checkEmptyGADTs $-                                                      L (comb2 $1 $3)-                                                        ([mj AnnWhere $1-                                                         ,moc $2-                                                         ,mcc $4]-                                                        , unLoc $3) }-        | 'where' vocurly    gadt_constrs close  {% checkEmptyGADTs $-                                                      L (comb2 $1 $3)-                                                        ([mj AnnWhere $1]-                                                        , unLoc $3) }-        | {- empty -}                            { noLoc ([],[]) }--gadt_constrs :: { Located [LConDecl GhcPs] }-        : gadt_constr ';' gadt_constrs-                  {% do { h <- addTrailingSemiA $1 (gl $2)-                        ; return (L (comb2 (reLoc $1) $3) (h : unLoc $3)) }}-        | gadt_constr                   { L (glA $1) [$1] }-        | {- empty -}                   { noLoc [] }---- We allow the following forms:---      C :: Eq a => a -> T a---      C :: forall a. Eq a => !a -> T a---      D { x,y :: a } :: T a---      forall a. Eq a => D { x,y :: a } :: T a--gadt_constr :: { LConDecl GhcPs }-    -- see Note [Difference in parsing GADT and data constructors]-    -- Returns a list because of:   C,D :: ty-    -- TODO:AZ capture the optSemi. Why leading?-        : optSemi con_list '::' sigtype-                {% mkGadtDecl (comb2A $2 $>) (unLoc $2) $4 [mu AnnDcolon $3] }--{- Note [Difference in parsing GADT and data constructors]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-GADT constructors have simpler syntax than usual data constructors:-in GADTs, types cannot occur to the left of '::', so they cannot be mixed-with constructor names (see Note [Parsing data constructors is hard]).--Due to simplified syntax, GADT constructor names (left-hand side of '::')-use simpler grammar production than usual data constructor names. As a-consequence, GADT constructor names are restricted (names like '(*)' are-allowed in usual data constructors, but not in GADTs).--}--constrs :: { Located ([AddEpAnn],[LConDecl GhcPs]) }-        : '=' constrs1    { sLL $1 $2 ([mj AnnEqual $1],unLoc $2)}--constrs1 :: { Located [LConDecl GhcPs] }-        : constrs1 '|' constr-            {% do { let (h:t) = unLoc $1-                  ; h' <- addTrailingVbarA h (gl $2)-                  ; return (sLLlA $1 $> ($3 : h' : t)) }}-        | constr                         { sL1A $1 [$1] }--constr :: { LConDecl GhcPs }-        : forall context '=>' constr_stuff-                {% acsA (\cs -> let (con,details) = unLoc $4 in-                  (L (comb4 $1 (reLoc $2) $3 $4) (mkConDeclH98-                                                       (EpAnn (spanAsAnchor (comb4 $1 (reLoc $2) $3 $4))-                                                                    (mu AnnDarrow $3:(fst $ unLoc $1)) cs)-                                                       con-                                                       (snd $ unLoc $1)-                                                       (Just $2)-                                                       details))) }-        | forall constr_stuff-                {% acsA (\cs -> let (con,details) = unLoc $2 in-                  (L (comb2 $1 $2) (mkConDeclH98 (EpAnn (spanAsAnchor (comb2 $1 $2)) (fst $ unLoc $1) cs)-                                                      con-                                                      (snd $ unLoc $1)-                                                      Nothing   -- No context-                                                      details))) }--forall :: { Located ([AddEpAnn], Maybe [LHsTyVarBndr Specificity GhcPs]) }-        : 'forall' tv_bndrs '.'       { sLL $1 $> ([mu AnnForall $1,mj AnnDot $3], Just $2) }-        | {- empty -}                 { noLoc ([], Nothing) }--constr_stuff :: { Located (LocatedN RdrName, HsConDeclH98Details GhcPs) }-        : infixtype       {% fmap (reLoc. (mapLoc (\b -> (dataConBuilderCon b,-                                                          dataConBuilderDetails b))))-                                     (runPV $1) }--fielddecls :: { [LConDeclField GhcPs] }-        : {- empty -}     { [] }-        | fielddecls1     { $1 }--fielddecls1 :: { [LConDeclField GhcPs] }-        : fielddecl ',' fielddecls1-            {% do { h <- addTrailingCommaA $1 (gl $2)-                  ; return (h : $3) }}-        | fielddecl   { [$1] }--fielddecl :: { LConDeclField GhcPs }-                                              -- A list because of   f,g :: Int-        : sig_vars '::' ctype-            {% acsA (\cs -> L (comb2 $1 (reLoc $3))-                      (ConDeclField (EpAnn (glR $1) [mu AnnDcolon $2] cs)-                                    (reverse (map (\ln@(L l n) -> L (locA l) $ FieldOcc noExtField ln) (unLoc $1))) $3 Nothing))}---- Reversed!-maybe_derivings :: { Located (HsDeriving GhcPs) }-        : {- empty -}             { noLoc [] }-        | derivings               { $1 }---- A list of one or more deriving clauses at the end of a datatype-derivings :: { Located (HsDeriving GhcPs) }-        : derivings deriving      { sLL $1 $> ($2 : unLoc $1) } -- AZ: order?-        | deriving                { sLL $1 $> [$1] }---- The outer Located is just to allow the caller to--- know the rightmost extremity of the 'deriving' clause-deriving :: { LHsDerivingClause GhcPs }-        : 'deriving' deriv_clause_types-              {% let { full_loc = comb2A $1 $> }-                 in acs (\cs -> L full_loc $ HsDerivingClause (EpAnn (glR $1) [mj AnnDeriving $1] cs) Nothing $2) }--        | 'deriving' deriv_strategy_no_via deriv_clause_types-              {% let { full_loc = comb2A $1 $> }-                 in acs (\cs -> L full_loc $ HsDerivingClause (EpAnn (glR $1) [mj AnnDeriving $1] cs) (Just $2) $3) }--        | 'deriving' deriv_clause_types deriv_strategy_via-              {% let { full_loc = comb2 $1 $> }-                 in acs (\cs -> L full_loc $ HsDerivingClause (EpAnn (glR $1) [mj AnnDeriving $1] cs) (Just $3) $2) }--deriv_clause_types :: { LDerivClauseTys GhcPs }-        : qtycon              { let { tc = sL1 (reLocL $1) $ mkHsImplicitSigType $-                                           sL1 (reLocL $1) $ HsTyVar noAnn NotPromoted $1 } in-                                sL1 (reLocC $1) (DctSingle noExtField tc) }-        | '(' ')'             {% amsrc (sLL $1 $> (DctMulti noExtField []))-                                       (AnnContext Nothing [glAA $1] [glAA $2]) }-        | '(' deriv_types ')' {% amsrc (sLL $1 $> (DctMulti noExtField $2))-                                       (AnnContext Nothing [glAA $1] [glAA $3])}---------------------------------------------------------------------------------- Value definitions--{- Note [Declaration/signature overlap]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-There's an awkward overlap with a type signature.  Consider-        f :: Int -> Int = ...rhs...-   Then we can't tell whether it's a type signature or a value-   definition with a result signature until we see the '='.-   So we have to inline enough to postpone reductions until we know.--}--{--  ATTENTION: Dirty Hackery Ahead! If the second alternative of vars is var-  instead of qvar, we get another shift/reduce-conflict. Consider the-  following programs:--     { (^^) :: Int->Int ; }          Type signature; only var allowed--     { (^^) :: Int->Int = ... ; }    Value defn with result signature;-                                     qvar allowed (because of instance decls)--  We can't tell whether to reduce var to qvar until after we've read the signatures.--}--decl_no_th :: { LHsDecl GhcPs }-        : sigdecl               { $1 }--        | infixexp     opt_sig rhs  {% runPV (unECP $1) >>= \ $1 ->-                                       do { let { l = comb2Al $1 $> }-                                          ; r <- checkValDef l $1 $2 $3;-                                        -- Depending upon what the pattern looks like we might get either-                                        -- a FunBind or PatBind back from checkValDef. See Note-                                        -- [FunBind vs PatBind]-                                          ; cs <- getCommentsFor l-                                          ; return $! (sL (commentsA l cs) $ ValD noExtField r) } }-        | pattern_synonym_decl  { $1 }--decl    :: { LHsDecl GhcPs }-        : decl_no_th            { $1 }--        -- Why do we only allow naked declaration splices in top-level-        -- declarations and not here? Short answer: because readFail009-        -- fails terribly with a panic in cvBindsAndSigs otherwise.-        | splice_exp            {% mkSpliceDecl $1 }--rhs     :: { Located (GRHSs GhcPs (LHsExpr GhcPs)) }-        : '=' exp wherebinds    {% runPV (unECP $2) >>= \ $2 ->-                                  do { let L l (bs, csw) = adaptWhereBinds $3-                                     ; let loc = (comb3 $1 (reLoc $2) (L l bs))-                                     ; acs (\cs ->-                                       sL loc (GRHSs csw (unguardedRHS (EpAnn (anc $ rs loc) (GrhsAnn Nothing (mj AnnEqual $1)) cs) loc $2)-                                                      bs)) } }-        | gdrhs wherebinds      {% do { let {L l (bs, csw) = adaptWhereBinds $2}-                                      ; acs (\cs -> sL (comb2 $1 (L l bs))-                                                (GRHSs (cs Semi.<> csw) (reverse (unLoc $1)) bs)) }}--gdrhs :: { Located [LGRHS GhcPs (LHsExpr GhcPs)] }-        : gdrhs gdrh            { sLL $1 $> ($2 : unLoc $1) }-        | gdrh                  { sL1 $1 [$1] }--gdrh :: { LGRHS GhcPs (LHsExpr GhcPs) }-        : '|' guardquals '=' exp  {% runPV (unECP $4) >>= \ $4 ->-                                     acs (\cs -> sL (comb2A $1 $>) $ GRHS (EpAnn (glR $1) (GrhsAnn (Just $ glAA $1) (mj AnnEqual $3)) cs) (unLoc $2) $4) }--sigdecl :: { LHsDecl GhcPs }-        :-        -- See Note [Declaration/signature overlap] for why we need infixexp here-          infixexp     '::' sigtype-                        {% do { $1 <- runPV (unECP $1)-                              ; v <- checkValSigLhs $1-                              ; acsA (\cs -> (sLLAl $1 (reLoc $>) $ SigD noExtField $-                                  TypeSig (EpAnn (glAR $1) (AnnSig (mu AnnDcolon $2) []) cs) [v] (mkHsWildCardBndrs $3)))} }--        | var ',' sig_vars '::' sigtype-           {% do { v <- addTrailingCommaN $1 (gl $2)-                 ; let sig cs = TypeSig (EpAnn (glNR $1) (AnnSig (mu AnnDcolon $4) []) cs) (v : reverse (unLoc $3))-                                      (mkHsWildCardBndrs $5)-                 ; acsA (\cs -> sLL (reLocN $1) (reLoc $>) $ SigD noExtField (sig cs) ) }}--        | infix prec ops-             {% do { mbPrecAnn <- traverse (\l2 -> do { checkPrecP l2 $3-                                                      ; pure (mj AnnVal l2) })-                                       $2-                   ; let (fixText, fixPrec) = case $2 of-                                                -- If an explicit precedence isn't supplied,-                                                -- it defaults to maxPrecedence-                                                Nothing -> (NoSourceText, maxPrecedence)-                                                Just l2 -> (fst $ unLoc l2, snd $ unLoc l2)-                   ; acsA (\cs -> sLL $1 $> $ SigD noExtField-                            (FixSig (EpAnn (glR $1) (mj AnnInfix $1 : maybeToList mbPrecAnn) cs) (FixitySig noExtField (fromOL $ unLoc $3)-                                    (Fixity fixText fixPrec (unLoc $1)))))-                   }}--        | pattern_synonym_sig   { sL1 $1 . SigD noExtField . unLoc $ $1 }--        | '{-# COMPLETE' con_list opt_tyconsig  '#-}'-                {% let (dcolon, tc) = $3-                   in acsA-                       (\cs -> sLL $1 $>-                         (SigD noExtField (CompleteMatchSig (EpAnn (glR $1) ([ mo $1 ] ++ dcolon ++ [mc $4]) cs) (getCOMPLETE_PRAGs $1) $2 tc))) }--        -- This rule is for both INLINE and INLINABLE pragmas-        | '{-# INLINE' activation qvarcon '#-}'-                {% acsA (\cs -> (sLL $1 $> $ SigD noExtField (InlineSig (EpAnn (glR $1) ((mo $1:fst $2) ++ [mc $4]) cs) $3-                            (mkInlinePragma (getINLINE_PRAGs $1) (getINLINE $1)-                                            (snd $2))))) }--        | '{-# SCC' qvar '#-}'-          {% acsA (\cs -> sLL $1 $> (SigD noExtField (SCCFunSig (EpAnn (glR $1) [mo $1, mc $3] cs) (getSCC_PRAGs $1) $2 Nothing))) }--        | '{-# SCC' qvar STRING '#-}'-          {% do { scc <- getSCC $3-                ; let str_lit = StringLiteral (getSTRINGs $3) scc Nothing-                ; acsA (\cs -> sLL $1 $> (SigD noExtField (SCCFunSig (EpAnn (glR $1) [mo $1, mc $4] cs) (getSCC_PRAGs $1) $2 (Just ( sL1 $3 str_lit))))) }}--        | '{-# SPECIALISE' activation qvar '::' sigtypes1 '#-}'-             {% acsA (\cs ->-                 let inl_prag = mkInlinePragma (getSPEC_PRAGs $1)-                                             (NoUserInlinePrag, FunLike) (snd $2)-                  in sLL $1 $> $ SigD noExtField (SpecSig (EpAnn (glR $1) (mo $1:mu AnnDcolon $4:mc $6:(fst $2)) cs) $3 (fromOL $5) inl_prag)) }--        | '{-# SPECIALISE_INLINE' activation qvar '::' sigtypes1 '#-}'-             {% acsA (\cs -> sLL $1 $> $ SigD noExtField (SpecSig (EpAnn (glR $1) (mo $1:mu AnnDcolon $4:mc $6:(fst $2)) cs) $3 (fromOL $5)-                               (mkInlinePragma (getSPEC_INLINE_PRAGs $1)-                                               (getSPEC_INLINE $1) (snd $2)))) }--        | '{-# SPECIALISE' 'instance' inst_type '#-}'-                {% acsA (\cs -> sLL $1 $>-                                  $ SigD noExtField (SpecInstSig (EpAnn (glR $1) [mo $1,mj AnnInstance $2,mc $4] cs) (getSPEC_PRAGs $1) $3)) }--        -- A minimal complete definition-        | '{-# MINIMAL' name_boolformula_opt '#-}'-            {% acsA (\cs -> sLL $1 $> $ SigD noExtField (MinimalSig (EpAnn (glR $1) [mo $1,mc $3] cs) (getMINIMAL_PRAGs $1) $2)) }--activation :: { ([AddEpAnn],Maybe Activation) }-        -- See Note [%shift: activation -> {- empty -}]-        : {- empty -} %shift                    { ([],Nothing) }-        | explicit_activation                   { (fst $1,Just (snd $1)) }--explicit_activation :: { ([AddEpAnn],Activation) }  -- In brackets-        : '[' INTEGER ']'       { ([mj AnnOpenS $1,mj AnnVal $2,mj AnnCloseS $3]-                                  ,ActiveAfter  (getINTEGERs $2) (fromInteger (il_value (getINTEGER $2)))) }-        | '[' rule_activation_marker INTEGER ']'-                                { ($2++[mj AnnOpenS $1,mj AnnVal $3,mj AnnCloseS $4]-                                  ,ActiveBefore (getINTEGERs $3) (fromInteger (il_value (getINTEGER $3)))) }---------------------------------------------------------------------------------- Expressions--quasiquote :: { Located (HsSplice GhcPs) }-        : TH_QUASIQUOTE   { let { loc = getLoc $1-                                ; ITquasiQuote (quoter, quote, quoteSpan) = unLoc $1-                                ; quoterId = mkUnqual varName quoter }-                            in sL1 $1 (mkHsQuasiQuote quoterId (mkSrcSpanPs quoteSpan) quote) }-        | TH_QQUASIQUOTE  { let { loc = getLoc $1-                                ; ITqQuasiQuote (qual, quoter, quote, quoteSpan) = unLoc $1-                                ; quoterId = mkQual varName (qual, quoter) }-                            in sL1 $1 (mkHsQuasiQuote quoterId (mkSrcSpanPs quoteSpan) quote) }--exp   :: { ECP }-        : infixexp '::' ctype-                                { ECP $-                                   unECP $1 >>= \ $1 ->-                                   rejectPragmaPV $1 >>-                                   mkHsTySigPV (noAnnSrcSpan $ comb2Al $1 (reLoc $>)) $1 $3-                                          [(mu AnnDcolon $2)] }-        | infixexp '-<' exp     {% runPV (unECP $1) >>= \ $1 ->-                                   runPV (unECP $3) >>= \ $3 ->-                                   fmap ecpFromCmd $-                                   acsA (\cs -> sLLAA $1 $> $ HsCmdArrApp (EpAnn (glAR $1) (mu Annlarrowtail $2) cs) $1 $3-                                                        HsFirstOrderApp True) }-        | infixexp '>-' exp     {% runPV (unECP $1) >>= \ $1 ->-                                   runPV (unECP $3) >>= \ $3 ->-                                   fmap ecpFromCmd $-                                   acsA (\cs -> sLLAA $1 $> $ HsCmdArrApp (EpAnn (glAR $1) (mu Annrarrowtail $2) cs) $3 $1-                                                      HsFirstOrderApp False) }-        | infixexp '-<<' exp    {% runPV (unECP $1) >>= \ $1 ->-                                   runPV (unECP $3) >>= \ $3 ->-                                   fmap ecpFromCmd $-                                   acsA (\cs -> sLLAA $1 $> $ HsCmdArrApp (EpAnn (glAR $1) (mu AnnLarrowtail $2) cs) $1 $3-                                                      HsHigherOrderApp True) }-        | infixexp '>>-' exp    {% runPV (unECP $1) >>= \ $1 ->-                                   runPV (unECP $3) >>= \ $3 ->-                                   fmap ecpFromCmd $-                                   acsA (\cs -> sLLAA $1 $> $ HsCmdArrApp (EpAnn (glAR $1) (mu AnnRarrowtail $2) cs) $3 $1-                                                      HsHigherOrderApp False) }-        -- See Note [%shift: exp -> infixexp]-        | infixexp %shift       { $1 }-        | exp_prag(exp)         { $1 } -- See Note [Pragmas and operator fixity]--infixexp :: { ECP }-        : exp10 { $1 }-        | infixexp qop exp10p    -- See Note [Pragmas and operator fixity]-                               { ECP $-                                 superInfixOp $-                                 $2 >>= \ $2 ->-                                 unECP $1 >>= \ $1 ->-                                 unECP $3 >>= \ $3 ->-                                 rejectPragmaPV $1 >>-                                 (mkHsOpAppPV (comb2A (reLoc $1) $3) $1 $2 $3) }-                 -- AnnVal annotation for NPlusKPat, which discards the operator--exp10p :: { ECP }-  : exp10            { $1 }-  | exp_prag(exp10p) { $1 } -- See Note [Pragmas and operator fixity]--exp_prag(e) :: { ECP }-  : prag_e e  -- See Note [Pragmas and operator fixity]-      {% runPV (unECP $2) >>= \ $2 ->-         fmap ecpFromExp $-         return $ (reLocA $ sLLlA $1 $> $ HsPragE noExtField (unLoc $1) $2) }--exp10 :: { ECP }-        -- See Note [%shift: exp10 -> '-' fexp]-        : '-' fexp %shift               { ECP $-                                           unECP $2 >>= \ $2 ->-                                           mkHsNegAppPV (comb2A $1 $>) $2-                                                 [mj AnnMinus $1] }-        -- See Note [%shift: exp10 -> fexp]-        | fexp %shift                  { $1 }--optSemi :: { (Maybe EpaLocation,Bool) }-        : ';'         { (msemim $1,True) }-        | {- empty -} { (Nothing,False) }--{- Note [Pragmas and operator fixity]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-'prag_e' is an expression pragma, such as {-# SCC ... #-}.--It must be used with care, or else #15730 happens. Consider this infix-expression:--         1 / 2 / 2--There are two ways to parse it:--    1.   (1 / 2) / 2   =  0.25-    2.   1 / (2 / 2)   =  1.0--Due to the fixity of the (/) operator (assuming it comes from Prelude),-option 1 is the correct parse. However, in the past GHC's parser used to get-confused by the SCC annotation when it occurred in the middle of an infix-expression:--         1 / {-# SCC ann #-} 2 / 2    -- used to get parsed as option 2--There are several ways to address this issue, see GHC Proposal #176 for a-detailed exposition:--  https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0176-scc-parsing.rst--The accepted fix is to disallow pragmas that occur within infix expressions.-Infix expressions are assembled out of 'exp10', so 'exp10' must not accept-pragmas. Instead, we accept them in exactly two places:--* at the start of an expression or a parenthesized subexpression:--    f = {-# SCC ann #-} 1 / 2 / 2          -- at the start of the expression-    g = 5 + ({-# SCC ann #-} 1 / 2 / 2)    -- at the start of a parenthesized subexpression--* immediately after the last operator:--    f = 1 / 2 / {-# SCC ann #-} 2--In both cases, the parse does not depend on operator fixity. The second case-may sound unnecessary, but it's actually needed to support a common idiom:--    f $ {-# SCC ann $-} ...---}-prag_e :: { Located (HsPragE GhcPs) }-      : '{-# SCC' STRING '#-}'      {% do { scc <- getSCC $2-                                          ; acs (\cs -> (sLL $1 $>-                                             (HsPragSCC-                                                (EpAnn (glR $1) (AnnPragma (mo $1) (mc $3) [mj AnnValStr $2]) cs)-                                                (getSCC_PRAGs $1)-                                                (StringLiteral (getSTRINGs $2) scc Nothing))))} }-      | '{-# SCC' VARID  '#-}'      {% acs (\cs -> (sLL $1 $>-                                             (HsPragSCC-                                               (EpAnn (glR $1) (AnnPragma (mo $1) (mc $3) [mj AnnVal $2]) cs)-                                               (getSCC_PRAGs $1)-                                               (StringLiteral NoSourceText (getVARID $2) Nothing)))) }--fexp    :: { ECP }-        : fexp aexp                  { ECP $-                                          superFunArg $-                                          unECP $1 >>= \ $1 ->-                                          unECP $2 >>= \ $2 ->-                                          mkHsAppPV (noAnnSrcSpan $ comb2A (reLoc $1) $>) $1 $2 }--        -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer-        | fexp PREFIX_AT atype       { ECP $-                                        unECP $1 >>= \ $1 ->-                                        mkHsAppTypePV (noAnnSrcSpan $ comb2 (reLoc $1) (reLoc $>)) $1 (getLoc $2) $3 }--        | 'static' aexp              {% runPV (unECP $2) >>= \ $2 ->-                                        fmap ecpFromExp $-                                        acsA (\cs -> sLL $1 (reLoc $>) $ HsStatic (EpAnn (glR $1) [mj AnnStatic $1] cs) $2) }--        | aexp                       { $1 }--aexp    :: { ECP }-        -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer-        : qvar TIGHT_INFIX_AT aexp-                                { ECP $-                                   unECP $3 >>= \ $3 ->-                                     mkHsAsPatPV (comb2 (reLocN $1) (reLoc $>)) $1 $3 [mj AnnAt $2] }---        -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer-        | PREFIX_TILDE aexp     { ECP $-                                   unECP $2 >>= \ $2 ->-                                   mkHsLazyPatPV (comb2 $1 (reLoc $>)) $2 [mj AnnTilde $1] }-        | PREFIX_BANG aexp      { ECP $-                                   unECP $2 >>= \ $2 ->-                                   mkHsBangPatPV (comb2 $1 (reLoc $>)) $2 [mj AnnBang $1] }-        | PREFIX_MINUS aexp     { ECP $-                                   unECP $2 >>= \ $2 ->-                                   mkHsNegAppPV (comb2A $1 $>) $2 [mj AnnMinus $1] }--        | '\\' apat apats '->' exp-                   {  ECP $-                      unECP $5 >>= \ $5 ->-                      mkHsLamPV (comb2 $1 (reLoc $>)) (\cs -> mkMatchGroup FromSource-                            (reLocA $ sLLlA $1 $>-                            [reLocA $ sLLlA $1 $>-                                         $ Match { m_ext = EpAnn (glR $1) [mj AnnLam $1] cs-                                                 , m_ctxt = LambdaExpr-                                                 , m_pats = $2:$3-                                                 , m_grhss = unguardedGRHSs (comb2 $4 (reLoc $5)) $5 (EpAnn (glR $4) (GrhsAnn Nothing (mu AnnRarrow $4)) emptyComments) }])) }-        | 'let' binds 'in' exp          {  ECP $-                                           unECP $4 >>= \ $4 ->-                                           mkHsLetPV (comb2A $1 $>) (unLoc $2) $4-                                                 (AnnsLet (glAA $1) (glAA $3)) }-        | '\\' 'lcase' altslist-            {  ECP $ $3 >>= \ $3 ->-                 mkHsLamCasePV (comb2 $1 (reLoc $>)) $3 [mj AnnLam $1,mj AnnCase $2] }-        | 'if' exp optSemi 'then' exp optSemi 'else' exp-                         {% runPV (unECP $2) >>= \ ($2 :: LHsExpr GhcPs) ->-                            return $ ECP $-                              unECP $5 >>= \ $5 ->-                              unECP $8 >>= \ $8 ->-                              mkHsIfPV (comb2A $1 $>) $2 (snd $3) $5 (snd $6) $8-                                    (AnnsIf-                                      { aiIf = glAA $1-                                      , aiThen = glAA $4-                                      , aiElse = glAA $7-                                      , aiThenSemi = fst $3-                                      , aiElseSemi = fst $6})}--        | 'if' ifgdpats                 {% hintMultiWayIf (getLoc $1) >>= \_ ->-                                           fmap ecpFromExp $-                                           acsA (\cs -> sLL $1 $> $ HsMultiIf (EpAnn (glR $1) (mj AnnIf $1:(fst $ unLoc $2)) cs)-                                                     (reverse $ snd $ unLoc $2)) }-        | 'case' exp 'of' altslist    {% runPV (unECP $2) >>= \ ($2 :: LHsExpr GhcPs) ->-                                         return $ ECP $-                                           $4 >>= \ $4 ->-                                           mkHsCasePV (comb3 $1 $3 (reLoc $4)) $2 $4-                                                (EpAnnHsCase (glAA $1) (glAA $3) []) }-        -- QualifiedDo.-        | DO  stmtlist               {% do-                                      hintQualifiedDo $1-                                      return $ ECP $-                                        $2 >>= \ $2 ->-                                        mkHsDoPV (comb2A $1 $2)-                                                 (fmap mkModuleNameFS (getDO $1))-                                                 $2-                                                 (AnnList (Just $ glAR $2) Nothing Nothing [mj AnnDo $1] []) }-        | MDO stmtlist             {% hintQualifiedDo $1 >> runPV $2 >>= \ $2 ->-                                       fmap ecpFromExp $-                                       acsA (\cs -> L (comb2A $1 $2)-                                              (mkHsDoAnns (MDoExpr $-                                                          fmap mkModuleNameFS (getMDO $1))-                                                          $2-                                           (EpAnn (glR $1) (AnnList (Just $ glAR $2) Nothing Nothing [mj AnnMdo $1] []) cs) )) }-        | 'proc' aexp '->' exp-                       {% (checkPattern <=< runPV) (unECP $2) >>= \ p ->-                           runPV (unECP $4) >>= \ $4@cmd ->-                           fmap ecpFromExp $-                           acsA (\cs -> sLLlA $1 $> $ HsProc (EpAnn (glR $1) [mj AnnProc $1,mu AnnRarrow $3] cs) p (sLLlA $1 $> $ HsCmdTop noExtField cmd)) }--        | aexp1                 { $1 }--aexp1   :: { ECP }-        : aexp1 '{' fbinds '}' { ECP $-                                   getBit OverloadedRecordUpdateBit >>= \ overloaded ->-                                   unECP $1 >>= \ $1 ->-                                   $3 >>= \ $3 ->-                                   mkHsRecordPV overloaded (comb2 (reLoc $1) $>) (comb2 $2 $4) $1 $3-                                        [moc $2,mcc $4]-                               }--        -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer-        | aexp1 TIGHT_INFIX_PROJ field-            {% runPV (unECP $1) >>= \ $1 ->-               fmap ecpFromExp $ acsa (\cs ->-                 let fl = sLL $2 $> (HsFieldLabel ((EpAnn (glR $2) (AnnFieldLabel (Just $ glAA $2)) emptyComments)) $3) in-                 mkRdrGetField (noAnnSrcSpan $ comb2 (reLoc $1) $>) $1 fl (EpAnn (glAR $1) NoEpAnns cs))  }---        | aexp2                { $1 }--aexp2   :: { ECP }-        : qvar                          { ECP $ mkHsVarPV $! $1 }-        | qcon                          { ECP $ mkHsVarPV $! $1 }-        -- See Note [%shift: aexp2 -> ipvar]-        | ipvar %shift                  {% acsExpr (\cs -> sL1a $1 (HsIPVar (comment (glRR $1) cs) $! unLoc $1)) }-        | overloaded_label              {% acsExpr (\cs -> sL1a $1 (HsOverLabel (comment (glRR $1) cs) $! unLoc $1)) }-        | literal                       { ECP $ pvA (mkHsLitPV $! $1) }--- This will enable overloaded strings permanently.  Normally the renamer turns HsString--- into HsOverLit when -foverloaded-strings is on.---      | STRING    { sL (getLoc $1) (HsOverLit $! mkHsIsString (getSTRINGs $1)---                                       (getSTRING $1) noExtField) }-        | INTEGER   { ECP $ pvA $ mkHsOverLitPV (sL1 $1 $ mkHsIntegral   (getINTEGER  $1)) }-        | RATIONAL  { ECP $ pvA $ mkHsOverLitPV (sL1 $1 $ mkHsFractional (getRATIONAL $1)) }--        -- N.B.: sections get parsed by these next two productions.-        -- This allows you to write, e.g., '(+ 3, 4 -)', which isn't-        -- correct Haskell (you'd have to write '((+ 3), (4 -))')-        -- but the less cluttered version fell out of having texps.-        | '(' texp ')'                  { ECP $-                                           unECP $2 >>= \ $2 ->-                                           mkHsParPV (comb2 $1 $>) $2 (AnnParen AnnParens (glAA $1) (glAA $3)) }-        | '(' tup_exprs ')'             { ECP $-                                           $2 >>= \ $2 ->-                                           mkSumOrTuplePV (noAnnSrcSpan $ comb2 $1 $>) Boxed $2-                                                [mop $1,mcp $3]}--        -- This case is only possible when 'OverloadedRecordDotBit' is enabled.-        | '(' projection ')'            { ECP $-                                            acsA (\cs -> sLL $1 $> $ mkRdrProjection (NE.reverse (unLoc $2)) (EpAnn (glR $1) (AnnProjection (glAA $1) (glAA $3)) cs))-                                            >>= ecpFromExp'-                                        }--        | '(#' texp '#)'                { ECP $-                                           unECP $2 >>= \ $2 ->-                                           mkSumOrTuplePV (noAnnSrcSpan $ comb2 $1 $>) Unboxed (Tuple [Right $2])-                                                 [moh $1,mch $3] }-        | '(#' tup_exprs '#)'           { ECP $-                                           $2 >>= \ $2 ->-                                           mkSumOrTuplePV (noAnnSrcSpan $ comb2 $1 $>) Unboxed $2-                                                [moh $1,mch $3] }--        | '[' list ']'      { ECP $ $2 (comb2 $1 $>) (mos $1,mcs $3) }-        | '_'               { ECP $ pvA $ mkHsWildCardPV (getLoc $1) }--        -- Template Haskell Extension-        | splice_untyped { ECP $ pvA $ mkHsSplicePV $1 }-        | splice_typed   { ecpFromExp $ mapLoc (HsSpliceE noAnn) (reLocA $1) }--        | SIMPLEQUOTE  qvar     {% fmap ecpFromExp $ acsA (\cs -> sLL $1 (reLocN $>) $ HsBracket (EpAnn (glR $1) [mj AnnSimpleQuote $1] cs) (VarBr noExtField True  $2)) }-        | SIMPLEQUOTE  qcon     {% fmap ecpFromExp $ acsA (\cs -> sLL $1 (reLocN $>) $ HsBracket (EpAnn (glR $1) [mj AnnSimpleQuote $1] cs) (VarBr noExtField True  $2)) }-        | TH_TY_QUOTE tyvar     {% fmap ecpFromExp $ acsA (\cs -> sLL $1 (reLocN $>) $ HsBracket (EpAnn (glR $1) [mj AnnThTyQuote $1  ] cs) (VarBr noExtField False $2)) }-        | TH_TY_QUOTE gtycon    {% fmap ecpFromExp $ acsA (\cs -> sLL $1 (reLocN $>) $ HsBracket (EpAnn (glR $1) [mj AnnThTyQuote $1  ] cs) (VarBr noExtField False $2)) }-        -- See Note [%shift: aexp2 -> TH_TY_QUOTE]-        | TH_TY_QUOTE %shift    {% reportEmptyDoubleQuotes (getLoc $1) }-        | '[|' exp '|]'       {% runPV (unECP $2) >>= \ $2 ->-                                 fmap ecpFromExp $-                                 acsA (\cs -> sLL $1 $> $ HsBracket (EpAnn (glR $1) (if (hasE $1) then [mj AnnOpenE $1, mu AnnCloseQ $3]-                                                                                         else [mu AnnOpenEQ $1,mu AnnCloseQ $3]) cs) (ExpBr noExtField $2)) }-        | '[||' exp '||]'     {% runPV (unECP $2) >>= \ $2 ->-                                 fmap ecpFromExp $-                                 acsA (\cs -> sLL $1 $> $ HsBracket (EpAnn (glR $1) (if (hasE $1) then [mj AnnOpenE $1,mc $3] else [mo $1,mc $3]) cs) (TExpBr noExtField $2)) }-        | '[t|' ktype '|]'    {% fmap ecpFromExp $-                                 acsA (\cs -> sLL $1 $> $ HsBracket (EpAnn (glR $1) [mo $1,mu AnnCloseQ $3] cs) (TypBr noExtField $2)) }-        | '[p|' infixexp '|]' {% (checkPattern <=< runPV) (unECP $2) >>= \p ->-                                      fmap ecpFromExp $-                                      acsA (\cs -> sLL $1 $> $ HsBracket (EpAnn (glR $1) [mo $1,mu AnnCloseQ $3] cs) (PatBr noExtField p)) }-        | '[d|' cvtopbody '|]' {% fmap ecpFromExp $-                                  acsA (\cs -> sLL $1 $> $ HsBracket (EpAnn (glR $1) (mo $1:mu AnnCloseQ $3:fst $2) cs) (DecBrL noExtField (snd $2))) }-        | quasiquote          { ECP $ pvA $ mkHsSplicePV $1 }--        -- arrow notation extension-        | '(|' aexp cmdargs '|)'  {% runPV (unECP $2) >>= \ $2 ->-                                      fmap ecpFromCmd $-                                      acsA (\cs -> sLL $1 $> $ HsCmdArrForm (EpAnn (glR $1) (AnnList (Just $ glR $1) (Just $ mu AnnOpenB $1) (Just $ mu AnnCloseB $4) [] []) cs) $2 Prefix-                                                           Nothing (reverse $3)) }--projection :: { Located (NonEmpty (Located (HsFieldLabel GhcPs))) }-projection-        -- See Note [Whitespace-sensitive operator parsing] in GHC.Parsing.Lexer-        : projection TIGHT_INFIX_PROJ field-                             {% acs (\cs -> sLL $1 $> ((sLL $2 $> $ HsFieldLabel (EpAnn (glR $1) (AnnFieldLabel (Just $ glAA $2)) cs) $3) `NE.cons` unLoc $1)) }-        | PREFIX_PROJ field  {% acs (\cs -> sLL $1 $> ((sLL $1 $> $ HsFieldLabel (EpAnn (glR $1) (AnnFieldLabel (Just $ glAA $1)) cs) $2) :| [])) }--splice_exp :: { LHsExpr GhcPs }-        : splice_untyped { mapLoc (HsSpliceE noAnn) (reLocA $1) }-        | splice_typed   { mapLoc (HsSpliceE noAnn) (reLocA $1) }--splice_untyped :: { Located (HsSplice GhcPs) }-        -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer-        : PREFIX_DOLLAR aexp2   {% runPV (unECP $2) >>= \ $2 ->-                                   acs (\cs -> sLLlA $1 $> $ mkUntypedSplice (EpAnn (glR $1) [mj AnnDollar $1] cs) DollarSplice $2) }--splice_typed :: { Located (HsSplice GhcPs) }-        -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer-        : PREFIX_DOLLAR_DOLLAR aexp2-                                {% runPV (unECP $2) >>= \ $2 ->-                                   acs (\cs -> sLLlA $1 $> $ mkTypedSplice (EpAnn (glR $1) [mj AnnDollarDollar $1] cs) DollarSplice $2) }--cmdargs :: { [LHsCmdTop GhcPs] }-        : cmdargs acmd                  { $2 : $1 }-        | {- empty -}                   { [] }--acmd    :: { LHsCmdTop GhcPs }-        : aexp                  {% runPV (unECP $1) >>= \ (cmd :: LHsCmd GhcPs) ->-                                   runPV (checkCmdBlockArguments cmd) >>= \ _ ->-                                   return (sL1A cmd $ HsCmdTop noExtField cmd) }--cvtopbody :: { ([AddEpAnn],[LHsDecl GhcPs]) }-        :  '{'            cvtopdecls0 '}'      { ([mj AnnOpenC $1-                                                  ,mj AnnCloseC $3],$2) }-        |      vocurly    cvtopdecls0 close    { ([],$2) }--cvtopdecls0 :: { [LHsDecl GhcPs] }-        : topdecls_semi         { cvTopDecls $1 }-        | topdecls              { cvTopDecls $1 }---------------------------------------------------------------------------------- Tuple expressions---- "texp" is short for tuple expressions:--- things that can appear unparenthesized as long as they're--- inside parens or delimited by commas-texp :: { ECP }-        : exp                           { $1 }--        -- Note [Parsing sections]-        -- ~~~~~~~~~~~~~~~~~~~~~~~-        -- We include left and right sections here, which isn't-        -- technically right according to the Haskell standard.-        -- For example (3 +, True) isn't legal.-        -- However, we want to parse bang patterns like-        --      (!x, !y)-        -- and it's convenient to do so here as a section-        -- Then when converting expr to pattern we unravel it again-        -- Meanwhile, the renamer checks that real sections appear-        -- inside parens.-        | infixexp qop-                             {% runPV (unECP $1) >>= \ $1 ->-                                runPV (rejectPragmaPV $1) >>-                                runPV $2 >>= \ $2 ->-                                return $ ecpFromExp $-                                reLocA $ sLL (reLoc $1) (reLocN $>) $ SectionL noAnn $1 (n2l $2) }-        | qopm infixexp      { ECP $-                                superInfixOp $-                                unECP $2 >>= \ $2 ->-                                $1 >>= \ $1 ->-                                pvA $ mkHsSectionR_PV (comb2 (reLocN $1) (reLoc $>)) (n2l $1) $2 }--       -- View patterns get parenthesized above-        | exp '->' texp   { ECP $-                             unECP $1 >>= \ $1 ->-                             unECP $3 >>= \ $3 ->-                             mkHsViewPatPV (comb2 (reLoc $1) (reLoc $>)) $1 $3 [mu AnnRarrow $2] }---- Always at least one comma or bar.--- Though this can parse just commas (without any expressions), it won't--- in practice, because (,,,) is parsed as a name. See Note [ExplicitTuple]--- in GHC.Hs.Expr.-tup_exprs :: { forall b. DisambECP b => PV (SumOrTuple b) }-           : texp commas_tup_tail-                           { unECP $1 >>= \ $1 ->-                             $2 >>= \ $2 ->-                             do { t <- amsA $1 [AddCommaAnn (EpaSpan $ rs $ fst $2)]-                                ; return (Tuple (Right t : snd $2)) } }-           | commas tup_tail-                 { $2 >>= \ $2 ->-                   do { let {cos = map (\ll -> (Left (EpAnn (anc $ rs ll) (EpaSpan $ rs ll) emptyComments))) (fst $1) }-                      ; return (Tuple (cos ++ $2)) } }--           | texp bars   { unECP $1 >>= \ $1 -> return $-                            (Sum 1  (snd $2 + 1) $1 [] (fst $2)) }--           | bars texp bars0-                { unECP $2 >>= \ $2 -> return $-                  (Sum (snd $1 + 1) (snd $1 + snd $3 + 1) $2 (fst $1) (fst $3)) }---- Always starts with commas; always follows an expr-commas_tup_tail :: { forall b. DisambECP b => PV (SrcSpan,[Either (EpAnn EpaLocation) (LocatedA b)]) }-commas_tup_tail : commas tup_tail-        { $2 >>= \ $2 ->-          do { let {cos = map (\l -> (Left (EpAnn (anc $ rs l) (EpaSpan $ rs l) emptyComments))) (tail $ fst $1) }-             ; return ((head $ fst $1, cos ++ $2)) } }---- Always follows a comma-tup_tail :: { forall b. DisambECP b => PV [Either (EpAnn EpaLocation) (LocatedA b)] }-          : texp commas_tup_tail { unECP $1 >>= \ $1 ->-                                   $2 >>= \ $2 ->-                                   do { t <- amsA $1 [AddCommaAnn (EpaSpan $ rs $ fst $2)]-                                      ; return (Right t : snd $2) } }-          | texp                 { unECP $1 >>= \ $1 ->-                                   return [Right $1] }-          -- See Note [%shift: tup_tail -> {- empty -}]-          | {- empty -} %shift   { return [Left noAnn] }---------------------------------------------------------------------------------- List expressions---- The rules below are little bit contorted to keep lexps left-recursive while--- avoiding another shift/reduce-conflict.--- Never empty.-list :: { forall b. DisambECP b => SrcSpan -> (AddEpAnn, AddEpAnn) -> PV (LocatedA b) }-        : texp    { \loc (ao,ac) -> unECP $1 >>= \ $1 ->-                            mkHsExplicitListPV loc [$1] (AnnList Nothing (Just ao) (Just ac) [] []) }-        | lexps   { \loc (ao,ac) -> $1 >>= \ $1 ->-                            mkHsExplicitListPV loc (reverse $1) (AnnList Nothing (Just ao) (Just ac) [] []) }-        | texp '..'  { \loc (ao,ac) -> unECP $1 >>= \ $1 ->-                                  acsA (\cs -> L loc $ ArithSeq (EpAnn (spanAsAnchor loc) [ao,mj AnnDotdot $2,ac] cs) Nothing (From $1))-                                      >>= ecpFromExp' }-        | texp ',' exp '..' { \loc (ao,ac) ->-                                   unECP $1 >>= \ $1 ->-                                   unECP $3 >>= \ $3 ->-                                   acsA (\cs -> L loc $ ArithSeq (EpAnn (spanAsAnchor loc) [ao,mj AnnComma $2,mj AnnDotdot $4,ac] cs) Nothing (FromThen $1 $3))-                                       >>= ecpFromExp' }-        | texp '..' exp  { \loc (ao,ac) ->-                                   unECP $1 >>= \ $1 ->-                                   unECP $3 >>= \ $3 ->-                                   acsA (\cs -> L loc $ ArithSeq (EpAnn (spanAsAnchor loc) [ao,mj AnnDotdot $2,ac] cs) Nothing (FromTo $1 $3))-                                       >>= ecpFromExp' }-        | texp ',' exp '..' exp { \loc (ao,ac) ->-                                   unECP $1 >>= \ $1 ->-                                   unECP $3 >>= \ $3 ->-                                   unECP $5 >>= \ $5 ->-                                   acsA (\cs -> L loc $ ArithSeq (EpAnn (spanAsAnchor loc) [ao,mj AnnComma $2,mj AnnDotdot $4,ac] cs) Nothing (FromThenTo $1 $3 $5))-                                       >>= ecpFromExp' }-        | texp '|' flattenedpquals-             { \loc (ao,ac) ->-                checkMonadComp >>= \ ctxt ->-                unECP $1 >>= \ $1 -> do { t <- addTrailingVbarA $1 (gl $2)-                ; acsA (\cs -> L loc $ mkHsCompAnns ctxt (unLoc $3) t (EpAnn (spanAsAnchor loc) (AnnList Nothing (Just ao) (Just ac) [] []) cs))-                    >>= ecpFromExp' } }--lexps :: { forall b. DisambECP b => PV [LocatedA b] }-        : lexps ',' texp           { $1 >>= \ $1 ->-                                     unECP $3 >>= \ $3 ->-                                     case $1 of-                                       (h:t) -> do-                                         h' <- addTrailingCommaA h (gl $2)-                                         return (((:) $! $3) $! (h':t)) }-        | texp ',' texp             { unECP $1 >>= \ $1 ->-                                      unECP $3 >>= \ $3 ->-                                      do { h <- addTrailingCommaA $1 (gl $2)-                                         ; return [$3,h] }}---------------------------------------------------------------------------------- List Comprehensions--flattenedpquals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] }-    : pquals   { case (unLoc $1) of-                    [qs] -> sL1 $1 qs-                    -- We just had one thing in our "parallel" list so-                    -- we simply return that thing directly--                    qss -> sL1 $1 [sL1a $1 $ ParStmt noExtField [ParStmtBlock noExtField qs [] noSyntaxExpr |-                                            qs <- qss]-                                            noExpr noSyntaxExpr]-                    -- We actually found some actual parallel lists so-                    -- we wrap them into as a ParStmt-                }--pquals :: { Located [[LStmt GhcPs (LHsExpr GhcPs)]] }-    : squals '|' pquals-                     {% case unLoc $1 of-                          (h:t) -> do-                            h' <- addTrailingVbarA h (gl $2)-                            return (sLL $1 $> (reverse (h':t) : unLoc $3)) }-    | squals         { L (getLoc $1) [reverse (unLoc $1)] }--squals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] }   -- In reverse order, because the last-                                        -- one can "grab" the earlier ones-    : squals ',' transformqual-             {% case unLoc $1 of-                  (h:t) -> do-                    h' <- addTrailingCommaA h (gl $2)-                    return (sLL $1 $> [sLLa $1 $> ((unLoc $3) (glRR $1) (reverse (h':t)))]) }-    | squals ',' qual-             {% runPV $3 >>= \ $3 ->-                case unLoc $1 of-                  (h:t) -> do-                    h' <- addTrailingCommaA h (gl $2)-                    return (sLL $1 (reLoc $>) ($3 : (h':t))) }-    | transformqual        {% return (sLL $1 $> [L (getLocAnn $1) ((unLoc $1) (glRR $1) [])]) }-    | qual                               {% runPV $1 >>= \ $1 ->-                                            return $ sL1A $1 [$1] }---  | transformquals1 ',' '{|' pquals '|}'   { sLL $1 $> ($4 : unLoc $1) }---  | '{|' pquals '|}'                       { sL1 $1 [$2] }---- It is possible to enable bracketing (associating) qualifier lists--- by uncommenting the lines with {| |} above. Due to a lack of--- consensus on the syntax, this feature is not being used until we--- get user demand.--transformqual :: { Located (RealSrcSpan -> [LStmt GhcPs (LHsExpr GhcPs)] -> Stmt GhcPs (LHsExpr GhcPs)) }-                        -- Function is applied to a list of stmts *in order*-    : 'then' exp              {% runPV (unECP $2) >>= \ $2 ->-                                 acs (\cs->-                                 sLLlA $1 $> (\r ss -> (mkTransformStmt (EpAnn (anc r) [mj AnnThen $1] cs) ss $2))) }-    | 'then' exp 'by' exp     {% runPV (unECP $2) >>= \ $2 ->-                                 runPV (unECP $4) >>= \ $4 ->-                                 acs (\cs -> sLLlA $1 $> (-                                                     \r ss -> (mkTransformByStmt (EpAnn (anc r) [mj AnnThen $1,mj AnnBy $3] cs) ss $2 $4))) }-    | 'then' 'group' 'using' exp-            {% runPV (unECP $4) >>= \ $4 ->-               acs (\cs -> sLLlA $1 $> (-                                   \r ss -> (mkGroupUsingStmt (EpAnn (anc r) [mj AnnThen $1,mj AnnGroup $2,mj AnnUsing $3] cs) ss $4))) }--    | 'then' 'group' 'by' exp 'using' exp-            {% runPV (unECP $4) >>= \ $4 ->-               runPV (unECP $6) >>= \ $6 ->-               acs (\cs -> sLLlA $1 $> (-                                   \r ss -> (mkGroupByUsingStmt (EpAnn (anc r) [mj AnnThen $1,mj AnnGroup $2,mj AnnBy $3,mj AnnUsing $5] cs) ss $4 $6))) }---- Note that 'group' is a special_id, which means that you can enable--- TransformListComp while still using Data.List.group. However, this--- introduces a shift/reduce conflict. Happy chooses to resolve the conflict--- in by choosing the "group by" variant, which is what we want.---------------------------------------------------------------------------------- Guards--guardquals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] }-    : guardquals1           { L (getLoc $1) (reverse (unLoc $1)) }--guardquals1 :: { Located [LStmt GhcPs (LHsExpr GhcPs)] }-    : guardquals1 ',' qual  {% runPV $3 >>= \ $3 ->-                               case unLoc $1 of-                                 (h:t) -> do-                                   h' <- addTrailingCommaA h (gl $2)-                                   return (sLL $1 (reLoc $>) ($3 : (h':t))) }-    | qual                  {% runPV $1 >>= \ $1 ->-                               return $ sL1A $1 [$1] }---------------------------------------------------------------------------------- Case alternatives--altslist :: { forall b. DisambECP b => PV (LocatedL [LMatch GhcPs (LocatedA b)]) }-        : '{'            alts '}'  { $2 >>= \ $2 -> amsrl-                                     (sLL $1 $> (reverse (snd $ unLoc $2)))-                                               (AnnList (Just $ glR $2) (Just $ moc $1) (Just $ mcc $3) (fst $ unLoc $2) []) }-        |     vocurly    alts  close { $2 >>= \ $2 -> amsrl-                                       (L (getLoc $2) (reverse (snd $ unLoc $2)))-                                        (AnnList (Just $ glR $2) Nothing Nothing (fst $ unLoc $2) []) }-        | '{'                 '}'    { amsrl (sLL $1 $> []) (AnnList Nothing (Just $ moc $1) (Just $ mcc $2) [] []) }-        |     vocurly          close { return $ noLocA [] }--alts    :: { forall b. DisambECP b => PV (Located ([AddEpAnn],[LMatch GhcPs (LocatedA b)])) }-        : alts1                    { $1 >>= \ $1 -> return $-                                     sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }-        | ';' alts                 { $2 >>= \ $2 -> return $-                                     sLL $1 $> (((mz AnnSemi $1) ++ (fst $ unLoc $2) )-                                               ,snd $ unLoc $2) }--alts1   :: { forall b. DisambECP b => PV (Located ([AddEpAnn],[LMatch GhcPs (LocatedA b)])) }-        : alts1 ';' alt         { $1 >>= \ $1 ->-                                  $3 >>= \ $3 ->-                                     case snd $ unLoc $1 of-                                       [] -> return (sLL $1 (reLoc $>) ((fst $ unLoc $1) ++ (mz AnnSemi $2)-                                                                       ,[$3]))-                                       (h:t) -> do-                                         h' <- addTrailingSemiA h (gl $2)-                                         return (sLL $1 (reLoc $>) (fst $ unLoc $1,$3 : h' : t)) }-        | alts1 ';'             {  $1 >>= \ $1 ->-                                     case snd $ unLoc $1 of-                                       [] -> return (sLL $1 $> ((fst $ unLoc $1) ++ (mz AnnSemi $2)-                                                                       ,[]))-                                       (h:t) -> do-                                         h' <- addTrailingSemiA h (gl $2)-                                         return (sLL $1 $> (fst $ unLoc $1, h' : t)) }-        | alt                   { $1 >>= \ $1 -> return $ sL1 (reLoc $1) ([],[$1]) }--alt     :: { forall b. DisambECP b => PV (LMatch GhcPs (LocatedA b)) }-           : pat alt_rhs  { $2 >>= \ $2 ->-                            acsA (\cs -> sLL (reLoc $1) $>-                                           (Match { m_ext = (EpAnn (glAR $1) [] cs)-                                                  , m_ctxt = CaseAlt-                                                  , m_pats = [$1]-                                                  , m_grhss = unLoc $2 }))}--alt_rhs :: { forall b. DisambECP b => PV (Located (GRHSs GhcPs (LocatedA b))) }-        : ralt wherebinds           { $1 >>= \alt ->-                                      do { let {L l (bs, csw) = adaptWhereBinds $2}-                                         ; acs (\cs -> sLL alt (L l bs) (GRHSs (cs Semi.<> csw) (unLoc alt) bs)) }}--ralt :: { forall b. DisambECP b => PV (Located [LGRHS GhcPs (LocatedA b)]) }-        : '->' exp            { unECP $2 >>= \ $2 ->-                                acs (\cs -> sLLlA $1 $> (unguardedRHS (EpAnn (glR $1) (GrhsAnn Nothing (mu AnnRarrow $1)) cs) (comb2 $1 (reLoc $2)) $2)) }-        | gdpats              { $1 >>= \gdpats ->-                                return $ sL1 gdpats (reverse (unLoc gdpats)) }--gdpats :: { forall b. DisambECP b => PV (Located [LGRHS GhcPs (LocatedA b)]) }-        : gdpats gdpat { $1 >>= \gdpats ->-                         $2 >>= \gdpat ->-                         return $ sLL gdpats gdpat (gdpat : unLoc gdpats) }-        | gdpat        { $1 >>= \gdpat -> return $ sL1 gdpat [gdpat] }---- layout for MultiWayIf doesn't begin with an open brace, because it's hard to--- generate the open brace in addition to the vertical bar in the lexer, and--- we don't need it.-ifgdpats :: { Located ([AddEpAnn],[LGRHS GhcPs (LHsExpr GhcPs)]) }-         : '{' gdpats '}'                 {% runPV $2 >>= \ $2 ->-                                             return $ sLL $1 $> ([moc $1,mcc $3],unLoc $2)  }-         |     gdpats close               {% runPV $1 >>= \ $1 ->-                                             return $ sL1 $1 ([],unLoc $1) }--gdpat   :: { forall b. DisambECP b => PV (LGRHS GhcPs (LocatedA b)) }-        : '|' guardquals '->' exp-                                   { unECP $4 >>= \ $4 ->-                                     acs (\cs -> sL (comb2A $1 $>) $ GRHS (EpAnn (glR $1) (GrhsAnn (Just $ glAA $1) (mu AnnRarrow $3)) cs) (unLoc $2) $4) }---- 'pat' recognises a pattern, including one with a bang at the top---      e.g.  "!x" or "!(x,y)" or "C a b" etc--- Bangs inside are parsed as infix operator applications, so that--- we parse them right when bang-patterns are off-pat     :: { LPat GhcPs }-pat     :  exp          {% (checkPattern <=< runPV) (unECP $1) }--bindpat :: { LPat GhcPs }-bindpat :  exp            {% -- See Note [Parser-Validator Hint] in GHC.Parser.PostProcess-                             checkPattern_hints [SuggestMissingDo]-                                              (unECP $1) }--apat   :: { LPat GhcPs }-apat    : aexp                  {% (checkPattern <=< runPV) (unECP $1) }--apats  :: { [LPat GhcPs] }-        : apat apats            { $1 : $2 }-        | {- empty -}           { [] }---------------------------------------------------------------------------------- Statement sequences--stmtlist :: { forall b. DisambECP b => PV (LocatedL [LocatedA (Stmt GhcPs (LocatedA b))]) }-        : '{'           stmts '}'       { $2 >>= \ $2 -> amsrl-                                          (sLL $1 $> (reverse $ snd $ unLoc $2)) (AnnList (Just $ glR $2) (Just $ moc $1) (Just $ mcc $3) (fromOL $ fst $ unLoc $2) []) }-        |     vocurly   stmts close     { $2 >>= \ $2 -> amsrl-                                          (L (gl $2) (reverse $ snd $ unLoc $2)) (AnnList (Just $ glR $2) Nothing Nothing (fromOL $ fst $ unLoc $2) []) }----      do { ;; s ; s ; ; s ;; }--- The last Stmt should be an expression, but that's hard to enforce--- here, because we need too much lookahead if we see do { e ; }--- So we use BodyStmts throughout, and switch the last one over--- in ParseUtils.checkDo instead--stmts :: { forall b. DisambECP b => PV (Located (OrdList AddEpAnn,[LStmt GhcPs (LocatedA b)])) }-        : stmts ';' stmt  { $1 >>= \ $1 ->-                            $3 >>= \ ($3 :: LStmt GhcPs (LocatedA b)) ->-                            case (snd $ unLoc $1) of-                              [] -> return (sLL $1 (reLoc $>) ((fst $ unLoc $1) `snocOL` (mj AnnSemi $2)-                                                     ,$3   : (snd $ unLoc $1)))-                              (h:t) -> do-                               { h' <- addTrailingSemiA h (gl $2)-                               ; return $ sLL $1 (reLoc $>) (fst $ unLoc $1,$3 :(h':t)) }}--        | stmts ';'     {  $1 >>= \ $1 ->-                           case (snd $ unLoc $1) of-                             [] -> return (sLL $1 $> ((fst $ unLoc $1) `snocOL` (mj AnnSemi $2),snd $ unLoc $1))-                             (h:t) -> do-                               { h' <- addTrailingSemiA h (gl $2)-                               ; return $ sL1 $1 (fst $ unLoc $1,h':t) }}-        | stmt                   { $1 >>= \ $1 ->-                                   return $ sL1A $1 (nilOL,[$1]) }-        | {- empty -}            { return $ noLoc (nilOL,[]) }----- For typing stmts at the GHCi prompt, where--- the input may consist of just comments.-maybe_stmt :: { Maybe (LStmt GhcPs (LHsExpr GhcPs)) }-        : stmt                          {% fmap Just (runPV $1) }-        | {- nothing -}                 { Nothing }---- For GHC API.-e_stmt :: { LStmt GhcPs (LHsExpr GhcPs) }-        : stmt                          {% runPV $1 }--stmt  :: { forall b. DisambECP b => PV (LStmt GhcPs (LocatedA b)) }-        : qual                          { $1 }-        | 'rec' stmtlist                {  $2 >>= \ $2 ->-                                           acsA (\cs -> (sLL $1 (reLoc $>) $ mkRecStmt-                                                 (EpAnn (glR $1) (hsDoAnn $1 $2 AnnRec) cs)-                                                  $2)) }--qual  :: { forall b. DisambECP b => PV (LStmt GhcPs (LocatedA b)) }-    : bindpat '<-' exp                   { unECP $3 >>= \ $3 ->-                                           acsA (\cs -> sLLlA (reLoc $1) $>-                                            $ mkPsBindStmt (EpAnn (glAR $1) [mu AnnLarrow $2] cs) $1 $3) }-    | exp                                { unECP $1 >>= \ $1 ->-                                           return $ sL1 $1 $ mkBodyStmt $1 }-    | 'let' binds                        { acsA (\cs -> (sLL $1 $>-                                                $ mkLetStmt (EpAnn (glR $1) [mj AnnLet $1] cs) (unLoc $2))) }---------------------------------------------------------------------------------- Record Field Update/Construction--fbinds  :: { forall b. DisambECP b => PV ([Fbind b], Maybe SrcSpan) }-        : fbinds1                       { $1 }-        | {- empty -}                   { return ([], Nothing) }--fbinds1 :: { forall b. DisambECP b => PV ([Fbind b], Maybe SrcSpan) }-        : fbind ',' fbinds1-                 { $1 >>= \ $1 ->-                   $3 >>= \ $3 -> do-                   h <- addTrailingCommaFBind $1 (gl $2)-                   return (case $3 of (flds, dd) -> (h : flds, dd)) }-        | fbind                         { $1 >>= \ $1 ->-                                          return ([$1], Nothing) }-        | '..'                          { return ([],   Just (getLoc $1)) }--fbind   :: { forall b. DisambECP b => PV (Fbind b) }-        : qvar '=' texp  { unECP $3 >>= \ $3 ->-                           fmap Left $ acsA (\cs -> sLL (reLocN $1) (reLoc $>) $ HsRecField (EpAnn (glNR $1) [mj AnnEqual $2] cs) (sL1N $1 $ mkFieldOcc $1) $3 False) }-                        -- RHS is a 'texp', allowing view patterns (#6038)-                        -- and, incidentally, sections.  Eg-                        -- f (R { x = show -> s }) = ...--        | qvar          { placeHolderPunRhs >>= \rhs ->-                          fmap Left $ acsa (\cs -> sL1a (reLocN $1) $ HsRecField (EpAnn (glNR $1) [] cs) (sL1N $1 $ mkFieldOcc $1) rhs True) }-                        -- In the punning case, use a place-holder-                        -- The renamer fills in the final value--        -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer-        -- AZ: need to pull out the let block into a helper-        | field TIGHT_INFIX_PROJ fieldToUpdate '=' texp-                        { do-                            let top = sL1 $1 $ HsFieldLabel noAnn $1-                                ((L lf (HsFieldLabel _ f)):t) = reverse (unLoc $3)-                                lf' = comb2 $2 (L lf ())-                                fields = top : L lf' (HsFieldLabel (EpAnn (spanAsAnchor lf') (AnnFieldLabel (Just $ glAA $2)) emptyComments) f) : t-                                final = last fields-                                l = comb2 $1 $3-                                isPun = False-                            $5 <- unECP $5-                            fmap Right $ mkHsProjUpdatePV (comb2 $1 (reLoc $5)) (L l fields) $5 isPun-                                            [mj AnnEqual $4]-                        }--        -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer-        -- AZ: need to pull out the let block into a helper-        | field TIGHT_INFIX_PROJ fieldToUpdate-                        { do-                            let top =  sL1 $1 $ HsFieldLabel noAnn $1-                                ((L lf (HsFieldLabel _ f)):t) = reverse (unLoc $3)-                                lf' = comb2 $2 (L lf ())-                                fields = top : L lf' (HsFieldLabel (EpAnn (spanAsAnchor lf') (AnnFieldLabel (Just $ glAA $2)) emptyComments) f) : t-                                final = last fields-                                l = comb2 $1 $3-                                isPun = True-                            var <- mkHsVarPV (L (noAnnSrcSpan $ getLoc final) (mkRdrUnqual . mkVarOcc . unpackFS . unLoc . hflLabel . unLoc $ final))-                            fmap Right $ mkHsProjUpdatePV l (L l fields) var isPun []-                        }--fieldToUpdate :: { Located [Located (HsFieldLabel GhcPs)] }-fieldToUpdate-        -- See Note [Whitespace-sensitive operator parsing] in Lexer.x-        : fieldToUpdate TIGHT_INFIX_PROJ field   {% getCommentsFor (getLoc $3) >>= \cs ->-                                                     return (sLL $1 $> ((sLL $2 $> (HsFieldLabel (EpAnn (glR $2) (AnnFieldLabel $ Just $ glAA $2) cs) $3)) : unLoc $1)) }-        | field       {% getCommentsFor (getLoc $1) >>= \cs ->-                        return (sL1 $1 [sL1 $1 (HsFieldLabel (EpAnn (glR $1) (AnnFieldLabel Nothing) cs) $1)]) }---------------------------------------------------------------------------------- Implicit Parameter Bindings--dbinds  :: { Located [LIPBind GhcPs] } -- reversed-        : dbinds ';' dbind-                      {% case unLoc $1 of-                           (h:t) -> do-                             h' <- addTrailingSemiA h (gl $2)-                             return (let { this = $3; rest = h':t }-                                in rest `seq` this `seq` sLL $1 (reLoc $>) (this : rest)) }-        | dbinds ';'  {% case unLoc $1 of-                           (h:t) -> do-                             h' <- addTrailingSemiA h (gl $2)-                             return (sLL $1 $> (h':t)) }-        | dbind                        { let this = $1 in this `seq` (sL1 (reLoc $1) [this]) }---      | {- empty -}                  { [] }--dbind   :: { LIPBind GhcPs }-dbind   : ipvar '=' exp                {% runPV (unECP $3) >>= \ $3 ->-                                          acsA (\cs -> sLLlA $1 $> (IPBind (EpAnn (glR $1) [mj AnnEqual $2] cs) (Left $1) $3)) }--ipvar   :: { Located HsIPName }-        : IPDUPVARID            { sL1 $1 (HsIPName (getIPDUPVARID $1)) }---------------------------------------------------------------------------------- Overloaded labels--overloaded_label :: { Located FastString }-        : LABELVARID          { sL1 $1 (getLABELVARID $1) }---------------------------------------------------------------------------------- Warnings and deprecations--name_boolformula_opt :: { LBooleanFormula (LocatedN RdrName) }-        : name_boolformula          { $1 }-        | {- empty -}               { noLocA mkTrue }--name_boolformula :: { LBooleanFormula (LocatedN RdrName) }-        : name_boolformula_and                      { $1 }-        | name_boolformula_and '|' name_boolformula-                           {% do { h <- addTrailingVbarL $1 (gl $2)-                                 ; return (reLocA $ sLLAA $1 $> (Or [h,$3])) } }--name_boolformula_and :: { LBooleanFormula (LocatedN RdrName) }-        : name_boolformula_and_list-                  { reLocA $ sLLAA (head $1) (last $1) (And ($1)) }--name_boolformula_and_list :: { [LBooleanFormula (LocatedN RdrName)] }-        : name_boolformula_atom                               { [$1] }-        | name_boolformula_atom ',' name_boolformula_and_list-            {% do { h <- addTrailingCommaL $1 (gl $2)-                  ; return (h : $3) } }--name_boolformula_atom :: { LBooleanFormula (LocatedN RdrName) }-        : '(' name_boolformula ')'  {% amsrl (sLL $1 $> (Parens $2))-                                      (AnnList Nothing (Just (mop $1)) (Just (mcp $3)) [] []) }-        | name_var                  { reLocA $ sL1N $1 (Var $1) }--namelist :: { Located [LocatedN RdrName] }-namelist : name_var              { sL1N $1 [$1] }-         | name_var ',' namelist {% do { h <- addTrailingCommaN $1 (gl $2)-                                       ; return (sLL (reLocN $1) $> (h : unLoc $3)) }}--name_var :: { LocatedN RdrName }-name_var : var { $1 }-         | con { $1 }---------------------------------------------- Data constructors--- There are two different productions here as lifted list constructors--- are parsed differently.--qcon_nowiredlist :: { LocatedN RdrName }-        : gen_qcon                     { $1 }-        | sysdcon_nolist               { L (getLoc $1) $ nameRdrName (dataConName (unLoc $1)) }--qcon :: { LocatedN RdrName }-  : gen_qcon              { $1}-  | sysdcon               { L (getLoc $1) $ nameRdrName (dataConName (unLoc $1)) }--gen_qcon :: { LocatedN RdrName }-  : qconid                { $1 }-  | '(' qconsym ')'       {% amsrn (sLL $1 $> (unLoc $2))-                                   (NameAnn NameParens (glAA $1) (glNRR $2) (glAA $3) []) }--con     :: { LocatedN RdrName }-        : conid                 { $1 }-        | '(' consym ')'        {% amsrn (sLL $1 $> (unLoc $2))-                                         (NameAnn NameParens (glAA $1) (glNRR $2) (glAA $3) []) }-        | sysdcon               { L (getLoc $1) $ nameRdrName (dataConName (unLoc $1)) }--con_list :: { Located [LocatedN RdrName] }-con_list : con                  { sL1N $1 [$1] }-         | con ',' con_list     {% do { h <- addTrailingCommaN $1 (gl $2)-                                      ; return (sLL (reLocN $1) $> (h : unLoc $3)) }}---- See Note [ExplicitTuple] in GHC.Hs.Expr-sysdcon_nolist :: { LocatedN DataCon }  -- Wired in data constructors-        : '(' ')'               {% amsrn (sLL $1 $> unitDataCon) (NameAnnOnly NameParens (glAA $1) (glAA $2) []) }-        | '(' commas ')'        {% amsrn (sLL $1 $> $ tupleDataCon Boxed (snd $2 + 1))-                                       (NameAnnCommas NameParens (glAA $1) (map (EpaSpan . realSrcSpan) (fst $2)) (glAA $3) []) }-        | '(#' '#)'             {% amsrn (sLL $1 $> $ unboxedUnitDataCon) (NameAnnOnly NameParensHash (glAA $1) (glAA $2) []) }-        | '(#' commas '#)'      {% amsrn (sLL $1 $> $ tupleDataCon Unboxed (snd $2 + 1))-                                       (NameAnnCommas NameParensHash (glAA $1) (map (EpaSpan . realSrcSpan) (fst $2)) (glAA $3) []) }---- See Note [Empty lists] in GHC.Hs.Expr-sysdcon :: { LocatedN DataCon }-        : sysdcon_nolist                 { $1 }-        | '[' ']'               {% amsrn (sLL $1 $> nilDataCon) (NameAnnOnly NameSquare (glAA $1) (glAA $2) []) }--conop :: { LocatedN RdrName }-        : consym                { $1 }-        | '`' conid '`'         {% amsrn (sLL $1 $> (unLoc $2))-                                           (NameAnn NameBackquotes (glAA $1) (glNRR $2) (glAA $3) []) }--qconop :: { LocatedN RdrName }-        : qconsym               { $1 }-        | '`' qconid '`'        {% amsrn (sLL $1 $> (unLoc $2))-                                           (NameAnn NameBackquotes (glAA $1) (glNRR $2) (glAA $3) []) }--------------------------------------------------------------------------------- Type constructors----- See Note [Unit tuples] in GHC.Hs.Type for the distinction--- between gtycon and ntgtycon-gtycon :: { LocatedN RdrName }  -- A "general" qualified tycon, including unit tuples-        : ntgtycon                     { $1 }-        | '(' ')'                      {% amsrn (sLL $1 $> $ getRdrName unitTyCon)-                                                 (NameAnnOnly NameParens (glAA $1) (glAA $2) []) }-        | '(#' '#)'                    {% amsrn (sLL $1 $> $ getRdrName unboxedUnitTyCon)-                                                 (NameAnnOnly NameParensHash (glAA $1) (glAA $2) []) }--ntgtycon :: { LocatedN RdrName }  -- A "general" qualified tycon, excluding unit tuples-        : oqtycon               { $1 }-        | '(' commas ')'        {% amsrn (sLL $1 $> $ getRdrName (tupleTyCon Boxed-                                                        (snd $2 + 1)))-                                       (NameAnnCommas NameParens (glAA $1) (map (EpaSpan . realSrcSpan) (fst $2)) (glAA $3) []) }-        | '(#' commas '#)'      {% amsrn (sLL $1 $> $ getRdrName (tupleTyCon Unboxed-                                                        (snd $2 + 1)))-                                       (NameAnnCommas NameParensHash (glAA $1) (map (EpaSpan . realSrcSpan) (fst $2)) (glAA $3) []) }-        | '(' '->' ')'          {% amsrn (sLL $1 $> $ getRdrName unrestrictedFunTyCon)-                                       (NameAnn NameParens (glAA $1) (glAA $2) (glAA $3) []) }-        | '[' ']'               {% amsrn (sLL $1 $> $ listTyCon_RDR)-                                       (NameAnnOnly NameSquare (glAA $1) (glAA $2) []) }--oqtycon :: { LocatedN RdrName }  -- An "ordinary" qualified tycon;-                                -- These can appear in export lists-        : qtycon                        { $1 }-        | '(' qtyconsym ')'             {% amsrn (sLL $1 $> (unLoc $2))-                                                  (NameAnn NameParens (glAA $1) (glNRR $2) (glAA $3) []) }--oqtycon_no_varcon :: { LocatedN RdrName }  -- Type constructor which cannot be mistaken-                                          -- for variable constructor in export lists-                                          -- see Note [Type constructors in export list]-        :  qtycon            { $1 }-        | '(' QCONSYM ')'    {% let { name :: Located RdrName-                                    ; name = sL1 $2 $! mkQual tcClsName (getQCONSYM $2) }-                                in amsrn (sLL $1 $> (unLoc name)) (NameAnn NameParens (glAA $1) (glAA $2) (glAA $3) []) }-        | '(' CONSYM ')'     {% let { name :: Located RdrName-                                    ; name = sL1 $2 $! mkUnqual tcClsName (getCONSYM $2) }-                                in amsrn (sLL $1 $> (unLoc name)) (NameAnn NameParens (glAA $1) (glAA $2) (glAA $3) []) }-        | '(' ':' ')'        {% let { name :: Located RdrName-                                    ; name = sL1 $2 $! consDataCon_RDR }-                                in amsrn (sLL $1 $> (unLoc name)) (NameAnn NameParens (glAA $1) (glAA $2) (glAA $3) []) }--{- Note [Type constructors in export list]-~~~~~~~~~~~~~~~~~~~~~-Mixing type constructors and data constructors in export lists introduces-ambiguity in grammar: e.g. (*) may be both a type constructor and a function.---XExplicitNamespaces allows to disambiguate by explicitly prefixing type-constructors with 'type' keyword.--This ambiguity causes reduce/reduce conflicts in parser, which are always-resolved in favour of data constructors. To get rid of conflicts we demand-that ambiguous type constructors (those, which are formed by the same-productions as variable constructors) are always prefixed with 'type' keyword.-Unambiguous type constructors may occur both with or without 'type' keyword.--Note that in the parser we still parse data constructors as type-constructors. As such, they still end up in the type constructor namespace-until after renaming when we resolve the proper namespace for each exported-child.--}--qtyconop :: { LocatedN RdrName } -- Qualified or unqualified-        -- See Note [%shift: qtyconop -> qtyconsym]-        : qtyconsym %shift              { $1 }-        | '`' qtycon '`'                {% amsrn (sLL $1 $> (unLoc $2))-                                                 (NameAnn NameBackquotes (glAA $1) (glNRR $2) (glAA $3) []) }--qtycon :: { LocatedN RdrName }   -- Qualified or unqualified-        : QCONID            { sL1n $1 $! mkQual tcClsName (getQCONID $1) }-        | tycon             { $1 }--tycon   :: { LocatedN RdrName }  -- Unqualified-        : CONID                   { sL1n $1 $! mkUnqual tcClsName (getCONID $1) }--qtyconsym :: { LocatedN RdrName }-        : QCONSYM            { sL1n $1 $! mkQual tcClsName (getQCONSYM $1) }-        | QVARSYM            { sL1n $1 $! mkQual tcClsName (getQVARSYM $1) }-        | tyconsym           { $1 }--tyconsym :: { LocatedN RdrName }-        : CONSYM                { sL1n $1 $! mkUnqual tcClsName (getCONSYM $1) }-        | VARSYM                { sL1n $1 $!-                                    -- See Note [eqTyCon (~) is built-in syntax] in GHC.Builtin.Types-                                    if getVARSYM $1 == fsLit "~"-                                      then eqTyCon_RDR-                                      else mkUnqual tcClsName (getVARSYM $1) }-        | ':'                   { sL1n $1 $! consDataCon_RDR }-        | '-'                   { sL1n $1 $! mkUnqual tcClsName (fsLit "-") }-        | '.'                   { sL1n $1 $! mkUnqual tcClsName (fsLit ".") }---- An "ordinary" unqualified tycon. See `oqtycon` for the qualified version.--- These can appear in `ANN type` declarations (#19374).-otycon :: { LocatedN RdrName }-        : tycon                 { $1 }-        | '(' tyconsym ')'      {% amsrn (sLL $1 $> (unLoc $2))-                                         (NameAnn NameParens (glAA $1) (glNRR $2) (glAA $3) []) }---------------------------------------------------------------------------------- Operators--op      :: { LocatedN RdrName }   -- used in infix decls-        : varop                 { $1 }-        | conop                 { $1 }-        | '->'                  { sL1n $1 $ getRdrName unrestrictedFunTyCon }--varop   :: { LocatedN RdrName }-        : varsym                { $1 }-        | '`' varid '`'         {% amsrn (sLL $1 $> (unLoc $2))-                                           (NameAnn NameBackquotes (glAA $1) (glNRR $2) (glAA $3) []) }--qop     :: { forall b. DisambInfixOp b => PV (LocatedN b) }   -- used in sections-        : qvarop                { mkHsVarOpPV $1 }-        | qconop                { mkHsConOpPV $1 }-        | hole_op               { pvN $1 }--qopm    :: { forall b. DisambInfixOp b => PV (LocatedN b) }   -- used in sections-        : qvaropm               { mkHsVarOpPV $1 }-        | qconop                { mkHsConOpPV $1 }-        | hole_op               { pvN $1 }--hole_op :: { forall b. DisambInfixOp b => PV (Located b) }   -- used in sections-hole_op : '`' '_' '`'           { mkHsInfixHolePV (comb2 $1 $>)-                                         (\cs -> EpAnn (glR $1) (EpAnnUnboundVar (glAA $1, glAA $3) (glAA $2)) cs) }--qvarop :: { LocatedN RdrName }-        : qvarsym               { $1 }-        | '`' qvarid '`'        {% amsrn (sLL $1 $> (unLoc $2))-                                           (NameAnn NameBackquotes (glAA $1) (glNRR $2) (glAA $3) []) }--qvaropm :: { LocatedN RdrName }-        : qvarsym_no_minus      { $1 }-        | '`' qvarid '`'        {% amsrn (sLL $1 $> (unLoc $2))-                                           (NameAnn NameBackquotes (glAA $1) (glNRR $2) (glAA $3) []) }---------------------------------------------------------------------------------- Type variables--tyvar   :: { LocatedN RdrName }-tyvar   : tyvarid               { $1 }--tyvarop :: { LocatedN RdrName }-tyvarop : '`' tyvarid '`'       {% amsrn (sLL $1 $> (unLoc $2))-                                           (NameAnn NameBackquotes (glAA $1) (glNRR $2) (glAA $3) []) }--tyvarid :: { LocatedN RdrName }-        : VARID            { sL1n $1 $! mkUnqual tvName (getVARID $1) }-        | special_id       { sL1n $1 $! mkUnqual tvName (unLoc $1) }-        | 'unsafe'         { sL1n $1 $! mkUnqual tvName (fsLit "unsafe") }-        | 'safe'           { sL1n $1 $! mkUnqual tvName (fsLit "safe") }-        | 'interruptible'  { sL1n $1 $! mkUnqual tvName (fsLit "interruptible") }-        -- If this changes relative to varid, update 'checkRuleTyVarBndrNames'-        -- in GHC.Parser.PostProcess-        -- See Note [Parsing explicit foralls in Rules]---------------------------------------------------------------------------------- Variables--var     :: { LocatedN RdrName }-        : varid                 { $1 }-        | '(' varsym ')'        {% amsrn (sLL $1 $> (unLoc $2))-                                   (NameAnn NameParens (glAA $1) (glNRR $2) (glAA $3) []) }--qvar    :: { LocatedN RdrName }-        : qvarid                { $1 }-        | '(' varsym ')'        {% amsrn (sLL $1 $> (unLoc $2))-                                   (NameAnn NameParens (glAA $1) (glNRR $2) (glAA $3) []) }-        | '(' qvarsym1 ')'      {% amsrn (sLL $1 $> (unLoc $2))-                                   (NameAnn NameParens (glAA $1) (glNRR $2) (glAA $3) []) }--- We've inlined qvarsym here so that the decision about--- whether it's a qvar or a var can be postponed until--- *after* we see the close paren.--field :: { Located FastString  }-      : varid { reLocN $ fmap (occNameFS . rdrNameOcc) $1 }--qvarid :: { LocatedN RdrName }-        : varid               { $1 }-        | QVARID              { sL1n $1 $! mkQual varName (getQVARID $1) }---- Note that 'role' and 'family' get lexed separately regardless of--- the use of extensions. However, because they are listed here,--- this is OK and they can be used as normal varids.--- See Note [Lexing type pseudo-keywords] in GHC.Parser.Lexer-varid :: { LocatedN RdrName }-        : VARID            { sL1n $1 $! mkUnqual varName (getVARID $1) }-        | special_id       { sL1n $1 $! mkUnqual varName (unLoc $1) }-        | 'unsafe'         { sL1n $1 $! mkUnqual varName (fsLit "unsafe") }-        | 'safe'           { sL1n $1 $! mkUnqual varName (fsLit "safe") }-        | 'interruptible'  { sL1n $1 $! mkUnqual varName (fsLit "interruptible")}-        | 'forall'         { sL1n $1 $! mkUnqual varName (fsLit "forall") }-        | 'family'         { sL1n $1 $! mkUnqual varName (fsLit "family") }-        | 'role'           { sL1n $1 $! mkUnqual varName (fsLit "role") }-        -- If this changes relative to tyvarid, update 'checkRuleTyVarBndrNames'-        -- in GHC.Parser.PostProcess-        -- See Note [Parsing explicit foralls in Rules]--qvarsym :: { LocatedN RdrName }-        : varsym                { $1 }-        | qvarsym1              { $1 }--qvarsym_no_minus :: { LocatedN RdrName }-        : varsym_no_minus       { $1 }-        | qvarsym1              { $1 }--qvarsym1 :: { LocatedN RdrName }-qvarsym1 : QVARSYM              { sL1n $1 $ mkQual varName (getQVARSYM $1) }--varsym :: { LocatedN RdrName }-        : varsym_no_minus       { $1 }-        | '-'                   { sL1n $1 $ mkUnqual varName (fsLit "-") }--varsym_no_minus :: { LocatedN RdrName } -- varsym not including '-'-        : VARSYM               { sL1n $1 $ mkUnqual varName (getVARSYM $1) }-        | special_sym          { sL1n $1 $ mkUnqual varName (unLoc $1) }----- These special_ids are treated as keywords in various places,--- but as ordinary ids elsewhere.   'special_id' collects all these--- except 'unsafe', 'interruptible', 'forall', 'family', 'role', 'stock', and--- 'anyclass', whose treatment differs depending on context-special_id :: { Located FastString }-special_id-        : 'as'                  { sL1 $1 (fsLit "as") }-        | 'qualified'           { sL1 $1 (fsLit "qualified") }-        | 'hiding'              { sL1 $1 (fsLit "hiding") }-        | 'export'              { sL1 $1 (fsLit "export") }-        | 'label'               { sL1 $1 (fsLit "label")  }-        | 'dynamic'             { sL1 $1 (fsLit "dynamic") }-        | 'stdcall'             { sL1 $1 (fsLit "stdcall") }-        | 'ccall'               { sL1 $1 (fsLit "ccall") }-        | 'capi'                { sL1 $1 (fsLit "capi") }-        | 'prim'                { sL1 $1 (fsLit "prim") }-        | 'javascript'          { sL1 $1 (fsLit "javascript") }-        -- See Note [%shift: special_id -> 'group']-        | 'group' %shift        { sL1 $1 (fsLit "group") }-        | 'stock'               { sL1 $1 (fsLit "stock") }-        | 'anyclass'            { sL1 $1 (fsLit "anyclass") }-        | 'via'                 { sL1 $1 (fsLit "via") }-        | 'unit'                { sL1 $1 (fsLit "unit") }-        | 'dependency'          { sL1 $1 (fsLit "dependency") }-        | 'signature'           { sL1 $1 (fsLit "signature") }--special_sym :: { Located FastString }-special_sym : '.'       { sL1 $1 (fsLit ".") }-            | '*'       { sL1 $1 (fsLit (starSym (isUnicode $1))) }---------------------------------------------------------------------------------- Data constructors--qconid :: { LocatedN RdrName }   -- Qualified or unqualified-        : conid              { $1 }-        | QCONID             { sL1n $1 $! mkQual dataName (getQCONID $1) }--conid   :: { LocatedN RdrName }-        : CONID                { sL1n $1 $ mkUnqual dataName (getCONID $1) }--qconsym :: { LocatedN RdrName }  -- Qualified or unqualified-        : consym               { $1 }-        | QCONSYM              { sL1n $1 $ mkQual dataName (getQCONSYM $1) }--consym :: { LocatedN RdrName }-        : CONSYM              { sL1n $1 $ mkUnqual dataName (getCONSYM $1) }--        -- ':' means only list cons-        | ':'                { sL1n $1 $ consDataCon_RDR }----------------------------------------------------------------------------------- Literals--literal :: { Located (HsLit GhcPs) }-        : CHAR              { sL1 $1 $ HsChar       (getCHARs $1) $ getCHAR $1 }-        | STRING            { sL1 $1 $ HsString     (getSTRINGs $1)-                                                    $ getSTRING $1 }-        | PRIMINTEGER       { sL1 $1 $ HsIntPrim    (getPRIMINTEGERs $1)-                                                    $ getPRIMINTEGER $1 }-        | PRIMWORD          { sL1 $1 $ HsWordPrim   (getPRIMWORDs $1)-                                                    $ getPRIMWORD $1 }-        | PRIMCHAR          { sL1 $1 $ HsCharPrim   (getPRIMCHARs $1)-                                                    $ getPRIMCHAR $1 }-        | PRIMSTRING        { sL1 $1 $ HsStringPrim (getPRIMSTRINGs $1)-                                                    $ getPRIMSTRING $1 }-        | PRIMFLOAT         { sL1 $1 $ HsFloatPrim  noExtField $ getPRIMFLOAT $1 }-        | PRIMDOUBLE        { sL1 $1 $ HsDoublePrim noExtField $ getPRIMDOUBLE $1 }---------------------------------------------------------------------------------- Layout--close :: { () }-        : vccurly               { () } -- context popped in lexer.-        | error                 {% popContext }---------------------------------------------------------------------------------- Miscellaneous (mostly renamings)--modid   :: { LocatedA ModuleName }-        : CONID                 { sL1a $1 $ mkModuleNameFS (getCONID $1) }-        | QCONID                { sL1a $1 $ let (mod,c) = getQCONID $1 in-                                  mkModuleNameFS-                                   (mkFastString-                                     (unpackFS mod ++ '.':unpackFS c))-                                }--commas :: { ([SrcSpan],Int) }   -- One or more commas-        : commas ','             { ((fst $1)++[gl $2],snd $1 + 1) }-        | ','                    { ([gl $1],1) }--bars0 :: { ([EpaLocation],Int) }     -- Zero or more bars-        : bars                   { $1 }-        |                        { ([], 0) }--bars :: { ([EpaLocation],Int) }     -- One or more bars-        : bars '|'               { ((fst $1)++[glAA $2],snd $1 + 1) }-        | '|'                    { ([glAA $1],1) }--{-happyError :: P a-happyError = srcParseFail--getVARID        (L _ (ITvarid    x)) = x-getCONID        (L _ (ITconid    x)) = x-getVARSYM       (L _ (ITvarsym   x)) = x-getCONSYM       (L _ (ITconsym   x)) = x-getDO           (L _ (ITdo      x)) = x-getMDO          (L _ (ITmdo     x)) = x-getQVARID       (L _ (ITqvarid   x)) = x-getQCONID       (L _ (ITqconid   x)) = x-getQVARSYM      (L _ (ITqvarsym  x)) = x-getQCONSYM      (L _ (ITqconsym  x)) = x-getIPDUPVARID   (L _ (ITdupipvarid   x)) = x-getLABELVARID   (L _ (ITlabelvarid   x)) = x-getCHAR         (L _ (ITchar   _ x)) = x-getSTRING       (L _ (ITstring _ x)) = x-getINTEGER      (L _ (ITinteger x))  = x-getRATIONAL     (L _ (ITrational x)) = x-getPRIMCHAR     (L _ (ITprimchar _ x)) = x-getPRIMSTRING   (L _ (ITprimstring _ x)) = x-getPRIMINTEGER  (L _ (ITprimint  _ x)) = x-getPRIMWORD     (L _ (ITprimword _ x)) = x-getPRIMFLOAT    (L _ (ITprimfloat x)) = x-getPRIMDOUBLE   (L _ (ITprimdouble x)) = x-getINLINE       (L _ (ITinline_prag _ inl conl)) = (inl,conl)-getSPEC_INLINE  (L _ (ITspec_inline_prag _ True))  = (Inline,  FunLike)-getSPEC_INLINE  (L _ (ITspec_inline_prag _ False)) = (NoInline,FunLike)-getCOMPLETE_PRAGs (L _ (ITcomplete_prag x)) = x-getVOCURLY      (L (RealSrcSpan l _) ITvocurly) = srcSpanStartCol l--getINTEGERs     (L _ (ITinteger (IL src _ _))) = src-getCHARs        (L _ (ITchar       src _)) = src-getSTRINGs      (L _ (ITstring     src _)) = src-getPRIMCHARs    (L _ (ITprimchar   src _)) = src-getPRIMSTRINGs  (L _ (ITprimstring src _)) = src-getPRIMINTEGERs (L _ (ITprimint    src _)) = src-getPRIMWORDs    (L _ (ITprimword   src _)) = src---- See Note [Pragma source text] in "GHC.Types.Basic" for the following-getINLINE_PRAGs       (L _ (ITinline_prag       src _ _)) = src-getSPEC_PRAGs         (L _ (ITspec_prag         src))     = src-getSPEC_INLINE_PRAGs  (L _ (ITspec_inline_prag  src _))   = src-getSOURCE_PRAGs       (L _ (ITsource_prag       src)) = src-getRULES_PRAGs        (L _ (ITrules_prag        src)) = src-getWARNING_PRAGs      (L _ (ITwarning_prag      src)) = src-getDEPRECATED_PRAGs   (L _ (ITdeprecated_prag   src)) = src-getSCC_PRAGs          (L _ (ITscc_prag          src)) = src-getUNPACK_PRAGs       (L _ (ITunpack_prag       src)) = src-getNOUNPACK_PRAGs     (L _ (ITnounpack_prag     src)) = src-getANN_PRAGs          (L _ (ITann_prag          src)) = src-getMINIMAL_PRAGs      (L _ (ITminimal_prag      src)) = src-getOVERLAPPABLE_PRAGs (L _ (IToverlappable_prag src)) = src-getOVERLAPPING_PRAGs  (L _ (IToverlapping_prag  src)) = src-getOVERLAPS_PRAGs     (L _ (IToverlaps_prag     src)) = src-getINCOHERENT_PRAGs   (L _ (ITincoherent_prag   src)) = src-getCTYPEs             (L _ (ITctype             src)) = src--getStringLiteral l = StringLiteral (getSTRINGs l) (getSTRING l) Nothing--isUnicode :: Located Token -> Bool-isUnicode (L _ (ITforall         iu)) = iu == UnicodeSyntax-isUnicode (L _ (ITdarrow         iu)) = iu == UnicodeSyntax-isUnicode (L _ (ITdcolon         iu)) = iu == UnicodeSyntax-isUnicode (L _ (ITlarrow         iu)) = iu == UnicodeSyntax-isUnicode (L _ (ITrarrow         iu)) = iu == UnicodeSyntax-isUnicode (L _ (ITlarrowtail     iu)) = iu == UnicodeSyntax-isUnicode (L _ (ITrarrowtail     iu)) = iu == UnicodeSyntax-isUnicode (L _ (ITLarrowtail     iu)) = iu == UnicodeSyntax-isUnicode (L _ (ITRarrowtail     iu)) = iu == UnicodeSyntax-isUnicode (L _ (IToparenbar      iu)) = iu == UnicodeSyntax-isUnicode (L _ (ITcparenbar      iu)) = iu == UnicodeSyntax-isUnicode (L _ (ITopenExpQuote _ iu)) = iu == UnicodeSyntax-isUnicode (L _ (ITcloseQuote     iu)) = iu == UnicodeSyntax-isUnicode (L _ (ITstar           iu)) = iu == UnicodeSyntax-isUnicode (L _ ITlolly)               = True-isUnicode _                           = False--hasE :: Located Token -> Bool-hasE (L _ (ITopenExpQuote HasE _)) = True-hasE (L _ (ITopenTExpQuote HasE))  = True-hasE _                             = False--getSCC :: Located Token -> P FastString-getSCC lt = do let s = getSTRING lt-               -- We probably actually want to be more restrictive than this-               if ' ' `elem` unpackFS s-                   then addFatalError $ PsError PsErrSpaceInSCC [] (getLoc lt)-                   else return s---- Utilities for combining source spans-comb2 :: Located a -> Located b -> SrcSpan-comb2 a b = a `seq` b `seq` combineLocs a b---- Utilities for combining source spans-comb2A :: Located a -> LocatedAn t b -> SrcSpan-comb2A a b = a `seq` b `seq` combineLocs a (reLoc b)--comb2N :: Located a -> LocatedN b -> SrcSpan-comb2N a b = a `seq` b `seq` combineLocs a (reLocN b)--comb2Al :: LocatedAn t a -> Located b -> SrcSpan-comb2Al a b = a `seq` b `seq` combineLocs (reLoc a) b--comb3 :: Located a -> Located b -> Located c -> SrcSpan-comb3 a b c = a `seq` b `seq` c `seq`-    combineSrcSpans (getLoc a) (combineSrcSpans (getLoc b) (getLoc c))--comb3A :: Located a -> Located b -> LocatedAn t c -> SrcSpan-comb3A a b c = a `seq` b `seq` c `seq`-    combineSrcSpans (getLoc a) (combineSrcSpans (getLoc b) (getLocA c))--comb3N :: Located a -> Located b -> LocatedN c -> SrcSpan-comb3N a b c = a `seq` b `seq` c `seq`-    combineSrcSpans (getLoc a) (combineSrcSpans (getLoc b) (getLocA c))--comb4 :: Located a -> Located b -> Located c -> Located d -> SrcSpan-comb4 a b c d = a `seq` b `seq` c `seq` d `seq`-    (combineSrcSpans (getLoc a) $ combineSrcSpans (getLoc b) $-                combineSrcSpans (getLoc c) (getLoc d))--comb5 :: Located a -> Located b -> Located c -> Located d -> Located e -> SrcSpan-comb5 a b c d e = a `seq` b `seq` c `seq` d `seq` e `seq`-    (combineSrcSpans (getLoc a) $ combineSrcSpans (getLoc b) $-       combineSrcSpans (getLoc c) $ combineSrcSpans (getLoc d) (getLoc e))---- strict constructor version:-{-# INLINE sL #-}-sL :: l -> a -> GenLocated l a-sL loc a = loc `seq` a `seq` L loc a---- See Note [Adding location info] for how these utility functions are used---- replaced last 3 CPP macros in this file-{-# INLINE sL0 #-}-sL0 :: a -> Located a-sL0 = L noSrcSpan       -- #define L0   L noSrcSpan--{-# INLINE sL1 #-}-sL1 :: GenLocated l a -> b -> GenLocated l b-sL1 x = sL (getLoc x)   -- #define sL1   sL (getLoc $1)--{-# INLINE sL1A #-}-sL1A :: LocatedAn t a -> b -> Located b-sL1A x = sL (getLocA x)   -- #define sL1   sL (getLoc $1)--{-# INLINE sL1N #-}-sL1N :: LocatedN a -> b -> Located b-sL1N x = sL (getLocA x)   -- #define sL1   sL (getLoc $1)--{-# INLINE sL1a #-}-sL1a :: Located a -> b -> LocatedAn t b-sL1a x = sL (noAnnSrcSpan $ getLoc x)   -- #define sL1   sL (getLoc $1)--{-# INLINE sL1n #-}-sL1n :: Located a -> b -> LocatedN b-sL1n x = L (noAnnSrcSpan $ getLoc x)   -- #define sL1   sL (getLoc $1)--{-# INLINE sLL #-}-sLL :: Located a -> Located b -> c -> Located c-sLL x y = sL (comb2 x y) -- #define LL   sL (comb2 $1 $>)--{-# INLINE sLLa #-}-sLLa :: Located a -> Located b -> c -> LocatedAn t c-sLLa x y = sL (noAnnSrcSpan $ comb2 x y) -- #define LL   sL (comb2 $1 $>)--{-# INLINE sLLlA #-}-sLLlA :: Located a -> LocatedAn t b -> c -> Located c-sLLlA x y = sL (comb2A x y) -- #define LL   sL (comb2 $1 $>)--{-# INLINE sLLAl #-}-sLLAl :: LocatedAn t a -> Located b -> c -> Located c-sLLAl x y = sL (comb2A y x) -- #define LL   sL (comb2 $1 $>)--{-# INLINE sLLAA #-}-sLLAA :: LocatedAn t a -> LocatedAn u b -> c -> Located c-sLLAA x y = sL (comb2 (reLoc y) (reLoc x)) -- #define LL   sL (comb2 $1 $>)---{- Note [Adding location info]-   ~~~~~~~~~~~~~~~~~~~~~~~~~~~--This is done using the three functions below, sL0, sL1-and sLL.  Note that these functions were mechanically-converted from the three macros that used to exist before,-namely L0, L1 and LL.--They each add a SrcSpan to their argument.--   sL0  adds 'noSrcSpan', used for empty productions-     -- This doesn't seem to work anymore -=chak--   sL1  for a production with a single token on the lhs.  Grabs the SrcSpan-        from that token.--   sLL  for a production with >1 token on the lhs.  Makes up a SrcSpan from-        the first and last tokens.--These suffice for the majority of cases.  However, we must be-especially careful with empty productions: sLL won't work if the first-or last token on the lhs can represent an empty span.  In these cases,-we have to calculate the span using more of the tokens from the lhs, eg.--        | 'newtype' tycl_hdr '=' newconstr deriving-                { L (comb3 $1 $4 $5)-                    (mkTyData NewType (unLoc $2) $4 (unLoc $5)) }--We provide comb3 and comb4 functions which are useful in such cases.--Be careful: there's no checking that you actually got this right, the-only symptom will be that the SrcSpans of your syntax will be-incorrect.---}---- Make a source location for the file.  We're a bit lazy here and just--- make a point SrcSpan at line 1, column 0.  Strictly speaking we should--- try to find the span of the whole file (ToDo).-fileSrcSpan :: P SrcSpan-fileSrcSpan = do-  l <- getRealSrcLoc;-  let loc = mkSrcLoc (srcLocFile l) 1 1;-  return (mkSrcSpan loc loc)---- Hint about linear types-hintLinear :: MonadP m => SrcSpan -> m ()-hintLinear span = do-  linearEnabled <- getBit LinearTypesBit-  unless linearEnabled $ addError $ PsError PsErrLinearFunction [] span---- Does this look like (a %m)?-looksLikeMult :: LHsType GhcPs -> LocatedN RdrName -> LHsType GhcPs -> Bool-looksLikeMult ty1 l_op ty2-  | Unqual op_name <- unLoc l_op-  , occNameFS op_name == fsLit "%"-  , Just ty1_pos <- getBufSpan (getLocA ty1)-  , Just pct_pos <- getBufSpan (getLocA l_op)-  , Just ty2_pos <- getBufSpan (getLocA ty2)-  , bufSpanEnd ty1_pos /= bufSpanStart pct_pos-  , bufSpanEnd pct_pos == bufSpanStart ty2_pos-  = True-  | otherwise = False---- Hint about the MultiWayIf extension-hintMultiWayIf :: SrcSpan -> P ()-hintMultiWayIf span = do-  mwiEnabled <- getBit MultiWayIfBit-  unless mwiEnabled $ addError $ PsError PsErrMultiWayIf [] span---- Hint about explicit-forall-hintExplicitForall :: Located Token -> P ()-hintExplicitForall tok = do-    forall   <- getBit ExplicitForallBit-    rulePrag <- getBit InRulePragBit-    unless (forall || rulePrag) $ addError $ PsError (PsErrExplicitForall (isUnicode tok)) [] (getLoc tok)---- Hint about qualified-do-hintQualifiedDo :: Located Token -> P ()-hintQualifiedDo tok = do-    qualifiedDo   <- getBit QualifiedDoBit-    case maybeQDoDoc of-      Just qdoDoc | not qualifiedDo ->-        addError $ PsError (PsErrIllegalQualifiedDo qdoDoc) [] (getLoc tok)-      _ -> return ()-  where-    maybeQDoDoc = case unLoc tok of-      ITdo (Just m) -> Just $ ftext m <> text ".do"-      ITmdo (Just m) -> Just $ ftext m <> text ".mdo"-      t -> Nothing---- When two single quotes don't followed by tyvar or gtycon, we report the--- error as empty character literal, or TH quote that missing proper type--- variable or constructor. See #13450.-reportEmptyDoubleQuotes :: SrcSpan -> P a-reportEmptyDoubleQuotes span = do-    thQuotes <- getBit ThQuotesBit-    addFatalError $ PsError (PsErrEmptyDoubleQuotes thQuotes) [] span--{--%************************************************************************-%*                                                                      *-        Helper functions for generating annotations in the parser-%*                                                                      *-%************************************************************************--For the general principles of the following routines, see Note [exact print annotations]-in GHC.Parser.Annotation---}---- |Construct an AddEpAnn from the annotation keyword and the location--- of the keyword itself-mj :: AnnKeywordId -> Located e -> AddEpAnn-mj a l = AddEpAnn a (EpaSpan $ rs $ gl l)--mjN :: AnnKeywordId -> LocatedN e -> AddEpAnn-mjN a l = AddEpAnn a (EpaSpan $ rs $ glN l)---- |Construct an AddEpAnn from the annotation keyword and the location--- of the keyword itself, provided the span is not zero width-mz :: AnnKeywordId -> Located e -> [AddEpAnn]-mz a l = if isZeroWidthSpan (gl l) then [] else [AddEpAnn a (EpaSpan $ rs $ gl l)]--msemi :: Located e -> [TrailingAnn]-msemi l = if isZeroWidthSpan (gl l) then [] else [AddSemiAnn (EpaSpan $ rs $ gl l)]--msemim :: Located e -> Maybe EpaLocation-msemim l = if isZeroWidthSpan (gl l) then Nothing else Just (EpaSpan $ rs $ gl l)---- |Construct an AddEpAnn from the annotation keyword and the Located Token. If--- the token has a unicode equivalent and this has been used, provide the--- unicode variant of the annotation.-mu :: AnnKeywordId -> Located Token -> AddEpAnn-mu a lt@(L l t) = AddEpAnn (toUnicodeAnn a lt) (EpaSpan $ rs l)--mau :: Located Token -> TrailingAnn-mau lt@(L l t) = if isUnicode lt then AddRarrowAnnU (EpaSpan $ rs l)-                                 else AddRarrowAnn  (EpaSpan $ rs l)--mlu :: Located Token -> TrailingAnn-mlu lt@(L l t) = AddLollyAnnU (EpaSpan $ rs l)---- | If the 'Token' is using its unicode variant return the unicode variant of---   the annotation-toUnicodeAnn :: AnnKeywordId -> Located Token -> AnnKeywordId-toUnicodeAnn a t = if isUnicode t then unicodeAnn a else a--toUnicode :: Located Token -> IsUnicodeSyntax-toUnicode t = if isUnicode t then UnicodeSyntax else NormalSyntax--gl :: GenLocated l a -> l-gl = getLoc--glA :: LocatedAn t a -> SrcSpan-glA = getLocA--glN :: LocatedN a -> SrcSpan-glN = getLocA--glR :: Located a -> Anchor-glR la = Anchor (realSrcSpan $ getLoc la) UnchangedAnchor--glAA :: Located a -> EpaLocation-glAA = EpaSpan <$> realSrcSpan . getLoc--glRR :: Located a -> RealSrcSpan-glRR = realSrcSpan . getLoc--glAR :: LocatedAn t a -> Anchor-glAR la = Anchor (realSrcSpan $ getLocA la) UnchangedAnchor--glNR :: LocatedN a -> Anchor-glNR ln = Anchor (realSrcSpan $ getLocA ln) UnchangedAnchor--glNRR :: LocatedN a -> EpaLocation-glNRR = EpaSpan <$> realSrcSpan . getLocA--anc :: RealSrcSpan -> Anchor-anc r = Anchor r UnchangedAnchor--acs :: MonadP m => (EpAnnComments -> Located a) -> m (Located a)-acs a = do-  let (L l _) = a emptyComments-  cs <- getCommentsFor l-  return (a cs)---- Called at the very end to pick up the EOF position, as well as any comments not allocated yet.-acsFinal :: (EpAnnComments -> Located a) -> P (Located a)-acsFinal a = do-  let (L l _) = a emptyComments-  cs <- getCommentsFor l-  csf <- getFinalCommentsFor l-  meof <- getEofPos-  let ce = case meof of-             Nothing  -> EpaComments []-             Just (pos, gap) -> EpaCommentsBalanced [] [L (realSpanAsAnchor pos) (EpaComment EpaEofComment gap)]-  return (a (cs Semi.<> csf Semi.<> ce))--acsa :: MonadP m => (EpAnnComments -> LocatedAn t a) -> m (LocatedAn t a)-acsa a = do-  let (L l _) = a emptyComments-  cs <- getCommentsFor (locA l)-  return (a cs)--acsA :: MonadP m => (EpAnnComments -> Located a) -> m (LocatedAn t a)-acsA a = reLocA <$> acs a--acsExpr :: (EpAnnComments -> LHsExpr GhcPs) -> P ECP-acsExpr a = do { expr :: (LHsExpr GhcPs) <- runPV $ acsa a-               ; return (ecpFromExp $ expr) }--amsA :: MonadP m => LocatedA a -> [TrailingAnn] -> m (LocatedA a)-amsA (L l a) bs = do-  cs <- getCommentsFor (locA l)-  return (L (addAnnsA l bs cs) a)--amsAl :: MonadP m => LocatedA a -> SrcSpan -> [TrailingAnn] -> m (LocatedA a)-amsAl (L l a) loc bs = do-  cs <- getCommentsFor loc-  return (L (addAnnsA l bs cs) a)--amsrc :: MonadP m => Located a -> AnnContext -> m (LocatedC a)-amsrc a@(L l _) bs = do-  cs <- getCommentsFor l-  return (reAnnC bs cs a)--amsrl :: MonadP m => Located a -> AnnList -> m (LocatedL a)-amsrl a@(L l _) bs = do-  cs <- getCommentsFor l-  return (reAnnL bs cs a)--amsrp :: MonadP m => Located a -> AnnPragma -> m (LocatedP a)-amsrp a@(L l _) bs = do-  cs <- getCommentsFor l-  return (reAnnL bs cs a)--amsrn :: MonadP m => Located a -> NameAnn -> m (LocatedN a)-amsrn (L l a) an = do-  cs <- getCommentsFor l-  let ann = (EpAnn (spanAsAnchor l) an cs)-  return (L (SrcSpanAnn ann l) a)---- |Synonyms for AddEpAnn versions of AnnOpen and AnnClose-mo,mc :: Located Token -> AddEpAnn-mo ll = mj AnnOpen ll-mc ll = mj AnnClose ll--moc,mcc :: Located Token -> AddEpAnn-moc ll = mj AnnOpenC ll-mcc ll = mj AnnCloseC ll--mop,mcp :: Located Token -> AddEpAnn-mop ll = mj AnnOpenP ll-mcp ll = mj AnnCloseP ll--moh,mch :: Located Token -> AddEpAnn-moh ll = mj AnnOpenPH ll-mch ll = mj AnnClosePH ll--mos,mcs :: Located Token -> AddEpAnn-mos ll = mj AnnOpenS ll-mcs ll = mj AnnCloseS ll--pvA :: MonadP m => m (Located a) -> m (LocatedAn t a)-pvA a = do { av <- a-           ; return (reLocA av) }--pvN :: MonadP m => m (Located a) -> m (LocatedN a)-pvN a = do { (L l av) <- a-           ; return (L (noAnnSrcSpan l) av) }--pvL :: MonadP m => m (LocatedAn t a) -> m (Located a)-pvL a = do { av <- a-           ; return (reLoc av) }---- | Parse a Haskell module with Haddock comments.--- This is done in two steps:------ * 'parseModuleNoHaddock' to build the AST--- * 'addHaddockToModule' to insert Haddock comments into it------ This is the only parser entry point that deals with Haddock comments.--- The other entry points ('parseDeclaration', 'parseExpression', etc) do--- not insert them into the AST.-parseModule :: P (Located HsModule)-parseModule = parseModuleNoHaddock >>= addHaddockToModule--commentsA :: (Monoid ann) => SrcSpan -> EpAnnComments -> SrcSpanAnn' (EpAnn ann)-commentsA loc cs = SrcSpanAnn (EpAnn (Anchor (rs loc) UnchangedAnchor) mempty cs) loc---- | Instead of getting the *enclosed* comments, this includes the--- *preceding* ones.  It is used at the top level to get comments--- between top level declarations.-commentsPA :: (Monoid ann) => LocatedAn ann a -> P (LocatedAn ann a)-commentsPA la@(L l a) = do-  cs <- getPriorCommentsFor (getLocA la)-  return (L (addCommentsToSrcAnn l cs) a)--rs :: SrcSpan -> RealSrcSpan-rs (RealSrcSpan l _) = l-rs _ = panic "Parser should only have RealSrcSpan"--hsDoAnn :: Located a -> LocatedAn t b -> AnnKeywordId -> AnnList-hsDoAnn (L l _) (L ll _) kw-  = AnnList (Just $ spanAsAnchor (locA ll)) Nothing Nothing [AddEpAnn kw (EpaSpan $ rs l)] []--listAsAnchor :: [LocatedAn t a] -> Anchor-listAsAnchor [] = spanAsAnchor noSrcSpan-listAsAnchor (L l _:_) = spanAsAnchor (locA l)---- ---------------------------------------addTrailingCommaFBind :: MonadP m => Fbind b -> SrcSpan -> m (Fbind b)-addTrailingCommaFBind (Left b)  l = fmap Left  (addTrailingCommaA b l)-addTrailingCommaFBind (Right b) l = fmap Right (addTrailingCommaA b l)--addTrailingVbarA :: MonadP m => LocatedA a -> SrcSpan -> m (LocatedA a)-addTrailingVbarA  la span = addTrailingAnnA la span AddVbarAnn--addTrailingSemiA :: MonadP m => LocatedA a -> SrcSpan -> m (LocatedA a)-addTrailingSemiA  la span = addTrailingAnnA la span AddSemiAnn--addTrailingCommaA :: MonadP m => LocatedA a -> SrcSpan -> m (LocatedA a)-addTrailingCommaA  la span = addTrailingAnnA la span AddCommaAnn--addTrailingAnnA :: MonadP m => LocatedA a -> SrcSpan -> (EpaLocation -> TrailingAnn) -> m (LocatedA a)-addTrailingAnnA (L (SrcSpanAnn anns l) a) ss ta = do-  -- cs <- getCommentsFor l-  let cs = emptyComments-  -- AZ:TODO: generalise updating comments into an annotation-  let-    anns' = if isZeroWidthSpan ss-              then anns-              else addTrailingAnnToA l (ta (EpaSpan $ rs ss)) cs anns-  return (L (SrcSpanAnn anns' l) a)---- ---------------------------------------addTrailingVbarL :: MonadP m => LocatedL a -> SrcSpan -> m (LocatedL a)-addTrailingVbarL  la span = addTrailingAnnL la (AddVbarAnn (EpaSpan $ rs span))--addTrailingCommaL :: MonadP m => LocatedL a -> SrcSpan -> m (LocatedL a)-addTrailingCommaL  la span = addTrailingAnnL la (AddCommaAnn (EpaSpan $ rs span))--addTrailingAnnL :: MonadP m => LocatedL a -> TrailingAnn -> m (LocatedL a)-addTrailingAnnL (L (SrcSpanAnn anns l) a) ta = do-  cs <- getCommentsFor l-  let anns' = addTrailingAnnToL l ta cs anns-  return (L (SrcSpanAnn anns' l) a)---- ----------------------------------------- Mostly use to add AnnComma, special case it to NOP if adding a zero-width annotation-addTrailingCommaN :: MonadP m => LocatedN a -> SrcSpan -> m (LocatedN a)-addTrailingCommaN (L (SrcSpanAnn anns l) a) span = do-  -- cs <- getCommentsFor l-  let cs = emptyComments-  -- AZ:TODO: generalise updating comments into an annotation-  let anns' = if isZeroWidthSpan span-                then anns-                else addTrailingCommaToN l anns (EpaSpan $ rs span)-  return (L (SrcSpanAnn anns' l) a)--addTrailingCommaS :: Located StringLiteral -> EpaLocation -> Located StringLiteral-addTrailingCommaS (L l sl) span = L l (sl { sl_tc = Just (epaLocationRealSrcSpan span) })---- ---------------------------------------addTrailingDarrowC :: LocatedC a -> Located Token -> EpAnnComments -> LocatedC a-addTrailingDarrowC (L (SrcSpanAnn EpAnnNotUsed l) a) lt cs =-  let-    u = if (isUnicode lt) then UnicodeSyntax else NormalSyntax-  in L (SrcSpanAnn (EpAnn (spanAsAnchor l) (AnnContext (Just (u,glAA lt)) [] []) cs) l) a-addTrailingDarrowC (L (SrcSpanAnn (EpAnn lr (AnnContext _ o c) csc) l) a) lt cs =-  let-    u = if (isUnicode lt) then UnicodeSyntax else NormalSyntax-  in L (SrcSpanAnn (EpAnn lr (AnnContext (Just (u,glAA lt)) o c) (cs Semi.<> csc)) l) a---- ----------------------------------------- We need a location for the where binds, when computing the SrcSpan--- for the AST element using them.  Where there is a span, we return--- it, else noLoc, which is ignored in the comb2 call.-adaptWhereBinds :: Maybe (Located (HsLocalBinds GhcPs, Maybe EpAnnComments))-                ->        Located (HsLocalBinds GhcPs,       EpAnnComments)-adaptWhereBinds Nothing = noLoc (EmptyLocalBinds noExtField, emptyComments)-adaptWhereBinds (Just (L l (b, mc))) = L l (b, maybe emptyComments id mc)--}
GHC/Parser/Annotation.hs view
@@ -14,6 +14,7 @@   -- * In-tree Exact Print Annotations   AddEpAnn(..),   EpaLocation(..), epaLocationRealSrcSpan, epaLocationFromSrcAnn,+  TokenLocation(..),   DeltaPos(..), deltaPos, getDeltaLine,    EpAnn(..), Anchor(..), AnchorOperation(..),@@ -42,7 +43,8 @@   AnnSortKey(..),    -- ** Trailing annotations in lists-  TrailingAnn(..), addTrailingAnnToA, addTrailingAnnToL, addTrailingCommaToN,+  TrailingAnn(..), trailingAnnToAddEpAnn,+  addTrailingAnnToA, addTrailingAnnToL, addTrailingCommaToN,    -- ** Utilities for converting between different 'GenLocated' when   -- ** we do not care about the annotations.@@ -92,9 +94,11 @@ import GHC.Data.FastString import GHC.Types.Name import GHC.Types.SrcLoc+import GHC.Hs.DocString import GHC.Utils.Binary import GHC.Utils.Outputable hiding ( (<>) ) import GHC.Utils.Panic+import qualified GHC.Data.Strict as Strict  {- Note [exact print annotations]@@ -194,7 +198,7 @@ -- -- Note: in general the names of these are taken from the -- corresponding token, unless otherwise noted--- See note [exact print annotations] above for details of the usage+-- See Note [exact print annotations] above for details of the usage data AnnKeywordId     = AnnAnyclass     | AnnAs@@ -203,6 +207,7 @@     | AnnBackquote -- ^ '`'     | AnnBy     | AnnCase -- ^ case or lambda case+    | AnnCases -- ^ lambda cases     | AnnClass     | AnnClose -- ^  '\#)' or '\#-}'  etc     | AnnCloseB -- ^ '|)'@@ -356,14 +361,11 @@     -- and the start of this location is used for the spacing when     -- exact printing the comment.     }-    deriving (Eq, Ord, Data, Show)+    deriving (Eq, Data, Show)  data EpaCommentTok =   -- Documentation annotations-    EpaDocCommentNext  String     -- ^ something beginning '-- |'-  | EpaDocCommentPrev  String     -- ^ something beginning '-- ^'-  | EpaDocCommentNamed String     -- ^ something beginning '-- $'-  | EpaDocSection      Int String -- ^ a section heading+    EpaDocComment      HsDocString -- ^ a docstring that can be pretty printed using pprHsDocString   | EpaDocOptions      String     -- ^ doc options (prune, ignore-exports, etc)   | EpaLineComment     String     -- ^ comment starting by "--"   | EpaBlockComment    String     -- ^ comment in {- -}@@ -374,7 +376,7 @@   -- should be removed in favour of capturing it in the location for   -- 'Located HsModule' in the parser. -    deriving (Eq, Ord, Data, Show)+    deriving (Eq, Data, Show) -- Note: these are based on the Token versions, but the Token type is -- defined in GHC.Parser.Lexer and bringing it in here would create a loop @@ -405,8 +407,13 @@ -- sort the relative order. data EpaLocation = EpaSpan !RealSrcSpan                  | EpaDelta !DeltaPos ![LEpaComment]-               deriving (Data,Eq,Ord)+               deriving (Data,Eq) +-- | Tokens embedded in the AST have an EpaLocation, unless they come from+-- generated code (e.g. by TH).+data TokenLocation = NoTokenLoc | TokenLoc !EpaLocation+               deriving (Data,Eq)+ -- | Spacing between output items when exact printing.  It captures -- the spacing from the current print position on the page to the -- position required for the thing about to be printed.  This is@@ -453,9 +460,6 @@ instance Outputable AddEpAnn where   ppr (AddEpAnn kw ss) = text "AddEpAnn" <+> ppr kw <+> ppr ss -instance Ord AddEpAnn where-  compare (AddEpAnn kw1 loc1) (AddEpAnn kw2 loc2) = compare (loc1, kw1) (loc2,kw2)- -- ---------------------------------------------------------------------  -- | The exact print annotations (EPAs) are kept in the HsSyn AST for@@ -633,18 +637,12 @@   = AddSemiAnn EpaLocation    -- ^ Trailing ';'   | AddCommaAnn EpaLocation   -- ^ Trailing ','   | AddVbarAnn EpaLocation    -- ^ Trailing '|'-  | AddRarrowAnn EpaLocation  -- ^ Trailing '->'-  | AddRarrowAnnU EpaLocation -- ^ Trailing '->', unicode variant-  | AddLollyAnnU EpaLocation  -- ^ Trailing '⊸'-  deriving (Data,Eq, Ord)+  deriving (Data, Eq)  instance Outputable TrailingAnn where   ppr (AddSemiAnn ss)    = text "AddSemiAnn"    <+> ppr ss   ppr (AddCommaAnn ss)   = text "AddCommaAnn"   <+> ppr ss   ppr (AddVbarAnn ss)    = text "AddVbarAnn"    <+> ppr ss-  ppr (AddRarrowAnn ss)  = text "AddRarrowAnn"  <+> ppr ss-  ppr (AddRarrowAnnU ss) = text "AddRarrowAnnU" <+> ppr ss-  ppr (AddLollyAnnU ss)  = text "AddLollyAnnU"  <+> ppr ss  -- | Annotation for items appearing in a list. They can have one or -- more trailing punctuations items, such as commas or semicolons.@@ -735,6 +733,14 @@       nann_close     :: EpaLocation,       nann_trailing  :: [TrailingAnn]       }+  -- | Used for @(# | | #)@+  | NameAnnBars {+      nann_adornment :: NameAdornment,+      nann_open      :: EpaLocation,+      nann_bars      :: [EpaLocation],+      nann_close     :: EpaLocation,+      nann_trailing  :: [TrailingAnn]+      }   -- | Used for @()@, @(##)@, @[]@   | NameAnnOnly {       nann_adornment :: NameAdornment,@@ -797,6 +803,11 @@  -- --------------------------------------------------------------------- +-- | Convert a 'TrailingAnn' to an 'AddEpAnn'+trailingAnnToAddEpAnn :: TrailingAnn -> AddEpAnn+trailingAnnToAddEpAnn (AddSemiAnn ss)    = AddEpAnn AnnSemi ss+trailingAnnToAddEpAnn (AddCommaAnn ss)   = AddEpAnn AnnComma ss+trailingAnnToAddEpAnn (AddVbarAnn ss)    = AddEpAnn AnnVbar ss  -- | Helper function used in the parser to add a 'TrailingAnn' items -- to an existing annotation.@@ -964,7 +975,7 @@ widenSpan s as = foldl combineSrcSpans s (go as)   where     go [] = []-    go (AddEpAnn _ (EpaSpan s):rest) = RealSrcSpan s Nothing : go rest+    go (AddEpAnn _ (EpaSpan s):rest) = RealSrcSpan s Strict.Nothing : go rest     go (AddEpAnn _ (EpaDelta _ _):rest) = go rest  -- | The annotations need to all come after the anchor.  Make sure@@ -1051,7 +1062,6 @@ -- Comment-only annotations -- --------------------------------------------------------------------- --- TODO:AZ I think EpAnnCO is not needed type EpAnnCO = EpAnn NoEpAnns -- ^ Api Annotations for comments only  data NoEpAnns = NoEpAnns@@ -1162,6 +1172,9 @@ instance (Monoid a) => Monoid (EpAnn a) where   mempty = EpAnnNotUsed +instance Semigroup NoEpAnns where+  _ <> _ = NoEpAnns+ instance Semigroup AnnListItem where   (AnnListItem l1) <> (AnnListItem l2) = AnnListItem (l1 <> l2) @@ -1200,6 +1213,9 @@   ppr (EpAnn l a c)  = text "EpAnn" <+> ppr l <+> ppr a <+> ppr c   ppr EpAnnNotUsed = text "EpAnnNotUsed" +instance Outputable NoEpAnns where+  ppr NoEpAnns = text "NoEpAnns"+ instance Outputable Anchor where   ppr (Anchor a o)        = text "Anchor" <+> ppr a <+> ppr o @@ -1249,6 +1265,11 @@      => Outputable (GenLocated (SrcSpanAnn' a) e) where   ppr = pprLocated +instance (Outputable a, OutputableBndr e)+     => OutputableBndr (GenLocated (SrcSpanAnn' a) e) where+  pprInfixOcc = pprInfixOcc . unLoc+  pprPrefixOcc = pprPrefixOcc . unLoc+ instance Outputable AnnListItem where   ppr (AnnListItem ts) = text "AnnListItem" <+> ppr ts @@ -1263,6 +1284,8 @@     = text "NameAnn" <+> ppr a <+> ppr o <+> ppr n <+> ppr c <+> ppr t   ppr (NameAnnCommas a o n c t)     = text "NameAnnCommas" <+> ppr a <+> ppr o <+> ppr n <+> ppr c <+> ppr t+  ppr (NameAnnBars a o n b t)+    = text "NameAnnBars" <+> ppr a <+> ppr o <+> ppr n <+> ppr b <+> ppr t   ppr (NameAnnOnly a o c t)     = text "NameAnnOnly" <+> ppr a <+> ppr o <+> ppr c <+> ppr t   ppr (NameAnnRArrow n t)
GHC/Parser/CharClass.hs view
@@ -1,5 +1,5 @@ -- Character classification-{-# LANGUAGE CPP #-}+ module GHC.Parser.CharClass         ( is_ident      -- Char# -> Bool         , is_symbol     -- Char# -> Bool@@ -13,8 +13,6 @@         , is_decdigit, is_hexdigit, is_octdigit, is_bindigit         , hexDigit, octDecDigit         ) where--#include "HsVersions.h"  import GHC.Prelude
− GHC/Parser/Errors.hs 
@@ -1,442 +0,0 @@-module GHC.Parser.Errors-   ( PsWarning(..)-   , TransLayoutReason(..)-   , OperatorWhitespaceSymbol(..)-   , OperatorWhitespaceOccurrence(..)-   , NumUnderscoreReason(..)-   , PsError(..)-   , PsErrorDesc(..)-   , LexErr(..)-   , CmmParserError(..)-   , LexErrKind(..)-   , Hint(..)-   , StarIsType (..)-   )-where--import GHC.Prelude-import GHC.Types.SrcLoc-import GHC.Types.Name.Reader (RdrName)-import GHC.Types.Name.Occurrence (OccName)-import GHC.Parser.Types-import Language.Haskell.Syntax.Extension-import GHC.Hs.Extension-import GHC.Hs.Expr-import GHC.Hs.Pat-import GHC.Hs.Type-import GHC.Hs.Lit-import GHC.Hs.Decls-import GHC.Core.Coercion.Axiom (Role)-import GHC.Utils.Outputable (SDoc)-import GHC.Data.FastString-import GHC.Unit.Module.Name-import Data.List.NonEmpty (NonEmpty)---- | A warning that might arise during parsing.-data PsWarning--     -- | Warn when tabulations are found-   = PsWarnTab-      { tabFirst :: !SrcSpan -- ^ First occurrence of a tab-      , tabCount :: !Word    -- ^ Number of other occurrences-      }--   {-| PsWarnBidirectionalFormatChars is a warning (controlled by the -Wwarn-bidirectional-format-characters flag)-   that occurs when unicode bi-directional format characters are found within in a file--   The 'PsLoc' contains the exact position in the buffer the character occured, and the-   string contains a description of the character.-   -}-   | PsWarnBidirectionalFormatChars (NonEmpty (PsLoc, Char, String))--   | PsWarnTransitionalLayout !SrcSpan !TransLayoutReason-      -- ^ Transitional layout warnings--   | PsWarnUnrecognisedPragma !SrcSpan-      -- ^ Unrecognised pragma--   | PsWarnHaddockInvalidPos !SrcSpan-      -- ^ Invalid Haddock comment position--   | PsWarnHaddockIgnoreMulti !SrcSpan-      -- ^ Multiple Haddock comment for the same entity--   | PsWarnStarBinder !SrcSpan-      -- ^ Found binding occurrence of "*" while StarIsType is enabled--   | PsWarnStarIsType !SrcSpan-      -- ^ Using "*" for "Type" without StarIsType enabled--   | PsWarnImportPreQualified !SrcSpan-      -- ^ Pre qualified import with 'WarnPrepositiveQualifiedModule' enabled--   | PsWarnOperatorWhitespaceExtConflict !SrcSpan !OperatorWhitespaceSymbol-   | PsWarnOperatorWhitespace !SrcSpan !FastString !OperatorWhitespaceOccurrence---- | The operator symbol in the 'WarnOperatorWhitespaceExtConflict' warning.-data OperatorWhitespaceSymbol-   = OperatorWhitespaceSymbol_PrefixPercent-   | OperatorWhitespaceSymbol_PrefixDollar-   | OperatorWhitespaceSymbol_PrefixDollarDollar---- | The operator occurrence type in the 'WarnOperatorWhitespace' warning.-data OperatorWhitespaceOccurrence-   = OperatorWhitespaceOccurrence_Prefix-   | OperatorWhitespaceOccurrence_Suffix-   | OperatorWhitespaceOccurrence_TightInfix--data TransLayoutReason-   = TransLayout_Where -- ^ "`where' clause at the same depth as implicit layout block"-   | TransLayout_Pipe  -- ^ "`|' at the same depth as implicit layout block")--data PsError = PsError-   { errDesc  :: !PsErrorDesc   -- ^ Error description-   , errHints :: ![Hint]      -- ^ Hints-   , errLoc   :: !SrcSpan     -- ^ Error position-   }--data PsErrorDesc-   = PsErrLambdaCase-      -- ^ LambdaCase syntax used without the extension enabled--   | PsErrNumUnderscores !NumUnderscoreReason-      -- ^ Underscores in literals without the extension enabled--   | PsErrPrimStringInvalidChar-      -- ^ Invalid character in primitive string--   | PsErrMissingBlock-      -- ^ Missing block--   | PsErrLexer !LexErr !LexErrKind-      -- ^ Lexer error--   | PsErrSuffixAT-      -- ^ Suffix occurrence of `@`--   | PsErrParse !String-      -- ^ Parse errors--   | PsErrCmmLexer-      -- ^ Cmm lexer error--   | PsErrUnsupportedBoxedSumExpr !(SumOrTuple (HsExpr GhcPs))-      -- ^ Unsupported boxed sum in expression--   | PsErrUnsupportedBoxedSumPat !(SumOrTuple (PatBuilder GhcPs))-      -- ^ Unsupported boxed sum in pattern--   | PsErrUnexpectedQualifiedConstructor !RdrName-      -- ^ Unexpected qualified constructor--   | PsErrTupleSectionInPat-      -- ^ Tuple section in pattern context--   | PsErrIllegalBangPattern !(Pat GhcPs)-      -- ^ Bang-pattern without BangPattterns enabled--   | PsErrOpFewArgs !StarIsType !RdrName-      -- ^ Operator applied to too few arguments--   | PsErrImportQualifiedTwice-      -- ^ Import: multiple occurrences of 'qualified'--   | PsErrImportPostQualified-      -- ^ Post qualified import without 'ImportQualifiedPost'--   | PsErrIllegalExplicitNamespace-      -- ^ Explicit namespace keyword without 'ExplicitNamespaces'--   | PsErrVarForTyCon !RdrName-      -- ^ Expecting a type constructor but found a variable--   | PsErrIllegalPatSynExport-      -- ^ Illegal export form allowed by PatternSynonyms--   | PsErrMalformedEntityString-      -- ^ Malformed entity string--   | PsErrDotsInRecordUpdate-      -- ^ Dots used in record update--   | PsErrPrecedenceOutOfRange !Int-      -- ^ Precedence out of range--   | PsErrOverloadedRecordDotInvalid-      -- ^ Invalid use of record dot syntax `.'--   | PsErrOverloadedRecordUpdateNotEnabled-      -- ^ `OverloadedRecordUpdate` is not enabled.--   | PsErrOverloadedRecordUpdateNoQualifiedFields-      -- ^ Can't use qualified fields when OverloadedRecordUpdate is enabled.--   | PsErrInvalidDataCon !(HsType GhcPs)-      -- ^ Cannot parse data constructor in a data/newtype declaration--   | PsErrInvalidInfixDataCon !(HsType GhcPs) !RdrName !(HsType GhcPs)-      -- ^ Cannot parse data constructor in a data/newtype declaration--   | PsErrUnpackDataCon-      -- ^ UNPACK applied to a data constructor--   | PsErrUnexpectedKindAppInDataCon !DataConBuilder !(HsType GhcPs)-      -- ^ Unexpected kind application in data/newtype declaration--   | PsErrInvalidRecordCon !(PatBuilder GhcPs)-      -- ^ Not a record constructor--   | PsErrIllegalUnboxedStringInPat !(HsLit GhcPs)-      -- ^ Illegal unboxed string literal in pattern--   | PsErrDoNotationInPat-      -- ^ Do-notation in pattern--   | PsErrIfTheElseInPat-      -- ^ If-then-else syntax in pattern--   | PsErrLambdaCaseInPat-      -- ^ Lambda-case in pattern--   | PsErrCaseInPat-      -- ^ case..of in pattern--   | PsErrLetInPat-      -- ^ let-syntax in pattern--   | PsErrLambdaInPat-      -- ^ Lambda-syntax in pattern--   | PsErrArrowExprInPat !(HsExpr GhcPs)-      -- ^ Arrow expression-syntax in pattern--   | PsErrArrowCmdInPat !(HsCmd GhcPs)-      -- ^ Arrow command-syntax in pattern--   | PsErrArrowCmdInExpr !(HsCmd GhcPs)-      -- ^ Arrow command-syntax in expression--   | PsErrViewPatInExpr !(LHsExpr GhcPs) !(LHsExpr GhcPs)-      -- ^ View-pattern in expression--   | PsErrTypeAppWithoutSpace !RdrName !(LHsExpr GhcPs)-      -- ^ Type-application without space before '@'--   | PsErrLazyPatWithoutSpace !(LHsExpr GhcPs)-      -- ^ Lazy-pattern ('~') without space after it--   | PsErrBangPatWithoutSpace !(LHsExpr GhcPs)-      -- ^ Bang-pattern ('!') without space after it--   | PsErrUnallowedPragma !(HsPragE GhcPs)-      -- ^ Pragma not allowed in this position--   | PsErrQualifiedDoInCmd !ModuleName-      -- ^ Qualified do block in command--   | PsErrInvalidInfixHole-      -- ^ Invalid infix hole, expected an infix operator--   | PsErrSemiColonsInCondExpr-      -- ^ Unexpected semi-colons in conditional expression-         !(HsExpr GhcPs) -- ^ conditional expr-         !Bool           -- ^ "then" semi-colon?-         !(HsExpr GhcPs) -- ^ "then" expr-         !Bool           -- ^ "else" semi-colon?-         !(HsExpr GhcPs) -- ^ "else" expr--   | PsErrSemiColonsInCondCmd-      -- ^ Unexpected semi-colons in conditional command-         !(HsExpr GhcPs) -- ^ conditional expr-         !Bool           -- ^ "then" semi-colon?-         !(HsCmd GhcPs)  -- ^ "then" expr-         !Bool           -- ^ "else" semi-colon?-         !(HsCmd GhcPs)  -- ^ "else" expr--   | PsErrAtInPatPos-      -- ^ @-operator in a pattern position--   | PsErrLambdaCmdInFunAppCmd !(LHsCmd GhcPs)-      -- ^ Unexpected lambda command in function application--   | PsErrCaseCmdInFunAppCmd !(LHsCmd GhcPs)-      -- ^ Unexpected case command in function application--   | PsErrIfCmdInFunAppCmd !(LHsCmd GhcPs)-      -- ^ Unexpected if command in function application--   | PsErrLetCmdInFunAppCmd !(LHsCmd GhcPs)-      -- ^ Unexpected let command in function application--   | PsErrDoCmdInFunAppCmd !(LHsCmd GhcPs)-      -- ^ Unexpected do command in function application--   | PsErrDoInFunAppExpr !(Maybe ModuleName) !(LHsExpr GhcPs)-      -- ^ Unexpected do block in function application--   | PsErrMDoInFunAppExpr !(Maybe ModuleName) !(LHsExpr GhcPs)-      -- ^ Unexpected mdo block in function application--   | PsErrLambdaInFunAppExpr !(LHsExpr GhcPs)-      -- ^ Unexpected lambda expression in function application--   | PsErrCaseInFunAppExpr !(LHsExpr GhcPs)-      -- ^ Unexpected case expression in function application--   | PsErrLambdaCaseInFunAppExpr !(LHsExpr GhcPs)-      -- ^ Unexpected lambda-case expression in function application--   | PsErrLetInFunAppExpr !(LHsExpr GhcPs)-      -- ^ Unexpected let expression in function application--   | PsErrIfInFunAppExpr !(LHsExpr GhcPs)-      -- ^ Unexpected if expression in function application--   | PsErrProcInFunAppExpr !(LHsExpr GhcPs)-      -- ^ Unexpected proc expression in function application--   | PsErrMalformedTyOrClDecl !(LHsType GhcPs)-      -- ^ Malformed head of type or class declaration--   | PsErrIllegalWhereInDataDecl-      -- ^ Illegal 'where' keyword in data declaration--   | PsErrIllegalDataTypeContext !(LHsContext GhcPs)-      -- ^ Illegal datatyp context--   | PsErrParseErrorOnInput !OccName-      -- ^ Parse error on input--   | PsErrMalformedDecl !SDoc !RdrName-      -- ^ Malformed ... declaration for ...--   | PsErrUnexpectedTypeAppInDecl !(LHsType GhcPs) !SDoc !RdrName-      -- ^ Unexpected type application in a declaration--   | PsErrNotADataCon !RdrName-      -- ^ Not a data constructor--   | PsErrRecordSyntaxInPatSynDecl !(LPat GhcPs)-      -- ^ Record syntax used in pattern synonym declaration--   | PsErrEmptyWhereInPatSynDecl !RdrName-      -- ^ Empty 'where' clause in pattern-synonym declaration--   | PsErrInvalidWhereBindInPatSynDecl !RdrName !(HsDecl GhcPs)-      -- ^ Invalid binding name in 'where' clause of pattern-synonym declaration--   | PsErrNoSingleWhereBindInPatSynDecl !RdrName !(HsDecl GhcPs)-      -- ^ Multiple bindings in 'where' clause of pattern-synonym declaration--   | PsErrDeclSpliceNotAtTopLevel !(SpliceDecl GhcPs)-      -- ^ Declaration splice not a top-level--   | PsErrInferredTypeVarNotAllowed-      -- ^ Inferred type variables not allowed here--   | PsErrMultipleNamesInStandaloneKindSignature [LIdP GhcPs]-      -- ^ Multiple names in standalone kind signatures--   | PsErrIllegalImportBundleForm-      -- ^ Illegal import bundle form--   | PsErrIllegalRoleName !FastString [Role]-      -- ^ Illegal role name--   | PsErrInvalidTypeSignature !(LHsExpr GhcPs)-      -- ^ Invalid type signature--   | PsErrUnexpectedTypeInDecl !(LHsType GhcPs) !SDoc !RdrName [LHsTypeArg GhcPs] !SDoc-      -- ^ Unexpected type in declaration--   | PsErrExpectedHyphen-      -- ^ Expected a hyphen--   | PsErrSpaceInSCC-      -- ^ Found a space in a SCC--   | PsErrEmptyDoubleQuotes !Bool-- Is TH on?-      -- ^ Found two single quotes--   | PsErrInvalidPackageName !FastString-      -- ^ Invalid package name--   | PsErrInvalidRuleActivationMarker-      -- ^ Invalid rule activation marker--   | PsErrLinearFunction-      -- ^ Linear function found but LinearTypes not enabled--   | PsErrInvalidCApiImport-      -- ^ Invalid CApi import--   | PsErrMultiWayIf-      -- ^ Multi-way if-expression found but MultiWayIf not enabled--   | PsErrExplicitForall !Bool -- is Unicode forall?-      -- ^ Explicit forall found but no extension allowing it is enabled--   | PsErrIllegalQualifiedDo !SDoc-      -- ^ Found qualified-do without QualifiedDo enabled--   | PsErrCmmParser !CmmParserError-      -- ^ Cmm parser error--   | PsErrIllegalTraditionalRecordSyntax !SDoc-      -- ^ Illegal traditional record syntax-      ---      -- TODO: distinguish errors without using SDoc--   | PsErrParseErrorInCmd !SDoc-      -- ^ Parse error in command-      ---      -- TODO: distinguish errors without using SDoc--   | PsErrParseErrorInPat !SDoc-      -- ^ Parse error in pattern-      ---      -- TODO: distinguish errors without using SDoc---newtype StarIsType = StarIsType Bool--data NumUnderscoreReason-   = NumUnderscore_Integral-   | NumUnderscore_Float-   deriving (Show,Eq,Ord)--data Hint-   = SuggestTH-   | SuggestRecursiveDo-   | SuggestDo-   | SuggestMissingDo-   | SuggestLetInDo-   | SuggestPatternSynonyms-   | SuggestInfixBindMaybeAtPat !RdrName-   | TypeApplicationsInPatternsOnlyDataCons -- ^ Type applications in patterns are only allowed on data constructors---data LexErrKind-   = LexErrKind_EOF        -- ^ End of input-   | LexErrKind_UTF8       -- ^ UTF-8 decoding error-   | LexErrKind_Char !Char -- ^ Error at given character-   deriving (Show,Eq,Ord)--data LexErr-   = LexError               -- ^ Lexical error-   | LexUnknownPragma       -- ^ Unknown pragma-   | LexErrorInPragma       -- ^ Lexical error in pragma-   | LexNumEscapeRange      -- ^ Numeric escape sequence out of range-   | LexStringCharLit       -- ^ Llexical error in string/character literal-   | LexStringCharLitEOF    -- ^ Unexpected end-of-file in string/character literal-   | LexUnterminatedComment -- ^ Unterminated `{-'-   | LexUnterminatedOptions -- ^ Unterminated OPTIONS pragma-   | LexUnterminatedQQ      -- ^ Unterminated quasiquotation---- | Errors from the Cmm parser-data CmmParserError-   = CmmUnknownPrimitive    !FastString -- ^ Unknown Cmm primitive-   | CmmUnknownMacro        !FastString -- ^ Unknown macro-   | CmmUnknownCConv        !String     -- ^ Unknown calling convention-   | CmmUnrecognisedSafety  !String     -- ^ Unrecognised safety-   | CmmUnrecognisedHint    !String     -- ^ Unrecognised hint
+ GHC/Parser/Errors/Basic.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE LambdaCase #-}+module GHC.Parser.Errors.Basic where++import GHC.Utils.Outputable ( SDoc, text )++-- | The operator symbol in the 'PsOperatorWhitespaceExtConflictMessage' diagnostic.+data OperatorWhitespaceSymbol+   = OperatorWhitespaceSymbol_PrefixPercent+   | OperatorWhitespaceSymbol_PrefixDollar+   | OperatorWhitespaceSymbol_PrefixDollarDollar++pprOperatorWhitespaceSymbol :: OperatorWhitespaceSymbol -> SDoc+pprOperatorWhitespaceSymbol = \case+  OperatorWhitespaceSymbol_PrefixPercent      -> text "%"+  OperatorWhitespaceSymbol_PrefixDollar       -> text "$"+  OperatorWhitespaceSymbol_PrefixDollarDollar -> text "$$"++-- | The operator occurrence type in the 'PsOperatorWhitespaceMessage' diagnostic.+data OperatorWhitespaceOccurrence+   = OperatorWhitespaceOccurrence_Prefix+   | OperatorWhitespaceOccurrence_Suffix+   | OperatorWhitespaceOccurrence_TightInfix
GHC/Parser/Errors/Ppr.hs view
@@ -1,638 +1,853 @@-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE FlexibleContexts #-}--module GHC.Parser.Errors.Ppr-   ( pprWarning-   , pprError-   )-where--import GHC.Prelude-import GHC.Driver.Flags-import GHC.Parser.Errors-import GHC.Parser.Types-import GHC.Types.Basic-import GHC.Types.SrcLoc-import GHC.Types.Name.Reader (starInfo, rdrNameOcc, opIsAt, mkUnqual)-import GHC.Types.Name.Occurrence (isSymOcc, occNameFS, varName)-import GHC.Utils.Error-import GHC.Utils.Outputable-import GHC.Utils.Misc-import GHC.Data.FastString-import GHC.Hs.Expr (prependQualified,HsExpr(..))-import GHC.Hs.Type (pprLHsContext)-import GHC.Builtin.Names (allNameStrings)-import GHC.Builtin.Types (filterCTuple)-import Data.List.NonEmpty (NonEmpty((:|)))--mkParserErr :: SrcSpan -> SDoc -> MsgEnvelope DecoratedSDoc-mkParserErr span doc = MsgEnvelope-   { errMsgSpan        = span-   , errMsgContext     = alwaysQualify-   , errMsgDiagnostic  = mkDecorated [doc]-   , errMsgSeverity    = SevError-   , errMsgReason      = NoReason-   }--mkParserWarn :: WarningFlag -> SrcSpan -> SDoc -> MsgEnvelope DecoratedSDoc-mkParserWarn flag span doc = MsgEnvelope-   { errMsgSpan        = span-   , errMsgContext     = alwaysQualify-   , errMsgDiagnostic  = mkDecorated [doc]-   , errMsgSeverity    = SevWarning-   , errMsgReason      = Reason flag-   }--pprWarning :: PsWarning -> MsgEnvelope DecoratedSDoc-pprWarning = \case-   PsWarnTab loc tc-      -> mkParserWarn Opt_WarnTabs loc $-          text "Tab character found here"-            <> (if tc == 1-                then text ""-                else text ", and in" <+> speakNOf (fromIntegral (tc - 1)) (text "further location"))-            <> text "."-            $+$ text "Please use spaces instead."--   PsWarnTransitionalLayout loc reason-      -> mkParserWarn Opt_WarnAlternativeLayoutRuleTransitional loc $-            text "transitional layout will not be accepted in the future:"-            $$ text (case reason of-               TransLayout_Where -> "`where' clause at the same depth as implicit layout block"-               TransLayout_Pipe  -> "`|' at the same depth as implicit layout block"-            )--   PsWarnBidirectionalFormatChars ((loc,_,desc) :| xs)-      -> mkParserWarn Opt_WarnUnicodeBidirectionalFormatCharacters (RealSrcSpan (realSrcLocSpan $ psRealLoc loc) Nothing) $-            text "A unicode bidirectional formatting character" <+> parens (text desc)-         $$ text "was found at offset" <+> ppr (bufPos (psBufPos loc)) <+> text "in the file"-         $$ (case xs of-           [] -> empty-           xs -> text "along with further bidirectional formatting characters at" <+> pprChars xs-            where-              pprChars [] = empty-              pprChars ((loc,_,desc):xs) = text "offset" <+> ppr (bufPos (psBufPos loc)) <> text ":" <+> text desc-                                       $$ pprChars xs-              )-         $$ text "Bidirectional formatting characters may be rendered misleadingly in certain editors"--   PsWarnUnrecognisedPragma loc-      -> mkParserWarn Opt_WarnUnrecognisedPragmas loc $-            text "Unrecognised pragma"--   PsWarnHaddockInvalidPos loc-      -> mkParserWarn Opt_WarnInvalidHaddock loc $-            text "A Haddock comment cannot appear in this position and will be ignored."--   PsWarnHaddockIgnoreMulti loc-      -> mkParserWarn Opt_WarnInvalidHaddock loc $-            text "Multiple Haddock comments for a single entity are not allowed." $$-            text "The extraneous comment will be ignored."--   PsWarnStarBinder loc-      -> mkParserWarn Opt_WarnStarBinder loc $-            text "Found binding occurrence of" <+> quotes (text "*")-            <+> text "yet StarIsType is enabled."-         $$ text "NB. To use (or export) this operator in"-            <+> text "modules with StarIsType,"-         $$ text "    including the definition module, you must qualify it."--   PsWarnStarIsType loc-      -> mkParserWarn Opt_WarnStarIsType loc $-             text "Using" <+> quotes (text "*")-             <+> text "(or its Unicode variant) to mean"-             <+> quotes (text "Data.Kind.Type")-          $$ text "relies on the StarIsType extension, which will become"-          $$ text "deprecated in the future."-          $$ text "Suggested fix: use" <+> quotes (text "Type")-           <+> text "from" <+> quotes (text "Data.Kind") <+> text "instead."--   PsWarnImportPreQualified loc-      -> mkParserWarn Opt_WarnPrepositiveQualifiedModule loc $-            text "Found" <+> quotes (text "qualified")-             <+> text "in prepositive position"-         $$ text "Suggested fix: place " <+> quotes (text "qualified")-             <+> text "after the module name instead."-         $$ text "To allow this, enable language extension 'ImportQualifiedPost'"--   PsWarnOperatorWhitespaceExtConflict loc sym-      -> mkParserWarn Opt_WarnOperatorWhitespaceExtConflict loc $-         let mk_prefix_msg operator_symbol extension_name syntax_meaning =-                  text "The prefix use of a" <+> quotes (text operator_symbol)-                    <+> text "would denote" <+> text syntax_meaning-               $$ nest 2 (text "were the" <+> text extension_name <+> text "extension enabled.")-               $$ text "Suggested fix: add whitespace after the"-                    <+> quotes (text operator_symbol) <> char '.'-         in-         case sym of-           OperatorWhitespaceSymbol_PrefixPercent -> mk_prefix_msg "%" "LinearTypes" "a multiplicity annotation"-           OperatorWhitespaceSymbol_PrefixDollar -> mk_prefix_msg "$" "TemplateHaskell" "an untyped splice"-           OperatorWhitespaceSymbol_PrefixDollarDollar -> mk_prefix_msg "$$" "TemplateHaskell" "a typed splice"---   PsWarnOperatorWhitespace loc sym occ_type-      -> mkParserWarn Opt_WarnOperatorWhitespace loc $-         let mk_msg occ_type_str =-                  text "The" <+> text occ_type_str <+> text "use of a" <+> quotes (ftext sym)-                    <+> text "might be repurposed as special syntax"-               $$ nest 2 (text "by a future language extension.")-               $$ text "Suggested fix: add whitespace around it."-         in-         case occ_type of-           OperatorWhitespaceOccurrence_Prefix -> mk_msg "prefix"-           OperatorWhitespaceOccurrence_Suffix -> mk_msg "suffix"-           OperatorWhitespaceOccurrence_TightInfix -> mk_msg "tight infix"--pprError :: PsError -> MsgEnvelope DecoratedSDoc-pprError err = mkParserErr (errLoc err) $ vcat-   (pp_err (errDesc err) : map pp_hint (errHints err))--pp_err :: PsErrorDesc -> SDoc-pp_err = \case-   PsErrLambdaCase-      -> text "Illegal lambda-case (use LambdaCase)"--   PsErrNumUnderscores reason-      -> text $ case reason of-            NumUnderscore_Integral -> "Use NumericUnderscores to allow underscores in integer literals"-            NumUnderscore_Float    -> "Use NumericUnderscores to allow underscores in floating literals"--   PsErrPrimStringInvalidChar-      -> text "primitive string literal must contain only characters <= \'\\xFF\'"--   PsErrMissingBlock-      -> text "Missing block"--   PsErrLexer err kind-      -> hcat-         [ text $ case err of-            LexError               -> "lexical error"-            LexUnknownPragma       -> "unknown pragma"-            LexErrorInPragma       -> "lexical error in pragma"-            LexNumEscapeRange      -> "numeric escape sequence out of range"-            LexStringCharLit       -> "lexical error in string/character literal"-            LexStringCharLitEOF    -> "unexpected end-of-file in string/character literal"-            LexUnterminatedComment -> "unterminated `{-'"-            LexUnterminatedOptions -> "unterminated OPTIONS pragma"-            LexUnterminatedQQ      -> "unterminated quasiquotation"---         , text $ case kind of-            LexErrKind_EOF    -> " at end of input"-            LexErrKind_UTF8   -> " (UTF-8 decoding error)"-            LexErrKind_Char c -> " at character " ++ show c-         ]--   PsErrSuffixAT-      -> text "Suffix occurrence of @. For an as-pattern, remove the leading whitespace."--   PsErrParse token-      | null token-      -> text "parse error (possibly incorrect indentation or mismatched brackets)"--      | otherwise-      -> text "parse error on input" <+> quotes (text token)--   PsErrCmmLexer-      -> text "Cmm lexical error"--   PsErrUnsupportedBoxedSumExpr s-      -> hang (text "Boxed sums not supported:") 2-              (pprSumOrTuple Boxed s)--   PsErrUnsupportedBoxedSumPat s-      -> hang (text "Boxed sums not supported:") 2-              (pprSumOrTuple Boxed s)--   PsErrUnexpectedQualifiedConstructor v-      -> hang (text "Expected an unqualified type constructor:") 2-              (ppr v)--   PsErrTupleSectionInPat-      -> text "Tuple section in pattern context"--   PsErrIllegalBangPattern e-      -> text "Illegal bang-pattern (use BangPatterns):" $$ ppr e--   PsErrOpFewArgs (StarIsType star_is_type) op-      -> text "Operator applied to too few arguments:" <+> ppr op-         $$ starInfo star_is_type op--   PsErrImportQualifiedTwice-      -> text "Multiple occurrences of 'qualified'"--   PsErrImportPostQualified-      -> text "Found" <+> quotes (text "qualified")-          <+> text "in postpositive position. "-         $$ text "To allow this, enable language extension 'ImportQualifiedPost'"--   PsErrIllegalExplicitNamespace-      -> text "Illegal keyword 'type' (use ExplicitNamespaces to enable)"--   PsErrVarForTyCon name-      -> text "Expecting a type constructor but found a variable,"-           <+> quotes (ppr name) <> text "."-         $$ if isSymOcc $ rdrNameOcc name-            then text "If" <+> quotes (ppr name) <+> text "is a type constructor"-                  <+> text "then enable ExplicitNamespaces and use the 'type' keyword."-            else empty--   PsErrIllegalPatSynExport-      -> text "Illegal export form (use PatternSynonyms to enable)"--   PsErrMalformedEntityString-      -> text "Malformed entity string"--   PsErrDotsInRecordUpdate-      -> text "You cannot use `..' in a record update"--   PsErrPrecedenceOutOfRange i-      -> text "Precedence out of range: " <> int i--   PsErrOverloadedRecordDotInvalid-      -> text "Use of OverloadedRecordDot '.' not valid ('.' isn't allowed when constructing records or in record patterns)"--   PsErrOverloadedRecordUpdateNoQualifiedFields-      -> text "Fields cannot be qualified when OverloadedRecordUpdate is enabled"--   PsErrOverloadedRecordUpdateNotEnabled-      -> text "OverloadedRecordUpdate needs to be enabled"--   PsErrInvalidDataCon t-      -> hang (text "Cannot parse data constructor in a data/newtype declaration:") 2-              (ppr t)--   PsErrInvalidInfixDataCon lhs tc rhs-      -> hang (text "Cannot parse an infix data constructor in a data/newtype declaration:")-            2 (ppr lhs <+> ppr tc <+> ppr rhs)--   PsErrUnpackDataCon-      -> text "{-# UNPACK #-} cannot be applied to a data constructor."--   PsErrUnexpectedKindAppInDataCon lhs ki-      -> hang (text "Unexpected kind application in a data/newtype declaration:") 2-              (ppr lhs <+> text "@" <> ppr ki)--   PsErrInvalidRecordCon p-      -> text "Not a record constructor:" <+> ppr p--   PsErrIllegalUnboxedStringInPat lit-      -> text "Illegal unboxed string literal in pattern:" $$ ppr lit--   PsErrDoNotationInPat-      -> text "do-notation in pattern"--   PsErrIfTheElseInPat-      -> text "(if ... then ... else ...)-syntax in pattern"--   PsErrLambdaCaseInPat-      -> text "(\\case ...)-syntax in pattern"--   PsErrCaseInPat-      -> text "(case ... of ...)-syntax in pattern"--   PsErrLetInPat-      -> text "(let ... in ...)-syntax in pattern"--   PsErrLambdaInPat-      -> text "Lambda-syntax in pattern."-         $$ text "Pattern matching on functions is not possible."--   PsErrArrowExprInPat e-      -> text "Expression syntax in pattern:" <+> ppr e--   PsErrArrowCmdInPat c-      -> text "Command syntax in pattern:" <+> ppr c--   PsErrArrowCmdInExpr c-      -> vcat-         [ text "Arrow command found where an expression was expected:"-         , nest 2 (ppr c)-         ]--   PsErrViewPatInExpr a b-      -> sep [ text "View pattern in expression context:"-             , nest 4 (ppr a <+> text "->" <+> ppr b)-             ]--   PsErrTypeAppWithoutSpace v e-      -> sep [ text "@-pattern in expression context:"-             , nest 4 (pprPrefixOcc v <> text "@" <> ppr e)-             ]-         $$ text "Type application syntax requires a space before '@'"---   PsErrLazyPatWithoutSpace e-      -> sep [ text "Lazy pattern in expression context:"-             , nest 4 (text "~" <> ppr e)-             ]-         $$ text "Did you mean to add a space after the '~'?"--   PsErrBangPatWithoutSpace e-      -> sep [ text "Bang pattern in expression context:"-             , nest 4 (text "!" <> ppr e)-             ]-         $$ text "Did you mean to add a space after the '!'?"--   PsErrUnallowedPragma prag-      -> hang (text "A pragma is not allowed in this position:") 2-              (ppr prag)--   PsErrQualifiedDoInCmd m-      -> hang (text "Parse error in command:") 2 $-            text "Found a qualified" <+> ppr m <> text ".do block in a command, but"-            $$ text "qualified 'do' is not supported in commands."--   PsErrParseErrorInCmd s-      -> hang (text "Parse error in command:") 2 s--   PsErrParseErrorInPat s-      -> text "Parse error in pattern:" <+> s---   PsErrInvalidInfixHole-      -> text "Invalid infix hole, expected an infix operator"--   PsErrSemiColonsInCondExpr c st t se e-      -> text "Unexpected semi-colons in conditional:"-         $$ nest 4 expr-         $$ text "Perhaps you meant to use DoAndIfThenElse?"-         where-            pprOptSemi True  = semi-            pprOptSemi False = empty-            expr = text "if"   <+> ppr c <> pprOptSemi st <+>-                   text "then" <+> ppr t <> pprOptSemi se <+>-                   text "else" <+> ppr e--   PsErrSemiColonsInCondCmd c st t se e-      -> text "Unexpected semi-colons in conditional:"-         $$ nest 4 expr-         $$ text "Perhaps you meant to use DoAndIfThenElse?"-         where-            pprOptSemi True  = semi-            pprOptSemi False = empty-            expr = text "if"   <+> ppr c <> pprOptSemi st <+>-                   text "then" <+> ppr t <> pprOptSemi se <+>-                   text "else" <+> ppr e---   PsErrAtInPatPos-      -> text "Found a binding for the"-         <+> quotes (text "@")-         <+> text "operator in a pattern position."-         $$ perhaps_as_pat--   PsErrLambdaCmdInFunAppCmd a-      -> pp_unexpected_fun_app (text "lambda command") a--   PsErrCaseCmdInFunAppCmd a-      -> pp_unexpected_fun_app (text "case command") a--   PsErrIfCmdInFunAppCmd a-      -> pp_unexpected_fun_app (text "if command") a--   PsErrLetCmdInFunAppCmd a-      -> pp_unexpected_fun_app (text "let command") a--   PsErrDoCmdInFunAppCmd a-      -> pp_unexpected_fun_app (text "do command") a--   PsErrDoInFunAppExpr m a-      -> pp_unexpected_fun_app (prependQualified m (text "do block")) a--   PsErrMDoInFunAppExpr m a-      -> pp_unexpected_fun_app (prependQualified m (text "mdo block")) a--   PsErrLambdaInFunAppExpr a-      -> pp_unexpected_fun_app (text "lambda expression") a--   PsErrCaseInFunAppExpr a-      -> pp_unexpected_fun_app (text "case expression") a--   PsErrLambdaCaseInFunAppExpr a-      -> pp_unexpected_fun_app (text "lambda-case expression") a--   PsErrLetInFunAppExpr a-      -> pp_unexpected_fun_app (text "let expression") a--   PsErrIfInFunAppExpr a-      -> pp_unexpected_fun_app (text "if expression") a--   PsErrProcInFunAppExpr a-      -> pp_unexpected_fun_app (text "proc expression") a--   PsErrMalformedTyOrClDecl ty-      -> text "Malformed head of type or class declaration:"-         <+> ppr ty--   PsErrIllegalWhereInDataDecl-      -> vcat-            [ text "Illegal keyword 'where' in data declaration"-            , text "Perhaps you intended to use GADTs or a similar language"-            , text "extension to enable syntax: data T where"-            ]--   PsErrIllegalTraditionalRecordSyntax s-      -> text "Illegal record syntax (use TraditionalRecordSyntax):"-         <+> s--   PsErrParseErrorOnInput occ-      -> text "parse error on input" <+> ftext (occNameFS occ)--   PsErrIllegalDataTypeContext c-      -> text "Illegal datatype context (use DatatypeContexts):"-         <+> pprLHsContext (Just c)--   PsErrMalformedDecl what for-      -> text "Malformed" <+> what-         <+> text "declaration for" <+> quotes (ppr for)--   PsErrUnexpectedTypeAppInDecl ki what for-      -> vcat [ text "Unexpected type application"-                <+> text "@" <> ppr ki-              , text "In the" <+> what-                <+> text "declaration for"-                <+> quotes (ppr for)-              ]--   PsErrNotADataCon name-      -> text "Not a data constructor:" <+> quotes (ppr name)--   PsErrRecordSyntaxInPatSynDecl pat-      -> text "record syntax not supported for pattern synonym declarations:"-         $$ ppr pat--   PsErrEmptyWhereInPatSynDecl patsyn_name-      -> text "pattern synonym 'where' clause cannot be empty"-         $$ text "In the pattern synonym declaration for: "-            <+> ppr (patsyn_name)--   PsErrInvalidWhereBindInPatSynDecl patsyn_name decl-      -> text "pattern synonym 'where' clause must bind the pattern synonym's name"-         <+> quotes (ppr patsyn_name) $$ ppr decl--   PsErrNoSingleWhereBindInPatSynDecl _patsyn_name decl-      -> text "pattern synonym 'where' clause must contain a single binding:"-         $$ ppr decl--   PsErrDeclSpliceNotAtTopLevel d-      -> hang (text "Declaration splices are allowed only"-               <+> text "at the top level:")-           2 (ppr d)--   PsErrInferredTypeVarNotAllowed-      -> text "Inferred type variables are not allowed here"--   PsErrIllegalRoleName role nearby-      -> text "Illegal role name" <+> quotes (ppr role)-         $$ case nearby of-             []  -> empty-             [r] -> text "Perhaps you meant" <+> quotes (ppr r)-             -- will this last case ever happen??-             _   -> hang (text "Perhaps you meant one of these:")-                         2 (pprWithCommas (quotes . ppr) nearby)--   PsErrMultipleNamesInStandaloneKindSignature vs-      -> vcat [ hang (text "Standalone kind signatures do not support multiple names at the moment:")-                2 (pprWithCommas ppr vs)-              , text "See https://gitlab.haskell.org/ghc/ghc/issues/16754 for details."-              ]--   PsErrIllegalImportBundleForm-      -> text "Illegal import form, this syntax can only be used to bundle"-         $+$ text "pattern synonyms with types in module exports."--   PsErrInvalidTypeSignature lhs-      -> text "Invalid type signature:"-         <+> ppr lhs-         <+> text ":: ..."-         $$ text hint-         where-         hint | foreign_RDR `looks_like` lhs-              = "Perhaps you meant to use ForeignFunctionInterface?"-              | default_RDR `looks_like` lhs-              = "Perhaps you meant to use DefaultSignatures?"-              | pattern_RDR `looks_like` lhs-              = "Perhaps you meant to use PatternSynonyms?"-              | otherwise-              = "Should be of form <variable> :: <type>"--         -- A common error is to forget the ForeignFunctionInterface flag-         -- so check for that, and suggest.  cf #3805-         -- Sadly 'foreign import' still barfs 'parse error' because-         --  'import' is a keyword-         -- looks_like :: RdrName -> LHsExpr GhcPs -> Bool -- AZ-         looks_like s (L _ (HsVar _ (L _ v))) = v == s-         looks_like s (L _ (HsApp _ lhs _))   = looks_like s lhs-         looks_like _ _                       = False--         foreign_RDR = mkUnqual varName (fsLit "foreign")-         default_RDR = mkUnqual varName (fsLit "default")-         pattern_RDR = mkUnqual varName (fsLit "pattern")--   PsErrUnexpectedTypeInDecl t what tc tparms equals_or_where-      -> vcat [ text "Unexpected type" <+> quotes (ppr t)-              , text "In the" <+> what-                <+> ptext (sLit "declaration for") <+> quotes tc'-              , vcat[ (text "A" <+> what-                       <+> ptext (sLit "declaration should have form"))-              , nest 2-                (what-                 <+> tc'-                 <+> hsep (map text (takeList tparms allNameStrings))-                 <+> equals_or_where) ] ]-          where-            -- Avoid printing a constraint tuple in the error message. Print-            -- a plain old tuple instead (since that's what the user probably-            -- wrote). See #14907-            tc' = ppr $ filterCTuple tc--   PsErrCmmParser cmm_err -> case cmm_err of-      CmmUnknownPrimitive name     -> text "unknown primitive" <+> ftext name-      CmmUnknownMacro fun          -> text "unknown macro" <+> ftext fun-      CmmUnknownCConv cconv        -> text "unknown calling convention:" <+> text cconv-      CmmUnrecognisedSafety safety -> text "unrecognised safety" <+> text safety-      CmmUnrecognisedHint hint     -> text "unrecognised hint:" <+> text hint--   PsErrExpectedHyphen-      -> text "Expected a hyphen"--   PsErrSpaceInSCC-      -> text "Spaces are not allowed in SCCs"--   PsErrEmptyDoubleQuotes th_on-      -> if th_on then vcat (msg ++ th_msg) else vcat msg-         where-            msg    = [ text "Parser error on `''`"-                     , text "Character literals may not be empty"-                     ]-            th_msg = [ text "Or perhaps you intended to use quotation syntax of TemplateHaskell,"-                     , text "but the type variable or constructor is missing"-                     ]--   PsErrInvalidPackageName pkg-      -> vcat-            [ text "Parse error" <> colon <+> quotes (ftext pkg)-            , text "Version number or non-alphanumeric" <+>-              text "character in package name"-            ]--   PsErrInvalidRuleActivationMarker-      -> text "Invalid rule activation marker"--   PsErrLinearFunction-      -> text "Enable LinearTypes to allow linear functions"--   PsErrInvalidCApiImport {}-      -> text "Wrapper stubs can't be used with CApiFFI."--   PsErrMultiWayIf-      -> text "Multi-way if-expressions need MultiWayIf turned on"--   PsErrExplicitForall is_unicode-      -> vcat-         [ text "Illegal symbol" <+> quotes (forallSym is_unicode) <+> text "in type"-         , text "Perhaps you intended to use RankNTypes or a similar language"-         , text "extension to enable explicit-forall syntax:" <+>-           forallSym is_unicode <+> text "<tvs>. <type>"-         ]-         where-          forallSym True  = text "∀"-          forallSym False = text "forall"--   PsErrIllegalQualifiedDo qdoDoc-      -> vcat-         [ text "Illegal qualified" <+> quotes qdoDoc <+> text "block"-         , text "Perhaps you intended to use QualifiedDo"-         ]--pp_unexpected_fun_app :: Outputable a => SDoc -> a -> SDoc-pp_unexpected_fun_app e a =-   text "Unexpected " <> e <> text " in function application:"-    $$ nest 4 (ppr a)-    $$ text "You could write it with parentheses"-    $$ text "Or perhaps you meant to enable BlockArguments?"--pp_hint :: Hint -> SDoc-pp_hint = \case-   SuggestTH              -> text "Perhaps you intended to use TemplateHaskell"-   SuggestDo              -> text "Perhaps this statement should be within a 'do' block?"-   SuggestMissingDo       -> text "Possibly caused by a missing 'do'?"-   SuggestRecursiveDo     -> text "Perhaps you intended to use RecursiveDo"-   SuggestLetInDo         -> text "Perhaps you need a 'let' in a 'do' block?"-                             $$ text "e.g. 'let x = 5' instead of 'x = 5'"-   SuggestPatternSynonyms -> text "Perhaps you intended to use PatternSynonyms"--   SuggestInfixBindMaybeAtPat fun-      -> text "In a function binding for the"-            <+> quotes (ppr fun)-            <+> text "operator."-         $$ if opIsAt fun-               then perhaps_as_pat-               else empty-   TypeApplicationsInPatternsOnlyDataCons ->-     text "Type applications in patterns are only allowed on data constructors."--perhaps_as_pat :: SDoc-perhaps_as_pat = text "Perhaps you meant an as-pattern, which must not be surrounded by whitespace"+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE FlexibleContexts #-}++{-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic PsMessage++module GHC.Parser.Errors.Ppr where++import GHC.Prelude+import GHC.Driver.Flags+import GHC.Parser.Errors.Basic+import GHC.Parser.Errors.Types+import GHC.Parser.Types+import GHC.Types.Basic+import GHC.Types.Hint+import GHC.Types.Error+import GHC.Types.Hint.Ppr (perhapsAsPat)+import GHC.Types.SrcLoc+import GHC.Types.Name.Reader ( opIsAt, rdrNameOcc, mkUnqual )+import GHC.Types.Name.Occurrence (isSymOcc, occNameFS, varName)+import GHC.Utils.Outputable+import GHC.Utils.Misc+import GHC.Data.FastString+import GHC.Data.Maybe (catMaybes)+import GHC.Hs.Expr (prependQualified, HsExpr(..), LamCaseVariant(..), lamCaseKeyword)+import GHC.Hs.Type (pprLHsContext)+import GHC.Builtin.Names (allNameStrings)+import GHC.Builtin.Types (filterCTuple)+import qualified GHC.LanguageExtensions as LangExt+import Data.List.NonEmpty (NonEmpty((:|)))+++instance Diagnostic PsMessage where+  diagnosticMessage = \case+    PsUnknownMessage m+      -> diagnosticMessage m++    PsHeaderMessage m+      -> psHeaderMessageDiagnostic m++    PsWarnHaddockInvalidPos+       -> mkSimpleDecorated $ text "A Haddock comment cannot appear in this position and will be ignored."+    PsWarnHaddockIgnoreMulti+       -> mkSimpleDecorated $+            text "Multiple Haddock comments for a single entity are not allowed." $$+            text "The extraneous comment will be ignored."+    PsWarnBidirectionalFormatChars ((loc,_,desc) :| xs)+      -> mkSimpleDecorated $+            text "A unicode bidirectional formatting character" <+> parens (text desc)+         $$ text "was found at offset" <+> ppr (bufPos (psBufPos loc)) <+> text "in the file"+         $$ (case xs of+           [] -> empty+           xs -> text "along with further bidirectional formatting characters at" <+> pprChars xs+            where+              pprChars [] = empty+              pprChars ((loc,_,desc):xs) = text "offset" <+> ppr (bufPos (psBufPos loc)) <> text ":" <+> text desc+                                       $$ pprChars xs+              )+         $$ text "Bidirectional formatting characters may be rendered misleadingly in certain editors"++    PsWarnTab tc+      -> mkSimpleDecorated $+           text "Tab character found here"+             <> (if tc == 1+                 then text ""+                 else text ", and in" <+> speakNOf (fromIntegral (tc - 1)) (text "further location"))+             <> text "."+    PsWarnTransitionalLayout reason+      -> mkSimpleDecorated $+            text "transitional layout will not be accepted in the future:"+            $$ text (case reason of+               TransLayout_Where -> "`where' clause at the same depth as implicit layout block"+               TransLayout_Pipe  -> "`|' at the same depth as implicit layout block"+            )+    PsWarnOperatorWhitespaceExtConflict sym+      -> let mk_prefix_msg extension_name syntax_meaning =+                  text "The prefix use of a" <+> quotes (pprOperatorWhitespaceSymbol sym)+                    <+> text "would denote" <+> text syntax_meaning+               $$ nest 2 (text "were the" <+> text extension_name <+> text "extension enabled.")+         in mkSimpleDecorated $+         case sym of+           OperatorWhitespaceSymbol_PrefixPercent -> mk_prefix_msg "LinearTypes" "a multiplicity annotation"+           OperatorWhitespaceSymbol_PrefixDollar -> mk_prefix_msg "TemplateHaskell" "an untyped splice"+           OperatorWhitespaceSymbol_PrefixDollarDollar -> mk_prefix_msg "TemplateHaskell" "a typed splice"+    PsWarnOperatorWhitespace sym occ_type+      -> let mk_msg occ_type_str =+                  text "The" <+> text occ_type_str <+> text "use of a" <+> quotes (ftext sym)+                    <+> text "might be repurposed as special syntax"+               $$ nest 2 (text "by a future language extension.")+         in mkSimpleDecorated $+         case occ_type of+           OperatorWhitespaceOccurrence_Prefix -> mk_msg "prefix"+           OperatorWhitespaceOccurrence_Suffix -> mk_msg "suffix"+           OperatorWhitespaceOccurrence_TightInfix -> mk_msg "tight infix"+    PsWarnStarBinder+      -> mkSimpleDecorated $+            text "Found binding occurrence of" <+> quotes (text "*")+            <+> text "yet StarIsType is enabled."+    PsWarnStarIsType+      -> mkSimpleDecorated $+             text "Using" <+> quotes (text "*")+             <+> text "(or its Unicode variant) to mean"+             <+> quotes (text "Data.Kind.Type")+          $$ text "relies on the StarIsType extension, which will become"+          $$ text "deprecated in the future."+    PsWarnUnrecognisedPragma+      -> mkSimpleDecorated $ text "Unrecognised pragma"+    PsWarnMisplacedPragma prag+      -> mkSimpleDecorated $ text "Misplaced" <+> pprFileHeaderPragmaType prag <+> text "pragma"+    PsWarnImportPreQualified+      -> mkSimpleDecorated $+            text "Found" <+> quotes (text "qualified")+             <+> text "in prepositive position"++    PsErrLexer err kind+      -> mkSimpleDecorated $ hcat+           [ text $ case err of+              LexError               -> "lexical error"+              LexUnknownPragma       -> "unknown pragma"+              LexErrorInPragma       -> "lexical error in pragma"+              LexNumEscapeRange      -> "numeric escape sequence out of range"+              LexStringCharLit       -> "lexical error in string/character literal"+              LexStringCharLitEOF    -> "unexpected end-of-file in string/character literal"+              LexUnterminatedComment -> "unterminated `{-'"+              LexUnterminatedOptions -> "unterminated OPTIONS pragma"+              LexUnterminatedQQ      -> "unterminated quasiquotation"++           , text $ case kind of+              LexErrKind_EOF    -> " at end of input"+              LexErrKind_UTF8   -> " (UTF-8 decoding error)"+              LexErrKind_Char c -> " at character " ++ show c+           ]+    PsErrParse token _details+      | null token+      -> mkSimpleDecorated $ text "parse error (possibly incorrect indentation or mismatched brackets)"+      | otherwise+      -> mkSimpleDecorated $ text "parse error on input" <+> quotes (text token)+    PsErrCmmLexer+      -> mkSimpleDecorated $ text "Cmm lexical error"+    PsErrCmmParser cmm_err -> mkSimpleDecorated $ case cmm_err of+      CmmUnknownPrimitive name     -> text "unknown primitive" <+> ftext name+      CmmUnknownMacro fun          -> text "unknown macro" <+> ftext fun+      CmmUnknownCConv cconv        -> text "unknown calling convention:" <+> text cconv+      CmmUnrecognisedSafety safety -> text "unrecognised safety" <+> text safety+      CmmUnrecognisedHint hint     -> text "unrecognised hint:" <+> text hint++    PsErrTypeAppWithoutSpace v e+      -> mkSimpleDecorated $+           sep [ text "@-pattern in expression context:"+               , nest 4 (pprPrefixOcc v <> text "@" <> ppr e)+               ]+           $$ text "Type application syntax requires a space before '@'"+    PsErrLazyPatWithoutSpace e+      -> mkSimpleDecorated $+           sep [ text "Lazy pattern in expression context:"+               , nest 4 (text "~" <> ppr e)+               ]+           $$ text "Did you mean to add a space after the '~'?"+    PsErrBangPatWithoutSpace e+      -> mkSimpleDecorated $+           sep [ text "Bang pattern in expression context:"+               , nest 4 (text "!" <> ppr e)+               ]+           $$ text "Did you mean to add a space after the '!'?"+    PsErrInvalidInfixHole+      -> mkSimpleDecorated $ text "Invalid infix hole, expected an infix operator"+    PsErrExpectedHyphen+      -> mkSimpleDecorated $ text "Expected a hyphen"+    PsErrSpaceInSCC+      -> mkSimpleDecorated $ text "Spaces are not allowed in SCCs"+    PsErrEmptyDoubleQuotes _th_on+      -> mkSimpleDecorated $ vcat msg+         where+            msg    = [ text "Parser error on `''`"+                     , text "Character literals may not be empty"+                     ]+    PsErrLambdaCase+      -- we can't get this error for \cases, since without -XLambdaCase, that's+      -- just a regular lambda expression+      -> mkSimpleDecorated $ text "Illegal" <+> lamCaseKeyword LamCase+    PsErrEmptyLambda+      -> mkSimpleDecorated $ text "A lambda requires at least one parameter"+    PsErrLinearFunction+      -> mkSimpleDecorated $ text "Illegal use of linear functions"+    PsErrOverloadedRecordUpdateNotEnabled+      -> mkSimpleDecorated $ text "Illegal overloaded record update"+    PsErrMultiWayIf+      -> mkSimpleDecorated $ text "Illegal multi-way if-expression"+    PsErrNumUnderscores reason+      -> mkSimpleDecorated $+           text $ case reason of+             NumUnderscore_Integral -> "Illegal underscores in integer literals"+             NumUnderscore_Float    -> "Illegal underscores in floating literals"+    PsErrIllegalBangPattern e+      -> mkSimpleDecorated $ text "Illegal bang-pattern" $$ ppr e+    PsErrOverloadedRecordDotInvalid+      -> mkSimpleDecorated $+           text "Use of OverloadedRecordDot '.' not valid ('.' isn't allowed when constructing records or in record patterns)"+    PsErrIllegalPatSynExport+      -> mkSimpleDecorated $ text "Illegal export form"+    PsErrOverloadedRecordUpdateNoQualifiedFields+      -> mkSimpleDecorated $ text "Fields cannot be qualified when OverloadedRecordUpdate is enabled"+    PsErrExplicitForall is_unicode+      -> mkSimpleDecorated $ text "Illegal symbol" <+> quotes (forallSym is_unicode) <+> text "in type"+    PsErrIllegalQualifiedDo qdoDoc+      -> mkSimpleDecorated $+           text "Illegal qualified" <+> quotes qdoDoc <+> text "block"+    PsErrQualifiedDoInCmd m+      -> mkSimpleDecorated $+           hang (text "Parse error in command:") 2 $+             text "Found a qualified" <+> ppr m <> text ".do block in a command, but"+             $$ text "qualified 'do' is not supported in commands."+    PsErrRecordSyntaxInPatSynDecl pat+      -> mkSimpleDecorated $+           text "record syntax not supported for pattern synonym declarations:"+           $$ ppr pat+    PsErrEmptyWhereInPatSynDecl patsyn_name+      -> mkSimpleDecorated $+           text "pattern synonym 'where' clause cannot be empty"+           $$ text "In the pattern synonym declaration for: "+              <+> ppr (patsyn_name)+    PsErrInvalidWhereBindInPatSynDecl patsyn_name decl+      -> mkSimpleDecorated $+           text "pattern synonym 'where' clause must bind the pattern synonym's name"+           <+> quotes (ppr patsyn_name) $$ ppr decl+    PsErrNoSingleWhereBindInPatSynDecl _patsyn_name decl+      -> mkSimpleDecorated $+           text "pattern synonym 'where' clause must contain a single binding:"+           $$ ppr decl+    PsErrDeclSpliceNotAtTopLevel d+      -> mkSimpleDecorated $+           hang (text "Declaration splices are allowed only"+                 <+> text "at the top level:")+             2 (ppr d)+    PsErrMultipleNamesInStandaloneKindSignature vs+      -> mkSimpleDecorated $+           vcat [ hang (text "Standalone kind signatures do not support multiple names at the moment:")+                  2 (pprWithCommas ppr vs)+                , text "See https://gitlab.haskell.org/ghc/ghc/issues/16754 for details."+                ]+    PsErrIllegalExplicitNamespace+      -> mkSimpleDecorated $+           text "Illegal keyword 'type'"++    PsErrUnallowedPragma prag+      -> mkSimpleDecorated $+           hang (text "A pragma is not allowed in this position:") 2+                (ppr prag)+    PsErrImportPostQualified+      -> mkSimpleDecorated $+           text "Found" <+> quotes (text "qualified")+             <+> text "in postpositive position. "+    PsErrImportQualifiedTwice+      -> mkSimpleDecorated $ text "Multiple occurrences of 'qualified'"+    PsErrIllegalImportBundleForm+      -> mkSimpleDecorated $+           text "Illegal import form, this syntax can only be used to bundle"+           $+$ text "pattern synonyms with types in module exports."+    PsErrInvalidRuleActivationMarker+      -> mkSimpleDecorated $ text "Invalid rule activation marker"++    PsErrMissingBlock+      -> mkSimpleDecorated $ text "Missing block"+    PsErrUnsupportedBoxedSumExpr s+      -> mkSimpleDecorated $+           hang (text "Boxed sums not supported:") 2+                (pprSumOrTuple Boxed s)+    PsErrUnsupportedBoxedSumPat s+      -> mkSimpleDecorated $+           hang (text "Boxed sums not supported:") 2+                (pprSumOrTuple Boxed s)+    PsErrUnexpectedQualifiedConstructor v+      -> mkSimpleDecorated $+           hang (text "Expected an unqualified type constructor:") 2+                (ppr v)+    PsErrTupleSectionInPat+      -> mkSimpleDecorated $ text "Tuple section in pattern context"+    PsErrOpFewArgs _ op+      -> mkSimpleDecorated $+           text "Operator applied to too few arguments:" <+> ppr op+    PsErrVarForTyCon name+      -> mkSimpleDecorated $+           text "Expecting a type constructor but found a variable,"+             <+> quotes (ppr name) <> text "."+           $$ if isSymOcc $ rdrNameOcc name+              then text "If" <+> quotes (ppr name) <+> text "is a type constructor"+                    <+> text "then enable ExplicitNamespaces and use the 'type' keyword."+              else empty+    PsErrMalformedEntityString+      -> mkSimpleDecorated $ text "Malformed entity string"+    PsErrDotsInRecordUpdate+      -> mkSimpleDecorated $ text "You cannot use `..' in a record update"+    PsErrInvalidDataCon t+      -> mkSimpleDecorated $+           hang (text "Cannot parse data constructor in a data/newtype declaration:") 2+                (ppr t)+    PsErrInvalidInfixDataCon lhs tc rhs+      -> mkSimpleDecorated $+           hang (text "Cannot parse an infix data constructor in a data/newtype declaration:") 2+                (ppr lhs <+> ppr tc <+> ppr rhs)+    PsErrIllegalPromotionQuoteDataCon name+      -> mkSimpleDecorated $+           text "Illegal promotion quote mark in the declaration of" $$+           text "data/newtype constructor" <+> pprPrefixOcc name+    PsErrUnpackDataCon+      -> mkSimpleDecorated $ text "{-# UNPACK #-} cannot be applied to a data constructor."+    PsErrUnexpectedKindAppInDataCon lhs ki+      -> mkSimpleDecorated $+           hang (text "Unexpected kind application in a data/newtype declaration:") 2+                (ppr lhs <+> text "@" <> ppr ki)+    PsErrInvalidRecordCon p+      -> mkSimpleDecorated $ text "Not a record constructor:" <+> ppr p+    PsErrIllegalUnboxedStringInPat lit+      -> mkSimpleDecorated $ text "Illegal unboxed string literal in pattern:" $$ ppr lit+    PsErrIllegalUnboxedFloatingLitInPat lit+      -> mkSimpleDecorated $ text "Illegal unboxed floating point literal in pattern:" $$ ppr lit+    PsErrDoNotationInPat+      -> mkSimpleDecorated $ text "do-notation in pattern"+    PsErrIfThenElseInPat+      -> mkSimpleDecorated $ text "(if ... then ... else ...)-syntax in pattern"+    (PsErrLambdaCaseInPat lc_variant)+      -> mkSimpleDecorated $ lamCaseKeyword lc_variant <+> text "...-syntax in pattern"+    PsErrCaseInPat+      -> mkSimpleDecorated $ text "(case ... of ...)-syntax in pattern"+    PsErrLetInPat+      -> mkSimpleDecorated $ text "(let ... in ...)-syntax in pattern"+    PsErrLambdaInPat+      -> mkSimpleDecorated $+           text "Lambda-syntax in pattern."+           $$ text "Pattern matching on functions is not possible."+    PsErrArrowExprInPat e+      -> mkSimpleDecorated $ text "Expression syntax in pattern:" <+> ppr e+    PsErrArrowCmdInPat c+      -> mkSimpleDecorated $ text "Command syntax in pattern:" <+> ppr c+    PsErrArrowCmdInExpr c+      -> mkSimpleDecorated $+           vcat+           [ text "Arrow command found where an expression was expected:"+           , nest 2 (ppr c)+           ]+    PsErrViewPatInExpr a b+      -> mkSimpleDecorated $+           sep [ text "View pattern in expression context:"+               , nest 4 (ppr a <+> text "->" <+> ppr b)+               ]+    PsErrLambdaCmdInFunAppCmd a+      -> mkSimpleDecorated $ pp_unexpected_fun_app (text "lambda command") a+    PsErrCaseCmdInFunAppCmd a+      -> mkSimpleDecorated $ pp_unexpected_fun_app (text "case command") a+    PsErrLambdaCaseCmdInFunAppCmd lc_variant a+      -> mkSimpleDecorated $+           pp_unexpected_fun_app (lamCaseKeyword lc_variant <+> text "command") a+    PsErrIfCmdInFunAppCmd a+      -> mkSimpleDecorated $ pp_unexpected_fun_app (text "if command") a+    PsErrLetCmdInFunAppCmd a+      -> mkSimpleDecorated $ pp_unexpected_fun_app (text "let command") a+    PsErrDoCmdInFunAppCmd a+      -> mkSimpleDecorated $ pp_unexpected_fun_app (text "do command") a+    PsErrDoInFunAppExpr m a+      -> mkSimpleDecorated $ pp_unexpected_fun_app (prependQualified m (text "do block")) a+    PsErrMDoInFunAppExpr m a+      -> mkSimpleDecorated $ pp_unexpected_fun_app (prependQualified m (text "mdo block")) a+    PsErrLambdaInFunAppExpr a+      -> mkSimpleDecorated $ pp_unexpected_fun_app (text "lambda expression") a+    PsErrCaseInFunAppExpr a+      -> mkSimpleDecorated $ pp_unexpected_fun_app (text "case expression") a+    PsErrLambdaCaseInFunAppExpr lc_variant a+      -> mkSimpleDecorated $ pp_unexpected_fun_app (lamCaseKeyword lc_variant <+> text "expression") a+    PsErrLetInFunAppExpr a+      -> mkSimpleDecorated $ pp_unexpected_fun_app (text "let expression") a+    PsErrIfInFunAppExpr a+      -> mkSimpleDecorated $ pp_unexpected_fun_app (text "if expression") a+    PsErrProcInFunAppExpr a+      -> mkSimpleDecorated $ pp_unexpected_fun_app (text "proc expression") a+    PsErrMalformedTyOrClDecl ty+      -> mkSimpleDecorated $+           text "Malformed head of type or class declaration:" <+> ppr ty+    PsErrIllegalWhereInDataDecl+      -> mkSimpleDecorated $ text "Illegal keyword 'where' in data declaration"+    PsErrIllegalDataTypeContext c+      -> mkSimpleDecorated $+           text "Illegal datatype context:"+             <+> pprLHsContext (Just c)+    PsErrPrimStringInvalidChar+      -> mkSimpleDecorated $ text "primitive string literal must contain only characters <= \'\\xFF\'"+    PsErrSuffixAT+      -> mkSimpleDecorated $+           text "Suffix occurrence of @. For an as-pattern, remove the leading whitespace."+    PsErrPrecedenceOutOfRange i+      -> mkSimpleDecorated $ text "Precedence out of range: " <> int i+    PsErrSemiColonsInCondExpr c st t se e+      -> mkSimpleDecorated $+           text "Unexpected semi-colons in conditional:"+           $$ nest 4 expr+         where+            pprOptSemi True  = semi+            pprOptSemi False = empty+            expr = text "if"   <+> ppr c <> pprOptSemi st <+>+                   text "then" <+> ppr t <> pprOptSemi se <+>+                   text "else" <+> ppr e+    PsErrSemiColonsInCondCmd c st t se e+      -> mkSimpleDecorated $+           text "Unexpected semi-colons in conditional:"+           $$ nest 4 expr+         where+            pprOptSemi True  = semi+            pprOptSemi False = empty+            expr = text "if"   <+> ppr c <> pprOptSemi st <+>+                   text "then" <+> ppr t <> pprOptSemi se <+>+                   text "else" <+> ppr e+    PsErrAtInPatPos+      -> mkSimpleDecorated $+           text "Found a binding for the"+           <+> quotes (text "@")+           <+> text "operator in a pattern position."+           $$ perhapsAsPat+    PsErrParseErrorOnInput occ+      -> mkSimpleDecorated $ text "parse error on input" <+> ftext (occNameFS occ)+    PsErrMalformedDecl what for+      -> mkSimpleDecorated $+           text "Malformed" <+> what+           <+> text "declaration for" <+> quotes (ppr for)+    PsErrUnexpectedTypeAppInDecl ki what for+      -> mkSimpleDecorated $+           vcat [ text "Unexpected type application"+                  <+> text "@" <> ppr ki+                , text "In the" <+> what+                  <+> text "declaration for"+                  <+> quotes (ppr for)+                ]+    PsErrNotADataCon name+      -> mkSimpleDecorated $ text "Not a data constructor:" <+> quotes (ppr name)+    PsErrInferredTypeVarNotAllowed+      -> mkSimpleDecorated $ text "Inferred type variables are not allowed here"+    PsErrIllegalTraditionalRecordSyntax s+      -> mkSimpleDecorated $+           text "Illegal record syntax:" <+> s+    PsErrParseErrorInCmd s+      -> mkSimpleDecorated $ hang (text "Parse error in command:") 2 s+    PsErrInPat s details+      -> let msg  = parse_error_in_pat+             body = case details of+                 PEIP_NegApp -> text "-" <> ppr s+                 PEIP_TypeArgs peipd_tyargs+                   | not (null peipd_tyargs) -> ppr s <+> vcat [+                               hsep [text "@" <> ppr t | t <- peipd_tyargs]+                             , text "Type applications in patterns are only allowed on data constructors."+                             ]+                   | otherwise -> ppr s+                 PEIP_OtherPatDetails (ParseContext (Just fun) _)+                  -> ppr s <+> text "In a function binding for the"+                                     <+> quotes (ppr fun)+                                     <+> text "operator."+                                  $$ if opIsAt fun+                                        then perhapsAsPat+                                        else empty+                 _  -> ppr s+         in mkSimpleDecorated $ msg <+> body+    PsErrParseRightOpSectionInPat infixOcc s+      -> mkSimpleDecorated $ parse_error_in_pat <+> pprInfixOcc infixOcc <> ppr s+    PsErrIllegalRoleName role _nearby+      -> mkSimpleDecorated $+           text "Illegal role name" <+> quotes (ppr role)+    PsErrInvalidTypeSignature lhs+      -> mkSimpleDecorated $+           text "Invalid type signature:"+           <+> ppr lhs+           <+> text ":: ..."+    PsErrUnexpectedTypeInDecl t what tc tparms equals_or_where+       -> mkSimpleDecorated $+            vcat [ text "Unexpected type" <+> quotes (ppr t)+                 , text "In the" <+> what+                   <+> text "declaration for" <+> quotes tc'+                 , vcat[ (text "A" <+> what+                          <+> text "declaration should have form")+                 , nest 2+                   (what+                    <+> tc'+                    <+> hsep (map text (takeList tparms allNameStrings))+                    <+> equals_or_where) ] ]+           where+             -- Avoid printing a constraint tuple in the error message. Print+             -- a plain old tuple instead (since that's what the user probably+             -- wrote). See #14907+             tc' = ppr $ filterCTuple tc+    PsErrInvalidPackageName pkg+      -> mkSimpleDecorated $ vcat+            [ text "Parse error" <> colon <+> quotes (ftext pkg)+            , text "Version number or non-alphanumeric" <+>+              text "character in package name"+            ]++    PsErrIllegalGadtRecordMultiplicity arr+      -> mkSimpleDecorated $ vcat+            [ text "Parse error" <> colon <+> quotes (ppr arr)+            , text "Record constructors in GADTs must use an ordinary, non-linear arrow."+            ]+    PsErrInvalidCApiImport {} -> mkSimpleDecorated $ vcat [ text "Wrapper stubs can't be used with CApiFFI."]++  diagnosticReason  = \case+    PsUnknownMessage m                            -> diagnosticReason m+    PsHeaderMessage  m                            -> psHeaderMessageReason m+    PsWarnBidirectionalFormatChars{}              -> WarningWithFlag Opt_WarnUnicodeBidirectionalFormatCharacters+    PsWarnTab{}                                   -> WarningWithFlag Opt_WarnTabs+    PsWarnTransitionalLayout{}                    -> WarningWithFlag Opt_WarnAlternativeLayoutRuleTransitional+    PsWarnOperatorWhitespaceExtConflict{}         -> WarningWithFlag Opt_WarnOperatorWhitespaceExtConflict+    PsWarnOperatorWhitespace{}                    -> WarningWithFlag Opt_WarnOperatorWhitespace+    PsWarnHaddockInvalidPos                       -> WarningWithFlag Opt_WarnInvalidHaddock+    PsWarnHaddockIgnoreMulti                      -> WarningWithFlag Opt_WarnInvalidHaddock+    PsWarnStarBinder                              -> WarningWithFlag Opt_WarnStarBinder+    PsWarnStarIsType                              -> WarningWithFlag Opt_WarnStarIsType+    PsWarnUnrecognisedPragma                      -> WarningWithFlag Opt_WarnUnrecognisedPragmas+    PsWarnMisplacedPragma{}                       -> WarningWithFlag Opt_WarnMisplacedPragmas+    PsWarnImportPreQualified                      -> WarningWithFlag Opt_WarnPrepositiveQualifiedModule+    PsErrLexer{}                                  -> ErrorWithoutFlag+    PsErrCmmLexer                                 -> ErrorWithoutFlag+    PsErrCmmParser{}                              -> ErrorWithoutFlag+    PsErrParse{}                                  -> ErrorWithoutFlag+    PsErrTypeAppWithoutSpace{}                    -> ErrorWithoutFlag+    PsErrLazyPatWithoutSpace{}                    -> ErrorWithoutFlag+    PsErrBangPatWithoutSpace{}                    -> ErrorWithoutFlag+    PsErrInvalidInfixHole                         -> ErrorWithoutFlag+    PsErrExpectedHyphen                           -> ErrorWithoutFlag+    PsErrSpaceInSCC                               -> ErrorWithoutFlag+    PsErrEmptyDoubleQuotes{}                      -> ErrorWithoutFlag+    PsErrLambdaCase{}                             -> ErrorWithoutFlag+    PsErrEmptyLambda{}                            -> ErrorWithoutFlag+    PsErrLinearFunction{}                         -> ErrorWithoutFlag+    PsErrMultiWayIf{}                             -> ErrorWithoutFlag+    PsErrOverloadedRecordUpdateNotEnabled{}       -> ErrorWithoutFlag+    PsErrNumUnderscores{}                         -> ErrorWithoutFlag+    PsErrIllegalBangPattern{}                     -> ErrorWithoutFlag+    PsErrOverloadedRecordDotInvalid{}             -> ErrorWithoutFlag+    PsErrIllegalPatSynExport                      -> ErrorWithoutFlag+    PsErrOverloadedRecordUpdateNoQualifiedFields  -> ErrorWithoutFlag+    PsErrExplicitForall{}                         -> ErrorWithoutFlag+    PsErrIllegalQualifiedDo{}                     -> ErrorWithoutFlag+    PsErrQualifiedDoInCmd{}                       -> ErrorWithoutFlag+    PsErrRecordSyntaxInPatSynDecl{}               -> ErrorWithoutFlag+    PsErrEmptyWhereInPatSynDecl{}                 -> ErrorWithoutFlag+    PsErrInvalidWhereBindInPatSynDecl{}           -> ErrorWithoutFlag+    PsErrNoSingleWhereBindInPatSynDecl{}          -> ErrorWithoutFlag+    PsErrDeclSpliceNotAtTopLevel{}                -> ErrorWithoutFlag+    PsErrMultipleNamesInStandaloneKindSignature{} -> ErrorWithoutFlag+    PsErrIllegalExplicitNamespace                 -> ErrorWithoutFlag+    PsErrUnallowedPragma{}                        -> ErrorWithoutFlag+    PsErrImportPostQualified                      -> ErrorWithoutFlag+    PsErrImportQualifiedTwice                     -> ErrorWithoutFlag+    PsErrIllegalImportBundleForm                  -> ErrorWithoutFlag+    PsErrInvalidRuleActivationMarker              -> ErrorWithoutFlag+    PsErrMissingBlock                             -> ErrorWithoutFlag+    PsErrUnsupportedBoxedSumExpr{}                -> ErrorWithoutFlag+    PsErrUnsupportedBoxedSumPat{}                 -> ErrorWithoutFlag+    PsErrUnexpectedQualifiedConstructor{}         -> ErrorWithoutFlag+    PsErrTupleSectionInPat{}                      -> ErrorWithoutFlag+    PsErrOpFewArgs{}                              -> ErrorWithoutFlag+    PsErrVarForTyCon{}                            -> ErrorWithoutFlag+    PsErrMalformedEntityString                    -> ErrorWithoutFlag+    PsErrDotsInRecordUpdate                       -> ErrorWithoutFlag+    PsErrInvalidDataCon{}                         -> ErrorWithoutFlag+    PsErrInvalidInfixDataCon{}                    -> ErrorWithoutFlag+    PsErrIllegalPromotionQuoteDataCon{}           -> ErrorWithoutFlag+    PsErrUnpackDataCon                            -> ErrorWithoutFlag+    PsErrUnexpectedKindAppInDataCon{}             -> ErrorWithoutFlag+    PsErrInvalidRecordCon{}                       -> ErrorWithoutFlag+    PsErrIllegalUnboxedStringInPat{}              -> ErrorWithoutFlag+    PsErrIllegalUnboxedFloatingLitInPat{}         -> ErrorWithoutFlag+    PsErrDoNotationInPat{}                        -> ErrorWithoutFlag+    PsErrIfThenElseInPat                          -> ErrorWithoutFlag+    PsErrLambdaCaseInPat{}                        -> ErrorWithoutFlag+    PsErrCaseInPat                                -> ErrorWithoutFlag+    PsErrLetInPat                                 -> ErrorWithoutFlag+    PsErrLambdaInPat                              -> ErrorWithoutFlag+    PsErrArrowExprInPat{}                         -> ErrorWithoutFlag+    PsErrArrowCmdInPat{}                          -> ErrorWithoutFlag+    PsErrArrowCmdInExpr{}                         -> ErrorWithoutFlag+    PsErrViewPatInExpr{}                          -> ErrorWithoutFlag+    PsErrLambdaCmdInFunAppCmd{}                   -> ErrorWithoutFlag+    PsErrCaseCmdInFunAppCmd{}                     -> ErrorWithoutFlag+    PsErrLambdaCaseCmdInFunAppCmd{}               -> ErrorWithoutFlag+    PsErrIfCmdInFunAppCmd{}                       -> ErrorWithoutFlag+    PsErrLetCmdInFunAppCmd{}                      -> ErrorWithoutFlag+    PsErrDoCmdInFunAppCmd{}                       -> ErrorWithoutFlag+    PsErrDoInFunAppExpr{}                         -> ErrorWithoutFlag+    PsErrMDoInFunAppExpr{}                        -> ErrorWithoutFlag+    PsErrLambdaInFunAppExpr{}                     -> ErrorWithoutFlag+    PsErrCaseInFunAppExpr{}                       -> ErrorWithoutFlag+    PsErrLambdaCaseInFunAppExpr{}                 -> ErrorWithoutFlag+    PsErrLetInFunAppExpr{}                        -> ErrorWithoutFlag+    PsErrIfInFunAppExpr{}                         -> ErrorWithoutFlag+    PsErrProcInFunAppExpr{}                       -> ErrorWithoutFlag+    PsErrMalformedTyOrClDecl{}                    -> ErrorWithoutFlag+    PsErrIllegalWhereInDataDecl                   -> ErrorWithoutFlag+    PsErrIllegalDataTypeContext{}                 -> ErrorWithoutFlag+    PsErrPrimStringInvalidChar                    -> ErrorWithoutFlag+    PsErrSuffixAT                                 -> ErrorWithoutFlag+    PsErrPrecedenceOutOfRange{}                   -> ErrorWithoutFlag+    PsErrSemiColonsInCondExpr{}                   -> ErrorWithoutFlag+    PsErrSemiColonsInCondCmd{}                    -> ErrorWithoutFlag+    PsErrAtInPatPos                               -> ErrorWithoutFlag+    PsErrParseErrorOnInput{}                      -> ErrorWithoutFlag+    PsErrMalformedDecl{}                          -> ErrorWithoutFlag+    PsErrUnexpectedTypeAppInDecl{}                -> ErrorWithoutFlag+    PsErrNotADataCon{}                            -> ErrorWithoutFlag+    PsErrInferredTypeVarNotAllowed                -> ErrorWithoutFlag+    PsErrIllegalTraditionalRecordSyntax{}         -> ErrorWithoutFlag+    PsErrParseErrorInCmd{}                        -> ErrorWithoutFlag+    PsErrInPat{}                                  -> ErrorWithoutFlag+    PsErrIllegalRoleName{}                        -> ErrorWithoutFlag+    PsErrInvalidTypeSignature{}                   -> ErrorWithoutFlag+    PsErrUnexpectedTypeInDecl{}                   -> ErrorWithoutFlag+    PsErrInvalidPackageName{}                     -> ErrorWithoutFlag+    PsErrParseRightOpSectionInPat{}               -> ErrorWithoutFlag+    PsErrIllegalGadtRecordMultiplicity{}          -> ErrorWithoutFlag+    PsErrInvalidCApiImport {}                     -> ErrorWithoutFlag++  diagnosticHints  = \case+    PsUnknownMessage m                            -> diagnosticHints m+    PsHeaderMessage  m                            -> psHeaderMessageHints m+    PsWarnBidirectionalFormatChars{}              -> noHints+    PsWarnTab{}                                   -> [SuggestUseSpaces]+    PsWarnTransitionalLayout{}                    -> noHints+    PsWarnOperatorWhitespaceExtConflict sym       -> [SuggestUseWhitespaceAfter sym]+    PsWarnOperatorWhitespace sym occ              -> [SuggestUseWhitespaceAround (unpackFS sym) occ]+    PsWarnHaddockInvalidPos                       -> noHints+    PsWarnHaddockIgnoreMulti                      -> noHints+    PsWarnStarBinder                              -> [SuggestQualifyStarOperator]+    PsWarnStarIsType                              -> [SuggestUseTypeFromDataKind Nothing]+    PsWarnUnrecognisedPragma                      -> noHints+    PsWarnMisplacedPragma{}                       -> [SuggestPlacePragmaInHeader]+    PsWarnImportPreQualified                      -> [ SuggestQualifiedAfterModuleName+                                                     , suggestExtension LangExt.ImportQualifiedPost]+    PsErrLexer{}                                  -> noHints+    PsErrCmmLexer                                 -> noHints+    PsErrCmmParser{}                              -> noHints+    PsErrParse token PsErrParseDetails{..}        -> case token of+      ""                         -> []+      "$"  | not ped_th_enabled  -> [suggestExtension LangExt.TemplateHaskell]   -- #7396+      "$$" | not ped_th_enabled  -> [suggestExtension LangExt.TemplateHaskell]   -- #20157+      "<-" | ped_mdo_in_last_100 -> [suggestExtension LangExt.RecursiveDo]+           | otherwise           -> [SuggestMissingDo]+      "="  | ped_do_in_last_100  -> [SuggestLetInDo]                             -- #15849+      _    | not ped_pat_syn_enabled+           , ped_pattern_parsed  -> [suggestExtension LangExt.PatternSynonyms]   -- #12429+           | otherwise           -> []+    PsErrTypeAppWithoutSpace{}                    -> noHints+    PsErrLazyPatWithoutSpace{}                    -> noHints+    PsErrBangPatWithoutSpace{}                    -> noHints+    PsErrInvalidInfixHole                         -> noHints+    PsErrExpectedHyphen                           -> noHints+    PsErrSpaceInSCC                               -> noHints+    PsErrEmptyDoubleQuotes th_on | th_on          -> [SuggestThQuotationSyntax]+                                 | otherwise      -> noHints+    PsErrLambdaCase{}                             -> [suggestExtension LangExt.LambdaCase]+    PsErrEmptyLambda{}                            -> noHints+    PsErrLinearFunction{}                         -> [suggestExtension LangExt.LinearTypes]+    PsErrMultiWayIf{}                             -> [suggestExtension LangExt.MultiWayIf]+    PsErrOverloadedRecordUpdateNotEnabled{}       -> [suggestExtension LangExt.OverloadedRecordUpdate]+    PsErrNumUnderscores{}                         -> [suggestExtension LangExt.NumericUnderscores]+    PsErrIllegalBangPattern{}                     -> [suggestExtension LangExt.BangPatterns]+    PsErrOverloadedRecordDotInvalid{}             -> noHints+    PsErrIllegalPatSynExport                      -> [suggestExtension LangExt.PatternSynonyms]+    PsErrOverloadedRecordUpdateNoQualifiedFields  -> noHints+    PsErrExplicitForall is_unicode                ->+      let info = text "or a similar language extension to enable explicit-forall syntax:" <+>+                 forallSym is_unicode <+> text "<tvs>. <type>"+      in [ suggestExtensionWithInfo info LangExt.RankNTypes ]+    PsErrIllegalQualifiedDo{}                     -> [suggestExtension LangExt.QualifiedDo]+    PsErrQualifiedDoInCmd{}                       -> noHints+    PsErrRecordSyntaxInPatSynDecl{}               -> noHints+    PsErrEmptyWhereInPatSynDecl{}                 -> noHints+    PsErrInvalidWhereBindInPatSynDecl{}           -> noHints+    PsErrNoSingleWhereBindInPatSynDecl{}          -> noHints+    PsErrDeclSpliceNotAtTopLevel{}                -> noHints+    PsErrMultipleNamesInStandaloneKindSignature{} -> noHints+    PsErrIllegalExplicitNamespace                 -> [suggestExtension LangExt.ExplicitNamespaces]+    PsErrUnallowedPragma{}                        -> noHints+    PsErrImportPostQualified                      -> [suggestExtension LangExt.ImportQualifiedPost]+    PsErrImportQualifiedTwice                     -> noHints+    PsErrIllegalImportBundleForm                  -> noHints+    PsErrInvalidRuleActivationMarker              -> noHints+    PsErrMissingBlock                             -> noHints+    PsErrUnsupportedBoxedSumExpr{}                -> noHints+    PsErrUnsupportedBoxedSumPat{}                 -> noHints+    PsErrUnexpectedQualifiedConstructor{}         -> noHints+    PsErrTupleSectionInPat{}                      -> noHints+    PsErrOpFewArgs star_is_type op+      -> noStarIsTypeHints star_is_type op+    PsErrVarForTyCon{}                            -> noHints+    PsErrMalformedEntityString                    -> noHints+    PsErrDotsInRecordUpdate                       -> noHints+    PsErrInvalidDataCon{}                         -> noHints+    PsErrInvalidInfixDataCon{}                    -> noHints+    PsErrIllegalPromotionQuoteDataCon{}           -> noHints+    PsErrUnpackDataCon                            -> noHints+    PsErrUnexpectedKindAppInDataCon{}             -> noHints+    PsErrInvalidRecordCon{}                       -> noHints+    PsErrIllegalUnboxedStringInPat{}              -> noHints+    PsErrIllegalUnboxedFloatingLitInPat{}         -> noHints+    PsErrDoNotationInPat{}                        -> noHints+    PsErrIfThenElseInPat                          -> noHints+    PsErrLambdaCaseInPat{}                        -> noHints+    PsErrCaseInPat                                -> noHints+    PsErrLetInPat                                 -> noHints+    PsErrLambdaInPat                              -> noHints+    PsErrArrowExprInPat{}                         -> noHints+    PsErrArrowCmdInPat{}                          -> noHints+    PsErrArrowCmdInExpr{}                         -> noHints+    PsErrViewPatInExpr{}                          -> noHints+    PsErrLambdaCmdInFunAppCmd{}                   -> suggestParensAndBlockArgs+    PsErrCaseCmdInFunAppCmd{}                     -> suggestParensAndBlockArgs+    PsErrLambdaCaseCmdInFunAppCmd{}               -> suggestParensAndBlockArgs+    PsErrIfCmdInFunAppCmd{}                       -> suggestParensAndBlockArgs+    PsErrLetCmdInFunAppCmd{}                      -> suggestParensAndBlockArgs+    PsErrDoCmdInFunAppCmd{}                       -> suggestParensAndBlockArgs+    PsErrDoInFunAppExpr{}                         -> suggestParensAndBlockArgs+    PsErrMDoInFunAppExpr{}                        -> suggestParensAndBlockArgs+    PsErrLambdaInFunAppExpr{}                     -> suggestParensAndBlockArgs+    PsErrCaseInFunAppExpr{}                       -> suggestParensAndBlockArgs+    PsErrLambdaCaseInFunAppExpr{}                 -> suggestParensAndBlockArgs+    PsErrLetInFunAppExpr{}                        -> suggestParensAndBlockArgs+    PsErrIfInFunAppExpr{}                         -> suggestParensAndBlockArgs+    PsErrProcInFunAppExpr{}                       -> suggestParensAndBlockArgs+    PsErrMalformedTyOrClDecl{}                    -> noHints+    PsErrIllegalWhereInDataDecl                   ->+      [ suggestExtensionWithInfo (text "or a similar language extension to enable syntax: data T where")+                                 LangExt.GADTs ]+    PsErrIllegalDataTypeContext{}                 -> [suggestExtension LangExt.DatatypeContexts]+    PsErrPrimStringInvalidChar                    -> noHints+    PsErrSuffixAT                                 -> noHints+    PsErrPrecedenceOutOfRange{}                   -> noHints+    PsErrSemiColonsInCondExpr{}                   -> [suggestExtension LangExt.DoAndIfThenElse]+    PsErrSemiColonsInCondCmd{}                    -> [suggestExtension LangExt.DoAndIfThenElse]+    PsErrAtInPatPos                               -> noHints+    PsErrParseErrorOnInput{}                      -> noHints+    PsErrMalformedDecl{}                          -> noHints+    PsErrUnexpectedTypeAppInDecl{}                -> noHints+    PsErrNotADataCon{}                            -> noHints+    PsErrInferredTypeVarNotAllowed                -> noHints+    PsErrIllegalTraditionalRecordSyntax{}         -> [suggestExtension LangExt.TraditionalRecordSyntax]+    PsErrParseErrorInCmd{}                        -> noHints+    PsErrInPat _ details                          -> case details of+      PEIP_RecPattern args YesPatIsRecursive ctx+       | length args /= 0 -> catMaybes [sug_recdo, sug_missingdo ctx]+       | otherwise        -> catMaybes [sug_missingdo ctx]+      PEIP_OtherPatDetails ctx -> catMaybes [sug_missingdo ctx]+      _                        -> []+      where+        sug_recdo                                           = Just (suggestExtension LangExt.RecursiveDo)+        sug_missingdo (ParseContext _ YesIncompleteDoBlock) = Just SuggestMissingDo+        sug_missingdo _                                     = Nothing+    PsErrParseRightOpSectionInPat{}               -> noHints+    PsErrIllegalRoleName _ nearby                 -> [SuggestRoles nearby]+    PsErrInvalidTypeSignature lhs                 ->+        if | foreign_RDR `looks_like` lhs+           -> [suggestExtension LangExt.ForeignFunctionInterface]+           | default_RDR `looks_like` lhs+           -> [suggestExtension LangExt.DefaultSignatures]+           | pattern_RDR `looks_like` lhs+           -> [suggestExtension LangExt.PatternSynonyms]+           | otherwise+           -> [SuggestTypeSignatureForm]+      where+        -- A common error is to forget the ForeignFunctionInterface flag+        -- so check for that, and suggest.  cf #3805+        -- Sadly 'foreign import' still barfs 'parse error' because+        --  'import' is a keyword+        -- looks_like :: RdrName -> LHsExpr GhcPsErr -> Bool -- AZ+        looks_like s (L _ (HsVar _ (L _ v))) = v == s+        looks_like s (L _ (HsApp _ lhs _))   = looks_like s lhs+        looks_like _ _                       = False++        foreign_RDR = mkUnqual varName (fsLit "foreign")+        default_RDR = mkUnqual varName (fsLit "default")+        pattern_RDR = mkUnqual varName (fsLit "pattern")+    PsErrUnexpectedTypeInDecl{}                   -> noHints+    PsErrInvalidPackageName{}                     -> noHints+    PsErrIllegalGadtRecordMultiplicity{}          -> noHints+    PsErrInvalidCApiImport {}                     -> noHints++psHeaderMessageDiagnostic :: PsHeaderMessage -> DecoratedSDoc+psHeaderMessageDiagnostic = \case+  PsErrParseLanguagePragma+    -> mkSimpleDecorated $+         vcat [ text "Cannot parse LANGUAGE pragma"+              , text "Expecting comma-separated list of language options,"+              , text "each starting with a capital letter"+              , nest 2 (text "E.g. {-# LANGUAGE TemplateHaskell, GADTs #-}") ]+  PsErrUnsupportedExt unsup _+    -> mkSimpleDecorated $ text "Unsupported extension: " <> text unsup+  PsErrParseOptionsPragma str+    -> mkSimpleDecorated $+         vcat [ text "Error while parsing OPTIONS_GHC pragma."+              , text "Expecting whitespace-separated list of GHC options."+              , text "  E.g. {-# OPTIONS_GHC -Wall -O2 #-}"+              , text ("Input was: " ++ show str) ]+  PsErrUnknownOptionsPragma flag+    -> mkSimpleDecorated $ text "Unknown flag in  {-# OPTIONS_GHC #-} pragma:" <+> text flag++psHeaderMessageReason :: PsHeaderMessage -> DiagnosticReason+psHeaderMessageReason = \case+  PsErrParseLanguagePragma+    -> ErrorWithoutFlag+  PsErrUnsupportedExt{}+    -> ErrorWithoutFlag+  PsErrParseOptionsPragma{}+    -> ErrorWithoutFlag+  PsErrUnknownOptionsPragma{}+    -> ErrorWithoutFlag++psHeaderMessageHints :: PsHeaderMessage -> [GhcHint]+psHeaderMessageHints = \case+  PsErrParseLanguagePragma+    -> noHints+  PsErrUnsupportedExt unsup supported+    -> if null suggestions+          then noHints+          -- FIXME(adn) To fix the compiler crash in #19923 we just rewrap this into an+          -- UnknownHint, but we should have here a proper hint, but that would require+          -- changing 'supportedExtensions' to emit a list of 'Extension'.+          else [UnknownHint $ text "Perhaps you meant" <+> quotedListWithOr (map text suggestions)]+       where+         suggestions :: [String]+         suggestions = fuzzyMatch unsup supported+  PsErrParseOptionsPragma{}+    -> noHints+  PsErrUnknownOptionsPragma{}+    -> noHints+++suggestParensAndBlockArgs :: [GhcHint]+suggestParensAndBlockArgs =+  [SuggestParentheses, suggestExtension LangExt.BlockArguments]++pp_unexpected_fun_app :: Outputable a => SDoc -> a -> SDoc+pp_unexpected_fun_app e a =+   text "Unexpected " <> e <> text " in function application:"+    $$ nest 4 (ppr a)++parse_error_in_pat :: SDoc+parse_error_in_pat = text "Parse error in pattern:"++forallSym :: Bool -> SDoc+forallSym True  = text "∀"+forallSym False = text "forall"++pprFileHeaderPragmaType :: FileHeaderPragmaType -> SDoc+pprFileHeaderPragmaType OptionsPrag    = text "OPTIONS"+pprFileHeaderPragmaType IncludePrag    = text "INCLUDE"+pprFileHeaderPragmaType LanguagePrag   = text "LANGUAGE"+pprFileHeaderPragmaType DocOptionsPrag = text "OPTIONS_HADDOCK"
+ GHC/Parser/Errors/Types.hs view
@@ -0,0 +1,563 @@+{-# LANGUAGE ExistentialQuantification #-}++module GHC.Parser.Errors.Types where++import GHC.Prelude++import Data.Typeable++import GHC.Core.TyCon (Role)+import GHC.Data.FastString+import GHC.Hs+import GHC.Parser.Types+import GHC.Parser.Errors.Basic+import GHC.Types.Error+import GHC.Types.Hint+import GHC.Types.Name.Occurrence (OccName)+import GHC.Types.Name.Reader+import GHC.Unit.Module.Name+import GHC.Utils.Outputable+import Data.List.NonEmpty (NonEmpty)+import GHC.Types.SrcLoc (PsLoc)++-- The type aliases below are useful to make some type signatures a bit more+-- descriptive, like 'handleWarningsThrowErrors' in 'GHC.Driver.Main'.++type PsWarning = PsMessage   -- /INVARIANT/: The diagnosticReason is a Warning reason+type PsError   = PsMessage   -- /INVARIANT/: The diagnosticReason is ErrorWithoutFlag++{-+Note [Messages from GHC.Parser.Header+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++We group the messages from 'GHC.Parser.Header' because we need to+be able to pattern match on them in the driver code. This is because+in functions like 'GHC.Driver.Pipeline.preprocess' we want to handle+only a specific subset of parser messages, during dependency analysis,+and having a single constructor to handle them all is handy.++-}++data PsHeaderMessage+  = PsErrParseLanguagePragma+  | PsErrUnsupportedExt !String ![String]+  | PsErrParseOptionsPragma !String++  {-| PsErrUnsupportedOptionsPragma is an error that occurs when an unknown+      OPTIONS_GHC pragma is supplied is found.++      Example(s):+        {-# OPTIONS_GHC foo #-}++      Test case(s):++        tests/safeHaskell/flags/SafeFlags28+        tests/safeHaskell/flags/SafeFlags19+        tests/safeHaskell/flags/SafeFlags29+        tests/parser/should_fail/T19923c+        tests/parser/should_fail/T19923b+        tests/parser/should_fail/readFail044+        tests/driver/T2499+  -}+  | PsErrUnknownOptionsPragma !String+++data PsMessage+  =+    {-| An \"unknown\" message from the parser. This type constructor allows+        arbitrary messages to be embedded. The typical use case would be GHC plugins+        willing to emit custom diagnostics.+    -}+   forall a. (Diagnostic a, Typeable a) => PsUnknownMessage a++    {-| A group of parser messages emitted in 'GHC.Parser.Header'.+        See Note [Messages from GHC.Parser.Header].+    -}+   | PsHeaderMessage !PsHeaderMessage++   {-| PsWarnBidirectionalFormatChars is a warning (controlled by the -Wwarn-bidirectional-format-characters flag)+   that occurs when unicode bi-directional format characters are found within in a file++   The 'PsLoc' contains the exact position in the buffer the character occured, and the+   string contains a description of the character.+   -}+   | PsWarnBidirectionalFormatChars (NonEmpty (PsLoc, Char, String))++   {-| PsWarnTab is a warning (controlled by the -Wwarn-tabs flag) that occurs+       when tabulations (tabs) are found within a file.++       Test case(s): parser/should_fail/T12610+                     parser/should_compile/T9723b+                     parser/should_compile/T9723a+                     parser/should_compile/read043+                     parser/should_fail/T16270+                     warnings/should_compile/T9230++   -}+   | PsWarnTab !Word -- ^ Number of other occurrences other than the first one++   {-| PsWarnTransitionalLayout is a warning (controlled by the+       -Walternative-layout-rule-transitional flag) that occurs when pipes ('|')+       or 'where' are at the same depth of an implicit layout block.++       Example(s):++          f :: IO ()+          f+           | True = do+           let x = ()+               y = ()+           return ()+           | True = return ()++       Test case(s): layout/layout006+                     layout/layout003+                     layout/layout001++   -}+   | PsWarnTransitionalLayout !TransLayoutReason++   -- | Unrecognised pragma+   | PsWarnUnrecognisedPragma+   | PsWarnMisplacedPragma !FileHeaderPragmaType++   -- | Invalid Haddock comment position+   | PsWarnHaddockInvalidPos++   -- | Multiple Haddock comment for the same entity+   | PsWarnHaddockIgnoreMulti++   -- | Found binding occurrence of "*" while StarIsType is enabled+   | PsWarnStarBinder++   -- | Using "*" for "Type" without StarIsType enabled+   | PsWarnStarIsType++   -- | Pre qualified import with 'WarnPrepositiveQualifiedModule' enabled+   | PsWarnImportPreQualified++   | PsWarnOperatorWhitespaceExtConflict !OperatorWhitespaceSymbol++   | PsWarnOperatorWhitespace !FastString !OperatorWhitespaceOccurrence++   -- | LambdaCase syntax used without the extension enabled+   | PsErrLambdaCase++   -- | A lambda requires at least one parameter+   | PsErrEmptyLambda++   -- | Underscores in literals without the extension enabled+   | PsErrNumUnderscores !NumUnderscoreReason++   -- | Invalid character in primitive string+   | PsErrPrimStringInvalidChar++   -- | Missing block+   | PsErrMissingBlock++   -- | Lexer error+   | PsErrLexer !LexErr !LexErrKind++   -- | Suffix occurrence of `@`+   | PsErrSuffixAT++   -- | Parse errors+   | PsErrParse !String !PsErrParseDetails++   -- | Cmm lexer error+   | PsErrCmmLexer++   -- | Unsupported boxed sum in expression+   | PsErrUnsupportedBoxedSumExpr !(SumOrTuple (HsExpr GhcPs))++   -- | Unsupported boxed sum in pattern+   | PsErrUnsupportedBoxedSumPat !(SumOrTuple (PatBuilder GhcPs))++   -- | Unexpected qualified constructor+   | PsErrUnexpectedQualifiedConstructor !RdrName++   -- | Tuple section in pattern context+   | PsErrTupleSectionInPat++   -- | Bang-pattern without BangPattterns enabled+   | PsErrIllegalBangPattern !(Pat GhcPs)++   -- | Operator applied to too few arguments+   | PsErrOpFewArgs !StarIsType !RdrName++   -- | Import: multiple occurrences of 'qualified'+   | PsErrImportQualifiedTwice++   -- | Post qualified import without 'ImportQualifiedPost'+   | PsErrImportPostQualified++   -- | Explicit namespace keyword without 'ExplicitNamespaces'+   | PsErrIllegalExplicitNamespace++   -- | Expecting a type constructor but found a variable+   | PsErrVarForTyCon !RdrName++   -- | Illegal export form allowed by PatternSynonyms+   | PsErrIllegalPatSynExport++   -- | Malformed entity string+   | PsErrMalformedEntityString++   -- | Dots used in record update+   | PsErrDotsInRecordUpdate++   -- | Precedence out of range+   | PsErrPrecedenceOutOfRange !Int++   -- | Invalid use of record dot syntax `.'+   | PsErrOverloadedRecordDotInvalid++   -- | `OverloadedRecordUpdate` is not enabled.+   | PsErrOverloadedRecordUpdateNotEnabled++   -- | Can't use qualified fields when OverloadedRecordUpdate is enabled.+   | PsErrOverloadedRecordUpdateNoQualifiedFields++   -- | Cannot parse data constructor in a data/newtype declaration+   | PsErrInvalidDataCon !(HsType GhcPs)++   -- | Cannot parse data constructor in a data/newtype declaration+   | PsErrInvalidInfixDataCon !(HsType GhcPs) !RdrName !(HsType GhcPs)++   -- | Illegal DataKinds quote mark in data/newtype constructor declaration+   | PsErrIllegalPromotionQuoteDataCon !RdrName++   -- | UNPACK applied to a data constructor+   | PsErrUnpackDataCon++   -- | Unexpected kind application in data/newtype declaration+   | PsErrUnexpectedKindAppInDataCon !DataConBuilder !(HsType GhcPs)++   -- | Not a record constructor+   | PsErrInvalidRecordCon !(PatBuilder GhcPs)++   -- | Illegal unboxed string literal in pattern+   | PsErrIllegalUnboxedStringInPat !(HsLit GhcPs)++   -- | Illegal primitive floating point literal in pattern+   | PsErrIllegalUnboxedFloatingLitInPat !(HsLit GhcPs)++   -- | Do-notation in pattern+   | PsErrDoNotationInPat++   -- | If-then-else syntax in pattern+   | PsErrIfThenElseInPat++   -- | Lambda-case in pattern+   | PsErrLambdaCaseInPat LamCaseVariant++   -- | case..of in pattern+   | PsErrCaseInPat++   -- | let-syntax in pattern+   | PsErrLetInPat++   -- | Lambda-syntax in pattern+   | PsErrLambdaInPat++   -- | Arrow expression-syntax in pattern+   | PsErrArrowExprInPat !(HsExpr GhcPs)++   -- | Arrow command-syntax in pattern+   | PsErrArrowCmdInPat !(HsCmd GhcPs)++   -- | Arrow command-syntax in expression+   | PsErrArrowCmdInExpr !(HsCmd GhcPs)++   -- | View-pattern in expression+   | PsErrViewPatInExpr !(LHsExpr GhcPs) !(LHsExpr GhcPs)++   -- | Type-application without space before '@'+   | PsErrTypeAppWithoutSpace !RdrName !(LHsExpr GhcPs)++   -- | Lazy-pattern ('~') without space after it+   | PsErrLazyPatWithoutSpace !(LHsExpr GhcPs)++   -- | Bang-pattern ('!') without space after it+   | PsErrBangPatWithoutSpace !(LHsExpr GhcPs)++   -- | Pragma not allowed in this position+   | PsErrUnallowedPragma !(HsPragE GhcPs)++   -- | Qualified do block in command+   | PsErrQualifiedDoInCmd !ModuleName++   -- | Invalid infix hole, expected an infix operator+   | PsErrInvalidInfixHole++   -- | Unexpected semi-colons in conditional expression+   | PsErrSemiColonsInCondExpr+       !(HsExpr GhcPs) -- ^ conditional expr+       !Bool           -- ^ "then" semi-colon?+       !(HsExpr GhcPs) -- ^ "then" expr+       !Bool           -- ^ "else" semi-colon?+       !(HsExpr GhcPs) -- ^ "else" expr++   -- | Unexpected semi-colons in conditional command+   | PsErrSemiColonsInCondCmd+       !(HsExpr GhcPs) -- ^ conditional expr+       !Bool           -- ^ "then" semi-colon?+       !(HsCmd GhcPs)  -- ^ "then" expr+       !Bool           -- ^ "else" semi-colon?+       !(HsCmd GhcPs)  -- ^ "else" expr++   -- | @-operator in a pattern position+   | PsErrAtInPatPos++   -- | Unexpected lambda command in function application+   | PsErrLambdaCmdInFunAppCmd !(LHsCmd GhcPs)++   -- | Unexpected case command in function application+   | PsErrCaseCmdInFunAppCmd !(LHsCmd GhcPs)++   -- | Unexpected \case(s) command in function application+   | PsErrLambdaCaseCmdInFunAppCmd !LamCaseVariant !(LHsCmd GhcPs)++   -- | Unexpected if command in function application+   | PsErrIfCmdInFunAppCmd !(LHsCmd GhcPs)++   -- | Unexpected let command in function application+   | PsErrLetCmdInFunAppCmd !(LHsCmd GhcPs)++   -- | Unexpected do command in function application+   | PsErrDoCmdInFunAppCmd !(LHsCmd GhcPs)++   -- | Unexpected do block in function application+   | PsErrDoInFunAppExpr !(Maybe ModuleName) !(LHsExpr GhcPs)++   -- | Unexpected mdo block in function application+   | PsErrMDoInFunAppExpr !(Maybe ModuleName) !(LHsExpr GhcPs)++   -- | Unexpected lambda expression in function application+   | PsErrLambdaInFunAppExpr !(LHsExpr GhcPs)++   -- | Unexpected case expression in function application+   | PsErrCaseInFunAppExpr !(LHsExpr GhcPs)++   -- | Unexpected \case(s) expression in function application+   | PsErrLambdaCaseInFunAppExpr !LamCaseVariant !(LHsExpr GhcPs)++   -- | Unexpected let expression in function application+   | PsErrLetInFunAppExpr !(LHsExpr GhcPs)++   -- | Unexpected if expression in function application+   | PsErrIfInFunAppExpr !(LHsExpr GhcPs)++   -- | Unexpected proc expression in function application+   | PsErrProcInFunAppExpr !(LHsExpr GhcPs)++   -- | Malformed head of type or class declaration+   | PsErrMalformedTyOrClDecl !(LHsType GhcPs)++   -- | Illegal 'where' keyword in data declaration+   | PsErrIllegalWhereInDataDecl++   -- | Illegal datatype context+   | PsErrIllegalDataTypeContext !(LHsContext GhcPs)++   -- | Parse error on input+   | PsErrParseErrorOnInput !OccName++   -- | Malformed ... declaration for ...+   | PsErrMalformedDecl !SDoc !RdrName++   -- | Unexpected type application in a declaration+   | PsErrUnexpectedTypeAppInDecl !(LHsType GhcPs) !SDoc !RdrName++   -- | Not a data constructor+   | PsErrNotADataCon !RdrName++   -- | Record syntax used in pattern synonym declaration+   | PsErrRecordSyntaxInPatSynDecl !(LPat GhcPs)++   -- | Empty 'where' clause in pattern-synonym declaration+   | PsErrEmptyWhereInPatSynDecl !RdrName++   -- | Invalid binding name in 'where' clause of pattern-synonym declaration+   | PsErrInvalidWhereBindInPatSynDecl !RdrName !(HsDecl GhcPs)++   -- | Multiple bindings in 'where' clause of pattern-synonym declaration+   | PsErrNoSingleWhereBindInPatSynDecl !RdrName !(HsDecl GhcPs)++   -- | Declaration splice not a top-level+   | PsErrDeclSpliceNotAtTopLevel !(SpliceDecl GhcPs)++   -- | Inferred type variables not allowed here+   | PsErrInferredTypeVarNotAllowed++   -- | Multiple names in standalone kind signatures+   | PsErrMultipleNamesInStandaloneKindSignature [LIdP GhcPs]++   -- | Illegal import bundle form+   | PsErrIllegalImportBundleForm++   -- | Illegal role name+   | PsErrIllegalRoleName !FastString [Role]++   -- | Invalid type signature+   | PsErrInvalidTypeSignature !(LHsExpr GhcPs)++   -- | Unexpected type in declaration+   | PsErrUnexpectedTypeInDecl !(LHsType GhcPs)+                               !SDoc+                               !RdrName+                               [LHsTypeArg GhcPs]+                               !SDoc++   -- | Expected a hyphen+   | PsErrExpectedHyphen++   -- | Found a space in a SCC+   | PsErrSpaceInSCC++   -- | Found two single quotes+   | PsErrEmptyDoubleQuotes !Bool+                            -- ^ Is TH on?++   -- | Invalid package name+   | PsErrInvalidPackageName !FastString++   -- | Invalid rule activation marker+   | PsErrInvalidRuleActivationMarker++   -- | Linear function found but LinearTypes not enabled+   | PsErrLinearFunction++   -- | Multi-way if-expression found but MultiWayIf not enabled+   | PsErrMultiWayIf++   -- | Explicit forall found but no extension allowing it is enabled+   | PsErrExplicitForall !Bool+                         -- ^ is Unicode forall?++   -- | Found qualified-do without QualifiedDo enabled+   | PsErrIllegalQualifiedDo !SDoc++   -- | Cmm parser error+   | PsErrCmmParser !CmmParserError++   -- | Illegal traditional record syntax+   --+   -- TODO: distinguish errors without using SDoc+   | PsErrIllegalTraditionalRecordSyntax !SDoc++   -- | Parse error in command+   --+   -- TODO: distinguish errors without using SDoc+   | PsErrParseErrorInCmd !SDoc++   -- | Parse error in pattern+   | PsErrInPat !(PatBuilder GhcPs) !PsErrInPatDetails++   -- | Parse error in right operator section pattern+   -- TODO: embed the proper operator, if possible+   | forall infixOcc. (OutputableBndr infixOcc) => PsErrParseRightOpSectionInPat !infixOcc !(PatBuilder GhcPs)++   -- | Illegal linear arrow or multiplicity annotation in GADT record syntax+   | PsErrIllegalGadtRecordMultiplicity !(HsArrow GhcPs)++   | PsErrInvalidCApiImport++-- | Extra details about a parse error, which helps+-- us in determining which should be the hints to+-- suggest.+data PsErrParseDetails+  = PsErrParseDetails+  { ped_th_enabled :: !Bool+    -- Is 'TemplateHaskell' enabled?+  , ped_do_in_last_100 :: !Bool+    -- ^ Is there a 'do' in the last 100 characters?+  , ped_mdo_in_last_100 :: !Bool+    -- ^ Is there an 'mdo' in the last 100 characters?+  , ped_pat_syn_enabled :: !Bool+    -- ^ Is 'PatternSynonyms' enabled?+  , ped_pattern_parsed :: !Bool+    -- ^ Did we parse a \"pattern\" keyword?+  }++-- | Is the parsed pattern recursive?+data PatIsRecursive+  = YesPatIsRecursive+  | NoPatIsRecursive++data PatIncompleteDoBlock+  = YesIncompleteDoBlock+  | NoIncompleteDoBlock+  deriving Eq++-- | Extra information for the expression GHC is currently inspecting/parsing.+-- It can be used to generate more informative parser diagnostics and hints.+data ParseContext+  = ParseContext+  { is_infix :: !(Maybe RdrName)+    -- ^ If 'Just', this is an infix+    -- pattern with the binded operator name+  , incomplete_do_block :: !PatIncompleteDoBlock+    -- ^ Did the parser likely fail due to an incomplete do block?+  } deriving Eq++data PsErrInPatDetails+  = PEIP_NegApp+    -- ^ Negative application pattern?+  | PEIP_TypeArgs [HsPatSigType GhcPs]+    -- ^ The list of type arguments for the pattern+  | PEIP_RecPattern [LPat GhcPs]    -- ^ The pattern arguments+                    !PatIsRecursive -- ^ Is the parsed pattern recursive?+                    !ParseContext+  | PEIP_OtherPatDetails !ParseContext++noParseContext :: ParseContext+noParseContext = ParseContext Nothing NoIncompleteDoBlock++incompleteDoBlock :: ParseContext+incompleteDoBlock = ParseContext Nothing YesIncompleteDoBlock++-- | Builds a 'PsErrInPatDetails' with the information provided by the 'ParseContext'.+fromParseContext :: ParseContext -> PsErrInPatDetails+fromParseContext = PEIP_OtherPatDetails++data NumUnderscoreReason+   = NumUnderscore_Integral+   | NumUnderscore_Float+   deriving (Show,Eq,Ord)++data LexErrKind+   = LexErrKind_EOF        -- ^ End of input+   | LexErrKind_UTF8       -- ^ UTF-8 decoding error+   | LexErrKind_Char !Char -- ^ Error at given character+   deriving (Show,Eq,Ord)++data LexErr+   = LexError               -- ^ Lexical error+   | LexUnknownPragma       -- ^ Unknown pragma+   | LexErrorInPragma       -- ^ Lexical error in pragma+   | LexNumEscapeRange      -- ^ Numeric escape sequence out of range+   | LexStringCharLit       -- ^ Lexical error in string/character literal+   | LexStringCharLitEOF    -- ^ Unexpected end-of-file in string/character literal+   | LexUnterminatedComment -- ^ Unterminated `{-'+   | LexUnterminatedOptions -- ^ Unterminated OPTIONS pragma+   | LexUnterminatedQQ      -- ^ Unterminated quasiquotation++-- | Errors from the Cmm parser+data CmmParserError+   = CmmUnknownPrimitive    !FastString -- ^ Unknown Cmm primitive+   | CmmUnknownMacro        !FastString -- ^ Unknown macro+   | CmmUnknownCConv        !String     -- ^ Unknown calling convention+   | CmmUnrecognisedSafety  !String     -- ^ Unrecognised safety+   | CmmUnrecognisedHint    !String     -- ^ Unrecognised hint++data TransLayoutReason+   = TransLayout_Where -- ^ "`where' clause at the same depth as implicit layout block"+   | TransLayout_Pipe  -- ^ "`|' at the same depth as implicit layout block")+++data FileHeaderPragmaType+  = OptionsPrag+  | IncludePrag+  | LanguagePrag+  | DocOptionsPrag
+ GHC/Parser/HaddockLex.hs view
@@ -0,0 +1,470 @@+{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-missing-signatures #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+{-# LINE 1 "_build/source-dist/ghc-9.4.1-src/ghc-9.4.1/compiler/GHC/Parser/HaddockLex.x" #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# OPTIONS_GHC -funbox-strict-fields #-}++module GHC.Parser.HaddockLex (lexHsDoc, lexStringLiteral) where++import GHC.Prelude++import GHC.Data.FastString+import GHC.Hs.Doc+import GHC.Parser.Lexer+import GHC.Parser.Annotation+import GHC.Types.SrcLoc+import GHC.Types.SourceText+import GHC.Data.StringBuffer+import qualified GHC.Data.Strict as Strict+import GHC.Types.Name.Reader+import GHC.Utils.Outputable+import GHC.Utils.Error+import GHC.Utils.Encoding+import GHC.Hs.Extension++import qualified GHC.Data.EnumSet as EnumSet++import Data.Maybe+import Data.Word++import Data.ByteString ( ByteString )+import qualified Data.ByteString as BS++import qualified GHC.LanguageExtensions as LangExt+#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#+  "\xda\xff\xff\xff\x0b\x00\x00\x00\x65\x00\x00\x00\xe3\x00\x00\x00\x3d\x01\x00\x00\xbb\x01\x00\x00\xe5\xff\xff\xff\x15\x02\x00\x00\x55\x02\x00\x00\xaf\x02\x00\x00\x00\x00\x00\x00\x2d\x03\x00\x00\xab\x03\x00\x00\x05\x04\x00\x00\xe6\xff\xff\xff\x61\x04\x00\x00\xa1\x04\x00\x00\x1b\x05\x00\x00\x99\x05\x00\x00\x00\x00\x00\x00\x13\x06\x00\x00\x6d\x06\x00\x00\xeb\x06\x00\x00\x65\x07\x00\x00\xdf\xff\xff\xff\xbf\x07\x00\x00\x00\x00\x00\x00\xdc\xff\xff\xff\xff\x07\x00\x00\x59\x08\x00\x00\xe1\xff\xff\xff\x9c\x08\x00\x00\xa5\xff\xff\xff"#++alex_table :: AlexAddr+alex_table = AlexA#+  "\x00\x00\x0b\x00\x18\x00\x1a\x00\x1e\x00\x1a\x00\x13\x00\x00\x00\x06\x00\x0e\x00\x1b\x00\x00\x00\x01\x00\x01\x00\x01\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\x11\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x09\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x1b\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x11\x00\x00\x00\x11\x00\x01\x00\x00\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x11\x00\x00\x00\x11\x00\x11\x00\x11\x00\x11\x00\x00\x00\x00\x00\x00\x00\x11\x00\x11\x00\x00\x00\x11\x00\x11\x00\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x00\x00\x11\x00\x00\x00\x11\x00\x11\x00\x00\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x00\x00\x11\x00\x00\x00\x11\x00\x03\x00\x03\x00\x03\x00\x00\x00\x00\x00\x00\x00\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\x06\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x08\x00\x00\x00\x07\x00\x03\x00\x1b\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x07\x00\x00\x00\x07\x00\x07\x00\x07\x00\x07\x00\x00\x00\x00\x00\x00\x00\x07\x00\x07\x00\x00\x00\x07\x00\x07\x00\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x00\x00\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x00\x00\x07\x00\x00\x00\x07\x00\x08\x00\x00\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x00\x00\x07\x00\x00\x00\x07\x00\x05\x00\x05\x00\x05\x00\x00\x00\x00\x00\x00\x00\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x05\x00\x00\x00\x1b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1f\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\x00\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\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\x07\x00\x05\x00\x00\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x07\x00\x00\x00\x07\x00\x07\x00\x07\x00\x07\x00\x00\x00\x00\x00\x00\x00\x07\x00\x07\x00\x00\x00\x07\x00\x07\x00\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x00\x00\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x08\x00\x08\x00\x08\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\x00\x00\x00\x00\x07\x00\x00\x00\x07\x00\x00\x00\x1b\x00\x00\x00\x00\x00\x06\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\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x00\x00\x00\x00\x07\x00\x00\x00\x07\x00\x00\x00\x00\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x0c\x00\x10\x00\x00\x00\x0f\x00\x08\x00\x1b\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x0f\x00\x00\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x00\x00\x02\x00\x00\x00\x0f\x00\x0f\x00\x00\x00\x0f\x00\x0f\x00\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0f\x00\x00\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x00\x00\x0f\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x00\x00\x0f\x00\x00\x00\x0f\x00\x16\x00\x14\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\x00\x00\x00\x19\x00\x19\x00\x19\x00\x19\x00\x00\x00\x1f\x00\x00\x00\x19\x00\x19\x00\x00\x00\x19\x00\x19\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\x00\x00\x00\x19\x00\x19\x00\x19\x00\x19\x00\x19\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x00\x00\x19\x00\x00\x00\x19\x00\x14\x00\x04\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x00\x00\x19\x00\x00\x00\x19\x00\x0c\x00\x0c\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x00\x00\x00\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x10\x00\x00\x00\x0f\x00\x0c\x00\x13\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0f\x00\x00\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x00\x00\x00\x00\x00\x00\x0f\x00\x0f\x00\x00\x00\x0f\x00\x0f\x00\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0f\x00\x00\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x00\x00\x0f\x00\x00\x00\x0f\x00\x10\x00\x0f\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x00\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x00\x00\x00\x00\x00\x00\x0f\x00\x0f\x00\x00\x00\x0f\x00\x0f\x00\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0f\x00\x00\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x10\x00\x10\x00\x10\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\x0f\x00\x00\x00\x0f\x00\x00\x00\x13\x00\x00\x00\x00\x00\x0e\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\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x00\x00\x00\x00\x0f\x00\x00\x00\x0f\x00\x00\x00\x00\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x13\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x11\x00\x11\x00\x11\x00\x11\x00\x00\x00\x00\x00\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x00\x00\x20\x00\x11\x00\x11\x00\x00\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x00\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x00\x00\x11\x00\x00\x00\x11\x00\x11\x00\x00\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x00\x00\x11\x00\x00\x00\x11\x00\x14\x00\x14\x00\x14\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x16\x00\x14\x00\x00\x00\x19\x00\x14\x00\x00\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x19\x00\x00\x00\x19\x00\x19\x00\x19\x00\x19\x00\x00\x00\x00\x00\x00\x00\x19\x00\x19\x00\x00\x00\x19\x00\x19\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\x00\x00\x00\x19\x00\x19\x00\x19\x00\x19\x00\x19\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x00\x00\x19\x00\x00\x00\x19\x00\x14\x00\x00\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x00\x00\x19\x00\x00\x00\x19\x00\x16\x00\x16\x00\x16\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x00\x00\x00\x00\x00\x00\x19\x00\x16\x00\x00\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x19\x00\x00\x00\x19\x00\x19\x00\x19\x00\x19\x00\x13\x00\x00\x00\x00\x00\x19\x00\x19\x00\x00\x00\x19\x00\x19\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\x00\x00\x00\x19\x00\x19\x00\x19\x00\x19\x00\x19\x00\x1c\x00\x1c\x00\x1c\x00\x00\x00\x00\x00\x00\x00\x1c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x1c\x00\x00\x00\x1b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x00\x00\x00\x00\x19\x00\x00\x00\x19\x00\x00\x00\x00\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x00\x00\x00\x00\x00\x00\x1d\x00\x1c\x00\x00\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1d\x00\x00\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x00\x00\x00\x00\x1b\x00\x1d\x00\x1d\x00\x00\x00\x1d\x00\x1d\x00\x1d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1d\x00\x00\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x00\x00\x00\x00\x00\x00\x05\x00\x1c\x00\x00\x00\x1d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1d\x00\x00\x00\x1d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1d\x00\x00\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x00\x00\x00\x00\x00\x00\x1d\x00\x1d\x00\x00\x00\x1d\x00\x1d\x00\x1d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x00\x00\x1d\x00\x00\x00\x1d\x00\x1c\x00\x00\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x00\x00\x1d\x00\x00\x00\x1d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"#++alex_check :: AlexAddr+alex_check = AlexA#+  "\xff\xff\x27\x00\x23\x00\x27\x00\x23\x00\x60\x00\x27\x00\xff\xff\x23\x00\x23\x00\x29\x00\xff\xff\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\x29\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\x60\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x60\x00\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\x02\x00\xff\xff\x04\x00\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\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\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\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\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\xff\xff\x5c\x00\xff\xff\x5e\x00\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\x7c\x00\xff\xff\x7e\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\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\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\x02\x00\xff\xff\x04\x00\x5f\x00\x60\x00\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\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\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\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\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\xff\xff\x5c\x00\xff\xff\x5e\x00\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\x7c\x00\xff\xff\x7e\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\x29\x00\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\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\x04\x00\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\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\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\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\x23\x00\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\x38\x00\x39\x00\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\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\x02\x00\xff\xff\x04\x00\x5f\x00\x60\x00\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\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\x28\x00\xff\xff\x2a\x00\x2b\x00\xff\xff\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\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\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\xff\xff\x5c\x00\xff\xff\x5e\x00\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\x7c\x00\xff\xff\x7e\x00\x01\x00\x02\x00\xff\xff\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\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\x28\x00\xff\xff\x2a\x00\x2b\x00\xff\xff\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\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\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\xff\xff\x5c\x00\xff\xff\x5e\x00\x5f\x00\x60\x00\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\x7c\x00\xff\xff\x7e\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\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\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\x02\x00\xff\xff\x04\x00\x5f\x00\x60\x00\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\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\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\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\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\xff\xff\x5c\x00\xff\xff\x5e\x00\x5f\x00\x04\x00\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\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\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\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\x23\x00\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\x38\x00\x39\x00\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\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\x60\x00\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\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\x29\x00\x2a\x00\x2b\x00\xff\xff\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\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\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\xff\xff\x5c\x00\xff\xff\x5e\x00\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\x7c\x00\xff\xff\x7e\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\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\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\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\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\x02\x00\xff\xff\x04\x00\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\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\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\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\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\xff\xff\x5c\x00\xff\xff\x5e\x00\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\x7c\x00\xff\xff\x7e\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\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\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\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\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\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\x04\x00\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\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\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\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\x29\x00\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\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\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\x04\x00\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\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\x29\x00\x2a\x00\x2b\x00\xff\xff\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\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\x01\x00\x02\x00\xff\xff\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\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\x3a\x00\x7e\x00\x3c\x00\x3d\x00\x3e\x00\x3f\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\xff\xff\x5c\x00\xff\xff\x5e\x00\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\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"#++alex_deflt :: AlexAddr+alex_deflt = AlexA#+  "\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"#++alex_accept = listArray (0 :: Int, 32)+  [ AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAccSkip+  , AlexAccSkip+  , AlexAccSkip+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAcc 3+  , AlexAcc 2+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAcc 1+  , AlexAccNone+  , AlexAccNone+  , AlexAcc 0+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  ]++alex_actions = array (0 :: Int, 4)+  [ (3,alex_action_0)+  , (2,alex_action_0)+  , (1,alex_action_0)+  , (0,alex_action_1)+  ]++{-# LINE 87 "_build/source-dist/ghc-9.4.1-src/ghc-9.4.1/compiler/GHC/Parser/HaddockLex.x" #-}+data AlexInput = AlexInput+  { alexInput_position     :: !RealSrcLoc+  , alexInput_string       :: !ByteString+  }++-- NB: As long as we don't use a left-context we don't need to track the+-- previous input character.+alexInputPrevChar :: AlexInput -> Word8+alexInputPrevChar = error "Left-context not supported"++alexGetByte :: AlexInput -> Maybe (Word8, AlexInput)+alexGetByte (AlexInput p s) = case utf8UnconsByteString s of+  Nothing -> Nothing+  Just (c,bs) -> Just (adjustChar c, AlexInput (advanceSrcLoc p c) bs)++alexScanTokens :: RealSrcLoc -> ByteString -> [(RealSrcSpan, ByteString)]+alexScanTokens start str0 = go (AlexInput start str0)+  where go inp@(AlexInput pos str) =+          case alexScan inp 0 of+            AlexSkip  inp' _ln          -> go inp'+            AlexToken inp'@(AlexInput _ str') _ act -> act pos (BS.length str - BS.length str') str : go inp'+            AlexEOF                     -> []+            AlexError (AlexInput p _) -> error $ "lexical error at " ++ show p++--------------------------------------------------------------------------------++-- | Extract identifier from Alex state.+getIdentifier :: Int -- ^ adornment length+              -> RealSrcLoc+              -> Int+                 -- ^ Token length+              -> ByteString+                 -- ^ The remaining input beginning with the found token+              -> (RealSrcSpan, ByteString)+getIdentifier !i !loc0 !len0 !s0 =+    (mkRealSrcSpan loc1 loc2, ident)+  where+    (adornment, s1) = BS.splitAt i s0+    ident = BS.take (len0 - 2*i) s1+    loc1 = advanceSrcLocBS loc0 adornment+    loc2 = advanceSrcLocBS loc1 ident++advanceSrcLocBS :: RealSrcLoc -> ByteString -> RealSrcLoc+advanceSrcLocBS !loc bs = case utf8UnconsByteString bs of+  Nothing -> loc+  Just (c, bs') -> advanceSrcLocBS (advanceSrcLoc loc c) bs'++-- | Lex 'StringLiteral' for warning messages+lexStringLiteral :: P (LocatedN RdrName) -- ^ A precise identifier parser+                 -> Located StringLiteral+                 -> Located (WithHsDocIdentifiers StringLiteral GhcPs)+lexStringLiteral identParser (L l sl@(StringLiteral _ fs _))+  = L l (WithHsDocIdentifiers sl idents)+  where+    bs = bytesFS fs++    idents = mapMaybe (uncurry (validateIdentWith identParser)) plausibleIdents++    plausibleIdents :: [(SrcSpan,ByteString)]+    plausibleIdents = case l of+      RealSrcSpan span _ -> [(RealSrcSpan span' Strict.Nothing, tok) | (span', tok) <- alexScanTokens (realSrcSpanStart span) bs]+      UnhelpfulSpan reason -> [(UnhelpfulSpan reason, tok) | (_, tok) <- alexScanTokens fakeLoc bs]++    fakeLoc = mkRealSrcLoc (mkFastString "") 0 0++-- | Lex identifiers from a docstring.+lexHsDoc :: P (LocatedN RdrName)      -- ^ A precise identifier parser+         -> HsDocString+         -> HsDoc GhcPs+lexHsDoc identParser doc =+    WithHsDocIdentifiers doc idents+  where+    docStrings = docStringChunks doc+    idents = concat [mapMaybe maybeDocIdentifier (plausibleIdents doc) | doc <- docStrings]++    maybeDocIdentifier :: (SrcSpan, ByteString) -> Maybe (Located RdrName)+    maybeDocIdentifier = uncurry (validateIdentWith identParser)++    plausibleIdents :: LHsDocStringChunk -> [(SrcSpan,ByteString)]+    plausibleIdents (L (RealSrcSpan span _) (HsDocStringChunk s))+      = [(RealSrcSpan span' Strict.Nothing, tok) | (span', tok) <- alexScanTokens (realSrcSpanStart span) s]+    plausibleIdents (L (UnhelpfulSpan reason) (HsDocStringChunk s))+      = [(UnhelpfulSpan reason, tok) | (_, tok) <- alexScanTokens fakeLoc s] -- preserve the original reason++    fakeLoc = mkRealSrcLoc (mkFastString "") 0 0++validateIdentWith :: P (LocatedN RdrName) -> SrcSpan -> ByteString -> Maybe (Located RdrName)+validateIdentWith identParser mloc str0 =+  let -- These ParserFlags should be as "inclusive" as possible, allowing+      -- identifiers defined with any language extension.+      pflags = mkParserOpts+                 (EnumSet.fromList [LangExt.MagicHash])+                 dopts+                 []+                 False False False False+      dopts = DiagOpts+        { diag_warning_flags = EnumSet.empty+          , diag_fatal_warning_flags = EnumSet.empty+          , diag_warn_is_error = False+          , diag_reverse_errors = False+          , diag_max_errors = Nothing+          , diag_ppr_ctx = defaultSDocContext+        }+      buffer = stringBufferFromByteString str0+      realSrcLc = case mloc of+        RealSrcSpan loc _ -> realSrcSpanStart loc+        UnhelpfulSpan _ -> mkRealSrcLoc (mkFastString "") 0 0+      pstate = initParserState pflags buffer realSrcLc+  in case unP identParser pstate of+    POk _ name -> Just $ case mloc of+       RealSrcSpan _ _ -> reLoc name+       UnhelpfulSpan _ -> L mloc (unLoc name) -- Preserve the original reason+    _ -> Nothing+alex_action_0 = getIdentifier 1+alex_action_1 = getIdentifier 2++#define ALEX_GHC 1+#define ALEX_LATIN1 1+#define ALEX_NOPRED 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)+                check  = alexIndexInt16OffAddr alex_check offset++                new_s = if GTE(offset,ILIT(0)) && 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
GHC/Parser/Header.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP          #-} {-# LANGUAGE TypeFamilies #-}  -----------------------------------------------------------------------------@@ -16,22 +15,18 @@    , mkPrelImports -- used by the renamer too    , getOptionsFromFile    , getOptions-   , optionsErrorMsgs+   , toArgs    , checkProcessArgsResult    ) where -#include "HsVersions.h"- import GHC.Prelude -import GHC.Platform+import GHC.Data.Bag -import GHC.Driver.Session-import GHC.Driver.Config+import GHC.Driver.Errors.Types -- Unfortunate, needed due to the fact we throw exceptions! -import GHC.Parser.Errors.Ppr-import GHC.Parser.Errors+import GHC.Parser.Errors.Types import GHC.Parser           ( parseHeader ) import GHC.Parser.Lexer @@ -39,26 +34,31 @@ import GHC.Unit.Module import GHC.Builtin.Names -import GHC.Types.Error hiding ( getErrorMessages, getWarningMessages )+import GHC.Types.Error import GHC.Types.SrcLoc import GHC.Types.SourceError import GHC.Types.SourceText+import GHC.Types.PkgQual  import GHC.Utils.Misc-import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic import GHC.Utils.Monad+import GHC.Utils.Error import GHC.Utils.Exception as Exception  import GHC.Data.StringBuffer import GHC.Data.Maybe-import GHC.Data.Bag         ( Bag, listToBag, unitBag, isEmptyBag ) import GHC.Data.FastString+import qualified GHC.Data.Strict as Strict  import Control.Monad import System.IO import System.IO.Unsafe import Data.List (partition)+import Data.Char (isSpace)+import Text.ParserCombinators.ReadP (readP_to_S, gather)+import Text.ParserCombinators.ReadPrec (readPrec_to_P)+import Text.Read (readPrec)  ------------------------------------------------------------------------------ @@ -73,9 +73,10 @@            -> FilePath     -- ^ The original source filename (used for locations                            --   in the function result)            -> IO (Either-               (Bag PsError)-               ([(Maybe FastString, Located ModuleName)],-                [(Maybe FastString, Located ModuleName)],+               (Messages PsMessage)+               ([(RawPkgQual, Located ModuleName)],+                [(RawPkgQual, Located ModuleName)],+                Bool, -- Is GHC.Prim imported or not                 Located ModuleName))               -- ^ The source imports and normal imports (with optional package               -- names from -XPackageImports), and the module name.@@ -84,13 +85,13 @@   case unP parseHeader (initParserState popts buf loc) of     PFailed pst ->         -- assuming we're not logging warnings here as per below-      return $ Left $ getErrorMessages pst+      return $ Left $ getPsErrorMessages pst     POk pst rdr_module -> fmap Right $ do-      let (_warns, errs) = getMessages pst+      let (_warns, errs) = getPsMessages pst       -- don't log warnings: they'll be reported when we parse the file       -- for real.  See #2500.-      if not (isEmptyBag errs)-        then throwIO $ mkSrcErr (fmap pprError errs)+      if not (isEmptyMessages errs)+        then throwErrors (GhcPsMessage <$> errs)         else           let   hsmod = unLoc rdr_module                 mb_mod = hsmodName hsmod@@ -101,17 +102,19 @@                 (src_idecls, ord_idecls) = partition ((== IsBoot) . ideclSource . unLoc) imps                 -- GHC.Prim doesn't exist physically, so don't go looking for it.-                ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc-                                        . ideclName . unLoc)-                                       ord_idecls+                (ordinary_imps, ghc_prim_import)+                  = partition ((/= moduleName gHC_PRIM) . unLoc+                                  . ideclName . unLoc)+                                 ord_idecls                  implicit_imports = mkPrelImports (unLoc mod) main_loc                                                  implicit_prelude imps-                convImport (L _ i) = (fmap sl_fs (ideclPkgQual i), reLoc (ideclName i))+                convImport (L _ i) = (ideclPkgQual i, reLoc $ ideclName i)               in-              return (map convImport src_idecls,-                      map convImport (implicit_imports ++ ordinary_imps),-                      reLoc mod)+              return (map convImport src_idecls+                     , map convImport (implicit_imports ++ ordinary_imps)+                     , not (null ghc_prim_import)+                     , reLoc mod)  mkPrelImports :: ModuleName               -> SrcSpan    -- Attribute the "import Prelude" to this location@@ -135,8 +138,8 @@         unLoc (ideclName decl) == pRELUDE_NAME         -- allow explicit "base" package qualifier (#19082, #17045)         && case ideclPkgQual decl of-            Nothing -> True-            Just b  -> sl_fs b == unitIdFS baseUnitId+            NoRawPkgQual -> True+            RawPkgQual b -> sl_fs b == unitIdFS baseUnitId         loc' = noAnnSrcSpan loc@@ -145,7 +148,7 @@         = L loc' $ ImportDecl { ideclExt       = noAnn,                                 ideclSourceSrc = NoSourceText,                                 ideclName      = L loc' pRELUDE_NAME,-                                ideclPkgQual   = Nothing,+                                ideclPkgQual   = NoRawPkgQual,                                 ideclSource    = NotBoot,                                 ideclSafe      = False,  -- Not a safe import                                 ideclQualified = NotQualified,@@ -160,17 +163,19 @@ -- | Parse OPTIONS and LANGUAGE pragmas of the source file. -- -- Throws a 'SourceError' if flag parsing fails (including unsupported flags.)-getOptionsFromFile :: DynFlags+getOptionsFromFile :: ParserOpts                    -> FilePath            -- ^ Input file-                   -> IO [Located String] -- ^ Parsed options, if any.-getOptionsFromFile dflags filename+                   -> IO (Messages PsMessage, [Located String]) -- ^ Parsed options, if any.+getOptionsFromFile opts filename     = Exception.bracket               (openBinaryFile filename ReadMode)               (hClose)               (\handle -> do-                  opts <- fmap (getOptions' dflags)-                               (lazyGetToks (initParserOpts dflags') filename handle)-                  seqList opts $ return opts)+                  (warns, opts) <- fmap (getOptions' opts)+                               (lazyGetToks opts' filename handle)+                  seqList opts+                    $ seqList (bagToList $ getMessages warns)+                    $ return (warns, opts))     where -- We don't need to get haddock doc tokens when we're just           -- getting the options from pragmas, and lazily lexing them           -- correctly is a little tricky: If there is "\n" or "\n-"@@ -179,7 +184,7 @@           -- we already have an apparently-complete token.           -- We therefore just turn Opt_Haddock off when doing the lazy           -- lex.-          dflags' = gopt_unset dflags Opt_Haddock+          opts' = disableHaddock opts  blockSize :: Int -- blockSize = 17 -- for testing :-)@@ -239,49 +244,55 @@ -- | Parse OPTIONS and LANGUAGE pragmas of the source file. -- -- Throws a 'SourceError' if flag parsing fails (including unsupported flags.)-getOptions :: DynFlags+getOptions :: ParserOpts            -> StringBuffer -- ^ Input Buffer            -> FilePath     -- ^ Source filename.  Used for location info.-           -> [Located String] -- ^ Parsed options.-getOptions dflags buf filename-    = getOptions' dflags (getToks (initParserOpts dflags) filename buf)+           -> (Messages PsMessage,[Located String]) -- ^ warnings and parsed options.+getOptions opts buf filename+    = getOptions' opts (getToks opts filename buf)  -- The token parser is written manually because Happy can't -- return a partial result when it encounters a lexer error. -- We want to extract options before the buffer is passed through -- CPP, so we can't use the same trick as 'getImports'.-getOptions' :: DynFlags+getOptions' :: ParserOpts             -> [Located Token]      -- Input buffer-            -> [Located String]     -- Options.-getOptions' dflags toks+            -> (Messages PsMessage,[Located String])     -- Options.+getOptions' opts toks     = parseToks toks     where           parseToks (open:close:xs)               | IToptions_prag str <- unLoc open               , ITclose_prag       <- unLoc close-              = case toArgs str of+              = case toArgs starting_loc str of                   Left _err -> optionsParseError str $   -- #15053                                  combineSrcSpans (getLoc open) (getLoc close)-                  Right args -> map (L (getLoc open)) args ++ parseToks xs+                  Right args -> fmap (args ++) (parseToks xs)+            where+              src_span      = getLoc open+              real_src_span = expectJust "getOptions'" (srcSpanToRealSrcSpan src_span)+              starting_loc  = realSrcSpanStart real_src_span           parseToks (open:close:xs)               | ITinclude_prag str <- unLoc open               , ITclose_prag       <- unLoc close-              = map (L (getLoc open)) ["-#include",removeSpaces str] ++-                parseToks xs+              = fmap (map (L (getLoc open)) ["-#include",removeSpaces str] ++)+                     (parseToks xs)           parseToks (open:close:xs)               | ITdocOptions str _ <- unLoc open               , ITclose_prag       <- unLoc close-              = map (L (getLoc open)) ["-haddock-opts", removeSpaces str]-                ++ parseToks xs+              = fmap (map (L (getLoc open)) ["-haddock-opts", removeSpaces str] ++)+                     (parseToks xs)           parseToks (open:xs)               | ITlanguage_prag <- unLoc open               = parseLanguage xs           parseToks (comment:xs) -- Skip over comments               | isComment (unLoc comment)               = parseToks xs-          parseToks _ = []+          -- At the end of the header, warn about all the misplaced pragmas+          parseToks xs = (unionManyMessages $ mapMaybe mkMessage xs ,[])+           parseLanguage ((L loc (ITconid fs)):rest)-              = checkExtension dflags (L loc fs) :+              = fmap (checkExtension opts (L loc fs) :) $                 case rest of                   (L _loc ITcomma):more -> parseLanguage more                   (L _loc ITclose_prag):more -> parseToks more@@ -292,17 +303,129 @@           parseLanguage []               = panic "getOptions'.parseLanguage(2) went past eof token" +          -- Warn for all the misplaced pragmas+          mkMessage :: Located Token -> Maybe (Messages PsMessage)+          mkMessage (L loc token)+            | IToptions_prag _ <- token+            = Just (singleMessage $ mkPlainMsgEnvelope diag_opts loc (PsWarnMisplacedPragma OptionsPrag))+            | ITinclude_prag _ <- token+            = Just (singleMessage $ mkPlainMsgEnvelope diag_opts loc (PsWarnMisplacedPragma IncludePrag))+            | ITdocOptions _ _ <- token+            = Just (singleMessage $ mkPlainMsgEnvelope diag_opts loc (PsWarnMisplacedPragma DocOptionsPrag))+            | ITlanguage_prag <- token+            = Just (singleMessage $ mkPlainMsgEnvelope diag_opts loc (PsWarnMisplacedPragma LanguagePrag))+            | otherwise = Nothing+            where diag_opts = pDiagOpts opts+           isComment :: Token -> Bool           isComment c =             case c of-              (ITlineComment {})     -> True-              (ITblockComment {})    -> True-              (ITdocCommentNext {})  -> True-              (ITdocCommentPrev {})  -> True-              (ITdocCommentNamed {}) -> True-              (ITdocSection {})      -> True-              _                      -> False+              (ITlineComment {})  -> True+              (ITblockComment {}) -> True+              (ITdocComment {})   -> True+              _                   -> False +toArgs :: RealSrcLoc+       -> String -> Either String   -- Error+                           [Located String] -- Args+toArgs starting_loc orig_str+    = let (after_spaces_loc, after_spaces_str) = consume_spaces starting_loc orig_str in+      case after_spaces_str of+      '[':after_bracket ->+        let after_bracket_loc = advanceSrcLoc after_spaces_loc '['+            (after_bracket_spaces_loc, after_bracket_spaces_str)+              = consume_spaces after_bracket_loc after_bracket in+        case after_bracket_spaces_str of+          ']':rest | all isSpace rest -> Right []+          _ -> readAsList after_bracket_spaces_loc after_bracket_spaces_str++      _ -> toArgs' after_spaces_loc after_spaces_str+ where+  consume_spaces :: RealSrcLoc -> String -> (RealSrcLoc, String)+  consume_spaces loc [] = (loc, [])+  consume_spaces loc (c:cs)+    | isSpace c = consume_spaces (advanceSrcLoc loc c) cs+    | otherwise = (loc, c:cs)++  break_with_loc :: (Char -> Bool) -> RealSrcLoc -> String+                 -> (String, RealSrcLoc, String)  -- location is start of second string+  break_with_loc p = go []+    where+      go reversed_acc loc [] = (reverse reversed_acc, loc, [])+      go reversed_acc loc (c:cs)+        | p c       = (reverse reversed_acc, loc, c:cs)+        | otherwise = go (c:reversed_acc) (advanceSrcLoc loc c) cs++  advance_src_loc_many :: RealSrcLoc -> String -> RealSrcLoc+  advance_src_loc_many = foldl' advanceSrcLoc++  locate :: RealSrcLoc -> RealSrcLoc -> a -> Located a+  locate begin end x = L (RealSrcSpan (mkRealSrcSpan begin end) Strict.Nothing) x++  toArgs' :: RealSrcLoc -> String -> Either String [Located String]+  -- Remove outer quotes:+  -- > toArgs' "\"foo\" \"bar baz\""+  -- Right ["foo", "bar baz"]+  --+  -- Keep inner quotes:+  -- > toArgs' "-DFOO=\"bar baz\""+  -- Right ["-DFOO=\"bar baz\""]+  toArgs' loc s =+    let (after_spaces_loc, after_spaces_str) = consume_spaces loc s in+    case after_spaces_str of+      [] -> Right []+      '"' : _ -> do+        -- readAsString removes outer quotes+        (arg, new_loc, rest) <- readAsString after_spaces_loc after_spaces_str+        check_for_space rest+        (locate after_spaces_loc new_loc arg:)+          `fmap` toArgs' new_loc rest+      _ -> case break_with_loc (isSpace <||> (== '"')) after_spaces_loc after_spaces_str of+            (argPart1, loc2, s''@('"':_)) -> do+                (argPart2, loc3, rest) <- readAsString loc2 s''+                check_for_space rest+                -- show argPart2 to keep inner quotes+                (locate after_spaces_loc loc3 (argPart1 ++ show argPart2):)+                  `fmap` toArgs' loc3 rest+            (arg, loc2, s'') -> (locate after_spaces_loc loc2 arg:)+                                  `fmap` toArgs' loc2 s''++  check_for_space :: String -> Either String ()+  check_for_space [] = Right ()+  check_for_space (c:_)+    | isSpace c = Right ()+    | otherwise = Left ("Whitespace expected after string in " ++ show orig_str)++  reads_with_consumed :: Read a => String+                      -> [((String, a), String)]+                        -- ((consumed string, parsed result), remainder of input)+  reads_with_consumed = readP_to_S (gather (readPrec_to_P readPrec 0))++  readAsString :: RealSrcLoc+               -> String+               -> Either String (String, RealSrcLoc, String)+  readAsString loc s = case reads_with_consumed s of+                [((consumed, arg), rest)] ->+                    Right (arg, advance_src_loc_many loc consumed, rest)+                _ ->+                    Left ("Couldn't read " ++ show s ++ " as String")++   -- input has had the '[' stripped off+  readAsList :: RealSrcLoc -> String -> Either String [Located String]+  readAsList loc s = do+    let (after_spaces_loc, after_spaces_str) = consume_spaces loc s+    (arg, after_arg_loc, after_arg_str) <- readAsString after_spaces_loc after_spaces_str+    let (after_arg_spaces_loc, after_arg_spaces_str)+          = consume_spaces after_arg_loc after_arg_str+    (locate after_spaces_loc after_arg_loc arg :) <$>+      case after_arg_spaces_str of+        ',':after_comma -> readAsList (advanceSrcLoc after_arg_spaces_loc ',') after_comma+        ']':after_bracket+          | all isSpace after_bracket+          -> Right []+        _ -> Left ("Couldn't read " ++ show ('[' : s) ++ " as [String]")+             -- reinsert missing '[' for clarity.+ -----------------------------------------------------------------------------  -- | Complain about non-dynamic flags in OPTIONS pragmas.@@ -312,63 +435,36 @@ checkProcessArgsResult :: MonadIO m => [Located String] -> m () checkProcessArgsResult flags   = when (notNull flags) $-      liftIO $ throwIO $ mkSrcErr $ listToBag $ map mkMsg flags+      liftIO $ throwErrors $ foldMap (singleMessage . mkMsg) flags     where mkMsg (L loc flag)-              = mkPlainMsgEnvelope loc $-                  (text "unknown flag in  {-# OPTIONS_GHC #-} pragma:" <+>-                   text flag)+              = mkPlainErrorMsgEnvelope loc $+                GhcPsMessage $ PsHeaderMessage $ PsErrUnknownOptionsPragma flag  ----------------------------------------------------------------------------- -checkExtension :: DynFlags -> Located FastString -> Located String-checkExtension dflags (L l ext)+checkExtension :: ParserOpts -> Located FastString -> Located String+checkExtension opts (L l ext) -- Checks if a given extension is valid, and if so returns -- its corresponding flag. Otherwise it throws an exception.-  = if ext' `elem` supported+  = if ext' `elem` (pSupportedExts opts)     then L l ("-X"++ext')-    else unsupportedExtnError dflags l ext'+    else unsupportedExtnError opts l ext'   where     ext' = unpackFS ext-    supported = supportedLanguagesAndExtensions $ platformArchOS $ targetPlatform dflags  languagePragParseError :: SrcSpan -> a languagePragParseError loc =-    throwErr loc $-       vcat [ text "Cannot parse LANGUAGE pragma"-            , text "Expecting comma-separated list of language options,"-            , text "each starting with a capital letter"-            , nest 2 (text "E.g. {-# LANGUAGE TemplateHaskell, GADTs #-}") ]--unsupportedExtnError :: DynFlags -> SrcSpan -> String -> a-unsupportedExtnError dflags loc unsup =-    throwErr loc $-        text "Unsupported extension: " <> text unsup $$-        if null suggestions then Outputable.empty else text "Perhaps you meant" <+> quotedListWithOr (map text suggestions)-  where-     supported = supportedLanguagesAndExtensions $ platformArchOS $ targetPlatform dflags-     suggestions = fuzzyMatch unsup supported-+    throwErr loc $ PsErrParseLanguagePragma -optionsErrorMsgs :: [String] -> [Located String] -> FilePath -> Messages DecoratedSDoc-optionsErrorMsgs unhandled_flags flags_lines _filename-  = mkMessages $ listToBag (map mkMsg unhandled_flags_lines)-  where unhandled_flags_lines :: [Located String]-        unhandled_flags_lines = [ L l f-                                | f <- unhandled_flags-                                , L l f' <- flags_lines-                                , f == f' ]-        mkMsg (L flagSpan flag) =-            mkPlainMsgEnvelope flagSpan $-                    text "unknown flag in  {-# OPTIONS_GHC #-} pragma:" <+> text flag+unsupportedExtnError :: ParserOpts -> SrcSpan -> String -> a+unsupportedExtnError opts loc unsup =+    throwErr loc $ PsErrUnsupportedExt unsup (pSupportedExts opts)  optionsParseError :: String -> SrcSpan -> a     -- #15053 optionsParseError str loc =-  throwErr loc $-      vcat [ text "Error while parsing OPTIONS_GHC pragma."-           , text "Expecting whitespace-separated list of GHC options."-           , text "  E.g. {-# OPTIONS_GHC -Wall -O2 #-}"-           , text ("Input was: " ++ show str) ]+  throwErr loc $ PsErrParseOptionsPragma str -throwErr :: SrcSpan -> SDoc -> a                -- #15053-throwErr loc doc =-  throw $ mkSrcErr $ unitBag $ mkPlainMsgEnvelope loc doc+throwErr :: SrcSpan -> PsHeaderMessage -> a                -- #15053+throwErr loc ps_msg =+  let msg = mkPlainErrorMsgEnvelope loc $ GhcPsMessage (PsHeaderMessage ps_msg)+  in throw $ mkSrcErr $ singleMessage msg
+ GHC/Parser/Lexer.hs view
@@ -0,0 +1,3883 @@+{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-missing-signatures #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+{-# LINE 43 "_build/source-dist/ghc-9.4.1-src/ghc-9.4.1/compiler/GHC/Parser/Lexer.x" #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE UnboxedSums #-}+{-# LANGUAGE UnliftedNewtypes #-}+{-# LANGUAGE PatternSynonyms #-}+++{-# OPTIONS_GHC -funbox-strict-fields #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++module GHC.Parser.Lexer (+   Token(..), lexer, lexerDbg,+   ParserOpts(..), mkParserOpts,+   PState (..), initParserState, initPragState,+   P(..), ParseResult(POk, PFailed),+   allocateComments, allocatePriorComments, allocateFinalComments,+   MonadP(..),+   getRealSrcLoc, getPState,+   failMsgP, failLocMsgP, srcParseFail,+   getPsErrorMessages, getPsMessages,+   popContext, pushModuleContext, setLastToken, setSrcLoc,+   activeContext, nextIsEOF,+   getLexState, popLexState, pushLexState,+   ExtBits(..),+   xtest, xunset, xset,+   disableHaddock,+   lexTokenStream,+   mkParensEpAnn,+   getCommentsFor, getPriorCommentsFor, getFinalCommentsFor,+   getEofPos,+   commentToAnnotation,+   HdkComment(..),+   warnopt,+   adjustChar,+   addPsMessage+  ) where++import GHC.Prelude+import qualified GHC.Data.Strict as Strict++-- base+import Control.Monad+import Control.Applicative+import Data.Char+import Data.List (stripPrefix, isInfixOf, partition)+import Data.List.NonEmpty ( NonEmpty(..) )+import qualified Data.List.NonEmpty as NE+import Data.Maybe+import Data.Word+import Debug.Trace (trace)++import GHC.Data.EnumSet as EnumSet++-- ghc-boot+import qualified GHC.LanguageExtensions as LangExt++-- bytestring+import Data.ByteString (ByteString)++-- containers+import Data.Map (Map)+import qualified Data.Map as Map++-- compiler+import GHC.Utils.Error+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Data.StringBuffer+import GHC.Data.FastString+import GHC.Types.Error+import GHC.Types.Unique.FM+import GHC.Data.Maybe+import GHC.Data.OrdList+import GHC.Utils.Misc ( readSignificandExponentPair, readHexSignificandExponentPair )++import GHC.Types.SrcLoc+import GHC.Types.SourceText+import GHC.Types.Basic ( InlineSpec(..), RuleMatchInfo(..))+import GHC.Hs.Doc++import GHC.Parser.CharClass++import GHC.Parser.Annotation+import GHC.Driver.Flags+import GHC.Parser.Errors.Basic+import GHC.Parser.Errors.Types+import GHC.Parser.Errors.Ppr ()+#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\x7b\x00\x00\x00\x84\x00\x00\x00\xa0\x00\x00\x00\xbc\x00\x00\x00\xc5\x00\x00\x00\xce\x00\x00\x00\xec\x00\x00\x00\x06\x01\x00\x00\x22\x01\x00\x00\x3f\x01\x00\x00\x7b\x01\x00\x00\x00\x00\x00\x00\x85\xff\xff\xff\x00\x00\x00\x00\xf8\x01\x00\x00\x00\x00\x00\x00\x74\x02\x00\x00\x00\x00\x00\x00\xf0\x02\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x6c\x03\x00\x00\x00\x00\x00\x00\xe8\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x04\x00\x00\x00\x00\x00\x00\x82\x04\x00\x00\xfc\x04\x00\x00\x67\x00\x00\x00\x00\x00\x00\x00\x56\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd7\xff\xff\xff\x00\x00\x00\x00\xd4\x05\x00\x00\x4e\x06\x00\x00\xc8\x06\x00\x00\x42\x07\x00\x00\xbc\x07\x00\x00\x36\x08\x00\x00\xb0\x08\x00\x00\x2a\x09\x00\x00\xa4\x09\x00\x00\x1e\x0a\x00\x00\x98\x0a\x00\x00\x12\x0b\x00\x00\x4c\x0b\x00\x00\xc6\x0b\x00\x00\x40\x0c\x00\x00\xba\x0c\x00\x00\x34\x0d\x00\x00\xae\x0d\x00\x00\x28\x0e\x00\x00\xa2\x0e\x00\x00\x1c\x0f\x00\x00\x96\x0f\x00\x00\x10\x10\x00\x00\x9c\xff\xff\xff\xa0\xff\xff\xff\xa1\xff\xff\xff\xab\xff\xff\xff\xee\xff\xff\xff\xef\xff\xff\xff\xf0\xff\xff\xff\xf1\xff\xff\xff\xf2\xff\xff\xff\xf3\xff\xff\xff\x6a\x10\x00\x00\x9f\x10\x00\x00\xe5\x10\x00\x00\x08\x11\x00\x00\x2b\x11\x00\x00\x3d\x01\x00\x00\x82\x10\x00\x00\x51\x00\x00\x00\x76\x00\x00\x00\xd1\x00\x00\x00\xd4\x01\x00\x00\x3c\x11\x00\x00\x80\x11\x00\x00\xa5\x11\x00\x00\xee\x11\x00\x00\x63\x00\x00\x00\x7e\x00\x00\x00\x4f\x02\x00\x00\xcc\x02\x00\x00\xf8\x11\x00\x00\x31\x12\x00\x00\xe1\x01\x00\x00\x47\x03\x00\x00\xe7\xff\xff\xff\xc4\x03\x00\x00\x5c\x02\x00\x00\x5d\x04\x00\x00\xd7\x04\x00\x00\xaf\x05\x00\x00\x72\x05\x00\x00\xd4\x02\x00\x00\x2f\x06\x00\x00\x72\x12\x00\x00\xa1\x06\x00\x00\x56\x03\x00\x00\xb3\x12\x00\x00\xce\x03\x00\x00\xf4\x12\x00\x00\x1d\x07\x00\x00\x35\x13\x00\x00\x95\x07\x00\x00\xe6\x04\x00\x00\x76\x13\x00\x00\x67\x05\x00\x00\xb7\x13\x00\x00\x11\x08\x00\x00\x60\x00\x00\x00\x68\x00\x00\x00\x69\x00\x00\x00\x6b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfd\x13\x00\x00\x09\x01\x00\x00\x00\x00\x00\x00\x1b\x01\x00\x00\x6a\x00\x00\x00\x90\x00\x00\x00\x92\x00\x00\x00\x93\x00\x00\x00\x95\x00\x00\x00\x96\x00\x00\x00\x98\x00\x00\x00\x99\x00\x00\x00\x74\x14\x00\x00\x9c\x14\x00\x00\x85\x00\x00\x00\xdf\x14\x00\x00\x07\x15\x00\x00\x4a\x15\x00\x00\x72\x15\x00\x00\xba\x00\x00\x00\xf7\x01\x00\x00\x8b\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x00\x00\x05\x09\x00\x00\x5d\x00\x00\x00\x56\x00\x00\x00\xcc\x00\x00\x00\x7f\x09\x00\x00\x84\x15\x00\x00\xb9\x05\x00\x00\xf9\x09\x00\x00\x73\x0a\x00\x00\xa1\x15\x00\x00\x39\x06\x00\x00\xed\x0a\x00\x00\x00\x00\x00\x00\xca\x00\x00\x00\x75\x00\x00\x00\x74\x00\x00\x00\x71\x00\x00\x00\x7f\x00\x00\x00\x70\x00\x00\x00\xde\x15\x00\x00\x00\x00\x00\x00\xdc\x00\x00\x00\x00\x00\x00\x00\xdd\x00\x00\x00\xcb\x00\x00\x00\x58\x01\x00\x00\xbe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x16\x00\x00\xd6\x16\x00\x00\xef\x02\x00\x00\x50\x17\x00\x00\xca\x17\x00\x00\x44\x18\x00\x00\xbe\x18\x00\x00\x38\x19\x00\x00\xb2\x19\x00\x00\x2c\x1a\x00\x00\xa6\x1a\x00\x00\x24\x1b\x00\x00\x8d\x01\x00\x00\x9e\x1b\x00\x00\xa1\x0b\x00\x00\xbe\x1b\x00\x00\xe5\x00\x00\x00\xe6\x00\x00\x00\x18\x02\x00\x00\xea\x00\x00\x00\xff\x00\x00\x00\x38\x1c\x00\x00\xb6\x1c\x00\x00\x91\x02\x00\x00\x30\x1d\x00\x00\x1b\x0c\x00\x00\x00\x00\x00\x00\xc6\x00\x00\x00\x7d\x00\x00\x00\xcf\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\xd3\x00\x00\x00\x3a\x1d\x00\x00\xb9\x0c\x00\x00\x97\x0c\x00\x00\x54\x1d\x00\x00\xa3\x1d\x00\x00\x1d\x1e\x00\x00\x00\x00\x00\x00\x81\x00\x00\x00\xe0\x00\x00\x00\x57\x1e\x00\x00\xb1\x1e\x00\x00\x2d\x1f\x00\x00\x87\x1f\x00\x00\xc7\x1f\x00\x00\x84\x04\x00\x00\xed\x00\x00\x00\x41\x20\x00\x00\x00\x00\x00\x00\x8e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9b\x20\x00\x00"#++alex_table :: AlexAddr+alex_table = AlexA#+  "\x00\x00\x0e\x00\x43\x00\xca\x00\x91\x00\x4e\x00\x8f\x00\x1a\x00\x45\x00\x46\x00\x90\x00\xc5\x00\x8f\x00\x8f\x00\x8f\x00\x47\x00\xc3\x00\x48\x00\x49\x00\x4a\x00\x4c\x00\x4a\x00\x4d\x00\x66\x00\x66\x00\x66\x00\x66\x00\x66\x00\x66\x00\x66\x00\x66\x00\x66\x00\x66\x00\x8f\x00\x4e\x00\x8d\x00\x22\x00\x4e\x00\x4e\x00\x4e\x00\x8c\x00\x20\x00\x25\x00\x4e\x00\x4e\x00\x28\x00\x4f\x00\x4e\x00\x4e\x00\x53\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x52\x00\x29\x00\x4e\x00\x4e\x00\x4e\x00\xea\x00\x4e\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\xf1\x00\x4e\x00\x27\x00\x4e\x00\x40\x00\x2a\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xf6\x00\x1c\x00\x2c\x00\x4e\x00\x8f\x00\x56\x00\x56\x00\x84\x00\x90\x00\xa4\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x21\x00\x85\x00\x86\x00\x90\x00\x87\x00\x8f\x00\x8f\x00\x8f\x00\xf8\x00\x5e\x00\x5e\x00\x89\x00\x8b\x00\xc8\x00\xf8\x00\x7d\x00\xff\xff\xc0\x00\xff\xff\xff\xff\xaa\x00\xff\xff\xff\xff\x81\x00\xff\xff\xff\xff\x8f\x00\x8f\x00\x56\x00\x56\x00\x9c\x00\x90\x00\xc2\x00\x8f\x00\x8f\x00\x8f\x00\x5e\x00\x5e\x00\x55\x00\x9c\x00\x9b\x00\xd5\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xa5\x00\xa8\x00\x8f\x00\x8f\x00\x5d\x00\x44\x00\xff\xff\x90\x00\xc2\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\xa6\x00\xf8\x00\x9c\x00\x90\x00\xc2\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\xb3\x00\x55\x00\xb4\x00\x90\x00\xb6\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x5d\x00\x98\x00\x44\x00\xb7\x00\xb5\x00\xb8\x00\x1b\x00\x98\x00\x8f\x00\xbb\x00\xbd\x00\x44\x00\x9c\x00\xf8\x00\xc8\x00\xbe\x00\xbc\x00\x8f\x00\xff\xff\xff\xff\x8f\x00\x9c\x00\x9b\x00\xff\xff\x90\x00\x92\x00\x8f\x00\x8f\x00\x8f\x00\xe0\x00\x9c\x00\xe2\x00\xe4\x00\xed\x00\x92\x00\xe5\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\xff\xff\xfa\x00\xd8\x00\x8f\x00\xee\x00\x8f\x00\xd7\x00\xff\xff\xd8\x00\xd8\x00\xd8\x00\x8f\x00\x8f\x00\x8f\x00\x9e\x00\x98\x00\x9c\x00\xf5\x00\xc1\x00\xd3\x00\xd3\x00\xd3\x00\xd3\x00\xd3\x00\xd3\x00\xd3\x00\xd3\x00\xd3\x00\xd3\x00\xd8\x00\x8f\x00\x00\x00\x8f\x00\x00\x00\x90\x00\x93\x00\x8f\x00\x8f\x00\x8f\x00\x57\x00\x00\x00\x00\x00\xd9\x00\x00\x00\x00\x00\x98\x00\xc1\x00\xa9\x00\x00\x00\x00\x00\x15\x00\xb9\x00\x00\x00\xf7\x00\xf8\x00\xc1\x00\xc4\x00\x8f\x00\xe0\x00\x8f\x00\xf8\x00\x00\x00\x00\x00\x90\x00\x92\x00\x8f\x00\x8f\x00\x8f\x00\x00\x00\x00\x00\x9c\x00\x00\x00\x00\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\x00\x00\x8f\x00\x00\x00\x8f\x00\x7c\x00\x00\x00\xe3\x00\x8f\x00\x8f\x00\x8f\x00\x00\x00\x92\x00\x00\x00\x00\x00\x00\x00\xb1\x00\xe1\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x00\x00\x8f\x00\xf8\x00\x00\x00\xbf\x00\x42\x00\x41\x00\x00\x00\x55\x00\x8f\x00\xda\x00\x63\x00\x00\x00\x90\x00\xc5\x00\x8f\x00\x8f\x00\x8f\x00\x00\x00\x00\x00\x00\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd2\x00\x00\x00\x00\x00\x59\x00\x00\x00\xf8\x00\xd2\x00\xd2\x00\xd2\x00\x8f\x00\xaf\x00\x92\x00\xef\x00\x55\x00\x00\x00\x00\x00\x63\x00\x24\x00\x25\x00\x00\x00\x00\x00\x28\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x57\x00\xd2\x00\x00\x00\xd1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x29\x00\x00\x00\x00\x00\x00\x00\x92\x00\x00\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x26\x00\x00\x00\x27\x00\x00\x00\x41\x00\x2a\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x2b\x00\x7e\x00\x2c\x00\x16\x00\x16\x00\x16\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\xff\xff\x00\x00\x00\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\x65\x00\x00\x00\x65\x00\x00\x00\x00\x00\x66\x00\x66\x00\x66\x00\x66\x00\x66\x00\x66\x00\x66\x00\x66\x00\x66\x00\x66\x00\x97\x00\x00\x00\xd8\x00\x00\x00\x16\x00\x00\x00\x97\x00\xff\xff\xd8\x00\xd8\x00\xd8\x00\x00\x00\x00\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x00\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd8\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x00\x00\x00\x00\x97\x00\x00\x00\x16\x00\x00\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x97\x00\x10\x00\x16\x00\x16\x00\x16\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x00\x00\x00\x00\x60\x00\x60\x00\x60\x00\x60\x00\x60\x00\x60\x00\x60\x00\x60\x00\x6c\x00\x00\x00\x6c\x00\x00\x00\x00\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\xdd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\xdd\x00\xdd\x00\xdd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x5f\x00\x00\x00\x00\x00\xdd\x00\x00\x00\xdc\x00\x00\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x82\x00\x12\x00\x16\x00\x16\x00\x16\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x00\x60\x00\x60\x00\x60\x00\x60\x00\x60\x00\x60\x00\x60\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x00\x00\x15\x00\x00\x00\x00\x00\xc7\x00\xf8\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\xf8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x00\x00\x5f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x00\x00\x00\x00\xf8\x00\x00\x00\x16\x00\x00\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\xf8\x00\x14\x00\x16\x00\x16\x00\x16\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x00\x00\x00\x00\x66\x00\x66\x00\x66\x00\x66\x00\x66\x00\x66\x00\x66\x00\x66\x00\x66\x00\x66\x00\x72\x00\x00\x00\x72\x00\x00\x00\x00\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x88\x00\x17\x00\x18\x00\x18\x00\x18\x00\x00\x00\x00\x00\x00\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x66\x00\x66\x00\x66\x00\x66\x00\x66\x00\x66\x00\x66\x00\x66\x00\x66\x00\x66\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\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\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x18\x00\x00\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x4e\x00\x19\x00\x4e\x00\x4e\x00\x4e\x00\x4e\x00\x00\x00\x00\x00\x1d\x00\x4e\x00\x4e\x00\x00\x00\x4e\x00\x4e\x00\x4e\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\x4e\x00\x4e\x00\x4e\x00\x4e\x00\x4e\x00\x1e\x00\x1e\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4e\x00\xfb\x00\x4e\x00\x00\x00\x67\x00\x00\x00\x15\x00\x00\x00\x00\x00\xf4\x00\xf8\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf8\x00\x00\x00\x00\x00\x00\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x68\x00\x00\x00\xfc\x00\x00\x00\x4e\x00\x00\x00\x67\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1e\x00\xf8\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1f\x00\x1f\x00\x1f\x00\xf8\x00\x00\x00\x00\x00\x1f\x00\x00\x00\x00\x00\x00\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x79\x00\x00\x00\x79\x00\x00\x00\x00\x00\x7b\x00\x7b\x00\x7b\x00\x7b\x00\x7b\x00\x7b\x00\x7b\x00\x7b\x00\x7b\x00\x7b\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x69\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x00\x00\x1f\x00\x00\x00\x4e\x00\x1f\x00\x00\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x4e\x00\x00\x00\x4e\x00\x4e\x00\x4e\x00\x4e\x00\x00\x00\x00\x00\x23\x00\x4e\x00\x4e\x00\x00\x00\xf3\x00\x4e\x00\x4e\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\x4e\x00\x4e\x00\x4e\x00\x4e\x00\x4e\x00\x7b\x00\x7b\x00\x7b\x00\x7b\x00\x7b\x00\x7b\x00\x7b\x00\x7b\x00\x7b\x00\x7b\x00\x00\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x00\x00\x4e\x00\x1f\x00\x00\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x6b\x00\x4e\x00\x00\x00\x4e\x00\x35\x00\x35\x00\x35\x00\x00\x00\x00\x00\x00\x00\x35\x00\x00\x00\xad\x00\x00\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\xac\x00\xac\x00\xac\x00\xac\x00\xac\x00\xac\x00\xac\x00\xac\x00\xac\x00\xac\x00\x00\x00\x67\x00\x00\x00\x00\x00\x48\x00\x00\x00\x00\x00\x00\x00\x35\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x68\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x67\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x00\x00\x00\x00\x00\x00\x00\x00\x35\x00\x00\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x38\x00\x38\x00\x38\x00\x8a\x00\x00\x00\x00\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\x00\x00\x00\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x00\x00\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x35\x00\x35\x00\x35\x00\x00\x00\x00\x00\x00\x00\x35\x00\x00\x00\x73\x00\x73\x00\x73\x00\x73\x00\x73\x00\x73\x00\x73\x00\x73\x00\x73\x00\x73\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x73\x00\x73\x00\x73\x00\x73\x00\x73\x00\x73\x00\x00\x00\x00\x00\x00\x00\x48\x00\x00\x00\x00\x00\x00\x00\x35\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x73\x00\x73\x00\x73\x00\x73\x00\x73\x00\x73\x00\x00\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x00\x00\x00\x00\x00\x00\x00\x00\x35\x00\x00\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x30\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x00\x00\x00\x00\x00\x00\x35\x00\x00\x00\x00\x00\x00\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\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\x48\x00\x00\x00\x00\x00\x00\x00\x35\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x00\x00\x00\x00\x00\x00\x00\x00\x35\x00\x00\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x38\x00\x38\x00\x38\x00\x00\x00\x00\x00\x00\x00\x38\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\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\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x00\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x00\x00\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x32\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x00\x00\x00\x00\x00\x00\x38\x00\x00\x00\x00\x00\x00\x00\x7b\x00\x7b\x00\x7b\x00\x7b\x00\x7b\x00\x7b\x00\x7b\x00\x7b\x00\x7b\x00\x7b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x00\x00\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x35\x00\x35\x00\x35\x00\x00\x00\x00\x00\x00\x00\x35\x00\x00\x00\x00\x00\x00\x00\x7b\x00\x7b\x00\x7b\x00\x7b\x00\x7b\x00\x7b\x00\x7b\x00\x7b\x00\x7b\x00\x7b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x48\x00\x00\x00\x00\x00\x00\x00\x35\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x00\x00\x00\x00\x00\x00\x00\x00\x35\x00\x00\x00\x35\x00\x35\x00\x35\x00\x2f\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x00\x00\x00\x00\x00\x00\x35\x00\x00\x00\x00\x00\x00\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\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\x48\x00\x00\x00\x00\x00\x00\x00\x35\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x00\x00\x00\x00\x00\x00\x00\x00\x35\x00\x00\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x2d\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x00\x00\x00\x00\x00\x00\x35\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\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\x48\x00\x00\x00\x00\x00\x00\x00\x35\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x67\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x00\x00\x00\x00\x00\x00\x00\x00\x35\x00\x00\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x38\x00\x38\x00\x38\x00\x00\x00\x00\x00\x00\x00\x38\x00\x00\x00\x00\x00\x00\x00\xac\x00\xac\x00\xac\x00\xac\x00\xac\x00\xac\x00\xac\x00\xac\x00\xac\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\x67\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\xae\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x67\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x00\x00\x00\x38\x00\x38\x00\x38\x00\x31\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x00\x00\x00\x00\x00\x00\x38\x00\x00\x00\x00\x00\x00\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\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\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\xaf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x63\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x00\x00\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x2e\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x00\x00\x00\x00\x00\x00\x38\x00\x00\x00\x00\x00\x00\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\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\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\xb2\x00\x3a\x00\x38\x00\x00\x00\x00\x00\x00\x00\x63\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x00\x00\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x00\x00\x00\x38\x00\x38\x00\x38\x00\x37\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x36\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x3a\x00\x3a\x00\x3a\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x00\x00\x00\x00\xd3\x00\xd3\x00\xd3\x00\xd3\x00\xd3\x00\xd3\x00\xd3\x00\xd3\x00\xd3\x00\xd3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x39\x00\x00\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\xd4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3b\x00\x3b\x00\x3b\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x00\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xba\x00\x00\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\xdf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x00\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\xca\x00\xca\x00\xca\x00\xe8\x00\x00\x00\x00\x00\xca\x00\x00\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe8\x00\x00\x00\x00\x00\xe6\x00\x4a\x00\x00\x00\x00\x00\x00\x00\xca\x00\x00\x00\x00\x00\x00\x00\x65\x00\x00\x00\x65\x00\x00\x00\x00\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x00\x00\x00\x00\xe9\x00\x00\x00\x00\x00\x00\x00\x00\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\x00\x00\x00\x00\x00\x00\x00\x00\xca\x00\x00\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\x00\x00\x00\x00\x00\x00\xca\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x00\x00\x00\x00\x00\x00\xca\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x00\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xca\x00\xca\x00\xca\x00\xca\x00\x3c\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc9\x00\x00\x00\xca\x00\xca\x00\xca\x00\xca\x00\x3c\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\x00\x00\x00\x00\x00\x00\xca\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x00\x00\x00\x00\x00\x00\xca\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3e\x00\x00\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\x00\x00\x00\x00\x00\x00\xca\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x00\x00\x00\x00\x00\x00\xca\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3e\x00\x00\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\x00\x00\x00\x00\x00\x00\xca\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x00\x00\x00\x00\x00\x00\xca\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\x41\x00\x41\x00\x41\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x42\x00\x42\x00\x42\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x39\x00\x00\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x43\x00\x43\x00\x43\x00\x00\x00\x00\x00\x00\x00\x43\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x43\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xba\x00\x00\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x43\x00\x00\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x4e\x00\x00\x00\x4e\x00\x4e\x00\x4e\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x4e\x00\x00\x00\x4e\x00\x4e\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x4e\x00\x7c\x00\x4e\x00\x4e\x00\x4e\x00\x4e\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x00\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x00\x00\x4e\x00\x4e\x00\x4e\x00\x4e\x00\x4e\x00\x63\x00\x4e\x00\x4e\x00\x4e\x00\x00\x00\xa0\x00\x4e\x00\x4e\x00\x5b\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x4e\x00\x00\x00\x4e\x00\x4e\x00\x4e\x00\x4e\x00\x4e\x00\x00\x00\xaf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x63\x00\x4e\x00\x50\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x4e\x00\x69\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x50\x00\x00\x00\x50\x00\x50\x00\x50\x00\x50\x00\x51\x00\x00\x00\x00\x00\x50\x00\x50\x00\x00\x00\x50\x00\x50\x00\x50\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x00\x00\x4e\x00\x00\x00\x50\x00\x00\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x00\x00\x00\x00\x00\x00\x51\x00\x00\x00\x51\x00\x51\x00\x51\x00\x51\x00\x52\x00\x00\x00\x00\x00\x51\x00\x51\x00\x00\x00\x51\x00\x51\x00\x51\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x50\x00\x51\x00\x50\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x00\x00\x00\x00\x00\x00\x52\x00\x00\x00\x52\x00\x52\x00\x52\x00\x52\x00\x00\x00\x00\x00\x00\x00\x52\x00\x52\x00\x00\x00\x52\x00\x52\x00\x52\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x50\x00\x00\x00\x50\x00\x51\x00\x52\x00\x51\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x00\x00\x51\x00\x00\x00\x51\x00\x52\x00\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\x59\x00\x00\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x7f\x00\x00\x00\x00\x00\x00\x00\x52\x00\x00\x00\x52\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6f\x00\x00\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x00\x00\x00\x00\xad\x00\x00\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x71\x00\x00\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5d\x00\x00\x00\x00\x00\x67\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xab\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x67\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xad\x00\x61\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x62\x00\x62\x00\x62\x00\x62\x00\x62\x00\x62\x00\x62\x00\x62\x00\x62\x00\x62\x00\x00\x00\x67\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x62\x00\x62\x00\x62\x00\x62\x00\x62\x00\x62\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x67\x00\x83\x00\x00\x00\x00\x00\x61\x00\x00\x00\x62\x00\x62\x00\x62\x00\x62\x00\x62\x00\x62\x00\x76\x00\x00\x00\x62\x00\x62\x00\x62\x00\x62\x00\x62\x00\x62\x00\x62\x00\x62\x00\x62\x00\x62\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x62\x00\x62\x00\x62\x00\x62\x00\x62\x00\x62\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x77\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x78\x00\x00\x00\x62\x00\x62\x00\x62\x00\x62\x00\x62\x00\x62\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x77\x00\x73\x00\x73\x00\x73\x00\x73\x00\x73\x00\x73\x00\x73\x00\x73\x00\x73\x00\x73\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x73\x00\x73\x00\x73\x00\x73\x00\x73\x00\x73\x00\x00\x00\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\x6e\x00\x00\x00\x73\x00\x73\x00\x73\x00\x73\x00\x73\x00\x73\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x00\x00\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\x71\x00\x00\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x73\x00\x73\x00\x73\x00\x73\x00\x73\x00\x73\x00\x73\x00\x73\x00\x73\x00\x73\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x73\x00\x73\x00\x73\x00\x73\x00\x73\x00\x73\x00\x00\x00\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\x6e\x00\x00\x00\x73\x00\x73\x00\x73\x00\x73\x00\x73\x00\x73\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\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\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\x77\x00\x00\x00\x00\x00\x00\x00\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\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\x77\x00\x62\x00\x62\x00\x62\x00\x62\x00\x62\x00\x62\x00\x62\x00\x62\x00\x62\x00\x62\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x62\x00\x62\x00\x62\x00\x62\x00\x62\x00\x62\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x77\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x78\x00\x00\x00\x62\x00\x62\x00\x62\x00\x62\x00\x62\x00\x62\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x77\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\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x16\x00\x16\x00\x16\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x00\x00\x77\x00\x00\x00\x00\x00\x00\x00\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\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x00\x00\x77\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\xff\xff\x0d\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\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\x9a\x00\xff\xff\xff\xff\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\x00\x00\x9a\x00\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd6\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\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd6\x00\x00\x00\xd6\x00\xd6\x00\xd6\x00\xd6\x00\x00\x00\x00\x00\x00\x00\xd6\x00\xd6\x00\xd6\x00\x9d\x00\xd6\x00\xd6\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xd6\x00\xff\xff\xd6\x00\xd6\x00\xd6\x00\xd6\x00\xd6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xd6\x00\x00\x00\xd6\x00\xd6\x00\xd6\x00\xd6\x00\x00\x00\x00\x00\x00\x00\xd6\x00\xd6\x00\x00\x00\x9d\x00\xd6\x00\xd6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd6\x00\x00\x00\xd6\x00\x00\x00\x00\x00\x00\x00\xd6\x00\x00\x00\xd6\x00\xd6\x00\xd6\x00\xd6\x00\xd6\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\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd6\x00\x00\x00\xd6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd6\x00\x00\x00\xd6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x00\x00\x4e\x00\x4e\x00\x4e\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x4e\x00\x4e\x00\x9f\x00\x4e\x00\x4e\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd6\x00\x4e\x00\xd6\x00\x4e\x00\x4e\x00\x4e\x00\x4e\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x4e\x00\x00\x00\x4e\x00\x4e\x00\x4e\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x4e\x00\x00\x00\x9f\x00\x4e\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x8a\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x00\x00\x4e\x00\x4e\x00\x4e\x00\x4e\x00\x4e\x00\x00\x00\xac\x00\xac\x00\xac\x00\xac\x00\xac\x00\xac\x00\xac\x00\xac\x00\xac\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x00\x00\x4e\x00\x00\x00\x4e\x00\x67\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x00\x00\x4e\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x35\x00\x00\x00\x50\x00\xae\x00\x00\x00\x00\x00\x63\x00\x00\x00\x00\x00\x67\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4e\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\x50\x00\xb2\x00\x50\x00\x50\x00\x50\x00\x50\x00\x00\x00\x63\x00\x00\x00\x50\x00\x50\x00\x00\x00\x50\x00\x50\x00\x50\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x51\x00\x00\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x00\x00\x50\x00\x00\x00\x50\x00\x35\x00\x00\x00\x35\x00\x35\x00\x35\x00\x34\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x33\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x00\x00\x50\x00\x00\x00\x50\x00\xc6\x00\xc6\x00\xc6\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc6\x00\x00\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\x00\x00\xc7\x00\x00\x00\xc6\x00\x00\x00\x00\x00\xc7\x00\xc7\x00\xc7\x00\xc7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc6\x00\x00\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xca\x00\xca\x00\xca\x00\x00\x00\x00\x00\x00\x00\xca\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x00\x00\x00\x00\x00\x00\xca\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xca\x00\xca\x00\xca\x00\xca\x00\x3c\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc9\x00\x00\x00\xca\x00\xca\x00\xca\x00\xca\x00\x3c\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\x00\x00\x00\x00\x00\x00\xca\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x00\x00\x00\x00\x00\x00\xca\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\x00\x00\x00\x00\x00\x00\x00\x00\xca\x00\x00\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xcb\x00\xcb\x00\xcb\x00\x00\x00\x00\x00\x00\x00\xcb\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcb\x00\x00\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcc\x00\xcc\x00\xcc\x00\x00\x00\xec\x00\x00\x00\xcc\x00\x00\x00\x00\x00\xec\x00\xec\x00\xec\x00\xec\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcc\x00\x00\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\x00\x00\xcd\x00\x00\x00\xcc\x00\x00\x00\x00\x00\xcd\x00\xcd\x00\xcd\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\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\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcc\x00\x00\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xce\x00\xce\x00\xce\x00\x00\x00\xec\x00\x00\x00\xce\x00\x00\x00\x00\x00\xec\x00\xec\x00\xec\x00\xec\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\x00\x00\x00\x00\x00\x00\x00\x00\xce\x00\x00\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\x00\x00\xcf\x00\x00\x00\xce\x00\x00\x00\x00\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcf\x00\x00\x00\x00\x00\x00\x00\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\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\x00\x00\x00\x00\x00\x00\x00\x00\xce\x00\x00\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\x00\x00\xd1\x00\xd1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\xd1\x00\xd0\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\x00\x00\xd1\x00\xd1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\xd1\x00\xd0\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd2\x00\xd2\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\xd2\x00\xcb\x00\xcb\x00\xcb\x00\x00\x00\xd5\x00\x00\x00\xcb\x00\x00\x00\x00\x00\xc7\x00\xd5\x00\xd5\x00\xd5\x00\x00\x00\x00\x00\xd3\x00\xd3\x00\xd3\x00\xd3\x00\xd3\x00\xd3\x00\xd3\x00\xd3\x00\xd3\x00\xd3\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\x00\x00\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcb\x00\x00\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\x00\x00\xdc\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\xdc\x00\xdc\x00\xdb\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\x00\x00\xdc\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\xdc\x00\xdc\x00\xdb\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdd\x00\xdd\x00\xdd\x00\x00\x00\xe8\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1e\x00\x00\x00\x4e\x00\x00\x00\xe8\x00\x00\x00\x00\x00\xe6\x00\x00\x00\x00\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\x00\x00\x4e\x00\x00\x00\x4e\x00\x4e\x00\x4e\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x4e\x00\x00\x00\x4e\x00\x4e\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4e\x00\xdf\x00\x4e\x00\x4e\x00\x4e\x00\x4e\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xeb\x00\xeb\x00\xeb\x00\x00\x00\x00\x00\x00\x00\xeb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x00\x00\x4e\x00\x1e\x00\x00\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x00\x00\x4e\x00\x00\x00\x4e\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xeb\x00\x00\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\x00\x00\xec\x00\x00\x00\xeb\x00\x00\x00\x00\x00\xec\x00\xec\x00\xec\x00\xec\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\x00\x00\xf2\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xeb\x00\x00\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\x16\x00\x00\x00\x00\x00\x18\x00\x00\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\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\x00\x00\x00\x00\x00\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\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x16\x00\x16\x00\x16\x00\x11\x00\x8e\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x0f\x00\x16\x00\x16\x00\x16\x00\x13\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x00\x00\xf9\x00\xf2\x00\xf2\x00\xf2\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\xf0\x00\x00\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\x00\x00\x00\x00\x00\x00\x4e\x00\xf2\x00\x00\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\x4e\x00\x00\x00\x4e\x00\x4e\x00\x4e\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x4e\x00\x00\x00\x4e\x00\x4e\x00\x4e\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\x4e\x00\x4e\x00\x4e\x00\x4e\x00\x4e\x00\xce\x00\xce\x00\xce\x00\x00\x00\xcf\x00\x00\x00\xce\x00\x00\x00\x00\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\x00\x00\x00\x00\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\x4e\x00\x00\x00\xcf\x00\x00\x00\x00\x00\x00\x00\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\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\x00\x00\x00\x00\x4e\x00\xed\x00\x4e\x00\x00\x00\x00\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\x00\x00\x00\x00\x00\x00\x00\x00\xce\x00\x00\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xcc\x00\xcc\x00\xcc\x00\x00\x00\xcd\x00\x00\x00\xcc\x00\x00\x00\x00\x00\xcd\x00\xcd\x00\xcd\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\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\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\x00\x00\x00\x00\x00\x00\x4e\x00\xcc\x00\x00\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\x4e\x00\x00\x00\x4e\x00\x4e\x00\x4e\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x4e\x00\x00\x00\x4e\x00\x4e\x00\x4e\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\x4e\x00\x4e\x00\x4e\x00\x4e\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\x00\x00\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\x0c\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\x00\x00\x00\x00\x00\x00\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"#++alex_check :: AlexAddr+alex_check = AlexA#+  "\xff\xff\x7c\x00\x01\x00\x02\x00\x2d\x00\x04\x00\x05\x00\x06\x00\x6c\x00\x69\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x6e\x00\x65\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\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\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\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\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\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x05\x00\x30\x00\x31\x00\x23\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x05\x00\x23\x00\x23\x00\x23\x00\x09\x00\x23\x00\x0b\x00\x0c\x00\x0d\x00\x24\x00\x30\x00\x31\x00\x23\x00\x23\x00\x2d\x00\x2a\x00\x23\x00\x0a\x00\x20\x00\x0a\x00\x0a\x00\x23\x00\x0a\x00\x0a\x00\x23\x00\x0a\x00\x0a\x00\x20\x00\x05\x00\x30\x00\x31\x00\x2d\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x30\x00\x31\x00\x5f\x00\x2d\x00\x2d\x00\x23\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x65\x00\x69\x00\x20\x00\x05\x00\x5f\x00\x23\x00\x0a\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x05\x00\x6e\x00\x5e\x00\x2d\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x05\x00\x0a\x00\x5f\x00\x61\x00\x09\x00\x67\x00\x0b\x00\x0c\x00\x0d\x00\x20\x00\x5f\x00\x24\x00\x23\x00\x61\x00\x6d\x00\x72\x00\x7c\x00\x2a\x00\x20\x00\x0a\x00\x0a\x00\x23\x00\x2d\x00\x7c\x00\x2d\x00\x21\x00\x21\x00\x20\x00\x0a\x00\x0a\x00\x05\x00\x2d\x00\x2d\x00\x0a\x00\x09\x00\x7b\x00\x0b\x00\x0c\x00\x0d\x00\x7d\x00\x2d\x00\x2d\x00\x7d\x00\x7d\x00\x7b\x00\x2d\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x0a\x00\x7c\x00\x05\x00\x20\x00\x2d\x00\x05\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0b\x00\x0c\x00\x0d\x00\x2d\x00\x5e\x00\x2d\x00\x2d\x00\x7b\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x20\x00\x05\x00\xff\xff\x20\x00\xff\xff\x09\x00\x2d\x00\x0b\x00\x0c\x00\x0d\x00\x5f\x00\xff\xff\xff\xff\x2d\x00\xff\xff\xff\xff\x7c\x00\x7b\x00\x6c\x00\xff\xff\xff\xff\x20\x00\x70\x00\xff\xff\x23\x00\x24\x00\x7b\x00\x7c\x00\x20\x00\x7d\x00\x05\x00\x2a\x00\xff\xff\xff\xff\x09\x00\x7b\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\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\x05\x00\xff\xff\x20\x00\x23\x00\xff\xff\x23\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\x7b\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2d\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x20\x00\x5e\x00\xff\xff\x23\x00\x01\x00\x02\x00\xff\xff\x42\x00\x05\x00\x7b\x00\x45\x00\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x00\xff\xff\xff\xff\x58\x00\xff\xff\x7c\x00\x0b\x00\x0c\x00\x0d\x00\x20\x00\x5f\x00\x7b\x00\x23\x00\x62\x00\xff\xff\xff\xff\x65\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\x2d\x00\xff\xff\xff\xff\xff\xff\x6f\x00\x20\x00\xff\xff\x22\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x78\x00\x3b\x00\xff\xff\xff\xff\xff\xff\x7b\x00\xff\xff\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\x5b\x00\xff\xff\x5d\x00\xff\xff\x5f\x00\x60\x00\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\x7b\x00\x23\x00\x7d\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\x0a\x00\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\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\x24\x00\xff\xff\x05\x00\xff\xff\x27\x00\xff\xff\x2a\x00\x0a\x00\x0b\x00\x0c\x00\x0d\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\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x20\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\x5e\x00\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\x7c\x00\x7c\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\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\x05\x00\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\x0b\x00\x0c\x00\x0d\x00\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\x5f\x00\xff\xff\xff\xff\x20\x00\xff\xff\x22\x00\xff\xff\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\x23\x00\x7c\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\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\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\x2a\x00\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\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\x5e\x00\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\x7c\x00\x7c\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\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\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\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\x38\x00\x39\x00\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\x23\x00\x7c\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\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\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\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\x38\x00\x39\x00\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\x04\x00\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\x21\x00\x7c\x00\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\x29\x00\x2a\x00\x2b\x00\xff\xff\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\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\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\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\x5d\x00\x5e\x00\xff\xff\x45\x00\xff\xff\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2a\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\x5f\x00\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\x65\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\x5e\x00\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\x02\x00\x03\x00\x7c\x00\xff\xff\xff\xff\x07\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\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\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\x38\x00\x39\x00\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\x02\x00\xff\xff\x04\x00\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\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\x29\x00\x2a\x00\x2b\x00\xff\xff\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\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\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\x5c\x00\xff\xff\x5e\x00\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\x5f\x00\x7c\x00\xff\xff\x7e\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\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\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x45\x00\xff\xff\xff\xff\x23\x00\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\x38\x00\x39\x00\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\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\x01\x00\x02\x00\x03\x00\x23\x00\xff\xff\xff\xff\x07\x00\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\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\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\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\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\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\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\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\xff\xff\xff\xff\x23\x00\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\x38\x00\x39\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\xff\xff\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\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\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\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\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\x38\x00\x39\x00\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\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\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\xff\xff\xff\xff\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\x38\x00\x39\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\xff\xff\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\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\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\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\x38\x00\x39\x00\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\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\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\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\x38\x00\x39\x00\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\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\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\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\x38\x00\x39\x00\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\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\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\x23\x00\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\x38\x00\x39\x00\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\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\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\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\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\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\x38\x00\x39\x00\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\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\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\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\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\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\x38\x00\x39\x00\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\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\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\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\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\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\x38\x00\x39\x00\x5f\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\x65\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\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\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\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\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\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\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\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\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\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\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\x01\x00\x02\x00\x03\x00\x05\x00\xff\xff\xff\xff\x07\x00\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\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\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\x23\x00\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\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\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\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\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\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\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\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\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\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\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\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\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\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\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\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\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\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\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\x04\x00\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\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x04\x00\x3a\x00\x23\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\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\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x5c\x00\x45\x00\x5e\x00\x2a\x00\x2b\x00\xff\xff\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\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\x65\x00\x7e\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\x5c\x00\xff\xff\x5e\x00\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x04\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x04\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\x3a\x00\x5e\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\x5c\x00\x3a\x00\x5e\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\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\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\x7c\x00\xff\xff\x7e\x00\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x23\x00\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\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\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\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\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x42\x00\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\x4f\x00\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\x5f\x00\xff\xff\xff\xff\x62\x00\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\x6f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\x78\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\x23\x00\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\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\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\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\xff\xff\xff\xff\xff\xff\xff\xff\x5f\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\xff\xff\x70\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\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\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\xff\xff\xff\xff\xff\xff\xff\xff\x5f\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\xff\xff\x70\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\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\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\xff\xff\xff\xff\xff\xff\xff\xff\x5f\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\xff\xff\x70\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\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\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\xff\xff\xff\xff\xff\xff\xff\xff\x5f\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\xff\xff\x70\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\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\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\xff\xff\xff\xff\xff\xff\xff\xff\x5f\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\xff\xff\x70\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\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\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\xff\xff\xff\xff\xff\xff\xff\xff\x5f\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\xff\xff\x70\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\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\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\xff\xff\xff\xff\xff\xff\xff\xff\x5f\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\x27\x00\xff\xff\xff\xff\x70\x00\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\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\x04\x00\x7c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\x04\x00\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\x04\x00\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\x3a\x00\x7e\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\x04\x00\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\x3a\x00\x7e\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\x23\x00\x5e\x00\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\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\x23\x00\xff\xff\x7c\x00\xff\xff\x7e\x00\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\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\x01\x00\x02\x00\xff\xff\x04\x00\x5f\x00\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\x5f\x00\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\x65\x00\xff\xff\x2a\x00\x2b\x00\xff\xff\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\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\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\xff\xff\x5c\x00\xff\xff\x5e\x00\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\x7c\x00\xff\xff\x7e\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\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\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\x07\x00\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\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\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\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\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\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\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\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\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\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\x07\x00\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\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\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\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\x07\x00\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\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\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\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\x07\x00\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\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\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\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\x07\x00\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\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\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\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\x06\x00\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\x22\x00\x23\x00\x24\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\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\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\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\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\x06\x00\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\x22\x00\x23\x00\x24\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\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\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\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\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x05\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\x07\x00\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\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\x20\x00\xff\xff\xff\xff\xff\xff\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\x5f\x00\xff\xff\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\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\x06\x00\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\x22\x00\x23\x00\x24\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\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\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\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\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\x06\x00\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\x22\x00\x23\x00\x24\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\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\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\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\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x05\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0b\x00\x0c\x00\x0d\x00\xff\xff\x05\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\x04\x00\xff\xff\x20\x00\xff\xff\xff\xff\x23\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\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\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\x5f\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\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\x7c\x00\xff\xff\x7e\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\xff\xff\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\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\x07\x00\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\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\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\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\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\x02\x00\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\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\x7c\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\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\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\x04\x00\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\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\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\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\x07\x00\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\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\x7c\x00\x7d\x00\x7e\x00\xff\xff\xff\xff\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\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\x07\x00\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\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\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\x04\x00\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\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\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\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\x5d\x00\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"#++alex_deflt :: AlexAddr+alex_deflt = AlexA#+  "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd6\x00\x94\x00\x95\x00\x96\x00\x97\x00\x96\x00\x99\x00\x99\x00\x95\x00\xff\xff\x99\x00\x95\x00\x99\x00\x95\x00\x94\x00\x94\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xb4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbc\x00\xff\xff\xbe\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd6\x00\xd6\x00\xd6\x00\xd6\x00\xd6\x00\xd6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"#++alex_accept = listArray (0 :: Int, 252)+  [ AlexAccNone+  , AlexAcc 209+  , AlexAccNone+  , AlexAcc 208+  , AlexAcc 207+  , AlexAcc 206+  , AlexAcc 205+  , AlexAcc 204+  , AlexAcc 203+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAcc 202+  , AlexAccPred 201 (ifExtension ThQuotesBit)(AlexAccPred 200 (ifExtension QqBit)(AlexAccNone))+  , AlexAccPred 199 (ifExtension ThQuotesBit)(AlexAccNone)+  , AlexAccNone+  , AlexAccPred 198 (ifExtension ThQuotesBit)(AlexAccPred 197 (ifExtension QqBit)(AlexAccNone))+  , AlexAccNone+  , AlexAccPred 196 (ifExtension ThQuotesBit)(AlexAccPred 195 (ifExtension QqBit)(AlexAccNone))+  , AlexAccNone+  , AlexAccPred 194 (ifExtension ThQuotesBit)(AlexAccPred 193 (ifExtension QqBit)(AlexAccNone))+  , AlexAccNone+  , AlexAccNone+  , AlexAccPred 192 (ifExtension QqBit)(AlexAccNone)+  , AlexAccNone+  , AlexAccPred 191 (ifExtension QqBit)(AlexAccNone)+  , AlexAccPred 190 (ifCurrentChar '⟦' `alexAndPred`+        ifExtension UnicodeSyntaxBit `alexAndPred`+        ifExtension ThQuotesBit)(AlexAccPred 189 (ifCurrentChar '⟧' `alexAndPred`+        ifExtension UnicodeSyntaxBit `alexAndPred`+        ifExtension ThQuotesBit)(AlexAccPred 188 (ifCurrentChar '⦇' `alexAndPred`+        ifExtension UnicodeSyntaxBit `alexAndPred`+        ifExtension ArrowsBit)(AlexAccPred 187 (ifCurrentChar '⦈' `alexAndPred`+        ifExtension UnicodeSyntaxBit `alexAndPred`+        ifExtension ArrowsBit)(AlexAccNone))))+  , AlexAccPred 186 (ifExtension ArrowsBit `alexAndPred`+        notFollowedBySymbol)(AlexAccNone)+  , AlexAccPred 185 (precededByClosingToken `alexAndPred` followedByOpeningToken)(AlexAccPred 184 (followedByOpeningToken)(AlexAccPred 183 (precededByClosingToken)(AlexAcc 182)))+  , AlexAccPred 181 (ifExtension ArrowsBit)(AlexAccNone)+  , AlexAccPred 180 (ifExtension IpBit)(AlexAccNone)+  , AlexAccPred 179 (ifExtension OverloadedLabelsBit)(AlexAccNone)+  , AlexAcc 178+  , AlexAccPred 177 (ifExtension UnboxedParensBit)(AlexAccNone)+  , AlexAccPred 176 (precededByClosingToken `alexAndPred` followedByOpeningToken)(AlexAccPred 175 (followedByOpeningToken)(AlexAccPred 174 (precededByClosingToken)(AlexAcc 173)))+  , AlexAccPred 172 (ifExtension UnboxedParensBit)(AlexAccNone)+  , AlexAcc 171+  , AlexAcc 170+  , AlexAcc 169+  , AlexAcc 168+  , AlexAcc 167+  , AlexAcc 166+  , AlexAcc 165+  , AlexAcc 164+  , AlexAcc 163+  , AlexAcc 162+  , AlexAcc 161+  , AlexAcc 160+  , AlexAccPred 159 (ifExtension RecursiveDoBit)(AlexAcc 158)+  , AlexAcc 157+  , AlexAccPred 156 (ifExtension RecursiveDoBit)(AlexAcc 155)+  , AlexAcc 154+  , AlexAcc 153+  , AlexAcc 152+  , AlexAcc 151+  , AlexAcc 150+  , AlexAcc 149+  , AlexAccNone+  , AlexAcc 148+  , AlexAcc 147+  , AlexAcc 146+  , AlexAcc 145+  , AlexAcc 144+  , AlexAcc 143+  , AlexAcc 142+  , AlexAcc 141+  , AlexAcc 140+  , AlexAcc 139+  , AlexAccPred 138 (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAccNone)+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAccPred 137 (ifExtension MagicHashBit)(AlexAccNone)+  , AlexAccPred 136 (ifExtension MagicHashBit)(AlexAccNone)+  , AlexAccPred 135 (ifExtension MagicHashBit)(AlexAccNone)+  , AlexAccPred 134 (ifExtension MagicHashBit)(AlexAccPred 133 (ifExtension MagicHashBit)(AlexAccNone))+  , AlexAccPred 132 (ifExtension MagicHashBit)(AlexAccPred 131 (ifExtension MagicHashBit)(AlexAccNone))+  , AlexAccPred 130 (ifExtension MagicHashBit)(AlexAccNone)+  , AlexAccPred 129 (precededByClosingToken `alexAndPred` followedByOpeningToken)(AlexAccPred 128 (followedByOpeningToken)(AlexAccPred 127 (precededByClosingToken)(AlexAcc 126)))+  , AlexAccPred 125 (precededByClosingToken `alexAndPred` followedByOpeningToken)(AlexAccPred 124 (followedByOpeningToken)(AlexAccPred 123 (precededByClosingToken)(AlexAcc 122)))+  , AlexAcc 121+  , AlexAcc 120+  , AlexAcc 119+  , AlexAcc 118+  , AlexAcc 117+  , AlexAccNone+  , AlexAccPred 116 (ifExtension BinaryLiteralsBit)(AlexAccNone)+  , AlexAccNone+  , AlexAcc 115+  , AlexAccNone+  , AlexAcc 114+  , AlexAccPred 113 (negLitPred)(AlexAccNone)+  , AlexAccPred 112 (negLitPred)(AlexAccNone)+  , AlexAccNone+  , AlexAccPred 111 (negLitPred `alexAndPred`+                                           ifExtension BinaryLiteralsBit)(AlexAccNone)+  , AlexAccNone+  , AlexAccPred 110 (negLitPred)(AlexAccNone)+  , AlexAccNone+  , AlexAccPred 109 (negLitPred)(AlexAccNone)+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAcc 108+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAccPred 107 (negLitPred)(AlexAccNone)+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAccPred 106 (ifExtension HexFloatLiteralsBit)(AlexAccNone)+  , AlexAccPred 105 (ifExtension HexFloatLiteralsBit)(AlexAccNone)+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAccPred 104 (ifExtension HexFloatLiteralsBit `alexAndPred`+                                           negLitPred)(AlexAccNone)+  , AlexAccPred 103 (ifExtension HexFloatLiteralsBit `alexAndPred`+                                           negLitPred)(AlexAccNone)+  , AlexAccPred 102 (ifExtension MagicHashBit)(AlexAccNone)+  , AlexAccPred 101 (ifExtension MagicHashBit `alexAndPred`+                                           ifExtension BinaryLiteralsBit)(AlexAccNone)+  , AlexAccPred 100 (ifExtension MagicHashBit)(AlexAccNone)+  , AlexAccPred 99 (ifExtension MagicHashBit)(AlexAccNone)+  , AlexAccPred 98 (negHashLitPred)(AlexAccNone)+  , AlexAccPred 97 (negHashLitPred `alexAndPred`+                                           ifExtension BinaryLiteralsBit)(AlexAccNone)+  , AlexAccPred 96 (negHashLitPred)(AlexAccNone)+  , AlexAccPred 95 (negHashLitPred)(AlexAccNone)+  , AlexAccPred 94 (ifExtension MagicHashBit)(AlexAccNone)+  , AlexAccPred 93 (ifExtension MagicHashBit `alexAndPred`+                                           ifExtension BinaryLiteralsBit)(AlexAccNone)+  , AlexAccPred 92 (ifExtension MagicHashBit)(AlexAccNone)+  , AlexAccPred 91 (ifExtension MagicHashBit)(AlexAccNone)+  , AlexAccPred 90 (ifExtension MagicHashBit)(AlexAccNone)+  , AlexAccPred 89 (ifExtension MagicHashBit)(AlexAccNone)+  , AlexAccPred 88 (negHashLitPred)(AlexAccNone)+  , AlexAccPred 87 (negHashLitPred)(AlexAccNone)+  , AlexAcc 86+  , AlexAcc 85+  , AlexAccNone+  , AlexAccSkip+  , AlexAcc 84+  , AlexAccPred 83 (isNormalComment)(AlexAccNone)+  , AlexAccNone+  , AlexAccPred 82 (isNormalComment)(AlexAcc 81)+  , AlexAcc 80+  , AlexAcc 79+  , AlexAccPred 78 (alexNotPred (ifExtension HaddockBit))(AlexAccNone)+  , AlexAccPred 77 (alexNotPred (ifExtension HaddockBit))(AlexAcc 76)+  , AlexAccPred 75 (alexNotPred (ifExtension HaddockBit))(AlexAccPred 74 (ifExtension HaddockBit)(AlexAccNone))+  , AlexAcc 73+  , AlexAccPred 72 (atEOL)(AlexAccNone)+  , AlexAccPred 71 (atEOL)(AlexAccNone)+  , AlexAccNone+  , AlexAccPred 70 (atEOL)(AlexAcc 69)+  , AlexAccPred 68 (atEOL)(AlexAcc 67)+  , AlexAccPred 66 (atEOL)(AlexAccPred 65 (precededByClosingToken `alexAndPred` followedByOpeningToken)(AlexAccPred 64 (followedByOpeningToken)(AlexAccPred 63 (precededByClosingToken)(AlexAcc 62))))+  , AlexAccPred 61 (atEOL)(AlexAccPred 60 (precededByClosingToken `alexAndPred` followedByOpeningToken)(AlexAccPred 59 (followedByOpeningToken)(AlexAccPred 58 (precededByClosingToken)(AlexAcc 57))))+  , AlexAccPred 56 (atEOL)(AlexAccNone)+  , AlexAccPred 55 (atEOL)(AlexAcc 54)+  , AlexAccNone+  , AlexAccSkip+  , AlexAccPred 53 (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAccNone)+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAccPred 52 (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False) `alexAndPred` followedByDigit)(AlexAccNone)+  , AlexAccNone+  , AlexAccPred 51 (negLitPred)(AlexAccNone)+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAcc 50+  , AlexAccNone+  , AlexAccNone+  , AlexAccSkipPred (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAccNone)+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAccSkipPred (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAccNone)+  , AlexAccNone+  , AlexAccSkipPred (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAccNone)+  , AlexAccNone+  , AlexAccNone+  , AlexAccSkip+  , AlexAccPred 49 (notFollowedBy '-')(AlexAccNone)+  , AlexAccSkip+  , AlexAccPred 48 (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAccNone)+  , AlexAccPred 47 (notFollowedBySymbol)(AlexAccNone)+  , AlexAcc 46+  , AlexAccPred 45 (known_pragma linePrags)(AlexAccNone)+  , AlexAccNone+  , AlexAccPred 44 (isNormalComment)(AlexAccNone)+  , AlexAcc 43+  , AlexAcc 42+  , AlexAccPred 41 (known_pragma linePrags)(AlexAcc 40)+  , AlexAccPred 39 (known_pragma linePrags)(AlexAccPred 38 (known_pragma oneWordPrags)(AlexAccPred 37 (known_pragma ignoredPrags)(AlexAccPred 36 (known_pragma fileHeaderPrags)(AlexAccNone))))+  , AlexAccNone+  , AlexAccPred 35 (known_pragma linePrags)(AlexAccPred 34 (known_pragma oneWordPrags)(AlexAccPred 33 (known_pragma ignoredPrags)(AlexAccPred 32 (known_pragma fileHeaderPrags)(AlexAccNone))))+  , AlexAccNone+  , AlexAcc 31+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAcc 30+  , AlexAcc 29+  , AlexAcc 28+  , AlexAccSkip+  , AlexAcc 27+  , AlexAcc 26+  , AlexAcc 25+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAcc 24+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAcc 23+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAccPred 22 (precededByClosingToken `alexAndPred` followedByOpeningToken)(AlexAccPred 21 (followedByOpeningToken)(AlexAccPred 20 (precededByClosingToken)(AlexAcc 19)))+  , AlexAccPred 18 (known_pragma twoWordPrags)(AlexAccNone)+  , AlexAccNone+  , AlexAcc 17+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAcc 16+  , AlexAccNone+  , AlexAccPred 15 (precededByClosingToken `alexAndPred` followedByOpeningToken)(AlexAccPred 14 (followedByOpeningToken)(AlexAccPred 13 (precededByClosingToken)(AlexAcc 12)))+  , AlexAcc 11+  , AlexAccPred 10 (isNormalComment)(AlexAccNone)+  , AlexAcc 9+  , AlexAcc 8+  , AlexAccPred 7 (ifExtension HaddockBit)(AlexAccNone)+  , AlexAcc 6+  , AlexAcc 5+  , AlexAcc 4+  , AlexAccPred 3 (precededByClosingToken `alexAndPred` followedByOpeningToken)(AlexAccPred 2 (followedByOpeningToken)(AlexAccPred 1 (precededByClosingToken)(AlexAcc 0)))+  ]++alex_actions = array (0 :: Int, 210)+  [ (209,alex_action_15)+  , (208,alex_action_21)+  , (207,alex_action_22)+  , (206,alex_action_20)+  , (205,alex_action_23)+  , (204,alex_action_27)+  , (203,alex_action_28)+  , (202,alex_action_44)+  , (201,alex_action_45)+  , (200,alex_action_50)+  , (199,alex_action_46)+  , (198,alex_action_47)+  , (197,alex_action_50)+  , (196,alex_action_48)+  , (195,alex_action_50)+  , (194,alex_action_49)+  , (193,alex_action_50)+  , (192,alex_action_50)+  , (191,alex_action_51)+  , (190,alex_action_52)+  , (189,alex_action_53)+  , (188,alex_action_56)+  , (187,alex_action_57)+  , (186,alex_action_54)+  , (185,alex_action_81)+  , (184,alex_action_82)+  , (183,alex_action_83)+  , (182,alex_action_84)+  , (181,alex_action_55)+  , (180,alex_action_58)+  , (179,alex_action_59)+  , (178,alex_action_62)+  , (177,alex_action_60)+  , (176,alex_action_81)+  , (175,alex_action_82)+  , (174,alex_action_83)+  , (173,alex_action_84)+  , (172,alex_action_61)+  , (171,alex_action_62)+  , (170,alex_action_63)+  , (169,alex_action_64)+  , (168,alex_action_65)+  , (167,alex_action_66)+  , (166,alex_action_67)+  , (165,alex_action_68)+  , (164,alex_action_69)+  , (163,alex_action_70)+  , (162,alex_action_71)+  , (161,alex_action_71)+  , (160,alex_action_73)+  , (159,alex_action_72)+  , (158,alex_action_73)+  , (157,alex_action_73)+  , (156,alex_action_72)+  , (155,alex_action_73)+  , (154,alex_action_73)+  , (153,alex_action_73)+  , (152,alex_action_73)+  , (151,alex_action_73)+  , (150,alex_action_73)+  , (149,alex_action_73)+  , (148,alex_action_74)+  , (147,alex_action_74)+  , (146,alex_action_75)+  , (145,alex_action_75)+  , (144,alex_action_75)+  , (143,alex_action_75)+  , (142,alex_action_75)+  , (141,alex_action_75)+  , (140,alex_action_76)+  , (139,alex_action_76)+  , (138,alex_action_18)+  , (137,alex_action_77)+  , (136,alex_action_78)+  , (135,alex_action_79)+  , (134,alex_action_79)+  , (133,alex_action_112)+  , (132,alex_action_79)+  , (131,alex_action_113)+  , (130,alex_action_80)+  , (129,alex_action_81)+  , (128,alex_action_82)+  , (127,alex_action_83)+  , (126,alex_action_84)+  , (125,alex_action_81)+  , (124,alex_action_82)+  , (123,alex_action_83)+  , (122,alex_action_84)+  , (121,alex_action_85)+  , (120,alex_action_86)+  , (119,alex_action_87)+  , (118,alex_action_88)+  , (117,alex_action_88)+  , (116,alex_action_89)+  , (115,alex_action_90)+  , (114,alex_action_91)+  , (113,alex_action_92)+  , (112,alex_action_92)+  , (111,alex_action_93)+  , (110,alex_action_94)+  , (109,alex_action_95)+  , (108,alex_action_96)+  , (107,alex_action_97)+  , (106,alex_action_98)+  , (105,alex_action_98)+  , (104,alex_action_99)+  , (103,alex_action_99)+  , (102,alex_action_100)+  , (101,alex_action_101)+  , (100,alex_action_102)+  , (99,alex_action_103)+  , (98,alex_action_104)+  , (97,alex_action_105)+  , (96,alex_action_106)+  , (95,alex_action_107)+  , (94,alex_action_108)+  , (93,alex_action_109)+  , (92,alex_action_110)+  , (91,alex_action_111)+  , (90,alex_action_112)+  , (89,alex_action_113)+  , (88,alex_action_114)+  , (87,alex_action_115)+  , (86,alex_action_116)+  , (85,alex_action_117)+  , (84,alex_action_1)+  , (83,alex_action_2)+  , (82,alex_action_2)+  , (81,alex_action_28)+  , (80,alex_action_3)+  , (79,alex_action_4)+  , (78,alex_action_5)+  , (77,alex_action_5)+  , (76,alex_action_28)+  , (75,alex_action_5)+  , (74,alex_action_39)+  , (73,alex_action_6)+  , (72,alex_action_7)+  , (71,alex_action_7)+  , (70,alex_action_7)+  , (69,alex_action_28)+  , (68,alex_action_7)+  , (67,alex_action_28)+  , (66,alex_action_7)+  , (65,alex_action_81)+  , (64,alex_action_82)+  , (63,alex_action_83)+  , (62,alex_action_84)+  , (61,alex_action_7)+  , (60,alex_action_81)+  , (59,alex_action_82)+  , (58,alex_action_83)+  , (57,alex_action_84)+  , (56,alex_action_8)+  , (55,alex_action_8)+  , (54,alex_action_28)+  , (53,alex_action_10)+  , (52,alex_action_11)+  , (51,alex_action_97)+  , (50,alex_action_96)+  , (49,alex_action_16)+  , (48,alex_action_18)+  , (47,alex_action_19)+  , (46,alex_action_24)+  , (45,alex_action_25)+  , (44,alex_action_2)+  , (43,alex_action_75)+  , (42,alex_action_75)+  , (41,alex_action_25)+  , (40,alex_action_28)+  , (39,alex_action_25)+  , (38,alex_action_33)+  , (37,alex_action_34)+  , (36,alex_action_36)+  , (35,alex_action_25)+  , (34,alex_action_33)+  , (33,alex_action_34)+  , (32,alex_action_37)+  , (31,alex_action_26)+  , (30,alex_action_28)+  , (29,alex_action_28)+  , (28,alex_action_1)+  , (27,alex_action_28)+  , (26,alex_action_28)+  , (25,alex_action_29)+  , (24,alex_action_30)+  , (23,alex_action_31)+  , (22,alex_action_81)+  , (21,alex_action_82)+  , (20,alex_action_83)+  , (19,alex_action_84)+  , (18,alex_action_32)+  , (17,alex_action_35)+  , (16,alex_action_64)+  , (15,alex_action_81)+  , (14,alex_action_82)+  , (13,alex_action_83)+  , (12,alex_action_84)+  , (11,alex_action_38)+  , (10,alex_action_2)+  , (9,alex_action_69)+  , (8,alex_action_38)+  , (7,alex_action_40)+  , (6,alex_action_41)+  , (5,alex_action_42)+  , (4,alex_action_43)+  , (3,alex_action_81)+  , (2,alex_action_82)+  , (1,alex_action_83)+  , (0,alex_action_84)+  ]++{-# LINE 700 "_build/source-dist/ghc-9.4.1-src/ghc-9.4.1/compiler/GHC/Parser/Lexer.x" #-}+-- -----------------------------------------------------------------------------+-- The token type++data Token+  = ITas                        -- Haskell keywords+  | ITcase+  | ITclass+  | ITdata+  | ITdefault+  | ITderiving+  | ITdo (Maybe FastString)+  | ITelse+  | IThiding+  | ITforeign+  | ITif+  | ITimport+  | ITin+  | ITinfix+  | ITinfixl+  | ITinfixr+  | ITinstance+  | ITlet+  | ITmodule+  | ITnewtype+  | ITof+  | ITqualified+  | ITthen+  | ITtype+  | ITwhere++  | ITforall            IsUnicodeSyntax -- GHC extension keywords+  | ITexport+  | ITlabel+  | ITdynamic+  | ITsafe+  | ITinterruptible+  | ITunsafe+  | ITstdcallconv+  | ITccallconv+  | ITcapiconv+  | ITprimcallconv+  | ITjavascriptcallconv+  | ITmdo (Maybe FastString)+  | ITfamily+  | ITrole+  | ITgroup+  | ITby+  | ITusing+  | ITpattern+  | ITstatic+  | ITstock+  | ITanyclass+  | ITvia++  -- Backpack tokens+  | ITunit+  | ITsignature+  | ITdependency+  | ITrequires++  -- Pragmas, see  Note [Pragma source text] in "GHC.Types.Basic"+  | ITinline_prag       SourceText InlineSpec RuleMatchInfo+  | ITopaque_prag       SourceText+  | ITspec_prag         SourceText                -- SPECIALISE+  | ITspec_inline_prag  SourceText Bool    -- SPECIALISE INLINE (or NOINLINE)+  | ITsource_prag       SourceText+  | ITrules_prag        SourceText+  | ITwarning_prag      SourceText+  | ITdeprecated_prag   SourceText+  | ITline_prag         SourceText  -- not usually produced, see 'UsePosPragsBit'+  | ITcolumn_prag       SourceText  -- not usually produced, see 'UsePosPragsBit'+  | ITscc_prag          SourceText+  | ITunpack_prag       SourceText+  | ITnounpack_prag     SourceText+  | ITann_prag          SourceText+  | ITcomplete_prag     SourceText+  | ITclose_prag+  | IToptions_prag String+  | ITinclude_prag String+  | ITlanguage_prag+  | ITminimal_prag      SourceText+  | IToverlappable_prag SourceText  -- instance overlap mode+  | IToverlapping_prag  SourceText  -- instance overlap mode+  | IToverlaps_prag     SourceText  -- instance overlap mode+  | ITincoherent_prag   SourceText  -- instance overlap mode+  | ITctype             SourceText+  | ITcomment_line_prag         -- See Note [Nested comment line pragmas]++  | ITdotdot                    -- reserved symbols+  | ITcolon+  | ITdcolon            IsUnicodeSyntax+  | ITequal+  | ITlam+  | ITlcase+  | ITlcases+  | ITvbar+  | ITlarrow            IsUnicodeSyntax+  | ITrarrow            IsUnicodeSyntax+  | ITdarrow            IsUnicodeSyntax+  | ITlolly       -- The (⊸) arrow (for LinearTypes)+  | ITminus       -- See Note [Minus tokens]+  | ITprefixminus -- See Note [Minus tokens]+  | ITbang     -- Prefix (!) only, e.g. f !x = rhs+  | ITtilde    -- Prefix (~) only, e.g. f ~x = rhs+  | ITat       -- Tight infix (@) only, e.g. f x@pat = rhs+  | ITtypeApp  -- Prefix (@) only, e.g. f @t+  | ITpercent  -- Prefix (%) only, e.g. a %1 -> b+  | ITstar              IsUnicodeSyntax+  | ITdot+  | ITproj Bool -- Extension: OverloadedRecordDotBit++  | ITbiglam                    -- GHC-extension symbols++  | ITocurly                    -- special symbols+  | ITccurly+  | ITvocurly+  | ITvccurly+  | ITobrack+  | ITopabrack                  -- [:, for parallel arrays with -XParallelArrays+  | ITcpabrack                  -- :], for parallel arrays with -XParallelArrays+  | ITcbrack+  | IToparen+  | ITcparen+  | IToubxparen+  | ITcubxparen+  | ITsemi+  | ITcomma+  | ITunderscore+  | ITbackquote+  | ITsimpleQuote               --  '++  | ITvarid   FastString        -- identifiers+  | ITconid   FastString+  | ITvarsym  FastString+  | ITconsym  FastString+  | ITqvarid  (FastString,FastString)+  | ITqconid  (FastString,FastString)+  | ITqvarsym (FastString,FastString)+  | ITqconsym (FastString,FastString)++  | ITdupipvarid   FastString   -- GHC extension: implicit param: ?x+  | ITlabelvarid   FastString   -- Overloaded label: #x++  | ITchar     SourceText Char       -- Note [Literal source text] in "GHC.Types.Basic"+  | ITstring   SourceText FastString -- Note [Literal source text] in "GHC.Types.Basic"+  | ITinteger  IntegralLit           -- Note [Literal source text] in "GHC.Types.Basic"+  | ITrational FractionalLit++  | ITprimchar   SourceText Char     -- Note [Literal source text] in "GHC.Types.Basic"+  | ITprimstring SourceText ByteString -- Note [Literal source text] in "GHC.Types.Basic"+  | ITprimint    SourceText Integer  -- Note [Literal source text] in "GHC.Types.Basic"+  | ITprimword   SourceText Integer  -- Note [Literal source text] in "GHC.Types.Basic"+  | ITprimfloat  FractionalLit+  | ITprimdouble FractionalLit++  -- Template Haskell extension tokens+  | ITopenExpQuote HasE IsUnicodeSyntax --  [| or [e|+  | ITopenPatQuote                      --  [p|+  | ITopenDecQuote                      --  [d|+  | ITopenTypQuote                      --  [t|+  | ITcloseQuote IsUnicodeSyntax        --  |]+  | ITopenTExpQuote HasE                --  [|| or [e||+  | ITcloseTExpQuote                    --  ||]+  | ITdollar                            --  prefix $+  | ITdollardollar                      --  prefix $$+  | ITtyQuote                           --  ''+  | ITquasiQuote (FastString,FastString,PsSpan)+    -- ITquasiQuote(quoter, quote, loc)+    -- represents a quasi-quote of the form+    -- [quoter| quote |]+  | ITqQuasiQuote (FastString,FastString,FastString,PsSpan)+    -- ITqQuasiQuote(Qual, quoter, quote, loc)+    -- represents a qualified quasi-quote of the form+    -- [Qual.quoter| quote |]++  -- Arrow notation extension+  | ITproc+  | ITrec+  | IToparenbar  IsUnicodeSyntax -- ^ @(|@+  | ITcparenbar  IsUnicodeSyntax -- ^ @|)@+  | ITlarrowtail IsUnicodeSyntax -- ^ @-<@+  | ITrarrowtail IsUnicodeSyntax -- ^ @>-@+  | ITLarrowtail IsUnicodeSyntax -- ^ @-<<@+  | ITRarrowtail IsUnicodeSyntax -- ^ @>>-@++  | ITunknown String             -- ^ Used when the lexer can't make sense of it+  | ITeof                        -- ^ end of file token++  -- Documentation annotations. See Note [PsSpan in Comments]+  | ITdocComment   HsDocString PsSpan -- ^ The HsDocString contains more details about what+                                      -- this is and how to pretty print it+  | ITdocOptions   String      PsSpan -- ^ doc options (prune, ignore-exports, etc)+  | ITlineComment  String      PsSpan -- ^ comment starting by "--"+  | ITblockComment String      PsSpan -- ^ comment in {- -}++  deriving Show++instance Outputable Token where+  ppr x = text (show x)++{- Note [PsSpan in Comments]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When using the Api Annotations to exact print a modified AST, managing+the space before a comment is important.  The PsSpan in the comment+token allows this to happen.++We also need to track the space before the end of file. The normal+mechanism of using the previous token does not work, as the ITeof is+synthesised to come at the same location of the last token, and the+normal previous token updating has by then updated the required+location.++We track this using a 2-back location, prev_loc2. This adds extra+processing to every single token, which is a performance hit for+something needed only at the end of the file. This needs+improving. Perhaps a backward scan on eof?+-}++{- Note [Minus tokens]+~~~~~~~~~~~~~~~~~~~~~~+A minus sign can be used in prefix form (-x) and infix form (a - b).++When LexicalNegation is on:+  * ITprefixminus  represents the prefix form+  * ITvarsym "-"   represents the infix form+  * ITminus        is not used++When LexicalNegation is off:+  * ITminus        represents all forms+  * ITprefixminus  is not used+  * ITvarsym "-"   is not used+-}++{- Note [Why not LexicalNegationBit]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+One might wonder why we define NoLexicalNegationBit instead of+LexicalNegationBit. The problem lies in the following line in reservedSymsFM:++    ,("-", ITminus, NormalSyntax, xbit NoLexicalNegationBit)++We want to generate ITminus only when LexicalNegation is off. How would one+do it if we had LexicalNegationBit? I (int-index) tried to use bitwise+complement:++    ,("-", ITminus, NormalSyntax, complement (xbit LexicalNegationBit))++This did not work, so I opted for NoLexicalNegationBit instead.+-}+++-- the bitmap provided as the third component indicates whether the+-- corresponding extension keyword is valid under the extension options+-- provided to the compiler; if the extension corresponding to *any* of the+-- bits set in the bitmap is enabled, the keyword is valid (this setup+-- facilitates using a keyword in two different extensions that can be+-- activated independently)+--+reservedWordsFM :: UniqFM FastString (Token, ExtsBitmap)+reservedWordsFM = listToUFM $+    map (\(x, y, z) -> (mkFastString x, (y, z)))+        [( "_",              ITunderscore,    0 ),+         ( "as",             ITas,            0 ),+         ( "case",           ITcase,          0 ),+         ( "cases",          ITlcases,        xbit LambdaCaseBit ),+         ( "class",          ITclass,         0 ),+         ( "data",           ITdata,          0 ),+         ( "default",        ITdefault,       0 ),+         ( "deriving",       ITderiving,      0 ),+         ( "do",             ITdo Nothing,    0 ),+         ( "else",           ITelse,          0 ),+         ( "hiding",         IThiding,        0 ),+         ( "if",             ITif,            0 ),+         ( "import",         ITimport,        0 ),+         ( "in",             ITin,            0 ),+         ( "infix",          ITinfix,         0 ),+         ( "infixl",         ITinfixl,        0 ),+         ( "infixr",         ITinfixr,        0 ),+         ( "instance",       ITinstance,      0 ),+         ( "let",            ITlet,           0 ),+         ( "module",         ITmodule,        0 ),+         ( "newtype",        ITnewtype,       0 ),+         ( "of",             ITof,            0 ),+         ( "qualified",      ITqualified,     0 ),+         ( "then",           ITthen,          0 ),+         ( "type",           ITtype,          0 ),+         ( "where",          ITwhere,         0 ),++         ( "forall",         ITforall NormalSyntax, 0),+         ( "mdo",            ITmdo Nothing,   xbit RecursiveDoBit),+             -- See Note [Lexing type pseudo-keywords]+         ( "family",         ITfamily,        0 ),+         ( "role",           ITrole,          0 ),+         ( "pattern",        ITpattern,       xbit PatternSynonymsBit),+         ( "static",         ITstatic,        xbit StaticPointersBit ),+         ( "stock",          ITstock,         0 ),+         ( "anyclass",       ITanyclass,      0 ),+         ( "via",            ITvia,           0 ),+         ( "group",          ITgroup,         xbit TransformComprehensionsBit),+         ( "by",             ITby,            xbit TransformComprehensionsBit),+         ( "using",          ITusing,         xbit TransformComprehensionsBit),++         ( "foreign",        ITforeign,       xbit FfiBit),+         ( "export",         ITexport,        xbit FfiBit),+         ( "label",          ITlabel,         xbit FfiBit),+         ( "dynamic",        ITdynamic,       xbit FfiBit),+         ( "safe",           ITsafe,          xbit FfiBit .|.+                                              xbit SafeHaskellBit),+         ( "interruptible",  ITinterruptible, xbit InterruptibleFfiBit),+         ( "unsafe",         ITunsafe,        xbit FfiBit),+         ( "stdcall",        ITstdcallconv,   xbit FfiBit),+         ( "ccall",          ITccallconv,     xbit FfiBit),+         ( "capi",           ITcapiconv,      xbit CApiFfiBit),+         ( "prim",           ITprimcallconv,  xbit FfiBit),+         ( "javascript",     ITjavascriptcallconv, xbit FfiBit),++         ( "unit",           ITunit,          0 ),+         ( "dependency",     ITdependency,       0 ),+         ( "signature",      ITsignature,     0 ),++         ( "rec",            ITrec,           xbit ArrowsBit .|.+                                              xbit RecursiveDoBit),+         ( "proc",           ITproc,          xbit ArrowsBit)+     ]++{-----------------------------------+Note [Lexing type pseudo-keywords]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++One might think that we wish to treat 'family' and 'role' as regular old+varids whenever -XTypeFamilies and -XRoleAnnotations are off, respectively.+But, there is no need to do so. These pseudo-keywords are not stolen syntax:+they are only used after the keyword 'type' at the top-level, where varids are+not allowed. Furthermore, checks further downstream (GHC.Tc.TyCl) ensure that+type families and role annotations are never declared without their extensions+on. In fact, by unconditionally lexing these pseudo-keywords as special, we+can get better error messages.++Also, note that these are included in the `varid` production in the parser --+a key detail to make all this work.+-------------------------------------}++reservedSymsFM :: UniqFM FastString (Token, IsUnicodeSyntax, ExtsBitmap)+reservedSymsFM = listToUFM $+    map (\ (x,w,y,z) -> (mkFastString x,(w,y,z)))+      [ ("..",  ITdotdot,                   NormalSyntax,  0 )+        -- (:) is a reserved op, meaning only list cons+       ,(":",   ITcolon,                    NormalSyntax,  0 )+       ,("::",  ITdcolon NormalSyntax,      NormalSyntax,  0 )+       ,("=",   ITequal,                    NormalSyntax,  0 )+       ,("\\",  ITlam,                      NormalSyntax,  0 )+       ,("|",   ITvbar,                     NormalSyntax,  0 )+       ,("<-",  ITlarrow NormalSyntax,      NormalSyntax,  0 )+       ,("->",  ITrarrow NormalSyntax,      NormalSyntax,  0 )+       ,("=>",  ITdarrow NormalSyntax,      NormalSyntax,  0 )+       ,("-",   ITminus,                    NormalSyntax,  xbit NoLexicalNegationBit)++       ,("*",   ITstar NormalSyntax,        NormalSyntax,  xbit StarIsTypeBit)++        -- For 'forall a . t'+       ,(".",   ITdot,                      NormalSyntax,  0 )++       ,("-<",  ITlarrowtail NormalSyntax,  NormalSyntax,  xbit ArrowsBit)+       ,(">-",  ITrarrowtail NormalSyntax,  NormalSyntax,  xbit ArrowsBit)+       ,("-<<", ITLarrowtail NormalSyntax,  NormalSyntax,  xbit ArrowsBit)+       ,(">>-", ITRarrowtail NormalSyntax,  NormalSyntax,  xbit ArrowsBit)++       ,("∷",   ITdcolon UnicodeSyntax,     UnicodeSyntax, 0 )+       ,("⇒",   ITdarrow UnicodeSyntax,     UnicodeSyntax, 0 )+       ,("∀",   ITforall UnicodeSyntax,     UnicodeSyntax, 0 )+       ,("→",   ITrarrow UnicodeSyntax,     UnicodeSyntax, 0 )+       ,("←",   ITlarrow UnicodeSyntax,     UnicodeSyntax, 0 )++       ,("⊸",   ITlolly, UnicodeSyntax, 0)++       ,("⤙",   ITlarrowtail UnicodeSyntax, UnicodeSyntax, xbit ArrowsBit)+       ,("⤚",   ITrarrowtail UnicodeSyntax, UnicodeSyntax, xbit ArrowsBit)+       ,("⤛",   ITLarrowtail UnicodeSyntax, UnicodeSyntax, xbit ArrowsBit)+       ,("⤜",   ITRarrowtail UnicodeSyntax, UnicodeSyntax, xbit ArrowsBit)++       ,("★",   ITstar UnicodeSyntax,       UnicodeSyntax, xbit StarIsTypeBit)++        -- ToDo: ideally, → and ∷ should be "specials", so that they cannot+        -- form part of a large operator.  This would let us have a better+        -- syntax for kinds: ɑ∷*→* would be a legal kind signature. (maybe).+       ]++-- -----------------------------------------------------------------------------+-- Lexer actions++type Action = PsSpan -> StringBuffer -> Int -> P (PsLocated Token)++special :: Token -> Action+special tok span _buf _len = return (L span tok)++token, layout_token :: Token -> Action+token t span _buf _len = return (L span t)+layout_token t span _buf _len = pushLexState layout >> return (L span t)++idtoken :: (StringBuffer -> Int -> Token) -> Action+idtoken f span buf len = return (L span $! (f buf len))++qdo_token :: (Maybe FastString -> Token) -> Action+qdo_token con span buf len = do+    maybe_layout token+    return (L span $! token)+  where+    !token = con $! Just $! fst $! splitQualName buf len False++skip_one_varid :: (FastString -> Token) -> Action+skip_one_varid f span buf len+  = return (L span $! f (lexemeToFastString (stepOn buf) (len-1)))++skip_two_varid :: (FastString -> Token) -> Action+skip_two_varid f span buf len+  = return (L span $! f (lexemeToFastString (stepOn (stepOn buf)) (len-2)))++strtoken :: (String -> Token) -> Action+strtoken f span buf len =+  return (L span $! (f $! lexemeToString buf len))++begin :: Int -> Action+begin code _span _str _len = do pushLexState code; lexToken++pop :: Action+pop _span _buf _len = do _ <- popLexState+                         lexToken+-- See Note [Nested comment line pragmas]+failLinePrag1 :: Action+failLinePrag1 span _buf _len = do+  b <- getBit InNestedCommentBit+  if b then return (L span ITcomment_line_prag)+       else lexError LexErrorInPragma++-- See Note [Nested comment line pragmas]+popLinePrag1 :: Action+popLinePrag1 span _buf _len = do+  b <- getBit InNestedCommentBit+  if b then return (L span ITcomment_line_prag) else do+    _ <- popLexState+    lexToken++hopefully_open_brace :: Action+hopefully_open_brace span buf len+ = do relaxed <- getBit RelaxedLayoutBit+      ctx <- getContext+      (AI l _) <- getInput+      let offset = srcLocCol (psRealLoc l)+          isOK = relaxed ||+                 case ctx of+                 Layout prev_off _ : _ -> prev_off < offset+                 _                     -> True+      if isOK then pop_and open_brace span buf len+              else addFatalError $+                     mkPlainErrorMsgEnvelope (mkSrcSpanPs span) PsErrMissingBlock++pop_and :: Action -> Action+pop_and act span buf len = do _ <- popLexState+                              act span buf len++-- See Note [Whitespace-sensitive operator parsing]+followedByOpeningToken :: AlexAccPred ExtsBitmap+followedByOpeningToken _ _ _ (AI _ buf)+  | atEnd buf = False+  | otherwise =+      case nextChar buf of+        ('{', buf') -> nextCharIsNot buf' (== '-')+        ('(', _) -> True+        ('[', _) -> True+        ('\"', _) -> True+        ('\'', _) -> True+        ('_', _) -> True+        ('⟦', _) -> True+        ('⦇', _) -> True+        (c, _) -> isAlphaNum c++-- See Note [Whitespace-sensitive operator parsing]+precededByClosingToken :: AlexAccPred ExtsBitmap+precededByClosingToken _ (AI _ buf) _ _ =+  case prevChar buf '\n' of+    '}' -> decodePrevNChars 1 buf /= "-"+    ')' -> True+    ']' -> True+    '\"' -> True+    '\'' -> True+    '_' -> True+    '⟧' -> True+    '⦈' -> True+    c -> isAlphaNum c++{-# INLINE nextCharIs #-}+nextCharIs :: StringBuffer -> (Char -> Bool) -> Bool+nextCharIs buf p = not (atEnd buf) && p (currentChar buf)++{-# INLINE nextCharIsNot #-}+nextCharIsNot :: StringBuffer -> (Char -> Bool) -> Bool+nextCharIsNot buf p = not (nextCharIs buf p)++notFollowedBy :: Char -> AlexAccPred ExtsBitmap+notFollowedBy char _ _ _ (AI _ buf)+  = nextCharIsNot buf (== char)++notFollowedBySymbol :: AlexAccPred ExtsBitmap+notFollowedBySymbol _ _ _ (AI _ buf)+  = nextCharIsNot buf (`elem` "!#$%&*+./<=>?@\\^|-~")++followedByDigit :: AlexAccPred ExtsBitmap+followedByDigit _ _ _ (AI _ buf)+  = afterOptionalSpace buf (\b -> nextCharIs b (`elem` ['0'..'9']))++ifCurrentChar :: Char -> AlexAccPred ExtsBitmap+ifCurrentChar char _ (AI _ buf) _ _+  = nextCharIs buf (== char)++-- We must reject doc comments as being ordinary comments everywhere.+-- In some cases the doc comment will be selected as the lexeme due to+-- maximal munch, but not always, because the nested comment rule is+-- valid in all states, but the doc-comment rules are only valid in+-- the non-layout states.+isNormalComment :: AlexAccPred ExtsBitmap+isNormalComment bits _ _ (AI _ buf)+  | HaddockBit `xtest` bits = notFollowedByDocOrPragma+  | otherwise               = nextCharIsNot buf (== '#')+  where+    notFollowedByDocOrPragma+       = afterOptionalSpace buf (\b -> nextCharIsNot b (`elem` "|^*$#"))++afterOptionalSpace :: StringBuffer -> (StringBuffer -> Bool) -> Bool+afterOptionalSpace buf p+    = if nextCharIs buf (== ' ')+      then p (snd (nextChar buf))+      else p buf++atEOL :: AlexAccPred ExtsBitmap+atEOL _ _ _ (AI _ buf) = atEnd buf || currentChar buf == '\n'++-- Check if we should parse a negative literal (e.g. -123) as a single token.+negLitPred :: AlexAccPred ExtsBitmap+negLitPred =+    prefix_minus `alexAndPred`+    (negative_literals `alexOrPred` lexical_negation)+  where+    negative_literals = ifExtension NegativeLiteralsBit++    lexical_negation  =+      -- See Note [Why not LexicalNegationBit]+      alexNotPred (ifExtension NoLexicalNegationBit)++    prefix_minus =+      -- Note [prefix_minus in negLitPred and negHashLitPred]+      alexNotPred precededByClosingToken++-- Check if we should parse an unboxed negative literal (e.g. -123#) as a single token.+negHashLitPred :: AlexAccPred ExtsBitmap+negHashLitPred = prefix_minus `alexAndPred` magic_hash+  where+    magic_hash = ifExtension MagicHashBit+    prefix_minus =+      -- Note [prefix_minus in negLitPred and negHashLitPred]+      alexNotPred precededByClosingToken++{- Note [prefix_minus in negLitPred and negHashLitPred]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We want to parse -1 as a single token, but x-1 as three tokens.+So in negLitPred (and negHashLitPred) we require that we have a prefix+occurrence of the minus sign. See Note [Whitespace-sensitive operator parsing]+for a detailed definition of a prefix occurrence.++The condition for a prefix occurrence of an operator is:++  not precededByClosingToken && followedByOpeningToken++but we don't check followedByOpeningToken when parsing a negative literal.+It holds simply because we immediately lex a literal after the minus.+-}++ifExtension :: ExtBits -> AlexAccPred ExtsBitmap+ifExtension extBits bits _ _ _ = extBits `xtest` bits++alexNotPred p userState in1 len in2+  = not (p userState in1 len in2)++alexOrPred p1 p2 userState in1 len in2+  = p1 userState in1 len in2 || p2 userState in1 len in2++multiline_doc_comment :: Action+multiline_doc_comment span buf _len = {-# SCC "multiline_doc_comment" #-} withLexedDocType worker+  where+    worker input@(AI start_loc _) docType checkNextLine = go start_loc "" [] input+      where+        go start_loc curLine prevLines input@(AI end_loc _) = case alexGetChar' input of+            Just ('\n', input')+              | checkNextLine -> case checkIfCommentLine input' of+                Just input@(AI next_start _) ->  go next_start "" (locatedLine : prevLines) input -- Start a new line+                Nothing -> endComment+              | otherwise -> endComment+            Just (c, input) -> go start_loc (c:curLine) prevLines input+            Nothing -> endComment+          where+            lineSpan = mkSrcSpanPs $ mkPsSpan start_loc end_loc+            locatedLine = L lineSpan (mkHsDocStringChunk $ reverse curLine)+            commentLines = NE.reverse $ locatedLine :| prevLines+            endComment = docCommentEnd input (docType (\dec -> MultiLineDocString dec commentLines)) buf span++    -- Check if the next line of input belongs to this doc comment as well.+    -- A doc comment continues onto the next line when the following+    -- conditions are met:+    --   * The line starts with "--"+    --   * The line doesn't start with "---".+    --   * The line doesn't start with "-- $", because that would be the+    --     start of a /new/ named haddock chunk (#10398).+    checkIfCommentLine :: AlexInput -> Maybe AlexInput+    checkIfCommentLine input = check (dropNonNewlineSpace input)+      where+        check input = do+          ('-', input) <- alexGetChar' input+          ('-', input) <- alexGetChar' input+          (c, after_c) <- alexGetChar' input+          case c of+            '-' -> Nothing+            ' ' -> case alexGetChar' after_c of+                     Just ('$', _) -> Nothing+                     _ -> Just input+            _   -> Just input++        dropNonNewlineSpace input = case alexGetChar' input of+          Just (c, input')+            | isSpace c && c /= '\n' -> dropNonNewlineSpace input'+            | otherwise -> input+          Nothing -> input++lineCommentToken :: Action+lineCommentToken span buf len = do+  b <- getBit RawTokenStreamBit+  if b then do+         lt <- getLastLocComment+         strtoken (\s -> ITlineComment s lt) span buf len+       else lexToken+++{-+  nested comments require traversing by hand, they can't be parsed+  using regular expressions.+-}+nested_comment :: Action+nested_comment span buf len = {-# SCC "nested_comment" #-} do+  l <- getLastLocComment+  let endComment input (L _ comment) = commentEnd lexToken input (Nothing, ITblockComment comment l) buf span+  input <- getInput+  -- Include decorator in comment+  let start_decorator = reverse $ lexemeToString buf len+  nested_comment_logic endComment start_decorator input span++nested_doc_comment :: Action+nested_doc_comment span buf _len = {-# SCC "nested_doc_comment" #-} withLexedDocType worker+  where+    worker input docType _checkNextLine = nested_comment_logic endComment "" input span+      where+        endComment input lcomment+          = docCommentEnd input (docType (\d -> NestedDocString d (mkHsDocStringChunk . dropTrailingDec <$> lcomment))) buf span++        dropTrailingDec [] = []+        dropTrailingDec "-}" = ""+        dropTrailingDec (x:xs) = x:dropTrailingDec xs++{-# INLINE nested_comment_logic #-}+-- | Includes the trailing '-}' decorators+-- drop the last two elements with the callback if you don't want them to be included+nested_comment_logic+  :: (AlexInput -> Located String -> P (PsLocated Token))  -- ^ Continuation that gets the rest of the input and the lexed comment+  -> String -- ^ starting value for accumulator (reversed) - When we want to include a decorator '{-' in the comment+  -> AlexInput+  -> PsSpan+  -> P (PsLocated Token)+nested_comment_logic endComment commentAcc input span = go commentAcc (1::Int) input+  where+    go commentAcc 0 input@(AI end_loc _) = do+      let comment = reverse commentAcc+          cspan = mkSrcSpanPs $ mkPsSpan (psSpanStart span) end_loc+          lcomment = L cspan comment+      endComment input lcomment+    go commentAcc n input = case alexGetChar' input of+      Nothing -> errBrace input (psRealSpan span)+      Just ('-',input) -> case alexGetChar' input of+        Nothing  -> errBrace input (psRealSpan span)+        Just ('\125',input) -> go ('\125':'-':commentAcc) (n-1) input -- '}'+        Just (_,_)          -> go ('-':commentAcc) n input+      Just ('\123',input) -> case alexGetChar' input of  -- '{' char+        Nothing  -> errBrace input (psRealSpan span)+        Just ('-',input) -> go ('-':'\123':commentAcc) (n+1) input+        Just (_,_)       -> go ('\123':commentAcc) n input+      -- See Note [Nested comment line pragmas]+      Just ('\n',input) -> case alexGetChar' input of+        Nothing  -> errBrace input (psRealSpan span)+        Just ('#',_) -> do (parsedAcc,input) <- parseNestedPragma input+                           go (parsedAcc ++ '\n':commentAcc) n input+        Just (_,_)   -> go ('\n':commentAcc) n input+      Just (c,input) -> go (c:commentAcc) n input++-- See Note [Nested comment line pragmas]+parseNestedPragma :: AlexInput -> P (String,AlexInput)+parseNestedPragma input@(AI _ buf) = do+  origInput <- getInput+  setInput input+  setExts (.|. xbit InNestedCommentBit)+  pushLexState bol+  lt <- lexToken+  _ <- popLexState+  setExts (.&. complement (xbit InNestedCommentBit))+  postInput@(AI _ postBuf) <- getInput+  setInput origInput+  case unLoc lt of+    ITcomment_line_prag -> do+      let bytes = byteDiff buf postBuf+          diff  = lexemeToString buf bytes+      return (reverse diff, postInput)+    lt' -> panic ("parseNestedPragma: unexpected token" ++ (show lt'))++{-+Note [Nested comment line pragmas]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We used to ignore cpp-preprocessor-generated #line pragmas if they were inside+nested comments.++Now, when parsing a nested comment, if we encounter a line starting with '#' we+call parseNestedPragma, which executes the following:+1. Save the current lexer input (loc, buf) for later+2. Set the current lexer input to the beginning of the line starting with '#'+3. Turn the 'InNestedComment' extension on+4. Push the 'bol' lexer state+5. Lex a token. Due to (2), (3), and (4), this should always lex a single line+   or less and return the ITcomment_line_prag token. This may set source line+   and file location if a #line pragma is successfully parsed+6. Restore lexer input and state to what they were before we did all this+7. Return control to the function parsing a nested comment, informing it of+   what the lexer parsed++Regarding (5) above:+Every exit from the 'bol' lexer state (do_bol, popLinePrag1, failLinePrag1)+checks if the 'InNestedComment' extension is set. If it is, that function will+return control to parseNestedPragma by returning the ITcomment_line_prag token.++See #314 for more background on the bug this fixes.+-}++{-# INLINE withLexedDocType #-}+withLexedDocType :: (AlexInput -> ((HsDocStringDecorator -> HsDocString) -> (HdkComment, Token)) -> Bool -> P (PsLocated Token))+                 -> P (PsLocated Token)+withLexedDocType lexDocComment = do+  input@(AI _ buf) <- getInput+  l <- getLastLocComment+  case prevChar buf ' ' of+    -- The `Bool` argument to lexDocComment signals whether or not the next+    -- line of input might also belong to this doc comment.+    '|' -> lexDocComment input (mkHdkCommentNext l) True+    '^' -> lexDocComment input (mkHdkCommentPrev l) True+    '$' -> case lexDocName input of+       Nothing -> do setInput input; lexToken -- eof reached, lex it normally+       Just (name, input) -> lexDocComment input (mkHdkCommentNamed l name) True+    '*' -> lexDocSection l 1 input+    _ -> panic "withLexedDocType: Bad doc type"+ where+    lexDocSection l n input = case alexGetChar' input of+      Just ('*', input) -> lexDocSection l (n+1) input+      Just (_,   _)     -> lexDocComment input (mkHdkCommentSection l n) False+      Nothing -> do setInput input; lexToken -- eof reached, lex it normally++    lexDocName :: AlexInput -> Maybe (String, AlexInput)+    lexDocName = go ""+      where+        go acc input = case alexGetChar' input of+          Just (c, input')+            | isSpace c -> Just (reverse acc, input)+            | otherwise -> go (c:acc) input'+          Nothing -> Nothing++mkHdkCommentNext, mkHdkCommentPrev  :: PsSpan -> (HsDocStringDecorator -> HsDocString) -> (HdkComment, Token)+mkHdkCommentNext loc mkDS =  (HdkCommentNext ds,ITdocComment ds loc)+  where ds = mkDS HsDocStringNext+mkHdkCommentPrev loc mkDS =  (HdkCommentPrev ds,ITdocComment ds loc)+  where ds = mkDS HsDocStringPrevious++mkHdkCommentNamed :: PsSpan -> String -> (HsDocStringDecorator -> HsDocString) -> (HdkComment, Token)+mkHdkCommentNamed loc name mkDS = (HdkCommentNamed name ds, ITdocComment ds loc)+  where ds = mkDS (HsDocStringNamed name)++mkHdkCommentSection :: PsSpan -> Int -> (HsDocStringDecorator -> HsDocString) -> (HdkComment, Token)+mkHdkCommentSection loc n mkDS = (HdkCommentSection n ds, ITdocComment ds loc)+  where ds = mkDS (HsDocStringGroup n)++-- RULES pragmas turn on the forall and '.' keywords, and we turn them+-- off again at the end of the pragma.+rulePrag :: Action+rulePrag span buf len = do+  setExts (.|. xbit InRulePragBit)+  let !src = lexemeToString buf len+  return (L span (ITrules_prag (SourceText src)))++-- When 'UsePosPragsBit' is not set, it is expected that we emit a token instead+-- of updating the position in 'PState'+linePrag :: Action+linePrag span buf len = do+  usePosPrags <- getBit UsePosPragsBit+  if usePosPrags+    then begin line_prag2 span buf len+    else let !src = lexemeToString buf len+         in return (L span (ITline_prag (SourceText src)))++-- When 'UsePosPragsBit' is not set, it is expected that we emit a token instead+-- of updating the position in 'PState'+columnPrag :: Action+columnPrag span buf len = do+  usePosPrags <- getBit UsePosPragsBit+  let !src = lexemeToString buf len+  if usePosPrags+    then begin column_prag span buf len+    else let !src = lexemeToString buf len+         in return (L span (ITcolumn_prag (SourceText src)))++endPrag :: Action+endPrag span _buf _len = do+  setExts (.&. complement (xbit InRulePragBit))+  return (L span ITclose_prag)++-- docCommentEnd+-------------------------------------------------------------------------------+-- This function is quite tricky. We can't just return a new token, we also+-- need to update the state of the parser. Why? Because the token is longer+-- than what was lexed by Alex, and the lexToken function doesn't know this, so+-- it writes the wrong token length to the parser state. This function is+-- called afterwards, so it can just update the state.++{-# INLINE commentEnd #-}+commentEnd :: P (PsLocated Token)+           -> AlexInput+           -> (Maybe HdkComment, Token)+           -> StringBuffer+           -> PsSpan+           -> P (PsLocated Token)+commentEnd cont input (m_hdk_comment, hdk_token) buf span = do+  setInput input+  let (AI loc nextBuf) = input+      span' = mkPsSpan (psSpanStart span) loc+      last_len = byteDiff buf nextBuf+  span `seq` setLastToken span' last_len+  whenIsJust m_hdk_comment $ \hdk_comment ->+    P $ \s -> POk (s {hdk_comments = hdk_comments s `snocOL` L span' hdk_comment}) ()+  b <- getBit RawTokenStreamBit+  if b then return (L span' hdk_token)+       else cont++{-# INLINE docCommentEnd #-}+docCommentEnd :: AlexInput -> (HdkComment, Token) -> StringBuffer ->+                 PsSpan -> P (PsLocated Token)+docCommentEnd input (hdk_comment, tok) buf span+  = commentEnd lexToken input (Just hdk_comment, tok) buf span++errBrace :: AlexInput -> RealSrcSpan -> P a+errBrace (AI end _) span =+  failLocMsgP (realSrcSpanStart span)+              (psRealLoc end)+              (\srcLoc -> mkPlainErrorMsgEnvelope srcLoc (PsErrLexer LexUnterminatedComment LexErrKind_EOF))++open_brace, close_brace :: Action+open_brace span _str _len = do+  ctx <- getContext+  setContext (NoLayout:ctx)+  return (L span ITocurly)+close_brace span _str _len = do+  popContext+  return (L span ITccurly)++qvarid, qconid :: StringBuffer -> Int -> Token+qvarid buf len = ITqvarid $! splitQualName buf len False+qconid buf len = ITqconid $! splitQualName buf len False++splitQualName :: StringBuffer -> Int -> Bool -> (FastString,FastString)+-- takes a StringBuffer and a length, and returns the module name+-- and identifier parts of a qualified name.  Splits at the *last* dot,+-- because of hierarchical module names.+--+-- Throws an error if the name is not qualified.+splitQualName orig_buf len parens = split orig_buf orig_buf+  where+    split buf dot_buf+        | orig_buf `byteDiff` buf >= len  = done dot_buf+        | c == '.'                        = found_dot buf'+        | otherwise                       = split buf' dot_buf+      where+       (c,buf') = nextChar buf++    -- careful, we might get names like M....+    -- so, if the character after the dot is not upper-case, this is+    -- the end of the qualifier part.+    found_dot buf -- buf points after the '.'+        | isUpper c    = split buf' buf+        | otherwise    = done buf+      where+       (c,buf') = nextChar buf++    done dot_buf+        | qual_size < 1 = error "splitQualName got an unqualified named"+        | otherwise =+        (lexemeToFastString orig_buf (qual_size - 1),+         if parens -- Prelude.(+)+            then lexemeToFastString (stepOn dot_buf) (len - qual_size - 2)+            else lexemeToFastString dot_buf (len - qual_size))+      where+        qual_size = orig_buf `byteDiff` dot_buf++varid :: Action+varid span buf len =+  case lookupUFM reservedWordsFM fs of+    Just (ITcase, _) -> do+      lastTk <- getLastTk+      keyword <- case lastTk of+        Strict.Just (L _ ITlam) -> do+          lambdaCase <- getBit LambdaCaseBit+          unless lambdaCase $ do+            pState <- getPState+            addError $ mkPlainErrorMsgEnvelope (mkSrcSpanPs (last_loc pState)) PsErrLambdaCase+          return ITlcase+        _ -> return ITcase+      maybe_layout keyword+      return $ L span keyword+    Just (ITlcases, _) -> do+      lastTk <- getLastTk+      lambdaCase <- getBit LambdaCaseBit+      token <- case lastTk of+        Strict.Just (L _ ITlam) | lambdaCase -> return ITlcases+        _ -> return $ ITvarid fs+      maybe_layout token+      return $ L span token+    Just (keyword, 0) -> do+      maybe_layout keyword+      return $ L span keyword+    Just (keyword, i) -> do+      exts <- getExts+      if exts .&. i /= 0+        then do+          maybe_layout keyword+          return $ L span keyword+        else+          return $ L span $ ITvarid fs+    Nothing ->+      return $ L span $ ITvarid fs+  where+    !fs = lexemeToFastString buf len++conid :: StringBuffer -> Int -> Token+conid buf len = ITconid $! lexemeToFastString buf len++qvarsym, qconsym :: StringBuffer -> Int -> Token+qvarsym buf len = ITqvarsym $! splitQualName buf len False+qconsym buf len = ITqconsym $! splitQualName buf len False++-- See Note [Whitespace-sensitive operator parsing]+varsym_prefix :: Action+varsym_prefix = sym $ \span exts s ->+  let warnExtConflict errtok =+        do { addPsMessage (mkSrcSpanPs span) (PsWarnOperatorWhitespaceExtConflict errtok)+           ; return (ITvarsym s) }+  in+  if | s == fsLit "@" ->+         return ITtypeApp  -- regardless of TypeApplications for better error messages+     | s == fsLit "%" ->+         if xtest LinearTypesBit exts+         then return ITpercent+         else warnExtConflict OperatorWhitespaceSymbol_PrefixPercent+     | s == fsLit "$" ->+         if xtest ThQuotesBit exts+         then return ITdollar+         else warnExtConflict OperatorWhitespaceSymbol_PrefixDollar+     | s == fsLit "$$" ->+         if xtest ThQuotesBit exts+         then return ITdollardollar+         else warnExtConflict OperatorWhitespaceSymbol_PrefixDollarDollar+     | s == fsLit "-" ->+         return ITprefixminus -- Only when LexicalNegation is on, otherwise we get ITminus+                              -- and don't hit this code path. See Note [Minus tokens]+     | s == fsLit ".", OverloadedRecordDotBit `xtest` exts ->+         return (ITproj True) -- e.g. '(.x)'+     | s == fsLit "." -> return ITdot+     | s == fsLit "!" -> return ITbang+     | s == fsLit "~" -> return ITtilde+     | otherwise ->+         do { addPsMessage+                (mkSrcSpanPs span)+                (PsWarnOperatorWhitespace s OperatorWhitespaceOccurrence_Prefix)+            ; return (ITvarsym s) }++-- See Note [Whitespace-sensitive operator parsing]+varsym_suffix :: Action+varsym_suffix = sym $ \span _ s ->+  if | s == fsLit "@" -> failMsgP (\srcLoc -> mkPlainErrorMsgEnvelope srcLoc $ PsErrSuffixAT)+     | s == fsLit "." -> return ITdot+     | otherwise ->+         do { addPsMessage+                (mkSrcSpanPs span)+                (PsWarnOperatorWhitespace s OperatorWhitespaceOccurrence_Suffix)+            ; return (ITvarsym s) }++-- See Note [Whitespace-sensitive operator parsing]+varsym_tight_infix :: Action+varsym_tight_infix = sym $ \span exts s ->+  if | s == fsLit "@" -> return ITat+     | s == fsLit ".", OverloadedRecordDotBit `xtest` exts  -> return (ITproj False)+     | s == fsLit "." -> return ITdot+     | otherwise ->+         do { addPsMessage+                (mkSrcSpanPs span)+                (PsWarnOperatorWhitespace s (OperatorWhitespaceOccurrence_TightInfix))+            ;  return (ITvarsym s) }++-- See Note [Whitespace-sensitive operator parsing]+varsym_loose_infix :: Action+varsym_loose_infix = sym $ \_ _ s ->+  if | s == fsLit "."+     -> return ITdot+     | otherwise+     -> return $ ITvarsym s++consym :: Action+consym = sym (\_span _exts s -> return $ ITconsym s)++sym :: (PsSpan -> ExtsBitmap -> FastString -> P Token) -> Action+sym con span buf len =+  case lookupUFM reservedSymsFM fs of+    Just (keyword, NormalSyntax, 0) -> do+      exts <- getExts+      if fs == fsLit "." &&+         exts .&. (xbit OverloadedRecordDotBit) /= 0 &&+         xtest OverloadedRecordDotBit exts+      then L span <$!> con span exts fs  -- Process by varsym_*.+      else return $ L span keyword+    Just (keyword, NormalSyntax, i) -> do+      exts <- getExts+      if exts .&. i /= 0+        then return $ L span keyword+        else L span <$!> con span exts fs+    Just (keyword, UnicodeSyntax, 0) -> do+      exts <- getExts+      if xtest UnicodeSyntaxBit exts+        then return $ L span keyword+        else L span <$!> con span exts fs+    Just (keyword, UnicodeSyntax, i) -> do+      exts <- getExts+      if exts .&. i /= 0 && xtest UnicodeSyntaxBit exts+        then return $ L span keyword+        else L span <$!> con span exts fs+    Nothing -> do+      exts <- getExts+      L span <$!> con span exts fs+  where+    !fs = lexemeToFastString buf len++-- Variations on the integral numeric literal.+tok_integral :: (SourceText -> Integer -> Token)+             -> (Integer -> Integer)+             -> Int -> Int+             -> (Integer, (Char -> Int))+             -> Action+tok_integral itint transint transbuf translen (radix,char_to_int) span buf len = do+  numericUnderscores <- getBit NumericUnderscoresBit  -- #14473+  let src = lexemeToString buf len+  when ((not numericUnderscores) && ('_' `elem` src)) $ do+    pState <- getPState+    let msg = PsErrNumUnderscores NumUnderscore_Integral+    addError $ mkPlainErrorMsgEnvelope (mkSrcSpanPs (last_loc pState)) msg+  return $ L span $ itint (SourceText src)+       $! transint $ parseUnsignedInteger+       (offsetBytes transbuf buf) (subtract translen len) radix char_to_int++tok_num :: (Integer -> Integer)+        -> Int -> Int+        -> (Integer, (Char->Int)) -> Action+tok_num = tok_integral $ \case+    st@(SourceText ('-':_)) -> itint st (const True)+    st@(SourceText _)       -> itint st (const False)+    st@NoSourceText         -> itint st (< 0)+  where+    itint :: SourceText -> (Integer -> Bool) -> Integer -> Token+    itint !st is_negative !val = ITinteger ((IL st $! is_negative val) val)++tok_primint :: (Integer -> Integer)+            -> Int -> Int+            -> (Integer, (Char->Int)) -> Action+tok_primint = tok_integral ITprimint+++tok_primword :: Int -> Int+             -> (Integer, (Char->Int)) -> Action+tok_primword = tok_integral ITprimword positive+positive, negative :: (Integer -> Integer)+positive = id+negative = negate+decimal, octal, hexadecimal :: (Integer, Char -> Int)+decimal = (10,octDecDigit)+binary = (2,octDecDigit)+octal = (8,octDecDigit)+hexadecimal = (16,hexDigit)++-- readSignificandExponentPair can understand negative rationals, exponents, everything.+tok_frac :: Int -> (String -> Token) -> Action+tok_frac drop f span buf len = do+  numericUnderscores <- getBit NumericUnderscoresBit  -- #14473+  let src = lexemeToString buf (len-drop)+  when ((not numericUnderscores) && ('_' `elem` src)) $ do+    pState <- getPState+    let msg = PsErrNumUnderscores NumUnderscore_Float+    addError $ mkPlainErrorMsgEnvelope (mkSrcSpanPs (last_loc pState)) msg+  return (L span $! (f $! src))++tok_float, tok_primfloat, tok_primdouble :: String -> Token+tok_float        str = ITrational   $! readFractionalLit str+tok_hex_float    str = ITrational   $! readHexFractionalLit str+tok_primfloat    str = ITprimfloat  $! readFractionalLit str+tok_primdouble   str = ITprimdouble $! readFractionalLit str++readFractionalLit, readHexFractionalLit :: String -> FractionalLit+readHexFractionalLit = readFractionalLitX readHexSignificandExponentPair Base2+readFractionalLit = readFractionalLitX readSignificandExponentPair Base10++readFractionalLitX :: (String -> (Integer, Integer))+                   -> FractionalExponentBase+                   -> String -> FractionalLit+readFractionalLitX readStr b str =+  mkSourceFractionalLit str is_neg i e b+  where+    is_neg = case str of+                    '-' : _ -> True+                    _      -> False+    (i, e) = readStr str++-- -----------------------------------------------------------------------------+-- Layout processing++-- we're at the first token on a line, insert layout tokens if necessary+do_bol :: Action+do_bol span _str _len = do+        -- See Note [Nested comment line pragmas]+        b <- getBit InNestedCommentBit+        if b then return (L span ITcomment_line_prag) else do+          (pos, gen_semic) <- getOffside+          case pos of+              LT -> do+                  --trace "layout: inserting '}'" $ do+                  popContext+                  -- do NOT pop the lex state, we might have a ';' to insert+                  return (L span ITvccurly)+              EQ | gen_semic -> do+                  --trace "layout: inserting ';'" $ do+                  _ <- popLexState+                  return (L span ITsemi)+              _ -> do+                  _ <- popLexState+                  lexToken++-- certain keywords put us in the "layout" state, where we might+-- add an opening curly brace.+maybe_layout :: Token -> P ()+maybe_layout t = do -- If the alternative layout rule is enabled then+                    -- we never create an implicit layout context here.+                    -- Layout is handled XXX instead.+                    -- The code for closing implicit contexts, or+                    -- inserting implicit semi-colons, is therefore+                    -- irrelevant as it only applies in an implicit+                    -- context.+                    alr <- getBit AlternativeLayoutRuleBit+                    unless alr $ f t+    where f (ITdo _)    = pushLexState layout_do+          f (ITmdo _)   = pushLexState layout_do+          f ITof        = pushLexState layout+          f ITlcase     = pushLexState layout+          f ITlcases    = pushLexState layout+          f ITlet       = pushLexState layout+          f ITwhere     = pushLexState layout+          f ITrec       = pushLexState layout+          f ITif        = pushLexState layout_if+          f _           = return ()++-- Pushing a new implicit layout context.  If the indentation of the+-- next token is not greater than the previous layout context, then+-- Haskell 98 says that the new layout context should be empty; that is+-- the lexer must generate {}.+--+-- We are slightly more lenient than this: when the new context is started+-- by a 'do', then we allow the new context to be at the same indentation as+-- the previous context.  This is what the 'strict' argument is for.+new_layout_context :: Bool -> Bool -> Token -> Action+new_layout_context strict gen_semic tok span _buf len = do+    _ <- popLexState+    (AI l _) <- getInput+    let offset = srcLocCol (psRealLoc l) - len+    ctx <- getContext+    nondecreasing <- getBit NondecreasingIndentationBit+    let strict' = strict || not nondecreasing+    case ctx of+        Layout prev_off _ : _  |+           (strict'     && prev_off >= offset  ||+            not strict' && prev_off > offset) -> do+                -- token is indented to the left of the previous context.+                -- we must generate a {} sequence now.+                pushLexState layout_left+                return (L span tok)+        _ -> do setContext (Layout offset gen_semic : ctx)+                return (L span tok)++do_layout_left :: Action+do_layout_left span _buf _len = do+    _ <- popLexState+    pushLexState bol  -- we must be at the start of a line+    return (L span ITvccurly)++-- -----------------------------------------------------------------------------+-- LINE pragmas++setLineAndFile :: Int -> Action+setLineAndFile code (PsSpan span _) buf len = do+  let src = lexemeToString buf (len - 1)  -- drop trailing quotation mark+      linenumLen = length $ head $ words src+      linenum = parseUnsignedInteger buf linenumLen 10 octDecDigit+      file = mkFastString $ go $ drop 1 $ dropWhile (/= '"') src+          -- skip everything through first quotation mark to get to the filename+        where go ('\\':c:cs) = c : go cs+              go (c:cs)      = c : go cs+              go []          = []+              -- decode escapes in the filename.  e.g. on Windows+              -- when our filenames have backslashes in, gcc seems to+              -- escape the backslashes.  One symptom of not doing this+              -- is that filenames in error messages look a bit strange:+              --   C:\\foo\bar.hs+              -- only the first backslash is doubled, because we apply+              -- System.FilePath.normalise before printing out+              -- filenames and it does not remove duplicate+              -- backslashes after the drive letter (should it?).+  resetAlrLastLoc file+  setSrcLoc (mkRealSrcLoc file (fromIntegral linenum - 1) (srcSpanEndCol span))+      -- subtract one: the line number refers to the *following* line+  addSrcFile file+  _ <- popLexState+  pushLexState code+  lexToken++setColumn :: Action+setColumn (PsSpan span _) buf len = do+  let column =+        case reads (lexemeToString buf len) of+          [(column, _)] -> column+          _ -> error "setColumn: expected integer" -- shouldn't happen+  setSrcLoc (mkRealSrcLoc (srcSpanFile span) (srcSpanEndLine span)+                          (fromIntegral (column :: Integer)))+  _ <- popLexState+  lexToken++alrInitialLoc :: FastString -> RealSrcSpan+alrInitialLoc file = mkRealSrcSpan loc loc+    where -- This is a hack to ensure that the first line in a file+          -- looks like it is after the initial location:+          loc = mkRealSrcLoc file (-1) (-1)++-- -----------------------------------------------------------------------------+-- Options, includes and language pragmas.+++lex_string_prag :: (String -> Token) -> Action+lex_string_prag mkTok = lex_string_prag_comment mkTok'+  where+    mkTok' s _ = mkTok s++lex_string_prag_comment :: (String -> PsSpan -> Token) -> Action+lex_string_prag_comment mkTok span _buf _len+    = do input <- getInput+         start <- getParsedLoc+         l <- getLastLocComment+         tok <- go l [] input+         end <- getParsedLoc+         return (L (mkPsSpan start end) tok)+    where go l acc input+              = if isString input "#-}"+                   then do setInput input+                           return (mkTok (reverse acc) l)+                   else case alexGetChar input of+                          Just (c,i) -> go l (c:acc) i+                          Nothing -> err input+          isString _ [] = True+          isString i (x:xs)+              = case alexGetChar i of+                  Just (c,i') | c == x    -> isString i' xs+                  _other -> False+          err (AI end _) = failLocMsgP (realSrcSpanStart (psRealSpan span))+                                       (psRealLoc end)+                                       (\srcLoc -> mkPlainErrorMsgEnvelope srcLoc $ PsErrLexer LexUnterminatedOptions LexErrKind_EOF)++-- -----------------------------------------------------------------------------+-- Strings & Chars++-- This stuff is horrible.  I hates it.++lex_string_tok :: Action+lex_string_tok span buf _len = do+  tok <- lex_string ""+  (AI end bufEnd) <- getInput+  let+    tok' = case tok of+            ITprimstring _ bs -> ITprimstring (SourceText src) bs+            ITstring _ s -> ITstring (SourceText src) s+            _ -> panic "lex_string_tok"+    src = lexemeToString buf (cur bufEnd - cur buf)+  return (L (mkPsSpan (psSpanStart span) end) tok')++lex_string :: String -> P Token+lex_string s = do+  i <- getInput+  case alexGetChar' i of+    Nothing -> lit_error i++    Just ('"',i)  -> do+        setInput i+        let s' = reverse s+        magicHash <- getBit MagicHashBit+        if magicHash+          then do+            i <- getInput+            case alexGetChar' i of+              Just ('#',i) -> do+                setInput i+                when (any (> '\xFF') s') $ do+                  pState <- getPState+                  let msg = PsErrPrimStringInvalidChar+                  let err = mkPlainErrorMsgEnvelope (mkSrcSpanPs (last_loc pState)) msg+                  addError err+                return (ITprimstring (SourceText s') (unsafeMkByteString s'))+              _other ->+                return (ITstring (SourceText s') (mkFastString s'))+          else+                return (ITstring (SourceText s') (mkFastString s'))++    Just ('\\',i)+        | Just ('&',i) <- next -> do+                setInput i; lex_string s+        | Just (c,i) <- next, c <= '\x7f' && is_space c -> do+                           -- is_space only works for <= '\x7f' (#3751, #5425)+                setInput i; lex_stringgap s+        where next = alexGetChar' i++    Just (c, i1) -> do+        case c of+          '\\' -> do setInput i1; c' <- lex_escape; lex_string (c':s)+          c | isAny c -> do setInput i1; lex_string (c:s)+          _other -> lit_error i++lex_stringgap :: String -> P Token+lex_stringgap s = do+  i <- getInput+  c <- getCharOrFail i+  case c of+    '\\' -> lex_string s+    c | c <= '\x7f' && is_space c -> lex_stringgap s+                           -- is_space only works for <= '\x7f' (#3751, #5425)+    _other -> lit_error i+++lex_char_tok :: Action+-- Here we are basically parsing character literals, such as 'x' or '\n'+-- but we additionally spot 'x and ''T, returning ITsimpleQuote and+-- ITtyQuote respectively, but WITHOUT CONSUMING the x or T part+-- (the parser does that).+-- So we have to do two characters of lookahead: when we see 'x we need to+-- see if there's a trailing quote+lex_char_tok span buf _len = do        -- We've seen '+   i1 <- getInput       -- Look ahead to first character+   let loc = psSpanStart span+   case alexGetChar' i1 of+        Nothing -> lit_error  i1++        Just ('\'', i2@(AI end2 _)) -> do       -- We've seen ''+                   setInput i2+                   return (L (mkPsSpan loc end2)  ITtyQuote)++        Just ('\\', i2@(AI _end2 _)) -> do      -- We've seen 'backslash+                  setInput i2+                  lit_ch <- lex_escape+                  i3 <- getInput+                  mc <- getCharOrFail i3 -- Trailing quote+                  if mc == '\'' then finish_char_tok buf loc lit_ch+                                else lit_error i3++        Just (c, i2@(AI _end2 _))+                | not (isAny c) -> lit_error i1+                | otherwise ->++                -- We've seen 'x, where x is a valid character+                --  (i.e. not newline etc) but not a quote or backslash+           case alexGetChar' i2 of      -- Look ahead one more character+                Just ('\'', i3) -> do   -- We've seen 'x'+                        setInput i3+                        finish_char_tok buf loc c+                _other -> do            -- We've seen 'x not followed by quote+                                        -- (including the possibility of EOF)+                                        -- Just parse the quote only+                        let (AI end _) = i1+                        return (L (mkPsSpan loc end) ITsimpleQuote)++finish_char_tok :: StringBuffer -> PsLoc -> Char -> P (PsLocated Token)+finish_char_tok buf loc ch  -- We've already seen the closing quote+                        -- Just need to check for trailing #+  = do  magicHash <- getBit MagicHashBit+        i@(AI end bufEnd) <- getInput+        let src = lexemeToString buf (cur bufEnd - cur buf)+        if magicHash then do+            case alexGetChar' i of+              Just ('#',i@(AI end _)) -> do+                setInput i+                return (L (mkPsSpan loc end)+                          (ITprimchar (SourceText src) ch))+              _other ->+                return (L (mkPsSpan loc end)+                          (ITchar (SourceText src) ch))+            else do+              return (L (mkPsSpan loc end) (ITchar (SourceText src) ch))++isAny :: Char -> Bool+isAny c | c > '\x7f' = isPrint c+        | otherwise  = is_any c++lex_escape :: P Char+lex_escape = do+  i0 <- getInput+  c <- getCharOrFail i0+  case c of+        'a'   -> return '\a'+        'b'   -> return '\b'+        'f'   -> return '\f'+        'n'   -> return '\n'+        'r'   -> return '\r'+        't'   -> return '\t'+        'v'   -> return '\v'+        '\\'  -> return '\\'+        '"'   -> return '\"'+        '\''  -> return '\''+        '^'   -> do i1 <- getInput+                    c <- getCharOrFail i1+                    if c >= '@' && c <= '_'+                        then return (chr (ord c - ord '@'))+                        else lit_error i1++        'x'   -> readNum is_hexdigit 16 hexDigit+        'o'   -> readNum is_octdigit  8 octDecDigit+        x | is_decdigit x -> readNum2 is_decdigit 10 octDecDigit (octDecDigit x)++        c1 ->  do+           i <- getInput+           case alexGetChar' i of+            Nothing -> lit_error i0+            Just (c2,i2) ->+              case alexGetChar' i2 of+                Nothing -> do lit_error i0+                Just (c3,i3) ->+                   let str = [c1,c2,c3] in+                   case [ (c,rest) | (p,c) <- silly_escape_chars,+                                     Just rest <- [stripPrefix p str] ] of+                          (escape_char,[]):_ -> do+                                setInput i3+                                return escape_char+                          (escape_char,_:_):_ -> do+                                setInput i2+                                return escape_char+                          [] -> lit_error i0++readNum :: (Char -> Bool) -> Int -> (Char -> Int) -> P Char+readNum is_digit base conv = do+  i <- getInput+  c <- getCharOrFail i+  if is_digit c+        then readNum2 is_digit base conv (conv c)+        else lit_error i++readNum2 :: (Char -> Bool) -> Int -> (Char -> Int) -> Int -> P Char+readNum2 is_digit base conv i = do+  input <- getInput+  read i input+  where read i input = do+          case alexGetChar' input of+            Just (c,input') | is_digit c -> do+               let i' = i*base + conv c+               if i' > 0x10ffff+                  then setInput input >> lexError LexNumEscapeRange+                  else read i' input'+            _other -> do+              setInput input; return (chr i)+++silly_escape_chars :: [(String, Char)]+silly_escape_chars = [+        ("NUL", '\NUL'),+        ("SOH", '\SOH'),+        ("STX", '\STX'),+        ("ETX", '\ETX'),+        ("EOT", '\EOT'),+        ("ENQ", '\ENQ'),+        ("ACK", '\ACK'),+        ("BEL", '\BEL'),+        ("BS", '\BS'),+        ("HT", '\HT'),+        ("LF", '\LF'),+        ("VT", '\VT'),+        ("FF", '\FF'),+        ("CR", '\CR'),+        ("SO", '\SO'),+        ("SI", '\SI'),+        ("DLE", '\DLE'),+        ("DC1", '\DC1'),+        ("DC2", '\DC2'),+        ("DC3", '\DC3'),+        ("DC4", '\DC4'),+        ("NAK", '\NAK'),+        ("SYN", '\SYN'),+        ("ETB", '\ETB'),+        ("CAN", '\CAN'),+        ("EM", '\EM'),+        ("SUB", '\SUB'),+        ("ESC", '\ESC'),+        ("FS", '\FS'),+        ("GS", '\GS'),+        ("RS", '\RS'),+        ("US", '\US'),+        ("SP", '\SP'),+        ("DEL", '\DEL')+        ]++-- before calling lit_error, ensure that the current input is pointing to+-- the position of the error in the buffer.  This is so that we can report+-- a correct location to the user, but also so we can detect UTF-8 decoding+-- errors if they occur.+lit_error :: AlexInput -> P a+lit_error i = do setInput i; lexError LexStringCharLit++getCharOrFail :: AlexInput -> P Char+getCharOrFail i =  do+  case alexGetChar' i of+        Nothing -> lexError LexStringCharLitEOF+        Just (c,i)  -> do setInput i; return c++-- -----------------------------------------------------------------------------+-- QuasiQuote++lex_qquasiquote_tok :: Action+lex_qquasiquote_tok span buf len = do+  let (qual, quoter) = splitQualName (stepOn buf) (len - 2) False+  quoteStart <- getParsedLoc+  quote <- lex_quasiquote (psRealLoc quoteStart) ""+  end <- getParsedLoc+  return (L (mkPsSpan (psSpanStart span) end)+           (ITqQuasiQuote (qual,+                           quoter,+                           mkFastString (reverse quote),+                           mkPsSpan quoteStart end)))++lex_quasiquote_tok :: Action+lex_quasiquote_tok span buf len = do+  let quoter = tail (lexemeToString buf (len - 1))+                -- 'tail' drops the initial '[',+                -- while the -1 drops the trailing '|'+  quoteStart <- getParsedLoc+  quote <- lex_quasiquote (psRealLoc quoteStart) ""+  end <- getParsedLoc+  return (L (mkPsSpan (psSpanStart span) end)+           (ITquasiQuote (mkFastString quoter,+                          mkFastString (reverse quote),+                          mkPsSpan quoteStart end)))++lex_quasiquote :: RealSrcLoc -> String -> P String+lex_quasiquote start s = do+  i <- getInput+  case alexGetChar' i of+    Nothing -> quasiquote_error start++    -- NB: The string "|]" terminates the quasiquote,+    -- with absolutely no escaping. See the extensive+    -- discussion on #5348 for why there is no+    -- escape handling.+    Just ('|',i)+        | Just (']',i) <- alexGetChar' i+        -> do { setInput i; return s }++    Just (c, i) -> do+         setInput i; lex_quasiquote start (c : s)++quasiquote_error :: RealSrcLoc -> P a+quasiquote_error start = do+  (AI end buf) <- getInput+  reportLexError start (psRealLoc end) buf+    (\k srcLoc -> mkPlainErrorMsgEnvelope srcLoc (PsErrLexer LexUnterminatedQQ k))++-- -----------------------------------------------------------------------------+-- Warnings++warnTab :: Action+warnTab srcspan _buf _len = do+    addTabWarning (psRealSpan srcspan)+    lexToken++warnThen :: PsMessage -> Action -> Action+warnThen warning action srcspan buf len = do+    addPsMessage (RealSrcSpan (psRealSpan srcspan) Strict.Nothing) warning+    action srcspan buf len++-- -----------------------------------------------------------------------------+-- The Parse Monad++-- | Do we want to generate ';' layout tokens? In some cases we just want to+-- generate '}', e.g. in MultiWayIf we don't need ';'s because '|' separates+-- alternatives (unlike a `case` expression where we need ';' to as a separator+-- between alternatives).+type GenSemic = Bool++generateSemic, dontGenerateSemic :: GenSemic+generateSemic     = True+dontGenerateSemic = False++data LayoutContext+  = NoLayout+  | Layout !Int !GenSemic+  deriving Show++-- | The result of running a parser.+newtype ParseResult a = PR (# (# PState, a #) | PState #)++-- | The parser has consumed a (possibly empty) prefix of the input and produced+-- a result. Use 'getPsMessages' to check for accumulated warnings and non-fatal+-- errors.+--+-- The carried parsing state can be used to resume parsing.+pattern POk :: PState -> a -> ParseResult a+pattern POk s a = PR (# (# s , a #) | #)++-- | The parser has consumed a (possibly empty) prefix of the input and failed.+--+-- The carried parsing state can be used to resume parsing. It is the state+-- right before failure, including the fatal parse error. 'getPsMessages' and+-- 'getPsErrorMessages' must return a non-empty bag of errors.+pattern PFailed :: PState -> ParseResult a+pattern PFailed s = PR (# | s #)++{-# COMPLETE POk, PFailed #-}++-- | Test whether a 'WarningFlag' is set+warnopt :: WarningFlag -> ParserOpts -> Bool+warnopt f options = f `EnumSet.member` pWarningFlags options++-- | Parser options.+--+-- See 'mkParserOpts' to construct this.+data ParserOpts = ParserOpts+  { pExtsBitmap     :: !ExtsBitmap -- ^ bitmap of permitted extensions+  , pDiagOpts       :: !DiagOpts+    -- ^ Options to construct diagnostic messages.+  , pSupportedExts  :: [String]+    -- ^ supported extensions (only used for suggestions in error messages)+  }++pWarningFlags :: ParserOpts -> EnumSet WarningFlag+pWarningFlags opts = diag_warning_flags (pDiagOpts opts)++-- | Haddock comment as produced by the lexer. These are accumulated in 'PState'+-- and then processed in "GHC.Parser.PostProcess.Haddock". The location of the+-- 'HsDocString's spans over the contents of the docstring - i.e. it does not+-- include the decorator ("-- |", "{-|" etc.)+data HdkComment+  = HdkCommentNext HsDocString+  | HdkCommentPrev HsDocString+  | HdkCommentNamed String HsDocString+  | HdkCommentSection Int HsDocString+  deriving Show++data PState = PState {+        buffer     :: StringBuffer,+        options    :: ParserOpts,+        warnings   :: Messages PsMessage,+        errors     :: Messages PsMessage,+        tab_first  :: Strict.Maybe RealSrcSpan, -- pos of first tab warning in the file+        tab_count  :: !Word,             -- number of tab warnings in the file+        last_tk    :: Strict.Maybe (PsLocated Token), -- last non-comment token+        prev_loc   :: PsSpan,      -- pos of previous token, including comments,+        prev_loc2  :: PsSpan,      -- pos of two back token, including comments,+                                   -- see Note [PsSpan in Comments]+        last_loc   :: PsSpan,      -- pos of current token+        last_len   :: !Int,        -- len of current token+        loc        :: PsLoc,       -- current loc (end of prev token + 1)+        context    :: [LayoutContext],+        lex_state  :: [Int],+        srcfiles   :: [FastString],+        -- Used in the alternative layout rule:+        -- These tokens are the next ones to be sent out. They are+        -- just blindly emitted, without the rule looking at them again:+        alr_pending_implicit_tokens :: [PsLocated Token],+        -- This is the next token to be considered or, if it is Nothing,+        -- we need to get the next token from the input stream:+        alr_next_token :: Maybe (PsLocated Token),+        -- This is what we consider to be the location of the last token+        -- emitted:+        alr_last_loc :: PsSpan,+        -- The stack of layout contexts:+        alr_context :: [ALRContext],+        -- Are we expecting a '{'? If it's Just, then the ALRLayout tells+        -- us what sort of layout the '{' will open:+        alr_expecting_ocurly :: Maybe ALRLayout,+        -- Have we just had the '}' for a let block? If so, than an 'in'+        -- token doesn't need to close anything:+        alr_justClosedExplicitLetBlock :: Bool,++        -- The next three are used to implement Annotations giving the+        -- locations of 'noise' tokens in the source, so that users of+        -- the GHC API can do source to source conversions.+        -- See Note [exact print annotations] in GHC.Parser.Annotation+        eof_pos :: Strict.Maybe (Strict.Pair RealSrcSpan RealSrcSpan), -- pos, gap to prior token+        header_comments :: Strict.Maybe [LEpaComment],+        comment_q :: [LEpaComment],++        -- Haddock comments accumulated in ascending order of their location+        -- (BufPos). We use OrdList to get O(1) snoc.+        --+        -- See Note [Adding Haddock comments to the syntax tree] in GHC.Parser.PostProcess.Haddock+        hdk_comments :: OrdList (PsLocated HdkComment)+     }+        -- last_loc and last_len are used when generating error messages,+        -- and in pushCurrentContext only.  Sigh, if only Happy passed the+        -- current token to happyError, we could at least get rid of last_len.+        -- Getting rid of last_loc would require finding another way to+        -- implement pushCurrentContext (which is only called from one place).++        -- AZ question: setLastToken which sets last_loc and last_len+        -- is called whan processing AlexToken, immediately prior to+        -- calling the action in the token.  So from the perspective+        -- of the action, it is the *current* token.  Do I understand+        -- correctly?++data ALRContext = ALRNoLayout Bool{- does it contain commas? -}+                              Bool{- is it a 'let' block? -}+                | ALRLayout ALRLayout Int+data ALRLayout = ALRLayoutLet+               | ALRLayoutWhere+               | ALRLayoutOf+               | ALRLayoutDo++-- | The parsing monad, isomorphic to @StateT PState Maybe@.+newtype P a = P { unP :: PState -> ParseResult a }++instance Functor P where+  fmap = liftM++instance Applicative P where+  pure = returnP+  (<*>) = ap++instance Monad P where+  (>>=) = thenP++returnP :: a -> P a+returnP a = a `seq` (P $ \s -> POk s a)++thenP :: P a -> (a -> P b) -> P b+(P m) `thenP` k = P $ \ s ->+        case m s of+                POk s1 a         -> (unP (k a)) s1+                PFailed s1 -> PFailed s1++failMsgP :: (SrcSpan -> MsgEnvelope PsMessage) -> P a+failMsgP f = do+  pState <- getPState+  addFatalError (f (mkSrcSpanPs (last_loc pState)))++failLocMsgP :: RealSrcLoc -> RealSrcLoc -> (SrcSpan -> MsgEnvelope PsMessage) -> P a+failLocMsgP loc1 loc2 f =+  addFatalError (f (RealSrcSpan (mkRealSrcSpan loc1 loc2) Strict.Nothing))++getPState :: P PState+getPState = P $ \s -> POk s s++getExts :: P ExtsBitmap+getExts = P $ \s -> POk s (pExtsBitmap . options $ s)++setExts :: (ExtsBitmap -> ExtsBitmap) -> P ()+setExts f = P $ \s -> POk s {+  options =+    let p = options s+    in  p { pExtsBitmap = f (pExtsBitmap p) }+  } ()++setSrcLoc :: RealSrcLoc -> P ()+setSrcLoc new_loc =+  P $ \s@(PState{ loc = PsLoc _ buf_loc }) ->+  POk s{ loc = PsLoc new_loc buf_loc } ()++getRealSrcLoc :: P RealSrcLoc+getRealSrcLoc = P $ \s@(PState{ loc=loc }) -> POk s (psRealLoc loc)++getParsedLoc :: P PsLoc+getParsedLoc  = P $ \s@(PState{ loc=loc }) -> POk s loc++addSrcFile :: FastString -> P ()+addSrcFile f = P $ \s -> POk s{ srcfiles = f : srcfiles s } ()++setEofPos :: RealSrcSpan -> RealSrcSpan -> P ()+setEofPos span gap = P $ \s -> POk s{ eof_pos = Strict.Just (span `Strict.And` gap) } ()++setLastToken :: PsSpan -> Int -> P ()+setLastToken loc len = P $ \s -> POk s {+  last_loc=loc,+  last_len=len+  } ()++setLastTk :: PsLocated Token -> P ()+setLastTk tk@(L l _) = P $ \s -> POk s { last_tk = Strict.Just tk+                                       , prev_loc = l+                                       , prev_loc2 = prev_loc s} ()++setLastComment :: PsLocated Token -> P ()+setLastComment (L l _) = P $ \s -> POk s { prev_loc = l+                                         , prev_loc2 = prev_loc s} ()++getLastTk :: P (Strict.Maybe (PsLocated Token))+getLastTk = P $ \s@(PState { last_tk = last_tk }) -> POk s last_tk++-- see Note [PsSpan in Comments]+getLastLocComment :: P PsSpan+getLastLocComment = P $ \s@(PState { prev_loc = prev_loc }) -> POk s prev_loc++-- see Note [PsSpan in Comments]+getLastLocEof :: P PsSpan+getLastLocEof = P $ \s@(PState { prev_loc2 = prev_loc2 }) -> POk s prev_loc2++getLastLoc :: P PsSpan+getLastLoc = P $ \s@(PState { last_loc = last_loc }) -> POk s last_loc++data AlexInput = AI !PsLoc !StringBuffer++{-+Note [Unicode in Alex]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Although newer versions of Alex support unicode, this grammar is processed with+the old style '--latin1' behaviour. This means that when implementing the+functions++    alexGetByte       :: AlexInput -> Maybe (Word8,AlexInput)+    alexInputPrevChar :: AlexInput -> Char++which Alex uses to take apart our 'AlexInput', we must++  * return a latin1 character in the 'Word8' that 'alexGetByte' expects+  * return a latin1 character in 'alexInputPrevChar'.++We handle this in 'adjustChar' by squishing entire classes of unicode+characters into single bytes.+-}++{-# INLINE adjustChar #-}+adjustChar :: Char -> Word8+adjustChar c = fromIntegral $ ord adj_c+  where non_graphic     = '\x00'+        upper           = '\x01'+        lower           = '\x02'+        digit           = '\x03'+        symbol          = '\x04'+        space           = '\x05'+        other_graphic   = '\x06'+        uniidchar       = '\x07'++        adj_c+          | c <= '\x07' = non_graphic+          | c <= '\x7f' = c+          -- Alex doesn't handle Unicode, so when Unicode+          -- character is encountered we output these values+          -- with the actual character value hidden in the state.+          | otherwise =+                -- NB: The logic behind these definitions is also reflected+                -- in "GHC.Utils.Lexeme"+                -- Any changes here should likely be reflected there.++                case generalCategory c of+                  UppercaseLetter       -> upper+                  LowercaseLetter       -> lower+                  TitlecaseLetter       -> upper+                  ModifierLetter        -> uniidchar -- see #10196+                  OtherLetter           -> lower -- see #1103+                  NonSpacingMark        -> uniidchar -- see #7650+                  SpacingCombiningMark  -> other_graphic+                  EnclosingMark         -> other_graphic+                  DecimalNumber         -> digit+                  LetterNumber          -> digit+                  OtherNumber           -> digit -- see #4373+                  ConnectorPunctuation  -> symbol+                  DashPunctuation       -> symbol+                  OpenPunctuation       -> other_graphic+                  ClosePunctuation      -> other_graphic+                  InitialQuote          -> other_graphic+                  FinalQuote            -> other_graphic+                  OtherPunctuation      -> symbol+                  MathSymbol            -> symbol+                  CurrencySymbol        -> symbol+                  ModifierSymbol        -> symbol+                  OtherSymbol           -> symbol+                  Space                 -> space+                  _other                -> non_graphic++-- Getting the previous 'Char' isn't enough here - we need to convert it into+-- the same format that 'alexGetByte' would have produced.+--+-- See Note [Unicode in Alex] and #13986.+alexInputPrevChar :: AlexInput -> Char+alexInputPrevChar (AI _ buf) = chr (fromIntegral (adjustChar pc))+  where pc = prevChar buf '\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++-- See Note [Unicode in Alex]+alexGetByte :: AlexInput -> Maybe (Word8,AlexInput)+alexGetByte (AI loc s)+  | atEnd s   = Nothing+  | otherwise = byte `seq` loc' `seq` s' `seq`+                --trace (show (ord c)) $+                Just (byte, (AI loc' s'))+  where (c,s') = nextChar s+        loc'   = advancePsLoc loc c+        byte   = adjustChar c++{-# INLINE alexGetChar' #-}+-- This version does not squash unicode characters, it is used when+-- lexing strings.+alexGetChar' :: AlexInput -> Maybe (Char,AlexInput)+alexGetChar' (AI loc s)+  | atEnd s   = Nothing+  | otherwise = c `seq` loc' `seq` s' `seq`+                --trace (show (ord c)) $+                Just (c, (AI loc' s'))+  where (c,s') = nextChar s+        loc'   = advancePsLoc loc c++getInput :: P AlexInput+getInput = P $ \s@PState{ loc=l, buffer=b } -> POk s (AI l b)++setInput :: AlexInput -> P ()+setInput (AI l b) = P $ \s -> POk s{ loc=l, buffer=b } ()++nextIsEOF :: P Bool+nextIsEOF = do+  AI _ s <- getInput+  return $ atEnd s++pushLexState :: Int -> P ()+pushLexState ls = P $ \s@PState{ lex_state=l } -> POk s{lex_state=ls:l} ()++popLexState :: P Int+popLexState = P $ \s@PState{ lex_state=ls:l } -> POk s{ lex_state=l } ls++getLexState :: P Int+getLexState = P $ \s@PState{ lex_state=ls:_ } -> POk s ls++popNextToken :: P (Maybe (PsLocated Token))+popNextToken+    = P $ \s@PState{ alr_next_token = m } ->+              POk (s {alr_next_token = Nothing}) m++activeContext :: P Bool+activeContext = do+  ctxt <- getALRContext+  expc <- getAlrExpectingOCurly+  impt <- implicitTokenPending+  case (ctxt,expc) of+    ([],Nothing) -> return impt+    _other       -> return True++resetAlrLastLoc :: FastString -> P ()+resetAlrLastLoc file =+  P $ \s@(PState {alr_last_loc = PsSpan _ buf_span}) ->+  POk s{ alr_last_loc = PsSpan (alrInitialLoc file) buf_span } ()++setAlrLastLoc :: PsSpan -> P ()+setAlrLastLoc l = P $ \s -> POk (s {alr_last_loc = l}) ()++getAlrLastLoc :: P PsSpan+getAlrLastLoc = P $ \s@(PState {alr_last_loc = l}) -> POk s l++getALRContext :: P [ALRContext]+getALRContext = P $ \s@(PState {alr_context = cs}) -> POk s cs++setALRContext :: [ALRContext] -> P ()+setALRContext cs = P $ \s -> POk (s {alr_context = cs}) ()++getJustClosedExplicitLetBlock :: P Bool+getJustClosedExplicitLetBlock+ = P $ \s@(PState {alr_justClosedExplicitLetBlock = b}) -> POk s b++setJustClosedExplicitLetBlock :: Bool -> P ()+setJustClosedExplicitLetBlock b+ = P $ \s -> POk (s {alr_justClosedExplicitLetBlock = b}) ()++setNextToken :: PsLocated Token -> P ()+setNextToken t = P $ \s -> POk (s {alr_next_token = Just t}) ()++implicitTokenPending :: P Bool+implicitTokenPending+    = P $ \s@PState{ alr_pending_implicit_tokens = ts } ->+              case ts of+              [] -> POk s False+              _  -> POk s True++popPendingImplicitToken :: P (Maybe (PsLocated Token))+popPendingImplicitToken+    = P $ \s@PState{ alr_pending_implicit_tokens = ts } ->+              case ts of+              [] -> POk s Nothing+              (t : ts') -> POk (s {alr_pending_implicit_tokens = ts'}) (Just t)++setPendingImplicitTokens :: [PsLocated Token] -> P ()+setPendingImplicitTokens ts = P $ \s -> POk (s {alr_pending_implicit_tokens = ts}) ()++getAlrExpectingOCurly :: P (Maybe ALRLayout)+getAlrExpectingOCurly = P $ \s@(PState {alr_expecting_ocurly = b}) -> POk s b++setAlrExpectingOCurly :: Maybe ALRLayout -> P ()+setAlrExpectingOCurly b = P $ \s -> POk (s {alr_expecting_ocurly = b}) ()++-- | For reasons of efficiency, boolean parsing flags (eg, language extensions+-- or whether we are currently in a @RULE@ pragma) are represented by a bitmap+-- stored in a @Word64@.+type ExtsBitmap = Word64++xbit :: ExtBits -> ExtsBitmap+xbit = bit . fromEnum++xtest :: ExtBits -> ExtsBitmap -> Bool+xtest ext xmap = testBit xmap (fromEnum ext)++xset :: ExtBits -> ExtsBitmap -> ExtsBitmap+xset ext xmap = setBit xmap (fromEnum ext)++xunset :: ExtBits -> ExtsBitmap -> ExtsBitmap+xunset ext xmap = clearBit xmap (fromEnum ext)++-- | Various boolean flags, mostly language extensions, that impact lexing and+-- parsing. Note that a handful of these can change during lexing/parsing.+data ExtBits+  -- Flags that are constant once parsing starts+  = FfiBit+  | InterruptibleFfiBit+  | CApiFfiBit+  | ArrowsBit+  | ThBit+  | ThQuotesBit+  | IpBit+  | OverloadedLabelsBit -- #x overloaded labels+  | ExplicitForallBit -- the 'forall' keyword+  | BangPatBit -- Tells the parser to understand bang-patterns+               -- (doesn't affect the lexer)+  | PatternSynonymsBit -- pattern synonyms+  | HaddockBit-- Lex and parse Haddock comments+  | MagicHashBit -- "#" in both functions and operators+  | RecursiveDoBit -- mdo+  | QualifiedDoBit -- .do and .mdo+  | UnicodeSyntaxBit -- the forall symbol, arrow symbols, etc+  | UnboxedParensBit -- (# and #)+  | DatatypeContextsBit+  | MonadComprehensionsBit+  | TransformComprehensionsBit+  | QqBit -- enable quasiquoting+  | RawTokenStreamBit -- producing a token stream with all comments included+  | AlternativeLayoutRuleBit+  | ALRTransitionalBit+  | RelaxedLayoutBit+  | NondecreasingIndentationBit+  | SafeHaskellBit+  | TraditionalRecordSyntaxBit+  | ExplicitNamespacesBit+  | LambdaCaseBit+  | BinaryLiteralsBit+  | NegativeLiteralsBit+  | HexFloatLiteralsBit+  | StaticPointersBit+  | NumericUnderscoresBit+  | StarIsTypeBit+  | BlockArgumentsBit+  | NPlusKPatternsBit+  | DoAndIfThenElseBit+  | MultiWayIfBit+  | GadtSyntaxBit+  | ImportQualifiedPostBit+  | LinearTypesBit+  | NoLexicalNegationBit   -- See Note [Why not LexicalNegationBit]+  | OverloadedRecordDotBit+  | OverloadedRecordUpdateBit++  -- Flags that are updated once parsing starts+  | InRulePragBit+  | InNestedCommentBit -- See Note [Nested comment line pragmas]+  | UsePosPragsBit+    -- ^ If this is enabled, '{-# LINE ... -#}' and '{-# COLUMN ... #-}'+    -- update the internal position. Otherwise, those pragmas are lexed as+    -- tokens of their own.+  deriving Enum++{-# INLINE mkParserOpts #-}+mkParserOpts+  :: EnumSet LangExt.Extension  -- ^ permitted language extensions enabled+  -> DiagOpts                   -- ^ diagnostic options+  -> [String]                   -- ^ Supported Languages and Extensions+  -> Bool                       -- ^ are safe imports on?+  -> Bool                       -- ^ keeping Haddock comment tokens+  -> Bool                       -- ^ keep regular comment tokens++  -> Bool+  -- ^ If this is enabled, '{-# LINE ... -#}' and '{-# COLUMN ... #-}' update+  -- the internal position kept by the parser. Otherwise, those pragmas are+  -- lexed as 'ITline_prag' and 'ITcolumn_prag' tokens.++  -> ParserOpts+-- ^ Given exactly the information needed, set up the 'ParserOpts'+mkParserOpts extensionFlags diag_opts supported+  safeImports isHaddock rawTokStream usePosPrags =+    ParserOpts {+      pDiagOpts      = diag_opts+    , pExtsBitmap    = safeHaskellBit .|. langExtBits .|. optBits+    , pSupportedExts = supported+    }+  where+    safeHaskellBit = SafeHaskellBit `setBitIf` safeImports+    langExtBits =+          FfiBit                      `xoptBit` LangExt.ForeignFunctionInterface+      .|. InterruptibleFfiBit         `xoptBit` LangExt.InterruptibleFFI+      .|. CApiFfiBit                  `xoptBit` LangExt.CApiFFI+      .|. ArrowsBit                   `xoptBit` LangExt.Arrows+      .|. ThBit                       `xoptBit` LangExt.TemplateHaskell+      .|. ThQuotesBit                 `xoptBit` LangExt.TemplateHaskellQuotes+      .|. QqBit                       `xoptBit` LangExt.QuasiQuotes+      .|. IpBit                       `xoptBit` LangExt.ImplicitParams+      .|. OverloadedLabelsBit         `xoptBit` LangExt.OverloadedLabels+      .|. ExplicitForallBit           `xoptBit` LangExt.ExplicitForAll+      .|. BangPatBit                  `xoptBit` LangExt.BangPatterns+      .|. MagicHashBit                `xoptBit` LangExt.MagicHash+      .|. RecursiveDoBit              `xoptBit` LangExt.RecursiveDo+      .|. QualifiedDoBit              `xoptBit` LangExt.QualifiedDo+      .|. UnicodeSyntaxBit            `xoptBit` LangExt.UnicodeSyntax+      .|. UnboxedParensBit            `orXoptsBit` [LangExt.UnboxedTuples, LangExt.UnboxedSums]+      .|. DatatypeContextsBit         `xoptBit` LangExt.DatatypeContexts+      .|. TransformComprehensionsBit  `xoptBit` LangExt.TransformListComp+      .|. MonadComprehensionsBit      `xoptBit` LangExt.MonadComprehensions+      .|. AlternativeLayoutRuleBit    `xoptBit` LangExt.AlternativeLayoutRule+      .|. ALRTransitionalBit          `xoptBit` LangExt.AlternativeLayoutRuleTransitional+      .|. RelaxedLayoutBit            `xoptBit` LangExt.RelaxedLayout+      .|. NondecreasingIndentationBit `xoptBit` LangExt.NondecreasingIndentation+      .|. TraditionalRecordSyntaxBit  `xoptBit` LangExt.TraditionalRecordSyntax+      .|. ExplicitNamespacesBit       `xoptBit` LangExt.ExplicitNamespaces+      .|. LambdaCaseBit               `xoptBit` LangExt.LambdaCase+      .|. BinaryLiteralsBit           `xoptBit` LangExt.BinaryLiterals+      .|. NegativeLiteralsBit         `xoptBit` LangExt.NegativeLiterals+      .|. HexFloatLiteralsBit         `xoptBit` LangExt.HexFloatLiterals+      .|. PatternSynonymsBit          `xoptBit` LangExt.PatternSynonyms+      .|. StaticPointersBit           `xoptBit` LangExt.StaticPointers+      .|. NumericUnderscoresBit       `xoptBit` LangExt.NumericUnderscores+      .|. StarIsTypeBit               `xoptBit` LangExt.StarIsType+      .|. BlockArgumentsBit           `xoptBit` LangExt.BlockArguments+      .|. NPlusKPatternsBit           `xoptBit` LangExt.NPlusKPatterns+      .|. DoAndIfThenElseBit          `xoptBit` LangExt.DoAndIfThenElse+      .|. MultiWayIfBit               `xoptBit` LangExt.MultiWayIf+      .|. GadtSyntaxBit               `xoptBit` LangExt.GADTSyntax+      .|. ImportQualifiedPostBit      `xoptBit` LangExt.ImportQualifiedPost+      .|. LinearTypesBit              `xoptBit` LangExt.LinearTypes+      .|. NoLexicalNegationBit        `xoptNotBit` LangExt.LexicalNegation -- See Note [Why not LexicalNegationBit]+      .|. OverloadedRecordDotBit      `xoptBit` LangExt.OverloadedRecordDot+      .|. OverloadedRecordUpdateBit   `xoptBit` LangExt.OverloadedRecordUpdate  -- Enable testing via 'getBit OverloadedRecordUpdateBit' in the parser (RecordDotSyntax parsing uses that information).+    optBits =+          HaddockBit        `setBitIf` isHaddock+      .|. RawTokenStreamBit `setBitIf` rawTokStream+      .|. UsePosPragsBit    `setBitIf` usePosPrags++    xoptBit bit ext = bit `setBitIf` EnumSet.member ext extensionFlags+    xoptNotBit bit ext = bit `setBitIf` not (EnumSet.member ext extensionFlags)++    orXoptsBit bit exts = bit `setBitIf` any (`EnumSet.member` extensionFlags) exts++    setBitIf :: ExtBits -> Bool -> ExtsBitmap+    b `setBitIf` cond | cond      = xbit b+                      | otherwise = 0++disableHaddock :: ParserOpts -> ParserOpts+disableHaddock opts = upd_bitmap (xunset HaddockBit)+  where+    upd_bitmap f = opts { pExtsBitmap = f (pExtsBitmap opts) }+++-- | Set parser options for parsing OPTIONS pragmas+initPragState :: ParserOpts -> StringBuffer -> RealSrcLoc -> PState+initPragState options buf loc = (initParserState options buf loc)+   { lex_state = [bol, option_prags, 0]+   }++-- | Creates a parse state from a 'ParserOpts' value+initParserState :: ParserOpts -> StringBuffer -> RealSrcLoc -> PState+initParserState options buf loc =+  PState {+      buffer        = buf,+      options       = options,+      errors        = emptyMessages,+      warnings      = emptyMessages,+      tab_first     = Strict.Nothing,+      tab_count     = 0,+      last_tk       = Strict.Nothing,+      prev_loc      = mkPsSpan init_loc init_loc,+      prev_loc2     = mkPsSpan init_loc init_loc,+      last_loc      = mkPsSpan init_loc init_loc,+      last_len      = 0,+      loc           = init_loc,+      context       = [],+      lex_state     = [bol, 0],+      srcfiles      = [],+      alr_pending_implicit_tokens = [],+      alr_next_token = Nothing,+      alr_last_loc = PsSpan (alrInitialLoc (fsLit "<no file>")) (BufSpan (BufPos 0) (BufPos 0)),+      alr_context = [],+      alr_expecting_ocurly = Nothing,+      alr_justClosedExplicitLetBlock = False,+      eof_pos = Strict.Nothing,+      header_comments = Strict.Nothing,+      comment_q = [],+      hdk_comments = nilOL+    }+  where init_loc = PsLoc loc (BufPos 0)++-- | An mtl-style class for monads that support parsing-related operations.+-- For example, sometimes we make a second pass over the parsing results to validate,+-- disambiguate, or rearrange them, and we do so in the PV monad which cannot consume+-- input but can report parsing errors, check for extension bits, and accumulate+-- parsing annotations. Both P and PV are instances of MonadP.+--+-- MonadP grants us convenient overloading. The other option is to have separate operations+-- for each monad: addErrorP vs addErrorPV, getBitP vs getBitPV, and so on.+--+class Monad m => MonadP m where+  -- | Add a non-fatal error. Use this when the parser can produce a result+  --   despite the error.+  --+  --   For example, when GHC encounters a @forall@ in a type,+  --   but @-XExplicitForAll@ is disabled, the parser constructs @ForAllTy@+  --   as if @-XExplicitForAll@ was enabled, adding a non-fatal error to+  --   the accumulator.+  --+  --   Control flow wise, non-fatal errors act like warnings: they are added+  --   to the accumulator and parsing continues. This allows GHC to report+  --   more than one parse error per file.+  --+  addError :: MsgEnvelope PsMessage -> m ()++  -- | Add a warning to the accumulator.+  --   Use 'getPsMessages' to get the accumulated warnings.+  addWarning :: MsgEnvelope PsMessage -> m ()++  -- | Add a fatal error. This will be the last error reported by the parser, and+  --   the parser will not produce any result, ending in a 'PFailed' state.+  addFatalError :: MsgEnvelope PsMessage -> m a++  -- | Check if a given flag is currently set in the bitmap.+  getBit :: ExtBits -> m Bool+  -- | Go through the @comment_q@ in @PState@ and remove all comments+  -- that belong within the given span+  allocateCommentsP :: RealSrcSpan -> m EpAnnComments+  -- | Go through the @comment_q@ in @PState@ and remove all comments+  -- that come before or within the given span+  allocatePriorCommentsP :: RealSrcSpan -> m EpAnnComments+  -- | Go through the @comment_q@ in @PState@ and remove all comments+  -- that come after the given span+  allocateFinalCommentsP :: RealSrcSpan -> m EpAnnComments++instance MonadP P where+  addError err+   = P $ \s -> POk s { errors = err `addMessage` errors s} ()++  -- If the warning is meant to be suppressed, GHC will assign+  -- a `SevIgnore` severity and the message will be discarded,+  -- so we can simply add it no matter what.+  addWarning w+   = P $ \s -> POk (s { warnings = w `addMessage` warnings s }) ()++  addFatalError err =+    addError err >> P PFailed++  getBit ext = P $ \s -> let b =  ext `xtest` pExtsBitmap (options s)+                         in b `seq` POk s b+  allocateCommentsP ss = P $ \s ->+    let (comment_q', newAnns) = allocateComments ss (comment_q s) in+      POk s {+         comment_q = comment_q'+       } (EpaComments newAnns)+  allocatePriorCommentsP ss = P $ \s ->+    let (header_comments', comment_q', newAnns)+             = allocatePriorComments ss (comment_q s) (header_comments s) in+      POk s {+         header_comments = header_comments',+         comment_q = comment_q'+       } (EpaComments newAnns)+  allocateFinalCommentsP ss = P $ \s ->+    let (header_comments', comment_q', newAnns)+             = allocateFinalComments ss (comment_q s) (header_comments s) in+      POk s {+         header_comments = header_comments',+         comment_q = comment_q'+       } (EpaCommentsBalanced (Strict.fromMaybe [] header_comments') newAnns)++getCommentsFor :: (MonadP m) => SrcSpan -> m EpAnnComments+getCommentsFor (RealSrcSpan l _) = allocateCommentsP l+getCommentsFor _ = return emptyComments++getPriorCommentsFor :: (MonadP m) => SrcSpan -> m EpAnnComments+getPriorCommentsFor (RealSrcSpan l _) = allocatePriorCommentsP l+getPriorCommentsFor _ = return emptyComments++getFinalCommentsFor :: (MonadP m) => SrcSpan -> m EpAnnComments+getFinalCommentsFor (RealSrcSpan l _) = allocateFinalCommentsP l+getFinalCommentsFor _ = return emptyComments++getEofPos :: P (Strict.Maybe (Strict.Pair RealSrcSpan RealSrcSpan))+getEofPos = P $ \s@(PState { eof_pos = pos }) -> POk s pos++addPsMessage :: SrcSpan -> PsMessage -> P ()+addPsMessage srcspan msg = do+  diag_opts <- (pDiagOpts . options) <$> getPState+  addWarning (mkPlainMsgEnvelope diag_opts srcspan msg)++addTabWarning :: RealSrcSpan -> P ()+addTabWarning srcspan+ = P $ \s@PState{tab_first=tf, tab_count=tc, options=o} ->+       let tf' = tf <|> Strict.Just srcspan+           tc' = tc + 1+           s' = if warnopt Opt_WarnTabs o+                then s{tab_first = tf', tab_count = tc'}+                else s+       in POk s' ()++-- | Get a bag of the errors that have been accumulated so far.+--   Does not take -Werror into account.+getPsErrorMessages :: PState -> Messages PsMessage+getPsErrorMessages p = errors p++-- | Get the warnings and errors accumulated so far.+--   Does not take -Werror into account.+getPsMessages :: PState -> (Messages PsMessage, Messages PsMessage)+getPsMessages p =+  let ws = warnings p+      diag_opts = pDiagOpts (options p)+      -- we add the tabulation warning on the fly because+      -- we count the number of occurrences of tab characters+      ws' = case tab_first p of+        Strict.Nothing -> ws+        Strict.Just tf ->+          let msg = mkPlainMsgEnvelope diag_opts+                          (RealSrcSpan tf Strict.Nothing)+                          (PsWarnTab (tab_count p))+          in msg `addMessage` ws+  in (ws', errors p)++getContext :: P [LayoutContext]+getContext = P $ \s@PState{context=ctx} -> POk s ctx++setContext :: [LayoutContext] -> P ()+setContext ctx = P $ \s -> POk s{context=ctx} ()++popContext :: P ()+popContext = P $ \ s@(PState{ buffer = buf, options = o, context = ctx,+                              last_len = len, last_loc = last_loc }) ->+  case ctx of+        (_:tl) ->+          POk s{ context = tl } ()+        []     ->+          unP (addFatalError $ srcParseErr o buf len (mkSrcSpanPs last_loc)) s++-- Push a new layout context at the indentation of the last token read.+pushCurrentContext :: GenSemic -> P ()+pushCurrentContext gen_semic = P $ \ s@PState{ last_loc=loc, context=ctx } ->+    POk s{context = Layout (srcSpanStartCol (psRealSpan loc)) gen_semic : ctx} ()++-- This is only used at the outer level of a module when the 'module' keyword is+-- missing.+pushModuleContext :: P ()+pushModuleContext = pushCurrentContext generateSemic++getOffside :: P (Ordering, Bool)+getOffside = P $ \s@PState{last_loc=loc, context=stk} ->+                let offs = srcSpanStartCol (psRealSpan loc) in+                let ord = case stk of+                            Layout n gen_semic : _ ->+                              --trace ("layout: " ++ show n ++ ", offs: " ++ show offs) $+                              (compare offs n, gen_semic)+                            _ ->+                              (GT, dontGenerateSemic)+                in POk s ord++-- ---------------------------------------------------------------------------+-- Construct a parse error++srcParseErr+  :: ParserOpts+  -> StringBuffer       -- current buffer (placed just after the last token)+  -> Int                -- length of the previous token+  -> SrcSpan+  -> MsgEnvelope PsMessage+srcParseErr options buf len loc = mkPlainErrorMsgEnvelope loc (PsErrParse token details)+  where+   token = lexemeToString (offsetBytes (-len) buf) len+   pattern_ = decodePrevNChars 8 buf+   last100 = decodePrevNChars 100 buf+   doInLast100 = "do" `isInfixOf` last100+   mdoInLast100 = "mdo" `isInfixOf` last100+   th_enabled = ThQuotesBit `xtest` pExtsBitmap options+   ps_enabled = PatternSynonymsBit `xtest` pExtsBitmap options+   details = PsErrParseDetails {+       ped_th_enabled      = th_enabled+     , ped_do_in_last_100  = doInLast100+     , ped_mdo_in_last_100 = mdoInLast100+     , ped_pat_syn_enabled = ps_enabled+     , ped_pattern_parsed  = pattern_ == "pattern "+     }++-- Report a parse failure, giving the span of the previous token as+-- the location of the error.  This is the entry point for errors+-- detected during parsing.+srcParseFail :: P a+srcParseFail = P $ \s@PState{ buffer = buf, options = o, last_len = len,+                            last_loc = last_loc } ->+    unP (addFatalError $ srcParseErr o buf len (mkSrcSpanPs last_loc)) s++-- A lexical error is reported at a particular position in the source file,+-- not over a token range.+lexError :: LexErr -> P a+lexError e = do+  loc <- getRealSrcLoc+  (AI end buf) <- getInput+  reportLexError loc (psRealLoc end) buf+    (\k srcLoc -> mkPlainErrorMsgEnvelope srcLoc $ PsErrLexer e k)++-- -----------------------------------------------------------------------------+-- This is the top-level function: called from the parser each time a+-- new token is to be read from the input.++lexer, lexerDbg :: Bool -> (Located Token -> P a) -> P a++lexer queueComments cont = do+  alr <- getBit AlternativeLayoutRuleBit+  let lexTokenFun = if alr then lexTokenAlr else lexToken+  (L span tok) <- lexTokenFun+  --trace ("token: " ++ show tok) $ do++  if (queueComments && isComment tok)+    then queueComment (L (psRealSpan span) tok) >> lexer queueComments cont+    else cont (L (mkSrcSpanPs span) tok)++-- Use this instead of 'lexer' in GHC.Parser to dump the tokens for debugging.+lexerDbg queueComments cont = lexer queueComments contDbg+  where+    contDbg tok = trace ("token: " ++ show (unLoc tok)) (cont tok)++lexTokenAlr :: P (PsLocated Token)+lexTokenAlr = do mPending <- popPendingImplicitToken+                 t <- case mPending of+                      Nothing ->+                          do mNext <- popNextToken+                             t <- case mNext of+                                  Nothing -> lexToken+                                  Just next -> return next+                             alternativeLayoutRuleToken t+                      Just t ->+                          return t+                 setAlrLastLoc (getLoc t)+                 case unLoc t of+                     ITwhere  -> setAlrExpectingOCurly (Just ALRLayoutWhere)+                     ITlet    -> setAlrExpectingOCurly (Just ALRLayoutLet)+                     ITof     -> setAlrExpectingOCurly (Just ALRLayoutOf)+                     ITlcase  -> setAlrExpectingOCurly (Just ALRLayoutOf)+                     ITlcases -> setAlrExpectingOCurly (Just ALRLayoutOf)+                     ITdo  _  -> setAlrExpectingOCurly (Just ALRLayoutDo)+                     ITmdo _  -> setAlrExpectingOCurly (Just ALRLayoutDo)+                     ITrec    -> setAlrExpectingOCurly (Just ALRLayoutDo)+                     _        -> return ()+                 return t++alternativeLayoutRuleToken :: PsLocated Token -> P (PsLocated Token)+alternativeLayoutRuleToken t+    = do context <- getALRContext+         lastLoc <- getAlrLastLoc+         mExpectingOCurly <- getAlrExpectingOCurly+         transitional <- getBit ALRTransitionalBit+         justClosedExplicitLetBlock <- getJustClosedExplicitLetBlock+         setJustClosedExplicitLetBlock False+         let thisLoc = getLoc t+             thisCol = srcSpanStartCol (psRealSpan thisLoc)+             newLine = srcSpanStartLine (psRealSpan thisLoc) > srcSpanEndLine (psRealSpan lastLoc)+         case (unLoc t, context, mExpectingOCurly) of+             -- This case handles a GHC extension to the original H98+             -- layout rule...+             (ITocurly, _, Just alrLayout) ->+                 do setAlrExpectingOCurly Nothing+                    let isLet = case alrLayout of+                                ALRLayoutLet -> True+                                _ -> False+                    setALRContext (ALRNoLayout (containsCommas ITocurly) isLet : context)+                    return t+             -- ...and makes this case unnecessary+             {-+             -- I think our implicit open-curly handling is slightly+             -- different to John's, in how it interacts with newlines+             -- and "in"+             (ITocurly, _, Just _) ->+                 do setAlrExpectingOCurly Nothing+                    setNextToken t+                    lexTokenAlr+             -}+             (_, ALRLayout _ col : _ls, Just expectingOCurly)+              | (thisCol > col) ||+                (thisCol == col &&+                 isNonDecreasingIndentation expectingOCurly) ->+                 do setAlrExpectingOCurly Nothing+                    setALRContext (ALRLayout expectingOCurly thisCol : context)+                    setNextToken t+                    return (L thisLoc ITvocurly)+              | otherwise ->+                 do setAlrExpectingOCurly Nothing+                    setPendingImplicitTokens [L lastLoc ITvccurly]+                    setNextToken t+                    return (L lastLoc ITvocurly)+             (_, _, Just expectingOCurly) ->+                 do setAlrExpectingOCurly Nothing+                    setALRContext (ALRLayout expectingOCurly thisCol : context)+                    setNextToken t+                    return (L thisLoc ITvocurly)+             -- We do the [] cases earlier than in the spec, as we+             -- have an actual EOF token+             (ITeof, ALRLayout _ _ : ls, _) ->+                 do setALRContext ls+                    setNextToken t+                    return (L thisLoc ITvccurly)+             (ITeof, _, _) ->+                 return t+             -- the other ITeof case omitted; general case below covers it+             (ITin, _, _)+              | justClosedExplicitLetBlock ->+                 return t+             (ITin, ALRLayout ALRLayoutLet _ : ls, _)+              | newLine ->+                 do setPendingImplicitTokens [t]+                    setALRContext ls+                    return (L thisLoc ITvccurly)+             -- This next case is to handle a transitional issue:+             (ITwhere, ALRLayout _ col : ls, _)+              | newLine && thisCol == col && transitional ->+                 do addPsMessage+                      (mkSrcSpanPs thisLoc)+                      (PsWarnTransitionalLayout TransLayout_Where)+                    setALRContext ls+                    setNextToken t+                    -- Note that we use lastLoc, as we may need to close+                    -- more layouts, or give a semicolon+                    return (L lastLoc ITvccurly)+             -- This next case is to handle a transitional issue:+             (ITvbar, ALRLayout _ col : ls, _)+              | newLine && thisCol == col && transitional ->+                 do addPsMessage+                      (mkSrcSpanPs thisLoc)+                      (PsWarnTransitionalLayout TransLayout_Pipe)+                    setALRContext ls+                    setNextToken t+                    -- Note that we use lastLoc, as we may need to close+                    -- more layouts, or give a semicolon+                    return (L lastLoc ITvccurly)+             (_, ALRLayout _ col : ls, _)+              | newLine && thisCol == col ->+                 do setNextToken t+                    let loc = psSpanStart thisLoc+                        zeroWidthLoc = mkPsSpan loc loc+                    return (L zeroWidthLoc ITsemi)+              | newLine && thisCol < col ->+                 do setALRContext ls+                    setNextToken t+                    -- Note that we use lastLoc, as we may need to close+                    -- more layouts, or give a semicolon+                    return (L lastLoc ITvccurly)+             -- We need to handle close before open, as 'then' is both+             -- an open and a close+             (u, _, _)+              | isALRclose u ->+                 case context of+                 ALRLayout _ _ : ls ->+                     do setALRContext ls+                        setNextToken t+                        return (L thisLoc ITvccurly)+                 ALRNoLayout _ isLet : ls ->+                     do let ls' = if isALRopen u+                                     then ALRNoLayout (containsCommas u) False : ls+                                     else ls+                        setALRContext ls'+                        when isLet $ setJustClosedExplicitLetBlock True+                        return t+                 [] ->+                     do let ls = if isALRopen u+                                    then [ALRNoLayout (containsCommas u) False]+                                    else []+                        setALRContext ls+                        -- XXX This is an error in John's code, but+                        -- it looks reachable to me at first glance+                        return t+             (u, _, _)+              | isALRopen u ->+                 do setALRContext (ALRNoLayout (containsCommas u) False : context)+                    return t+             (ITin, ALRLayout ALRLayoutLet _ : ls, _) ->+                 do setALRContext ls+                    setPendingImplicitTokens [t]+                    return (L thisLoc ITvccurly)+             (ITin, ALRLayout _ _ : ls, _) ->+                 do setALRContext ls+                    setNextToken t+                    return (L thisLoc ITvccurly)+             -- the other ITin case omitted; general case below covers it+             (ITcomma, ALRLayout _ _ : ls, _)+              | topNoLayoutContainsCommas ls ->+                 do setALRContext ls+                    setNextToken t+                    return (L thisLoc ITvccurly)+             (ITwhere, ALRLayout ALRLayoutDo _ : ls, _) ->+                 do setALRContext ls+                    setPendingImplicitTokens [t]+                    return (L thisLoc ITvccurly)+             -- the other ITwhere case omitted; general case below covers it+             (_, _, _) -> return t++isALRopen :: Token -> Bool+isALRopen ITcase          = True+isALRopen ITif            = True+isALRopen ITthen          = True+isALRopen IToparen        = True+isALRopen ITobrack        = True+isALRopen ITocurly        = True+-- GHC Extensions:+isALRopen IToubxparen     = True+isALRopen _               = False++isALRclose :: Token -> Bool+isALRclose ITof     = True+isALRclose ITthen   = True+isALRclose ITelse   = True+isALRclose ITcparen = True+isALRclose ITcbrack = True+isALRclose ITccurly = True+-- GHC Extensions:+isALRclose ITcubxparen = True+isALRclose _        = False++isNonDecreasingIndentation :: ALRLayout -> Bool+isNonDecreasingIndentation ALRLayoutDo = True+isNonDecreasingIndentation _           = False++containsCommas :: Token -> Bool+containsCommas IToparen = True+containsCommas ITobrack = True+-- John doesn't have {} as containing commas, but records contain them,+-- which caused a problem parsing Cabal's Distribution.Simple.InstallDirs+-- (defaultInstallDirs).+containsCommas ITocurly = True+-- GHC Extensions:+containsCommas IToubxparen = True+containsCommas _        = False++topNoLayoutContainsCommas :: [ALRContext] -> Bool+topNoLayoutContainsCommas [] = False+topNoLayoutContainsCommas (ALRLayout _ _ : ls) = topNoLayoutContainsCommas ls+topNoLayoutContainsCommas (ALRNoLayout b _ : _) = b++lexToken :: P (PsLocated Token)+lexToken = do+  inp@(AI loc1 buf) <- getInput+  sc <- getLexState+  exts <- getExts+  case alexScanUser exts inp sc of+    AlexEOF -> do+        let span = mkPsSpan loc1 loc1+        lt <- getLastLocEof+        setEofPos (psRealSpan span) (psRealSpan lt)+        setLastToken span 0+        return (L span ITeof)+    AlexError (AI loc2 buf) ->+        reportLexError (psRealLoc loc1) (psRealLoc loc2) buf+          (\k srcLoc -> mkPlainErrorMsgEnvelope srcLoc $ PsErrLexer LexError k)+    AlexSkip inp2 _ -> do+        setInput inp2+        lexToken+    AlexToken inp2@(AI end buf2) _ t -> do+        setInput inp2+        let span = mkPsSpan loc1 end+        let bytes = byteDiff buf buf2+        span `seq` setLastToken span bytes+        lt <- t span buf bytes+        let lt' = unLoc lt+        if (isComment lt') then setLastComment lt else setLastTk lt+        return lt++reportLexError :: RealSrcLoc+               -> RealSrcLoc+               -> StringBuffer+               -> (LexErrKind -> SrcSpan -> MsgEnvelope PsMessage)+               -> P a+reportLexError loc1 loc2 buf f+  | atEnd buf = failLocMsgP loc1 loc2 (f LexErrKind_EOF)+  | otherwise =+  let c = fst (nextChar buf)+  in if c == '\0' -- decoding errors are mapped to '\0', see utf8DecodeChar#+     then failLocMsgP loc2 loc2 (f LexErrKind_UTF8)+     else failLocMsgP loc1 loc2 (f (LexErrKind_Char c))++lexTokenStream :: ParserOpts -> StringBuffer -> RealSrcLoc -> ParseResult [Located Token]+lexTokenStream opts buf loc = unP go initState{ options = opts' }+    where+    new_exts  =   xunset UsePosPragsBit  -- parse LINE/COLUMN pragmas as tokens+                $ xset RawTokenStreamBit -- include comments+                $ pExtsBitmap opts+    opts'     = opts { pExtsBitmap = new_exts }+    initState = initParserState opts' buf loc+    go = do+      ltok <- lexer False return+      case ltok of+        L _ ITeof -> return []+        _ -> liftM (ltok:) go++linePrags = Map.singleton "line" linePrag++fileHeaderPrags = Map.fromList([("options", lex_string_prag IToptions_prag),+                                 ("options_ghc", lex_string_prag IToptions_prag),+                                 ("options_haddock", lex_string_prag_comment ITdocOptions),+                                 ("language", token ITlanguage_prag),+                                 ("include", lex_string_prag ITinclude_prag)])++ignoredPrags = Map.fromList (map ignored pragmas)+               where ignored opt = (opt, nested_comment)+                     impls = ["hugs", "nhc98", "jhc", "yhc", "catch", "derive"]+                     options_pragmas = map ("options_" ++) impls+                     -- CFILES is a hugs-only thing.+                     pragmas = options_pragmas ++ ["cfiles", "contract"]++oneWordPrags = Map.fromList [+     ("rules", rulePrag),+     ("inline",+         strtoken (\s -> (ITinline_prag (SourceText s) (Inline (SourceText s)) FunLike))),+     ("inlinable",+         strtoken (\s -> (ITinline_prag (SourceText s) (Inlinable (SourceText s)) FunLike))),+     ("inlineable",+         strtoken (\s -> (ITinline_prag (SourceText s) (Inlinable (SourceText s)) FunLike))),+                                    -- Spelling variant+     ("notinline",+         strtoken (\s -> (ITinline_prag (SourceText s) (NoInline (SourceText s)) FunLike))),+     ("opaque", strtoken (\s -> ITopaque_prag (SourceText s))),+     ("specialize", strtoken (\s -> ITspec_prag (SourceText s))),+     ("source", strtoken (\s -> ITsource_prag (SourceText s))),+     ("warning", strtoken (\s -> ITwarning_prag (SourceText s))),+     ("deprecated", strtoken (\s -> ITdeprecated_prag (SourceText s))),+     ("scc", strtoken (\s -> ITscc_prag (SourceText s))),+     ("unpack", strtoken (\s -> ITunpack_prag (SourceText s))),+     ("nounpack", strtoken (\s -> ITnounpack_prag (SourceText s))),+     ("ann", strtoken (\s -> ITann_prag (SourceText s))),+     ("minimal", strtoken (\s -> ITminimal_prag (SourceText s))),+     ("overlaps", strtoken (\s -> IToverlaps_prag (SourceText s))),+     ("overlappable", strtoken (\s -> IToverlappable_prag (SourceText s))),+     ("overlapping", strtoken (\s -> IToverlapping_prag (SourceText s))),+     ("incoherent", strtoken (\s -> ITincoherent_prag (SourceText s))),+     ("ctype", strtoken (\s -> ITctype (SourceText s))),+     ("complete", strtoken (\s -> ITcomplete_prag (SourceText s))),+     ("column", columnPrag)+     ]++twoWordPrags = Map.fromList [+     ("inline conlike",+         strtoken (\s -> (ITinline_prag (SourceText s) (Inline (SourceText s)) ConLike))),+     ("notinline conlike",+         strtoken (\s -> (ITinline_prag (SourceText s) (NoInline (SourceText s)) ConLike))),+     ("specialize inline",+         strtoken (\s -> (ITspec_inline_prag (SourceText s) True))),+     ("specialize notinline",+         strtoken (\s -> (ITspec_inline_prag (SourceText s) False)))+     ]++dispatch_pragmas :: Map String Action -> Action+dispatch_pragmas prags span buf len = case Map.lookup (clean_pragma (lexemeToString buf len)) prags of+                                       Just found -> found span buf len+                                       Nothing -> lexError LexUnknownPragma++known_pragma :: Map String Action -> AlexAccPred ExtsBitmap+known_pragma prags _ (AI _ startbuf) _ (AI _ curbuf)+ = isKnown && nextCharIsNot curbuf pragmaNameChar+    where l = lexemeToString startbuf (byteDiff startbuf curbuf)+          isKnown = isJust $ Map.lookup (clean_pragma l) prags+          pragmaNameChar c = isAlphaNum c || c == '_'++clean_pragma :: String -> String+clean_pragma prag = canon_ws (map toLower (unprefix prag))+                    where unprefix prag' = case stripPrefix "{-#" prag' of+                                             Just rest -> rest+                                             Nothing -> prag'+                          canonical prag' = case prag' of+                                              "noinline" -> "notinline"+                                              "specialise" -> "specialize"+                                              "constructorlike" -> "conlike"+                                              _ -> prag'+                          canon_ws s = unwords (map canonical (words s))++++{-+%************************************************************************+%*                                                                      *+        Helper functions for generating annotations in the parser+%*                                                                      *+%************************************************************************+-}+++-- |Given a 'RealSrcSpan' that surrounds a 'HsPar' or 'HsParTy', generate+-- 'AddEpAnn' values for the opening and closing bordering on the start+-- and end of the span+mkParensEpAnn :: RealSrcSpan -> (AddEpAnn, AddEpAnn)+mkParensEpAnn ss = (AddEpAnn AnnOpenP (EpaSpan lo),AddEpAnn AnnCloseP (EpaSpan lc))+  where+    f = srcSpanFile ss+    sl = srcSpanStartLine ss+    sc = srcSpanStartCol ss+    el = srcSpanEndLine ss+    ec = srcSpanEndCol ss+    lo = mkRealSrcSpan (realSrcSpanStart ss)        (mkRealSrcLoc f sl (sc+1))+    lc = mkRealSrcSpan (mkRealSrcLoc f el (ec - 1)) (realSrcSpanEnd ss)++queueComment :: RealLocated Token -> P()+queueComment c = P $ \s -> POk s {+  comment_q = commentToAnnotation c : comment_q s+  } ()++allocateComments+  :: RealSrcSpan+  -> [LEpaComment]+  -> ([LEpaComment], [LEpaComment])+allocateComments ss comment_q =+  let+    (before,rest)  = break (\(L l _) -> isRealSubspanOf (anchor l) ss) comment_q+    (middle,after) = break (\(L l _) -> not (isRealSubspanOf (anchor l) ss)) rest+    comment_q' = before ++ after+    newAnns = middle+  in+    (comment_q', reverse newAnns)++allocatePriorComments+  :: RealSrcSpan+  -> [LEpaComment]+  -> Strict.Maybe [LEpaComment]+  -> (Strict.Maybe [LEpaComment], [LEpaComment], [LEpaComment])+allocatePriorComments ss comment_q mheader_comments =+  let+    cmp (L l _) = anchor l <= ss+    (before,after) = partition cmp comment_q+    newAnns = before+    comment_q'= after+  in+    case mheader_comments of+      Strict.Nothing -> (Strict.Just (reverse newAnns), comment_q', [])+      Strict.Just _ -> (mheader_comments, comment_q', reverse newAnns)++allocateFinalComments+  :: RealSrcSpan+  -> [LEpaComment]+  -> Strict.Maybe [LEpaComment]+  -> (Strict.Maybe [LEpaComment], [LEpaComment], [LEpaComment])+allocateFinalComments _ss comment_q mheader_comments =+  -- We ignore the RealSrcSpan as the parser currently provides a+  -- point span at (1,1).+  case mheader_comments of+    Strict.Nothing -> (Strict.Just (reverse comment_q), [], [])+    Strict.Just _ -> (mheader_comments, [], reverse comment_q)++commentToAnnotation :: RealLocated Token -> LEpaComment+commentToAnnotation (L l (ITdocComment s ll))   = mkLEpaComment l ll (EpaDocComment s)+commentToAnnotation (L l (ITdocOptions s ll))   = mkLEpaComment l ll (EpaDocOptions s)+commentToAnnotation (L l (ITlineComment s ll))  = mkLEpaComment l ll (EpaLineComment s)+commentToAnnotation (L l (ITblockComment s ll)) = mkLEpaComment l ll (EpaBlockComment s)+commentToAnnotation _                           = panic "commentToAnnotation"++-- see Note [PsSpan in Comments]+mkLEpaComment :: RealSrcSpan -> PsSpan -> EpaCommentTok -> LEpaComment+mkLEpaComment l ll tok = L (realSpanAsAnchor l) (EpaComment tok (psRealSpan ll))++-- ---------------------------------------------------------------------++isComment :: Token -> Bool+isComment (ITlineComment  _ _) = True+isComment (ITblockComment _ _) = True+isComment (ITdocComment   _ _) = True+isComment (ITdocOptions   _ _) = True+isComment _                    = False++bol,column_prag,layout,layout_do,layout_if,layout_left,line_prag1,line_prag1a,line_prag2,line_prag2a,option_prags :: Int+bol = 1+column_prag = 2+layout = 3+layout_do = 4+layout_if = 5+layout_left = 6+line_prag1 = 7+line_prag1a = 8+line_prag2 = 9+line_prag2a = 10+option_prags = 11+alex_action_1 = warnTab+alex_action_2 = nested_comment+alex_action_3 = lineCommentToken+alex_action_4 = lineCommentToken+alex_action_5 = lineCommentToken+alex_action_6 = lineCommentToken+alex_action_7 = lineCommentToken+alex_action_8 = lineCommentToken+alex_action_10 = begin line_prag1+alex_action_11 = begin line_prag1+alex_action_15 = do_bol+alex_action_16 = hopefully_open_brace+alex_action_18 = begin line_prag1+alex_action_19 = new_layout_context True dontGenerateSemic ITvbar+alex_action_20 = pop+alex_action_21 = new_layout_context True  generateSemic ITvocurly+alex_action_22 = new_layout_context False generateSemic ITvocurly+alex_action_23 = do_layout_left+alex_action_24 = begin bol+alex_action_25 = dispatch_pragmas linePrags+alex_action_26 = setLineAndFile line_prag1a+alex_action_27 = failLinePrag1+alex_action_28 = popLinePrag1+alex_action_29 = setLineAndFile line_prag2a+alex_action_30 = pop+alex_action_31 = setColumn+alex_action_32 = dispatch_pragmas twoWordPrags+alex_action_33 = dispatch_pragmas oneWordPrags+alex_action_34 = dispatch_pragmas ignoredPrags+alex_action_35 = endPrag+alex_action_36 = dispatch_pragmas fileHeaderPrags+alex_action_37 = nested_comment+alex_action_38 = warnThen PsWarnUnrecognisedPragma+                    (nested_comment )+alex_action_39 = multiline_doc_comment+alex_action_40 = nested_doc_comment+alex_action_41 = token (ITopenExpQuote NoE NormalSyntax)+alex_action_42 = token (ITopenTExpQuote NoE)+alex_action_43 = token (ITcloseQuote NormalSyntax)+alex_action_44 = token ITcloseTExpQuote+alex_action_45 = token (ITopenExpQuote HasE NormalSyntax)+alex_action_46 = token (ITopenTExpQuote HasE)+alex_action_47 = token ITopenPatQuote+alex_action_48 = layout_token ITopenDecQuote+alex_action_49 = token ITopenTypQuote+alex_action_50 = lex_quasiquote_tok+alex_action_51 = lex_qquasiquote_tok+alex_action_52 = token (ITopenExpQuote NoE UnicodeSyntax)+alex_action_53 = token (ITcloseQuote UnicodeSyntax)+alex_action_54 = special (IToparenbar NormalSyntax)+alex_action_55 = special (ITcparenbar NormalSyntax)+alex_action_56 = special (IToparenbar UnicodeSyntax)+alex_action_57 = special (ITcparenbar UnicodeSyntax)+alex_action_58 = skip_one_varid ITdupipvarid+alex_action_59 = skip_one_varid ITlabelvarid+alex_action_60 = token IToubxparen+alex_action_61 = token ITcubxparen+alex_action_62 = special IToparen+alex_action_63 = special ITcparen+alex_action_64 = special ITobrack+alex_action_65 = special ITcbrack+alex_action_66 = special ITcomma+alex_action_67 = special ITsemi+alex_action_68 = special ITbackquote+alex_action_69 = open_brace+alex_action_70 = close_brace+alex_action_71 = qdo_token ITdo+alex_action_72 = qdo_token ITmdo+alex_action_73 = idtoken qvarid+alex_action_74 = idtoken qconid+alex_action_75 = varid+alex_action_76 = idtoken conid+alex_action_77 = idtoken qvarid+alex_action_78 = idtoken qconid+alex_action_79 = varid+alex_action_80 = idtoken conid+alex_action_81 = varsym_tight_infix+alex_action_82 = varsym_prefix+alex_action_83 = varsym_suffix+alex_action_84 = varsym_loose_infix+alex_action_85 = idtoken qvarsym+alex_action_86 = idtoken qconsym+alex_action_87 = consym+alex_action_88 = tok_num positive 0 0 decimal+alex_action_89 = tok_num positive 2 2 binary+alex_action_90 = tok_num positive 2 2 octal+alex_action_91 = tok_num positive 2 2 hexadecimal+alex_action_92 = tok_num negative 1 1 decimal+alex_action_93 = tok_num negative 3 3 binary+alex_action_94 = tok_num negative 3 3 octal+alex_action_95 = tok_num negative 3 3 hexadecimal+alex_action_96 = tok_frac 0 tok_float+alex_action_97 = tok_frac 0 tok_float+alex_action_98 = tok_frac 0 tok_hex_float+alex_action_99 = tok_frac 0 tok_hex_float+alex_action_100 = tok_primint positive 0 1 decimal+alex_action_101 = tok_primint positive 2 3 binary+alex_action_102 = tok_primint positive 2 3 octal+alex_action_103 = tok_primint positive 2 3 hexadecimal+alex_action_104 = tok_primint negative 1 2 decimal+alex_action_105 = tok_primint negative 3 4 binary+alex_action_106 = tok_primint negative 3 4 octal+alex_action_107 = tok_primint negative 3 4 hexadecimal+alex_action_108 = tok_primword 0 2 decimal+alex_action_109 = tok_primword 2 4 binary+alex_action_110 = tok_primword 2 4 octal+alex_action_111 = tok_primword 2 4 hexadecimal+alex_action_112 = tok_frac 1 tok_primfloat+alex_action_113 = tok_frac 2 tok_primdouble+alex_action_114 = tok_frac 1 tok_primfloat+alex_action_115 = tok_frac 2 tok_primdouble+alex_action_116 = lex_char_tok+alex_action_117 = lex_string_tok++#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)+                check  = alexIndexInt16OffAddr alex_check offset++                new_s = if GTE(offset,ILIT(0)) && 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
− GHC/Parser/Lexer.x 
@@ -1,3526 +0,0 @@--------------------------------------------------------------------------------- (c) The University of Glasgow, 2006------ GHC's lexer for Haskell 2010 [1].------ This is a combination of an Alex-generated lexer [2] from a regex--- definition, with some hand-coded bits. [3]------ Completely accurate information about token-spans within the source--- file is maintained.  Every token has a start and end RealSrcLoc--- attached to it.------ References:--- [1] https://www.haskell.org/onlinereport/haskell2010/haskellch2.html--- [2] http://www.haskell.org/alex/--- [3] https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/parser-------------------------------------------------------------------------------------   ToDo / known bugs:---    - parsing integers is a bit slow---    - readRational is a bit slow------   Known bugs, that were also in the previous version:---    - M... should be 3 tokens, not 1.---    - pragma-end should be only valid in a pragma----   qualified operator NOTES.------   - If M.(+) is a single lexeme, then..---     - Probably (+) should be a single lexeme too, for consistency.---       Otherwise ( + ) would be a prefix operator, but M.( + ) would not be.---     - But we have to rule out reserved operators, otherwise (..) becomes---       a different lexeme.---     - Should we therefore also rule out reserved operators in the qualified---       form?  This is quite difficult to achieve.  We don't do it for---       qualified varids.----- -------------------------------------------------------------------------------- Alex "Haskell code fragment top"--{-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiWayIf #-}--{-# OPTIONS_GHC -funbox-strict-fields #-}-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}--module GHC.Parser.Lexer (-   Token(..), lexer, lexerDbg,-   ParserOpts(..), mkParserOpts,-   PState (..), initParserState, initPragState,-   P(..), ParseResult(..),-   allocateComments, allocatePriorComments, allocateFinalComments,-   MonadP(..),-   getRealSrcLoc, getPState,-   failMsgP, failLocMsgP, srcParseFail,-   getErrorMessages, getMessages,-   popContext, pushModuleContext, setLastToken, setSrcLoc,-   activeContext, nextIsEOF,-   getLexState, popLexState, pushLexState,-   ExtBits(..),-   xtest, xunset, xset,-   lexTokenStream,-   mkParensEpAnn,-   getCommentsFor, getPriorCommentsFor, getFinalCommentsFor,-   getEofPos,-   commentToAnnotation,-   HdkComment(..),-   warnopt,-  ) where--import GHC.Prelude---- base-import Control.Monad-import Data.Char-import Data.List (stripPrefix, isInfixOf, partition)-import Data.Maybe-import Data.Word--import GHC.Data.EnumSet as EnumSet---- ghc-boot-import qualified GHC.LanguageExtensions as LangExt---- bytestring-import Data.ByteString (ByteString)---- containers-import Data.Map (Map)-import qualified Data.Map as Map---- compiler-import GHC.Data.Bag-import GHC.Utils.Outputable-import GHC.Utils.Panic-import GHC.Data.StringBuffer-import GHC.Data.FastString-import GHC.Types.Unique.FM-import GHC.Data.Maybe-import GHC.Data.OrdList-import GHC.Utils.Misc ( readSignificandExponentPair, readHexSignificandExponentPair )--import GHC.Types.SrcLoc-import GHC.Types.SourceText-import GHC.Types.Basic ( InlineSpec(..), RuleMatchInfo(..))-import GHC.Hs.Doc--import GHC.Parser.CharClass--import GHC.Parser.Annotation-import GHC.Driver.Flags-import GHC.Parser.Errors-}---- -------------------------------------------------------------------------------- Alex "Character set macros"---- NB: The logic behind these definitions is also reflected in "GHC.Utils.Lexeme"--- Any changes here should likely be reflected there.-$unispace    = \x05 -- Trick Alex into handling Unicode. See [Unicode in Alex].-$nl          = [\n\r\f]-$whitechar   = [$nl\v\ $unispace]-$white_no_nl = $whitechar # \n -- TODO #8424-$tab         = \t--$ascdigit  = 0-9-$unidigit  = \x03 -- Trick Alex into handling Unicode. See [Unicode in Alex].-$decdigit  = $ascdigit -- for now, should really be $digit (ToDo)-$digit     = [$ascdigit $unidigit]--$special   = [\(\)\,\;\[\]\`\{\}]-$ascsymbol = [\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~\:]-$unisymbol = \x04 -- Trick Alex into handling Unicode. See [Unicode in Alex].-$symbol    = [$ascsymbol $unisymbol] # [$special \_\"\']--$unilarge  = \x01 -- Trick Alex into handling Unicode. See [Unicode in Alex].-$asclarge  = [A-Z]-$large     = [$asclarge $unilarge]--$unismall  = \x02 -- Trick Alex into handling Unicode. See [Unicode in Alex].-$ascsmall  = [a-z]-$small     = [$ascsmall $unismall \_]--$unigraphic = \x06 -- Trick Alex into handling Unicode. See [Unicode in Alex].-$graphic   = [$small $large $symbol $digit $special $unigraphic \"\']--$binit     = 0-1-$octit     = 0-7-$hexit     = [$decdigit A-F a-f]--$uniidchar = \x07 -- Trick Alex into handling Unicode. See [Unicode in Alex].-$idchar    = [$small $large $digit $uniidchar \']--$pragmachar = [$small $large $digit]--$docsym    = [\| \^ \* \$]----- -------------------------------------------------------------------------------- Alex "Regular expression macros"--@varid     = $small $idchar*          -- variable identifiers-@conid     = $large $idchar*          -- constructor identifiers--@varsym    = ($symbol # \:) $symbol*  -- variable (operator) symbol-@consym    = \: $symbol*              -- constructor (operator) symbol---- See Note [Lexing NumericUnderscores extension] and #14473-@numspc       = _*                   -- numeric spacer (#14473)-@decimal      = $decdigit(@numspc $decdigit)*-@binary       = $binit(@numspc $binit)*-@octal        = $octit(@numspc $octit)*-@hexadecimal  = $hexit(@numspc $hexit)*-@exponent     = @numspc [eE] [\-\+]? @decimal-@bin_exponent = @numspc [pP] [\-\+]? @decimal--@qual = (@conid \.)+-@qvarid = @qual @varid-@qconid = @qual @conid-@qvarsym = @qual @varsym-@qconsym = @qual @consym---- QualifiedDo needs to parse "M.do" not as a variable, so as to keep the--- layout rules.-@qdo    = @qual "do"-@qmdo   = @qual "mdo"--@floating_point = @numspc @decimal \. @decimal @exponent? | @numspc @decimal @exponent-@hex_floating_point = @numspc @hexadecimal \. @hexadecimal @bin_exponent? | @numspc @hexadecimal @bin_exponent---- normal signed numerical literals can only be explicitly negative,--- not explicitly positive (contrast @exponent)-@negative = \------ -------------------------------------------------------------------------------- Alex "Identifier"--haskell :------ -------------------------------------------------------------------------------- Alex "Rules"---- everywhere: skip whitespace-$white_no_nl+ ;-$tab          { warnTab }---- Everywhere: deal with nested comments.  We explicitly rule out--- pragmas, "{-#", so that we don't accidentally treat them as comments.--- (this can happen even though pragmas will normally take precedence due to--- longest-match, because pragmas aren't valid in every state, but comments--- are). We also rule out nested Haddock comments, if the -haddock flag is--- set.--"{-" / { isNormalComment } { nested_comment lexToken }---- Single-line comments are a bit tricky.  Haskell 98 says that two or--- more dashes followed by a symbol should be parsed as a varsym, so we--- have to exclude those.---- Since Haddock comments aren't valid in every state, we need to rule them--- out here.---- The following two rules match comments that begin with two dashes, but--- continue with a different character. The rules test that this character--- is not a symbol (in which case we'd have a varsym), and that it's not a--- space followed by a Haddock comment symbol (docsym) (in which case we'd--- have a Haddock comment). The rules then munch the rest of the line.--"-- " ~$docsym .* { lineCommentToken }-"--" [^$symbol \ ] .* { lineCommentToken }---- Next, match Haddock comments if no -haddock flag--"-- " $docsym .* / { alexNotPred (ifExtension HaddockBit) } { lineCommentToken }---- Now, when we've matched comments that begin with 2 dashes and continue--- with a different character, we need to match comments that begin with three--- or more dashes (which clearly can't be Haddock comments). We only need to--- make sure that the first non-dash character isn't a symbol, and munch the--- rest of the line.--"---"\-* ~$symbol .* { lineCommentToken }---- Since the previous rules all match dashes followed by at least one--- character, we also need to match a whole line filled with just dashes.--"--"\-* / { atEOL } { lineCommentToken }---- We need this rule since none of the other single line comment rules--- actually match this case.--"-- " / { atEOL } { lineCommentToken }---- 'bol' state: beginning of a line.  Slurp up all the whitespace (including--- blank lines) until we find a non-whitespace character, then do layout--- processing.------ One slight wibble here: what if the line begins with {-#? In--- theory, we have to lex the pragma to see if it's one we recognise,--- and if it is, then we backtrack and do_bol, otherwise we treat it--- as a nested comment.  We don't bother with this: if the line begins--- with {-#, then we'll assume it's a pragma we know about and go for do_bol.-<bol> {-  \n                                    ;-  ^\# line                              { begin line_prag1 }-  ^\# / { followedByDigit }             { begin line_prag1 }-  ^\# pragma .* \n                      ; -- GCC 3.3 CPP generated, apparently-  ^\# \! .* \n                          ; -- #!, for scripts-  ()                                    { do_bol }-}---- after a layout keyword (let, where, do, of), we begin a new layout--- context if the curly brace is missing.--- Careful! This stuff is quite delicate.-<layout, layout_do, layout_if> {-  \{ / { notFollowedBy '-' }            { hopefully_open_brace }-        -- we might encounter {-# here, but {- has been handled already-  \n                                    ;-  ^\# (line)?                           { begin line_prag1 }-}---- after an 'if', a vertical bar starts a layout context for MultiWayIf-<layout_if> {-  \| / { notFollowedBySymbol }          { new_layout_context True dontGenerateSemic ITvbar }-  ()                                    { pop }-}---- do is treated in a subtly different way, see new_layout_context-<layout>    ()                          { new_layout_context True  generateSemic ITvocurly }-<layout_do> ()                          { new_layout_context False generateSemic ITvocurly }---- after a new layout context which was found to be to the left of the--- previous context, we have generated a '{' token, and we now need to--- generate a matching '}' token.-<layout_left>  ()                       { do_layout_left }--<0,option_prags> \n                     { begin bol }--"{-#" $whitechar* $pragmachar+ / { known_pragma linePrags }-                                { dispatch_pragmas linePrags }---- single-line line pragmas, of the form---    # <line> "<file>" <extra-stuff> \n-<line_prag1> {-  @decimal $white_no_nl+ \" [$graphic \ ]* \"  { setLineAndFile line_prag1a }-  ()                                           { failLinePrag1 }-}-<line_prag1a> .*                               { popLinePrag1 }---- Haskell-style line pragmas, of the form---    {-# LINE <line> "<file>" #-}-<line_prag2> {-  @decimal $white_no_nl+ \" [$graphic \ ]* \"  { setLineAndFile line_prag2a }-}-<line_prag2a> "#-}"|"-}"                       { pop }-   -- NOTE: accept -} at the end of a LINE pragma, for compatibility-   -- with older versions of GHC which generated these.---- Haskell-style column pragmas, of the form---    {-# COLUMN <column> #-}-<column_prag> @decimal $whitechar* "#-}" { setColumn }--<0,option_prags> {-  "{-#" $whitechar* $pragmachar+-        $whitechar+ $pragmachar+ / { known_pragma twoWordPrags }-                                 { dispatch_pragmas twoWordPrags }--  "{-#" $whitechar* $pragmachar+ / { known_pragma oneWordPrags }-                                 { dispatch_pragmas oneWordPrags }--  -- We ignore all these pragmas, but don't generate a warning for them-  "{-#" $whitechar* $pragmachar+ / { known_pragma ignoredPrags }-                                 { dispatch_pragmas ignoredPrags }--  -- ToDo: should only be valid inside a pragma:-  "#-}"                          { endPrag }-}--<option_prags> {-  "{-#"  $whitechar* $pragmachar+ / { known_pragma fileHeaderPrags }-                                   { dispatch_pragmas fileHeaderPrags }-}--<0> {-  -- In the "0" mode we ignore these pragmas-  "{-#"  $whitechar* $pragmachar+ / { known_pragma fileHeaderPrags }-                     { nested_comment lexToken }-}--<0,option_prags> {-  "{-#"  { warnThen Opt_WarnUnrecognisedPragmas PsWarnUnrecognisedPragma-                    (nested_comment lexToken) }-}---- '0' state: ordinary lexemes---- Haddock comments--"-- " $docsym      / { ifExtension HaddockBit } { multiline_doc_comment }-"{-" \ ? $docsym   / { ifExtension HaddockBit } { nested_doc_comment }---- "special" symbols--<0> {--  -- Don't check ThQuotesBit here as the renamer can produce a better-  -- error message than the lexer (see the thQuotesEnabled check in rnBracket).-  "[|"  { token (ITopenExpQuote NoE NormalSyntax) }-  "[||" { token (ITopenTExpQuote NoE) }-  "|]"  { token (ITcloseQuote NormalSyntax) }-  "||]" { token ITcloseTExpQuote }--  -- Check ThQuotesBit here as to not steal syntax.-  "[e|"       / { ifExtension ThQuotesBit } { token (ITopenExpQuote HasE NormalSyntax) }-  "[e||"      / { ifExtension ThQuotesBit } { token (ITopenTExpQuote HasE) }-  "[p|"       / { ifExtension ThQuotesBit } { token ITopenPatQuote }-  "[d|"       / { ifExtension ThQuotesBit } { layout_token ITopenDecQuote }-  "[t|"       / { ifExtension ThQuotesBit } { token ITopenTypQuote }--  "[" @varid "|"  / { ifExtension QqBit }   { lex_quasiquote_tok }--  -- qualified quasi-quote (#5555)-  "[" @qvarid "|"  / { ifExtension QqBit }  { lex_qquasiquote_tok }--  $unigraphic -- ⟦-    / { ifCurrentChar '⟦' `alexAndPred`-        ifExtension UnicodeSyntaxBit `alexAndPred`-        ifExtension ThQuotesBit }-    { token (ITopenExpQuote NoE UnicodeSyntax) }-  $unigraphic -- ⟧-    / { ifCurrentChar '⟧' `alexAndPred`-        ifExtension UnicodeSyntaxBit `alexAndPred`-        ifExtension ThQuotesBit }-    { token (ITcloseQuote UnicodeSyntax) }-}--<0> {-  "(|"-    / { ifExtension ArrowsBit `alexAndPred`-        notFollowedBySymbol }-    { special (IToparenbar NormalSyntax) }-  "|)"-    / { ifExtension ArrowsBit }-    { special (ITcparenbar NormalSyntax) }--  $unigraphic -- ⦇-    / { ifCurrentChar '⦇' `alexAndPred`-        ifExtension UnicodeSyntaxBit `alexAndPred`-        ifExtension ArrowsBit }-    { special (IToparenbar UnicodeSyntax) }-  $unigraphic -- ⦈-    / { ifCurrentChar '⦈' `alexAndPred`-        ifExtension UnicodeSyntaxBit `alexAndPred`-        ifExtension ArrowsBit }-    { special (ITcparenbar UnicodeSyntax) }-}--<0> {-  \? @varid / { ifExtension IpBit } { skip_one_varid ITdupipvarid }-}--<0> {-  "#" @varid / { ifExtension OverloadedLabelsBit } { skip_one_varid ITlabelvarid }-}--<0> {-  "(#" / { ifExtension UnboxedTuplesBit `alexOrPred`-           ifExtension UnboxedSumsBit }-         { token IToubxparen }-  "#)" / { ifExtension UnboxedTuplesBit `alexOrPred`-           ifExtension UnboxedSumsBit }-         { token ITcubxparen }-}--<0,option_prags> {-  \(                                    { special IToparen }-  \)                                    { special ITcparen }-  \[                                    { special ITobrack }-  \]                                    { special ITcbrack }-  \,                                    { special ITcomma }-  \;                                    { special ITsemi }-  \`                                    { special ITbackquote }--  \{                                    { open_brace }-  \}                                    { close_brace }-}--<0,option_prags> {-  @qdo                                      { qdo_token ITdo }-  @qmdo    / { ifExtension RecursiveDoBit } { qdo_token ITmdo }-  @qvarid                       { idtoken qvarid }-  @qconid                       { idtoken qconid }-  @varid                        { varid }-  @conid                        { idtoken conid }-}--<0> {-  @qvarid "#"+      / { ifExtension MagicHashBit } { idtoken qvarid }-  @qconid "#"+      / { ifExtension MagicHashBit } { idtoken qconid }-  @varid "#"+       / { ifExtension MagicHashBit } { varid }-  @conid "#"+       / { ifExtension MagicHashBit } { idtoken conid }-}---- Operators classified into prefix, suffix, tight infix, and loose infix.--- See Note [Whitespace-sensitive operator parsing]-<0> {-  @varsym / { precededByClosingToken `alexAndPred` followedByOpeningToken } { varsym_tight_infix }-  @varsym / { followedByOpeningToken }  { varsym_prefix }-  @varsym / { precededByClosingToken }  { varsym_suffix }-  @varsym                               { varsym_loose_infix }-}---- ToDo: - move `var` and (sym) into lexical syntax?---       - remove backquote from $special?-<0> {-  @qvarsym                                         { idtoken qvarsym }-  @qconsym                                         { idtoken qconsym }-  @consym                                          { consym }-}---- For the normal boxed literals we need to be careful--- when trying to be close to Haskell98---- Note [Lexing NumericUnderscores extension] (#14473)------ NumericUnderscores extension allows underscores in numeric literals.--- Multiple underscores are represented with @numspc macro.--- To be simpler, we have only the definitions with underscores.--- And then we have a separate function (tok_integral and tok_frac)--- that validates the literals.--- If extensions are not enabled, check that there are no underscores.----<0> {-  -- Normal integral literals (:: Num a => a, from Integer)-  @decimal                                                                   { tok_num positive 0 0 decimal }-  0[bB] @numspc @binary                / { ifExtension BinaryLiteralsBit }   { tok_num positive 2 2 binary }-  0[oO] @numspc @octal                                                       { tok_num positive 2 2 octal }-  0[xX] @numspc @hexadecimal                                                 { tok_num positive 2 2 hexadecimal }-  @negative @decimal                   / { negLitPred }                      { tok_num negative 1 1 decimal }-  @negative 0[bB] @numspc @binary      / { negLitPred `alexAndPred`-                                           ifExtension BinaryLiteralsBit }   { tok_num negative 3 3 binary }-  @negative 0[oO] @numspc @octal       / { negLitPred }                      { tok_num negative 3 3 octal }-  @negative 0[xX] @numspc @hexadecimal / { negLitPred }                      { tok_num negative 3 3 hexadecimal }--  -- Normal rational literals (:: Fractional a => a, from Rational)-  @floating_point                                                            { tok_frac 0 tok_float }-  @negative @floating_point            / { negLitPred }                      { tok_frac 0 tok_float }-  0[xX] @numspc @hex_floating_point    / { ifExtension HexFloatLiteralsBit } { tok_frac 0 tok_hex_float }-  @negative 0[xX] @numspc @hex_floating_point-                                       / { ifExtension HexFloatLiteralsBit `alexAndPred`-                                           negLitPred }                      { tok_frac 0 tok_hex_float }-}--<0> {-  -- Unboxed ints (:: Int#) and words (:: Word#)-  -- It's simpler (and faster?) to give separate cases to the negatives,-  -- especially considering octal/hexadecimal prefixes.-  @decimal                          \# / { ifExtension MagicHashBit }        { tok_primint positive 0 1 decimal }-  0[bB] @numspc @binary             \# / { ifExtension MagicHashBit `alexAndPred`-                                           ifExtension BinaryLiteralsBit }   { tok_primint positive 2 3 binary }-  0[oO] @numspc @octal              \# / { ifExtension MagicHashBit }        { tok_primint positive 2 3 octal }-  0[xX] @numspc @hexadecimal        \# / { ifExtension MagicHashBit }        { tok_primint positive 2 3 hexadecimal }-  @negative @decimal                \# / { negHashLitPred }                  { tok_primint negative 1 2 decimal }-  @negative 0[bB] @numspc @binary   \# / { negHashLitPred `alexAndPred`-                                           ifExtension BinaryLiteralsBit }   { tok_primint negative 3 4 binary }-  @negative 0[oO] @numspc @octal    \# / { negHashLitPred }                  { tok_primint negative 3 4 octal }-  @negative 0[xX] @numspc @hexadecimal \#-                                       / { negHashLitPred }                  { tok_primint negative 3 4 hexadecimal }--  @decimal                       \# \# / { ifExtension MagicHashBit }        { tok_primword 0 2 decimal }-  0[bB] @numspc @binary          \# \# / { ifExtension MagicHashBit `alexAndPred`-                                           ifExtension BinaryLiteralsBit }   { tok_primword 2 4 binary }-  0[oO] @numspc @octal           \# \# / { ifExtension MagicHashBit }        { tok_primword 2 4 octal }-  0[xX] @numspc @hexadecimal     \# \# / { ifExtension MagicHashBit }        { tok_primword 2 4 hexadecimal }--  -- Unboxed floats and doubles (:: Float#, :: Double#)-  -- prim_{float,double} work with signed literals-  @floating_point                  \# / { ifExtension MagicHashBit }        { tok_frac 1 tok_primfloat }-  @floating_point               \# \# / { ifExtension MagicHashBit }        { tok_frac 2 tok_primdouble }--  @negative @floating_point        \# / { negHashLitPred }                  { tok_frac 1 tok_primfloat }-  @negative @floating_point     \# \# / { negHashLitPred }                  { tok_frac 2 tok_primdouble }-}---- Strings and chars are lexed by hand-written code.  The reason is--- that even if we recognise the string or char here in the regex--- lexer, we would still have to parse the string afterward in order--- to convert it to a String.-<0> {-  \'                            { lex_char_tok }-  \"                            { lex_string_tok }-}---- Note [Whitespace-sensitive operator parsing]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- In accord with GHC Proposal #229 https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0229-whitespace-bang-patterns.rst--- we classify operator occurrences into four categories:------     a ! b   -- a loose infix occurrence---     a!b     -- a tight infix occurrence---     a !b    -- a prefix occurrence---     a! b    -- a suffix occurrence------ The rules are a bit more elaborate than simply checking for whitespace, in--- order to accommodate the following use cases:------     f (!a) = ...    -- prefix occurrence---     g (a !)         -- loose infix occurrence---     g (! a)         -- loose infix occurrence------ The precise rules are as follows:------  * Identifiers, literals, and opening brackets (, (#, (|, [, [|, [||, [p|,---    [e|, [t|, {, ⟦, ⦇, are considered "opening tokens". The function---    followedByOpeningToken tests whether the next token is an opening token.------  * Identifiers, literals, and closing brackets ), #), |), ], |], }, ⟧, ⦈,---    are considered "closing tokens". The function precededByClosingToken tests---    whether the previous token is a closing token.------  * Whitespace, comments, separators, and other tokens, are considered---    neither opening nor closing.------  * Any unqualified operator occurrence is classified as prefix, suffix, or---    tight/loose infix, based on preceding and following tokens:------       precededByClosingToken | followedByOpeningToken | Occurrence---      ------------------------+------------------------+---------------       False                  | True                   | prefix---       True                   | False                  | suffix---       True                   | True                   | tight infix---       False                  | False                  | loose infix---      ------------------------+------------------------+------------------ A loose infix occurrence is always considered an operator. Other types of--- occurrences may be assigned a special per-operator meaning override:------   Operator |  Occurrence   | Token returned---  ----------+---------------+---------------------------------------------    !       |  prefix       | ITbang---            |               |   strictness annotation or bang pattern,---            |               |   e.g.  f !x = rhs, data T = MkT !a---            |  not prefix   | ITvarsym "!"---            |               |   ordinary operator or type operator,---            |               |   e.g.  xs ! 3, (! x), Int ! Bool---  ----------+---------------+---------------------------------------------    ~       |  prefix       | ITtilde---            |               |   laziness annotation or lazy pattern,---            |               |   e.g.  f ~x = rhs, data T = MkT ~a---            |  not prefix   | ITvarsym "~"---            |               |   ordinary operator or type operator,---            |               |   e.g.  xs ~ 3, (~ x), Int ~ Bool---  ----------+---------------+---------------------------------------------    .       |  prefix       | ITproj True---            |               |   field projection,---            |               |   e.g.  .x---            |  tight infix  | ITproj False---            |               |   field projection,---            |               |   e.g. r.x---            |  suffix       | ITdot---            |               |   function composition,---            |               |   e.g. f. g---            |  loose infix  | ITdot---            |               |   function composition,---            |               |   e.g.  f . g---  ----------+---------------+---------------------------------------------    $  $$   |  prefix       | ITdollar, ITdollardollar---            |               |   untyped or typed Template Haskell splice,---            |               |   e.g.  $(f x), $$(f x), $$"str"---            |  not prefix   | ITvarsym "$", ITvarsym "$$"---            |               |   ordinary operator or type operator,---            |               |   e.g.  f $ g x, a $$ b---  ----------+---------------+---------------------------------------------    @       |  prefix       | ITtypeApp---            |               |   type application, e.g.  fmap @Maybe---            |  tight infix  | ITat---            |               |   as-pattern, e.g.  f p@(a,b) = rhs---            |  suffix       | parse error---            |               |   e.g. f p@ x = rhs---            |  loose infix  | ITvarsym "@"---            |               |   ordinary operator or type operator,---            |               |   e.g.  f @ g, (f @)---  ----------+---------------+------------------------------------------------ Also, some of these overrides are guarded behind language extensions.--- According to the specification, we must determine the occurrence based on--- surrounding *tokens* (see the proposal for the exact rules). However, in--- the implementation we cheat a little and do the classification based on--- characters, for reasons of both simplicity and efficiency (see--- 'followedByOpeningToken' and 'precededByClosingToken')------ When an operator is subject to a meaning override, it is mapped to special--- token: ITbang, ITtilde, ITat, ITdollar, ITdollardollar. Otherwise, it is--- returned as ITvarsym.------ For example, this is how we process the (!):------    precededByClosingToken | followedByOpeningToken | Token---   ------------------------+------------------------+----------------    False                  | True                   | ITbang---    True                   | False                  | ITvarsym "!"---    True                   | True                   | ITvarsym "!"---    False                  | False                  | ITvarsym "!"---   ------------------------+------------------------+------------------- And this is how we process the (@):------    precededByClosingToken | followedByOpeningToken | Token---   ------------------------+------------------------+----------------    False                  | True                   | ITtypeApp---    True                   | False                  | parse error---    True                   | True                   | ITat---    False                  | False                  | ITvarsym "@"---   ------------------------+------------------------+----------------- -------------------------------------------------------------------------------- Alex "Haskell code fragment bottom"--{---- -------------------------------------------------------------------------------- The token type--data Token-  = ITas                        -- Haskell keywords-  | ITcase-  | ITclass-  | ITdata-  | ITdefault-  | ITderiving-  | ITdo (Maybe FastString)-  | ITelse-  | IThiding-  | ITforeign-  | ITif-  | ITimport-  | ITin-  | ITinfix-  | ITinfixl-  | ITinfixr-  | ITinstance-  | ITlet-  | ITmodule-  | ITnewtype-  | ITof-  | ITqualified-  | ITthen-  | ITtype-  | ITwhere--  | ITforall            IsUnicodeSyntax -- GHC extension keywords-  | ITexport-  | ITlabel-  | ITdynamic-  | ITsafe-  | ITinterruptible-  | ITunsafe-  | ITstdcallconv-  | ITccallconv-  | ITcapiconv-  | ITprimcallconv-  | ITjavascriptcallconv-  | ITmdo (Maybe FastString)-  | ITfamily-  | ITrole-  | ITgroup-  | ITby-  | ITusing-  | ITpattern-  | ITstatic-  | ITstock-  | ITanyclass-  | ITvia--  -- Backpack tokens-  | ITunit-  | ITsignature-  | ITdependency-  | ITrequires--  -- Pragmas, see  note [Pragma source text] in "GHC.Types.Basic"-  | ITinline_prag       SourceText InlineSpec RuleMatchInfo-  | ITspec_prag         SourceText                -- SPECIALISE-  | ITspec_inline_prag  SourceText Bool    -- SPECIALISE INLINE (or NOINLINE)-  | ITsource_prag       SourceText-  | ITrules_prag        SourceText-  | ITwarning_prag      SourceText-  | ITdeprecated_prag   SourceText-  | ITline_prag         SourceText  -- not usually produced, see 'UsePosPragsBit'-  | ITcolumn_prag       SourceText  -- not usually produced, see 'UsePosPragsBit'-  | ITscc_prag          SourceText-  | ITunpack_prag       SourceText-  | ITnounpack_prag     SourceText-  | ITann_prag          SourceText-  | ITcomplete_prag     SourceText-  | ITclose_prag-  | IToptions_prag String-  | ITinclude_prag String-  | ITlanguage_prag-  | ITminimal_prag      SourceText-  | IToverlappable_prag SourceText  -- instance overlap mode-  | IToverlapping_prag  SourceText  -- instance overlap mode-  | IToverlaps_prag     SourceText  -- instance overlap mode-  | ITincoherent_prag   SourceText  -- instance overlap mode-  | ITctype             SourceText-  | ITcomment_line_prag         -- See Note [Nested comment line pragmas]--  | ITdotdot                    -- reserved symbols-  | ITcolon-  | ITdcolon            IsUnicodeSyntax-  | ITequal-  | ITlam-  | ITlcase-  | ITvbar-  | ITlarrow            IsUnicodeSyntax-  | ITrarrow            IsUnicodeSyntax-  | ITdarrow            IsUnicodeSyntax-  | ITlolly       -- The (⊸) arrow (for LinearTypes)-  | ITminus       -- See Note [Minus tokens]-  | ITprefixminus -- See Note [Minus tokens]-  | ITbang     -- Prefix (!) only, e.g. f !x = rhs-  | ITtilde    -- Prefix (~) only, e.g. f ~x = rhs-  | ITat       -- Tight infix (@) only, e.g. f x@pat = rhs-  | ITtypeApp  -- Prefix (@) only, e.g. f @t-  | ITpercent  -- Prefix (%) only, e.g. a %1 -> b-  | ITstar              IsUnicodeSyntax-  | ITdot-  | ITproj Bool -- Extension: OverloadedRecordDotBit--  | ITbiglam                    -- GHC-extension symbols--  | ITocurly                    -- special symbols-  | ITccurly-  | ITvocurly-  | ITvccurly-  | ITobrack-  | ITopabrack                  -- [:, for parallel arrays with -XParallelArrays-  | ITcpabrack                  -- :], for parallel arrays with -XParallelArrays-  | ITcbrack-  | IToparen-  | ITcparen-  | IToubxparen-  | ITcubxparen-  | ITsemi-  | ITcomma-  | ITunderscore-  | ITbackquote-  | ITsimpleQuote               --  '--  | ITvarid   FastString        -- identifiers-  | ITconid   FastString-  | ITvarsym  FastString-  | ITconsym  FastString-  | ITqvarid  (FastString,FastString)-  | ITqconid  (FastString,FastString)-  | ITqvarsym (FastString,FastString)-  | ITqconsym (FastString,FastString)--  | ITdupipvarid   FastString   -- GHC extension: implicit param: ?x-  | ITlabelvarid   FastString   -- Overloaded label: #x--  | ITchar     SourceText Char       -- Note [Literal source text] in "GHC.Types.Basic"-  | ITstring   SourceText FastString -- Note [Literal source text] in "GHC.Types.Basic"-  | ITinteger  IntegralLit           -- Note [Literal source text] in "GHC.Types.Basic"-  | ITrational FractionalLit--  | ITprimchar   SourceText Char     -- Note [Literal source text] in "GHC.Types.Basic"-  | ITprimstring SourceText ByteString -- Note [Literal source text] in "GHC.Types.Basic"-  | ITprimint    SourceText Integer  -- Note [Literal source text] in "GHC.Types.Basic"-  | ITprimword   SourceText Integer  -- Note [Literal source text] in "GHC.Types.Basic"-  | ITprimfloat  FractionalLit-  | ITprimdouble FractionalLit--  -- Template Haskell extension tokens-  | ITopenExpQuote HasE IsUnicodeSyntax --  [| or [e|-  | ITopenPatQuote                      --  [p|-  | ITopenDecQuote                      --  [d|-  | ITopenTypQuote                      --  [t|-  | ITcloseQuote IsUnicodeSyntax        --  |]-  | ITopenTExpQuote HasE                --  [|| or [e||-  | ITcloseTExpQuote                    --  ||]-  | ITdollar                            --  prefix $-  | ITdollardollar                      --  prefix $$-  | ITtyQuote                           --  ''-  | ITquasiQuote (FastString,FastString,PsSpan)-    -- ITquasiQuote(quoter, quote, loc)-    -- represents a quasi-quote of the form-    -- [quoter| quote |]-  | ITqQuasiQuote (FastString,FastString,FastString,PsSpan)-    -- ITqQuasiQuote(Qual, quoter, quote, loc)-    -- represents a qualified quasi-quote of the form-    -- [Qual.quoter| quote |]--  -- Arrow notation extension-  | ITproc-  | ITrec-  | IToparenbar  IsUnicodeSyntax -- ^ @(|@-  | ITcparenbar  IsUnicodeSyntax -- ^ @|)@-  | ITlarrowtail IsUnicodeSyntax -- ^ @-<@-  | ITrarrowtail IsUnicodeSyntax -- ^ @>-@-  | ITLarrowtail IsUnicodeSyntax -- ^ @-<<@-  | ITRarrowtail IsUnicodeSyntax -- ^ @>>-@--  | ITunknown String             -- ^ Used when the lexer can't make sense of it-  | ITeof                        -- ^ end of file token--  -- Documentation annotations. See Note [PsSpan in Comments]-  | ITdocCommentNext  String     PsSpan -- ^ something beginning @-- |@-  | ITdocCommentPrev  String     PsSpan -- ^ something beginning @-- ^@-  | ITdocCommentNamed String     PsSpan -- ^ something beginning @-- $@-  | ITdocSection      Int String PsSpan -- ^ a section heading-  | ITdocOptions      String     PsSpan -- ^ doc options (prune, ignore-exports, etc)-  | ITlineComment     String     PsSpan -- ^ comment starting by "--"-  | ITblockComment    String     PsSpan -- ^ comment in {- -}--  deriving Show--instance Outputable Token where-  ppr x = text (show x)--{- Note [PsSpan in Comments]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When using the Api Annotations to exact print a modified AST, managing-the space before a comment is important.  The PsSpan in the comment-token allows this to happen.--We also need to track the space before the end of file. The normal-mechanism of using the previous token does not work, as the ITeof is-synthesised to come at the same location of the last token, and the-normal previous token updating has by then updated the required-location.--We track this using a 2-back location, prev_loc2. This adds extra-processing to every single token, which is a performance hit for-something needed only at the end of the file. This needs-improving. Perhaps a backward scan on eof?--}--{- Note [Minus tokens]-~~~~~~~~~~~~~~~~~~~~~~-A minus sign can be used in prefix form (-x) and infix form (a - b).--When LexicalNegation is on:-  * ITprefixminus  represents the prefix form-  * ITvarsym "-"   represents the infix form-  * ITminus        is not used--When LexicalNegation is off:-  * ITminus        represents all forms-  * ITprefixminus  is not used-  * ITvarsym "-"   is not used--}--{- Note [Why not LexicalNegationBit]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-One might wonder why we define NoLexicalNegationBit instead of-LexicalNegationBit. The problem lies in the following line in reservedSymsFM:--    ,("-", ITminus, NormalSyntax, xbit NoLexicalNegationBit)--We want to generate ITminus only when LexicalNegation is off. How would one-do it if we had LexicalNegationBit? I (int-index) tried to use bitwise-complement:--    ,("-", ITminus, NormalSyntax, complement (xbit LexicalNegationBit))--This did not work, so I opted for NoLexicalNegationBit instead.--}----- the bitmap provided as the third component indicates whether the--- corresponding extension keyword is valid under the extension options--- provided to the compiler; if the extension corresponding to *any* of the--- bits set in the bitmap is enabled, the keyword is valid (this setup--- facilitates using a keyword in two different extensions that can be--- activated independently)----reservedWordsFM :: UniqFM FastString (Token, ExtsBitmap)-reservedWordsFM = listToUFM $-    map (\(x, y, z) -> (mkFastString x, (y, z)))-        [( "_",              ITunderscore,    0 ),-         ( "as",             ITas,            0 ),-         ( "case",           ITcase,          0 ),-         ( "class",          ITclass,         0 ),-         ( "data",           ITdata,          0 ),-         ( "default",        ITdefault,       0 ),-         ( "deriving",       ITderiving,      0 ),-         ( "do",             ITdo Nothing,    0 ),-         ( "else",           ITelse,          0 ),-         ( "hiding",         IThiding,        0 ),-         ( "if",             ITif,            0 ),-         ( "import",         ITimport,        0 ),-         ( "in",             ITin,            0 ),-         ( "infix",          ITinfix,         0 ),-         ( "infixl",         ITinfixl,        0 ),-         ( "infixr",         ITinfixr,        0 ),-         ( "instance",       ITinstance,      0 ),-         ( "let",            ITlet,           0 ),-         ( "module",         ITmodule,        0 ),-         ( "newtype",        ITnewtype,       0 ),-         ( "of",             ITof,            0 ),-         ( "qualified",      ITqualified,     0 ),-         ( "then",           ITthen,          0 ),-         ( "type",           ITtype,          0 ),-         ( "where",          ITwhere,         0 ),--         ( "forall",         ITforall NormalSyntax, 0),-         ( "mdo",            ITmdo Nothing,   xbit RecursiveDoBit),-             -- See Note [Lexing type pseudo-keywords]-         ( "family",         ITfamily,        0 ),-         ( "role",           ITrole,          0 ),-         ( "pattern",        ITpattern,       xbit PatternSynonymsBit),-         ( "static",         ITstatic,        xbit StaticPointersBit ),-         ( "stock",          ITstock,         0 ),-         ( "anyclass",       ITanyclass,      0 ),-         ( "via",            ITvia,           0 ),-         ( "group",          ITgroup,         xbit TransformComprehensionsBit),-         ( "by",             ITby,            xbit TransformComprehensionsBit),-         ( "using",          ITusing,         xbit TransformComprehensionsBit),--         ( "foreign",        ITforeign,       xbit FfiBit),-         ( "export",         ITexport,        xbit FfiBit),-         ( "label",          ITlabel,         xbit FfiBit),-         ( "dynamic",        ITdynamic,       xbit FfiBit),-         ( "safe",           ITsafe,          xbit FfiBit .|.-                                              xbit SafeHaskellBit),-         ( "interruptible",  ITinterruptible, xbit InterruptibleFfiBit),-         ( "unsafe",         ITunsafe,        xbit FfiBit),-         ( "stdcall",        ITstdcallconv,   xbit FfiBit),-         ( "ccall",          ITccallconv,     xbit FfiBit),-         ( "capi",           ITcapiconv,      xbit CApiFfiBit),-         ( "prim",           ITprimcallconv,  xbit FfiBit),-         ( "javascript",     ITjavascriptcallconv, xbit FfiBit),--         ( "unit",           ITunit,          0 ),-         ( "dependency",     ITdependency,       0 ),-         ( "signature",      ITsignature,     0 ),--         ( "rec",            ITrec,           xbit ArrowsBit .|.-                                              xbit RecursiveDoBit),-         ( "proc",           ITproc,          xbit ArrowsBit)-     ]--{------------------------------------Note [Lexing type pseudo-keywords]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--One might think that we wish to treat 'family' and 'role' as regular old-varids whenever -XTypeFamilies and -XRoleAnnotations are off, respectively.-But, there is no need to do so. These pseudo-keywords are not stolen syntax:-they are only used after the keyword 'type' at the top-level, where varids are-not allowed. Furthermore, checks further downstream (GHC.Tc.TyCl) ensure that-type families and role annotations are never declared without their extensions-on. In fact, by unconditionally lexing these pseudo-keywords as special, we-can get better error messages.--Also, note that these are included in the `varid` production in the parser ---a key detail to make all this work.--------------------------------------}--reservedSymsFM :: UniqFM FastString (Token, IsUnicodeSyntax, ExtsBitmap)-reservedSymsFM = listToUFM $-    map (\ (x,w,y,z) -> (mkFastString x,(w,y,z)))-      [ ("..",  ITdotdot,                   NormalSyntax,  0 )-        -- (:) is a reserved op, meaning only list cons-       ,(":",   ITcolon,                    NormalSyntax,  0 )-       ,("::",  ITdcolon NormalSyntax,      NormalSyntax,  0 )-       ,("=",   ITequal,                    NormalSyntax,  0 )-       ,("\\",  ITlam,                      NormalSyntax,  0 )-       ,("|",   ITvbar,                     NormalSyntax,  0 )-       ,("<-",  ITlarrow NormalSyntax,      NormalSyntax,  0 )-       ,("->",  ITrarrow NormalSyntax,      NormalSyntax,  0 )-       ,("=>",  ITdarrow NormalSyntax,      NormalSyntax,  0 )-       ,("-",   ITminus,                    NormalSyntax,  xbit NoLexicalNegationBit)--       ,("*",   ITstar NormalSyntax,        NormalSyntax,  xbit StarIsTypeBit)--        -- For 'forall a . t'-       ,(".",   ITdot,                      NormalSyntax,  0 )--       ,("-<",  ITlarrowtail NormalSyntax,  NormalSyntax,  xbit ArrowsBit)-       ,(">-",  ITrarrowtail NormalSyntax,  NormalSyntax,  xbit ArrowsBit)-       ,("-<<", ITLarrowtail NormalSyntax,  NormalSyntax,  xbit ArrowsBit)-       ,(">>-", ITRarrowtail NormalSyntax,  NormalSyntax,  xbit ArrowsBit)--       ,("∷",   ITdcolon UnicodeSyntax,     UnicodeSyntax, 0 )-       ,("⇒",   ITdarrow UnicodeSyntax,     UnicodeSyntax, 0 )-       ,("∀",   ITforall UnicodeSyntax,     UnicodeSyntax, 0 )-       ,("→",   ITrarrow UnicodeSyntax,     UnicodeSyntax, 0 )-       ,("←",   ITlarrow UnicodeSyntax,     UnicodeSyntax, 0 )--       ,("⊸",   ITlolly, UnicodeSyntax, 0)--       ,("⤙",   ITlarrowtail UnicodeSyntax, UnicodeSyntax, xbit ArrowsBit)-       ,("⤚",   ITrarrowtail UnicodeSyntax, UnicodeSyntax, xbit ArrowsBit)-       ,("⤛",   ITLarrowtail UnicodeSyntax, UnicodeSyntax, xbit ArrowsBit)-       ,("⤜",   ITRarrowtail UnicodeSyntax, UnicodeSyntax, xbit ArrowsBit)--       ,("★",   ITstar UnicodeSyntax,       UnicodeSyntax, xbit StarIsTypeBit)--        -- ToDo: ideally, → and ∷ should be "specials", so that they cannot-        -- form part of a large operator.  This would let us have a better-        -- syntax for kinds: ɑ∷*→* would be a legal kind signature. (maybe).-       ]---- -------------------------------------------------------------------------------- Lexer actions--type Action = PsSpan -> StringBuffer -> Int -> P (PsLocated Token)--special :: Token -> Action-special tok span _buf _len = return (L span tok)--token, layout_token :: Token -> Action-token t span _buf _len = return (L span t)-layout_token t span _buf _len = pushLexState layout >> return (L span t)--idtoken :: (StringBuffer -> Int -> Token) -> Action-idtoken f span buf len = return (L span $! (f buf len))--qdo_token :: (Maybe FastString -> Token) -> Action-qdo_token con span buf len = do-    maybe_layout token-    return (L span $! token)-  where-    !token = con $! Just $! fst $! splitQualName buf len False--skip_one_varid :: (FastString -> Token) -> Action-skip_one_varid f span buf len-  = return (L span $! f (lexemeToFastString (stepOn buf) (len-1)))--skip_two_varid :: (FastString -> Token) -> Action-skip_two_varid f span buf len-  = return (L span $! f (lexemeToFastString (stepOn (stepOn buf)) (len-2)))--strtoken :: (String -> Token) -> Action-strtoken f span buf len =-  return (L span $! (f $! lexemeToString buf len))--begin :: Int -> Action-begin code _span _str _len = do pushLexState code; lexToken--pop :: Action-pop _span _buf _len = do _ <- popLexState-                         lexToken--- See Note [Nested comment line pragmas]-failLinePrag1 :: Action-failLinePrag1 span _buf _len = do-  b <- getBit InNestedCommentBit-  if b then return (L span ITcomment_line_prag)-       else lexError LexErrorInPragma---- See Note [Nested comment line pragmas]-popLinePrag1 :: Action-popLinePrag1 span _buf _len = do-  b <- getBit InNestedCommentBit-  if b then return (L span ITcomment_line_prag) else do-    _ <- popLexState-    lexToken--hopefully_open_brace :: Action-hopefully_open_brace span buf len- = do relaxed <- getBit RelaxedLayoutBit-      ctx <- getContext-      (AI l _) <- getInput-      let offset = srcLocCol (psRealLoc l)-          isOK = relaxed ||-                 case ctx of-                 Layout prev_off _ : _ -> prev_off < offset-                 _                     -> True-      if isOK then pop_and open_brace span buf len-              else addFatalError $ PsError PsErrMissingBlock [] (mkSrcSpanPs span)--pop_and :: Action -> Action-pop_and act span buf len = do _ <- popLexState-                              act span buf len---- See Note [Whitespace-sensitive operator parsing]-followedByOpeningToken :: AlexAccPred ExtsBitmap-followedByOpeningToken _ _ _ (AI _ buf)-  | atEnd buf = False-  | otherwise =-      case nextChar buf of-        ('{', buf') -> nextCharIsNot buf' (== '-')-        ('(', _) -> True-        ('[', _) -> True-        ('\"', _) -> True-        ('\'', _) -> True-        ('_', _) -> True-        ('⟦', _) -> True-        ('⦇', _) -> True-        (c, _) -> isAlphaNum c---- See Note [Whitespace-sensitive operator parsing]-precededByClosingToken :: AlexAccPred ExtsBitmap-precededByClosingToken _ (AI _ buf) _ _ =-  case prevChar buf '\n' of-    '}' -> decodePrevNChars 1 buf /= "-"-    ')' -> True-    ']' -> True-    '\"' -> True-    '\'' -> True-    '_' -> True-    '⟧' -> True-    '⦈' -> True-    c -> isAlphaNum c--{-# INLINE nextCharIs #-}-nextCharIs :: StringBuffer -> (Char -> Bool) -> Bool-nextCharIs buf p = not (atEnd buf) && p (currentChar buf)--{-# INLINE nextCharIsNot #-}-nextCharIsNot :: StringBuffer -> (Char -> Bool) -> Bool-nextCharIsNot buf p = not (nextCharIs buf p)--notFollowedBy :: Char -> AlexAccPred ExtsBitmap-notFollowedBy char _ _ _ (AI _ buf)-  = nextCharIsNot buf (== char)--notFollowedBySymbol :: AlexAccPred ExtsBitmap-notFollowedBySymbol _ _ _ (AI _ buf)-  = nextCharIsNot buf (`elem` "!#$%&*+./<=>?@\\^|-~")--followedByDigit :: AlexAccPred ExtsBitmap-followedByDigit _ _ _ (AI _ buf)-  = afterOptionalSpace buf (\b -> nextCharIs b (`elem` ['0'..'9']))--ifCurrentChar :: Char -> AlexAccPred ExtsBitmap-ifCurrentChar char _ (AI _ buf) _ _-  = nextCharIs buf (== char)---- We must reject doc comments as being ordinary comments everywhere.--- In some cases the doc comment will be selected as the lexeme due to--- maximal munch, but not always, because the nested comment rule is--- valid in all states, but the doc-comment rules are only valid in--- the non-layout states.-isNormalComment :: AlexAccPred ExtsBitmap-isNormalComment bits _ _ (AI _ buf)-  | HaddockBit `xtest` bits = notFollowedByDocOrPragma-  | otherwise               = nextCharIsNot buf (== '#')-  where-    notFollowedByDocOrPragma-       = afterOptionalSpace buf (\b -> nextCharIsNot b (`elem` "|^*$#"))--afterOptionalSpace :: StringBuffer -> (StringBuffer -> Bool) -> Bool-afterOptionalSpace buf p-    = if nextCharIs buf (== ' ')-      then p (snd (nextChar buf))-      else p buf--atEOL :: AlexAccPred ExtsBitmap-atEOL _ _ _ (AI _ buf) = atEnd buf || currentChar buf == '\n'---- Check if we should parse a negative literal (e.g. -123) as a single token.-negLitPred :: AlexAccPred ExtsBitmap-negLitPred =-    prefix_minus `alexAndPred`-    (negative_literals `alexOrPred` lexical_negation)-  where-    negative_literals = ifExtension NegativeLiteralsBit--    lexical_negation  =-      -- See Note [Why not LexicalNegationBit]-      alexNotPred (ifExtension NoLexicalNegationBit)--    prefix_minus =-      -- Note [prefix_minus in negLitPred and negHashLitPred]-      alexNotPred precededByClosingToken---- Check if we should parse an unboxed negative literal (e.g. -123#) as a single token.-negHashLitPred :: AlexAccPred ExtsBitmap-negHashLitPred = prefix_minus `alexAndPred` magic_hash-  where-    magic_hash = ifExtension MagicHashBit-    prefix_minus =-      -- Note [prefix_minus in negLitPred and negHashLitPred]-      alexNotPred precededByClosingToken--{- Note [prefix_minus in negLitPred and negHashLitPred]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We want to parse -1 as a single token, but x-1 as three tokens.-So in negLitPred (and negHashLitPred) we require that we have a prefix-occurrence of the minus sign. See Note [Whitespace-sensitive operator parsing]-for a detailed definition of a prefix occurrence.--The condition for a prefix occurrence of an operator is:--  not precededByClosingToken && followedByOpeningToken--but we don't check followedByOpeningToken when parsing a negative literal.-It holds simply because we immediately lex a literal after the minus.--}--ifExtension :: ExtBits -> AlexAccPred ExtsBitmap-ifExtension extBits bits _ _ _ = extBits `xtest` bits--alexNotPred p userState in1 len in2-  = not (p userState in1 len in2)--alexOrPred p1 p2 userState in1 len in2-  = p1 userState in1 len in2 || p2 userState in1 len in2--multiline_doc_comment :: Action-multiline_doc_comment span buf _len = withLexedDocType (worker "")-  where-    worker commentAcc input docType checkNextLine = case alexGetChar' input of-      Just ('\n', input')-        | checkNextLine -> case checkIfCommentLine input' of-          Just input -> worker ('\n':commentAcc) input docType checkNextLine-          Nothing -> docCommentEnd input commentAcc docType buf span-        | otherwise -> docCommentEnd input commentAcc docType buf span-      Just (c, input) -> worker (c:commentAcc) input docType checkNextLine-      Nothing -> docCommentEnd input commentAcc docType buf span--    -- Check if the next line of input belongs to this doc comment as well.-    -- A doc comment continues onto the next line when the following-    -- conditions are met:-    --   * The line starts with "--"-    --   * The line doesn't start with "---".-    --   * The line doesn't start with "-- $", because that would be the-    --     start of a /new/ named haddock chunk (#10398).-    checkIfCommentLine :: AlexInput -> Maybe AlexInput-    checkIfCommentLine input = check (dropNonNewlineSpace input)-      where-        check input = do-          ('-', input) <- alexGetChar' input-          ('-', input) <- alexGetChar' input-          (c, after_c) <- alexGetChar' input-          case c of-            '-' -> Nothing-            ' ' -> case alexGetChar' after_c of-                     Just ('$', _) -> Nothing-                     _ -> Just input-            _   -> Just input--        dropNonNewlineSpace input = case alexGetChar' input of-          Just (c, input')-            | isSpace c && c /= '\n' -> dropNonNewlineSpace input'-            | otherwise -> input-          Nothing -> input--lineCommentToken :: Action-lineCommentToken span buf len = do-  b <- getBit RawTokenStreamBit-  if b then do-         lt <- getLastLocComment-         strtoken (\s -> ITlineComment s lt) span buf len-       else lexToken---{--  nested comments require traversing by hand, they can't be parsed-  using regular expressions.--}-nested_comment :: P (PsLocated Token) -> Action-nested_comment cont span buf len = do-  input <- getInput-  go (reverse $ lexemeToString buf len) (1::Int) input-  where-    go commentAcc 0 input = do-      l <- getLastLocComment-      let finalizeComment str = (Nothing, ITblockComment str l)-      commentEnd cont input commentAcc finalizeComment buf span-    go commentAcc n input = case alexGetChar' input of-      Nothing -> errBrace input (psRealSpan span)-      Just ('-',input) -> case alexGetChar' input of-        Nothing  -> errBrace input (psRealSpan span)-        Just ('\125',input) -> go ('\125':'-':commentAcc) (n-1) input -- '}'-        Just (_,_)          -> go ('-':commentAcc) n input-      Just ('\123',input) -> case alexGetChar' input of  -- '{' char-        Nothing  -> errBrace input (psRealSpan span)-        Just ('-',input) -> go ('-':'\123':commentAcc) (n+1) input-        Just (_,_)       -> go ('\123':commentAcc) n input-      -- See Note [Nested comment line pragmas]-      Just ('\n',input) -> case alexGetChar' input of-        Nothing  -> errBrace input (psRealSpan span)-        Just ('#',_) -> do (parsedAcc,input) <- parseNestedPragma input-                           go (parsedAcc ++ '\n':commentAcc) n input-        Just (_,_)   -> go ('\n':commentAcc) n input-      Just (c,input) -> go (c:commentAcc) n input--nested_doc_comment :: Action-nested_doc_comment span buf _len = withLexedDocType (go "")-  where-    go commentAcc input docType _ = case alexGetChar' input of-      Nothing -> errBrace input (psRealSpan span)-      Just ('-',input) -> case alexGetChar' input of-        Nothing -> errBrace input (psRealSpan span)-        Just ('\125',input) ->-          docCommentEnd input commentAcc docType buf span-        Just (_,_) -> go ('-':commentAcc) input docType False-      Just ('\123', input) -> case alexGetChar' input of-        Nothing  -> errBrace input (psRealSpan span)-        Just ('-',input) -> do-          setInput input-          let cont = do input <- getInput; go commentAcc input docType False-          nested_comment cont span buf _len-        Just (_,_) -> go ('\123':commentAcc) input docType False-      -- See Note [Nested comment line pragmas]-      Just ('\n',input) -> case alexGetChar' input of-        Nothing  -> errBrace input (psRealSpan span)-        Just ('#',_) -> do (parsedAcc,input) <- parseNestedPragma input-                           go (parsedAcc ++ '\n':commentAcc) input docType False-        Just (_,_)   -> go ('\n':commentAcc) input docType False-      Just (c,input) -> go (c:commentAcc) input docType False---- See Note [Nested comment line pragmas]-parseNestedPragma :: AlexInput -> P (String,AlexInput)-parseNestedPragma input@(AI _ buf) = do-  origInput <- getInput-  setInput input-  setExts (.|. xbit InNestedCommentBit)-  pushLexState bol-  lt <- lexToken-  _ <- popLexState-  setExts (.&. complement (xbit InNestedCommentBit))-  postInput@(AI _ postBuf) <- getInput-  setInput origInput-  case unLoc lt of-    ITcomment_line_prag -> do-      let bytes = byteDiff buf postBuf-          diff  = lexemeToString buf bytes-      return (reverse diff, postInput)-    lt' -> panic ("parseNestedPragma: unexpected token" ++ (show lt'))--{--Note [Nested comment line pragmas]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We used to ignore cpp-preprocessor-generated #line pragmas if they were inside-nested comments.--Now, when parsing a nested comment, if we encounter a line starting with '#' we-call parseNestedPragma, which executes the following:-1. Save the current lexer input (loc, buf) for later-2. Set the current lexer input to the beginning of the line starting with '#'-3. Turn the 'InNestedComment' extension on-4. Push the 'bol' lexer state-5. Lex a token. Due to (2), (3), and (4), this should always lex a single line-   or less and return the ITcomment_line_prag token. This may set source line-   and file location if a #line pragma is successfully parsed-6. Restore lexer input and state to what they were before we did all this-7. Return control to the function parsing a nested comment, informing it of-   what the lexer parsed--Regarding (5) above:-Every exit from the 'bol' lexer state (do_bol, popLinePrag1, failLinePrag1)-checks if the 'InNestedComment' extension is set. If it is, that function will-return control to parseNestedPragma by returning the ITcomment_line_prag token.--See #314 for more background on the bug this fixes.--}--withLexedDocType :: (AlexInput -> (String -> (HdkComment, Token)) -> Bool -> P (PsLocated Token))-                 -> P (PsLocated Token)-withLexedDocType lexDocComment = do-  input@(AI _ buf) <- getInput-  l <- getLastLocComment-  case prevChar buf ' ' of-    -- The `Bool` argument to lexDocComment signals whether or not the next-    -- line of input might also belong to this doc comment.-    '|' -> lexDocComment input (mkHdkCommentNext l) True-    '^' -> lexDocComment input (mkHdkCommentPrev l) True-    '$' -> lexDocComment input (mkHdkCommentNamed l) True-    '*' -> lexDocSection l 1 input-    _ -> panic "withLexedDocType: Bad doc type"- where-    lexDocSection l n input = case alexGetChar' input of-      Just ('*', input) -> lexDocSection l (n+1) input-      Just (_,   _)     -> lexDocComment input (mkHdkCommentSection l n) False-      Nothing -> do setInput input; lexToken -- eof reached, lex it normally--mkHdkCommentNext, mkHdkCommentPrev :: PsSpan -> String -> (HdkComment, Token)-mkHdkCommentNext loc str = (HdkCommentNext (mkHsDocString str), ITdocCommentNext str loc)-mkHdkCommentPrev loc str = (HdkCommentPrev (mkHsDocString str), ITdocCommentPrev str loc)--mkHdkCommentNamed :: PsSpan -> String -> (HdkComment, Token)-mkHdkCommentNamed loc str =-  let (name, rest) = break isSpace str-  in (HdkCommentNamed name (mkHsDocString rest), ITdocCommentNamed str loc)--mkHdkCommentSection :: PsSpan -> Int -> String -> (HdkComment, Token)-mkHdkCommentSection loc n str =-  (HdkCommentSection n (mkHsDocString str), ITdocSection n str loc)---- RULES pragmas turn on the forall and '.' keywords, and we turn them--- off again at the end of the pragma.-rulePrag :: Action-rulePrag span buf len = do-  setExts (.|. xbit InRulePragBit)-  let !src = lexemeToString buf len-  return (L span (ITrules_prag (SourceText src)))---- When 'UsePosPragsBit' is not set, it is expected that we emit a token instead--- of updating the position in 'PState'-linePrag :: Action-linePrag span buf len = do-  usePosPrags <- getBit UsePosPragsBit-  if usePosPrags-    then begin line_prag2 span buf len-    else let !src = lexemeToString buf len-         in return (L span (ITline_prag (SourceText src)))---- When 'UsePosPragsBit' is not set, it is expected that we emit a token instead--- of updating the position in 'PState'-columnPrag :: Action-columnPrag span buf len = do-  usePosPrags <- getBit UsePosPragsBit-  let !src = lexemeToString buf len-  if usePosPrags-    then begin column_prag span buf len-    else let !src = lexemeToString buf len-         in return (L span (ITcolumn_prag (SourceText src)))--endPrag :: Action-endPrag span _buf _len = do-  setExts (.&. complement (xbit InRulePragBit))-  return (L span ITclose_prag)---- docCommentEnd----------------------------------------------------------------------------------- This function is quite tricky. We can't just return a new token, we also--- need to update the state of the parser. Why? Because the token is longer--- than what was lexed by Alex, and the lexToken function doesn't know this, so--- it writes the wrong token length to the parser state. This function is--- called afterwards, so it can just update the state.--commentEnd :: P (PsLocated Token)-           -> AlexInput-           -> String-           -> (String -> (Maybe HdkComment, Token))-           -> StringBuffer-           -> PsSpan-           -> P (PsLocated Token)-commentEnd cont input commentAcc finalizeComment buf span = do-  setInput input-  let (AI loc nextBuf) = input-      comment = reverse commentAcc-      span' = mkPsSpan (psSpanStart span) loc-      last_len = byteDiff buf nextBuf-  span `seq` setLastToken span' last_len-  let (m_hdk_comment, hdk_token) = finalizeComment comment-  whenIsJust m_hdk_comment $ \hdk_comment ->-    P $ \s -> POk (s {hdk_comments = hdk_comments s `snocOL` L span' hdk_comment}) ()-  b <- getBit RawTokenStreamBit-  if b then return (L span' hdk_token)-       else cont--docCommentEnd :: AlexInput -> String -> (String -> (HdkComment, Token)) -> StringBuffer ->-                 PsSpan -> P (PsLocated Token)-docCommentEnd input commentAcc docType buf span = do-  let finalizeComment str =-        let (hdk_comment, token) = docType str-        in (Just hdk_comment, token)-  commentEnd lexToken input commentAcc finalizeComment buf span--errBrace :: AlexInput -> RealSrcSpan -> P a-errBrace (AI end _) span = failLocMsgP (realSrcSpanStart span) (psRealLoc end) (PsError (PsErrLexer LexUnterminatedComment LexErrKind_EOF) [])--open_brace, close_brace :: Action-open_brace span _str _len = do-  ctx <- getContext-  setContext (NoLayout:ctx)-  return (L span ITocurly)-close_brace span _str _len = do-  popContext-  return (L span ITccurly)--qvarid, qconid :: StringBuffer -> Int -> Token-qvarid buf len = ITqvarid $! splitQualName buf len False-qconid buf len = ITqconid $! splitQualName buf len False--splitQualName :: StringBuffer -> Int -> Bool -> (FastString,FastString)--- takes a StringBuffer and a length, and returns the module name--- and identifier parts of a qualified name.  Splits at the *last* dot,--- because of hierarchical module names.------ Throws an error if the name is not qualified.-splitQualName orig_buf len parens = split orig_buf orig_buf-  where-    split buf dot_buf-        | orig_buf `byteDiff` buf >= len  = done dot_buf-        | c == '.'                        = found_dot buf'-        | otherwise                       = split buf' dot_buf-      where-       (c,buf') = nextChar buf--    -- careful, we might get names like M....-    -- so, if the character after the dot is not upper-case, this is-    -- the end of the qualifier part.-    found_dot buf -- buf points after the '.'-        | isUpper c    = split buf' buf-        | otherwise    = done buf-      where-       (c,buf') = nextChar buf--    done dot_buf-        | qual_size < 1 = error "splitQualName got an unqualified named"-        | otherwise =-        (lexemeToFastString orig_buf (qual_size - 1),-         if parens -- Prelude.(+)-            then lexemeToFastString (stepOn dot_buf) (len - qual_size - 2)-            else lexemeToFastString dot_buf (len - qual_size))-      where-        qual_size = orig_buf `byteDiff` dot_buf--varid :: Action-varid span buf len =-  case lookupUFM reservedWordsFM fs of-    Just (ITcase, _) -> do-      lastTk <- getLastTk-      keyword <- case lastTk of-        Just (L _ ITlam) -> do-          lambdaCase <- getBit LambdaCaseBit-          unless lambdaCase $ do-            pState <- getPState-            addError $ PsError PsErrLambdaCase [] (mkSrcSpanPs (last_loc pState))-          return ITlcase-        _ -> return ITcase-      maybe_layout keyword-      return $ L span keyword-    Just (keyword, 0) -> do-      maybe_layout keyword-      return $ L span keyword-    Just (keyword, i) -> do-      exts <- getExts-      if exts .&. i /= 0-        then do-          maybe_layout keyword-          return $ L span keyword-        else-          return $ L span $ ITvarid fs-    Nothing ->-      return $ L span $ ITvarid fs-  where-    !fs = lexemeToFastString buf len--conid :: StringBuffer -> Int -> Token-conid buf len = ITconid $! lexemeToFastString buf len--qvarsym, qconsym :: StringBuffer -> Int -> Token-qvarsym buf len = ITqvarsym $! splitQualName buf len False-qconsym buf len = ITqconsym $! splitQualName buf len False---- See Note [Whitespace-sensitive operator parsing]-varsym_prefix :: Action-varsym_prefix = sym $ \span exts s ->-  let warnExtConflict errtok =-        do { addWarning Opt_WarnOperatorWhitespaceExtConflict $-               PsWarnOperatorWhitespaceExtConflict (mkSrcSpanPs span) errtok-           ; return (ITvarsym s) }-  in-  if | s == fsLit "@" ->-         return ITtypeApp  -- regardless of TypeApplications for better error messages-     | s == fsLit "%" ->-         if xtest LinearTypesBit exts-         then return ITpercent-         else warnExtConflict OperatorWhitespaceSymbol_PrefixPercent-     | s == fsLit "$" ->-         if xtest ThQuotesBit exts-         then return ITdollar-         else warnExtConflict OperatorWhitespaceSymbol_PrefixDollar-     | s == fsLit "$$" ->-         if xtest ThQuotesBit exts-         then return ITdollardollar-         else warnExtConflict OperatorWhitespaceSymbol_PrefixDollarDollar-     | s == fsLit "-" ->-         return ITprefixminus -- Only when LexicalNegation is on, otherwise we get ITminus-                              -- and don't hit this code path. See Note [Minus tokens]-     | s == fsLit ".", OverloadedRecordDotBit `xtest` exts ->-         return (ITproj True) -- e.g. '(.x)'-     | s == fsLit "." -> return ITdot-     | s == fsLit "!" -> return ITbang-     | s == fsLit "~" -> return ITtilde-     | otherwise ->-         do { addWarning Opt_WarnOperatorWhitespace $-                PsWarnOperatorWhitespace (mkSrcSpanPs span) s-                  OperatorWhitespaceOccurrence_Prefix-            ; return (ITvarsym s) }---- See Note [Whitespace-sensitive operator parsing]-varsym_suffix :: Action-varsym_suffix = sym $ \span _ s ->-  if | s == fsLit "@" -> failMsgP (PsError PsErrSuffixAT [])-     | s == fsLit "." -> return ITdot-     | otherwise ->-         do { addWarning Opt_WarnOperatorWhitespace $-                PsWarnOperatorWhitespace (mkSrcSpanPs span) s-                  OperatorWhitespaceOccurrence_Suffix-            ; return (ITvarsym s) }---- See Note [Whitespace-sensitive operator parsing]-varsym_tight_infix :: Action-varsym_tight_infix = sym $ \span exts s ->-  if | s == fsLit "@" -> return ITat-     | s == fsLit ".", OverloadedRecordDotBit `xtest` exts  -> return (ITproj False)-     | s == fsLit "." -> return ITdot-     | otherwise ->-         do { addWarning Opt_WarnOperatorWhitespace $-                PsWarnOperatorWhitespace (mkSrcSpanPs span) s-                  OperatorWhitespaceOccurrence_TightInfix-            ;  return (ITvarsym s) }---- See Note [Whitespace-sensitive operator parsing]-varsym_loose_infix :: Action-varsym_loose_infix = sym $ \_ _ s ->-  if | s == fsLit "."-     -> return ITdot-     | otherwise-     -> return $ ITvarsym s--consym :: Action-consym = sym (\_span _exts s -> return $ ITconsym s)--sym :: (PsSpan -> ExtsBitmap -> FastString -> P Token) -> Action-sym con span buf len =-  case lookupUFM reservedSymsFM fs of-    Just (keyword, NormalSyntax, 0) -> do-      exts <- getExts-      if fs == fsLit "." &&-         exts .&. (xbit OverloadedRecordDotBit) /= 0 &&-         xtest OverloadedRecordDotBit exts-      then L span <$!> con span exts fs  -- Process by varsym_*.-      else return $ L span keyword-    Just (keyword, NormalSyntax, i) -> do-      exts <- getExts-      if exts .&. i /= 0-        then return $ L span keyword-        else L span <$!> con span exts fs-    Just (keyword, UnicodeSyntax, 0) -> do-      exts <- getExts-      if xtest UnicodeSyntaxBit exts-        then return $ L span keyword-        else L span <$!> con span exts fs-    Just (keyword, UnicodeSyntax, i) -> do-      exts <- getExts-      if exts .&. i /= 0 && xtest UnicodeSyntaxBit exts-        then return $ L span keyword-        else L span <$!> con span exts fs-    Nothing -> do-      exts <- getExts-      L span <$!> con span exts fs-  where-    !fs = lexemeToFastString buf len---- Variations on the integral numeric literal.-tok_integral :: (SourceText -> Integer -> Token)-             -> (Integer -> Integer)-             -> Int -> Int-             -> (Integer, (Char -> Int))-             -> Action-tok_integral itint transint transbuf translen (radix,char_to_int) span buf len = do-  numericUnderscores <- getBit NumericUnderscoresBit  -- #14473-  let src = lexemeToString buf len-  when ((not numericUnderscores) && ('_' `elem` src)) $ do-    pState <- getPState-    addError $ PsError (PsErrNumUnderscores NumUnderscore_Integral) [] (mkSrcSpanPs (last_loc pState))-  return $ L span $ itint (SourceText src)-       $! transint $ parseUnsignedInteger-       (offsetBytes transbuf buf) (subtract translen len) radix char_to_int--tok_num :: (Integer -> Integer)-        -> Int -> Int-        -> (Integer, (Char->Int)) -> Action-tok_num = tok_integral $ \case-    st@(SourceText ('-':_)) -> itint st (const True)-    st@(SourceText _)       -> itint st (const False)-    st@NoSourceText         -> itint st (< 0)-  where-    itint :: SourceText -> (Integer -> Bool) -> Integer -> Token-    itint !st is_negative !val = ITinteger ((IL st $! is_negative val) val)--tok_primint :: (Integer -> Integer)-            -> Int -> Int-            -> (Integer, (Char->Int)) -> Action-tok_primint = tok_integral ITprimint---tok_primword :: Int -> Int-             -> (Integer, (Char->Int)) -> Action-tok_primword = tok_integral ITprimword positive-positive, negative :: (Integer -> Integer)-positive = id-negative = negate-decimal, octal, hexadecimal :: (Integer, Char -> Int)-decimal = (10,octDecDigit)-binary = (2,octDecDigit)-octal = (8,octDecDigit)-hexadecimal = (16,hexDigit)---- readSignificandExponentPair can understand negative rationals, exponents, everything.-tok_frac :: Int -> (String -> Token) -> Action-tok_frac drop f span buf len = do-  numericUnderscores <- getBit NumericUnderscoresBit  -- #14473-  let src = lexemeToString buf (len-drop)-  when ((not numericUnderscores) && ('_' `elem` src)) $ do-    pState <- getPState-    addError $ PsError (PsErrNumUnderscores NumUnderscore_Float) [] (mkSrcSpanPs (last_loc pState))-  return (L span $! (f $! src))--tok_float, tok_primfloat, tok_primdouble :: String -> Token-tok_float        str = ITrational   $! readFractionalLit str-tok_hex_float    str = ITrational   $! readHexFractionalLit str-tok_primfloat    str = ITprimfloat  $! readFractionalLit str-tok_primdouble   str = ITprimdouble $! readFractionalLit str--readFractionalLit, readHexFractionalLit :: String -> FractionalLit-readHexFractionalLit = readFractionalLitX readHexSignificandExponentPair Base2-readFractionalLit = readFractionalLitX readSignificandExponentPair Base10--readFractionalLitX :: (String -> (Integer, Integer))-                   -> FractionalExponentBase-                   -> String -> FractionalLit-readFractionalLitX readStr b str =-  mkSourceFractionalLit str is_neg i e b-  where-    is_neg = case str of-                    '-' : _ -> True-                    _      -> False-    (i, e) = readStr str---- -------------------------------------------------------------------------------- Layout processing---- we're at the first token on a line, insert layout tokens if necessary-do_bol :: Action-do_bol span _str _len = do-        -- See Note [Nested comment line pragmas]-        b <- getBit InNestedCommentBit-        if b then return (L span ITcomment_line_prag) else do-          (pos, gen_semic) <- getOffside-          case pos of-              LT -> do-                  --trace "layout: inserting '}'" $ do-                  popContext-                  -- do NOT pop the lex state, we might have a ';' to insert-                  return (L span ITvccurly)-              EQ | gen_semic -> do-                  --trace "layout: inserting ';'" $ do-                  _ <- popLexState-                  return (L span ITsemi)-              _ -> do-                  _ <- popLexState-                  lexToken---- certain keywords put us in the "layout" state, where we might--- add an opening curly brace.-maybe_layout :: Token -> P ()-maybe_layout t = do -- If the alternative layout rule is enabled then-                    -- we never create an implicit layout context here.-                    -- Layout is handled XXX instead.-                    -- The code for closing implicit contexts, or-                    -- inserting implicit semi-colons, is therefore-                    -- irrelevant as it only applies in an implicit-                    -- context.-                    alr <- getBit AlternativeLayoutRuleBit-                    unless alr $ f t-    where f (ITdo _)    = pushLexState layout_do-          f (ITmdo _)   = pushLexState layout_do-          f ITof        = pushLexState layout-          f ITlcase     = pushLexState layout-          f ITlet       = pushLexState layout-          f ITwhere     = pushLexState layout-          f ITrec       = pushLexState layout-          f ITif        = pushLexState layout_if-          f _           = return ()---- Pushing a new implicit layout context.  If the indentation of the--- next token is not greater than the previous layout context, then--- Haskell 98 says that the new layout context should be empty; that is--- the lexer must generate {}.------ We are slightly more lenient than this: when the new context is started--- by a 'do', then we allow the new context to be at the same indentation as--- the previous context.  This is what the 'strict' argument is for.-new_layout_context :: Bool -> Bool -> Token -> Action-new_layout_context strict gen_semic tok span _buf len = do-    _ <- popLexState-    (AI l _) <- getInput-    let offset = srcLocCol (psRealLoc l) - len-    ctx <- getContext-    nondecreasing <- getBit NondecreasingIndentationBit-    let strict' = strict || not nondecreasing-    case ctx of-        Layout prev_off _ : _  |-           (strict'     && prev_off >= offset  ||-            not strict' && prev_off > offset) -> do-                -- token is indented to the left of the previous context.-                -- we must generate a {} sequence now.-                pushLexState layout_left-                return (L span tok)-        _ -> do setContext (Layout offset gen_semic : ctx)-                return (L span tok)--do_layout_left :: Action-do_layout_left span _buf _len = do-    _ <- popLexState-    pushLexState bol  -- we must be at the start of a line-    return (L span ITvccurly)---- -------------------------------------------------------------------------------- LINE pragmas--setLineAndFile :: Int -> Action-setLineAndFile code (PsSpan span _) buf len = do-  let src = lexemeToString buf (len - 1)  -- drop trailing quotation mark-      linenumLen = length $ head $ words src-      linenum = parseUnsignedInteger buf linenumLen 10 octDecDigit-      file = mkFastString $ go $ drop 1 $ dropWhile (/= '"') src-          -- skip everything through first quotation mark to get to the filename-        where go ('\\':c:cs) = c : go cs-              go (c:cs)      = c : go cs-              go []          = []-              -- decode escapes in the filename.  e.g. on Windows-              -- when our filenames have backslashes in, gcc seems to-              -- escape the backslashes.  One symptom of not doing this-              -- is that filenames in error messages look a bit strange:-              --   C:\\foo\bar.hs-              -- only the first backslash is doubled, because we apply-              -- System.FilePath.normalise before printing out-              -- filenames and it does not remove duplicate-              -- backslashes after the drive letter (should it?).-  resetAlrLastLoc file-  setSrcLoc (mkRealSrcLoc file (fromIntegral linenum - 1) (srcSpanEndCol span))-      -- subtract one: the line number refers to the *following* line-  addSrcFile file-  _ <- popLexState-  pushLexState code-  lexToken--setColumn :: Action-setColumn (PsSpan span _) buf len = do-  let column =-        case reads (lexemeToString buf len) of-          [(column, _)] -> column-          _ -> error "setColumn: expected integer" -- shouldn't happen-  setSrcLoc (mkRealSrcLoc (srcSpanFile span) (srcSpanEndLine span)-                          (fromIntegral (column :: Integer)))-  _ <- popLexState-  lexToken--alrInitialLoc :: FastString -> RealSrcSpan-alrInitialLoc file = mkRealSrcSpan loc loc-    where -- This is a hack to ensure that the first line in a file-          -- looks like it is after the initial location:-          loc = mkRealSrcLoc file (-1) (-1)---- -------------------------------------------------------------------------------- Options, includes and language pragmas.---lex_string_prag :: (String -> Token) -> Action-lex_string_prag mkTok = lex_string_prag_comment mkTok'-  where-    mkTok' s _ = mkTok s--lex_string_prag_comment :: (String -> PsSpan -> Token) -> Action-lex_string_prag_comment mkTok span _buf _len-    = do input <- getInput-         start <- getParsedLoc-         l <- getLastLocComment-         tok <- go l [] input-         end <- getParsedLoc-         return (L (mkPsSpan start end) tok)-    where go l acc input-              = if isString input "#-}"-                   then do setInput input-                           return (mkTok (reverse acc) l)-                   else case alexGetChar input of-                          Just (c,i) -> go l (c:acc) i-                          Nothing -> err input-          isString _ [] = True-          isString i (x:xs)-              = case alexGetChar i of-                  Just (c,i') | c == x    -> isString i' xs-                  _other -> False-          err (AI end _) = failLocMsgP (realSrcSpanStart (psRealSpan span)) (psRealLoc end) (PsError (PsErrLexer LexUnterminatedOptions LexErrKind_EOF) [])---- -------------------------------------------------------------------------------- Strings & Chars---- This stuff is horrible.  I hates it.--lex_string_tok :: Action-lex_string_tok span buf _len = do-  tok <- lex_string ""-  (AI end bufEnd) <- getInput-  let-    tok' = case tok of-            ITprimstring _ bs -> ITprimstring (SourceText src) bs-            ITstring _ s -> ITstring (SourceText src) s-            _ -> panic "lex_string_tok"-    src = lexemeToString buf (cur bufEnd - cur buf)-  return (L (mkPsSpan (psSpanStart span) end) tok')--lex_string :: String -> P Token-lex_string s = do-  i <- getInput-  case alexGetChar' i of-    Nothing -> lit_error i--    Just ('"',i)  -> do-        setInput i-        let s' = reverse s-        magicHash <- getBit MagicHashBit-        if magicHash-          then do-            i <- getInput-            case alexGetChar' i of-              Just ('#',i) -> do-                setInput i-                when (any (> '\xFF') s') $ do-                  pState <- getPState-                  let err = PsError PsErrPrimStringInvalidChar [] (mkSrcSpanPs (last_loc pState))-                  addError err-                return (ITprimstring (SourceText s') (unsafeMkByteString s'))-              _other ->-                return (ITstring (SourceText s') (mkFastString s'))-          else-                return (ITstring (SourceText s') (mkFastString s'))--    Just ('\\',i)-        | Just ('&',i) <- next -> do-                setInput i; lex_string s-        | Just (c,i) <- next, c <= '\x7f' && is_space c -> do-                           -- is_space only works for <= '\x7f' (#3751, #5425)-                setInput i; lex_stringgap s-        where next = alexGetChar' i--    Just (c, i1) -> do-        case c of-          '\\' -> do setInput i1; c' <- lex_escape; lex_string (c':s)-          c | isAny c -> do setInput i1; lex_string (c:s)-          _other -> lit_error i--lex_stringgap :: String -> P Token-lex_stringgap s = do-  i <- getInput-  c <- getCharOrFail i-  case c of-    '\\' -> lex_string s-    c | c <= '\x7f' && is_space c -> lex_stringgap s-                           -- is_space only works for <= '\x7f' (#3751, #5425)-    _other -> lit_error i---lex_char_tok :: Action--- Here we are basically parsing character literals, such as 'x' or '\n'--- but we additionally spot 'x and ''T, returning ITsimpleQuote and--- ITtyQuote respectively, but WITHOUT CONSUMING the x or T part--- (the parser does that).--- So we have to do two characters of lookahead: when we see 'x we need to--- see if there's a trailing quote-lex_char_tok span buf _len = do        -- We've seen '-   i1 <- getInput       -- Look ahead to first character-   let loc = psSpanStart span-   case alexGetChar' i1 of-        Nothing -> lit_error  i1--        Just ('\'', i2@(AI end2 _)) -> do       -- We've seen ''-                   setInput i2-                   return (L (mkPsSpan loc end2)  ITtyQuote)--        Just ('\\', i2@(AI _end2 _)) -> do      -- We've seen 'backslash-                  setInput i2-                  lit_ch <- lex_escape-                  i3 <- getInput-                  mc <- getCharOrFail i3 -- Trailing quote-                  if mc == '\'' then finish_char_tok buf loc lit_ch-                                else lit_error i3--        Just (c, i2@(AI _end2 _))-                | not (isAny c) -> lit_error i1-                | otherwise ->--                -- We've seen 'x, where x is a valid character-                --  (i.e. not newline etc) but not a quote or backslash-           case alexGetChar' i2 of      -- Look ahead one more character-                Just ('\'', i3) -> do   -- We've seen 'x'-                        setInput i3-                        finish_char_tok buf loc c-                _other -> do            -- We've seen 'x not followed by quote-                                        -- (including the possibility of EOF)-                                        -- Just parse the quote only-                        let (AI end _) = i1-                        return (L (mkPsSpan loc end) ITsimpleQuote)--finish_char_tok :: StringBuffer -> PsLoc -> Char -> P (PsLocated Token)-finish_char_tok buf loc ch  -- We've already seen the closing quote-                        -- Just need to check for trailing #-  = do  magicHash <- getBit MagicHashBit-        i@(AI end bufEnd) <- getInput-        let src = lexemeToString buf (cur bufEnd - cur buf)-        if magicHash then do-            case alexGetChar' i of-              Just ('#',i@(AI end _)) -> do-                setInput i-                return (L (mkPsSpan loc end)-                          (ITprimchar (SourceText src) ch))-              _other ->-                return (L (mkPsSpan loc end)-                          (ITchar (SourceText src) ch))-            else do-              return (L (mkPsSpan loc end) (ITchar (SourceText src) ch))--isAny :: Char -> Bool-isAny c | c > '\x7f' = isPrint c-        | otherwise  = is_any c--lex_escape :: P Char-lex_escape = do-  i0 <- getInput-  c <- getCharOrFail i0-  case c of-        'a'   -> return '\a'-        'b'   -> return '\b'-        'f'   -> return '\f'-        'n'   -> return '\n'-        'r'   -> return '\r'-        't'   -> return '\t'-        'v'   -> return '\v'-        '\\'  -> return '\\'-        '"'   -> return '\"'-        '\''  -> return '\''-        '^'   -> do i1 <- getInput-                    c <- getCharOrFail i1-                    if c >= '@' && c <= '_'-                        then return (chr (ord c - ord '@'))-                        else lit_error i1--        'x'   -> readNum is_hexdigit 16 hexDigit-        'o'   -> readNum is_octdigit  8 octDecDigit-        x | is_decdigit x -> readNum2 is_decdigit 10 octDecDigit (octDecDigit x)--        c1 ->  do-           i <- getInput-           case alexGetChar' i of-            Nothing -> lit_error i0-            Just (c2,i2) ->-              case alexGetChar' i2 of-                Nothing -> do lit_error i0-                Just (c3,i3) ->-                   let str = [c1,c2,c3] in-                   case [ (c,rest) | (p,c) <- silly_escape_chars,-                                     Just rest <- [stripPrefix p str] ] of-                          (escape_char,[]):_ -> do-                                setInput i3-                                return escape_char-                          (escape_char,_:_):_ -> do-                                setInput i2-                                return escape_char-                          [] -> lit_error i0--readNum :: (Char -> Bool) -> Int -> (Char -> Int) -> P Char-readNum is_digit base conv = do-  i <- getInput-  c <- getCharOrFail i-  if is_digit c-        then readNum2 is_digit base conv (conv c)-        else lit_error i--readNum2 :: (Char -> Bool) -> Int -> (Char -> Int) -> Int -> P Char-readNum2 is_digit base conv i = do-  input <- getInput-  read i input-  where read i input = do-          case alexGetChar' input of-            Just (c,input') | is_digit c -> do-               let i' = i*base + conv c-               if i' > 0x10ffff-                  then setInput input >> lexError LexNumEscapeRange-                  else read i' input'-            _other -> do-              setInput input; return (chr i)---silly_escape_chars :: [(String, Char)]-silly_escape_chars = [-        ("NUL", '\NUL'),-        ("SOH", '\SOH'),-        ("STX", '\STX'),-        ("ETX", '\ETX'),-        ("EOT", '\EOT'),-        ("ENQ", '\ENQ'),-        ("ACK", '\ACK'),-        ("BEL", '\BEL'),-        ("BS", '\BS'),-        ("HT", '\HT'),-        ("LF", '\LF'),-        ("VT", '\VT'),-        ("FF", '\FF'),-        ("CR", '\CR'),-        ("SO", '\SO'),-        ("SI", '\SI'),-        ("DLE", '\DLE'),-        ("DC1", '\DC1'),-        ("DC2", '\DC2'),-        ("DC3", '\DC3'),-        ("DC4", '\DC4'),-        ("NAK", '\NAK'),-        ("SYN", '\SYN'),-        ("ETB", '\ETB'),-        ("CAN", '\CAN'),-        ("EM", '\EM'),-        ("SUB", '\SUB'),-        ("ESC", '\ESC'),-        ("FS", '\FS'),-        ("GS", '\GS'),-        ("RS", '\RS'),-        ("US", '\US'),-        ("SP", '\SP'),-        ("DEL", '\DEL')-        ]---- before calling lit_error, ensure that the current input is pointing to--- the position of the error in the buffer.  This is so that we can report--- a correct location to the user, but also so we can detect UTF-8 decoding--- errors if they occur.-lit_error :: AlexInput -> P a-lit_error i = do setInput i; lexError LexStringCharLit--getCharOrFail :: AlexInput -> P Char-getCharOrFail i =  do-  case alexGetChar' i of-        Nothing -> lexError LexStringCharLitEOF-        Just (c,i)  -> do setInput i; return c---- -------------------------------------------------------------------------------- QuasiQuote--lex_qquasiquote_tok :: Action-lex_qquasiquote_tok span buf len = do-  let (qual, quoter) = splitQualName (stepOn buf) (len - 2) False-  quoteStart <- getParsedLoc-  quote <- lex_quasiquote (psRealLoc quoteStart) ""-  end <- getParsedLoc-  return (L (mkPsSpan (psSpanStart span) end)-           (ITqQuasiQuote (qual,-                           quoter,-                           mkFastString (reverse quote),-                           mkPsSpan quoteStart end)))--lex_quasiquote_tok :: Action-lex_quasiquote_tok span buf len = do-  let quoter = tail (lexemeToString buf (len - 1))-                -- 'tail' drops the initial '[',-                -- while the -1 drops the trailing '|'-  quoteStart <- getParsedLoc-  quote <- lex_quasiquote (psRealLoc quoteStart) ""-  end <- getParsedLoc-  return (L (mkPsSpan (psSpanStart span) end)-           (ITquasiQuote (mkFastString quoter,-                          mkFastString (reverse quote),-                          mkPsSpan quoteStart end)))--lex_quasiquote :: RealSrcLoc -> String -> P String-lex_quasiquote start s = do-  i <- getInput-  case alexGetChar' i of-    Nothing -> quasiquote_error start--    -- NB: The string "|]" terminates the quasiquote,-    -- with absolutely no escaping. See the extensive-    -- discussion on #5348 for why there is no-    -- escape handling.-    Just ('|',i)-        | Just (']',i) <- alexGetChar' i-        -> do { setInput i; return s }--    Just (c, i) -> do-         setInput i; lex_quasiquote start (c : s)--quasiquote_error :: RealSrcLoc -> P a-quasiquote_error start = do-  (AI end buf) <- getInput-  reportLexError start (psRealLoc end) buf-    (\k -> PsError (PsErrLexer LexUnterminatedQQ k) [])---- -------------------------------------------------------------------------------- Warnings--warnTab :: Action-warnTab srcspan _buf _len = do-    addTabWarning (psRealSpan srcspan)-    lexToken--warnThen :: WarningFlag -> (SrcSpan -> PsWarning) -> Action -> Action-warnThen flag warning action srcspan buf len = do-    addWarning flag (warning (RealSrcSpan (psRealSpan srcspan) Nothing))-    action srcspan buf len---- -------------------------------------------------------------------------------- The Parse Monad---- | Do we want to generate ';' layout tokens? In some cases we just want to--- generate '}', e.g. in MultiWayIf we don't need ';'s because '|' separates--- alternatives (unlike a `case` expression where we need ';' to as a separator--- between alternatives).-type GenSemic = Bool--generateSemic, dontGenerateSemic :: GenSemic-generateSemic     = True-dontGenerateSemic = False--data LayoutContext-  = NoLayout-  | Layout !Int !GenSemic-  deriving Show---- | The result of running a parser.-data ParseResult a-  = POk      -- ^ The parser has consumed a (possibly empty) prefix-             --   of the input and produced a result. Use 'getMessages'-             --   to check for accumulated warnings and non-fatal errors.-      PState -- ^ The resulting parsing state. Can be used to resume parsing.-      a      -- ^ The resulting value.-  | PFailed  -- ^ The parser has consumed a (possibly empty) prefix-             --   of the input and failed.-      PState -- ^ The parsing state right before failure, including the fatal-             --   parse error. 'getMessages' and 'getErrorMessages' must return-             --   a non-empty bag of errors.---- | Test whether a 'WarningFlag' is set-warnopt :: WarningFlag -> ParserOpts -> Bool-warnopt f options = f `EnumSet.member` pWarningFlags options---- | Parser options.------ See 'mkParserOpts' to construct this.-data ParserOpts = ParserOpts-  { pWarningFlags   :: EnumSet WarningFlag -- ^ enabled warning flags-  , pExtsBitmap     :: !ExtsBitmap -- ^ bitmap of permitted extensions-  }---- | Haddock comment as produced by the lexer. These are accumulated in--- 'PState' and then processed in "GHC.Parser.PostProcess.Haddock".-data HdkComment-  = HdkCommentNext HsDocString-  | HdkCommentPrev HsDocString-  | HdkCommentNamed String HsDocString-  | HdkCommentSection Int HsDocString-  deriving Show--data PState = PState {-        buffer     :: StringBuffer,-        options    :: ParserOpts,-        warnings   :: Bag PsWarning,-        errors     :: Bag PsError,-        tab_first  :: Maybe RealSrcSpan, -- pos of first tab warning in the file-        tab_count  :: !Word,             -- number of tab warnings in the file-        last_tk    :: Maybe (PsLocated Token), -- last non-comment token-        prev_loc   :: PsSpan,      -- pos of previous token, including comments,-        prev_loc2  :: PsSpan,      -- pos of two back token, including comments,-                                   -- see Note [PsSpan in Comments]-        last_loc   :: PsSpan,      -- pos of current token-        last_len   :: !Int,        -- len of current token-        loc        :: PsLoc,       -- current loc (end of prev token + 1)-        context    :: [LayoutContext],-        lex_state  :: [Int],-        srcfiles   :: [FastString],-        -- Used in the alternative layout rule:-        -- These tokens are the next ones to be sent out. They are-        -- just blindly emitted, without the rule looking at them again:-        alr_pending_implicit_tokens :: [PsLocated Token],-        -- This is the next token to be considered or, if it is Nothing,-        -- we need to get the next token from the input stream:-        alr_next_token :: Maybe (PsLocated Token),-        -- This is what we consider to be the location of the last token-        -- emitted:-        alr_last_loc :: PsSpan,-        -- The stack of layout contexts:-        alr_context :: [ALRContext],-        -- Are we expecting a '{'? If it's Just, then the ALRLayout tells-        -- us what sort of layout the '{' will open:-        alr_expecting_ocurly :: Maybe ALRLayout,-        -- Have we just had the '}' for a let block? If so, than an 'in'-        -- token doesn't need to close anything:-        alr_justClosedExplicitLetBlock :: Bool,--        -- The next three are used to implement Annotations giving the-        -- locations of 'noise' tokens in the source, so that users of-        -- the GHC API can do source to source conversions.-        -- See note [exact print annotations] in GHC.Parser.Annotation-        eof_pos :: Maybe (RealSrcSpan, RealSrcSpan), -- pos, gap to prior token-        header_comments :: Maybe [LEpaComment],-        comment_q :: [LEpaComment],--        -- Haddock comments accumulated in ascending order of their location-        -- (BufPos). We use OrdList to get O(1) snoc.-        ---        -- See Note [Adding Haddock comments to the syntax tree] in GHC.Parser.PostProcess.Haddock-        hdk_comments :: OrdList (PsLocated HdkComment)-     }-        -- last_loc and last_len are used when generating error messages,-        -- and in pushCurrentContext only.  Sigh, if only Happy passed the-        -- current token to happyError, we could at least get rid of last_len.-        -- Getting rid of last_loc would require finding another way to-        -- implement pushCurrentContext (which is only called from one place).--        -- AZ question: setLastToken which sets last_loc and last_len-        -- is called whan processing AlexToken, immediately prior to-        -- calling the action in the token.  So from the perspective-        -- of the action, it is the *current* token.  Do I understand-        -- correctly?--data ALRContext = ALRNoLayout Bool{- does it contain commas? -}-                              Bool{- is it a 'let' block? -}-                | ALRLayout ALRLayout Int-data ALRLayout = ALRLayoutLet-               | ALRLayoutWhere-               | ALRLayoutOf-               | ALRLayoutDo---- | The parsing monad, isomorphic to @StateT PState Maybe@.-newtype P a = P { unP :: PState -> ParseResult a }--instance Functor P where-  fmap = liftM--instance Applicative P where-  pure = returnP-  (<*>) = ap--instance Monad P where-  (>>=) = thenP--returnP :: a -> P a-returnP a = a `seq` (P $ \s -> POk s a)--thenP :: P a -> (a -> P b) -> P b-(P m) `thenP` k = P $ \ s ->-        case m s of-                POk s1 a         -> (unP (k a)) s1-                PFailed s1 -> PFailed s1--failMsgP :: (SrcSpan -> PsError) -> P a-failMsgP f = do-  pState <- getPState-  addFatalError (f (mkSrcSpanPs (last_loc pState)))--failLocMsgP :: RealSrcLoc -> RealSrcLoc -> (SrcSpan -> PsError) -> P a-failLocMsgP loc1 loc2 f =-  addFatalError (f (RealSrcSpan (mkRealSrcSpan loc1 loc2) Nothing))--getPState :: P PState-getPState = P $ \s -> POk s s--getExts :: P ExtsBitmap-getExts = P $ \s -> POk s (pExtsBitmap . options $ s)--setExts :: (ExtsBitmap -> ExtsBitmap) -> P ()-setExts f = P $ \s -> POk s {-  options =-    let p = options s-    in  p { pExtsBitmap = f (pExtsBitmap p) }-  } ()--setSrcLoc :: RealSrcLoc -> P ()-setSrcLoc new_loc =-  P $ \s@(PState{ loc = PsLoc _ buf_loc }) ->-  POk s{ loc = PsLoc new_loc buf_loc } ()--getRealSrcLoc :: P RealSrcLoc-getRealSrcLoc = P $ \s@(PState{ loc=loc }) -> POk s (psRealLoc loc)--getParsedLoc :: P PsLoc-getParsedLoc  = P $ \s@(PState{ loc=loc }) -> POk s loc--addSrcFile :: FastString -> P ()-addSrcFile f = P $ \s -> POk s{ srcfiles = f : srcfiles s } ()--setEofPos :: RealSrcSpan -> RealSrcSpan -> P ()-setEofPos span gap = P $ \s -> POk s{ eof_pos = Just (span, gap) } ()--setLastToken :: PsSpan -> Int -> P ()-setLastToken loc len = P $ \s -> POk s {-  last_loc=loc,-  last_len=len-  } ()--setLastTk :: PsLocated Token -> P ()-setLastTk tk@(L l _) = P $ \s -> POk s { last_tk = Just tk-                                       , prev_loc = l-                                       , prev_loc2 = prev_loc s} ()--setLastComment :: PsLocated Token -> P ()-setLastComment (L l _) = P $ \s -> POk s { prev_loc = l-                                         , prev_loc2 = prev_loc s} ()--getLastTk :: P (Maybe (PsLocated Token))-getLastTk = P $ \s@(PState { last_tk = last_tk }) -> POk s last_tk---- see Note [PsSpan in Comments]-getLastLocComment :: P PsSpan-getLastLocComment = P $ \s@(PState { prev_loc = prev_loc }) -> POk s prev_loc---- see Note [PsSpan in Comments]-getLastLocEof :: P PsSpan-getLastLocEof = P $ \s@(PState { prev_loc2 = prev_loc2 }) -> POk s prev_loc2--getLastLoc :: P PsSpan-getLastLoc = P $ \s@(PState { last_loc = last_loc }) -> POk s last_loc--data AlexInput = AI !PsLoc !StringBuffer--{--Note [Unicode in Alex]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Although newer versions of Alex support unicode, this grammar is processed with-the old style '--latin1' behaviour. This means that when implementing the-functions--    alexGetByte       :: AlexInput -> Maybe (Word8,AlexInput)-    alexInputPrevChar :: AlexInput -> Char--which Alex uses to take apart our 'AlexInput', we must--  * return a latin1 character in the 'Word8' that 'alexGetByte' expects-  * return a latin1 character in 'alexInputPrevChar'.--We handle this in 'adjustChar' by squishing entire classes of unicode-characters into single bytes.--}--{-# INLINE adjustChar #-}-adjustChar :: Char -> Word8-adjustChar c = fromIntegral $ ord adj_c-  where non_graphic     = '\x00'-        upper           = '\x01'-        lower           = '\x02'-        digit           = '\x03'-        symbol          = '\x04'-        space           = '\x05'-        other_graphic   = '\x06'-        uniidchar       = '\x07'--        adj_c-          | c <= '\x07' = non_graphic-          | c <= '\x7f' = c-          -- Alex doesn't handle Unicode, so when Unicode-          -- character is encountered we output these values-          -- with the actual character value hidden in the state.-          | otherwise =-                -- NB: The logic behind these definitions is also reflected-                -- in "GHC.Utils.Lexeme"-                -- Any changes here should likely be reflected there.--                case generalCategory c of-                  UppercaseLetter       -> upper-                  LowercaseLetter       -> lower-                  TitlecaseLetter       -> upper-                  ModifierLetter        -> uniidchar -- see #10196-                  OtherLetter           -> lower -- see #1103-                  NonSpacingMark        -> uniidchar -- see #7650-                  SpacingCombiningMark  -> other_graphic-                  EnclosingMark         -> other_graphic-                  DecimalNumber         -> digit-                  LetterNumber          -> other_graphic-                  OtherNumber           -> digit -- see #4373-                  ConnectorPunctuation  -> symbol-                  DashPunctuation       -> symbol-                  OpenPunctuation       -> other_graphic-                  ClosePunctuation      -> other_graphic-                  InitialQuote          -> other_graphic-                  FinalQuote            -> other_graphic-                  OtherPunctuation      -> symbol-                  MathSymbol            -> symbol-                  CurrencySymbol        -> symbol-                  ModifierSymbol        -> symbol-                  OtherSymbol           -> symbol-                  Space                 -> space-                  _other                -> non_graphic---- Getting the previous 'Char' isn't enough here - we need to convert it into--- the same format that 'alexGetByte' would have produced.------ See Note [Unicode in Alex] and #13986.-alexInputPrevChar :: AlexInput -> Char-alexInputPrevChar (AI _ buf) = chr (fromIntegral (adjustChar pc))-  where pc = prevChar buf '\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---- See Note [Unicode in Alex]-alexGetByte :: AlexInput -> Maybe (Word8,AlexInput)-alexGetByte (AI loc s)-  | atEnd s   = Nothing-  | otherwise = byte `seq` loc' `seq` s' `seq`-                --trace (show (ord c)) $-                Just (byte, (AI loc' s'))-  where (c,s') = nextChar s-        loc'   = advancePsLoc loc c-        byte   = adjustChar c---- This version does not squash unicode characters, it is used when--- lexing strings.-alexGetChar' :: AlexInput -> Maybe (Char,AlexInput)-alexGetChar' (AI loc s)-  | atEnd s   = Nothing-  | otherwise = c `seq` loc' `seq` s' `seq`-                --trace (show (ord c)) $-                Just (c, (AI loc' s'))-  where (c,s') = nextChar s-        loc'   = advancePsLoc loc c--getInput :: P AlexInput-getInput = P $ \s@PState{ loc=l, buffer=b } -> POk s (AI l b)--setInput :: AlexInput -> P ()-setInput (AI l b) = P $ \s -> POk s{ loc=l, buffer=b } ()--nextIsEOF :: P Bool-nextIsEOF = do-  AI _ s <- getInput-  return $ atEnd s--pushLexState :: Int -> P ()-pushLexState ls = P $ \s@PState{ lex_state=l } -> POk s{lex_state=ls:l} ()--popLexState :: P Int-popLexState = P $ \s@PState{ lex_state=ls:l } -> POk s{ lex_state=l } ls--getLexState :: P Int-getLexState = P $ \s@PState{ lex_state=ls:_ } -> POk s ls--popNextToken :: P (Maybe (PsLocated Token))-popNextToken-    = P $ \s@PState{ alr_next_token = m } ->-              POk (s {alr_next_token = Nothing}) m--activeContext :: P Bool-activeContext = do-  ctxt <- getALRContext-  expc <- getAlrExpectingOCurly-  impt <- implicitTokenPending-  case (ctxt,expc) of-    ([],Nothing) -> return impt-    _other       -> return True--resetAlrLastLoc :: FastString -> P ()-resetAlrLastLoc file =-  P $ \s@(PState {alr_last_loc = PsSpan _ buf_span}) ->-  POk s{ alr_last_loc = PsSpan (alrInitialLoc file) buf_span } ()--setAlrLastLoc :: PsSpan -> P ()-setAlrLastLoc l = P $ \s -> POk (s {alr_last_loc = l}) ()--getAlrLastLoc :: P PsSpan-getAlrLastLoc = P $ \s@(PState {alr_last_loc = l}) -> POk s l--getALRContext :: P [ALRContext]-getALRContext = P $ \s@(PState {alr_context = cs}) -> POk s cs--setALRContext :: [ALRContext] -> P ()-setALRContext cs = P $ \s -> POk (s {alr_context = cs}) ()--getJustClosedExplicitLetBlock :: P Bool-getJustClosedExplicitLetBlock- = P $ \s@(PState {alr_justClosedExplicitLetBlock = b}) -> POk s b--setJustClosedExplicitLetBlock :: Bool -> P ()-setJustClosedExplicitLetBlock b- = P $ \s -> POk (s {alr_justClosedExplicitLetBlock = b}) ()--setNextToken :: PsLocated Token -> P ()-setNextToken t = P $ \s -> POk (s {alr_next_token = Just t}) ()--implicitTokenPending :: P Bool-implicitTokenPending-    = P $ \s@PState{ alr_pending_implicit_tokens = ts } ->-              case ts of-              [] -> POk s False-              _  -> POk s True--popPendingImplicitToken :: P (Maybe (PsLocated Token))-popPendingImplicitToken-    = P $ \s@PState{ alr_pending_implicit_tokens = ts } ->-              case ts of-              [] -> POk s Nothing-              (t : ts') -> POk (s {alr_pending_implicit_tokens = ts'}) (Just t)--setPendingImplicitTokens :: [PsLocated Token] -> P ()-setPendingImplicitTokens ts = P $ \s -> POk (s {alr_pending_implicit_tokens = ts}) ()--getAlrExpectingOCurly :: P (Maybe ALRLayout)-getAlrExpectingOCurly = P $ \s@(PState {alr_expecting_ocurly = b}) -> POk s b--setAlrExpectingOCurly :: Maybe ALRLayout -> P ()-setAlrExpectingOCurly b = P $ \s -> POk (s {alr_expecting_ocurly = b}) ()---- | For reasons of efficiency, boolean parsing flags (eg, language extensions--- or whether we are currently in a @RULE@ pragma) are represented by a bitmap--- stored in a @Word64@.-type ExtsBitmap = Word64--xbit :: ExtBits -> ExtsBitmap-xbit = bit . fromEnum--xtest :: ExtBits -> ExtsBitmap -> Bool-xtest ext xmap = testBit xmap (fromEnum ext)--xset :: ExtBits -> ExtsBitmap -> ExtsBitmap-xset ext xmap = setBit xmap (fromEnum ext)--xunset :: ExtBits -> ExtsBitmap -> ExtsBitmap-xunset ext xmap = clearBit xmap (fromEnum ext)---- | Various boolean flags, mostly language extensions, that impact lexing and--- parsing. Note that a handful of these can change during lexing/parsing.-data ExtBits-  -- Flags that are constant once parsing starts-  = FfiBit-  | InterruptibleFfiBit-  | CApiFfiBit-  | ArrowsBit-  | ThBit-  | ThQuotesBit-  | IpBit-  | OverloadedLabelsBit -- #x overloaded labels-  | ExplicitForallBit -- the 'forall' keyword-  | BangPatBit -- Tells the parser to understand bang-patterns-               -- (doesn't affect the lexer)-  | PatternSynonymsBit -- pattern synonyms-  | HaddockBit-- Lex and parse Haddock comments-  | MagicHashBit -- "#" in both functions and operators-  | RecursiveDoBit -- mdo-  | QualifiedDoBit -- .do and .mdo-  | UnicodeSyntaxBit -- the forall symbol, arrow symbols, etc-  | UnboxedTuplesBit -- (# and #)-  | UnboxedSumsBit -- (# and #)-  | DatatypeContextsBit-  | MonadComprehensionsBit-  | TransformComprehensionsBit-  | QqBit -- enable quasiquoting-  | RawTokenStreamBit -- producing a token stream with all comments included-  | AlternativeLayoutRuleBit-  | ALRTransitionalBit-  | RelaxedLayoutBit-  | NondecreasingIndentationBit-  | SafeHaskellBit-  | TraditionalRecordSyntaxBit-  | ExplicitNamespacesBit-  | LambdaCaseBit-  | BinaryLiteralsBit-  | NegativeLiteralsBit-  | HexFloatLiteralsBit-  | StaticPointersBit-  | NumericUnderscoresBit-  | StarIsTypeBit-  | BlockArgumentsBit-  | NPlusKPatternsBit-  | DoAndIfThenElseBit-  | MultiWayIfBit-  | GadtSyntaxBit-  | ImportQualifiedPostBit-  | LinearTypesBit-  | NoLexicalNegationBit   -- See Note [Why not LexicalNegationBit]-  | OverloadedRecordDotBit-  | OverloadedRecordUpdateBit--  -- Flags that are updated once parsing starts-  | InRulePragBit-  | InNestedCommentBit -- See Note [Nested comment line pragmas]-  | UsePosPragsBit-    -- ^ If this is enabled, '{-# LINE ... -#}' and '{-# COLUMN ... #-}'-    -- update the internal position. Otherwise, those pragmas are lexed as-    -- tokens of their own.-  deriving Enum--{-# INLINE mkParserOpts #-}-mkParserOpts-  :: EnumSet WarningFlag        -- ^ warnings flags enabled-  -> EnumSet LangExt.Extension  -- ^ permitted language extensions enabled-  -> Bool                       -- ^ are safe imports on?-  -> Bool                       -- ^ keeping Haddock comment tokens-  -> Bool                       -- ^ keep regular comment tokens--  -> Bool-  -- ^ If this is enabled, '{-# LINE ... -#}' and '{-# COLUMN ... #-}' update-  -- the internal position kept by the parser. Otherwise, those pragmas are-  -- lexed as 'ITline_prag' and 'ITcolumn_prag' tokens.--  -> ParserOpts--- ^ Given exactly the information needed, set up the 'ParserOpts'-mkParserOpts warningFlags extensionFlags-  safeImports isHaddock rawTokStream usePosPrags =-    ParserOpts {-      pWarningFlags = warningFlags-    , pExtsBitmap   = safeHaskellBit .|. langExtBits .|. optBits-    }-  where-    safeHaskellBit = SafeHaskellBit `setBitIf` safeImports-    langExtBits =-          FfiBit                      `xoptBit` LangExt.ForeignFunctionInterface-      .|. InterruptibleFfiBit         `xoptBit` LangExt.InterruptibleFFI-      .|. CApiFfiBit                  `xoptBit` LangExt.CApiFFI-      .|. ArrowsBit                   `xoptBit` LangExt.Arrows-      .|. ThBit                       `xoptBit` LangExt.TemplateHaskell-      .|. ThQuotesBit                 `xoptBit` LangExt.TemplateHaskellQuotes-      .|. QqBit                       `xoptBit` LangExt.QuasiQuotes-      .|. IpBit                       `xoptBit` LangExt.ImplicitParams-      .|. OverloadedLabelsBit         `xoptBit` LangExt.OverloadedLabels-      .|. ExplicitForallBit           `xoptBit` LangExt.ExplicitForAll-      .|. BangPatBit                  `xoptBit` LangExt.BangPatterns-      .|. MagicHashBit                `xoptBit` LangExt.MagicHash-      .|. RecursiveDoBit              `xoptBit` LangExt.RecursiveDo-      .|. QualifiedDoBit              `xoptBit` LangExt.QualifiedDo-      .|. UnicodeSyntaxBit            `xoptBit` LangExt.UnicodeSyntax-      .|. UnboxedTuplesBit            `xoptBit` LangExt.UnboxedTuples-      .|. UnboxedSumsBit              `xoptBit` LangExt.UnboxedSums-      .|. DatatypeContextsBit         `xoptBit` LangExt.DatatypeContexts-      .|. TransformComprehensionsBit  `xoptBit` LangExt.TransformListComp-      .|. MonadComprehensionsBit      `xoptBit` LangExt.MonadComprehensions-      .|. AlternativeLayoutRuleBit    `xoptBit` LangExt.AlternativeLayoutRule-      .|. ALRTransitionalBit          `xoptBit` LangExt.AlternativeLayoutRuleTransitional-      .|. RelaxedLayoutBit            `xoptBit` LangExt.RelaxedLayout-      .|. NondecreasingIndentationBit `xoptBit` LangExt.NondecreasingIndentation-      .|. TraditionalRecordSyntaxBit  `xoptBit` LangExt.TraditionalRecordSyntax-      .|. ExplicitNamespacesBit       `xoptBit` LangExt.ExplicitNamespaces-      .|. LambdaCaseBit               `xoptBit` LangExt.LambdaCase-      .|. BinaryLiteralsBit           `xoptBit` LangExt.BinaryLiterals-      .|. NegativeLiteralsBit         `xoptBit` LangExt.NegativeLiterals-      .|. HexFloatLiteralsBit         `xoptBit` LangExt.HexFloatLiterals-      .|. PatternSynonymsBit          `xoptBit` LangExt.PatternSynonyms-      .|. StaticPointersBit           `xoptBit` LangExt.StaticPointers-      .|. NumericUnderscoresBit       `xoptBit` LangExt.NumericUnderscores-      .|. StarIsTypeBit               `xoptBit` LangExt.StarIsType-      .|. BlockArgumentsBit           `xoptBit` LangExt.BlockArguments-      .|. NPlusKPatternsBit           `xoptBit` LangExt.NPlusKPatterns-      .|. DoAndIfThenElseBit          `xoptBit` LangExt.DoAndIfThenElse-      .|. MultiWayIfBit               `xoptBit` LangExt.MultiWayIf-      .|. GadtSyntaxBit               `xoptBit` LangExt.GADTSyntax-      .|. ImportQualifiedPostBit      `xoptBit` LangExt.ImportQualifiedPost-      .|. LinearTypesBit              `xoptBit` LangExt.LinearTypes-      .|. NoLexicalNegationBit        `xoptNotBit` LangExt.LexicalNegation -- See Note [Why not LexicalNegationBit]-      .|. OverloadedRecordDotBit      `xoptBit` LangExt.OverloadedRecordDot-      .|. OverloadedRecordUpdateBit   `xoptBit` LangExt.OverloadedRecordUpdate  -- Enable testing via 'getBit OverloadedRecordUpdateBit' in the parser (RecordDotSyntax parsing uses that information).-    optBits =-          HaddockBit        `setBitIf` isHaddock-      .|. RawTokenStreamBit `setBitIf` rawTokStream-      .|. UsePosPragsBit    `setBitIf` usePosPrags--    xoptBit bit ext = bit `setBitIf` EnumSet.member ext extensionFlags-    xoptNotBit bit ext = bit `setBitIf` not (EnumSet.member ext extensionFlags)--    setBitIf :: ExtBits -> Bool -> ExtsBitmap-    b `setBitIf` cond | cond      = xbit b-                      | otherwise = 0---- | Set parser options for parsing OPTIONS pragmas-initPragState :: ParserOpts -> StringBuffer -> RealSrcLoc -> PState-initPragState options buf loc = (initParserState options buf loc)-   { lex_state = [bol, option_prags, 0]-   }---- | Creates a parse state from a 'ParserOpts' value-initParserState :: ParserOpts -> StringBuffer -> RealSrcLoc -> PState-initParserState options buf loc =-  PState {-      buffer        = buf,-      options       = options,-      errors        = emptyBag,-      warnings      = emptyBag,-      tab_first     = Nothing,-      tab_count     = 0,-      last_tk       = Nothing,-      prev_loc      = mkPsSpan init_loc init_loc,-      prev_loc2     = mkPsSpan init_loc init_loc,-      last_loc      = mkPsSpan init_loc init_loc,-      last_len      = 0,-      loc           = init_loc,-      context       = [],-      lex_state     = [bol, 0],-      srcfiles      = [],-      alr_pending_implicit_tokens = [],-      alr_next_token = Nothing,-      alr_last_loc = PsSpan (alrInitialLoc (fsLit "<no file>")) (BufSpan (BufPos 0) (BufPos 0)),-      alr_context = [],-      alr_expecting_ocurly = Nothing,-      alr_justClosedExplicitLetBlock = False,-      eof_pos = Nothing,-      header_comments = Nothing,-      comment_q = [],-      hdk_comments = nilOL-    }-  where init_loc = PsLoc loc (BufPos 0)---- | An mtl-style class for monads that support parsing-related operations.--- For example, sometimes we make a second pass over the parsing results to validate,--- disambiguate, or rearrange them, and we do so in the PV monad which cannot consume--- input but can report parsing errors, check for extension bits, and accumulate--- parsing annotations. Both P and PV are instances of MonadP.------ MonadP grants us convenient overloading. The other option is to have separate operations--- for each monad: addErrorP vs addErrorPV, getBitP vs getBitPV, and so on.----class Monad m => MonadP m where-  -- | Add a non-fatal error. Use this when the parser can produce a result-  --   despite the error.-  ---  --   For example, when GHC encounters a @forall@ in a type,-  --   but @-XExplicitForAll@ is disabled, the parser constructs @ForAllTy@-  --   as if @-XExplicitForAll@ was enabled, adding a non-fatal error to-  --   the accumulator.-  ---  --   Control flow wise, non-fatal errors act like warnings: they are added-  --   to the accumulator and parsing continues. This allows GHC to report-  --   more than one parse error per file.-  ---  addError :: PsError -> m ()--  -- | Add a warning to the accumulator.-  --   Use 'getMessages' to get the accumulated warnings.-  addWarning :: WarningFlag -> PsWarning -> m ()--  -- | Add a fatal error. This will be the last error reported by the parser, and-  --   the parser will not produce any result, ending in a 'PFailed' state.-  addFatalError :: PsError -> m a--  -- | Check if a given flag is currently set in the bitmap.-  getBit :: ExtBits -> m Bool-  -- | Go through the @comment_q@ in @PState@ and remove all comments-  -- that belong within the given span-  allocateCommentsP :: RealSrcSpan -> m EpAnnComments-  -- | Go through the @comment_q@ in @PState@ and remove all comments-  -- that come before or within the given span-  allocatePriorCommentsP :: RealSrcSpan -> m EpAnnComments-  -- | Go through the @comment_q@ in @PState@ and remove all comments-  -- that come after the given span-  allocateFinalCommentsP :: RealSrcSpan -> m EpAnnComments--instance MonadP P where-  addError err-   = P $ \s -> POk s { errors = err `consBag` errors s} ()--  addWarning option w-   = P $ \s -> if warnopt option (options s)-                  then POk (s { warnings = w `consBag` warnings s }) ()-                  else POk s ()--  addFatalError err =-    addError err >> P PFailed--  getBit ext = P $ \s -> let b =  ext `xtest` pExtsBitmap (options s)-                         in b `seq` POk s b-  allocateCommentsP ss = P $ \s ->-    let (comment_q', newAnns) = allocateComments ss (comment_q s) in-      POk s {-         comment_q = comment_q'-       } (EpaComments newAnns)-  allocatePriorCommentsP ss = P $ \s ->-    let (header_comments', comment_q', newAnns)-             = allocatePriorComments ss (comment_q s) (header_comments s) in-      POk s {-         header_comments = header_comments',-         comment_q = comment_q'-       } (EpaComments newAnns)-  allocateFinalCommentsP ss = P $ \s ->-    let (header_comments', comment_q', newAnns)-             = allocateFinalComments ss (comment_q s) (header_comments s) in-      POk s {-         header_comments = header_comments',-         comment_q = comment_q'-       } (EpaCommentsBalanced (fromMaybe [] header_comments') (reverse newAnns))--getCommentsFor :: (MonadP m) => SrcSpan -> m EpAnnComments-getCommentsFor (RealSrcSpan l _) = allocateCommentsP l-getCommentsFor _ = return emptyComments--getPriorCommentsFor :: (MonadP m) => SrcSpan -> m EpAnnComments-getPriorCommentsFor (RealSrcSpan l _) = allocatePriorCommentsP l-getPriorCommentsFor _ = return emptyComments--getFinalCommentsFor :: (MonadP m) => SrcSpan -> m EpAnnComments-getFinalCommentsFor (RealSrcSpan l _) = allocateFinalCommentsP l-getFinalCommentsFor _ = return emptyComments--getEofPos :: P (Maybe (RealSrcSpan, RealSrcSpan))-getEofPos = P $ \s@(PState { eof_pos = pos }) -> POk s pos--addTabWarning :: RealSrcSpan -> P ()-addTabWarning srcspan- = P $ \s@PState{tab_first=tf, tab_count=tc, options=o} ->-       let tf' = if isJust tf then tf else Just srcspan-           tc' = tc + 1-           s' = if warnopt Opt_WarnTabs o-                then s{tab_first = tf', tab_count = tc'}-                else s-       in POk s' ()---- | Get a bag of the errors that have been accumulated so far.---   Does not take -Werror into account.-getErrorMessages :: PState -> Bag PsError-getErrorMessages p = errors p---- | Get the warnings and errors accumulated so far.---   Does not take -Werror into account.-getMessages :: PState -> (Bag PsWarning, Bag PsError)-getMessages p =-  let ws = warnings p-      -- we add the tabulation warning on the fly because-      -- we count the number of occurrences of tab characters-      ws' = case tab_first p of-               Nothing -> ws-               Just tf -> PsWarnTab (RealSrcSpan tf Nothing) (tab_count p)-                           `consBag` ws-  in (ws', errors p)--getContext :: P [LayoutContext]-getContext = P $ \s@PState{context=ctx} -> POk s ctx--setContext :: [LayoutContext] -> P ()-setContext ctx = P $ \s -> POk s{context=ctx} ()--popContext :: P ()-popContext = P $ \ s@(PState{ buffer = buf, options = o, context = ctx,-                              last_len = len, last_loc = last_loc }) ->-  case ctx of-        (_:tl) ->-          POk s{ context = tl } ()-        []     ->-          unP (addFatalError $ srcParseErr o buf len (mkSrcSpanPs last_loc)) s---- Push a new layout context at the indentation of the last token read.-pushCurrentContext :: GenSemic -> P ()-pushCurrentContext gen_semic = P $ \ s@PState{ last_loc=loc, context=ctx } ->-    POk s{context = Layout (srcSpanStartCol (psRealSpan loc)) gen_semic : ctx} ()---- This is only used at the outer level of a module when the 'module' keyword is--- missing.-pushModuleContext :: P ()-pushModuleContext = pushCurrentContext generateSemic--getOffside :: P (Ordering, Bool)-getOffside = P $ \s@PState{last_loc=loc, context=stk} ->-                let offs = srcSpanStartCol (psRealSpan loc) in-                let ord = case stk of-                            Layout n gen_semic : _ ->-                              --trace ("layout: " ++ show n ++ ", offs: " ++ show offs) $-                              (compare offs n, gen_semic)-                            _ ->-                              (GT, dontGenerateSemic)-                in POk s ord---- ------------------------------------------------------------------------------ Construct a parse error--srcParseErr-  :: ParserOpts-  -> StringBuffer       -- current buffer (placed just after the last token)-  -> Int                -- length of the previous token-  -> SrcSpan-  -> PsError-srcParseErr options buf len loc = PsError (PsErrParse token) suggests loc-  where-   token = lexemeToString (offsetBytes (-len) buf) len-   pattern = decodePrevNChars 8 buf-   last100 = decodePrevNChars 100 buf-   doInLast100 = "do" `isInfixOf` last100-   mdoInLast100 = "mdo" `isInfixOf` last100-   th_enabled = ThQuotesBit `xtest` pExtsBitmap options-   ps_enabled = PatternSynonymsBit `xtest` pExtsBitmap options--   sug c s = if c then Just s else Nothing-   sug_th  = sug (not th_enabled && token == "$")          SuggestTH              -- #7396-   sug_rdo = sug (token == "<-" && mdoInLast100)           SuggestRecursiveDo-   sug_do  = sug (token == "<-" && not mdoInLast100)       SuggestDo-   sug_let = sug (token == "=" && doInLast100)             SuggestLetInDo         -- #15849-   sug_pat = sug (not ps_enabled && pattern == "pattern ") SuggestPatternSynonyms -- #12429-   suggests-         | null token = []-         | otherwise  = catMaybes [sug_th, sug_rdo, sug_do, sug_let, sug_pat]---- Report a parse failure, giving the span of the previous token as--- the location of the error.  This is the entry point for errors--- detected during parsing.-srcParseFail :: P a-srcParseFail = P $ \s@PState{ buffer = buf, options = o, last_len = len,-                            last_loc = last_loc } ->-    unP (addFatalError $ srcParseErr o buf len (mkSrcSpanPs last_loc)) s---- A lexical error is reported at a particular position in the source file,--- not over a token range.-lexError :: LexErr -> P a-lexError e = do-  loc <- getRealSrcLoc-  (AI end buf) <- getInput-  reportLexError loc (psRealLoc end) buf-    (\k -> PsError (PsErrLexer e k) [])---- -------------------------------------------------------------------------------- This is the top-level function: called from the parser each time a--- new token is to be read from the input.--lexer, lexerDbg :: Bool -> (Located Token -> P a) -> P a--lexer queueComments cont = do-  alr <- getBit AlternativeLayoutRuleBit-  let lexTokenFun = if alr then lexTokenAlr else lexToken-  (L span tok) <- lexTokenFun-  --trace ("token: " ++ show tok) $ do--  if (queueComments && isComment tok)-    then queueComment (L (psRealSpan span) tok) >> lexer queueComments cont-    else cont (L (mkSrcSpanPs span) tok)---- Use this instead of 'lexer' in GHC.Parser to dump the tokens for debugging.-lexerDbg queueComments cont = lexer queueComments contDbg-  where-    contDbg tok = trace ("token: " ++ show (unLoc tok)) (cont tok)--lexTokenAlr :: P (PsLocated Token)-lexTokenAlr = do mPending <- popPendingImplicitToken-                 t <- case mPending of-                      Nothing ->-                          do mNext <- popNextToken-                             t <- case mNext of-                                  Nothing -> lexToken-                                  Just next -> return next-                             alternativeLayoutRuleToken t-                      Just t ->-                          return t-                 setAlrLastLoc (getLoc t)-                 case unLoc t of-                     ITwhere  -> setAlrExpectingOCurly (Just ALRLayoutWhere)-                     ITlet    -> setAlrExpectingOCurly (Just ALRLayoutLet)-                     ITof     -> setAlrExpectingOCurly (Just ALRLayoutOf)-                     ITlcase  -> setAlrExpectingOCurly (Just ALRLayoutOf)-                     ITdo  _  -> setAlrExpectingOCurly (Just ALRLayoutDo)-                     ITmdo _  -> setAlrExpectingOCurly (Just ALRLayoutDo)-                     ITrec    -> setAlrExpectingOCurly (Just ALRLayoutDo)-                     _        -> return ()-                 return t--alternativeLayoutRuleToken :: PsLocated Token -> P (PsLocated Token)-alternativeLayoutRuleToken t-    = do context <- getALRContext-         lastLoc <- getAlrLastLoc-         mExpectingOCurly <- getAlrExpectingOCurly-         transitional <- getBit ALRTransitionalBit-         justClosedExplicitLetBlock <- getJustClosedExplicitLetBlock-         setJustClosedExplicitLetBlock False-         let thisLoc = getLoc t-             thisCol = srcSpanStartCol (psRealSpan thisLoc)-             newLine = srcSpanStartLine (psRealSpan thisLoc) > srcSpanEndLine (psRealSpan lastLoc)-         case (unLoc t, context, mExpectingOCurly) of-             -- This case handles a GHC extension to the original H98-             -- layout rule...-             (ITocurly, _, Just alrLayout) ->-                 do setAlrExpectingOCurly Nothing-                    let isLet = case alrLayout of-                                ALRLayoutLet -> True-                                _ -> False-                    setALRContext (ALRNoLayout (containsCommas ITocurly) isLet : context)-                    return t-             -- ...and makes this case unnecessary-             {--             -- I think our implicit open-curly handling is slightly-             -- different to John's, in how it interacts with newlines-             -- and "in"-             (ITocurly, _, Just _) ->-                 do setAlrExpectingOCurly Nothing-                    setNextToken t-                    lexTokenAlr-             -}-             (_, ALRLayout _ col : _ls, Just expectingOCurly)-              | (thisCol > col) ||-                (thisCol == col &&-                 isNonDecreasingIndentation expectingOCurly) ->-                 do setAlrExpectingOCurly Nothing-                    setALRContext (ALRLayout expectingOCurly thisCol : context)-                    setNextToken t-                    return (L thisLoc ITvocurly)-              | otherwise ->-                 do setAlrExpectingOCurly Nothing-                    setPendingImplicitTokens [L lastLoc ITvccurly]-                    setNextToken t-                    return (L lastLoc ITvocurly)-             (_, _, Just expectingOCurly) ->-                 do setAlrExpectingOCurly Nothing-                    setALRContext (ALRLayout expectingOCurly thisCol : context)-                    setNextToken t-                    return (L thisLoc ITvocurly)-             -- We do the [] cases earlier than in the spec, as we-             -- have an actual EOF token-             (ITeof, ALRLayout _ _ : ls, _) ->-                 do setALRContext ls-                    setNextToken t-                    return (L thisLoc ITvccurly)-             (ITeof, _, _) ->-                 return t-             -- the other ITeof case omitted; general case below covers it-             (ITin, _, _)-              | justClosedExplicitLetBlock ->-                 return t-             (ITin, ALRLayout ALRLayoutLet _ : ls, _)-              | newLine ->-                 do setPendingImplicitTokens [t]-                    setALRContext ls-                    return (L thisLoc ITvccurly)-             -- This next case is to handle a transitional issue:-             (ITwhere, ALRLayout _ col : ls, _)-              | newLine && thisCol == col && transitional ->-                 do addWarning Opt_WarnAlternativeLayoutRuleTransitional-                      $ PsWarnTransitionalLayout (mkSrcSpanPs thisLoc) TransLayout_Where-                    setALRContext ls-                    setNextToken t-                    -- Note that we use lastLoc, as we may need to close-                    -- more layouts, or give a semicolon-                    return (L lastLoc ITvccurly)-             -- This next case is to handle a transitional issue:-             (ITvbar, ALRLayout _ col : ls, _)-              | newLine && thisCol == col && transitional ->-                 do addWarning Opt_WarnAlternativeLayoutRuleTransitional-                      $ PsWarnTransitionalLayout (mkSrcSpanPs thisLoc) TransLayout_Pipe-                    setALRContext ls-                    setNextToken t-                    -- Note that we use lastLoc, as we may need to close-                    -- more layouts, or give a semicolon-                    return (L lastLoc ITvccurly)-             (_, ALRLayout _ col : ls, _)-              | newLine && thisCol == col ->-                 do setNextToken t-                    let loc = psSpanStart thisLoc-                        zeroWidthLoc = mkPsSpan loc loc-                    return (L zeroWidthLoc ITsemi)-              | newLine && thisCol < col ->-                 do setALRContext ls-                    setNextToken t-                    -- Note that we use lastLoc, as we may need to close-                    -- more layouts, or give a semicolon-                    return (L lastLoc ITvccurly)-             -- We need to handle close before open, as 'then' is both-             -- an open and a close-             (u, _, _)-              | isALRclose u ->-                 case context of-                 ALRLayout _ _ : ls ->-                     do setALRContext ls-                        setNextToken t-                        return (L thisLoc ITvccurly)-                 ALRNoLayout _ isLet : ls ->-                     do let ls' = if isALRopen u-                                     then ALRNoLayout (containsCommas u) False : ls-                                     else ls-                        setALRContext ls'-                        when isLet $ setJustClosedExplicitLetBlock True-                        return t-                 [] ->-                     do let ls = if isALRopen u-                                    then [ALRNoLayout (containsCommas u) False]-                                    else []-                        setALRContext ls-                        -- XXX This is an error in John's code, but-                        -- it looks reachable to me at first glance-                        return t-             (u, _, _)-              | isALRopen u ->-                 do setALRContext (ALRNoLayout (containsCommas u) False : context)-                    return t-             (ITin, ALRLayout ALRLayoutLet _ : ls, _) ->-                 do setALRContext ls-                    setPendingImplicitTokens [t]-                    return (L thisLoc ITvccurly)-             (ITin, ALRLayout _ _ : ls, _) ->-                 do setALRContext ls-                    setNextToken t-                    return (L thisLoc ITvccurly)-             -- the other ITin case omitted; general case below covers it-             (ITcomma, ALRLayout _ _ : ls, _)-              | topNoLayoutContainsCommas ls ->-                 do setALRContext ls-                    setNextToken t-                    return (L thisLoc ITvccurly)-             (ITwhere, ALRLayout ALRLayoutDo _ : ls, _) ->-                 do setALRContext ls-                    setPendingImplicitTokens [t]-                    return (L thisLoc ITvccurly)-             -- the other ITwhere case omitted; general case below covers it-             (_, _, _) -> return t--isALRopen :: Token -> Bool-isALRopen ITcase          = True-isALRopen ITif            = True-isALRopen ITthen          = True-isALRopen IToparen        = True-isALRopen ITobrack        = True-isALRopen ITocurly        = True--- GHC Extensions:-isALRopen IToubxparen     = True-isALRopen _               = False--isALRclose :: Token -> Bool-isALRclose ITof     = True-isALRclose ITthen   = True-isALRclose ITelse   = True-isALRclose ITcparen = True-isALRclose ITcbrack = True-isALRclose ITccurly = True--- GHC Extensions:-isALRclose ITcubxparen = True-isALRclose _        = False--isNonDecreasingIndentation :: ALRLayout -> Bool-isNonDecreasingIndentation ALRLayoutDo = True-isNonDecreasingIndentation _           = False--containsCommas :: Token -> Bool-containsCommas IToparen = True-containsCommas ITobrack = True--- John doesn't have {} as containing commas, but records contain them,--- which caused a problem parsing Cabal's Distribution.Simple.InstallDirs--- (defaultInstallDirs).-containsCommas ITocurly = True--- GHC Extensions:-containsCommas IToubxparen = True-containsCommas _        = False--topNoLayoutContainsCommas :: [ALRContext] -> Bool-topNoLayoutContainsCommas [] = False-topNoLayoutContainsCommas (ALRLayout _ _ : ls) = topNoLayoutContainsCommas ls-topNoLayoutContainsCommas (ALRNoLayout b _ : _) = b--lexToken :: P (PsLocated Token)-lexToken = do-  inp@(AI loc1 buf) <- getInput-  sc <- getLexState-  exts <- getExts-  case alexScanUser exts inp sc of-    AlexEOF -> do-        let span = mkPsSpan loc1 loc1-        lt <- getLastLocEof-        setEofPos (psRealSpan span) (psRealSpan lt)-        setLastToken span 0-        return (L span ITeof)-    AlexError (AI loc2 buf) ->-        reportLexError (psRealLoc loc1) (psRealLoc loc2) buf-          (\k -> PsError (PsErrLexer LexError k) [])-    AlexSkip inp2 _ -> do-        setInput inp2-        lexToken-    AlexToken inp2@(AI end buf2) _ t -> do-        setInput inp2-        let span = mkPsSpan loc1 end-        let bytes = byteDiff buf buf2-        span `seq` setLastToken span bytes-        lt <- t span buf bytes-        let lt' = unLoc lt-        if (isComment lt') then setLastComment lt else setLastTk lt-        return lt--reportLexError :: RealSrcLoc -> RealSrcLoc -> StringBuffer -> (LexErrKind -> SrcSpan -> PsError) -> P a-reportLexError loc1 loc2 buf f-  | atEnd buf = failLocMsgP loc1 loc2 (f LexErrKind_EOF)-  | otherwise =-  let c = fst (nextChar buf)-  in if c == '\0' -- decoding errors are mapped to '\0', see utf8DecodeChar#-     then failLocMsgP loc2 loc2 (f LexErrKind_UTF8)-     else failLocMsgP loc1 loc2 (f (LexErrKind_Char c))--lexTokenStream :: ParserOpts -> StringBuffer -> RealSrcLoc -> ParseResult [Located Token]-lexTokenStream opts buf loc = unP go initState{ options = opts' }-    where-    new_exts  = xunset HaddockBit        -- disable Haddock-                $ xunset UsePosPragsBit  -- parse LINE/COLUMN pragmas as tokens-                $ xset RawTokenStreamBit -- include comments-                $ pExtsBitmap opts-    opts'     = opts { pExtsBitmap = new_exts }-    initState = initParserState opts' buf loc-    go = do-      ltok <- lexer False return-      case ltok of-        L _ ITeof -> return []-        _ -> liftM (ltok:) go--linePrags = Map.singleton "line" linePrag--fileHeaderPrags = Map.fromList([("options", lex_string_prag IToptions_prag),-                                 ("options_ghc", lex_string_prag IToptions_prag),-                                 ("options_haddock", lex_string_prag_comment ITdocOptions),-                                 ("language", token ITlanguage_prag),-                                 ("include", lex_string_prag ITinclude_prag)])--ignoredPrags = Map.fromList (map ignored pragmas)-               where ignored opt = (opt, nested_comment lexToken)-                     impls = ["hugs", "nhc98", "jhc", "yhc", "catch", "derive"]-                     options_pragmas = map ("options_" ++) impls-                     -- CFILES is a hugs-only thing.-                     pragmas = options_pragmas ++ ["cfiles", "contract"]--oneWordPrags = Map.fromList [-     ("rules", rulePrag),-     ("inline",-         strtoken (\s -> (ITinline_prag (SourceText s) Inline FunLike))),-     ("inlinable",-         strtoken (\s -> (ITinline_prag (SourceText s) Inlinable FunLike))),-     ("inlineable",-         strtoken (\s -> (ITinline_prag (SourceText s) Inlinable FunLike))),-                                    -- Spelling variant-     ("notinline",-         strtoken (\s -> (ITinline_prag (SourceText s) NoInline FunLike))),-     ("specialize", strtoken (\s -> ITspec_prag (SourceText s))),-     ("source", strtoken (\s -> ITsource_prag (SourceText s))),-     ("warning", strtoken (\s -> ITwarning_prag (SourceText s))),-     ("deprecated", strtoken (\s -> ITdeprecated_prag (SourceText s))),-     ("scc", strtoken (\s -> ITscc_prag (SourceText s))),-     ("unpack", strtoken (\s -> ITunpack_prag (SourceText s))),-     ("nounpack", strtoken (\s -> ITnounpack_prag (SourceText s))),-     ("ann", strtoken (\s -> ITann_prag (SourceText s))),-     ("minimal", strtoken (\s -> ITminimal_prag (SourceText s))),-     ("overlaps", strtoken (\s -> IToverlaps_prag (SourceText s))),-     ("overlappable", strtoken (\s -> IToverlappable_prag (SourceText s))),-     ("overlapping", strtoken (\s -> IToverlapping_prag (SourceText s))),-     ("incoherent", strtoken (\s -> ITincoherent_prag (SourceText s))),-     ("ctype", strtoken (\s -> ITctype (SourceText s))),-     ("complete", strtoken (\s -> ITcomplete_prag (SourceText s))),-     ("column", columnPrag)-     ]--twoWordPrags = Map.fromList [-     ("inline conlike",-         strtoken (\s -> (ITinline_prag (SourceText s) Inline ConLike))),-     ("notinline conlike",-         strtoken (\s -> (ITinline_prag (SourceText s) NoInline ConLike))),-     ("specialize inline",-         strtoken (\s -> (ITspec_inline_prag (SourceText s) True))),-     ("specialize notinline",-         strtoken (\s -> (ITspec_inline_prag (SourceText s) False)))-     ]--dispatch_pragmas :: Map String Action -> Action-dispatch_pragmas prags span buf len = case Map.lookup (clean_pragma (lexemeToString buf len)) prags of-                                       Just found -> found span buf len-                                       Nothing -> lexError LexUnknownPragma--known_pragma :: Map String Action -> AlexAccPred ExtsBitmap-known_pragma prags _ (AI _ startbuf) _ (AI _ curbuf)- = isKnown && nextCharIsNot curbuf pragmaNameChar-    where l = lexemeToString startbuf (byteDiff startbuf curbuf)-          isKnown = isJust $ Map.lookup (clean_pragma l) prags-          pragmaNameChar c = isAlphaNum c || c == '_'--clean_pragma :: String -> String-clean_pragma prag = canon_ws (map toLower (unprefix prag))-                    where unprefix prag' = case stripPrefix "{-#" prag' of-                                             Just rest -> rest-                                             Nothing -> prag'-                          canonical prag' = case prag' of-                                              "noinline" -> "notinline"-                                              "specialise" -> "specialize"-                                              "constructorlike" -> "conlike"-                                              _ -> prag'-                          canon_ws s = unwords (map canonical (words s))----{--%************************************************************************-%*                                                                      *-        Helper functions for generating annotations in the parser-%*                                                                      *-%************************************************************************--}----- |Given a 'RealSrcSpan' that surrounds a 'HsPar' or 'HsParTy', generate--- 'AddEpAnn' values for the opening and closing bordering on the start--- and end of the span-mkParensEpAnn :: RealSrcSpan -> (AddEpAnn, AddEpAnn)-mkParensEpAnn ss = (AddEpAnn AnnOpenP (EpaSpan lo),AddEpAnn AnnCloseP (EpaSpan lc))-  where-    f = srcSpanFile ss-    sl = srcSpanStartLine ss-    sc = srcSpanStartCol ss-    el = srcSpanEndLine ss-    ec = srcSpanEndCol ss-    lo = mkRealSrcSpan (realSrcSpanStart ss)        (mkRealSrcLoc f sl (sc+1))-    lc = mkRealSrcSpan (mkRealSrcLoc f el (ec - 1)) (realSrcSpanEnd ss)--queueComment :: RealLocated Token -> P()-queueComment c = P $ \s -> POk s {-  comment_q = commentToAnnotation c : comment_q s-  } ()--allocateComments-  :: RealSrcSpan-  -> [LEpaComment]-  -> ([LEpaComment], [LEpaComment])-allocateComments ss comment_q =-  let-    (before,rest)  = break (\(L l _) -> isRealSubspanOf (anchor l) ss) comment_q-    (middle,after) = break (\(L l _) -> not (isRealSubspanOf (anchor l) ss)) rest-    comment_q' = before ++ after-    newAnns = middle-  in-    (comment_q', newAnns)--allocatePriorComments-  :: RealSrcSpan-  -> [LEpaComment]-  -> Maybe [LEpaComment]-  -> (Maybe [LEpaComment], [LEpaComment], [LEpaComment])-allocatePriorComments ss comment_q mheader_comments =-  let-    cmp (L l _) = anchor l <= ss-    (before,after) = partition cmp comment_q-    newAnns = before-    comment_q'= after-  in-    case mheader_comments of-      Nothing -> (Just newAnns, comment_q', [])-      Just _ -> (mheader_comments, comment_q', newAnns)--allocateFinalComments-  :: RealSrcSpan-  -> [LEpaComment]-  -> Maybe [LEpaComment]-  -> (Maybe [LEpaComment], [LEpaComment], [LEpaComment])-allocateFinalComments ss comment_q mheader_comments =-  let-    cmp (L l _) = anchor l <= ss-    (before,after) = partition cmp comment_q-    newAnns = after-    comment_q'= before-  in-    case mheader_comments of-      Nothing -> (Just newAnns,    [], comment_q')-      Just _ -> (mheader_comments, [], comment_q' ++ newAnns)--commentToAnnotation :: RealLocated Token -> LEpaComment-commentToAnnotation (L l (ITdocCommentNext s ll))  = mkLEpaComment l ll (EpaDocCommentNext s)-commentToAnnotation (L l (ITdocCommentPrev s ll))  = mkLEpaComment l ll (EpaDocCommentPrev s)-commentToAnnotation (L l (ITdocCommentNamed s ll)) = mkLEpaComment l ll (EpaDocCommentNamed s)-commentToAnnotation (L l (ITdocSection n s ll))    = mkLEpaComment l ll (EpaDocSection n s)-commentToAnnotation (L l (ITdocOptions s ll))      = mkLEpaComment l ll (EpaDocOptions s)-commentToAnnotation (L l (ITlineComment s ll))     = mkLEpaComment l ll (EpaLineComment s)-commentToAnnotation (L l (ITblockComment s ll))    = mkLEpaComment l ll (EpaBlockComment s)-commentToAnnotation _                           = panic "commentToAnnotation"---- see Note [PsSpan in Comments]-mkLEpaComment :: RealSrcSpan -> PsSpan -> EpaCommentTok -> LEpaComment-mkLEpaComment l ll tok = L (realSpanAsAnchor l) (EpaComment tok (psRealSpan ll))---- -----------------------------------------------------------------------isComment :: Token -> Bool-isComment (ITlineComment     _ _)   = True-isComment (ITblockComment    _ _)   = True-isComment (ITdocCommentNext  _ _)   = True-isComment (ITdocCommentPrev  _ _)   = True-isComment (ITdocCommentNamed _ _)   = True-isComment (ITdocSection      _ _ _) = True-isComment (ITdocOptions      _ _)   = True-isComment _ = False-}
GHC/Parser/PostProcess.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}@@ -7,6 +7,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE DataKinds #-}  {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -29,6 +30,7 @@         mkTyFamInst,         mkFamDecl,         mkInlinePragma,+        mkOpaquePragma,         mkPatSynMatchGroup,         mkRecConstrOrUpdate,         mkTyClD, mkInstD,@@ -36,6 +38,7 @@         setRdrNameSpace,         fromSpecTyVarBndr, fromSpecTyVarBndrs,         annBinds,+        fixValbindsAnn,          cvBindGroup,         cvBindsAndSigs,@@ -57,7 +60,9 @@         checkPrecP,           -- Int -> P Int         checkContext,         -- HsType -> P HsContext         checkPattern,         -- HsExp -> P HsPat-        checkPattern_hints,+        checkPattern_details,+        incompleteDoBlock,+        ParseContext(..),         checkMonadComp,       -- P (HsStmtContext GhcPs)         checkValDef,          -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl         checkValSigLhs,@@ -71,6 +76,9 @@         UnpackednessPragma(..),         mkMultTy, +        -- Token location+        mkTokenLocation,+         -- Help with processing exports         ImpExpSubSpec(..),         ImpExpQcSpec(..),@@ -118,17 +126,20 @@ import GHC.Types.Name import GHC.Unit.Module (ModuleName) import GHC.Types.Basic+import GHC.Types.Error import GHC.Types.Fixity+import GHC.Types.Hint import GHC.Types.SourceText import GHC.Parser.Types import GHC.Parser.Lexer-import GHC.Parser.Errors-import GHC.Utils.Lexeme ( isLexCon )+import GHC.Parser.Errors.Types+import GHC.Parser.Errors.Ppr ()+import GHC.Utils.Lexeme ( okConOcc ) import GHC.Types.TyThing import GHC.Core.Type    ( unrestrictedFunTyCon, Specificity(..) ) import GHC.Builtin.Types( cTupleTyConName, tupleTyCon, tupleDataCon,                           nilDataConName, nilDataConKey,-                          listTyConName, listTyConKey, eqTyCon_RDR )+                          listTyConName, listTyConKey ) import GHC.Types.ForeignCall import GHC.Types.SrcLoc import GHC.Types.Unique ( hasKey )@@ -136,14 +147,15 @@ import GHC.Utils.Outputable as Outputable import GHC.Data.FastString import GHC.Data.Maybe-import GHC.Data.Bag+import GHC.Utils.Error import GHC.Utils.Misc import Data.Either-import Data.List+import Data.List        ( findIndex ) import Data.Foldable-import GHC.Driver.Flags ( WarningFlag(..) ) import qualified Data.Semigroup as Semi import GHC.Utils.Panic+import GHC.Utils.Panic.Plain+import qualified GHC.Data.Strict as Strict  import Control.Monad import Text.ParserCombinators.ReadP as ReadP@@ -152,8 +164,6 @@ import Data.Kind       ( Type ) import Data.List.NonEmpty (NonEmpty) -#include "HsVersions.h"- {- **********************************************************************    Construction functions for Rdr stuff@@ -273,12 +283,14 @@     check_lhs_name v@(unLoc->name) =       if isUnqual name && isTcOcc (rdrNameOcc name)       then return v-      else addFatalError $ PsError (PsErrUnexpectedQualifiedConstructor (unLoc v)) [] (getLocA v)+      else addFatalError $ mkPlainErrorMsgEnvelope (getLocA v) $+             (PsErrUnexpectedQualifiedConstructor (unLoc v))     check_singular_lhs vs =       case vs of         [] -> panic "mkStandaloneKindSig: empty left-hand side"         [v] -> return v-        _ -> addFatalError $ PsError (PsErrMultipleNamesInStandaloneKindSignature vs) [] (getLoc lhs)+        _ -> addFatalError $ mkPlainErrorMsgEnvelope (getLoc lhs) $+               (PsErrMultipleNamesInStandaloneKindSignature vs)  mkTyFamInstEqn :: SrcSpan                -> HsOuterFamEqnTyVarBndrs GhcPs@@ -311,16 +323,32 @@               ksig data_cons (L _ maybe_deriv) anns   = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr        ; cs <- getCommentsFor loc -- Add any API Annotations to the top SrcSpan-       ; let anns' = addAnns (EpAnn (spanAsAnchor loc) ann cs) anns emptyComments+       ; let fam_eqn_ans = addAnns (EpAnn (spanAsAnchor loc) ann cs) anns emptyComments        ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv-       ; return (L (noAnnSrcSpan loc) (DataFamInstD anns' (DataFamInstDecl-                  (FamEqn { feqn_ext    = anns'+       ; return (L (noAnnSrcSpan loc) (DataFamInstD noExtField (DataFamInstDecl+                  (FamEqn { feqn_ext    = fam_eqn_ans                           , feqn_tycon  = tc                           , feqn_bndrs  = bndrs                           , feqn_pats   = tparams                           , feqn_fixity = fixity                           , feqn_rhs    = defn })))) } +-- mkDataFamInst loc new_or_data cType (mcxt, bndrs, tycl_hdr)+--               ksig data_cons (L _ maybe_deriv) anns+--   = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr+--        ; cs <- getCommentsFor loc -- Add any API Annotations to the top SrcSpan+--        ; let anns' = addAnns (EpAnn (spanAsAnchor loc) ann cs) anns emptyComments+--        ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv+--        ; return (L (noAnnSrcSpan loc) (DataFamInstD anns' (DataFamInstDecl+--                   (FamEqn { feqn_ext    = anns'+--                           , feqn_tycon  = tc+--                           , feqn_bndrs  = bndrs+--                           , feqn_pats   = tparams+--                           , feqn_fixity = fixity+--                           , feqn_rhs    = defn })))) }+++ mkTyFamInst :: SrcSpan             -> TyFamInstEqn GhcPs             -> [AddEpAnn]@@ -334,7 +362,7 @@           -> FamilyInfo GhcPs           -> TopLevelFlag           -> LHsType GhcPs                   -- LHS-          -> Located (FamilyResultSig GhcPs) -- Optional result signature+          -> LFamilyResultSig GhcPs          -- Optional result signature           -> Maybe (LInjectivityAnn GhcPs)   -- Injectivity annotation           -> [AddEpAnn]           -> P (LTyClDecl GhcPs)@@ -399,15 +427,16 @@     all_roles = map fromConstr $ dataTypeConstrs role_data_type     possible_roles = [(fsFromRole role, role) | role <- all_roles] -    parse_role (L loc_role Nothing) = return $ L loc_role Nothing+    parse_role (L loc_role Nothing) = return $ L (noAnnSrcSpan loc_role) Nothing     parse_role (L loc_role (Just role))       = case lookup role possible_roles of-          Just found_role -> return $ L loc_role $ Just found_role+          Just found_role -> return $ L (noAnnSrcSpan loc_role) $ Just found_role           Nothing         ->             let nearby = fuzzyLookup (unpackFS role)                   (mapFst unpackFS possible_roles)             in-            addFatalError $ PsError (PsErrIllegalRoleName role nearby) [] loc_role+            addFatalError $ mkPlainErrorMsgEnvelope loc_role $+              (PsErrIllegalRoleName role nearby)  -- | Converts a list of 'LHsTyVarBndr's annotated with their 'Specificity' to -- binders without annotations. Only accepts specified variables, and errors if@@ -427,7 +456,8 @@   where     check_spec :: Specificity -> SrcSpanAnnA -> P ()     check_spec SpecifiedSpec _   = return ()-    check_spec InferredSpec  loc = addFatalError $ PsError PsErrInferredTypeVarNotAllowed [] (locA loc)+    check_spec InferredSpec  loc = addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $+                                     PsErrInferredTypeVarNotAllowed  -- | Add the annotation for a 'where' keyword to existing @HsLocalBinds@ annBinds :: AddEpAnn -> EpAnnComments -> HsLocalBinds GhcPs@@ -459,6 +489,11 @@   where     r = if srcSpanStartLine r0 < 0 then r1 else r0 +fixValbindsAnn :: EpAnn AnnList -> EpAnn AnnList+fixValbindsAnn EpAnnNotUsed = EpAnnNotUsed+fixValbindsAnn (EpAnn anchor (AnnList ma o c r t) cs)+  = (EpAnn (widenAnchor anchor (map trailingAnnToAddEpAnn t)) (AnnList ma o c r t) cs)+ {- **********************************************************************    #cvBinds-etc# Converting to @HsBinds@, etc.@@ -479,8 +514,8 @@ cvBindGroup binding   = do { (mbs, sigs, fam_ds, tfam_insts          , dfam_insts, _) <- cvBindsAndSigs binding-       ; ASSERT( null fam_ds && null tfam_insts && null dfam_insts)-         return $ ValBinds NoAnnSortKey mbs sigs }+       ; massert (null fam_ds && null tfam_insts && null dfam_insts)+       ; return $ ValBinds NoAnnSortKey mbs sigs }  cvBindsAndSigs :: OrdList (LHsDecl GhcPs)   -> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs]@@ -508,7 +543,7 @@     -- called on top-level declarations.     drop_bad_decls [] = return []     drop_bad_decls (L l (SpliceD _ d) : ds) = do-      addError $ PsError (PsErrDeclSpliceNotAtTopLevel d) [] (locA l)+      addError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrDeclSpliceNotAtTopLevel d       drop_bad_decls ds     drop_bad_decls (d:ds) = (d:) <$> drop_bad_decls ds @@ -618,14 +653,13 @@ -- | Reinterpret a type constructor, including type operators, as a data --   constructor. -- See Note [Parsing data constructors is hard]-tyConToDataCon :: LocatedN RdrName -> Either PsError (LocatedN RdrName)+tyConToDataCon :: LocatedN RdrName -> Either (MsgEnvelope PsMessage) (LocatedN RdrName) tyConToDataCon (L loc tc)-  | isTcOcc occ || isDataOcc occ-  , isLexCon (occNameFS occ)+  | okConOcc (occNameString occ)   = return (L loc (setRdrNameSpace tc srcDataName))    | otherwise-  = Left $ PsError (PsErrNotADataCon tc) [] (locA loc)+  = Left $ mkPlainErrorMsgEnvelope (locA loc) $ (PsErrNotADataCon tc)   where     occ = rdrNameOcc tc @@ -666,17 +700,21 @@     fromDecl (L loc decl) = extraDeclErr (locA loc) decl      extraDeclErr loc decl =-        addFatalError $ PsError (PsErrNoSingleWhereBindInPatSynDecl patsyn_name decl) [] loc+        addFatalError $ mkPlainErrorMsgEnvelope loc $+          (PsErrNoSingleWhereBindInPatSynDecl patsyn_name decl)      wrongNameBindingErr loc decl =-      addFatalError $ PsError (PsErrInvalidWhereBindInPatSynDecl patsyn_name decl) [] loc+      addFatalError $ mkPlainErrorMsgEnvelope loc $+          (PsErrInvalidWhereBindInPatSynDecl patsyn_name decl)      wrongNumberErr loc =-      addFatalError $ PsError (PsErrEmptyWhereInPatSynDecl patsyn_name) [] loc+      addFatalError $ mkPlainErrorMsgEnvelope loc $+        (PsErrEmptyWhereInPatSynDecl patsyn_name)  recordPatSynErr :: SrcSpan -> LPat GhcPs -> P a recordPatSynErr loc pat =-    addFatalError $ PsError (PsErrRecordSyntaxInPatSynDecl pat) [] loc+    addFatalError $ mkPlainErrorMsgEnvelope loc $+      (PsErrRecordSyntaxInPatSynDecl pat)  mkConDeclH98 :: EpAnn [AddEpAnn] -> LocatedN RdrName -> Maybe [LHsTyVarBndr Specificity GhcPs]                 -> Maybe (LHsContext GhcPs) -> HsConDeclH98Details GhcPs@@ -707,19 +745,24 @@   cs <- getCommentsFor loc   let l = noAnnSrcSpan loc -  let (args, res_ty, annsa, csa)-        | L ll (HsFunTy af _w (L loc' (HsRecTy an rf)) res_ty) <- body_ty-        = let-            an' = addTrailingAnnToL (locA loc') (anns af) (comments af) an-          in ( RecConGADT (L (SrcSpanAnn an' (locA loc')) rf), res_ty-             , [], epAnnComments (ann ll))-        | otherwise-        = let (anns, cs, arg_types, res_type) = splitHsFunType body_ty-          in (PrefixConGADT arg_types, res_type, anns, cs)+  (args, res_ty, annsa, csa) <-+    case body_ty of+     L ll (HsFunTy af hsArr (L loc' (HsRecTy an rf)) res_ty) -> do+       let an' = addCommentsToEpAnn (locA loc') an (comments af)+       arr <- case hsArr of+         HsUnrestrictedArrow arr -> return arr+         _ -> do addError $ mkPlainErrorMsgEnvelope (getLocA body_ty) $+                                 (PsErrIllegalGadtRecordMultiplicity hsArr)+                 return noHsUniTok -      an = case outer_bndrs of-        _                -> EpAnn (spanAsAnchor loc) (annsIn ++ annsa) (cs Semi.<> csa)+       return ( RecConGADT (L (SrcSpanAnn an' (locA loc')) rf) arr, res_ty+              , [], epAnnComments (ann ll))+     _ -> do+       let (anns, cs, arg_types, res_type) = splitHsFunType body_ty+       return (PrefixConGADT arg_types, res_type, anns, cs) +  let an = EpAnn (spanAsAnchor loc) (annsIn ++ annsa) (cs Semi.<> csa)+   pure $ L l ConDeclGADT                      { con_g_ext  = an                      , con_names  = names@@ -817,7 +860,7 @@ really doesn't matter! -} -eitherToP :: MonadP m => Either PsError a -> m a+eitherToP :: MonadP m => Either (MsgEnvelope PsMessage) a -> m a -- Adapts the Either monad to the P monad eitherToP (Left err)    = addFatalError err eitherToP (Right thing) = return thing@@ -830,9 +873,11 @@   = do { tvs <- mapM check tparms        ; return (mkHsQTvs tvs) }   where-    check (HsTypeArg _ ki@(L loc _)) = addFatalError $ PsError (PsErrUnexpectedTypeAppInDecl ki pp_what (unLoc tc)) [] (locA loc)+    check (HsTypeArg _ ki@(L loc _)) = addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $+                                         (PsErrUnexpectedTypeAppInDecl ki pp_what (unLoc tc))     check (HsValArg ty) = chkParens [] [] emptyComments ty-    check (HsArgPar sp) = addFatalError $ PsError (PsErrMalformedDecl pp_what (unLoc tc)) [] sp+    check (HsArgPar sp) = addFatalError $ mkPlainErrorMsgEnvelope sp $+                            (PsErrMalformedDecl pp_what (unLoc tc))         -- Keep around an action for adjusting the annotations of extra parens     chkParens :: [AddEpAnn] -> [AddEpAnn] -> EpAnnComments -> LHsType GhcPs               -> P (LHsTyVarBndr () GhcPs)@@ -860,7 +905,8 @@                 return (L (widenLocatedAn l an)                                      (UserTyVar (addAnns ann an cs) () (L ltv tv)))     chk _ _ _ t@(L loc _)-        = addFatalError $ PsError (PsErrUnexpectedTypeInDecl t pp_what (unLoc tc) tparms equals_or_where) [] (locA loc)+        = addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $+            (PsErrUnexpectedTypeInDecl t pp_what (unLoc tc) tparms equals_or_where)   whereDots, equalsDots :: SDoc@@ -872,9 +918,10 @@ checkDatatypeContext Nothing = return () checkDatatypeContext (Just c)     = do allowed <- getBit DatatypeContextsBit-         unless allowed $ addError $ PsError (PsErrIllegalDataTypeContext c) [] (getLocA c)+         unless allowed $ addError $ mkPlainErrorMsgEnvelope (getLocA c) $+                                       (PsErrIllegalDataTypeContext c) -type LRuleTyTmVar = Located RuleTyTmVar+type LRuleTyTmVar = LocatedAn NoEpAnns RuleTyTmVar data RuleTyTmVar = RuleTyTmVar (EpAnn [AddEpAnn]) (LocatedN RdrName) (Maybe (LHsType GhcPs)) -- ^ Essentially a wrapper for a @RuleBndr GhcPs@ @@ -889,26 +936,28 @@ mkRuleTyVarBndrs :: [LRuleTyTmVar] -> [LHsTyVarBndr () GhcPs] mkRuleTyVarBndrs = fmap cvt_one   where cvt_one (L l (RuleTyTmVar ann v Nothing))-          = L (noAnnSrcSpan l) (UserTyVar ann () (fmap tm_to_ty v))+          = L (l2l l) (UserTyVar ann () (fmap tm_to_ty v))         cvt_one (L l (RuleTyTmVar ann v (Just sig)))-          = L (noAnnSrcSpan l) (KindedTyVar ann () (fmap tm_to_ty v) sig)+          = L (l2l l) (KindedTyVar ann () (fmap tm_to_ty v) sig)     -- takes something in namespace 'varName' to something in namespace 'tvName'         tm_to_ty (Unqual occ) = Unqual (setOccNameSpace tvName occ)         tm_to_ty _ = panic "mkRuleTyVarBndrs" --- See note [Parsing explicit foralls in Rules] in Parser.y+-- See Note [Parsing explicit foralls in Rules] in Parser.y checkRuleTyVarBndrNames :: [LHsTyVarBndr flag GhcPs] -> P () checkRuleTyVarBndrNames = mapM_ (check . fmap hsTyVarName)   where check (L loc (Unqual occ)) =           -- TODO: don't use string here, OccName has a Unique/FastString           when ((occNameString occ ==) `any` ["forall","family","role"])-            (addFatalError $ PsError (PsErrParseErrorOnInput occ) [] (locA loc))+            (addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $+               (PsErrParseErrorOnInput occ))         check _ = panic "checkRuleTyVarBndrNames"  checkRecordSyntax :: (MonadP m, Outputable a) => LocatedA a -> m (LocatedA a) checkRecordSyntax lr@(L loc r)     = do allowed <- getBit TraditionalRecordSyntaxBit-         unless allowed $ addError $ PsError (PsErrIllegalTraditionalRecordSyntax (ppr r)) [] (locA loc)+         unless allowed $ addError $ mkPlainErrorMsgEnvelope (locA loc) $+                                       (PsErrIllegalTraditionalRecordSyntax (ppr r))          return lr  -- | Check if the gadt_constrlist is empty. Only raise parse error for@@ -917,7 +966,8 @@                 -> P (Located ([AddEpAnn], [LConDecl GhcPs])) checkEmptyGADTs gadts@(L span (_, []))           -- Empty GADT declaration.     = do gadtSyntax <- getBit GadtSyntaxBit   -- GADTs implies GADTSyntax-         unless gadtSyntax $ addError $ PsError PsErrIllegalWhereInDataDecl [] span+         unless gadtSyntax $ addError $ mkPlainErrorMsgEnvelope span $+                                          PsErrIllegalWhereInDataDecl          return gadts checkEmptyGADTs gadts = return gadts              -- Ordinary GADT declaration. @@ -940,7 +990,7 @@      -- workaround to define '*' despite StarIsType     go _ (HsParTy an (L l (HsStarTy _ isUni))) acc ops' cps' fix-      = do { addWarning Opt_WarnStarBinder (PsWarnStarBinder (locA l))+      = do { addPsMessage (locA l) PsWarnStarBinder            ; let name = mkOccName tcClsName (starSym isUni)            ; let a' = newAnns l an            ; return (L a' (Unqual name), acc, fix@@ -948,7 +998,7 @@      go _ (HsTyVar _ _ ltc@(L _ tc)) acc ops cps fix       | isRdrTc tc               = return (ltc, acc, fix, (reverse ops) ++ cps)-    go _ (HsOpTy _ t1 ltc@(L _ tc) t2) acc ops cps _fix+    go _ (HsOpTy _ _ t1 ltc@(L _ tc) t2) acc ops cps _fix       | isRdrTc tc               = return (ltc, HsValArg t1:HsValArg t2:acc, Infix, (reverse ops) ++ cps)     go l (HsParTy _ ty)    acc ops cps fix = goL ty acc (o:ops) (c:cps) fix       where@@ -964,7 +1014,8 @@                  | otherwise = getName (tupleTyCon Boxed arity)           -- See Note [Unit tuples] in GHC.Hs.Type  (TODO: is this still relevant?)     go l _ _ _ _ _-      = addFatalError $ PsError (PsErrMalformedTyOrClDecl ty) [] l+      = addFatalError $ mkPlainErrorMsgEnvelope l $+          (PsErrMalformedTyOrClDecl ty)      -- Combine the annotations from the HsParTy and HsStarTy into a     -- new one for the LocatedN RdrName@@ -972,15 +1023,14 @@     newAnns (SrcSpanAnn EpAnnNotUsed l) (EpAnn as (AnnParen _ o c) cs) =       let         lr = combineRealSrcSpans (realSrcSpan l) (anchor as)-        -- lr = widenAnchorR as (realSrcSpan l)         an = (EpAnn (Anchor lr UnchangedAnchor) (NameAnn NameParens o (EpaSpan $ realSrcSpan l) c []) cs)-      in SrcSpanAnn an (RealSrcSpan lr Nothing)+      in SrcSpanAnn an (RealSrcSpan lr Strict.Nothing)     newAnns _ EpAnnNotUsed = panic "missing AnnParen"     newAnns (SrcSpanAnn (EpAnn ap (AnnListItem ta) csp) l) (EpAnn as (AnnParen _ o c) cs) =       let         lr = combineRealSrcSpans (anchor ap) (anchor as)         an = (EpAnn (Anchor lr UnchangedAnchor) (NameAnn NameParens o (EpaSpan $ realSrcSpan l) c ta) (csp Semi.<> cs))-      in SrcSpanAnn an (RealSrcSpan lr Nothing)+      in SrcSpanAnn an (RealSrcSpan lr Strict.Nothing)  -- | Yield a parse error if we have a function applied directly to a do block -- etc. and BlockArguments is not enabled.@@ -990,29 +1040,30 @@   where     checkExpr :: LHsExpr GhcPs -> PV ()     checkExpr expr = case unLoc expr of-      HsDo _ (DoExpr m) _  -> check (PsErrDoInFunAppExpr m)     expr-      HsDo _ (MDoExpr m) _ -> check (PsErrMDoInFunAppExpr m)    expr-      HsLam {}             -> check PsErrLambdaInFunAppExpr     expr-      HsCase {}            -> check PsErrCaseInFunAppExpr       expr-      HsLamCase {}         -> check PsErrLambdaCaseInFunAppExpr expr-      HsLet {}             -> check PsErrLetInFunAppExpr        expr-      HsIf {}              -> check PsErrIfInFunAppExpr         expr-      HsProc {}            -> check PsErrProcInFunAppExpr       expr-      _                    -> return ()+      HsDo _ (DoExpr m) _      -> check (PsErrDoInFunAppExpr m)                  expr+      HsDo _ (MDoExpr m) _     -> check (PsErrMDoInFunAppExpr m)                 expr+      HsLam {}                 -> check PsErrLambdaInFunAppExpr                  expr+      HsCase {}                -> check PsErrCaseInFunAppExpr                    expr+      HsLamCase _ lc_variant _ -> check (PsErrLambdaCaseInFunAppExpr lc_variant) expr+      HsLet {}                 -> check PsErrLetInFunAppExpr                     expr+      HsIf {}                  -> check PsErrIfInFunAppExpr                      expr+      HsProc {}                -> check PsErrProcInFunAppExpr                    expr+      _                        -> return ()      checkCmd :: LHsCmd GhcPs -> PV ()     checkCmd cmd = case unLoc cmd of-      HsCmdLam {}  -> check PsErrLambdaCmdInFunAppCmd cmd-      HsCmdCase {} -> check PsErrCaseCmdInFunAppCmd   cmd-      HsCmdIf {}   -> check PsErrIfCmdInFunAppCmd     cmd-      HsCmdLet {}  -> check PsErrLetCmdInFunAppCmd    cmd-      HsCmdDo {}   -> check PsErrDoCmdInFunAppCmd     cmd-      _            -> return ()+      HsCmdLam {}                 -> check PsErrLambdaCmdInFunAppCmd                  cmd+      HsCmdCase {}                -> check PsErrCaseCmdInFunAppCmd                    cmd+      HsCmdLamCase _ lc_variant _ -> check (PsErrLambdaCaseCmdInFunAppCmd lc_variant) cmd+      HsCmdIf {}                  -> check PsErrIfCmdInFunAppCmd                      cmd+      HsCmdLet {}                 -> check PsErrLetCmdInFunAppCmd                     cmd+      HsCmdDo {}                  -> check PsErrDoCmdInFunAppCmd                      cmd+      _                           -> return ()      check err a = do       blockArguments <- getBit BlockArgumentsBit       unless blockArguments $-        addError $ PsError (err a) [] (getLocA a)+        addError $ mkPlainErrorMsgEnvelope (getLocA a) $ (err a)  -- | Validate the context constraints and break up a context into a list -- of predicates.@@ -1065,18 +1116,18 @@   -- 'ImportQualifiedPost' is not in effect.   whenJust mPost $ \post ->     when (not importQualifiedPostEnabled) $-      failOpNotEnabledImportQualifiedPost (RealSrcSpan (epaLocationRealSrcSpan post) Nothing)+      failOpNotEnabledImportQualifiedPost (RealSrcSpan (epaLocationRealSrcSpan post) Strict.Nothing)    -- Error if 'qualified' occurs in both pre and postpositive   -- positions.   whenJust mPost $ \post ->     when (isJust mPre) $-      failOpImportQualifiedTwice (RealSrcSpan (epaLocationRealSrcSpan post) Nothing)+      failOpImportQualifiedTwice (RealSrcSpan (epaLocationRealSrcSpan post) Strict.Nothing)    -- Warn if 'qualified' found in prepositive position and   -- 'Opt_WarnPrepositiveQualifiedModule' is enabled.   whenJust mPre $ \pre ->-    warnPrepositiveQualifiedModule (RealSrcSpan (epaLocationRealSrcSpan pre) Nothing)+    warnPrepositiveQualifiedModule (RealSrcSpan (epaLocationRealSrcSpan pre) Strict.Nothing)  -- ------------------------------------------------------------------------- -- Checking Patterns.@@ -1087,8 +1138,8 @@ checkPattern :: LocatedA (PatBuilder GhcPs) -> P (LPat GhcPs) checkPattern = runPV . checkLPat -checkPattern_hints :: [Hint] -> PV (LocatedA (PatBuilder GhcPs)) -> P (LPat GhcPs)-checkPattern_hints hints pp = runPV_hints hints (pp >>= checkLPat)+checkPattern_details :: ParseContext -> PV (LocatedA (PatBuilder GhcPs)) -> P (LPat GhcPs)+checkPattern_details extraDetails pp = runPV_details extraDetails (pp >>= checkLPat)  checkLPat :: LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs) checkLPat e@(L l _) = checkPat l e [] []@@ -1102,11 +1153,10 @@       , pat_args = PrefixCon tyargs args       }   | not (null tyargs) =-      add_hint TypeApplicationsInPatternsOnlyDataCons $-      patFail (locA l) (ppr e <+> hsep [text "@" <> ppr t | t <- tyargs])-  | not (null args) && patIsRec c =-      add_hint SuggestRecursiveDo $-      patFail (locA l) (ppr e)+      patFail (locA l) . PsErrInPat e $ PEIP_TypeArgs tyargs+  | (not (null args) && patIsRec c) = do+      ctx <- askParseContext+      patFail (locA l) . PsErrInPat e $ PEIP_RecPattern args YesPatIsRecursive ctx checkPat loc (L _ (PatBuilderAppType f t)) tyargs args =   checkPat loc f (t : tyargs) args checkPat loc (L _ (PatBuilderApp f e)) [] args = do@@ -1115,7 +1165,9 @@ checkPat loc (L l e) [] [] = do   p <- checkAPat loc e   return (L l p)-checkPat loc e _ _ = patFail (locA loc) (ppr e)+checkPat loc e _ _ = do+  details <- fromParseContext <$> askParseContext+  patFail (locA loc) (PsErrInPat (unLoc e) details)  checkAPat :: SrcSpanAnnA -> PatBuilder GhcPs -> PV (Pat GhcPs) checkAPat loc e0 = do@@ -1127,7 +1179,7 @@    -- Overloaded numeric patterns (e.g. f 0 x = x)    -- Negation is recorded separately, so that the literal is zero or +ve    -- NB. Negative *primitive* literals are already handled by the lexer-   PatBuilderOverLit pos_lit -> return (mkNPat (L (locA loc) pos_lit) Nothing noAnn)+   PatBuilderOverLit pos_lit -> return (mkNPat (L (l2l loc) pos_lit) Nothing noAnn)     -- n+k patterns    PatBuilderOpApp@@ -1136,12 +1188,12 @@            (L lloc (PatBuilderOverLit lit@(OverLit {ol_val = HsIntegral {}})))            (EpAnn anc _ cs)                      | nPlusKPatterns && (plus == plus_RDR)-                     -> return (mkNPlusKPat (L nloc n) (L (locA lloc) lit)+                     -> return (mkNPlusKPat (L nloc n) (L (l2l lloc) lit)                                 (EpAnn anc (epaLocationFromSrcAnn l) cs))     -- Improve error messages for the @-operator when the user meant an @-pattern    PatBuilderOpApp _ op _ _ | opIsAt (unLoc op) -> do-     addError $ PsError PsErrAtInPatPos [] (getLocA op)+     addError $ mkPlainErrorMsgEnvelope (getLocA op) PsErrAtInPatPos      return (WildPat noExtField)     PatBuilderOpApp l (L cl c) r anns@@ -1154,13 +1206,14 @@            , pat_args = InfixCon l r            } -   PatBuilderPar e an@(AnnParen pt o c) -> do-     (L l p) <- checkLPat e-     let aa = [AddEpAnn ai o, AddEpAnn ac c]-         (ai,ac) = parenTypeKws pt-     return (ParPat (EpAnn (spanAsAnchor $ (widenSpan (locA l) aa)) an emptyComments) (L l p))-   _           -> patFail (locA loc) (ppr e0)+   PatBuilderPar lpar e rpar -> do+     p <- checkLPat e+     return (ParPat (EpAnn (spanAsAnchor (locA loc)) NoEpAnns emptyComments) lpar p rpar) +   _           -> do+     details <- fromParseContext <$> askParseContext+     patFail (locA loc) (PsErrInPat e0 details)+ placeHolderPunRhs :: DisambECP b => PV (LocatedA b) -- The RHS of a punned record field will be filled in by the renamer -- It's better not to make it an error, in case we want to print it when@@ -1173,11 +1226,11 @@  checkPatField :: LHsRecField GhcPs (LocatedA (PatBuilder GhcPs))               -> PV (LHsRecField GhcPs (LPat GhcPs))-checkPatField (L l fld) = do p <- checkLPat (hsRecFieldArg fld)-                             return (L l (fld { hsRecFieldArg = p }))+checkPatField (L l fld) = do p <- checkLPat (hfbRHS fld)+                             return (L l (fld { hfbRHS = p })) -patFail :: SrcSpan -> SDoc -> PV a-patFail loc e = addFatalError $ PsError (PsErrParseErrorInPat e) [] loc+patFail :: SrcSpan -> PsMessage -> PV a+patFail loc msg = addFatalError $ mkPlainErrorMsgEnvelope loc $ msg  patIsRec :: RdrName -> Bool patIsRec e = e == mkUnqual varName (fsLit "rec")@@ -1216,7 +1269,7 @@              -> Located (GRHSs GhcPs (LHsExpr GhcPs))              -> P (HsBind GhcPs) checkFunBind strictness locF ann fun is_infix pats (L _ grhss)-  = do  ps <- runPV_hints param_hints (mapM checkLPat pats)+  = do  ps <- runPV_details extraDetails (mapM checkLPat pats)         let match_span = noAnnSrcSpan $ locF         cs <- getCommentsFor locF         return (makeFunBind fun (L (noAnnSrcSpan $ locA match_span)@@ -1230,9 +1283,9 @@         -- The span of the match covers the entire equation.         -- That isn't quite right, but it'll do for now.   where-    param_hints-      | Infix <- is_infix = [SuggestInfixBindMaybeAtPat (unLoc fun)]-      | otherwise         = []+    extraDetails+      | Infix <- is_infix = ParseContext (Just $ unLoc fun) NoIncompleteDoBlock+      | otherwise         = noParseContext  makeFunBind :: LocatedN RdrName -> LocatedL [LMatch GhcPs (LHsExpr GhcPs)]             -> HsBind GhcPs@@ -1272,11 +1325,11 @@   = return lrdr  checkValSigLhs lhs@(L l _)-  = addFatalError $ PsError (PsErrInvalidTypeSignature lhs) [] (locA l)+  = addFatalError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrInvalidTypeSignature lhs  checkDoAndIfThenElse   :: (Outputable a, Outputable b, Outputable c)-  => (a -> Bool -> b -> Bool -> c -> PsErrorDesc)+  => (a -> Bool -> b -> Bool -> c -> PsMessage)   -> LocatedA a -> Bool -> LocatedA b -> Bool -> LocatedA c -> PV () checkDoAndIfThenElse err guardExpr semiThen thenExpr semiElse elseExpr  | semiThen || semiElse = do@@ -1286,7 +1339,7 @@                     semiElse (unLoc elseExpr)           loc = combineLocs (reLoc guardExpr) (reLoc elseExpr) -      unless doAndIfThenElse $ addError (PsError e [] loc)+      unless doAndIfThenElse $ addError (mkPlainErrorMsgEnvelope loc e)   | otherwise = return ()  isFunLhs :: LocatedA (PatBuilder GhcPs)@@ -1299,7 +1352,7 @@    go (L _ (PatBuilderVar (L loc f))) es ops cps        | not (isRdrDataCon f)        = return (Just (L loc f, Prefix, es, (reverse ops) ++ cps))    go (L _ (PatBuilderApp f e)) es       ops cps = go f (e:es) ops cps-   go (L l (PatBuilderPar e _)) es@(_:_) ops cps+   go (L l (PatBuilderPar _ e _)) es@(_:_) ops cps                                       = let                                           (o,c) = mkParensEpAnn (realSrcSpan $ locA l)                                         in@@ -1351,7 +1404,7 @@ -- If the flag MonadComprehensions is set, return a 'MonadComp' context, -- otherwise use the usual 'ListComp' context -checkMonadComp :: PV (HsStmtContext GhcRn)+checkMonadComp :: PV HsDoFlavour checkMonadComp = do     monadComprehensions <- getBit MonadComprehensionsBit     return $ if monadComprehensions@@ -1405,10 +1458,10 @@ instance DisambInfixOp RdrName where   mkHsConOpPV (L l v) = return $ L l v   mkHsVarOpPV (L l v) = return $ L l v-  mkHsInfixHolePV l _ = addFatalError $ PsError PsErrInvalidInfixHole [] l+  mkHsInfixHolePV l _ = addFatalError $ mkPlainErrorMsgEnvelope l $ PsErrInvalidInfixHole  type AnnoBody b-  = ( Anno (GRHS GhcPs (LocatedA (Body b GhcPs))) ~ SrcSpan+  = ( Anno (GRHS GhcPs (LocatedA (Body b GhcPs))) ~ SrcAnn NoEpAnns     , Anno [LocatedA (Match GhcPs (LocatedA (Body b GhcPs)))] ~ SrcSpanAnnL     , Anno (Match GhcPs (LocatedA (Body b GhcPs))) ~ SrcSpanAnnA     , Anno (StmtLR GhcPs GhcPs (LocatedA (Body (Body b GhcPs) GhcPs))) ~ SrcSpanAnnA@@ -1426,14 +1479,19 @@   ecpFromCmd' :: LHsCmd GhcPs -> PV (LocatedA b)   -- | Return an expression without ambiguity, or fail in a non-expression context.   ecpFromExp' :: LHsExpr GhcPs -> PV (LocatedA b)-  mkHsProjUpdatePV :: SrcSpan -> Located [Located (HsFieldLabel GhcPs)]+  mkHsProjUpdatePV :: SrcSpan -> Located [LocatedAn NoEpAnns (DotFieldOcc GhcPs)]     -> LocatedA b -> Bool -> [AddEpAnn] -> PV (LHsRecProj GhcPs (LocatedA b))   -- | Disambiguate "\... -> ..." (lambda)   mkHsLamPV     :: SrcSpan -> (EpAnnComments -> MatchGroup GhcPs (LocatedA b)) -> PV (LocatedA b)   -- | Disambiguate "let ... in ..."   mkHsLetPV-    :: SrcSpan -> HsLocalBinds GhcPs -> LocatedA b -> AnnsLet -> PV (LocatedA b)+    :: SrcSpan+    -> LHsToken "let" GhcPs+    -> HsLocalBinds GhcPs+    -> LHsToken "in" GhcPs+    -> LocatedA b+    -> PV (LocatedA b)   -- | Infix operator representation   type InfixOp b   -- | Bring superclass constraints on InfixOp into scope.@@ -1446,8 +1504,9 @@   -- | Disambiguate "case ... of ..."   mkHsCasePV :: SrcSpan -> LHsExpr GhcPs -> (LocatedL [LMatch GhcPs (LocatedA b)])              -> EpAnnHsCase -> PV (LocatedA b)-  mkHsLamCasePV :: SrcSpan -> (LocatedL [LMatch GhcPs (LocatedA b)])-                -> [AddEpAnn]+  -- | Disambiguate "\case" and "\cases"+  mkHsLamCasePV :: SrcSpan -> LamCaseVariant+                -> (LocatedL [LMatch GhcPs (LocatedA b)]) -> [AddEpAnn]                 -> PV (LocatedA b)   -- | Function argument representation   type FunArg b@@ -1475,13 +1534,13 @@     AnnList ->     PV (LocatedA b)   -- | Disambiguate "( ... )" (parentheses)-  mkHsParPV :: SrcSpan -> LocatedA b -> AnnParen -> PV (LocatedA b)+  mkHsParPV :: SrcSpan -> LHsToken "(" GhcPs -> LocatedA b -> LHsToken ")" GhcPs -> PV (LocatedA b)   -- | Disambiguate a variable "f" or a data constructor "MkF".   mkHsVarPV :: LocatedN RdrName -> PV (LocatedA b)   -- | Disambiguate a monomorphic literal   mkHsLitPV :: Located (HsLit GhcPs) -> PV (Located b)   -- | Disambiguate an overloaded literal-  mkHsOverLitPV :: Located (HsOverLit GhcPs) -> PV (Located b)+  mkHsOverLitPV :: LocatedAn a (HsOverLit GhcPs) -> PV (LocatedAn a b)   -- | Disambiguate a wildcard   mkHsWildCardPV :: SrcSpan -> PV (Located b)   -- | Disambiguate "a :: t" (type annotation)@@ -1569,27 +1628,28 @@   type Body (HsCmd GhcPs) = HsCmd   ecpFromCmd' = return   ecpFromExp' (L l e) = cmdFail (locA l) (ppr e)-  mkHsProjUpdatePV l _ _ _ _ = addFatalError $ PsError PsErrOverloadedRecordDotInvalid [] l+  mkHsProjUpdatePV l _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l $+                                                 PsErrOverloadedRecordDotInvalid   mkHsLamPV l mg = do     cs <- getCommentsFor l     return $ L (noAnnSrcSpan l) (HsCmdLam NoExtField (mg cs))-  mkHsLetPV l bs e anns = do+  mkHsLetPV l tkLet bs tkIn e = do     cs <- getCommentsFor l-    return $ L (noAnnSrcSpan l) (HsCmdLet (EpAnn (spanAsAnchor l) anns cs) bs e)+    return $ L (noAnnSrcSpan l) (HsCmdLet (EpAnn (spanAsAnchor l) NoEpAnns cs) tkLet bs tkIn e)   type InfixOp (HsCmd GhcPs) = HsExpr GhcPs   superInfixOp m = m   mkHsOpAppPV l c1 op c2 = do-    let cmdArg c = L (getLocA c) $ HsCmdTop noExtField c+    let cmdArg c = L (l2l $ getLoc c) $ HsCmdTop noExtField c     cs <- getCommentsFor l     return $ L (noAnnSrcSpan l) $ HsCmdArrForm (EpAnn (spanAsAnchor l) (AnnList Nothing Nothing Nothing [] []) cs) (reLocL op) Infix Nothing [cmdArg c1, cmdArg c2]   mkHsCasePV l c (L lm m) anns = do     cs <- getCommentsFor l     let mg = mkMatchGroup FromSource (L lm m)     return $ L (noAnnSrcSpan l) (HsCmdCase (EpAnn (spanAsAnchor l) anns cs) c mg)-  mkHsLamCasePV l (L lm m) anns = do+  mkHsLamCasePV l lc_variant (L lm m) anns = do     cs <- getCommentsFor l-    let mg = mkMatchGroup FromSource (L lm m)-    return $ L (noAnnSrcSpan l) (HsCmdLamCase (EpAnn (spanAsAnchor l) anns cs) mg)+    let mg = mkLamCaseMatchGroup FromSource lc_variant (L lm m)+    return $ L (noAnnSrcSpan l) (HsCmdLamCase (EpAnn (spanAsAnchor l) anns cs) lc_variant mg)   type FunArg (HsCmd GhcPs) = HsExpr GhcPs   superFunArg m = m   mkHsAppPV l c e = do@@ -1605,13 +1665,13 @@   mkHsDoPV l Nothing stmts anns = do     cs <- getCommentsFor l     return $ L (noAnnSrcSpan l) (HsCmdDo (EpAnn (spanAsAnchor l) anns cs) stmts)-  mkHsDoPV l (Just m)    _ _ = addFatalError $ PsError (PsErrQualifiedDoInCmd m) [] l-  mkHsParPV l c ann = do+  mkHsDoPV l (Just m)    _ _ = addFatalError $ mkPlainErrorMsgEnvelope l $ PsErrQualifiedDoInCmd m+  mkHsParPV l lpar c rpar = do     cs <- getCommentsFor l-    return $ L (noAnnSrcSpan l) (HsCmdPar (EpAnn (spanAsAnchor l) ann cs) c)+    return $ L (noAnnSrcSpan l) (HsCmdPar (EpAnn (spanAsAnchor l) NoEpAnns cs) lpar c rpar)   mkHsVarPV (L l v) = cmdFail (locA l) (ppr v)   mkHsLitPV (L l a) = cmdFail l (ppr a)-  mkHsOverLitPV (L l a) = cmdFail l (ppr a)+  mkHsOverLitPV (L l a) = cmdFail (locA l) (ppr a)   mkHsWildCardPV l = cmdFail l (text "_")   mkHsTySigPV l a sig _ = cmdFail (locA l) (ppr a <+> text "::" <+> ppr sig)   mkHsExplicitListPV l xs _ = cmdFail l $@@ -1620,7 +1680,7 @@   mkHsRecordPV _ l _ a (fbinds, ddLoc) _ = do     let (fs, ps) = partitionEithers fbinds     if not (null ps)-      then addFatalError $ PsError PsErrOverloadedRecordDotInvalid [] l+      then addFatalError $ mkPlainErrorMsgEnvelope l $ PsErrOverloadedRecordDotInvalid       else cmdFail l $ ppr a <+> ppr (mk_rec_fields fs ddLoc)   mkHsNegAppPV l a _ = cmdFail l (text "-" <> ppr a)   mkHsSectionR_PV l op c = cmdFail l $@@ -1639,12 +1699,17 @@   rejectPragmaPV _ = return ()  cmdFail :: SrcSpan -> SDoc -> PV a-cmdFail loc e = addFatalError $ PsError (PsErrParseErrorInCmd e) [] loc+cmdFail loc e = addFatalError $ mkPlainErrorMsgEnvelope loc $ PsErrParseErrorInCmd e +checkLamMatchGroup :: SrcSpan -> MatchGroup GhcPs (LHsExpr GhcPs) -> PV ()+checkLamMatchGroup l (MG { mg_alts = (L _ (matches:_))}) = do+  when (null (hsLMatchPats matches)) $ addError $ mkPlainErrorMsgEnvelope l PsErrEmptyLambda+checkLamMatchGroup _ _ = return ()+ instance DisambECP (HsExpr GhcPs) where   type Body (HsExpr GhcPs) = HsExpr   ecpFromCmd' (L l c) = do-    addError $ PsError (PsErrArrowCmdInExpr c) [] (locA l)+    addError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrArrowCmdInExpr c     return (L l (hsHoleExpr noAnn))   ecpFromExp' = return   mkHsProjUpdatePV l fields arg isPun anns = do@@ -1652,10 +1717,12 @@     return $ mkRdrProjUpdate (noAnnSrcSpan l) fields arg isPun (EpAnn (spanAsAnchor l) anns cs)   mkHsLamPV l mg = do     cs <- getCommentsFor l-    return $ L (noAnnSrcSpan l) (HsLam NoExtField (mg cs))-  mkHsLetPV l bs c anns = do+    let mg' = mg cs+    checkLamMatchGroup l mg'+    return $ L (noAnnSrcSpan l) (HsLam NoExtField mg')+  mkHsLetPV l tkLet bs tkIn c = do     cs <- getCommentsFor l-    return $ L (noAnnSrcSpan l) (HsLet (EpAnn (spanAsAnchor l) anns cs) bs c)+    return $ L (noAnnSrcSpan l) (HsLet (EpAnn (spanAsAnchor l) NoEpAnns cs) tkLet bs tkIn c)   type InfixOp (HsExpr GhcPs) = HsExpr GhcPs   superInfixOp m = m   mkHsOpAppPV l e1 op e2 = do@@ -1665,10 +1732,10 @@     cs <- getCommentsFor l     let mg = mkMatchGroup FromSource (L lm m)     return $ L (noAnnSrcSpan l) (HsCase (EpAnn (spanAsAnchor l) anns cs) e mg)-  mkHsLamCasePV l (L lm m) anns = do+  mkHsLamCasePV l lc_variant (L lm m) anns = do     cs <- getCommentsFor l-    let mg = mkMatchGroup FromSource (L lm m)-    return $ L (noAnnSrcSpan l) (HsLamCase (EpAnn (spanAsAnchor l) anns cs) mg)+    let mg = mkLamCaseMatchGroup FromSource lc_variant (L lm m)+    return $ L (noAnnSrcSpan l) (HsLamCase (EpAnn (spanAsAnchor l) anns cs) lc_variant mg)   type FunArg (HsExpr GhcPs) = HsExpr GhcPs   superFunArg m = m   mkHsAppPV l e1 e2 = do@@ -1686,16 +1753,16 @@   mkHsDoPV l mod stmts anns = do     cs <- getCommentsFor l     return $ L (noAnnSrcSpan l) (HsDo (EpAnn (spanAsAnchor l) anns cs) (DoExpr mod) stmts)-  mkHsParPV l e ann = do+  mkHsParPV l lpar e rpar = do     cs <- getCommentsFor l-    return $ L (noAnnSrcSpan l) (HsPar (EpAnn (spanAsAnchor l) ann cs) e)+    return $ L (noAnnSrcSpan l) (HsPar (EpAnn (spanAsAnchor l) NoEpAnns cs) lpar e rpar)   mkHsVarPV v@(L l _) = return $ L (na2la l) (HsVar noExtField v)   mkHsLitPV (L l a) = do     cs <- getCommentsFor l     return $ L l (HsLit (comment (realSrcSpan l) cs) a)   mkHsOverLitPV (L l a) = do-    cs <- getCommentsFor l-    return $ L l (HsOverLit (comment (realSrcSpan l) cs) a)+    cs <- getCommentsFor (locA l)+    return $ L l (HsOverLit (comment (realSrcSpan (locA l)) cs) a)   mkHsWildCardPV l = return $ L l (hsHoleExpr noAnn)   mkHsTySigPV l a sig anns = do     cs <- getCommentsFor (locA l)@@ -1716,44 +1783,45 @@   mkHsSectionR_PV l op e = do     cs <- getCommentsFor l     return $ L l (SectionR (comment (realSrcSpan l) cs) op e)-  mkHsViewPatPV l a b _ = addError (PsError (PsErrViewPatInExpr a b) [] l)+  mkHsViewPatPV l a b _ = addError (mkPlainErrorMsgEnvelope l $ PsErrViewPatInExpr a b)                           >> return (L (noAnnSrcSpan l) (hsHoleExpr noAnn))-  mkHsAsPatPV l v e   _ = addError (PsError (PsErrTypeAppWithoutSpace (unLoc v) e) [] l)+  mkHsAsPatPV l v e   _ = addError (mkPlainErrorMsgEnvelope l $ PsErrTypeAppWithoutSpace (unLoc v) e)                           >> return (L (noAnnSrcSpan l) (hsHoleExpr noAnn))-  mkHsLazyPatPV l e   _ = addError (PsError (PsErrLazyPatWithoutSpace e) [] l)+  mkHsLazyPatPV l e   _ = addError (mkPlainErrorMsgEnvelope l $ PsErrLazyPatWithoutSpace e)                           >> return (L (noAnnSrcSpan l) (hsHoleExpr noAnn))-  mkHsBangPatPV l e   _ = addError (PsError (PsErrBangPatWithoutSpace e) [] l)+  mkHsBangPatPV l e   _ = addError (mkPlainErrorMsgEnvelope l $ PsErrBangPatWithoutSpace e)                           >> return (L (noAnnSrcSpan l) (hsHoleExpr noAnn))   mkSumOrTuplePV = mkSumOrTupleExpr   rejectPragmaPV (L _ (OpApp _ _ _ e)) =     -- assuming left-associative parsing of operators     rejectPragmaPV e-  rejectPragmaPV (L l (HsPragE _ prag _)) = addError $ PsError (PsErrUnallowedPragma prag) [] (locA l)+  rejectPragmaPV (L l (HsPragE _ prag _)) = addError $ mkPlainErrorMsgEnvelope (locA l) $+                                                         (PsErrUnallowedPragma prag)   rejectPragmaPV _                        = return ()  hsHoleExpr :: EpAnn EpAnnUnboundVar -> HsExpr GhcPs hsHoleExpr anns = HsUnboundVar anns (mkVarOcc "_") -type instance Anno (GRHS GhcPs (LocatedA (PatBuilder GhcPs))) = SrcSpan+type instance Anno (GRHS GhcPs (LocatedA (PatBuilder GhcPs))) = SrcAnn NoEpAnns type instance Anno [LocatedA (Match GhcPs (LocatedA (PatBuilder GhcPs)))] = SrcSpanAnnL type instance Anno (Match GhcPs (LocatedA (PatBuilder GhcPs))) = SrcSpanAnnA type instance Anno (StmtLR GhcPs GhcPs (LocatedA (PatBuilder GhcPs))) = SrcSpanAnnA  instance DisambECP (PatBuilder GhcPs) where   type Body (PatBuilder GhcPs) = PatBuilder-  ecpFromCmd' (L l c)    = addFatalError $ PsError (PsErrArrowCmdInPat c) [] (locA l)-  ecpFromExp' (L l e)    = addFatalError $ PsError (PsErrArrowExprInPat e) [] (locA l)-  mkHsLamPV l _          = addFatalError $ PsError PsErrLambdaInPat [] l-  mkHsLetPV l _ _ _      = addFatalError $ PsError PsErrLetInPat [] l-  mkHsProjUpdatePV l _ _ _ _ = addFatalError $ PsError PsErrOverloadedRecordDotInvalid [] l+  ecpFromCmd' (L l c)    = addFatalError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrArrowCmdInPat c+  ecpFromExp' (L l e)    = addFatalError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrArrowExprInPat e+  mkHsLamPV l _          = addFatalError $ mkPlainErrorMsgEnvelope l PsErrLambdaInPat+  mkHsLetPV l _ _ _ _    = addFatalError $ mkPlainErrorMsgEnvelope l PsErrLetInPat+  mkHsProjUpdatePV l _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrOverloadedRecordDotInvalid   type InfixOp (PatBuilder GhcPs) = RdrName   superInfixOp m = m   mkHsOpAppPV l p1 op p2 = do     cs <- getCommentsFor l     let anns = EpAnn (spanAsAnchor l) [] cs     return $ L (noAnnSrcSpan l) $ PatBuilderOpApp p1 op p2 anns-  mkHsCasePV l _ _ _     = addFatalError $ PsError PsErrCaseInPat [] l-  mkHsLamCasePV l _ _    = addFatalError $ PsError PsErrLambdaCaseInPat [] l+  mkHsCasePV l _ _ _          = addFatalError $ mkPlainErrorMsgEnvelope l PsErrCaseInPat+  mkHsLamCasePV l lc_variant _ _ = addFatalError $ mkPlainErrorMsgEnvelope l (PsErrLambdaCaseInPat lc_variant)   type FunArg (PatBuilder GhcPs) = PatBuilder GhcPs   superFunArg m = m   mkHsAppPV l p1 p2      = return $ L l (PatBuilderApp p1 p2)@@ -1761,12 +1829,12 @@     cs <- getCommentsFor (locA l)     let anns = EpAnn (spanAsAnchor (combineSrcSpans la (getLocA t))) (EpaSpan (realSrcSpan la)) cs     return $ L l (PatBuilderAppType p (mkHsPatSigType anns t))-  mkHsIfPV l _ _ _ _ _ _ = addFatalError $ PsError PsErrIfTheElseInPat [] l-  mkHsDoPV l _ _ _       = addFatalError $ PsError PsErrDoNotationInPat [] l-  mkHsParPV l p an       = return $ L (noAnnSrcSpan l) (PatBuilderPar p an)+  mkHsIfPV l _ _ _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrIfThenElseInPat+  mkHsDoPV l _ _ _       = addFatalError $ mkPlainErrorMsgEnvelope l PsErrDoNotationInPat+  mkHsParPV l lpar p rpar   = return $ L (noAnnSrcSpan l) (PatBuilderPar lpar p rpar)   mkHsVarPV v@(getLoc -> l) = return $ L (na2la l) (PatBuilderVar v)   mkHsLitPV lit@(L l a) = do-    checkUnboxedStringLitPat lit+    checkUnboxedLitPat lit     return $ L l (PatBuilderPat (LitPat noExtField a))   mkHsOverLitPV (L l a) = return $ L l (PatBuilderOverLit a)   mkHsWildCardPV l = return $ L l (PatBuilderPat (WildPat noExtField))@@ -1782,19 +1850,19 @@   mkHsRecordPV _ l _ a (fbinds, ddLoc) anns = do     let (fs, ps) = partitionEithers fbinds     if not (null ps)-     then addFatalError $ PsError PsErrOverloadedRecordDotInvalid [] l+     then addFatalError $ mkPlainErrorMsgEnvelope l PsErrOverloadedRecordDotInvalid      else do        cs <- getCommentsFor l        r <- mkPatRec a (mk_rec_fields fs ddLoc) (EpAnn (spanAsAnchor l) anns cs)        checkRecordSyntax (L (noAnnSrcSpan l) r)   mkHsNegAppPV l (L lp p) anns = do     lit <- case p of-      PatBuilderOverLit pos_lit -> return (L (locA lp) pos_lit)-      _ -> patFail l (text "-" <> ppr p)+      PatBuilderOverLit pos_lit -> return (L (l2l lp) pos_lit)+      _ -> patFail l $ PsErrInPat p PEIP_NegApp     cs <- getCommentsFor l     let an = EpAnn (spanAsAnchor l) anns cs     return $ L (noAnnSrcSpan l) (PatBuilderPat (mkNPat lit (Just noSyntaxExpr) an))-  mkHsSectionR_PV l op p = patFail l (pprInfixOcc (unLoc op) <> ppr p)+  mkHsSectionR_PV l op p = patFail l (PsErrParseRightOpSectionInPat (unLoc op) (unLoc p))   mkHsViewPatPV l a b anns = do     p <- checkLPat b     cs <- getCommentsFor l@@ -1816,13 +1884,32 @@   mkSumOrTuplePV = mkSumOrTuplePat   rejectPragmaPV _ = return () -checkUnboxedStringLitPat :: Located (HsLit GhcPs) -> PV ()-checkUnboxedStringLitPat (L loc lit) =+-- | Ensure that a literal pattern isn't of type Addr#, Float#, Double#.+checkUnboxedLitPat :: Located (HsLit GhcPs) -> PV ()+checkUnboxedLitPat (L loc lit) =   case lit of-    HsStringPrim _ _  -- Trac #13260-      -> addFatalError $ PsError (PsErrIllegalUnboxedStringInPat lit) [] loc-    _ -> return ()+    -- Don't allow primitive string literal patterns.+    -- See #13260.+    HsStringPrim {}+      -> addError $ mkPlainErrorMsgEnvelope loc $+                           (PsErrIllegalUnboxedStringInPat lit) +   -- Don't allow Float#/Double# literal patterns.+   -- See #9238 and Note [Rules for floating-point comparisons]+   -- in GHC.Core.Opt.ConstantFold.+    _ | is_floating_lit lit+      -> addError $ mkPlainErrorMsgEnvelope loc $+                           (PsErrIllegalUnboxedFloatingLitInPat lit)++      | otherwise+      -> return ()++  where+    is_floating_lit :: HsLit GhcPs -> Bool+    is_floating_lit (HsFloatPrim  {}) = True+    is_floating_lit (HsDoublePrim {}) = True+    is_floating_lit _                 = False+ mkPatRec ::   LocatedA (PatBuilder GhcPs) ->   HsRecFields GhcPs (LocatedA (PatBuilder GhcPs)) ->@@ -1837,7 +1924,8 @@          , pat_args = RecCon (HsRecFields fs dd)          } mkPatRec p _ _ =-  addFatalError $ PsError (PsErrInvalidRecordCon (unLoc p)) [] (getLocA p)+  addFatalError $ mkPlainErrorMsgEnvelope (getLocA p) $+                    (PsErrInvalidRecordCon (unLoc p))  -- | Disambiguate constructs that may appear when we do not know -- ahead of time whether we are parsing a type or a newtype/data constructor.@@ -1856,7 +1944,7 @@   -- | Disambiguate @f \@t@ (visible kind application)   mkHsAppKindTyPV :: LocatedA b -> SrcSpan -> LHsType GhcPs -> PV (LocatedA b)   -- | Disambiguate @f \# x@ (infix operator)-  mkHsOpTyPV :: LHsType GhcPs -> LocatedN RdrName -> LHsType GhcPs -> PV (LocatedA b)+  mkHsOpTyPV :: PromotionFlag -> LHsType GhcPs -> LocatedN RdrName -> LHsType GhcPs -> PV (LocatedA b)   -- | Disambiguate @{-\# UNPACK \#-} t@ (unpack/nounpack pragma)   mkUnpackednessPV :: Located UnpackednessPragma -> LocatedA b -> PV (LocatedA b) @@ -1864,7 +1952,7 @@   mkHsAppTyHeadPV = return   mkHsAppTyPV t1 t2 = return (mkHsAppTy t1 t2)   mkHsAppKindTyPV t l_at ki = return (mkHsAppKindTy l_at t ki)-  mkHsOpTyPV t1 op t2 = return (mkLHsOpTy t1 op t2)+  mkHsOpTyPV prom t1 op t2 = return (mkLHsOpTy prom t1 op t2)   mkUnpackednessPV = addUnpackednessP  dataConBuilderCon :: DataConBuilder -> LocatedN RdrName@@ -1900,17 +1988,20 @@     panic "mkHsAppTyPV: InfixDataConBuilder"    mkHsAppKindTyPV lhs l_at ki =-    addFatalError $ PsError (PsErrUnexpectedKindAppInDataCon (unLoc lhs) (unLoc ki)) [] l_at+    addFatalError $ mkPlainErrorMsgEnvelope l_at $+                      (PsErrUnexpectedKindAppInDataCon (unLoc lhs) (unLoc ki)) -  mkHsOpTyPV lhs tc rhs = do+  mkHsOpTyPV prom lhs tc rhs = do       check_no_ops (unLoc rhs)  -- check the RHS because parsing type operators is right-associative       data_con <- eitherToP $ tyConToDataCon tc+      checkNotPromotedDataCon prom data_con       return $ L l (InfixDataConBuilder lhs data_con rhs)     where       l = combineLocsA lhs rhs       check_no_ops (HsBangTy _ _ t) = check_no_ops (unLoc t)       check_no_ops (HsOpTy{}) =-        addError $ PsError (PsErrInvalidInfixDataCon (unLoc lhs) (unLoc tc) (unLoc rhs)) [] (locA l)+        addError $ mkPlainErrorMsgEnvelope (locA l) $+                     (PsErrInvalidInfixDataCon (unLoc lhs) (unLoc tc) (unLoc rhs))       check_no_ops _ = return ()    mkUnpackednessPV unpk constr_stuff@@ -1921,19 +2012,28 @@          let l = combineLocsA (reLocA unpk) constr_stuff          return $ L l (InfixDataConBuilder lhs' data_con rhs)     | otherwise =-      do addError $ PsError PsErrUnpackDataCon [] (getLoc unpk)+      do addError $ mkPlainErrorMsgEnvelope (getLoc unpk) PsErrUnpackDataCon          return constr_stuff  tyToDataConBuilder :: LHsType GhcPs -> PV (LocatedA DataConBuilder)-tyToDataConBuilder (L l (HsTyVar _ NotPromoted v)) = do+tyToDataConBuilder (L l (HsTyVar _ prom v)) = do   data_con <- eitherToP $ tyConToDataCon v+  checkNotPromotedDataCon prom data_con   return $ L l (PrefixDataConBuilder nilOL data_con) tyToDataConBuilder (L l (HsTupleTy _ HsBoxedOrConstraintTuple ts)) = do   let data_con = L (l2l l) (getRdrName (tupleDataCon Boxed (length ts)))   return $ L l (PrefixDataConBuilder (toOL ts) data_con) tyToDataConBuilder t =-  addFatalError $ PsError (PsErrInvalidDataCon (unLoc t)) [] (getLocA t)+  addFatalError $ mkPlainErrorMsgEnvelope (getLocA t) $+                    (PsErrInvalidDataCon (unLoc t)) +-- | Rejects declarations such as @data T = 'MkT@ (note the leading tick).+checkNotPromotedDataCon :: PromotionFlag -> LocatedN RdrName -> PV ()+checkNotPromotedDataCon NotPromoted _ = return ()+checkNotPromotedDataCon IsPromoted (L l name) =+  addError $ mkPlainErrorMsgEnvelope (locA l) $+    PsErrIllegalPromotionQuoteDataCon name+ {- Note [Ambiguous syntactic categories] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ There are places in the grammar where we do not know whether we are parsing an@@ -2381,11 +2481,10 @@ checkPrecP (L l (_,i)) (L _ ol)  | 0 <= i, i <= maxPrecedence = pure ()  | all specialOp ol = pure ()- | otherwise = addFatalError $ PsError (PsErrPrecedenceOutOfRange i) [] l+ | otherwise = addFatalError $ mkPlainErrorMsgEnvelope l (PsErrPrecedenceOutOfRange i)   where     -- If you change this, consider updating Note [Fixity of (->)] in GHC/Types.hs-    specialOp op = unLoc op `elem` [ eqTyCon_RDR-                                   , getRdrName unrestrictedFunTyCon ]+    specialOp op = unLoc op == getRdrName unrestrictedFunTyCon  mkRecConstrOrUpdate         :: Bool@@ -2399,10 +2498,12 @@   = do       let (fs, ps) = partitionEithers fbinds       if not (null ps)-        then addFatalError $ PsError PsErrOverloadedRecordDotInvalid [] (getLocA (head ps))+        then addFatalError $ mkPlainErrorMsgEnvelope (getLocA (head ps)) $+                               PsErrOverloadedRecordDotInvalid         else return (mkRdrRecordCon (L l c) (mk_rec_fields fs dd) anns) mkRecConstrOrUpdate overloaded_update exp _ (fs,dd) anns-  | Just dd_loc <- dd = addFatalError $ PsError PsErrDotsInRecordUpdate [] dd_loc+  | Just dd_loc <- dd = addFatalError $ mkPlainErrorMsgEnvelope dd_loc $+                                          PsErrDotsInRecordUpdate   | otherwise = mkRdrRecordUpd overloaded_update exp fs anns  mkRdrRecordUpd :: Bool -> LHsExpr GhcPs -> [Fbind (HsExpr GhcPs)] -> EpAnn [AddEpAnn] -> PV (HsExpr GhcPs)@@ -2412,11 +2513,12 @@   -- overloaded_on) is in effect because it affects the Left/Right nature   -- of the RecordUpd value we calculate.   let (fs, ps) = partitionEithers fbinds+      fs' :: [LHsRecUpdField GhcPs]       fs' = map (fmap mk_rec_upd_field) fs   case overloaded_on of     False | not $ null ps ->       -- A '.' was found in an update and OverloadedRecordUpdate isn't on.-      addFatalError $ PsError PsErrOverloadedRecordUpdateNotEnabled [] (locA loc)+      addFatalError $ mkPlainErrorMsgEnvelope (locA loc) PsErrOverloadedRecordUpdateNotEnabled     False ->       -- This is just a regular record update.       return RecordUpd {@@ -2425,12 +2527,13 @@       , rupd_flds = Left fs' }     True -> do       let qualifiedFields =-            [ L l lbl | L _ (HsRecField _ (L l lbl) _ _) <- fs'+            [ L l lbl | L _ (HsFieldBind _ (L l lbl) _ _) <- fs'                       , isQual . rdrNameAmbiguousFieldOcc $ lbl             ]       if not $ null qualifiedFields         then-          addFatalError $ PsError PsErrOverloadedRecordUpdateNoQualifiedFields [] (getLoc (head qualifiedFields))+          addFatalError $ mkPlainErrorMsgEnvelope (getLocA (head qualifiedFields)) $+            PsErrOverloadedRecordUpdateNoQualifiedFields         else -- This is a RecordDotSyntax update.           return RecordUpd {             rupd_ext = anns@@ -2443,12 +2546,12 @@     -- Convert a top-level field update like {foo=2} or {bar} (punned)     -- to a projection update.     recFieldToProjUpdate :: LHsRecField GhcPs  (LHsExpr GhcPs) -> LHsRecUpdProj GhcPs-    recFieldToProjUpdate (L l (HsRecField anns (L _ (FieldOcc _ (L loc rdr))) arg pun)) =+    recFieldToProjUpdate (L l (HsFieldBind anns (L _ (FieldOcc _ (L loc rdr))) arg pun)) =         -- The idea here is to convert the label to a singleton [FastString].         let f = occNameFS . rdrNameOcc $ rdr-            fl = HsFieldLabel noAnn (L lf f) -- AZ: what about the ann?+            fl = DotFieldOcc noAnn (L (l2l loc) f) -- AZ: what about the ann?             lf = locA loc-        in mkRdrProjUpdate l (L lf [L lf fl]) (punnedVar f) pun anns+        in mkRdrProjUpdate l (L lf [L (l2l loc) fl]) (punnedVar f) pun anns         where           -- If punning, compute HsVar "f" otherwise just arg. This           -- has the effect that sentinel HsVar "pun-rhs" is replaced@@ -2468,8 +2571,8 @@                                      , rec_dotdot = Just (L s (length fs)) }  mk_rec_upd_field :: HsRecField GhcPs (LHsExpr GhcPs) -> HsRecUpdField GhcPs-mk_rec_upd_field (HsRecField noAnn (L loc (FieldOcc _ rdr)) arg pun)-  = HsRecField noAnn (L loc (Unambiguous noExtField rdr)) arg pun+mk_rec_upd_field (HsFieldBind noAnn (L loc (FieldOcc _ rdr)) arg pun)+  = HsFieldBind noAnn (L loc (Unambiguous noExtField rdr)) arg pun  mkInlinePragma :: SourceText -> (InlineSpec, RuleMatchInfo) -> Maybe Activation                -> InlinePragma@@ -2486,9 +2589,23 @@             Just act -> act             Nothing  -> -- No phase specified                         case inl of-                          NoInline -> NeverActive-                          _other   -> AlwaysActive+                          NoInline _  -> NeverActive+                          Opaque _    -> NeverActive+                          _other      -> AlwaysActive +mkOpaquePragma :: SourceText -> InlinePragma+mkOpaquePragma src+  = InlinePragma { inl_src    = src+                 , inl_inline = Opaque src+                 , inl_sat    = Nothing+                 -- By marking the OPAQUE pragma NeverActive we stop+                 -- (constructor) specialisation on OPAQUE things.+                 --+                 -- See Note [OPAQUE pragma]+                 , inl_act    = NeverActive+                 , inl_rule   = FunLike+                 }+ ----------------------------------------------------------------------------- -- utilities for foreign declarations @@ -2504,7 +2621,7 @@       CApiConv           -> do         imp <- mkCImport         if isCWrapperImport imp-          then addFatalError $ PsError PsErrInvalidCApiImport [] loc+          then addFatalError $ mkPlainErrorMsgEnvelope loc PsErrInvalidCApiImport           else returnSpec imp       StdCallConv        -> returnSpec =<< mkCImport       PrimCallConv       -> mkOtherImport@@ -2517,7 +2634,8 @@     mkCImport = do       let e = unpackFS entity       case parseCImport cconv safety (mkExtName (unLoc v)) e (L loc esrc) of-        Nothing         -> addFatalError $ PsError PsErrMalformedEntityString [] loc+        Nothing         -> addFatalError $ mkPlainErrorMsgEnvelope loc $+                             PsErrMalformedEntityString         Just importSpec -> return importSpec      isCWrapperImport (CImport _ _ _ CWrapper _) = True@@ -2661,12 +2779,14 @@             in (\newName                         -> IEThingWith ann (L l newName) pos ies)                <$> nameT-          else addFatalError $ PsError PsErrIllegalPatSynExport [] (locA l)+          else addFatalError $ mkPlainErrorMsgEnvelope (locA l) $+                 PsErrIllegalPatSynExport   where     name = ieNameVal specname     nameT =       if isVarNameSpace (rdrNameSpace name)-        then addFatalError $ PsError (PsErrVarForTyCon name) [] (locA l)+        then addFatalError $ mkPlainErrorMsgEnvelope (locA l) $+               (PsErrVarForTyCon name)         else return $ ieNameFromSpec specname      ieNameVal (ImpExpQcName ln)   = unLoc ln@@ -2683,7 +2803,8 @@              -> P (LocatedN RdrName) mkTypeImpExp name =   do allowed <- getBit ExplicitNamespacesBit-     unless allowed $ addError $ PsError PsErrIllegalExplicitNamespace [] (getLocA name)+     unless allowed $ addError $ mkPlainErrorMsgEnvelope (getLocA name) $+                                   PsErrIllegalExplicitNamespace      return (fmap (`setRdrNameSpace` tcClsName) name)  checkImportSpec :: LocatedL [LIE GhcPs] -> P (LocatedL [LIE GhcPs])@@ -2693,7 +2814,7 @@       (l:_) -> importSpecError (locA l)   where     importSpecError l =-      addFatalError $ PsError PsErrIllegalImportBundleForm [] l+      addFatalError $ mkPlainErrorMsgEnvelope l PsErrIllegalImportBundleForm  -- In the correct order mkImpExpSubSpec :: [LocatedA ImpExpQcSpec] -> P ([AddEpAnn], ImpExpSubSpec)@@ -2714,21 +2835,25 @@  warnPrepositiveQualifiedModule :: SrcSpan -> P () warnPrepositiveQualifiedModule span =-  addWarning Opt_WarnPrepositiveQualifiedModule (PsWarnImportPreQualified span)+  addPsMessage span PsWarnImportPreQualified  failOpNotEnabledImportQualifiedPost :: SrcSpan -> P ()-failOpNotEnabledImportQualifiedPost loc = addError $ PsError PsErrImportPostQualified [] loc+failOpNotEnabledImportQualifiedPost loc =+  addError $ mkPlainErrorMsgEnvelope loc $ PsErrImportPostQualified  failOpImportQualifiedTwice :: SrcSpan -> P ()-failOpImportQualifiedTwice loc = addError $ PsError PsErrImportQualifiedTwice [] loc+failOpImportQualifiedTwice loc =+  addError $ mkPlainErrorMsgEnvelope loc $ PsErrImportQualifiedTwice  warnStarIsType :: SrcSpan -> P ()-warnStarIsType span = addWarning Opt_WarnStarIsType (PsWarnStarIsType span)+warnStarIsType span = addPsMessage span PsWarnStarIsType  failOpFewArgs :: MonadP m => LocatedN RdrName -> m a failOpFewArgs (L loc op) =   do { star_is_type <- getBit StarIsTypeBit-     ; addFatalError $ PsError (PsErrOpFewArgs (StarIsType star_is_type) op) [] (locA loc) }+     ; let is_star_type = if star_is_type then StarIsType else StarIsNotType+     ; addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $+         (PsErrOpFewArgs is_star_type op) }  ----------------------------------------------------------------------------- -- Misc utils@@ -2736,14 +2861,14 @@ data PV_Context =   PV_Context     { pv_options :: ParserOpts-    , pv_hints   :: [Hint]  -- See Note [Parser-Validator Hint]+    , pv_details :: ParseContext -- See Note [Parser-Validator Details]     }  data PV_Accum =   PV_Accum-    { pv_warnings        :: Bag PsWarning-    , pv_errors          :: Bag PsError-    , pv_header_comments :: Maybe [LEpaComment]+    { pv_warnings        :: Messages PsMessage+    , pv_errors          :: Messages PsMessage+    , pv_header_comments :: Strict.Maybe [LEpaComment]     , pv_comment_q       :: [LEpaComment]     } @@ -2784,15 +2909,18 @@       PV_Failed acc' -> PV_Failed acc'  runPV :: PV a -> P a-runPV = runPV_hints []+runPV = runPV_details noParseContext -runPV_hints :: [Hint] -> PV a -> P a-runPV_hints hints m =+askParseContext :: PV ParseContext+askParseContext = PV $ \(PV_Context _ details) acc -> PV_Ok acc details++runPV_details :: ParseContext -> PV a -> P a+runPV_details details m =   P $ \s ->     let       pv_ctx = PV_Context         { pv_options = options s-        , pv_hints   = hints }+        , pv_details = details }       pv_acc = PV_Accum         { pv_warnings = warnings s         , pv_errors   = errors s@@ -2807,22 +2935,14 @@         PV_Ok acc' a -> POk (mkPState acc') a         PV_Failed acc' -> PFailed (mkPState acc') -add_hint :: Hint -> PV a -> PV a-add_hint hint m =-  let modifyHint ctx = ctx{pv_hints = pv_hints ctx ++ [hint]} in-  PV (\ctx acc -> unPV m (modifyHint ctx) acc)- instance MonadP PV where-  addError err@(PsError e hints loc) =-    PV $ \ctx acc ->-      let err' | null (pv_hints ctx) = err-               | otherwise           = PsError e (hints ++ pv_hints ctx) loc-      in PV_Ok acc{pv_errors = err' `consBag` pv_errors acc} ()-  addWarning option w =-    PV $ \ctx acc ->-      if warnopt option (pv_options ctx)-         then PV_Ok acc{pv_warnings= w `consBag` pv_warnings acc} ()-         else PV_Ok acc ()+  addError err =+    PV $ \_ctx acc -> PV_Ok acc{pv_errors = err `addMessage` pv_errors acc} ()+  addWarning w =+    PV $ \_ctx acc ->+      -- No need to check for the warning flag to be set, GHC will correctly discard suppressed+      -- diagnostics.+      PV_Ok acc{pv_warnings= w `addMessage` pv_warnings acc} ()   addFatalError err =     addError err >> PV (const PV_Failed)   getBit ext =@@ -2847,11 +2967,11 @@       PV_Ok s {          pv_header_comments = header_comments',          pv_comment_q = comment_q'-       } (EpaCommentsBalanced (fromMaybe [] header_comments') (reverse newAnns))+       } (EpaCommentsBalanced (Strict.fromMaybe [] header_comments') newAnns) -{- Note [Parser-Validator Hint]+{- Note [Parser-Validator Details] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-A PV computation is parametrized by a hint for error messages, which can be set+A PV computation is parametrized by some 'ParseContext' for diagnostic messages, which can be set depending on validation context. We use this in checkPattern to fix #984.  Consider this example, where the user has forgotten a 'do':@@ -2878,16 +2998,17 @@     _ ->       result -We attempt to detect such cases and add a hint to the error messages:+We attempt to detect such cases and add a hint to the diagnostic messages:    T984.hs:6:9:     Parse error in pattern: case () of { _ -> result }     Possibly caused by a missing 'do'? -The "Possibly caused by a missing 'do'?" suggestion is the hint that is passed-as the 'pv_hints' field 'PV_Context'. When validating in a context other than-'bindpat' (a pattern to the left of <-), we set the hint to 'empty' and it has-no effect on the error messages.+The "Possibly caused by a missing 'do'?" suggestion is the hint that is computed+out of the 'ParseContext', which are read by functions like 'patFail' when+constructing the 'PsParseErrorInPatDetails' data structure. When validating in a+context other than 'bindpat' (a pattern to the left of <-), we set the+details to 'noParseContext' and it has no effect on the diagnostic messages.  -} @@ -2896,7 +3017,7 @@ hintBangPat span e = do     bang_on <- getBit BangPatBit     unless bang_on $-      addError $ PsError (PsErrIllegalBangPattern e) [] span+      addError $ mkPlainErrorMsgEnvelope span $ PsErrIllegalBangPattern e  mkSumOrTupleExpr :: SrcSpanAnnA -> Boxity -> SumOrTuple (HsExpr GhcPs)                  -> [AddEpAnn]@@ -2922,7 +3043,7 @@     cs <- getCommentsFor (locA l)     return $ L l (ExplicitSum (EpAnn (spanAsAnchor $ locA l) an cs) alt arity e) mkSumOrTupleExpr l Boxed a@Sum{} _ =-    addFatalError $ PsError (PsErrUnsupportedBoxedSumExpr a) [] (locA l)+    addFatalError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrUnsupportedBoxedSumExpr a  mkSumOrTuplePat   :: SrcSpanAnnA -> Boxity -> SumOrTuple (PatBuilder GhcPs) -> [AddEpAnn]@@ -2938,7 +3059,8 @@     -- Ignore the element location so that the error message refers to the     -- entire tuple. See #19504 (and the discussion) for details.     toTupPat p = case p of-      Left _ -> addFatalError $ PsError PsErrTupleSectionInPat [] (locA l)+      Left _ -> addFatalError $+                  mkPlainErrorMsgEnvelope (locA l) PsErrTupleSectionInPat       Right p' -> checkLPat p'  -- Sum@@ -2948,19 +3070,39 @@    let an = EpAnn (spanAsAnchor $ locA l) (EpAnnSumPat anns barsb barsa) cs    return $ L l (PatBuilderPat (SumPat an p' alt arity)) mkSumOrTuplePat l Boxed a@Sum{} _ =-    addFatalError $ PsError (PsErrUnsupportedBoxedSumPat a) [] (locA l)+    addFatalError $+      mkPlainErrorMsgEnvelope (locA l) $ PsErrUnsupportedBoxedSumPat a -mkLHsOpTy :: LHsType GhcPs -> LocatedN RdrName -> LHsType GhcPs -> LHsType GhcPs-mkLHsOpTy x op y =+mkLHsOpTy :: PromotionFlag -> LHsType GhcPs -> LocatedN RdrName -> LHsType GhcPs -> LHsType GhcPs+mkLHsOpTy prom x op y =   let loc = getLoc x `combineSrcSpansA` (noAnnSrcSpan $ getLocA op) `combineSrcSpansA` getLoc y-  in L loc (mkHsOpTy x op y)+  in L loc (mkHsOpTy prom x op y) -mkMultTy :: IsUnicodeSyntax -> Located Token -> LHsType GhcPs -> HsArrow GhcPs-mkMultTy u tok t@(L _ (HsTyLit _ (HsNumTy (SourceText "1") 1)))+mkMultTy :: LHsToken "%" GhcPs -> LHsType GhcPs -> LHsUniToken "->" "→" GhcPs -> HsArrow GhcPs+mkMultTy pct t@(L _ (HsTyLit _ (HsNumTy (SourceText "1") 1))) arr   -- See #18888 for the use of (SourceText "1") above-  = HsLinearArrow u (Just $ AddEpAnn AnnPercentOne (EpaSpan $ realSrcSpan $ combineLocs tok (reLoc t)))-mkMultTy u tok t = HsExplicitMult u (Just $ AddEpAnn AnnPercent (EpaSpan $ realSrcSpan $ getLoc tok)) t+  = HsLinearArrow (HsPct1 (L locOfPct1 HsTok) arr)+  where+    -- The location of "%" combined with the location of "1".+    locOfPct1 :: TokenLocation+    locOfPct1 = token_location_widenR (getLoc pct) (locA (getLoc t))+mkMultTy pct t arr = HsExplicitMult pct t arr +mkTokenLocation :: SrcSpan -> TokenLocation+mkTokenLocation (UnhelpfulSpan _) = NoTokenLoc+mkTokenLocation (RealSrcSpan r _)  = TokenLoc (EpaSpan r)++-- Precondition: the TokenLocation has EpaSpan, never EpaDelta.+token_location_widenR :: TokenLocation -> SrcSpan -> TokenLocation+token_location_widenR NoTokenLoc _ = NoTokenLoc+token_location_widenR tl (UnhelpfulSpan _) = tl+token_location_widenR (TokenLoc (EpaSpan r1)) (RealSrcSpan r2 _) =+                      (TokenLoc (EpaSpan (combineRealSrcSpans r1 r2)))+token_location_widenR (TokenLoc (EpaDelta _ _)) _ =+  -- Never happens because the parser does not produce EpaDelta.+  panic "token_location_widenR: EpaDelta"++ ----------------------------------------------------------------------------- -- Token symbols @@ -2971,7 +3113,7 @@ ----------------------------------------- -- Bits and pieces for RecordDotSyntax. -mkRdrGetField :: SrcSpanAnnA -> LHsExpr GhcPs -> Located (HsFieldLabel GhcPs)+mkRdrGetField :: SrcSpanAnnA -> LHsExpr GhcPs -> LocatedAn NoEpAnns (DotFieldOcc GhcPs)   -> EpAnnCO -> LHsExpr GhcPs mkRdrGetField loc arg field anns =   L loc HsGetField {@@ -2980,21 +3122,21 @@     , gf_field = field     } -mkRdrProjection :: NonEmpty (Located (HsFieldLabel GhcPs)) -> EpAnn AnnProjection -> HsExpr GhcPs+mkRdrProjection :: NonEmpty (LocatedAn NoEpAnns (DotFieldOcc GhcPs)) -> EpAnn AnnProjection -> HsExpr GhcPs mkRdrProjection flds anns =   HsProjection {       proj_ext = anns     , proj_flds = flds     } -mkRdrProjUpdate :: SrcSpanAnnA -> Located [Located (HsFieldLabel GhcPs)]+mkRdrProjUpdate :: SrcSpanAnnA -> Located [LocatedAn NoEpAnns (DotFieldOcc GhcPs)]                 -> LHsExpr GhcPs -> Bool -> EpAnn [AddEpAnn]                 -> LHsRecProj GhcPs (LHsExpr GhcPs) mkRdrProjUpdate _ (L _ []) _ _ _ = panic "mkRdrProjUpdate: The impossible has happened!" mkRdrProjUpdate loc (L l flds) arg isPun anns =-  L loc HsRecField {-      hsRecFieldAnn = anns-    , hsRecFieldLbl = L l (FieldLabelStrings flds)-    , hsRecFieldArg = arg-    , hsRecPun = isPun+  L loc HsFieldBind {+      hfbAnn = anns+    , hfbLHS = L (noAnnSrcSpan l) (FieldLabelStrings flds)+    , hfbRHS = arg+    , hfbPun = isPun   }
GHC/Parser/PostProcess/Haddock.hs view
@@ -2,7 +2,6 @@ {-# LANGUAGE DeriveFunctor              #-} {-# LANGUAGE DerivingVia                #-} {-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE NamedFieldPuns             #-} {-# LANGUAGE RankNTypes                 #-} {-# LANGUAGE ScopedTypeVariables        #-}@@ -54,7 +53,6 @@ import GHC.Hs  import GHC.Types.SrcLoc-import GHC.Driver.Flags ( WarningFlag(..) ) import GHC.Utils.Panic import GHC.Data.Bag @@ -67,12 +65,14 @@ import Control.Monad.Trans.Reader import Control.Monad.Trans.Writer import Data.Functor.Identity-import Data.Coerce import qualified Data.Monoid +import {-# SOURCE #-} GHC.Parser (parseIdentifier) import GHC.Parser.Lexer-import GHC.Parser.Errors+import GHC.Parser.HaddockLex+import GHC.Parser.Errors.Types import GHC.Utils.Misc (mergeListsBy, filterOut, mapLastM, (<&&>))+import qualified GHC.Data.Strict as Strict  {- Note [Adding Haddock comments to the syntax tree] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -192,9 +192,9 @@  reportHdkWarning :: HdkWarn -> P () reportHdkWarning (HdkWarnInvalidComment (L l _)) =-  addWarning Opt_WarnInvalidHaddock $ PsWarnHaddockInvalidPos (mkSrcSpanPs l)+  addPsMessage (mkSrcSpanPs l) PsWarnHaddockInvalidPos reportHdkWarning (HdkWarnExtraComment (L l _)) =-  addWarning Opt_WarnInvalidHaddock $ PsWarnHaddockIgnoreMulti l+  addPsMessage l PsWarnHaddockIgnoreMulti  collectHdkWarnings :: HdkSt -> [HdkWarn] collectHdkWarnings HdkSt{ hdk_st_pending, hdk_st_warnings } =@@ -254,7 +254,8 @@         docs <-           inLocRange (locRangeTo (getBufPos (srcSpanStart (locA l_name)))) $           takeHdkComments mkDocNext-        selectDocString docs+        dc <- selectDocString docs+        pure $ lexLHsDocString <$> dc      -- Step 2, process documentation comments in the export list:     --@@ -294,6 +295,12 @@           , hsmodDecls = hsmodDecls'           , hsmodHaddockModHeader = join @Maybe headerDocs } +lexHsDocString :: HsDocString -> HsDoc GhcPs+lexHsDocString = lexHsDoc parseIdentifier++lexLHsDocString :: Located HsDocString -> LHsDoc GhcPs+lexLHsDocString = fmap lexHsDocString+ -- Only for module exports, not module imports. -- --    module M (a, b, c) where   -- use on this [LIE GhcPs]@@ -592,7 +599,7 @@  -- Process the deriving clauses of a data/newtype declaration. -- Not used for standalone deriving.-instance HasHaddock (Located [Located (HsDerivingClause GhcPs)]) where+instance HasHaddock (Located [LocatedAn NoEpAnns (HsDerivingClause GhcPs)]) where   addHaddock lderivs =     extendHdkA (getLoc lderivs) $     traverse @Located addHaddock lderivs@@ -604,10 +611,10 @@ --    deriving (Ord {- ^ Comment on Ord N -}) via Down N -- -- Not used for standalone deriving.-instance HasHaddock (Located (HsDerivingClause GhcPs)) where+instance HasHaddock (LocatedAn NoEpAnns (HsDerivingClause GhcPs)) where   addHaddock lderiv =-    extendHdkA (getLoc lderiv) $-    for @Located lderiv $ \deriv ->+    extendHdkA (getLocA lderiv) $+    for @(LocatedAn NoEpAnns) lderiv $ \deriv ->     case deriv of       HsDerivingClause { deriv_clause_ext, deriv_clause_strategy, deriv_clause_tys } -> do         let@@ -620,8 +627,8 @@           (register_strategy_before, register_strategy_after) =             case deriv_clause_strategy of               Nothing -> (pure (), pure ())-              Just (L l (ViaStrategy _)) -> (pure (), registerLocHdkA l)-              Just (L l _) -> (registerLocHdkA l, pure ())+              Just (L l (ViaStrategy _)) -> (pure (), registerLocHdkA (locA l))+              Just (L l _) -> (registerLocHdkA (locA l), pure ())         register_strategy_before         deriv_clause_tys' <- addHaddock deriv_clause_tys         register_strategy_after@@ -695,14 +702,14 @@         con_g_args' <-           case con_g_args of             PrefixConGADT ts -> PrefixConGADT <$> addHaddock ts-            RecConGADT (L l_rec flds) -> do+            RecConGADT (L l_rec flds) arr -> do               -- discardHasInnerDocs is ok because we don't need this info for GADTs.               flds' <- traverse (discardHasInnerDocs . addHaddockConDeclField) flds-              pure $ RecConGADT (L l_rec flds')+              pure $ RecConGADT (L l_rec flds') arr         con_res_ty' <- addHaddock con_res_ty         pure $ L l_con_decl $           ConDeclGADT { con_g_ext, con_names, con_bndrs, con_mb_cxt,-                        con_doc = con_doc',+                        con_doc = lexLHsDocString <$> con_doc',                         con_g_args = con_g_args',                         con_res_ty = con_res_ty' }       ConDeclH98 { con_ext, con_name, con_forall, con_ex_tvs, con_mb_cxt, con_args } ->@@ -713,7 +720,7 @@             ts' <- traverse addHaddockConDeclFieldTy ts             pure $ L l_con_decl $               ConDeclH98 { con_ext, con_name, con_forall, con_ex_tvs, con_mb_cxt,-                           con_doc = con_doc',+                           con_doc = lexLHsDocString <$> con_doc',                            con_args = PrefixCon noTypeArgs ts' }           InfixCon t1 t2 -> do             t1' <- addHaddockConDeclFieldTy t1@@ -721,14 +728,14 @@             t2' <- addHaddockConDeclFieldTy t2             pure $ L l_con_decl $               ConDeclH98 { con_ext, con_name, con_forall, con_ex_tvs, con_mb_cxt,-                           con_doc = con_doc',+                           con_doc = lexLHsDocString <$> con_doc',                            con_args = InfixCon t1' t2' }           RecCon (L l_rec flds) -> do             con_doc' <- getConDoc (getLocA con_name)             flds' <- traverse addHaddockConDeclField flds             pure $ L l_con_decl $               ConDeclH98 { con_ext, con_name, con_forall, con_ex_tvs, con_mb_cxt,-                           con_doc = con_doc',+                           con_doc = lexLHsDocString <$> con_doc',                            con_args = RecCon (L l_rec flds') }  -- Keep track of documentation comments on the data constructor or any of its@@ -770,7 +777,7 @@ -- data/newtype declaration. getConDoc   :: SrcSpan  -- Location of the data constructor-  -> ConHdkA (Maybe LHsDocString)+  -> ConHdkA (Maybe (Located HsDocString)) getConDoc l =   WriterT $ extendHdkA l $ liftHdkA $ do     mDoc <- getPrevNextDoc l@@ -794,7 +801,7 @@   -> ConHdkA (LConDeclField GhcPs) addHaddockConDeclField (L l_fld fld) =   WriterT $ extendHdkA (locA l_fld) $ liftHdkA $ do-    cd_fld_doc <- getPrevNextDoc (locA l_fld)+    cd_fld_doc <- fmap lexLHsDocString <$> getPrevNextDoc (locA l_fld)     return (L l_fld (fld { cd_fld_doc }),             HasInnerDocs (isJust cd_fld_doc)) @@ -863,7 +870,7 @@                     x <$ reportExtraDocs trailingDocs                   mk_doc_fld (L l' con_fld) = do                     doc <- selectDocString trailingDocs-                    return $ L l' (con_fld { cd_fld_doc = doc })+                    return $ L l' (con_fld { cd_fld_doc = fmap lexLHsDocString doc })               con_args' <- case con_args con_decl of                 x@(PrefixCon _ [])  -> x <$ reportExtraDocs trailingDocs                 x@(RecCon (L _ [])) -> x <$ reportExtraDocs trailingDocs@@ -874,7 +881,7 @@                   return (RecCon (L l_rec flds'))               return $ L l (con_decl{ con_args = con_args' })             else do-              con_doc' <- selectDocString (con_doc con_decl `mcons` trailingDocs)+              con_doc' <- selectDoc (con_doc con_decl `mcons` (map lexLHsDocString trailingDocs))               return $ L l (con_decl{ con_doc = con_doc' })         _ -> panic "addConTrailingDoc: non-H98 ConDecl" @@ -979,10 +986,10 @@         pure $ L l (HsForAllTy x tele body')        -- (Eq a, Num a) => t-      HsQualTy x mlhs rhs -> do-        traverse_ registerHdkA mlhs+      HsQualTy x lhs rhs -> do+        registerHdkA lhs         rhs' <- addHaddock rhs-        pure $ L l (HsQualTy x mlhs rhs')+        pure $ L l (HsQualTy x lhs rhs')        -- arg -> res       HsFunTy u mult lhs rhs -> do@@ -1023,7 +1030,8 @@ --  which it is used. data HdkA a =   HdkA-    !(Maybe BufSpan) -- Just b  <=> BufSpan occupied by the processed AST element.+    !(Strict.Maybe BufSpan)+                     -- Just b  <=> BufSpan occupied by the processed AST element.                      --             The surrounding computations will not look inside.                      --                      -- Nothing <=> No BufSpan (e.g. when the HdkA is constructed by 'pure' or 'liftHdkA').@@ -1048,7 +1056,7 @@                                 -- without any smart reordering strategy. So users of this                                 -- operation must take care to traverse the AST                                 -- in concrete syntax order.-                                -- See Note [Smart reordering in HdkA (or lack of thereof)]+                                -- See Note [Smart reordering in HdkA (or lack thereof)]                                 --                                 -- Each computation is delimited ("sandboxed")                                 -- in a way that it doesn't see any Haddock@@ -1056,17 +1064,17 @@                                 -- These delim1/delim2 are key to how HdkA operates.     where       -- Delimit the LHS by the location information from the RHS-      delim1 = inLocRange (locRangeTo (fmap @Maybe bufSpanStart l2))+      delim1 = inLocRange (locRangeTo (fmap @Strict.Maybe bufSpanStart l2))       -- Delimit the RHS by the location information from the LHS-      delim2 = inLocRange (locRangeFrom (fmap @Maybe bufSpanEnd l1))+      delim2 = inLocRange (locRangeFrom (fmap @Strict.Maybe bufSpanEnd l1))    pure a =     -- Return a value without performing any stateful computation, and without     -- any delimiting effect on the surrounding computations.     liftHdkA (pure a) -{- Note [Smart reordering in HdkA (or lack of thereof)]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+{- Note [Smart reordering in HdkA (or lack thereof)]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When traversing the AST, the user must take care to traverse it in concrete syntax order. @@ -1181,8 +1189,8 @@ -- Haddock twice. -- -- See Note [Adding Haddock comments to the syntax tree].-newtype HdkM a = HdkM (ReaderT LocRange (State HdkSt) a)-  deriving (Functor, Applicative, Monad)+newtype HdkM a = HdkM { unHdkM :: LocRange -> HdkSt -> (a, HdkSt) }+  deriving (Functor, Applicative, Monad) via (ReaderT LocRange (State HdkSt))  -- | The state of HdkM. data HdkSt =@@ -1197,15 +1205,7 @@ -- | Warnings accumulated in HdkM. data HdkWarn   = HdkWarnInvalidComment (PsLocated HdkComment)-  | HdkWarnExtraComment LHsDocString---- 'HdkM' without newtype wrapping/unwrapping.-type InlineHdkM a = LocRange -> HdkSt -> (a, HdkSt)--mkHdkM :: InlineHdkM a -> HdkM a-unHdkM :: HdkM a -> InlineHdkM a-mkHdkM = coerce-unHdkM = coerce+  | HdkWarnExtraComment (Located HsDocString)  -- Restrict the range in which a HdkM computation will look up comments: --@@ -1231,13 +1231,13 @@ -- In 'HdkA', every (<*>) may restrict the location range of its -- subcomputations. inLocRange :: LocRange -> HdkM a -> HdkM a-inLocRange r (HdkM m) = HdkM (local (mappend r) m)+inLocRange r (HdkM m) = HdkM (\r' -> m (r <> r'))  -- Take the Haddock comments that satisfy the matching function, -- leaving the rest pending. takeHdkComments :: forall a. (PsLocated HdkComment -> Maybe a) -> HdkM [a] takeHdkComments f =-  mkHdkM $+  HdkM $     \(LocRange hdk_from hdk_to hdk_col) ->     \hdk_st ->       let@@ -1247,8 +1247,7 @@         (items, other_comments) = foldr add_comment ([], []) comments_in_range         remaining_comments = comments_before_range ++ other_comments ++ comments_after_range         hdk_st' = hdk_st{ hdk_st_pending = remaining_comments }-      in-        (items, hdk_st')+      in (items, hdk_st')   where     is_after    StartOfFile    _               = True     is_after    (StartLoc l)   (L l_comment _) = bufSpanStart (psBufSpan l_comment) >= l@@ -1266,7 +1265,7 @@         Nothing -> (items, hdk_comment : other_hdk_comments)  -- Get the docnext or docprev comment for an AST node at the given source span.-getPrevNextDoc :: SrcSpan -> HdkM (Maybe LHsDocString)+getPrevNextDoc :: SrcSpan -> HdkM (Maybe (Located HsDocString)) getPrevNextDoc l = do   let (l_start, l_end) = (srcSpanStart l, srcSpanEnd l)       before_t = locRangeTo (getBufPos l_start)@@ -1276,11 +1275,11 @@   selectDocString (nextDocs ++ prevDocs)  appendHdkWarning :: HdkWarn -> HdkM ()-appendHdkWarning e = HdkM (ReaderT (\_ -> modify append_warn))-  where-    append_warn hdk_st = hdk_st { hdk_st_warnings = e : hdk_st_warnings hdk_st }+appendHdkWarning e = HdkM $ \_ hdk_st ->+  let hdk_st' = hdk_st { hdk_st_warnings = e : hdk_st_warnings hdk_st }+  in ((), hdk_st') -selectDocString :: [LHsDocString] -> HdkM (Maybe LHsDocString)+selectDocString :: [Located HsDocString] -> HdkM (Maybe (Located HsDocString)) selectDocString = select . filterOut (isEmptyDocString . unLoc)   where     select [] = return Nothing@@ -1289,7 +1288,16 @@       reportExtraDocs extra_docs       return (Just doc) -reportExtraDocs :: [LHsDocString] -> HdkM ()+selectDoc :: forall a. [LHsDoc a] -> HdkM (Maybe (LHsDoc a))+selectDoc = select . filterOut (isEmptyDocString . hsDocString . unLoc)+  where+    select [] = return Nothing+    select [doc] = return (Just doc)+    select (doc : extra_docs) = do+      reportExtraDocs $ map (\(L l d) -> L l $ hsDocString d) extra_docs+      return (Just doc)++reportExtraDocs :: [Located HsDocString] -> HdkM () reportExtraDocs =   traverse_ (\extra_doc -> appendHdkWarning (HdkWarnExtraComment extra_doc)) @@ -1306,13 +1314,14 @@ mkDocDecl layout_info (L l_comment hdk_comment)   | indent_mismatch = Nothing   | otherwise =-    Just $ L (noAnnSrcSpan $ mkSrcSpanPs l_comment) $+    Just $ L (noAnnSrcSpan span) $       case hdk_comment of-        HdkCommentNext doc -> DocCommentNext doc-        HdkCommentPrev doc -> DocCommentPrev doc-        HdkCommentNamed s doc -> DocCommentNamed s doc-        HdkCommentSection n doc -> DocGroup n doc+        HdkCommentNext doc -> DocCommentNext (L span $ lexHsDocString doc)+        HdkCommentPrev doc -> DocCommentPrev (L span $ lexHsDocString doc)+        HdkCommentNamed s doc -> DocCommentNamed s (L span $ lexHsDocString doc)+        HdkCommentSection n doc -> DocGroup n (L span $ lexHsDocString doc)   where+    span = mkSrcSpanPs l_comment     --  'indent_mismatch' checks if the documentation comment has the exact     --  indentation level expected by the parent node.     --@@ -1341,18 +1350,19 @@ mkDocIE :: PsLocated HdkComment -> Maybe (LIE GhcPs) mkDocIE (L l_comment hdk_comment) =   case hdk_comment of-    HdkCommentSection n doc -> Just $ L l (IEGroup noExtField n doc)+    HdkCommentSection n doc -> Just $ L l (IEGroup noExtField n $ L span $ lexHsDocString doc)     HdkCommentNamed s _doc -> Just $ L l (IEDocNamed noExtField s)-    HdkCommentNext doc -> Just $ L l (IEDoc noExtField doc)+    HdkCommentNext doc -> Just $ L l (IEDoc noExtField $ L span $ lexHsDocString doc)     _ -> Nothing-  where l = noAnnSrcSpan $ mkSrcSpanPs l_comment+  where l = noAnnSrcSpan span+        span = mkSrcSpanPs l_comment -mkDocNext :: PsLocated HdkComment -> Maybe LHsDocString-mkDocNext (L l (HdkCommentNext doc)) = Just $ L (mkSrcSpanPs l) doc+mkDocNext :: PsLocated HdkComment -> Maybe (Located HsDocString)+mkDocNext (L l (HdkCommentNext doc)) = Just (L (mkSrcSpanPs l) doc) mkDocNext _ = Nothing -mkDocPrev :: PsLocated HdkComment -> Maybe LHsDocString-mkDocPrev (L l (HdkCommentPrev doc)) = Just $ L (mkSrcSpanPs l) doc+mkDocPrev :: PsLocated HdkComment -> Maybe (Located HsDocString)+mkDocPrev (L l (HdkCommentPrev doc)) = Just (L (mkSrcSpanPs l) doc) mkDocPrev _ = Nothing  @@ -1377,14 +1387,14 @@   mempty = LocRange mempty mempty mempty  -- The location range from the specified position to the end of the file.-locRangeFrom :: Maybe BufPos -> LocRange-locRangeFrom (Just l) = mempty { loc_range_from = StartLoc l }-locRangeFrom Nothing = mempty+locRangeFrom :: Strict.Maybe BufPos -> LocRange+locRangeFrom (Strict.Just l) = mempty { loc_range_from = StartLoc l }+locRangeFrom Strict.Nothing = mempty  -- The location range from the start of the file to the specified position.-locRangeTo :: Maybe BufPos -> LocRange-locRangeTo (Just l) = mempty { loc_range_to = EndLoc l }-locRangeTo Nothing = mempty+locRangeTo :: Strict.Maybe BufPos -> LocRange+locRangeTo (Strict.Just l) = mempty { loc_range_to = EndLoc l }+locRangeTo Strict.Nothing = mempty  -- Represents a predicate on BufPos: --@@ -1405,6 +1415,7 @@ --  We'd rather only do the (>=40) check. So we reify the predicate to make --  sure we only check for the most restrictive bound. data LowerLocBound = StartOfFile | StartLoc !BufPos+  deriving Show  instance Semigroup LowerLocBound where   StartOfFile <> l = l@@ -1433,6 +1444,7 @@ --  We'd rather only do the (<=20) check. So we reify the predicate to make --  sure we only check for the most restrictive bound. data UpperLocBound = EndOfFile | EndLoc !BufPos+  deriving Show  instance Semigroup UpperLocBound where   EndOfFile <> l = l@@ -1451,6 +1463,7 @@ --  The semigroup instance corresponds to (&&). -- newtype ColumnBound = ColumnFrom Int -- n >= GHC.Types.SrcLoc.leftmostColumn+  deriving Show  instance Semigroup ColumnBound where   ColumnFrom n <> ColumnFrom m = ColumnFrom (max n m)@@ -1465,9 +1478,9 @@ *                                                                      * ********************************************************************* -} -mkLHsDocTy :: LHsType GhcPs -> Maybe LHsDocString -> LHsType GhcPs+mkLHsDocTy :: LHsType GhcPs -> Maybe (Located HsDocString) -> LHsType GhcPs mkLHsDocTy t Nothing = t-mkLHsDocTy t (Just doc) = L (getLoc t) (HsDocTy noAnn t doc)+mkLHsDocTy t (Just doc) = L (getLoc t) (HsDocTy noAnn t $ lexLHsDocString doc)  getForAllTeleLoc :: HsForAllTelescope GhcPs -> SrcSpan getForAllTeleLoc tele =@@ -1498,7 +1511,7 @@     mapLL (\s -> SigD noExtField s) all_ss,     mapLL (\t -> TyClD noExtField (FamDecl noExtField t)) all_ts,     mapLL (\tfi -> InstD noExtField (TyFamInstD noExtField tfi)) all_tfis,-    mapLL (\dfi -> InstD noExtField (DataFamInstD noAnn dfi)) all_dfis,+    mapLL (\dfi -> InstD noExtField (DataFamInstD noExtField dfi)) all_dfis,     mapLL (\d -> DocD noExtField d) all_docs   ] @@ -1561,13 +1574,9 @@     data Foo -- | Comment for MkFoo       where MkFoo :: Foo -The issue stems from the lack of location information for keywords. We could-utilize API Annotations for this purpose, but not without modification. For-example, API Annotations operate on RealSrcSpan, whereas we need BufSpan.--Also, there's work towards making API Annotations available in-tree (not in-a separate Map), see #17638. This change should make the fix very easy (it-is not as easy with the current design).+We could use EPA (exactprint annotations) to fix this, but not without+modification. For example, EpaLocation contains RealSrcSpan but not BufSpan.+Also, the fix would be more straghtforward after #19623. -See also testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.hs+For examples, see tests/haddock/should_compile_flag_haddock/T17544_kw.hs -}
GHC/Parser/Types.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DataKinds #-}  module GHC.Parser.Types    ( SumOrTuple(..)@@ -52,7 +53,7 @@ -- | See Note [Ambiguous syntactic categories] and Note [PatBuilder] data PatBuilder p   = PatBuilderPat (Pat p)-  | PatBuilderPar (LocatedA (PatBuilder p)) AnnParen+  | PatBuilderPar (LHsToken "(" p) (LocatedA (PatBuilder p)) (LHsToken ")" p)   | PatBuilderApp (LocatedA (PatBuilder p)) (LocatedA (PatBuilder p))   | PatBuilderAppType (LocatedA (PatBuilder p)) (HsPatSigType GhcPs)   | PatBuilderOpApp (LocatedA (PatBuilder p)) (LocatedN RdrName)@@ -62,7 +63,7 @@  instance Outputable (PatBuilder GhcPs) where   ppr (PatBuilderPat p) = ppr p-  ppr (PatBuilderPar (L _ p) _) = parens (ppr p)+  ppr (PatBuilderPar _ (L _ p) _) = parens (ppr p)   ppr (PatBuilderApp (L _ p1) (L _ p2)) = ppr p1 <+> ppr p2   ppr (PatBuilderAppType (L _ p) t) = ppr p <+> text "@" <> ppr t   ppr (PatBuilderOpApp (L _ p1) op (L _ p2) _) = ppr p1 <+> ppr op <+> ppr p2
GHC/Platform.hs view
@@ -32,6 +32,10 @@    , PlatformMisc(..)    , SseVersion (..)    , BmiVersion (..)+   , wordAlignment+   -- * SSE and AVX+   , isSseEnabled+   , isSse2Enabled    -- * Platform constants    , PlatformConstants(..)    , lookupPlatformConstants@@ -50,6 +54,7 @@ import GHC.ByteOrder (ByteOrder(..)) import GHC.Platform.Constants import GHC.Platform.ArchOS+import GHC.Types.Basic (Alignment, alignmentOf) import GHC.Utils.Panic.Plain  import Data.Word@@ -73,12 +78,50 @@    , platformTablesNextToCode         :: !Bool       -- ^ Determines whether we will be compiling info tables that reside just       --   before the entry code, or with an indirection to the entry code. See-      --   TABLES_NEXT_TO_CODE in includes/rts/storage/InfoTables.h.+      --   TABLES_NEXT_TO_CODE in rts/include/rts/storage/InfoTables.h.+   , platformHasLibm                  :: !Bool+      -- ^ Some platforms require that we explicitly link against @libm@ if any+      -- math-y things are used (which we assume to include all programs). See+      -- #14022.+    , platform_constants               :: !(Maybe PlatformConstants)       -- ^ Constants such as structure offsets, type sizes, etc.    }-   deriving (Read, Show, Eq)+   deriving (Read, Show, Eq, Ord) +wordAlignment :: Platform -> Alignment+wordAlignment platform = alignmentOf (platformWordSizeInBytes platform)++-- -----------------------------------------------------------------------------+-- SSE and AVX++-- TODO: Instead of using a separate predicate (i.e. isSse2Enabled) to+-- check if SSE is enabled, we might have x86-64 imply the -msse2+-- flag.++isSseEnabled :: Platform -> Bool+isSseEnabled platform = case platformArch platform of+    ArchX86_64 -> True+    ArchX86    -> True+    _          -> False++isSse2Enabled :: Platform -> Bool+isSse2Enabled platform = case platformArch platform of+  -- We assume  SSE1 and SSE2 operations are available on both+  -- x86 and x86_64. Historically we didn't default to SSE2 and+  -- SSE1 on x86, which results in defacto nondeterminism for how+  -- rounding behaves in the associated x87 floating point instructions+  -- because variations in the spill/fpu stack placement of arguments for+  -- operations would change the precision and final result of what+  -- would otherwise be the same expressions with respect to single or+  -- double precision IEEE floating point computations.+    ArchX86_64 -> True+    ArchX86    -> True+    _          -> False++-- -----------------------------------------------------------------------------+-- Platform Constants+ platformConstants :: Platform -> PlatformConstants platformConstants platform = case platform_constants platform of   Nothing -> panic "Platform constants not available!"@@ -93,6 +136,7 @@    , platformHasGnuNonexecStack      = False    , platformHasIdentDirective       = False    , platformHasSubsectionsViaSymbols= False+   , platformHasLibm                 = False    , platformIsCrossCompiling        = False    , platformLeadingUnderscore       = False    , platformTablesNextToCode        = True@@ -253,10 +297,7 @@   { -- TODO Recalculate string from richer info?     platformMisc_targetPlatformString :: String   , platformMisc_ghcWithInterpreter   :: Bool-  , platformMisc_ghcWithSMP           :: Bool-  , platformMisc_ghcRTSWays           :: String   , platformMisc_libFFI               :: Bool-  , platformMisc_ghcRtsWithLibdw      :: Bool   , platformMisc_llvmTarget           :: String   }
GHC/Platform/AArch64.hs view
@@ -6,4 +6,4 @@  #define MACHREGS_NO_REGS 0 #define MACHREGS_aarch64 1-#include "../../../includes/CodeGen.Platform.hs"+#include "CodeGen.Platform.h"
GHC/Platform/ARM.hs view
@@ -6,5 +6,5 @@  #define MACHREGS_NO_REGS 0 #define MACHREGS_arm 1-#include "../../../includes/CodeGen.Platform.hs"+#include "CodeGen.Platform.h"
− GHC/Platform/Constants.hs 
@@ -1,298 +0,0 @@-module GHC.Platform.Constants where--import Prelude-import Data.Char--data PlatformConstants = PlatformConstants {-      pc_CONTROL_GROUP_CONST_291 :: {-# UNPACK #-} !Int,-      pc_STD_HDR_SIZE :: {-# UNPACK #-} !Int,-      pc_PROF_HDR_SIZE :: {-# UNPACK #-} !Int,-      pc_BLOCK_SIZE :: {-# UNPACK #-} !Int,-      pc_BLOCKS_PER_MBLOCK :: {-# UNPACK #-} !Int,-      pc_TICKY_BIN_COUNT :: {-# UNPACK #-} !Int,-      pc_OFFSET_StgRegTable_rR1 :: {-# UNPACK #-} !Int,-      pc_OFFSET_StgRegTable_rR2 :: {-# UNPACK #-} !Int,-      pc_OFFSET_StgRegTable_rR3 :: {-# UNPACK #-} !Int,-      pc_OFFSET_StgRegTable_rR4 :: {-# UNPACK #-} !Int,-      pc_OFFSET_StgRegTable_rR5 :: {-# UNPACK #-} !Int,-      pc_OFFSET_StgRegTable_rR6 :: {-# UNPACK #-} !Int,-      pc_OFFSET_StgRegTable_rR7 :: {-# UNPACK #-} !Int,-      pc_OFFSET_StgRegTable_rR8 :: {-# UNPACK #-} !Int,-      pc_OFFSET_StgRegTable_rR9 :: {-# UNPACK #-} !Int,-      pc_OFFSET_StgRegTable_rR10 :: {-# UNPACK #-} !Int,-      pc_OFFSET_StgRegTable_rF1 :: {-# UNPACK #-} !Int,-      pc_OFFSET_StgRegTable_rF2 :: {-# UNPACK #-} !Int,-      pc_OFFSET_StgRegTable_rF3 :: {-# UNPACK #-} !Int,-      pc_OFFSET_StgRegTable_rF4 :: {-# UNPACK #-} !Int,-      pc_OFFSET_StgRegTable_rF5 :: {-# UNPACK #-} !Int,-      pc_OFFSET_StgRegTable_rF6 :: {-# UNPACK #-} !Int,-      pc_OFFSET_StgRegTable_rD1 :: {-# UNPACK #-} !Int,-      pc_OFFSET_StgRegTable_rD2 :: {-# UNPACK #-} !Int,-      pc_OFFSET_StgRegTable_rD3 :: {-# UNPACK #-} !Int,-      pc_OFFSET_StgRegTable_rD4 :: {-# UNPACK #-} !Int,-      pc_OFFSET_StgRegTable_rD5 :: {-# UNPACK #-} !Int,-      pc_OFFSET_StgRegTable_rD6 :: {-# UNPACK #-} !Int,-      pc_OFFSET_StgRegTable_rXMM1 :: {-# UNPACK #-} !Int,-      pc_OFFSET_StgRegTable_rXMM2 :: {-# UNPACK #-} !Int,-      pc_OFFSET_StgRegTable_rXMM3 :: {-# UNPACK #-} !Int,-      pc_OFFSET_StgRegTable_rXMM4 :: {-# UNPACK #-} !Int,-      pc_OFFSET_StgRegTable_rXMM5 :: {-# UNPACK #-} !Int,-      pc_OFFSET_StgRegTable_rXMM6 :: {-# UNPACK #-} !Int,-      pc_OFFSET_StgRegTable_rYMM1 :: {-# UNPACK #-} !Int,-      pc_OFFSET_StgRegTable_rYMM2 :: {-# UNPACK #-} !Int,-      pc_OFFSET_StgRegTable_rYMM3 :: {-# UNPACK #-} !Int,-      pc_OFFSET_StgRegTable_rYMM4 :: {-# UNPACK #-} !Int,-      pc_OFFSET_StgRegTable_rYMM5 :: {-# UNPACK #-} !Int,-      pc_OFFSET_StgRegTable_rYMM6 :: {-# UNPACK #-} !Int,-      pc_OFFSET_StgRegTable_rZMM1 :: {-# UNPACK #-} !Int,-      pc_OFFSET_StgRegTable_rZMM2 :: {-# UNPACK #-} !Int,-      pc_OFFSET_StgRegTable_rZMM3 :: {-# UNPACK #-} !Int,-      pc_OFFSET_StgRegTable_rZMM4 :: {-# UNPACK #-} !Int,-      pc_OFFSET_StgRegTable_rZMM5 :: {-# UNPACK #-} !Int,-      pc_OFFSET_StgRegTable_rZMM6 :: {-# UNPACK #-} !Int,-      pc_OFFSET_StgRegTable_rL1 :: {-# UNPACK #-} !Int,-      pc_OFFSET_StgRegTable_rSp :: {-# UNPACK #-} !Int,-      pc_OFFSET_StgRegTable_rSpLim :: {-# UNPACK #-} !Int,-      pc_OFFSET_StgRegTable_rHp :: {-# UNPACK #-} !Int,-      pc_OFFSET_StgRegTable_rHpLim :: {-# UNPACK #-} !Int,-      pc_OFFSET_StgRegTable_rCCCS :: {-# UNPACK #-} !Int,-      pc_OFFSET_StgRegTable_rCurrentTSO :: {-# UNPACK #-} !Int,-      pc_OFFSET_StgRegTable_rCurrentNursery :: {-# UNPACK #-} !Int,-      pc_OFFSET_StgRegTable_rHpAlloc :: {-# UNPACK #-} !Int,-      pc_OFFSET_stgEagerBlackholeInfo :: {-# UNPACK #-} !Int,-      pc_OFFSET_stgGCEnter1 :: {-# UNPACK #-} !Int,-      pc_OFFSET_stgGCFun :: {-# UNPACK #-} !Int,-      pc_OFFSET_Capability_r :: {-# UNPACK #-} !Int,-      pc_OFFSET_bdescr_start :: {-# UNPACK #-} !Int,-      pc_OFFSET_bdescr_free :: {-# UNPACK #-} !Int,-      pc_OFFSET_bdescr_blocks :: {-# UNPACK #-} !Int,-      pc_OFFSET_bdescr_flags :: {-# UNPACK #-} !Int,-      pc_SIZEOF_CostCentreStack :: {-# UNPACK #-} !Int,-      pc_OFFSET_CostCentreStack_mem_alloc :: {-# UNPACK #-} !Int,-      pc_REP_CostCentreStack_mem_alloc :: {-# UNPACK #-} !Int,-      pc_OFFSET_CostCentreStack_scc_count :: {-# UNPACK #-} !Int,-      pc_REP_CostCentreStack_scc_count :: {-# UNPACK #-} !Int,-      pc_OFFSET_StgHeader_ccs :: {-# UNPACK #-} !Int,-      pc_OFFSET_StgHeader_ldvw :: {-# UNPACK #-} !Int,-      pc_SIZEOF_StgSMPThunkHeader :: {-# UNPACK #-} !Int,-      pc_OFFSET_StgEntCounter_allocs :: {-# UNPACK #-} !Int,-      pc_REP_StgEntCounter_allocs :: {-# UNPACK #-} !Int,-      pc_OFFSET_StgEntCounter_allocd :: {-# UNPACK #-} !Int,-      pc_REP_StgEntCounter_allocd :: {-# UNPACK #-} !Int,-      pc_OFFSET_StgEntCounter_registeredp :: {-# UNPACK #-} !Int,-      pc_OFFSET_StgEntCounter_link :: {-# UNPACK #-} !Int,-      pc_OFFSET_StgEntCounter_entry_count :: {-# UNPACK #-} !Int,-      pc_SIZEOF_StgUpdateFrame_NoHdr :: {-# UNPACK #-} !Int,-      pc_SIZEOF_StgMutArrPtrs_NoHdr :: {-# UNPACK #-} !Int,-      pc_OFFSET_StgMutArrPtrs_ptrs :: {-# UNPACK #-} !Int,-      pc_OFFSET_StgMutArrPtrs_size :: {-# UNPACK #-} !Int,-      pc_SIZEOF_StgSmallMutArrPtrs_NoHdr :: {-# UNPACK #-} !Int,-      pc_OFFSET_StgSmallMutArrPtrs_ptrs :: {-# UNPACK #-} !Int,-      pc_SIZEOF_StgArrBytes_NoHdr :: {-# UNPACK #-} !Int,-      pc_OFFSET_StgArrBytes_bytes :: {-# UNPACK #-} !Int,-      pc_OFFSET_StgTSO_alloc_limit :: {-# UNPACK #-} !Int,-      pc_OFFSET_StgTSO_cccs :: {-# UNPACK #-} !Int,-      pc_OFFSET_StgTSO_stackobj :: {-# UNPACK #-} !Int,-      pc_OFFSET_StgStack_sp :: {-# UNPACK #-} !Int,-      pc_OFFSET_StgStack_stack :: {-# UNPACK #-} !Int,-      pc_OFFSET_StgUpdateFrame_updatee :: {-# UNPACK #-} !Int,-      pc_OFFSET_StgFunInfoExtraFwd_arity :: {-# UNPACK #-} !Int,-      pc_REP_StgFunInfoExtraFwd_arity :: {-# UNPACK #-} !Int,-      pc_SIZEOF_StgFunInfoExtraRev :: {-# UNPACK #-} !Int,-      pc_OFFSET_StgFunInfoExtraRev_arity :: {-# UNPACK #-} !Int,-      pc_REP_StgFunInfoExtraRev_arity :: {-# UNPACK #-} !Int,-      pc_MAX_SPEC_SELECTEE_SIZE :: {-# UNPACK #-} !Int,-      pc_MAX_SPEC_AP_SIZE :: {-# UNPACK #-} !Int,-      pc_MIN_PAYLOAD_SIZE :: {-# UNPACK #-} !Int,-      pc_MIN_INTLIKE :: {-# UNPACK #-} !Int,-      pc_MAX_INTLIKE :: {-# UNPACK #-} !Int,-      pc_MIN_CHARLIKE :: {-# UNPACK #-} !Int,-      pc_MAX_CHARLIKE :: {-# UNPACK #-} !Int,-      pc_MUT_ARR_PTRS_CARD_BITS :: {-# UNPACK #-} !Int,-      pc_MAX_Vanilla_REG :: {-# UNPACK #-} !Int,-      pc_MAX_Float_REG :: {-# UNPACK #-} !Int,-      pc_MAX_Double_REG :: {-# UNPACK #-} !Int,-      pc_MAX_Long_REG :: {-# UNPACK #-} !Int,-      pc_MAX_XMM_REG :: {-# UNPACK #-} !Int,-      pc_MAX_Real_Vanilla_REG :: {-# UNPACK #-} !Int,-      pc_MAX_Real_Float_REG :: {-# UNPACK #-} !Int,-      pc_MAX_Real_Double_REG :: {-# UNPACK #-} !Int,-      pc_MAX_Real_XMM_REG :: {-# UNPACK #-} !Int,-      pc_MAX_Real_Long_REG :: {-# UNPACK #-} !Int,-      pc_RESERVED_C_STACK_BYTES :: {-# UNPACK #-} !Int,-      pc_RESERVED_STACK_WORDS :: {-# UNPACK #-} !Int,-      pc_AP_STACK_SPLIM :: {-# UNPACK #-} !Int,-      pc_WORD_SIZE :: {-# UNPACK #-} !Int,-      pc_CINT_SIZE :: {-# UNPACK #-} !Int,-      pc_CLONG_SIZE :: {-# UNPACK #-} !Int,-      pc_CLONG_LONG_SIZE :: {-# UNPACK #-} !Int,-      pc_BITMAP_BITS_SHIFT :: {-# UNPACK #-} !Int,-      pc_TAG_BITS :: {-# UNPACK #-} !Int,-      pc_LDV_SHIFT :: {-# UNPACK #-} !Int,-      pc_ILDV_CREATE_MASK :: !Integer,-      pc_ILDV_STATE_CREATE :: !Integer,-      pc_ILDV_STATE_USE :: !Integer-  } deriving (Show,Read,Eq)---parseConstantsHeader :: FilePath -> IO PlatformConstants-parseConstantsHeader fp = do-  s <- readFile fp-  let def = "#define HS_CONSTANTS \""-      find [] xs = xs-      find _  [] = error $ "Couldn't find " ++ def ++ " in " ++ fp-      find (d:ds) (x:xs)-        | d == x    = find ds xs-        | otherwise = find def xs--      readVal' :: Bool -> Integer -> String -> [Integer]-      readVal' n     c (x:xs) = case x of-        '"' -> [if n then negate c else c]-        '-' -> readVal' True c xs-        ',' -> (if n then negate c else c) : readVal' False 0 xs-        _   -> readVal' n (c*10 + fromIntegral (ord x - ord '0')) xs-      readVal' n     c []     = [if n then negate c else c]--      readVal = readVal' False 0--  return $! case readVal (find def s) of-    [v0,v1,v2,v3,v4,v5,v6,v7,v8,v9,v10,v11,v12,v13,v14,v15-     ,v16,v17,v18,v19,v20,v21,v22,v23,v24,v25,v26,v27,v28,v29,v30,v31-     ,v32,v33,v34,v35,v36,v37,v38,v39,v40,v41,v42,v43,v44,v45,v46,v47-     ,v48,v49,v50,v51,v52,v53,v54,v55,v56,v57,v58,v59,v60,v61,v62,v63-     ,v64,v65,v66,v67,v68,v69,v70,v71,v72,v73,v74,v75,v76,v77,v78,v79-     ,v80,v81,v82,v83,v84,v85,v86,v87,v88,v89,v90,v91,v92,v93,v94,v95-     ,v96,v97,v98,v99,v100,v101,v102,v103,v104,v105,v106,v107,v108,v109,v110,v111-     ,v112,v113,v114,v115,v116,v117,v118,v119,v120,v121,v122,v123,v124,v125,v126,v127-     ] -> PlatformConstants-            { pc_CONTROL_GROUP_CONST_291 = fromIntegral v0-            , pc_STD_HDR_SIZE = fromIntegral v1-            , pc_PROF_HDR_SIZE = fromIntegral v2-            , pc_BLOCK_SIZE = fromIntegral v3-            , pc_BLOCKS_PER_MBLOCK = fromIntegral v4-            , pc_TICKY_BIN_COUNT = fromIntegral v5-            , pc_OFFSET_StgRegTable_rR1 = fromIntegral v6-            , pc_OFFSET_StgRegTable_rR2 = fromIntegral v7-            , pc_OFFSET_StgRegTable_rR3 = fromIntegral v8-            , pc_OFFSET_StgRegTable_rR4 = fromIntegral v9-            , pc_OFFSET_StgRegTable_rR5 = fromIntegral v10-            , pc_OFFSET_StgRegTable_rR6 = fromIntegral v11-            , pc_OFFSET_StgRegTable_rR7 = fromIntegral v12-            , pc_OFFSET_StgRegTable_rR8 = fromIntegral v13-            , pc_OFFSET_StgRegTable_rR9 = fromIntegral v14-            , pc_OFFSET_StgRegTable_rR10 = fromIntegral v15-            , pc_OFFSET_StgRegTable_rF1 = fromIntegral v16-            , pc_OFFSET_StgRegTable_rF2 = fromIntegral v17-            , pc_OFFSET_StgRegTable_rF3 = fromIntegral v18-            , pc_OFFSET_StgRegTable_rF4 = fromIntegral v19-            , pc_OFFSET_StgRegTable_rF5 = fromIntegral v20-            , pc_OFFSET_StgRegTable_rF6 = fromIntegral v21-            , pc_OFFSET_StgRegTable_rD1 = fromIntegral v22-            , pc_OFFSET_StgRegTable_rD2 = fromIntegral v23-            , pc_OFFSET_StgRegTable_rD3 = fromIntegral v24-            , pc_OFFSET_StgRegTable_rD4 = fromIntegral v25-            , pc_OFFSET_StgRegTable_rD5 = fromIntegral v26-            , pc_OFFSET_StgRegTable_rD6 = fromIntegral v27-            , pc_OFFSET_StgRegTable_rXMM1 = fromIntegral v28-            , pc_OFFSET_StgRegTable_rXMM2 = fromIntegral v29-            , pc_OFFSET_StgRegTable_rXMM3 = fromIntegral v30-            , pc_OFFSET_StgRegTable_rXMM4 = fromIntegral v31-            , pc_OFFSET_StgRegTable_rXMM5 = fromIntegral v32-            , pc_OFFSET_StgRegTable_rXMM6 = fromIntegral v33-            , pc_OFFSET_StgRegTable_rYMM1 = fromIntegral v34-            , pc_OFFSET_StgRegTable_rYMM2 = fromIntegral v35-            , pc_OFFSET_StgRegTable_rYMM3 = fromIntegral v36-            , pc_OFFSET_StgRegTable_rYMM4 = fromIntegral v37-            , pc_OFFSET_StgRegTable_rYMM5 = fromIntegral v38-            , pc_OFFSET_StgRegTable_rYMM6 = fromIntegral v39-            , pc_OFFSET_StgRegTable_rZMM1 = fromIntegral v40-            , pc_OFFSET_StgRegTable_rZMM2 = fromIntegral v41-            , pc_OFFSET_StgRegTable_rZMM3 = fromIntegral v42-            , pc_OFFSET_StgRegTable_rZMM4 = fromIntegral v43-            , pc_OFFSET_StgRegTable_rZMM5 = fromIntegral v44-            , pc_OFFSET_StgRegTable_rZMM6 = fromIntegral v45-            , pc_OFFSET_StgRegTable_rL1 = fromIntegral v46-            , pc_OFFSET_StgRegTable_rSp = fromIntegral v47-            , pc_OFFSET_StgRegTable_rSpLim = fromIntegral v48-            , pc_OFFSET_StgRegTable_rHp = fromIntegral v49-            , pc_OFFSET_StgRegTable_rHpLim = fromIntegral v50-            , pc_OFFSET_StgRegTable_rCCCS = fromIntegral v51-            , pc_OFFSET_StgRegTable_rCurrentTSO = fromIntegral v52-            , pc_OFFSET_StgRegTable_rCurrentNursery = fromIntegral v53-            , pc_OFFSET_StgRegTable_rHpAlloc = fromIntegral v54-            , pc_OFFSET_stgEagerBlackholeInfo = fromIntegral v55-            , pc_OFFSET_stgGCEnter1 = fromIntegral v56-            , pc_OFFSET_stgGCFun = fromIntegral v57-            , pc_OFFSET_Capability_r = fromIntegral v58-            , pc_OFFSET_bdescr_start = fromIntegral v59-            , pc_OFFSET_bdescr_free = fromIntegral v60-            , pc_OFFSET_bdescr_blocks = fromIntegral v61-            , pc_OFFSET_bdescr_flags = fromIntegral v62-            , pc_SIZEOF_CostCentreStack = fromIntegral v63-            , pc_OFFSET_CostCentreStack_mem_alloc = fromIntegral v64-            , pc_REP_CostCentreStack_mem_alloc = fromIntegral v65-            , pc_OFFSET_CostCentreStack_scc_count = fromIntegral v66-            , pc_REP_CostCentreStack_scc_count = fromIntegral v67-            , pc_OFFSET_StgHeader_ccs = fromIntegral v68-            , pc_OFFSET_StgHeader_ldvw = fromIntegral v69-            , pc_SIZEOF_StgSMPThunkHeader = fromIntegral v70-            , pc_OFFSET_StgEntCounter_allocs = fromIntegral v71-            , pc_REP_StgEntCounter_allocs = fromIntegral v72-            , pc_OFFSET_StgEntCounter_allocd = fromIntegral v73-            , pc_REP_StgEntCounter_allocd = fromIntegral v74-            , pc_OFFSET_StgEntCounter_registeredp = fromIntegral v75-            , pc_OFFSET_StgEntCounter_link = fromIntegral v76-            , pc_OFFSET_StgEntCounter_entry_count = fromIntegral v77-            , pc_SIZEOF_StgUpdateFrame_NoHdr = fromIntegral v78-            , pc_SIZEOF_StgMutArrPtrs_NoHdr = fromIntegral v79-            , pc_OFFSET_StgMutArrPtrs_ptrs = fromIntegral v80-            , pc_OFFSET_StgMutArrPtrs_size = fromIntegral v81-            , pc_SIZEOF_StgSmallMutArrPtrs_NoHdr = fromIntegral v82-            , pc_OFFSET_StgSmallMutArrPtrs_ptrs = fromIntegral v83-            , pc_SIZEOF_StgArrBytes_NoHdr = fromIntegral v84-            , pc_OFFSET_StgArrBytes_bytes = fromIntegral v85-            , pc_OFFSET_StgTSO_alloc_limit = fromIntegral v86-            , pc_OFFSET_StgTSO_cccs = fromIntegral v87-            , pc_OFFSET_StgTSO_stackobj = fromIntegral v88-            , pc_OFFSET_StgStack_sp = fromIntegral v89-            , pc_OFFSET_StgStack_stack = fromIntegral v90-            , pc_OFFSET_StgUpdateFrame_updatee = fromIntegral v91-            , pc_OFFSET_StgFunInfoExtraFwd_arity = fromIntegral v92-            , pc_REP_StgFunInfoExtraFwd_arity = fromIntegral v93-            , pc_SIZEOF_StgFunInfoExtraRev = fromIntegral v94-            , pc_OFFSET_StgFunInfoExtraRev_arity = fromIntegral v95-            , pc_REP_StgFunInfoExtraRev_arity = fromIntegral v96-            , pc_MAX_SPEC_SELECTEE_SIZE = fromIntegral v97-            , pc_MAX_SPEC_AP_SIZE = fromIntegral v98-            , pc_MIN_PAYLOAD_SIZE = fromIntegral v99-            , pc_MIN_INTLIKE = fromIntegral v100-            , pc_MAX_INTLIKE = fromIntegral v101-            , pc_MIN_CHARLIKE = fromIntegral v102-            , pc_MAX_CHARLIKE = fromIntegral v103-            , pc_MUT_ARR_PTRS_CARD_BITS = fromIntegral v104-            , pc_MAX_Vanilla_REG = fromIntegral v105-            , pc_MAX_Float_REG = fromIntegral v106-            , pc_MAX_Double_REG = fromIntegral v107-            , pc_MAX_Long_REG = fromIntegral v108-            , pc_MAX_XMM_REG = fromIntegral v109-            , pc_MAX_Real_Vanilla_REG = fromIntegral v110-            , pc_MAX_Real_Float_REG = fromIntegral v111-            , pc_MAX_Real_Double_REG = fromIntegral v112-            , pc_MAX_Real_XMM_REG = fromIntegral v113-            , pc_MAX_Real_Long_REG = fromIntegral v114-            , pc_RESERVED_C_STACK_BYTES = fromIntegral v115-            , pc_RESERVED_STACK_WORDS = fromIntegral v116-            , pc_AP_STACK_SPLIM = fromIntegral v117-            , pc_WORD_SIZE = fromIntegral v118-            , pc_CINT_SIZE = fromIntegral v119-            , pc_CLONG_SIZE = fromIntegral v120-            , pc_CLONG_LONG_SIZE = fromIntegral v121-            , pc_BITMAP_BITS_SHIFT = fromIntegral v122-            , pc_TAG_BITS = fromIntegral v123-            , pc_LDV_SHIFT = fromIntegral v124-            , pc_ILDV_CREATE_MASK = v125-            , pc_ILDV_STATE_CREATE = v126-            , pc_ILDV_STATE_USE = v127-            }-    _ -> error "Invalid platform constants"-
GHC/Platform/NoRegs.hs view
@@ -5,5 +5,5 @@ import GHC.Prelude  #define MACHREGS_NO_REGS 1-#include "../../../includes/CodeGen.Platform.hs"+#include "CodeGen.Platform.h"
GHC/Platform/PPC.hs view
@@ -6,5 +6,5 @@  #define MACHREGS_NO_REGS 0 #define MACHREGS_powerpc 1-#include "../../../includes/CodeGen.Platform.hs"+#include "CodeGen.Platform.h"
GHC/Platform/Profile.hs view
@@ -23,6 +23,7 @@    { profilePlatform :: !Platform -- ^ Platform    , profileWays     :: !Ways     -- ^ Ways    }+  deriving (Eq, Ord, Show, Read)  -- | Get platform constants profileConstants :: Profile -> PlatformConstants
GHC/Platform/RISCV64.hs view
@@ -6,5 +6,5 @@  #define MACHREGS_NO_REGS 0 #define MACHREGS_riscv64 1-#include "../../../includes/CodeGen.Platform.hs"+#include "CodeGen.Platform.h"
GHC/Platform/Reg.hs view
@@ -6,7 +6,6 @@ module GHC.Platform.Reg (         RegNo,         Reg(..),-        regPair,         regSingle,         realRegSingle,         isRealReg,      takeRealReg,@@ -34,7 +33,6 @@ import GHC.Types.Unique import GHC.Builtin.Uniques import GHC.Platform.Reg.Class-import Data.List (intersect)  -- | An identifier for a primitive real machine register. type RegNo@@ -144,37 +142,34 @@ --      the usual way.  We know what class they are, because that's part of --      the processor's architecture. -----      RealRegPairs are pairs of real registers that are allocated together---      to hold a larger value, such as with Double regs on SPARC.----data RealReg-        = RealRegSingle {-# UNPACK #-} !RegNo-        | RealRegPair   {-# UNPACK #-} !RegNo {-# UNPACK #-} !RegNo+newtype RealReg+        = RealRegSingle RegNo         deriving (Eq, Show, Ord)  instance Uniquable RealReg where         getUnique reg          = case reg of                 RealRegSingle i         -> mkRegSingleUnique i-                RealRegPair r1 r2       -> mkRegPairUnique (r1 * 65536 + r2)  instance Outputable RealReg where         ppr reg          = case reg of                 RealRegSingle i         -> text "%r"  <> int i-                RealRegPair r1 r2       -> text "%r(" <> int r1-                                           <> vbar <> int r2 <> text ")"  regNosOfRealReg :: RealReg -> [RegNo] regNosOfRealReg rr  = case rr of         RealRegSingle r1        -> [r1]-        RealRegPair   r1 r2     -> [r1, r2]   realRegsAlias :: RealReg -> RealReg -> Bool-realRegsAlias rr1 rr2-        = not $ null $ intersect (regNosOfRealReg rr1) (regNosOfRealReg rr2)+realRegsAlias rr1 rr2 =+    -- used to be `not $ null $ intersect (regNosOfRealReg rr1) (regNosOfRealReg rr2)`+    -- but that resulted in some gnarly, gnarly, allocating code. So we manually+    -- write out all the cases which gives us nice non-allocating code.+    case rr1 of+        RealRegSingle r1 ->+            case rr2 of RealRegSingle r2 -> r1 == r2  -------------------------------------------------------------------------------- -- | A register, either virtual or real@@ -188,9 +183,6 @@  realRegSingle :: RegNo -> RealReg realRegSingle regNo = RealRegSingle regNo--regPair :: RegNo -> RegNo -> Reg-regPair regNo1 regNo2   = RegReal $ RealRegPair regNo1 regNo2   -- We like to have Uniques for Reg so that we can make UniqFM and UniqSets
GHC/Platform/Regs.hs view
@@ -12,7 +12,6 @@ import qualified GHC.Platform.AArch64    as AArch64 import qualified GHC.Platform.PPC        as PPC import qualified GHC.Platform.S390X      as S390X-import qualified GHC.Platform.SPARC      as SPARC import qualified GHC.Platform.X86        as X86 import qualified GHC.Platform.X86_64     as X86_64 import qualified GHC.Platform.RISCV64    as RISCV64@@ -29,7 +28,6 @@    ArchX86     -> X86.callerSaves    ArchX86_64  -> X86_64.callerSaves    ArchS390X   -> S390X.callerSaves-   ArchSPARC   -> SPARC.callerSaves    ArchARM {}  -> ARM.callerSaves    ArchAArch64 -> AArch64.callerSaves    ArchRISCV64 -> RISCV64.callerSaves@@ -52,7 +50,6 @@    ArchX86     -> X86.activeStgRegs    ArchX86_64  -> X86_64.activeStgRegs    ArchS390X   -> S390X.activeStgRegs-   ArchSPARC   -> SPARC.activeStgRegs    ArchARM {}  -> ARM.activeStgRegs    ArchAArch64 -> AArch64.activeStgRegs    ArchRISCV64 -> RISCV64.activeStgRegs@@ -70,7 +67,6 @@    ArchX86     -> X86.haveRegBase    ArchX86_64  -> X86_64.haveRegBase    ArchS390X   -> S390X.haveRegBase-   ArchSPARC   -> SPARC.haveRegBase    ArchARM {}  -> ARM.haveRegBase    ArchAArch64 -> AArch64.haveRegBase    ArchRISCV64 -> RISCV64.haveRegBase@@ -88,7 +84,6 @@    ArchX86     -> X86.globalRegMaybe    ArchX86_64  -> X86_64.globalRegMaybe    ArchS390X   -> S390X.globalRegMaybe-   ArchSPARC   -> SPARC.globalRegMaybe    ArchARM {}  -> ARM.globalRegMaybe    ArchAArch64 -> AArch64.globalRegMaybe    ArchRISCV64 -> RISCV64.globalRegMaybe@@ -106,7 +101,6 @@    ArchX86     -> X86.freeReg    ArchX86_64  -> X86_64.freeReg    ArchS390X   -> S390X.freeReg-   ArchSPARC   -> SPARC.freeReg    ArchARM {}  -> ARM.freeReg    ArchAArch64 -> AArch64.freeReg    ArchRISCV64 -> RISCV64.freeReg
GHC/Platform/S390X.hs view
@@ -6,5 +6,5 @@  #define MACHREGS_NO_REGS 0 #define MACHREGS_s390x 1-#include "../../../includes/CodeGen.Platform.hs"+#include "CodeGen.Platform.h"
− GHC/Platform/SPARC.hs 
@@ -1,10 +0,0 @@-{-# LANGUAGE CPP #-}--module GHC.Platform.SPARC where--import GHC.Prelude--#define MACHREGS_NO_REGS 0-#define MACHREGS_sparc 1-#include "../../../includes/CodeGen.Platform.hs"-
GHC/Platform/Ways.hs view
@@ -24,7 +24,9 @@    ( Way(..)    , Ways    , hasWay+   , hasNotWay    , addWay+   , removeWay    , allowed_combination    , wayGeneralFlags    , wayUnsetGeneralFlags@@ -49,8 +51,6 @@    ) where -#include "HsVersions.h"- import GHC.Prelude import GHC.Platform import GHC.Driver.Flags@@ -68,20 +68,27 @@   | WayThreaded      -- ^ (RTS only) Multithreaded runtime system   | WayDebug         -- ^ Debugging, enable trace messages and extra checks   | WayProf          -- ^ Profiling, enable cost-centre stacks and profiling reports-  | WayTracing       -- ^ (RTS only) enable event logging (tracing)   | WayDyn           -- ^ Dynamic linking-  deriving (Eq, Ord, Show)+  deriving (Eq, Ord, Show, Read)  type Ways = Set Way --- | Test if a ways is enabled+-- | Test if a way is enabled hasWay :: Ways -> Way -> Bool hasWay ws w = Set.member w ws +-- | Test if a way is not enabled+hasNotWay :: Ways -> Way -> Bool+hasNotWay ws w = Set.notMember w ws+ -- | Add a way addWay :: Way -> Ways -> Ways addWay = Set.insert +-- | Remove a way+removeWay :: Way -> Ways -> Ways+removeWay = Set.delete+ -- | Check if a combination of ways is allowed allowed_combination :: Ways -> Bool allowed_combination ways = not disallowed@@ -110,7 +117,6 @@ wayTag WayDebug       = "debug" wayTag WayDyn         = "dyn" wayTag WayProf        = "p"-wayTag WayTracing     = "l" -- "l" for "logging"  -- | Return true for ways that only impact the RTS, not the generated code wayRTSOnly :: Way -> Bool@@ -119,7 +125,6 @@ wayRTSOnly WayProf        = False wayRTSOnly WayThreaded    = True wayRTSOnly WayDebug       = True-wayRTSOnly WayTracing     = True  -- | Filter ways that have an impact on compilation fullWays :: Ways -> Ways@@ -135,7 +140,6 @@ wayDesc WayDebug       = "Debug" wayDesc WayDyn         = "Dynamic" wayDesc WayProf        = "Profiling"-wayDesc WayTracing     = "Tracing"  -- | Turn these flags on when enabling this way wayGeneralFlags :: Platform -> Way -> [GeneralFlag]@@ -151,7 +155,6 @@     -- PIC objects can be linked into a .so, we have to compile even     -- modules of the main program with -fPIC when using -dynamic. wayGeneralFlags _ WayProf     = []-wayGeneralFlags _ WayTracing  = []  -- | Turn these flags off when enabling this way wayUnsetGeneralFlags :: Platform -> Way -> [GeneralFlag]@@ -162,7 +165,6 @@    -- There's no point splitting when we're going to be dynamically linking.    -- Plus it breaks compilation on OSX x86. wayUnsetGeneralFlags _ WayProf     = []-wayUnsetGeneralFlags _ WayTracing  = []  -- | Pass these options to the C compiler when enabling this way wayOptc :: Platform -> Way -> [String]@@ -174,7 +176,6 @@ wayOptc _ WayDebug      = [] wayOptc _ WayDyn        = [] wayOptc _ WayProf       = ["-DPROFILING"]-wayOptc _ WayTracing    = ["-DTRACING"]  -- | Pass these options to linker when enabling this way wayOptl :: Platform -> Way -> [String]@@ -190,7 +191,6 @@ wayOptl _ WayDebug      = [] wayOptl _ WayDyn        = [] wayOptl _ WayProf       = []-wayOptl _ WayTracing    = []  -- | Pass these options to the preprocessor when enabling this way wayOptP :: Platform -> Way -> [String]@@ -199,7 +199,6 @@ wayOptP _ WayDebug    = [] wayOptP _ WayDyn      = [] wayOptP _ WayProf     = ["-DPROFILING"]-wayOptP _ WayTracing  = ["-DTRACING"]   -- | Consult the RTS to find whether it has been built with profiling enabled.@@ -260,7 +259,6 @@    , if hostIsProfiled then Set.singleton WayProf     else Set.empty    , if hostIsThreaded then Set.singleton WayThreaded else Set.empty    , if hostIsDebugged then Set.singleton WayDebug    else Set.empty-   , if hostIsTracing  then Set.singleton WayTracing  else Set.empty    ]  -- | Host "full" ways (i.e. ways that have an impact on the compilation,
GHC/Platform/X86.hs view
@@ -6,5 +6,5 @@  #define MACHREGS_NO_REGS 0 #define MACHREGS_i386 1-#include "../../../includes/CodeGen.Platform.hs"+#include "CodeGen.Platform.h"
GHC/Platform/X86_64.hs view
@@ -6,5 +6,5 @@  #define MACHREGS_NO_REGS 0 #define MACHREGS_x86_64 1-#include "../../../includes/CodeGen.Platform.hs"+#include "CodeGen.Platform.h"
GHC/Plugins.hs view
@@ -15,6 +15,7 @@    , module GHC.Types.Var    , module GHC.Types.Id    , module GHC.Types.Id.Info+   , module GHC.Types.PkgQual    , module GHC.Core.Opt.Monad    , module GHC.Core    , module GHC.Types.Literal@@ -29,6 +30,7 @@    , module GHC.Driver.Ppr    , module GHC.Unit.State    , module GHC.Unit.Module+   , module GHC.Unit.Home    , module GHC.Core.Type    , module GHC.Core.TyCon    , module GHC.Core.Coercion@@ -56,8 +58,12 @@    , module GHC.Unit.Module.ModIface    , module GHC.Types.Meta    , module GHC.Types.SourceError+   , module GHC.Parser.Errors.Types+   , module GHC.Types.Error+   , module GHC.Hs    , -- * Getting 'Name's      thNameToGhcName+   , thNameToGhcNameIO    ) where @@ -66,6 +72,7 @@  -- Variable naming import GHC.Types.TyThing+import GHC.Types.PkgQual import GHC.Types.SourceError import GHC.Types.Name.Reader import GHC.Types.Name.Occurrence  hiding  ( varName {- conflicts with Var.varName -} )@@ -92,6 +99,7 @@ import GHC.Driver.Session import GHC.Unit.State +import GHC.Unit.Home import GHC.Unit.Module import GHC.Unit.Module.ModGuts import GHC.Unit.Module.ModSummary@@ -128,14 +136,20 @@ import GHC.Data.FastString import Data.Maybe -import GHC.Iface.Env    ( lookupOrigIO )+import GHC.Iface.Env    ( lookupNameCache ) import GHC.Prelude import GHC.Utils.Monad  ( mapMaybeM ) import GHC.ThToHs       ( thRdrNameGuesses ) import GHC.Tc.Utils.Env ( lookupGlobal )+import GHC.Types.Name.Cache ( NameCache )  import GHC.Tc.Errors.Hole.FitTypes +-- For parse result plugins+import GHC.Parser.Errors.Types ( PsWarning, PsError )+import GHC.Types.Error         ( Messages )+import GHC.Hs                  ( HsParsedModule )+ import qualified Language.Haskell.TH as TH  {- This instance is defined outside GHC.Core.Opt.Monad so that@@ -159,7 +173,29 @@ -- to names in the module being compiled, if possible. Exact TH names -- will be bound to the name they represent, exactly. thNameToGhcName :: TH.Name -> CoreM (Maybe Name)-thNameToGhcName th_name+thNameToGhcName th_name = do+  hsc_env <- getHscEnv+  liftIO $ thNameToGhcNameIO (hsc_NC hsc_env) th_name++-- | Attempt to convert a Template Haskell name to one that GHC can+-- understand. Original TH names such as those you get when you use+-- the @'foo@ syntax will be translated to their equivalent GHC name+-- exactly. Qualified or unqualified TH names will be dynamically bound+-- to names in the module being compiled, if possible. Exact TH names+-- will be bound to the name they represent, exactly.+--+-- One must be careful to consistently use the same 'NameCache' to+-- create identifier that might be compared. (C.f. how the+-- 'Control.Monad.ST.ST' Monad enforces that variables from separate+-- 'Control.Monad.ST.runST' invocations are never intermingled; it would+-- be valid to use the same tricks for 'Name's and 'NameCache's.)+--+-- For now, the easiest and recommended way to ensure a consistent+-- 'NameCache' is used it to retrieve the preexisting one from an active+-- 'HscEnv'. A single 'HscEnv' is created per GHC "session", and this+-- ensures everything in that sesssion will getthe same name cache.+thNameToGhcNameIO :: NameCache -> TH.Name -> IO (Maybe Name)+thNameToGhcNameIO cache th_name   =  do { names <- mapMaybeM lookup (thRdrNameGuesses th_name)           -- Pick the first that works           -- E.g. reify (mkName "A") will pick the class A in preference@@ -170,6 +206,5 @@       | Just n <- isExact_maybe rdr_name   -- This happens in derived code       = return $ if isExternalName n then Just n else Nothing       | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name-      = do { hsc_env <- getHscEnv-           ; Just <$> liftIO (lookupOrigIO hsc_env rdr_mod rdr_occ) }+      = Just <$> lookupNameCache cache rdr_mod rdr_occ       | otherwise = return Nothing
GHC/Prelude.hs view
@@ -1,4 +1,6 @@ {-# LANGUAGE CPP #-}+{-# OPTIONS_HADDOCK not-home #-}+{-# OPTIONS_GHC -O2 #-} -- See Note [-O2 Prelude]  -- | Custom GHC "Prelude" --@@ -17,6 +19,17 @@   ) where  +{- Note [-O2 Prelude]+~~~~~~~~~~~~~~~~~~~~~+There is some code in GHC that is *always* compiled with -O[2] because+of it's impact on compile time performance. Some of this code might depend+on the definitions like shiftL being defined here being performant.++So we always compile this module with -O2. It's (currently) tiny so I+have little reason to suspect this impacts overall GHC compile times+negatively.++-} -- We export the 'Semigroup' class but w/o the (<>) operator to avoid -- clashing with the (Outputable.<>) operator which is heavily used -- through GHC's code-base.
GHC/Rename/Bind.hs view
@@ -18,7 +18,7 @@  module GHC.Rename.Bind (    -- Renaming top-level bindings-   rnTopBindsLHS, rnTopBindsBoot, rnValBindsRHS,+   rnTopBindsLHS, rnTopBindsLHSBoot, rnTopBindsBoot, rnValBindsRHS,     -- Renaming local bindings    rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS,@@ -35,19 +35,23 @@ import {-# SOURCE #-} GHC.Rename.Expr( rnExpr, rnLExpr, rnStmts )  import GHC.Hs+import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Rename.HsType import GHC.Rename.Pat import GHC.Rename.Names import GHC.Rename.Env import GHC.Rename.Fixity-import GHC.Rename.Utils ( HsDocContext(..), mapFvRn-                        , checkDupRdrNames, checkDupRdrNamesN, warnUnusedLocalBinds+import GHC.Rename.Utils ( mapFvRn+                        , checkDupRdrNames, checkDupRdrNamesN+                        , warnUnusedLocalBinds+                        , warnForallIdentifier                         , checkUnusedRecordWildcard                         , checkDupAndShadowedNames, bindLocalNamesFV                         , addNoNestedForallsContextsErr, checkInferredVars ) import GHC.Driver.Session import GHC.Unit.Module+import GHC.Types.Error import GHC.Types.FieldLabel import GHC.Types.Name import GHC.Types.Name.Env@@ -187,13 +191,24 @@ rnTopBindsLHS fix_env binds   = rnValBindsLHS (topRecNameMaker fix_env) binds +-- Ensure that a hs-boot file has no top-level bindings.+rnTopBindsLHSBoot :: MiniFixityEnv+                  -> HsValBinds GhcPs+                  -> RnM (HsValBindsLR GhcRn GhcPs)+rnTopBindsLHSBoot fix_env binds+  = do  { topBinds <- rnTopBindsLHS fix_env binds+        ; case topBinds of+            ValBinds x mbinds sigs ->+              do  { mapM_ bindInHsBootFileErr mbinds+                  ; pure (ValBinds x emptyBag sigs) }+            _ -> pprPanic "rnTopBindsLHSBoot" (ppr topBinds) }+ rnTopBindsBoot :: NameSet -> HsValBindsLR GhcRn GhcPs                -> RnM (HsValBinds GhcRn, DefUses) -- A hs-boot file has no bindings. -- Return a single HsBindGroup with empty binds and renamed signatures-rnTopBindsBoot bound_names (ValBinds _ mbinds sigs)-  = do  { checkErr (isEmptyLHsBinds mbinds) (bindsInHsBootFile mbinds)-        ; (sigs', fvs) <- renameSigs (HsBootCtxt bound_names) sigs+rnTopBindsBoot bound_names (ValBinds _ _ sigs)+  = do  { (sigs', fvs) <- renameSigs (HsBootCtxt bound_names) sigs         ; return (XValBindsLR (NValBinds [] sigs'), usesOnly fvs) } rnTopBindsBoot _ b = pprPanic "rnTopBindsBoot" (ppr b) @@ -229,9 +244,9 @@     return (IPBinds noExtField ip_binds', plusFVs fvs_s)  rnIPBind :: IPBind GhcPs -> RnM (IPBind GhcRn, FreeVars)-rnIPBind (IPBind _ ~(Left n) expr) = do+rnIPBind (IPBind _ n expr) = do     (expr',fvExpr) <- rnLExpr expr-    return (IPBind noAnn (Left n) expr', fvExpr)+    return (IPBind noExtField n expr', fvExpr)  {- ************************************************************************@@ -431,7 +446,8 @@ rnBindLHS name_maker _ (PatSynBind x psb@PSB{ psb_id = rdrname })   | isTopRecNameMaker name_maker   = do { addLocMA checkConName rdrname-       ; name <- lookupLocatedTopBndrRnN rdrname -- Should be in scope already+       ; name <-+           lookupLocatedTopConstructorRnN rdrname -- Should be in scope already        ; return (PatSynBind x psb{ psb_ext = noAnn, psb_id = name }) }    | otherwise  -- Pattern synonym, not at top level@@ -440,10 +456,8 @@        ; name <- applyNameMaker name_maker rdrname        ; return (PatSynBind x psb{ psb_ext = noAnn, psb_id = name }) }   where-    localPatternSynonymErr :: SDoc-    localPatternSynonymErr-      = hang (text "Illegal pattern synonym declaration for" <+> quotes (ppr rdrname))-           2 (text "Pattern synonym declarations are only valid at top level")+    localPatternSynonymErr :: TcRnMessage+    localPatternSynonymErr = TcRnIllegalPatSynDecl rdrname  rnBindLHS _ _ b = pprPanic "rnBindHS" (ppr b) @@ -489,8 +503,7 @@         -- See Note [Pattern bindings that bind no variables]         ; whenWOptM Opt_WarnUnusedPatternBinds $           when (null bndrs && not ok_nobind_pat) $-          addWarn (Reason Opt_WarnUnusedPatternBinds) $-          unusedPatBindWarn bind'+          addTcRnDiagnostic (TcRnUnusedPatternBinds bind')          ; fvs' `seq` -- See Note [Free-variable space leak]           return (bind', bndrs, all_fvs) }@@ -651,9 +664,10 @@            ; return env}      } -dupFixityDecl :: SrcSpan -> RdrName -> SDoc+dupFixityDecl :: SrcSpan -> RdrName -> TcRnMessage dupFixityDecl loc rdr_name-  = vcat [text "Multiple fixity declarations for" <+> quotes (ppr rdr_name),+  = TcRnUnknownMessage $ mkPlainError noHints $+    vcat [text "Multiple fixity declarations for" <+> quotes (ppr rdr_name),           text "also at " <+> ppr loc]  @@ -694,7 +708,7 @@                       ; return ( (pat', InfixCon name1 name2)                                , mkFVs (map unLoc [name1, name2])) }                RecCon vars ->-                   do { checkDupRdrNames (map (rdrNameFieldOcc . recordPatSynField) vars)+                   do { checkDupRdrNames (map (foLabel . recordPatSynField) vars)                       ; fls <- lookupConstructorFields name                       ; let fld_env = mkFsEnv [ (flLabel fl, fl) | fl <- fls ]                       ; let rnRecordPatSynField@@ -730,7 +744,7 @@                           , psb_ext = fvs' }               selector_names = case details' of                                  RecCon names ->-                                  map (extFieldOcc . recordPatSynField) names+                                  map (foExt . recordPatSynField) names                                  _ -> []          ; fvs' `seq` -- See Note [Free-variable space leak]@@ -741,9 +755,10 @@     -- See Note [Renaming pattern synonym variables]     lookupPatSynBndr = wrapLocMA lookupLocalOccRn -    patternSynonymErr :: SDoc+    patternSynonymErr :: TcRnMessage     patternSynonymErr-      = hang (text "Illegal pattern synonym declaration")+      = TcRnUnknownMessage $ mkPlainError noHints $+        hang (text "Illegal pattern synonym declaration")            2 (text "Use -XPatternSynonyms to enable this extension")  {-@@ -860,15 +875,17 @@         -- Rename the pragmas and signatures        -- Annoyingly the type variables /are/ in scope for signatures, but-       -- /are not/ in scope in SPECIALISE and SPECIALISE instance pragmas.-       -- See Note [Type variable scoping in SPECIALISE pragmas].-       ; let (spec_prags, other_sigs) = partition (isSpecLSig <||> isSpecInstLSig) sigs+       -- /are not/ in scope in the SPECIALISE instance pramas; e.g.+       --    instance Eq a => Eq (T a) where+       --       (==) :: a -> a -> a+       --       {-# SPECIALISE instance Eq a => Eq (T [a]) #-}+       ; let (spec_inst_prags, other_sigs) = partition isSpecInstLSig sigs              bound_nms = mkNameSet (collectHsBindsBinders CollNoDictBinders binds')              sig_ctxt | is_cls_decl = ClsDeclCtxt cls                       | otherwise   = InstDeclCtxt bound_nms-       ; (spec_prags', spg_fvs) <- renameSigs sig_ctxt spec_prags-       ; (other_sigs', sig_fvs) <- bindLocalNamesFV ktv_names $-                                      renameSigs sig_ctxt other_sigs+       ; (spec_inst_prags', sip_fvs) <- renameSigs sig_ctxt spec_inst_prags+       ; (other_sigs',      sig_fvs) <- bindLocalNamesFV ktv_names $+                                        renameSigs sig_ctxt other_sigs         -- Rename the bindings RHSs.  Again there's an issue about whether the        -- type variables from the class/instance head are in scope.@@ -879,47 +896,8 @@                                            emptyFVs binds_w_dus                  ; return (mapBag fstOf3 binds_w_dus, bind_fvs) } -       ; return ( binds'', spec_prags' ++ other_sigs'-                , sig_fvs `plusFV` spg_fvs `plusFV` bind_fvs) }--{- Note [Type variable scoping in SPECIALISE pragmas]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When renaming the methods of a class or instance declaration, we must be careful-with the scoping of the type variables that occur in SPECIALISE and SPECIALISE instance-pragmas: the type variables from the class/instance header DO NOT scope over these,-unlike class/instance method type signatures.--Examples:--  1. SPECIALISE--    class C a where-      meth :: a-    instance C (Maybe a) where-      meth = Nothing-      {-# SPECIALISE INLINE meth :: Maybe [a] #-}--  2. SPECIALISE instance--    instance Eq a => Eq (T a) where-       (==) :: a -> a -> a-       {-# SPECIALISE instance Eq a => Eq (T [a]) #-}--  In both cases, the type variable `a` mentioned in the PRAGMA is NOT the same-  as the type variable `a` from the instance header.-  For example, the SPECIALISE instance pragma above is a shorthand for--      {-# SPECIALISE instance forall a. Eq a => Eq (T [a]) #-}--  which is alpha-equivalent to--      {-# SPECIALISE instance forall b. Eq b => Eq (T [b]) #-}--  This shows that the type variables are not bound in the header.--  Getting this scoping wrong can lead to out-of-scope type variable errors from-  Core Lint, see e.g. #22913.--}+       ; return ( binds'', spec_inst_prags' ++ other_sigs'+                , sig_fvs `plusFV` sip_fvs `plusFV` bind_fvs) }  rnMethodBindLHS :: Bool -> Name                 -> LHsBindLR GhcPs GhcPs@@ -935,7 +913,7 @@ -- Report error for all other forms of bindings -- This is why we use a fold rather than map rnMethodBindLHS is_cls_decl _ (L loc bind) rest-  = do { addErrAt (locA loc) $+  = do { addErrAt (locA loc) $ TcRnUnknownMessage $ mkPlainError noHints $          vcat [ what <+> text "not allowed in" <+> decl_sort               , nest 2 (ppr bind) ]        ; return rest }@@ -1005,6 +983,7 @@   = do  { defaultSigs_on <- xoptM LangExt.DefaultSignatures         ; when (is_deflt && not defaultSigs_on) $           addErr (defaultSigErr sig)+        ; mapM_ warnForallIdentifier vs         ; new_v <- mapM (lookupSigOccRnN ctxt sig) vs         ; (new_ty, fvs) <- rnHsSigType ty_ctxt TypeLevel ty         ; return (ClassOpSig noAnn is_deflt new_v new_ty, fvs) }@@ -1081,8 +1060,8 @@         return (CompleteMatchSig noAnn s (L l new_bf) new_mty, emptyFVs)   where-    orphanError :: SDoc-    orphanError =+    orphanError :: TcRnMessage+    orphanError = TcRnUnknownMessage $ mkPlainError noHints $       text "Orphan COMPLETE pragmas not supported" $$       text "A COMPLETE pragma must mention at least one data constructor" $$       text "or pattern synonym defined in the same module."@@ -1205,20 +1184,48 @@     , Anno [LocatedA (Match GhcPs (LocatedA (body GhcPs)))] ~ SrcSpanAnnL     , Anno (Match GhcRn (LocatedA (body GhcRn))) ~ SrcSpanAnnA     , Anno (Match GhcPs (LocatedA (body GhcPs))) ~ SrcSpanAnnA-    , Anno (GRHS GhcRn (LocatedA (body GhcRn))) ~ SrcSpan-    , Anno (GRHS GhcPs (LocatedA (body GhcPs))) ~ SrcSpan+    , Anno (GRHS GhcRn (LocatedA (body GhcRn))) ~ SrcAnn NoEpAnns+    , Anno (GRHS GhcPs (LocatedA (body GhcPs))) ~ SrcAnn NoEpAnns     , Outputable (body GhcPs)     ) +-- Note [Empty MatchGroups]+-- ~~~~~~~~~~~~~~~~~~~~~~~~+-- In some cases, MatchGroups are allowed to be empty. Firstly, the+-- prerequisite is that -XEmptyCase is enabled. Then you have an empty+-- MatchGroup resulting either from a case-expression:+--+--     case e of {}+--+-- or from a \case-expression:+--+--     \case {}+--+-- NB: \cases {} is not allowed, since it's not clear how many patterns this+-- should match on.+--+-- The same applies in arrow notation commands: With -XEmptyCases, it is+-- allowed in case- and \case-commands, but not \cases.+--+-- Since the lambda expressions and empty function definitions are already+-- disallowed elsewhere, here, we only need to make sure we don't accept empty+-- \cases expressions or commands. In that case, or if we encounter an empty+-- MatchGroup but -XEmptyCases is disabled, we add an error.+ rnMatchGroup :: (Outputable (body GhcPs), AnnoBody body) => HsMatchContext GhcRn              -> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars))              -> MatchGroup GhcPs (LocatedA (body GhcPs))              -> RnM (MatchGroup GhcRn (LocatedA (body GhcRn)), FreeVars) rnMatchGroup ctxt rnBody (MG { mg_alts = L lm ms, mg_origin = origin })-  = do { empty_case_ok <- xoptM LangExt.EmptyCase-       ; when (null ms && not empty_case_ok) (addErr (emptyCaseErr ctxt))+         -- see Note [Empty MatchGroups]+  = do { whenM ((null ms &&) <$> mustn't_be_empty) (addErr (emptyCaseErr ctxt))        ; (new_ms, ms_fvs) <- mapFvRn (rnMatch ctxt rnBody) ms        ; return (mkMatchGroup origin (L lm new_ms), ms_fvs) }+  where+    mustn't_be_empty = case ctxt of+      LamCaseAlt LamCases -> return True+      ArrowMatchCtxt (ArrowLamCaseAlt LamCases) -> return True+      _ -> not <$> xoptM LangExt.EmptyCase  rnMatch :: AnnoBody body         => HsMatchContext GhcRn@@ -1242,18 +1249,30 @@         ; return (Match { m_ext = noAnn, m_ctxt = mf', m_pats = pats'                         , m_grhss = grhss'}, grhss_fvs ) } -emptyCaseErr :: HsMatchContext GhcRn -> SDoc-emptyCaseErr ctxt = hang (text "Empty list of alternatives in" <+> pp_ctxt ctxt)-                       2 (text "Use EmptyCase to allow this")+emptyCaseErr :: HsMatchContext GhcRn -> TcRnMessage+emptyCaseErr ctxt = TcRnUnknownMessage $ mkPlainError noHints $ message ctxt   where     pp_ctxt :: HsMatchContext GhcRn -> SDoc     pp_ctxt c = case c of-      CaseAlt       -> text "case expression"-      LambdaExpr    -> text "\\case expression"-      ArrowMatchCtxt ArrowCaseAlt -> text "case expression"-      ArrowMatchCtxt KappaExpr    -> text "kappa abstraction"-      _             -> text "(unexpected)" <+> pprMatchContextNoun c+      CaseAlt                                  -> text "case expression"+      LamCaseAlt LamCase                       -> text "\\case expression"+      ArrowMatchCtxt (ArrowLamCaseAlt LamCase) -> text "\\case command"+      ArrowMatchCtxt ArrowCaseAlt              -> text "case command"+      ArrowMatchCtxt KappaExpr                 -> text "kappa abstraction"+      _                                        -> text "(unexpected)"+                                                  <+> pprMatchContextNoun c +    message :: HsMatchContext GhcRn -> SDoc+    message (LamCaseAlt LamCases) = lcases_msg <+> text "expression"+    message (ArrowMatchCtxt (ArrowLamCaseAlt LamCases)) =+      lcases_msg <+> text "command"+    message ctxt =+      hang (text "Empty list of alternatives in" <+> pp_ctxt ctxt)+           2 (text "Use EmptyCase to allow this")++    lcases_msg =+      text "Empty list of alternatives is not allowed in \\cases"+ {- ************************************************************************ *                                                                      *@@ -1277,7 +1296,7 @@        -> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars))        -> LGRHS GhcPs (LocatedA (body GhcPs))        -> RnM (LGRHS GhcRn (LocatedA (body GhcRn)), FreeVars)-rnGRHS ctxt rnBody = wrapLocFstM (rnGRHS' ctxt rnBody)+rnGRHS ctxt rnBody = wrapLocFstMA (rnGRHS' ctxt rnBody)  rnGRHS' :: HsMatchContext GhcRn         -> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars))@@ -1288,8 +1307,10 @@         ; ((guards', rhs'), fvs) <- rnStmts (PatGuard ctxt) rnExpr guards $ \ _ ->                                     rnBody rhs -        ; unless (pattern_guards_allowed || is_standard_guard guards')-                 (addWarn NoReason (nonStdGuardErr guards'))+        ; unless (pattern_guards_allowed || is_standard_guard guards') $+            let diag = TcRnUnknownMessage $+                  mkPlainDiagnostic WarningWithoutFlag noHints (nonStdGuardErr guards')+            in addDiagnostic diag          ; return (GRHS noAnn guards' rhs', fvs) }   where@@ -1342,7 +1363,7 @@  dupSigDeclErr :: NonEmpty (LocatedN RdrName, Sig GhcPs) -> RnM () dupSigDeclErr pairs@((L loc name, sig) :| _)-  = addErrAt (locA loc) $+  = addErrAt (locA loc) $ TcRnUnknownMessage $ mkPlainError noHints $     vcat [ text "Duplicate" <+> what_it_is            <> text "s for" <+> quotes (ppr name)          , text "at" <+> vcat (map ppr $ sortBy SrcLoc.leftmost_smallest@@ -1354,18 +1375,19 @@  misplacedSigErr :: LSig GhcRn -> RnM () misplacedSigErr (L loc sig)-  = addErrAt (locA loc) $+  = addErrAt (locA loc) $ TcRnUnknownMessage $ mkPlainError noHints $     sep [text "Misplaced" <+> hsSigDoc sig <> colon, ppr sig] -defaultSigErr :: Sig GhcPs -> SDoc-defaultSigErr sig = vcat [ hang (text "Unexpected default signature:")-                              2 (ppr sig)-                         , text "Use DefaultSignatures to enable default signatures" ]+defaultSigErr :: Sig GhcPs -> TcRnMessage+defaultSigErr sig = TcRnUnknownMessage $ mkPlainError noHints $+  vcat [ hang (text "Unexpected default signature:")+         2 (ppr sig)+       , text "Use DefaultSignatures to enable default signatures" ] -bindsInHsBootFile :: LHsBindsLR GhcRn GhcPs -> SDoc-bindsInHsBootFile mbinds-  = hang (text "Bindings in hs-boot files are not allowed")-       2 (ppr mbinds)+bindInHsBootFileErr :: LHsBindLR GhcRn GhcPs -> RnM ()+bindInHsBootFileErr (L loc _)+  = addErrAt (locA loc) $ TcRnUnknownMessage $ mkPlainError noHints $+      vcat [ text "Bindings in hs-boot files are not allowed" ]  nonStdGuardErr :: (Outputable body,                    Anno (Stmt GhcRn body) ~ SrcSpanAnnA)@@ -1374,14 +1396,9 @@   = hang (text "accepting non-standard pattern guards (use PatternGuards to suppress this message)")        4 (interpp'SP guards) -unusedPatBindWarn :: HsBind GhcRn -> SDoc-unusedPatBindWarn bind-  = hang (text "This pattern-binding binds no variables:")-       2 (ppr bind)- dupMinimalSigErr :: [LSig GhcPs] -> RnM () dupMinimalSigErr sigs@(L loc _ : _)-  = addErrAt (locA loc) $+  = addErrAt (locA loc) $ TcRnUnknownMessage $ mkPlainError noHints $     vcat [ text "Multiple minimal complete definitions"          , text "at" <+> vcat (map ppr $ sortBy SrcLoc.leftmost_smallest $ map getLocA sigs)          , text "Combine alternative minimal complete definitions with `|'" ]
+ GHC/Rename/Doc.hs view
@@ -0,0 +1,46 @@+module GHC.Rename.Doc ( rnHsDoc, rnLHsDoc, rnLDocDecl, rnDocDecl ) where++import GHC.Prelude++import GHC.Tc.Types+import GHC.Hs+import GHC.Types.Name.Reader+import GHC.Types.Name+import GHC.Types.SrcLoc+import GHC.Tc.Utils.Monad (getGblEnv)+import GHC.Types.Avail+import GHC.Rename.Env++rnLHsDoc :: LHsDoc GhcPs -> RnM (LHsDoc GhcRn)+rnLHsDoc = traverse rnHsDoc++rnLDocDecl :: LDocDecl GhcPs -> RnM (LDocDecl GhcRn)+rnLDocDecl = traverse rnDocDecl++rnDocDecl :: DocDecl GhcPs -> RnM (DocDecl GhcRn)+rnDocDecl (DocCommentNext doc) = do+  doc' <- rnLHsDoc doc+  pure $ (DocCommentNext doc')+rnDocDecl (DocCommentPrev doc) = do+  doc' <- rnLHsDoc doc+  pure $ (DocCommentPrev doc')+rnDocDecl (DocCommentNamed n doc) = do+  doc' <- rnLHsDoc doc+  pure $ (DocCommentNamed n doc')+rnDocDecl (DocGroup i doc) = do+  doc' <- rnLHsDoc doc+  pure $ (DocGroup i doc')++rnHsDoc :: WithHsDocIdentifiers a GhcPs -> RnM (WithHsDocIdentifiers a GhcRn)+rnHsDoc (WithHsDocIdentifiers s ids) = do+  gre <- tcg_rdr_env <$> getGblEnv+  pure (WithHsDocIdentifiers s (rnHsDocIdentifiers gre ids))++rnHsDocIdentifiers :: GlobalRdrEnv+                  -> [Located RdrName]+                  -> [Located Name]+rnHsDocIdentifiers gre ns = concat+  [ map (L l . greNamePrintableName . gre_name) (lookupGRE_RdrName c gre)+  | L l rdr_name <- ns+  , c <- dataTcOccs rdr_name+  ]
GHC/Rename/Env.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE TypeApplications #-} @@ -13,8 +13,11 @@         newTopSrcBinder,          lookupLocatedTopBndrRn, lookupLocatedTopBndrRnN, lookupTopBndrRn,+        lookupLocatedTopConstructorRn, lookupLocatedTopConstructorRnN, -        lookupLocatedOccRn, lookupOccRn, lookupOccRn_maybe,+        lookupLocatedOccRn, lookupLocatedOccRnConstr, lookupLocatedOccRnRecField,+        lookupLocatedOccRnNone,+        lookupOccRn, lookupOccRn_maybe,         lookupLocalOccRn_maybe, lookupInfoOccRn,         lookupLocalOccThLvl_maybe, lookupLocalOccRn,         lookupTypeOccRn,@@ -55,14 +58,13 @@      ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Iface.Load   ( loadInterfaceForName, loadSrcInterface_maybe ) import GHC.Iface.Env import GHC.Hs import GHC.Types.Name.Reader+import GHC.Tc.Errors.Types import GHC.Tc.Utils.Env import GHC.Tc.Utils.Monad import GHC.Parser.PostProcess ( setRdrNameSpace )@@ -71,6 +73,8 @@ import GHC.Types.Name.Set import GHC.Types.Name.Env import GHC.Types.Avail+import GHC.Types.Hint+import GHC.Types.Error import GHC.Unit.Module import GHC.Unit.Module.ModIface import GHC.Unit.Module.Warnings  ( WarningTxt, pprWarningTxtForMsg )@@ -94,11 +98,12 @@ import GHC.Rename.Utils import qualified Data.Semigroup as Semi import Data.Either      ( partitionEithers )-import Data.List        ( find, sortBy )+import Data.List        ( find ) import qualified Data.List.NonEmpty as NE import Control.Arrow    ( first )-import Data.Function import GHC.Types.FieldLabel+import GHC.Data.Bag+import GHC.Types.PkgQual  {- *********************************************************@@ -252,7 +257,7 @@  -- Can be made to not be exposed -- Only used unwrapped in rnAnnProvenance-lookupTopBndrRn :: RdrName -> RnM Name+lookupTopBndrRn :: WhatLooking -> RdrName -> RnM Name -- Look up a top-level source-code binder.   We may be looking up an unqualified 'f', -- and there may be several imported 'f's too, which must not confuse us. -- For example, this is OK:@@ -263,7 +268,7 @@ -- -- A separate function (importsFromLocalDecls) reports duplicate top level -- decls, so here it's safe just to choose an arbitrary one.-lookupTopBndrRn rdr_name =+lookupTopBndrRn which_suggest rdr_name =   lookupExactOrOrig rdr_name id $     do  {  -- Check for operators in type or class declarations            -- See Note [Type and class operator definitions]@@ -277,19 +282,25 @@             [gre] -> return (greMangledName gre)             _     -> do -- Ambiguous (can't happen) or unbound                         traceRn "lookupTopBndrRN fail" (ppr rdr_name)-                        unboundName WL_LocalTop rdr_name+                        unboundName (LF which_suggest WL_LocalTop) rdr_name     } +lookupLocatedTopConstructorRn :: Located RdrName -> RnM (Located Name)+lookupLocatedTopConstructorRn = wrapLocM (lookupTopBndrRn WL_Constructor)++lookupLocatedTopConstructorRnN :: LocatedN RdrName -> RnM (LocatedN Name)+lookupLocatedTopConstructorRnN = wrapLocMA (lookupTopBndrRn WL_Constructor)+ lookupLocatedTopBndrRn :: Located RdrName -> RnM (Located Name)-lookupLocatedTopBndrRn = wrapLocM lookupTopBndrRn+lookupLocatedTopBndrRn = wrapLocM (lookupTopBndrRn WL_Anything)  lookupLocatedTopBndrRnN :: LocatedN RdrName -> RnM (LocatedN Name)-lookupLocatedTopBndrRnN = wrapLocMA lookupTopBndrRn+lookupLocatedTopBndrRnN = wrapLocMA (lookupTopBndrRn WL_Anything)  -- | Lookup an @Exact@ @RdrName@. See Note [Looking up Exact RdrNames]. -- This never adds an error, but it may return one, see -- Note [Errors in lookup functions]-lookupExactOcc_either :: Name -> RnM (Either SDoc Name)+lookupExactOcc_either :: Name -> RnM (Either NotInScopeError Name) lookupExactOcc_either name   | Just thing <- wiredInNameTyThing_maybe name   , Just tycon <- case thing of@@ -330,28 +341,12 @@                             ; th_topnames <- readTcRef th_topnames_var                             ; if name `elemNameSet` th_topnames                               then return (Right name)-                              else return (Left (exactNameErr name))+                              else return (Left (NoExactName name))                             }                        }-           gres -> return (Left (sameNameErr gres))   -- Ugh!  See Note [Template Haskell ambiguity]-       } -sameNameErr :: [GlobalRdrElt] -> SDoc-sameNameErr [] = panic "addSameNameErr: empty list"-sameNameErr gres@(_ : _)-  = hang (text "Same exact name in multiple name-spaces:")-       2 (vcat (map pp_one sorted_names) $$ th_hint)-  where-    sorted_names = sortBy (SrcLoc.leftmost_smallest `on` nameSrcSpan) (map greMangledName gres)-    pp_one name-      = hang (pprNameSpace (occNameSpace (getOccName name))-              <+> quotes (ppr name) <> comma)-           2 (text "declared at:" <+> ppr (nameSrcLoc name))--    th_hint = vcat [ text "Probable cause: you bound a unique Template Haskell name (NameU),"-                   , text "perhaps via newName, in different name-spaces."-                   , text "If that's it, then -ddump-splices might be useful" ]-+           gres -> return (Left (SameName gres)) -- Ugh!  See Note [Template Haskell ambiguity]+       }  ----------------------------------------------- lookupInstDeclBndr :: Name -> SDoc -> RdrName -> RnM Name@@ -382,7 +377,8 @@                                 -- when it's used                           cls doc rdr        ; case mb_name of-           Left err -> do { addErr err; return (mkUnboundNameRdr rdr) }+           Left err -> do { addErr (mkTcRnNotInScope rdr err)+                          ; return (mkUnboundNameRdr rdr) }            Right nm -> return nm }   where     doc = what <+> text "of class" <+> quotes (ppr cls)@@ -395,7 +391,7 @@ lookupFamInstName (Just cls) tc_rdr  -- Associated type; c.f GHC.Rename.Bind.rnMethodBind   = wrapLocMA (lookupInstDeclBndr cls (text "associated type")) tc_rdr lookupFamInstName Nothing tc_rdr     -- Family instance; tc_rdr is an *occurrence*-  = lookupLocatedOccRn tc_rdr+  = lookupLocatedOccRnConstr tc_rdr  ----------------------------------------------- lookupConstructorFields :: Name -> RnM [FieldLabel]@@ -429,7 +425,7 @@        ; case men of           FoundExactOrOrig n -> return (res n)           ExactOrOrigError e ->-            do { addErr e+            do { addErr (mkTcRnNotInScope rdr_name e)                ; return (res (mkUnboundNameRdr rdr_name)) }           NotExactOrOrig     -> k } @@ -445,9 +441,9 @@            NotExactOrOrig     -> k }  data ExactOrOrigResult = FoundExactOrOrig Name -- ^ Found an Exact Or Orig Name-                       | ExactOrOrigError SDoc -- ^ The RdrName was an Exact-                                                 -- or Orig, but there was an-                                                 -- error looking up the Name+                       | ExactOrOrigError NotInScopeError -- ^ The RdrName was an Exact+                                                          -- or Orig, but there was an+                                                          -- error looking up the Name                        | NotExactOrOrig -- ^ The RdrName is neither an Exact nor                                         -- Orig @@ -499,7 +495,8 @@   , isUnboundName con  -- Avoid error cascade   = return (mkUnboundNameRdr rdr_name)   | Just con <- mb_con-  = do { flds <- lookupConstructorFields con+  = lookupExactOrOrig rdr_name id $  -- See Note [Record field names and Template Haskell]+    do { flds <- lookupConstructorFields con        ; env <- getGlobalRdrEnv        ; let lbl      = occNameFS (rdrNameOcc rdr_name)              mb_field = do fl <- find ((== lbl) . flLabel) flds@@ -515,12 +512,13 @@        ; case mb_field of            Just (fl, gre) -> do { addUsedGRE True gre                                 ; return (flSelector fl) }-           Nothing        -> lookupGlobalOccRn' WantBoth rdr_name }-             -- See Note [Fall back on lookupGlobalOccRn in lookupRecFieldOcc]-  | otherwise-  -- This use of Global is right as we are looking up a selector which-  -- can only be defined at the top level.+           Nothing        -> do { addErr (badFieldConErr con lbl)+                                ; return (mkUnboundNameRdr rdr_name) } }++  | otherwise  -- Can't use the data constructor to disambiguate   = lookupGlobalOccRn' WantBoth rdr_name+    -- This use of Global is right as we are looking up a selector,+    -- which can only be defined at the top level.  -- | Look up an occurrence of a field in a record update, returning the selector -- name.@@ -552,7 +550,8 @@                                   Nothing -> unbound           | otherwise   -> unbound   where-    unbound = UnambiguousGre . NormalGreName <$> unboundName WL_Global rdr_name+    unbound = UnambiguousGre . NormalGreName+          <$> unboundName (LF WL_RecField WL_Global) rdr_name   {- Note [DisambiguateRecordFields]@@ -635,25 +634,8 @@ qualifier to be omitted, because we do not have a data constructor from which to determine it. --Note [Fall back on lookupGlobalOccRn in lookupRecFieldOcc]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Whenever we fail to find the field or it is not in scope, mb_field-will be False, and we fall back on looking it up normally using-lookupGlobalOccRn.  We don't report an error immediately because the-actual problem might be located elsewhere.  For example (#9975):--   data Test = Test { x :: Int }-   pattern Test wat = Test { x = wat }--Here there are multiple declarations of Test (as a data constructor-and as a pattern synonym), which will be reported as an error.  We-shouldn't also report an error about the occurrence of `x` in the-pattern synonym RHS.  However, if the pattern synonym gets added to-the environment first, we will try and fail to find `x` amongst the-(nonexistent) fields of the pattern synonym.--Alternatively, the scope check can fail due to Template Haskell.+Note [Record field names and Template Haskell]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider (#12130):     module Foo where@@ -672,7 +654,6 @@ -}  - -- | Used in export lists to lookup the children. lookupSubBndrOcc_helper :: Bool -> Bool -> Name -> RdrName                         -> RnM ChildLookupResult@@ -835,21 +816,21 @@                  -> Name     -- Parent                  -> SDoc                  -> RdrName-                 -> RnM (Either SDoc Name)+                 -> RnM (Either NotInScopeError Name) -- Find all the things the rdr-name maps to--- and pick the one with the right parent namep+-- and pick the one with the right parent name lookupSubBndrOcc warn_if_deprec the_parent doc rdr_name = do   res <-     lookupExactOrOrig rdr_name (FoundChild NoParent . NormalGreName) $       -- This happens for built-in classes, see mod052 for example       lookupSubBndrOcc_helper True warn_if_deprec the_parent rdr_name   case res of-    NameNotFound -> return (Left (unknownSubordinateErr doc rdr_name))+    NameNotFound -> return (Left (UnknownSubordinate doc))     FoundChild _p child -> return (Right (greNameMangledName child))     IncorrectParent {}          -- See [Mismatched class methods and associated type families]          -- in TcInstDecls.-      -> return $ Left (unknownSubordinateErr doc rdr_name)+      -> return $ Left (UnknownSubordinate doc)  {- Note [Family instance binders]@@ -993,6 +974,18 @@                    -> TcRn (GenLocated (SrcSpanAnn' ann) Name) lookupLocatedOccRn = wrapLocMA lookupOccRn +lookupLocatedOccRnConstr :: GenLocated (SrcSpanAnn' ann) RdrName+                         -> TcRn (GenLocated (SrcSpanAnn' ann) Name)+lookupLocatedOccRnConstr = wrapLocMA lookupOccRnConstr++lookupLocatedOccRnRecField :: GenLocated (SrcSpanAnn' ann) RdrName+                           -> TcRn (GenLocated (SrcSpanAnn' ann) Name)+lookupLocatedOccRnRecField = wrapLocMA lookupOccRnRecField++lookupLocatedOccRnNone :: GenLocated (SrcSpanAnn' ann) RdrName+                       -> TcRn (GenLocated (SrcSpanAnn' ann) Name)+lookupLocatedOccRnNone = wrapLocMA lookupOccRnNone+ lookupLocalOccRn_maybe :: RdrName -> RnM (Maybe Name) -- Just look in the local environment lookupLocalOccRn_maybe rdr_name@@ -1005,14 +998,35 @@   = do { lcl_env <- getLclEnv        ; return (lookupNameEnv (tcl_th_bndrs lcl_env) name) } --- lookupOccRn looks up an occurrence of a RdrName-lookupOccRn :: RdrName -> RnM Name-lookupOccRn rdr_name+-- lookupOccRn' looks up an occurrence of a RdrName, and uses its argument to+-- determine what kind of suggestions should be displayed if it is not in scope+lookupOccRn' :: WhatLooking -> RdrName -> RnM Name+lookupOccRn' which_suggest rdr_name   = do { mb_name <- lookupOccRn_maybe rdr_name        ; case mb_name of            Just name -> return name-           Nothing   -> reportUnboundName rdr_name }+           Nothing   -> reportUnboundName' which_suggest rdr_name } +-- lookupOccRn looks up an occurrence of a RdrName and displays suggestions if+-- it is not in scope+lookupOccRn :: RdrName -> RnM Name+lookupOccRn = lookupOccRn' WL_Anything++-- lookupOccRnConstr looks up an occurrence of a RdrName and displays+-- constructors and pattern synonyms as suggestions if it is not in scope+lookupOccRnConstr :: RdrName -> RnM Name+lookupOccRnConstr = lookupOccRn' WL_Constructor++-- lookupOccRnRecField looks up an occurrence of a RdrName and displays+-- record fields as suggestions if it is not in scope+lookupOccRnRecField :: RdrName -> RnM Name+lookupOccRnRecField = lookupOccRn' WL_RecField++-- lookupOccRnRecField looks up an occurrence of a RdrName and displays+-- no suggestions if it is not in scope+lookupOccRnNone :: RdrName -> RnM Name+lookupOccRnNone = lookupOccRn' WL_None+ -- Only used in one place, to rename pattern synonym binders. -- See Note [Renaming pattern synonym variables] in GHC.Rename.Bind lookupLocalOccRn :: RdrName -> RnM Name@@ -1020,7 +1034,7 @@   = do { mb_name <- lookupLocalOccRn_maybe rdr_name        ; case mb_name of            Just name -> return name-           Nothing   -> unboundName WL_LocalOnly rdr_name }+           Nothing   -> unboundName (LF WL_Anything WL_LocalOnly) rdr_name }  -- lookupTypeOccRn looks up an optionally promoted RdrName. -- Used for looking up type variables.@@ -1033,47 +1047,56 @@   = do { mb_name <- lookupOccRn_maybe rdr_name        ; case mb_name of              Just name -> return name-             Nothing   -> lookup_demoted rdr_name }+             Nothing   ->+               if occName rdr_name == occName eqTyCon_RDR -- See Note [eqTyCon (~) compatibility fallback]+               then eqTyConName <$ addDiagnostic TcRnTypeEqualityOutOfScope+               else lookup_demoted rdr_name } +{- Note [eqTyCon (~) compatibility fallback]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Before GHC Proposal #371, the (~) type operator used in type equality+constraints (a~b) was considered built-in syntax.++This had two implications:++1. Users could use it without importing it from Data.Type.Equality or Prelude.+2. TypeOperators were not required to use it (it was guarded behind TypeFamilies/GADTs instead)++To ease migration and minimize breakage, we continue to support those usages+but emit appropriate warnings.+-}+ lookup_demoted :: RdrName -> RnM Name lookup_demoted rdr_name   | Just demoted_rdr <- demoteRdrName rdr_name     -- Maybe it's the name of a *data* constructor   = do { data_kinds <- xoptM LangExt.DataKinds        ; star_is_type <- xoptM LangExt.StarIsType-       ; let star_info = starInfo star_is_type rdr_name+       ; let is_star_type = if star_is_type then StarIsType else StarIsNotType+             star_is_type_hints = noStarIsTypeHints is_star_type rdr_name        ; if data_kinds             then do { mb_demoted_name <- lookupOccRn_maybe demoted_rdr                     ; case mb_demoted_name of-                        Nothing -> unboundNameX WL_Any rdr_name star_info-                        Just demoted_name ->-                          do { whenWOptM Opt_WarnUntickedPromotedConstructors $-                               addWarn-                                 (Reason Opt_WarnUntickedPromotedConstructors)-                                 (untickedPromConstrWarn demoted_name)-                             ; return demoted_name } }+                        Nothing -> unboundNameX looking_for rdr_name star_is_type_hints+                        Just demoted_name -> return demoted_name }             else do { -- We need to check if a data constructor of this name is                       -- in scope to give good error messages. However, we do                       -- not want to give an additional error if the data                       -- constructor happens to be out of scope! See #13947.                       mb_demoted_name <- discardErrs $                                          lookupOccRn_maybe demoted_rdr-                    ; let suggestion | isJust mb_demoted_name = suggest_dk-                                     | otherwise = star_info-                    ; unboundNameX WL_Any rdr_name suggestion } }+                    ; let suggestion | isJust mb_demoted_name+                                     , let additional = text "to refer to the data constructor of that name?"+                                     = [SuggestExtension $ SuggestSingleExtension additional LangExt.DataKinds]+                                     | otherwise+                                     = star_is_type_hints+                    ; unboundNameX looking_for rdr_name suggestion } }    | otherwise-  = reportUnboundName rdr_name+  = reportUnboundName' (lf_which looking_for) rdr_name    where-    suggest_dk = text "A data constructor of that name is in scope; did you mean DataKinds?"-    untickedPromConstrWarn name =-      text "Unticked promoted constructor" <> colon <+> quotes (ppr name) <> dot-      $$-      hsep [ text "Use"-           , quotes (char '\'' <> ppr name)-           , text "instead of"-           , quotes (ppr name) <> dot ]+    looking_for = LF WL_Constructor WL_Anywhere  -- If the given RdrName can be promoted to the type level and its promoted variant is in scope, -- lookup_promoted returns the corresponding type-level Name.@@ -1088,8 +1111,9 @@  badVarInType :: RdrName -> RnM Name badVarInType rdr_name-  = do { addErr (text "Illegal promoted term variable in a type:"-                 <+> ppr rdr_name)+  = do { addErr (TcRnUnknownMessage $ mkPlainError noHints+           (text "Illegal promoted term variable in a type:"+                 <+> ppr rdr_name))        ; return (mkUnboundNameRdr rdr_name) }  {- Note [Promoted variables in types]@@ -1158,21 +1182,17 @@ -- -- This may be a local variable, global variable, or one or more record selector -- functions.  It will not return record fields created with the--- @NoFieldSelectors@ extension (see Note [NoFieldSelectors]).  The--- 'DuplicateRecordFields' argument controls whether ambiguous fields will be--- allowed (resulting in an 'AmbiguousFields' result being returned).+-- @NoFieldSelectors@ extension (see Note [NoFieldSelectors]). -- -- If the name is not in scope at the term level, but its promoted equivalent is -- in scope at the type level, the lookup will succeed (so that the type-checker -- can report a more informative error later).  See Note [Promotion]. ---lookupExprOccRn-  :: DuplicateRecordFields -> RdrName-  -> RnM (Maybe AmbiguousResult)-lookupExprOccRn dup_fields_ok rdr_name-  = do { mb_name <- lookupOccRnX_maybe global_lookup (UnambiguousGre . NormalGreName) rdr_name+lookupExprOccRn :: RdrName -> RnM (Maybe GreName)+lookupExprOccRn rdr_name+  = do { mb_name <- lookupOccRnX_maybe global_lookup NormalGreName rdr_name        ; case mb_name of-           Nothing   -> fmap @Maybe (UnambiguousGre . NormalGreName) <$> lookup_promoted rdr_name+           Nothing   -> fmap @Maybe NormalGreName <$> lookup_promoted rdr_name                         -- See Note [Promotion].                         -- We try looking up the name as a                         -- type constructor or type variable, if@@ -1180,8 +1200,14 @@            p         -> return p }    where-    global_lookup :: RdrName -> RnM (Maybe AmbiguousResult)-    global_lookup = lookupGlobalOccRn_overloaded dup_fields_ok WantNormal+    global_lookup :: RdrName -> RnM (Maybe GreName)+    global_lookup  rdr_name =+      do { mb_name <- lookupGlobalOccRn_overloaded NoDuplicateRecordFields WantNormal rdr_name+         ; case mb_name of+             Just (UnambiguousGre name) -> return (Just name)+             Just _ -> panic "GHC.Rename.Env.global_lookup: The impossible happened!"+             Nothing -> return Nothing+         }  lookupGlobalOccRn_maybe :: RdrName -> RnM (Maybe Name) -- Looks up a RdrName occurrence in the top-level@@ -1211,7 +1237,11 @@     case mn of       Just n -> return n       Nothing -> do { traceRn "lookupGlobalOccRn" (ppr rdr_name)-                    ; unboundName WL_Global rdr_name }+                    ; unboundName (LF which_suggest WL_Global) rdr_name }+        where which_suggest = case fos of+                WantNormal -> WL_Anything+                WantBoth   -> WL_RecField+                WantField  -> WL_RecField  -- Looks up a RdrName occurrence in the GlobalRdrEnv and with -- lookupQualifiedNameGHCi. Does not try to find an Exact or Orig name first.@@ -1399,7 +1429,7 @@ {-  Note [ Unbound vs Ambiguous Names ]-+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ lookupGreRn_maybe deals with failures in two different ways. If a name is unbound then we return a `Nothing` but if the name is ambiguous then we raise an error and return a dummy name.@@ -1447,7 +1477,7 @@         GreNotFound ->           do             traceRn "lookupGreAvailRn" (ppr rdr_name)-            name <- unboundName WL_Global rdr_name+            name <- unboundName (LF WL_Anything WL_Global) rdr_name             return (name, avail name)         MultipleNames gres ->           do@@ -1515,7 +1545,7 @@  warnIfDeprecated :: GlobalRdrElt -> RnM () warnIfDeprecated gre@(GRE { gre_imp = iss })-  | (imp_spec : _) <- iss+  | Just imp_spec <- headMaybe iss   = do { dflags <- getDynFlags        ; this_mod <- getModule        ; when (wopt Opt_WarnWarningsDeprecations dflags &&@@ -1523,16 +1553,21 @@                    -- See Note [Handling of deprecations]          do { iface <- loadInterfaceForName doc name             ; case lookupImpDeprec iface gre of-                Just txt -> addWarn (Reason Opt_WarnWarningsDeprecations)-                                   (mk_msg imp_spec txt)+                Just txt -> do+                  let msg = TcRnUnknownMessage $+                              mkPlainDiagnostic (WarningWithFlag Opt_WarnWarningsDeprecations)+                                                noHints+                                                (mk_msg imp_spec txt)++                  addDiagnostic msg                 Nothing  -> return () } }   | otherwise   = return ()   where     occ = greOccName gre     name = greMangledName gre-    name_mod = ASSERT2( isExternalName name, ppr name ) nameModule name-    doc = text "The name" <+> quotes (ppr occ) <+> ptext (sLit "is mentioned explicitly")+    name_mod = assertPpr (isExternalName name) (ppr name) (nameModule name)+    doc = text "The name" <+> quotes (ppr occ) <+> text "is mentioned explicitly"      mk_msg imp_spec txt       = sep [ sep [ text "In the use of"@@ -1546,7 +1581,7 @@         extra | imp_mod == moduleName name_mod = Outputable.empty               | otherwise = text ", but defined in" <+> ppr name_mod -lookupImpDeprec :: ModIface -> GlobalRdrElt -> Maybe WarningTxt+lookupImpDeprec :: ModIface -> GlobalRdrElt -> Maybe (WarningTxt GhcRn) lookupImpDeprec iface gre   = mi_warn_fn (mi_final_exts iface) (greOccName gre) `mplus`  -- Bleat if the thing,     case gre_par gre of                      -- or its parent, is warn'd@@ -1631,7 +1666,7 @@     -- -fimplicit-import-qualified is used with a module that exports the same     -- field name multiple times (see     -- Note [DuplicateRecordFields and -fimplicit-import-qualified]).-    toGRE gname = GRE { gre_name = gname, gre_par = NoParent, gre_lcl = False, gre_imp = [is] }+    toGRE gname = GRE { gre_name = gname, gre_par = NoParent, gre_lcl = False, gre_imp = unitBag is }     is = ImpSpec { is_decl = ImpDeclSpec { is_mod = mod, is_as = mod, is_qual = True, is_dloc = noSrcSpan }                  , is_item = ImpAll }     -- If -fimplicit-import-qualified succeeded, the name must be qualified.@@ -1655,7 +1690,7 @@       , is_ghci       , gopt Opt_ImplicitImportQualified dflags   -- Enables this GHCi behaviour       , not (safeDirectImpsReq dflags)            -- See Note [Safe Haskell and GHCi]-      = do { res <- loadSrcInterface_maybe doc mod NotBoot Nothing+      = do { res <- loadSrcInterface_maybe doc mod NotBoot NoPkgQual            ; case res of                 Succeeded iface                   -> return [ gname@@ -1762,7 +1797,8 @@   = wrapLocMA $ \ rdr_name ->     do { mb_name <- lookupBindGroupOcc ctxt what rdr_name        ; case mb_name of-           Left err   -> do { addErr err; return (mkUnboundNameRdr rdr_name) }+           Left err   -> do { addErr (mkTcRnNotInScope rdr_name err)+                            ; return (mkUnboundNameRdr rdr_name) }            Right name -> return name }  -- | Lookup a name in relation to the names in a 'HsSigCtxt'@@ -1774,12 +1810,13 @@   = wrapLocMA $ \ rdr_name ->     do { mb_name <- lookupBindGroupOcc ctxt what rdr_name        ; case mb_name of-           Left err   -> do { addErr err; return (mkUnboundNameRdr rdr_name) }+           Left err   -> do { addErr (mkTcRnNotInScope rdr_name err)+                            ; return (mkUnboundNameRdr rdr_name) }            Right name -> return name }  lookupBindGroupOcc :: HsSigCtxt                    -> SDoc-                   -> RdrName -> RnM (Either SDoc Name)+                   -> RdrName -> RnM (Either NotInScopeError Name) -- Looks up the RdrName, expecting it to resolve to one of the -- bound names passed in.  If not, return an appropriate error message --@@ -1814,11 +1851,12 @@      lookup_top keep_me       = do { env <- getGlobalRdrEnv+           ; dflags <- getDynFlags            ; let all_gres = lookupGlobalRdrEnv env (rdrNameOcc rdr_name)                  names_in_scope = -- If rdr_name lacks a binding, only                                   -- recommend alternatives from related                                   -- namespaces. See #17593.-                                  filter (\n -> nameSpacesRelated+                                  filter (\n -> nameSpacesRelated dflags WL_Anything                                                   (rdrNameSpace rdr_name)                                                   (nameNameSpace n))                                 $ map greMangledName@@ -1840,32 +1878,24 @@                  | otherwise                   -> bale_out_with local_msg                Nothing                         -> bale_out_with candidates_msg } -    bale_out_with msg-        = return (Left (sep [ text "The" <+> what-                                <+> text "for" <+> quotes (ppr rdr_name)-                           , nest 2 $ text "lacks an accompanying binding"]-                       $$ nest 2 msg))+    bale_out_with hints = return (Left $ MissingBinding what hints) -    local_msg = parens $ text "The"  <+> what <+> ptext (sLit "must be given where")-                           <+> quotes (ppr rdr_name) <+> text "is declared"+    local_msg = [SuggestMoveToDeclarationSite what rdr_name]      -- Identify all similar names and produce a message listing them-    candidates :: [Name] -> SDoc+    candidates :: [Name] -> [GhcHint]     candidates names_in_scope-      = case similar_names of-          []  -> Outputable.empty-          [n] -> text "Perhaps you meant" <+> pp_item n-          _   -> sep [ text "Perhaps you meant one of these:"-                     , nest 2 (pprWithCommas pp_item similar_names) ]+      | (nm : nms) <- map SimilarName similar_names+      = [SuggestSimilarNames rdr_name (nm NE.:| nms)]+      | otherwise+      = []       where         similar_names           = fuzzyLookup (unpackFS $ occNameFS $ rdrNameOcc rdr_name)                         $ map (\x -> ((unpackFS $ occNameFS $ nameOccName x), x))                               names_in_scope -        pp_item x = quotes (ppr x) <+> parens (pprDefinedAt x) - --------------- lookupLocalTcNames :: HsSigCtxt -> SDoc -> RdrName -> RnM [(RdrName, Name)] -- GHC extension: look up both the tycon and data con or variable.@@ -1875,7 +1905,8 @@ lookupLocalTcNames ctxt what rdr_name   = do { mb_gres <- mapM lookup (dataTcOccs rdr_name)        ; let (errs, names) = partitionEithers mb_gres-       ; when (null names) $ addErr (head errs) -- Bleat about one only+       ; when (null names) $+          addErr (head errs) -- Bleat about one only        ; return names }   where     lookup rdr = do { this_mod <- getModule@@ -1886,10 +1917,11 @@     guard_builtin_syntax this_mod rdr (Right name)       | Just _ <- isBuiltInOcc_maybe (occName rdr)       , this_mod /= nameModule name-      = Left (hsep [text "Illegal", what, text "of built-in syntax:", ppr rdr])+      = Left $ TcRnIllegalBuiltinSyntax what rdr       | otherwise       = Right (rdr, name)-    guard_builtin_syntax _ _ (Left err) = Left err+    guard_builtin_syntax _ _ (Left err)+      = Left $ mkTcRnNotInScope rdr_name err  dataTcOccs :: RdrName -> [RdrName] -- Return both the given name and the same name promoted to the TcClsName@@ -1902,13 +1934,7 @@   = [rdr_name]   where     occ = rdrNameOcc rdr_name-    rdr_name_tc =-      case rdr_name of-        -- The (~) type operator is always in scope, so we need a special case-        -- for it here, or else  :info (~)  fails in GHCi.-        -- See Note [eqTyCon (~) is built-in syntax]-        Unqual occ | occNameFS occ == fsLit "~" -> eqTyCon_RDR-        _ -> setRdrNameSpace rdr_name tcName+    rdr_name_tc = setRdrNameSpace rdr_name tcName  {- Note [dataTcOccs and Exact Names]@@ -1977,7 +2003,7 @@   = do { rebindable_on <- xoptM LangExt.RebindableSyntax        ; if not rebindable_on          then return Nothing-         else do { ite <- lookupOccRn (mkVarUnqual (fsLit "ifThenElse"))+         else do { ite <- lookupOccRnNone (mkVarUnqual (fsLit "ifThenElse"))                  ; return (Just ite) } }  lookupSyntaxName :: Name                 -- ^ The standard name@@ -1992,7 +2018,7 @@   = do { rebind <- xoptM LangExt.RebindableSyntax        ; if not rebind          then return (std_name, emptyFVs)-         else do { nm <- lookupOccRn (mkRdrUnqual (nameOccName std_name))+         else do { nm <- lookupOccRnNone (mkRdrUnqual (nameOccName std_name))                  ; return (nm, unitFV nm) } }  lookupSyntaxExpr :: Name                          -- ^ The standard name@@ -2016,7 +2042,8 @@        ; if not rebindable_on then              return (map (HsVar noExtField . noLocA) std_names, emptyFVs)         else-          do { usr_names <- mapM (lookupOccRn . mkRdrUnqual . nameOccName) std_names+          do { usr_names <-+                 mapM (lookupOccRnNone . mkRdrUnqual . nameOccName) std_names              ; return (map (HsVar noExtField . noLocA) usr_names, mkFVs usr_names) } }  @@ -2050,7 +2077,7 @@  lookupNameWithQualifier :: Name -> ModuleName -> RnM (Name, FreeVars) lookupNameWithQualifier std_name modName-  = do { qname <- lookupOccRn (mkRdrQual modName (nameOccName std_name))+  = do { qname <- lookupOccRnNone (mkRdrQual modName (nameOccName std_name))        ; return (qname, unitFV qname) }  -- See Note [QualifiedDo].@@ -2066,19 +2093,20 @@  -- Error messages -opDeclErr :: RdrName -> SDoc+opDeclErr :: RdrName -> TcRnMessage opDeclErr n-  = hang (text "Illegal declaration of a type or class operator" <+> quotes (ppr n))+  = TcRnUnknownMessage $ mkPlainError noHints $+    hang (text "Illegal declaration of a type or class operator" <+> quotes (ppr n))        2 (text "Use TypeOperators to declare operators in type and declarations") -badOrigBinding :: RdrName -> SDoc+badOrigBinding :: RdrName -> TcRnMessage badOrigBinding name   | Just _ <- isBuiltInOcc_maybe occ-  = text "Illegal binding of built-in syntax:" <+> ppr occ+  = TcRnUnknownMessage $ mkPlainError noHints $ text "Illegal binding of built-in syntax:" <+> ppr occ     -- Use an OccName here because we don't want to print Prelude.(,)   | otherwise-  = text "Cannot redefine a Name retrieved by a Template Haskell quote:"-    <+> ppr name+  = TcRnUnknownMessage $ mkPlainError noHints $+    text "Cannot redefine a Name retrieved by a Template Haskell quote:" <+> ppr name     -- This can happen when one tries to use a Template Haskell splice to     -- define a top-level identifier with an already existing name, e.g.,     --
GHC/Rename/Expr.hs view
@@ -1,8 +1,10 @@-{-# LANGUAGE CPP                 #-}+ {-# LANGUAGE ConstraintKinds     #-}+{-# LANGUAGE CPP                 #-} {-# LANGUAGE FlexibleContexts    #-} {-# LANGUAGE MultiWayIf          #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-} {-# LANGUAGE TypeFamilies        #-}  {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}@@ -25,25 +27,27 @@         AnnoBody    ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Rename.Bind ( rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS                         , rnMatchGroup, rnGRHS, makeMiniFixityEnv) import GHC.Hs+import GHC.Tc.Errors.Types import GHC.Tc.Utils.Env ( isBrackStage ) import GHC.Tc.Utils.Monad-import GHC.Unit.Module ( getModule )+import GHC.Unit.Module ( getModule, isInteractiveModule ) import GHC.Rename.Env import GHC.Rename.Fixity-import GHC.Rename.Utils ( HsDocContext(..), bindLocalNamesFV, checkDupNames+import GHC.Rename.Utils ( bindLocalNamesFV, checkDupNames                         , bindLocalNames                         , mapMaybeFvRn, mapFvRn                         , warnUnusedLocalBinds, typeAppErr-                        , checkUnusedRecordWildcard )+                        , checkUnusedRecordWildcard+                        , wrapGenSpan, genHsIntegralLit, genHsTyLit+                        , genHsVar, genLHsVar, genHsApp, genHsApps+                        , genAppType ) import GHC.Rename.Unbound ( reportUnboundName )-import GHC.Rename.Splice  ( rnBracket, rnSpliceExpr, checkThLocalName )+import GHC.Rename.Splice  ( rnTypedBracket, rnUntypedBracket, rnSpliceExpr, checkThLocalName ) import GHC.Rename.HsType import GHC.Rename.Pat import GHC.Driver.Session@@ -51,6 +55,7 @@  import GHC.Types.FieldLabel import GHC.Types.Fixity+import GHC.Types.Hint (suggestExtension) import GHC.Types.Id.Make import GHC.Types.Name import GHC.Types.Name.Set@@ -61,9 +66,9 @@ import GHC.Data.List.SetOps ( removeDups ) import GHC.Utils.Error import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Utils.Outputable as Outputable import GHC.Types.SrcLoc-import GHC.Data.FastString import Control.Monad import GHC.Builtin.Types ( nilDataConName ) import qualified GHC.LanguageExtensions as LangExt@@ -108,7 +113,10 @@ This is accomplished by lookupSyntaxName, and it applies to all the constructs below. -Here are the constructs that we transform in this way. Some are uniform,+See also Note [Handling overloaded and rebindable patterns] in GHC.Rename.Pat+for the story with patterns.++Here are the expressions that we transform in this way. Some are uniform, but several have a little bit of special treatment:  * HsIf (if-the-else)@@ -132,7 +140,7 @@ * SectionL and SectionR (left and right sections)      (`op` e) ==> rightSection op e      (e `op`) ==> leftSection  (op e)-  where `leftSection` and `rightSection` are levity-polymorphic+  where `leftSection` and `rightSection` are representation-polymorphic   wired-in Ids. See Note [Left and right sections]  * It's a bit painful to transform `OpApp e1 op e2` to a `HsExpansion`@@ -200,25 +208,18 @@       ; return (HsVar noExtField (L (la2na l) name), unitFV name) }  rnUnboundVar :: RdrName -> RnM (HsExpr GhcRn, FreeVars)-rnUnboundVar v =-  if isUnqual v-  then -- Treat this as a "hole"-       -- Do not fail right now; instead, return HsUnboundVar-       -- and let the type checker report the error-       return (HsUnboundVar noExtField (rdrNameOcc v), emptyFVs)--        else -- Fail immediately (qualified name)-             do { n <- reportUnboundName v-                ; return (HsVar noExtField (noLocA n), emptyFVs) }+rnUnboundVar v = do+  deferOutofScopeVariables <- goptM Opt_DeferOutOfScopeVariables+  unless (isUnqual v || deferOutofScopeVariables) (reportUnboundName v >> return ())+  return (HsUnboundVar noExtField (rdrNameOcc v), emptyFVs)  rnExpr (HsVar _ (L l v))   = do { dflags <- getDynFlags-       ; let dup_fields_ok = xopt_DuplicateRecordFields dflags-       ; mb_name <- lookupExprOccRn dup_fields_ok v+       ; mb_name <- lookupExprOccRn v         ; case mb_name of {            Nothing -> rnUnboundVar v ;-           Just (UnambiguousGre (NormalGreName name))+           Just (NormalGreName name)               | name == nilDataConName -- Treat [] as an ExplicitList, so that                                        -- OverloadedLists works correctly                                        -- Note [Empty lists] in GHC.Hs.Expr@@ -227,12 +228,15 @@                | otherwise               -> finishHsVar (L (na2la l) name) ;-            Just (UnambiguousGre (FieldGreName fl)) ->-              let sel_name = flSelector fl in-              return ( HsRecFld noExtField (Unambiguous sel_name (L l v) ), unitFV sel_name) ;-            Just AmbiguousFields ->-              return ( HsRecFld noExtField (Ambiguous noExtField (L l v) ), emptyFVs) } }-+            Just (FieldGreName fl)+              -> do { let sel_name = flSelector fl+                    ; this_mod <- getModule+                    ; when (nameIsLocalOrFrom this_mod sel_name) $+                        checkThLocalName sel_name+                    ; return ( HsRecSel noExtField (FieldOcc sel_name (L l v) ), unitFV sel_name)+                    }+         }+       }  rnExpr (HsIPVar x v)   = return (HsIPVar x v, emptyFVs)@@ -294,7 +298,7 @@         -- should prevent bad things happening.         ; fixity <- case op' of               L _ (HsVar _ (L _ n)) -> lookupFixityRn n-              L _ (HsRecFld _ f)    -> lookupFieldFixityRn f+              L _ (HsRecSel _ f)    -> lookupFieldFixityRn f               _ -> return (Fixity NoSourceText minPrecedence InfixL)                    -- c.f. lookupFixity for unbound @@ -316,41 +320,42 @@ rnExpr (HsGetField _ e f)  = do { (getField, fv_getField) <- lookupSyntaxName getFieldName       ; (e, fv_e) <- rnLExpr e-      ; let f' = rnHsFieldLabel f+      ; let f' = rnDotFieldOcc f       ; return ( mkExpandedExpr                    (HsGetField noExtField e f')-                   (mkGetField getField e (fmap (unLoc . hflLabel) f'))+                   (mkGetField getField e (fmap (unLoc . dfoLabel) f'))                , fv_e `plusFV` fv_getField ) }  rnExpr (HsProjection _ fs)   = do { (getField, fv_getField) <- lookupSyntaxName getFieldName        ; circ <- lookupOccRn compose_RDR-       ; let fs' = fmap rnHsFieldLabel fs+       ; let fs' = fmap rnDotFieldOcc fs        ; return ( mkExpandedExpr                     (HsProjection noExtField fs')-                    (mkProjection getField circ (fmap (fmap (unLoc . hflLabel)) fs'))+                    (mkProjection getField circ (fmap (fmap (unLoc . dfoLabel)) fs'))                 , unitFV circ `plusFV` fv_getField) }  ------------------------------------------ -- Template Haskell extensions-rnExpr e@(HsBracket _ br_body) = rnBracket e br_body+rnExpr e@(HsTypedBracket _ br_body)   = rnTypedBracket e br_body+rnExpr e@(HsUntypedBracket _ br_body) = rnUntypedBracket e br_body  rnExpr (HsSpliceE _ splice) = rnSpliceExpr splice  --------------------------------------------- --      Sections -- See Note [Parsing sections] in GHC.Parser-rnExpr (HsPar x (L loc (section@(SectionL {}))))+rnExpr (HsPar x lpar (L loc (section@(SectionL {}))) rpar)   = do  { (section', fvs) <- rnSection section-        ; return (HsPar x (L loc section'), fvs) }+        ; return (HsPar x lpar (L loc section') rpar, fvs) } -rnExpr (HsPar x (L loc (section@(SectionR {}))))+rnExpr (HsPar x lpar (L loc (section@(SectionR {}))) rpar)   = do  { (section', fvs) <- rnSection section-        ; return (HsPar x (L loc section'), fvs) }+        ; return (HsPar x lpar (L loc section') rpar, fvs) } -rnExpr (HsPar x e)+rnExpr (HsPar x lpar e rpar)   = do  { (e', fvs_e) <- rnLExpr e-        ; return (HsPar x e', fvs_e) }+        ; return (HsPar x lpar e' rpar, fvs_e) }  rnExpr expr@(SectionL {})   = do  { addErr (sectionErr expr); rnSection expr }@@ -369,26 +374,26 @@   = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLExpr matches        ; return (HsLam x matches', fvMatch) } -rnExpr (HsLamCase x matches)-  = do { (matches', fvs_ms) <- rnMatchGroup CaseAlt rnLExpr matches-       ; return (HsLamCase x matches', fvs_ms) }+rnExpr (HsLamCase x lc_variant matches)+  = do { (matches', fvs_ms) <- rnMatchGroup (LamCaseAlt lc_variant) rnLExpr matches+       ; return (HsLamCase x lc_variant matches', fvs_ms) }  rnExpr (HsCase _ expr matches)   = do { (new_expr, e_fvs) <- rnLExpr expr        ; (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLExpr matches        ; return (HsCase noExtField new_expr new_matches, e_fvs `plusFV` ms_fvs) } -rnExpr (HsLet _ binds expr)+rnExpr (HsLet _ tkLet binds tkIn expr)   = rnLocalBindsAndThen binds $ \binds' _ -> do       { (expr',fvExpr) <- rnLExpr expr-      ; return (HsLet noExtField binds' expr', fvExpr) }+      ; return (HsLet noExtField tkLet binds' tkIn expr', fvExpr) }  rnExpr (HsDo _ do_or_lc (L l stmts))-  = do  { ((stmts', _), fvs) <--           rnStmtsWithPostProcessing do_or_lc rnExpr-             postProcessStmtsForApplicativeDo stmts-             (\ _ -> return ((), emptyFVs))-        ; return ( HsDo noExtField do_or_lc (L l stmts'), fvs ) }+ = do { ((stmts1, _), fvs1) <-+          rnStmtsWithFreeVars (HsDoStmt do_or_lc) rnExpr stmts+            (\ _ -> return ((), emptyFVs))+      ; (pp_stmts, fvs2) <- postProcessStmtsForApplicativeDo do_or_lc stmts1+      ; return ( HsDo noExtField do_or_lc (L l pp_stmts), fvs1 `plusFV` fvs2 ) }  -- ExplicitList: see Note [Handling overloaded and rebindable constructs] rnExpr (ExplicitList _ exps)@@ -400,7 +405,7 @@     do { (from_list_n_name, fvs') <- lookupSyntaxName fromListNName        ; let rn_list  = ExplicitList noExtField exps'              lit_n    = mkIntegralLit (length exps)-             hs_lit   = wrapGenSpan (HsLit noAnn (HsInt noExtField lit_n))+             hs_lit   = genHsIntegralLit lit_n              exp_list = genHsApps from_list_n_name [hs_lit, wrapGenSpan rn_list]        ; return ( mkExpandedExpr rn_list exp_list                 , fvs `plusFV` fvs') } }@@ -420,7 +425,7 @@  rnExpr (RecordCon { rcon_con = con_id                   , rcon_flds = rec_binds@(HsRecFields { rec_dotdot = dd }) })-  = do { con_lname@(L _ con_name) <- lookupLocatedOccRn con_id+  = do { con_lname@(L _ con_name) <- lookupLocatedOccRnConstr con_id        ; (flds, fvs)   <- rnHsRecFields (HsRecFieldCon con_name) mk_hs_var rec_binds        ; (flds', fvss) <- mapAndUnzipM rn_field flds        ; let rec_binds' = HsRecFields { rec_flds = flds', rec_dotdot = dd }@@ -429,8 +434,8 @@                 , fvs `plusFV` plusFVs fvss `addOneFV` con_name) }   where     mk_hs_var l n = HsVar noExtField (L (noAnnSrcSpan l) n)-    rn_field (L l fld) = do { (arg', fvs) <- rnLExpr (hsRecFieldArg fld)-                            ; return (L l (fld { hsRecFieldArg = arg' }), fvs) }+    rn_field (L l fld) = do { (arg', fvs) <- rnLExpr (hfbRHS fld)+                            ; return (L l (fld { hfbRHS = arg' }), fvs) }  rnExpr (RecordUpd { rupd_expr = expr, rupd_flds = rbinds })   = case rbinds of@@ -441,11 +446,13 @@             }       Right flds ->  -- 'OverloadedRecordUpdate' is in effect. Record dot update desugaring.         do { ; unlessXOptM LangExt.RebindableSyntax $-                 addErr $ text "RebindableSyntax is required if OverloadedRecordUpdate is enabled."-             ; let punnedFields = [fld | (L _ fld) <- flds, hsRecPun fld]-             ; punsEnabled <-xoptM LangExt.RecordPuns+                 addErr $ TcRnUnknownMessage $ mkPlainError noHints $+                   text "RebindableSyntax is required if OverloadedRecordUpdate is enabled."+             ; let punnedFields = [fld | (L _ fld) <- flds, hfbPun fld]+             ; punsEnabled <-xoptM LangExt.NamedFieldPuns              ; unless (null punnedFields || punsEnabled) $-                 addErr $ text "For this to work enable NamedFieldPuns."+                 addErr $ TcRnUnknownMessage $ mkPlainError noHints $+                   text "For this to work enable NamedFieldPuns."              ; (getField, fv_getField) <- lookupSyntaxName getFieldName              ; (setField, fv_setField) <- lookupSyntaxName setFieldName              ; (e, fv_e) <- rnLExpr expr@@ -520,12 +527,13 @@     -- absolutely prepared to cope with static forms, we check for     -- -XStaticPointers here as well.     unlessXOptM LangExt.StaticPointers $-      addErr $ hang (text "Illegal static expression:" <+> ppr e)+      addErr $ TcRnUnknownMessage $ mkPlainError noHints $+        hang (text "Illegal static expression:" <+> ppr e)                   2 (text "Use StaticPointers to enable this extension")     (expr',fvExpr) <- rnLExpr expr     stage <- getStage     case stage of-      Splice _ -> addErr $ sep+      Splice _ -> addErr $ TcRnUnknownMessage $ mkPlainError noHints $ sep              [ text "static forms cannot be used in splices:"              , nest 2 $ ppr e              ]@@ -534,7 +542,8 @@     let fvExpr' = filterNameSet (nameIsLocalOrFrom mod) fvExpr     return (HsStatic fvExpr' expr', fvExpr) -{- *********************************************************************+{-+************************************************************************ *                                                                      *         Arrow notation *                                                                      *@@ -549,7 +558,8 @@ rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other)         -- HsWrap -{- *********************************************************************+{-+************************************************************************ *                                                                      *         Operator sections *                                                                      *@@ -600,11 +610,11 @@ Note [Desugaring operator sections]  Here are their definitions:-   leftSection :: forall r1 r2 n (a:TYPE r1) (b:TYPE r2).+   leftSection :: forall r1 r2 n (a::TYPE r1) (b::TYPE r2).                   (a %n-> b) -> a %n-> b    leftSection f x = f x -   rightSection :: forall r1 r2 r3 (a:TYPE r1) (b:TYPE r2) (c:TYPE r3).+   rightSection :: forall r1 r2 r3 n1 n2 (a::TYPE r1) (b::TYPE r2) (c::TYPE r3).                    (a %n1 -> b %n2-> c) -> b %n2-> a %n1-> c    rightSection f y x = f x y @@ -616,23 +626,23 @@   Plus, infix operator applications would be trickier to make   rebindable, so it'd be inconsistent to do so for sections. -  TL;DR: we still us the renamer-expansion mechanism for operator-  sections , but only to eliminate special-purpose code paths in the+  TL;DR: we still use the renamer-expansion mechanism for operator+  sections, but only to eliminate special-purpose code paths in the   renamer and desugarer. -* leftSection and rightSection must be levity-polymorphic, to allow-  (+# 4#) and (4# +#) to work. See GHC.Types.Id.Make.-  Note [Wired-in Ids for rebindable syntax] in+* leftSection and rightSection must be representation-polymorphic, to allow+  (+# 4#) and (4# +#) to work. See+  Note [Wired-in Ids for rebindable syntax] in GHC.Types.Id.Make.  * leftSection and rightSection must be multiplicity-polymorphic.   (Test linear/should_compile/OldList showed this up.) -* Because they are levity-polymorphic, we have to define them+* Because they are representation-polymorphic, we have to define them   as wired-in Ids, with compulsory inlining.  See   GHC.Types.Id.Make.leftSectionId, rightSectionId.  * leftSection is just ($) really; but unlike ($) it is-  levity polymorphic in the result type, so we can write+  representation-polymorphic in the result type, so we can write   `(x +#)`, say.  * The type of leftSection must have an arrow in its first argument,@@ -649,16 +659,6 @@       (e `op`)  ==>   op e   with no auxiliary function at all.  Simple! -* leftSection and rightSection switch on ImpredicativeTypes locally,-  during Quick Look; see GHC.Tc.Gen.App.wantQuickLook. Consider-  test DeepSubsumption08:-     type Setter st t a b = forall f. Identical f => blah-     (.~) :: Setter s t a b -> b -> s -> t-     clear :: Setter a a' b (Maybe b') -> a -> a'-     clear = (.~ Nothing)-   The expansion look like (rightSection (.~) Nothing).  So we must-   instantiate `rightSection` first type argument to a polytype!-   Hence the special magic in App.wantQuickLook.  Historical Note [Desugaring operator sections] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -719,11 +719,11 @@ ************************************************************************ -} -rnHsFieldLabel :: Located (HsFieldLabel GhcPs) -> Located (HsFieldLabel GhcRn)-rnHsFieldLabel (L l (HsFieldLabel x label)) = L l (HsFieldLabel x label)+rnDotFieldOcc :: LocatedAn NoEpAnns (DotFieldOcc GhcPs) -> LocatedAn NoEpAnns (DotFieldOcc GhcRn)+rnDotFieldOcc (L l (DotFieldOcc x label)) = L l (DotFieldOcc x label)  rnFieldLabelStrings :: FieldLabelStrings GhcPs -> FieldLabelStrings GhcRn-rnFieldLabelStrings (FieldLabelStrings fls) = FieldLabelStrings (map rnHsFieldLabel fls)+rnFieldLabelStrings (FieldLabelStrings fls) = FieldLabelStrings (map rnDotFieldOcc fls)  {- ************************************************************************@@ -741,7 +741,7 @@        ; return (arg':args', fvArg `plusFV` fvArgs) }  rnCmdTop :: LHsCmdTop GhcPs -> RnM (LHsCmdTop GhcRn, FreeVars)-rnCmdTop = wrapLocFstM rnCmdTop'+rnCmdTop = wrapLocFstMA rnCmdTop'  where   rnCmdTop' :: HsCmdTop GhcPs -> RnM (HsCmdTop GhcRn, FreeVars)   rnCmdTop' (HsCmdTop _ cmd)@@ -800,9 +800,9 @@   = do { (matches', fvMatch) <- rnMatchGroup (ArrowMatchCtxt KappaExpr) rnLCmd matches        ; return (HsCmdLam noExtField matches', fvMatch) } -rnCmd (HsCmdPar x e)+rnCmd (HsCmdPar x lpar e rpar)   = do  { (e', fvs_e) <- rnLCmd e-        ; return (HsCmdPar x e', fvs_e) }+        ; return (HsCmdPar x lpar e' rpar, fvs_e) }  rnCmd (HsCmdCase _ expr matches)   = do { (new_expr, e_fvs) <- rnLExpr expr@@ -810,9 +810,10 @@        ; return (HsCmdCase noExtField new_expr new_matches                 , e_fvs `plusFV` ms_fvs) } -rnCmd (HsCmdLamCase x matches)-  = do { (new_matches, ms_fvs) <- rnMatchGroup (ArrowMatchCtxt ArrowCaseAlt) rnLCmd matches-       ; return (HsCmdLamCase x new_matches, ms_fvs) }+rnCmd (HsCmdLamCase x lc_variant matches)+  = do { (new_matches, ms_fvs) <-+           rnMatchGroup (ArrowMatchCtxt $ ArrowLamCaseAlt lc_variant) rnLCmd matches+       ; return (HsCmdLamCase x lc_variant new_matches, ms_fvs) }  rnCmd (HsCmdIf _ _ p b1 b2)   = do { (p', fvP) <- rnLExpr p@@ -826,10 +827,10 @@         ; return (HsCmdIf noExtField ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2])} -rnCmd (HsCmdLet _ binds cmd)+rnCmd (HsCmdLet _ tkLet binds tkIn cmd)   = rnLocalBindsAndThen binds $ \ binds' _ -> do       { (cmd',fvExpr) <- rnLCmd cmd-      ; return (HsCmdLet noExtField binds' cmd', fvExpr) }+      ; return (HsCmdLet noExtField tkLet binds' tkIn cmd', fvExpr) }  rnCmd (HsCmdDo _ (L l stmts))   = do  { ((stmts', _), fvs) <-@@ -852,19 +853,19 @@   = unitFV appAName methodNamesCmd (HsCmdArrForm {}) = emptyFVs -methodNamesCmd (HsCmdPar _ c) = methodNamesLCmd c+methodNamesCmd (HsCmdPar _ _ c _) = methodNamesLCmd c  methodNamesCmd (HsCmdIf _ _ _ c1 c2)   = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName -methodNamesCmd (HsCmdLet _ _ c)          = methodNamesLCmd c+methodNamesCmd (HsCmdLet _ _ _ _ c)      = methodNamesLCmd c methodNamesCmd (HsCmdDo _ (L _ stmts))   = methodNamesStmts stmts methodNamesCmd (HsCmdApp _ c _)          = methodNamesLCmd c methodNamesCmd (HsCmdLam _ match)        = methodNamesMatch match  methodNamesCmd (HsCmdCase _ _ matches)   = methodNamesMatch matches `addOneFV` choiceAName-methodNamesCmd (HsCmdLamCase _ matches)+methodNamesCmd (HsCmdLamCase _ _ matches)   = methodNamesMatch matches `addOneFV` choiceAName  --methodNamesCmd _ = emptyFVs@@ -886,7 +887,7 @@  ------------------------------------------------- -methodNamesGRHS :: Located (GRHS GhcRn (LHsCmd GhcRn)) -> CmdNeeds+methodNamesGRHS :: LocatedAn NoEpAnns (GRHS GhcRn (LHsCmd GhcRn)) -> CmdNeeds methodNamesGRHS (L _ (GRHS _ _ rhs)) = methodNamesLCmd rhs  ---------------------------------------------------@@ -987,34 +988,13 @@            -- ^ if these statements scope over something, this renames it            -- and returns the result.         -> RnM (([LStmt GhcRn (LocatedA (body GhcRn))], thing), FreeVars)-rnStmts ctxt rnBody = rnStmtsWithPostProcessing ctxt rnBody noPostProcessStmts---- | like 'rnStmts' but applies a post-processing step to the renamed Stmts-rnStmtsWithPostProcessing-        :: AnnoBody body-        => HsStmtContext GhcRn-        -> (body GhcPs -> RnM (body GhcRn, FreeVars))-           -- ^ How to rename the body of each statement (e.g. rnLExpr)-        -> (HsStmtContext GhcRn-              -> [(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)]-              -> RnM ([LStmt GhcRn (LocatedA (body GhcRn))], FreeVars))-           -- ^ postprocess the statements-        -> [LStmt GhcPs (LocatedA (body GhcPs))]-           -- ^ Statements-        -> ([Name] -> RnM (thing, FreeVars))-           -- ^ if these statements scope over something, this renames it-           -- and returns the result.-        -> RnM (([LStmt GhcRn (LocatedA (body GhcRn))], thing), FreeVars)-rnStmtsWithPostProcessing ctxt rnBody ppStmts stmts thing_inside- = do { ((stmts', thing), fvs) <--          rnStmtsWithFreeVars ctxt rnBody stmts thing_inside-      ; (pp_stmts, fvs') <- ppStmts ctxt stmts'-      ; return ((pp_stmts, thing), fvs `plusFV` fvs')-      }+rnStmts ctxt rnBody stmts thing_inside+ = do { ((stmts', thing), fvs) <- rnStmtsWithFreeVars ctxt rnBody stmts thing_inside+      ; return ((map fst stmts', thing), fvs) }  -- | maybe rearrange statements according to the ApplicativeDo transformation postProcessStmtsForApplicativeDo-  :: HsStmtContext GhcRn+  :: HsDoFlavour   -> [(ExprLStmt GhcRn, FreeVars)]   -> RnM ([ExprLStmt GhcRn], FreeVars) postProcessStmtsForApplicativeDo ctxt stmts@@ -1031,7 +1011,7 @@        ; if ado_is_on && is_do_expr && not in_th_bracket             then do { traceRn "ppsfa" (ppr stmts)                     ; rearrangeForApplicativeDo ctxt stmts }-            else noPostProcessStmts ctxt stmts }+            else noPostProcessStmts (HsDoStmt ctxt) stmts }  -- | strip the FreeVars annotations from statements noPostProcessStmts@@ -1059,7 +1039,7 @@        ; (thing, fvs) <- thing_inside []        ; return (([], thing), fvs) } -rnStmtsWithFreeVars mDoExpr@MDoExpr{} rnBody stmts thing_inside    -- Deal with mdo+rnStmtsWithFreeVars mDoExpr@(HsDoStmt MDoExpr{}) rnBody stmts thing_inside    -- Deal with mdo   = -- Behave like do { rec { ...all but last... }; last }     do { ((stmts1, (stmts2, thing)), fvs)            <- rnStmt mDoExpr rnBody (noLocA $ mkRecStmt noAnn (noLocA all_but_last)) $ \ _ ->@@ -1194,7 +1174,11 @@                               segs           -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring]         ; (thing, fvs_later) <- thing_inside bndrs-        ; let (rec_stmts', fvs) = segmentRecStmts (locA loc) ctxt empty_rec_stmt segs fvs_later+        -- In interactive mode, all variables could be used later. So we pass whether+        -- we are in GHCi along to segmentRecStmts. See Note [What is "used later" in a rec stmt]+        ; is_interactive <- isInteractiveModule . tcg_mod <$> getGblEnv+        ; let+             (rec_stmts', fvs) = segmentRecStmts (locA loc) ctxt empty_rec_stmt segs (fvs_later, is_interactive)         -- We aren't going to try to group RecStmts with         -- ApplicativeDo, so attaching empty FVs is fine.         ; return ( ((zip rec_stmts' (repeat emptyNameSet)), thing)@@ -1278,7 +1262,8 @@            ; return ((seg':segs', thing), fvs) }      cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2-    dupErr vs = addErr (text "Duplicate binding in parallel list comprehension for:"+    dupErr vs = addErr $ TcRnUnknownMessage $ mkPlainError noHints $+                  (text "Duplicate binding in parallel list comprehension for:"                     <+> quotes (ppr (NE.head vs)))  lookupQualifiedDoStmtName :: HsStmtContext GhcRn -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)@@ -1315,18 +1300,22 @@ -- Neither is ArrowExpr, which has its own desugarer in GHC.HsToCore.Arrows rebindableContext :: HsStmtContext GhcRn -> Bool rebindableContext ctxt = case ctxt of-  ListComp        -> False-  ArrowExpr       -> False-  PatGuard {}     -> False+  HsDoStmt flavour -> rebindableDoStmtContext flavour+  ArrowExpr -> False+  PatGuard {} -> False -  DoExpr m        -> isNothing m-  MDoExpr m       -> isNothing m-  MonadComp       -> True-  GhciStmtCtxt    -> True   -- I suppose?    ParStmtCtxt   c -> rebindableContext c     -- Look inside to   TransStmtCtxt c -> rebindableContext c     -- the parent context +rebindableDoStmtContext :: HsDoFlavour -> Bool+rebindableDoStmtContext flavour = case flavour of+  ListComp -> False+  DoExpr m -> isNothing m+  MDoExpr m -> isNothing m+  MonadComp -> True+  GhciStmtCtxt -> True   -- I suppose?+ {- Note [Renaming parallel Stmts] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1541,14 +1530,19 @@ segmentRecStmts :: AnnoBody body                 => SrcSpan -> HsStmtContext GhcRn                 -> Stmt GhcRn (LocatedA (body GhcRn))-                -> [Segment (LStmt GhcRn (LocatedA (body GhcRn)))] -> FreeVars+                -> [Segment (LStmt GhcRn (LocatedA (body GhcRn)))]+                -> (FreeVars, Bool)+                    -- ^ The free variables used in later statements.+                    -- If the boolean is 'True', this might be an underestimate+                    -- because we are in GHCi, and might thus be missing some "used later"+                    -- FVs. See Note [What is "used later" in a rec stmt]                 -> ([LStmt GhcRn (LocatedA (body GhcRn))], FreeVars) -segmentRecStmts loc ctxt empty_rec_stmt segs fvs_later+segmentRecStmts loc ctxt empty_rec_stmt segs (fvs_later, might_be_more_fvs_later)   | null segs-  = ([], fvs_later)+  = ([], final_fv_uses) -  | MDoExpr _ <- ctxt+  | HsDoStmt (MDoExpr _) <- ctxt   = segsToStmts empty_rec_stmt grouped_segs fvs_later                -- Step 4: Turn the segments into Stmts                 --         Use RecStmt when and only when there are fwd refs@@ -1559,14 +1553,23 @@   | otherwise   = ([ L (noAnnSrcSpan loc) $        empty_rec_stmt { recS_stmts = noLocA ss-                      , recS_later_ids = nameSetElemsStable-                                           (defs `intersectNameSet` fvs_later)+                      , recS_later_ids = nameSetElemsStable final_fvs_later                       , recS_rec_ids   = nameSetElemsStable                                            (defs `intersectNameSet` uses) }]           -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring]-    , uses `plusFV` fvs_later)+    , uses `plusFV` final_fv_uses)    where+    (final_fv_uses, final_fvs_later)+      | might_be_more_fvs_later+      = (defs, defs)+        -- If there might be more uses later (e.g. we are in GHCi and have not+        -- yet seen the whole rec statement), conservatively assume that everything+        -- will be used later (as is possible).+      | otherwise+      = ( uses `plusFV` fvs_later+        , defs `intersectNameSet` fvs_later )+     (defs_s, uses_s, _, ss) = unzip4 segs     defs = plusFVs defs_s     uses = plusFVs uses_s@@ -1641,6 +1644,28 @@      { rec { x <- ...y...; p <- z ; y <- ...x... ;              q <- x ; z <- y } ;        r <- x }++Note [What is "used later" in a rec stmt]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We desugar a recursive Stmt to something like++  (a,_,c) <- mfix (\(a,b,_) -> do { ... ; return (a,b,c) })+  ...stuff after the rec...++The knot-tied tuple must contain+* All the variables that are used before they are bound in the `rec` block+* All the variables that are used after the entire `rec` block++In the case of GHCi, however, we don't know what variables will be used+after the `rec` (#20206).  For example, we might have+    ghci>  rec { x <- e1; y <- e2 }+    ghci>  print x+    ghci>  print y++So we have to assume that *all* the variables bound in the `rec` are used+afterwards.  We pass a Boolean to segmentRecStmts to signal such a situation,+in which case that function conservatively assumes that everything might well+be used later. -}  glomSegments :: HsStmtContext GhcRn@@ -1684,7 +1709,7 @@  segsToStmts _ [] fvs_later = ([], fvs_later) segsToStmts empty_rec_stmt ((defs, uses, fwds, ss) : segs) fvs_later-  = ASSERT( not (null ss) )+  = assert (not (null ss))     (new_stmt : later_stmts, later_uses `plusFV` uses)   where     (later_stmts, later_uses) = segsToStmts empty_rec_stmt segs fvs_later@@ -1706,7 +1731,7 @@ ************************************************************************  Note [ApplicativeDo]-+~~~~~~~~~~~~~~~~~~~~ = Example =  For a sequence of statements@@ -1812,6 +1837,12 @@      <*> ...      <*> argexpr(arg_n) +== Special cases ==++If a do-expression contains only "return E" or "return $ E" plus+zero or more let-statements, we replace the "return" with "pure".+See Section 3.6 of the paper.+ = Relevant modules in the rest of the compiler =  ApplicativeDo touches a few phases in the compiler:@@ -1854,19 +1885,29 @@ -- | rearrange a list of statements using ApplicativeDoStmt.  See -- Note [ApplicativeDo]. rearrangeForApplicativeDo-  :: HsStmtContext GhcRn+  :: HsDoFlavour   -> [(ExprLStmt GhcRn, FreeVars)]   -> RnM ([ExprLStmt GhcRn], FreeVars)  rearrangeForApplicativeDo _ [] = return ([], emptyNameSet)-rearrangeForApplicativeDo _ [(one,_)] = return ([one], emptyNameSet)+-- If the do-block contains a single @return@ statement, change it to+-- @pure@ if ApplicativeDo is turned on. See Note [ApplicativeDo].+rearrangeForApplicativeDo ctxt [(one,_)] = do+  (return_name, _) <- lookupQualifiedDoName (HsDoStmt ctxt) returnMName+  (pure_name, _)   <- lookupQualifiedDoName (HsDoStmt ctxt) pureAName+  let pure_expr = nl_HsVar pure_name+  let monad_names = MonadNames { return_name = return_name+                               , pure_name   = pure_name }+  return $ case needJoin monad_names [one] (Just pure_expr) of+    (False, one') -> (one', emptyNameSet)+    (True, _) -> ([one], emptyNameSet) rearrangeForApplicativeDo ctxt stmts0 = do   optimal_ado <- goptM Opt_OptimalApplicativeDo   let stmt_tree | optimal_ado = mkStmtTreeOptimal stmts                 | otherwise = mkStmtTreeHeuristic stmts   traceRn "rearrangeForADo" (ppr stmt_tree)-  (return_name, _) <- lookupQualifiedDoName ctxt returnMName-  (pure_name, _)   <- lookupQualifiedDoName ctxt pureAName+  (return_name, _) <- lookupQualifiedDoName (HsDoStmt ctxt) returnMName+  (pure_name, _)   <- lookupQualifiedDoName (HsDoStmt ctxt) pureAName   let monad_names = MonadNames { return_name = return_name                                , pure_name   = pure_name }   stmtTreeToStmts monad_names ctxt stmt_tree [last] last_fvs@@ -1917,8 +1958,8 @@ -- using dynamic programming.  /O(n^3)/ mkStmtTreeOptimal :: [(ExprLStmt GhcRn, FreeVars)] -> ExprStmtTree mkStmtTreeOptimal stmts =-  ASSERT(not (null stmts)) -- the empty case is handled by the caller;-                           -- we don't support empty StmtTrees.+  assert (not (null stmts)) $ -- the empty case is handled by the caller;+                              -- we don't support empty StmtTrees.   fst (arr ! (0,n))   where     n = length stmts - 1@@ -1980,7 +2021,7 @@ -- ApplicativeStmt where necessary. stmtTreeToStmts   :: MonadNames-  -> HsStmtContext GhcRn+  -> HsDoFlavour   -> ExprStmtTree   -> [ExprLStmt GhcRn]             -- ^ the "tail"   -> FreeVars                     -- ^ free variables of the tail@@ -1993,9 +2034,12 @@ -- In the spec, but we do it here rather than in the desugarer, -- because we need the typechecker to typecheck the <$> form rather than -- the bind form, which would give rise to a Monad constraint.+--+-- If we have a single let, and the last statement is @return E@ or @return $ E@,+-- change the @return@ to @pure@. stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BindStmt xbs pat rhs), _))                 tail _tail_fvs-  | not (isStrictPattern pat), (False,tail') <- needJoin monad_names tail+  | not (isStrictPattern pat), (False,tail') <- needJoin monad_names tail Nothing   -- See Note [ApplicativeDo and strict patterns]   = mkApplicativeStmt ctxt [ApplicativeArgOne                             { xarg_app_arg_one = xbsrn_failOp xbs@@ -2006,7 +2050,7 @@                       False tail' stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BodyStmt _ rhs _ _),_))                 tail _tail_fvs-  | (False,tail') <- needJoin monad_names tail+  | (False,tail') <- needJoin monad_names tail Nothing   = mkApplicativeStmt ctxt       [ApplicativeArgOne        { xarg_app_arg_one = Nothing@@ -2014,6 +2058,12 @@        , arg_expr         = rhs        , is_body_stmt     = True        }] False tail'+stmtTreeToStmts monad_names ctxt (StmtTreeOne (let_stmt@(L _ LetStmt{}),_))+                tail _tail_fvs = do+  (pure_expr, _) <- lookupQualifiedDoExpr (HsDoStmt ctxt) pureAName+  return $ case needJoin monad_names tail (Just pure_expr) of+    (False, tail') -> (let_stmt : tail', emptyNameSet)+    (True, _) -> (let_stmt : tail, emptyNameSet)  stmtTreeToStmts _monad_names _ctxt (StmtTreeOne (s,_)) tail _tail_fvs =   return (s : tail, emptyNameSet)@@ -2032,7 +2082,7 @@      -- See Note [ApplicativeDo and refutable patterns]          if any (hasRefutablePattern dflags) stmts'          then (True, tail)-         else needJoin monad_names tail+         else needJoin monad_names tail Nothing     (stmts, fvs) <- mkApplicativeStmt ctxt stmts' need_join tail'    return (stmts, unionNameSets (fvs:fvss))@@ -2064,7 +2114,7 @@         if | L _ ApplicativeStmt{} <- last stmts' ->              return (unLoc tup, emptyNameSet)            | otherwise -> do-             (ret, _) <- lookupQualifiedDoExpr ctxt returnMName+             (ret, _) <- lookupQualifiedDoExpr (HsDoStmt ctxt) returnMName              let expr = HsApp noComments (noLocA ret) tup              return (expr, emptyFVs)      return ( ApplicativeArgMany@@ -2145,7 +2195,7 @@    (\(x,y) -> \z -> C) <$> A <*> B -then it could be lazier than the standard desuraging using >>=.  See #13875+then it could be lazier than the standard desugaring using >>=.  See #13875 for more examples.  Thus, whenever we have a strict pattern match, we treat it as a@@ -2155,14 +2205,14 @@ can do with the rest of the statements in the same "do" expression. -} -isStrictPattern :: LPat (GhcPass p) -> Bool-isStrictPattern lpat =-  case unLoc lpat of+isStrictPattern :: forall p. IsPass p => LPat (GhcPass p) -> Bool+isStrictPattern (L loc pat) =+  case pat of     WildPat{}       -> False     VarPat{}        -> False     LazyPat{}       -> False     AsPat _ _ p     -> isStrictPattern p-    ParPat _ p      -> isStrictPattern p+    ParPat _ _ p _  -> isStrictPattern p     ViewPat _ _ p   -> isStrictPattern p     SigPat _ p _    -> isStrictPattern p     BangPat{}       -> True@@ -2174,7 +2224,16 @@     NPat{}          -> True     NPlusKPat{}     -> True     SplicePat{}     -> True-    XPat{}          -> panic "isStrictPattern: XPat"+    XPat ext        -> case ghcPass @p of+#if __GLASGOW_HASKELL__ < 811+      GhcPs -> dataConCantHappen ext+#endif+      GhcRn+        | HsPatExpanded _ p <- ext+        -> isStrictPattern (L loc p)+      GhcTc -> case ext of+        ExpansionPat _ p -> isStrictPattern (L loc p)+        CoPat {} -> panic "isStrictPattern: CoPat"  {- Note [ApplicativeDo and refutable patterns]@@ -2259,17 +2318,17 @@ -- it this way rather than try to ignore the return later in both the -- typechecker and the desugarer (I tried it that way first!). mkApplicativeStmt-  :: HsStmtContext GhcRn+  :: HsDoFlavour   -> [ApplicativeArg GhcRn]             -- ^ The args   -> Bool                               -- ^ True <=> need a join   -> [ExprLStmt GhcRn]        -- ^ The body statements   -> RnM ([ExprLStmt GhcRn], FreeVars) mkApplicativeStmt ctxt args need_join body_stmts-  = do { (fmap_op, fvs1) <- lookupQualifiedDoStmtName ctxt fmapName-       ; (ap_op, fvs2) <- lookupQualifiedDoStmtName ctxt apAName+  = do { (fmap_op, fvs1) <- lookupQualifiedDoStmtName (HsDoStmt ctxt) fmapName+       ; (ap_op, fvs2) <- lookupQualifiedDoStmtName (HsDoStmt ctxt) apAName        ; (mb_join, fvs3) <-            if need_join then-             do { (join_op, fvs) <- lookupQualifiedDoStmtName ctxt joinMName+             do { (join_op, fvs) <- lookupQualifiedDoStmtName (HsDoStmt ctxt) joinMName                 ; return (Just join_op, fvs) }            else              return (Nothing, emptyNameSet)@@ -2281,28 +2340,50 @@  -- | Given the statements following an ApplicativeStmt, determine whether -- we need a @join@ or not, and remove the @return@ if necessary.+--+-- We don't need @join@ if there's a single @LastStmt@ in the form of+-- @return E@, @return $ E@, @pure E@ or @pure $ E@. needJoin :: MonadNames          -> [ExprLStmt GhcRn]+            -- If this is @Just pure@, replace return by pure+            -- If this is @Nothing@, strip the return/pure+         -> Maybe (HsExpr GhcRn)          -> (Bool, [ExprLStmt GhcRn])-needJoin _monad_names [] = (False, [])  -- we're in an ApplicativeArg-needJoin monad_names  [L loc (LastStmt _ e _ t)]- | Just (arg, wasDollar) <- isReturnApp monad_names e =-       (False, [L loc (LastStmt noExtField arg (Just wasDollar) t)])-needJoin _monad_names stmts = (True, stmts)+needJoin _monad_names [] _mb_pure = (False, [])  -- we're in an ApplicativeArg+needJoin monad_names  [L loc (LastStmt _ e _ t)] mb_pure+ | Just (arg, noret) <- isReturnApp monad_names e mb_pure =+       (False, [L loc (LastStmt noExtField arg noret t)])+needJoin _monad_names stmts _mb_pure = (True, stmts) --- | @(Just e, False)@, if the expression is @return e@---   @(Just e, True)@ if the expression is @return $ e@,+-- | @(Just e, Just False)@, if the expression is @return/pure e@,+--     and the third argument is Nothing,+--   @(Just e, Just True)@ if the expression is @return/pure $ e@,+--     and the third argument is Nothing,+--   @(Just (pure e), Nothing)@ if the expression is @return/pure e@,+--     and the third argument is @Just pure_expr@,+--   @(Just (pure $ e), Nothing)@ if the expression is @return/pure $ e@,+--     and the third argument is @Just pure_expr@, --   otherwise @Nothing@. isReturnApp :: MonadNames             -> LHsExpr GhcRn-            -> Maybe (LHsExpr GhcRn, Bool)-isReturnApp monad_names (L _ (HsPar _ expr)) = isReturnApp monad_names expr-isReturnApp monad_names (L _ e) = case e of-  OpApp _ l op r | is_return l, is_dollar op -> Just (r, True)-  HsApp _ f arg  | is_return f               -> Just (arg, False)+            -- If this is @Just pure@, replace return by pure+            -- If this is @Nothing@, strip the return/pure+            -> Maybe (HsExpr GhcRn)+            -> Maybe (LHsExpr GhcRn, Maybe Bool)+isReturnApp monad_names (L _ (HsPar _ _ expr _)) mb_pure =+  isReturnApp monad_names expr mb_pure+isReturnApp monad_names (L loc e) mb_pure = case e of+  OpApp x l op r+    | Just pure_expr <- mb_pure, is_return l, is_dollar op ->+        Just (L loc (OpApp x (to_pure l pure_expr) op r), Nothing)+    | is_return l, is_dollar op -> Just (r, Just True)+  HsApp x f arg+    | Just pure_expr <- mb_pure, is_return f ->+        Just (L loc (HsApp x (to_pure f pure_expr) arg), Nothing)+    | is_return f -> Just (arg, Just False)   _otherwise -> Nothing  where-  is_var f (L _ (HsPar _ e)) = is_var f e+  is_var f (L _ (HsPar _ _ e _)) = is_var f e   is_var f (L _ (HsAppType _ e _)) = is_var f e   is_var f (L _ (HsVar _ (L _ r))) = f r        -- TODO: I don't know how to get this right for rebindable syntax@@ -2310,6 +2391,7 @@    is_return = is_var (\n -> n == return_name monad_names                          || n == pure_name monad_names)+  to_pure (L loc _) pure_expr = L loc pure_expr   is_dollar = is_var (`hasKey` dollarIdKey)  {-@@ -2329,10 +2411,15 @@ okEmpty (PatGuard {}) = True okEmpty _             = False -emptyErr :: HsStmtContext GhcRn -> SDoc-emptyErr (ParStmtCtxt {})   = text "Empty statement group in parallel comprehension"-emptyErr (TransStmtCtxt {}) = text "Empty statement group preceding 'group' or 'then'"-emptyErr ctxt               = text "Empty" <+> pprStmtContext ctxt+emptyErr :: HsStmtContext GhcRn -> TcRnMessage+emptyErr (ParStmtCtxt {})   = TcRnUnknownMessage $ mkPlainError noHints $+  text "Empty statement group in parallel comprehension"+emptyErr (TransStmtCtxt {}) = TcRnUnknownMessage $ mkPlainError noHints $+  text "Empty statement group preceding 'group' or 'then'"+emptyErr ctxt@(HsDoStmt _)  = TcRnUnknownMessage $ mkPlainError [suggestExtension LangExt.NondecreasingIndentation] $+  text "Empty" <+> pprStmtContext ctxt+emptyErr ctxt               = TcRnUnknownMessage $ mkPlainError noHints $+  text "Empty" <+> pprStmtContext ctxt  ---------------------- checkLastStmt :: AnnoBody body => HsStmtContext GhcRn@@ -2340,11 +2427,11 @@               -> RnM (LStmt GhcPs (LocatedA (body GhcPs))) checkLastStmt ctxt lstmt@(L loc stmt)   = case ctxt of-      ListComp  -> check_comp-      MonadComp -> check_comp+      HsDoStmt ListComp  -> check_comp+      HsDoStmt MonadComp -> check_comp+      HsDoStmt DoExpr{}  -> check_do+      HsDoStmt MDoExpr{} -> check_do       ArrowExpr -> check_do-      DoExpr{}  -> check_do-      MDoExpr{} -> check_do       _         -> check_other   where     check_do    -- Expect BodyStmt, and change it to LastStmt@@ -2352,7 +2439,9 @@           BodyStmt _ e _ _ -> return (L loc (mkLastStmt e))           LastStmt {}      -> return lstmt   -- "Deriving" clauses may generate a                                              -- LastStmt directly (unlike the parser)-          _                -> do { addErr (hang last_error 2 (ppr stmt)); return lstmt }+          _                -> do { addErr $ TcRnUnknownMessage $ mkPlainError noHints $+                                     (hang last_error 2 (ppr stmt))+                                 ; return lstmt }     last_error = (text "The last statement in" <+> pprAStmtContext ctxt                   <+> text "must be an expression") @@ -2372,9 +2461,9 @@   = do { dflags <- getDynFlags        ; case okStmt dflags ctxt stmt of            IsValid        -> return ()-           NotValid extra -> addErr (msg $$ extra) }+           NotValid extra -> addErr $ TcRnUnknownMessage $ mkPlainError noHints (msg $$ extra) }   where-   msg = sep [ text "Unexpected" <+> pprStmtCat stmt <+> ptext (sLit "statement")+   msg = sep [ text "Unexpected" <+> pprStmtCat stmt <+> text "statement"              , text "in" <+> pprAStmtContext ctxt ]  pprStmtCat :: Stmt (GhcPass a) body -> SDoc@@ -2401,14 +2490,20 @@   = case ctxt of       PatGuard {}        -> okPatGuardStmt stmt       ParStmtCtxt ctxt   -> okParStmt  dflags ctxt stmt-      DoExpr{}           -> okDoStmt   dflags ctxt stmt-      MDoExpr{}          -> okDoStmt   dflags ctxt stmt+      HsDoStmt flavour   -> okDoFlavourStmt dflags flavour ctxt stmt       ArrowExpr          -> okDoStmt   dflags ctxt stmt-      GhciStmtCtxt       -> okDoStmt   dflags ctxt stmt-      ListComp           -> okCompStmt dflags ctxt stmt-      MonadComp          -> okCompStmt dflags ctxt stmt       TransStmtCtxt ctxt -> okStmt dflags ctxt stmt +okDoFlavourStmt+  :: DynFlags -> HsDoFlavour -> HsStmtContext GhcRn+  -> Stmt GhcPs (LocatedA (body GhcPs)) -> Validity+okDoFlavourStmt dflags flavour ctxt stmt = case flavour of+      DoExpr{}     -> okDoStmt   dflags ctxt stmt+      MDoExpr{}    -> okDoStmt   dflags ctxt stmt+      GhciStmtCtxt -> okDoStmt   dflags ctxt stmt+      ListComp     -> okCompStmt dflags ctxt stmt+      MonadComp    -> okCompStmt dflags ctxt stmt+ ------------- okPatGuardStmt :: Stmt GhcPs (LocatedA (body GhcPs)) -> Validity okPatGuardStmt stmt@@ -2458,17 +2553,21 @@   = do  { tuple_section <- xoptM LangExt.TupleSections         ; checkErr (all tupArgPresent args || tuple_section) msg }   where-    msg = text "Illegal tuple section: use TupleSections"+    msg :: TcRnMessage+    msg = TcRnUnknownMessage $ mkPlainError noHints $+      text "Illegal tuple section: use TupleSections"  ----------sectionErr :: HsExpr GhcPs -> SDoc+sectionErr :: HsExpr GhcPs -> TcRnMessage sectionErr expr-  = hang (text "A section must be enclosed in parentheses")+  = TcRnUnknownMessage $ mkPlainError noHints $+    hang (text "A section must be enclosed in parentheses")        2 (text "thus:" <+> (parens (ppr expr))) -badIpBinds :: Outputable a => SDoc -> a -> SDoc+badIpBinds :: Outputable a => SDoc -> a -> TcRnMessage badIpBinds what binds-  = hang (text "Implicit-parameter bindings illegal in" <+> what)+  = TcRnUnknownMessage $ mkPlainError noHints $+    hang (text "Implicit-parameter bindings illegal in" <+> what)          2 (ppr binds)  ---------@@ -2560,29 +2659,6 @@ *                                                                      * ********************************************************************* -} -genHsApps :: Name -> [LHsExpr GhcRn] -> HsExpr GhcRn-genHsApps fun args = foldl genHsApp (genHsVar fun) args--genHsApp :: HsExpr GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn-genHsApp fun arg = HsApp noAnn (wrapGenSpan fun) arg--genLHsVar :: Name -> LHsExpr GhcRn-genLHsVar nm = wrapGenSpan $ genHsVar nm--genHsVar :: Name -> HsExpr GhcRn-genHsVar nm = HsVar noExtField $ wrapGenSpan nm--genAppType :: HsExpr GhcRn -> HsType (NoGhcTc GhcRn) -> HsExpr GhcRn-genAppType expr = HsAppType noExtField (wrapGenSpan expr) . mkEmptyWildCardBndrs . wrapGenSpan--genHsTyLit :: FastString -> HsType GhcRn-genHsTyLit = HsTyLit noExtField . HsStrTy NoSourceText--wrapGenSpan :: a -> LocatedAn an a--- Wrap something in a "generatedSrcSpan"--- See Note [Rebindable syntax and HsExpansion]-wrapGenSpan x = L (noAnnSrcSpan generatedSrcSpan) x- -- | Build a 'HsExpansion' out of an extension constructor, --   and the two components of the expansion: original and --   desugared expressions.@@ -2599,42 +2675,42 @@  -- mkGetField arg field calcuates a get_field @field arg expression. -- e.g. z.x = mkGetField z x = get_field @x z-mkGetField :: Name -> LHsExpr GhcRn -> Located FieldLabelString -> HsExpr GhcRn+mkGetField :: Name -> LHsExpr GhcRn -> LocatedAn NoEpAnns FieldLabelString -> HsExpr GhcRn mkGetField get_field arg field = unLoc (head $ mkGet get_field [arg] field)  -- mkSetField a field b calculates a set_field @field expression. -- e.g mkSetSetField a field b = set_field @"field" a b (read as "set field 'field' on a to b").-mkSetField :: Name -> LHsExpr GhcRn -> Located FieldLabelString -> LHsExpr GhcRn -> HsExpr GhcRn+mkSetField :: Name -> LHsExpr GhcRn -> LocatedAn NoEpAnns FieldLabelString -> LHsExpr GhcRn -> HsExpr GhcRn mkSetField set_field a (L _ field) b =   genHsApp (genHsApp (genHsVar set_field `genAppType` genHsTyLit field)  a) b -mkGet :: Name -> [LHsExpr GhcRn] -> Located FieldLabelString -> [LHsExpr GhcRn]+mkGet :: Name -> [LHsExpr GhcRn] -> LocatedAn NoEpAnns FieldLabelString -> [LHsExpr GhcRn] mkGet get_field l@(r : _) (L _ field) =   wrapGenSpan (genHsApp (genHsVar get_field `genAppType` genHsTyLit field) r) : l mkGet _ [] _ = panic "mkGet : The impossible has happened!" -mkSet :: Name -> LHsExpr GhcRn -> (Located FieldLabelString, LHsExpr GhcRn) -> LHsExpr GhcRn+mkSet :: Name -> LHsExpr GhcRn -> (LocatedAn NoEpAnns FieldLabelString, LHsExpr GhcRn) -> LHsExpr GhcRn mkSet set_field acc (field, g) = wrapGenSpan (mkSetField set_field g field acc)  -- mkProjection fields calculates a projection. -- e.g. .x = mkProjection [x] = getField @"x" --      .x.y = mkProjection [.x, .y] = (.y) . (.x) = getField @"y" . getField @"x"-mkProjection :: Name -> Name -> NonEmpty (Located FieldLabelString) -> HsExpr GhcRn+mkProjection :: Name -> Name -> NonEmpty (LocatedAn NoEpAnns FieldLabelString) -> HsExpr GhcRn mkProjection getFieldName circName (field :| fields) = foldl' f (proj field) fields   where-    f :: HsExpr GhcRn -> Located FieldLabelString -> HsExpr GhcRn+    f :: HsExpr GhcRn -> LocatedAn NoEpAnns FieldLabelString -> HsExpr GhcRn     f acc field = genHsApps circName $ map wrapGenSpan [proj field, acc] -    proj :: Located FieldLabelString -> HsExpr GhcRn+    proj :: LocatedAn NoEpAnns FieldLabelString -> HsExpr GhcRn     proj (L _ f) = genHsVar getFieldName `genAppType` genHsTyLit f  -- mkProjUpdateSetField calculates functions representing dot notation record updates. -- e.g. Suppose an update like foo.bar = 1. --      We calculate the function \a -> setField @"foo" a (setField @"bar" (getField @"foo" a) 1). mkProjUpdateSetField :: Name -> Name -> LHsRecProj GhcRn (LHsExpr GhcRn) -> (LHsExpr GhcRn -> LHsExpr GhcRn)-mkProjUpdateSetField get_field set_field (L _ (HsRecField { hsRecFieldLbl = (L _ (FieldLabelStrings flds')), hsRecFieldArg = arg } ))+mkProjUpdateSetField get_field set_field (L _ (HsFieldBind { hfbLHS = (L _ (FieldLabelStrings flds')), hfbRHS = arg } ))   = let {-      ; flds = map (fmap (unLoc . hflLabel)) flds'+      ; flds = map (fmap (unLoc . dfoLabel)) flds'       ; final = last flds  -- quux       ; fields = init flds   -- [foo, bar, baz]       ; getters = \a -> foldl' (mkGet get_field) [a] fields  -- Ordered from deep to shallow.@@ -2657,9 +2733,11 @@   pure (u, plusFVs fvs)   where     rnRecUpdProj :: LHsRecUpdProj GhcPs -> RnM (LHsRecUpdProj GhcRn, FreeVars)-    rnRecUpdProj (L l (HsRecField _ fs arg pun))+    rnRecUpdProj (L l (HsFieldBind _ fs arg pun))       = do { (arg, fv) <- rnLExpr arg-           ; return $ (L l (HsRecField { hsRecFieldAnn = noAnn-                                       , hsRecFieldLbl = fmap rnFieldLabelStrings fs-                                       , hsRecFieldArg = arg-                                       , hsRecPun = pun}), fv) }+           ; return $+               (L l (HsFieldBind {+                         hfbAnn = noAnn+                       , hfbLHS = fmap rnFieldLabelStrings fs+                       , hfbRHS = arg+                       , hfbPun = pun}), fv ) }
GHC/Rename/Expr.hs-boot view
@@ -1,6 +1,12 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ConstraintKinds #-} module GHC.Rename.Expr where++#if MIN_VERSION_GLASGOW_HASKELL(9,3,0,0)+import Data.Type.Equality (type (~))+#endif+ import GHC.Types.Name import GHC.Hs import GHC.Types.Name.Set ( FreeVars )
GHC/Rename/Fixity.hs view
@@ -30,15 +30,11 @@ import GHC.Types.SrcLoc  import GHC.Utils.Outputable-import GHC.Utils.Panic  import GHC.Data.Maybe  import GHC.Rename.Unbound -import Data.List (groupBy)-import Data.Function    ( on )- {- ********************************************************* *                                                      *@@ -184,39 +180,10 @@ lookupTyFixityRn :: LocatedN Name -> RnM Fixity lookupTyFixityRn = lookupFixityRn . unLoc --- | Look up the fixity of a (possibly ambiguous) occurrence of a record field--- selector.  We use 'lookupFixityRn'' so that we can specify the 'OccName' as--- the field label, which might be different to the 'OccName' of the selector--- 'Name' if @DuplicateRecordFields@ is in use (#1173). If there are--- multiple possible selectors with different fixities, generate an error.-lookupFieldFixityRn :: AmbiguousFieldOcc GhcRn -> RnM Fixity-lookupFieldFixityRn (Unambiguous n lrdr)+-- | Look up the fixity of an occurrence of a record field selector.+-- We use 'lookupFixityRn'' so that we can specify the 'OccName' as+-- the field label, which might be different to the 'OccName' of the+-- selector 'Name' if @DuplicateRecordFields@ is in use (#1173).+lookupFieldFixityRn :: FieldOcc GhcRn -> RnM Fixity+lookupFieldFixityRn (FieldOcc n lrdr)   = lookupFixityRn' n (rdrNameOcc (unLoc lrdr))-lookupFieldFixityRn (Ambiguous _ lrdr) = get_ambiguous_fixity (unLoc lrdr)-  where-    get_ambiguous_fixity :: RdrName -> RnM Fixity-    get_ambiguous_fixity rdr_name = do-      traceRn "get_ambiguous_fixity" (ppr rdr_name)-      rdr_env <- getGlobalRdrEnv-      let elts =  lookupGRE_RdrName rdr_name rdr_env--      fixities <- groupBy ((==) `on` snd) . zip elts-                  <$> mapM lookup_gre_fixity elts--      case fixities of-        -- There should always be at least one fixity.-        -- Something's very wrong if there are no fixity candidates, so panic-        [] -> panic "get_ambiguous_fixity: no candidates for a given RdrName"-        [ (_, fix):_ ] -> return fix-        ambigs -> addErr (ambiguous_fixity_err rdr_name ambigs)-                  >> return (Fixity NoSourceText minPrecedence InfixL)--    lookup_gre_fixity gre = lookupFixityRn' (greMangledName gre) (greOccName gre)--    ambiguous_fixity_err rn ambigs-      = vcat [ text "Ambiguous fixity for record field" <+> quotes (ppr rn)-             , hang (text "Conflicts: ") 2 . vcat .-               map format_ambig $ concat ambigs ]--    format_ambig (elt, fix) = hang (ppr fix)-                                 2 (pprNameProvenance elt)
GHC/Rename/HsType.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP                 #-}+ {-# LANGUAGE DataKinds           #-} {-# LANGUAGE FlexibleContexts    #-} {-# LANGUAGE LambdaCase          #-}@@ -12,7 +12,7 @@  module GHC.Rename.HsType (         -- Type related stuff-        rnHsType, rnLHsType, rnLHsTypes, rnContext,+        rnHsType, rnLHsType, rnLHsTypes, rnContext, rnMaybeContext,         rnHsKind, rnLHsKind, rnLHsTypeArgs,         rnHsSigType, rnHsWcType, rnHsPatSigTypeBindingVars,         HsPatSigTypeScoping(..), rnHsSigWcType, rnHsPatSigType,@@ -32,7 +32,7 @@         bindHsOuterTyVarBndrs, bindHsForAllTelescope,         bindLHsTyVarBndr, bindLHsTyVarBndrs, WarnUnusedForalls(..),         rnImplicitTvOccs, bindSigTyVarsFV, bindHsQTyVars,-        FreeKiTyVars,+        FreeKiTyVars, filterInScopeM,         extractHsTyRdrTyVars, extractHsTyRdrTyVarsKindVars,         extractHsTysRdrTyVars, extractRdrKindSigVars,         extractConDeclGADTDetailsTyVars, extractDataDefnKindVars,@@ -48,28 +48,33 @@ import GHC.Driver.Session import GHC.Hs import GHC.Rename.Env-import GHC.Rename.Utils  ( HsDocContext(..), inHsDocContext, withHsDocContext-                         , mapFvRn, pprHsDocContext, bindLocalNamesFV+import GHC.Rename.Doc+import GHC.Rename.Utils  ( mapFvRn, bindLocalNamesFV                          , typeAppErr, newLocalBndrRn, checkDupRdrNamesN-                         , checkShadowedRdrNames )+                         , checkShadowedRdrNames, warnForallIdentifier ) import GHC.Rename.Fixity ( lookupFieldFixityRn, lookupFixityRn                          , lookupTyFixityRn )-import GHC.Rename.Unbound ( notInScopeErr )+import GHC.Rename.Unbound ( notInScopeErr, WhereLooking(WL_LocalOnly) )+import GHC.Tc.Errors.Types+import GHC.Tc.Errors.Ppr ( pprScopeError+                         , inHsDocContext, withHsDocContext, pprHsDocContext ) import GHC.Tc.Utils.Monad import GHC.Types.Name.Reader import GHC.Builtin.Names+import GHC.Types.Hint ( UntickedPromotedThing(..) ) import GHC.Types.Name import GHC.Types.SrcLoc import GHC.Types.Name.Set import GHC.Types.FieldLabel+import GHC.Types.Error  import GHC.Utils.Misc import GHC.Types.Fixity ( compareFixity, negateFixity                         , Fixity(..), FixityDirection(..), LexicalFixity(..) )-import GHC.Types.Basic  ( TypeOrKind(..) )+import GHC.Types.Basic  ( PromotionFlag(..), isPromoted, TypeOrKind(..) ) import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Data.FastString+import GHC.Utils.Panic.Plain import GHC.Data.Maybe import qualified GHC.LanguageExtensions as LangExt @@ -78,8 +83,6 @@ import Data.List.NonEmpty (NonEmpty(..)) import Control.Monad -#include "HsVersions.h"- {- These type renamers are in a separate module, rather than in (say) GHC.Rename.Module, to break several loops.@@ -210,7 +213,7 @@     -- Should the inner `a` refer to the outer one? shadow it? We are, as yet, undecided,     -- so we currently reject.     when (not (null varsInScope)) $-      addErr $+      addErr $ TcRnUnknownMessage $ mkPlainError noHints $         vcat           [ text "Type variable" <> plural varsInScope             <+> hcat (punctuate (text ",") (map (quotes . ppr) varsInScope))@@ -257,34 +260,27 @@                                 , hst_tele = tele', hst_body = hs_body' }                     , fvs) } -    rn_ty env (HsQualTy { hst_ctxt = m_ctxt+    rn_ty env (HsQualTy { hst_ctxt = L cx hs_ctxt                         , hst_body = hs_ty })-      | Just (L cx hs_ctxt) <- m_ctxt-      , Just (hs_ctxt1, hs_ctxt_last) <- snocView hs_ctxt+      | Just (hs_ctxt1, hs_ctxt_last) <- snocView hs_ctxt       , L lx (HsWildCardTy _)  <- ignoreParens hs_ctxt_last       = do { (hs_ctxt1', fvs1) <- mapFvRn (rn_top_constraint env) hs_ctxt1            ; setSrcSpanA lx $ checkExtraConstraintWildCard env hs_ctxt1            ; let hs_ctxt' = hs_ctxt1' ++ [L lx (HsWildCardTy noExtField)]            ; (hs_ty', fvs2) <- rnLHsTyKi env hs_ty            ; return (HsQualTy { hst_xqual = noExtField-                              , hst_ctxt = Just (L cx hs_ctxt')+                              , hst_ctxt = L cx hs_ctxt'                               , hst_body = hs_ty' }                     , fvs1 `plusFV` fvs2) } -      | Just (L cx hs_ctxt) <- m_ctxt+      | otherwise       = do { (hs_ctxt', fvs1) <- mapFvRn (rn_top_constraint env) hs_ctxt            ; (hs_ty', fvs2)   <- rnLHsTyKi env hs_ty            ; return (HsQualTy { hst_xqual = noExtField-                              , hst_ctxt = Just (L cx hs_ctxt')+                              , hst_ctxt = L cx hs_ctxt'                               , hst_body = hs_ty' }                     , fvs1 `plusFV` fvs2) } -      | Nothing <- m_ctxt-      = do { (hs_ty', fvs2)   <- rnLHsTyKi env hs_ty-           ; return (HsQualTy { hst_xqual = noExtField-                              , hst_ctxt = Nothing-                              , hst_body = hs_ty' }-                    , fvs2) }      rn_ty env hs_ty = rnHsTyKi env hs_ty @@ -297,10 +293,11 @@ -- Check that extra-constraints are allowed at all, and -- if so that it's an anonymous wildcard checkExtraConstraintWildCard env hs_ctxt-  = checkWildCard env mb_bad+  = checkWildCard env Nothing mb_bad   where     mb_bad | not (extraConstraintWildCardsAllowed env)-           = Just base_msg+           = Just $ ExtraConstraintWildcardNotAllowed+                      SoleExtraConstraintWildcardNotAllowed              -- Currently, we do not allow wildcards in their full glory in              -- standalone deriving declarations. We only allow a single              -- extra-constraints wildcard à la:@@ -312,18 +309,11 @@              --   deriving instance (Eq a, _) => Eq (Foo a)            | DerivDeclCtx {} <- rtke_ctxt env            , not (null hs_ctxt)-           = Just deriv_decl_msg+           = Just $ ExtraConstraintWildcardNotAllowed+                      SoleExtraConstraintWildcardAllowed            | otherwise            = Nothing -    base_msg = text "Extra-constraint wildcard" <+> quotes pprAnonWildCard-                   <+> text "not allowed"--    deriv_decl_msg-      = hang base_msg-           2 (vcat [ text "except as the sole constraint"-                   , nest 2 (text "e.g., deriving instance _ => Eq (Foo a)") ])- extraConstraintWildCardsAllowed :: RnTyKiEnv -> Bool extraConstraintWildCardsAllowed env   = case rtke_ctxt env of@@ -453,8 +443,11 @@ rnImplicitTvBndrs ctx mb_assoc implicit_vs_with_dups thing_inside   = do { implicit_vs <- forM (NE.groupBy eqLocated $ sortBy cmpLocated $ implicit_vs_with_dups) $ \case            (x :| []) -> return x-           (x :| _) -> do addErr $ text "Variable" <+> text "`" <> ppr x <> text "'" <+> text "would be bound multiple times by" <+> pprHsDocContext ctx <> text "."-                          return x+           (x :| _) -> do+             let msg = TcRnUnknownMessage $ mkPlainError noHints $+                   text "Variable" <+> text "`" <> ppr x <> text "'" <+> text "would be bound multiple times by" <+> pprHsDocContext ctx <> text "."+             addErr msg+             return x         ; traceRn "rnImplicitTvBndrs" $          vcat [ ppr implicit_vs_with_dups, ppr implicit_vs ]@@ -577,19 +570,27 @@ rnLHsTypeArgs doc args = mapFvRn (rnLHsTypeArg doc) args  ---------------rnTyKiContext :: RnTyKiEnv -> Maybe (LHsContext GhcPs)-              -> RnM (Maybe (LHsContext GhcRn), FreeVars)-rnTyKiContext _ Nothing = return (Nothing, emptyFVs)-rnTyKiContext env (Just (L loc cxt))+rnTyKiContext :: RnTyKiEnv -> LHsContext GhcPs+              -> RnM (LHsContext GhcRn, FreeVars)+rnTyKiContext env (L loc cxt)   = do { traceRn "rncontext" (ppr cxt)        ; let env' = env { rtke_what = RnConstraint }        ; (cxt', fvs) <- mapFvRn (rnLHsTyKi env') cxt-       ; return (Just $ L loc cxt', fvs) }+       ; return (L loc cxt', fvs) } -rnContext :: HsDocContext -> Maybe (LHsContext GhcPs)-          -> RnM (Maybe (LHsContext GhcRn), FreeVars)+rnContext :: HsDocContext -> LHsContext GhcPs+          -> RnM (LHsContext GhcRn, FreeVars) rnContext doc theta = rnTyKiContext (mkTyKiEnv doc TypeLevel RnConstraint) theta +rnMaybeContext :: HsDocContext -> Maybe (LHsContext GhcPs)+          -> RnM (Maybe (LHsContext GhcRn), FreeVars)+rnMaybeContext _ Nothing = return (Nothing, emptyFVs)+rnMaybeContext doc (Just theta)+  = do { (theta', fvs) <- rnContext doc theta+       ; return (Just theta', fvs)+       }++ -------------- rnLHsTyKi  :: RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars) rnLHsTyKi env (L loc ty)@@ -619,22 +620,28 @@  rnHsTyKi env (HsTyVar _ ip (L loc rdr_name))   = do { when (isRnKindLevel env && isRdrTyVar rdr_name) $-         unlessXOptM LangExt.PolyKinds $ addErr $+         unlessXOptM LangExt.PolyKinds $ addErr $ TcRnUnknownMessage $ mkPlainError noHints $          withHsDocContext (rtke_ctxt env) $          vcat [ text "Unexpected kind variable" <+> quotes (ppr rdr_name)               , text "Perhaps you intended to use PolyKinds" ]            -- Any type variable at the kind level is illegal without the use            -- of PolyKinds (see #14710)        ; name <- rnTyVar env rdr_name+       ; when (isDataConName name && not (isPromoted ip)) $+         -- NB: a prefix symbolic operator such as (:) is represented as HsTyVar.+            addDiagnostic (TcRnUntickedPromotedThing $ UntickedConstructor Prefix name)        ; return (HsTyVar noAnn ip (L loc name), unitFV name) } -rnHsTyKi env ty@(HsOpTy _ ty1 l_op ty2)+rnHsTyKi env ty@(HsOpTy _ prom ty1 l_op ty2)   = setSrcSpan (getLocA l_op) $-    do  { (l_op', fvs1) <- rnHsTyOp env ty l_op+    do  { (l_op', fvs1) <- rnHsTyOp env (ppr ty) l_op+        ; let op_name = unLoc l_op'         ; fix   <- lookupTyFixityRn l_op'         ; (ty1', fvs2) <- rnLHsTyKi env ty1         ; (ty2', fvs3) <- rnLHsTyKi env ty2-        ; res_ty <- mkHsOpTyRn l_op' fix ty1' ty2'+        ; res_ty <- mkHsOpTyRn prom l_op' fix ty1' ty2'+        ; when (isDataConName op_name && not (isPromoted prom)) $+            addDiagnostic (TcRnUntickedPromotedThing $ UntickedConstructor Infix op_name)         ; return (res_ty, plusFVs [fvs1, fvs2, fvs3]) }  rnHsTyKi env (HsParTy _ ty)@@ -654,8 +661,8 @@     get_fields (ConDeclCtx names)       = concatMapM (lookupConstructorFields . unLoc) names     get_fields _-      = do { addErr (hang (text "Record syntax is illegal here:")-                                   2 (ppr ty))+      = do { addErr $ TcRnUnknownMessage $ mkPlainError noHints $+               (hang (text "Record syntax is illegal here:") 2 (ppr ty))            ; return [] }  rnHsTyKi env (HsFunTy u mult ty1 ty2)@@ -705,7 +712,9 @@     negLit (HsStrTy _ _) = False     negLit (HsNumTy _ i) = i < 0     negLit (HsCharTy _ _) = False-    negLitErr = text "Illegal literal in type (type literals must not be negative):" <+> ppr tyLit+    negLitErr :: TcRnMessage+    negLitErr = TcRnUnknownMessage $ mkPlainError noHints $+      text "Illegal literal in type (type literals must not be negative):" <+> ppr tyLit  rnHsTyKi env (HsAppTy _ ty1 ty2)   = do { (ty1', fvs1) <- rnLHsTyKi env ty1@@ -732,7 +741,8 @@  rnHsTyKi env (HsDocTy x ty haddock_doc)   = do { (ty', fvs) <- rnLHsTyKi env ty-       ; return (HsDocTy x ty' haddock_doc, fvs) }+       ; haddock_doc' <- rnLHsDoc haddock_doc+       ; return (HsDocTy x ty' haddock_doc', fvs) }  -- See Note [Renaming HsCoreTys] rnHsTyKi env (XHsType ty)@@ -745,14 +755,18 @@     check_in_scope :: RdrName -> RnM ()     check_in_scope rdr_name = do       mb_name <- lookupLocalOccRn_maybe rdr_name+      -- TODO: refactor this to avoid TcRnUnknownMessage       when (isNothing mb_name) $-        addErr $ withHsDocContext (rtke_ctxt env) $-        notInScopeErr rdr_name+        addErr $ TcRnUnknownMessage $ mkPlainError noHints $+          withHsDocContext (rtke_ctxt env) $+          pprScopeError rdr_name (notInScopeErr WL_LocalOnly rdr_name)  rnHsTyKi env ty@(HsExplicitListTy _ ip tys)   = do { data_kinds <- xoptM LangExt.DataKinds        ; unless data_kinds (addErr (dataKindsErr env ty))        ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys+       ; unless (isPromoted ip) $+           addDiagnostic (TcRnUntickedPromotedThing $ UntickedExplicitList)        ; return (HsExplicitListTy noExtField ip tys', fvs) }  rnHsTyKi env ty@(HsExplicitTupleTy _ tys)@@ -766,10 +780,11 @@        ; return (HsWildCardTy noExtField, emptyFVs) }  rnHsArrow :: RnTyKiEnv -> HsArrow GhcPs -> RnM (HsArrow GhcRn, FreeVars)-rnHsArrow _env (HsUnrestrictedArrow u) = return (HsUnrestrictedArrow u, emptyFVs)-rnHsArrow _env (HsLinearArrow u a) = return (HsLinearArrow u a, emptyFVs)-rnHsArrow env (HsExplicitMult u a p)-  = (\(mult, fvs) -> (HsExplicitMult u a mult, fvs)) <$> rnLHsTyKi env p+rnHsArrow _env (HsUnrestrictedArrow arr) = return (HsUnrestrictedArrow arr, emptyFVs)+rnHsArrow _env (HsLinearArrow (HsPct1 pct1 arr)) = return (HsLinearArrow (HsPct1 pct1 arr), emptyFVs)+rnHsArrow _env (HsLinearArrow (HsLolly arr)) = return (HsLinearArrow (HsLolly arr), emptyFVs)+rnHsArrow env (HsExplicitMult pct p arr)+  = (\(mult, fvs) -> (HsExplicitMult pct mult arr, fvs)) <$> rnLHsTyKi env p  {- Note [Renaming HsCoreTys]@@ -818,57 +833,50 @@        ; return (L loc tyvar) }  ---------------rnHsTyOp :: Outputable a-         => RnTyKiEnv -> a -> LocatedN RdrName+rnHsTyOp :: RnTyKiEnv -> SDoc -> LocatedN RdrName          -> RnM (LocatedN Name, FreeVars) rnHsTyOp env overall_ty (L loc op)-  = do { ops_ok <- xoptM LangExt.TypeOperators-       ; op' <- rnTyVar env op-       ; unless (ops_ok || op' `hasKey` eqTyConKey) $-           addErr (opTyErr op overall_ty)-       ; let l_op' = L loc op'-       ; return (l_op', unitFV op') }+  = do { op' <- rnTyVar env op+       ; unlessXOptM LangExt.TypeOperators $+           if (op' `hasKey` eqTyConKey) -- See [eqTyCon (~) compatibility fallback] in GHC.Rename.Env+           then addDiagnostic TcRnTypeEqualityRequiresOperators+           else addErr $ TcRnIllegalTypeOperator overall_ty op+       ; return (L loc op', unitFV op') }  ---------------notAllowed :: SDoc -> SDoc-notAllowed doc-  = text "Wildcard" <+> quotes doc <+> ptext (sLit "not allowed")--checkWildCard :: RnTyKiEnv -> Maybe SDoc -> RnM ()-checkWildCard env (Just doc)-  = addErr $ vcat [doc, nest 2 (text "in" <+> pprHsDocContext (rtke_ctxt env))]-checkWildCard _ Nothing+checkWildCard :: RnTyKiEnv+              -> Maybe Name -- ^ name of the wildcard,+                            -- or 'Nothing' for an anonymous wildcard+              -> Maybe BadAnonWildcardContext+              -> RnM ()+checkWildCard env mb_name (Just bad)+  = addErr $ TcRnIllegalWildcardInType mb_name bad (Just $ rtke_ctxt env)+checkWildCard _ _ Nothing   = return ()  checkAnonWildCard :: RnTyKiEnv -> RnM () -- Report an error if an anonymous wildcard is illegal here checkAnonWildCard env-  = checkWildCard env mb_bad+  = checkWildCard env Nothing mb_bad   where-    mb_bad :: Maybe SDoc+    mb_bad :: Maybe BadAnonWildcardContext     mb_bad | not (wildCardsAllowed env)-           = Just (notAllowed pprAnonWildCard)+           = Just WildcardsNotAllowedAtAll            | otherwise            = case rtke_what env of                RnTypeBody      -> Nothing-               RnTopConstraint -> Just constraint_msg-               RnConstraint    -> Just constraint_msg--    constraint_msg = hang-                         (notAllowed pprAnonWildCard <+> text "in a constraint")-                        2 hint_msg-    hint_msg = vcat [ text "except as the last top-level constraint of a type signature"-                    , nest 2 (text "e.g  f :: (Eq a, _) => blah") ]+               RnTopConstraint -> Just WildcardNotLastInConstraint+               RnConstraint    -> Just WildcardNotLastInConstraint  checkNamedWildCard :: RnTyKiEnv -> Name -> RnM () -- Report an error if a named wildcard is illegal here checkNamedWildCard env name-  = checkWildCard env mb_bad+  = checkWildCard env (Just name) mb_bad   where     mb_bad | not (name `elemNameSet` rtke_nwcs env)            = Nothing  -- Not a wildcard            | not (wildCardsAllowed env)-           = Just (notAllowed (ppr name))+           = Just WildcardsNotAllowedAtAll            | otherwise            = case rtke_what env of                RnTypeBody      -> Nothing   -- Allowed@@ -876,8 +884,7 @@                   -- f :: (Eq _a) => _a -> Int                   -- g :: (_a, _b) => T _a _b -> Int                   -- The named tyvars get filled in from elsewhere-               RnConstraint    -> Just constraint_msg-    constraint_msg = notAllowed (ppr name) <+> text "in a constraint"+               RnConstraint    -> Just WildcardNotLastInConstraint  wildCardsAllowed :: RnTyKiEnv -> Bool -- ^ In what contexts are wildcards permitted@@ -907,8 +914,9 @@   | isRnKindLevel env   = do { polykinds <- xoptM LangExt.PolyKinds        ; unless polykinds $-         addErr (text "Illegal kind:" <+> ppr ty $$-                 text "Did you mean to enable PolyKinds?") }+         addErr $ TcRnUnknownMessage $ mkPlainError noHints $+           (text "Illegal kind:" <+> ppr ty $$+            text "Did you mean to enable PolyKinds?") } checkPolyKinds _ _ = return ()  notInKinds :: Outputable ty@@ -917,7 +925,8 @@            -> RnM () notInKinds env ty   | isRnKindLevel env-  = addErr (text "Illegal kind:" <+> ppr ty)+  = addErr $ TcRnUnknownMessage $ mkPlainError noHints $+     text "Illegal kind:" <+> ppr ty notInKinds _ _ = return ()  {- *****************************************************@@ -948,8 +957,8 @@               -> (LHsQTyVars GhcRn -> Bool -> RnM (b, FreeVars))                   -- The Bool is True <=> all kind variables used in the                   -- kind signature are bound on the left.  Reason:-                  -- the last clause of Note [CUSKs: Complete user-supplied-                  -- kind signatures] in GHC.Hs.Decls+                  -- the last clause of Note [CUSKs: complete user-supplied kind signatures]+                  -- in GHC.Hs.Decls               -> RnM (b, FreeVars)  -- See Note [bindHsQTyVars examples]@@ -1270,9 +1279,11 @@ rnField :: FastStringEnv FieldLabel -> RnTyKiEnv -> LConDeclField GhcPs         -> RnM (LConDeclField GhcRn, FreeVars) rnField fl_env env (L l (ConDeclField _ names ty haddock_doc))-  = do { let new_names = map (fmap (lookupField fl_env)) names+  = do { mapM_ (\(L _ (FieldOcc _ rdr_name)) -> warnForallIdentifier rdr_name) names+       ; let new_names = map (fmap (lookupField fl_env)) names        ; (new_ty, fvs) <- rnLHsTyKi env ty-       ; return (L l (ConDeclField noAnn new_names new_ty haddock_doc)+       ; haddock_doc' <- traverse rnLHsDoc haddock_doc+       ; return (L l (ConDeclField noAnn new_names new_ty haddock_doc')                 , fvs) }  lookupField :: FastStringEnv FieldLabel -> FieldOcc GhcPs -> FieldOcc GhcRn@@ -1312,33 +1323,34 @@ -}  ------------------ Building (ty1 `op1` (ty21 `op2` ty22))-mkHsOpTyRn :: LocatedN Name -> Fixity -> LHsType GhcRn -> LHsType GhcRn+-- Building (ty1 `op1` (ty2a `op2` ty2b))+mkHsOpTyRn :: PromotionFlag+           -> LocatedN Name -> Fixity -> LHsType GhcRn -> LHsType GhcRn            -> RnM (HsType GhcRn) -mkHsOpTyRn op1 fix1 ty1 (L loc2 (HsOpTy _ ty21 op2 ty22))+mkHsOpTyRn prom1 op1 fix1 ty1 (L loc2 (HsOpTy _ prom2 ty2a op2 ty2b))   = do  { fix2 <- lookupTyFixityRn op2-        ; mk_hs_op_ty op1 fix1 ty1 op2 fix2 ty21 ty22 loc2 }+        ; mk_hs_op_ty prom1 op1 fix1 ty1 prom2 op2 fix2 ty2a ty2b loc2 } -mkHsOpTyRn op1 _ ty1 ty2              -- Default case, no rearrangment-  = return (HsOpTy noExtField ty1 op1 ty2)+mkHsOpTyRn prom1 op1 _ ty1 ty2              -- Default case, no rearrangment+  = return (HsOpTy noAnn prom1 ty1 op1 ty2)  ----------------mk_hs_op_ty :: LocatedN Name -> Fixity -> LHsType GhcRn-            -> LocatedN Name -> Fixity -> LHsType GhcRn+mk_hs_op_ty :: PromotionFlag -> LocatedN Name -> Fixity -> LHsType GhcRn+            -> PromotionFlag -> LocatedN Name -> Fixity -> LHsType GhcRn             -> LHsType GhcRn -> SrcSpanAnnA             -> RnM (HsType GhcRn)-mk_hs_op_ty op1 fix1 ty1 op2 fix2 ty21 ty22 loc2+mk_hs_op_ty prom1 op1 fix1 ty1 prom2 op2 fix2 ty2a ty2b loc2   | nofix_error     = do { precParseErr (NormalOp (unLoc op1),fix1)                                         (NormalOp (unLoc op2),fix2)-                         ; return (ty1 `op1ty` (L loc2 (ty21 `op2ty` ty22))) }-  | associate_right = return (ty1 `op1ty` (L loc2 (ty21 `op2ty` ty22)))-  | otherwise       = do { -- Rearrange to ((ty1 `op1` ty21) `op2` ty22)-                           new_ty <- mkHsOpTyRn op1 fix1 ty1 ty21-                         ; return (noLocA new_ty `op2ty` ty22) }+                         ; return (ty1 `op1ty` (L loc2 (ty2a `op2ty` ty2b))) }+  | associate_right = return (ty1 `op1ty` (L loc2 (ty2a `op2ty` ty2b)))+  | otherwise       = do { -- Rearrange to ((ty1 `op1` ty2a) `op2` ty2b)+                           new_ty <- mkHsOpTyRn prom1 op1 fix1 ty1 ty2a+                         ; return (noLocA new_ty `op2ty` ty2b) }   where-    lhs `op1ty` rhs = HsOpTy noExtField lhs op1 rhs-    lhs `op2ty` rhs = HsOpTy noExtField lhs op2 rhs+    lhs `op1ty` rhs = HsOpTy noAnn prom1 lhs op1 rhs+    lhs `op2ty` rhs = HsOpTy noAnn prom2 lhs op2 rhs     (nofix_error, associate_right) = compareFixity fix1 fix2  @@ -1350,17 +1362,17 @@                                        -- be a NegApp)           -> RnM (HsExpr GhcRn) --- (e11 `op1` e12) `op2` e2-mkOpAppRn negation_handling e1@(L _ (OpApp fix1 e11 op1 e12)) op2 fix2 e2+-- (e1a `op1` e1b) `op2` e2+mkOpAppRn negation_handling e1@(L _ (OpApp fix1 e1a op1 e1b)) op2 fix2 e2   | nofix_error   = do precParseErr (get_op op1,fix1) (get_op op2,fix2)        return (OpApp fix2 e1 op2 e2)    | associate_right = do-    new_e <- mkOpAppRn negation_handling e12 op2 fix2 e2-    return (OpApp fix1 e11 op1 (L loc' new_e))+    new_e <- mkOpAppRn negation_handling e1b op2 fix2 e2+    return (OpApp fix1 e1a op1 (L loc' new_e))   where-    loc'= combineLocsA e12 e2+    loc'= combineLocsA e1b e2     (nofix_error, associate_right) = compareFixity fix1 fix2  ---------------------------@@ -1389,7 +1401,8 @@ --------------------------- --      Default case mkOpAppRn _ e1 op fix e2                  -- Default case, no rearrangment-  = ASSERT2(right_op_ok fix (unLoc e2), ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2)+  = assertPpr (right_op_ok fix (unLoc e2))+              (ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2) $     return (OpApp fix e1 op e2)  data NegationHandling = ReassociateNegation | KeepNegationIntact@@ -1397,11 +1410,10 @@ ----------------------------  -- | Name of an operator in an operator application or section-data OpName = NormalOp Name         -- ^ A normal identifier-            | NegateOp              -- ^ Prefix negation-            | UnboundOp OccName     -- ^ An unbound indentifier-            | RecFldOp (AmbiguousFieldOcc GhcRn)-              -- ^ A (possibly ambiguous) record field occurrence+data OpName = NormalOp Name             -- ^ A normal identifier+            | NegateOp                  -- ^ Prefix negation+            | UnboundOp OccName         -- ^ An unbound indentifier+            | RecFldOp (FieldOcc GhcRn) -- ^ A record field occurrence  instance Outputable OpName where   ppr (NormalOp n)   = ppr n@@ -1414,7 +1426,7 @@ -- See GHC.Rename.Expr.rnUnboundVar get_op (L _ (HsVar _ n))         = NormalOp (unLoc n) get_op (L _ (HsUnboundVar _ uv)) = UnboundOp uv-get_op (L _ (HsRecFld _ fld))    = RecFldOp fld+get_op (L _ (HsRecSel _ fld))    = RecFldOp fld get_op other                     = pprPanic "get_op" (ppr other)  -- Parser left-associates everything, but@@ -1432,7 +1444,7 @@ -- And "deriving" code should respect this (use HsPar if not) mkNegAppRn :: LHsExpr GhcRn -> SyntaxExpr GhcRn -> RnM (HsExpr GhcRn) mkNegAppRn neg_arg neg_name-  = ASSERT( not_op_app (unLoc neg_arg) )+  = assert (not_op_app (unLoc neg_arg)) $     return (NegApp noExtField neg_arg neg_name)  not_op_app :: HsExpr id -> Bool@@ -1445,20 +1457,20 @@           -> LHsCmdTop GhcRn             -- Right operand (not an infix)           -> RnM (HsCmd GhcRn) --- (e11 `op1` e12) `op2` e2-mkOpFormRn a1@(L loc+-- (e1a `op1` e1b) `op2` e2+mkOpFormRn e1@(L loc                     (HsCmdTop _                      (L _ (HsCmdArrForm x op1 f (Just fix1)-                        [a11,a12]))))-        op2 fix2 a2+                        [e1a,e1b]))))+        op2 fix2 e2   | nofix_error   = do precParseErr (get_op op1,fix1) (get_op op2,fix2)-       return (HsCmdArrForm x op2 f (Just fix2) [a1, a2])+       return (HsCmdArrForm x op2 f (Just fix2) [e1, e2])    | associate_right-  = do new_c <- mkOpFormRn a12 op2 fix2 a2+  = do new_c <- mkOpFormRn e1a op2 fix2 e2        return (HsCmdArrForm noExtField op1 f (Just fix1)-               [a11, L loc (HsCmdTop [] (L (noAnnSrcSpan loc) new_c))])+               [e1b, L loc (HsCmdTop [] (L (l2l loc) new_c))])         -- TODO: locs are wrong   where     (nofix_error, associate_right) = compareFixity fix1 fix2@@ -1472,7 +1484,7 @@ mkConOpPatRn :: LocatedN Name -> Fixity -> LPat GhcRn -> LPat GhcRn              -> RnM (Pat GhcRn) -mkConOpPatRn op2 fix2 p1@(L loc (ConPat NoExtField op1 (InfixCon p11 p12))) p2+mkConOpPatRn op2 fix2 p1@(L loc (ConPat NoExtField op1 (InfixCon p1a p1b))) p2   = do  { fix1 <- lookupFixityRn (unLoc op1)         ; let (nofix_error, associate_right) = compareFixity fix1 fix2 @@ -1487,11 +1499,11 @@                 }            else if associate_right then do-                { new_p <- mkConOpPatRn op2 fix2 p12 p2+                { new_p <- mkConOpPatRn op2 fix2 p1b p2                 ; return $ ConPat                     { pat_con_ext = noExtField                     , pat_con = op1-                    , pat_args = InfixCon p11 (L loc new_p)+                    , pat_args = InfixCon p1a (L loc new_p)                     }                 }                 -- XXX loc right?@@ -1503,7 +1515,7 @@         }  mkConOpPatRn op _ p1 p2                         -- Default case, no rearrangment-  = ASSERT( not_op_pat (unLoc p2) )+  = assert (not_op_pat (unLoc p2)) $     return $ ConPat       { pat_con_ext = noExtField       , pat_con = op@@ -1578,8 +1590,7 @@                                  (arg_op, arg_fix) section)  -- | Look up the fixity for an operator name.  Be careful to use--- 'lookupFieldFixityRn' for (possibly ambiguous) record fields--- (see #13132).+-- 'lookupFieldFixityRn' for record fields (see #13132). lookupFixityOp :: OpName -> RnM Fixity lookupFixityOp (NormalOp n)  = lookupFixityRn n lookupFixityOp NegateOp      = lookupFixityRn negateName@@ -1594,8 +1605,9 @@   | is_unbound n1 || is_unbound n2   = return ()     -- Avoid error cascade   | otherwise-  = addErr $ hang (text "Precedence parsing error")-      4 (hsep [text "cannot mix", ppr_opfix op1, ptext (sLit "and"),+  = addErr $ TcRnUnknownMessage $ mkPlainError noHints $+      hang (text "Precedence parsing error")+      4 (hsep [text "cannot mix", ppr_opfix op1, text "and",                ppr_opfix op2,                text "in the same infix expression"]) @@ -1604,7 +1616,8 @@   | is_unbound n1 || is_unbound n2   = return ()     -- Avoid error cascade   | otherwise-  = addErr $ vcat [text "The operator" <+> ppr_opfix op <+> ptext (sLit "of a section"),+  = addErr $ TcRnUnknownMessage $ mkPlainError noHints $+      vcat [text "The operator" <+> ppr_opfix op <+> text "of a section",          nest 4 (sep [text "must have lower precedence than that of the operand,",                       nest 2 (text "namely" <+> ppr_opfix arg_op)]),          nest 4 (text "in the section:" <+> quotes (ppr section))]@@ -1627,21 +1640,23 @@ *                                                      * ***************************************************** -} -unexpectedPatSigTypeErr :: HsPatSigType GhcPs -> SDoc+unexpectedPatSigTypeErr :: HsPatSigType GhcPs -> TcRnMessage unexpectedPatSigTypeErr ty-  = hang (text "Illegal type signature:" <+> quotes (ppr ty))+  = TcRnUnknownMessage $ mkPlainError noHints $+    hang (text "Illegal type signature:" <+> quotes (ppr ty))        2 (text "Type signatures are only allowed in patterns with ScopedTypeVariables")  badKindSigErr :: HsDocContext -> LHsType GhcPs -> TcM () badKindSigErr doc (L loc ty)-  = setSrcSpanA loc $ addErr $+  = setSrcSpanA loc $ addErr $ TcRnUnknownMessage $ mkPlainError noHints $     withHsDocContext doc $     hang (text "Illegal kind signature:" <+> quotes (ppr ty))        2 (text "Perhaps you intended to use KindSignatures") -dataKindsErr :: RnTyKiEnv -> HsType GhcPs -> SDoc+dataKindsErr :: RnTyKiEnv -> HsType GhcPs -> TcRnMessage dataKindsErr env thing-  = hang (text "Illegal" <+> pp_what <> colon <+> quotes (ppr thing))+  = TcRnUnknownMessage $ mkPlainError noHints $+    hang (text "Illegal" <+> pp_what <> colon <+> quotes (ppr thing))        2 (text "Perhaps you intended to use DataKinds")   where     pp_what | isRnKindLevel env = text "kind"@@ -1650,16 +1665,12 @@ warnUnusedForAll :: OutputableBndrFlag flag 'Renamed                  => HsDocContext -> LHsTyVarBndr flag GhcRn -> FreeVars -> TcM () warnUnusedForAll doc (L loc tv) used_names-  = whenWOptM Opt_WarnUnusedForalls $-    unless (hsTyVarName tv `elemNameSet` used_names) $-    addWarnAt (Reason Opt_WarnUnusedForalls) (locA loc) $-    vcat [ text "Unused quantified type variable" <+> quotes (ppr tv)-         , inHsDocContext doc ]--opTyErr :: Outputable a => RdrName -> a -> SDoc-opTyErr op overall_ty-  = hang (text "Illegal operator" <+> quotes (ppr op) <+> ptext (sLit "in type") <+> quotes (ppr overall_ty))-         2 (text "Use TypeOperators to allow operators in types")+  = unless (hsTyVarName tv `elemNameSet` used_names) $ do+      let msg = TcRnUnknownMessage $+            mkPlainDiagnostic (WarningWithFlag Opt_WarnUnusedForalls) noHints $+              vcat [ text "Unused quantified type variable" <+> quotes (ppr tv)+                   , inHsDocContext doc ]+      addDiagnosticAt (locA loc) msg  {- ************************************************************************@@ -1898,8 +1909,8 @@ extractConDeclGADTDetailsTyVars ::   HsConDeclGADTDetails GhcPs -> FreeKiTyVars -> FreeKiTyVars extractConDeclGADTDetailsTyVars con_args = case con_args of-  PrefixConGADT args    -> extract_scaled_ltys args-  RecConGADT (L _ flds) -> extract_ltys $ map (cd_fld_type . unLoc) $ flds+  PrefixConGADT args      -> extract_scaled_ltys args+  RecConGADT (L _ flds) _ -> extract_ltys $ map (cd_fld_type . unLoc) $ flds  -- | Get type/kind variables mentioned in the kind signature, preserving -- left-to-right order:@@ -1912,9 +1923,8 @@ extractDataDefnKindVars (HsDataDefn { dd_kindSig = ksig })   = maybe [] extractHsTyRdrTyVars ksig -extract_lctxt :: Maybe (LHsContext GhcPs) -> FreeKiTyVars -> FreeKiTyVars-extract_lctxt Nothing     = id-extract_lctxt (Just ctxt) = extract_ltys (unLoc ctxt)+extract_lctxt :: LHsContext GhcPs -> FreeKiTyVars -> FreeKiTyVars+extract_lctxt ctxt = extract_ltys (unLoc ctxt)  extract_scaled_ltys :: [HsScaled GhcPs (LHsType GhcPs)]                     -> FreeKiTyVars -> FreeKiTyVars@@ -1946,7 +1956,7 @@                                      extract_lty ty2 $                                      extract_hs_arrow w acc       HsIParamTy _ _ ty           -> extract_lty ty acc-      HsOpTy _ ty1 tv ty2         -> extract_tv tv $+      HsOpTy _ _ ty1 tv ty2       -> extract_tv tv $                                      extract_lty ty1 $                                      extract_lty ty2 acc       HsParTy _ ty                -> extract_lty ty acc@@ -1974,7 +1984,7 @@  extract_hs_arrow :: HsArrow GhcPs -> FreeKiTyVars ->                    FreeKiTyVars-extract_hs_arrow (HsExplicitMult _ _ p) acc = extract_lty p acc+extract_hs_arrow (HsExplicitMult _ p _) acc = extract_lty p acc extract_hs_arrow _ acc = acc  extract_hs_for_all_telescope :: HsForAllTelescope GhcPs
GHC/Rename/Module.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP                 #-}+ {-# LANGUAGE FlexibleContexts    #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies        #-}@@ -13,30 +13,32 @@ -}  module GHC.Rename.Module (-        rnSrcDecls, addTcgDUs, findSplice+        rnSrcDecls, addTcgDUs, findSplice, rnWarningTxt     ) where -#include "HsVersions.h"- import GHC.Prelude  import {-# SOURCE #-} GHC.Rename.Expr( rnLExpr ) import {-# SOURCE #-} GHC.Rename.Splice ( rnSpliceDecl, rnTopSpliceDecls )  import GHC.Hs+import GHC.Types.Error import GHC.Types.FieldLabel import GHC.Types.Name.Reader import GHC.Rename.HsType import GHC.Rename.Bind+import GHC.Rename.Doc import GHC.Rename.Env-import GHC.Rename.Utils ( HsDocContext(..), mapFvRn, bindLocalNames+import GHC.Rename.Utils ( mapFvRn, bindLocalNames                         , checkDupRdrNamesN, bindLocalNamesFV                         , checkShadowedRdrNames, warnUnusedTypePatterns                         , newLocalBndrsRn-                        , withHsDocContext, noNestedForallsContextsErr-                        , addNoNestedForallsContextsErr, checkInferredVars )-import GHC.Rename.Unbound ( mkUnboundName, notInScopeErr )+                        , noNestedForallsContextsErr+                        , addNoNestedForallsContextsErr, checkInferredVars, warnForallIdentifier )+import GHC.Rename.Unbound ( mkUnboundName, notInScopeErr, WhereLooking(WL_Global) ) import GHC.Rename.Names+import GHC.Tc.Errors.Types+import GHC.Tc.Errors.Ppr (withHsDocContext, pprScopeError ) import GHC.Tc.Gen.Annotation ( annCtxt ) import GHC.Tc.Utils.Monad @@ -58,7 +60,7 @@ import GHC.Data.FastString import GHC.Types.SrcLoc as SrcLoc import GHC.Driver.Session-import GHC.Utils.Misc   ( debugIsOn, lengthExceeds, partitionWith )+import GHC.Utils.Misc   ( lengthExceeds, partitionWith ) import GHC.Utils.Panic import GHC.Driver.Env ( HscEnv(..), hsc_home_unit) import GHC.Data.List.SetOps ( findDupsEq, removeDups, equivClasses )@@ -125,7 +127,7 @@    (tc_envs, tc_bndrs) <- getLocalNonValBinders local_fix_env group ;  -   setEnvs tc_envs $ do {+   restoreEnvs tc_envs $ do {     failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations @@ -140,15 +142,20 @@    -- (D2) Rename the left-hand sides of the value bindings.    --     This depends on everything from (B) being in scope.    --     It uses the fixity env from (A) to bind fixities for view patterns.-   new_lhs <- rnTopBindsLHS local_fix_env val_decls ; +   -- We need to throw an error on such value bindings when in a boot file.+   is_boot <- tcIsHsBootOrSig ;+   new_lhs <- if is_boot+    then rnTopBindsLHSBoot local_fix_env val_decls+    else rnTopBindsLHS     local_fix_env val_decls ;+    -- Bind the LHSes (and their fixities) in the global rdr environment    let { id_bndrs = collectHsIdBinders CollNoDictBinders new_lhs } ;                     -- Excludes pattern-synonym binders                     -- They are already in scope    traceRn "rnSrcDecls" (ppr id_bndrs) ;    tc_envs <- extendGlobalRdrEnvRn (map avail id_bndrs) local_fix_env ;-   setEnvs tc_envs $ do {+   restoreEnvs tc_envs $ do {     --  Now everything is in scope, as the remaining renaming assumes. @@ -168,7 +175,6 @@    -- (F) Rename Value declarations right-hand sides    traceRn "Start rnmono" empty ;    let { val_bndr_set = mkNameSet id_bndrs `unionNameSet` mkNameSet pat_syn_bndrs } ;-   is_boot <- tcIsHsBootOrSig ;    (rn_val_decls, bind_dus) <- if is_boot     -- For an hs-boot, use tc_bndrs (which collects how we're renamed     -- signatures), since val_bndr_set is empty (there are no x = ...@@ -200,6 +206,7 @@    (rn_default_decls, src_fvs5) <- rnList rnDefaultDecl   default_decls ;    (rn_deriv_decls,   src_fvs6) <- rnList rnSrcDerivDecl  deriv_decls ;    (rn_splice_decls,  src_fvs7) <- rnList rnSpliceDecl    splice_decls ;+   rn_docs <- traverse rnLDocDecl docs ;     last_tcg_env <- getGblEnv ;    -- (I) Compute the results and return@@ -215,7 +222,7 @@                              hs_annds  = rn_ann_decls,                              hs_defds  = rn_default_decls,                              hs_ruleds = rn_rule_decls,-                             hs_docs   = docs } ;+                             hs_docs   = rn_docs } ;          tcf_bndrs = hsTyClForeignBinders rn_tycl_decls rn_foreign_decls ;         other_def  = (Just (mkNameSet tcf_bndrs), emptyNameSet) ;@@ -259,14 +266,14 @@ -}  -- checks that the deprecations are defined locally, and that there are no duplicates-rnSrcWarnDecls :: NameSet -> [LWarnDecls GhcPs] -> RnM Warnings+rnSrcWarnDecls :: NameSet -> [LWarnDecls GhcPs] -> RnM (Warnings GhcRn) rnSrcWarnDecls _ []   = return NoWarnings  rnSrcWarnDecls bndr_set decls'   = do { -- check for duplicates        ; mapM_ (\ dups -> let ((L loc rdr) :| (lrdr':_)) = dups-                          in addErrAt (locA loc) (dupWarnDecl lrdr' rdr))+                          in addErrAt (locA loc) (TcRnDuplicateWarningDecls lrdr' rdr))                warn_rdr_dups        ; pairs_s <- mapM (addLocMA rn_deprec) decls        ; return (WarnSome ((concat pairs_s))) }@@ -279,13 +286,23 @@        -- ensures that the names are defined locally      = do { names <- concatMapM (lookupLocalTcNames sig_ctxt what . unLoc)                                 rdr_names-          ; return [(rdrNameOcc rdr, txt) | (rdr, _) <- names] }+          ; txt' <- rnWarningTxt txt+          ; return [(rdrNameOcc rdr, txt') | (rdr, _) <- names] }     what = text "deprecation"     warn_rdr_dups = findDupRdrNames                    $ concatMap (\(L _ (Warning _ ns _)) -> ns) decls +rnWarningTxt :: WarningTxt GhcPs -> RnM (WarningTxt GhcRn)+rnWarningTxt (WarningTxt st wst) = do+  wst' <- traverse (traverse rnHsDoc) wst+  pure (WarningTxt st wst')+rnWarningTxt (DeprecatedTxt st wst) = do+  wst' <- traverse (traverse rnHsDoc) wst+  pure (DeprecatedTxt st wst')++ findDupRdrNames :: [LocatedN RdrName] -> [NonEmpty (LocatedN RdrName)] findDupRdrNames = findDupsEq (\ x -> \ y -> rdrNameOcc (unLoc x) == rdrNameOcc (unLoc y)) @@ -293,12 +310,6 @@ -- we check that the names are defined above -- invt: the lists returned by findDupsEq always have at least two elements -dupWarnDecl :: LocatedN RdrName -> RdrName -> SDoc--- Located RdrName -> DeprecDecl RdrName -> SDoc-dupWarnDecl d rdr_name-  = vcat [text "Multiple warning declarations for" <+> quotes (ppr rdr_name),-          text "also at " <+> ppr (getLocA d)]- {- ********************************************************* *                                                      *@@ -320,8 +331,10 @@                 -> RnM (AnnProvenance GhcRn, FreeVars) rnAnnProvenance provenance = do     provenance' <- case provenance of-      ValueAnnProvenance n -> ValueAnnProvenance <$> lookupLocatedTopBndrRnN n-      TypeAnnProvenance n  -> TypeAnnProvenance  <$> lookupLocatedTopBndrRnN n+      ValueAnnProvenance n -> ValueAnnProvenance+                          <$> lookupLocatedTopBndrRnN n+      TypeAnnProvenance n  -> TypeAnnProvenance+                          <$> lookupLocatedTopConstructorRnN n       ModuleAnnProvenance  -> return ModuleAnnProvenance     return (provenance', maybe emptyFVs unitFV (annProvenanceName_maybe provenance')) @@ -351,6 +364,7 @@ rnHsForeignDecl :: ForeignDecl GhcPs -> RnM (ForeignDecl GhcRn, FreeVars) rnHsForeignDecl (ForeignImport { fd_name = name, fd_sig_ty = ty, fd_fi = spec })   = do { topEnv :: HscEnv <- getTopEnv+       ; warnForallIdentifier name        ; name' <- lookupLocatedTopBndrRnN name        ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) TypeLevel ty @@ -441,7 +455,7 @@         "https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/semigroup-monoid"    where-    -- | Warn about unsound/non-canonical 'Applicative'/'Monad' instance+    -- Warn about unsound/non-canonical 'Applicative'/'Monad' instance     -- declarations. Specifically, the following conditions are verified:     --     -- In 'Monad' instances declarations:@@ -487,7 +501,7 @@        | otherwise = return () -    -- | Check whether Monoid(mappend) is defined in terms of+    -- Check whether Monoid(mappend) is defined in terms of     -- Semigroup((<>)) (and not the other way round). Specifically,     -- the following conditions are verified:     --@@ -526,7 +540,7 @@        | otherwise = return () -    -- | test whether MatchGroup represents a trivial \"lhsName = rhsName\"+    -- test whether MatchGroup represents a trivial \"lhsName = rhsName\"     -- binding, and return @Just rhsName@ if this is the case     isAliasMG :: MatchGroup GhcRn (LHsExpr GhcRn) -> Maybe Name     isAliasMG MG {mg_alts = (L _ [L _ (Match { m_pats = []@@ -537,36 +551,40 @@     isAliasMG _ = Nothing      -- got "lhs = rhs" but expected something different-    addWarnNonCanonicalMethod1 refURL flag lhs rhs =-        addWarn (Reason flag) $ vcat-                       [ text "Noncanonical" <+>-                         quotes (text (lhs ++ " = " ++ rhs)) <+>-                         text "definition detected"-                       , instDeclCtxt1 poly_ty-                       , text "Move definition from" <+>-                         quotes (text rhs) <+>-                         text "to" <+> quotes (text lhs)-                       , text "See also:" <+>-                         text refURL-                       ]+    addWarnNonCanonicalMethod1 refURL flag lhs rhs = do+        let dia = TcRnUnknownMessage $+              mkPlainDiagnostic (WarningWithFlag flag) noHints $+                vcat [ text "Noncanonical" <+>+                       quotes (text (lhs ++ " = " ++ rhs)) <+>+                       text "definition detected"+                     , instDeclCtxt1 poly_ty+                     , text "Move definition from" <+>+                       quotes (text rhs) <+>+                       text "to" <+> quotes (text lhs)+                     , text "See also:" <+>+                       text refURL+                     ]+        addDiagnostic dia      -- expected "lhs = rhs" but got something else-    addWarnNonCanonicalMethod2 refURL flag lhs rhs =-        addWarn (Reason flag) $ vcat-                       [ text "Noncanonical" <+>-                         quotes (text lhs) <+>-                         text "definition detected"-                       , instDeclCtxt1 poly_ty-                       , quotes (text lhs) <+>-                         text "will eventually be removed in favour of" <+>-                         quotes (text rhs)-                       , text "Either remove definition for" <+>-                         quotes (text lhs) <+> text "(recommended)" <+>-                         text "or define as" <+>-                         quotes (text (lhs ++ " = " ++ rhs))-                       , text "See also:" <+>-                         text refURL-                       ]+    addWarnNonCanonicalMethod2 refURL flag lhs rhs = do+        let dia = TcRnUnknownMessage $+              mkPlainDiagnostic (WarningWithFlag flag) noHints $+                vcat [ text "Noncanonical" <+>+                       quotes (text lhs) <+>+                       text "definition detected"+                     , instDeclCtxt1 poly_ty+                     , quotes (text lhs) <+>+                       text "will eventually be removed in favour of" <+>+                       quotes (text rhs)+                     , text "Either remove definition for" <+>+                       quotes (text lhs) <+> text "(recommended)" <+>+                       text "or define as" <+>+                       quotes (text (lhs ++ " = " ++ rhs))+                     , text "See also:" <+>+                       text refURL+                     ]+        addDiagnostic dia      -- stolen from GHC.Tc.TyCl.Instance     instDeclCtxt1 :: LHsSigType GhcRn -> SDoc@@ -661,7 +679,7 @@     -- reach the typechecker, lest we encounter different errors that are     -- hopelessly confusing (such as the one in #16114).     bail_out (l, err_msg) = do-      addErrAt l $ withHsDocContext ctxt err_msg+      addErrAt l $ TcRnUnknownMessage $ mkPlainError noHints (withHsDocContext ctxt err_msg)       pure $ mkUnboundName (mkTcOccFS (fsLit "<class>"))  rnFamEqn :: HsDocContext@@ -719,7 +737,10 @@          -- data instance H :: k -> Type where ...          --   -- all_imp_vars = [k]          -- @-       ; let all_imp_vars = pat_kity_vars ++ extra_kvars+         --+         -- For associated type family instances, exclude the type variables+         -- bound by the instance head with filterInScopeM (#19649).+       ; all_imp_vars <- filterInScopeM $ pat_kity_vars ++ extra_kvars         ; bindHsOuterTyVarBndrs doc mb_cls all_imp_vars outer_bndrs $ \rn_outer_bndrs ->     do { (pats', pat_fvs) <- rnLHsTypeArgs (FamPatCtx tycon) pats@@ -755,8 +776,18 @@          -- parent instance declaration is mentioned on the RHS of the          -- associated family instance but not bound on the LHS, then reject          -- that type variable as being out of scope.-         -- See Note [Renaming associated types]-       ; let lhs_bound_vars = extendNameSetList pat_fvs all_nms+         -- See Note [Renaming associated types].+         -- Per that Note, the LHS type variables consist of:+         --+         -- - The variables mentioned in the instance's type patterns+         --   (pat_fvs), and+         --+         -- - The variables mentioned in an outermost kind signature on the+         --   RHS. This is a subset of `rhs_fvs`. To compute it, we look up+         --   each RdrName in `extra_kvars` to find its corresponding Name in+         --   the LocalRdrEnv.+       ; extra_kvar_nms <- mapMaybeM (lookupLocalOccRn_maybe . unLoc) extra_kvars+       ; let lhs_bound_vars = pat_fvs `extendNameSetList` extra_kvar_nms              improperly_scoped cls_tkv =                   cls_tkv `elemNameSet` rhs_fvs                     -- Mentioned on the RHS...@@ -812,7 +843,8 @@      badAssocRhs :: [Name] -> RnM ()     badAssocRhs ns-      = addErr (hang (text "The RHS of an associated type declaration mentions"+      = addErr $ TcRnUnknownMessage $ mkPlainError noHints $+           (hang (text "The RHS of an associated type declaration mentions"                       <+> text "out-of-scope variable" <> plural ns                       <+> pprWithCommas (quotes . ppr) ns)                    2 (text "All such variables must be bound on the LHS"))@@ -1120,7 +1152,7 @@ Here, we /do/ want to warn that `CF` is unused in the module `C`, as it is defined but not used (#18470). -GHC accomplishes this in rnFamInstEqn when determining the set of free+GHC accomplishes this in rnFamEqn when determining the set of free variables to return at the end. If renaming a data family or open type family equation, we add the name of the type family constructor to the set of returned free variables to ensure that the name is marked as an occurrence. If renaming@@ -1172,9 +1204,10 @@     loc = getLocA nowc_ty     nowc_ty = dropWildCards ty -standaloneDerivErr :: SDoc+standaloneDerivErr :: TcRnMessage standaloneDerivErr-  = hang (text "Illegal standalone deriving declaration")+  = TcRnUnknownMessage $ mkPlainError noHints $+    hang (text "Illegal standalone deriving declaration")        2 (text "Use StandaloneDeriving to enable this extension")  {-@@ -1201,6 +1234,7 @@                      , rd_lhs  = lhs                      , rd_rhs  = rhs })   = do { let rdr_names_w_loc = map (get_var . unLoc) tmvs+       ; mapM_ warnForallIdentifier rdr_names_w_loc        ; checkDupRdrNamesN rdr_names_w_loc        ; checkShadowedRdrNames rdr_names_w_loc        ; names <- newLocalBndrsRn rdr_names_w_loc@@ -1315,23 +1349,28 @@     checkl_es es = foldr (mplus . checkl_e) Nothing es -} -badRuleVar :: FastString -> Name -> SDoc+badRuleVar :: FastString -> Name -> TcRnMessage badRuleVar name var-  = sep [text "Rule" <+> doubleQuotes (ftext name) <> colon,+  = TcRnUnknownMessage $ mkPlainError noHints $+    sep [text "Rule" <+> doubleQuotes (ftext name) <> colon,          text "Forall'd variable" <+> quotes (ppr var) <+>                 text "does not appear on left hand side"] -badRuleLhsErr :: FastString -> LHsExpr GhcRn -> HsExpr GhcRn -> SDoc+badRuleLhsErr :: FastString -> LHsExpr GhcRn -> HsExpr GhcRn -> TcRnMessage badRuleLhsErr name lhs bad_e-  = sep [text "Rule" <+> pprRuleName name <> colon,+  = TcRnUnknownMessage $ mkPlainError noHints $+    sep [text "Rule" <+> pprRuleName name <> colon,          nest 2 (vcat [err,                        text "in left-hand side:" <+> ppr lhs])]     $$     text "LHS must be of form (f e1 .. en) where f is not forall'd"   where-    err = case bad_e of-            HsUnboundVar _ uv -> notInScopeErr (mkRdrUnqual uv)-            _                 -> text "Illegal expression:" <+> ppr bad_e+    err =+      case bad_e of+        HsUnboundVar _ uv ->+          let rdr = mkRdrUnqual uv+          in  pprScopeError rdr $ notInScopeErr WL_Global (mkRdrUnqual uv)+        _ -> text "Illegal expression:" <+> ppr bad_e  {- **************************************************************          *                                                      *@@ -1510,8 +1549,11 @@               all_groups = first_group ++ groups -       ; MASSERT2( null final_inst_ds,  ppr instds_w_fvs $$ ppr inst_ds_map-                                       $$ ppr (flattenSCCs tycl_sccs) $$ ppr final_inst_ds  )+       ; massertPpr (null final_inst_ds)+                    (ppr instds_w_fvs+                     $$ ppr inst_ds_map+                     $$ ppr (flattenSCCs tycl_sccs)+                     $$ ppr final_inst_ds)         ; traceRn "rnTycl dependency analysis made groups" (ppr all_groups)        ; return (all_groups, all_fvs) }@@ -1580,8 +1622,8 @@         ; return (StandaloneKindSig noExtField new_v new_ki, fvs)         }   where-    standaloneKiSigErr :: SDoc-    standaloneKiSigErr =+    standaloneKiSigErr :: TcRnMessage+    standaloneKiSigErr = TcRnUnknownMessage $ mkPlainError noHints $       hang (text "Illegal standalone kind signature")          2 (text "Did you mean to enable StandaloneKindSignatures?") @@ -1654,7 +1696,7 @@  dupRoleAnnotErr :: NonEmpty (LRoleAnnotDecl GhcPs) -> RnM () dupRoleAnnotErr list-  = addErrAt (locA loc) $+  = addErrAt (locA loc) $ TcRnUnknownMessage $ mkPlainError noHints $     hang (text "Duplicate role annotations for" <+>           quotes (ppr $ roleAnnotDeclName first_decl) <> colon)        2 (vcat $ map pp_role_annot $ NE.toList sorted_list)@@ -1669,7 +1711,7 @@  dupKindSig_Err :: NonEmpty (LStandaloneKindSig GhcPs) -> RnM () dupKindSig_Err list-  = addErrAt (locA loc) $+  = addErrAt (locA loc) $ TcRnUnknownMessage $ mkPlainError noHints $     hang (text "Duplicate standalone kind signatures for" <+>           quotes (ppr $ standaloneKindSigName first_decl) <> colon)        2 (vcat $ map pp_kisig $ NE.toList sorted_list)@@ -1763,7 +1805,7 @@  rnTyClDecl (SynDecl { tcdLName = tycon, tcdTyVars = tyvars,                       tcdFixity = fixity, tcdRhs = rhs })-  = do { tycon' <- lookupLocatedTopBndrRnN tycon+  = do { tycon' <- lookupLocatedTopConstructorRnN tycon        ; let kvs = extractHsTyRdrTyVarsKindVars rhs              doc = TySynCtx tycon        ; traceRn "rntycl-ty" (ppr tycon <+> ppr kvs)@@ -1779,7 +1821,7 @@       tcdFixity = fixity,       tcdDataDefn = defn@HsDataDefn{ dd_ND = new_or_data                                    , dd_kindSig = kind_sig} })-  = do { tycon' <- lookupLocatedTopBndrRnN tycon+  = do { tycon' <- lookupLocatedTopConstructorRnN tycon        ; let kvs = extractDataDefnKindVars defn              doc = TyDataCtx tycon        ; traceRn "rntycl-data" (ppr tycon <+> ppr kvs)@@ -1800,7 +1842,7 @@                         tcdFDs = fds, tcdSigs = sigs,                         tcdMeths = mbinds, tcdATs = ats, tcdATDefs = at_defs,                         tcdDocs = docs})-  = do  { lcls' <- lookupLocatedTopBndrRnN lcls+  = do  { lcls' <- lookupLocatedTopConstructorRnN lcls         ; let cls' = unLoc lcls'               kvs = []  -- No scoped kind vars except those in                         -- kind signatures on the tyvars@@ -1809,7 +1851,7 @@         ; ((tyvars', context', fds', ats'), stuff_fvs)             <- bindHsQTyVars cls_doc Nothing kvs tyvars $ \ tyvars' _ -> do                   -- Checks for distinct tyvars-             { (context', cxt_fvs) <- rnContext cls_doc context+             { (context', cxt_fvs) <- rnMaybeContext cls_doc context              ; fds'  <- rnFds fds                          -- The fundeps have no free variables              ; (ats', fv_ats) <- rnATDecls cls' ats@@ -1848,11 +1890,12 @@                 -- and the methods are already in scope          ; let all_fvs = meth_fvs `plusFV` stuff_fvs `plusFV` fv_at_defs+        ; docs' <- traverse rnLDocDecl docs         ; return (ClassDecl { tcdCtxt = context', tcdLName = lcls',                               tcdTyVars = tyvars', tcdFixity = fixity,                               tcdFDs = fds', tcdSigs = sigs',                               tcdMeths = mbinds', tcdATs = ats', tcdATDefs = at_defs',-                              tcdDocs = docs, tcdCExt = all_fvs },+                              tcdDocs = docs', tcdCExt = all_fvs },                   all_fvs ) }   where     cls_doc  = ClassDeclCtx lcls@@ -1900,13 +1943,15 @@ rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType                            , dd_ctxt = context, dd_cons = condecls                            , dd_kindSig = m_sig, dd_derivs = derivs })-  = do  { checkTc (h98_style || null (fromMaybeContext context))+  = do  { -- DatatypeContexts (i.e., stupid contexts) can't be combined with+          -- GADT syntax. See Note [The stupid context] in GHC.Core.DataCon.+          checkTc (h98_style || null (fromMaybeContext context))                   (badGadtStupidTheta doc)          ; (m_sig', sig_fvs) <- case m_sig of              Just sig -> first Just <$> rnLHsKind doc sig              Nothing  -> return (Nothing, emptyFVs)-        ; (context', fvs1) <- rnContext doc context+        ; (context', fvs1) <- rnMaybeContext doc context         ; (derivs',  fvs3) <- rn_derivs derivs          -- For the constructor declarations, drop the LocalRdrEnv@@ -1945,16 +1990,16 @@                  -> RnM () warnNoDerivStrat mds loc   = do { dyn_flags <- getDynFlags-       ; when (wopt Opt_WarnMissingDerivingStrategies dyn_flags) $-           case mds of-             Nothing -> addWarnAt-               (Reason Opt_WarnMissingDerivingStrategies)-               loc-               (if xopt LangExt.DerivingStrategies dyn_flags-                 then no_strat_warning-                 else no_strat_warning $+$ deriv_strat_nenabled-               )-             _ -> pure ()+       ; case mds of+           Nothing ->+             let dia = TcRnUnknownMessage $+                   mkPlainDiagnostic (WarningWithFlag Opt_WarnMissingDerivingStrategies) noHints $+                     (if xopt LangExt.DerivingStrategies dyn_flags+                       then no_strat_warning+                       else no_strat_warning $+$ deriv_strat_nenabled+                     )+             in addDiagnosticAt loc dia+           _ -> pure ()        }   where     no_strat_warning :: SDoc@@ -1972,7 +2017,7 @@                               , deriv_clause_tys = dct }))   = do { (dcs', dct', fvs)            <- rnLDerivStrategy doc dcs $ rn_deriv_clause_tys dct-       ; warnNoDerivStrat dcs' loc+       ; warnNoDerivStrat dcs' (locA loc)        ; pure ( L loc (HsDerivingClause { deriv_clause_ext = noExtField                                         , deriv_clause_strategy = dcs'                                         , deriv_clause_tys = dct' })@@ -2010,7 +2055,7 @@   = case mds of       Nothing -> boring_case Nothing       Just (L loc ds) ->-        setSrcSpan loc $ do+        setSrcSpanA loc $ do           (ds', thing, fvs) <- rn_deriv_strat ds           pure (Just (L loc ds'), thing, fvs)   where@@ -2053,14 +2098,16 @@       (thing, fvs) <- thing_inside       pure (ds, thing, fvs) -badGadtStupidTheta :: HsDocContext -> SDoc+badGadtStupidTheta :: HsDocContext -> TcRnMessage badGadtStupidTheta _-  = vcat [text "No context is allowed on a GADT-style data declaration",+  = TcRnUnknownMessage $ mkPlainError noHints $+    vcat [text "No context is allowed on a GADT-style data declaration",           text "(You can put a context on each constructor, though.)"] -illegalDerivStrategyErr :: DerivStrategy GhcPs -> SDoc+illegalDerivStrategyErr :: DerivStrategy GhcPs -> TcRnMessage illegalDerivStrategyErr ds-  = vcat [ text "Illegal deriving strategy" <> colon <+> derivStrategyName ds+  = TcRnUnknownMessage $ mkPlainError noHints $+    vcat [ text "Illegal deriving strategy" <> colon <+> derivStrategyName ds          , text enableStrategy ]    where@@ -2071,9 +2118,10 @@       | otherwise       = "Use DerivingStrategies to enable this extension" -multipleDerivClausesErr :: SDoc+multipleDerivClausesErr :: TcRnMessage multipleDerivClausesErr-  = vcat [ text "Illegal use of multiple, consecutive deriving clauses"+  = TcRnUnknownMessage $ mkPlainError noHints $+    vcat [ text "Illegal use of multiple, consecutive deriving clauses"          , text "Use DerivingStrategies to allow this" ]  rnFamDecl :: Maybe Name -- Just cls => this FamilyDecl is nested@@ -2086,11 +2134,11 @@                              , fdFixity = fixity                              , fdInfo = info, fdResultSig = res_sig                              , fdInjectivityAnn = injectivity })-  = do { tycon' <- lookupLocatedTopBndrRnN tycon+  = do { tycon' <- lookupLocatedTopConstructorRnN tycon        ; ((tyvars', res_sig', injectivity'), fv1) <-             bindHsQTyVars doc mb_cls kvs tyvars $ \ tyvars' _ ->             do { let rn_sig = rnFamResultSig doc-               ; (res_sig', fv_kind) <- wrapLocFstM rn_sig res_sig+               ; (res_sig', fv_kind) <- wrapLocFstMA rn_sig res_sig                ; injectivity' <- traverse (rnInjectivityAnn tyvars' res_sig')                                           injectivity                ; return ( (tyvars', res_sig', injectivity') , fv_kind ) }@@ -2138,7 +2186,7 @@           rdr_env <- getLocalRdrEnv        ;  let resName = hsLTyVarName tvbndr        ;  when (resName `elemLocalRdrEnv` rdr_env) $-          addErrAt (getLocA tvbndr) $+          addErrAt (getLocA tvbndr) $ TcRnUnknownMessage $ mkPlainError noHints $                      (hsep [ text "Type variable", quotes (ppr resName) <> comma                            , text "naming a type family result,"                            ] $$@@ -2198,7 +2246,9 @@              -- e.g.   type family F a = (r::*) | r -> a              do { injFrom' <- rnLTyVar injFrom                 ; injTo'   <- mapM rnLTyVar injTo-                ; return $ L srcSpan (InjectivityAnn x injFrom' injTo') }+                -- Note: srcSpan is unchanged, but typechecker gets+                -- confused, l2l call makes it happy+                ; return $ L (l2l srcSpan) (InjectivityAnn x injFrom' injTo') }     ; let tvNames  = Set.fromList $ hsAllLTyVarNames tvBndrs          resName  = hsLTyVarName resTv@@ -2210,7 +2260,7 @@    -- not-in-scope variables) don't check the validity of injectivity    -- annotation. This gives better error messages.    ; when (noRnErrors && not lhsValid) $-        addErrAt (getLocA injFrom)+        addErrAt (getLocA injFrom) $ TcRnUnknownMessage $ mkPlainError noHints $               ( vcat [ text $ "Incorrect type variable on the LHS of "                            ++ "injectivity condition"               , nest 5@@ -2219,7 +2269,8 @@     ; when (noRnErrors && not (Set.null rhsValid)) $       do { let errorVars = Set.toList rhsValid-         ; addErrAt srcSpan $ ( hsep+         ; addErrAt (locA srcSpan) $ TcRnUnknownMessage $ mkPlainError noHints $+                        ( hsep                         [ text "Unknown type variable" <> plural errorVars                         , text "on the RHS of injectivity condition:"                         , interpp'SP errorVars ] ) }@@ -2235,7 +2286,7 @@ -- So we rename injectivity annotation like we normally would except that -- this time we expect "result" to be reported not in scope by rnLTyVar. rnInjectivityAnn _ _ (L srcSpan (InjectivityAnn x injFrom injTo)) =-   setSrcSpan srcSpan $ do+   setSrcSpanA srcSpan $ do    (injDecl', _) <- askNoErrs $ do      injFrom' <- rnLTyVar injFrom      injTo'   <- mapM rnLTyVar injTo@@ -2267,9 +2318,9 @@ rnConDecl :: ConDecl GhcPs -> RnM (ConDecl GhcRn, FreeVars) rnConDecl decl@(ConDeclH98 { con_name = name, con_ex_tvs = ex_tvs                            , con_mb_cxt = mcxt, con_args = args-                           , con_doc = mb_doc, con_forall = forall })+                           , con_doc = mb_doc, con_forall = forall_ })   = do  { _        <- addLocMA checkConName name-        ; new_name <- lookupLocatedTopBndrRnN name+        ; new_name <- lookupLocatedTopConstructorRnN name          -- We bind no implicit binders here; this is just like         -- a nested HsForAllTy.  E.g. consider@@ -2290,11 +2341,12 @@              [ text "ex_tvs:" <+> ppr ex_tvs              , text "new_ex_dqtvs':" <+> ppr new_ex_tvs ]) +        ; mb_doc' <- traverse rnLHsDoc mb_doc         ; return (decl { con_ext = noAnn                        , con_name = new_name, con_ex_tvs = new_ex_tvs                        , con_mb_cxt = new_context, con_args = new_args-                       , con_doc = mb_doc-                       , con_forall = forall }, -- Remove when #18311 is fixed+                       , con_doc = mb_doc'+                       , con_forall = forall_ }, -- Remove when #18311 is fixed                   all_fvs) }}  rnConDecl (ConDeclGADT { con_names   = names@@ -2304,7 +2356,7 @@                        , con_res_ty  = res_ty                        , con_doc     = mb_doc })   = do  { mapM_ (addLocMA checkConName) names-        ; new_names <- mapM lookupLocatedTopBndrRnN names+        ; new_names <- mapM (lookupLocatedTopConstructorRnN) names          ; let -- We must ensure that we extract the free tkvs in left-to-right               -- order of their appearance in the constructor type.@@ -2334,16 +2386,17 @@          ; traceRn "rnConDecl (ConDeclGADT)"             (ppr names $$ ppr outer_bndrs')+        ; new_mb_doc <- traverse rnLHsDoc mb_doc         ; return (ConDeclGADT { con_g_ext = noAnn, con_names = new_names                               , con_bndrs = L l outer_bndrs', con_mb_cxt = new_cxt                               , con_g_args = new_args, con_res_ty = new_res_ty-                              , con_doc = mb_doc },+                              , con_doc = new_mb_doc },                   all_fvs) } }  rnMbContext :: HsDocContext -> Maybe (LHsContext GhcPs)             -> RnM (Maybe (LHsContext GhcRn), FreeVars) rnMbContext _    Nothing    = return (Nothing, emptyFVs)-rnMbContext doc cxt = do { (ctx',fvs) <- rnContext doc cxt+rnMbContext doc cxt = do { (ctx',fvs) <- rnMaybeContext doc cxt                          ; return (ctx',fvs) }  rnConDeclH98Details ::@@ -2370,9 +2423,9 @@ rnConDeclGADTDetails _ doc (PrefixConGADT tys)   = do { (new_tys, fvs) <- mapFvRn (rnScaledLHsType doc) tys        ; return (PrefixConGADT new_tys, fvs) }-rnConDeclGADTDetails con doc (RecConGADT flds)+rnConDeclGADTDetails con doc (RecConGADT flds arr)   = do { (new_flds, fvs) <- rnRecConDeclFields con doc flds-       ; return (RecConGADT new_flds, fvs) }+       ; return (RecConGADT new_flds arr, fvs) }  rnRecConDeclFields ::      Name@@ -2402,7 +2455,7 @@     ; let field_env' = extendNameEnvList (tcg_field_env gbl_env) names_with_fls          final_gbl_env = gbl_env { tcg_field_env = field_env' }-   ; setEnvs (final_gbl_env, lcl_env) (thing pat_syn_bndrs) }+   ; restoreEnvs (final_gbl_env, lcl_env) (thing pat_syn_bndrs) }   where     new_ps :: HsValBinds GhcPs -> TcM [(Name, [FieldLabel])]     new_ps (ValBinds _ binds _) = foldrM new_ps' [] binds@@ -2416,7 +2469,7 @@                                        , psb_args = RecCon as }))) <- bind       = do           bnd_name <- newTopSrcBinder (L (l2l bind_loc) n)-          let field_occs = map ((\ f -> L (getLocA (rdrNameFieldOcc f)) f) . recordPatSynField) as+          let field_occs = map ((\ f -> L (noAnnSrcSpan $ getLocA (foLabel f)) f) . recordPatSynField) as           flds <- mapM (newRecordSelector dup_fields_ok has_sel [bnd_name]) field_occs           return ((bnd_name, flds): names)       | L bind_loc (PatSynBind _ (PSB { psb_id = L _ n})) <- bind@@ -2497,7 +2550,9 @@         ; return (gp, Just (splice, ds)) }   where-    badImplicitSplice = text "Parse error: module header, import declaration"+    badImplicitSplice :: TcRnMessage+    badImplicitSplice = TcRnUnknownMessage $ mkPlainError noHints $+                        text "Parse error: module header, import declaration"                      $$ text "or top-level declaration expected."                      -- The compiler should suggest the above, and not using                      -- TemplateHaskell since the former suggestion is more
GHC/Rename/Names.hs view
@@ -4,11 +4,12 @@ Extracting imported and top-level names in scope -} -{-# LANGUAGE CPP, NondecreasingIndentation #-}+{-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE LambdaCase #-}  {-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}@@ -22,16 +23,13 @@         checkConName,         mkChildEnv,         findChildren,-        dodgyMsg,-        dodgyMsgInsert,         findImportUsage,         getMinimalImports,         printMinimalImports,+        renamePkgQual, renameRawPkgQual,         ImportDeclUsage     ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Driver.Env@@ -42,6 +40,7 @@ import GHC.Rename.Fixity import GHC.Rename.Utils ( warnUnusedTopBinds, mkFieldEnv ) +import GHC.Tc.Errors.Types import GHC.Tc.Utils.Env import GHC.Tc.Utils.Monad @@ -51,13 +50,13 @@ import GHC.Parser.PostProcess ( setRdrNameSpace ) import GHC.Core.Type import GHC.Core.PatSyn-import GHC.Core.TyCo.Ppr-import GHC.Core.TyCon ( TyCon, tyConName, tyConKind )+import GHC.Core.TyCon ( TyCon, tyConName ) import qualified GHC.LanguageExtensions as LangExt  import GHC.Utils.Outputable as Outputable import GHC.Utils.Misc as Utils import GHC.Utils.Panic+import GHC.Utils.Trace  import GHC.Types.Fixity.Env import GHC.Types.SafeHaskell@@ -73,12 +72,15 @@ import GHC.Types.SourceText import GHC.Types.Id import GHC.Types.HpcInfo+import GHC.Types.Error+import GHC.Types.PkgQual  import GHC.Unit import GHC.Unit.Module.Warnings import GHC.Unit.Module.ModIface import GHC.Unit.Module.Imported import GHC.Unit.Module.Deps+import GHC.Unit.Env  import GHC.Data.Maybe import GHC.Data.FastString@@ -95,6 +97,7 @@ import System.FilePath  ((</>))  import System.IO+import GHC.Data.Bag  {- ************************************************************************@@ -111,7 +114,7 @@ and packages. Doing this without caching any trust information would be very slow as we would need to touch all packages and interface files a module depends on. To avoid this we make use of the property that if a modules Safe Haskell-mode changes, this triggers a recompilation from that module in the dependcy+mode changes, this triggers a recompilation from that module in the dependecy graph. So we can just worry mostly about direct imports.  There is one trust property that can change for a package though without@@ -187,22 +190,37 @@ -- the return types represent. -- Note: Do the non SOURCE ones first, so that we get a helpful warning -- for SOURCE ones that are unnecessary-rnImports :: [LImportDecl GhcPs]+rnImports :: [(LImportDecl GhcPs, SDoc)]           -> RnM ([LImportDecl GhcRn], GlobalRdrEnv, ImportAvails, AnyHpcUsage) rnImports imports = do     tcg_env <- getGblEnv     -- NB: want an identity module here, because it's OK for a signature     -- module to import from its implementor     let this_mod = tcg_mod tcg_env-    let (source, ordinary) = partition is_source_import imports+    let (source, ordinary) = partition (is_source_import . fst) imports         is_source_import d = ideclSource (unLoc d) == IsBoot     stuff1 <- mapAndReportM (rnImportDecl this_mod) ordinary     stuff2 <- mapAndReportM (rnImportDecl this_mod) source     -- Safe Haskell: See Note [Tracking Trust Transitively]     let (decls, rdr_env, imp_avails, hpc_usage) = combine (stuff1 ++ stuff2)-    return (decls, rdr_env, imp_avails, hpc_usage)+    -- Update imp_boot_mods if imp_direct_mods mentions any of them+    let merged_import_avail = clobberSourceImports imp_avails+    dflags <- getDynFlags+    let final_import_avail  =+          merged_import_avail { imp_dep_direct_pkgs = S.fromList (implicitPackageDeps dflags)+                                                        `S.union` imp_dep_direct_pkgs merged_import_avail}+    return (decls, rdr_env, final_import_avail, hpc_usage)    where+    clobberSourceImports imp_avails =+      imp_avails { imp_boot_mods = imp_boot_mods' }+      where+        imp_boot_mods' = mergeInstalledModuleEnv combJ id (const emptyInstalledModuleEnv)+                            (imp_boot_mods imp_avails)+                            (imp_direct_dep_mods imp_avails)++        combJ (GWIB _ IsBoot) x = Just x+        combJ r _               = Just r     -- See Note [Combining ImportAvails]     combine :: [(LImportDecl GhcRn,  GlobalRdrEnv, ImportAvails, AnyHpcUsage)]             -> ([LImportDecl GhcRn], GlobalRdrEnv, ImportAvails, AnyHpcUsage)@@ -284,17 +302,19 @@ -- --  4. A boolean 'AnyHpcUsage' which is true if the imported module --     used HPC.-rnImportDecl  :: Module -> LImportDecl GhcPs+rnImportDecl  :: Module -> (LImportDecl GhcPs, SDoc)              -> RnM (LImportDecl GhcRn, GlobalRdrEnv, ImportAvails, AnyHpcUsage) rnImportDecl this_mod              (L loc decl@(ImportDecl { ideclName = loc_imp_mod_name-                                     , ideclPkgQual = mb_pkg+                                     , ideclPkgQual = raw_pkg_qual                                      , ideclSource = want_boot, ideclSafe = mod_safe                                      , ideclQualified = qual_style, ideclImplicit = implicit-                                     , ideclAs = as_mod, ideclHiding = imp_details }))+                                     , ideclAs = as_mod, ideclHiding = imp_details }), import_reason)   = setSrcSpanA loc $ do -    when (isJust mb_pkg) $ do+    case raw_pkg_qual of+      NoRawPkgQual -> pure ()+      RawPkgQual _ -> do         pkg_imports <- xoptM LangExt.PackageImports         when (not pkg_imports) $ addErr packageImportErr @@ -303,8 +323,12 @@     -- If there's an error in loadInterface, (e.g. interface     -- file not found) we get lots of spurious errors from 'filterImports'     let imp_mod_name = unLoc loc_imp_mod_name-        doc = ppr imp_mod_name <+> text "is directly imported"+        doc = ppr imp_mod_name <+> import_reason +    hsc_env <- getTopEnv+    unit_env <- hsc_unit_env <$> getTopEnv+    let pkg_qual = renameRawPkgQual unit_env imp_mod_name raw_pkg_qual+     -- Check for self-import, which confuses the typechecker (#9032)     -- ghc --make rejects self-import cycles already, but batch-mode may not     -- at least not until GHC.IfaceToCore.tcHiBootIface, which is too late to avoid@@ -318,14 +342,15 @@     -- extend Provenance to support a local definition in a qualified location.     -- For now, we don't support it, but see #10336     when (imp_mod_name == moduleName this_mod &&-          (case mb_pkg of  -- If we have import "<pkg>" M, then we should-                           -- check that "<pkg>" is "this" (which is magic)-                           -- or the name of this_mod's package.  Yurgh!-                           -- c.f. GHC.findModule, and #9997-             Nothing         -> True-             Just (StringLiteral _ pkg_fs _) -> pkg_fs == fsLit "this" ||-                            fsToUnit pkg_fs == moduleUnit this_mod))-         (addErr (text "A module cannot import itself:" <+> ppr imp_mod_name))+          (case pkg_qual of -- If we have import "<pkg>" M, then we should+                            -- check that "<pkg>" is "this" (which is magic)+                            -- or the name of this_mod's package.  Yurgh!+                            -- c.f. GHC.findModule, and #9997+             NoPkgQual         -> True+             ThisPkg uid       -> uid == homeUnitId_ (hsc_dflags hsc_env)+             OtherPkg _        -> False))+         (addErr $ TcRnUnknownMessage $ mkPlainError noHints $+           (text "A module cannot import itself:" <+> ppr imp_mod_name))      -- Check for a missing import list (Opt_WarnMissingImportList also     -- checks for T(..) items but that is done in checkDodgyImport below)@@ -333,15 +358,19 @@         Just (False, _) -> return () -- Explicit import list         _  | implicit   -> return () -- Do not bleat for implicit imports            | qual_only  -> return ()-           | otherwise  -> whenWOptM Opt_WarnMissingImportList $-                           addWarn (Reason Opt_WarnMissingImportList)-                                   (missingImportListWarn imp_mod_name)+           | otherwise  -> whenWOptM Opt_WarnMissingImportList $ do+                             let msg = TcRnUnknownMessage $+                                   mkPlainDiagnostic (WarningWithFlag Opt_WarnMissingImportList)+                                                     noHints+                                                     (missingImportListWarn imp_mod_name)+                             addDiagnostic msg -    iface <- loadSrcInterface doc imp_mod_name want_boot (fmap sl_fs mb_pkg) +    iface <- loadSrcInterface doc imp_mod_name want_boot pkg_qual+     -- Compiler sanity check: if the import didn't say     -- {-# SOURCE #-} we should not get a hi-boot file-    WARN( (want_boot == NotBoot) && (mi_boot iface == IsBoot), ppr imp_mod_name ) do+    warnPprTrace ((want_boot == NotBoot) && (mi_boot iface == IsBoot)) "rnImportDecl" (ppr imp_mod_name) $ do      -- Issue a user warning for a redundant {- SOURCE -} import     -- NB that we arrange to read all the ordinary imports before@@ -355,9 +384,9 @@     warnIf ((want_boot == IsBoot) && (mi_boot iface == NotBoot) && isOneShot (ghcMode dflags))            (warnRedundantSourceImport imp_mod_name)     when (mod_safe && not (safeImportsOn dflags)) $-        addErr (text "safe import can't be used as Safe Haskell isn't on!"-                $+$ ptext (sLit $ "please enable Safe Haskell through either "-                                   ++ "Safe, Trustworthy or Unsafe"))+        addErr $ TcRnUnknownMessage $ mkPlainError noHints $+          (text "safe import can't be used as Safe Haskell isn't on!"+                $+$ text ("please enable Safe Haskell through either Safe, Trustworthy or Unsafe"))      let         qual_mod_name = fmap unLoc as_mod `orElse` imp_mod_name@@ -383,6 +412,7 @@      hsc_env <- getTopEnv     let home_unit = hsc_home_unit hsc_env+        other_home_units = hsc_all_home_unit_ids hsc_env         imv = ImportedModsVal             { imv_name        = qual_mod_name             , imv_span        = locA loc@@ -391,35 +421,81 @@             , imv_all_exports = potential_gres             , imv_qualified   = qual_only             }-        imports = calculateAvails home_unit iface mod_safe' want_boot (ImportedByUser imv)+        imports = calculateAvails home_unit other_home_units iface mod_safe' want_boot (ImportedByUser imv)      -- Complain if we import a deprecated module-    whenWOptM Opt_WarnWarningsDeprecations (-       case (mi_warns iface) of-          WarnAll txt -> addWarn (Reason Opt_WarnWarningsDeprecations)-                                (moduleWarn imp_mod_name txt)-          _           -> return ()-     )+    case mi_warns iface of+       WarnAll txt -> do+         let msg = TcRnUnknownMessage $+               mkPlainDiagnostic (WarningWithFlag Opt_WarnWarningsDeprecations)+                                 noHints+                                 (moduleWarn imp_mod_name txt)+         addDiagnostic msg+       _           -> return ()      -- Complain about -Wcompat-unqualified-imports violations.     warnUnqualifiedImport decl iface -    let new_imp_decl = L loc (decl { ideclExt = noExtField, ideclSafe = mod_safe'-                                   , ideclHiding = new_imp_details-                                   , ideclName = ideclName decl-                                   , ideclAs = ideclAs decl })+    let new_imp_decl = ImportDecl+          { ideclExt       = noExtField+          , ideclSourceSrc = ideclSourceSrc decl+          , ideclName      = ideclName decl+          , ideclPkgQual   = pkg_qual+          , ideclSource    = ideclSource decl+          , ideclSafe      = mod_safe'+          , ideclQualified = ideclQualified decl+          , ideclImplicit  = ideclImplicit decl+          , ideclAs        = ideclAs decl+          , ideclHiding    = new_imp_details+          } -    return (new_imp_decl, gbl_env, imports, mi_hpc iface)+    return (L loc new_imp_decl, gbl_env, imports, mi_hpc iface) ++-- | Rename raw package imports+renameRawPkgQual :: UnitEnv -> ModuleName -> RawPkgQual -> PkgQual+renameRawPkgQual unit_env mn = \case+  NoRawPkgQual -> NoPkgQual+  RawPkgQual p -> renamePkgQual unit_env mn (Just (sl_fs p))++-- | Rename raw package imports+renamePkgQual :: UnitEnv -> ModuleName -> Maybe FastString -> PkgQual+renamePkgQual unit_env mn mb_pkg = case mb_pkg of+  Nothing -> NoPkgQual+  Just pkg_fs+    | Just uid <- homeUnitId <$> ue_homeUnit unit_env+    , pkg_fs == fsLit "this"+    -> ThisPkg uid++    | Just (uid, _) <- find (fromMaybe False . fmap (== pkg_fs) . snd) home_names+    -> ThisPkg uid++    | Just uid <- resolvePackageImport (ue_units unit_env) mn (PackageName pkg_fs)+    -> OtherPkg uid++    | otherwise+    -> OtherPkg (UnitId pkg_fs)+       -- not really correct as pkg_fs is unlikely to be a valid unit-id but+       -- we will report the failure later...+  where+    home_names  = map (\uid -> (uid, mkFastString <$> thisPackageName (homeUnitEnv_dflags (ue_findHomeUnitEnv uid unit_env)))) hpt_deps++    units = ue_units unit_env++    hpt_deps :: [UnitId]+    hpt_deps  = homeUnitDepends units++ -- | Calculate the 'ImportAvails' induced by an import of a particular -- interface, but without 'imp_mods'. calculateAvails :: HomeUnit+                -> S.Set UnitId                 -> ModIface                 -> IsSafeImport                 -> IsBootInterface                 -> ImportedBy                 -> ImportAvails-calculateAvails home_unit iface mod_safe' want_boot imported_by =+calculateAvails home_unit other_home_units iface mod_safe' want_boot imported_by =   let imp_mod    = mi_module iface       imp_sem_mod= mi_semantic_module iface       orph_iface = mi_orphan (mi_final_exts iface)@@ -427,6 +503,7 @@       deps       = mi_deps iface       trust      = getSafeMode $ mi_trust iface       trust_pkg  = mi_trust_pkg iface+      is_sig     = mi_hsc_src iface == HsigFile        -- If the module exports anything defined in this module, just       -- ignore it.  Reason: otherwise it looks as if there are two@@ -454,61 +531,72 @@       -- 'imp_finsts' if it defines an orphan or instance family; thus the       -- orph_iface/has_iface tests. -      orphans | orph_iface = ASSERT2( not (imp_sem_mod `elem` dep_orphs deps), ppr imp_sem_mod <+> ppr (dep_orphs deps) )-                             imp_sem_mod : dep_orphs deps-              | otherwise  = dep_orphs deps+      deporphs  = dep_orphs deps+      depfinsts = dep_finsts deps -      finsts | has_finsts = ASSERT2( not (imp_sem_mod `elem` dep_finsts deps), ppr imp_sem_mod <+> ppr (dep_orphs deps) )-                            imp_sem_mod : dep_finsts deps-             | otherwise  = dep_finsts deps+      orphans | orph_iface = assertPpr (not (imp_sem_mod `elem` deporphs)) (ppr imp_sem_mod <+> ppr deporphs) $+                             imp_sem_mod : deporphs+              | otherwise  = deporphs +      finsts | has_finsts = assertPpr (not (imp_sem_mod `elem` depfinsts)) (ppr imp_sem_mod <+> ppr depfinsts) $+                            imp_sem_mod : depfinsts+             | otherwise  = depfinsts++      -- Trusted packages are a lot like orphans.+      trusted_pkgs | mod_safe' = dep_trusted_pkgs deps+                   | otherwise = S.empty++       pkg = moduleUnit (mi_module iface)       ipkg = toUnitId pkg        -- Does this import mean we now require our own pkg       -- to be trusted? See Note [Trust Own Package]       ptrust = trust == Sf_Trustworthy || trust_pkg+      pkg_trust_req+        | isHomeUnit home_unit pkg = ptrust+        | otherwise = False -      (dependent_mods, dependent_pkgs, pkg_trust_req)-         | isHomeUnit home_unit pkg =-            -- Imported module is from the home package-            -- Take its dependent modules and add imp_mod itself-            -- Take its dependent packages unchanged-            ---            -- NB: (dep_mods deps) might include a hi-boot file-            -- for the module being compiled, CM. Do *not* filter-            -- this out (as we used to), because when we've-            -- finished dealing with the direct imports we want to-            -- know if any of them depended on CM.hi-boot, in-            -- which case we should do the hi-boot consistency-            -- check.  See GHC.Iface.Load.loadHiBootInterface-            ( GWIB { gwib_mod = moduleName imp_mod, gwib_isBoot = want_boot } : dep_mods deps-            , dep_pkgs deps-            , ptrust-            )+      dependent_pkgs = if toUnitId pkg `S.member` other_home_units+                        then S.empty+                        else S.singleton ipkg -         | otherwise =-            -- Imported module is from another package-            -- Dump the dependent modules-            -- Add the package imp_mod comes from to the dependent packages-            ASSERT2( not (ipkg `elem` (map fst $ dep_pkgs deps))-                   , ppr ipkg <+> ppr (dep_pkgs deps) )-            ([], (ipkg, False) : dep_pkgs deps, False)+      direct_mods = mkModDeps $ if toUnitId pkg `S.member` other_home_units+                      then S.singleton (moduleUnitId imp_mod, (GWIB (moduleName imp_mod) want_boot))+                      else S.empty +      dep_boot_mods_map = mkModDeps (dep_boot_mods deps)++      boot_mods+        -- If we are looking for a boot module, it must be HPT+        | IsBoot <- want_boot = extendInstalledModuleEnv dep_boot_mods_map (toUnitId <$> imp_mod) (GWIB (moduleName imp_mod) IsBoot)+        -- Now we are importing A properly, so don't go looking for+        -- A.hs-boot+        | isHomeUnit home_unit pkg = dep_boot_mods_map+        -- There's no boot files to find in external imports+        | otherwise = emptyInstalledModuleEnv++      sig_mods =+        if is_sig+          then moduleName imp_mod : dep_sig_mods deps+          else dep_sig_mods deps++   in ImportAvails {           imp_mods       = unitModuleEnv (mi_module iface) [imported_by],           imp_orphs      = orphans,           imp_finsts     = finsts,-          imp_dep_mods   = mkModDeps dependent_mods,-          imp_dep_pkgs   = S.fromList . map fst $ dependent_pkgs,+          imp_sig_mods   = sig_mods,+          imp_direct_dep_mods = direct_mods,+          imp_dep_direct_pkgs = dependent_pkgs,+          imp_boot_mods = boot_mods,+           -- Add in the imported modules trusted package           -- requirements. ONLY do this though if we import the           -- module as a safe import.           -- See Note [Tracking Trust Transitively]           -- and Note [Trust Transitive Property]-          imp_trust_pkgs = if mod_safe'-                               then S.fromList . map fst $ filter snd dependent_pkgs-                               else S.empty,+          imp_trust_pkgs = trusted_pkgs,           -- Do we require our own pkg to be trusted?           -- See Note [Trust Own Package]           imp_trust_own_pkg = pkg_trust_req@@ -520,9 +608,12 @@ -- `Data.List.singleton` proposal. See #17244. warnUnqualifiedImport :: ImportDecl GhcPs -> ModIface -> RnM () warnUnqualifiedImport decl iface =-    whenWOptM Opt_WarnCompatUnqualifiedImports-    $ when bad_import-    $ addWarnAt (Reason Opt_WarnCompatUnqualifiedImports) loc warning+    when bad_import $ do+      let msg = TcRnUnknownMessage $+            mkPlainDiagnostic (WarningWithFlag Opt_WarnCompatUnqualifiedImports)+                              noHints+                              warning+      addDiagnosticAt loc msg   where     mod = mi_module iface     loc = getLocA $ ideclName decl@@ -535,9 +626,9 @@         Just (False, _) -> True         _               -> False     bad_import =-      mod `elemModuleSet` qualifiedMods-      && not is_qual+         not is_qual       && not has_import_list+      && mod `elemModuleSet` qualifiedMods      warning = vcat       [ text "To ensure compatibility with future core libraries changes"@@ -549,10 +640,10 @@     qualifiedMods = mkModuleSet [ dATA_LIST ]  -warnRedundantSourceImport :: ModuleName -> SDoc+warnRedundantSourceImport :: ModuleName -> TcRnMessage warnRedundantSourceImport mod_name-  = text "Unnecessary {-# SOURCE #-} in the import of module"-          <+> quotes (ppr mod_name)+  = TcRnUnknownMessage $ mkPlainDiagnostic WarningWithoutFlag noHints $+      text "Unnecessary {-# SOURCE #-} in the import of module" <+> quotes (ppr mod_name)  {- ************************************************************************@@ -598,7 +689,8 @@ -- see Note [Top-level Names in Template Haskell decl quotes]  extendGlobalRdrEnvRn avails new_fixities-  = do  { (gbl_env, lcl_env) <- getEnvs+  = checkNoErrs $  -- See Note [Fail fast on duplicate definitions]+    do  { (gbl_env, lcl_env) <- getEnvs         ; stage <- getStage         ; isGHCi <- getIsGHCi         ; let rdr_env  = tcg_rdr_env gbl_env@@ -612,7 +704,7 @@               -- See Note [GlobalRdrEnv shadowing]               inBracket = isBrackStage stage -              lcl_env_TH = lcl_env { tcl_rdr = delLocalRdrEnvList (tcl_rdr lcl_env) new_occs }+              lcl_env_TH = lcl_env { tcl_rdr = minusLocalRdrEnv (tcl_rdr lcl_env) new_occs }                            -- See Note [GlobalRdrEnv shadowing]                lcl_env2 | inBracket = lcl_env_TH@@ -620,7 +712,7 @@                -- Deal with shadowing: see Note [GlobalRdrEnv shadowing]               want_shadowing = isGHCi || inBracket-              rdr_env1 | want_shadowing = shadowNames rdr_env new_names+              rdr_env1 | want_shadowing = shadowNames rdr_env new_occs                        | otherwise      = rdr_env                lcl_env3 = lcl_env2 { tcl_th_bndrs = extendNameEnvList th_bndrs@@ -637,7 +729,7 @@         ; return (gbl_env', lcl_env3) }   where     new_names = concatMap availGreNames avails-    new_occs  = map occName new_names+    new_occs  = occSetToEnv (mkOccSet (map occName new_names))      -- If there is a fixity decl for the gre, add it to the fixity env     extend_fix_env fix_env gre@@ -675,7 +767,19 @@               (False, True)  -> isNoFieldSelectorGRE gre'               (False, False) -> False -{-+{- Note [Fail fast on duplicate definitions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If there are duplicate bindings for the same thing, we want to fail+fast. Having two bindings for the same thing can cause follow-on errors.+Example (test T9975a):+   data Test = Test { x :: Int }+   pattern Test wat = Test { x = wat }+This defines 'Test' twice.  The second defn has no field-names; and then+we get an error from Test { x=wat }, saying "Test has no field 'x'".++Easiest thing is to bale out fast on duplicate definitions, which+we do via `checkNoErrs` on `extendGlobalRdrEnvRn`.+ Note [Reporting duplicate local declarations] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In general, a single module may not define the same OccName multiple times. This@@ -799,7 +903,7 @@                                  (tyClGroupTyClDecls tycl_decls)         ; traceRn "getLocalNonValBinders 1" (ppr tc_avails)         ; envs <- extendGlobalRdrEnvRn tc_avails fixity_env-        ; setEnvs envs $ do {+        ; restoreEnvs envs $ do {             -- Bring these things into scope first             -- See Note [Looking up family names in family instances] @@ -823,9 +927,12 @@         ; traceRn "getLocalNonValBinders 2" (ppr avails)         ; (tcg_env, tcl_env) <- extendGlobalRdrEnvRn avails fixity_env +        -- Force the field access so that tcg_env is not retained. The+        -- selector thunk optimisation doesn't kick-in, see #20139+        ; let !old_field_env = tcg_field_env tcg_env         -- Extend tcg_field_env with new fields (this used to be the         -- work of extendRecordFieldEnv)-        ; let field_env = extendNameEnvList (tcg_field_env tcg_env) flds+              field_env = extendNameEnvList old_field_env flds               envs      = (tcg_env { tcg_field_env = field_env }, tcl_env)          ; traceRn "getLocalNonValBinders 3" (vcat [ppr flds, ppr field_env])@@ -871,7 +978,7 @@             = [( find_con_name rdr                , concatMap find_con_decl_flds (unLoc cdflds) )]         find_con_flds (L _ (ConDeclGADT { con_names = rdrs-                                        , con_g_args = RecConGADT flds }))+                                        , con_g_args = RecConGADT flds _ }))             = [ ( find_con_name rdr                  , concatMap find_con_decl_flds (unLoc flds))               | L _ rdr <- rdrs ]@@ -943,7 +1050,7 @@ newRecordSelector :: DuplicateRecordFields -> FieldSelectors -> [Name] -> LFieldOcc GhcPs -> RnM FieldLabel newRecordSelector _ _ [] _ = error "newRecordSelector: datatype has no constructors!" newRecordSelector dup_fields_ok has_sel (dc:_) (L loc (FieldOcc _ (L _ fld)))-  = do { selName <- newTopSrcBinder $ L (noAnnSrcSpan loc) $ field+  = do { selName <- newTopSrcBinder $ L (l2l loc) $ field        ; return $ FieldLabel { flLabel = fieldLabelString                              , flHasDuplicateRecordFields = dup_fields_ok                              , flHasFieldSelector = has_sel@@ -1128,16 +1235,16 @@             -> (GreName, AvailInfo, Maybe Name)     combine (NormalGreName name1, a1@(AvailTC p1 _), mb1)             (NormalGreName name2, a2@(AvailTC p2 _), mb2)-      = ASSERT2( name1 == name2 && isNothing mb1 && isNothing mb2-               , ppr name1 <+> ppr name2 <+> ppr mb1 <+> ppr mb2 )+      = assertPpr (name1 == name2 && isNothing mb1 && isNothing mb2)+                  (ppr name1 <+> ppr name2 <+> ppr mb1 <+> ppr mb2) $         if p1 == name1 then (NormalGreName name1, a1, Just p2)                        else (NormalGreName name1, a2, Just p1)     -- 'combine' may also be called for pattern synonyms which appear both     -- unassociated and associated (see Note [Importing PatternSynonyms]).     combine (c1, a1, mb1) (c2, a2, mb2)-      = ASSERT2( c1 == c2 && isNothing mb1 && isNothing mb2-                          && (isAvailTC a1 || isAvailTC a2)-               , ppr c1 <+> ppr c2 <+> ppr a1 <+> ppr a2 <+> ppr mb1 <+> ppr mb2 )+      = assertPpr (c1 == c2 && isNothing mb1 && isNothing mb2+                          && (isAvailTC a1 || isAvailTC a2))+                  (ppr c1 <+> ppr c2 <+> ppr a1 <+> ppr a2 <+> ppr mb1 <+> ppr mb2) $         if isAvailTC a1 then (c1, a1, Nothing)                         else (c1, a2, Nothing) @@ -1147,7 +1254,7 @@     lookup_name :: IE GhcPs -> RdrName -> IELookupM (Name, AvailInfo, Maybe Name)     lookup_name ie rdr        | isQual rdr              = failLookupWith (QualImportError rdr)-       | Just succ <- mb_success = case nameEnvElts succ of+       | Just succ <- mb_success = case nonDetNameEnvElts succ of                                      -- See Note [Importing DuplicateRecordFields]                                      [(c,a,x)] -> return (greNameMangledName c, a, x)                                      xs -> failLookupWith (AmbiguousImport rdr (map sndOf3 xs))@@ -1165,15 +1272,21 @@         where             -- Warn when importing T(..) if T was exported abstractly             emit_warning (DodgyImport n) = whenWOptM Opt_WarnDodgyImports $-              addWarn (Reason Opt_WarnDodgyImports) (dodgyImportWarn n)+              addTcRnDiagnostic (TcRnDodgyImports n)             emit_warning MissingImportList = whenWOptM Opt_WarnMissingImportList $-              addWarn (Reason Opt_WarnMissingImportList) (missingImportListItem ieRdr)-            emit_warning (BadImportW ie) = whenWOptM Opt_WarnDodgyImports $-              addWarn (Reason Opt_WarnDodgyImports) (lookup_err_msg (BadImport ie))+              addTcRnDiagnostic (TcRnMissingImportList ieRdr)+            emit_warning (BadImportW ie) = whenWOptM Opt_WarnDodgyImports $ do+              let msg = TcRnUnknownMessage $+                    mkPlainDiagnostic (WarningWithFlag Opt_WarnDodgyImports)+                                      noHints+                                      (lookup_err_msg (BadImport ie))+              addDiagnostic msg              run_lookup :: IELookupM a -> TcRn (Maybe a)             run_lookup m = case m of-              Failed err -> addErr (lookup_err_msg err) >> return Nothing+              Failed err -> do+                addErr $ TcRnUnknownMessage $ mkPlainError noHints (lookup_err_msg err)+                return Nothing               Succeeded a -> return (Just a)              lookup_err_msg err = case err of@@ -1465,86 +1578,103 @@ *                                                                      * ********************************************************************* -} +{-+Note [Missing signatures]+~~~~~~~~~~~~~~~~~~~~~~~~~+There are four warning flags in play:++  * -Wmissing-exported-signatures+    Warn about any exported top-level function/value without a type signature.+    Does not include pattern synonyms.++  * -Wmissing-signatures+    Warn about any top-level function/value without a type signature. Does not+    include pattern synonyms. Takes priority over -Wmissing-exported-signatures.++  * -Wmissing-exported-pattern-synonym-signatures+    Warn about any exported pattern synonym without a type signature.++  * -Wmissing-pattern-synonym-signatures+    Warn about any pattern synonym without a type signature. Takes priority over+    -Wmissing-exported-pattern-synonym-signatures.++-}+ -- | Warn the user about top level binders that lack type signatures. -- Called /after/ type inference, so that we can report the -- inferred type of the function warnMissingSignatures :: TcGblEnv -> RnM () warnMissingSignatures gbl_env-  = do { let exports = availsToNameSet (tcg_exports gbl_env)+  = do { warn_binds    <- woptM Opt_WarnMissingSignatures+       ; warn_pat_syns <- woptM Opt_WarnMissingPatternSynonymSignatures+       ; let exports = availsToNameSet (tcg_exports gbl_env)              sig_ns  = tcg_sigs gbl_env                -- We use sig_ns to exclude top-level bindings that are generated by GHC              binds    = collectHsBindsBinders CollNoDictBinders $ tcg_binds gbl_env              pat_syns = tcg_patsyns gbl_env -         -- Warn about missing signatures-         -- Do this only when we have a type to offer-       ; warn_missing_sigs  <- woptM Opt_WarnMissingSignatures-       ; warn_only_exported <- woptM Opt_WarnMissingExportedSignatures-       ; warn_pat_syns      <- woptM Opt_WarnMissingPatternSynonymSignatures--       ; let add_sig_warns-               | warn_missing_sigs  = add_warns Opt_WarnMissingSignatures-               | warn_only_exported = add_warns Opt_WarnMissingExportedSignatures-               | warn_pat_syns      = add_warns Opt_WarnMissingPatternSynonymSignatures-               | otherwise          = return ()--             add_warns flag-                = when (warn_missing_sigs || warn_only_exported)-                       (mapM_ add_bind_warn binds) >>-                  when (warn_missing_sigs || warn_pat_syns)-                       (mapM_ add_pat_syn_warn pat_syns)-                where-                  add_pat_syn_warn p-                    = add_warn name $-                      hang (text "Pattern synonym with no type signature:")-                         2 (text "pattern" <+> pprPrefixName name <+> dcolon <+> pp_ty)-                    where-                      name  = patSynName p-                      pp_ty = pprPatSynType p--                  add_bind_warn :: Id -> IOEnv (Env TcGblEnv TcLclEnv) ()-                  add_bind_warn id-                    = do { env <- tcInitTidyEnv     -- Why not use emptyTidyEnv?-                         ; let name    = idName id-                               (_, ty) = tidyOpenType env (idType id)-                               ty_msg  = pprSigmaType ty-                         ; add_warn name $-                           hang (text "Top-level binding with no type signature:")-                              2 (pprPrefixName name <+> dcolon <+> ty_msg) }+             not_ghc_generated :: Name -> Bool+             not_ghc_generated name = name `elemNameSet` sig_ns -                  add_warn name msg-                    = when (name `elemNameSet` sig_ns && export_check name)-                           (addWarnAt (Reason flag) (getSrcSpan name) msg)+             add_binding_warn :: Id -> RnM ()+             add_binding_warn id =+               when (not_ghc_generated name) $+               do { env <- tcInitTidyEnv -- Why not use emptyTidyEnv?+                  ; let (_, ty) = tidyOpenType env (idType id)+                        missing = MissingTopLevelBindingSig name ty+                        diag = TcRnMissingSignature missing exported warn_binds+                  ; addDiagnosticAt (getSrcSpan name) diag }+               where+                 name = idName id+                 exported = if name `elemNameSet` exports+                            then IsExported+                            else IsNotExported -                  export_check name-                    = warn_missing_sigs || not warn_only_exported || name `elemNameSet` exports+             add_patsyn_warn :: PatSyn -> RnM ()+             add_patsyn_warn ps =+               when (not_ghc_generated name) $+                 addDiagnosticAt (getSrcSpan name)+                  (TcRnMissingSignature missing exported warn_pat_syns)+               where+                 name = patSynName ps+                 missing = MissingPatSynSig ps+                 exported = if name `elemNameSet` exports+                            then IsExported+                            else IsNotExported -       ; add_sig_warns }+         -- Warn about missing signatures+         -- Do this only when we have a type to offer+         -- See Note [Missing signatures]+       ; mapM_ add_binding_warn binds+       ; mapM_ add_patsyn_warn  pat_syns+       }  -- | Warn the user about tycons that lack kind signatures. -- Called /after/ type (and kind) inference, so that we can report the -- inferred kinds. warnMissingKindSignatures :: TcGblEnv -> RnM () warnMissingKindSignatures gbl_env-  = do { warn_missing_kind_sigs  <- woptM Opt_WarnMissingKindSignatures-       ; cusks_enabled <- xoptM LangExt.CUSKs-       ; when (warn_missing_kind_sigs) (mapM_ (add_ty_warn cusks_enabled) tcs)+  = do { cusks_enabled <- xoptM LangExt.CUSKs+       ; mapM_ (add_ty_warn cusks_enabled) tcs        }   where     tcs = tcg_tcs gbl_env     ksig_ns = tcg_ksigs gbl_env+    exports = availsToNameSet (tcg_exports gbl_env)+    not_ghc_generated :: Name -> Bool+    not_ghc_generated name = name `elemNameSet` ksig_ns -    add_ty_warn :: Bool -> TyCon -> IOEnv (Env TcGblEnv TcLclEnv) ()-    add_ty_warn cusks_enabled tyCon = when (name `elemNameSet` ksig_ns) $-        addWarnAt (Reason Opt_WarnMissingKindSignatures) (getSrcSpan name) $-            hang msg 2 (text "type" <+> pprPrefixName name <+> dcolon <+> ki_msg)+    add_ty_warn :: Bool -> TyCon -> RnM ()+    add_ty_warn cusks_enabled tyCon =+      when (not_ghc_generated name) $+        addDiagnosticAt (getSrcSpan name) diag       where-        msg | cusks_enabled = text "Top-level type constructor with no standalone kind signature or CUSK:"-            | otherwise     = text "Top-level type constructor with no standalone kind signature:"         name = tyConName tyCon-        ki = tyConKind tyCon-        ki_msg :: SDoc-        ki_msg = pprKind ki+        diag = TcRnMissingSignature missing exported False+        missing = MissingTyConKindSig tyCon cusks_enabled+        exported = if name `elemNameSet` exports+                   then IsExported+                   else IsNotExported  {- *********************************************************@@ -1684,7 +1814,7 @@        RealSrcLoc decl_loc _ -> Map.insertWith add decl_loc [gre] imp_map        UnhelpfulLoc _ -> imp_map        where-          best_imp_spec = bestImport imp_specs+          best_imp_spec = bestImport (bagToList imp_specs)           add _ gres = gre : gres  warnUnusedImport :: WarningFlag -> NameEnv (FieldLabelString, Parent)@@ -1703,7 +1833,9 @@    -- Nothing used; drop entire declaration   | null used-  = addWarnAt (Reason flag) (locA loc) msg1+  = let dia = TcRnUnknownMessage $+          mkPlainDiagnostic (WarningWithFlag flag) noHints msg1+    in addDiagnosticAt (locA loc) dia    -- Everything imported is used; nop   | null unused@@ -1714,11 +1846,13 @@   | Just (_, L _ imports) <- ideclHiding decl   , length unused == 1   , Just (L loc _) <- find (\(L _ ie) -> ((ieName ie) :: Name) `elem` unused) imports-  = addWarnAt (Reason flag) (locA loc) msg2+  = let dia = TcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag flag) noHints msg2+    in addDiagnosticAt (locA loc) dia    -- Some imports are unused   | otherwise-  = addWarnAt (Reason flag) (locA loc)  msg2+  = let dia = TcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag flag) noHints msg2+    in addDiagnosticAt (locA loc) dia    where     msg1 = vcat [ pp_herald <+> quotes pp_mod <+> is_redundant@@ -1781,8 +1915,8 @@       | otherwise       = do { let ImportDecl { ideclName    = L _ mod_name                             , ideclSource  = is_boot-                            , ideclPkgQual = mb_pkg } = decl-           ; iface <- loadSrcInterface doc mod_name is_boot (fmap sl_fs mb_pkg)+                            , ideclPkgQual = pkg_qual } = decl+           ; iface <- loadSrcInterface doc mod_name is_boot pkg_qual            ; let used_avails = gresToAvailInfo used_gres                  lies = map (L l) (concatMap (to_ie iface) used_avails)            ; return (L l (decl { ideclHiding = Just (False, L (l2l l) lies) })) }@@ -2006,30 +2140,10 @@ illegalImportItemErr :: SDoc illegalImportItemErr = text "Illegal import item" -dodgyImportWarn :: RdrName -> SDoc-dodgyImportWarn item-  = dodgyMsg (text "import") item (dodgyMsgInsert item :: IE GhcPs)--dodgyMsg :: (Outputable a, Outputable b) => SDoc -> a -> b -> SDoc-dodgyMsg kind tc ie-  = sep [ text "The" <+> kind <+> ptext (sLit "item")-                    -- <+> quotes (ppr (IEThingAll (noLoc (IEName $ noLoc tc))))-                     <+> quotes (ppr ie)-                <+> text "suggests that",-          quotes (ppr tc) <+> text "has (in-scope) constructors or class methods,",-          text "but it has none" ]--dodgyMsgInsert :: forall p . IdP (GhcPass p) -> IE (GhcPass p)-dodgyMsgInsert tc = IEThingAll noAnn ii-  where-    ii :: LIEWrappedName (IdP (GhcPass p))-    ii = noLocA (IEName $ noLocA tc)-- addDupDeclErr :: [GlobalRdrElt] -> TcRn () addDupDeclErr [] = panic "addDupDeclErr: empty list" addDupDeclErr gres@(gre : _)-  = addErrAt (getSrcSpan (last sorted_names)) $+  = addErrAt (getSrcSpan (last sorted_names)) $ TcRnUnknownMessage $ mkPlainError noHints $     -- Report the error at the later location     vcat [text "Multiple declarations of" <+>              quotes (ppr (greOccName gre)),@@ -2047,24 +2161,21 @@  missingImportListWarn :: ModuleName -> SDoc missingImportListWarn mod-  = text "The module" <+> quotes (ppr mod) <+> ptext (sLit "does not have an explicit import list")--missingImportListItem :: IE GhcPs -> SDoc-missingImportListItem ie-  = text "The import item" <+> quotes (ppr ie) <+> ptext (sLit "does not have an explicit import list")+  = text "The module" <+> quotes (ppr mod) <+> text "does not have an explicit import list" -moduleWarn :: ModuleName -> WarningTxt -> SDoc+moduleWarn :: ModuleName -> WarningTxt GhcRn -> SDoc moduleWarn mod (WarningTxt _ txt)-  = sep [ text "Module" <+> quotes (ppr mod) <> ptext (sLit ":"),-          nest 2 (vcat (map (ppr . sl_fs . unLoc) txt)) ]+  = sep [ text "Module" <+> quotes (ppr mod) <> colon,+          nest 2 (vcat (map (ppr . hsDocString . unLoc) txt)) ] moduleWarn mod (DeprecatedTxt _ txt)   = sep [ text "Module" <+> quotes (ppr mod)                                 <+> text "is deprecated:",-          nest 2 (vcat (map (ppr . sl_fs . unLoc) txt)) ]+          nest 2 (vcat (map (ppr . hsDocString . unLoc) txt)) ] -packageImportErr :: SDoc+packageImportErr :: TcRnMessage packageImportErr-  = text "Package-qualified imports are not enabled; use PackageImports"+  = TcRnUnknownMessage $ mkPlainError noHints $+  text "Package-qualified imports are not enabled; use PackageImports"  -- This data decl will parse OK --      data T = a Int@@ -2079,6 +2190,7 @@ checkConName :: RdrName -> TcRn () checkConName name = checkErr (isRdrDataCon name) (badDataCon name) -badDataCon :: RdrName -> SDoc+badDataCon :: RdrName -> TcRnMessage badDataCon name-   = hsep [text "Illegal data constructor name", quotes (ppr name)]+   = TcRnUnknownMessage $ mkPlainError noHints $+   hsep [text "Illegal data constructor name", quotes (ppr name)]
GHC/Rename/Pat.hs view
@@ -1,11 +1,11 @@ {-# LANGUAGE TypeApplications #-}-{-# LANGUAGE CPP                 #-} {-# LANGUAGE DeriveFunctor       #-} {-# LANGUAGE FlexibleContexts    #-} {-# LANGUAGE RankNTypes          #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies        #-} {-# LANGUAGE ViewPatterns        #-}+{-# LANGUAGE DisambiguateRecordFields #-}  {-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}@@ -37,9 +37,6 @@                -- Literals               rnLit, rnOverLit,--             -- Pattern Error message that is also used elsewhere-             patSigErr              ) where  -- ENH: thin imports to only what is necessary for patterns@@ -49,20 +46,21 @@ import {-# SOURCE #-} GHC.Rename.Expr ( rnLExpr ) import {-# SOURCE #-} GHC.Rename.Splice ( rnSplicePat ) -#include "HsVersions.h"- import GHC.Hs+import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Zonk   ( hsOverLitName ) import GHC.Rename.Env import GHC.Rename.Fixity-import GHC.Rename.Utils    ( HsDocContext(..), newLocalBndrRn, bindLocalNames+import GHC.Rename.Utils    ( newLocalBndrRn, bindLocalNames                            , warnUnusedMatches, newLocalBndrRn                            , checkUnusedRecordWildcard-                           , checkDupNames, checkDupAndShadowedNames )+                           , checkDupNames, checkDupAndShadowedNames+                           , wrapGenSpan, genHsApps, genLHsVar, genHsIntegralLit, warnForallIdentifier ) import GHC.Rename.HsType import GHC.Builtin.Names import GHC.Types.Avail ( greNameMangledName )+import GHC.Types.Error import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.Name.Reader@@ -71,7 +69,7 @@ import GHC.Utils.Misc import GHC.Data.List.SetOps( removeDups ) import GHC.Utils.Outputable-import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Types.SrcLoc import GHC.Types.Literal   ( inCharRange ) import GHC.Builtin.Types   ( nilDataCon )@@ -149,7 +147,7 @@  lookupConCps :: LocatedN RdrName -> CpsRn (LocatedN Name) lookupConCps con_rdr-  = CpsRn (\k -> do { con_name <- lookupLocatedOccRn con_rdr+  = CpsRn (\k -> do { con_name <- lookupLocatedOccRnConstr con_rdr                     ; (r, fvs) <- k con_name                     ; return (r, addOneFV fvs (unLoc con_name)) })     -- We add the constructor name to the free vars@@ -220,7 +218,7 @@     -- Do not report unused names in interactive contexts     -- i.e. when you type 'x <- e' at the GHCi prompt     report_unused = case ctxt of-                      StmtCtxt GhciStmtCtxt -> False+                      StmtCtxt (HsDoStmt GhciStmtCtxt) -> False                       -- also, don't warn in pattern quotes, as there                       -- is no RHS where the variables can be used!                       ThPatQuote            -> False@@ -234,14 +232,16 @@ newPatName :: NameMaker -> LocatedN RdrName -> CpsRn Name newPatName (LamMk report_unused) rdr_name   = CpsRn (\ thing_inside ->-        do { name <- newLocalBndrRn rdr_name+        do { warnForallIdentifier rdr_name+           ; name <- newLocalBndrRn rdr_name            ; (res, fvs) <- bindLocalNames [name] (thing_inside name)            ; when report_unused $ warnUnusedMatches [name] fvs            ; return (res, name `delFV` fvs) })  newPatName (LetMk is_top fix_env) rdr_name   = CpsRn (\ thing_inside ->-        do { name <- case is_top of+        do { warnForallIdentifier rdr_name+           ; name <- case is_top of                        NotTopLevel -> newLocalBndrRn rdr_name                        TopLevel    -> newTopSrcBinder rdr_name            ; bindLocalNames [name] $@@ -297,6 +297,85 @@  See #12615 for some more examples. +Note [Handling overloaded and rebindable patterns]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Overloaded paterns and rebindable patterns are desugared in the renamer+using the HsPatExpansion mechanism detailed in:+Note [Rebindable syntax and HsExpansion]+The approach is similar to that of expressions, which is further detailed+in Note [Handling overloaded and rebindable constructs] in GHC.Rename.Expr.++Here are the patterns that are currently desugared in this way:++* ListPat (list patterns [p1,p2,p3])+  When (and only when) OverloadedLists is on, desugar to a view pattern:+    [p1, p2, p3]+  ==>+    toList -> [p1, p2, p3]+              ^^^^^^^^^^^^ built-in (non-overloaded) list pattern+  NB: the type checker and desugarer still see ListPat,+      but to them it always means the built-in list pattern.+  See Note [Desugaring overloaded list patterns] below for more details.++We expect to add to this list as we deal with more patterns via the expansion+mechanism.++Note [Desugaring overloaded list patterns]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If OverloadedLists is enabled, we desugar a list pattern to a view pattern:++  [p1, p2, p3]+==>+  toList -> [p1, p2, p3]++This happens directly in the renamer, using the HsPatExpansion mechanism+detailed in Note [Rebindable syntax and HsExpansion].++Note that we emit a special view pattern: we additionally keep track of an+inverse to the pattern.+See Note [Invertible view patterns] in GHC.Tc.TyCl.PatSyn for details.++== Wrinkle ==++This is all fine, except in one very specific case:+  - when RebindableSyntax is off,+  - and the type being matched on is already a list type.++In this case, it is undesirable to desugar an overloaded list pattern into+a view pattern. To illustrate, consider the following program:++> {-# LANGUAGE OverloadedLists #-}+>+> f []    = True+> f (_:_) = False++Without any special logic, the pattern `[]` is desugared to `(toList -> [])`,+whereas `(_:_)` remains a constructor pattern. This implies that the argument+of `f` is necessarily a list (even though `OverloadedLists` is enabled).+After desugaring the overloaded list pattern `[]`, and type-checking, we obtain:++> f :: [a] -> Bool+> f (toList -> []) = True+> f (_:_)          = False++The pattern match checker then warns that the pattern `[]` is not covered,+as it isn't able to look through view patterns.+We can see that this is silly: as we are matching on a list, `toList` doesn't+actually do anything. So we ignore it, and desugar the pattern to an explicit+list pattern, instead of a view pattern.++Note however that this is not necessarily sound, because it is possible to have+a list `l` such that `toList l` is not the same as `l`.+This can happen with an overlapping instance, such as the following:++instance {-# OVERLAPPING #-} IsList [Int] where+  type Item [Int] = Int+  toList = reverse+  fromList = reverse++We make the assumption that no such instance exists, in order to avoid worsening+pattern-match warnings (see #14547).+ ********************************************************* *                                                      *         External entry points@@ -343,7 +422,7 @@           -- Nor can we check incrementally for shadowing, else we'll           --    complain *twice* about duplicates e.g. f (x,x) = ...           ---          -- See note [Don't report shadowing for pattern synonyms]+          -- See Note [Don't report shadowing for pattern synonyms]         ; let bndrs = collectPatsBinders CollNoDictBinders pats'         ; addErrCtxt doc_pat $           if isPatSynCtxt ctxt@@ -403,8 +482,9 @@  rnPatAndThen :: NameMaker -> Pat GhcPs -> CpsRn (Pat GhcRn) rnPatAndThen _  (WildPat _)   = return (WildPat noExtField)-rnPatAndThen mk (ParPat x pat)  = do { pat' <- rnLPatAndThen mk pat-                                     ; return (ParPat x pat') }+rnPatAndThen mk (ParPat x lpar pat rpar) =+  do { pat' <- rnLPatAndThen mk pat+     ; return (ParPat x lpar pat' rpar) } rnPatAndThen mk (LazyPat _ pat) = do { pat' <- rnLPatAndThen mk pat                                      ; return (LazyPat noExtField pat') } rnPatAndThen mk (BangPat _ pat) = do { pat' <- rnLPatAndThen mk pat@@ -438,7 +518,7 @@   = do { ovlStr <- liftCps (xoptM LangExt.OverloadedStrings)        ; if ovlStr          then rnPatAndThen mk-                           (mkNPat (noLoc (mkHsIsString src s))+                           (mkNPat (noLocA (mkHsIsString src s))                                       Nothing noAnn)          else normal_lit }   | otherwise = normal_lit@@ -478,15 +558,18 @@  rnPatAndThen mk p@(ViewPat _ expr pat)   = do { liftCps $ do { vp_flag <- xoptM LangExt.ViewPatterns-                      ; checkErr vp_flag (badViewPat p) }+                      ; checkErr vp_flag (TcRnIllegalViewPattern p) }          -- Because of the way we're arranging the recursive calls,          -- this will be in the right context        ; expr' <- liftCpsFV $ rnLExpr expr        ; pat' <- rnLPatAndThen mk pat        -- Note: at this point the PreTcType in ty can only be a placeHolder        -- ; return (ViewPat expr' pat' ty) }-       ; return (ViewPat noExtField expr' pat') } +       -- Note: we can't cook up an inverse for an arbitrary view pattern,+       -- so we pass 'Nothing'.+       ; return (ViewPat Nothing expr' pat') }+ rnPatAndThen mk (ConPat _ con args)    -- rnConPatAndThen takes care of reconstructing the pattern    -- The pattern for the empty list needs to be replaced by an empty explicit list pattern when overloaded lists is turned on.@@ -497,12 +580,25 @@       False   -> rnConPatAndThen mk con args  rnPatAndThen mk (ListPat _ pats)-  = do { opt_OverloadedLists <- liftCps $ xoptM LangExt.OverloadedLists+  = do { opt_OverloadedLists  <- liftCps $ xoptM LangExt.OverloadedLists        ; pats' <- rnLPatsAndThen mk pats-       ; case opt_OverloadedLists of-          True -> do { (to_list_name,_) <- liftCps $ lookupSyntax toListName-                     ; return (ListPat (Just to_list_name) pats')}-          False -> return (ListPat Nothing pats') }+       ; if not opt_OverloadedLists+         then return (ListPat noExtField pats')+         else+    -- If OverloadedLists is enabled, desugar to a view pattern.+    -- See Note [Desugaring overloaded list patterns]+    do { (to_list_name,_)     <- liftCps $ lookupSyntaxName toListName+       -- Use 'fromList' as proof of invertibility of the view pattern.+       -- See Note [Invertible view patterns] in GHC.Tc.TyCl.PatSyn+       ; (from_list_n_name,_) <- liftCps $ lookupSyntaxName fromListNName+       ; let+           lit_n   = mkIntegralLit (length pats)+           hs_lit  = genHsIntegralLit lit_n+           inverse = genHsApps from_list_n_name [hs_lit]+           rn_list_pat  = ListPat noExtField pats'+           exp_expr     = genLHsVar to_list_name+           exp_list_pat = ViewPat (Just inverse) exp_expr (wrapGenSpan rn_list_pat)+       ; return $ mkExpandedPat rn_list_pat exp_list_pat }}  rnPatAndThen mk (TuplePat _ pats boxed)   = do { pats' <- rnLPatsAndThen mk pats@@ -549,7 +645,7 @@       unless (scoped_tyvars && type_app) $         case listToMaybe tyargs of           Nothing    -> pure ()-          Just tyarg -> addErr $+          Just tyarg -> addErr $ TcRnUnknownMessage $ mkPlainError noHints $             hang (text "Illegal visible type application in a pattern:"                     <+> quotes (char '@' <> ppr tyarg))                2 (text "Both ScopedTypeVariables and TypeApplications are"@@ -593,15 +689,15 @@   where     mkVarPat l n = VarPat noExtField (L (noAnnSrcSpan l) n)     rn_field (L l fld, n') =-      do { arg' <- rnLPatAndThen (nested_mk dd mk n') (hsRecFieldArg fld)-         ; return (L l (fld { hsRecFieldArg = arg' })) }+      do { arg' <- rnLPatAndThen (nested_mk dd mk n') (hfbRHS fld)+         ; return (L l (fld { hfbRHS = arg' })) }      loc = maybe noSrcSpan getLoc dd      -- Get the arguments of the implicit binders     implicit_binders fs (unLoc -> n) = collectPatsBinders CollNoDictBinders implicit_pats       where-        implicit_pats = map (hsRecFieldArg . unLoc) (drop n fs)+        implicit_pats = map (hfbRHS . unLoc) (drop n fs)      -- Don't warn for let P{..} = ... in ...     check_unused_wildcard = case mk of@@ -614,6 +710,23 @@     nested_mk (Just (unLoc -> n)) (LamMk report_unused) n'       = LamMk (report_unused && (n' <= n)) ++{- *********************************************************************+*                                                                      *+              Generating code for HsPatExpanded+      See Note [Handling overloaded and rebindable constructs]+*                                                                      *+********************************************************************* -}++-- | Build a 'HsPatExpansion' out of an extension constructor,+--   and the two components of the expansion: original and+--   desugared patterns+mkExpandedPat+  :: Pat GhcRn -- ^ source pattern+  -> Pat GhcRn -- ^ expanded pattern+  -> Pat GhcRn -- ^ suitably wrapped 'HsPatExpansion'+mkExpandedPat a b = XPat (HsPatExpanded a b)+ {- ************************************************************************ *                                                                      *@@ -644,7 +757,7 @@ -- This is used for record construction and pattern-matching, but not updates.  rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })-  = do { pun_ok      <- xoptM LangExt.RecordPuns+  = do { pun_ok      <- xoptM LangExt.NamedFieldPuns        ; disambig_ok <- xoptM LangExt.DisambiguateRecordFields        ; let parent = guard disambig_ok >> mb_con        ; flds1  <- mapM (rn_fld pun_ok parent) flds@@ -662,23 +775,23 @@     rn_fld :: Bool -> Maybe Name -> LHsRecField GhcPs (LocatedA arg)            -> RnM (LHsRecField GhcRn (LocatedA arg))     rn_fld pun_ok parent (L l-                           (HsRecField-                              { hsRecFieldLbl =+                           (HsFieldBind+                              { hfbLHS =                                   (L loc (FieldOcc _ (L ll lbl)))-                              , hsRecFieldArg = arg-                              , hsRecPun      = pun }))-      = do { sel <- setSrcSpan loc $ lookupRecFieldOcc parent lbl+                              , hfbRHS = arg+                              , hfbPun      = pun }))+      = do { sel <- setSrcSpanA loc $ lookupRecFieldOcc parent lbl            ; arg' <- if pun-                     then do { checkErr pun_ok (badPun (L loc lbl))+                     then do { checkErr pun_ok (TcRnIllegalFieldPunning (L (locA loc) lbl))                                -- Discard any module qualifier (#11662)                              ; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl)-                             ; return (L (noAnnSrcSpan loc) (mk_arg loc arg_rdr)) }+                             ; return (L (l2l loc) (mk_arg (locA loc) arg_rdr)) }                      else return arg-           ; return (L l (HsRecField-                             { hsRecFieldAnn = noAnn-                             , hsRecFieldLbl = (L loc (FieldOcc sel (L ll lbl)))-                             , hsRecFieldArg = arg'-                             , hsRecPun      = pun })) }+           ; return (L l (HsFieldBind+                             { hfbAnn = noAnn+                             , hfbLHS = (L loc (FieldOcc sel (L ll lbl)))+                             , hfbRHS = arg'+                             , hfbPun      = pun })) }       rn_dotdot :: Maybe (Located Int)      -- See Note [DotDot fields] in GHC.Hs.Pat@@ -691,12 +804,12 @@                                 -- isn't in scope the constructor lookup will add                                 -- an error but still return an unbound name. We                                 -- don't want that to screw up the dot-dot fill-in stuff.-      = ASSERT( flds `lengthIs` n )+      = assert (flds `lengthIs` n) $         do { dd_flag <- xoptM LangExt.RecordWildCards            ; checkErr dd_flag (needFlagDotDot ctxt)            ; (rdr_env, lcl_env) <- getRdrEnvs            ; con_fields <- lookupConstructorFields con-           ; when (null con_fields) (addErr (badDotDotCon con))+           ; when (null con_fields) (addErr (TcRnIllegalWildcardsInConstructor con))            ; let present_flds = mkOccSet $ map rdrNameOcc (getFieldLbls flds)                     -- For constructor uses (but not patterns)@@ -719,12 +832,12 @@             ; addUsedGREs dot_dot_gres            ; let locn = noAnnSrcSpan loc-           ; return [ L (noAnnSrcSpan loc) (HsRecField-                        { hsRecFieldAnn = noAnn-                        , hsRecFieldLbl-                           = L loc (FieldOcc sel (L (noAnnSrcSpan loc) arg_rdr))-                        , hsRecFieldArg = L locn (mk_arg loc arg_rdr)-                        , hsRecPun      = False })+           ; return [ L (noAnnSrcSpan loc) (HsFieldBind+                        { hfbAnn = noAnn+                        , hfbLHS+                           = L (noAnnSrcSpan loc) (FieldOcc sel (L (noAnnSrcSpan loc) arg_rdr))+                        , hfbRHS = L locn (mk_arg loc arg_rdr)+                        , hfbPun      = False })                     | fl <- dot_dot_fields                     , let sel     = flSelector fl                     , let arg_rdr = mkVarUnqual (flLabel fl) ] }@@ -753,45 +866,45 @@     :: [LHsRecUpdField GhcPs]     -> RnM ([LHsRecUpdField GhcRn], FreeVars) rnHsRecUpdFields flds-  = do { pun_ok        <- xoptM LangExt.RecordPuns+  = do { pun_ok        <- xoptM LangExt.NamedFieldPuns        ; dup_fields_ok <- xopt_DuplicateRecordFields <$> getDynFlags        ; (flds1, fvss) <- mapAndUnzipM (rn_fld pun_ok dup_fields_ok) flds        ; mapM_ (addErr . dupFieldErr HsRecFieldUpd) dup_flds         -- Check for an empty record update  e {}        -- NB: don't complain about e { .. }, because rn_dotdot has done that already-       ; when (null flds) $ addErr emptyUpdateErr+       ; when (null flds) $ addErr TcRnEmptyRecordUpdate         ; return (flds1, plusFVs fvss) }   where     rn_fld :: Bool -> DuplicateRecordFields -> LHsRecUpdField GhcPs            -> RnM (LHsRecUpdField GhcRn, FreeVars)-    rn_fld pun_ok dup_fields_ok (L l (HsRecField { hsRecFieldLbl = L loc f-                                               , hsRecFieldArg = arg-                                               , hsRecPun      = pun }))+    rn_fld pun_ok dup_fields_ok (L l (HsFieldBind { hfbLHS = L loc f+                                                  , hfbRHS = arg+                                                  , hfbPun      = pun }))       = do { let lbl = rdrNameAmbiguousFieldOcc f-           ; mb_sel <- setSrcSpan loc $+           ; mb_sel <- setSrcSpanA loc $                       -- Defer renaming of overloaded fields to the typechecker                       -- See Note [Disambiguating record fields] in GHC.Tc.Gen.Head                       lookupRecFieldOcc_update dup_fields_ok lbl            ; arg' <- if pun-                     then do { checkErr pun_ok (badPun (L loc lbl))+                     then do { checkErr pun_ok (TcRnIllegalFieldPunning (L (locA loc) lbl))                                -- Discard any module qualifier (#11662)                              ; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl)-                             ; return (L (noAnnSrcSpan loc) (HsVar noExtField-                                              (L (noAnnSrcSpan loc) arg_rdr))) }+                             ; return (L (l2l loc) (HsVar noExtField+                                              (L (l2l loc) arg_rdr))) }                      else return arg            ; (arg'', fvs) <- rnLExpr arg'             ; let (lbl', fvs') = case mb_sel of                    UnambiguousGre gname -> let sel_name = greNameMangledName gname-                                           in (Unambiguous sel_name (L (noAnnSrcSpan loc) lbl), fvs `addOneFV` sel_name)-                   AmbiguousFields       -> (Ambiguous   noExtField (L (noAnnSrcSpan loc) lbl), fvs)+                                           in (Unambiguous sel_name (L (l2l loc) lbl), fvs `addOneFV` sel_name)+                   AmbiguousFields       -> (Ambiguous   noExtField (L (l2l loc) lbl), fvs) -           ; return (L l (HsRecField { hsRecFieldAnn = noAnn-                                     , hsRecFieldLbl = L loc lbl'-                                     , hsRecFieldArg = arg''-                                     , hsRecPun      = pun }), fvs') }+           ; return (L l (HsFieldBind { hfbAnn = noAnn+                                      , hfbLHS = L loc lbl'+                                      , hfbRHS = arg''+                                      , hfbPun = pun }), fvs') }      dup_flds :: [NE.NonEmpty RdrName]         -- Each list represents a RdrName that occurred more than once@@ -802,41 +915,25 @@   getFieldIds :: [LHsRecField GhcRn arg] -> [Name]-getFieldIds flds = map (unLoc . hsRecFieldSel . unLoc) flds+getFieldIds flds = map (hsRecFieldSel . unLoc) flds  getFieldLbls :: forall p arg . UnXRec p => [LHsRecField p arg] -> [RdrName] getFieldLbls flds-  = map (unLoc . rdrNameFieldOcc . unLoc . hsRecFieldLbl . unXRec @p) flds+  = map (unXRec @p . foLabel . unXRec @p . hfbLHS . unXRec @p) flds  getFieldUpdLbls :: [LHsRecUpdField GhcPs] -> [RdrName]-getFieldUpdLbls flds = map (rdrNameAmbiguousFieldOcc . unLoc . hsRecFieldLbl . unLoc) flds--needFlagDotDot :: HsRecFieldContext -> SDoc-needFlagDotDot ctxt = vcat [text "Illegal `..' in record" <+> pprRFC ctxt,-                            text "Use RecordWildCards to permit this"]--badDotDotCon :: Name -> SDoc-badDotDotCon con-  = vcat [ text "Illegal `..' notation for constructor" <+> quotes (ppr con)-         , nest 2 (text "The constructor has no labelled fields") ]--emptyUpdateErr :: SDoc-emptyUpdateErr = text "Empty record update"+getFieldUpdLbls flds = map (rdrNameAmbiguousFieldOcc . unLoc . hfbLHS . unLoc) flds -badPun :: Located RdrName -> SDoc-badPun fld = vcat [text "Illegal use of punning for field" <+> quotes (ppr fld),-                   text "Use NamedFieldPuns to permit this"]+needFlagDotDot :: HsRecFieldContext -> TcRnMessage+needFlagDotDot = TcRnIllegalWildcardsInRecord . toRecordFieldPart -dupFieldErr :: HsRecFieldContext -> NE.NonEmpty RdrName -> SDoc-dupFieldErr ctxt dups-  = hsep [text "duplicate field name",-          quotes (ppr (NE.head dups)),-          text "in record", pprRFC ctxt]+dupFieldErr :: HsRecFieldContext -> NE.NonEmpty RdrName -> TcRnMessage+dupFieldErr ctxt = TcRnDuplicateFieldName (toRecordFieldPart ctxt) -pprRFC :: HsRecFieldContext -> SDoc-pprRFC (HsRecFieldCon {}) = text "construction"-pprRFC (HsRecFieldPat {}) = text "pattern"-pprRFC (HsRecFieldUpd {}) = text "update"+toRecordFieldPart :: HsRecFieldContext -> RecordFieldPart+toRecordFieldPart (HsRecFieldCon n)  = RecordFieldConstructor n+toRecordFieldPart (HsRecFieldPat n)  = RecordFieldPattern     n+toRecordFieldPart (HsRecFieldUpd {}) = RecordFieldUpdate  {- ************************************************************************@@ -851,7 +948,7 @@ -}  rnLit :: HsLit p -> RnM ()-rnLit (HsChar _ c) = checkErr (inCharRange c) (bogusCharError c)+rnLit (HsChar _ c) = checkErr (inCharRange c) (TcRnCharLiteralOutOfRange c) rnLit _ = return ()  -- | Turn a Fractional-looking literal which happens to be an integer into an@@ -898,31 +995,10 @@         ; let std_name = hsOverLitName val         ; (from_thing_name, fvs1) <- lookupSyntaxName std_name         ; let rebindable = from_thing_name /= std_name-              lit' = lit { ol_witness = nl_HsVar from_thing_name-                         , ol_ext = rebindable }+              lit' = lit { ol_ext = OverLitRn { ol_rebindable = rebindable+                                              , ol_from_fun = noLocA from_thing_name } }         ; if isNegativeZeroOverLit lit'           then do { (negate_name, fvs2) <- lookupSyntaxExpr negateName                   ; return ((lit' { ol_val = negateOverLitVal val }, Just negate_name)                                   , fvs1 `plusFV` fvs2) }           else return ((lit', Nothing), fvs1) }--{--************************************************************************-*                                                                      *-\subsubsection{Errors}-*                                                                      *-************************************************************************--}--patSigErr :: Outputable a => a -> SDoc-patSigErr ty-  =  (text "Illegal signature in pattern:" <+> ppr ty)-        $$ nest 4 (text "Use ScopedTypeVariables to permit it")--bogusCharError :: Char -> SDoc-bogusCharError c-  = text "character literal out of range: '\\" <> char c  <> char '\''--badViewPat :: Pat GhcPs -> SDoc-badViewPat pat = vcat [text "Illegal view pattern: " <+> ppr pat,-                       text "Use ViewPatterns to enable view patterns"]
GHC/Rename/Splice.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP          #-}+ {-# LANGUAGE TypeFamilies #-}  {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}@@ -6,27 +6,27 @@ module GHC.Rename.Splice (         rnTopSpliceDecls,         rnSpliceType, rnSpliceExpr, rnSplicePat, rnSpliceDecl,-        rnBracket,+        rnTypedBracket, rnUntypedBracket,         checkThLocalName         , traceSplice, SpliceInfo(..)   ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Types.Name import GHC.Types.Name.Set import GHC.Hs import GHC.Types.Name.Reader+import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Driver.Env.Types  import GHC.Rename.Env-import GHC.Rename.Utils   ( HsDocContext(..), newLocalBndrRn )+import GHC.Rename.Utils   ( newLocalBndrRn ) import GHC.Rename.Unbound ( isUnboundName ) import GHC.Rename.Module  ( rnSrcDecls, findSplice ) import GHC.Rename.Pat     ( rnPat )+import GHC.Types.Error import GHC.Types.Basic    ( TopLevelFlag, isTopLevel ) import GHC.Types.SourceText ( SourceText(..) ) import GHC.Utils.Outputable@@ -42,7 +42,7 @@  import GHC.Driver.Session import GHC.Data.FastString-import GHC.Utils.Logger  ( dumpIfSet_dyn_printer, DumpFormat (..), getLogger )+import GHC.Utils.Logger import GHC.Utils.Panic import GHC.Driver.Hooks import GHC.Builtin.Names.TH ( decsQTyConName, expQTyConName, liftName@@ -73,27 +73,30 @@ ************************************************************************ -} -rnBracket :: HsExpr GhcPs -> HsBracket GhcPs -> RnM (HsExpr GhcRn, FreeVars)-rnBracket e br_body-  = addErrCtxt (quotationCtxtDoc br_body) $-    do { -- Check that -XTemplateHaskellQuotes is enabled and available-         thQuotesEnabled <- xoptM LangExt.TemplateHaskellQuotes+-- Check that -XTemplateHaskellQuotes is enabled and available+checkForTemplateHaskellQuotes :: HsExpr GhcPs ->  RnM ()+checkForTemplateHaskellQuotes e =+    do { thQuotesEnabled <- xoptM LangExt.TemplateHaskellQuotes        ; unless thQuotesEnabled $-           failWith ( vcat+           failWith ( TcRnUnknownMessage $ mkPlainError noHints $ vcat                       [ text "Syntax error on" <+> ppr e                       , text ("Perhaps you intended to use TemplateHaskell"                               ++ " or TemplateHaskellQuotes") ] )+       } +rnTypedBracket :: HsExpr GhcPs -> LHsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars)+rnTypedBracket e br_body+  = addErrCtxt (typedQuotationCtxtDoc br_body) $+    do { checkForTemplateHaskellQuotes e+          -- Check for nested brackets        ; cur_stage <- getStage        ; case cur_stage of-           { Splice Typed   -> checkTc (isTypedBracket br_body)-                                       illegalUntypedBracket-           ; Splice Untyped -> checkTc (not (isTypedBracket br_body))-                                       illegalTypedBracket+           { Splice Typed   -> return ()+           ; Splice Untyped -> failWithTc illegalTypedBracket            ; RunSplice _    ->                -- See Note [RunSplice ThLevel] in GHC.Tc.Types.-               pprPanic "rnBracket: Renaming bracket when running a splice"+               pprPanic "rnTypedBracket: Renaming typed bracket when running a splice"                         (ppr e)            ; Comp           -> return ()            ; Brack {}       -> failWithTc illegalBracket@@ -102,27 +105,50 @@          -- Brackets are desugared to code that mentions the TH package        ; recordThUse -       ; case isTypedBracket br_body of-            True  -> do { traceRn "Renaming typed TH bracket" empty-                        ; (body', fvs_e) <--                          setStage (Brack cur_stage RnPendingTyped) $-                                   rn_bracket cur_stage br_body-                        ; return (HsBracket noAnn body', fvs_e) }+       ; traceRn "Renaming typed TH bracket" empty+       ; (body', fvs_e) <- setStage (Brack cur_stage RnPendingTyped) $ rnLExpr br_body -            False -> do { traceRn "Renaming untyped TH bracket" empty-                        ; ps_var <- newMutVar []-                        ; (body', fvs_e) <--                          -- See Note [Rebindable syntax and Template Haskell]-                          unsetXOptM LangExt.RebindableSyntax $-                          setStage (Brack cur_stage (RnPendingUntyped ps_var)) $-                                   rn_bracket cur_stage br_body-                        ; pendings <- readMutVar ps_var-                        ; return (HsRnBracketOut noExtField body' pendings, fvs_e) }+       ; return (HsTypedBracket noExtField body', fvs_e)+        } -rn_bracket :: ThStage -> HsBracket GhcPs -> RnM (HsBracket GhcRn, FreeVars)-rn_bracket outer_stage br@(VarBr x flg rdr_name)+rnUntypedBracket :: HsExpr GhcPs -> HsQuote GhcPs -> RnM (HsExpr GhcRn, FreeVars)+rnUntypedBracket e br_body+  = addErrCtxt (untypedQuotationCtxtDoc br_body) $+    do { checkForTemplateHaskellQuotes e++         -- Check for nested brackets+       ; cur_stage <- getStage+       ; case cur_stage of+           { Splice Typed   -> failWithTc illegalUntypedBracket+           ; Splice Untyped -> return ()+           ; RunSplice _    ->+               -- See Note [RunSplice ThLevel] in GHC.Tc.Types.+               pprPanic "rnUntypedBracket: Renaming untyped bracket when running a splice"+                        (ppr e)+           ; Comp           -> return ()+           ; Brack {}       -> failWithTc illegalBracket+           }++         -- Brackets are desugared to code that mentions the TH package+       ; recordThUse++       ; traceRn "Renaming untyped TH bracket" empty+       ; ps_var <- newMutVar []+       ; (body', fvs_e) <-+         -- See Note [Rebindable syntax and Template Haskell]+         unsetXOptM LangExt.RebindableSyntax $+         setStage (Brack cur_stage (RnPendingUntyped ps_var)) $+                  rn_utbracket cur_stage br_body+       ; pendings <- readMutVar ps_var+       ; return (HsUntypedBracket pendings body', fvs_e)++       }++rn_utbracket :: ThStage -> HsQuote GhcPs -> RnM (HsQuote GhcRn, FreeVars)+rn_utbracket outer_stage br@(VarBr x flg rdr_name)   = do { name <- lookupOccRn (unLoc rdr_name)+       ; check_namespace flg name        ; this_mod <- getModule         ; when (flg && nameIsLocalOrFrom this_mod name) $@@ -136,7 +162,7 @@                              | isTopLevel top_lvl                              -> when (isExternalName name) (keepAlive name)                              | otherwise-                             -> do { traceRn "rn_bracket VarBr"+                             -> do { traceRn "rn_utbracket VarBr"                                       (ppr name <+> ppr bind_lvl                                                 <+> ppr outer_stage)                                    ; checkTc (thLevel outer_stage + 1 == bind_lvl)@@ -145,16 +171,16 @@                     }        ; return (VarBr x flg (noLocA name), unitFV name) } -rn_bracket _ (ExpBr x e) = do { (e', fvs) <- rnLExpr e-                            ; return (ExpBr x e', fvs) }+rn_utbracket _ (ExpBr x e) = do { (e', fvs) <- rnLExpr e+                                ; return (ExpBr x e', fvs) } -rn_bracket _ (PatBr x p)+rn_utbracket _ (PatBr x p)   = rnPat ThPatQuote p $ \ p' -> return (PatBr x p', emptyFVs) -rn_bracket _ (TypBr x t) = do { (t', fvs) <- rnLHsType TypBrCtx t-                              ; return (TypBr x t', fvs) }+rn_utbracket _ (TypBr x t) = do { (t', fvs) <- rnLHsType TypBrCtx t+                                ; return (TypBr x t', fvs) } -rn_bracket _ (DecBrL x decls)+rn_utbracket _ (DecBrL x decls)   = do { group <- groupDecls decls        ; gbl_env  <- getGblEnv        ; let new_gbl_env = gbl_env { tcg_dus = emptyDUs }@@ -164,7 +190,7 @@                               rnSrcDecls group                -- Discard the tcg_env; it contains only extra info about fixity-        ; traceRn "rn_bracket dec" (ppr (tcg_dus tcg_env) $$+        ; traceRn "rn_utbracket dec" (ppr (tcg_dus tcg_env) $$                    ppr (duUses (tcg_dus tcg_env)))         ; return (DecBrG x group', duUses (tcg_dus tcg_env)) }   where@@ -180,32 +206,45 @@                   }            }} -rn_bracket _ (DecBrG {}) = panic "rn_bracket: unexpected DecBrG"+rn_utbracket _ (DecBrG {}) = panic "rn_ut_bracket: unexpected DecBrG" -rn_bracket _ (TExpBr x e) = do { (e', fvs) <- rnLExpr e-                               ; return (TExpBr x e', fvs) } -quotationCtxtDoc :: HsBracket GhcPs -> SDoc-quotationCtxtDoc br_body+-- | Ensure that we are not using a term-level name in a type-level namespace+-- or vice-versa. Throws a 'TcRnIncorrectNameSpace' error if there is a problem.+check_namespace :: Bool -> Name -> RnM ()+check_namespace is_single_tick nm+  = unless (isValNameSpace ns == is_single_tick) $+      failWithTc $ (TcRnIncorrectNameSpace nm True)+  where+    ns = nameNameSpace nm++typedQuotationCtxtDoc :: LHsExpr GhcPs -> SDoc+typedQuotationCtxtDoc br_body+  = hang (text "In the Template Haskell typed quotation")+         2 (thTyBrackets . ppr $ br_body)++untypedQuotationCtxtDoc :: HsQuote GhcPs -> SDoc+untypedQuotationCtxtDoc br_body   = hang (text "In the Template Haskell quotation")          2 (ppr br_body) -illegalBracket :: SDoc-illegalBracket =+illegalBracket :: TcRnMessage+illegalBracket = TcRnUnknownMessage $ mkPlainError noHints $     text "Template Haskell brackets cannot be nested" <+>     text "(without intervening splices)" -illegalTypedBracket :: SDoc-illegalTypedBracket =+illegalTypedBracket :: TcRnMessage+illegalTypedBracket = TcRnUnknownMessage $ mkPlainError noHints $     text "Typed brackets may only appear in typed splices." -illegalUntypedBracket :: SDoc-illegalUntypedBracket =+illegalUntypedBracket :: TcRnMessage+illegalUntypedBracket = TcRnUnknownMessage $ mkPlainError noHints $     text "Untyped brackets may only appear in untyped splices." -quotedNameStageErr :: HsBracket GhcPs -> SDoc+quotedNameStageErr :: HsQuote GhcPs -> TcRnMessage quotedNameStageErr br-  = sep [ text "Stage error: the non-top-level quoted name" <+> ppr br+  = TcRnUnknownMessage $ mkPlainError noHints $+    sep [ text "Stage error: the non-top-level quoted name" <+> ppr br         , text "must be used at the same stage at which it is bound" ]  @@ -294,7 +333,8 @@   let (herald, ext) = spliceExtension splice   extEnabled <- xoptM ext   unless extEnabled-    (failWith $ text herald <+> text "are not permitted without" <+> ppr ext)+    (failWith $ TcRnUnknownMessage $ mkPlainError noHints $+       text herald <+> text "are not permitted without" <+> ppr ext)   where      spliceExtension :: HsSplice GhcPs -> (String, LangExt.Extension)      spliceExtension (HsQuasiQuote {}) = ("Quasi-quotes", LangExt.QuasiQuotes)@@ -451,11 +491,11 @@                 runRnSplice UntypedExpSplice runMetaE ppr rn_splice            ; (lexpr3, fvs) <- checkNoErrs (rnLExpr rn_expr)              -- See Note [Delaying modFinalizers in untyped splices].-           ; return ( HsPar noAnn $ HsSpliceE noAnn-                            . HsSpliced noExtField (ThModFinalizers mod_finalizers)-                            . HsSplicedExpr <$>-                            lexpr3-                    , fvs)+           ; let e =  HsSpliceE noAnn+                    . HsSpliced noExtField (ThModFinalizers mod_finalizers)+                    . HsSplicedExpr+                        <$> lexpr3+           ; return (gHsPar e, fvs)            }  {- Note [Running splices in the Renamer]@@ -695,12 +735,11 @@            ; (pat, mod_finalizers) <-                 runRnSplice UntypedPatSplice runMetaP ppr rn_splice              -- See Note [Delaying modFinalizers in untyped splices].-           ; return ( Left $ ParPat noAnn $ ((SplicePat noExtField)-                              . HsSpliced noExtField (ThModFinalizers mod_finalizers)-                              . HsSplicedPat)  `mapLoc`-                              pat-                    , emptyFVs-                    ) }+           ; let p =  SplicePat noExtField+                    . HsSpliced noExtField (ThModFinalizers mod_finalizers)+                    . HsSplicedPat+                        <$> pat+           ; return (Left $ gParPat p, emptyFVs) }               -- Wrap the result of the quasi-quoter in parens so that we don't               -- lose the outermost location set by runQuasiQuote (#7918) @@ -819,10 +858,8 @@        traceOptTcRn Opt_D_dump_splices (spliceDebugDoc loc)         when is_decl $ do -- Raw material for -dth-dec-file-        dflags <- getDynFlags         logger <- getLogger-        liftIO $ dumpIfSet_dyn_printer alwaysQualify logger dflags Opt_D_th_dec_file-                                       "" FormatHaskell (spliceCodeDoc loc)+        liftIO $ putDumpFileMaybe logger Opt_D_th_dec_file "" FormatHaskell (spliceCodeDoc loc)   where     -- `-ddump-splices`     spliceDebugDoc :: SrcSpan -> SDoc@@ -840,11 +877,13 @@       = vcat [ text "--" <+> ppr loc <> colon <+> text "Splicing" <+> text sd              , gen ] -illegalTypedSplice :: SDoc-illegalTypedSplice = text "Typed splices may not appear in untyped brackets"+illegalTypedSplice :: TcRnMessage+illegalTypedSplice = TcRnUnknownMessage $ mkPlainError noHints $+  text "Typed splices may not appear in untyped brackets" -illegalUntypedSplice :: SDoc-illegalUntypedSplice = text "Untyped splices may not appear in typed brackets"+illegalUntypedSplice :: TcRnMessage+illegalUntypedSplice = TcRnUnknownMessage $ mkPlainError noHints $+  text "Untyped splices may not appear in typed brackets"  checkThLocalName :: Name -> RnM () checkThLocalName name@@ -912,10 +951,7 @@               pend_splice = PendingRnSplice UntypedExpSplice name lift_expr            -- Warning for implicit lift (#17804)-        ; whenWOptM Opt_WarnImplicitLift $-            addWarnTc (Reason Opt_WarnImplicitLift)-                       (text "The variable" <+> quotes (ppr name) <+>-                        text "is implicitly lifted in the TH quotation")+        ; addDetailedDiagnostic (TcRnImplicitLift name)            -- Update the pending splices         ; ps <- readMutVar ps_var
GHC/Rename/Unbound.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE PatternSynonyms #-}+ {-  This module contains helper functions for reporting and creating@@ -9,12 +11,15 @@    , mkUnboundNameRdr    , isUnboundName    , reportUnboundName+   , reportUnboundName'    , unknownNameSuggestions+   , WhatLooking(..)    , WhereLooking(..)+   , LookingFor(..)    , unboundName    , unboundNameX    , notInScopeErr-   , exactNameErr+   , nameSpacesRelated    ) where @@ -23,14 +28,20 @@ import GHC.Driver.Session import GHC.Driver.Ppr +import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Builtin.Names ( mkUnboundName, isUnboundName, getUnique)-import GHC.Utils.Outputable as Outputable import GHC.Utils.Misc  import GHC.Data.Maybe import GHC.Data.FastString +import qualified GHC.LanguageExtensions as LangExt++import GHC.Types.Hint+  ( GhcHint (SuggestExtension, RemindFieldSelectorSuppressed, ImportSuggestion, SuggestSimilarNames)+  , LanguageExtensionHint (SuggestSingleExtension)+  , ImportSuggestion(..), SimilarName(..), HowInScope(..) ) import GHC.Types.SrcLoc as SrcLoc import GHC.Types.Name import GHC.Types.Name.Reader@@ -40,7 +51,11 @@ import GHC.Unit.Module.Imported import GHC.Unit.Home.ModInfo +import GHC.Data.Bag+import GHC.Utils.Outputable (empty)+ import Data.List (sortBy, partition, nub)+import Data.List.NonEmpty ( pattern (:|), NonEmpty ) import Data.Function ( on )  {-@@ -51,140 +66,141 @@ ************************************************************************ -} -data WhereLooking = WL_Any        -- Any binding+-- What kind of suggestion are we looking for? #19843+data WhatLooking = WL_Anything    -- Any binding+                 | WL_Constructor -- Constructors and pattern synonyms+                        -- E.g. in K { f1 = True }, if K is not in scope,+                        -- suggest only constructors+                 | WL_RecField    -- Record fields+                        -- E.g. in K { f1 = True, f2 = False }, if f2 is not in+                        -- scope, suggest only constructor fields+                 | WL_None        -- No suggestions+                        -- WS_None is used for rebindable syntax, where there+                        -- is no point in suggesting alternative spellings+                 deriving Eq++data WhereLooking = WL_Anywhere   -- Any binding                   | WL_Global     -- Any top-level binding (local or imported)                   | WL_LocalTop   -- Any top-level binding in this module                   | WL_LocalOnly                         -- Only local bindings-                        -- (pattern synonyms declaractions,-                        -- see Note [Renaming pattern synonym variables])+                        -- (pattern synonyms declarations,+                        -- see Note [Renaming pattern synonym variables]+                        -- in GHC.Rename.Bind) +data LookingFor = LF { lf_which :: WhatLooking+                     , lf_where :: WhereLooking+                     }+ mkUnboundNameRdr :: RdrName -> Name mkUnboundNameRdr rdr = mkUnboundName (rdrNameOcc rdr) +reportUnboundName' :: WhatLooking -> RdrName -> RnM Name+reportUnboundName' what_look rdr = unboundName (LF what_look WL_Anywhere) rdr+ reportUnboundName :: RdrName -> RnM Name-reportUnboundName rdr = unboundName WL_Any rdr+reportUnboundName = reportUnboundName' WL_Anything -unboundName :: WhereLooking -> RdrName -> RnM Name-unboundName wl rdr = unboundNameX wl rdr Outputable.empty+unboundName :: LookingFor -> RdrName -> RnM Name+unboundName lf rdr = unboundNameX lf rdr [] -unboundNameX :: WhereLooking -> RdrName -> SDoc -> RnM Name-unboundNameX where_look rdr_name extra+unboundNameX :: LookingFor -> RdrName -> [GhcHint] -> RnM Name+unboundNameX looking_for rdr_name hints   = do  { dflags <- getDynFlags         ; let show_helpful_errors = gopt Opt_HelpfulErrors dflags-              err = notInScopeErr rdr_name $$ extra+              err = notInScopeErr (lf_where looking_for) rdr_name         ; if not show_helpful_errors-          then addErr err+          then addErr $ TcRnNotInScope err rdr_name [] hints           else do { local_env  <- getLocalRdrEnv                   ; global_env <- getGlobalRdrEnv                   ; impInfo <- getImports                   ; currmod <- getModule                   ; hpt <- getHpt-                  ; let suggestions = unknownNameSuggestions_ where_look-                          dflags hpt currmod global_env local_env impInfo-                          rdr_name-                  ; addErr (err $$ suggestions) }+                  ; let (imp_errs, suggs) =+                          unknownNameSuggestions_ looking_for+                            dflags hpt currmod global_env local_env impInfo+                            rdr_name+                  ; addErr $+                      TcRnNotInScope err rdr_name imp_errs (hints ++ suggs) }         ; return (mkUnboundNameRdr rdr_name) } -notInScopeErr :: RdrName -> SDoc-notInScopeErr rdr_name-  = case isExact_maybe rdr_name of-      Just name -> exactNameErr name-      Nothing -> hang (text "Not in scope:")-                  2 (what <+> quotes (ppr rdr_name))-  where-    what = pprNonVarNameSpace (occNameSpace (rdrNameOcc rdr_name)) -type HowInScope = Either SrcSpan ImpDeclSpec-     -- Left loc    =>  locally bound at loc-     -- Right ispec =>  imported as specified by ispec-+notInScopeErr :: WhereLooking -> RdrName -> NotInScopeError+notInScopeErr where_look rdr_name+  | Just name <- isExact_maybe rdr_name+  = NoExactName name+  | WL_LocalTop <- where_look+  = NoTopLevelBinding+  | otherwise+  = NotInScope  -- | Called from the typechecker ("GHC.Tc.Errors") when we find an unbound variable-unknownNameSuggestions :: DynFlags+unknownNameSuggestions :: WhatLooking -> DynFlags                        -> HomePackageTable -> Module                        -> GlobalRdrEnv -> LocalRdrEnv -> ImportAvails-                       -> RdrName -> SDoc-unknownNameSuggestions = unknownNameSuggestions_ WL_Any+                       -> RdrName -> ([ImportError], [GhcHint])+unknownNameSuggestions what_look = unknownNameSuggestions_ (LF what_look WL_Anywhere) -unknownNameSuggestions_ :: WhereLooking -> DynFlags+unknownNameSuggestions_ :: LookingFor -> DynFlags                        -> HomePackageTable -> Module                        -> GlobalRdrEnv -> LocalRdrEnv -> ImportAvails-                       -> RdrName -> SDoc-unknownNameSuggestions_ where_look dflags hpt curr_mod global_env local_env-                          imports tried_rdr_name =-    similarNameSuggestions where_look dflags global_env local_env tried_rdr_name $$-    importSuggestions where_look global_env hpt-                      curr_mod imports tried_rdr_name $$-    extensionSuggestions tried_rdr_name $$-    fieldSelectorSuggestions global_env tried_rdr_name+                       -> RdrName -> ([ImportError], [GhcHint])+unknownNameSuggestions_ looking_for dflags hpt curr_mod global_env local_env+                          imports tried_rdr_name = (imp_errs, suggs)+  where+    suggs = mconcat+      [ if_ne (SuggestSimilarNames tried_rdr_name) $+          similarNameSuggestions looking_for dflags global_env local_env tried_rdr_name+      , map ImportSuggestion imp_suggs+      , extensionSuggestions tried_rdr_name+      , fieldSelectorSuggestions global_env tried_rdr_name ]+    (imp_errs, imp_suggs) = importSuggestions looking_for global_env hpt curr_mod imports tried_rdr_name +    if_ne :: (NonEmpty a -> b) -> [a] -> [b]+    if_ne _ []       = []+    if_ne f (a : as) = [f (a :| as)]+ -- | When the name is in scope as field whose selector has been suppressed by -- NoFieldSelectors, display a helpful message explaining this.-fieldSelectorSuggestions :: GlobalRdrEnv -> RdrName -> SDoc+fieldSelectorSuggestions :: GlobalRdrEnv -> RdrName -> [GhcHint] fieldSelectorSuggestions global_env tried_rdr_name-  | null gres = Outputable.empty-  | otherwise = text "NB:"-      <+> quotes (ppr tried_rdr_name)-      <+> text "is a field selector" <+> whose-      $$ text "that has been suppressed by NoFieldSelectors"+  | null gres = []+  | otherwise = [RemindFieldSelectorSuppressed tried_rdr_name parents]   where     gres = filter isNoFieldSelectorGRE $                lookupGRE_RdrName' tried_rdr_name global_env     parents = [ parent | ParentIs parent <- map gre_par gres ] -    -- parents may be empty if this is a pattern synonym field without a selector-    whose | null parents = empty-          | otherwise    = text "belonging to the type" <> plural parents-                             <+> pprQuotedList parents--similarNameSuggestions :: WhereLooking -> DynFlags-                        -> GlobalRdrEnv -> LocalRdrEnv-                        -> RdrName -> SDoc-similarNameSuggestions where_look dflags global_env-                        local_env tried_rdr_name-  = case suggest of-      []  -> Outputable.empty-      [p] -> perhaps <+> pp_item p-      ps  -> sep [ perhaps <+> text "one of these:"-                 , nest 2 (pprWithCommas pp_item ps) ]+similarNameSuggestions :: LookingFor -> DynFlags+                       -> GlobalRdrEnv -> LocalRdrEnv+                       -> RdrName -> [SimilarName]+similarNameSuggestions looking_for@(LF what_look where_look) dflags global_env+                       local_env tried_rdr_name+  = fuzzyLookup (showPpr dflags tried_rdr_name) all_possibilities   where-    all_possibilities :: [(String, (RdrName, HowInScope))]-    all_possibilities-       =  [ (showPpr dflags r, (r, Left loc))-          | (r,loc) <- local_possibilities local_env ]-       ++ [ (showPpr dflags r, rp) | (r, rp) <- global_possibilities global_env ]--    suggest = fuzzyLookup (showPpr dflags tried_rdr_name) all_possibilities-    perhaps = text "Perhaps you meant"--    pp_item :: (RdrName, HowInScope) -> SDoc-    pp_item (rdr, Left loc) = pp_ns rdr <+> quotes (ppr rdr) <+> loc' -- Locally defined-        where loc' = case loc of-                     UnhelpfulSpan l -> parens (ppr l)-                     RealSrcSpan l _ -> parens (text "line" <+> int (srcSpanStartLine l))-    pp_item (rdr, Right is) = pp_ns rdr <+> quotes (ppr rdr) <+>   -- Imported-                              parens (text "imported from" <+> ppr (is_mod is))--    pp_ns :: RdrName -> SDoc-    pp_ns rdr | ns /= tried_ns = pprNameSpace ns-              | otherwise      = Outputable.empty-      where ns = rdrNameSpace rdr+    all_possibilities :: [(String, SimilarName)]+    all_possibilities = case what_look of+      WL_None -> []+      _ -> [ (showPpr dflags r, SimilarRdrName r (LocallyBoundAt loc))+           | (r,loc) <- local_possibilities local_env ]+        ++ [ (showPpr dflags r, rp) | (r, rp) <- global_possibilities global_env ]      tried_occ     = rdrNameOcc tried_rdr_name     tried_is_sym  = isSymOcc tried_occ     tried_ns      = occNameSpace tried_occ     tried_is_qual = isQual tried_rdr_name -    correct_name_space occ =  nameSpacesRelated (occNameSpace occ) tried_ns-                           && isSymOcc occ == tried_is_sym+    correct_name_space occ =+      (nameSpacesRelated dflags what_look tried_ns (occNameSpace occ))+      && isSymOcc occ == tried_is_sym         -- Treat operator and non-operators as non-matching         -- This heuristic avoids things like         --      Not in scope 'f'; perhaps you meant '+' (from Prelude) -    local_ok = case where_look of { WL_Any -> True+    local_ok = case where_look of { WL_Anywhere  -> True                                   ; WL_LocalOnly -> True-                                  ; _ -> False }+                                  ; _            -> False }+     local_possibilities :: LocalRdrEnv -> [(RdrName, SrcSpan)]     local_possibilities env       | tried_is_qual = []@@ -194,30 +210,29 @@                         , let occ = nameOccName name                         , correct_name_space occ] -    global_possibilities :: GlobalRdrEnv -> [(RdrName, (RdrName, HowInScope))]+    global_possibilities :: GlobalRdrEnv -> [(RdrName, SimilarName)]     global_possibilities global_env-      | tried_is_qual = [ (rdr_qual, (rdr_qual, how))+      | tried_is_qual = [ (rdr_qual, SimilarRdrName rdr_qual how)                         | gre <- globalRdrEnvElts global_env-                        , isGreOk where_look gre-                        , not (isNoFieldSelectorGRE gre)+                        , isGreOk looking_for gre                         , let occ = greOccName gre                         , correct_name_space occ                         , (mod, how) <- qualsInScope gre                         , let rdr_qual = mkRdrQual mod occ ] -      | otherwise = [ (rdr_unqual, pair)+      | otherwise = [ (rdr_unqual, sim)                     | gre <- globalRdrEnvElts global_env-                    , isGreOk where_look gre-                    , not (isNoFieldSelectorGRE gre)+                    , isGreOk looking_for gre                     , let occ = greOccName gre                           rdr_unqual = mkRdrUnqual occ                     , correct_name_space occ-                    , pair <- case (unquals_in_scope gre, quals_only gre) of-                                (how:_, _)    -> [ (rdr_unqual, how) ]+                    , sim <- case (unquals_in_scope gre, quals_only gre) of+                                (how:_, _)    -> [ SimilarRdrName rdr_unqual how ]                                 ([],    pr:_) -> [ pr ]  -- See Note [Only-quals]                                 ([],    [])   -> [] ]                -- Note [Only-quals]+              -- ~~~~~~~~~~~~~~~~~               -- The second alternative returns those names with the same               -- OccName as the one we tried, but live in *qualified* imports               -- e.g. if you have:@@ -230,97 +245,43 @@     --------------------     unquals_in_scope :: GlobalRdrElt -> [HowInScope]     unquals_in_scope (gre@GRE { gre_lcl = lcl, gre_imp = is })-      | lcl       = [ Left (greDefinitionSrcSpan gre) ]-      | otherwise = [ Right ispec-                    | i <- is, let ispec = is_decl i+      | lcl       = [ LocallyBoundAt (greDefinitionSrcSpan gre) ]+      | otherwise = [ ImportedBy ispec+                    | i <- bagToList is, let ispec = is_decl i                     , not (is_qual ispec) ]       ---------------------    quals_only :: GlobalRdrElt -> [(RdrName, HowInScope)]+    quals_only :: GlobalRdrElt -> [SimilarName]     -- Ones for which *only* the qualified version is in scope     quals_only (gre@GRE { gre_imp = is })-      = [ (mkRdrQual (is_as ispec) (greOccName gre), Right ispec)-        | i <- is, let ispec = is_decl i, is_qual ispec ]+      = [ (SimilarRdrName (mkRdrQual (is_as ispec) (greOccName gre)) (ImportedBy ispec))+        | i <- bagToList is, let ispec = is_decl i, is_qual ispec ] --- | Generate helpful suggestions if a qualified name Mod.foo is not in scope.-importSuggestions :: WhereLooking++-- | Generate errors and helpful suggestions if a qualified name Mod.foo is not in scope.+importSuggestions :: LookingFor                   -> GlobalRdrEnv                   -> HomePackageTable -> Module-                  -> ImportAvails -> RdrName -> SDoc-importSuggestions where_look global_env hpt currMod imports rdr_name-  | WL_LocalOnly <- where_look                 = Outputable.empty-  | not (isQual rdr_name || isUnqual rdr_name) = Outputable.empty+                  -> ImportAvails -> RdrName -> ([ImportError], [ImportSuggestion])+importSuggestions looking_for global_env hpt currMod imports rdr_name+  | WL_LocalOnly <- lf_where looking_for       = ([], [])+  | WL_LocalTop  <- lf_where looking_for       = ([], [])+  | not (isQual rdr_name || isUnqual rdr_name) = ([], [])   | null interesting_imports   , Just name <- mod_name   , show_not_imported_line name-  = hsep-      [ text "No module named"-      , quotes (ppr name)-      , text "is imported."-      ]-  | is_qualified-  , null helpful_imports-  , [(mod,_)] <- interesting_imports-  = hsep-      [ text "Module"-      , quotes (ppr mod)-      , text "does not export"-      , quotes (ppr occ_name) <> dot-      ]+  = ([MissingModule name], [])   | is_qualified   , null helpful_imports-  , not (null interesting_imports)-  , mods <- map fst interesting_imports-  = hsep-      [ text "Neither"-      , quotedListWithNor (map ppr mods)-      , text "exports"-      , quotes (ppr occ_name) <> dot-      ]-  | [(mod,imv)] <- helpful_imports_non_hiding-  = fsep-      [ text "Perhaps you want to add"-      , quotes (ppr occ_name)-      , text "to the import list"-      , text "in the import of"-      , quotes (ppr mod)-      , parens (ppr (imv_span imv)) <> dot-      ]-  | not (null helpful_imports_non_hiding)-  = fsep-      [ text "Perhaps you want to add"-      , quotes (ppr occ_name)-      , text "to one of these import lists:"-      ]-    $$-    nest 2 (vcat-        [ quotes (ppr mod) <+> parens (ppr (imv_span imv))-        | (mod,imv) <- helpful_imports_non_hiding-        ])-  | [(mod,imv)] <- helpful_imports_hiding-  = fsep-      [ text "Perhaps you want to remove"-      , quotes (ppr occ_name)-      , text "from the explicit hiding list"-      , text "in the import of"-      , quotes (ppr mod)-      , parens (ppr (imv_span imv)) <> dot-      ]-  | not (null helpful_imports_hiding)-  = fsep-      [ text "Perhaps you want to remove"-      , quotes (ppr occ_name)-      , text "from the hiding clauses"-      , text "in one of these imports:"-      ]-    $$-    nest 2 (vcat-        [ quotes (ppr mod) <+> parens (ppr (imv_span imv))-        | (mod,imv) <- helpful_imports_hiding-        ])+  , (mod : mods) <- map fst interesting_imports+  = ([ModulesDoNotExport (mod :| mods) occ_name], [])+  | mod : mods <- helpful_imports_non_hiding+  = ([], [CouldImportFrom (mod :| mods) occ_name])+  | mod : mods <- helpful_imports_hiding+  = ([], [CouldUnhideFrom (mod :| mods) occ_name])   | otherwise-  = Outputable.empty+  = ([], [])  where   is_qualified = isQual rdr_name   (mod_name, occ_name) = case rdr_name of@@ -352,17 +313,18 @@   -- wouldn't have an out-of-scope error in the first place)   helpful_imports = filter helpful interesting_imports     where helpful (_,imv)-            = not . null $ lookupGlobalRdrEnv (imv_all_exports imv) occ_name+            = any (isGreOk looking_for) $+              lookupGlobalRdrEnv (imv_all_exports imv) occ_name    -- Which of these do that because of an explicit hiding list resp. an   -- explicit import list   (helpful_imports_hiding, helpful_imports_non_hiding)     = partition (imv_is_hiding . snd) helpful_imports -  -- See note [When to show/hide the module-not-imported line]+  -- See Note [When to show/hide the module-not-imported line]   show_not_imported_line :: ModuleName -> Bool                    -- #15611   show_not_imported_line modnam-      | modnam `elem` globMods                = False    -- #14225     -- 1+      | modnam `elem` glob_mods               = False    -- #14225     -- 1       | moduleName currMod == modnam          = False                  -- 2.1       | is_last_loaded_mod modnam hpt_uniques = False                  -- 2.2       | otherwise                             = True@@ -370,35 +332,98 @@       hpt_uniques = map fst (udfmToList hpt)       is_last_loaded_mod _ []         = False       is_last_loaded_mod modnam uniqs = last uniqs == getUnique modnam-      globMods = nub [ mod+      glob_mods = nub [ mod                      | gre <- globalRdrEnvElts global_env-                     , isGreOk where_look gre                      , (mod, _) <- qualsInScope gre                      ] -extensionSuggestions :: RdrName -> SDoc+extensionSuggestions :: RdrName -> [GhcHint] extensionSuggestions rdrName   | rdrName == mkUnqual varName (fsLit "mdo") ||     rdrName == mkUnqual varName (fsLit "rec")-      = text "Perhaps you meant to use RecursiveDo"-  | otherwise = Outputable.empty+  = [SuggestExtension $ SuggestSingleExtension empty LangExt.RecursiveDo]+  | otherwise+  = []  qualsInScope :: GlobalRdrElt -> [(ModuleName, HowInScope)] -- Ones for which the qualified version is in scope qualsInScope gre@GRE { gre_lcl = lcl, gre_imp = is }       | lcl = case greDefinitionModule gre of                 Nothing -> []-                Just m  -> [(moduleName m, Left (greDefinitionSrcSpan gre))]-      | otherwise = [ (is_as ispec, Right ispec)-                    | i <- is, let ispec = is_decl i ]+                Just m  -> [(moduleName m, LocallyBoundAt (greDefinitionSrcSpan gre))]+      | otherwise = [ (is_as ispec, ImportedBy ispec)+                    | i <- bagToList is, let ispec = is_decl i ] -isGreOk :: WhereLooking -> GlobalRdrElt -> Bool-isGreOk where_look = case where_look of-                         WL_LocalTop  -> isLocalGRE-                         WL_LocalOnly -> const False-                         _            -> const True+isGreOk :: LookingFor -> GlobalRdrElt -> Bool+isGreOk (LF what_look where_look) gre = what_ok && where_ok+  where+    -- when looking for record fields, what_ok checks whether the GRE is a+    -- record field. Otherwise, it checks whether the GRE is a record field+    -- defined in a module with -XNoFieldSelectors - it wouldn't be a useful+    -- suggestion in that case.+    what_ok  = case what_look of+                 WL_RecField -> isRecFldGRE gre+                 _           -> not (isNoFieldSelectorGRE gre) -{- Note [When to show/hide the module-not-imported line]           -- #15611+    where_ok = case where_look of+                 WL_LocalTop  -> isLocalGRE gre+                 WL_LocalOnly -> False+                 _            -> True++-- see Note [Related name spaces]+nameSpacesRelated :: DynFlags    -- ^ to find out whether -XDataKinds is enabled+                  -> WhatLooking -- ^ What kind of name are we looking for+                  -> NameSpace   -- ^ Name space of the original name+                  -> NameSpace   -- ^ Name space of a name that might have been meant+                  -> Bool+nameSpacesRelated dflags what_looking ns ns'+  = ns' `elem` ns : [ other_ns+                    | (orig_ns, others) <- other_namespaces+                    , ns == orig_ns+                    , (other_ns, wls) <- others+                    , what_looking `elem` WL_Anything : wls+                    ]+  where+    -- explanation:+    -- [(orig_ns, [(other_ns, what_looking_possibilities)])]+    -- A particular other_ns is related if the original namespace is orig_ns+    -- and what_looking is either WL_Anything or is one of+    -- what_looking_possibilities+    other_namespaces =+      [ (varName  , [(dataName, [WL_Constructor])])+      , (dataName , [(varName , [WL_RecField])])+      , (tvName   , (tcClsName, [WL_Constructor]) : promoted_datacons)+      , (tcClsName, (tvName   , []) : promoted_datacons)+      ]+    -- If -XDataKinds is enabled, the data constructor name space is also+    -- related to the type-level name spaces+    data_kinds = xopt LangExt.DataKinds dflags+    promoted_datacons = [(dataName, [WL_Constructor]) | data_kinds]++{-+Note [Related name spaces]+~~~~~~~~~~~~~~~~~~~~~~~~~+Name spaces are related if there is a chance to mean the one when one writes+the other, i.e. variables <-> data constructors and type variables <-> type+constructors.++In most contexts, this mistake can happen in both directions. Not so in+patterns:++When a user writes+        foo (just a) = ...+It is possible that they meant to use `Just` instead. However, when they write+        foo (Map a) = ...+It is unlikely that they mean to use `map`, since variables cannot be used here.++Similarly, when we look for record fields, data constructors are not in a+related namespace.++Furthermore, with -XDataKinds, the data constructor name space is related to+the type variable and type constructor name spaces.++Note [When to show/hide the module-not-imported line]           -- #15611+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ For the error message:     Not in scope X.Y     Module X does not export Y@@ -414,10 +439,3 @@        and we have to check the current module in the last added entry of        the HomePackageTable. (See test T15611b) -}--exactNameErr :: Name -> SDoc-exactNameErr name =-  hang (text "The exact Name" <+> quotes (ppr name) <+> ptext (sLit "is not in scope"))-    2 (vcat [ text "Probable cause: you used a unique Template Haskell name (NameU), "-            , text "perhaps via newName, but did not bind it"-            , text "If that's it, then -ddump-splices might be useful" ])
GHC/Rename/Utils.hs view
@@ -15,11 +15,12 @@         addFvRn, mapFvRn, mapMaybeFvRn,         warnUnusedMatches, warnUnusedTypePatterns,         warnUnusedTopBinds, warnUnusedLocalBinds,+        warnForallIdentifier,         checkUnusedRecordWildcard,         mkFieldEnv,-        unknownSubordinateErr, badQualBndrErr, typeAppErr,-        HsDocContext(..), pprHsDocContext,-        inHsDocContext, withHsDocContext,+        badQualBndrErr, typeAppErr, badFieldConErr,+        wrapGenSpan, genHsVar, genLHsVar, genHsApp, genHsApps, genAppType,+        genHsIntegralLit, genHsTyLit,          newLocalBndrRn, newLocalBndrsRn, @@ -39,14 +40,18 @@ import GHC.Core.Type import GHC.Hs import GHC.Types.Name.Reader+import GHC.Tc.Errors.Types+import GHC.Tc.Errors.Ppr (withHsDocContext) import GHC.Tc.Utils.Env import GHC.Tc.Utils.Monad+import GHC.Types.Error import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.Name.Env import GHC.Core.DataCon import GHC.Types.SrcLoc as SrcLoc import GHC.Types.SourceFile+import GHC.Types.SourceText ( SourceText(..), IntegralLit ) import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Misc@@ -60,6 +65,7 @@ import GHC.Settings.Constants ( mAX_TUPLE_SIZE, mAX_CTUPLE_SIZE ) import qualified Data.List.NonEmpty as NE import qualified GHC.LanguageExtensions as LangExt+import GHC.Data.Bag  {- *********************************************************@@ -86,15 +92,14 @@ newLocalBndrsRn = mapM newLocalBndrRn  bindLocalNames :: [Name] -> RnM a -> RnM a-bindLocalNames names enclosed_scope-  = do { lcl_env <- getLclEnv-       ; let th_level  = thLevel (tcl_th_ctxt lcl_env)-             th_bndrs' = extendNameEnvList (tcl_th_bndrs lcl_env)-                           [ (n, (NotTopLevel, th_level)) | n <- names ]-             rdr_env'  = extendLocalRdrEnvList (tcl_rdr lcl_env) names-       ; setLclEnv (lcl_env { tcl_th_bndrs = th_bndrs'-                            , tcl_rdr      = rdr_env' })-                    enclosed_scope }+bindLocalNames names+  = updLclEnv $ \ lcl_env ->+    let th_level  = thLevel (tcl_th_ctxt lcl_env)+        th_bndrs' = extendNameEnvList (tcl_th_bndrs lcl_env)+                    [ (n, (NotTopLevel, th_level)) | n <- names ]+        rdr_env'  = extendLocalRdrEnvList (tcl_rdr lcl_env) names+    in lcl_env { tcl_th_bndrs = th_bndrs'+               , tcl_rdr      = rdr_env' }  bindLocalNamesFV :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars) bindLocalNamesFV names enclosed_scope@@ -158,9 +163,9 @@     check_shadow n         | startsWithUnderscore occ = return ()  -- Do not report shadowing for "_x"                                                 -- See #3262-        | Just n <- mb_local = complain [text "bound at" <+> ppr (nameSrcLoc n)]+        | Just n <- mb_local = complain (ShadowedNameProvenanceLocal (nameSrcLoc n))         | otherwise = do { gres' <- filterM is_shadowed_gre gres-                         ; complain (map pprNameProvenance gres') }+                         ; when (not . null $ gres') $ complain (ShadowedNameProvenanceGlobal gres') }         where           (loc,occ) = get_loc_occ n           mb_local  = lookupLocalRdrOcc local_env occ@@ -168,17 +173,14 @@                 -- Make an Unqualified RdrName and look that up, so that                 -- we don't find any GREs that are in scope qualified-only -          complain []      = return ()-          complain pp_locs = addWarnAt (Reason Opt_WarnNameShadowing)-                                       loc-                                       (shadowedNameWarn occ pp_locs)+          complain provenance = addDiagnosticAt loc (TcRnShadowedName occ provenance)      is_shadowed_gre :: GlobalRdrElt -> RnM Bool         -- Returns False for record selectors that are shadowed, when         -- punning or wild-cards are on (cf #2723)     is_shadowed_gre gre | isRecFldGRE gre         = do { dflags <- getDynFlags-             ; return $ not (xopt LangExt.RecordPuns dflags+             ; return $ not (xopt LangExt.NamedFieldPuns dflags                              || xopt LangExt.RecordWildCards dflags) }     is_shadowed_gre _other = return True @@ -199,7 +201,7 @@   let bndrs = sig_ty_bndrs ty   in case find ((==) InferredSpec . hsTyVarBndrFlag) bndrs of     Nothing -> return ()-    Just _  -> addErr $ withHsDocContext ctxt msg+    Just _  -> addErr $ TcRnUnknownMessage $ mkPlainError noHints (withHsDocContext ctxt msg)   where     sig_ty_bndrs :: LHsSigType GhcPs -> [HsTyVarBndr Specificity GhcPs]     sig_ty_bndrs (L _ (HsSig{sig_bndrs = outer_bndrs}))@@ -308,7 +310,7 @@ addNoNestedForallsContextsErr :: HsDocContext -> SDoc -> LHsType GhcRn -> RnM () addNoNestedForallsContextsErr ctxt what lty =   whenIsJust (noNestedForallsContextsErr what lty) $ \(l, err_msg) ->-    addErrAt l $ withHsDocContext ctxt err_msg+    addErrAt l $ TcRnUnknownMessage $ mkPlainError noHints (withHsDocContext ctxt err_msg)  {- ************************************************************************@@ -385,9 +387,12 @@ -- The `..` here doesn't bind any variables as `x` is already bound. warnRedundantRecordWildcard :: RnM () warnRedundantRecordWildcard =-  whenWOptM Opt_WarnRedundantRecordWildcards-            (addWarn (Reason Opt_WarnRedundantRecordWildcards)-                     redundantWildcardWarning)+  whenWOptM Opt_WarnRedundantRecordWildcards $+    let msg = TcRnUnknownMessage $+                mkPlainDiagnostic (WarningWithFlag Opt_WarnRedundantRecordWildcards)+                                  noHints+                                  redundantWildcardWarning+    in addDiagnostic msg   -- | Produce a warning when no variables bound by a `..` pattern are used.@@ -404,7 +409,7 @@ warnUnusedRecordWildcard ns used_names = do   let used = filter (`elemNameSet` used_names) ns   traceRn "warnUnused" (ppr ns $$ ppr used_names $$ ppr used)-  warnIfFlag Opt_WarnUnusedRecordWildcards (null used)+  warnIf (null used)     unusedRecordWildcardWarning  @@ -420,6 +425,13 @@   = whenWOptM flag (warnUnused flag (filterOut (`elemNameSet` used_names)                                                bound_names)) +warnForallIdentifier :: LocatedN RdrName -> RnM ()+warnForallIdentifier (L l rdr_name@(Unqual occ))+  | isKw (fsLit "forall") || isKw (fsLit "∀")+  = addDiagnosticAt (locA l) (TcRnForallIdentifier rdr_name)+  where isKw = (occNameFS occ ==)+warnForallIdentifier _ = return ()+ ------------------------- --      Helpers warnUnusedGREs :: [GlobalRdrElt] -> RnM ()@@ -451,13 +463,13 @@         where            span = importSpecLoc spec            pp_mod = quotes (ppr (importSpecModule spec))-           msg = text "Imported from" <+> pp_mod <+> ptext (sLit "but not used")+           msg = text "Imported from" <+> pp_mod <+> text "but not used"  -- | Make a map from selector names to field labels and parent tycon -- names, to be used when reporting unused record fields. mkFieldEnv :: GlobalRdrEnv -> NameEnv (FieldLabelString, Parent) mkFieldEnv rdr_env = mkNameEnv [ (greMangledName gre, (flLabel fl, gre_par gre))-                               | gres <- occEnvElts rdr_env+                               | gres <- nonDetOccEnvElts rdr_env                                , gre <- gres                                , Just fl <- [greFieldLabel gre]                                ]@@ -474,15 +486,17 @@   | otherwise = not (startsWithUnderscore (occName child))  addUnusedWarning :: WarningFlag -> OccName -> SrcSpan -> SDoc -> RnM ()-addUnusedWarning flag occ span msg-  = addWarnAt (Reason flag) span $-    sep [msg <> colon,-         nest 2 $ pprNonVarNameSpace (occNameSpace occ)-                        <+> quotes (ppr occ)]+addUnusedWarning flag occ span msg = do+  let diag = TcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag flag) noHints $+        sep [msg <> colon,+             nest 2 $ pprNonVarNameSpace (occNameSpace occ)+                            <+> quotes (ppr occ)]+  addDiagnosticAt span diag -unusedRecordWildcardWarning :: SDoc+unusedRecordWildcardWarning :: TcRnMessage unusedRecordWildcardWarning =-  wildcardDoc $ text "No variables bound in the record wildcard match are used"+  TcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag Opt_WarnUnusedRecordWildcards) noHints $+    wildcardDoc $ text "No variables bound in the record wildcard match are used"  redundantWildcardWarning :: SDoc redundantWildcardWarning =@@ -531,7 +545,8 @@   -- already, and we don't want an error cascade.   = return ()   | otherwise-  = addErr (vcat [ text "Ambiguous occurrence" <+> quotes (ppr rdr_name)+  = addErr $ TcRnUnknownMessage $ mkPlainError noHints $+    (vcat [ text "Ambiguous occurrence" <+> quotes (ppr rdr_name)                  , text "It could refer to"                  , nest 3 (vcat (msg1 : msgs)) ])   where@@ -561,7 +576,7 @@         pp_qual name                 | lcl                 = ppr (nameModule name)-                | imp : _ <- iss  -- This 'imp' is the one that+                | Just imp  <- headMaybe iss  -- This 'imp' is the one that                                   -- pprNameProvenance chooses                 , ImpDeclSpec { is_as = mod } <- is_decl imp                 = ppr mod@@ -581,22 +596,9 @@     num_non_flds = length non_flds  -shadowedNameWarn :: OccName -> [SDoc] -> SDoc-shadowedNameWarn occ shadowed_locs-  = sep [text "This binding for" <+> quotes (ppr occ)-            <+> text "shadows the existing binding" <> plural shadowed_locs,-         nest 2 (vcat shadowed_locs)]---unknownSubordinateErr :: SDoc -> RdrName -> SDoc-unknownSubordinateErr doc op    -- Doc is "method of class" or-                                -- "field of constructor"-  = quotes (ppr op) <+> text "is not a (visible)" <+> doc-- dupNamesErr :: Outputable n => (n -> SrcSpan) -> NE.NonEmpty n -> RnM () dupNamesErr get_loc names-  = addErrAt big_loc $+  = addErrAt big_loc $ TcRnUnknownMessage $ mkPlainError noHints $     vcat [text "Conflicting definitions for" <+> quotes (ppr (NE.head names)),           locations]   where@@ -604,16 +606,24 @@     big_loc   = foldr1 combineSrcSpans locs     locations = text "Bound at:" <+> vcat (map ppr (sortBy SrcLoc.leftmost_smallest locs)) -badQualBndrErr :: RdrName -> SDoc+badQualBndrErr :: RdrName -> TcRnMessage badQualBndrErr rdr_name-  = text "Qualified name in binding position:" <+> ppr rdr_name+  = TcRnUnknownMessage $ mkPlainError noHints $+  text "Qualified name in binding position:" <+> ppr rdr_name -typeAppErr :: String -> LHsType GhcPs -> SDoc+typeAppErr :: String -> LHsType GhcPs -> TcRnMessage typeAppErr what (L _ k)-  = hang (text "Illegal visible" <+> text what <+> text "application"+  = TcRnUnknownMessage $ mkPlainError noHints $+    hang (text "Illegal visible" <+> text what <+> text "application"             <+> quotes (char '@' <> ppr k))        2 (text "Perhaps you intended to use TypeApplications") +badFieldConErr :: Name -> FieldLabelString -> TcRnMessage+badFieldConErr con field+  = TcRnUnknownMessage $ mkPlainError noHints $+    hsep [text "Constructor" <+> quotes (ppr con),+          text "does not have field", quotes (ppr field)]+ -- | Ensure that a boxed or unboxed tuple has arity no larger than -- 'mAX_TUPLE_SIZE'. checkTupSize :: Int -> TcM ()@@ -621,9 +631,10 @@   | tup_size <= mAX_TUPLE_SIZE   = return ()   | otherwise-  = addErr (sep [text "A" <+> int tup_size <> ptext (sLit "-tuple is too large for GHC"),+  = addErr $ TcRnUnknownMessage $ mkPlainError noHints $+    sep [text "A" <+> int tup_size <> text "-tuple is too large for GHC",                  nest 2 (parens (text "max size is" <+> int mAX_TUPLE_SIZE)),-                 nest 2 (text "Workaround: use nested tuples or define a data type")])+                 nest 2 (text "Workaround: use nested tuples or define a data type")]  -- | Ensure that a constraint tuple has arity no larger than 'mAX_CTUPLE_SIZE'. checkCTupSize :: Int -> TcM ()@@ -631,76 +642,40 @@   | tup_size <= mAX_CTUPLE_SIZE   = return ()   | otherwise-  = addErr (hang (text "Constraint tuple arity too large:" <+> int tup_size+  = addErr $ TcRnUnknownMessage $ mkPlainError noHints $+    hang (text "Constraint tuple arity too large:" <+> int tup_size                   <+> parens (text "max arity =" <+> int mAX_CTUPLE_SIZE))-               2 (text "Instead, use a nested tuple"))-+               2 (text "Instead, use a nested tuple") -{--************************************************************************+{- ********************************************************************* *                                                                      *-\subsection{Contexts for renaming errors}+              Generating code for HsExpanded+      See Note [Handling overloaded and rebindable constructs] *                                                                      *-************************************************************************--}+********************************************************************* -} --- AZ:TODO: Change these all to be Name instead of RdrName.---          Merge TcType.UserTypeContext in to it.-data HsDocContext-  = TypeSigCtx SDoc-  | StandaloneKindSigCtx SDoc-  | PatCtx-  | SpecInstSigCtx-  | DefaultDeclCtx-  | ForeignDeclCtx (LocatedN RdrName)-  | DerivDeclCtx-  | RuleCtx FastString-  | TyDataCtx (LocatedN RdrName)-  | TySynCtx (LocatedN RdrName)-  | TyFamilyCtx (LocatedN RdrName)-  | FamPatCtx (LocatedN RdrName)    -- The patterns of a type/data family instance-  | ConDeclCtx [LocatedN Name]-  | ClassDeclCtx (LocatedN RdrName)-  | ExprWithTySigCtx-  | TypBrCtx-  | HsTypeCtx-  | HsTypePatCtx-  | GHCiCtx-  | SpliceTypeCtx (LHsType GhcPs)-  | ClassInstanceCtx-  | GenericCtx SDoc   -- Maybe we want to use this more!+wrapGenSpan :: a -> LocatedAn an a+-- Wrap something in a "generatedSrcSpan"+-- See Note [Rebindable syntax and HsExpansion]+wrapGenSpan x = L (noAnnSrcSpan generatedSrcSpan) x -withHsDocContext :: HsDocContext -> SDoc -> SDoc-withHsDocContext ctxt doc = doc $$ inHsDocContext ctxt+genHsApps :: Name -> [LHsExpr GhcRn] -> HsExpr GhcRn+genHsApps fun args = foldl genHsApp (genHsVar fun) args -inHsDocContext :: HsDocContext -> SDoc-inHsDocContext ctxt = text "In" <+> pprHsDocContext ctxt+genHsApp :: HsExpr GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn+genHsApp fun arg = HsApp noAnn (wrapGenSpan fun) arg -pprHsDocContext :: HsDocContext -> SDoc-pprHsDocContext (GenericCtx doc)      = doc-pprHsDocContext (TypeSigCtx doc)      = text "the type signature for" <+> doc-pprHsDocContext (StandaloneKindSigCtx doc) = text "the standalone kind signature for" <+> doc-pprHsDocContext PatCtx                = text "a pattern type-signature"-pprHsDocContext SpecInstSigCtx        = text "a SPECIALISE instance pragma"-pprHsDocContext DefaultDeclCtx        = text "a `default' declaration"-pprHsDocContext DerivDeclCtx          = text "a deriving declaration"-pprHsDocContext (RuleCtx name)        = text "the rewrite rule" <+> doubleQuotes (ftext name)-pprHsDocContext (TyDataCtx tycon)     = text "the data type declaration for" <+> quotes (ppr tycon)-pprHsDocContext (FamPatCtx tycon)     = text "a type pattern of family instance for" <+> quotes (ppr tycon)-pprHsDocContext (TySynCtx name)       = text "the declaration for type synonym" <+> quotes (ppr name)-pprHsDocContext (TyFamilyCtx name)    = text "the declaration for type family" <+> quotes (ppr name)-pprHsDocContext (ClassDeclCtx name)   = text "the declaration for class" <+> quotes (ppr name)-pprHsDocContext ExprWithTySigCtx      = text "an expression type signature"-pprHsDocContext TypBrCtx              = text "a Template-Haskell quoted type"-pprHsDocContext HsTypeCtx             = text "a type argument"-pprHsDocContext HsTypePatCtx          = text "a type argument in a pattern"-pprHsDocContext GHCiCtx               = text "GHCi input"-pprHsDocContext (SpliceTypeCtx hs_ty) = text "the spliced type" <+> quotes (ppr hs_ty)-pprHsDocContext ClassInstanceCtx      = text "GHC.Tc.Gen.Splice.reifyInstances"+genLHsVar :: Name -> LHsExpr GhcRn+genLHsVar nm = wrapGenSpan $ genHsVar nm -pprHsDocContext (ForeignDeclCtx name)-   = text "the foreign declaration for" <+> quotes (ppr name)-pprHsDocContext (ConDeclCtx [name])-   = text "the definition of data constructor" <+> quotes (ppr name)-pprHsDocContext (ConDeclCtx names)-   = text "the definition of data constructors" <+> interpp'SP names+genHsVar :: Name -> HsExpr GhcRn+genHsVar nm = HsVar noExtField $ wrapGenSpan nm++genAppType :: HsExpr GhcRn -> HsType (NoGhcTc GhcRn) -> HsExpr GhcRn+genAppType expr = HsAppType noExtField (wrapGenSpan expr) . mkEmptyWildCardBndrs . wrapGenSpan++genHsIntegralLit :: IntegralLit -> LocatedAn an (HsExpr GhcRn)+genHsIntegralLit lit = wrapGenSpan $ HsLit noAnn (HsInt noExtField lit)++genHsTyLit :: FastString -> HsType GhcRn+genHsTyLit = HsTyLit noExtField . HsStrTy NoSourceText
GHC/Runtime/Context.hs view
@@ -6,7 +6,8 @@    , extendInteractiveContextWithIds    , setInteractivePrintName    , substInteractiveContext-   , icExtendGblRdrEnv+   , replaceImportEnv+   , icReaderEnv    , icInteractiveModule    , icInScopeTTs    , icPrintUnqual@@ -20,18 +21,17 @@ import GHC.Driver.Session import {-# SOURCE #-} GHC.Driver.Plugins -import GHC.Runtime.Eval.Types ( Resume )+import GHC.Runtime.Eval.Types ( IcGlobalRdrEnv(..), Resume )  import GHC.Unit import GHC.Unit.Env  import GHC.Core.FamInstEnv-import GHC.Core.InstEnv ( ClsInst, identicalClsInstHead )+import GHC.Core.InstEnv import GHC.Core.Type  import GHC.Types.Avail import GHC.Types.Fixity.Env-import GHC.Types.Id ( isRecordSelector ) import GHC.Types.Id.Info ( IdDetails(..) ) import GHC.Types.Name import GHC.Types.Name.Env@@ -43,7 +43,6 @@ import GHC.Builtin.Names ( ioTyConName, printName, mkInteractiveModule )  import GHC.Utils.Outputable-import GHC.Utils.Misc  {- Note [The interactive package]@@ -67,7 +66,7 @@ Here we must display info about constructor A, but its type T has been shadowed by the second declaration.  But it has a respectable qualified name (Ghci1.T), and its source location says where it was-defined.+defined, and it can also be used with the qualified name.  So the main invariant continues to hold, that in any session an original name M.T only refers to one unique thing.  (In a previous@@ -182,6 +181,37 @@         Prelude> instance Eq T where ...   -- This one overrides  It's exactly the same for type-family instances.  See #7102++Note [icReaderEnv recalculation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The GlobalRdrEnv describing what’s in scope at the prompts consists+of all the imported things, followed by all the things defined on the prompt, with+shadowing. Defining new things on the prompt is easy: we shadow as needed and then extend the environment.  But changing the set of imports, which can happen later as well,+is tricky: we need to re-apply the shadowing from all the things defined at the prompt!++For example:++    ghci> let empty = True+    ghci> import Data.IntMap.Strict     -- Exports 'empty'+    ghci> empty   -- Still gets the 'empty' defined at the prompt+    True+++It would be correct ot re-construct the env from scratch based on+`ic_tythings`, but that'd be quite expensive if there are many entires in+`ic_tythings` that shadow each other.++Therefore we keep around a that `GlobalRdrEnv` in `igre_prompt_env` that+contians _just_ the things defined at the prompt, and use that in+`replaceImportEnv` to rebuild the full env.  Conveniently, `shadowNames` takes+such an `OccEnv` to denote the set of names to shadow.++INVARIANT: Every `OccName` in `igre_prompt_env` is present unqualified as well+(else it would not be right to use pass `igre_prompt_env` to `shadowNames`.)++The definition of the IcGlobalRdrEnv type should conceptually be in this module, and+made abstract, but it’s used in `Resume`, so it lives in GHC.Runtime.Eval.Type.+- -}  -- | Interactive context, recording information about the state of the@@ -200,7 +230,7 @@              -- See Note [The interactive package]           ic_imports :: [InteractiveImport],-             -- ^ The GHCi top-level scope (ic_rn_gbl_env) is extended with+             -- ^ The GHCi top-level scope (icReaderEnv) is extended with              -- these imports              --              -- This field is only stored here so that the client@@ -210,16 +240,23 @@           ic_tythings   :: [TyThing],              -- ^ TyThings defined by the user, in reverse order of-             -- definition (ie most recent at the front)+             -- definition (ie most recent at the front).+             -- Also used in GHC.Tc.Module.runTcInteractive to fill the type+             -- checker environment.              -- See Note [ic_tythings] -         ic_rn_gbl_env :: GlobalRdrEnv,-             -- ^ The cached 'GlobalRdrEnv', built by-             -- 'GHC.Runtime.Eval.setContext' and updated regularly-             -- It contains everything in scope at the command line,-             -- including everything in ic_tythings+         ic_gre_cache :: IcGlobalRdrEnv,+             -- ^ Essentially the cached 'GlobalRdrEnv'.+             --+             -- The GlobalRdrEnv contains everything in scope at the command+             -- line, both imported and everything in ic_tythings, with the+             -- correct shadowing.+             --+             -- The IcGlobalRdrEnv contains extra data to allow efficient+             -- recalculation when the set of imports change.+             -- See Note [icReaderEnv recalculation] -         ic_instances  :: ([ClsInst], [FamInst]),+         ic_instances  :: (InstEnv, [FamInst]),              -- ^ All instances and family instances created during              -- this session.  These are grabbed en masse after each              -- update to be sure that proper overlapping is retained.@@ -233,7 +270,7 @@          ic_default :: Maybe [Type],              -- ^ The current default types, set by a 'default' declaration -          ic_resume :: [Resume],+         ic_resume :: [Resume],              -- ^ The stack of breakpoint contexts           ic_monad      :: Name,@@ -246,7 +283,7 @@          ic_cwd :: Maybe FilePath,              -- ^ virtual CWD of the program -         ic_plugins :: ![LoadedPlugin]+         ic_plugins :: !Plugins              -- ^ Cache of loaded plugins. We store them here to avoid having to              -- load them everytime we switch to the interctive context.     }@@ -261,6 +298,11 @@       -- of this module, including the things imported       -- into it. +emptyIcGlobalRdrEnv :: IcGlobalRdrEnv+emptyIcGlobalRdrEnv = IcGlobalRdrEnv+    { igre_env = emptyGlobalRdrEnv+    , igre_prompt_env = emptyGlobalRdrEnv+    }  -- | Constructs an empty InteractiveContext. emptyInteractiveContext :: DynFlags -> InteractiveContext@@ -268,42 +310,56 @@   = InteractiveContext {        ic_dflags     = dflags,        ic_imports    = [],-       ic_rn_gbl_env = emptyGlobalRdrEnv,+       ic_gre_cache  = emptyIcGlobalRdrEnv,        ic_mod_index  = 1,        ic_tythings   = [],-       ic_instances  = ([],[]),+       ic_instances  = (emptyInstEnv,[]),        ic_fix_env    = emptyNameEnv,        ic_monad      = ioTyConName,  -- IO monad by default        ic_int_print  = printName,    -- System.IO.print by default        ic_default    = Nothing,        ic_resume     = [],        ic_cwd        = Nothing,-       ic_plugins    = []+       ic_plugins    = emptyPlugins        } +icReaderEnv :: InteractiveContext -> GlobalRdrEnv+icReaderEnv = igre_env . ic_gre_cache+ icInteractiveModule :: InteractiveContext -> Module icInteractiveModule (InteractiveContext { ic_mod_index = index })   = mkInteractiveModule index  -- | This function returns the list of visible TyThings (useful for--- e.g. showBindings)+-- e.g. showBindings).+--+-- It picks only those TyThings that are not shadowed by later definitions on the interpreter,+-- to not clutter :showBindings with shadowed ids, which would show up as Ghci9.foo.+--+-- Some TyThings define many names; we include them if _any_ name is still+-- available unqualified. icInScopeTTs :: InteractiveContext -> [TyThing]-icInScopeTTs = ic_tythings+icInScopeTTs ictxt = filter in_scope_unqualified (ic_tythings ictxt)+  where+    in_scope_unqualified thing = or+        [ unQualOK gre+        | avail <- tyThingAvailInfo thing+        , name <- availNames avail+        , Just gre <- [lookupGRE_Name (icReaderEnv ictxt) name]+        ] + -- | Get the PrintUnqualified function based on the flags and this InteractiveContext icPrintUnqual :: UnitEnv -> InteractiveContext -> PrintUnqualified-icPrintUnqual unit_env InteractiveContext{ ic_rn_gbl_env = grenv } =-    mkPrintUnqualified unit_env grenv+icPrintUnqual unit_env ictxt = mkPrintUnqualified unit_env (icReaderEnv ictxt)  -- | extendInteractiveContext is called with new TyThings recently defined to update the--- InteractiveContext to include them.  Ids are easily removed when shadowed,--- but Classes and TyCons are not.  Some work could be done to determine--- whether they are entirely shadowed, but as you could still have references--- to them (e.g. instances for classes or values of the type for TyCons), it's--- not clear whether removing them is even the appropriate behavior.+-- InteractiveContext to include them. By putting new things first, unqualified+-- use will pick the most recently defined thing with a given name, while+-- still keeping the old names in scope in their qualified form (Ghci1.foo). extendInteractiveContext :: InteractiveContext                          -> [TyThing]-                         -> [ClsInst] -> [FamInst]+                         -> InstEnv -> [FamInst]                          -> Maybe [Type]                          -> FixityEnv                          -> InteractiveContext@@ -311,9 +367,9 @@   = ictxt { ic_mod_index  = ic_mod_index ictxt + 1                             -- Always bump this; even instances should create                             -- a new mod_index (#9426)-          , ic_tythings   = new_tythings ++ old_tythings-          , ic_rn_gbl_env = ic_rn_gbl_env ictxt `icExtendGblRdrEnv` new_tythings-          , ic_instances  = ( new_cls_insts ++ old_cls_insts+          , ic_tythings   = new_tythings ++ ic_tythings ictxt+          , ic_gre_cache  = ic_gre_cache ictxt `icExtendIcGblRdrEnv` new_tythings+          , ic_instances  = ( new_cls_insts `unionInstEnv` old_cls_insts                             , new_fam_insts ++ fam_insts )                             -- we don't shadow old family instances (#7102),                             -- so don't need to remove them here@@ -321,38 +377,40 @@           , ic_fix_env    = fix_env  -- See Note [Fixity declarations in GHCi]           }   where-    new_ids = [id | AnId id <- new_tythings]-    old_tythings = filterOut (shadowed_by new_ids) (ic_tythings ictxt)-     -- Discard old instances that have been fully overridden     -- See Note [Override identical instances in GHCi]     (cls_insts, fam_insts) = ic_instances ictxt-    old_cls_insts = filterOut (\i -> any (identicalClsInstHead i) new_cls_insts) cls_insts+    old_cls_insts = filterInstEnv (\i -> not $ anyInstEnv (identicalClsInstHead i) new_cls_insts) cls_insts  extendInteractiveContextWithIds :: InteractiveContext -> [Id] -> InteractiveContext -- Just a specialised version extendInteractiveContextWithIds ictxt new_ids   | null new_ids = ictxt-  | otherwise    = ictxt { ic_mod_index  = ic_mod_index ictxt + 1-                         , ic_tythings   = new_tythings ++ old_tythings-                         , ic_rn_gbl_env = ic_rn_gbl_env ictxt `icExtendGblRdrEnv` new_tythings }+  | otherwise+  = ictxt { ic_mod_index  = ic_mod_index ictxt + 1+          , ic_tythings   = new_tythings ++ ic_tythings ictxt+          , ic_gre_cache  = ic_gre_cache ictxt `icExtendIcGblRdrEnv` new_tythings+          }   where     new_tythings = map AnId new_ids-    old_tythings = filterOut (shadowed_by new_ids) (ic_tythings ictxt) -shadowed_by :: [Id] -> TyThing -> Bool-shadowed_by ids = shadowed-  where-    -- Keep record selectors because they might be needed by HasField (#19322)-    shadowed (AnId id) | isRecordSelector id = False-    shadowed tything = getOccName tything `elemOccSet` new_occs-    new_occs = mkOccSet (map getOccName ids)- setInteractivePrintName :: InteractiveContext -> Name -> InteractiveContext setInteractivePrintName ic n = ic{ic_int_print = n} -    -- ToDo: should not add Ids to the gbl env here+icExtendIcGblRdrEnv :: IcGlobalRdrEnv -> [TyThing] -> IcGlobalRdrEnv+icExtendIcGblRdrEnv igre tythings = IcGlobalRdrEnv+    { igre_env = igre_env igre `icExtendGblRdrEnv` tythings+    , igre_prompt_env = igre_prompt_env igre `icExtendGblRdrEnv` tythings+    } +-- This is used by setContext in GHC.Runtime.Eval when the set of imports+-- changes, and recalculates the GlobalRdrEnv. See Note [icReaderEnv recalculation]+replaceImportEnv :: IcGlobalRdrEnv -> GlobalRdrEnv -> IcGlobalRdrEnv+replaceImportEnv igre import_env = igre { igre_env = new_env }+  where+    import_env_shadowed = import_env `shadowNames` igre_prompt_env igre+    new_env = import_env_shadowed `plusGlobalRdrEnv` igre_prompt_env igre+ -- | Add TyThings to the GlobalRdrEnv, earlier ones in the list shadowing -- later ones, and shadowing existing entries in the GlobalRdrEnv. icExtendGblRdrEnv :: GlobalRdrEnv -> [TyThing] -> GlobalRdrEnv@@ -367,7 +425,9 @@        | otherwise        = foldl' extendGlobalRdrEnv env1 (concatMap localGREsFromAvail avail)        where-          env1  = shadowNames env (concatMap availGreNames avail)+          new_gres = concatMap availGreNames avail+          new_occs = occSetToEnv (mkOccSet (map occName new_gres))+          env1  = shadowNames env new_occs           avail = tyThingAvailInfo thing      -- Ugh! The new_tythings may include record selectors, since they@@ -397,4 +457,3 @@ instance Outputable InteractiveImport where   ppr (IIModule m) = char '*' <> ppr m   ppr (IIDecl d)   = ppr d-
GHC/Runtime/Debugger.hs view
@@ -38,6 +38,7 @@ import GHC.Utils.Logger  import GHC.Types.Id+import GHC.Types.Id.Make (ghcPrimIds) import GHC.Types.Name import GHC.Types.Var hiding ( varName ) import GHC.Types.Var.Set@@ -47,7 +48,7 @@  import Control.Monad import Control.Monad.Catch as MC-import Data.List ( (\\) )+import Data.List ( (\\), partition ) import Data.Maybe import Data.IORef @@ -60,25 +61,45 @@                  mapM (\w -> GHC.parseName w >>=                                 mapM GHC.lookupName)                       (words str)-  let ids = [id | AnId id <- tythings] +  -- Sort out good and bad tythings for :print and friends+  let (pprintables, unpprintables) = partition can_pprint tythings+   -- Obtain the terms and the recovered type information+  let ids = [id | AnId id <- pprintables]   (subst, terms) <- mapAccumLM go emptyTCvSubst ids    -- Apply the substitutions obtained after recovering the types   modifySession $ \hsc_env ->     hsc_env{hsc_IC = substInteractiveContext (hsc_IC hsc_env) subst} -  -- Finally, print the Terms-  unqual  <- GHC.getPrintUnqual+  -- Finally, print the Results   docterms <- mapM showTerm terms-  dflags <- getDynFlags-  logger <- getLogger-  liftIO $ (printOutputForUser logger dflags unqual . vcat)-           (zipWith (\id docterm -> ppr id <+> char '=' <+> docterm)-                    ids-                    docterms)+  let sdocTerms = zipWith (\id docterm -> ppr id <+> char '=' <+> docterm)+                          ids+                          docterms+  printSDocs $ (no_pprint <$> unpprintables) ++ sdocTerms  where+   -- Check whether a TyThing can be processed by :print and friends.+   -- Take only Ids, exclude pseudoops, they don't have any HValues.+   can_pprint :: TyThing -> Bool                              -- #19394+   can_pprint (AnId x)+       | x `notElem` ghcPrimIds = True+       | otherwise              = False+   can_pprint _                 = False++   -- Create a short message for a TyThing, that cannot processed by :print+   no_pprint :: TyThing -> SDoc+   no_pprint tything = ppr tything <+>+          text "is not eligible for the :print, :sprint or :force commands."++   -- Helper to print out the results of :print and friends+   printSDocs :: GhcMonad m => [SDoc] -> m ()+   printSDocs sdocs = do+      logger <- getLogger+      unqual <- GHC.getPrintUnqual+      liftIO $ printOutputForUser logger unqual $ vcat sdocs+    -- Do the obtainTerm--bindSuspensions-computeSubstitution dance    go :: GhcMonad m => TCvSubst -> Id -> m (TCvSubst, Term)    go subst id = do@@ -96,10 +117,9 @@        hsc_env <- getSession        case (improveRTTIType hsc_env id_ty' reconstructed_type) of          Nothing     -> return (subst, term')-         Just subst' -> do { dflags <- GHC.getSessionDynFlags-                           ; logger <- getLogger+         Just subst' -> do { logger <- getLogger                            ; liftIO $-                               dumpIfSet_dyn logger dflags Opt_D_dump_rtti "RTTI"+                               putDumpFileMaybe logger Opt_D_dump_rtti "RTTI"                                  FormatText                                  (fsep $ [text "RTTI Improvement for", ppr id,                                   text "old substitution:" , ppr subst,@@ -184,7 +204,7 @@                 setSession new_env                  -- this disables logging of errors-                let noop_log _ _ _ _ _ = return ()+                let noop_log _ _ _ _ = return ()                 pushLogHookM (const noop_log)                  return (hsc_env, bname)
GHC/Runtime/Eval.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE RecordWildCards #-}  {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}@@ -44,15 +44,15 @@         Term(..), obtainTermFromId, obtainTermFromVal, reconstructType         ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Driver.Monad import GHC.Driver.Main+import GHC.Driver.Errors.Types ( hoistTcRnMessage ) import GHC.Driver.Env import GHC.Driver.Session import GHC.Driver.Ppr+import GHC.Driver.Config  import GHC.Runtime.Eval.Types import GHC.Runtime.Interpreter as GHCi@@ -81,7 +81,6 @@ import GHC.Tc.Types.Origin  import GHC.Builtin.Names ( toDynName, pretendNameIsInScope )-import GHC.Builtin.Types ( isCTupleTyConName )  import GHC.Data.Maybe import GHC.Data.FastString@@ -93,6 +92,7 @@ import GHC.Utils.Outputable import GHC.Utils.Misc import GHC.Utils.Logger+import GHC.Utils.Trace  import GHC.Types.RepType import GHC.Types.Fixity.Env@@ -105,7 +105,10 @@ import GHC.Types.SrcLoc import GHC.Types.Unique import GHC.Types.Unique.Supply+import GHC.Types.Unique.DSet import GHC.Types.TyThing+import GHC.Types.BreakInfo+import GHC.Types.Unique.Map  import GHC.Unit import GHC.Unit.Module.Graph@@ -119,7 +122,6 @@ import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap import Data.List (find,intercalate)-import qualified Data.Map as Map import Control.Monad import Control.Monad.Catch as MC import Data.Array@@ -133,6 +135,7 @@ import GHC.Tc.Solver (simplifyWantedsTcM) import GHC.Tc.Utils.Monad import GHC.Core.Class (classTyCon)+import GHC.Unit.Env  -- ----------------------------------------------------------------------------- -- running a statement interactively@@ -149,7 +152,7 @@ getHistorySpan :: HscEnv -> History -> SrcSpan getHistorySpan hsc_env History{..} =   let BreakInfo{..} = historyBreakInfo in-  case lookupHpt (hsc_HPT hsc_env) (moduleName breakInfo_module) of+  case lookupHugByModule breakInfo_module (hsc_HUG hsc_env) of     Just hmi -> modBreaks_locs (getModBreaks hmi) ! breakInfo_number     _ -> panic "getHistorySpan" @@ -160,7 +163,7 @@ findEnclosingDecls :: HscEnv -> BreakInfo -> [String] findEnclosingDecls hsc_env (BreakInfo modl ix) =    let hmi = expectJust "findEnclosingDecls" $-             lookupHpt (hsc_HPT hsc_env) (moduleName modl)+             lookupHugByModule modl (hsc_HUG hsc_env)        mb = getModBreaks hmi    in modBreaks_decls mb ! ix @@ -227,11 +230,12 @@          status <-           withVirtualCWD $-            liftIO $-              evalStmt interp idflags' (isStep execSingleStep) (execWrap hval)+            liftIO $ do+              let eval_opts = initEvalOpts idflags' (isStep execSingleStep)+              evalStmt interp eval_opts (execWrap hval)          let ic = hsc_IC hsc_env-            bindings = (ic_tythings ic, ic_rn_gbl_env ic)+            bindings = (ic_tythings ic, ic_gre_cache ic)              size = ghciHistSize idflags' @@ -308,7 +312,9 @@ emptyHistory size = nilBL size  handleRunStatus :: GhcMonad m-                => SingleStep -> String-> ([TyThing],GlobalRdrEnv) -> [Id]+                => SingleStep -> String+                -> ResumeBindings+                -> [Id]                 -> EvalStatus_ [ForeignHValue] [HValueRef]                 -> BoundedList History                 -> m ExecResult@@ -342,7 +348,8 @@                !history' = mkHistory hsc_env apStack_fhv bi `consBL` history                  -- history is strict, otherwise our BoundedList is pointless.            fhv <- liftIO $ mkFinalizedHValue interp resume_ctxt-           status <- liftIO $ GHCi.resumeStmt interp dflags True fhv+           let eval_opts = initEvalOpts dflags True+           status <- liftIO $ GHCi.resumeStmt interp eval_opts fhv            handleRunStatus RunAndLogSteps expr bindings final_ids                            status history'     | otherwise@@ -415,9 +422,9 @@         -- unbind the temporary locals by restoring the TypeEnv from         -- before the breakpoint, and drop this Resume from the         -- InteractiveContext.-        let (resume_tmp_te,resume_rdr_env) = resumeBindings r+        let (resume_tmp_te,resume_gre_cache) = resumeBindings r             ic' = ic { ic_tythings = resume_tmp_te,-                       ic_rn_gbl_env = resume_rdr_env,+                       ic_gre_cache = resume_gre_cache,                        ic_resume   = rs }         setSession hsc_env{ hsc_IC = ic' } @@ -442,7 +449,8 @@                   setupBreakpoint hsc_env (fromJust mb_brkpt) (fromJust mbCnt)                     -- When the user specified a break ignore count, set it                     -- in the interpreter-                status <- liftIO $ GHCi.resumeStmt interp dflags (isStep step) fhv+                let eval_opts = initEvalOpts dflags (isStep step)+                status <- liftIO $ GHCi.resumeStmt interp eval_opts fhv                 let prevHistoryLst = fromListBL 50 hist                     hist' = case mb_brkpt of                        Nothing -> prevHistoryLst@@ -566,7 +574,7 @@         (ids, offsets, occs') = syncOccs mbPointers occs -       free_tvs = tyCoVarsOfTypesList (result_ty:map idType ids)+       free_tvs = tyCoVarsOfTypesWellScoped (result_ty:map idType ids)     -- It might be that getIdValFromApStack fails, because the AP_STACK    -- has been accidentally evaluated, or something else has gone wrong.@@ -575,7 +583,7 @@    mb_hValues <-       mapM (getBreakpointVar interp apStack_fhv . fromIntegral) offsets    when (any isNothing mb_hValues) $-      debugTraceMsg (hsc_logger hsc_env) (hsc_dflags hsc_env) 1 $+      debugTraceMsg (hsc_logger hsc_env) 1 $           text "Warning: _result has been evaluated, some bindings have been lost"     us <- mkSplitUniqSupply 'I'   -- Dodgy; will give the same uniques every time@@ -616,10 +624,11 @@    newTyVars :: UniqSupply -> [TcTyVar] -> TCvSubst      -- Similarly, clone the type variables mentioned in the types      -- we have here, *and* make them all RuntimeUnk tyvars-   newTyVars us tvs-     = mkTvSubstPrs [ (tv, mkTyVarTy (mkRuntimeUnkTyVar name (tyVarKind tv)))-                    | (tv, uniq) <- tvs `zip` uniqsFromSupply us-                    , let name = setNameUnique (tyVarName tv) uniq ]+   newTyVars us tvs = foldl' new_tv emptyTCvSubst (tvs `zip` uniqsFromSupply us)+   new_tv subst (tv,uniq) = extendTCvSubstWithClone subst tv new_tv+    where+     new_tv = mkRuntimeUnkTyVar (setNameUnique (tyVarName tv) uniq)+                                (substTy subst (tyVarKind tv))     isPointer id | [rep] <- typePrimRep (idType id)                 , isGcPtrRep rep                   = True@@ -662,12 +671,11 @@              Just new_ty -> do               case improveRTTIType hsc_env old_ty new_ty of                Nothing -> return $-                        WARN(True, text (":print failed to calculate the "-                                           ++ "improvement for a type")) hsc_env+                        warnPprTrace True (":print failed to calculate the "+                                           ++ "improvement for a type") empty hsc_env                Just subst -> do-                 let dflags = hsc_dflags hsc_env                  let logger = hsc_logger hsc_env-                 dumpIfSet_dyn logger dflags Opt_D_dump_rtti "RTTI"+                 putDumpFileMaybe logger Opt_D_dump_rtti "RTTI"                    FormatText                    (fsep [text "RTTI Improvement for", ppr id, equals,                           ppr subst])@@ -684,7 +692,7 @@    {-   Note [Syncing breakpoint info]-+  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~   To display the values of the free variables for a single breakpoint, the   function `GHC.Runtime.Eval.bindLocalsAtBreakpoint` pulls   out the information from the fields `modBreaks_breakInfo` and@@ -770,7 +778,7 @@ -- -- (setContext imports) sets the ic_imports field (which in turn -- determines what is in scope at the prompt) to 'imports', and--- constructs the ic_rn_glb_env environment to reflect it.+-- updates the icReaderEnv environment to reflect it. -- -- We retain in scope all the things defined at the prompt, and kept -- in ic_tythings.  (Indeed, they shadow stuff from ic_imports.)@@ -785,10 +793,10 @@                liftIO $ throwGhcExceptionIO (formatError dflags mod err)            Right all_env -> do {        ; let old_ic         = hsc_IC hsc_env-             !final_rdr_env = all_env `icExtendGblRdrEnv` ic_tythings old_ic+             !final_gre_cache = ic_gre_cache old_ic `replaceImportEnv` all_env        ; setSession-         hsc_env{ hsc_IC = old_ic { ic_imports    = imports-                                  , ic_rn_gbl_env = final_rdr_env }}}}+         hsc_env{ hsc_IC = old_ic { ic_imports   = imports+                                  , ic_gre_cache = final_gre_cache }}}}   where     formatError dflags mod err = ProgramError . showSDoc dflags $       text "Cannot add module" <+> ppr mod <+>@@ -853,7 +861,7 @@        case mb_stuff of          Nothing -> return Nothing          Just (thing, fixity, cls_insts, fam_insts, docs) -> do-           let rdr_env = ic_rn_gbl_env (hsc_IC hsc_env)+           let rdr_env = icReaderEnv (hsc_IC hsc_env)             -- Filter the instances based on whether the constituent names of their            -- instance heads are all in scope.@@ -862,7 +870,7 @@            return (Just (thing, fixity, cls_insts', fam_insts', docs))   where     plausible rdr_env names-          -- Dfun involving only names that are in ic_rn_glb_env+          -- Dfun involving only names that are in icReaderEnv         = allInfo        || nameSetAll ok names         where   -- A name is ok if it's in the rdr_env,@@ -870,15 +878,14 @@           ok n | n == name              = True                        -- The one we looked for in the first place!                | pretendNameIsInScope n = True-               | isBuiltInSyntax n      = True-               | isCTupleTyConName n    = True+                   -- See Note [pretendNameIsInScope] in GHC.Builtin.Names                | isExternalName n       = isJust (lookupGRE_Name rdr_env n)                | otherwise              = True  -- | Returns all names in scope in the current interactive context getNamesInScope :: GhcMonad m => m [Name] getNamesInScope = withSession $ \hsc_env ->-  return (map greMangledName (globalRdrEnvElts (ic_rn_gbl_env (hsc_IC hsc_env))))+  return (map greMangledName (globalRdrEnvElts (icReaderEnv (hsc_IC hsc_env))))  -- | Returns all 'RdrName's in scope in the current interactive -- context, excluding any that are internally-generated.@@ -886,7 +893,7 @@ getRdrNamesInScope = withSession $ \hsc_env -> do   let       ic = hsc_IC hsc_env-      gbl_rdrenv = ic_rn_gbl_env ic+      gbl_rdrenv = icReaderEnv ic       gbl_names = concatMap greRdrNames $ globalRdrEnvElts gbl_rdrenv   -- Exclude internally generated names; see e.g. #11328   return (filter (not . isDerivedOccName . rdrNameOcc) gbl_names)@@ -902,7 +909,7 @@  getDocs :: GhcMonad m         => Name-        -> m (Either GetDocsFailure (Maybe HsDocString, IntMap HsDocString))+        -> m (Either GetDocsFailure (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn)))            -- TODO: What about docs for constructors etc.? getDocs name =   withSession $ \hsc_env -> do@@ -912,14 +919,14 @@          if isInteractiveModule mod            then pure (Left InteractiveName)            else do-             ModIface { mi_doc_hdr = mb_doc_hdr-                      , mi_decl_docs = DeclDocMap dmap-                      , mi_arg_docs = ArgDocMap amap-                      } <- liftIO $ hscGetModuleInterface hsc_env mod-             if isNothing mb_doc_hdr && Map.null dmap && Map.null amap-               then pure (Left (NoDocsInIface mod compiled))-               else pure (Right ( Map.lookup name dmap-                                , Map.findWithDefault mempty name amap))+             iface <- liftIO $ hscGetModuleInterface hsc_env mod+             case mi_docs iface of+               Nothing -> pure (Left (NoDocsInIface mod compiled))+               Just Docs { docs_decls = decls+                         , docs_args = args+                         } ->+                 pure (Right ( lookupUniqMap decls name+                             , fromMaybe mempty $ lookupUniqMap args name))   where     compiled =       -- TODO: Find a more direct indicator.@@ -928,16 +935,12 @@         UnhelpfulLoc {} -> True  -- | Failure modes for 'getDocs'.---- TODO: Find a way to differentiate between modules loaded without '-haddock'--- and modules that contain no docs. data GetDocsFailure      -- | 'nameModule_maybe' returned 'Nothing'.   = NameHasNoModule Name -    -- | This is probably because the module was loaded without @-haddock@,-    -- but it's also possible that the entire module contains no documentation.+    -- | The module was loaded without @-haddock@,   | NoDocsInIface       Module       Bool -- ^ 'True': The module was compiled.@@ -951,11 +954,6 @@     quotes (ppr name) <+> text "has no module where we could look for docs."   ppr (NoDocsInIface mod compiled) = vcat     [ text "Can't find any documentation for" <+> ppr mod <> char '.'-    , text "This is probably because the module was"-        <+> text (if compiled then "compiled" else "loaded")-        <+> text "without '-haddock',"-    , text "but it's also possible that the module contains no documentation."-    , text ""     , if compiled         then text "Try re-compiling with '-haddock'."         else text "Try running ':set -haddock' and :load the file again."@@ -1032,7 +1030,7 @@ getInstancesForType :: GhcMonad m => Type -> m [ClsInst] getInstancesForType ty = withSession $ \hsc_env ->   liftIO $ runInteractiveHsc hsc_env $-    ioMsgMaybe $ runTcInteractive hsc_env $ do+    ioMsgMaybe $ hoistTcRnMessage $ runTcInteractive hsc_env $ do       -- Bring class and instances from unqualified modules into scope, this fixes #16793.       loadUnqualIfaces hsc_env (hsc_IC hsc_env)       matches <- findMatchingInstances ty@@ -1045,7 +1043,7 @@   (ty, _) <- liftIO $ runInteractiveHsc hsc_env0 $ do     hsc_env <- getHscEnv     ty <- hscParseType str-    ioMsgMaybe $ tcRnType hsc_env SkolemiseFlexi True ty+    ioMsgMaybe $ hoistTcRnMessage $ tcRnType hsc_env SkolemiseFlexi True ty    return ty @@ -1054,24 +1052,20 @@ getDictionaryBindings theta = do   dictName <- newName (mkDictOcc (mkVarOcc "magic"))   let dict_var = mkVanillaGlobal dictName theta-  loc <- getCtLocM (GivenOrigin UnkSkol) Nothing+  loc <- getCtLocM (GivenOrigin (getSkolemInfo unkSkol)) Nothing -  -- Generate a wanted here because at the end of constraint-  -- solving, most derived constraints get thrown away, which in certain-  -- cases, notably with quantified constraints makes it impossible to rule-  -- out instances as invalid. (See #18071)   return CtWanted {     ctev_pred = varType dict_var,     ctev_dest = EvVarDest dict_var,-    ctev_nosh = WDeriv,-    ctev_loc = loc+    ctev_loc = loc,+    ctev_rewriters = emptyRewriterSet   }  -- Find instances where the head unifies with the provided type findMatchingInstances :: Type -> TcM [(ClsInst, [DFunInstType])] findMatchingInstances ty = do   ies@(InstEnvs {ie_global = ie_global, ie_local = ie_local}) <- tcGetInstEnvs-  let allClasses = instEnvClasses ie_global ++ instEnvClasses ie_local+  let allClasses = uniqDSetToList $ instEnvClasses ie_global `unionUniqDSets` instEnvClasses ie_local   return $ concatMap (try_cls ies) allClasses   where   {- Check that a class instance is well-kinded.@@ -1125,13 +1119,19 @@   -- which otherwise appear as opaque type variables. (See #18262).   WC { wc_simple = simples, wc_impl = impls } <- simplifyWantedsTcM wanteds -  if allBag allowedSimple simples && solvedImplics impls-  then return . Just $ substInstArgs tys (bagToList (mapBag ctPred simples)) clsInst+  -- The simples might contain superclasses. This clutters up the output+  -- (we want e.g. instance Ord a => Ord (Maybe a), not+  -- instance (Ord a, Eq a) => Ord (Maybe a)). So we use mkMinimalBySCs+  let simple_preds = map ctPred (bagToList simples)+  let minimal_simples = mkMinimalBySCs id simple_preds++  if all allowedSimple minimal_simples && solvedImplics impls+  then return . Just $ substInstArgs tys minimal_simples clsInst   else return Nothing    where-  allowedSimple :: Ct -> Bool-  allowedSimple ct = isSatisfiablePred (ctPred ct)+  allowedSimple :: PredType -> Bool+  allowedSimple pred = isSatisfiablePred pred    solvedImplics :: Bag Implication -> Bool   solvedImplics impls = allBag (isSolvedStatus . ic_status) impls@@ -1211,7 +1211,8 @@         _ -> panic "compileParsedExprRemote"    updateFixityEnv fix_env-  status <- liftIO $ evalStmt interp dflags False (EvalThis hvals_io)+  let eval_opts = initEvalOpts dflags False+  status <- liftIO $ evalStmt interp eval_opts (EvalThis hvals_io)   case status of     EvalComplete _ (EvalSuccess [hval]) -> return hval     EvalComplete _ (EvalException e) ->@@ -1243,8 +1244,7 @@     withSession $ \hsc_env -> do         interpreted <- moduleIsBootOrNotObjectLinkable mod_summary         let dflags = hsc_dflags hsc_env-        -- extendModSummaryNoDeps because the message doesn't look at the deps-        return (showSDoc dflags $ showModMsg dflags interpreted (ModuleNode (extendModSummaryNoDeps mod_summary)))+        return (showSDoc dflags $ showModMsg dflags interpreted (ModuleNode [] mod_summary))  moduleIsBootOrNotObjectLinkable :: GhcMonad m => ModSummary -> m Bool moduleIsBootOrNotObjectLinkable mod_summary = withSession $ \hsc_env ->@@ -1271,13 +1271,13 @@  obtainTermFromId :: HscEnv -> Int -> Bool -> Id -> IO Term obtainTermFromId hsc_env bound force id =  do-  hv <- Loader.loadName (hscInterp hsc_env) hsc_env (varName id)+  (hv, _, _) <- Loader.loadName (hscInterp hsc_env) hsc_env (varName id)   cvObtainTerm hsc_env bound force (idType id) hv  -- Uses RTTI to reconstruct the type of an Id, making it less polymorphic reconstructType :: HscEnv -> Int -> Id -> IO (Maybe Type) reconstructType hsc_env bound id = do-  hv <- Loader.loadName (hscInterp hsc_env) hsc_env (varName id)+  (hv, _, _) <- Loader.loadName (hscInterp hsc_env) hsc_env (varName id)   cvReconstructType hsc_env bound (idType id) hv  mkRuntimeUnkTyVar :: Name -> Kind -> TyVar
GHC/Runtime/Eval/Types.hs view
@@ -7,9 +7,9 @@ -- -----------------------------------------------------------------------------  module GHC.Runtime.Eval.Types (-        Resume(..), History(..), ExecResult(..),-        SingleStep(..), isStep, ExecOptions(..),-        BreakInfo(..)+        Resume(..), ResumeBindings, IcGlobalRdrEnv(..),+        History(..), ExecResult(..),+        SingleStep(..), isStep, ExecOptions(..)         ) where  import GHC.Prelude@@ -19,7 +19,7 @@ import GHC.Types.Id import GHC.Types.Name import GHC.Types.TyThing-import GHC.Unit.Module+import GHC.Types.BreakInfo import GHC.Types.Name.Reader import GHC.Types.SrcLoc import GHC.Utils.Exception@@ -54,15 +54,22 @@        , breakInfo :: Maybe BreakInfo        } -data BreakInfo = BreakInfo-  { breakInfo_module :: Module-  , breakInfo_number :: Int+-- | Essentially a GlobalRdrEnv, but with additional cached values to allow+-- efficient re-calculation when the imports change.+-- Fields are strict to avoid space leaks (see T4029)+-- All operations are in GHC.Runtime.Context.+-- See Note [icReaderEnv recalculation]+data IcGlobalRdrEnv = IcGlobalRdrEnv+  { igre_env :: !GlobalRdrEnv+    -- ^ The final environment+  , igre_prompt_env :: !GlobalRdrEnv+    -- ^ Just the things defined at the prompt (excluding imports!)   }  data Resume = Resume        { resumeStmt      :: String       -- the original statement        , resumeContext   :: ForeignRef (ResumeContext [HValueRef])-       , resumeBindings  :: ([TyThing], GlobalRdrEnv)+       , resumeBindings  :: ResumeBindings        , resumeFinalIds  :: [Id]         -- [Id] to bind on completion        , resumeApStack   :: ForeignHValue -- The object from which we can get                                         -- value of the free variables.@@ -80,6 +87,8 @@        , resumeHistory   :: [History]        , resumeHistoryIx :: Int           -- 0 <==> at the top of the history        }++type ResumeBindings = ([TyThing], IcGlobalRdrEnv)  data History    = History {
GHC/Runtime/Heap/Inspect.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE BangPatterns, CPP, ScopedTypeVariables, MagicHash #-}+{-# LANGUAGE BangPatterns, ScopedTypeVariables, MagicHash #-}  ----------------------------------------------------------------------------- --@@ -23,8 +23,6 @@      constrClosToName -- exported to use in test T4891  ) where -#include "HsVersions.h"- import GHC.Prelude import GHC.Platform @@ -60,6 +58,7 @@ import GHC.Driver.Ppr import GHC.Utils.Outputable as Ppr import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Char import GHC.Exts.Heap import GHC.Runtime.Heap.Layout ( roundUpTo )@@ -134,7 +133,7 @@ constrClosToName hsc_env ConstrClosure{pkg=pkg,modl=mod,name=occ} = do    let occName = mkOccName OccName.dataName occ        modName = mkModule (stringToUnit pkg) (mkModuleName mod)-   Right `fmap` lookupOrigIO hsc_env modName occName+   Right `fmap` lookupNameCache (hsc_NC hsc_env) modName occName constrClosToName _hsc_env clos =    return (Left ("conClosToName: Expected ConstrClosure, got " ++ show (fmap (const ()) clos))) @@ -267,17 +266,16 @@ ppr_termM1 Prim{valRaw=words, ty=ty} =     return $ repPrim (tyConAppTyCon ty) words ppr_termM1 Suspension{ty=ty, bound_to=Nothing} =-    return (char '_' <+> whenPprDebug (text "::" <> ppr ty))+    return (char '_' <+> whenPprDebug (dcolon <> pprSigmaType ty)) ppr_termM1 Suspension{ty=ty, bound_to=Just n}---  | Just _ <- splitFunTy_maybe ty = return$ ptext (sLit("<function>")-  | otherwise = return$ parens$ ppr n <> text "::" <> ppr ty+  | otherwise = return$ parens$ ppr n <> dcolon <> pprSigmaType ty ppr_termM1 Term{}        = panic "ppr_termM1 - Term" ppr_termM1 RefWrap{}     = panic "ppr_termM1 - RefWrap" ppr_termM1 NewtypeWrap{} = panic "ppr_termM1 - NewtypeWrap"  pprNewtypeWrap y p NewtypeWrap{ty=ty, wrapped_term=t}   | Just (tc,_) <- tcSplitTyConApp_maybe ty-  , ASSERT(isNewTyCon tc) True+  , assert (isNewTyCon tc) True   , Just new_dc <- tyConSingleDataCon_maybe tc = do              real_term <- y max_prec t              return $ cparen (p >= app_prec) (ppr new_dc <+> real_term)@@ -519,10 +517,7 @@ -}  --- A (non-mutable) tau type containing--- existentially quantified tyvars.---    (since GHC type language currently does not support---     existentials, we leave these variables unquantified)+-- See Note [RttiType] type RttiType = Type  -- An incomplete type as stored in GHCi:@@ -573,6 +568,37 @@ newOpenVar = liftTcM (do { kind <- newOpenTypeKind                          ; newVar kind }) +{- Note [RttiType]+~~~~~~~~~~~~~~~~~~+The type synonym `type RttiType = Type` is the type synonym used+by the debugger for the types of the data type `Term`.++For a long time the `RttiType` carried the following comment:++>     A (non-mutable) tau type containing+>     existentially quantified tyvars.+>          (since GHC type language currently does not support+>          existentials, we leave these variables unquantified)++The tau type part is only correct for terms representing the results+of fully saturated functions that return non-function (data) values+and not functions.++For non-function values, the GHC runtime always works with concrete+types eg `[Maybe Int]`, but never with polymorphic types like eg+`(Traversable t, Monad m) => t (m a)`. The concrete types, don't+need a quantification. They are always tau types.++The debugger binds the terms of :print commands and of the free+variables at a breakpoint to names. These newly bound names can+be used in new GHCi expressions. If these names represent functions,+then the type checker expects that the types of these functions are+fully-fledged. They must contain the necessary `forall`s and type+constraints. Hence the types of terms that represent functions must+be sigmas and not taus.+(See #12449)+-}+ {- Note [RuntimeUnkTv] ~~~~~~~~~~~~~~~~~~~~~~ In the GHCi debugger we use unification variables whose MetaInfo is@@ -606,7 +632,8 @@ This allows metavariables to unify with types that have nested (or higher-rank) `forall`s/`=>`s, which makes `:print fmap` display as-`fmap = (_t1::forall a b. Functor f => (a -> b) -> f a -> f b)`, as expected.+`fmap = (_t1::forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b)`,+as expected. -}  @@ -690,23 +717,22 @@   -- we quantify existential tyvars as universal,   -- as this is needed to be able to manipulate   -- them properly-   let quant_old_ty@(old_tvs, old_tau) = quantifyType old_ty-       sigma_old_ty = mkInfForAllTys old_tvs old_tau+   let quant_old_ty@(old_tvs, _) = quantifyType old_ty    traceTR (text "Term reconstruction started with initial type " <> ppr old_ty)    term <-      if null old_tvs       then do-        term  <- go max_depth sigma_old_ty sigma_old_ty hval+        term  <- go max_depth old_ty old_ty hval         term' <- zonkTerm term         return $ fixFunDictionaries $ expandNewtypes term'       else do               (old_ty', rev_subst) <- instScheme quant_old_ty               my_ty <- newOpenVar-              when (check1 quant_old_ty) (traceTR (text "check1 passed") >>+              when (check1 old_tvs) (traceTR (text "check1 passed") >>                                           addConstraint my_ty old_ty')-              term  <- go max_depth my_ty sigma_old_ty hval+              term  <- go max_depth my_ty old_ty hval               new_ty <- zonkTcType (termType term)-              if isMonomorphic new_ty || check2 (quantifyType new_ty) quant_old_ty+              if isMonomorphic new_ty || check2 new_ty old_ty                  then do                       traceTR (text "check2 passed")                       addConstraint new_ty old_ty'@@ -731,12 +757,9 @@    return term     where   interp = hscInterp hsc_env+  unit_env = hsc_unit_env hsc_env    go :: Int -> Type -> Type -> ForeignHValue -> TcM Term-   -- I believe that my_ty should not have any enclosing-   -- foralls, nor any free RuntimeUnk skolems;-   -- that is partly what the quantifyType stuff achieved-   --    -- [SPJ May 11] I don't understand the difference between my_ty and old_ty    go 0 my_ty _old_ty a = do@@ -753,7 +776,7 @@ -- Thunks we may want to force       t | isThunk t && force -> do          traceTR (text "Forcing a " <> text (show (fmap (const ()) t)))-         evalRslt <- liftIO $ GHCi.seqHValue interp hsc_env a+         evalRslt <- liftIO $ GHCi.seqHValue interp unit_env a          case evalRslt of                                            -- #2950            EvalSuccess _ -> go (pred max_depth) my_ty old_ty a            EvalException ex -> do@@ -784,17 +807,19 @@          go max_depth my_ty old_ty ind -- We also follow references       MutVarClosure{var=contents}-         | Just (tycon,[world,contents_ty]) <- tcSplitTyConApp_maybe old_ty+         | Just (tycon,[lev,world,contents_ty]) <- tcSplitTyConApp_maybe old_ty              -> do                   -- Deal with the MutVar# primitive                   -- It does not have a constructor at all,                   -- so we simulate the following one                   -- MutVar# :: contents_ty -> MutVar# s contents_ty+         massert (tycon == mutVarPrimTyCon)+         massert (isUnliftedType my_ty)          traceTR (text "Following a MutVar")-         contents_tv <- newVar liftedTypeKind-         MASSERT(isUnliftedType my_ty)+         let contents_kind = mkTYPEapp (mkTyConApp boxedRepDataConTyCon [lev])+         contents_tv <- newVar contents_kind          (mutvar_ty,_) <- instScheme $ quantifyType $ mkVisFunTyMany-                            contents_ty (mkTyConApp tycon [world,contents_ty])+                            contents_ty (mkTyConApp tycon [lev, world,contents_ty])          addConstraint (mkVisFunTyMany contents_tv my_ty) mutvar_ty          x <- go (pred max_depth) contents_tv contents_ty contents          return (RefWrap my_ty x)@@ -816,8 +841,7 @@                        traceTR (text "Not constructor" <+> ppr dcname)                        let dflags = hsc_dflags hsc_env                            tag = showPpr dflags dcname-                       vars     <- replicateM (length pArgs)-                                              (newVar liftedTypeKind)+                       vars     <- mapM (const (newVar liftedTypeKind)) pArgs                        subTerms <- sequence $ zipWith (\x tv ->                            go (pred max_depth) tv tv x) pArgs vars                        return (Term my_ty (Left ('<' : tag ++ ">")) a subTerms)@@ -912,7 +936,7 @@                      [index size_b aligned_idx word_size endian]                  | otherwise =                      let (q, r) = size_b `quotRem` word_size-                     in ASSERT( r == 0 )+                     in assert (r == 0 )                         [ array!!i                         | o <- [0.. q - 1]                         , let i = (aligned_idx `quot` word_size) + o@@ -979,14 +1003,14 @@         else do           (old_ty', rev_subst) <- instScheme sigma_old_ty           my_ty <- newOpenVar-          when (check1 sigma_old_ty) (traceTR (text "check1 passed") >>+          when (check1 old_tvs) (traceTR (text "check1 passed") >>                                       addConstraint my_ty old_ty')           search (isMonomorphic `fmap` zonkTcType my_ty)                  (\(ty,a) -> go ty a)                  (Seq.singleton (my_ty, hval))                  max_depth           new_ty <- zonkTcType my_ty-          if isMonomorphic new_ty || check2 (quantifyType new_ty) sigma_old_ty+          if isMonomorphic new_ty || check2 new_ty old_ty             then do                  traceTR (text "check2 passed" <+> ppr old_ty $$ ppr new_ty)                  addConstraint my_ty old_ty'@@ -1017,11 +1041,17 @@     case clos of       BlackholeClosure{indirectee=ind} -> go my_ty ind       IndClosure{indirectee=ind} -> go my_ty ind-      MutVarClosure{var=contents} -> do-         tv'   <- newVar liftedTypeKind-         world <- newVar liftedTypeKind-         addConstraint my_ty (mkTyConApp mutVarPrimTyCon [world,tv'])-         return [(tv', contents)]+      MutVarClosure{var=contents}+        | Just (_tycon,[lev,_world,_contents_ty]) <- tcSplitTyConApp_maybe my_ty+        -> do+        massert (_tycon == mutVarPrimTyCon)+        tv'   <- newVar $ mkTYPEapp (mkTyConApp boxedRepDataConTyCon [lev])+        world <- newVar liftedTypeKind+        addConstraint my_ty $ mkMutVarPrimTy world tv'+        return [(tv', contents)]+      APClosure {payload=pLoad} -> do                -- #19559 (incr)+        mapM_ (go my_ty) pLoad+        return []       ConstrClosure{ptrArgs=pArgs} -> do         Right dcname <- liftIO $ constrClosToName hsc_env clos         traceTR (text "Constr1" <+> ppr dcname)@@ -1079,13 +1109,11 @@ -- return the types of the arguments.  This is RTTI-land, so 'ty' might -- not be fully known.  Moreover, the arg types might involve existentials; -- if so, make up fresh RTTI type variables for them------ I believe that con_app_ty should not have any enclosing foralls getDataConArgTys dc con_app_ty   = do { let rep_con_app_ty = unwrapType con_app_ty        ; traceTR (text "getDataConArgTys 1" <+> (ppr con_app_ty $$ ppr rep_con_app_ty                    $$ ppr (tcSplitTyConApp_maybe rep_con_app_ty)))-       ; ASSERT( all isTyVar ex_tvs ) return ()+       ; assert (all isTyVar ex_tvs ) return ()                  -- ex_tvs can only be tyvars as data types in source                  -- Haskell cannot mention covar yet (Aug 2018)        ; (subst, _) <- instTyVars (univ_tvs ++ ex_tvs)@@ -1239,21 +1267,37 @@  -} -check1 :: QuantifiedType -> Bool-check1 (tvs, _) = not $ any isHigherKind (map tyVarKind tvs)+check1 :: [TyVar] -> Bool+check1 tvs = not $ any isHigherKind (map tyVarKind tvs)  where    isHigherKind = not . null . fst . splitPiTys -check2 :: QuantifiedType -> QuantifiedType -> Bool-check2 (_, rtti_ty) (_, old_ty)-  | Just (_, rttis) <- tcSplitTyConApp_maybe rtti_ty-  = case () of-      _ | Just (_,olds) <- tcSplitTyConApp_maybe old_ty-        -> and$ zipWith check2 (map quantifyType rttis) (map quantifyType olds)-      _ | Just _ <- splitAppTy_maybe old_ty-        -> isMonomorphicOnNonPhantomArgs rtti_ty-      _ -> True-  | otherwise = True+check2 :: Type -> Type -> Bool+check2 rtti_ty old_ty = check2' (tauPart rtti_ty) (tauPart old_ty)+  -- The function `tcSplitTyConApp_maybe` doesn't split foralls or types+  -- headed with (=>). Hence here we need only the tau part of a type.+  -- See Note [Missing test case].+  where+    check2' rtti_ty old_ty+      | Just (_, rttis) <- tcSplitTyConApp_maybe rtti_ty+      = case () of+          _ | Just (_,olds) <- tcSplitTyConApp_maybe old_ty+            -> and$ zipWith check2 rttis olds+          _ | Just _ <- splitAppTy_maybe old_ty+            -> isMonomorphicOnNonPhantomArgs rtti_ty+          _ -> True+      | otherwise = True+    tauPart ty = tau+      where+        (_, _, tau) = tcSplitNestedSigmaTys ty+{-+Note [Missing test case]+~~~~~~~~~~~~~~~~~~~~~~~~+Her we miss a test case. It should be a term, with a function `f`+with a non-empty sigma part and an unsound type. The result of+`check2 f` should be different if we omit or do the calls to `tauPart`.+I (R.Senn) was unable to find such a term, and I'm in doubt, whether it exists.+-}  -- Dealing with newtypes --------------------------@@ -1383,18 +1427,12 @@  type QuantifiedType = ([TyVar], Type)    -- Make the free type variables explicit-   -- The returned Type should have no top-level foralls (I believe)  quantifyType :: Type -> QuantifiedType--- Generalize the type: find all free and forall'd tyvars--- and return them, together with the type inside, which--- should not be a forall type.------ Thus (quantifyType (forall a. a->[b]))--- returns ([a,b], a -> [b])-+-- Find all free and forall'd tyvars and return them+-- together with the unmodified input type. quantifyType ty = ( filter isTyVar $                     tyCoVarsOfTypeWellScoped rho-                  , rho)+                  , ty)   where-    (_tvs, rho) = tcSplitForAllInvisTyVars ty+    (_tvs, _, rho) = tcSplitNestedSigmaTys ty
GHC/Runtime/Heap/Layout.hs view
@@ -3,7 +3,8 @@ -- -- Storage manager representation of closures -{-# LANGUAGE CPP,GeneralizedNewtypeDeriving #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}  module GHC.Runtime.Heap.Layout (         -- * Words and bytes@@ -47,11 +48,8 @@ import GHC.Prelude  import GHC.Types.Basic( ConTagZ )-import GHC.Driver.Session import GHC.Platform import GHC.Platform.Profile-import GHC.Data.FastString-import GHC.StgToCmm.Types  import GHC.Utils.Outputable import GHC.Utils.Panic@@ -70,6 +68,9 @@ -- | Byte offset, or byte count type ByteOff = Int +-- | Word offset, or word count+type WordOff = Int+ -- | Round up the given byte count to the next byte count that's a -- multiple of the machine's word size. roundUpToWords :: Platform -> ByteOff -> ByteOff@@ -174,6 +175,7 @@   | RTSRep              -- The RTS needs to declare info tables with specific         Int             -- type tags, so this form lets us override the default         SMRep           -- tag for an SMRep.+  deriving Eq  -- | True \<=> This is a static closure.  Affects how we garbage-collect it. -- Static closure have an extra static link field at the end.@@ -181,7 +183,7 @@ type IsStatic = Bool  -- From an SMRep you can get to the closure type defined in--- includes/rts/storage/ClosureTypes.h. Described by the function+-- rts/include/rts/storage/ClosureTypes.h. Described by the function -- rtsClosureType below.  data ClosureTypeInfo@@ -191,11 +193,43 @@   | ThunkSelector SelectorOffset   | BlackHole   | IndStatic+  deriving Eq  type ConstrDescription = ByteString -- result of dataConIdentity type FunArity          = Int type SelectorOffset    = Int +-- | We represent liveness bitmaps as a Bitmap (whose internal representation+-- really is a bitmap).  These are pinned onto case return vectors to indicate+-- the state of the stack for the garbage collector.+--+-- In the compiled program, liveness bitmaps that fit inside a single word+-- (StgWord) are stored as a single word, while larger bitmaps are stored as a+-- pointer to an array of words.++type Liveness = [Bool]   -- One Bool per word; True  <=> non-ptr or dead+                         --                    False <=> ptr++--------------------------------------------------------------------------------+-- | An ArgDescr describes the argument pattern of a function++data ArgDescr+  = ArgSpec             -- Fits one of the standard patterns+        !Int            -- RTS type identifier ARG_P, ARG_N, ...++  | ArgGen              -- General case+        Liveness        -- Details about the arguments++  | ArgUnknown          -- For imported binds.+                        -- Invariant: Never Unknown for binds of the module+                        -- we are compiling.+  deriving (Eq)++instance Outputable ArgDescr where+  ppr (ArgSpec n) = text "ArgSpec" <+> ppr n+  ppr (ArgGen ls) = text "ArgGen" <+> ppr ls+  ppr ArgUnknown = text "ArgUnknown"+ ----------------------------------------------------------------------------- -- Construction @@ -404,8 +438,8 @@ ----------------------------------------------------------------------------- -- deriving the RTS closure type from an SMRep -#include "../includes/rts/storage/ClosureTypes.h"-#include "../includes/rts/storage/FunTypes.h"+#include "ClosureTypes.h"+#include "FunTypes.h" -- Defines CONSTR, CONSTR_1_0 etc  -- | Derives the RTS closure type from an 'SMRep'@@ -445,6 +479,8 @@       HeapRep False _ _ BlackHole -> BLACKHOLE       HeapRep False _ _ IndStatic -> IND_STATIC +      StackRep _ -> STACK+       _ -> panic "rtsClosureType"  -- We export these ones@@ -534,8 +570,8 @@  pprTypeInfo (Fun arity args)   = text "Fun" <+>-    braces (sep [ text "arity:" <+> ppr arity-                , ptext (sLit ("fun_type:")) <+> ppr args ])+    braces (sep [ text "arity:"    <+> ppr arity+                , text "fun_type:" <+> ppr args ])  pprTypeInfo (ThunkSelector offset)   = text "ThunkSel" <+> ppr offset
GHC/Runtime/Interpreter.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-}@@ -11,6 +11,7 @@   ( module GHC.Runtime.Interpreter.Types    -- * High-level interface to the interpreter+  , BCOOpts (..)   , evalStmt, EvalStatus_(..), EvalStatus, EvalResult(..), EvalExpr(..)   , resumeStmt   , abandonStmt@@ -47,28 +48,25 @@    -- * Lower-level API using messages   , interpCmd, Message(..), withIServ, withIServ_-  , hscInterp, stopInterp+  , stopInterp   , iservCall, readIServ, writeIServ   , purgeLookupSymbolCache   , freeHValueRefs   , mkFinalizedHValue   , wormhole, wormholeRef-  , mkEvalOpts   , fromEvalResult   ) where  import GHC.Prelude -import GHC.Driver.Ppr (showSDoc)-import GHC.Driver.Env-import GHC.Driver.Session+import GHC.IO (catchException)  import GHC.Runtime.Interpreter.Types import GHCi.Message import GHCi.RemoteTypes import GHCi.ResolvedBCO import GHCi.BreakArray (BreakArray)-import GHC.Runtime.Eval.Types(BreakInfo(..))+import GHC.Types.BreakInfo (BreakInfo(..)) import GHC.ByteCode.Types  import GHC.Linker.Types@@ -83,13 +81,14 @@  import GHC.Utils.Panic import GHC.Utils.Exception as Ex-import GHC.Utils.Outputable(brackets, ppr)+import GHC.Utils.Outputable(brackets, ppr, showSDocUnsafe) import GHC.Utils.Fingerprint import GHC.Utils.Misc  import GHC.Unit.Module import GHC.Unit.Module.ModIface import GHC.Unit.Home.ModInfo+import GHC.Unit.Env  #if defined(HAVE_INTERNAL_INTERPRETER) import GHCi.Run@@ -119,10 +118,10 @@ #endif import System.Directory import System.Process-import GHC.Conc (getNumProcessors, pseq, par)+import GHC.Conc (pseq, par)  {- Note [Remote GHCi]-+   ~~~~~~~~~~~~~~~~~~ When the flag -fexternal-interpreter is given to GHC, interpreted code is run in a separate process called iserv, and we communicate with the external process over a pipe using Binary-encoded messages.@@ -200,16 +199,8 @@       iservCall iserv msg  --- | 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- -- Note [uninterruptibleMask_ and interpCmd]---+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- If we receive an async exception, such as ^C, while communicating -- with the iserv process then we will be out-of-sync and not be able -- to recover.  Thus we use uninterruptibleMask_ during@@ -260,13 +251,12 @@ -- each of the results. evalStmt   :: Interp-  -> DynFlags -- used by mkEvalOpts-  -> Bool     -- "step" for mkEvalOpts+  -> EvalOpts   -> EvalExpr ForeignHValue   -> IO (EvalStatus_ [ForeignHValue] [HValueRef])-evalStmt interp dflags step foreign_expr = do+evalStmt interp opts foreign_expr = do   status <- withExpr foreign_expr $ \expr ->-    interpCmd interp (EvalStmt (mkEvalOpts dflags step) expr)+    interpCmd interp (EvalStmt opts expr)   handleEvalStatus interp status  where   withExpr :: EvalExpr ForeignHValue -> (EvalExpr HValueRef -> IO a) -> IO a@@ -279,13 +269,12 @@  resumeStmt   :: Interp-  -> DynFlags -- used by mkEvalOpts-  -> Bool     -- "step" for mkEvalOpts+  -> EvalOpts   -> ForeignRef (ResumeContext [HValueRef])   -> IO (EvalStatus_ [ForeignHValue] [HValueRef])-resumeStmt interp dflags step resume_ctxt = do+resumeStmt interp opts resume_ctxt = do   status <- withForeignRef resume_ctxt $ \rhv ->-    interpCmd interp (ResumeStmt (mkEvalOpts dflags step) rhv)+    interpCmd interp (ResumeStmt opts rhv)   handleEvalStatus interp status  abandonStmt :: Interp -> ForeignRef (ResumeContext [HValueRef]) -> IO ()@@ -335,18 +324,18 @@ mkCostCentres interp mod ccs =   interpCmd interp (MkCostCentres mod ccs) +newtype BCOOpts = BCOOpts+  { bco_n_jobs :: Int -- ^ Number of parallel jobs doing BCO serialization+  }+ -- | Create a set of BCOs that may be mutually recursive.-createBCOs :: Interp -> DynFlags -> [ResolvedBCO] -> IO [HValueRef]-createBCOs interp dflags rbcos = do-  n_jobs <- case parMakeCount dflags of-              Nothing -> liftIO getNumProcessors-              Just n  -> return n-  -- Serializing ResolvedBCO is expensive, so if we're in parallel mode-  -- (-j<n>) parallelise the serialization.+createBCOs :: Interp -> BCOOpts -> [ResolvedBCO] -> IO [HValueRef]+createBCOs interp opts rbcos = do+  let n_jobs = bco_n_jobs opts+  -- Serializing ResolvedBCO is expensive, so if we support doing it in parallel   if (n_jobs == 1)     then       interpCmd interp (CreateBCOs [runPut (put rbcos)])-     else do       old_caps <- getNumCapabilities       if old_caps == n_jobs@@ -404,33 +393,33 @@     mapM (mkFinalizedHValue interp) mb  -- | Send a Seq message to the iserv process to force a value      #2950-seqHValue :: Interp -> HscEnv -> ForeignHValue -> IO (EvalResult ())-seqHValue interp hsc_env ref =+seqHValue :: Interp -> UnitEnv -> ForeignHValue -> IO (EvalResult ())+seqHValue interp unit_env ref =   withForeignRef ref $ \hval -> do     status <- interpCmd interp (Seq hval)-    handleSeqHValueStatus interp hsc_env status+    handleSeqHValueStatus interp unit_env status  -- | Process the result of a Seq or ResumeSeq message.             #2950-handleSeqHValueStatus :: Interp -> HscEnv -> EvalStatus () -> IO (EvalResult ())-handleSeqHValueStatus interp hsc_env eval_status =+handleSeqHValueStatus :: Interp -> UnitEnv -> EvalStatus () -> IO (EvalResult ())+handleSeqHValueStatus interp unit_env eval_status =   case eval_status of     (EvalBreak is_exception _ ix mod_uniq resume_ctxt _) -> do       -- A breakpoint was hit; inform the user and tell them       -- which breakpoint was hit.       resume_ctxt_fhv <- liftIO $ mkFinalizedHValue interp resume_ctxt       let hmi = expectJust "handleRunStatus" $-                  lookupHptDirectly (hsc_HPT hsc_env)+                  lookupHptDirectly (ue_hpt unit_env)                     (mkUniqueGrimily mod_uniq)           modl = mi_module (hm_iface hmi)           bp | is_exception = Nothing              | otherwise = Just (BreakInfo modl ix)           sdocBpLoc = brackets . ppr . getSeqBpSpan       putStrLn ("*** Ignoring breakpoint " ++-            (showSDoc (hsc_dflags hsc_env) $ sdocBpLoc bp))+            (showSDocUnsafe $ sdocBpLoc bp))       -- resume the seq (:force) processing in the iserv process       withForeignRef resume_ctxt_fhv $ \hval -> do         status <- interpCmd interp (ResumeSeq hval)-        handleSeqHValueStatus interp hsc_env status+        handleSeqHValueStatus interp unit_env status     (EvalComplete _ r) -> return r   where     getSeqBpSpan :: Maybe BreakInfo -> SrcSpan@@ -442,7 +431,7 @@     -- Reason: Setting of flags in libraries/ghci/GHCi/Run.hs:evalOptsSeq     getSeqBpSpan Nothing = mkGeneralSrcSpan (fsLit "<unknown>")     breaks mod = getModBreaks $ expectJust "getSeqBpSpan" $-      lookupHpt (hsc_HPT hsc_env) (moduleName mod)+      lookupHpt (ue_hpt unit_env) (moduleName mod)   -- -----------------------------------------------------------------------------@@ -521,6 +510,7 @@   interpCmd interp (UnloadObj path')  -- Note [loadObj and relative paths]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- the iserv process might have a different current directory from the -- GHC process, so we must make paths absolute before sending them -- over.@@ -547,19 +537,19 @@ iservCall :: Binary a => IServInstance -> Message a -> IO a iservCall iserv msg =   remoteCall (iservPipe iserv) msg-    `catch` \(e :: SomeException) -> handleIServFailure iserv e+    `catchException` \(e :: SomeException) -> handleIServFailure iserv e  -- | Read a value from the iserv process readIServ :: IServInstance -> Get a -> IO a readIServ iserv get =   readPipe (iservPipe iserv) get-    `catch` \(e :: SomeException) -> handleIServFailure iserv e+    `catchException` \(e :: SomeException) -> handleIServFailure iserv e  -- | Send a value to the iserv process writeIServ :: IServInstance -> Put -> IO () writeIServ iserv put =   writePipe (iservPipe iserv) put-    `catch` \(e :: SomeException) -> handleIServFailure iserv e+    `catchException` \(e :: SomeException) -> handleIServFailure iserv e  handleIServFailure :: IServInstance -> SomeException -> IO a handleIServFailure iserv e = do@@ -646,7 +636,7 @@  -- ----------------------------------------------------------------------------- {- Note [External GHCi pointers]-+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We have the following ways to reference things in GHCi:  HValue@@ -727,14 +717,6 @@  -- ----------------------------------------------------------------------------- -- Misc utils--mkEvalOpts :: DynFlags -> Bool -> EvalOpts-mkEvalOpts dflags step =-  EvalOpts-    { useSandboxThread = gopt Opt_GhciSandbox dflags-    , singleStep = step-    , breakOnException = gopt Opt_BreakOnException dflags-    , breakOnError = gopt Opt_BreakOnError dflags }  fromEvalResult :: EvalResult a -> IO a fromEvalResult (EvalException e) = throwIO (fromSerializableException e)
GHC/Runtime/Loader.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE CPP #-} + -- | Dynamically lookup up values from modules and loading them. module GHC.Runtime.Loader (         initializePlugins,@@ -28,7 +28,7 @@ import GHC.Driver.Plugins  import GHC.Linker.Loader       ( loadModule, loadName )-import GHC.Runtime.Interpreter ( wormhole, hscInterp )+import GHC.Runtime.Interpreter ( wormhole ) import GHC.Runtime.Interpreter.Types  import GHC.Tc.Utils.Monad      ( initTcInteractive, initIfaceTcRn )@@ -51,8 +51,10 @@                                , greMangledName, mkRdrQual )  import GHC.Unit.Finder         ( findPluginModule, FindResult(..) )+import GHC.Driver.Config.Finder ( initFinderOpts ) import GHC.Unit.Module   ( Module, ModuleName ) import GHC.Unit.Module.ModIface+import GHC.Unit.Env  import GHC.Utils.Panic import GHC.Utils.Logger@@ -60,11 +62,12 @@ import GHC.Utils.Outputable import GHC.Utils.Exception -import GHC.Data.FastString- import Control.Monad     ( unless ) import Data.Maybe        ( mapMaybe ) import Unsafe.Coerce     ( unsafeCoerce )+import GHC.Linker.Types+import GHC.Types.Unique.DFM+import Data.List (unzip4)  -- | Loads the plugins specified in the pluginModNames field of the dynamic -- flags. Should be called after command line arguments are parsed, but before@@ -73,29 +76,33 @@ initializePlugins :: HscEnv -> IO HscEnv initializePlugins hsc_env     -- plugins not changed-  | map lpModuleName (hsc_plugins hsc_env) == pluginModNames dflags+  | loaded_plugins <- loadedPlugins (hsc_plugins hsc_env)+  , map lpModuleName loaded_plugins == reverse (pluginModNames dflags)    -- arguments not changed-  , all same_args (hsc_plugins hsc_env)-  = return hsc_env -- no need to reload plugins+  , all same_args loaded_plugins+  = return hsc_env -- no need to reload plugins FIXME: doesn't take static plugins into account   | otherwise-  = do loaded_plugins <- loadPlugins hsc_env-       let hsc_env' = hsc_env { hsc_plugins = loaded_plugins }-       withPlugins hsc_env' driverPlugin hsc_env'+  = do (loaded_plugins, links, pkgs) <- loadPlugins hsc_env+       let plugins' = (hsc_plugins hsc_env) { loadedPlugins = loaded_plugins, loadedPluginDeps = (links, pkgs) }+       let hsc_env' = hsc_env { hsc_plugins = plugins' }+       withPlugins (hsc_plugins hsc_env') driverPlugin hsc_env'   where     plugin_args = pluginModNameOpts dflags     same_args p = paArguments (lpPlugin p) == argumentsForPlugin p plugin_args     argumentsForPlugin p = map snd . filter ((== lpModuleName p) . fst)     dflags = hsc_dflags hsc_env -loadPlugins :: HscEnv -> IO [LoadedPlugin]+loadPlugins :: HscEnv -> IO ([LoadedPlugin], [Linkable], PkgsLoaded) loadPlugins hsc_env   = do { unless (null to_load) $            checkExternalInterpreter hsc_env-       ; plugins <- mapM loadPlugin to_load-       ; return $ zipWith attachOptions to_load plugins }+       ; plugins_with_deps <- mapM loadPlugin to_load+       ; let (plugins, ifaces, links, pkgs) = unzip4 plugins_with_deps+       ; return (zipWith attachOptions to_load (zip plugins ifaces), concat links, foldl' plusUDFM emptyUDFM pkgs)+       }   where     dflags  = hsc_dflags hsc_env-    to_load = pluginModNames dflags+    to_load = reverse $ pluginModNames dflags      attachOptions mod_nm (plug, mod) =         LoadedPlugin (PluginWithArgs plug (reverse options)) mod@@ -105,11 +112,13 @@     loadPlugin = loadPlugin' (mkVarOcc "plugin") pluginTyConName hsc_env  -loadFrontendPlugin :: HscEnv -> ModuleName -> IO FrontendPlugin+loadFrontendPlugin :: HscEnv -> ModuleName -> IO (FrontendPlugin, [Linkable], PkgsLoaded) loadFrontendPlugin hsc_env mod_name = do     checkExternalInterpreter hsc_env-    fst <$> loadPlugin' (mkVarOcc "frontendPlugin") frontendPluginTyConName-                hsc_env mod_name+    (plugin, _iface, links, pkgs)+      <- loadPlugin' (mkVarOcc "frontendPlugin") frontendPluginTyConName+           hsc_env mod_name+    return (plugin, links, pkgs)  -- #14335 checkExternalInterpreter :: HscEnv -> IO ()@@ -118,7 +127,7 @@     -> throwIO (InstallationError "Plugins require -fno-external-interpreter")   _ -> pure () -loadPlugin' :: OccName -> Name -> HscEnv -> ModuleName -> IO (a, ModIface)+loadPlugin' :: OccName -> Name -> HscEnv -> ModuleName -> IO (a, ModIface, [Linkable], PkgsLoaded) loadPlugin' occ_name plugin_name hsc_env mod_name   = do { let plugin_rdr_name = mkRdrQual mod_name occ_name              dflags = hsc_dflags hsc_env@@ -133,14 +142,18 @@             Just (name, mod_iface) ->       do { plugin_tycon <- forceLoadTyCon hsc_env plugin_name-        ; mb_plugin <- getValueSafely hsc_env name (mkTyConTy plugin_tycon)-        ; case mb_plugin of-            Nothing ->-                throwGhcExceptionIO (CmdLineError $ showSDoc dflags $ hsep+        ; eith_plugin <- getValueSafely hsc_env name (mkTyConTy plugin_tycon)+        ; case eith_plugin of+            Left actual_type ->+                throwGhcExceptionIO (CmdLineError $+                    showSDocForUser dflags (ue_units (hsc_unit_env hsc_env))+                      alwaysQualify $ hsep                           [ text "The value", ppr name+                          , text "with type", ppr actual_type                           , text "did not have the type"-                          , ppr pluginTyConName, text "as required"])-            Just plugin -> return (plugin, mod_iface) } } }+                          , text "GHC.Plugins.Plugin"+                          , text "as required"])+            Right (plugin, links, pkgs) -> return (plugin, mod_iface, links, pkgs) } } }   -- | Force the interfaces for the given modules to be loaded. The 'SDoc' parameter is used@@ -178,30 +191,29 @@ -- | Loads the value corresponding to a 'Name' if that value has the given 'Type'. This only provides limited safety -- in that it is up to the user to ensure that that type corresponds to the type you try to use the return value at! ----- If the value found was not of the correct type, returns @Nothing@. Any other condition results in an exception:+-- If the value found was not of the correct type, returns @Left <actual_type>@. Any other condition results in an exception: -- -- * If we could not load the names module -- * If the thing being loaded is not a value -- * If the Name does not exist in the module -- * If the link failed -getValueSafely :: HscEnv -> Name -> Type -> IO (Maybe a)+getValueSafely :: HscEnv -> Name -> Type -> IO (Either Type (a, [Linkable], PkgsLoaded)) getValueSafely hsc_env val_name expected_type = do-  mb_hval <- case getValueSafelyHook hooks of+  eith_hval <- case getValueSafelyHook hooks of     Nothing -> getHValueSafely interp hsc_env val_name expected_type     Just h  -> h                      hsc_env val_name expected_type-  case mb_hval of-    Nothing   -> return Nothing-    Just hval -> do-      value <- lessUnsafeCoerce logger dflags "getValueSafely" hval-      return (Just value)+  case eith_hval of+    Left actual_type -> return (Left actual_type)+    Right (hval, links, pkgs) -> do+      value <- lessUnsafeCoerce logger "getValueSafely" hval+      return (Right (value, links, pkgs))   where     interp = hscInterp hsc_env-    dflags = hsc_dflags hsc_env     logger = hsc_logger hsc_env     hooks  = hsc_hooks hsc_env -getHValueSafely :: Interp -> HscEnv -> Name -> Type -> IO (Maybe HValue)+getHValueSafely :: Interp -> HscEnv -> Name -> Type -> IO (Either Type (HValue, [Linkable], PkgsLoaded)) getHValueSafely interp hsc_env val_name expected_type = do     forceLoadNameModuleInterface hsc_env (text "contains a name used in an invocation of getHValueSafely") val_name     -- Now look up the names for the value and type constructor in the type environment@@ -220,10 +232,11 @@                     Nothing ->  return ()                 -- Find the value that we just linked in and cast it given that we have proved it's type                 hval <- do-                  v <- loadName interp hsc_env val_name-                  wormhole interp v-                return (Just hval)-             else return Nothing+                  (v, links, pkgs) <- loadName interp hsc_env val_name+                  hv <- wormhole interp v+                  return (hv, links, pkgs)+                return (Right hval)+             else return (Left (idType id))         Just val_thing -> throwCmdLineErrorS dflags $ wrongTyThingError val_name val_thing    where dflags = hsc_dflags hsc_env @@ -233,12 +246,12 @@ -- -- 2) Wrap it in some debug messages at verbosity 3 or higher so we can see what happened --    if it /does/ segfault-lessUnsafeCoerce :: Logger -> DynFlags -> String -> a -> IO b-lessUnsafeCoerce logger dflags context what = do-    debugTraceMsg logger dflags 3 $+lessUnsafeCoerce :: Logger -> String -> a -> IO b+lessUnsafeCoerce logger context what = do+    debugTraceMsg logger 3 $         (text "Coercing a value in") <+> (text context) <> (text "...")     output <- evaluate (unsafeCoerce what)-    debugTraceMsg logger dflags 3 (text "Successfully evaluated coercion")+    debugTraceMsg logger 3 (text "Successfully evaluated coercion")     return output  @@ -259,8 +272,14 @@ lookupRdrNameInModuleForPlugins :: HscEnv -> ModuleName -> RdrName                                 -> IO (Maybe (Name, ModIface)) lookupRdrNameInModuleForPlugins hsc_env mod_name rdr_name = do+    let dflags     = hsc_dflags hsc_env+    let fopts      = initFinderOpts dflags+    let fc         = hsc_FC hsc_env+    let unit_env   = hsc_unit_env hsc_env+    let unit_state = ue_units unit_env+    let mhome_unit = hsc_home_unit_maybe hsc_env     -- First find the unit the module resides in by searching exposed units and home modules-    found_module <- findPluginModule hsc_env mod_name+    found_module <- findPluginModule fc fopts unit_state mhome_unit mod_name     case found_module of         Found _ mod -> do             -- Find the exports of the module@@ -282,14 +301,13 @@                 Nothing -> throwCmdLineErrorS dflags $ hsep [text "Could not determine the exports of the module", ppr mod_name]         err -> throwCmdLineErrorS dflags $ cannotFindModule hsc_env mod_name err   where-    dflags = hsc_dflags hsc_env     doc = text "contains a name used in an invocation of lookupRdrNameInModule"  wrongTyThingError :: Name -> TyThing -> SDoc-wrongTyThingError name got_thing = hsep [text "The name", ppr name, ptext (sLit "is not that of a value but rather a"), pprTyThingCategory got_thing]+wrongTyThingError name got_thing = hsep [text "The name", ppr name, text "is not that of a value but rather a", pprTyThingCategory got_thing]  missingTyThingError :: Name -> SDoc-missingTyThingError name = hsep [text "The name", ppr name, ptext (sLit "is not in the type environment: are you sure it exists?")]+missingTyThingError name = hsep [text "The name", ppr name, text "is not in the type environment: are you sure it exists?"]  throwCmdLineErrorS :: DynFlags -> SDoc -> IO a throwCmdLineErrorS dflags = throwCmdLineError . showSDoc dflags
GHC/Settings.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE CPP #-} + -- | Run-time settings module GHC.Settings   ( Settings (..)@@ -16,17 +16,19 @@   , sGhciUsagePath   , sToolDir   , sTopDir-  , sTmpDir   , sGlobalPackageDatabasePath   , sLdSupportsCompactUnwind   , sLdSupportsBuildId   , sLdSupportsFilelist   , sLdIsGnuLd   , sGccSupportsNoPie+  , sUseInplaceMinGW+  , sArSupportsDashL   , sPgm_L   , sPgm_P   , sPgm_F   , sPgm_c+  , sPgm_cxx   , sPgm_a   , sPgm_l   , sPgm_lm@@ -59,10 +61,7 @@   , sExtraGccViaCFlags   , sTargetPlatformString   , sGhcWithInterpreter-  , sGhcWithSMP-  , sGhcRTSWays   , sLibFFI-  , sGhcRtsWithLibdw   ) where  import GHC.Prelude@@ -93,15 +92,21 @@   , toolSettings_ldSupportsFilelist      :: Bool   , toolSettings_ldIsGnuLd               :: Bool   , toolSettings_ccSupportsNoPie         :: Bool+  , toolSettings_useInplaceMinGW         :: Bool+  , toolSettings_arSupportsDashL         :: Bool    -- commands for particular phases   , toolSettings_pgm_L       :: String   , toolSettings_pgm_P       :: (String, [Option])   , toolSettings_pgm_F       :: String   , toolSettings_pgm_c       :: String+  , toolSettings_pgm_cxx     :: String   , toolSettings_pgm_a       :: (String, [Option])   , toolSettings_pgm_l       :: (String, [Option])-  , toolSettings_pgm_lm      :: (String, [Option])+  , toolSettings_pgm_lm      :: Maybe (String, [Option])+    -- ^ N.B. On Windows we don't have a linker which supports object+    -- merging, hence the 'Maybe'. See Note [Object merging] in+    -- "GHC.Driver.Pipeline.Execute" for details.   , toolSettings_pgm_dll     :: (String, [Option])   , toolSettings_pgm_T       :: String   , toolSettings_pgm_windres :: String@@ -151,7 +156,6 @@   , fileSettings_ghciUsagePath         :: FilePath       -- ditto   , fileSettings_toolDir               :: Maybe FilePath -- ditto   , fileSettings_topDir                :: FilePath       -- ditto-  , fileSettings_tmpDir                :: String      -- no trailing '/'   , fileSettings_globalPackageDatabase :: FilePath   } @@ -182,8 +186,6 @@ sToolDir = fileSettings_toolDir . sFileSettings sTopDir              :: Settings -> FilePath sTopDir = fileSettings_topDir . sFileSettings-sTmpDir              :: Settings -> String-sTmpDir = fileSettings_tmpDir . sFileSettings sGlobalPackageDatabasePath :: Settings -> FilePath sGlobalPackageDatabasePath = fileSettings_globalPackageDatabase . sFileSettings @@ -197,6 +199,10 @@ sLdIsGnuLd = toolSettings_ldIsGnuLd . sToolSettings sGccSupportsNoPie :: Settings -> Bool sGccSupportsNoPie = toolSettings_ccSupportsNoPie . sToolSettings+sUseInplaceMinGW :: Settings -> Bool+sUseInplaceMinGW = toolSettings_useInplaceMinGW . sToolSettings+sArSupportsDashL :: Settings -> Bool+sArSupportsDashL = toolSettings_arSupportsDashL . sToolSettings  sPgm_L :: Settings -> String sPgm_L = toolSettings_pgm_L . sToolSettings@@ -206,11 +212,13 @@ sPgm_F = toolSettings_pgm_F . sToolSettings sPgm_c :: Settings -> String sPgm_c = toolSettings_pgm_c . sToolSettings+sPgm_cxx :: Settings -> String+sPgm_cxx = toolSettings_pgm_cxx . sToolSettings sPgm_a :: Settings -> (String, [Option]) sPgm_a = toolSettings_pgm_a . sToolSettings sPgm_l :: Settings -> (String, [Option]) sPgm_l = toolSettings_pgm_l . sToolSettings-sPgm_lm :: Settings -> (String, [Option])+sPgm_lm :: Settings -> Maybe (String, [Option]) sPgm_lm = toolSettings_pgm_lm . sToolSettings sPgm_dll :: Settings -> (String, [Option]) sPgm_dll = toolSettings_pgm_dll . sToolSettings@@ -272,11 +280,5 @@ sTargetPlatformString = platformMisc_targetPlatformString . sPlatformMisc sGhcWithInterpreter :: Settings -> Bool sGhcWithInterpreter = platformMisc_ghcWithInterpreter . sPlatformMisc-sGhcWithSMP :: Settings -> Bool-sGhcWithSMP = platformMisc_ghcWithSMP . sPlatformMisc-sGhcRTSWays :: Settings -> String-sGhcRTSWays = platformMisc_ghcRTSWays . sPlatformMisc sLibFFI :: Settings -> Bool sLibFFI = platformMisc_libFFI . sPlatformMisc-sGhcRtsWithLibdw :: Settings -> Bool-sGhcRtsWithLibdw = platformMisc_ghcRtsWithLibdw . sPlatformMisc
− GHC/Settings/Config.hs 
@@ -1,28 +0,0 @@-{-# LANGUAGE CPP #-}-module GHC.Settings.Config-  ( module GHC.Version-  , cBuildPlatformString-  , cHostPlatformString-  , cProjectName-  , cBooterVersion-  , cStage-  ) where--import GHC.Prelude--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        = "9.4.4"--cStage                :: String-cStage                = show (2 :: Int)
GHC/Settings/IO.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -7,8 +7,6 @@  , initSettings  ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Settings.Utils@@ -37,12 +35,6 @@   => String -- ^ TopDir path   -> ExceptT SettingsError m Settings initSettings top_dir = do-  -- see Note [topdir: How GHC finds its files]-  -- NB: top_dir is assumed to be in standard Unix-  -- format, '/' separated-  mtool_dir <- liftIO $ findToolDir top_dir-        -- see Note [tooldir: How GHC finds mingw on Windows]-   let installed :: FilePath -> FilePath       installed file = top_dir </> file       libexec :: FilePath -> FilePath@@ -60,25 +52,33 @@     Nothing -> throwE $ SettingsError_BadData $       "Can't parse " ++ show settingsFile   let mySettings = Map.fromList settingsList+      getBooleanSetting :: String -> ExceptT SettingsError m Bool+      getBooleanSetting key = either pgmError pure $+        getRawBooleanSetting settingsFile mySettings key++  -- On Windows, by mingw is often distributed with GHC,+  -- so we look in TopDir/../mingw/bin,+  -- as well as TopDir/../../mingw/bin for hadrian.+  -- But we might be disabled, in which we we don't do that.+  useInplaceMinGW <- getBooleanSetting "Use inplace MinGW toolchain"++  -- see Note [topdir: How GHC finds its files]+  -- NB: top_dir is assumed to be in standard Unix+  -- format, '/' separated+  mtool_dir <- liftIO $ findToolDir useInplaceMinGW top_dir+        -- see Note [tooldir: How GHC finds mingw on Windows]+   -- See Note [Settings file] for a little more about this file. We're   -- just partially applying those functions and throwing 'Left's; they're   -- written in a very portable style to keep ghc-boot light.   let getSetting key = either pgmError pure $         getRawFilePathSetting top_dir settingsFile mySettings key       getToolSetting :: String -> ExceptT SettingsError m String-      getToolSetting key = expandToolDir mtool_dir <$> getSetting key-      getBooleanSetting :: String -> ExceptT SettingsError m Bool-      getBooleanSetting key = either pgmError pure $-        getRawBooleanSetting settingsFile mySettings key+      getToolSetting key = expandToolDir useInplaceMinGW mtool_dir <$> getSetting key   targetPlatformString <- getSetting "target platform string"   myExtraGccViaCFlags <- getSetting "GCC extra via C opts"-  -- On Windows, mingw is distributed with GHC,-  -- so we look in TopDir/../mingw/bin,-  -- as well as TopDir/../../mingw/bin for hadrian.-  -- It would perhaps be nice to be able to override this-  -- with the settings file, but it would be a little fiddly-  -- to make that possible, so for now you can't.   cc_prog <- getToolSetting "C compiler command"+  cxx_prog <- getToolSetting "C++ compiler command"   cc_args_str <- getSetting "C compiler flags"   cxx_args_str <- getSetting "C++ compiler flags"   gccSupportsNoPie <- getBooleanSetting "C compiler supports -no-pie"@@ -97,6 +97,7 @@   ldSupportsBuildId       <- getBooleanSetting "ld supports build-id"   ldSupportsFilelist      <- getBooleanSetting "ld supports filelist"   ldIsGnuLd               <- getBooleanSetting "ld is GNU ld"+  arSupportsDashL         <- getBooleanSetting "ar supports -L"    let globalpkgdb_path = installed "package.conf.d"       ghc_usage_msg_path  = installed "ghc-usage.txt"@@ -113,10 +114,6 @@   install_name_tool_path <- getToolSetting "install_name_tool command"   ranlib_path <- getToolSetting "ranlib command" -  -- TODO this side-effect doesn't belong here. Reading and parsing the settings-  -- should be idempotent and accumulate no resources.-  tmpdir <- liftIO $ getTemporaryDirectory-   touch_path <- getToolSetting "touch command"    mkdll_prog <- getToolSetting "dllwrap command"@@ -135,6 +132,9 @@         ld_args  = map Option (cc_args ++ words cc_link_args_str)   ld_r_prog <- getToolSetting "Merge objects command"   ld_r_args <- getSetting "Merge objects flags"+  let ld_r+        | null ld_r_prog = Nothing+        | otherwise      = Just (ld_r_prog, map Option $ words ld_r_args)    llvmTarget <- getSetting "LLVM target" @@ -146,10 +146,7 @@   let iserv_prog = libexec "ghc-iserv"    ghcWithInterpreter <- getBooleanSetting "Use interpreter"-  ghcWithSMP <- getBooleanSetting "Support SMP"-  ghcRTSWays <- getSetting "RTS ways"   useLibFFI <- getBooleanSetting "Use LibFFI"-  ghcRtsWithLibdw <- getBooleanSetting "RTS expects libdw"    return $ Settings     { sGhcNameVersion = GhcNameVersion@@ -158,8 +155,7 @@       }      , sFileSettings = FileSettings-      { fileSettings_tmpDir         = normalise tmpdir-      , fileSettings_ghcUsagePath   = ghc_usage_msg_path+      { fileSettings_ghcUsagePath   = ghc_usage_msg_path       , fileSettings_ghciUsagePath  = ghci_usage_msg_path       , fileSettings_toolDir        = mtool_dir       , fileSettings_topDir         = top_dir@@ -172,14 +168,17 @@       , toolSettings_ldSupportsFilelist      = ldSupportsFilelist       , toolSettings_ldIsGnuLd               = ldIsGnuLd       , toolSettings_ccSupportsNoPie         = gccSupportsNoPie+      , toolSettings_useInplaceMinGW         = useInplaceMinGW+      , toolSettings_arSupportsDashL         = arSupportsDashL        , toolSettings_pgm_L   = unlit_path       , toolSettings_pgm_P   = (cpp_prog, cpp_args)       , toolSettings_pgm_F   = ""       , toolSettings_pgm_c   = cc_prog+      , toolSettings_pgm_cxx = cxx_prog       , toolSettings_pgm_a   = (as_prog, as_args)       , toolSettings_pgm_l   = (ld_prog, ld_args)-      , toolSettings_pgm_lm  = (ld_r_prog, map Option $ words ld_r_args)+      , toolSettings_pgm_lm  = ld_r       , toolSettings_pgm_dll = (mkdll_prog,mkdll_args)       , toolSettings_pgm_T   = touch_path       , toolSettings_pgm_windres = windres_path@@ -214,10 +213,7 @@     , sPlatformMisc = PlatformMisc       { platformMisc_targetPlatformString = targetPlatformString       , platformMisc_ghcWithInterpreter = ghcWithInterpreter-      , platformMisc_ghcWithSMP = ghcWithSMP-      , platformMisc_ghcRTSWays = ghcRTSWays       , platformMisc_libFFI = useLibFFI-      , platformMisc_ghcRtsWithLibdw = ghcRtsWithLibdw       , platformMisc_llvmTarget = llvmTarget       } @@ -242,6 +238,7 @@   targetHasGnuNonexecStack <- getBooleanSetting "target has GNU nonexec stack"   targetHasIdentDirective <- getBooleanSetting "target has .ident directive"   targetHasSubsectionsViaSymbols <- getBooleanSetting "target has subsections via symbols"+  targetHasLibm <- getBooleanSetting "target has libm"   crossCompiling <- getBooleanSetting "cross compiling"   tablesNextToCode <- getBooleanSetting "Tables next to code" @@ -256,5 +253,6 @@     , platformIsCrossCompiling = crossCompiling     , platformLeadingUnderscore = targetLeadingUnderscore     , platformTablesNextToCode  = tablesNextToCode+    , platformHasLibm = targetHasLibm     , platform_constants = Nothing -- will be filled later when loading (or building) the RTS unit     }
+ GHC/Stg/BcPrep.hs view
@@ -0,0 +1,214 @@+{-|+  Prepare the STG for bytecode generation:++   - Ensure that all breakpoints are directly under+        a let-binding, introducing a new binding for+        those that aren't already.++   - Protect Not-necessarily lifted join points, see+        Note [Not-necessarily-lifted join points]++ -}++module GHC.Stg.BcPrep ( bcPrep ) where++import GHC.Prelude++import GHC.Types.Id.Make+import GHC.Types.Id+import GHC.Core.Type+import GHC.Builtin.Types ( unboxedUnitTy )+import GHC.Builtin.Types.Prim+import GHC.Types.Unique+import GHC.Data.FastString+import GHC.Utils.Panic.Plain+import GHC.Types.Tickish+import GHC.Types.Unique.Supply+import qualified GHC.Types.CostCentre as CC+import GHC.Stg.Syntax+import GHC.Utils.Monad.State.Strict++data BcPrepM_State+   = BcPrepM_State+        { prepUniqSupply :: !UniqSupply      -- for generating fresh variable names+        }++type BcPrepM a = State BcPrepM_State a++bcPrepRHS :: StgRhs -> BcPrepM StgRhs+-- explicitly match all constructors so we get a warning if we miss any+bcPrepRHS (StgRhsClosure fvs cc upd args (StgTick bp@Breakpoint{} expr)) = do+  {- If we have a breakpoint directly under an StgRhsClosure we don't+     need to introduce a new binding for it.+   -}+  expr' <- bcPrepExpr expr+  pure (StgRhsClosure fvs cc upd args (StgTick bp expr'))+bcPrepRHS (StgRhsClosure fvs cc upd args expr) =+  StgRhsClosure fvs cc upd args <$> bcPrepExpr expr+bcPrepRHS con@StgRhsCon{} = pure con++bcPrepExpr :: StgExpr -> BcPrepM StgExpr+-- explicitly match all constructors so we get a warning if we miss any+bcPrepExpr (StgTick bp@(Breakpoint tick_ty _ _) rhs)+  | isLiftedTypeKind (typeKind tick_ty) = do+      id <- newId tick_ty+      rhs' <- bcPrepExpr rhs+      let expr' = StgTick bp rhs'+          bnd = StgNonRec id (StgRhsClosure noExtFieldSilent+                                            CC.dontCareCCS+                                            ReEntrant+                                            []+                                            expr'+                             )+          letExp = StgLet noExtFieldSilent bnd (StgApp id [])+      pure letExp+  | otherwise = do+      id <- newId (mkVisFunTyMany realWorldStatePrimTy tick_ty)+      rhs' <- bcPrepExpr rhs+      let expr' = StgTick bp rhs'+          bnd = StgNonRec id (StgRhsClosure noExtFieldSilent+                                            CC.dontCareCCS+                                            ReEntrant+                                            [voidArgId]+                                            expr'+                             )+      pure $ StgLet noExtFieldSilent bnd (StgApp id [StgVarArg realWorldPrimId])+bcPrepExpr (StgTick tick rhs) =+  StgTick tick <$> bcPrepExpr rhs+bcPrepExpr (StgLet xlet bnds expr) =+  StgLet xlet <$> bcPrepBind bnds+              <*> bcPrepExpr expr+bcPrepExpr (StgLetNoEscape xlne bnds expr) =+  StgLet xlne <$> bcPrepBind bnds+              <*> bcPrepExpr expr+bcPrepExpr (StgCase expr bndr alt_type alts) =+  StgCase <$> bcPrepExpr expr+          <*> pure bndr+          <*> pure alt_type+          <*> mapM bcPrepAlt alts+bcPrepExpr lit@StgLit{} = pure lit+-- See Note [Not-necessarily-lifted join points], step 3.+bcPrepExpr (StgApp x [])+  | isNNLJoinPoint x = pure $+      StgApp (protectNNLJoinPointId x) [StgVarArg voidPrimId]+bcPrepExpr app@StgApp{} = pure app+bcPrepExpr app@StgConApp{} = pure app+bcPrepExpr app@StgOpApp{} = pure app++bcPrepAlt :: StgAlt -> BcPrepM StgAlt+bcPrepAlt (GenStgAlt con bndrs rhs) = GenStgAlt con bndrs <$> bcPrepExpr rhs++bcPrepBind :: StgBinding -> BcPrepM StgBinding+-- explicitly match all constructors so we get a warning if we miss any+bcPrepBind (StgNonRec bndr rhs) =+  let (bndr', rhs') = bcPrepSingleBind (bndr, rhs)+  in  StgNonRec bndr' <$> bcPrepRHS rhs'+bcPrepBind (StgRec bnds) =+  StgRec <$> mapM ((\(b,r) -> (,) b <$> bcPrepRHS r) . bcPrepSingleBind)+                  bnds++bcPrepSingleBind :: (Id, StgRhs) -> (Id, StgRhs)+-- If necessary, modify this Id and body to protect not-necessarily-lifted join points.+-- See Note [Not-necessarily-lifted join points], step 2.+bcPrepSingleBind (x, StgRhsClosure ext cc upd_flag args body)+  | isNNLJoinPoint x+  = ( protectNNLJoinPointId x+    , StgRhsClosure ext cc upd_flag (args ++ [voidArgId]) body)+bcPrepSingleBind bnd = bnd++bcPrepTopLvl :: StgTopBinding -> BcPrepM StgTopBinding+bcPrepTopLvl lit@StgTopStringLit{} = pure lit+bcPrepTopLvl (StgTopLifted bnd) = StgTopLifted <$> bcPrepBind bnd++bcPrep :: UniqSupply -> [InStgTopBinding] -> [OutStgTopBinding]+bcPrep us bnds = evalState (mapM bcPrepTopLvl bnds) (BcPrepM_State us)++-- Is this Id a not-necessarily-lifted join point?+-- See Note [Not-necessarily-lifted join points], step 1+isNNLJoinPoint :: Id -> Bool+isNNLJoinPoint x = isJoinId x && mightBeUnliftedType (idType x)++-- Update an Id's type to take a Void# argument.+-- Precondition: the Id is a not-necessarily-lifted join point.+-- See Note [Not-necessarily-lifted join points]+protectNNLJoinPointId :: Id -> Id+protectNNLJoinPointId x+  = assert (isNNLJoinPoint x )+    updateIdTypeButNotMult (unboxedUnitTy `mkVisFunTyMany`) x++newUnique :: BcPrepM Unique+newUnique = state $+  \st -> case takeUniqFromSupply (prepUniqSupply st) of+            (uniq, us) -> (uniq, st { prepUniqSupply = us })++newId :: Type -> BcPrepM Id+newId ty = do+    uniq <- newUnique+    return $ mkSysLocal prepFS uniq Many ty++prepFS :: FastString+prepFS = fsLit "bcprep"++{-++Note [Not-necessarily-lifted join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A join point variable is essentially a goto-label: it is, for example,+never used as an argument to another function, and it is called only+in tail position. See Note [Join points] and Note [Invariants on join points],+both in GHC.Core. Because join points do not compile to true, red-blooded+variables (with, e.g., registers allocated to them), they are allowed+to be representation-polymorphic.+(See invariant #6 in Note [Invariants on join points] in GHC.Core.)++However, in this byte-code generator, join points *are* treated just as+ordinary variables. There is no check whether a binding is for a join point+or not; they are all treated uniformly. (Perhaps there is a missed optimization+opportunity here, but that is beyond the scope of my (Richard E's) Thursday.)++We thus must have *some* strategy for dealing with representation-polymorphic+and unlifted join points. Representation-polymorphic variables are generally+not allowed (though representation -polymorphic join points *are*; see+Note [Invariants on join points] in GHC.Core, point 6), and we don't wish to+evaluate unlifted join points eagerly.+The questionable join points are *not-necessarily-lifted join points*+(NNLJPs). (Not having such a strategy led to #16509, which panicked in the+isUnliftedType check in the AnnVar case of schemeE.) Here is the strategy:++1. Detect NNLJPs. This is done in isNNLJoinPoint.++2. When binding an NNLJP, add a `\ (_ :: (# #)) ->` to its RHS, and modify the+   type to tack on a `(# #) ->`.+   Note that functions are never representation-polymorphic, so this+   transformation changes an NNLJP to a non-representation-polymorphic+   join point. This is done in bcPrepSingleBind.++3. At an occurrence of an NNLJP, add an application to void# (called voidPrimId),+   being careful to note the new type of the NNLJP. This is done in the AnnVar+   case of schemeE, with help from protectNNLJoinPointId.++Here is an example. Suppose we have++  f = \(r :: RuntimeRep) (a :: TYPE r) (x :: T).+      join j :: a+           j = error @r @a "bloop"+      in case x of+           A -> j+           B -> j+           C -> error @r @a "blurp"++Our plan is to behave is if the code was++  f = \(r :: RuntimeRep) (a :: TYPE r) (x :: T).+      let j :: (Void# -> a)+          j = \ _ -> error @r @a "bloop"+      in case x of+           A -> j void#+           B -> j void#+           C -> error @r @a "blurp"++It's a bit hacky, but it works well in practice and is local. I suspect the+Right Fix is to take advantage of join points as goto-labels.++-}+
GHC/Stg/CSE.hs view
@@ -11,8 +11,8 @@ This was originally reported as #9291.  There are two types of common code occurrences that we aim for, see-note [Case 1: CSEing allocated closures] and-note [Case 2: CSEing case binders] below.+Note [Case 1: CSEing allocated closures] and+Note [Case 2: CSEing case binders] below.   Note [Case 1: CSEing allocated closures]@@ -147,7 +147,7 @@ -- The CSE Env -- ----------------- --- | The CSE environment. See note [CseEnv Example]+-- | The CSE environment. See Note [CseEnv Example] data CseEnv = CseEnv     { ce_conAppMap :: ConAppMap OutId         -- ^ The main component of the environment is the trie that maps@@ -203,31 +203,54 @@     , ce_in_scope  = in_scope     } +-------------------+normaliseConArgs :: CseEnv -> [OutStgArg] -> [OutStgArg]+-- See Note [Trivial case scrutinee]+normaliseConArgs env args+  = map go args+  where+    bndr_map = ce_bndrMap env+    go (StgVarArg v  ) = StgVarArg (normaliseId bndr_map v)+    go (StgLitArg lit) = StgLitArg lit++normaliseId :: IdEnv OutId -> OutId -> OutId+normaliseId bndr_map v = case lookupVarEnv bndr_map v of+                           Just v' -> v'+                           Nothing -> v++addTrivCaseBndr :: OutId -> OutId -> CseEnv -> CseEnv+-- See Note [Trivial case scrutinee]+addTrivCaseBndr from to env+    = env { ce_bndrMap = extendVarEnv bndr_map from norm_to }+    where+      bndr_map = ce_bndrMap env+      norm_to = normaliseId bndr_map to+ envLookup :: DataCon -> [OutStgArg] -> CseEnv -> Maybe OutId-envLookup dataCon args env = lookupTM (dataCon, args') (ce_conAppMap env)-  where args' = map go args -- See Note [Trivial case scrutinee]-        go (StgVarArg v  ) = StgVarArg (fromMaybe v $ lookupVarEnv (ce_bndrMap env) v)-        go (StgLitArg lit) = StgLitArg lit+envLookup dataCon args env+  = lookupTM (dataCon, normaliseConArgs env args)+             (ce_conAppMap env)+    -- normaliseConArgs: See Note [Trivial case scrutinee]  addDataCon :: OutId -> DataCon -> [OutStgArg] -> CseEnv -> CseEnv--- do not bother with nullary data constructors, they are static anyways+-- Do not bother with nullary data constructors; they are static anyway addDataCon _ _ [] env = env-addDataCon bndr dataCon args env = env { ce_conAppMap = new_env }+addDataCon bndr dataCon args env+  = env { ce_conAppMap = new_env }   where-    new_env = insertTM (dataCon, args) bndr (ce_conAppMap env)+    new_env = insertTM (dataCon, normaliseConArgs env args)+                       bndr (ce_conAppMap env)+    -- normaliseConArgs: See Note [Trivial case scrutinee] +------------------- forgetCse :: CseEnv -> CseEnv forgetCse env = env { ce_conAppMap = emptyTM }-    -- See note [Free variables of an StgClosure]+    -- See Note [Free variables of an StgClosure]  addSubst :: OutId -> OutId -> CseEnv -> CseEnv addSubst from to env     = env { ce_subst = extendVarEnv (ce_subst env) from to } -addTrivCaseBndr :: OutId -> OutId -> CseEnv -> CseEnv-addTrivCaseBndr from to env-    = env { ce_bndrMap = extendVarEnv (ce_bndrMap env) from to }- substArgs :: CseEnv -> [InStgArg] -> [OutStgArg] substArgs env = map (substArg env) @@ -318,9 +341,11 @@   where     scrut' = stgCseExpr env scrut     (env1, bndr') = substBndr env bndr-    env2 | StgApp trivial_scrut [] <- scrut' = addTrivCaseBndr bndr trivial_scrut env1+    env2 | StgApp trivial_scrut [] <- scrut'+         = addTrivCaseBndr bndr trivial_scrut env1                  -- See Note [Trivial case scrutinee]-         | otherwise                         = env1+         | otherwise+         = env1     alts' = map (stgCseAlt env2 ty bndr') alts  @@ -349,7 +374,7 @@ -- Case alternatives -- Extend the CSE environment stgCseAlt :: CseEnv -> AltType -> OutId -> InStgAlt -> OutStgAlt-stgCseAlt env ty case_bndr (DataAlt dataCon, args, rhs)+stgCseAlt env ty case_bndr GenStgAlt{alt_con=DataAlt dataCon, alt_bndrs=args, alt_rhs=rhs}     = let (env1, args') = substBndrs env args           env2             -- To avoid dealing with unboxed sums StgCse runs after unarise and@@ -362,13 +387,13 @@             = addDataCon case_bndr dataCon (map StgVarArg args') env1             | otherwise             = env1-            -- see note [Case 2: CSEing case binders]+            -- see Note [Case 2: CSEing case binders]           rhs' = stgCseExpr env2 rhs-      in (DataAlt dataCon, args', rhs')-stgCseAlt env _ _ (altCon, args, rhs)+      in GenStgAlt (DataAlt dataCon) args' rhs'+stgCseAlt env _ _ g@GenStgAlt{alt_con=_, alt_bndrs=args, alt_rhs=rhs}     = let (env1, args') = substBndrs env args           rhs' = stgCseExpr env1 rhs-      in (altCon, args', rhs')+      in g {alt_bndrs=args', alt_rhs=rhs'}  -- Bindings stgCseBind :: CseEnv -> InStgBinding -> (Maybe OutStgBinding, CseEnv)@@ -402,14 +427,14 @@       in (Nothing, env')     | otherwise     = let env' = addDataCon bndr dataCon args' env-            -- see note [Case 1: CSEing allocated closures]+            -- see Note [Case 1: CSEing allocated closures]           pair = (bndr, StgRhsCon ccs dataCon mu ticks args')       in (Just pair, env')   where args' = substArgs env args  stgCseRhs env bndr (StgRhsClosure ext ccs upd args body)     = let (env1, args') = substBndrs env args-          env2 = forgetCse env1 -- See note [Free variables of an StgClosure]+          env2 = forgetCse env1 -- See Note [Free variables of an StgClosure]           body' = stgCseExpr env2 body       in (Just (substVar env bndr, StgRhsClosure ext ccs upd args' body'), env) @@ -420,8 +445,8 @@    where     -- see Note [All alternatives are the binder]-    isBndr (_, _, StgApp f []) = f == bndr-    isBndr _                   = False+    isBndr GenStgAlt{alt_con=_,alt_bndrs=_,alt_rhs=StgApp f []} = f == bndr+    isBndr _                                                    = False   {- Note [Care with loop breakers]@@ -468,25 +493,70 @@  Note [Trivial case scrutinee] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We want to be able to handle nested reconstruction of constructors as in+We want to be able to CSE nested reconstruction of constructors as in      nested :: Either Int (Either Int a) -> Either Bool (Either Bool a)     nested (Right (Right v)) = Right (Right v)-    nested _ = Left True--So if we come across+    nested _                 = Left True +We want the RHS of the first branch to be just the original argument.+The RHS of 'nested' will look like     case x of r1       Right a -> case a of r2               Right b -> let v = Right b                          in Right v+Then:+* We create the ce_conAppMap [Right a :-> r1, Right b :-> r2].+* When we encounter v = Right b, we'll drop the binding and extend+  the substitution with [v :-> r2]+* But now when we see (Right v), we'll substitute to get (Right r2)...and+  fail to find that in the ce_conAppMap! -we first replace v with r2. Next we want to replace Right r2 with r1. But the-ce_conAppMap contains Right a!+Solution: -Therefore, we add r1 ↦ x to ce_bndrMap when analysing the outer case, and use-this substitution before looking Right r2 up in ce_conAppMap, and everything-works out.+* When passing (case x of bndr { alts }), where 'x' is a variable, we+  add [bndr :-> x] to the ce_bndrMap.  In our example the ce_bndrMap will+  be [r1 :-> x, r2 :-> a]. This is done in addTrivCaseBndr.++* Before doing the /lookup/ in ce_conAppMap, we "normalise" the+  arguments with the ce_bndrMap.  In our example, we normalise+  (Right r2) to (Right a), and then find it in the map.  Normalisation+  is done by normaliseConArgs.++* Similarly before /inserting/ in ce_conAppMap, we normalise the arguments.+  This is a bit more subtle. Suppose we have+       case x of y+         DEFAULT -> let a = Just y+                    let b = Just y+                    in ...+  We'll have [y :-> x] in the ce_bndrMap.  When looking up (Just y) in+  the map, we'll normalise it to (Just x).  So we'd better normalise+  the (Just y) in the defn of 'a', before inserting it!++* When inserting into cs_bndrMap, we must normalise that too!+      case x of y+        DEFAULT -> case y of z+                      DEFAULT -> ...+  We want the cs_bndrMap to be [y :-> x, z :-> x]!+  Hence the call to normaliseId in addTrivCaseBinder.++All this is a bit tricky.  Why does it not occur for the Core version+of CSE?  See Note [CSE for bindings] in GHC.Core.Opt.CSE.  The reason+is this: in Core CSE we augment the /main substitution/ with [y :-> x]+etc, so as a side consequence we transform+    case x of y       ===>    case x of y+      pat -> ...y...             pat -> ...x...+That is, the /exact reverse/ of the binder-swap transformation done by+the occurrence analyser.  However, it's easy for CSE to do on-the-fly,+and it completely solves the above tricky problem, using only two maps:+the main reverse-map, and the substitution.  The occurrence analyser+puts it back the way it should be, the next time it runs.++However in STG there is no occurrence analyser, and we don't want to+require another pass.  So the ce_bndrMap is a little swizzle that we+apply just when manipulating the ce_conAppMap, but that does not+affect the output program.+  Note [Free variables of an StgClosure] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
GHC/Stg/Debug.hs view
@@ -1,8 +1,11 @@ {-# LANGUAGE TupleSections #-}+ -- This module contains functions which implement -- the -finfo-table-map and -fdistinct-constructor-tables flags-module GHC.Stg.Debug(collectDebugInformation) where-+module GHC.Stg.Debug+  ( StgDebugOpts(..)+  , collectDebugInformation+  ) where  import GHC.Prelude @@ -15,11 +18,10 @@ import GHC.Unit.Module import GHC.Types.Name   ( getName, getOccName, occNameString, nameSrcSpan) import GHC.Data.FastString-import GHC.Driver.Session  import Control.Monad (when) import Control.Monad.Trans.Reader-import Control.Monad.Trans.State+import GHC.Utils.Monad.State.Strict import Control.Monad.Trans.Class import GHC.Types.Unique.Map import GHC.Types.SrcLoc@@ -29,11 +31,16 @@  data SpanWithLabel = SpanWithLabel RealSrcSpan String -data R = R { rDynFlags :: DynFlags, rModLocation :: ModLocation, rSpan :: Maybe SpanWithLabel }+data StgDebugOpts = StgDebugOpts+  { stgDebug_infoTableMap              :: !Bool+  , stgDebug_distinctConstructorTables :: !Bool+  } +data R = R { rOpts :: StgDebugOpts, rModLocation :: ModLocation, rSpan :: Maybe SpanWithLabel }+ type M a = ReaderT R (State InfoTableProvMap) a -withSpan :: (RealSrcSpan, String) -> M a -> M a+withSpan :: IpeSourceLocation -> M a -> M a withSpan (new_s, new_l) act = local maybe_replace act   where     maybe_replace r@R{ rModLocation = cur_mod, rSpan = Just (SpanWithLabel old_s _old_l) }@@ -44,9 +51,9 @@     maybe_replace r       = r { rSpan = Just (SpanWithLabel new_s new_l) } -collectDebugInformation :: DynFlags -> ModLocation -> [StgTopBinding] -> ([StgTopBinding], InfoTableProvMap)-collectDebugInformation dflags ml bs =-    runState (runReaderT (mapM collectTop bs) (R dflags ml Nothing)) emptyInfoTableProvMap+collectDebugInformation :: StgDebugOpts -> ModLocation -> [StgTopBinding] -> ([StgTopBinding], InfoTableProvMap)+collectDebugInformation opts ml bs =+    runState (runReaderT (mapM collectTop bs) (R opts ml Nothing)) emptyInfoTableProvMap  collectTop :: StgTopBinding -> M StgTopBinding collectTop (StgTopLifted t) = StgTopLifted <$> collectStgBind t@@ -117,7 +124,8 @@        return (StgTick tick e')  collectAlt :: StgAlt -> M StgAlt-collectAlt (ac, bs, e) = (ac, bs, ) <$> collectExpr e+collectAlt alt = do e' <- collectExpr $ alt_rhs alt+                    return $! alt { alt_rhs = e' }  -- | Try to find the best source position surrounding a 'StgExpr'. The -- heuristic strips ticks from the current expression until it finds one which@@ -135,8 +143,8 @@  recordStgIdPosition :: Id -> Maybe SpanWithLabel -> Maybe SpanWithLabel -> M () recordStgIdPosition id best_span ss = do-  dflags <- asks rDynFlags-  when (gopt Opt_InfoTableMap dflags) $ do+  opts <- asks rOpts+  when (stgDebug_infoTableMap opts) $ do     cc <- asks rSpan     --Useful for debugging why a certain Id gets given a certain span     --pprTraceM "recordStgIdPosition" (ppr id $$ ppr cc $$ ppr best_span $$ ppr ss)@@ -149,13 +157,13 @@ numberDataCon dc _ | isUnboxedTupleDataCon dc = return NoNumber numberDataCon dc _ | isUnboxedSumDataCon dc = return NoNumber numberDataCon dc ts = do-  dflags <- asks rDynFlags-  if not (gopt Opt_DistinctConstructorTables dflags) then return NoNumber else do+  opts <- asks rOpts+  if not (stgDebug_distinctConstructorTables opts) then return NoNumber else do     env <- lift get     mcc <- asks rSpan-    let mbest_span = (\(SpanWithLabel rss l) -> (rss, l)) <$> (selectTick ts <|> mcc)-    let dcMap' = alterUniqMap (maybe (Just ((0, mbest_span) :| [] ))-                        (\xs@((k, _):|_) -> Just ((k + 1, mbest_span) `NE.cons` xs))) (provDC env) dc+    let !mbest_span = (\(SpanWithLabel rss l) -> (rss, l)) <$> (selectTick ts <|> mcc)+    let !dcMap' = alterUniqMap (maybe (Just ((0, mbest_span) :| [] ))+                        (\xs@((k, _):|_) -> Just $! ((k + 1, mbest_span) `NE.cons` xs))) (provDC env) dc     lift $ put (env { provDC = dcMap' })     let r = lookupUniqMap dcMap' dc     return $ case r of@@ -178,16 +186,21 @@ a specific place in the source program, the mapping is usually quite precise because a fresh info table is created for each distinct THUNK. +The info table map is also used to generate stacktraces.+See Note [Stacktraces from Info Table Provenance Entries (IPE based stack unwinding)]+for details.+ There are three parts to the implementation -1. In GHC.Stg.Debug, the SourceNote information is used in order to give a source location to-some specific closures.-2. In StgToCmm, the actually used info tables are recorded in an IORef, this-is important as it's hard to predict beforehand what code generation will do-and which ids will end up in the generated program.-3. During code generation, a mapping from the info table to the statically-determined location is emitted which can then be queried at runtime by-various tools.+1. In GHC.Stg.Debug, the SourceNote information is used in order to give a source location+   to some specific closures.+2. In GHC.Driver.GenerateCgIPEStub, the actually used info tables are collected after the+   Cmm pipeline. This is important as it's hard to predict beforehand what code generation+   will do and which ids will end up in the generated program. Additionally, info tables of+   return frames (used to create stacktraces) are generated in the Cmm pipeline and aren't+   available before.+3. During code generation, a mapping from the info table to the statically determined location+   is emitted which can then be queried at runtime by various tools.  -- Giving Source Locations to Closures @@ -196,6 +209,8 @@  1. Data constructors to a list of where they are used. 2. `Name`s and where they originate from.+3. Stack represented info tables (return frames) to an approximated source location+   of the call that pushed a contiunation on the stacks.  During the CoreToStg phase, this map is populated whenever something is turned into a StgRhsClosure or an StgConApp. The current source position is recorded@@ -204,28 +219,27 @@ The functions which add information to the map are `recordStgIdPosition` and `numberDataCon`. -When the -fdistinct-constructor-tables` flag is turned on then every+When the `-fdistinct-constructor-tables` flag is turned on then every usage of a data constructor gets its own distinct info table. This is orchestrated in `collectExpr` where an incrementing number is used to distinguish each occurrence of a data constructor. --- StgToCmm+-- GenerateCgIPEStub -The info tables which are actually used in the generated program are recorded during the-conversion from STG to Cmm. The used info tables are recorded in the `emitProc` function.-All the used info tables are recorded in the `cgs_used_info` field. This step-is necessary because when the information about names is collected in the previous-phase it's unpredictable about which names will end up needing info tables. If-you don't record which ones are actually used then you end up generating code-which references info tables which don't exist.+The info tables which are actually used in the generated program are collected after+the Cmm pipeline. `initInfoTableProv` is used to create a CStub, that initializes the+map in C code. +This step has to be done after the Cmm pipeline to make sure that all info tables are+really used and, even more importantly, return frame info tables are generated by the+pipeline.+ -- Code Generation  The output of these two phases is combined together during code generation.-A C stub is generated which-creates the static map from info table pointer to the information about where that-info table was created from. This is created by `ipInitCode` in the same manner as a-C stub is generated for cost centres.+A C stub is generated which creates the static map from info table pointer to the+information about where that info table was created from. This is created by+`ipInitCode` in the same manner as a C stub is generated for cost centres.  This information can be consumed in two ways.
− GHC/Stg/DepAnal.hs 
@@ -1,146 +0,0 @@-{-# LANGUAGE CPP #-}--module GHC.Stg.DepAnal (depSortStgPgm) where--import GHC.Prelude--import GHC.Stg.Syntax-import GHC.Types.Id-import GHC.Types.Name (Name, nameIsLocalOrFrom)-import GHC.Types.Name.Env-import GHC.Utils.Outputable-import GHC.Utils.Panic-import GHC.Types.Unique.Set (nonDetEltsUniqSet)-import GHC.Types.Var.Set-import GHC.Unit.Module (Module)--import Data.Graph (SCC (..))-import Data.Bifunctor (first)------------------------------------------------------------------------------------- * Dependency analysis---- | Set of bound variables-type BVs = VarSet---- | Set of free variables-type FVs = VarSet---- | Dependency analysis on STG terms.------ Dependencies of a binding are just free variables in the binding. This--- includes imported ids and ids in the current module. For recursive groups we--- just return one set of free variables which is just the union of dependencies--- of all bindings in the group.------ Implementation: pass bound variables (BVs) to recursive calls, get free--- variables (FVs) back. We ignore imported FVs as they do not change the--- ordering but it improves performance.----annTopBindingsDeps :: Module -> [StgTopBinding] -> [(StgTopBinding, FVs)]-annTopBindingsDeps this_mod bs = zip bs (map top_bind bs)-  where-    top_bind :: StgTopBinding -> FVs-    top_bind StgTopStringLit{} =-      emptyVarSet--    top_bind (StgTopLifted bs) =-      binding emptyVarSet bs--    binding :: BVs -> StgBinding -> FVs-    binding bounds (StgNonRec _ r) =-      rhs bounds r-    binding bounds (StgRec bndrs) =-      unionVarSets $-        map (bind_non_rec (extendVarSetList bounds (map fst bndrs))) bndrs--    bind_non_rec :: BVs -> (Id, StgRhs) -> FVs-    bind_non_rec bounds (_, r) =-        rhs bounds r--    rhs :: BVs -> StgRhs -> FVs-    rhs bounds (StgRhsClosure _ _ _ as e) =-      expr (extendVarSetList bounds as) e--    rhs bounds (StgRhsCon _ _ _ _ as) =-      args bounds as--    var :: BVs -> Var -> FVs-    var bounds v-      | not (elemVarSet v bounds)-      , nameIsLocalOrFrom this_mod (idName v)-      = unitVarSet v-      | otherwise-      = emptyVarSet--    arg :: BVs -> StgArg -> FVs-    arg bounds (StgVarArg v) = var bounds v-    arg _ StgLitArg{} = emptyVarSet--    args :: BVs -> [StgArg] -> FVs-    args bounds as = unionVarSets (map (arg bounds) as)--    expr :: BVs -> StgExpr -> FVs-    expr bounds (StgApp f as) =-      var bounds f `unionVarSet` args bounds as--    expr _ StgLit{} =-      emptyVarSet--    expr bounds (StgConApp _ _ as _) =-      args bounds as-    expr bounds (StgOpApp _ as _) =-      args bounds as-    expr bounds (StgCase scrut scrut_bndr _ as) =-      expr bounds scrut `unionVarSet`-        alts (extendVarSet bounds scrut_bndr) as-    expr bounds (StgLet _ bs e) =-      binding bounds bs `unionVarSet`-        expr (extendVarSetList bounds (bindersOf bs)) e-    expr bounds (StgLetNoEscape _ bs e) =-      binding bounds bs `unionVarSet`-        expr (extendVarSetList bounds (bindersOf bs)) e--    expr bounds (StgTick _ e) =-      expr bounds e--    alts :: BVs -> [StgAlt] -> FVs-    alts bounds = unionVarSets . map (alt bounds)--    alt :: BVs -> StgAlt -> FVs-    alt bounds (_, bndrs, e) =-      expr (extendVarSetList bounds bndrs) e------------------------------------------------------------------------------------- * Dependency sorting---- | Dependency sort a STG program so that dependencies come before uses.-depSortStgPgm :: Module -> [StgTopBinding] -> [StgTopBinding]-depSortStgPgm this_mod =-    {-# SCC "STG.depSort" #-}-    map fst . depSort . annTopBindingsDeps this_mod---- | Sort free-variable-annotated STG bindings so that dependencies come before--- uses.-depSort :: [(StgTopBinding, FVs)] -> [(StgTopBinding, FVs)]-depSort = concatMap get_binds . depAnal defs uses-  where-    uses, defs :: (StgTopBinding, FVs) -> [Name]--    -- TODO (osa): I'm unhappy about two things in this code:-    ---    --     * Why do we need Name instead of Id for uses and dependencies?-    --     * Why do we need a [Name] instead of `Set Name`? Surely depAnal-    --       doesn't need any ordering.--    uses (StgTopStringLit{}, _) = []-    uses (StgTopLifted{}, fvs)  = map idName (nonDetEltsUniqSet fvs)--    defs (bind, _) = map idName (bindersOfTop bind)--    get_binds (AcyclicSCC bind) =-      [bind]-    get_binds (CyclicSCC binds) =-      pprPanic "depSortStgBinds"-               (text "Found cyclic SCC:"-               $$ ppr (map (first (pprStgTopBinding panicStgPprOpts)) binds))
GHC/Stg/FVs.hs view
@@ -40,129 +40,238 @@ variables are global. -} module GHC.Stg.FVs (-    annTopBindingsFreeVars,+    depSortWithAnnotStgPgm,     annBindingFreeVars   ) where -import GHC.Prelude+import GHC.Prelude hiding (mod)  import GHC.Stg.Syntax+import GHC.Stg.Utils (bindersOf) import GHC.Types.Id-import GHC.Types.Var.Set+import GHC.Types.Name (Name, nameIsLocalOrFrom) import GHC.Types.Tickish ( GenTickish(Breakpoint) )+import GHC.Types.Unique.Set (nonDetEltsUniqSet)+import GHC.Types.Var.Set+import GHC.Unit.Module (Module) import GHC.Utils.Misc -import Data.Maybe ( mapMaybe )+import Data.Graph (SCC (..))+import GHC.Data.Graph.Directed( Node(..), stronglyConnCompFromEdgedVerticesUniq ) -newtype Env+{- Note [Why do we need dependency analysis?]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The program needs to be in dependency order for the SRT algorithm to+work (see CmmBuildInfoTables, which also includes a detailed+description of the algorithm).++But isn't it in correct dependency order already?  No:++* The simplifier does not guarantee to produce programs in dependency+  order (see #16192 and Note [Glomming] in GHC.Core.Opt.OccurAnal).+  This could be solved by a final run of the occurrence analyser, but+  that's more work++* We also don't guarantee that StgLiftLams will preserve the order or+  only create minimal recursive groups.+-}++--------------------------------------------------------------------------------+-- | Dependency sort a STG program, and annotate it with free variables+-- The returned bindings:+--   * Are in dependency order+--   * Each StgRhsClosure is correctly annotated (in its extension field)+--     with the free variables needed in the closure+--   * Each StgCase is correctly annotated (in its extension field) with+--     the variables that must be saved across the case+depSortWithAnnotStgPgm :: Module -> [StgTopBinding] -> [CgStgTopBinding]+depSortWithAnnotStgPgm this_mod binds+  = {-# SCC "STG.depSortWithAnnotStgPgm" #-}+    lit_binds ++ map from_scc sccs+  where+    lit_binds :: [CgStgTopBinding]+    pairs     :: [(Id, StgRhs)]+    (lit_binds, pairs) = flattenTopStgBindings binds++    nodes :: [Node Name (Id, CgStgRhs)]+    nodes = map (annotateTopPair env0) pairs+    env0 = Env { locals = emptyVarSet, mod = this_mod }++    -- Do strongly connected component analysis.  Why?+    -- See Note [Why do we need dependency analysis?]+    sccs :: [SCC (Id,CgStgRhs)]+    sccs  = stronglyConnCompFromEdgedVerticesUniq nodes++    from_scc (CyclicSCC pairs)       = StgTopLifted (StgRec pairs)+    from_scc (AcyclicSCC (bndr,rhs)) = StgTopLifted (StgNonRec bndr rhs)+++flattenTopStgBindings :: [StgTopBinding] -> ([CgStgTopBinding], [(Id,StgRhs)])+flattenTopStgBindings binds+  = go [] [] binds+  where+    go lits pairs [] = (lits, pairs)+    go lits pairs (bind:binds)+      = case bind of+          StgTopStringLit bndr rhs -> go (StgTopStringLit bndr rhs:lits) pairs binds+          StgTopLifted stg_bind -> go lits (flatten_one stg_bind ++ pairs) binds++    flatten_one (StgNonRec b r) = [(b,r)]+    flatten_one (StgRec pairs)  = pairs++annotateTopPair :: Env -> (Id, StgRhs) -> Node Name (Id, CgStgRhs)+annotateTopPair env0 (bndr, rhs)+  = DigraphNode { node_key          = idName bndr+                , node_payload      = (bndr, rhs')+                , node_dependencies = map idName (nonDetEltsUniqSet top_fvs) }+  where+    (rhs', top_fvs, _) = rhsFVs env0 rhs++--------------------------------------------------------------------------------+-- * Non-global free variable analysis++data Env   = Env-  { locals :: IdSet+  { -- | Set of locally-bound, not-top-level binders in scope.+    -- That is, variables bound by a let (but not let-no-escape), a lambda+    -- (in a StgRhsClsoure), a case binder, or a case alternative.  These+    -- are the variables that must be captured in a function closure, if they+    -- are free in the RHS. Example+    --   f = \x. let g = \y. x+1+    --           let h = \z. g z + 1+    --           in h x+    -- In the body of h we have locals = {x, g, z}.  Note that f is top level+    -- and does not appear in locals.+    locals :: IdSet+  , mod    :: Module   } -emptyEnv :: Env-emptyEnv = Env emptyVarSet- addLocals :: [Id] -> Env -> Env addLocals bndrs env   = env { locals = extendVarSetList (locals env) bndrs } --- | Annotates a top-level STG binding group with its free variables.-annTopBindingsFreeVars :: [StgTopBinding] -> [CgStgTopBinding]-annTopBindingsFreeVars = map go-  where-    go (StgTopStringLit id bs) = StgTopStringLit id bs-    go (StgTopLifted bind)-      = StgTopLifted (annBindingFreeVars bind)---- | Annotates an STG binding with its free variables.-annBindingFreeVars :: StgBinding -> CgStgBinding-annBindingFreeVars = fst . binding emptyEnv emptyDVarSet+--------------------------------------------------------------------------------+-- | TopFVs: set of variables that are:+--    (a) bound at the top level of this module, and+--    (b) appear free in the expression+-- It is a /non-deterministic/ set because we use it only to perform dependency+-- analysis on the top-level bindings.+type TopFVs   = IdSet -boundIds :: StgBinding -> [Id]-boundIds (StgNonRec b _) = [b]-boundIds (StgRec pairs)  = map fst pairs+-- | LocalFVs: set of variable that are:+--     (a) bound locally (by a lambda, non-top-level let, or case); that is,+--         it appears in the 'locals' field of 'Env'+--     (b) appear free in the expression+-- It is a /deterministic/ set because it is used to annotate closures with+-- their free variables, and we want closure layout to be deterministic.+--+-- Invariant: the LocalFVs returned is a subset of the 'locals' field of Env+type LocalFVs = DIdSet --- Note [Tracking local binders]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- 'locals' contains non-toplevel, non-imported binders.--- We maintain the set in 'expr', 'alt' and 'rhs', which are the only--- places where new local binders are introduced.--- Why do it there rather than in 'binding'? Two reasons:+-- | Dependency analysis on STG terms. -----   1. We call 'binding' from 'annTopBindingsFreeVars', which would---      add top-level bindings to the 'locals' set.---   2. In the let(-no-escape) case, we need to extend the environment---      prior to analysing the body, but we also need the fvs from the---      body to analyse the RHSs. No way to do this without some---      knot-tying.+-- Dependencies of a binding are just free variables in the binding. This+-- includes imported ids and ids in the current module. For recursive groups we+-- just return one set of free variables which is just the union of dependencies+-- of all bindings in the group.+--+-- Implementation: pass bound variables (NestedIds) to recursive calls, get free+-- variables (TopFVs) back. We ignore imported TopFVs as they do not change the+-- ordering but it improves performance (see `nameIsExternalFrom` call in `vars_fvs`).+-- --- | This makes sure that only local, non-global free vars make it into the set.-mkFreeVarSet :: Env -> [Id] -> DIdSet-mkFreeVarSet env = mkDVarSet . filter (`elemVarSet` locals env)+annBindingFreeVars :: Module -> StgBinding -> CgStgBinding+annBindingFreeVars this_mod = fstOf3 . bindingFVs (Env emptyVarSet this_mod) emptyDVarSet -args :: Env -> [StgArg] -> DIdSet-args env = mkFreeVarSet env . mapMaybe f-  where-    f (StgVarArg occ) = Just occ-    f _               = Nothing+bindingFVs :: Env -> LocalFVs -> StgBinding -> (CgStgBinding, TopFVs, LocalFVs)+bindingFVs env body_fv b =+  case b of+    StgNonRec bndr r -> (StgNonRec bndr r', fvs, lcl_fvs)+      where+        (r', fvs, rhs_lcl_fvs) = rhsFVs env r+        lcl_fvs = delDVarSet body_fv bndr `unionDVarSet` rhs_lcl_fvs -binding :: Env -> DIdSet -> StgBinding -> (CgStgBinding, DIdSet)-binding env body_fv (StgNonRec bndr r) = (StgNonRec bndr r', fvs)-  where-    -- See Note [Tracking local binders]-    (r', rhs_fvs) = rhs env r-    fvs = delDVarSet body_fv bndr `unionDVarSet` rhs_fvs-binding env body_fv (StgRec pairs) = (StgRec pairs', fvs)-  where-    -- See Note [Tracking local binders]-    bndrs = map fst pairs-    (rhss, rhs_fvss) = mapAndUnzip (rhs env . snd) pairs-    pairs' = zip bndrs rhss-    fvs = delDVarSetList (unionDVarSets (body_fv:rhs_fvss)) bndrs+    StgRec pairs -> (StgRec pairs', fvs, lcl_fvss)+      where+        bndrs = map fst pairs+        env' = addLocals bndrs env+        (rhss, rhs_fvss, rhs_lcl_fvss) = mapAndUnzip3 (rhsFVs env' . snd) pairs+        fvs = unionVarSets rhs_fvss+        pairs' = zip bndrs rhss+        lcl_fvss = delDVarSetList (unionDVarSets (body_fv:rhs_lcl_fvss)) bndrs -expr :: Env -> StgExpr -> (CgStgExpr, DIdSet)-expr env = go+varFVs :: Env -> Id -> (TopFVs, LocalFVs) -> (TopFVs, LocalFVs)+varFVs env v (top_fvs, lcl_fvs)+  | v `elemVarSet` locals env                -- v is locally bound+  = (top_fvs, lcl_fvs `extendDVarSet` v)+  | nameIsLocalOrFrom (mod env) (idName v)   -- v is bound at top level+  = (top_fvs `extendVarSet` v, lcl_fvs)+  | otherwise                                -- v is imported+  = (top_fvs, lcl_fvs)++exprFVs :: Env -> StgExpr -> (CgStgExpr, TopFVs, LocalFVs)+exprFVs env = go   where-    go (StgApp occ as)-      = (StgApp occ as, unionDVarSet (args env as) (mkFreeVarSet env [occ]))-    go (StgLit lit) = (StgLit lit, emptyDVarSet)-    go (StgConApp dc n as tys) = (StgConApp dc n as tys, args env as)-    go (StgOpApp op as ty) = (StgOpApp op as ty, args env as)-    go (StgCase scrut bndr ty alts) = (StgCase scrut' bndr ty alts', fvs)-      where-        (scrut', scrut_fvs) = go scrut-        -- See Note [Tracking local binders]-        (alts', alt_fvss) = mapAndUnzip (alt (addLocals [bndr] env)) alts-        alt_fvs = unionDVarSets alt_fvss-        fvs = delDVarSet (unionDVarSet scrut_fvs alt_fvs) bndr-    go (StgLet ext bind body) = go_bind (StgLet ext) bind body+    go (StgApp f as)+      | (top_fvs, lcl_fvs) <- varFVs env f (argsFVs env as)+      = (StgApp f as, top_fvs, lcl_fvs)++    go (StgLit lit) = (StgLit lit, emptyVarSet, emptyDVarSet)++    go (StgConApp dc n as tys)+      | (top_fvs, lcl_fvs) <- argsFVs env as+      = (StgConApp dc n as tys, top_fvs, lcl_fvs)++    go (StgOpApp op as ty)+      | (top_fvs, lcl_fvs) <- argsFVs env as+      = (StgOpApp op as ty, top_fvs, lcl_fvs)++    go (StgCase scrut bndr ty alts)+      | (scrut',scrut_top_fvs,scrut_lcl_fvs) <- exprFVs env scrut+      , (alts',alts_top_fvss,alts_lcl_fvss)+          <- mapAndUnzip3 (altFVs (addLocals [bndr] env)) alts+      , let top_fvs = scrut_top_fvs `unionVarSet` unionVarSets alts_top_fvss+            alts_lcl_fvs = unionDVarSets alts_lcl_fvss+            lcl_fvs = delDVarSet (unionDVarSet scrut_lcl_fvs alts_lcl_fvs) bndr+      = (StgCase scrut' bndr ty alts', top_fvs,lcl_fvs)++    go (StgLet ext         bind body) = go_bind (StgLet ext) bind body     go (StgLetNoEscape ext bind body) = go_bind (StgLetNoEscape ext) bind body-    go (StgTick tick e) = (StgTick tick e', fvs')-      where-        (e', fvs) = go e-        fvs' = unionDVarSet (tickish tick) fvs-        tickish (Breakpoint _ _ ids) = mkDVarSet ids-        tickish _                    = emptyDVarSet -    go_bind dc bind body = (dc bind' body', fvs)+    go (StgTick tick e)+      | (e', top_fvs, lcl_fvs) <- exprFVs env e+      , let lcl_fvs' = unionDVarSet (tickish tick) lcl_fvs+      = (StgTick tick e', top_fvs, lcl_fvs')+        where+          tickish (Breakpoint _ _ ids) = mkDVarSet ids+          tickish _                    = emptyDVarSet++    go_bind dc bind body = (dc bind' body', top_fvs, lcl_fvs)       where-        -- See Note [Tracking local binders]-        env' = addLocals (boundIds bind) env-        (body', body_fvs) = expr env' body-        (bind', fvs) = binding env' body_fvs bind+        env' = addLocals (bindersOf bind) env+        (body', body_top_fvs, body_lcl_fvs) = exprFVs env' body+        (bind', bind_top_fvs, lcl_fvs)      = bindingFVs env' body_lcl_fvs bind+        top_fvs = bind_top_fvs `unionVarSet` body_top_fvs -rhs :: Env -> StgRhs -> (CgStgRhs, DIdSet)-rhs env (StgRhsClosure _ ccs uf bndrs body)-  = (StgRhsClosure fvs ccs uf bndrs body', fvs)-  where-    -- See Note [Tracking local binders]-    (body', body_fvs) = expr (addLocals bndrs env) body-    fvs = delDVarSetList body_fvs bndrs-rhs env (StgRhsCon ccs dc mu ts as) = (StgRhsCon ccs dc mu ts as, args env as) -alt :: Env -> StgAlt -> (CgStgAlt, DIdSet)-alt env (con, bndrs, e) = ((con, bndrs, e'), fvs)+rhsFVs :: Env -> StgRhs -> (CgStgRhs, TopFVs, LocalFVs)+rhsFVs env (StgRhsClosure _ ccs uf bs body)+  | (body', top_fvs, lcl_fvs) <- exprFVs (addLocals bs env) body+  , let lcl_fvs' = delDVarSetList lcl_fvs bs+  = (StgRhsClosure lcl_fvs' ccs uf bs body', top_fvs, lcl_fvs')+rhsFVs env (StgRhsCon ccs dc mu ts bs)+  | (top_fvs, lcl_fvs) <- argsFVs env bs+  = (StgRhsCon ccs dc mu ts bs, top_fvs, lcl_fvs)++argsFVs :: Env -> [StgArg] -> (TopFVs, LocalFVs)+argsFVs env = foldl' f (emptyVarSet, emptyDVarSet)   where-    -- See Note [Tracking local binders]-    (e', rhs_fvs) = expr (addLocals bndrs env) e-    fvs = delDVarSetList rhs_fvs bndrs+    f (fvs,ids) StgLitArg{}   = (fvs, ids)+    f (fvs,ids) (StgVarArg v) = varFVs env v (fvs, ids)++altFVs :: Env -> StgAlt -> (CgStgAlt, TopFVs, LocalFVs)+altFVs env GenStgAlt{alt_con=con, alt_bndrs=bndrs, alt_rhs=e}+  | (e', top_fvs, lcl_fvs) <- exprFVs (addLocals bndrs env) e+  , let lcl_fvs' = delDVarSetList lcl_fvs bndrs+  , let newAlt   = GenStgAlt{alt_con=con, alt_bndrs=bndrs, alt_rhs=e'}+  = (newAlt, top_fvs, lcl_fvs')
+ GHC/Stg/InferTags.hs view
@@ -0,0 +1,643 @@+{-# LANGUAGE TypeFamilies, DataKinds, GADTs, FlexibleInstances #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+ -- To permit: type instance XLet 'InferTaggedBinders = XLet 'SomePass++{-# OPTIONS_GHC -Wname-shadowing #-}+module GHC.Stg.InferTags ( inferTags ) where++import GHC.Prelude hiding (id)++import GHC.Core.DataCon+import GHC.Core.Type+import GHC.Types.Id+import GHC.Types.Id.Info (tagSigInfo)+import GHC.Types.Name+import GHC.Stg.Syntax+import GHC.Types.Basic ( CbvMark (..) )+import GHC.Types.Unique.Supply (mkSplitUniqSupply)+import GHC.Types.RepType (dataConRuntimeRepStrictness)+import GHC.Core (AltCon(..))+import Data.List (mapAccumL)+import GHC.Utils.Outputable+import GHC.Utils.Misc( zipWithEqual, zipEqual, notNull )++import GHC.Stg.InferTags.Types+import GHC.Stg.InferTags.Rewrite (rewriteTopBinds)+import Data.Maybe+import GHC.Types.Name.Env (mkNameEnv, NameEnv)+import GHC.Driver.Config.Stg.Ppr+import GHC.Driver.Session+import GHC.Utils.Logger+import qualified GHC.Unit.Types++{- Note [Tag Inference]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The purpose of this pass is to attach to every binder a flag+to indicate whether or not it is "properly tagged".  A binder+is properly tagged if it is guaranteed:+ - to point to a heap-allocated *value*+ - and to have the tag of the value encoded in the pointer++For example+  let x = Just y in ...++Here x will be properly tagged: it will point to the heap-allocated+values for (Just y), and the tag-bits of the pointer will encode+the tag for Just so there is no need to re-enter the closure or even+check for the presence of tag bits. The impacts of this can be very large.++For containers the reduction in runtimes with this optimization was as follows:++intmap-benchmarks:    89.30%+intset-benchmarks:    90.87%+map-benchmarks:       88.00%+sequence-benchmarks:  99.84%+set-benchmarks:       85.00%+set-operations-intmap:88.64%+set-operations-map:   74.23%+set-operations-set:   76.50%+lookupge-intmap:      89.57%+lookupge-map:         70.95%++With nofib being ~0.3% faster as well.++See Note [Tag inference passes] for how we proceed to generate and use this information.++Note [Strict Field Invariant]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+As part of tag inference we introduce the Strict Field Invariant.+Which consists of us saying that:++* Pointers in strict fields must (a) point directly to the value, and+  (b) must be properly tagged.++For example, given+  data T = MkT ![Int]++the Strict Field Invariant guarantees that the first field of any `MkT` constructor+will either point directly to nil, or directly to a cons cell;+and will be tagged with `001` or `010` respectively.+It will never point to a thunk, nor will it be tagged `000` (meaning "might be a thunk").+NB: Note that the proper tag for some objects is indeed `000`. Currently this is the case for PAPs.++This works analogous to how `WorkerLikeId`s work. See also Note [CBV Function Ids].++Why do we care? Because if we have code like:++case strictPair of+  SP x y ->+    case x of ...++It allows us to safely omit the code to enter x and the check+for the presence of a tag that goes along with it.+However we might still branch on the tag as usual.+See Note [Tag Inference] for how much impact this can have for+some code.++This is enforced by the code GHC.Stg.InferTags.Rewrite+where we:++* Look at all constructor allocations.+* Check if arguments to their strict fields are known to be properly tagged+* If not we convert `StrictJust x` into `case x of x' -> StrictJust x'`++This is usually very beneficial but can cause regressions in rare edge cases where+we fail to proof that x is properly tagged, or where it simply isn't.+See Note [How untagged pointers can end up in strict fields] for how the second case+can arise.++For a full example of the worst case consider this code:++foo ... = ...+  let c = StrictJust x+  in ...++Here we would rewrite `let c = StrictJust x` into `let c = case x of x' -> StrictJust x'`+However that is horrible! We end up allocating a thunk for `c` first, which only when+evaluated will allocate the constructor.++So we do our best to establish that `x` is already tagged (which it almost always is)+to avoid this cost. In my benchmarks I haven't seen any cases where this causes regressions.++Note that there are similar constraints around Note [CBV Function Ids].++Note [How untagged pointers can end up in strict fields]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  data Set a = Tip | Bin !a (Set a) (Set a)++We make a wrapper for Bin that evaluates its arguments+  $WBin x a b = case x of xv -> Bin xv a b+Here `xv` will always be evaluated and properly tagged, just as the+Strict Field Invariant requires.++But alas the Simplifier can destroy the invariant: see #15696.+We start with+  thk = f ()+  g x = ...(case thk of xv -> Bin xv Tip Tip)...++So far so good; the argument to Bin (which is strict) is evaluated.+Now we do float-out. And in doing so we do a reverse binder-swap (see+Note [Binder-swap during float-out] in SetLevels) thus++  g x = ...(case thk of xv -> Bin thk Nil Nil)...++The goal of the reverse binder-swap is to allow more floating -- and+indeed it does! We float the Bin to top level:++  lvl = Bin thk Tip Tip+  g x = ...(case thk of xv -> lvl)...++Now you can see that the argument of Bin, namely thk, points to the+thunk, not to the value as it did before.++In short, although it may be rare, the output of optimisation passes+cannot guarantee to obey the Strict Field Invariant. For this reason+we run tag inference. See Note [Tag inference passes].++Note [Tag inference passes]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Tag inference proceeds in two passes:+* The first pass is an analysis to compute which binders are properly tagged.+  The result is then attached to /binders/.+  This is implemented by `inferTagsAnal` in GHC.Stg.InferTags+* The second pass walks over the AST checking if the Strict Field Invariant is upheld.+  See Note [Strict Field Invariant].+  If required this pass modifies the program to uphold this invariant.+  Tag information is also moved from /binders/ to /occurrences/ during this pass.+  This is done by `GHC.Stg.InferTags.Rewrite (rewriteTopBinds)`.+* Finally the code generation uses this information to skip the thunk check when branching on+  values. This is done by `cgExpr`/`cgCase` in the backend.++Last but not least we also export the tag sigs of top level bindings to allow this optimization+ to work across module boundaries.++Note [TagInfo of functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+The purpose of tag inference is really to figure out when we don't have to enter+value closures. There the meaning of the tag is fairly obvious.+For functions we never make use of the tag info so we have two choices:+* Treat them as TagDunno+* Treat them as TagProper (as they *are* tagged with their arity) and be really+  careful to make sure we still enter them when needed.+As it makes little difference for runtime performance I've treated functions as TagDunno in a few places where+it made the code simpler. But besides implementation complexity there isn't any reason+why we couldn't be more rigourous in dealing with functions.++NB: It turned in #21193 that PAPs get tag zero, so the tag check can't be omitted for functions.+So option two isn't really an option without reworking this anyway.++Note [Tag inference debugging]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There is a flag -dtag-inference-checks which inserts various+compile/runtime checks in order to ensure the Strict Field Invariant+holds. It should cover all places+where tags matter and disable optimizations which interfere with checking+the invariant like generation of AP-Thunks.++Note [Polymorphic StgPass for inferTagExpr]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In order to reach a fixpoint we sometimes have to re-analyse an expression+multiple times. But after the initial run the Ast will be parameterized by+a different StgPass! To handle this a large part of the analysis is polymorphic+over the exact StgPass we are using. Which allows us to run the analysis on+the output of itself.++-}++{- *********************************************************************+*                                                                      *+                         Tag inference pass+*                                                                      *+********************************************************************* -}++-- doCodeGen :: HscEnv -> Module -> InfoTableProvMap -> [TyCon]+--           -> CollectedCCs+--           -> [CgStgTopBinding] -- ^ Bindings come already annotated with fvs+--           -> HpcInfo+--           -> IO (Stream IO CmmGroupSRTs CgInfos)+--          -- Note we produce a 'Stream' of CmmGroups, so that the+--          -- backend can be run incrementally.  Otherwise it generates all+--          -- the C-- up front, which has a significant space cost.+inferTags :: DynFlags -> Logger -> (GHC.Unit.Types.Module) -> [CgStgTopBinding] -> IO ([TgStgTopBinding], NameEnv TagSig)+inferTags dflags logger this_mod stg_binds = do++    -- Annotate binders with tag information.+    let (!stg_binds_w_tags) = {-# SCC "StgTagFields" #-}+                                        inferTagsAnal stg_binds+    putDumpFileMaybe logger Opt_D_dump_stg_tags "CodeGenAnal STG:" FormatSTG (pprGenStgTopBindings (initStgPprOpts dflags) stg_binds_w_tags)++    let export_tag_info = collectExportInfo stg_binds_w_tags++    -- Rewrite STG to uphold the strict field invariant+    us_t <- mkSplitUniqSupply 't'+    let rewritten_binds = {-# SCC "StgTagRewrite" #-} rewriteTopBinds this_mod us_t stg_binds_w_tags :: [TgStgTopBinding]++    return (rewritten_binds,export_tag_info)++{- *********************************************************************+*                                                                      *+                         Main inference algorithm+*                                                                      *+********************************************************************* -}++type OutputableInferPass p = (Outputable (TagEnv p)+                              , Outputable (GenStgExpr p)+                              , Outputable (BinderP p)+                              , Outputable (GenStgRhs p))++-- | This constraint encodes the fact that no matter what pass+-- we use the Let/Closure extension points are the same as these for+-- 'InferTaggedBinders.+type InferExtEq i = ( XLet i ~ XLet 'InferTaggedBinders+                    , XLetNoEscape i ~ XLetNoEscape 'InferTaggedBinders+                    , XRhsClosure i ~ XRhsClosure 'InferTaggedBinders)++inferTagsAnal :: [GenStgTopBinding 'CodeGen] -> [GenStgTopBinding 'InferTaggedBinders]+inferTagsAnal binds =+  -- pprTrace "Binds" (pprGenStgTopBindings shortStgPprOpts $ binds) $+  snd (mapAccumL inferTagTopBind initEnv binds)++-----------------------+inferTagTopBind :: TagEnv 'CodeGen -> GenStgTopBinding 'CodeGen+                -> (TagEnv 'CodeGen, GenStgTopBinding 'InferTaggedBinders)+inferTagTopBind env (StgTopStringLit id bs)+  = (env, StgTopStringLit id bs)+inferTagTopBind env (StgTopLifted bind)+  = (env', StgTopLifted bind')+  where+    (env', bind') = inferTagBind env bind+++-- Why is this polymorphic over the StgPass? See Note [Polymorphic StgPass for inferTagExpr]+-----------------------+inferTagExpr :: forall p. (OutputableInferPass p, InferExtEq p)+  => TagEnv p -> GenStgExpr p -> (TagInfo, GenStgExpr 'InferTaggedBinders)+inferTagExpr env (StgApp fun args)+  =  --pprTrace "inferTagExpr1"+      -- (ppr fun <+> ppr args $$ ppr info $$+      --  text "deadEndInfo:" <> ppr (isDeadEndId fun, idArity fun, length args)+      -- )+    (info, StgApp fun args)+  where+    !fun_arity = idArity fun+    info | fun_arity == 0 -- Unknown arity => Thunk or unknown call+         = TagDunno++         | isDeadEndId fun+         , fun_arity == length args -- Implies we will simply call the function.+         = TagTagged -- See Note [Bottom functions are TagTagged]++         | Just (TagSig res_info) <- tagSigInfo (idInfo fun)+         , fun_arity == length args  -- Saturated+         = res_info++         | Just (TagSig res_info) <- lookupSig env fun+         , fun_arity == length args  -- Saturated+         = res_info++         | otherwise+         = --pprTrace "inferAppUnknown" (ppr fun) $+           TagDunno+-- TODO:+-- If we have something like:+--   let x = thunk in+--   f g = case g of g' -> (# x, g' #)+-- then we *do* know that g' will be properly tagged,+-- so we should return TagTagged [TagDunno,TagProper] but currently we infer+-- TagTagged [TagDunno,TagDunno] because of the unknown arity case in inferTagExpr.+-- Seems not to matter much but should be changed eventually.++inferTagExpr env (StgConApp con cn args tys)+  = (inferConTag env con args, StgConApp con cn args tys)++inferTagExpr _ (StgLit l)+  = (TagTagged, StgLit l)++inferTagExpr env (StgTick tick body)+  = (info, StgTick tick body')+  where+    (info, body') = inferTagExpr env body++inferTagExpr _ (StgOpApp op args ty)+  = -- Do any primops guarantee to return a properly tagged value?+    -- I think not.  Ditto foreign calls.+    (TagDunno, StgOpApp op args ty)++inferTagExpr env (StgLet ext bind body)+  = (info, StgLet ext bind' body')+  where+    (env', bind') = inferTagBind env bind+    (info, body') = inferTagExpr env' body++inferTagExpr env (StgLetNoEscape ext bind body)+  = (info, StgLetNoEscape ext bind' body')+  where+    (env', bind') = inferTagBind env bind+    (info, body') = inferTagExpr env' body++inferTagExpr in_env (StgCase scrut bndr ty alts)+  -- Unboxed tuples get their info from the expression we scrutinise if any+  | [GenStgAlt{alt_con=DataAlt con, alt_bndrs=bndrs, alt_rhs=rhs}] <- alts+  , isUnboxedTupleDataCon con+  , Just infos <- scrut_infos bndrs+  , let bndrs' = zipWithEqual "inferTagExpr" mk_bndr bndrs infos+        mk_bndr :: BinderP p -> TagInfo -> (Id, TagSig)+        mk_bndr tup_bndr tup_info =+            --  pprTrace "mk_ubx_bndr_info" ( ppr bndr <+> ppr info ) $+            (getBinderId in_env tup_bndr, TagSig tup_info)+        -- no case binder in alt_env here, unboxed tuple binders are dead after unarise+        alt_env = extendSigEnv in_env bndrs'+        (info, rhs') = inferTagExpr alt_env rhs+  =+    -- pprTrace "inferCase1" (+    --   text "scrut:" <> ppr scrut $$+    --   text "bndr:" <> ppr bndr $$+    --   text "infos" <> ppr infos $$+    --   text "out_bndrs" <> ppr bndrs') $+    (info, StgCase scrut' (noSig in_env bndr) ty [GenStgAlt{ alt_con=DataAlt con+                                                           , alt_bndrs=bndrs'+                                                           , alt_rhs=rhs'}])++  | null alts -- Empty case, but I might just be paranoid.+  = -- pprTrace "inferCase2" empty $+    (TagDunno, StgCase scrut' bndr' ty [])+  -- More than one alternative OR non-TagTuple single alternative.+  | otherwise+  =+    let+        case_env = extendSigEnv in_env [bndr']++        (infos, alts')+          = unzip [ (info, g {alt_bndrs=bndrs', alt_rhs=rhs'})+                  | g@GenStgAlt{ alt_con = con+                               , alt_bndrs = bndrs+                               , alt_rhs   = rhs+                               } <- alts+                  , let (alt_env,bndrs') = addAltBndrInfo case_env con bndrs+                        (info, rhs') = inferTagExpr alt_env rhs+                  ]+        alt_info = foldr combineAltInfo TagTagged infos+    in ( alt_info, StgCase scrut' bndr' ty alts')+  where+    -- Single unboxed tuple alternative+    scrut_infos bndrs = case scrut_info of+      TagTagged -> Just $ replicate (length bndrs) TagProper+      TagTuple infos -> Just infos+      _ -> Nothing+    (scrut_info, scrut') = inferTagExpr in_env scrut+    bndr' = (getBinderId in_env bndr, TagSig TagProper)++-- Compute binder sigs based on the constructors strict fields.+-- NB: Not used if we have tuple info from the scrutinee.+addAltBndrInfo :: forall p. TagEnv p -> AltCon -> [BinderP p] -> (TagEnv p, [BinderP 'InferTaggedBinders])+addAltBndrInfo env (DataAlt con) bndrs+  | not (isUnboxedTupleDataCon con || isUnboxedSumDataCon con)+  = (out_env, out_bndrs)+  where+    marks = dataConRuntimeRepStrictness con :: [StrictnessMark]+    out_bndrs = zipWith mk_bndr bndrs marks+    out_env = extendSigEnv env out_bndrs++    mk_bndr :: (BinderP p -> StrictnessMark -> (Id, TagSig))+    mk_bndr bndr mark+      | isUnliftedType (idType id) || isMarkedStrict mark+      = (id, TagSig TagProper)+      | otherwise+      = noSig env bndr+        where+          id = getBinderId env bndr++addAltBndrInfo env _ bndrs = (env, map (noSig env) bndrs)++-----------------------------+inferTagBind :: (OutputableInferPass p, InferExtEq p)+  => TagEnv p -> GenStgBinding p -> (TagEnv p, GenStgBinding 'InferTaggedBinders)+inferTagBind in_env (StgNonRec bndr rhs)+  =+    -- pprTrace "inferBindNonRec" (+    --   ppr bndr $$+    --   ppr (isDeadEndId id) $$+    --   ppr sig)+    (env', StgNonRec (id, sig) rhs')+  where+    id   = getBinderId in_env bndr+    env' = extendSigEnv in_env [(id, sig)]+    (sig,rhs') = inferTagRhs id in_env rhs++inferTagBind in_env (StgRec pairs)+  = -- pprTrace "rec" (ppr (map fst pairs) $$ ppr (in_env { te_env = out_env }, StgRec pairs')) $+    (in_env { te_env = out_env }, StgRec pairs')+  where+    (bndrs, rhss)     = unzip pairs+    in_ids            = map (getBinderId in_env) bndrs+    init_sigs         = map (initSig) $ zip in_ids rhss+    (out_env, pairs') = go in_env init_sigs rhss++    go :: forall q. (OutputableInferPass q , InferExtEq q) => TagEnv q -> [TagSig] -> [GenStgRhs q]+                 -> (TagSigEnv, [((Id,TagSig), GenStgRhs 'InferTaggedBinders)])+    go go_env in_sigs go_rhss+      --   | pprTrace "go" (ppr in_ids $$ ppr in_sigs $$ ppr out_sigs $$ ppr rhss') False+      --  = undefined+       | in_sigs == out_sigs = (te_env rhs_env, out_bndrs `zip` rhss')+       | otherwise     = go env' out_sigs rhss'+       where+         out_bndrs = map updateBndr in_bndrs -- TODO: Keeps in_ids alive+         in_bndrs = in_ids `zip` in_sigs+         rhs_env = extendSigEnv go_env in_bndrs+         (out_sigs, rhss') = unzip (zipWithEqual "inferTagBind" anaRhs in_ids go_rhss)+         env' = makeTagged go_env++         anaRhs :: Id -> GenStgRhs q -> (TagSig, GenStgRhs 'InferTaggedBinders)+         anaRhs bnd rhs = inferTagRhs bnd rhs_env rhs++         updateBndr :: (Id,TagSig) -> (Id,TagSig)+         updateBndr (v,sig) = (setIdTagSig v sig, sig)++initSig :: forall p. (Id, GenStgRhs p) -> TagSig+-- Initial signature for the fixpoint loop+initSig (_bndr, StgRhsCon {})               = TagSig TagTagged+initSig (bndr, StgRhsClosure _ _ _ _ _) =+  fromMaybe defaultSig (idTagSig_maybe bndr)+  where defaultSig = (TagSig TagTagged)++{- Note [Bottom functions are TagTagged]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we have a function with two branches with one+being bottom, and the other returning a tagged+unboxed tuple what is the result? We give it TagTagged!+To answer why consider this function:++foo :: Bool -> (# Bool, Bool #)+foo x = case x of+    True -> (# True,True #)+    False -> undefined++The true branch is obviously tagged. The other branch isn't.+We want to treat the *result* of foo as tagged as well so that+the combination of the branches also is tagged if all non-bottom+branches are tagged.+This is safe because the function is still always called/entered as long+as it's applied to arguments. Since the function will never return we can give+it safely any tag sig we like.+So we give it TagTagged, as it allows the combined tag sig of the case expression+to be the combination of all non-bottoming branches.++-}++-----------------------------+inferTagRhs :: forall p.+     (OutputableInferPass p, InferExtEq p)+  => Id -- ^ Id we are binding to.+  -> TagEnv p -- ^+  -> GenStgRhs p -- ^+  -> (TagSig, GenStgRhs 'InferTaggedBinders)+inferTagRhs bnd_id in_env (StgRhsClosure ext cc upd bndrs body)+  | isDeadEndId bnd_id && (notNull) bndrs+  -- See Note [Bottom functions are TagTagged]+  = (TagSig TagTagged, StgRhsClosure ext cc upd out_bndrs body')+  | otherwise+  = --pprTrace "inferTagRhsClosure" (ppr (_top, _grp_ids, env,info')) $+    (TagSig info', StgRhsClosure ext cc upd out_bndrs body')+  where+    out_bndrs+      | Just marks <- idCbvMarks_maybe bnd_id+      -- Sometimes an we eta-expand foo with additional arguments after ww, and we also trim+      -- the list of marks to the last strict entry. So we can conservatively+      -- assume these are not strict+      = zipWith (mkArgSig) bndrs (marks ++ repeat NotMarkedCbv)+      | otherwise = map (noSig env') bndrs :: [(Id,TagSig)]++    env' = extendSigEnv in_env out_bndrs+    (info, body') = inferTagExpr env' body+    info'+      -- It's a thunk+      | null bndrs+      = TagDunno+      -- TODO: We could preserve tuple fields for thunks+      -- as well. But likely not worth the complexity.++      | otherwise  = info++    mkArgSig :: BinderP p -> CbvMark -> (Id,TagSig)+    mkArgSig bndp mark =+      let id = getBinderId in_env bndp+          tag = case mark of+            MarkedCbv -> TagProper+            _+              | isUnliftedType (idType id) -> TagProper+              | otherwise -> TagDunno+      in (id, TagSig tag)++inferTagRhs _ env _rhs@(StgRhsCon cc con cn ticks args)+-- Constructors, which have untagged arguments to strict fields+-- become thunks. We encode this by giving changing RhsCon nodes the info TagDunno+  = --pprTrace "inferTagRhsCon" (ppr grp_ids) $+    (TagSig (inferConTag env con args), StgRhsCon cc con cn ticks args)++{- Note [Constructor TagSigs]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+@inferConTag@ will infer the proper tag signature for a binding who's RHS is a constructor+or a StgConApp expression.+Usually these will simply be TagProper. But there are exceptions.+If any of the fields in the constructor are strict, but any argument to these+fields is not tagged then we will have to case on the argument before storing+in the constructor. Which means for let bindings the RHS turns into a thunk+which obviously is no longer properly tagged.+For example we might start with:++    let x<TagDunno> = f ...+    let c<TagProper> = StrictPair x True++But we know during the rewrite stage x will need to be evaluated in the RHS+of `c` so we will infer:++    let x<TagDunno> = f ...+    let c<TagDunno> = StrictPair x True++Which in the rewrite stage will then be rewritten into:++    let x<TagDunno> = f ...+    let c<TagDunno> = case x of x' -> StrictPair x' True++The other exception is unboxed tuples. These will get a TagTuple+signature with a list of TagInfo about their individual binders+as argument. As example:++    let c<TagProper> = True+    let x<TagDunno> = ...+    let f<?> z = case z of z'<TagProper> -> (# c, x #)++Here we will infer for f the Signature <TagTuple[TagProper,TagDunno]>.+This information will be used if we scrutinze a saturated application of+`f` in order to determine the taggedness of the result.+That is for `case f x of (# r1,r2 #) -> rhs` we can infer+r1<TagProper> and r2<TagDunno> which allows us to skip all tag checks on `r1`+in `rhs`.++Things get a bit more complicated with nesting:++    let closeFd<TagTuple[...]> = ...+    let f x = ...+        case x of+          _ -> Solo# closeFd++The "natural" signature for the Solo# branch in `f` would be <TagTuple[TagTuple[...]]>.+But we flatten this out to <TagTuple[TagDunno]> for the time being as it improves compile+time and there doesn't seem to huge benefit to doing differently.++  -}++-- See Note [Constructor TagSigs]+inferConTag :: TagEnv p -> DataCon -> [StgArg] -> TagInfo+inferConTag env con args+  | isUnboxedTupleDataCon con+  = TagTuple $ map (flatten_arg_tag . lookupInfo env) args+  | otherwise =+    -- pprTrace "inferConTag"+    --   ( text "con:" <> ppr con $$+    --     text "args:" <> ppr args $$+    --     text "marks:" <> ppr (dataConRuntimeRepStrictness con) $$+    --     text "arg_info:" <> ppr (map (lookupInfo env) args) $$+    --     text "info:" <> ppr info) $+    info+  where+    info = if any arg_needs_eval strictArgs then TagDunno else TagProper+    strictArgs = zipEqual "inferTagRhs" args (dataConRuntimeRepStrictness con) :: ([(StgArg, StrictnessMark)])+    arg_needs_eval (arg,strict)+      -- lazy args+      | not (isMarkedStrict strict) = False+      | tag <- (lookupInfo env arg)+      -- banged args need to be tagged, or require eval+      = not (isTaggedInfo tag)++    flatten_arg_tag (TagTagged) = TagProper+    flatten_arg_tag (TagProper ) = TagProper+    flatten_arg_tag (TagTuple _) = TagDunno -- See Note [Constructor TagSigs]+    flatten_arg_tag (TagDunno) = TagDunno+++collectExportInfo :: [GenStgTopBinding 'InferTaggedBinders] -> NameEnv TagSig+collectExportInfo binds =+  mkNameEnv bndr_info+  where+    bndr_info = concatMap collect binds :: [(Name,TagSig)]++    collect (StgTopStringLit {}) = []+    collect (StgTopLifted bnd) =+      case bnd of+        StgNonRec (id,sig) _rhs+          | TagSig TagDunno <- sig -> []+          | otherwise -> [(idName id,sig)]+        StgRec bnds -> collectRec bnds++    collectRec :: [(BinderP 'InferTaggedBinders, rhs)] -> [(Name,TagSig)]+    collectRec [] = []+    collectRec (bnd:bnds)+      | (p,_rhs)  <- bnd+      , (id,sig) <- p+      , TagSig TagDunno <- sig+      = (idName id,sig) : collectRec bnds+      | otherwise = collectRec bnds
+ GHC/Stg/InferTags/Rewrite.hs view
@@ -0,0 +1,493 @@+--+-- Copyright (c) 2019 Andreas Klebinger+--++{-# LANGUAGE BangPatterns               #-}+{-# LANGUAGE CPP                        #-}+{-# LANGUAGE DataKinds                  #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GADTs                      #-}+{-# LANGUAGE GeneralisedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE RankNTypes                 #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE TupleSections              #-}+{-# LANGUAGE TypeFamilies               #-}++module GHC.Stg.InferTags.Rewrite (rewriteTopBinds)+where++import GHC.Prelude++import GHC.Types.Id+import GHC.Types.Name+import GHC.Types.Unique.Supply+import GHC.Types.Unique.FM+import GHC.Types.RepType+import GHC.Unit.Types (Module)++import GHC.Core.DataCon+import GHC.Core (AltCon(..) )+import GHC.Core.Type++import GHC.StgToCmm.Types++import GHC.Stg.Utils+import GHC.Stg.Syntax as StgSyn++import GHC.Data.Maybe+import GHC.Utils.Panic+import GHC.Utils.Panic.Plain++import GHC.Utils.Outputable+import GHC.Utils.Monad.State.Strict+import GHC.Utils.Misc++import GHC.Stg.InferTags.Types++import Control.Monad+import GHC.Types.Basic (CbvMark (NotMarkedCbv, MarkedCbv), isMarkedCbv, TopLevelFlag(..), isTopLevel)+import GHC.Types.Var.Set+-- import GHC.Utils.Trace+-- import GHC.Driver.Ppr++newtype RM a = RM { unRM :: (State (UniqFM Id TagSig, UniqSupply, Module, IdSet) a) }+    deriving (Functor, Monad, Applicative)++------------------------------------------------------------+-- Add cases around strict fields where required.+------------------------------------------------------------+{-+The work of this pass is simple:+* We traverse the STG AST looking for constructor allocations.+* For all allocations we check if there are strict fields in the constructor.+* For any strict field we check if the argument is known to be properly tagged.+* If it's not known to be properly tagged, we wrap the whole thing in a case,+  which will force the argument before allocation.+This is described in detail in Note [Strict Field Invariant].++The only slight complication is that we have to make sure not to invalidate free+variable analysis in the process.++Note [Partially applied workers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Sometimes we will get a function f of the form+    -- Arity 1+    f :: Dict a -> a -> b -> (c -> d)+    f dict a b = case dict of+        C m1 m2 -> m1 a b++Which will result in a W/W split along the lines of+    -- Arity 1+    f :: Dict a -> a -> b -> (c -> d)+    f dict a = case dict of+        C m1 m2 -> $wf m1 a b++    -- Arity 4+    $wf :: (a -> b -> d -> c) -> a -> b -> c -> d+    $wf m1 a b c = m1 a b c++It's notable that the worker is called *undersatured* in the wrapper.+At runtime what happens is that the wrapper will allocate a PAP which+once fully applied will call the worker. And all is fine.++But what about a call by value function! Well the function returned by `f` would+be a unknown call, so we lose the ability to enfore the invariant that+cbv marked arguments from StictWorkerId's are actually properly tagged+as the annotations would be unavailable at the (unknown) call site.++The fix is easy. We eta-expand all calls to functions taking call-by-value+arguments during CorePrep just like we do with constructor allocations.++Note [Upholding free variable annotations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The code generator requires us to maintain exact information+about free variables about closures. Since we convert some+RHSs from constructor allocations to closures we have to provide+fvs of these closures. Not all constructor arguments will become+free variables. Only these which are not bound at the top level+have to be captured.+To facilitate this we keep track of a set of locally bound variables in+the current context which we then use to filter constructor arguments+when building the free variable list.+-}++--------------------------------+-- Utilities+--------------------------------++instance MonadUnique RM where+    getUniqueSupplyM = RM $ do+        (m, us, mod,lcls) <- get+        let (us1, us2) = splitUniqSupply us+        (put) (m,us2,mod,lcls)+        return us1++getMap :: RM (UniqFM Id TagSig)+getMap = RM $ ((\(fst,_,_,_) -> fst) <$> get)++setMap :: (UniqFM Id TagSig) -> RM ()+setMap m = RM $ do+    (_,us,mod,lcls) <- get+    put (m, us,mod,lcls)++getMod :: RM Module+getMod = RM $ ( (\(_,_,thrd,_) -> thrd) <$> get)++getFVs :: RM IdSet+getFVs = RM $ ((\(_,_,_,lcls) -> lcls) <$> get)++setFVs :: IdSet -> RM ()+setFVs fvs = RM $ do+    (tag_map,us,mod,_lcls) <- get+    put (tag_map, us,mod,fvs)++-- Rewrite the RHS(s) while making the id and it's sig available+-- to determine if things are tagged/need to be captured as FV.+withBind :: TopLevelFlag -> GenStgBinding 'InferTaggedBinders -> RM a -> RM a+withBind top_flag (StgNonRec bnd _) cont = withBinder top_flag bnd cont+withBind top_flag (StgRec binds) cont = do+    let (bnds,_rhss) = unzip binds :: ([(Id, TagSig)], [GenStgRhs 'InferTaggedBinders])+    withBinders top_flag bnds cont++addTopBind :: GenStgBinding 'InferTaggedBinders -> RM ()+addTopBind (StgNonRec (id, tag) _) = do+    s <- getMap+    -- pprTraceM "AddBind" (ppr id)+    setMap $ addToUFM s id tag+    return ()+addTopBind (StgRec binds) = do+    let (bnds,_rhss) = unzip binds+    !s <- getMap+    -- pprTraceM "AddBinds" (ppr $ map fst bnds)+    setMap $! addListToUFM s bnds++withBinder :: TopLevelFlag ->  (Id, TagSig) -> RM a -> RM a+withBinder top_flag (id,sig) cont = do+    oldMap <- getMap+    setMap $ addToUFM oldMap id sig+    a <- if isTopLevel top_flag+            then cont+            else withLcl id cont+    setMap oldMap+    return a++withBinders :: TopLevelFlag -> [(Id, TagSig)] -> RM a -> RM a+withBinders TopLevel sigs cont = do+    oldMap <- getMap+    setMap $ addListToUFM oldMap sigs+    a <- cont+    setMap oldMap+    return a+withBinders NotTopLevel sigs cont = do+    oldMap <- getMap+    oldFvs <- getFVs+    setMap $ addListToUFM oldMap sigs+    setFVs $ extendVarSetList oldFvs (map fst sigs)+    a <- cont+    setMap oldMap+    setFVs oldFvs+    return a++-- | Compute the argument with the given set of ids treated as requiring capture+-- as free variables.+withClosureLcls :: DIdSet -> RM a -> RM a+withClosureLcls fvs act = do+    old_fvs <- getFVs+    let fvs' = nonDetStrictFoldDVarSet (flip extendVarSet) old_fvs fvs+    setFVs fvs'+    r <- act+    setFVs old_fvs+    return r++-- | Compute the argument with the given id treated as requiring capture+-- as free variables in closures.+withLcl :: Id -> RM a -> RM a+withLcl fv act = do+    old_fvs <- getFVs+    let fvs' = extendVarSet old_fvs fv+    setFVs fvs'+    r <- act+    setFVs old_fvs+    return r++isTagged :: Id -> RM Bool+isTagged v = do+    this_mod <- getMod+    case nameIsLocalOrFrom this_mod (idName v) of+        True+            | isUnliftedType (idType v)+            -> return True+            | otherwise -> do -- Local binding+                !s <- getMap+                let !sig = lookupWithDefaultUFM s (pprPanic "unknown Id:" (ppr v)) v+                return $ case sig of+                    TagSig info ->+                        case info of+                            TagDunno -> False+                            TagProper -> True+                            TagTagged -> True+                            TagTuple _ -> True -- Consider unboxed tuples tagged.+        False -- Imported+            | Just con <- (isDataConWorkId_maybe v)+            , isNullaryRepDataCon con+            -> return True+            | Just lf_info <- idLFInfo_maybe v+            -> return $+                -- Can we treat the thing as tagged based on it's LFInfo?+                case lf_info of+                    -- Function, applied not entered.+                    LFReEntrant {}+                        -> True+                    -- Thunks need to be entered.+                    LFThunk {}+                        -> False+                    -- LFCon means we already know the tag, and it's tagged.+                    LFCon {}+                        -> True+                    LFUnknown {}+                        -> False+                    LFUnlifted {}+                        -> True+                    LFLetNoEscape {}+                    -- Shouldn't be possible. I don't think we can export letNoEscapes+                        -> True++            | otherwise+            -> return False+++isArgTagged :: StgArg -> RM Bool+isArgTagged (StgLitArg _) = return True+isArgTagged (StgVarArg v) = isTagged v++mkLocalArgId :: Id -> RM Id+mkLocalArgId id = do+    !u <- getUniqueM+    return $! setIdUnique (localiseId id) u++---------------------------+-- Actual rewrite pass+---------------------------+++rewriteTopBinds :: Module -> UniqSupply -> [GenStgTopBinding 'InferTaggedBinders] -> [TgStgTopBinding]+rewriteTopBinds mod us binds =+    let doBinds = mapM rewriteTop binds++    in evalState (unRM doBinds) (mempty, us, mod, mempty)++rewriteTop :: InferStgTopBinding -> RM TgStgTopBinding+rewriteTop (StgTopStringLit v s) = return $! (StgTopStringLit v s)+rewriteTop (StgTopLifted bind)   = do+    -- Top level bindings can, and must remain in scope+    addTopBind bind+    (StgTopLifted) <$!> (rewriteBinds TopLevel bind)++-- For top level binds, the wrapper is guaranteed to be `id`+rewriteBinds :: TopLevelFlag -> InferStgBinding -> RM (TgStgBinding)+rewriteBinds _top_flag (StgNonRec v rhs) = do+        (!rhs) <-  rewriteRhs v rhs+        return $! (StgNonRec (fst v) rhs)+rewriteBinds top_flag b@(StgRec binds) =+    -- Bring sigs of binds into scope for all rhss+    withBind top_flag b $ do+        (rhss) <- mapM (uncurry rewriteRhs) binds+        return $! (mkRec rhss)+        where+            mkRec :: [TgStgRhs] -> TgStgBinding+            mkRec rhss = StgRec (zip (map (fst . fst) binds) rhss)++-- Rewrite a RHS+rewriteRhs :: (Id,TagSig) -> InferStgRhs+           -> RM (TgStgRhs)+rewriteRhs (_id, _tagSig) (StgRhsCon ccs con cn ticks args) = {-# SCC rewriteRhs_ #-} do+    -- pprTraceM "rewriteRhs" (ppr _id)++    -- Look up the nodes representing the constructor arguments.+    fieldInfos <- mapM isArgTagged args++    -- Filter out non-strict fields.+    let strictFields =+            getStrictConArgs con (zip args fieldInfos) :: [(StgArg,Bool)] -- (nth-argument, tagInfo)+    -- Filter out already tagged arguments.+    let needsEval = map fst . --get the actual argument+                        filter (not . snd) $ -- Keep untagged (False) elements.+                        strictFields :: [StgArg]+    let evalArgs = [v | StgVarArg v <- needsEval] :: [Id]++    if (null evalArgs)+        then return $! (StgRhsCon ccs con cn ticks args)+        else do+            --assert not (isTaggedSig tagSig)+            -- pprTraceM "CreatingSeqs for " $ ppr _id <+> ppr node_id++            -- At this point iff we have  possibly untagged arguments to strict fields+            -- we convert the RHS into a RhsClosure which will evaluate the arguments+            -- before allocating the constructor.+            let ty_stub = panic "mkSeqs shouldn't use the type arg"+            conExpr <- mkSeqs args evalArgs (\taggedArgs -> StgConApp con cn taggedArgs ty_stub)++            fvs <- fvArgs args+            -- lcls <- getFVs+            -- pprTraceM "RhsClosureConversion" (ppr (StgRhsClosure fvs ccs ReEntrant [] $! conExpr) $$ text "lcls:" <> ppr lcls)+            return $! (StgRhsClosure fvs ccs ReEntrant [] $! conExpr)+rewriteRhs _binding (StgRhsClosure fvs ccs flag args body) = do+    withBinders NotTopLevel args $+        withClosureLcls fvs $+            StgRhsClosure fvs ccs flag (map fst args) <$> rewriteExpr False body+        -- return (closure)++fvArgs :: [StgArg] -> RM DVarSet+fvArgs args = do+    fv_lcls <- getFVs+    -- pprTraceM "fvArgs" (text "args:" <> ppr args $$ text "lcls:" <> pprVarSet (fv_lcls) (braces . fsep . map ppr) )+    return $ mkDVarSet [ v | StgVarArg v <- args, elemVarSet v fv_lcls]++type IsScrut = Bool++rewriteExpr :: IsScrut -> InferStgExpr -> RM TgStgExpr+rewriteExpr _ (e@StgCase {})          = rewriteCase e+rewriteExpr _ (e@StgLet {})           = rewriteLet e+rewriteExpr _ (e@StgLetNoEscape {})   = rewriteLetNoEscape e+rewriteExpr isScrut (StgTick t e)     = StgTick t <$!> rewriteExpr isScrut e+rewriteExpr _ e@(StgConApp {})        = rewriteConApp e++rewriteExpr isScrut e@(StgApp {})     = rewriteApp isScrut e+rewriteExpr _ (StgLit lit)           = return $! (StgLit lit)+rewriteExpr _ (StgOpApp op args res_ty) = return $! (StgOpApp op args res_ty)++rewriteCase :: InferStgExpr -> RM TgStgExpr+rewriteCase (StgCase scrut bndr alt_type alts) =+    withBinder NotTopLevel bndr $+        pure StgCase <*>+            rewriteExpr True scrut <*>+            pure (fst bndr) <*>+            pure alt_type <*>+            mapM rewriteAlt alts++rewriteCase _ = panic "Impossible: nodeCase"++rewriteAlt :: InferStgAlt -> RM TgStgAlt+rewriteAlt alt@GenStgAlt{alt_con=_, alt_bndrs=bndrs, alt_rhs=rhs} =+    withBinders NotTopLevel bndrs $ do+        !rhs' <- rewriteExpr False rhs+        return $! alt {alt_bndrs = map fst bndrs, alt_rhs = rhs'}++rewriteLet :: InferStgExpr -> RM TgStgExpr+rewriteLet (StgLet xt bind expr) = do+    (!bind') <- rewriteBinds NotTopLevel bind+    withBind NotTopLevel bind $ do+        -- pprTraceM "withBindLet" (ppr $ bindersOfX bind)+        !expr' <- rewriteExpr False expr+        return $! (StgLet xt bind' expr')+rewriteLet _ = panic "Impossible"++rewriteLetNoEscape :: InferStgExpr -> RM TgStgExpr+rewriteLetNoEscape (StgLetNoEscape xt bind expr) = do+    (!bind') <- rewriteBinds NotTopLevel bind+    withBind NotTopLevel bind $ do+        !expr' <- rewriteExpr False expr+        return $! (StgLetNoEscape xt bind' expr')+rewriteLetNoEscape _ = panic "Impossible"++rewriteConApp :: InferStgExpr -> RM TgStgExpr+rewriteConApp (StgConApp con cn args tys) = do+    -- We check if the strict field arguments are already known to be tagged.+    -- If not we evaluate them first.+    fieldInfos <- mapM isArgTagged args+    let strictIndices = getStrictConArgs con (zip fieldInfos args) :: [(Bool, StgArg)]+    let needsEval = map snd . filter (not . fst) $ strictIndices :: [StgArg]+    let evalArgs = [v | StgVarArg v <- needsEval] :: [Id]+    if (not $ null evalArgs)+        then do+            -- pprTraceM "Creating conAppSeqs for " $ ppr nodeId <+> parens ( ppr evalArgs ) -- <+> parens ( ppr fieldInfos )+            mkSeqs args evalArgs (\taggedArgs -> StgConApp con cn taggedArgs tys)+        else return $! (StgConApp con cn args tys)++rewriteConApp _ = panic "Impossible"++-- Special case: Expressions like `case x of { ... }`+rewriteApp :: IsScrut -> InferStgExpr -> RM TgStgExpr+rewriteApp True (StgApp f []) = do+    -- pprTraceM "rewriteAppScrut" (ppr f)+    f_tagged <- isTagged f+    -- isTagged looks at more than the result of our analysis.+    -- So always update here if useful.+    let f' = if f_tagged+                then setIdTagSig f (TagSig TagProper)+                else f+    return $! StgApp f' []+rewriteApp _ (StgApp f args)+    -- pprTrace "rewriteAppOther" (ppr f <+> ppr args) False+    -- = undefined+    | Just marks <- idCbvMarks_maybe f+    , relevant_marks <- dropWhileEndLE (not . isMarkedCbv) marks+    , any isMarkedCbv relevant_marks+    = assert (length relevant_marks <= length args)+      unliftArg relevant_marks++    where+      -- If the function expects any argument to be call-by-value ensure the argument is already+      -- evaluated.+      unliftArg relevant_marks = do+        argTags <- mapM isArgTagged args+        let argInfo = zipWith3 ((,,)) args (relevant_marks++repeat NotMarkedCbv)  argTags :: [(StgArg, CbvMark, Bool)]++            -- untagged cbv argument positions+            cbvArgInfo = filter (\x -> sndOf3 x == MarkedCbv && thdOf3 x == False) argInfo+            cbvArgIds = [x | StgVarArg x <- map fstOf3 cbvArgInfo] :: [Id]+        mkSeqs args cbvArgIds (\cbv_args -> StgApp f cbv_args)++rewriteApp _ (StgApp f args) = return $ StgApp f args+rewriteApp _ _ = panic "Impossible"++-- `mkSeq` x x' e generates `case x of x' -> e`+-- We could also substitute x' for x in e but that's so rarely beneficial+-- that we don't bother.+mkSeq :: Id -> Id -> TgStgExpr -> TgStgExpr+mkSeq id bndr !expr =+    -- pprTrace "mkSeq" (ppr (id,bndr)) $+    let altTy = mkStgAltTypeFromStgAlts bndr alt+        alt   = [GenStgAlt {alt_con = DEFAULT, alt_bndrs = [], alt_rhs = expr}]+    in StgCase (StgApp id []) bndr altTy alt++-- `mkSeqs args vs mkExpr` will force all vs, and construct+-- an argument list args' where each v is replaced by it's evaluated+-- counterpart v'.+-- That is if we call `mkSeqs [StgVar x, StgLit l] [x] mkExpr` then+-- the result will be (case x of x' { _DEFAULT -> <mkExpr [StgVar x', StgLit l]>}+{-# INLINE mkSeqs #-} -- We inline to avoid allocating mkExpr+mkSeqs  :: [StgArg] -- ^ Original arguments+        -> [Id]     -- ^ var args to be evaluated ahead of time+        -> ([StgArg] -> TgStgExpr)+                    -- ^ Function that reconstructs the expressions when passed+                    -- the list of evaluated arguments.+        -> RM TgStgExpr+mkSeqs args untaggedIds mkExpr = do+    argMap <- mapM (\arg -> (arg,) <$> mkLocalArgId arg ) untaggedIds :: RM [(InId, OutId)]+    -- mapM_ (pprTraceM "Forcing strict args before allocation:" . ppr) argMap+    let taggedArgs :: [StgArg]+            = map   (\v -> case v of+                        StgVarArg v' -> StgVarArg $ fromMaybe v' $ lookup v' argMap+                        lit -> lit)+                    args++    let conBody = mkExpr taggedArgs+    let body = foldr (\(v,bndr) expr -> mkSeq v bndr expr) conBody argMap+    return $! body++-- Out of all arguments passed at runtime only return these ending up in a+-- strict field+getStrictConArgs :: DataCon -> [a] -> [a]+getStrictConArgs con args+    -- These are always lazy in their arguments.+    | isUnboxedTupleDataCon con = []+    | isUnboxedSumDataCon con = []+    -- For proper data cons we have to check.+    | otherwise =+        [ arg | (arg,MarkedStrict)+                    <- zipEqual "getStrictConArgs"+                                args+                                (dataConRuntimeRepStrictness con)]
+ GHC/Stg/InferTags/TagSig.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE TypeFamilies, DataKinds, GADTs, FlexibleInstances #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}++-- We export this type from this module instead of GHC.Stg.InferTags.Types+-- because it's used by more than the analysis itself. For example in interface+-- files where we record a tag signature for bindings.+-- By putting the sig into it's own module we can avoid module loops.+module GHC.Stg.InferTags.TagSig++where++import GHC.Prelude++import GHC.Types.Var+import GHC.Utils.Outputable+import GHC.Utils.Binary+import GHC.Utils.Panic.Plain++data TagInfo+  = TagDunno            -- We don't know anything about the tag.+  | TagTuple [TagInfo]  -- Represents a function/thunk which when evaluated+                        -- will return a Unboxed tuple whos components have+                        -- the given TagInfos.+  | TagProper           -- Heap pointer to properly-tagged value+  | TagTagged           -- Bottom of the domain.+  deriving (Eq)++instance Outputable TagInfo where+  ppr TagTagged      = text "TagTagged"+  ppr TagDunno       = text "TagDunno"+  ppr TagProper      = text "TagProper"+  ppr (TagTuple tis) = text "TagTuple" <> brackets (pprWithCommas ppr tis)++instance Binary TagInfo where+  put_ bh TagDunno  = putByte bh 1+  put_ bh (TagTuple flds) = putByte bh 2 >> put_ bh flds+  put_ bh TagProper = putByte bh 3+  put_ bh TagTagged = putByte bh 4++  get bh = do tag <- getByte bh+              case tag of 1 -> return TagDunno+                          2 -> TagTuple <$> get bh+                          3 -> return TagProper+                          4 -> return TagTagged+                          _ -> panic ("get TagInfo " ++ show tag)++newtype TagSig  -- The signature for each binding, this is a newtype as we might+                -- want to track more information in the future.+  = TagSig TagInfo+  deriving (Eq)++instance Outputable TagSig where+  ppr (TagSig ti) = char '<' <> ppr ti <> char '>'+instance OutputableBndr (Id,TagSig) where+  pprInfixOcc  = ppr+  pprPrefixOcc = ppr++instance Binary TagSig where+  put_ bh (TagSig sig) = put_ bh sig+  get bh = pure TagSig <*> get bh++isTaggedSig :: TagSig -> Bool+isTaggedSig (TagSig TagProper) = True+isTaggedSig (TagSig TagTagged) = True+isTaggedSig _ = False
+ GHC/Stg/InferTags/Types.hs view
@@ -0,0 +1,137 @@+{-# LANGUAGE TypeFamilies, DataKinds, GADTs, FlexibleInstances #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}++{-# LANGUAGE UndecidableInstances #-}+ -- To permit: type instance XLet 'InferTaggedBinders = XLet 'CodeGen++module GHC.Stg.InferTags.Types+    ( module GHC.Stg.InferTags.Types+    , module TagSig)+where++import GHC.Prelude++import GHC.Core.DataCon+import GHC.Core.Type (isUnliftedType)+import GHC.Types.Id+import GHC.Stg.Syntax+import GHC.Stg.InferTags.TagSig as TagSig+import GHC.Types.Var.Env+import GHC.Utils.Outputable+import GHC.Utils.Misc( zipWithEqual )+import GHC.Utils.Panic++import GHC.StgToCmm.Types++{- *********************************************************************+*                                                                      *+                         Supporting data types+*                                                                      *+********************************************************************* -}++type instance BinderP      'InferTaggedBinders = (Id, TagSig)+type instance XLet         'InferTaggedBinders = XLet         'CodeGen+type instance XLetNoEscape 'InferTaggedBinders = XLetNoEscape 'CodeGen+type instance XRhsClosure  'InferTaggedBinders = XRhsClosure  'CodeGen++type InferStgTopBinding = GenStgTopBinding 'InferTaggedBinders+type InferStgBinding    = GenStgBinding    'InferTaggedBinders+type InferStgExpr       = GenStgExpr       'InferTaggedBinders+type InferStgRhs        = GenStgRhs        'InferTaggedBinders+type InferStgAlt        = GenStgAlt        'InferTaggedBinders++combineAltInfo :: TagInfo -> TagInfo -> TagInfo+combineAltInfo TagDunno         _              = TagDunno+combineAltInfo _                TagDunno       = TagDunno+combineAltInfo (TagTuple {})    TagProper      = panic "Combining unboxed tuple with non-tuple result"+combineAltInfo TagProper       (TagTuple {})   = panic "Combining unboxed tuple with non-tuple result"+combineAltInfo TagProper        TagProper      = TagProper+combineAltInfo (TagTuple is1)  (TagTuple is2)  = TagTuple (zipWithEqual "combineAltInfo" combineAltInfo is1 is2)+combineAltInfo (TagTagged)      ti             = ti+combineAltInfo ti               TagTagged      = ti++type TagSigEnv = IdEnv TagSig+data TagEnv p = TE { te_env :: TagSigEnv+                   , te_get :: BinderP p -> Id+                   }++instance Outputable (TagEnv p) where+    ppr te = ppr (te_env te)+++getBinderId :: TagEnv p -> BinderP p -> Id+getBinderId = te_get++initEnv :: TagEnv 'CodeGen+initEnv = TE { te_env = emptyVarEnv+             , te_get = \x -> x}++-- | Simple convert env to a env of the 'InferTaggedBinders pass+-- with no other changes.+makeTagged :: TagEnv p -> TagEnv 'InferTaggedBinders+makeTagged env = TE { te_env = te_env env+                    , te_get = fst }++noSig :: TagEnv p -> BinderP p -> (Id, TagSig)+noSig env bndr+  | isUnliftedType (idType var) = (var, TagSig TagProper)+  | otherwise = (var, TagSig TagDunno)+  where+    var = getBinderId env bndr++lookupSig :: TagEnv p -> Id -> Maybe TagSig+lookupSig env fun = lookupVarEnv (te_env env) fun++lookupInfo :: TagEnv p -> StgArg -> TagInfo+lookupInfo env (StgVarArg var)+  -- Nullary data constructors like True, False+  | Just dc <- isDataConWorkId_maybe var+  , isNullaryRepDataCon dc+  = TagProper++  | isUnliftedType (idType var)+  = TagProper++  -- Variables in the environment.+  | Just (TagSig info) <- lookupVarEnv (te_env env) var+  = info++  | Just lf_info <- idLFInfo_maybe var+  =   case lf_info of+          -- Function, tagged (with arity)+          LFReEntrant {}+              -> TagProper+          -- Thunks need to be entered.+          LFThunk {}+              -> TagDunno+          -- Constructors, already tagged.+          LFCon {}+              -> TagProper+          LFUnknown {}+              -> TagDunno+          LFUnlifted {}+              -> TagProper+          -- Shouldn't be possible. I don't think we can export letNoEscapes+          LFLetNoEscape {} -> panic "LFLetNoEscape exported"++  | otherwise+  = TagDunno++lookupInfo _ (StgLitArg {})+  = TagProper++isDunnoSig :: TagSig -> Bool+isDunnoSig (TagSig TagDunno) = True+isDunnoSig (TagSig TagProper) = False+isDunnoSig (TagSig TagTuple{}) = False+isDunnoSig (TagSig TagTagged{}) = False++isTaggedInfo :: TagInfo -> Bool+isTaggedInfo TagProper = True+isTaggedInfo TagTagged = True+isTaggedInfo _         = False++extendSigEnv :: TagEnv p -> [(Id,TagSig)] -> TagEnv p+extendSigEnv env@(TE { te_env = sig_env }) bndrs+  = env { te_env = extendVarEnvList sig_env bndrs }
GHC/Stg/Lift.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE CPP #-} + -- | Implements a selective lambda lifter, running late in the optimisation -- pipeline. --@@ -11,24 +11,23 @@    (     -- * Late lambda lifting in STG     -- $note+   StgLiftConfig (..),    stgLiftLams    ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Types.Basic-import GHC.Driver.Session import GHC.Types.Id import GHC.Stg.FVs ( annBindingFreeVars )+import GHC.Stg.Lift.Config import GHC.Stg.Lift.Analysis import GHC.Stg.Lift.Monad import GHC.Stg.Syntax-import GHC.Utils.Outputable+import GHC.Unit.Module (Module) import GHC.Types.Unique.Supply-import GHC.Utils.Misc+import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Types.Var.Set import Control.Monad ( when )@@ -127,17 +126,17 @@ -- -- (Mostly) textbook instance of the lambda lifting transformation, selecting -- which bindings to lambda lift by consulting 'goodToLift'.-stgLiftLams :: DynFlags -> UniqSupply -> [InStgTopBinding] -> [OutStgTopBinding]-stgLiftLams dflags us = runLiftM dflags us . foldr liftTopLvl (pure ())+stgLiftLams :: Module -> StgLiftConfig -> UniqSupply -> [InStgTopBinding] -> [OutStgTopBinding]+stgLiftLams this_mod cfg us = runLiftM cfg us . foldr (liftTopLvl this_mod) (pure ()) -liftTopLvl :: InStgTopBinding -> LiftM () -> LiftM ()-liftTopLvl (StgTopStringLit bndr lit) rest = withSubstBndr bndr $ \bndr' -> do+liftTopLvl :: Module -> InStgTopBinding -> LiftM () -> LiftM ()+liftTopLvl _ (StgTopStringLit bndr lit) rest = withSubstBndr bndr $ \bndr' -> do   addTopStringLit bndr' lit   rest-liftTopLvl (StgTopLifted bind) rest = do+liftTopLvl this_mod (StgTopLifted bind) rest = do   let is_rec = isRec $ fst $ decomposeStgBinding bind   when is_rec startBindingGroup-  let bind_w_fvs = annBindingFreeVars bind+  let bind_w_fvs = annBindingFreeVars this_mod bind   withLiftedBind TopLevel (tagSkeletonTopBind bind_w_fvs) NilSk $ \mb_bind' -> do     -- We signal lifting of a binding through returning Nothing.     -- Should never happen for a top-level binding, though, since we are already@@ -170,8 +169,8 @@   let (infos, rhss) = unzip pairs   let bndrs = map binderInfoBndr infos   expander <- liftedIdsExpander-  dflags <- getDynFlags-  case goodToLift dflags top rec expander pairs scope of+  cfg <- getConfig+  case goodToLift cfg top rec expander pairs scope of     -- @abs_ids@ is the set of all variables that need to become parameters.     Just abs_ids -> withLiftedBndrs abs_ids bndrs $ \bndrs' -> do       -- Within this block, all binders in @bndrs@ will be noted as lifted, so@@ -200,7 +199,9 @@   -> LlStgRhs   -> LiftM OutStgRhs liftRhs mb_former_fvs rhs@(StgRhsCon ccs con mn ts args)-  = ASSERT2(isNothing mb_former_fvs, text "Should never lift a constructor" $$ pprStgRhs panicStgPprOpts rhs)+  = assertPpr (isNothing mb_former_fvs)+              (text "Should never lift a constructor"+               $$ pprStgRhs panicStgPprOpts rhs) $     StgRhsCon ccs con mn ts <$> traverse liftArgs args liftRhs Nothing (StgRhsClosure _ ccs upd infos body) =   -- This RHS wasn't lifted.@@ -215,7 +216,7 @@ liftArgs :: InStgArg -> LiftM OutStgArg liftArgs a@(StgLitArg _) = pure a liftArgs (StgVarArg occ) = do-  ASSERTM2( not <$> isLifted occ, text "StgArgs should never be lifted" $$ ppr occ )+  assertPprM (not <$> isLifted occ) (text "StgArgs should never be lifted" $$ ppr occ)   StgVarArg <$> substOcc occ  liftExpr :: LlStgExpr -> LiftM OutStgExpr@@ -248,5 +249,7 @@         Just bind' -> pure (StgLetNoEscape noExtFieldSilent bind' body')  liftAlt :: LlStgAlt -> LiftM OutStgAlt-liftAlt (con, infos, rhs) = withSubstBndrs (map binderInfoBndr infos) $ \bndrs' ->-  (,,) con bndrs' <$> liftExpr rhs+liftAlt alt@GenStgAlt{alt_con=_, alt_bndrs=infos, alt_rhs=rhs} =+  withSubstBndrs (map binderInfoBndr infos) $ \bndrs' ->+    do !rhs' <- liftExpr rhs+       return $! alt {alt_bndrs = bndrs', alt_rhs = rhs'}
GHC/Stg/Lift/Analysis.hs view
@@ -26,9 +26,9 @@  import GHC.Types.Basic import GHC.Types.Demand-import GHC.Driver.Session import GHC.Types.Id import GHC.Runtime.Heap.Layout ( WordOff )+import GHC.Stg.Lift.Config import GHC.Stg.Syntax import qualified GHC.StgToCmm.ArgRep  as StgToCmm.ArgRep import qualified GHC.StgToCmm.Closure as StgToCmm.Closure@@ -114,7 +114,6 @@ type instance XRhsClosure  'LiftLams = DIdSet type instance XLet         'LiftLams = Skeleton type instance XLetNoEscape 'LiftLams = Skeleton-type instance XConApp      'LiftLams = ConstructorNumber   -- | Captures details of the syntax tree relevant to the cost model, such as@@ -334,8 +333,8 @@     n :* cd = idDemandInfo bndr  tagSkeletonAlt :: CgStgAlt -> (Skeleton, IdSet, LlStgAlt)-tagSkeletonAlt (con, bndrs, rhs)-  = (alt_skel, arg_occs, (con, map BoringBinder bndrs, rhs'))+tagSkeletonAlt old@GenStgAlt{alt_con=_, alt_bndrs=bndrs, alt_rhs=rhs}+  = (alt_skel, arg_occs, old {alt_bndrs=fmap BoringBinder bndrs, alt_rhs=rhs'})   where     (alt_skel, alt_arg_occs, rhs') = tagSkeletonExpr rhs     arg_occs = alt_arg_occs `delVarSetList` bndrs@@ -343,7 +342,7 @@ -- | Combines several heuristics to decide whether to lambda-lift a given -- @let@-binding to top-level. See "GHC.Stg.Lift.Analysis#when" for details. goodToLift-  :: DynFlags+  :: StgLiftConfig   -> TopLevelFlag   -> RecFlag   -> (DIdSet -> DIdSet) -- ^ An expander function, turning 'InId's into@@ -353,7 +352,7 @@   -> Maybe DIdSet       -- ^ @Just abs_ids@ <=> This binding is beneficial to                         -- lift and @abs_ids@ are the variables it would                         -- abstract over-goodToLift dflags top_lvl rec_flag expander pairs scope = decide+goodToLift cfg top_lvl rec_flag expander pairs scope = decide   [ ("top-level", isTopLevel top_lvl) -- keep in sync with Note [When to lift]   , ("memoized", any_memoized)   , ("argument occurrences", arg_occs)@@ -363,7 +362,7 @@   , ("args spill on stack", args_spill_on_stack)   , ("increases allocation", inc_allocs)   ] where-      profile  = targetProfile dflags+      profile  = c_targetProfile cfg       platform = profilePlatform profile       decide deciders         | not (fancy_or deciders)@@ -432,7 +431,7 @@       -- idArity f > 0 ==> known       known_fun id = idArity id > 0       abstracts_known_local_fun-        = not (liftLamsKnown dflags) && any known_fun (dVarSetElems abs_ids)+        = not (c_liftLamsKnown cfg) && any known_fun (dVarSetElems abs_ids)        -- Number of arguments of a RHS in the current binding group if we decide       -- to lift it@@ -442,8 +441,8 @@         . (dVarSetElems abs_ids ++)         . rhsLambdaBndrs       max_n_args-        | isRec rec_flag = liftLamsRecArgs dflags-        | otherwise      = liftLamsNonRecArgs dflags+        | isRec rec_flag = c_liftLamsRecArgs cfg+        | otherwise      = c_liftLamsNonRecArgs cfg       -- We have 5 hardware registers on x86_64 to pass arguments in. Any excess       -- args are passed on the stack, which means slow memory accesses       args_spill_on_stack
+ GHC/Stg/Lift/Config.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE TypeFamilies #-}++-- | Configuration options for Lift the lambda lifter.+module GHC.Stg.Lift.Config (+    StgLiftConfig (..),+  ) where++import GHC.Prelude++import GHC.Platform.Profile++data StgLiftConfig = StgLiftConfig+  { c_targetProfile         :: !Profile+  , c_liftLamsRecArgs       :: !(Maybe Int)+  -- ^ Maximum number of arguments after lambda lifting a recursive function.+  , c_liftLamsNonRecArgs    :: !(Maybe Int)+  -- ^ Maximum number of arguments after lambda lifting non-recursive function.+  , c_liftLamsKnown         :: !Bool+  -- ^ Lambda lift even when this turns a known call into an unknown call.+  }+  deriving (Show, Read, Eq, Ord)
GHC/Stg/Lift/Monad.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeFamilies #-} @@ -12,6 +12,8 @@     FloatLang (..), collectFloats, -- Exported just for the docs     -- * Transformation monad     LiftM, runLiftM,+    -- ** Get config+    getConfig,     -- ** Adding bindings     startBindingGroup, endBindingGroup, addTopStringLit, addLiftedBinding,     -- ** Substitution and binders@@ -20,24 +22,24 @@     substOcc, isLifted, formerFreeVars, liftedIdsExpander   ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Types.Basic import GHC.Types.CostCentre ( isCurrentCCS, dontCareCCS )-import GHC.Driver.Session import GHC.Data.FastString import GHC.Types.Id import GHC.Types.Name import GHC.Utils.Outputable import GHC.Data.OrdList++import GHC.Stg.Lift.Config import GHC.Stg.Subst import GHC.Stg.Syntax+ import GHC.Core.Utils import GHC.Types.Unique.Supply-import GHC.Utils.Misc import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Types.Var.Env import GHC.Types.Var.Set import GHC.Core.Multiplicity@@ -61,7 +63,7 @@ -- | Environment threaded around in a scoped, @Reader@-like fashion. data Env   = Env-  { e_dflags     :: !DynFlags+  { e_config     :: StgLiftConfig   -- ^ Read-only.   , e_subst      :: !Subst   -- ^ We need to track the renamings of local 'InId's to their lifted 'OutId',@@ -84,8 +86,12 @@   -- Invariant: 'Id's not present in this map won't be substituted.   } -emptyEnv :: DynFlags -> Env-emptyEnv dflags = Env dflags emptySubst emptyVarEnv+emptyEnv :: StgLiftConfig -> Env+emptyEnv cfg = Env+  { e_config = cfg+  , e_subst = emptySubst+  , e_expansions = emptyVarEnv+  }   -- Note [Handling floats]@@ -183,7 +189,7 @@      map_rhss f = uncurry mkStgBinding . second (map (second f)) . decomposeStgBinding     rm_cccs = map_rhss removeRhsCCCS-    merge_binds binds = ASSERT( any is_rec binds )+    merge_binds binds = assert (any is_rec binds) $                         StgRec (concatMap (snd . decomposeStgBinding . rm_cccs) binds)     is_rec StgRec{} = True     is_rec _ = False@@ -202,8 +208,8 @@ -- | The analysis monad consists of the following 'RWST' components: -- --     * 'Env': Reader-like context. Contains a substitution, info about how---       how lifted identifiers are to be expanded into applications and details---       such as 'DynFlags'.+--       how lifted identifiers are to be expanded into applications and+--       configuration options. -- --     * @'OrdList' 'FloatLang'@: Writer output for the resulting STG program. --@@ -216,18 +222,18 @@   = LiftM { unwrapLiftM :: RWST Env (OrdList FloatLang) () UniqSM a }   deriving (Functor, Applicative, Monad) -instance HasDynFlags LiftM where-  getDynFlags = LiftM (RWS.asks e_dflags)- instance MonadUnique LiftM where   getUniqueSupplyM = LiftM (lift getUniqueSupplyM)   getUniqueM = LiftM (lift getUniqueM)   getUniquesM = LiftM (lift getUniquesM) -runLiftM :: DynFlags -> UniqSupply -> LiftM () -> [OutStgTopBinding]-runLiftM dflags us (LiftM m) = collectFloats (fromOL floats)+runLiftM :: StgLiftConfig -> UniqSupply -> LiftM () -> [OutStgTopBinding]+runLiftM cfg us (LiftM m) = collectFloats (fromOL floats)   where-    (_, _, floats) = initUs_ us (runRWST m (emptyEnv dflags) ())+    (_, _, floats) = initUs_ us (runRWST m (emptyEnv cfg) ())++getConfig :: LiftM StgLiftConfig+getConfig = LiftM $ e_config <$> RWS.ask  -- | Writes a plain 'StgTopStringLit' to the output. addTopStringLit :: OutId -> ByteString -> LiftM ()
GHC/Stg/Lint.hs view
@@ -30,6 +30,56 @@ Since then there were some attempts at enabling it again, as summarised in #14787. It's finally decided that we remove all type checking and only look for basic properties listed above.++Note [Linting StgApp]+~~~~~~~~~~~~~~~~~~~~~+To lint an application of the form `f a_1 ... a_n`, we check that+the representations of the arguments `a_1`, ..., `a_n` match those+that the function expects.++More precisely, suppose the types in the application `f a_1 ... a_n`+are as follows:++  f :: t_1 -> ... -> t_n -> res+  a_1 :: s_1, ..., a_n :: s_n++  t_1 :: TYPE r_1, ..., t_n :: TYPE r_n+  s_1 :: TYPE p_1, ..., a_n :: TYPE p_n++Then we must check that each r_i is compatible with s_i. Compatibility+is weaker than on-the-nose equality: for example, IntRep and WordRep are+compatible. See Note [Bad unsafe coercion] in GHC.Core.Lint.++Wrinkle: it can sometimes happen that an argument type in the type of+the function does not have a fixed runtime representation, i.e.+there is an r_i such that runtimeRepPrimRep r_i crashes.+See https://gitlab.haskell.org/ghc/ghc/-/issues/21399 for an example.+Fixing this issue would require significant changes to the type system+of STG, so for now we simply skip the Lint check when we detect such+representation-polymorphic situations.++Note [Typing the STG language]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In Core, programs must be /well-typed/.  So if f :: ty1 -> ty2,+then in the application (f e), we must have  e :: ty1++STG is still a statically typed language, but the type system+is much coarser. In particular, STG programs must be /well-kinded/.+More precisely, if f :: ty1 -> ty2, then in the application (f e)+where e :: ty1', we must have kind(ty1) = kind(ty1').++So the STG type system does not distinguish beteen Int and Bool,+but it /does/ distinguish beteen Int and Int#, because they have+different kinds.  Actually, since all terms have kind (TYPE rep),+we might say that the STG language is well-runtime-rep'd.++This coarser type system makes fewer distinctions, and that allows+many nonsensical programs (such as ('x' && "foo")) -- but all type+systems accept buggy programs!  But the coarseness also permits+some optimisations that are ill-typed in Core.  For example, see+the module STG.CSE, which is all about doing CSE in STG that would+be ill-typed in Core.  But it must still be well-kinded!+ -}  {-# LANGUAGE ScopedTypeVariables, FlexibleContexts, TypeFamilies,@@ -40,32 +90,46 @@ import GHC.Prelude  import GHC.Stg.Syntax+import GHC.Stg.Utils -import GHC.Driver.Session import GHC.Core.Lint        ( interactiveInScope )-import GHC.Data.Bag         ( Bag, emptyBag, isEmptyBag, snocBag, bagToList )-import GHC.Types.Basic      ( TopLevelFlag(..), isTopLevel )+import GHC.Core.DataCon+import GHC.Core             ( AltCon(..) )+import GHC.Core.Type++import GHC.Types.Basic      ( TopLevelFlag(..), isTopLevel, isMarkedCbv ) import GHC.Types.CostCentre ( isCurrentCCS )+import GHC.Types.Error      ( DiagnosticReason(WarningWithoutFlag) ) import GHC.Types.Id import GHC.Types.Var.Set-import GHC.Core.DataCon-import GHC.Core             ( AltCon(..) ) import GHC.Types.Name       ( getSrcLoc, nameIsLocalOrFrom )-import GHC.Utils.Error      ( Severity(..), mkLocMessage )-import GHC.Core.Type import GHC.Types.RepType import GHC.Types.SrcLoc+ import GHC.Utils.Logger import GHC.Utils.Outputable+import GHC.Utils.Error      ( mkLocMessage, DiagOpts )+import qualified GHC.Utils.Error as Err+ import GHC.Unit.Module            ( Module ) import GHC.Runtime.Context        ( InteractiveContext )-import qualified GHC.Utils.Error as Err++import GHC.Data.Bag         ( Bag, emptyBag, isEmptyBag, snocBag, bagToList )+ import Control.Applicative ((<|>)) import Control.Monad+import Data.Maybe+import GHC.Utils.Misc+import GHC.Core.Multiplicity (scaledThing)+import GHC.Settings (Platform)+import GHC.Core.TyCon (primRepCompatible)+import GHC.Utils.Panic.Plain (panic)  lintStgTopBindings :: forall a . (OutputablePass a, BinderP a ~ Id)-                   => Logger-                   -> DynFlags+                   => Platform+                   -> Logger+                   -> DiagOpts+                   -> StgPprOpts                    -> InteractiveContext                    -> Module -- ^ module being compiled                    -> Bool   -- ^ have we run Unarise yet?@@ -73,13 +137,13 @@                    -> [GenStgTopBinding a]                    -> IO () -lintStgTopBindings logger dflags ictxt this_mod unarised whodunnit binds+lintStgTopBindings platform logger diag_opts opts ictxt this_mod unarised whodunnit binds   = {-# SCC "StgLint" #-}-    case initL this_mod unarised opts top_level_binds (lint_binds binds) of+    case initL platform diag_opts this_mod unarised opts top_level_binds (lint_binds binds) of       Nothing  ->         return ()       Just msg -> do-        putLogMsg logger dflags NoReason Err.SevDump noSrcSpan+        logMsg logger Err.MCDump noSrcSpan           $ withPprStyle defaultDumpStyle           (vcat [ text "*** Stg Lint ErrMsgs: in" <+>                         text whodunnit <+> text "***",@@ -87,9 +151,8 @@                   text "*** Offending Program ***",                   pprGenStgTopBindings opts binds,                   text "*** End of Offense ***"])-        Err.ghcExit logger dflags 1+        Err.ghcExit logger 1   where-    opts = initStgPprOpts dflags     -- Bring all top-level binds into scope because CoreToStg does not generate     -- bindings in dependency order (so we may see a use before its definition).     top_level_binds = extendVarSetList (mkVarSet (bindersOfTopBinds binds))@@ -172,10 +235,13 @@         lintStgExpr expr  lintStgRhs rhs@(StgRhsCon _ con _ _ args) = do+    opts <- getStgPprOpts     when (isUnboxedTupleDataCon con || isUnboxedSumDataCon con) $ do-      opts <- getStgPprOpts       addErrL (text "StgRhsCon is an unboxed tuple or sum application" $$                pprStgRhs opts rhs)++    lintConApp con args (pprStgRhs opts rhs)+     mapM_ lintStgArg args     mapM_ checkPostUnariseConArg args @@ -183,17 +249,23 @@  lintStgExpr (StgLit _) = return () -lintStgExpr (StgApp fun args) = do-    lintStgVar fun-    mapM_ lintStgArg args+lintStgExpr e@(StgApp fun args) = do+  lintStgVar fun+  mapM_ lintStgArg args +  lintAppCbvMarks e+  lintStgAppReps fun args+ lintStgExpr app@(StgConApp con _n args _arg_tys) = do     -- unboxed sums should vanish during unarise     lf <- getLintFlags+    opts <- getStgPprOpts     when (lf_unarised lf && isUnboxedSumDataCon con) $ do-      opts <- getStgPprOpts       addErrL (text "Unboxed sum after unarise:" $$                pprStgExpr opts app)++    lintConApp con args (pprStgExpr opts app)+     mapM_ lintStgArg args     mapM_ checkPostUnariseConArg args @@ -224,18 +296,100 @@  lintAlt     :: (OutputablePass a, BinderP a ~ Id)-    => (AltCon, [Id], GenStgExpr a) -> LintM ()+    => GenStgAlt a -> LintM () -lintAlt (DEFAULT, _, rhs) =-    lintStgExpr rhs+lintAlt GenStgAlt{ alt_con   = DEFAULT+                 , alt_bndrs = _+                 , alt_rhs   = rhs} = lintStgExpr rhs -lintAlt (LitAlt _, _, rhs) =-    lintStgExpr rhs+lintAlt GenStgAlt{ alt_con   = LitAlt _+                 , alt_bndrs = _+                 , alt_rhs   = rhs} = lintStgExpr rhs -lintAlt (DataAlt _, bndrs, rhs) = do+lintAlt GenStgAlt{ alt_con   = DataAlt _+                 , alt_bndrs = bndrs+                 , alt_rhs   = rhs} =+  do     mapM_ checkPostUnariseBndr bndrs     addInScopeVars bndrs (lintStgExpr rhs) +-- Post unarise check we apply constructors to the right number of args.+-- This can be violated by invalid use of unsafeCoerce as showcased by test+-- T9208+lintConApp :: Foldable t => DataCon -> t a -> SDoc -> LintM ()+lintConApp con args app = do+    unarised <- lf_unarised <$> getLintFlags+    when (unarised &&+          not (isUnboxedTupleDataCon con) &&+          length (dataConRuntimeRepStrictness con) /= length args) $ do+      addErrL (text "Constructor applied to incorrect number of arguments:" $$+               text "Application:" <> app)++-- See Note [Linting StgApp]+-- See Note [Typing the STG language]+lintStgAppReps :: Id -> [StgArg] -> LintM ()+lintStgAppReps _fun [] = return ()+lintStgAppReps fun args = do+  lf <- getLintFlags+  let platform = lf_platform lf+      (fun_arg_tys, _res) = splitFunTys (idType fun)+      fun_arg_tys' = map (scaledThing ) fun_arg_tys :: [Type]+      fun_arg_tys_reps, actual_arg_reps :: [Maybe [PrimRep]]+      fun_arg_tys_reps = map typePrimRep_maybe fun_arg_tys'+      actual_arg_reps = map (typePrimRep_maybe . stgArgType) args++      match_args :: [Maybe [PrimRep]] -> [Maybe [PrimRep]] -> LintM ()+      -- Might be wrongly typed as polymorphic. See #21399+      match_args (Nothing:_) _   = return ()+      match_args (_) (Nothing:_) = return ()+      match_args (Just actual_rep:actual_reps_left) (Just expected_rep:expected_reps_left)+        -- Common case, reps are exactly the same+        | actual_rep == expected_rep+        = match_args actual_reps_left expected_reps_left++        -- Check for void rep which can be either an empty list *or* [VoidRep]+        | isVoidRep actual_rep && isVoidRep expected_rep+        = match_args actual_reps_left expected_reps_left++        -- Some reps are compatible *even* if they are not the same. E.g. IntRep and WordRep.+        -- We check for that here with primRepCompatible+        | and $ zipWith (primRepCompatible platform) actual_rep expected_rep+        = match_args actual_reps_left expected_reps_left++        | otherwise = addErrL $ hang (text "Function type reps and function argument reps missmatched") 2 $+            (text "In application " <> ppr fun <+> ppr args $$+              text "argument rep:" <> ppr actual_rep $$+              text "expected rep:" <> ppr expected_rep $$+              -- text "expected reps:" <> ppr arg_ty_reps $$+              text "unarised?:" <> ppr (lf_unarised lf))+        where+          isVoidRep [] = True+          isVoidRep [VoidRep] = True+          isVoidRep _ = False++          -- n_arg_ty_reps = length arg_ty_reps++      match_args _ _ = return () -- Functions are allowed to be over/under applied.++  match_args actual_arg_reps fun_arg_tys_reps++lintAppCbvMarks :: OutputablePass pass+                => GenStgExpr pass -> LintM ()+lintAppCbvMarks e@(StgApp fun args) = do+  lf <- getLintFlags+  when (lf_unarised lf) $ do+    -- A function which expects a unlifted argument as n'th argument+    -- always needs to be applied to n arguments.+    -- See Note [CBV Function Ids].+    let marks = fromMaybe [] $ idCbvMarks_maybe fun+    when (length (dropWhileEndLE (not . isMarkedCbv) marks) > length args) $ do+      addErrL $ hang (text "Undersatured cbv marked ID in App" <+> ppr e ) 2 $+        (text "marks" <> ppr marks $$+        text "args" <> ppr args $$+        text "arity" <> ppr (idArity fun) $$+        text "join_arity" <> ppr (isJoinId_maybe fun))+lintAppCbvMarks _ = panic "impossible - lintAppCbvMarks"+ {- ************************************************************************ *                                                                      *@@ -247,6 +401,7 @@ newtype LintM a = LintM     { unLintM :: Module               -> LintFlags+              -> DiagOpts          -- Diagnostic options               -> StgPprOpts        -- Pretty-printing options               -> [LintLocInfo]     -- Locations               -> IdSet             -- Local vars in scope@@ -256,6 +411,7 @@     deriving (Functor)  data LintFlags = LintFlags { lf_unarised :: !Bool+                           , lf_platform :: !Platform                              -- ^ have we run the unariser yet?                            } @@ -281,16 +437,16 @@     pp_binder b       = hsep [ppr b, dcolon, ppr (idType b)] -initL :: Module -> Bool -> StgPprOpts -> IdSet -> LintM a -> Maybe SDoc-initL this_mod unarised opts locals (LintM m) = do-  let (_, errs) = m this_mod (LintFlags unarised) opts [] locals emptyBag+initL :: Platform -> DiagOpts -> Module -> Bool -> StgPprOpts -> IdSet -> LintM a -> Maybe SDoc+initL platform diag_opts this_mod unarised opts locals (LintM m) = do+  let (_, errs) = m this_mod (LintFlags unarised platform) diag_opts opts [] locals emptyBag   if isEmptyBag errs then       Nothing   else       Just (vcat (punctuate blankLine (bagToList errs)))  instance Applicative LintM where-      pure a = LintM $ \_mod _lf _opts _loc _scope errs -> (a, errs)+      pure a = LintM $ \_mod _lf _df _opts _loc _scope errs -> (a, errs)       (<*>) = ap       (*>)  = thenL_ @@ -299,14 +455,14 @@     (>>)  = (*>)  thenL :: LintM a -> (a -> LintM b) -> LintM b-thenL m k = LintM $ \mod lf opts loc scope errs-  -> case unLintM m mod lf opts loc scope errs of-      (r, errs') -> unLintM (k r) mod lf opts loc scope errs'+thenL m k = LintM $ \mod lf diag_opts opts loc scope errs+  -> case unLintM m mod lf diag_opts opts loc scope errs of+      (r, errs') -> unLintM (k r) mod lf diag_opts opts loc scope errs'  thenL_ :: LintM a -> LintM b -> LintM b-thenL_ m k = LintM $ \mod lf opts loc scope errs-  -> case unLintM m mod lf opts loc scope errs of-      (_, errs') -> unLintM k mod lf opts loc scope errs'+thenL_ m k = LintM $ \mod lf diag_opts opts loc scope errs+  -> case unLintM m mod lf diag_opts opts loc scope errs of+      (_, errs') -> unLintM k mod lf diag_opts opts loc scope errs'  checkL :: Bool -> SDoc -> LintM () checkL True  _   = return ()@@ -346,42 +502,43 @@       is_sum, is_tuple, is_void :: Maybe String       is_sum = guard (isUnboxedSumType id_ty) >> return "unboxed sum"       is_tuple = guard (isUnboxedTupleType id_ty) >> return "unboxed tuple"-      is_void = guard (isVoidTy id_ty) >> return "void"+      is_void = guard (isZeroBitTy id_ty) >> return "void"     in       is_sum <|> is_tuple <|> is_void  addErrL :: SDoc -> LintM ()-addErrL msg = LintM $ \_mod _lf _opts loc _scope errs -> ((), addErr errs msg loc)+addErrL msg = LintM $ \_mod _lf df _opts loc _scope errs -> ((), addErr df errs msg loc) -addErr :: Bag SDoc -> SDoc -> [LintLocInfo] -> Bag SDoc-addErr errs_so_far msg locs+addErr :: DiagOpts -> Bag SDoc -> SDoc -> [LintLocInfo] -> Bag SDoc+addErr diag_opts errs_so_far msg locs   = errs_so_far `snocBag` mk_msg locs   where     mk_msg (loc:_) = let (l,hdr) = dumpLoc loc-                     in  mkLocMessage SevWarning l (hdr $$ msg)+                     in  mkLocMessage (Err.mkMCDiagnostic diag_opts WarningWithoutFlag)+                                      l (hdr $$ msg)     mk_msg []      = msg  addLoc :: LintLocInfo -> LintM a -> LintM a-addLoc extra_loc m = LintM $ \mod lf opts loc scope errs-   -> unLintM m mod lf opts (extra_loc:loc) scope errs+addLoc extra_loc m = LintM $ \mod lf diag_opts opts loc scope errs+   -> unLintM m mod lf diag_opts opts (extra_loc:loc) scope errs  addInScopeVars :: [Id] -> LintM a -> LintM a-addInScopeVars ids m = LintM $ \mod lf opts loc scope errs+addInScopeVars ids m = LintM $ \mod lf diag_opts opts loc scope errs  -> let         new_set = mkVarSet ids-    in unLintM m mod lf opts loc (scope `unionVarSet` new_set) errs+    in unLintM m mod lf diag_opts opts loc (scope `unionVarSet` new_set) errs  getLintFlags :: LintM LintFlags-getLintFlags = LintM $ \_mod lf _opts _loc _scope errs -> (lf, errs)+getLintFlags = LintM $ \_mod lf _df _opts _loc _scope errs -> (lf, errs)  getStgPprOpts :: LintM StgPprOpts-getStgPprOpts = LintM $ \_mod _lf opts _loc _scope errs -> (opts, errs)+getStgPprOpts = LintM $ \_mod _lf _df opts _loc _scope errs -> (opts, errs)  checkInScope :: Id -> LintM ()-checkInScope id = LintM $ \mod _lf _opts loc scope errs+checkInScope id = LintM $ \mod _lf diag_opts _opts loc scope errs  -> if nameIsLocalOrFrom mod (idName id) && not (id `elemVarSet` scope) then-        ((), addErr errs (hsep [ppr id, dcolon, ppr (idType id),-                                text "is out of scope"]) loc)+        ((), addErr diag_opts errs (hsep [ppr id, dcolon, ppr (idType id),+                                    text "is out of scope"]) loc)     else         ((), errs)
GHC/Stg/Pipeline.hs view
@@ -4,14 +4,16 @@ \section[SimplStg]{Driver for simplifying @STG@ programs} -} -{-# LANGUAGE CPP #-}+ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} -module GHC.Stg.Pipeline ( stg2stg ) where--#include "HsVersions.h"+module GHC.Stg.Pipeline+  ( StgPipelineOpts (..)+  , StgToDo (..)+  , stg2stg+  ) where  import GHC.Prelude @@ -19,47 +21,57 @@  import GHC.Stg.Lint     ( lintStgTopBindings ) import GHC.Stg.Stats    ( showStgStats )-import GHC.Stg.DepAnal  ( depSortStgPgm )+import GHC.Stg.FVs      ( depSortWithAnnotStgPgm ) import GHC.Stg.Unarise  ( unarise )+import GHC.Stg.BcPrep   ( bcPrep ) import GHC.Stg.CSE      ( stgCse )-import GHC.Stg.Lift     ( stgLiftLams )+import GHC.Stg.Lift     ( StgLiftConfig, stgLiftLams ) import GHC.Unit.Module ( Module ) import GHC.Runtime.Context ( InteractiveContext ) -import GHC.Driver.Session+import GHC.Driver.Flags (DumpFlag(..)) import GHC.Utils.Error import GHC.Types.Unique.Supply import GHC.Utils.Outputable-import GHC.Utils.Panic import GHC.Utils.Logger import Control.Monad import Control.Monad.IO.Class-import Control.Monad.Trans.State.Strict+import Control.Monad.Trans.Reader+import GHC.Settings (Platform) -newtype StgM a = StgM { _unStgM :: StateT Char IO a }+data StgPipelineOpts = StgPipelineOpts+  { stgPipeline_phases      :: ![StgToDo]+  -- ^ Spec of what stg-to-stg passes to do+  , stgPipeline_lint        :: !(Maybe DiagOpts)+  -- ^ Should we lint the STG at various stages of the pipeline?+  , stgPipeline_pprOpts     :: !StgPprOpts+  , stgPlatform             :: !Platform+  }++newtype StgM a = StgM { _unStgM :: ReaderT Char IO a }   deriving (Functor, Applicative, Monad, MonadIO)  instance MonadUnique StgM where-  getUniqueSupplyM = StgM $ do { mask <- get+  getUniqueSupplyM = StgM $ do { mask <- ask                                ; liftIO $! mkSplitUniqSupply mask}-  getUniqueM = StgM $ do { mask <- get+  getUniqueM = StgM $ do { mask <- ask                          ; liftIO $! uniqFromMask mask}  runStgM :: Char -> StgM a -> IO a-runStgM mask (StgM m) = evalStateT m mask+runStgM mask (StgM m) = runReaderT m mask  stg2stg :: Logger-        -> DynFlags                  -- includes spec of what stg-to-stg passes to do         -> InteractiveContext+        -> StgPipelineOpts         -> Module                    -- module being compiled         -> [StgTopBinding]           -- input program-        -> IO [StgTopBinding]        -- output program-stg2stg logger dflags ictxt this_mod binds+        -> IO [CgStgTopBinding]        -- output program+stg2stg logger ictxt opts this_mod binds   = do  { dump_when Opt_D_dump_stg_from_core "Initial STG:" binds-        ; showPass logger dflags "Stg2Stg"+        ; showPass logger "Stg2Stg"         -- Do the main business!         ; binds' <- runStgM 'g' $-            foldM do_stg_pass binds (getStgToDo dflags)+            foldM (do_stg_pass this_mod) binds (stgPipeline_phases opts)            -- Dependency sort the program as last thing. The program needs to be           -- in dependency order for the SRT algorithm to work (see@@ -69,52 +81,63 @@           -- dependency order. We also don't guarantee that StgLiftLams will           -- preserve the order or only create minimal recursive groups, so a           -- sorting pass is necessary.-        ; let binds_sorted = depSortStgPgm this_mod binds'-        ; return binds_sorted+          -- This pass will also augment each closure with non-global free variables+          -- annotations (which is used by code generator to compute offsets into closures)+        ; let binds_sorted_with_fvs = depSortWithAnnotStgPgm this_mod binds'+        ; return binds_sorted_with_fvs    }    where     stg_linter unarised-      | gopt Opt_DoStgLinting dflags-      = lintStgTopBindings logger dflags ictxt this_mod unarised+      | Just diag_opts <- stgPipeline_lint opts+      = lintStgTopBindings+          (stgPlatform opts) logger+          diag_opts ppr_opts+          ictxt this_mod unarised       | otherwise       = \ _whodunnit _binds -> return ()      --------------------------------------------    do_stg_pass :: [StgTopBinding] -> StgToDo -> StgM [StgTopBinding]-    do_stg_pass binds to_do+    do_stg_pass :: Module -> [StgTopBinding] -> StgToDo -> StgM [StgTopBinding]+    do_stg_pass this_mod binds to_do       = case to_do of           StgDoNothing ->             return binds            StgStats ->-            trace (showStgStats binds) (return binds)+            logTraceMsg logger "STG stats" (text (showStgStats binds)) (return binds)            StgCSE -> do             let binds' = {-# SCC "StgCse" #-} stgCse binds             end_pass "StgCse" binds' -          StgLiftLams -> do+          StgLiftLams cfg -> do             us <- getUniqueSupplyM-            let binds' = {-# SCC "StgLiftLams" #-} stgLiftLams dflags us binds+            --+            let binds' = {-# SCC "StgLiftLams" #-} stgLiftLams this_mod cfg us binds             end_pass "StgLiftLams" binds' +          StgBcPrep -> do+            us <- getUniqueSupplyM+            let binds' = {-# SCC "StgBcPrep" #-} bcPrep us binds+            end_pass "StgBcPrep" binds'+           StgUnarise -> do             us <- getUniqueSupplyM             liftIO (stg_linter False "Pre-unarise" binds)-            let binds' = unarise us binds+            let binds' = {-# SCC "StgUnarise" #-} unarise us binds             liftIO (dump_when Opt_D_dump_stg_unarised "Unarised STG:" binds')             liftIO (stg_linter True "Unarise" binds')             return binds' -    opts = initStgPprOpts dflags+    ppr_opts = stgPipeline_pprOpts opts     dump_when flag header binds-      = dumpIfSet_dyn logger dflags flag header FormatSTG (pprStgTopBindings opts binds)+      = putDumpFileMaybe logger flag header FormatSTG (pprStgTopBindings ppr_opts binds)      end_pass what binds2       = liftIO $ do -- report verbosely, if required-          dumpIfSet_dyn logger dflags Opt_D_verbose_stg2stg what-            FormatSTG (vcat (map (pprStgTopBinding opts) binds2))+          putDumpFileMaybe logger Opt_D_verbose_stg2stg what+            FormatSTG (vcat (map (pprStgTopBinding ppr_opts) binds2))           stg_linter False what binds2           return binds2 @@ -125,30 +148,14 @@ data StgToDo   = StgCSE   -- ^ Common subexpression elimination-  | StgLiftLams+  | StgLiftLams StgLiftConfig   -- ^ Lambda lifting closure variables, trading stack/register allocation for   -- heap allocation   | StgStats   | StgUnarise   -- ^ Mandatory unarise pass, desugaring unboxed tuple and sum binders+  | StgBcPrep+  -- ^ Mandatory when compiling to bytecode   | StgDoNothing   -- ^ Useful for building up 'getStgToDo'-  deriving Eq---- | Which Stg-to-Stg passes to run. Depends on flags, ways etc.-getStgToDo :: DynFlags -> [StgToDo]-getStgToDo dflags =-  filter (/= StgDoNothing)-    [ mandatory StgUnarise-    -- Important that unarisation comes first-    -- See Note [StgCse after unarisation] in GHC.Stg.CSE-    , optional Opt_StgCSE StgCSE-    , optional Opt_StgLiftLams StgLiftLams-    , optional Opt_StgStats StgStats-    ] where-      optional opt = runWhen (gopt opt dflags)-      mandatory = id--runWhen :: Bool -> StgToDo -> StgToDo-runWhen True todo = todo-runWhen _    _    = StgDoNothing+  deriving (Show, Read, Eq, Ord)
GHC/Stg/Stats.hs view
@@ -21,11 +21,9 @@ \end{enumerate} -} -{-# LANGUAGE CPP #-} -module GHC.Stg.Stats ( showStgStats ) where -#include "HsVersions.h"+module GHC.Stg.Stats ( showStgStats ) where  import GHC.Prelude @@ -148,7 +146,7 @@  statExpr (StgApp _ _)     = countOne Applications statExpr (StgLit _)       = countOne Literals-statExpr (StgConApp _ _ _ _)= countOne ConstructorApps+statExpr (StgConApp {})   = countOne ConstructorApps statExpr (StgOpApp _ _ _) = countOne PrimitiveApps statExpr (StgTick _ e)    = statExpr e @@ -166,5 +164,4 @@     stat_alts alts      `combineSE`     countOne StgCases   where-    stat_alts alts-        = combineSEs (map statExpr [ e | (_,_,e) <- alts ])+    stat_alts = combineSEs . fmap (statExpr . alt_rhs)
GHC/Stg/Subst.hs view
@@ -1,20 +1,17 @@-{-# LANGUAGE CPP #-} -module GHC.Stg.Subst where -#include "HsVersions.h"+module GHC.Stg.Subst where  import GHC.Prelude  import GHC.Types.Id import GHC.Types.Var.Env-import Control.Monad.Trans.State.Strict+import GHC.Utils.Monad.State.Strict  import GHC.Utils.Outputable import GHC.Utils.Misc import GHC.Utils.Panic--import GHC.Driver.Ppr+import GHC.Utils.Trace  -- | A renaming substitution from 'Id's to 'Id's. Like 'RnEnv2', but not -- maintaining pairs of substitutions. Like 'GHC.Core.Subst.Subst', but@@ -57,8 +54,7 @@   | not (isLocalId id) = id   | Just id' <- lookupVarEnv env id = id'   | Just id' <- lookupInScope in_scope id = id'-  | otherwise = WARN( True, text "StgSubst.lookupIdSubst" <+> ppr id $$ ppr in_scope)-                id+  | otherwise = warnPprTrace True "StgSubst.lookupIdSubst" (ppr id $$ ppr in_scope) id  -- | Substitutes an occurrence of an identifier for its counterpart recorded -- in the 'Subst'. Does not generate a debug warning if the identifier to@@ -80,5 +76,5 @@ -- holds after extending the substitution like this. extendSubst :: Id -> Id -> Subst -> Subst extendSubst id new_id (Subst in_scope env)-  = ASSERT2( new_id `elemInScopeSet` in_scope, ppr id <+> ppr new_id $$ ppr in_scope )+  = assertPpr (new_id `elemInScopeSet` in_scope) (ppr id <+> ppr new_id $$ ppr in_scope) $     Subst in_scope (extendVarEnv env id new_id)
GHC/Stg/Syntax.hs view
@@ -1,10 +1,10 @@-{-# LANGUAGE CPP                  #-} {-# LANGUAGE ConstraintKinds      #-} {-# LANGUAGE DataKinds            #-} {-# LANGUAGE DeriveDataTypeable   #-} {-# LANGUAGE FlexibleContexts     #-} {-# LANGUAGE LambdaCase           #-} {-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE NamedFieldPuns       #-} {-# LANGUAGE UndecidableInstances #-}  {-@@ -23,9 +23,9 @@         StgArg(..),          GenStgTopBinding(..), GenStgBinding(..), GenStgExpr(..), GenStgRhs(..),-        GenStgAlt, AltType(..),+        GenStgAlt(..), AltType(..), -        StgPass(..), BinderP, XRhsClosure, XLet, XLetNoEscape, XConApp,+        StgPass(..), BinderP, XRhsClosure, XLet, XLetNoEscape,         NoExtFieldSilent, noExtFieldSilent,         OutputablePass, @@ -39,6 +39,9 @@         -- a set of synonyms for the code gen parameterisation         CgStgTopBinding, CgStgBinding, CgStgExpr, CgStgRhs, CgStgAlt, +        -- Same for taggedness+        TgStgTopBinding, TgStgBinding, TgStgExpr, TgStgRhs, TgStgAlt,+         -- a set of synonyms for the lambda lifting parameterisation         LlStgTopBinding, LlStgBinding, LlStgExpr, LlStgRhs, LlStgAlt, @@ -53,20 +56,16 @@         stgRhsArity, freeVarsOfRhs,         isDllConApp,         stgArgType,-        stripStgTicksTop, stripStgTicksTopE,         stgCaseBndrInScope,-        bindersOf, bindersOfTop, bindersOfTopBinds,          -- ppr-        StgPprOpts(..), initStgPprOpts,+        StgPprOpts(..),         panicStgPprOpts, shortStgPprOpts,         pprStgArg, pprStgExpr, pprStgRhs, pprStgBinding,         pprGenStgTopBinding, pprStgTopBinding,         pprGenStgTopBindings, pprStgTopBindings     ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Core     ( AltCon )@@ -75,7 +74,6 @@ import Data.Data   ( Data ) import Data.List   ( intersperse ) import GHC.Core.DataCon-import GHC.Driver.Session import GHC.Types.ForeignCall ( ForeignCall ) import GHC.Types.Id import GHC.Types.Name        ( isDynLinkName )@@ -90,8 +88,7 @@ import GHC.Core.TyCon    ( PrimRep(..), TyCon ) import GHC.Core.Type     ( Type ) import GHC.Types.RepType ( typePrimRep1 )-import GHC.Utils.Misc-import GHC.Utils.Panic+import GHC.Utils.Panic.Plain  {- ************************************************************************@@ -130,14 +127,19 @@ -- | Does this constructor application refer to anything in a different -- *Windows* DLL? -- If so, we can't allocate it statically-isDllConApp :: DynFlags -> Module -> DataCon -> [StgArg] -> Bool-isDllConApp dflags this_mod con args- | not (gopt Opt_ExternalDynamicRefs dflags) = False+isDllConApp+  :: Platform+  -> Bool          -- is Opt_ExternalDynamicRefs enabled?+  -> Module+  -> DataCon+  -> [StgArg]+  -> Bool+isDllConApp platform ext_dyn_refs this_mod con args+ | not ext_dyn_refs    = False  | platformOS platform == OSMinGW32     = isDynLinkName platform this_mod (dataConName con) || any is_dll_arg args  | otherwise = False   where-    platform = targetPlatform dflags     -- NB: typePrimRep1 is legit because any free variables won't have     -- unlifted type (there are no unlifted things at top level)     is_dll_arg :: StgArg -> Bool@@ -175,19 +177,6 @@ stgArgType (StgVarArg v)   = idType v stgArgType (StgLitArg lit) = literalType lit ---- | Strip ticks of a given type from an STG expression.-stripStgTicksTop :: (StgTickish -> Bool) -> GenStgExpr p -> ([StgTickish], GenStgExpr p)-stripStgTicksTop p = go []-   where go ts (StgTick t e) | p t = go (t:ts) e-         go ts other               = (reverse ts, other)---- | Strip ticks of a given type from an STG expression returning only the expression.-stripStgTicksTopE :: (StgTickish -> Bool) -> GenStgExpr p -> GenStgExpr p-stripStgTicksTopE p = go-   where go (StgTick t e) | p t = go e-         go other               = other- -- | Given an alt type and whether the program is unarised, return whether the -- case binder is in scope. --@@ -246,7 +235,7 @@         -- StgConApp is vital for returning unboxed tuples or sums         -- which can't be let-bound   | StgConApp   DataCon-                (XConApp pass)+                ConstructorNumber                 [StgArg] -- Saturated                 [Type]   -- See Note [Types in StgConApp] in GHC.Stg.Unarise @@ -425,36 +414,6 @@         [StgTickish]         [StgArg]        -- Args -{--Note Stg Passes-~~~~~~~~~~~~~~~-Here is a short summary of the STG pipeline and where we use the different-StgPass data type indexes:--  1. CoreToStg.Prep performs several transformations that prepare the desugared-     and simplified core to be converted to STG. One of these transformations is-     making it so that value lambdas only exist as the RHS of a binding.--  2. CoreToStg converts the prepared core to STG, specifically GenStg*-     parameterised by 'Vanilla.--  3. Stg.Pipeline does a number of passes on the generated STG. One of these is-     the lambda-lifting pass, which internally uses the 'LiftLams-     parameterisation to store information for deciding whether or not to lift-     each binding.--  4. Stg.FVs annotates closures with their free variables. To store these-     annotations we use the 'CodeGen parameterisation.--  5. Stg.StgToCmm generates Cmm from the annotated STG.--}---- | Used as a data type index for the stgSyn AST-data StgPass-  = Vanilla-  | LiftLams-  | CodeGen- -- | Like 'GHC.Hs.Extension.NoExtField', but with an 'Outputable' instance that -- returns 'empty'. data NoExtFieldSilent = NoExtFieldSilent@@ -470,44 +429,11 @@ -- TODO: Maybe move this to GHC.Hs.Extension? I'm not sure about the -- implications on build time... --- TODO: Do we really want to the extension point type families to have a closed--- domain?-type family BinderP (pass :: StgPass)-type instance BinderP 'Vanilla = Id-type instance BinderP 'CodeGen = Id--type family XRhsClosure (pass :: StgPass)-type instance XRhsClosure 'Vanilla = NoExtFieldSilent--- | Code gen needs to track non-global free vars-type instance XRhsClosure 'CodeGen = DIdSet--type family XLet (pass :: StgPass)-type instance XLet 'Vanilla = NoExtFieldSilent-type instance XLet 'CodeGen = NoExtFieldSilent--type family XConApp (pass :: StgPass)-type instance XConApp 'Vanilla =  ConstructorNumber-type instance XConApp 'CodeGen = ConstructorNumber---- | When `-fdistinct-constructor-tables` is turned on then--- each usage of a constructor is given an unique number and--- an info table is generated for each different constructor.-data ConstructorNumber =-      NoNumber | Numbered Int--instance Outputable ConstructorNumber where-  ppr NoNumber = empty-  ppr (Numbered n) = text "#" <> ppr n--type family XLetNoEscape (pass :: StgPass)-type instance XLetNoEscape 'Vanilla = NoExtFieldSilent-type instance XLetNoEscape 'CodeGen = NoExtFieldSilent- stgRhsArity :: StgRhs -> Int stgRhsArity (StgRhsClosure _ _ _ bndrs _)-  = ASSERT( all isId bndrs ) length bndrs+  = assert (all isId bndrs) $ length bndrs   -- The arity never includes type parameters, but they should have gone by now-stgRhsArity (StgRhsCon _ _ _ _ _) = 0+stgRhsArity (StgRhsCon {}) = 0  freeVarsOfRhs :: (XRhsClosure pass ~ DIdSet) => GenStgRhs pass -> DIdSet freeVarsOfRhs (StgRhsCon _ _ _ _ args) = mkDVarSet [ id | StgVarArg id <- args ]@@ -531,10 +457,11 @@ Real McCoy) rather than from the scrutinee type. -} -type GenStgAlt pass-  = (AltCon,          -- alts: data constructor,-     [BinderP pass],  -- constructor's parameters,-     GenStgExpr pass) -- ...right-hand side.+data GenStgAlt pass = GenStgAlt+  { alt_con          :: !AltCon            -- alts: data constructor,+  , alt_bndrs        :: ![BinderP pass]    -- constructor's parameters,+  , alt_rhs          :: !(GenStgExpr pass) -- right-hand side.+  }  data AltType   = PolyAlt             -- Polymorphic (a boxed type variable, lifted or unlifted)@@ -551,7 +478,31 @@ *                                                                      * ************************************************************************ -This happens to be the only one we use at the moment.+  Note [STG Extension points]+  ~~~~~~~~~~~~~~~~~~~~~~~~~~~+  We now make use of extension points in STG for different passes which want+  to associate information with AST nodes.++  Currently the pipeline is roughly:++  CoreToStg: Core -> Stg+  StgSimpl: Stg -> Stg+  CodeGen: Stg -> Cmm++    As part of StgSimpl we run late lambda lifting (Ll).+    Late lambda lift:+    Stg -> FvStg -> LlStg -> Stg++  CodeGen:+    As part of CodeGen we run tag inference.+    Tag Inference:+      Stg -> Stg 'InferTaggedBinders` -> Stg++    And at a last step we add the free Variables:+      Stg -> CgStg++  Which finally CgStg being used to generate Cmm.+ -}  type StgTopBinding = GenStgTopBinding 'Vanilla@@ -572,6 +523,12 @@ type CgStgRhs        = GenStgRhs        'CodeGen type CgStgAlt        = GenStgAlt        'CodeGen +type TgStgTopBinding = GenStgTopBinding 'CodeGen+type TgStgBinding    = GenStgBinding    'CodeGen+type TgStgExpr       = GenStgExpr       'CodeGen+type TgStgRhs        = GenStgRhs        'CodeGen+type TgStgAlt        = GenStgAlt        'CodeGen+ {- Many passes apply a substitution, and it's very handy to have type    synonyms to remind us whether or not the substitution has been applied.    See GHC.Core for precedence in Core land@@ -590,8 +547,81 @@ type OutStgRhs        = StgRhs type OutStgAlt        = StgAlt +-- | When `-fdistinct-constructor-tables` is turned on then+-- each usage of a constructor is given an unique number and+-- an info table is generated for each different constructor.+data ConstructorNumber =+      NoNumber | Numbered Int++instance Outputable ConstructorNumber where+  ppr NoNumber = empty+  ppr (Numbered n) = text "#" <> ppr n+ {-+Note Stg Passes+~~~~~~~~~~~~~~~+Here is a short summary of the STG pipeline and where we use the different+StgPass data type indexes: +  1. CoreToStg.Prep performs several transformations that prepare the desugared+     and simplified core to be converted to STG. One of these transformations is+     making it so that value lambdas only exist as the RHS of a binding.+     See Note [CorePrep Overview].++  2. CoreToStg converts the prepared core to STG, specifically GenStg*+     parameterised by 'Vanilla. See the GHC.CoreToStg Module.++  3. Stg.Pipeline does a number of passes on the generated STG. One of these is+     the lambda-lifting pass, which internally uses the 'LiftLams+     parameterisation to store information for deciding whether or not to lift+     each binding.+     See Note [Late lambda lifting in STG].++  4. Tag inference takes in 'Vanilla and produces 'InferTagged STG, while using+     the InferTaggedBinders annotated AST internally.+     See Note [Tag Inference].++  5. Stg.FVs annotates closures with their free variables. To store these+     annotations we use the 'CodeGen parameterisation.+     See the GHC.Stg.FVs module.++  6. The Module Stg.StgToCmm generates Cmm from the CodeGen annotated STG.+-}+++-- | Used as a data type index for the stgSyn AST+data StgPass+  = Vanilla+  | LiftLams -- ^ Use internally by the lambda lifting pass+  | InferTaggedBinders -- ^ Tag inference information on binders.+                       -- See Note [Tag inference passes] in GHC.Stg.InferTags+  | InferTagged -- ^ Tag inference information put on relevant StgApp nodes+                -- See Note [Tag inference passes] in GHC.Stg.InferTags+  | CodeGen++type family BinderP (pass :: StgPass)+type instance BinderP 'Vanilla = Id+type instance BinderP 'CodeGen = Id+type instance BinderP 'InferTagged = Id++type family XRhsClosure (pass :: StgPass)+type instance XRhsClosure 'Vanilla = NoExtFieldSilent+type instance XRhsClosure 'InferTagged = NoExtFieldSilent+-- | Code gen needs to track non-global free vars+type instance XRhsClosure 'CodeGen = DIdSet++type family XLet (pass :: StgPass)+type instance XLet 'Vanilla = NoExtFieldSilent+type instance XLet 'InferTagged = NoExtFieldSilent+type instance XLet 'CodeGen = NoExtFieldSilent++type family XLetNoEscape (pass :: StgPass)+type instance XLetNoEscape 'Vanilla = NoExtFieldSilent+type instance XLetNoEscape 'InferTagged = NoExtFieldSilent+type instance XLetNoEscape 'CodeGen = NoExtFieldSilent++{-+ ************************************************************************ *                                                                      * UpdateFlag@@ -644,25 +674,6 @@ {- ************************************************************************ *                                                                      *-Utilities-*                                                                      *-************************************************************************--}--bindersOf :: BinderP a ~ Id => GenStgBinding a -> [Id]-bindersOf (StgNonRec binder _) = [binder]-bindersOf (StgRec pairs)       = [binder | (binder, _) <- pairs]--bindersOfTop :: BinderP a ~ Id => GenStgTopBinding a -> [Id]-bindersOfTop (StgTopLifted bind) = bindersOf bind-bindersOfTop (StgTopStringLit binder _) = [binder]--bindersOfTopBinds :: BinderP a ~ Id => [GenStgTopBinding a] -> [Id]-bindersOfTopBinds = foldr ((++) . bindersOfTop) []--{--************************************************************************-*                                                                      * Pretty-printing *                                                                      * ************************************************************************@@ -673,7 +684,6 @@  type OutputablePass pass =   ( Outputable (XLet pass)-  , Outputable (XConApp pass)   , Outputable (XLetNoEscape pass)   , Outputable (XRhsClosure pass)   , OutputableBndr (BinderP pass)@@ -684,12 +694,6 @@    { stgSccEnabled :: !Bool -- ^ Enable cost-centres    } --- | Initialize STG pretty-printing options from DynFlags-initStgPprOpts :: DynFlags -> StgPprOpts-initStgPprOpts dflags = StgPprOpts-   { stgSccEnabled = sccProfilingEnabled dflags-   }- -- | STG pretty-printing options used for panic messages panicStgPprOpts :: StgPprOpts panicStgPprOpts = StgPprOpts@@ -720,17 +724,20 @@                              = hang (hsep [pprBndr LetBind bndr, equals])                                     4 (pprStgRhs opts expr <> semi) +instance OutputablePass pass => Outputable  (GenStgBinding pass) where+  ppr = pprGenStgBinding panicStgPprOpts+ pprGenStgTopBindings :: (OutputablePass pass) => StgPprOpts -> [GenStgTopBinding pass] -> SDoc pprGenStgTopBindings opts binds   = vcat $ intersperse blankLine (map (pprGenStgTopBinding opts) binds) -pprStgBinding :: StgPprOpts -> StgBinding -> SDoc+pprStgBinding :: OutputablePass pass => StgPprOpts -> GenStgBinding pass -> SDoc pprStgBinding = pprGenStgBinding -pprStgTopBinding :: StgPprOpts -> StgTopBinding -> SDoc+pprStgTopBinding :: OutputablePass pass => StgPprOpts -> GenStgTopBinding pass -> SDoc pprStgTopBinding = pprGenStgTopBinding -pprStgTopBindings :: StgPprOpts -> [StgTopBinding] -> SDoc+pprStgTopBindings :: OutputablePass pass => StgPprOpts -> [GenStgTopBinding pass] -> SDoc pprStgTopBindings = pprGenStgTopBindings  instance Outputable StgArg where@@ -740,12 +747,19 @@ pprStgArg (StgVarArg var) = ppr var pprStgArg (StgLitArg con) = ppr con +instance OutputablePass pass => Outputable  (GenStgExpr pass) where+  ppr = pprStgExpr panicStgPprOpts+ pprStgExpr :: OutputablePass pass => StgPprOpts -> GenStgExpr pass -> SDoc pprStgExpr opts e = case e of                            -- special case    StgLit lit           -> ppr lit                            -- general case-   StgApp func args     -> hang (ppr func) 4 (interppSP args)+   StgApp func args+      | null args+      , Just sig <- idTagSig_maybe func+      -> ppr func <> ppr sig+      | otherwise -> hang (ppr func) 4 (interppSP args) -- TODO: Print taggedness    StgConApp con n args _ -> hsep [ ppr con, ppr n, brackets (interppSP args) ]    StgOpApp op args _   -> hsep [ pprStgOp op, brackets (interppSP args)] @@ -761,10 +775,10 @@    StgLet srt (StgNonRec bndr (StgRhsClosure cc bi free_vars upd_flag args rhs))                         expr@(StgLet _ _))    -> ($$)-      (hang (hcat [text "let { ", ppr bndr, ptext (sLit " = "),+      (hang (hcat [text "let { ", ppr bndr, text " = ",                           ppr cc,                           pp_binder_info bi,-                          text " [", whenPprDebug (interppSP free_vars), ptext (sLit "] \\"),+                          text " [", whenPprDebug (interppSP free_vars), text "] \\",                           ppr upd_flag, text " [",                           interppSP args, char ']'])             8 (sep [hsep [ppr rhs, text "} in"]]))@@ -823,11 +837,14 @@   pprStgAlt :: OutputablePass pass => StgPprOpts -> Bool -> GenStgAlt pass -> SDoc-pprStgAlt opts indent (con, params, expr)-  | indent    = hang altPattern 4 (pprStgExpr opts expr <> semi)-  | otherwise = sep [altPattern, pprStgExpr opts expr <> semi]+pprStgAlt opts indent GenStgAlt{alt_con, alt_bndrs, alt_rhs}+  | indent    = hang altPattern 4 (pprStgExpr opts alt_rhs <> semi)+  | otherwise = sep [altPattern, pprStgExpr opts alt_rhs <> semi]     where-      altPattern = (hsep [ppr con, sep (map (pprBndr CasePatBind) params), text "->"])+      altPattern = hsep [ ppr alt_con+                        , sep (map (pprBndr CasePatBind) alt_bndrs)+                        , text "->"+                        ]   pprStgOp :: StgOp -> SDoc@@ -835,6 +852,9 @@ pprStgOp (StgPrimCallOp op)= ppr op pprStgOp (StgFCallOp op _) = ppr op +instance Outputable StgOp where+  ppr = pprStgOp+ instance Outputable AltType where   ppr PolyAlt         = text "Polymorphic"   ppr (MultiValAlt n) = text "MultiAlt" <+> ppr n@@ -855,4 +875,8 @@               , case mid of                   NoNumber -> empty                   Numbered n -> hcat [ppr n, space]+              -- The bang indicates this is an StgRhsCon instead of an StgConApp.               , ppr con, text "! ", brackets (sep (map pprStgArg args))]++instance OutputablePass pass => Outputable  (GenStgRhs pass) where+  ppr = pprStgRhs panicStgPprOpts
GHC/Stg/Unarise.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP              #-}+ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TupleSections    #-} @@ -130,20 +130,44 @@    (# 2#, rubbish, 2#, 3# #). ++Note [Don't merge lifted and unlifted slots]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When merging slots, one might be tempted to collapse lifted and unlifted-points. However, as seen in #19645, this is wrong. Imagine that you have+pointers. However, as seen in #19645, this is wrong. Imagine that you have the program: -    test :: (# Char | ByteArray# #) -> ByteArray#-    test (# | ba #) = ba-    test (# c | #) = ...+  test :: (# Char | ByteArray# #) -> ByteArray#+  test (# c | #) = doSomething c+  test (# | ba #) = ba -If we were to collapse the sum argument to (# Tag#, Any #) we would end up treating-the ByteArray# as a lifted object. This would cause the code generator to-attempt to enter it upon returning, causing a runtime crash. For this reason we-treat unlifted and lifted things as distinct slot types, despite both being GC-pointers.+Collapsing the Char and ByteArray# slots would produce STG like: +  test :: forall {t}. (# t | GHC.Prim.ByteArray# #) -> GHC.Prim.ByteArray#+    = {} \r [ (tag :: Int#) (slot0 :: (Any :: Type)) ]+          case tag of tag'+            1# -> doSomething slot0+            2# -> slot0;++Note how `slot0` has a lifted type, despite being bound to an unlifted+ByteArray# in the 2# alternative. This liftedness would cause the code generator to+attempt to enter it upon returning. As unlifted objects do not have entry code,+this causes a runtime crash.++For this reason, Unarise treats unlifted and lifted things as distinct slot+types, despite both being GC pointers. This approach is a slight pessimisation+(since we need to pass more arguments) but appears to be the simplest way to+avoid #19645. Other alternatives considered include:++ a. Giving unlifted objects "trivial" entry code. However, we ultimately+    concluded that the value of the "unlifted things are never entered" invariant+    outweighed the simplicity of this approach.++ b. Annotating occurrences with calling convention information instead of+    relying on the binder's type. This seemed like a very complicated+    way to fix what is ultimately a corner-case.++ Note [Types in StgConApp] ~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we have this unboxed sum term:@@ -229,8 +253,6 @@  module GHC.Stg.Unarise (unarise) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Types.Basic@@ -245,10 +267,12 @@ import GHC.Utils.Monad (mapAccumLM) import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Types.RepType import GHC.Stg.Syntax+import GHC.Stg.Utils import GHC.Core.Type-import GHC.Builtin.Types.Prim (intPrimTy, primRepToRuntimeRep)+import GHC.Builtin.Types.Prim (intPrimTy) import GHC.Builtin.Types import GHC.Types.Unique.Supply import GHC.Utils.Misc@@ -297,10 +321,10 @@ -- See Note [UnariseEnv] extendRho :: UnariseEnv -> Id -> UnariseVal -> UnariseEnv extendRho rho x (MultiVal args)-  = ASSERT(all (isNvUnaryType . stgArgType) args)+  = assert (all (isNvUnaryType . stgArgType) args)     extendVarEnv rho x (MultiVal args) extendRho rho x (UnaryVal val)-  = ASSERT(isNvUnaryType (stgArgType val))+  = assert (isNvUnaryType (stgArgType val))     extendVarEnv rho x (UnaryVal val) -- Properly shadow things from an outer scope. -- See Note [UnariseEnv]@@ -334,7 +358,7 @@        return (StgRhsClosure ext ccs update_flag args1 expr')  unariseRhs rho (StgRhsCon ccs con mu ts args)-  = ASSERT(not (isUnboxedTupleDataCon con || isUnboxedSumDataCon con))+  = assert (not (isUnboxedTupleDataCon con || isUnboxedSumDataCon con))     return (StgRhsCon ccs con mu ts (unariseConArgs rho args))  --------------------------------------------------------------------------------@@ -418,7 +442,7 @@   = Just (unariseConArgs rho args)    | isUnboxedSumDataCon dc-  , let args1 = ASSERT(isSingleton args) (unariseConArgs rho args)+  , let args1 = assert (isSingleton args) (unariseConArgs rho args)   = Just (mkUbxSum dc ty_args args1)    | otherwise@@ -445,13 +469,15 @@          -> [OutStgArg] -- non-void args          -> InId -> AltType -> [InStgAlt] -> UniqSM OutStgExpr -elimCase rho args bndr (MultiValAlt _) [(_, bndrs, rhs)]+elimCase rho args bndr (MultiValAlt _) [GenStgAlt{ alt_con   = _+                                                 , alt_bndrs = bndrs+                                                 , alt_rhs   = rhs}]   = do let rho1 = extendRho rho bndr (MultiVal args)            rho2              | isUnboxedTupleBndr bndr              = mapTupleIdBinders bndrs args rho1              | otherwise-             = ASSERT(isUnboxedSumBndr bndr)+             = assert (isUnboxedSumBndr bndr) $                if null bndrs then rho1                              else mapSumIdBinders bndrs args rho1 @@ -477,47 +503,55 @@ --------------------------------------------------------------------------------  unariseAlts :: UnariseEnv -> AltType -> InId -> [StgAlt] -> UniqSM [StgAlt]-unariseAlts rho (MultiValAlt n) bndr [(DEFAULT, [], e)]+unariseAlts rho (MultiValAlt n) bndr [GenStgAlt{ alt_con   = DEFAULT+                                               , alt_bndrs = []+                                               , alt_rhs   = e}]   | isUnboxedTupleBndr bndr   = do (rho', ys) <- unariseConArgBinder rho bndr-       e' <- unariseExpr rho' e-       return [(DataAlt (tupleDataCon Unboxed n), ys, e')]+       !e' <- unariseExpr rho' e+       return [GenStgAlt (DataAlt (tupleDataCon Unboxed n)) ys e'] -unariseAlts rho (MultiValAlt n) bndr [(DataAlt _, ys, e)]+unariseAlts rho (MultiValAlt n) bndr [GenStgAlt{ alt_con   = DataAlt _+                                               , alt_bndrs = ys+                                               , alt_rhs   = e}]   | isUnboxedTupleBndr bndr   = do (rho', ys1) <- unariseConArgBinders rho ys-       MASSERT(ys1 `lengthIs` n)+       massert (ys1 `lengthIs` n)        let rho'' = extendRho rho' bndr (MultiVal (map StgVarArg ys1))-       e' <- unariseExpr rho'' e-       return [(DataAlt (tupleDataCon Unboxed n), ys1, e')]+       !e' <- unariseExpr rho'' e+       return [GenStgAlt (DataAlt (tupleDataCon Unboxed n)) ys1 e']  unariseAlts _ (MultiValAlt _) bndr alts   | isUnboxedTupleBndr bndr   = pprPanic "unariseExpr: strange multi val alts" (pprPanicAlts alts)  -- In this case we don't need to scrutinize the tag bit-unariseAlts rho (MultiValAlt _) bndr [(DEFAULT, _, rhs)]+unariseAlts rho (MultiValAlt _) bndr [GenStgAlt{ alt_con    = DEFAULT+                                               , alt_bndrs = []+                                               , alt_rhs   = rhs}]   | isUnboxedSumBndr bndr   = do (rho_sum_bndrs, sum_bndrs) <- unariseConArgBinder rho bndr        rhs' <- unariseExpr rho_sum_bndrs rhs-       return [(DataAlt (tupleDataCon Unboxed (length sum_bndrs)), sum_bndrs, rhs')]+       return [GenStgAlt (DataAlt (tupleDataCon Unboxed (length sum_bndrs))) sum_bndrs rhs']  unariseAlts rho (MultiValAlt _) bndr alts   | isUnboxedSumBndr bndr   = do (rho_sum_bndrs, scrt_bndrs@(tag_bndr : real_bndrs)) <- unariseConArgBinder rho bndr        alts' <- unariseSumAlts rho_sum_bndrs (map StgVarArg real_bndrs) alts        let inner_case = StgCase (StgApp tag_bndr []) tag_bndr tagAltTy alts'-       return [ (DataAlt (tupleDataCon Unboxed (length scrt_bndrs)),-                 scrt_bndrs,-                 inner_case) ]+       return [GenStgAlt{ alt_con   = DataAlt (tupleDataCon Unboxed (length scrt_bndrs))+                        , alt_bndrs = scrt_bndrs+                        , alt_rhs   = inner_case+                        }]  unariseAlts rho _ _ alts   = mapM (\alt -> unariseAlt rho alt) alts  unariseAlt :: UnariseEnv -> StgAlt -> UniqSM StgAlt-unariseAlt rho (con, xs, e)+unariseAlt rho alt@GenStgAlt{alt_con=_,alt_bndrs=xs,alt_rhs=e}   = do (rho', xs') <- unariseConArgBinders rho xs-       (con, xs',) <$> unariseExpr rho' e+       !e' <- unariseExpr rho' e+       return $! alt {alt_bndrs = xs', alt_rhs = e'}  -------------------------------------------------------------------------------- @@ -535,13 +569,16 @@               -> [StgArg] -- sum components _excluding_ the tag bit.               -> StgAlt   -- original alternative with sum LHS               -> UniqSM StgAlt-unariseSumAlt rho _ (DEFAULT, _, e)-  = ( DEFAULT, [], ) <$> unariseExpr rho e+unariseSumAlt rho _ GenStgAlt{alt_con=DEFAULT,alt_bndrs=_,alt_rhs=e}+  = GenStgAlt DEFAULT mempty <$> unariseExpr rho e -unariseSumAlt rho args (DataAlt sumCon, bs, e)-  = do let rho' = mapSumIdBinders bs args rho-       e' <- unariseExpr rho' e-       return ( LitAlt (LitNumber LitNumInt (fromIntegral (dataConTag sumCon))), [], e' )+unariseSumAlt rho args GenStgAlt{ alt_con   = DataAlt sumCon+                                , alt_bndrs = bs+                                , alt_rhs   = e+                                }+  = do let rho'     = mapSumIdBinders bs args rho+           lit_case = LitAlt (LitNumber LitNumInt (fromIntegral (dataConTag sumCon)))+       GenStgAlt lit_case mempty <$> unariseExpr rho' e  unariseSumAlt _ scrt alt   = pprPanic "unariseSumAlt" (ppr scrt $$ pprPanicAlt alt)@@ -556,7 +593,7 @@   -> UnariseEnv   -> UnariseEnv mapTupleIdBinders ids args0 rho0-  = ASSERT(not (any (isVoidTy . stgArgType) args0))+  = assert (not (any (isZeroBitTy . stgArgType) args0)) $     let       ids_unarised :: [(Id, [PrimRep])]       ids_unarised = map (\id -> (id, typePrimRep (idType id))) ids@@ -567,12 +604,12 @@         let           x_arity = length x_reps           (x_args, args') =-            ASSERT(args `lengthAtLeast` x_arity)+            assert (args `lengthAtLeast` x_arity)             splitAt x_arity args            rho'             | x_arity == 1-            = ASSERT(x_args `lengthIs` 1)+            = assert (x_args `lengthIs` 1)               extendRho rho x (UnaryVal (head x_args))             | otherwise             = extendRho rho x (MultiVal x_args)@@ -590,7 +627,7 @@   -> UnariseEnv  mapSumIdBinders [id] args rho0-  = ASSERT(not (any (isVoidTy . stgArgType) args))+  = assert (not (any (isZeroBitTy . stgArgType) args)) $     let       arg_slots = map primRepSlot $ concatMap (typePrimRep . stgArgType) args       id_slots  = map primRepSlot $ typePrimRep (idType id)@@ -598,7 +635,7 @@     in       if isMultiValBndr id         then extendRho rho0 id (MultiVal [ args !! i | i <- layout1 ])-        else ASSERT(layout1 `lengthIs` 1)+        else assert (layout1 `lengthIs` 1)              extendRho rho0 id (UnaryVal (args !! head layout1))  mapSumIdBinders ids sum_args _@@ -657,8 +694,6 @@ ubxSumRubbishArg Word64Slot = StgLitArg (LitNumber LitNumWord64 0) ubxSumRubbishArg FloatSlot  = StgLitArg (LitFloat 0) ubxSumRubbishArg DoubleSlot = StgLitArg (LitDouble 0)-ubxSumRubbishArg (VecSlot n e) = StgLitArg (LitRubbish vec_rep)-  where vec_rep = primRepToRuntimeRep (VecRep n e)  -------------------------------------------------------------------------------- @@ -778,15 +813,15 @@     Just (UnaryVal arg) -> [arg]     Just (MultiVal as) -> as      -- 'as' can be empty     Nothing-      | isVoidTy (idType x) -> [] -- e.g. C realWorld#-                                  -- Here realWorld# is not in the envt, but-                                  -- is a void, and so should be eliminated+      | isZeroBitTy (idType x) -> [] -- e.g. C realWorld#+                                     -- Here realWorld# is not in the envt, but+                                     -- is a void, and so should be eliminated       | otherwise -> [StgVarArg x] unariseConArg _ arg@(StgLitArg lit)   | Just as <- unariseRubbish_maybe lit   = as   | otherwise-  = ASSERT(not (isVoidTy (literalType lit))) -- We have no non-rubbish void literals+  = assert (not (isZeroBitTy (literalType lit))) -- We have no non-rubbish void literals     [arg]  unariseConArgs :: UnariseEnv -> [InStgArg] -> [OutStgArg]@@ -803,10 +838,10 @@ --------------------------------------------------------------------------------  mkIds :: FastString -> [UnaryType] -> UniqSM [Id]-mkIds fs tys = mapM (mkId fs) tys+mkIds fs tys = mkUnarisedIds fs tys  mkId :: FastString -> UnaryType -> UniqSM Id-mkId s t = mkSysLocalM s Many t+mkId s t = mkUnarisedId s t  isMultiValBndr :: Id -> Bool isMultiValBndr id@@ -840,12 +875,12 @@ -- Since they are exhaustive, we can replace one with DEFAULT, to avoid -- generating a final test. Remember, the DEFAULT comes first if it exists. mkDefaultLitAlt [] = pprPanic "elimUbxSumExpr.mkDefaultAlt" (text "Empty alts")-mkDefaultLitAlt alts@((DEFAULT, _, _) : _) = alts-mkDefaultLitAlt ((LitAlt{}, [], rhs) : alts) = (DEFAULT, [], rhs) : alts+mkDefaultLitAlt alts@(GenStgAlt{alt_con=DEFAULT,alt_bndrs=_,alt_rhs=_} : _)   = alts+mkDefaultLitAlt (alt@GenStgAlt{alt_con=LitAlt{}, alt_bndrs=[]} : alts) = alt {alt_con = DEFAULT} : alts mkDefaultLitAlt alts = pprPanic "mkDefaultLitAlt" (text "Not a lit alt:" <+> pprPanicAlts alts) -pprPanicAlts :: (Outputable a, Outputable b, OutputablePass pass) => [(a,b,GenStgExpr pass)] -> SDoc+pprPanicAlts :: OutputablePass pass => [GenStgAlt pass] -> SDoc pprPanicAlts alts = ppr (map pprPanicAlt alts) -pprPanicAlt :: (Outputable a, Outputable b, OutputablePass pass) => (a,b,GenStgExpr pass) -> SDoc-pprPanicAlt (c,b,e) = ppr (c,b,pprStgExpr panicStgPprOpts e)+pprPanicAlt :: OutputablePass pass => GenStgAlt pass -> SDoc+pprPanicAlt GenStgAlt{alt_con=c,alt_bndrs=b,alt_rhs=e} = ppr (c,b,pprStgExpr panicStgPprOpts e)
+ GHC/Stg/Utils.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE CPP, ScopedTypeVariables, TypeFamilies #-}+{-# LANGUAGE DataKinds #-}++module GHC.Stg.Utils+    ( mkStgAltTypeFromStgAlts+    , bindersOf, bindersOfX, bindersOfTop, bindersOfTopBinds++    , stripStgTicksTop, stripStgTicksTopE+    , idArgs++    , mkUnarisedId, mkUnarisedIds+    ) where++import GHC.Prelude++import GHC.Types.Id+import GHC.Core.Type+import GHC.Core.TyCon+import GHC.Core.DataCon+import GHC.Core ( AltCon(..) )+import GHC.Types.Tickish+import GHC.Types.Unique.Supply++import GHC.Types.RepType+import GHC.Stg.Syntax++import GHC.Utils.Outputable++import GHC.Utils.Panic.Plain+import GHC.Utils.Panic++import GHC.Data.FastString++mkUnarisedIds :: MonadUnique m => FastString -> [UnaryType] -> m [Id]+mkUnarisedIds fs tys = mapM (mkUnarisedId fs) tys++mkUnarisedId :: MonadUnique m => FastString -> UnaryType -> m Id+mkUnarisedId s t = mkSysLocalM s Many t++-- Checks if id is a top level error application.+-- isErrorAp_maybe :: Id ->++-- | Extract the default case alternative+-- findDefaultStg :: [Alt b] -> ([Alt b], Maybe (Expr b))+findDefaultStg+  :: [GenStgAlt p]+  -> ([GenStgAlt p], Maybe (GenStgExpr p))+findDefaultStg (GenStgAlt{ alt_con    = DEFAULT+                         , alt_bndrs  = args+                         , alt_rhs    = rhs} : alts) = assert( null args ) (alts, Just rhs)+findDefaultStg alts                                  = (alts, Nothing)++mkStgAltTypeFromStgAlts :: forall p. Id -> [GenStgAlt p] -> AltType+mkStgAltTypeFromStgAlts bndr alts+  | isUnboxedTupleType bndr_ty || isUnboxedSumType bndr_ty+  = MultiValAlt (length prim_reps)  -- always use MultiValAlt for unboxed tuples++  | otherwise+  = case prim_reps of+      [rep] | isGcPtrRep rep ->+        case tyConAppTyCon_maybe (unwrapType bndr_ty) of+          Just tc+            | isAbstractTyCon tc -> look_for_better_tycon+            | isAlgTyCon tc      -> AlgAlt tc+            | otherwise          -> assertPpr ( _is_poly_alt_tycon tc) (ppr tc)+                                    PolyAlt+          Nothing                -> PolyAlt+      [non_gcd] -> PrimAlt non_gcd+      not_unary -> MultiValAlt (length not_unary)+  where+   bndr_ty   = idType bndr+   prim_reps = typePrimRep bndr_ty++   _is_poly_alt_tycon tc+        =  isFunTyCon tc+        || isPrimTyCon tc   -- "Any" is lifted but primitive+        || isFamilyTyCon tc -- Type family; e.g. Any, or arising from strict+                            -- function application where argument has a+                            -- type-family type++   -- Sometimes, the TyCon is a AbstractTyCon which may not have any+   -- constructors inside it.  Then we may get a better TyCon by+   -- grabbing the one from a constructor alternative+   -- if one exists.+   look_for_better_tycon+        | (DataAlt con : _) <- alt_con <$> data_alts =+                AlgAlt (dataConTyCon con)+        | otherwise =+                assert(null data_alts)+                PolyAlt+        where+                (data_alts, _deflt) = findDefaultStg alts++bindersOf :: BinderP a ~ Id => GenStgBinding a -> [Id]+bindersOf (StgNonRec binder _) = [binder]+bindersOf (StgRec pairs)       = [binder | (binder, _) <- pairs]++bindersOfX :: GenStgBinding a -> [BinderP a]+bindersOfX (StgNonRec binder _) = [binder]+bindersOfX (StgRec pairs)       = [binder | (binder, _) <- pairs]++bindersOfTop :: BinderP a ~ Id => GenStgTopBinding a -> [Id]+bindersOfTop (StgTopLifted bind) = bindersOf bind+bindersOfTop (StgTopStringLit binder _) = [binder]++-- All ids we bind something to on the top level.+bindersOfTopBinds :: BinderP a ~ Id => [GenStgTopBinding a] -> [Id]+-- bindersOfTopBinds binds = mapUnionVarSet (mkVarSet . bindersOfTop) binds+bindersOfTopBinds binds = foldr ((++) . bindersOfTop) [] binds++idArgs :: [StgArg] -> [Id]+idArgs args = [v | StgVarArg v <- args]++-- | Strip ticks of a given type from an STG expression.+stripStgTicksTop :: (StgTickish -> Bool) -> GenStgExpr p -> ([StgTickish], GenStgExpr p)+stripStgTicksTop p = go []+   where go ts (StgTick t e) | p t = go (t:ts) e+         -- This special case avoid building a thunk for "reverse ts" when there are no ticks+         go [] other               = ([], other)+         go ts other               = (reverse ts, other)++-- | Strip ticks of a given type from an STG expression returning only the expression.+stripStgTicksTopE :: (StgTickish -> Bool) -> GenStgExpr p -> GenStgExpr p+stripStgTicksTopE p = go+   where go (StgTick t e) | p t = go e+         go other               = other
GHC/StgToByteCode.hs view
@@ -1,7 +1,8 @@-{-# LANGUAGE CPP                        #-}+ {-# LANGUAGE DeriveFunctor              #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RecordWildCards            #-}+{-# LANGUAGE FlexibleContexts           #-}  {-# OPTIONS_GHC -fprof-auto-top #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}@@ -13,8 +14,6 @@ -- | GHC.StgToByteCode: Generate bytecode from STG module GHC.StgToByteCode ( UnlinkedBCO, byteCodeGen) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Driver.Session@@ -38,12 +37,12 @@ import GHC.Types.Basic import GHC.Utils.Outputable import GHC.Types.Name-import GHC.Types.Id.Make import GHC.Types.Id import GHC.Types.ForeignCall import GHC.Core import GHC.Types.Literal import GHC.Builtin.PrimOps+import GHC.Builtin.PrimOps.Ids (primOpId) import GHC.Core.Type import GHC.Types.RepType import GHC.Core.DataCon@@ -51,15 +50,15 @@ import GHC.Utils.Misc import GHC.Utils.Logger import GHC.Types.Var.Set-import GHC.Builtin.Types ( unboxedUnitTy ) import GHC.Builtin.Types.Prim import GHC.Core.TyCo.Ppr ( pprType ) import GHC.Utils.Error import GHC.Types.Unique import GHC.Builtin.Uniques-import GHC.Builtin.Utils ( primOpId ) import GHC.Data.FastString import GHC.Utils.Panic+import GHC.Utils.Panic.Plain+import GHC.Utils.Exception (evaluate) import GHC.StgToCmm.Closure ( NonVoid(..), fromNonVoid, nonVoidIds ) import GHC.StgToCmm.Layout import GHC.Runtime.Heap.Layout hiding (WordOff, ByteOff, wordsToBytes)@@ -75,10 +74,8 @@ import Control.Monad import Data.Char -import GHC.Types.Unique.Supply import GHC.Unit.Module -import Control.Exception import Data.Array import Data.Coerce (coerce) import Data.ByteString (ByteString)@@ -91,9 +88,7 @@ import GHC.Stack.CCS import Data.Either ( partitionEithers ) -import qualified GHC.Types.CostCentre as CC import GHC.Stg.Syntax-import GHC.Stg.FVs import qualified Data.IntSet as IntSet  -- -----------------------------------------------------------------------------@@ -101,12 +96,12 @@  byteCodeGen :: HscEnv             -> Module-            -> [StgTopBinding]+            -> [CgStgTopBinding]             -> [TyCon]             -> Maybe ModBreaks             -> IO CompiledByteCode byteCodeGen hsc_env this_mod binds tycs mb_modBreaks-   = withTiming logger dflags+   = withTiming logger                 (text "GHC.StgToByteCode"<+>brackets (ppr this_mod))                 (const ()) $ do         -- Split top-level binds into strings and others.@@ -120,18 +115,15 @@             flattenBind (StgRec bs)     = bs         stringPtrs <- allocateTopStrings interp strings -        us <- mkSplitUniqSupply 'y'         (BcM_State{..}, proto_bcos) <--           runBc hsc_env us this_mod mb_modBreaks (mkVarEnv stringPtrs) $ do-             prepd_binds <- mapM bcPrepBind lifted_binds-             let flattened_binds =-                   concatMap (flattenBind . annBindingFreeVars) (reverse prepd_binds)+           runBc hsc_env this_mod mb_modBreaks (mkVarEnv stringPtrs) $ do+             let flattened_binds = concatMap flattenBind (reverse lifted_binds)              mapM schemeTopBind flattened_binds          when (notNull ffis)              (panic "GHC.StgToByteCode.byteCodeGen: missing final emitBc?") -        dumpIfSet_dyn logger dflags Opt_D_dump_BCOs+        putDumpFileMaybe logger Opt_D_dump_BCOs            "Proto-BCOs" FormatByteCode            (vcat (intersperse (char ' ') (map ppr proto_bcos))) @@ -150,8 +142,8 @@          return cbc -  where dflags = hsc_dflags hsc_env-        logger = hsc_logger hsc_env+  where dflags  = hsc_dflags hsc_env+        logger  = hsc_logger hsc_env         interp  = hscInterp hsc_env         profile = targetProfile dflags @@ -166,7 +158,7 @@  {- Note [generating code for top-level string literal bindings]-+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Here is a summary on how the byte code generator deals with top-level string literals: @@ -178,100 +170,6 @@    BcM and used when generating code for variable references. -} -{--  Prepare the STG for bytecode generation:--   - Ensure that all breakpoints are directly under-        a let-binding, introducing a new binding for-        those that aren't already.--   - Protect Not-necessarily lifted join points, see-        Note [Not-necessarily-lifted join points]-- -}--bcPrepRHS :: StgRhs -> BcM StgRhs--- explicitly match all constructors so we get a warning if we miss any-bcPrepRHS (StgRhsClosure fvs cc upd args (StgTick bp@Breakpoint{} expr)) = do-  {- If we have a breakpoint directly under an StgRhsClosure we don't-     need to introduce a new binding for it.-   -}-  expr' <- bcPrepExpr expr-  pure (StgRhsClosure fvs cc upd args (StgTick bp expr'))-bcPrepRHS (StgRhsClosure fvs cc upd args expr) =-  StgRhsClosure fvs cc upd args <$> bcPrepExpr expr-bcPrepRHS con@StgRhsCon{} = pure con--bcPrepExpr :: StgExpr -> BcM StgExpr--- explicitly match all constructors so we get a warning if we miss any-bcPrepExpr (StgTick bp@(Breakpoint tick_ty _ _) rhs)-  | isLiftedTypeKind (typeKind tick_ty) = do-      id <- newId tick_ty-      rhs' <- bcPrepExpr rhs-      let expr' = StgTick bp rhs'-          bnd = StgNonRec id (StgRhsClosure noExtFieldSilent-                                            CC.dontCareCCS-                                            ReEntrant-                                            []-                                            expr'-                             )-          letExp = StgLet noExtFieldSilent bnd (StgApp id [])-      pure letExp-  | otherwise = do-      id <- newId (mkVisFunTyMany realWorldStatePrimTy tick_ty)-      st <- newId realWorldStatePrimTy-      rhs' <- bcPrepExpr rhs-      let expr' = StgTick bp rhs'-          bnd = StgNonRec id (StgRhsClosure noExtFieldSilent-                                            CC.dontCareCCS-                                            ReEntrant-                                            [voidArgId]-                                            expr'-                             )-      pure $ StgLet noExtFieldSilent bnd (StgApp id [StgVarArg st])-bcPrepExpr (StgTick tick rhs) =-  StgTick tick <$> bcPrepExpr rhs-bcPrepExpr (StgLet xlet bnds expr) =-  StgLet xlet <$> bcPrepBind bnds-              <*> bcPrepExpr expr-bcPrepExpr (StgLetNoEscape xlne bnds expr) =-  StgLet xlne <$> bcPrepBind bnds-              <*> bcPrepExpr expr-bcPrepExpr (StgCase expr bndr alt_type alts) =-  StgCase <$> bcPrepExpr expr-          <*> pure bndr-          <*> pure alt_type-          <*> mapM bcPrepAlt alts-bcPrepExpr lit@StgLit{} = pure lit--- See Note [Not-necessarily-lifted join points], step 3.-bcPrepExpr (StgApp x [])-  | isNNLJoinPoint x = pure $-      StgApp (protectNNLJoinPointId x) [StgVarArg voidPrimId]-bcPrepExpr app@StgApp{} = pure app-bcPrepExpr app@StgConApp{} = pure app-bcPrepExpr app@StgOpApp{} = pure app--bcPrepAlt :: StgAlt -> BcM StgAlt-bcPrepAlt (ac, bndrs, expr) = (,,) ac bndrs <$> bcPrepExpr expr--bcPrepBind :: StgBinding -> BcM StgBinding--- explicitly match all constructors so we get a warning if we miss any-bcPrepBind (StgNonRec bndr rhs) =-  let (bndr', rhs') = bcPrepSingleBind (bndr, rhs)-  in  StgNonRec bndr' <$> bcPrepRHS rhs'-bcPrepBind (StgRec bnds) =-  StgRec <$> mapM ((\(b,r) -> (,) b <$> bcPrepRHS r) . bcPrepSingleBind)-                  bnds--bcPrepSingleBind :: (Id, StgRhs) -> (Id, StgRhs)--- If necessary, modify this Id and body to protect not-necessarily-lifted join points.--- See Note [Not-necessarily-lifted join points], step 2.-bcPrepSingleBind (x, StgRhsClosure ext cc upd_flag args body)-  | isNNLJoinPoint x-  = ( protectNNLJoinPointId x-    , StgRhsClosure ext cc upd_flag (args ++ [voidArgId]) body)-bcPrepSingleBind bnd = bnd- -- ----------------------------------------------------------------------------- -- Compilation schema for the bytecode generator @@ -318,11 +216,11 @@    -> name    -> BCInstrList    -> Either  [CgStgAlt] (CgStgRhs)-        -- ^ original expression; for debugging only-   -> Int-   -> Word16-   -> [StgWord]-   -> Bool      -- True <=> is a return point, rather than a function+                -- ^ original expression; for debugging only+   -> Int       -- ^ arity+   -> Word16    -- ^ bitmap size+   -> [StgWord] -- ^ bitmap+   -> Bool      -- ^ True <=> is a return point, rather than a function    -> [FFIInfo]    -> ProtoBCO name mkProtoBCO platform nm instrs_ordlist origin arity bitmap_size bitmap is_ret ffis@@ -399,10 +297,7 @@         -- by just re-using the single top-level definition.  So         -- for the worker itself, we must allocate it directly.     -- ioToBc (putStrLn $ "top level BCO")-    let enter = if isUnliftedTypeKind (tyConResKind (dataConTyCon data_con))-                then RETURN_UNLIFTED P-                else ENTER-    emitBc (mkProtoBCO platform (getName id) (toOL [PACK data_con 0, enter])+    emitBc (mkProtoBCO platform (getName id) (toOL [PACK data_con 0, RETURN])                        (Right rhs) 0 0 [{-no bitmap-}] False{-not alts-})    | otherwise@@ -593,7 +488,7 @@         (tuple_info, tuple_components) = layoutTuple profile d arg_ty es         go _   pushes [] = return (reverse pushes)         go !dd pushes ((a, off):cs) = do (push, szb) <- pushAtom dd p a-                                         MASSERT(off == dd + szb)+                                         massert (off == dd + szb)                                          go (dd + szb) (push:pushes) cs     pushes <- go d [] tuple_components     ret <- returnUnliftedReps d@@ -608,7 +503,7 @@     :: StackDepth -> Sequel -> BCEnv -> CgStgExpr -> BcM BCInstrList schemeE d s p (StgLit lit) = returnUnliftedAtom d s p (StgLitArg lit) schemeE d s p (StgApp x [])-   | isUnliftedType (idType x) = returnUnliftedAtom d s p (StgVarArg x)+   | not (usePlainReturn (idType x)) = returnUnliftedAtom d s p (StgVarArg x) -- Delegate tail-calls to schemeT. schemeE d s p e@(StgApp {}) = schemeT d s p e schemeE d s p e@(StgConApp {}) = schemeT d s p e@@ -709,20 +604,7 @@ schemeE d s p (StgCase scrut bndr _ alts)    = doCase d s p scrut bndr alts --- Is this Id a not-necessarily-lifted join point?--- See Note [Not-necessarily-lifted join points], step 1-isNNLJoinPoint :: Id -> Bool-isNNLJoinPoint x = isJoinId x &&-                   Just True /= isLiftedType_maybe (idType x) --- Update an Id's type to take a Void# argument.--- Precondition: the Id is a not-necessarily-lifted join point.--- See Note [Not-necessarily-lifted join points]-protectNNLJoinPointId :: Id -> Id-protectNNLJoinPointId x-  = ASSERT( isNNLJoinPoint x )-    updateIdTypeButNotMult (unboxedUnitTy `mkVisFunTyMany`) x- {-    Ticked Expressions    ------------------@@ -730,65 +612,6 @@   The idea is that the "breakpoint<n,fvs> E" is really just an annotation on   the code. When we find such a thing, we pull out the useful information,   and then compile the code as if it was just the expression E.--Note [Not-necessarily-lifted join points]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-A join point variable is essentially a goto-label: it is, for example,-never used as an argument to another function, and it is called only-in tail position. See Note [Join points] and Note [Invariants on join points],-both in GHC.Core. Because join points do not compile to true, red-blooded-variables (with, e.g., registers allocated to them), they are allowed-to be levity-polymorphic. (See invariant #6 in Note [Invariants on join points]-in GHC.Core.)--However, in this byte-code generator, join points *are* treated just as-ordinary variables. There is no check whether a binding is for a join point-or not; they are all treated uniformly. (Perhaps there is a missed optimization-opportunity here, but that is beyond the scope of my (Richard E's) Thursday.)--We thus must have *some* strategy for dealing with levity-polymorphic and-unlifted join points. Levity-polymorphic variables are generally not allowed-(though levity-polymorphic join points *are*; see Note [Invariants on join points]-in GHC.Core, point 6), and we don't wish to evaluate unlifted join points eagerly.-The questionable join points are *not-necessarily-lifted join points*-(NNLJPs). (Not having such a strategy led to #16509, which panicked in the-isUnliftedType check in the AnnVar case of schemeE.) Here is the strategy:--1. Detect NNLJPs. This is done in isNNLJoinPoint.--2. When binding an NNLJP, add a `\ (_ :: (# #)) ->` to its RHS, and modify the-   type to tack on a `(# #) ->`.-   Note that functions are never levity-polymorphic, so this transformation-   changes an NNLJP to a non-levity-polymorphic join point. This is done-   in bcPrepSingleBind.--3. At an occurrence of an NNLJP, add an application to void# (called voidPrimId),-   being careful to note the new type of the NNLJP. This is done in the AnnVar-   case of schemeE, with help from protectNNLJoinPointId.--Here is an example. Suppose we have--  f = \(r :: RuntimeRep) (a :: TYPE r) (x :: T).-      join j :: a-           j = error @r @a "bloop"-      in case x of-           A -> j-           B -> j-           C -> error @r @a "blurp"--Our plan is to behave is if the code was--  f = \(r :: RuntimeRep) (a :: TYPE r) (x :: T).-      let j :: (Void# -> a)-          j = \ _ -> error @r @a "bloop"-      in case x of-           A -> j void#-           B -> j void#-           C -> error @r @a "blurp"--It's a bit hacky, but it works well in practice and is local. I suspect the-Right Fix is to take advantage of join points as goto-labels.- -}  -- Compile code to do a tail call.  Specifically, push the fn,@@ -836,7 +659,7 @@    = unsupportedCConvException     -- Case 2: Unboxed tuple-schemeT d s p (StgConApp con _ext args _tys)+schemeT d s p (StgConApp con _cn args _tys)    | isUnboxedTupleDataCon con || isUnboxedSumDataCon con    = returnUnboxedTuple d s p args @@ -845,10 +668,7 @@    = do alloc_con <- mkConAppCode d s p con args         platform <- profilePlatform <$> getProfile         return (alloc_con         `appOL`-                mkSlideW 1 (bytesToWords platform $ d - s) `snocOL`-                if isUnliftedTypeKind (tyConResKind (dataConTyCon con))-                then RETURN_UNLIFTED P-                else ENTER)+                mkSlideW 1 (bytesToWords platform $ d - s) `snocOL` RETURN)     -- Case 4: Tail call of function schemeT d s p (StgApp fn args)@@ -911,15 +731,12 @@    do_pushes init_d args (map (atomRep platform) args)   where   do_pushes !d [] reps = do-        ASSERT( null reps ) return ()+        assert (null reps) return ()         (push_fn, sz) <- pushAtom d p (StgVarArg fn)         platform <- profilePlatform <$> getProfile-        ASSERT( sz == wordSize platform ) return ()+        assert (sz == wordSize platform) return ()         let slide = mkSlideB platform (d - init_d + wordSize platform) (init_d - s)-            enter = if isUnliftedType (idType fn)-                    then RETURN_UNLIFTED P-                    else ENTER-        return (push_fn `appOL` (slide `appOL` unitOL enter))+        return (push_fn `appOL` (slide `appOL` unitOL ENTER))   do_pushes !d args reps = do       let (push_apply, n, rest_of_reps) = findPushSeq reps           (these_args, rest_of_args) = splitAt n args@@ -959,6 +776,9 @@   = (PUSH_APPLY_D, 1, rest) findPushSeq (L: rest)   = (PUSH_APPLY_L, 1, rest)+findPushSeq argReps+  | any (`elem` [V16, V32, V64]) argReps+  = sorry "SIMD vector operations are not available in GHCi" findPushSeq _   = panic "GHC.StgToByteCode.findPushSeq" @@ -992,6 +812,8 @@           (isUnboxedTupleType bndr_ty || isUnboxedSumType bndr_ty) &&           length non_void_arg_reps > 1 +        ubx_frame = not ubx_tuple_frame && not (usePlainReturn bndr_ty)+         non_void_arg_reps = non_void (typeArgReps platform bndr_ty)          profiling@@ -1013,12 +835,11 @@                           not ubx_tuple_frame = 2 * wordSize platform                         | otherwise = 0 -        -- An unlifted value gets an extra info table pushed on top-        -- when it is returned.+        -- The size of the return frame info table pointer if one exists         unlifted_itbl_size_b :: StackDepth-        unlifted_itbl_size_b | ubx_tuple_frame              = 3 * wordSize platform-                             | not (isUnliftedType bndr_ty) = 0-                             | otherwise                    = wordSize platform+        unlifted_itbl_size_b | ubx_tuple_frame = wordSize platform+                             | ubx_frame       = wordSize platform+                             | otherwise       = 0          (bndr_size, tuple_info, args_offsets)            | ubx_tuple_frame =@@ -1052,11 +873,12 @@         isAlgCase = isAlgType bndr_ty          -- given an alt, return a discr and code for it.-        codeAlt (DEFAULT, _, rhs)+        codeAlt :: CgStgAlt -> BcM (Discr, BCInstrList)+        codeAlt GenStgAlt{alt_con=DEFAULT,alt_bndrs=_,alt_rhs=rhs}            = do rhs_code <- schemeE d_alts s p_alts rhs                 return (NoDiscr, rhs_code) -        codeAlt alt@(_, bndrs, rhs)+        codeAlt alt@GenStgAlt{alt_con=_, alt_bndrs=bndrs, alt_rhs=rhs}            -- primitive or nullary constructor alt: no need to UNPACK            | null real_bndrs = do                 rhs_code <- schemeE d_alts s p_alts rhs@@ -1099,37 +921,33 @@                         | (NonVoid arg, offset) <- args_offsets ]                         p_alts -                 -- unlifted datatypes have an infotable word on top-                 unpack = if isUnliftedType bndr_ty-                          then PUSH_L 1 `consOL`-                               UNPACK (trunc16W size) `consOL`-                               unitOL (SLIDE (trunc16W size) 1)-                          else unitOL (UNPACK (trunc16W size))              in do-             MASSERT(isAlgCase)+             massert isAlgCase              rhs_code <- schemeE stack_bot s p' rhs-             return (my_discr alt, unpack `appOL` rhs_code)+             return (my_discr alt,+                     unitOL (UNPACK (trunc16W size)) `appOL` rhs_code)            where              real_bndrs = filterOut isTyVar bndrs -        my_discr (DEFAULT, _, _) = NoDiscr {-shouldn't really happen-}-        my_discr (DataAlt dc, _, _)-           | isUnboxedTupleDataCon dc || isUnboxedSumDataCon dc-           = NoDiscr-           | otherwise-           = DiscrP (fromIntegral (dataConTag dc - fIRST_TAG))-        my_discr (LitAlt l, _, _)-           = case l of LitNumber LitNumInt i  -> DiscrI (fromInteger i)-                       LitNumber LitNumWord w -> DiscrW (fromInteger w)-                       LitFloat r   -> DiscrF (fromRational r)-                       LitDouble r  -> DiscrD (fromRational r)-                       LitChar i    -> DiscrI (ord i)-                       _ -> pprPanic "schemeE(StgCase).my_discr" (ppr l)+        my_discr alt = case alt_con alt of+            DEFAULT    -> NoDiscr {-shouldn't really happen-}+            DataAlt dc+              | isUnboxedTupleDataCon dc || isUnboxedSumDataCon dc+              -> NoDiscr+              | otherwise+              -> DiscrP (fromIntegral (dataConTag dc - fIRST_TAG))+            LitAlt l -> case l of+              LitNumber LitNumInt i  -> DiscrI (fromInteger i)+              LitNumber LitNumWord w -> DiscrW (fromInteger w)+              LitFloat r             -> DiscrF (fromRational r)+              LitDouble r            -> DiscrD (fromRational r)+              LitChar i              -> DiscrI (ord i)+              _ -> pprPanic "schemeE(StgCase).my_discr" (ppr l)          maybe_ncons            | not isAlgCase = Nothing            | otherwise-           = case [dc | (DataAlt dc, _, _) <- alts] of+           = case [dc | DataAlt dc <- alt_con <$> alts] of                 []     -> Nothing                 (dc:_) -> Just (tyConFamilySize (dataConTyCon dc)) @@ -1178,8 +996,12 @@         bitmap = intsToReverseBitmap platform bitmap_size'{-size-} pointers       alt_stuff <- mapM codeAlt alts-     alt_final <- mkMultiBranch maybe_ncons alt_stuff+     alt_final0 <- mkMultiBranch maybe_ncons alt_stuff +     let alt_final+           | ubx_tuple_frame    = mkSlideW 0 2 `mappend` alt_final0+           | otherwise          = alt_final0+      let          alt_bco_name = getName bndr          alt_bco = mkProtoBCO platform alt_bco_name alt_final (Left alts)@@ -1197,7 +1019,7 @@               return (PUSH_ALTS_TUPLE alt_bco' tuple_info tuple_bco                       `consOL` scrut_code)        else let push_alts-                  | not (isUnliftedType bndr_ty)+                  | not ubx_frame                   = PUSH_ALTS alt_bco'                   | otherwise                   = let unlifted_rep =@@ -1275,9 +1097,21 @@                   (orig_stk_params ++ map get_byte_off new_stk_params)      ) +{-+  We use the plain return convention (ENTER/PUSH_ALTS) for+  lifted types and unlifted algebraic types.++  Other types use PUSH_ALTS_UNLIFTED/PUSH_ALTS_TUPLE which expect+  additional data on the stack.+ -}+usePlainReturn :: Type -> Bool+usePlainReturn t+  | isUnboxedTupleType t || isUnboxedSumType t = False+  | otherwise = typePrimRep t == [LiftedRep] ||+                (typePrimRep t == [UnliftedRep] && isAlgType t)+ {- Note [unboxed tuple bytecodes and tuple_BCO] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-   We have the bytecode instructions RETURN_TUPLE and PUSH_ALTS_TUPLE to   return and receive arbitrary unboxed tuples, respectively. These   instructions use the helper data tuple_BCO and tuple_info.@@ -1617,7 +1451,9 @@      AddrRep     -> FFIPointer      FloatRep    -> FFIFloat      DoubleRep   -> FFIDouble-     _           -> panic "primRepToFFIType"+     LiftedRep   -> FFIPointer+     UnliftedRep -> FFIPointer+     _           -> pprPanic "primRepToFFIType" (ppr r)   where     (signed_word, unsigned_word) = case platformWordSize platform of        PW4 -> (FFISInt32, FFIUInt32)@@ -1628,19 +1464,21 @@ mkDummyLiteral :: Platform -> PrimRep -> Literal mkDummyLiteral platform pr    = case pr of-        IntRep    -> mkLitInt  platform 0-        WordRep   -> mkLitWord platform 0-        Int8Rep   -> mkLitInt8 0-        Word8Rep  -> mkLitWord8 0-        Int16Rep  -> mkLitInt16 0-        Word16Rep -> mkLitWord16 0-        Int32Rep  -> mkLitInt32 0-        Word32Rep -> mkLitWord32 0-        Int64Rep  -> mkLitInt64 0-        Word64Rep -> mkLitWord64 0-        AddrRep   -> LitNullAddr-        DoubleRep -> LitDouble 0-        FloatRep  -> LitFloat 0+        IntRep      -> mkLitInt  platform 0+        WordRep     -> mkLitWord platform 0+        Int8Rep     -> mkLitInt8 0+        Word8Rep    -> mkLitWord8 0+        Int16Rep    -> mkLitInt16 0+        Word16Rep   -> mkLitWord16 0+        Int32Rep    -> mkLitInt32 0+        Word32Rep   -> mkLitWord32 0+        Int64Rep    -> mkLitInt64 0+        Word64Rep   -> mkLitWord64 0+        AddrRep     -> LitNullAddr+        DoubleRep   -> LitDouble 0+        FloatRep    -> LitFloat 0+        LiftedRep   -> LitNullAddr+        UnliftedRep -> LitNullAddr         _         -> pprPanic "mkDummyLiteral" (ppr pr)  @@ -1671,9 +1509,7 @@        case r_reps of          []            -> panic "empty typePrimRepArgs"          [VoidRep]     -> Nothing-         [rep]-           | isGcPtrRep rep -> blargh-           | otherwise      -> Just rep+         [rep]         -> Just rep                   -- if it was, it would be impossible to create a                  -- valid return value placeholder on the stack@@ -1742,7 +1578,7 @@     -> BcM BCInstrList -- See Note [Implementing tagToEnum#] implement_tagToId d s p arg names-  = ASSERT( notNull names )+  = assert (notNull names) $     do (push_arg, arg_bytes) <- pushAtom d p (StgVarArg arg)        labels <- getLabelsBc (genericLength names)        label_fail <- getLabelBc@@ -1835,7 +1671,7 @@               fromIntegral $ ptrToWordPtr $ fromRemotePtr ptr             Nothing -> do                 let sz = idSizeCon platform var-                MASSERT( sz == wordSize platform )+                massert (sz == wordSize platform)                 return (unitOL (PUSH_G (getName var)), sz)  @@ -1889,11 +1725,9 @@           LitNumWord32  -> code Word32Rep           LitNumInt64   -> code Int64Rep           LitNumWord64  -> code Word64Rep-          -- No LitInteger's or LitNatural's should be left by the time this is-          -- called. CorePrep should have converted them all to a real core-          -- representation.-          LitNumInteger -> panic "pushAtom: LitInteger"-          LitNumNatural -> panic "pushAtom: LitNatural"+          -- No LitNumBigNat should be left by the time this is called. CorePrep+          -- should have converted them all to a real core representation.+          LitNumBigNat  -> panic "pushAtom: LitNumBigNat"  -- | Push an atom for constructor (i.e., PACK instruction) onto the stack. -- This is slightly different to @pushAtom@ due to the fact that we allow@@ -1957,7 +1791,9 @@             | otherwise             = return (testEQ (fst val) lbl_default `consOL` snd val) -            -- Note [CASEFAIL] It may be that this case has no default+            -- Note [CASEFAIL]+            -- ~~~~~~~~~~~~~~~+            -- It may be that this case has no default             -- branch, but the alternatives are not exhaustive - this             -- happens for GADT cases for example, where the types             -- prove that certain branches are impossible.  We could@@ -2160,7 +1996,6 @@ data BcM_State    = BcM_State         { bcm_hsc_env :: HscEnv-        , uniqSupply  :: UniqSupply      -- for generating fresh variable names         , thisModule  :: Module          -- current module (for breakpoints)         , nextlabel   :: Word32          -- for generating local labels         , ffis        :: [FFIInfo]       -- ffi info blocks, to free later@@ -2178,12 +2013,12 @@   x <- io   return (st, x) -runBc :: HscEnv -> UniqSupply -> Module -> Maybe ModBreaks+runBc :: HscEnv -> Module -> Maybe ModBreaks       -> IdEnv (RemotePtr ())       -> BcM r       -> IO (BcM_State, r)-runBc hsc_env us this_mod modBreaks topStrings (BcM m)-   = m (BcM_State hsc_env us this_mod 0 [] modBreaks IntMap.empty topStrings)+runBc hsc_env this_mod modBreaks topStrings (BcM m)+   = m (BcM_State hsc_env this_mod 0 [] modBreaks IntMap.empty topStrings)  thenBc :: BcM a -> (a -> BcM b) -> BcM b thenBc (BcM expr) cont = BcM $ \st0 -> do@@ -2249,22 +2084,11 @@ newBreakInfo ix info = BcM $ \st ->   return (st{breakInfo = IntMap.insert ix info (breakInfo st)}, ()) -newUnique :: BcM Unique-newUnique = BcM $-   \st -> case takeUniqFromSupply (uniqSupply st) of-             (uniq, us) -> let newState = st { uniqSupply = us }-                           in  return (newState, uniq)- getCurrentModule :: BcM Module getCurrentModule = BcM $ \st -> return (st, thisModule st)  getTopStrings :: BcM (IdEnv (RemotePtr ())) getTopStrings = BcM $ \st -> return (st, topStrings st)--newId :: Type -> BcM Id-newId ty = do-    uniq <- newUnique-    return $ mkSysLocal tickFS uniq Many ty  tickFS :: FastString tickFS = fsLit "ticked"
GHC/StgToCmm.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE DataKinds #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE LambdaCase #-}@@ -13,14 +13,9 @@  module GHC.StgToCmm ( codeGen ) where -#include "HsVersions.h"- import GHC.Prelude as Prelude -import GHC.Driver.Backend-import GHC.Driver.Session--import GHC.StgToCmm.Prof (initInfoTableProv, initCostCentres, ldvEnter)+import GHC.StgToCmm.Prof (initCostCentres, ldvEnter) import GHC.StgToCmm.Monad import GHC.StgToCmm.Env import GHC.StgToCmm.Bind@@ -28,6 +23,7 @@ import GHC.StgToCmm.Layout import GHC.StgToCmm.Utils import GHC.StgToCmm.Closure+import GHC.StgToCmm.Config import GHC.StgToCmm.Hpc import GHC.StgToCmm.Ticky import GHC.StgToCmm.Types (ModuleLFInfos)@@ -49,7 +45,6 @@ import GHC.Types.Var.Set ( isEmptyDVarSet ) import GHC.Types.Unique.FM import GHC.Types.Name.Env-import GHC.Types.ForeignStubs  import GHC.Core.DataCon import GHC.Core.TyCon@@ -59,7 +54,7 @@  import GHC.Utils.Error import GHC.Utils.Outputable-import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Utils.Logger  import GHC.Utils.TmpFs@@ -72,50 +67,38 @@ import GHC.Utils.Misc import System.IO.Unsafe import qualified Data.ByteString as BS-import Data.Maybe import Data.IORef--data CodeGenState = CodeGenState { codegen_used_info :: !(OrdList CmmInfoTable)-                                 , codegen_state :: !CgState }-+import GHC.Utils.Panic (assertPpr)  codeGen :: Logger         -> TmpFs-        -> DynFlags-        -> Module+        -> StgToCmmConfig         -> InfoTableProvMap         -> [TyCon]         -> CollectedCCs                -- (Local/global) cost-centres needing declaring/registering.         -> [CgStgTopBinding]           -- Bindings to convert         -> HpcInfo-        -> Stream IO CmmGroup (CStub, ModuleLFInfos)       -- Output as a stream, so codegen can+        -> Stream IO CmmGroup ModuleLFInfos       -- Output as a stream, so codegen can                                        -- be interleaved with output -codeGen logger tmpfs dflags this_mod ip_map@(InfoTableProvMap (UniqMap denv) _) data_tycons+codeGen logger tmpfs cfg (InfoTableProvMap (UniqMap denv) _ _) data_tycons         cost_centre_info stg_binds hpc_info   = do  {     -- cg: run the code generator, and yield the resulting CmmGroup               -- Using an IORef to store the state is a bit crude, but otherwise               -- we would need to add a state monad layer which regresses               -- allocations by 0.5-2%.-        ; cgref <- liftIO $ initC >>= \s -> newIORef (CodeGenState mempty s)+        ; cgref <- liftIO $ initC >>= \s -> newIORef s         ; let cg :: FCode a -> Stream IO CmmGroup a               cg fcode = do-                (a, cmm) <- liftIO . withTimingSilent logger dflags (text "STG -> Cmm") (`seq` ()) $ do-                         CodeGenState ts st <- readIORef cgref-                         let (a,st') = runC dflags this_mod st (getCmm fcode)+                (a, cmm) <- liftIO . withTimingSilent logger (text "STG -> Cmm") (`seq` ()) $ do+                         st <- readIORef cgref+                         let fstate = initFCodeState $ stgToCmmPlatform cfg+                         let (a,st') = runC cfg fstate st (getCmm fcode)                           -- NB. stub-out cgs_tops and cgs_stmts.  This fixes                          -- a big space leak.  DO NOT REMOVE!                          -- This is observed by the #3294 test-                         let !used_info-                                | gopt Opt_InfoTableMap dflags = toOL (mapMaybe topInfoTable (snd a)) `mappend` ts-                                | otherwise = mempty-                         writeIORef cgref $!-                                    CodeGenState used_info-                                      (st'{ cgs_tops = nilOL,-                                            cgs_stmts = mkNop-                                          })-+                         writeIORef cgref $! (st'{ cgs_tops = nilOL, cgs_stmts = mkNop })                          return a                 yield cmm                 return a@@ -124,9 +107,9 @@                -- FIRST.  This is because when -split-objs is on we need to                -- combine this block with its initialisation routines; see                -- Note [pipeline-split-init].-        ; cg (mkModuleInit cost_centre_info this_mod hpc_info)+        ; cg (mkModuleInit cost_centre_info (stgToCmmThisModule cfg) hpc_info) -        ; mapM_ (cg . cgTopBinding logger tmpfs dflags) stg_binds+        ; mapM_ (cg . cgTopBinding logger tmpfs cfg) stg_binds                 -- Put datatype_stuff after code_stuff, because the                 -- datatype closure table (for enumeration types) to                 -- (say) PrelBase_True_closure, which is defined in@@ -143,13 +126,10 @@          -- Emit special info tables for everything used in this module         -- This will only do something if  `-fdistinct-info-tables` is turned on.-        ; mapM_ (\(dc, ns) -> forM_ ns $ \(k, _ss) -> cg (cgDataCon (UsageSite this_mod k) dc)) (nonDetEltsUFM denv)+        ; mapM_ (\(dc, ns) -> forM_ ns $ \(k, _ss) -> cg (cgDataCon (UsageSite (stgToCmmThisModule cfg) k) dc)) (nonDetEltsUFM denv)          ; final_state <- liftIO (readIORef cgref)-        ; let cg_id_infos = cgs_binds . codegen_state $ final_state-              used_info = fromOL . codegen_used_info $ final_state--        ; !foreign_stub <- cg (initInfoTableProv used_info ip_map this_mod)+        ; let cg_id_infos = cgs_binds final_state            -- See Note [Conveying CAF-info and LFInfo between modules] in           -- GHC.StgToCmm.Types@@ -159,12 +139,12 @@                   !lf = cg_lf info                !generatedInfo-                | gopt Opt_OmitInterfacePragmas dflags+                | stgToCmmOmitIfPragmas cfg                 = emptyNameEnv                 | otherwise-                = mkNameEnv (Prelude.map extractInfo (eltsUFM cg_id_infos))+                = mkNameEnv (Prelude.map extractInfo (nonDetEltsUFM cg_id_infos)) -        ; return (foreign_stub, generatedInfo)+        ; return generatedInfo         }  ---------------------------------------------------------------@@ -181,17 +161,17 @@ style, with the increasing static environment being plumbed as a state variable. -} -cgTopBinding :: Logger -> TmpFs -> DynFlags -> CgStgTopBinding -> FCode ()-cgTopBinding logger tmpfs dflags = \case+cgTopBinding :: Logger -> TmpFs -> StgToCmmConfig -> CgStgTopBinding -> FCode ()+cgTopBinding logger tmpfs cfg = \case     StgTopLifted (StgNonRec id rhs) -> do-        let (info, fcode) = cgTopRhs dflags NonRecursive id rhs+        let (info, fcode) = cgTopRhs cfg NonRecursive id rhs         fcode         addBindC info      StgTopLifted (StgRec pairs) -> do         let (bndrs, rhss) = unzip pairs         let pairs' = zip bndrs rhss-            r = unzipWith (cgTopRhs dflags Recursive) pairs'+            r = unzipWith (cgTopRhs cfg Recursive) pairs'             (infos, fcodes) = unzip r         addBindsC infos         sequence_ fcodes@@ -201,31 +181,31 @@         -- emit either a CmmString literal or dump the string in a file and emit a         -- CmmFileEmbed literal.         -- See Note [Embedding large binary blobs] in GHC.CmmToAsm.Ppr-        let isNCG    = backend dflags == NCG-            isSmall  = fromIntegral (BS.length str) <= binBlobThreshold dflags-            asString = binBlobThreshold dflags == 0 || isSmall+        let asString = case stgToCmmBinBlobThresh cfg of+              Just bin_blob_threshold -> fromIntegral (BS.length str) <= bin_blob_threshold+              Nothing                -> True -            (lit,decl) = if not isNCG || asString+            (lit,decl) = if asString               then mkByteStringCLit label str               else mkFileEmbedLit label $ unsafePerformIO $ do-                     bFile <- newTempName logger tmpfs dflags TFL_CurrentModule ".dat"+                     bFile <- newTempName logger tmpfs (stgToCmmTmpDir cfg) TFL_CurrentModule ".dat"                      BS.writeFile bFile str                      return bFile         emitDecl decl-        addBindC (litIdInfo (targetPlatform dflags) id mkLFStringLit lit)+        addBindC (litIdInfo (stgToCmmPlatform cfg) id mkLFStringLit lit)  -cgTopRhs :: DynFlags -> RecFlag -> Id -> CgStgRhs -> (CgIdInfo, FCode ())+cgTopRhs :: StgToCmmConfig -> RecFlag -> Id -> CgStgRhs -> (CgIdInfo, FCode ())         -- The Id is passed along for setting up a binding... -cgTopRhs dflags _rec bndr (StgRhsCon _cc con mn _ts args)-  = cgTopRhsCon dflags bndr con mn (assertNonVoidStgArgs args)+cgTopRhs cfg _rec bndr (StgRhsCon _cc con mn _ts args)+  = cgTopRhsCon cfg bndr con mn (assertNonVoidStgArgs args)       -- con args are always non-void,       -- see Note [Post-unarisation invariants] in GHC.Stg.Unarise -cgTopRhs dflags rec bndr (StgRhsClosure fvs cc upd_flag args body)-  = ASSERT(isEmptyDVarSet fvs)    -- There should be no free variables-    cgTopRhsClosure (targetPlatform dflags) rec bndr cc upd_flag args body+cgTopRhs cfg rec bndr (StgRhsClosure fvs cc upd_flag args body)+  = assertPpr (isEmptyDVarSet fvs) (text "fvs:" <> ppr fvs) $   -- There should be no free variables+    cgTopRhsClosure (stgToCmmPlatform cfg) rec bndr cc upd_flag args body   ---------------------------------------------------------------@@ -252,8 +232,8 @@ cgEnumerationTyCon :: TyCon -> FCode () cgEnumerationTyCon tycon   = do platform <- getPlatform-       emitRODataLits (mkLocalClosureTableLabel (tyConName tycon) NoCafRefs)-             [ CmmLabelOff (mkLocalClosureLabel (dataConName con) NoCafRefs)+       emitRODataLits (mkClosureTableLabel (tyConName tycon) NoCafRefs)+             [ CmmLabelOff (mkClosureLabel (dataConName con) NoCafRefs)                            (tagForCon platform con)              | con <- tyConDataCons tycon] @@ -262,7 +242,7 @@ -- Generate the entry code, info tables, and (for niladic constructor) -- the static closure, for a constructor. cgDataCon mn data_con-  = do  { MASSERT( not (isUnboxedTupleDataCon data_con || isUnboxedSumDataCon data_con) )+  = do  { massert (not (isUnboxedTupleDataCon data_con || isUnboxedSumDataCon data_con))         ; profile <- getProfile         ; platform <- getPlatform         ; let
GHC/StgToCmm/ArgRep.hs view
@@ -52,6 +52,7 @@             | V16 -- 16-byte (128-bit) vectors of Float/Double/Int8/Word32/etc.             | V32 -- 32-byte (256-bit) vectors of Float/Double/Int8/Word32/etc.             | V64 -- 64-byte (512-bit) vectors of Float/Double/Int8/Word32/etc.+            deriving Eq instance Outputable ArgRep where ppr = text . argRepString  argRepString :: ArgRep -> String@@ -120,11 +121,11 @@ --  * GHC.StgToCmm.Layout.stdPattern maybe to some degree? -- --  * the RTS_RET(stg_ap_*) and RTS_FUN_DECL(stg_ap_*_fast)---  declarations in includes/stg/MiscClosures.h+--  declarations in rts/include/stg/MiscClosures.h -----  * the SLOW_CALL_*_ctr declarations in includes/stg/Ticky.h,+--  * the SLOW_CALL_*_ctr declarations in rts/include/stg/Ticky.h, -----  * the TICK_SLOW_CALL_*() #defines in includes/Cmm.h,+--  * the TICK_SLOW_CALL_*() #defines in rts/include/Cmm.h, -- --  * the PR_CTR(SLOW_CALL_*_ctr) calls in rts/Ticky.c, --
GHC/StgToCmm/Bind.hs view
@@ -15,9 +15,16 @@  import GHC.Prelude hiding ((<*>)) +import GHC.Core          ( AltCon(..) )+import GHC.Runtime.Heap.Layout+import GHC.Unit.Module++import GHC.Stg.Syntax+ import GHC.Platform import GHC.Platform.Profile +import GHC.StgToCmm.Config import GHC.StgToCmm.Expr import GHC.StgToCmm.Monad import GHC.StgToCmm.Env@@ -25,6 +32,7 @@ import GHC.StgToCmm.Heap import GHC.StgToCmm.Prof (ldvEnterClosure, enterCostCentreFun, enterCostCentreThunk,                    initUpdFrameProf)+import GHC.StgToCmm.TagCheck import GHC.StgToCmm.Ticky import GHC.StgToCmm.Layout import GHC.StgToCmm.Utils@@ -32,29 +40,27 @@ import GHC.StgToCmm.Foreign    (emitPrimCall)  import GHC.Cmm.Graph-import GHC.Core          ( AltCon(..) ) import GHC.Cmm.BlockId-import GHC.Runtime.Heap.Layout import GHC.Cmm import GHC.Cmm.Info import GHC.Cmm.Utils import GHC.Cmm.CLabel-import GHC.Stg.Syntax++import GHC.Stg.Utils import GHC.Types.CostCentre import GHC.Types.Id import GHC.Types.Id.Info import GHC.Types.Name-import GHC.Unit.Module-import GHC.Data.List.SetOps-import GHC.Utils.Misc import GHC.Types.Var.Set import GHC.Types.Basic import GHC.Types.Tickish ( tickishIsCode )++import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic+ import GHC.Data.FastString-import GHC.Driver.Session-import GHC.Driver.Ppr+import GHC.Data.List.SetOps  import Control.Monad @@ -75,7 +81,7 @@                 -> (CgIdInfo, FCode ())  cgTopRhsClosure platform rec id ccs upd_flag args body =-  let closure_label = mkLocalClosureLabel (idName id) (idCafInfo id)+  let closure_label = mkClosureLabel (idName id) (idCafInfo id)       cg_id_info    = litIdInfo platform id lf_info (CmmLabel closure_label)       lf_info       = mkClosureLFInfo platform id TopLevel [] upd_flag args   in (cg_id_info, gen_code lf_info closure_label)@@ -86,7 +92,7 @@   -- shortcutting the whole process, and generating a lot less code   -- (#7308). Eventually the IND_STATIC closure will be eliminated   -- by assembly '.equiv' directives, where possible (#15155).-  -- See note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel".+  -- See Note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel".   --   -- Note: we omit the optimisation when this binding is part of a   -- recursive group, because the optimisation would inhibit the black@@ -101,10 +107,9 @@    gen_code lf_info _closure_label    = do { profile <- getProfile-        ; dflags <- getDynFlags         ; let name = idName id         ; mod_name <- getModuleName-        ; let descr         = closureDescription dflags mod_name name+        ; let descr         = closureDescription mod_name name               closure_info  = mkClosureInfo profile True id lf_info 0 0 descr          -- We don't generate the static closure here, because we might@@ -144,7 +149,7 @@         ;  emit (catAGraphs inits <*> body) }  {- Note [cgBind rec]-+   ~~~~~~~~~~~~~~~~~    Recursive let-bindings are tricky.    Consider the following pseudocode: @@ -207,21 +212,28 @@                )  cgRhs id (StgRhsCon cc con mn _ts args)-  = withNewTickyCounterCon (idName id) con $+  = withNewTickyCounterCon id con mn $     buildDynCon id mn True cc con (assertNonVoidStgArgs args)       -- con args are always non-void,       -- see Note [Post-unarisation invariants] in GHC.Stg.Unarise  {- See Note [GC recovery] in "GHC.StgToCmm.Closure" -} cgRhs id (StgRhsClosure fvs cc upd_flag args body)-  = do profile <- getProfile-       mkRhsClosure profile id cc (nonVoidIds (dVarSetElems fvs)) upd_flag args body+  = do+    checkFunctionArgTags (text "TagCheck Failed: Rhs of" <> ppr id) id args+    profile <- getProfile+    check_tags <- stgToCmmDoTagCheck <$> getStgToCmmConfig+    use_std_ap_thunk <- stgToCmmTickyAP <$> getStgToCmmConfig+    mkRhsClosure profile use_std_ap_thunk check_tags id cc (nonVoidIds (dVarSetElems fvs)) upd_flag args body  ------------------------------------------------------------------------ --              Non-constructor right hand sides ------------------------------------------------------------------------ -mkRhsClosure :: Profile -> Id -> CostCentreStack+mkRhsClosure :: Profile+             -> Bool                            -- Omit AP Thunks to improve profiling+             -> Bool                            -- Lint tag inference checks+             -> Id -> CostCentreStack              -> [NonVoid Id]                    -- Free vars              -> UpdateFlag              -> [Id]                            -- Args@@ -263,8 +275,8 @@  -} ----------- Note [Selectors] -------------------mkRhsClosure    profile bndr _cc+---------- See Note [Selectors] ------------------+mkRhsClosure    profile _ _check_tags bndr _cc                 [NonVoid the_fv]                -- Just one free var                 upd_flag                -- Updatable thunk                 []                      -- A thunk@@ -273,7 +285,9 @@   , StgCase (StgApp scrutinee [{-no args-}])          _   -- ignore bndr          (AlgAlt _)-         [(DataAlt _, params, sel_expr)] <- strip expr+         [GenStgAlt{ alt_con   = DataAlt _+                   , alt_bndrs = params+                   , alt_rhs   = sel_expr}] <- strip expr   , StgApp selectee [{-no args-}] <- strip sel_expr   , the_fv == scrutinee                -- Scrutinee is the only free variable @@ -285,7 +299,7 @@   , let offset_into_int = bytesToWordsRoundUp (profilePlatform profile) the_offset                           - fixedHdrSizeW profile   , offset_into_int <= pc_MAX_SPEC_SELECTEE_SIZE (profileConstants profile) -- Offset is small enough-  = -- NOT TRUE: ASSERT(is_single_constructor)+  = -- NOT TRUE: assert (is_single_constructor)     -- The simplifier may have statically determined that the single alternative     -- is the only possible case and eliminated the others, even if there are     -- other constructors in the datatype.  It's still ok to make a selector@@ -296,8 +310,8 @@     let lf_info = mkSelectorLFInfo bndr offset_into_int (isUpdatable upd_flag)     in cgRhsStdThunk bndr lf_info [StgVarArg the_fv] ----------- Note [Ap thunks] -------------------mkRhsClosure    profile bndr _cc+---------- See Note [Ap thunks] ------------------+mkRhsClosure    profile use_std_ap check_tags bndr _cc                 fvs                 upd_flag                 []                      -- No args; a thunk@@ -306,7 +320,8 @@   -- We are looking for an "ApThunk"; see data con ApThunk in GHC.StgToCmm.Closure   -- of form (x1 x2 .... xn), where all the xi are locals (not top-level)   -- So the xi will all be free variables-  | args `lengthIs` (n_fvs-1)  -- This happens only if the fun_id and+  | use_std_ap+  , args `lengthIs` (n_fvs-1)  -- This happens only if the fun_id and                                -- args are all distinct local variables                                -- The "-1" is for fun_id     -- Missed opportunity:   (f x x) is not detected@@ -318,8 +333,8 @@                          -- lose information about this particular                          -- thunk (e.g. its type) (#949)   , idArity fun_id == unknownArity -- don't spoil a known call-           -- Ha! an Ap thunk+  , not check_tags -- See Note [Tag inference debugging]   = cgRhsStdThunk bndr lf_info payload    where@@ -330,7 +345,7 @@     payload = StgVarArg fun_id : args  ---------- Default case -------------------mkRhsClosure profile bndr cc fvs upd_flag args body+mkRhsClosure profile _use_ap _check_tags bndr cc fvs upd_flag args body   = do  { let lf_info = mkClosureLFInfo (profilePlatform profile) bndr NotTopLevel fvs upd_flag args         ; (id_info, reg) <- rhsIdInfo bndr lf_info         ; return (id_info, gen_code lf_info reg) }@@ -351,9 +366,8 @@          -- MAKE CLOSURE INFO FOR THIS CLOSURE         ; mod_name <- getModuleName-        ; dflags <- getDynFlags         ; let   name  = idName bndr-                descr = closureDescription dflags mod_name name+                descr = closureDescription mod_name name                 fv_details :: [(NonVoid Id, ByteOff)]                 header = if isLFThunk lf_info then ThunkHeader else StdHeader                 (tot_wds, ptr_wds, fv_details)@@ -395,19 +409,19 @@        }  where  gen_code reg  -- AHA!  A STANDARD-FORM THUNK-  = withNewTickyCounterStdThunk (lfUpdatable lf_info) (idName bndr) $+  = withNewTickyCounterStdThunk (lfUpdatable lf_info) (bndr) payload $     do   {     -- LAY OUT THE OBJECT     mod_name <- getModuleName-  ; dflags <- getDynFlags-  ; profile <- getProfile-  ; let platform = profilePlatform profile+  ; profile  <- getProfile+  ; platform <- getPlatform+  ; let         header = if isLFThunk lf_info then ThunkHeader else StdHeader         (tot_wds, ptr_wds, payload_w_offsets)             = mkVirtHeapOffsets profile header                 (addArgReps (nonVoidStgArgs payload)) -        descr = closureDescription dflags mod_name (idName bndr)+        descr = closureDescription mod_name (idName bndr)         closure_info = mkClosureInfo profile False       -- Not static                                      bndr lf_info tot_wds ptr_wds                                      descr@@ -467,7 +481,8 @@   = withNewTickyCounterThunk         (isStaticClosure cl_info)         (closureUpdReqd cl_info)-        (closureName cl_info) $+        (closureName cl_info)+        (map fst fv_details) $     emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl [] $       \(_, node, _) -> thunkCode cl_info fv_details cc node body    where@@ -479,7 +494,7 @@         arity = length args     in     -- See Note [OneShotInfo overview] in GHC.Types.Basic.-    withNewTickyCounterFun (isOneShotBndr arg0) (closureName cl_info)+    withNewTickyCounterFun (isOneShotBndr arg0) (closureName cl_info) (map fst fv_details)         nv_args $ do {          ; let@@ -515,6 +530,7 @@                 -- Load free vars out of closure *after*                 -- heap check, to reduce live vars over check                 ; when node_points $ load_fvs node lf_info fv_bindings+                ; checkFunctionArgTags (text "TagCheck failed - Argument to local function:" <> ppr bndr) bndr (map fromNonVoid nv_args)                 ; void $ cgExpr body                 }}} @@ -522,7 +538,6 @@  -- Note [NodeReg clobbered with loopification] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- -- Previously we used to pass nodeReg (aka R1) here. With profiling, upon -- entering a closure, enterFunCCS was called with R1 passed to it. But since R1 -- may get clobbered inside the body of a closure, and since a self-recursive@@ -558,16 +573,18 @@ -- Here, we emit the slow-entry code. mkSlowEntryCode bndr cl_info arg_regs -- function closure is already in `Node'   | Just (_, ArgGen _) <- closureFunInfo cl_info-  = do profile <- getProfile-       platform <- getPlatform+  = do cfg       <- getStgToCmmConfig+       upd_frame <- getUpdFrameOff        let node = idToReg platform (NonVoid bndr)+           profile  = stgToCmmProfile  cfg+           platform = stgToCmmPlatform cfg            slow_lbl = closureSlowEntryLabel  platform cl_info            fast_lbl = closureLocalEntryLabel platform cl_info            -- mkDirectJump does not clobber `Node' containing function closure            jump = mkJump profile NativeNodeCall                                 (mkLblExpr fast_lbl)                                 (map (CmmReg . CmmLocal) (node : arg_regs))-                                (initUpdFrameOff platform)+                                upd_frame        tscope <- getTickScope        emitProcWithConvention Slow Nothing slow_lbl          (node : arg_regs) (jump, tscope)@@ -615,9 +632,10 @@  emitBlackHoleCode :: CmmExpr -> FCode () emitBlackHoleCode node = do-  dflags <- getDynFlags-  profile <- getProfile-  let platform = profilePlatform profile+  cfg <- getStgToCmmConfig+  let profile     = stgToCmmProfile  cfg+      platform    = stgToCmmPlatform cfg+      is_eager_bh = stgToCmmEagerBlackHole cfg    -- Eager blackholing is normally disabled, but can be turned on with   -- -feager-blackholing.  When it is on, we replace the info pointer@@ -637,8 +655,7 @@   -- Note the eager-blackholing check is here rather than in blackHoleOnEntry,   -- because emitBlackHoleCode is called from GHC.Cmm.Parser. -  let  eager_blackholing =  not (profileIsProfiling profile)-                         && gopt Opt_EagerBlackHoling dflags+  let  eager_blackholing =  not (profileIsProfiling profile) && is_eager_bh              -- Profiling needs slop filling (to support LDV              -- profiling), so currently eager blackholing doesn't              -- work with profiling.@@ -663,11 +680,11 @@       then do tickyUpdateFrameOmitted; body       else do           tickyPushUpdateFrame-          dflags <- getDynFlags+          cfg <- getStgToCmmConfig           let-              bh = blackHoleOnEntry closure_info &&-                   not (sccProfilingEnabled dflags) &&-                   gopt Opt_EagerBlackHoling dflags+              bh = blackHoleOnEntry closure_info+                && not (stgToCmmSCCProfiling cfg)+                && stgToCmmEagerBlackHole cfg                lbl | bh        = mkBHUpdInfoLabel                   | otherwise = mkUpdInfoLabel@@ -725,11 +742,12 @@ -- This function returns the address of the black hole, so it can be -- updated with the new value when available. link_caf node = do-  { profile <- getProfile+  { cfg <- getStgToCmmConfig         -- Call the RTS function newCAF, returning the newly-allocated         -- blackhole indirection closure   ; let newCAF_lbl = mkForeignLabel (fsLit "newCAF") Nothing                                     ForeignLabelInExternalPackage IsFunction+  ; let profile  = stgToCmmProfile cfg   ; let platform = profilePlatform profile   ; bh <- newTemp (bWord platform)   ; emitRtsCallGen [(bh,AddrHint)] newCAF_lbl@@ -739,8 +757,9 @@    -- see Note [atomic CAF entry] in rts/sm/Storage.c   ; updfr  <- getUpdFrameOff-  ; ptr_opts <- getPtrOpts-  ; let target = entryCode platform (closureInfoPtr ptr_opts (CmmReg (CmmLocal node)))+  ; let align_check = stgToCmmAlignCheck cfg+  ; let target      = entryCode platform+                        (closureInfoPtr platform align_check (CmmReg (CmmLocal node)))   ; emit =<< mkCmmIfThen       (cmmEqWord platform (CmmReg (CmmLocal bh)) (zeroExpr platform))         -- re-enter the CAF@@ -757,16 +776,11 @@ -- @closureDescription@ from the let binding information.  closureDescription-   :: DynFlags-   -> Module            -- Module+   :: Module            -- Module    -> Name              -- Id of closure binding    -> String         -- Not called for StgRhsCon which have global info tables built in         -- CgConTbls.hs with a description generated from the data constructor-closureDescription dflags mod_name name-  = showSDocDump (initSDocContext dflags defaultDumpStyle) (char '<' <>-                    (if isExternalName name-                      then ppr name -- ppr will include the module name prefix-                      else pprModule mod_name <> char '.' <> ppr name) <>-                    char '>')-   -- showSDocDump, because we want to see the unique on the Name.+closureDescription mod_name name+  = renderWithContext defaultSDocContext+    (char '<' <> pprFullName mod_name name <> char '>')
GHC/StgToCmm/Closure.hs view
@@ -1,10 +1,9 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} - ----------------------------------------------------------------------------- -- -- Stg to C-- code generation:@@ -35,9 +34,9 @@         isLFThunk, isLFReEntrant, lfUpdatable,          -- * Used by other modules-        CgLoc(..), SelfLoopInfo, CallMethod(..),+        CgLoc(..), CallMethod(..),         nodeMustPointToIt, isKnownFun, funTag, tagForArity,-        CallOpts(..), getCallMethod,+        getCallMethod,          -- * ClosureInfo         ClosureInfo,@@ -66,10 +65,9 @@         cafBlackHoleInfoTable,         indStaticInfoTable,         staticClosureNeedsLink,+        mkClosureInfoTableLabel     ) where -#include "HsVersions.h"- import GHC.Prelude import GHC.Platform import GHC.Platform.Profile@@ -80,6 +78,7 @@ import GHC.Cmm.Utils import GHC.Cmm.Ppr.Expr() -- For Outputable instances import GHC.StgToCmm.Types+import GHC.StgToCmm.Sequel  import GHC.Types.CostCentre import GHC.Cmm.BlockId@@ -96,10 +95,13 @@ import GHC.Types.Basic import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Utils.Misc  import Data.Coerce (coerce) import qualified Data.ByteString.Char8 as BS8+import GHC.StgToCmm.Config+import GHC.Stg.InferTags.TagSig (isTaggedSig)  ----------------------------------------------------------------------------- --                Data types and synonyms@@ -127,8 +129,6 @@    CmmLoc e    -> text "cmm" <+> pdoc platform e    LneLoc b rs -> text "lne" <+> ppr b <+> ppr rs -type SelfLoopInfo = (Id, BlockId, [LocalReg])- -- used by ticky profiling isKnownFun :: LambdaFormInfo -> Bool isKnownFun LFReEntrant{} = True@@ -152,23 +152,23 @@   ppr (NonVoid a) = ppr a  nonVoidIds :: [Id] -> [NonVoid Id]-nonVoidIds ids = [NonVoid id | id <- ids, not (isVoidTy (idType id))]+nonVoidIds ids = [NonVoid id | id <- ids, not (isZeroBitTy (idType id))]  -- | Used in places where some invariant ensures that all these Ids are -- non-void; e.g. constructor field binders in case expressions. -- See Note [Post-unarisation invariants] in "GHC.Stg.Unarise". assertNonVoidIds :: [Id] -> [NonVoid Id]-assertNonVoidIds ids = ASSERT(not (any (isVoidTy . idType) ids))+assertNonVoidIds ids = assert (not (any (isZeroBitTy . idType) ids)) $                        coerce ids  nonVoidStgArgs :: [StgArg] -> [NonVoid StgArg]-nonVoidStgArgs args = [NonVoid arg | arg <- args, not (isVoidTy (stgArgType arg))]+nonVoidStgArgs args = [NonVoid arg | arg <- args, not (isZeroBitTy (stgArgType arg))]  -- | Used in places where some invariant ensures that all these arguments are -- non-void; e.g. constructor arguments. -- See Note [Post-unarisation invariants] in "GHC.Stg.Unarise". assertNonVoidStgArgs :: [StgArg] -> [NonVoid StgArg]-assertNonVoidStgArgs args = ASSERT(not (any (isVoidTy . stgArgType) args))+assertNonVoidStgArgs args = assert (not (any (isZeroBitTy . stgArgType) args)) $                             coerce args  @@ -209,7 +209,7 @@ mkLFArgument :: Id -> LambdaFormInfo mkLFArgument id   | isUnliftedType ty      = LFUnlifted-  | might_be_a_function ty = LFUnknown True+  | mightBeFunTy ty = LFUnknown True   | otherwise              = LFUnknown False   where     ty = idType id@@ -233,23 +233,11 @@ ------------- mkLFThunk :: Type -> TopLevelFlag -> [Id] -> UpdateFlag -> LambdaFormInfo mkLFThunk thunk_ty top fvs upd_flag-  = ASSERT( not (isUpdatable upd_flag) || not (isUnliftedType thunk_ty) )+  = assert (not (isUpdatable upd_flag) || not (isUnliftedType thunk_ty)) $     LFThunk top (null fvs)             (isUpdatable upd_flag)             NonStandardThunk-            (might_be_a_function thunk_ty)-----------------might_be_a_function :: Type -> Bool--- Return False only if we are *sure* it's a data type--- Look through newtypes etc as much as poss-might_be_a_function ty-  | [LiftedRep] <- typePrimRep ty-  , Just tc <- tyConAppTyCon_maybe (unwrapType ty)-  , isDataTyCon tc-  = False-  | otherwise-  = True+            (mightBeFunTy thunk_ty)  ------------- mkConLFInfo :: DataCon -> LambdaFormInfo@@ -259,13 +247,13 @@ mkSelectorLFInfo :: Id -> Int -> Bool -> LambdaFormInfo mkSelectorLFInfo id offset updatable   = LFThunk NotTopLevel False updatable (SelectorThunk offset)-        (might_be_a_function (idType id))+        (mightBeFunTy (idType id))  ------------- mkApLFInfo :: Id -> UpdateFlag -> Arity -> LambdaFormInfo mkApLFInfo id upd_flag arity   = LFThunk NotTopLevel (arity == 0) (isUpdatable upd_flag) (ApThunk arity)-        (might_be_a_function (idType id))+        (mightBeFunTy (idType id))  ------------- mkLFImported :: Id -> LambdaFormInfo@@ -479,27 +467,39 @@ (rather than directly) to catch double-entry. -}  data CallMethod-  = EnterIt             -- No args, not a function+  = EnterIt             -- ^ No args, not a function    | JumpToIt BlockId [LocalReg] -- A join point or a header of a local loop    | ReturnIt            -- It's a value (function, unboxed value,                         -- or constructor), so just return it. -  | SlowCall                -- Unknown fun, or known fun with+  | InferedReturnIt     -- A properly tagged value, as determined by tag inference.+                        -- See Note [Tag Inference] and Note [Tag inference passes] in+                        -- GHC.Stg.InferTags.+                        -- It behaves /precisely/ like `ReturnIt`, except that when debugging is+                        -- enabled we emit an extra assertion to check that the returned value is+                        -- properly tagged.  We can use this as a check that tag inference is working+                        -- correctly.+                        -- TODO: SPJ suggested we could combine this with EnterIt, but for now I decided+                        -- not to do so.++  | SlowCall            -- Unknown fun, or known fun with                         -- too few args.    | DirectEntry         -- Jump directly, with args in regs         CLabel          --   The code label         RepArity        --   Its arity -data CallOpts = CallOpts-   { co_profile       :: !Profile   -- ^ Platform profile-   , co_loopification :: !Bool      -- ^ Loopification enabled (cf @-floopification@)-   , co_ticky         :: !Bool      -- ^ Ticky profiling enabled (cf @-ticky@)-   }+instance Outputable CallMethod where+  ppr (EnterIt) = text "Enter"+  ppr (JumpToIt {}) = text "JumpToIt"+  ppr (ReturnIt ) = text "ReturnIt"+  ppr (InferedReturnIt) = text "InferedReturnIt"+  ppr (SlowCall ) = text "SlowCall"+  ppr (DirectEntry {}) = text "DirectEntry" -getCallMethod :: CallOpts+getCallMethod :: StgToCmmConfig               -> Name           -- Function being applied               -> Id             -- Function Id used to chech if it can refer to                                 -- CAF's and whether the function is tail-calling@@ -512,12 +512,11 @@                                 -- tail calls using the same data constructor,                                 -- JumpToIt. This saves us one case branch in                                 -- cgIdApp-              -> Maybe SelfLoopInfo -- can we perform a self-recursive tail call?+              -> Maybe SelfLoopInfo -- can we perform a self-recursive tail-call               -> CallMethod -getCallMethod opts _ id _ n_args v_args _cg_loc-              (Just (self_loop_id, block_id, args))-  | co_loopification opts+getCallMethod cfg _ id _  n_args v_args _cg_loc (Just (self_loop_id, block_id, args))+  | stgToCmmLoopification cfg   , id == self_loop_id   , args `lengthIs` (n_args - v_args)   -- If these patterns match then we know that:@@ -528,31 +527,36 @@   -- self-recursive tail calls] in GHC.StgToCmm.Expr for more details   = JumpToIt block_id args -getCallMethod opts name id (LFReEntrant _ arity _ _) n_args _v_args _cg_loc-              _self_loop_info+getCallMethod cfg name id (LFReEntrant _ arity _ _) n_args _v_args _cg_loc _self_loop_info   | n_args == 0 -- No args at all-  && not (profileIsProfiling (co_profile opts))+  && not (profileIsProfiling (stgToCmmProfile cfg))      -- See Note [Evaluating functions with profiling] in rts/Apply.cmm-  = ASSERT( arity /= 0 ) ReturnIt+  = assert (arity /= 0) ReturnIt   | n_args < arity = SlowCall        -- Not enough args-  | otherwise      = DirectEntry (enterIdLabel (profilePlatform (co_profile opts)) name (idCafInfo id)) arity+  | otherwise      = DirectEntry (enterIdLabel (stgToCmmPlatform cfg) name (idCafInfo id)) arity  getCallMethod _ _name _ LFUnlifted n_args _v_args _cg_loc _self_loop_info-  = ASSERT( n_args == 0 ) ReturnIt+  = assert (n_args == 0) ReturnIt  getCallMethod _ _name _ (LFCon _) n_args _v_args _cg_loc _self_loop_info-  = ASSERT( n_args == 0 ) ReturnIt+  = assert (n_args == 0) ReturnIt     -- n_args=0 because it'd be ill-typed to apply a saturated     --          constructor application to anything -getCallMethod opts name id (LFThunk _ _ updatable std_form_info is_fun)+getCallMethod cfg name id (LFThunk _ _ updatable std_form_info is_fun)               n_args _v_args _cg_loc _self_loop_info++  | Just sig <- idTagSig_maybe id+  , isTaggedSig sig -- Infered to be already evaluated by Tag Inference+  , n_args == 0     -- See Note [Tag Inference]+  = InferedReturnIt+   | is_fun      -- it *might* be a function, so we must "call" it (which is always safe)   = SlowCall    -- We cannot just enter it [in eval/apply, the entry code                 -- is the fast-entry code]    -- Since is_fun is False, we are *definitely* looking at a data value-  | updatable || co_ticky opts -- to catch double entry+  | updatable || stgToCmmDoTicky cfg -- to catch double entry       {- OLD: || opt_SMP          I decided to remove this, because in SMP mode it doesn't matter          if we enter the same thunk multiple times, so the optimisation@@ -565,7 +569,7 @@   | SelectorThunk{} <- std_form_info   = EnterIt -    -- We used to have ASSERT( n_args == 0 ), but actually it is+    -- We used to have assert (n_args == 0 ), but actually it is     -- possible for the optimiser to generate     --   let bot :: Int = error Int "urk"     --   in (bot `cast` unsafeCoerce Int (Int -> Int)) 3@@ -573,19 +577,33 @@     -- So the right thing to do is just to enter the thing    | otherwise        -- Jump direct to code for single-entry thunks-  = ASSERT( n_args == 0 )-    DirectEntry (thunkEntryLabel (profilePlatform (co_profile opts)) name (idCafInfo id) std_form_info+  = assert (n_args == 0) $+    DirectEntry (thunkEntryLabel (stgToCmmPlatform cfg) name (idCafInfo id) std_form_info                 updatable) 0 -getCallMethod _ _name _ (LFUnknown True) _n_arg _v_args _cg_locs _self_loop_info-  = SlowCall -- might be a function+-- Imported(Unknown) Ids+getCallMethod cfg name id (LFUnknown might_be_a_function) n_args _v_args _cg_locs _self_loop_info+  | n_args == 0+  , Just sig <- idTagSig_maybe id+  , isTaggedSig sig -- Infered to be already evaluated by Tag Inference+  -- When profiling we must enter all potential functions to make sure we update the SCC+  -- even if the function itself is already evaluated.+  -- See Note [Evaluating functions with profiling] in rts/Apply.cmm+  , not (profileIsProfiling (stgToCmmProfile cfg) && might_be_a_function)+  = InferedReturnIt -- See Note [Tag Inference] -getCallMethod _ name _ (LFUnknown False) n_args _v_args _cg_loc _self_loop_info-  = ASSERT2( n_args == 0, ppr name <+> ppr n_args )-    EnterIt -- Not a function+  | might_be_a_function = SlowCall -getCallMethod _ _name _ LFLetNoEscape _n_args _v_args (LneLoc blk_id lne_regs)-              _self_loop_info+  | otherwise =+      assertPpr ( n_args == 0) ( ppr name <+> ppr n_args )+      EnterIt   -- Not a function++-- TODO: Redundant with above match?+-- getCallMethod _ name _ (LFUnknown False) n_args _v_args _cg_loc _self_loop_info+--   = assertPpr (n_args == 0) (ppr name <+> ppr n_args)+--     EnterIt -- Not a function++getCallMethod _ _name _ LFLetNoEscape _n_args _v_args (LneLoc blk_id lne_regs) _self_loop_info   = JumpToIt blk_id lne_regs  getCallMethod _ _ _ _ _ _ _ _ = panic "Unknown call method"@@ -613,7 +631,7 @@  data ClosureInfo   = ClosureInfo {-        closureName :: !Name,           -- The thing bound to this closure+        closureName :: !Id,           -- The thing bound to this closure            -- we don't really need this field: it's only used in generating            -- code for ticky and profiling, and we could pass the information            -- around separately, but it doesn't do much harm to keep it here.@@ -650,13 +668,12 @@               -> String         -- String descriptor               -> ClosureInfo mkClosureInfo profile is_static id lf_info tot_wds ptr_wds val_descr-  = ClosureInfo { closureName      = name+  = ClosureInfo { closureName      = id                 , closureLFInfo    = lf_info                 , closureInfoLabel = info_lbl   -- These three fields are                 , closureSMRep     = sm_rep     -- (almost) an info table                 , closureProf      = prof }     -- (we don't have an SRT yet)   where-    name       = idName id     sm_rep     = mkHeapRep profile is_static ptr_wds nonptr_wds (lfClosureType lf_info)     prof       = mkProfilingInfo profile id val_descr     nonptr_wds = tot_wds - ptr_wds@@ -810,6 +827,7 @@   | platformTablesNextToCode platform = toInfoLbl  platform . closureInfoLabel   | otherwise                         = toEntryLbl platform . closureInfoLabel +-- | Get the info table label for a *thunk*. mkClosureInfoTableLabel :: Platform -> Id -> LambdaFormInfo -> CLabel mkClosureInfoTableLabel platform id lf_info   = case lf_info of@@ -819,23 +837,14 @@         LFThunk _ _ upd_flag (ApThunk arity) _                       -> mkApInfoTableLabel platform upd_flag arity -        LFThunk{}     -> std_mk_lbl name cafs-        LFReEntrant{} -> std_mk_lbl name cafs+        LFThunk{}     -> mkInfoTableLabel name cafs+        LFReEntrant{} -> mkInfoTableLabel name cafs         _other        -> panic "closureInfoTableLabel"    where     name = idName id -    std_mk_lbl | is_local  = mkLocalInfoTableLabel-               | otherwise = mkInfoTableLabel-     cafs     = idCafInfo id-    is_local = isDataConWorkId id-       -- Make the _info pointer for the implicit datacon worker-       -- binding local. The reason we can do this is that importing-       -- code always either uses the _closure or _con_info. By the-       -- invariants in "GHC.CoreToStg.Prep" anything else gets eta expanded.-  -- | thunkEntryLabel is a local help function, not exported.  It's used from -- getCallMethod.
+ GHC/StgToCmm/Config.hs view
@@ -0,0 +1,85 @@+-- | The stg to cmm code generator configuration++module GHC.StgToCmm.Config+  ( StgToCmmConfig(..)+  , stgToCmmPlatform+  ) where++import GHC.Platform.Profile+import GHC.Platform+import GHC.Unit.Module+import GHC.Utils.Outputable+import GHC.Utils.TmpFs++import GHC.Prelude+++-- This config is static and contains information only passed *downwards* by StgToCmm.Monad+data StgToCmmConfig = StgToCmmConfig+  ----------------------------- General Settings --------------------------------+  { stgToCmmProfile       :: !Profile            -- ^ Current profile+  , stgToCmmThisModule    :: Module              -- ^ The module being compiled. This field kept lazy for+                                                 -- Cmm/Parser.y which preloads it with a panic+  , stgToCmmTmpDir        :: !TempDir            -- ^ Temp Dir for files used in compilation+  , stgToCmmContext       :: !SDocContext        -- ^ Context for StgToCmm phase+  , stgToCmmDebugLevel    :: !Int                -- ^ The verbosity of debug messages+  , stgToCmmBinBlobThresh :: !(Maybe Word)        -- ^ Threshold at which Binary literals (e.g. strings)+                                                 -- are either dumped to a file and a CmmFileEmbed literal+                                                 -- is emitted (over threshold), or become a CmmString+                                                 -- Literal (under or at threshold). CmmFileEmbed is only supported+                                                 -- with the NCG, thus a Just means two things: We have a threshold,+                                                 -- and will be using the NCG. Conversely, a Nothing implies we are not+                                                 -- using NCG and disables CmmFileEmbed. See Note+                                                 -- [Embedding large binary blobs] in GHC.CmmToAsm.Ppr, and+                                                 -- @cgTopBinding@ in GHC.StgToCmm.+  , stgToCmmMaxInlAllocSize :: !Int              -- ^ Max size, in bytes, of inline array allocations.+  ------------------------------ Ticky Options ----------------------------------+  , stgToCmmDoTicky        :: !Bool              -- ^ Ticky profiling enabled (cf @-ticky@)+  , stgToCmmTickyAllocd    :: !Bool              -- ^ True indicates ticky prof traces allocs of each named+                                                 -- thing in addition to allocs _by_ that thing+  , stgToCmmTickyLNE       :: !Bool              -- ^ True indicates ticky uses name-specific counters for+                                                 -- join-points (let-no-escape)+  , stgToCmmTickyDynThunk  :: !Bool              -- ^ True indicates ticky uses name-specific counters for+                                                 -- dynamic thunks+  , stgToCmmTickyTag       :: !Bool              -- ^ True indicates ticky will count number of avoided tag checks by tag inference.+  ---------------------------------- Flags --------------------------------------+  , stgToCmmLoopification  :: !Bool              -- ^ Loopification enabled (cf @-floopification@)+  , stgToCmmAlignCheck     :: !Bool              -- ^ Insert alignment check (cf @-falignment-sanitisation@)+  , stgToCmmOptHpc         :: !Bool              -- ^ perform code generation for code coverage+  , stgToCmmFastPAPCalls   :: !Bool              -- ^+  , stgToCmmSCCProfiling   :: !Bool              -- ^ Check if cost-centre profiling is enabled+  , stgToCmmEagerBlackHole :: !Bool              -- ^+  , stgToCmmInfoTableMap   :: !Bool              -- ^ true means generate C Stub for IPE map, See note [Mapping+                                                 -- Info Tables to Source Positions]+  , stgToCmmOmitYields     :: !Bool              -- ^ true means omit heap checks when no allocation is performed+  , stgToCmmOmitIfPragmas  :: !Bool              -- ^ true means don't generate interface programs (implied by -O0)+  , stgToCmmPIC            :: !Bool              -- ^ true if @-fPIC@+  , stgToCmmPIE            :: !Bool              -- ^ true if @-fPIE@+  , stgToCmmExtDynRefs     :: !Bool              -- ^ true if @-fexternal-dynamic-refs@, meaning generate+                                                 -- code for linking against dynamic libraries+  , stgToCmmDoBoundsCheck  :: !Bool              -- ^ decides whether to check array bounds in StgToCmm.Prim+                                                 -- or not+  , stgToCmmDoTagCheck     :: !Bool              -- ^ Verify tag inference predictions.+  ------------------------------ Backend Flags ----------------------------------+  , stgToCmmAllowBigArith             :: !Bool   -- ^ Allowed to emit larger than native size arithmetic (only LLVM and C backends)+  , stgToCmmAllowQuotRemInstr         :: !Bool   -- ^ Allowed to generate QuotRem instructions+  , stgToCmmAllowQuotRem2             :: !Bool   -- ^ Allowed to generate QuotRem+  , stgToCmmAllowExtendedAddSubInstrs :: !Bool   -- ^ Allowed to generate AddWordC, SubWordC, Add2, etc.+  , stgToCmmAllowIntMul2Instr         :: !Bool   -- ^ Allowed to generate IntMul2 instruction+  , stgToCmmAllowFabsInstrs           :: !Bool   -- ^ Allowed to generate Fabs instructions+  , stgToCmmTickyAP                   :: !Bool   -- ^ Disable use of precomputed standard thunks.+  ------------------------------ SIMD flags ------------------------------------+  -- Each of these flags checks vector compatibility with the backend requested+  -- during compilation. In essence, this means checking for @-fllvm@ which is+  -- the only backend that currently allows SIMD instructions, see+  -- Ghc.StgToCmm.Prim.checkVecCompatibility for these flags only call site.+  , stgToCmmVecInstrsErr   :: Maybe String       -- ^ Error (if any) to raise when vector instructions are+                                                 -- used, see @StgToCmm.Prim.checkVecCompatibility@+  , stgToCmmAvx            :: !Bool              -- ^ check for Advanced Vector Extensions+  , stgToCmmAvx2           :: !Bool              -- ^ check for Advanced Vector Extensions 2+  , stgToCmmAvx512f        :: !Bool              -- ^ check for Advanced Vector 512-bit Extensions+  }+++stgToCmmPlatform :: StgToCmmConfig -> Platform+stgToCmmPlatform = profilePlatform . stgToCmmProfile
GHC/StgToCmm/DataCon.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE CPP #-} + ----------------------------------------------------------------------------- -- -- Stg to C--: code generation for constructors@@ -15,12 +15,9 @@         cgTopRhsCon, buildDynCon, bindConArgs     ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Platform-import GHC.Platform.Profile  import GHC.Stg.Syntax import GHC.Core  ( AltCon(..) )@@ -40,7 +37,6 @@ import GHC.Types.CostCentre import GHC.Unit import GHC.Core.DataCon-import GHC.Driver.Session import GHC.Data.FastString import GHC.Types.Id import GHC.Types.Id.Info( CafInfo( NoCafRefs ) )@@ -49,24 +45,28 @@ import GHC.Types.Literal import GHC.Builtin.Utils import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Utils.Misc import GHC.Utils.Monad (mapMaybeM)  import Control.Monad import Data.Char+import GHC.StgToCmm.Config (stgToCmmPlatform)+import GHC.StgToCmm.TagCheck (checkConArgsStatic, checkConArgsDyn)+import GHC.Utils.Outputable  --------------------------------------------------------------- --      Top-level constructors --------------------------------------------------------------- -cgTopRhsCon :: DynFlags+cgTopRhsCon :: StgToCmmConfig             -> Id               -- Name of thing bound to this RHS             -> DataCon          -- Id             -> ConstructorNumber             -> [NonVoid StgArg] -- Args             -> (CgIdInfo, FCode ())-cgTopRhsCon dflags id con mn args-  | Just static_info <- precomputedStaticConInfo_maybe dflags id con args+cgTopRhsCon cfg id con mn args+  | Just static_info <- precomputedStaticConInfo_maybe cfg id con args   , let static_code | isInternalName name = pure ()                     | otherwise           = gen_code   = -- There is a pre-allocated static closure available; use it@@ -82,7 +82,7 @@   = (id_Info, gen_code)    where-   platform      = targetPlatform dflags+   platform      = stgToCmmPlatform cfg    id_Info       = litIdInfo platform id (mkConLFInfo con) (CmmLabel closure_label)    name          = idName id    caffy         = idCafInfo id -- any stgArgHasCafRefs args@@ -93,9 +93,9 @@         ; this_mod <- getModuleName         ; when (platformOS platform == OSMinGW32) $               -- Windows DLLs have a problem with static cross-DLL refs.-              MASSERT( not (isDllConApp dflags this_mod con (map fromNonVoid args)) )-        ; ASSERT( args `lengthIs` countConRepArgs con ) return ()-+              massert (not (isDllConApp platform (stgToCmmExtDynRefs cfg) this_mod con (map fromNonVoid args)))+        ; assert (args `lengthIs` countConRepArgs con ) return ()+        ; checkConArgsStatic (text "TagCheck failed - Top level con") con (map fromNonVoid args)         -- LAY IT OUT         ; let             (tot_wds, --  #ptr_wds + #nonptr_wds@@ -167,18 +167,20 @@             -> FCode (CgIdInfo, FCode CmmAGraph)                -- Return details about how to find it and initialization code buildDynCon binder mn actually_bound cc con args-    = do dflags <- getDynFlags-         buildDynCon' dflags binder mn actually_bound cc con args+    = do cfg <- getStgToCmmConfig+         --   pprTrace "noCodeLocal:" (ppr (binder,con,args,cgInfo)) True+         case precomputedStaticConInfo_maybe cfg binder con args of+           Just cgInfo -> return (cgInfo, return mkNop)+           Nothing     -> buildDynCon' binder mn actually_bound cc con args  -buildDynCon' :: DynFlags-             -> Id -> ConstructorNumber+buildDynCon' :: Id+             -> ConstructorNumber              -> Bool              -> CostCentreStack              -> DataCon              -> [NonVoid StgArg]              -> FCode (CgIdInfo, FCode CmmAGraph)- {- We used to pass a boolean indicating whether all the args were of size zero, so we could use a static constructor; but I concluded that it just isn't worth it.@@ -189,14 +191,8 @@ the addr modes of the args is that we may be in a "knot", and premature looking at the args will cause the compiler to black-hole! -}--buildDynCon' dflags binder _ _ _cc con args-  | Just cgInfo <- precomputedStaticConInfo_maybe dflags binder con args-  -- , pprTrace "noCodeLocal:" (ppr (binder,con,args,cgInfo)) True-  = return (cgInfo, return mkNop)- -------- buildDynCon': the general case ------------buildDynCon' _ binder mn actually_bound ccs con args+buildDynCon' binder mn actually_bound ccs con args   = do  { (id_info, reg) <- rhsIdInfo binder lf_info         ; return (id_info, gen_code reg)         }@@ -205,8 +201,9 @@    gen_code reg     = do  { modu <- getModuleName-          ; profile <- getProfile-          ; let platform = profilePlatform profile+          ; cfg  <- getStgToCmmConfig+          ; let platform = stgToCmmPlatform cfg+                profile  = stgToCmmProfile  cfg                 (tot_wds, ptr_wds, args_w_offsets)                    = mkVirtConstrOffsets profile (addArgReps args)                 nonptr_wds = tot_wds - ptr_wds@@ -215,6 +212,8 @@           ; let ticky_name | actually_bound = Just binder                            | otherwise = Nothing +          ; checkConArgsDyn (hang (text "TagCheck failed on constructor application.") 4 $+                                   text "On binder:" <> ppr binder $$ text "Constructor:" <> ppr con) con (map fromNonVoid args)           ; hp_plus_n <- allocDynClosure ticky_name info_tbl lf_info                                           use_cc blame_cc args_w_offsets           ; return (mkRhsInit platform reg lf_info hp_plus_n) }@@ -225,13 +224,14 @@        blame_cc = use_cc -- cost-centre on which to blame the alloc (same) + {- Note [Precomputed static closures]    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~  For Char/Int closures there are some value closures built into the RTS. This is the case for all values in the range mINT_INTLIKE .. mAX_INTLIKE (or CHARLIKE).-See Note [CHARLIKE and INTLIKE closures.] in the RTS code.+See Note [CHARLIKE and INTLIKE closures] in the RTS code.  Similarly zero-arity constructors have a closure in their defining Module we can use.@@ -318,36 +318,36 @@ because they don't support cross package data references well. -} --- (precomputedStaticConInfo_maybe dflags id con args)+-- (precomputedStaticConInfo_maybe cfg id con args) --     returns (Just cg_id_info) -- if there is a precomputed static closure for (con args). -- In that case, cg_id_info addresses it. -- See Note [Precomputed static closures]-precomputedStaticConInfo_maybe :: DynFlags -> Id -> DataCon -> [NonVoid StgArg] -> Maybe CgIdInfo-precomputedStaticConInfo_maybe dflags binder con []+precomputedStaticConInfo_maybe :: StgToCmmConfig -> Id -> DataCon -> [NonVoid StgArg] -> Maybe CgIdInfo+precomputedStaticConInfo_maybe cfg binder con [] -- Nullary constructors   | isNullaryRepDataCon con-  = Just $ litIdInfo (targetPlatform dflags) binder (mkConLFInfo con)+  = Just $ litIdInfo (stgToCmmPlatform cfg) binder (mkConLFInfo con)                 (CmmLabel (mkClosureLabel (dataConName con) NoCafRefs))-precomputedStaticConInfo_maybe dflags binder con [arg]+precomputedStaticConInfo_maybe cfg binder con [arg]   -- Int/Char values with existing closures in the RTS   | intClosure || charClosure-  , platformOS platform /= OSMinGW32 || not (positionIndependent dflags)+  , platformOS platform /= OSMinGW32 || not (stgToCmmPIE cfg || stgToCmmPIC cfg)   , Just val <- getClosurePayload arg   , inRange val   = let intlike_lbl   = mkCmmClosureLabel rtsUnitId (fsLit label)         val_int = fromIntegral val :: Int-        offsetW = (val_int - (fromIntegral min_static_range)) * (fixedHdrSizeW profile + 1)+        offsetW = (val_int - fromIntegral min_static_range) * (fixedHdrSizeW profile + 1)                 -- INTLIKE/CHARLIKE closures consist of a header and one word payload         static_amode = cmmLabelOffW platform intlike_lbl offsetW     in Just $ litIdInfo platform binder (mkConLFInfo con) static_amode   where-    profile = targetProfile dflags-    platform = profilePlatform profile-    intClosure = maybeIntLikeCon con+    profile     = stgToCmmProfile  cfg+    platform    = stgToCmmPlatform cfg+    intClosure  = maybeIntLikeCon  con     charClosure = maybeCharLikeCon con     getClosurePayload (NonVoid (StgLitArg (LitNumber LitNumInt val))) = Just val-    getClosurePayload (NonVoid (StgLitArg (LitChar val))) = Just $ (fromIntegral . ord $ val)+    getClosurePayload (NonVoid (StgLitArg (LitChar val))) = Just (fromIntegral . ord $ val)     getClosurePayload _ = Nothing     -- Avoid over/underflow by comparisons at type Integer!     inRange :: Integer -> Bool@@ -382,7 +382,7 @@ -- binders args, assuming that we have just returned from a 'case' which -- found a con bindConArgs (DataAlt con) base args-  = ASSERT(not (isUnboxedTupleDataCon con))+  = assert (not (isUnboxedTupleDataCon con)) $     do profile <- getProfile        platform <- getPlatform        let (_, _, args_w_offsets) = mkVirtConstrOffsets profile (addIdReps args)@@ -402,4 +402,4 @@        mapMaybeM bind_arg args_w_offsets  bindConArgs _other_con _base args-  = ASSERT( null args ) return []+  = assert (null args ) return []
GHC/StgToCmm/Env.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE CPP #-} + ----------------------------------------------------------------------------- -- -- Stg to C-- code generation: the binding environment@@ -17,11 +17,9 @@          bindArgsToRegs, bindToReg, rebindToReg,         bindArgToReg, idToReg,-        getCgIdInfo,+        getCgIdInfo, getCgInfo_maybe,         maybeLetNoEscape,-    ) where--#include "HsVersions.h"+        ) where  import GHC.Prelude @@ -42,11 +40,11 @@ import GHC.Types.Unique.FM import GHC.Types.Var.Env -import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain -import GHC.Driver.Session+import GHC.Builtin.Names (getUnique)   -------------------------------------@@ -86,16 +84,16 @@  idInfoToAmode :: CgIdInfo -> CmmExpr -- Returns a CmmExpr for the *tagged* pointer-idInfoToAmode (CgIdInfo { cg_loc = CmmLoc e }) = e+idInfoToAmode CgIdInfo { cg_loc = CmmLoc e } = e idInfoToAmode cg_info   = pprPanic "idInfoToAmode" (ppr (cg_id cg_info))        -- LneLoc  -- | A tag adds a byte offset to the pointer addDynTag :: Platform -> CmmExpr -> DynTag -> CmmExpr-addDynTag platform expr tag = cmmOffsetB platform expr tag+addDynTag = cmmOffsetB  maybeLetNoEscape :: CgIdInfo -> Maybe (BlockId, [LocalReg])-maybeLetNoEscape (CgIdInfo { cg_loc = LneLoc blk_id args}) = Just (blk_id, args)+maybeLetNoEscape CgIdInfo { cg_loc = LneLoc blk_id args} = Just (blk_id, args) maybeLetNoEscape _other                                      = Nothing  @@ -120,12 +118,20 @@                                new_bindings         setBinds new_binds +-- Inside GHC the average module creates 385 external references+-- with noteable cgIdInfo (so not generated by mkLFArgument).+-- On average 200 of these are covered by True/False/[]+-- and nullary constructors make up ~80.+-- One would think it would be worthwhile to cache these.+-- Sadly it's not. See #16937+ getCgIdInfo :: Id -> FCode CgIdInfo getCgIdInfo id-  = do  { platform <- targetPlatform <$> getDynFlags+  = do  { platform <- getPlatform         ; local_binds <- getBinds -- Try local bindings first         ; case lookupVarEnv local_binds id of {-            Just info -> return info ;+            Just info -> -- pprTrace "getCgIdInfoLocal" (ppr id) $+              return info ;             Nothing   -> do {                  -- Should be imported; make up a CgIdInfo for it@@ -137,7 +143,7 @@                       | isUnliftedType (idType id)                           -- An unlifted external Id must refer to a top-level                           -- string literal. See Note [Bytes label] in "GHC.Cmm.CLabel".-                      = ASSERT( idType id `eqType` addrPrimTy )+                      = assert (idType id `eqType` addrPrimTy) $                         mkBytesLabel name                       | otherwise                       = pprPanic "GHC.StgToCmm.Env: label not found" (ppr id <+> dcolon <+> ppr (idType id))@@ -147,6 +153,12 @@               cgLookupPanic id -- Bug         }}} +-- | Retrieve cg info for a name if it already exists.+getCgInfo_maybe :: Name -> FCode (Maybe CgIdInfo)+getCgInfo_maybe name+  = do  { local_binds <- getBinds -- Try local bindings first+        ; return $ lookupVarEnv_Directly local_binds (getUnique name) }+ cgLookupPanic :: Id -> FCode a cgLookupPanic id   = do  local_binds <- getBinds@@ -181,7 +193,7 @@ bindArgToReg nvid@(NonVoid id) = bindToReg nvid (mkLFArgument id)  bindArgsToRegs :: [NonVoid Id] -> FCode [LocalReg]-bindArgsToRegs args = mapM bindArgToReg args+bindArgsToRegs = mapM bindArgToReg  idToReg :: Platform -> NonVoid Id -> LocalReg -- Make a register from an Id, typically a function argument,
GHC/StgToCmm/Expr.hs view
@@ -1,6 +1,7 @@-{-# LANGUAGE CPP, BangPatterns #-}- {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeFamilies #-}  ----------------------------------------------------------------------------- --@@ -12,8 +13,6 @@  module GHC.StgToCmm.Expr ( cgExpr, cgLit ) where -#include "HsVersions.h"- import GHC.Prelude hiding ((<*>))  import {-# SOURCE #-} GHC.StgToCmm.Bind ( cgBind )@@ -27,6 +26,7 @@ import GHC.StgToCmm.Lit import GHC.StgToCmm.Prim import GHC.StgToCmm.Hpc+import GHC.StgToCmm.TagCheck import GHC.StgToCmm.Ticky import GHC.StgToCmm.Utils import GHC.StgToCmm.Closure@@ -38,6 +38,7 @@ import GHC.Cmm hiding ( succ ) import GHC.Cmm.Info import GHC.Cmm.Utils ( zeroExpr, cmmTagMask, mkWordCLit, mAX_PTR_TAG )+import GHC.Cmm.Ppr import GHC.Core import GHC.Core.DataCon import GHC.Types.ForeignCall@@ -45,7 +46,7 @@ import GHC.Builtin.PrimOps import GHC.Core.TyCon import GHC.Core.Type        ( isUnliftedType )-import GHC.Types.RepType    ( isVoidTy, countConRepArgs )+import GHC.Types.RepType    ( isZeroBitTy, countConRepArgs, mightBeFunTy ) import GHC.Types.CostCentre ( CostCentreStack, currentCCS ) import GHC.Types.Tickish import GHC.Data.Maybe@@ -53,10 +54,13 @@ import GHC.Data.FastString import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain  import Control.Monad ( unless, void ) import Control.Arrow ( first ) import Data.List     ( partition )+import GHC.Stg.InferTags.TagSig (isTaggedSig)+import GHC.Platform.Profile (profileIsProfiling)  ------------------------------------------------------------------------ --              cgExpr: the main function@@ -72,7 +76,7 @@   cgIdApp a []  -- dataToTag# :: a -> Int#--- See Note [dataToTag# magic] in primops.txt.pp+-- See Note [dataToTag# magic] in GHC.Core.Opt.ConstantFold cgExpr (StgOpApp (StgPrimOp DataToTagOp) [StgVarArg a] _res_ty) = do   platform <- getPlatform   emitComment (mkFastString "dataToTag#")@@ -92,9 +96,10 @@   slow_path <- getCode $ do       tmp <- newTemp (bWord platform)       _ <- withSequel (AssignTo [tmp] False) (cgIdApp a [])-      ptr_opts <- getPtrOpts+      profile     <- getProfile+      align_check <- stgToCmmAlignCheck <$> getStgToCmmConfig       emitAssign (CmmLocal result_reg)-        $ getConstrTag ptr_opts (cmmUntag platform (CmmReg (CmmLocal tmp)))+        $ getConstrTag profile align_check (cmmUntag platform (CmmReg (CmmLocal tmp)))    fast_path <- getCode $ do       -- Return the constructor index from the pointer tag@@ -103,9 +108,10 @@             $ cmmSubWord platform tag (CmmLit $ mkWordCLit platform 1)       -- Return the constructor index recorded in the info table       return_info_tag <- getCode $ do-          ptr_opts <- getPtrOpts+          profile     <- getProfile+          align_check <- stgToCmmAlignCheck <$> getStgToCmmConfig           emitAssign (CmmLocal result_reg)-            $ getConstrTag ptr_opts (cmmUntag platform amode)+            $ getConstrTag profile align_check (cmmUntag platform amode)        emit =<< mkCmmIfThenElse' is_too_big_tag return_info_tag return_ptr_tag (Just False) @@ -211,7 +217,7 @@   = do platform <- getPlatform        return ( lneIdInfo platform bndr args, code )   where-   code = forkLneBody $ withNewTickyCounterLNE (idName bndr) args $ do+   code = forkLneBody $ withNewTickyCounterLNE bndr args $ do             { restoreCurrentCostCentre cc_slot             ; arg_regs <- bindArgsToRegs args             ; void $ noEscapeHeapCheck arg_regs (tickyEnterLNE >> cgExpr body) }@@ -290,7 +296,7 @@ entry to a function, when not many things are live.  After a bunch of single-branch cases, we may have lots of things live -Hence: two basic plans for+Hence: Two basic plans for          case e of r { alts } @@ -305,6 +311,13 @@         ...code for alts...         ...alts do their own heap checks +   When using GcInAlts the return point for heap checks and evaluating+   the scrutinee is shared. This does mean we might execute the actual+   branching code twice but it's rare enough to not matter.+   The huge advantage of this pattern is that we do not require multiple+   info tables for returning from gc as they can be shared between all+   cases. Reducing code size nicely.+ ------ Plan B: special case when ---------   (i)  e does not allocate or call GC   (ii) either upstream code performs allocation@@ -319,6 +332,80 @@          ...code for alts...         ...no heap check...++   There is a variant B.2 which we use if:++  (i)   e is already evaluated+tagged+  (ii)  We have multiple alternatives+  (iii) and there is no upstream allocation.++  Here we also place one heap check before the `case` which+  branches on `e`. Hopefully to be absorbed by an already existing+  heap check further up. However the big difference in this case is that+  there is no code for e. So we are not guaranteed that the heap+  checks of the alts will be combined with an heap check further up.++  Very common example: Casing on strict fields.++        ...heap check...+        ...assign bindings...++        ...code for alts...+        ...no heap check...++  -- Reasoning for Plan B.2:+   Since the scrutinee is already evaluated there is no evaluation+   call which would force a info table that we can use as a shared+   return point.+   This means currently if we were to do GcInAlts like in Plan A then+   we would end up with one info table per alternative.++   To avoid this we unconditionally do gc outside of the alts with all+   the pros and cons described in Note [Compiling case expressions].+   Rewriting the logic to generate a shared return point before the case+   expression while keeping the heap checks in the alternatives would be+   possible. But it's unclear to me that this would actually be an improvement.++   This means if we have code along these lines:++      g x y = case x of+         True -> Left $ (y + 1,y,y-1)+         False -> Right $! y - (2 :: Int)++   We get these potential heap check placements:++   f = ...+      !max(L,R)!; -- Might be absorbed upstream.+      case x of+         True  -> !L!; ...L...+         False -> !R!; ...R...++   And we place a heap check at !max(L,R)!++   The downsides of using !max(L,R)! are:++   * If f is recursive, and the hot loop wouldn't allocate, but the exit branch does then we do+   a redundant heap check.+   * We use one more instruction to de-allocate the unused heap in the branch using less heap. (Neglible)+   * A small risk of running gc slightly more often than needed especially if one branch allocates a lot.++   The upsides are:+   * May save a heap overflow test if there is an upstream check already.+   * If the heap check is absorbed upstream we can also eliminate its info table.+   * We generate at most one heap check (versus one per alt otherwise).+   * No need to save volatile vars etc across heap checks in !L!, !R!+   * We can use relative addressing from a single Hp to get at all the closures so allocated. (seems neglible)+   * It fits neatly in the logic we already have for handling A/B++   For containers:Data/Sequence/Internal/Sorting.o the difference is+   about 10% in terms of code size compared to using Plan A for this case.+   The main downside is we might put heap checks into loops, even if we+   could avoid it (See Note [Compiling case expressions]).++   Potential improvement: Investigate if heap checks in alts would be an+   improvement if we generate and use a shared return point that is placed+   in the common path for all alts.+ -}  @@ -373,7 +460,7 @@  cgCase (StgApp v []) _ (PrimAlt _) alts   | isVoidRep (idPrimRep v)  -- See Note [Scrutinising VoidRep]-  , [(DEFAULT, _, rhs)] <- alts+  , [GenStgAlt{alt_con=DEFAULT, alt_bndrs=_, alt_rhs=rhs}] <- alts   = cgExpr rhs  {- Note [Dodgy unsafeCoerce 1]@@ -460,6 +547,7 @@        ; up_hp_usg <- getVirtHp        -- Upstream heap usage        ; let ret_bndrs = chooseReturnBndrs bndr alt_type alts              alt_regs  = map (idToReg platform) ret_bndrs+        ; simple_scrut <- isSimpleScrut scrut alt_type        ; let do_gc  | is_cmp_op scrut  = False  -- See Note [GC for conditionals]                     | not simple_scrut = True@@ -481,6 +569,7 @@     is_cmp_op (StgOpApp (StgPrimOp op) _ _) = isComparisonPrimOp op     is_cmp_op _                             = False + {- Note [GC for conditionals] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ For boolean conditionals it seems that we have always done NoGcInAlts.@@ -529,21 +618,28 @@ -- heap usage from alternatives into the stuff before the case -- NB: if you get this wrong, and claim that the expression doesn't allocate --     when it does, you'll deeply mess up allocation-isSimpleScrut (StgOpApp op args _) _       = isSimpleOp op args-isSimpleScrut (StgLit _)       _           = return True       -- case 1# of { 0# -> ..; ... }-isSimpleScrut (StgApp _ [])    (PrimAlt _) = return True       -- case x# of { 0# -> ..; ... }-isSimpleScrut _                _           = return False+isSimpleScrut (StgOpApp op args _) _         = isSimpleOp op args+isSimpleScrut (StgLit _)           _         = return True       -- case 1# of { 0# -> ..; ... }+isSimpleScrut (StgApp _ [])    (PrimAlt _)   = return True       -- case x# of { 0# -> ..; ... }+isSimpleScrut (StgApp f [])   _+  | Just sig <- idTagSig_maybe f+  , isTaggedSig sig  -- case !x of { ... }+  = if mightBeFunTy (idType f)+      -- See Note [Evaluating functions with profiling] in rts/Apply.cmm+      then not . profileIsProfiling <$> getProfile+      else pure True+isSimpleScrut _                    _         = return False  isSimpleOp :: StgOp -> [StgArg] -> FCode Bool -- True iff the op cannot block or allocate isSimpleOp (StgFCallOp (CCall (CCallSpec _ _ safe)) _) _ = return $! not (playSafe safe)--- dataToTag# evaluates its argument, see Note [dataToTag#] in primops.txt.pp+-- dataToTag# evaluates its argument, see Note [dataToTag# magic] in GHC.Core.Opt.ConstantFold isSimpleOp (StgPrimOp DataToTagOp) _ = return False isSimpleOp (StgPrimOp op) stg_args                  = do     arg_exprs <- getNonVoidArgAmodes stg_args-    dflags <- getDynFlags+    cfg       <- getStgToCmmConfig     -- See Note [Inlining out-of-line primops and heap checks]-    return $! shouldInlinePrimOp dflags op arg_exprs+    return $! shouldInlinePrimOp cfg op arg_exprs isSimpleOp (StgPrimCallOp _) _                           = return False  -----------------@@ -554,9 +650,10 @@ chooseReturnBndrs bndr (PrimAlt _) _alts   = assertNonVoidIds [bndr] -chooseReturnBndrs _bndr (MultiValAlt n) [(_, ids, _)]-  = ASSERT2(ids `lengthIs` n, ppr n $$ ppr ids $$ ppr _bndr)+chooseReturnBndrs _bndr (MultiValAlt n) [alt]+  = assertPpr (ids `lengthIs` n) (ppr n $$ ppr ids $$ ppr _bndr) $     assertNonVoidIds ids     -- 'bndr' is not assigned!+    where ids = alt_bndrs alt  chooseReturnBndrs bndr (AlgAlt _) _alts   = assertNonVoidIds [bndr]  -- Only 'bndr' is assigned@@ -571,11 +668,11 @@ cgAlts :: (GcPlan,ReturnKind) -> NonVoid Id -> AltType -> [CgStgAlt]        -> FCode ReturnKind -- At this point the result of the case are in the binders-cgAlts gc_plan _bndr PolyAlt [(_, _, rhs)]-  = maybeAltHeapCheck gc_plan (cgExpr rhs)+cgAlts gc_plan _bndr PolyAlt [alt]+  = maybeAltHeapCheck gc_plan (cgExpr $ alt_rhs alt) -cgAlts gc_plan _bndr (MultiValAlt _) [(_, _, rhs)]-  = maybeAltHeapCheck gc_plan (cgExpr rhs)+cgAlts gc_plan _bndr (MultiValAlt _) [alt]+  = maybeAltHeapCheck gc_plan (cgExpr $ alt_rhs alt)         -- Here bndrs are *already* in scope, so don't rebind them  cgAlts gc_plan bndr (PrimAlt _) alts@@ -616,9 +713,10 @@            else -- No, the get exact tag from info table when mAX_PTR_TAG                 -- See Note [Double switching for big families]               do-                ptr_opts <- getPtrOpts+                profile     <- getProfile+                align_check <- stgToCmmAlignCheck <$> getStgToCmmConfig                 let !untagged_ptr = cmmUntag platform (CmmReg bndr_reg)-                    !itag_expr = getConstrTag ptr_opts untagged_ptr+                    !itag_expr = getConstrTag profile align_check untagged_ptr                     !info0 = first pred <$> via_info                 if null via_ptr then                   emitSwitch itag_expr info0 mb_deflt 0 (fam_sz - 1)@@ -808,10 +906,10 @@ -- tricky part is that the default case needs (logical) duplication. -- To do this we emit an extra label for it and branch to that from -- the second switch. This avoids duplicated codegen. See Trac #14373.--- See note [Double switching for big families] for the mechanics+-- See Note [Double switching for big families] for the mechanics -- involved. ----- Also see note [Data constructor dynamic tags]+-- Also see Note [Data constructor dynamic tags] -- and the wiki https://gitlab.haskell.org/ghc/ghc/wikis/commentary/rts/haskell-execution/pointer-tagging -- @@ -843,7 +941,7 @@   let     base_reg = idToReg platform bndr     cg_alt :: CgStgAlt -> FCode (AltCon, CmmAGraphScoped)-    cg_alt (con, bndrs, rhs)+    cg_alt GenStgAlt{alt_con=con, alt_bndrs=bndrs, alt_rhs=rhs}       = getCodeScoped             $         maybeAltHeapCheck gc_plan $         do { _ <- bindConArgs con base_reg (assertNonVoidIds bndrs)@@ -872,7 +970,8 @@        ; emitReturn arg_exprs }    | otherwise   --  Boxed constructors; allocate and return-  = ASSERT2( stg_args `lengthIs` countConRepArgs con, ppr con <> parens (ppr (countConRepArgs con)) <+> ppr stg_args )+  = assertPpr (stg_args `lengthIs` countConRepArgs con)+              (ppr con <> parens (ppr (countConRepArgs con)) <+> ppr stg_args) $     do  { (idinfo, fcode_init) <- buildDynCon (dataConWorkId con) mn False                                      currentCCS con (assertNonVoidStgArgs stg_args)                                      -- con args are always non-void,@@ -887,24 +986,43 @@  cgIdApp :: Id -> [StgArg] -> FCode ReturnKind cgIdApp fun_id args = do+    platform       <- getPlatform     fun_info       <- getCgIdInfo fun_id-    self_loop_info <- getSelfLoop-    call_opts      <- getCallOpts-    profile        <- getProfile-    let fun_arg     = StgVarArg fun_id-        fun_name    = idName    fun_id-        fun         = idInfoToAmode fun_info-        lf_info     = cg_lf         fun_info-        n_args      = length args-        v_args      = length $ filter (isVoidTy . stgArgType) args-    case getCallMethod call_opts fun_name fun_id lf_info n_args v_args (cg_loc fun_info) self_loop_info of+    cfg            <- getStgToCmmConfig+    self_loop      <- getSelfLoop+    let profile        = stgToCmmProfile  cfg+        fun_arg        = StgVarArg fun_id+        fun_name       = idName    fun_id+        fun            = idInfoToAmode fun_info+        lf_info        = cg_lf         fun_info+        n_args         = length args+        v_args         = length $ filter (isZeroBitTy . stgArgType) args+    case getCallMethod cfg fun_name fun_id lf_info n_args v_args (cg_loc fun_info) self_loop of             -- A value in WHNF, so we can just return it.         ReturnIt-          | isVoidTy (idType fun_id) -> emitReturn []+          | isZeroBitTy (idType fun_id) -> emitReturn []           | otherwise                -> emitReturn [fun]-          -- ToDo: does ReturnIt guarantee tagged? -        EnterIt -> ASSERT( null args )  -- Discarding arguments+        -- A value infered to be in WHNF, so we can just return it.+        InferedReturnIt+          | isZeroBitTy (idType fun_id) -> trace >> emitReturn []+          | otherwise                   -> trace >> assertTag >>+                                                    emitReturn [fun]+            where+              trace = do+                tickyTagged+                use_id <- newUnique+                _lbl <- emitTickyCounterTag use_id (NonVoid fun_id)+                tickyTagSkip use_id fun_id++                -- pprTraceM "WHNF:" (ppr fun_id <+> ppr args )+              assertTag = whenCheckTags $ do+                  mod <- getModuleName+                  emitTagAssertion (showPprUnsafe+                      (text "TagCheck failed on entry in" <+> ppr mod <+> text "- value:" <> ppr fun_id <+> pprExpr platform fun))+                      fun++        EnterIt -> assert (null args) $  -- Discarding arguments                    emitEnter fun          SlowCall -> do      -- A slow function call via the RTS apply routines@@ -975,7 +1093,7 @@ -- Implementation is spread across a couple of places in the code: -- --   * FCode monad stores additional information in its reader environment---     (cgd_self_loop field). This information tells us which function can+--     (stgToCmmSelfLoop field). This information tells us which function can --     tail call itself in an optimized way (it is the function currently --     being compiled), what is the label of a loop header (L1 in example above) --     and information about local registers in which we should arguments@@ -1008,7 +1126,7 @@ --     command-line option. -- --   * Command line option to turn loopification on and off is implemented in---     DynFlags.+--     DynFlags, then passed to StgToCmmConfig for this phase. -- -- -- Note [Void arguments in self-recursive tail calls]@@ -1036,12 +1154,12 @@  emitEnter :: CmmExpr -> FCode ReturnKind emitEnter fun = do-  { ptr_opts <- getPtrOpts-  ; platform <- getPlatform-  ; profile <- getProfile+  { platform <- getPlatform+  ; profile  <- getProfile   ; adjustHpBackwards-  ; sequel <- getSequel-  ; updfr_off <- getUpdFrameOff+  ; sequel      <- getSequel+  ; updfr_off   <- getUpdFrameOff+  ; align_check <- stgToCmmAlignCheck <$> getStgToCmmConfig   ; case sequel of       -- For a return, we have the option of generating a tag-test or       -- not.  If the value is tagged, we can return directly, which@@ -1052,7 +1170,9 @@       -- Right now, we do what the old codegen did, and omit the tag       -- test, just generating an enter.       Return -> do-        { let entry = entryCode platform $ closureInfoPtr ptr_opts $ CmmReg nodeReg+        { let entry = entryCode platform+                $ closureInfoPtr platform align_check+                $ CmmReg nodeReg         ; emit $ mkJump profile NativeNodeCall entry                         [cmmUntag platform fun] updfr_off         ; return AssignedDirectly@@ -1084,17 +1204,18 @@       -- code in the enclosing case expression.       --       AssignTo res_regs _ -> do-       { lret <- newBlockId-       ; let (off, _, copyin) = copyInOflow profile NativeReturn (Young lret) res_regs []+       { lret  <- newBlockId        ; lcall <- newBlockId-       ; updfr_off <- getUpdFrameOff+       ; updfr_off   <- getUpdFrameOff+       ; align_check <- stgToCmmAlignCheck <$> getStgToCmmConfig+       ; let (off, _, copyin) = copyInOflow profile NativeReturn (Young lret) res_regs []        ; let area = Young lret        ; let (outArgs, regs, copyout) = copyOutOflow profile NativeNodeCall Call area                                           [fun] updfr_off []          -- refer to fun via nodeReg after the copyout, to avoid having          -- both live simultaneously; this sometimes enables fun to be          -- inlined in the RHS of the R1 assignment.-       ; let entry = entryCode platform (closureInfoPtr ptr_opts (CmmReg nodeReg))+       ; let entry = entryCode platform (closureInfoPtr platform align_check (CmmReg nodeReg))              the_call = toCall entry (Just lret) updfr_off off outArgs regs        ; tscope <- getTickScope        ; emit $
− GHC/StgToCmm/Expr.hs-boot 
@@ -1,7 +0,0 @@-module GHC.StgToCmm.Expr where--import GHC.Cmm.Expr-import GHC.StgToCmm.Monad-import GHC.Types.Literal--cgLit :: Literal -> FCode CmmExpr
GHC/StgToCmm/ExtCode.hs view
@@ -34,7 +34,7 @@         getCode, getCodeR, getCodeScoped,         emitOutOfLine,         withUpdFrameOff, getUpdFrameOff,-        getProfile, getPlatform, getPtrOpts+        getProfile, getPlatform, getContext )  where@@ -50,10 +50,8 @@ import GHC.Cmm import GHC.Cmm.CLabel import GHC.Cmm.Graph-import GHC.Cmm.Info  import GHC.Cmm.BlockId-import GHC.Driver.Session import GHC.Data.FastString import GHC.Unit.Module import GHC.Types.Unique.FM@@ -61,6 +59,7 @@ import GHC.Types.Unique.Supply  import Control.Monad (ap)+import GHC.Utils.Outputable (SDocContext)  -- | The environment contains variable definitions or blockids. data Named@@ -103,17 +102,14 @@     u <- getUniqueM     return (decls, u) -instance HasDynFlags CmmParse where-    getDynFlags = EC (\_ _ d -> (d,) <$> getDynFlags)- getProfile :: CmmParse Profile getProfile = EC (\_ _ d -> (d,) <$> F.getProfile)  getPlatform :: CmmParse Platform getPlatform = EC (\_ _ d -> (d,) <$> F.getPlatform) -getPtrOpts :: CmmParse PtrOpts-getPtrOpts = EC (\_ _ d -> (d,) <$> F.getPtrOpts)+getContext :: CmmParse SDocContext+getContext = EC (\_ _ d -> (d,) <$> F.getContext)  -- | Takes the variable declarations and imports from the monad --      and makes an environment, which is looped back into the computation.@@ -127,7 +123,6 @@         (_, a) <- F.fixC $ \ ~(decls, _) ->           fcode c (addListToUFM e decls) globalDecls         return (globalDecls, a)-  -- | Get the current environment from the monad. getEnv :: CmmParse Env
GHC/StgToCmm/Foreign.hs view
@@ -127,7 +127,7 @@          }  {- Note [safe foreign call convention]-+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The simple thing to do for a safe foreign call would be the same as an unsafe one: just @@ -174,7 +174,7 @@  L2:   ... r ... -And when the safe foreign call is lowered later (see Note [lower safe+And when the safe foreign call is lowered later (see Note [Lower safe foreign calls]) we get this:    suspendThread()@@ -601,9 +601,9 @@ -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- -- For certain types passed to foreign calls, we adjust the actual--- value passed to the call.  For ByteArray#, Array#, SmallArray#,--- and ArrayArray#, we pass the address of the array's payload, not--- the address of the heap object. For example, consider+-- value passed to the call.  For ByteArray#, Array# and SmallArray#,+-- we pass the address of the array's payload, not the address of+-- the heap object. For example, consider: --   foreign import "c_foo" foo :: ByteArray# -> Int# -> IO () -- At a Haskell call like `foo x y`, we'll generate a C call that -- is more like@@ -713,8 +713,6 @@ typeToStgFArgType typ   | tycon == arrayPrimTyCon = StgArrayType   | tycon == mutableArrayPrimTyCon = StgArrayType-  | tycon == arrayArrayPrimTyCon = StgArrayType-  | tycon == mutableArrayArrayPrimTyCon = StgArrayType   | tycon == smallArrayPrimTyCon = StgSmallArrayType   | tycon == smallMutableArrayPrimTyCon = StgSmallArrayType   | tycon == byteArrayPrimTyCon = StgByteArrayType
GHC/StgToCmm/Heap.hs view
@@ -44,7 +44,6 @@ import GHC.Types.Id.Info( CafInfo(..), mayHaveCafRefs ) import GHC.Types.Id ( Id ) import GHC.Unit-import GHC.Driver.Session import GHC.Platform import GHC.Platform.Profile import GHC.Data.FastString( mkFastString, fsLit )@@ -429,7 +428,7 @@ -- is more efficient), but cannot be optimized away in the non-allocating -- case because it may occur in a loop noEscapeHeapCheck :: [LocalReg] -> FCode a -> FCode a-noEscapeHeapCheck regs code = altOrNoEscapeHeapCheck True regs code+noEscapeHeapCheck = altOrNoEscapeHeapCheck True  cannedGCReturnsTo :: Bool -> Bool -> CmmExpr -> [LocalReg] -> Label -> ByteOff                   -> FCode a@@ -491,6 +490,7 @@       _otherwise -> Nothing  -- Note [stg_gc arguments]+-- ~~~~~~~~~~~~~~~~~~~~~~~ -- It might seem that we could avoid passing the arguments to the -- stg_gc function, because they are already in the right registers. -- While this is usually the case, it isn't always.  Sometimes the@@ -605,9 +605,9 @@           -> CmmAGraph        -- What to do on failure           -> FCode () do_checks mb_stk_hwm checkYield mb_alloc_lit do_gc = do-  dflags <- getDynFlags-  platform <- getPlatform-  gc_id <- newBlockId+  omit_yields <- stgToCmmOmitYields <$> getStgToCmmConfig+  platform    <- getPlatform+  gc_id       <- newBlockId    let     Just alloc_lit = mb_alloc_lit@@ -644,13 +644,13 @@         | checkYield && isJust mb_stk_hwm -> emitLabel loop_header_id     _otherwise -> return () -  if (isJust mb_alloc_lit)+  if isJust mb_alloc_lit     then do      tickyHeapCheck      emitAssign hpReg bump_hp      emit =<< mkCmmIfThen' hp_oflo (alloc_n <*> mkBranch gc_id) (Just False)     else-      when (checkYield && not (gopt Opt_OmitYields dflags)) $ do+      when (checkYield && not omit_yields) $ do          -- Yielding if HpLim == 0          let yielding = CmmMachOp (mo_wordEq platform)                                   [CmmReg hpLimReg,@@ -670,7 +670,6 @@  -- Note [Self-recursive loop header] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- -- Self-recursive loop header is required by loopification optimization (See -- Note [Self-recursive tail calls] in GHC.StgToCmm.Expr). We emit it if: --
GHC/StgToCmm/Hpc.hs view
@@ -11,8 +11,6 @@ import GHC.Prelude import GHC.Platform -import GHC.Driver.Session- import GHC.StgToCmm.Monad import GHC.StgToCmm.Utils @@ -39,13 +37,13 @@  -- | Emit top-level tables for HPC and return code to initialise initHpc :: Module -> HpcInfo -> FCode ()-initHpc _ (NoHpcInfo {})+initHpc _ NoHpcInfo{}   = return () initHpc this_mod (HpcInfo tickCount _hashNo)-  = do dflags <- getDynFlags-       when (gopt Opt_Hpc dflags) $+  = do do_hpc <- stgToCmmOptHpc <$> getStgToCmmConfig+       when do_hpc $            emitDataLits (mkHpcTicksLabel this_mod)-                        [ (CmmInt 0 W64)+                        [ CmmInt 0 W64                         | _ <- take tickCount [0 :: Int ..]                         ]
GHC/StgToCmm/Layout.hs view
@@ -31,13 +31,8 @@   ) where  -#include "HsVersions.h"- import GHC.Prelude hiding ((<*>)) -import GHC.Driver.Session-import GHC.Driver.Ppr- import GHC.StgToCmm.Closure import GHC.StgToCmm.Env import GHC.StgToCmm.ArgRep -- notably: ( slowCallPattern )@@ -65,8 +60,12 @@ import Data.List (mapAccumL, partition) import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain+import GHC.Utils.Constants (debugIsOn) import GHC.Data.FastString import Control.Monad+import GHC.StgToCmm.Config (stgToCmmPlatform)+import GHC.StgToCmm.Types  ------------------------------------------------------------------------ --                Call and return sequences@@ -196,9 +195,12 @@ slowCall :: CmmExpr -> [StgArg] -> FCode ReturnKind -- (slowCall fun args) applies fun to args, returning the results to Sequel slowCall fun stg_args-  = do  dflags <- getDynFlags-        profile <- getProfile-        let platform = profilePlatform profile+  = do  cfg <- getStgToCmmConfig+        let profile   = stgToCmmProfile      cfg+            platform  = stgToCmmPlatform     cfg+            ctx       = stgToCmmContext      cfg+            fast_pap  = stgToCmmFastPAPCalls cfg+            align_sat = stgToCmmAlignCheck   cfg         argsreps <- getArgRepsAmodes stg_args         let (rts_fun, arity) = slowCallPattern (map fst argsreps) @@ -206,18 +208,17 @@            r <- direct_call "slow_call" NativeNodeCall                  (mkRtsApFastLabel rts_fun) arity ((P,Just fun):argsreps)            emitComment $ mkFastString ("slow_call for " ++-                                      showSDoc dflags (pdoc platform fun) +++                                      renderWithContext ctx (pdoc platform fun) ++                                       " with pat " ++ unpackFS rts_fun)            return r -        -- Note [avoid intermediate PAPs]+        -- See Note [avoid intermediate PAPs]         let n_args = length stg_args-        if n_args > arity && optLevel dflags >= 2+        if n_args > arity && fast_pap            then do-             ptr_opts <- getPtrOpts              funv <- (CmmReg . CmmLocal) `fmap` assignTemp fun              fun_iptr <- (CmmReg . CmmLocal) `fmap`-                    assignTemp (closureInfoPtr ptr_opts (cmmUntag platform funv))+               assignTemp (closureInfoPtr platform align_sat (cmmUntag platform funv))               -- ToDo: we could do slightly better here by reusing the              -- continuation from the slow call, which we have in r.@@ -260,7 +261,7 @@   -- Note [avoid intermediate PAPs]---+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- A slow call which needs multiple generic apply patterns will be -- almost guaranteed to create one or more intermediate PAPs when -- applied to a function that takes the correct number of arguments.@@ -303,15 +304,14 @@   = emitCall (call_conv, NativeReturn) target (nonVArgs args)    | otherwise       -- Note [over-saturated calls]-  = do dflags <- getDynFlags+  = do do_scc_prof <- stgToCmmSCCProfiling <$> getStgToCmmConfig        emitCallWithExtraStack (call_conv, NativeReturn)                               target                               (nonVArgs fast_args)-                              (nonVArgs (stack_args dflags))+                              (nonVArgs (slowArgs rest_args do_scc_prof))   where     target = CmmLit (CmmLabel lbl)     (fast_args, rest_args) = splitAt real_arity args-    stack_args dflags = slowArgs dflags rest_args     real_arity = case call_conv of                    NativeNodeCall -> arity+1                    _              -> arity@@ -339,7 +339,7 @@  {- Note [over-saturated calls]-+~~~~~~~~~~~~~~~~~~~~~~~~~~~ The natural thing to do for an over-saturated call would be to call the function with the correct number of arguments, and then apply the remaining arguments to the value returned, e.g.@@ -375,12 +375,11 @@ -- | 'slowArgs' takes a list of function arguments and prepares them for -- pushing on the stack for "extra" arguments to a function which requires -- fewer arguments than we currently have.-slowArgs :: DynFlags -> [(ArgRep, Maybe CmmExpr)] -> [(ArgRep, Maybe CmmExpr)]-slowArgs _ [] = []-slowArgs dflags args -- careful: reps contains voids (V), but args does not-  | sccProfilingEnabled dflags-              = save_cccs ++ this_pat ++ slowArgs dflags rest_args-  | otherwise =              this_pat ++ slowArgs dflags rest_args+slowArgs :: [(ArgRep, Maybe CmmExpr)] -> DoSCCProfiling -> [(ArgRep, Maybe CmmExpr)]+slowArgs []   _                    = mempty+slowArgs args sccProfilingEnabled  -- careful: reps contains voids (V), but args does not+  | sccProfilingEnabled = save_cccs ++ this_pat ++ slowArgs rest_args sccProfilingEnabled+  | otherwise           =              this_pat ++ slowArgs rest_args sccProfilingEnabled   where     (arg_pat, n)            = slowCallPattern (map fst args)     (call_args, rest_args)  = splitAt n args@@ -438,7 +437,7 @@ -- than the unboxed things  mkVirtHeapOffsetsWithPadding profile header things =-    ASSERT(not (any (isVoidRep . fst . fromNonVoid) things))+    assert (not (any (isVoidRep . fst . fromNonVoid) things))     ( tot_wds     , bytesToWordsRoundUp platform bytes_of_ptrs     , concat (ptrs_w_offsets ++ non_ptrs_w_offsets) ++ final_pad@@ -541,7 +540,7 @@ -------------------------------------------------------------------------  -- bring in ARG_P, ARG_N, etc.-#include "../includes/rts/storage/FunTypes.h"+#include "FunTypes.h"  mkArgDescr :: Platform -> [Id] -> ArgDescr mkArgDescr platform args
GHC/StgToCmm/Lit.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, LambdaCase #-}+{-# LANGUAGE LambdaCase #-}  ----------------------------------------------------------------------------- --@@ -12,8 +12,6 @@     cgLit, mkSimpleLit,     newStringCLit, newByteStringCLit   ) where--#include "HsVersions.h"  import GHC.Prelude
GHC/StgToCmm/Monad.hs view
@@ -14,7 +14,7 @@ module GHC.StgToCmm.Monad (         FCode,        -- type -        initC, runC, fixC,+        initC, initFCodeState, runC, fixC,         newUnique,          emitLabel,@@ -28,7 +28,7 @@          getCmm, aGraphToGraph, getPlatform, getProfile,         getCodeR, getCode, getCodeScoped, getHeapUsage,-        getCallOpts, getPtrOpts,+        getContext,          mkCmmIfThenElse, mkCmmIfThen, mkCmmIfGoto,         mkCmmIfThenElse', mkCmmIfThen', mkCmmIfGoto',@@ -45,7 +45,7 @@         setTickyCtrLabel, getTickyCtrLabel,         tickScope, getTickScope, -        withUpdFrameOff, getUpdFrameOff, initUpdFrameOff,+        withUpdFrameOff, getUpdFrameOff,          HeapUsage(..), VirtualHpOffset,        initHpUsage,         getHpUsage,  setHpUsage, heapHWM,@@ -54,13 +54,13 @@         getModuleName,          -- ideally we wouldn't export these, but some other modules access internal state-        getState, setState, getSelfLoop, withSelfLoop, getInfoDown, getDynFlags,+        getState, setState, getSelfLoop, withSelfLoop, getStgToCmmConfig,          -- more localised access to monad state         CgIdInfo(..),         getBinds, setBinds,         -- out of general friendliness, we also export ...-        CgInfoDownwards(..), CgState(..) -- non-abstract+        StgToCmmConfig(..), CgState(..) -- non-abstract     ) where  import GHC.Prelude hiding( sequence, succ )@@ -68,13 +68,13 @@ import GHC.Platform import GHC.Platform.Profile import GHC.Cmm+import GHC.StgToCmm.Config import GHC.StgToCmm.Closure-import GHC.Driver.Session+import GHC.StgToCmm.Sequel import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Graph as CmmGraph import GHC.Cmm.BlockId import GHC.Cmm.CLabel-import GHC.Cmm.Info import GHC.Runtime.Heap.Layout import GHC.Unit import GHC.Types.Id@@ -86,7 +86,7 @@ import GHC.Data.FastString import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Misc+import GHC.Utils.Constants (debugIsOn) import GHC.Exts (oneShot)  import Control.Monad@@ -109,24 +109,30 @@ --    - the current heap usage --    - a UniqSupply -----  - A reader monad, for CgInfoDownwards, containing---    - DynFlags,+--  - A reader monad, for StgToCmmConfig, containing+--    - the profile, --    - the current Module+--    - the debug level+--    - a bunch of flags see StgToCmm.Config for full details++--  - A second reader monad with: --    - the update-frame offset --    - the ticky counter label --    - the Sequel (the continuation to return to) --    - the self-recursive tail call information+--    - The tick scope for new blocks and ticks+--  -------------------------------------------------------- -newtype FCode a = FCode' { doFCode :: CgInfoDownwards -> CgState -> (a, CgState) }+newtype FCode a = FCode' { doFCode :: StgToCmmConfig -> FCodeState -> CgState -> (a, CgState) }  -- Not derived because of #18202. -- See Note [The one-shot state monad trick] in GHC.Utils.Monad instance Functor FCode where   fmap f (FCode m) =-    FCode $ \info_down state ->-      case m info_down state of+    FCode $ \cfg fst state ->+      case m cfg fst state of         (x, state') -> (f x, state')  -- This pattern synonym makes the simplifier monad eta-expand,@@ -134,29 +140,31 @@ -- See #18202. -- See Note [The one-shot state monad trick] in GHC.Utils.Monad {-# COMPLETE FCode #-}-pattern FCode :: (CgInfoDownwards -> CgState -> (a, CgState))+pattern FCode :: (StgToCmmConfig -> FCodeState -> CgState -> (a, CgState))               -> FCode a pattern FCode m <- FCode' m   where-    FCode m = FCode' $ oneShot (\cgInfoDown -> oneShot (\state ->m cgInfoDown state))+    FCode m = FCode' $ oneShot (\cfg -> oneShot+                                 (\fstate -> oneShot+                                   (\state -> m cfg fstate state)))  instance Applicative FCode where-    pure val = FCode (\_info_down state -> (val, state))+    pure val = FCode (\_cfg _fstate state -> (val, state))     {-# INLINE pure #-}     (<*>) = ap  instance Monad FCode where     FCode m >>= k = FCode $-        \info_down state ->-            case m info_down state of+        \cfg fstate state ->+            case m cfg fstate state of               (m_result, new_state) ->                  case k m_result of-                   FCode kcode -> kcode info_down new_state+                   FCode kcode -> kcode cfg fstate new_state     {-# INLINE (>>=) #-}  instance MonadUnique FCode where   getUniqueSupplyM = cgs_uniqs <$> getState-  getUniqueM = FCode $ \_ st ->+  getUniqueM = FCode $ \_ _ st ->     let (u, us') = takeUniqFromSupply (cgs_uniqs st)     in (u, st { cgs_uniqs = us' }) @@ -164,36 +172,18 @@ initC  = do { uniqs <- mkSplitUniqSupply 'c'             ; return (initCgState uniqs) } -runC :: DynFlags -> Module -> CgState -> FCode a -> (a,CgState)-runC dflags mod st fcode = doFCode fcode (initCgInfoDown dflags mod) st+runC :: StgToCmmConfig -> FCodeState -> CgState -> FCode a -> (a, CgState)+runC cfg fst st fcode = doFCode fcode cfg fst st  fixC :: (a -> FCode a) -> FCode a fixC fcode = FCode $-    \info_down state -> let (v, s) = doFCode (fcode v) info_down state-                        in (v, s)+    \cfg fstate state ->+      let (v, s) = doFCode (fcode v) cfg fstate state+      in (v, s)  -------------------------------------------------------- --        The code generator environment ------------------------------------------------------------ This monadery has some information that it only passes--- *downwards*, as well as some ``state'' which is modified--- as we go along.--data CgInfoDownwards        -- information only passed *downwards* by the monad-  = MkCgInfoDown {-        cgd_dflags    :: DynFlags,-        cgd_mod       :: Module,            -- Module being compiled-        cgd_updfr_off :: UpdFrameOffset,    -- Size of current update frame-        cgd_ticky     :: CLabel,            -- Current destination for ticky counts-        cgd_sequel    :: Sequel,            -- What to do at end of basic block-        cgd_self_loop :: Maybe SelfLoopInfo,-- Which tail calls can be compiled-                                            -- as local jumps? See Note-                                            -- [Self-recursive tail calls] in-                                            -- GHC.StgToCmm.Expr-        cgd_tick_scope:: CmmTickScope       -- Tick scope for new blocks & ticks-  }- type CgBindings = IdEnv CgIdInfo  data CgIdInfo@@ -207,31 +197,13 @@   pdoc env (CgIdInfo { cg_id = id, cg_loc = loc })     = ppr id <+> text "-->" <+> pdoc env loc --- Sequel tells what to do with the result of this expression-data Sequel-  = Return              -- Return result(s) to continuation found on the stack.--  | AssignTo-        [LocalReg]      -- Put result(s) in these regs and fall through-                        -- NB: no void arguments here-                        ---        Bool            -- Should we adjust the heap pointer back to-                        -- recover space that's unused on this path?-                        -- We need to do this only if the expression-                        -- may allocate (e.g. it's a foreign call or-                        -- allocating primOp)--instance Outputable Sequel where-    ppr Return = text "Return"-    ppr (AssignTo regs b) = text "AssignTo" <+> ppr regs <+> ppr b- -- See Note [sharing continuations] below data ReturnKind   = AssignedDirectly   | ReturnedTo BlockId ByteOff  -- Note [sharing continuations]---+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- ReturnKind says how the expression being compiled returned its -- results: either by assigning directly to the registers specified -- by the Sequel, or by returning to a continuation that does the@@ -297,24 +269,6 @@ -- fall back to AssignedDirectly. -- --initCgInfoDown :: DynFlags -> Module -> CgInfoDownwards-initCgInfoDown dflags mod-  = MkCgInfoDown { cgd_dflags    = dflags-                 , cgd_mod       = mod-                 , cgd_updfr_off = initUpdFrameOff (targetPlatform dflags)-                 , cgd_ticky     = mkTopTickyCtrLabel-                 , cgd_sequel    = initSequel-                 , cgd_self_loop = Nothing-                 , cgd_tick_scope= GlobalScope }--initSequel :: Sequel-initSequel = Return--initUpdFrameOff :: Platform -> UpdFrameOffset-initUpdFrameOff platform = platformWordSizeInBytes platform -- space for the RA-- -------------------------------------------------------- --        The code generator state --------------------------------------------------------@@ -337,6 +291,17 @@ -- the reason is the knot-tying in 'getHeapUsage'. This problem is tracked -- in #19245 +data FCodeState =+  MkFCodeState { fcs_upframeoffset :: UpdFrameOffset     -- ^ Size of current update frame UpdFrameOffset must be kept lazy or+                                                         -- else the RTS will deadlock _and_ also experience a severe+                                                         -- performance degredation+              , fcs_sequel        :: !Sequel             -- ^ What to do at end of basic block+              , fcs_selfloop      :: Maybe SelfLoopInfo  -- ^ Which tail calls can be compiled as local jumps?+                                                         --   See Note [Self-recursive tail calls] in GHC.StgToCmm.Expr+              , fcs_ticky         :: !CLabel             -- ^ Destination for ticky counts+              , fcs_tickscope     :: !CmmTickScope       -- ^ Tick scope for new blocks & ticks+              }+ data HeapUsage   -- See Note [Virtual and real heap pointers]   = HeapUsage {         virtHp :: VirtualHpOffset,       -- Virtual offset of highest-allocated word@@ -418,14 +383,14 @@ hp_usg `maxHpHw` hw = hp_usg { virtHp = virtHp hp_usg `max` hw }  ----------------------------------------------------------- Operators for getting and setting the state and "info_down".+-- Operators for getting and setting the state and "stgToCmmConfig". --------------------------------------------------------  getState :: FCode CgState-getState = FCode $ \_info_down state -> (state, state)+getState = FCode $ \_cfg _fstate state -> (state, state)  setState :: CgState -> FCode ()-setState state = FCode $ \_info_down _ -> ((), state)+setState state = FCode $ \_cfg _fstate _ -> ((), state)  getHpUsage :: FCode HeapUsage getHpUsage = do@@ -462,9 +427,9 @@         state <- getState         setState $ state {cgs_binds = new_binds} -withState :: FCode a -> CgState -> FCode (a,CgState)-withState (FCode fcode) newstate = FCode $ \info_down state ->-  case fcode info_down newstate of+withCgState :: FCode a -> CgState -> FCode (a,CgState)+withCgState (FCode fcode) newstate = FCode $ \cfg fstate state ->+  case fcode cfg fstate newstate of     (retval, state2) -> ((retval,state2), state)  newUniqSupply :: FCode UniqSupply@@ -486,68 +451,41 @@                  ; return (LocalReg uniq rep) }  -------------------getInfoDown :: FCode CgInfoDownwards-getInfoDown = FCode $ \info_down state -> (info_down,state)+initFCodeState :: Platform -> FCodeState+initFCodeState p =+  MkFCodeState { fcs_upframeoffset = platformWordSizeInBytes p+               , fcs_sequel        = Return+               , fcs_selfloop      = Nothing+               , fcs_ticky         = mkTopTickyCtrLabel+               , fcs_tickscope     = GlobalScope+               } +getFCodeState :: FCode FCodeState+getFCodeState = FCode $ \_ fstate state -> (fstate,state)++-- basically local for the reader monad+withFCodeState :: FCode a -> FCodeState -> FCode a+withFCodeState (FCode fcode) fst = FCode $ \cfg _ state -> fcode cfg fst state+ getSelfLoop :: FCode (Maybe SelfLoopInfo)-getSelfLoop = do-        info_down <- getInfoDown-        return $ cgd_self_loop info_down+getSelfLoop = fcs_selfloop <$> getFCodeState  withSelfLoop :: SelfLoopInfo -> FCode a -> FCode a withSelfLoop self_loop code = do-        info_down <- getInfoDown-        withInfoDown code (info_down {cgd_self_loop = Just self_loop})--instance HasDynFlags FCode where-    getDynFlags = liftM cgd_dflags getInfoDown--getProfile :: FCode Profile-getProfile = targetProfile <$> getDynFlags--getPlatform :: FCode Platform-getPlatform = profilePlatform <$> getProfile--getCallOpts :: FCode CallOpts-getCallOpts = do-   dflags <- getDynFlags-   profile <- getProfile-   pure $ CallOpts-    { co_profile       = profile-    , co_loopification = gopt Opt_Loopification dflags-    , co_ticky         = gopt Opt_Ticky dflags-    }--getPtrOpts :: FCode PtrOpts-getPtrOpts = do-   dflags <- getDynFlags-   profile <- getProfile-   pure $ PtrOpts-      { po_profile     = profile-      , po_align_check = gopt Opt_AlignmentSanitisation dflags-      }---withInfoDown :: FCode a -> CgInfoDownwards -> FCode a-withInfoDown (FCode fcode) info_down = FCode $ \_ state -> fcode info_down state---- ------------------------------------------------------------------------------- Get the current module name--getModuleName :: FCode Module-getModuleName = do { info <- getInfoDown; return (cgd_mod info) }+        fstate <- getFCodeState+        withFCodeState code (fstate {fcs_selfloop = Just self_loop})  -- ---------------------------------------------------------------------------- -- Get/set the end-of-block info  withSequel :: Sequel -> FCode a -> FCode a withSequel sequel code-  = do  { info  <- getInfoDown-        ; withInfoDown code (info {cgd_sequel = sequel, cgd_self_loop = Nothing }) }+  = do  { fstate <- getFCodeState+        ; withFCodeState code (fstate { fcs_sequel = sequel+                                      , fcs_selfloop = Nothing }) }  getSequel :: FCode Sequel-getSequel = do  { info <- getInfoDown-                ; return (cgd_sequel info) }+getSequel = fcs_sequel <$> getFCodeState  -- ---------------------------------------------------------------------------- -- Get/set the size of the update frame@@ -561,35 +499,29 @@  withUpdFrameOff :: UpdFrameOffset -> FCode a -> FCode a withUpdFrameOff size code-  = do  { info  <- getInfoDown-        ; withInfoDown code (info {cgd_updfr_off = size }) }+  = do  { fstate <- getFCodeState+        ; withFCodeState code (fstate {fcs_upframeoffset = size }) }  getUpdFrameOff :: FCode UpdFrameOffset-getUpdFrameOff-  = do  { info  <- getInfoDown-        ; return $ cgd_updfr_off info }+getUpdFrameOff = fcs_upframeoffset <$> getFCodeState  -- ---------------------------------------------------------------------------- -- Get/set the current ticky counter label  getTickyCtrLabel :: FCode CLabel-getTickyCtrLabel = do-        info <- getInfoDown-        return (cgd_ticky info)+getTickyCtrLabel = fcs_ticky <$> getFCodeState  setTickyCtrLabel :: CLabel -> FCode a -> FCode a setTickyCtrLabel ticky code = do-        info <- getInfoDown-        withInfoDown code (info {cgd_ticky = ticky})+        fstate <- getFCodeState+        withFCodeState code (fstate {fcs_ticky = ticky})  -- ---------------------------------------------------------------------------- -- Manage tick scopes  -- | The current tick scope. We will assign this to generated blocks. getTickScope :: FCode CmmTickScope-getTickScope = do-        info <- getInfoDown-        return (cgd_tick_scope info)+getTickScope = fcs_tickscope <$> getFCodeState  -- | Places blocks generated by the given code into a fresh -- (sub-)scope. This will make sure that Cmm annotations in our scope@@ -597,13 +529,35 @@ -- way around. tickScope :: FCode a -> FCode a tickScope code = do-        info <- getInfoDown-        if debugLevel (cgd_dflags info) == 0 then code else do+        cfg <- getStgToCmmConfig+        fstate <- getFCodeState+        if stgToCmmDebugLevel cfg == 0 then code else do           u <- newUnique-          let scope' = SubScope u (cgd_tick_scope info)-          withInfoDown code info{ cgd_tick_scope = scope' }+          let scope' = SubScope u (fcs_tickscope fstate)+          withFCodeState code fstate{ fcs_tickscope = scope' } +-- ----------------------------------------------------------------------------+-- Config related helpers +getStgToCmmConfig :: FCode StgToCmmConfig+getStgToCmmConfig = FCode $ \cfg _ state -> (cfg,state)++getProfile :: FCode Profile+getProfile = stgToCmmProfile <$> getStgToCmmConfig++getPlatform :: FCode Platform+getPlatform = profilePlatform <$> getProfile++getContext :: FCode SDocContext+getContext = stgToCmmContext <$> getStgToCmmConfig++-- ----------------------------------------------------------------------------+-- Get the current module name++getModuleName :: FCode Module+getModuleName = stgToCmmThisModule <$> getStgToCmmConfig++ -------------------------------------------------------- --                 Forking --------------------------------------------------------@@ -618,14 +572,16 @@  forkClosureBody body_code   = do  { platform <- getPlatform-        ; info   <- getInfoDown-        ; us     <- newUniqSupply-        ; state  <- getState-        ; let body_info_down = info { cgd_sequel    = initSequel-                                    , cgd_updfr_off = initUpdFrameOff platform-                                    , cgd_self_loop = Nothing }+        ; cfg      <- getStgToCmmConfig+        ; fstate   <- getFCodeState+        ; us       <- newUniqSupply+        ; state    <- getState+        ; let fcs = fstate { fcs_sequel        = Return+                           , fcs_upframeoffset = platformWordSizeInBytes platform+                           , fcs_selfloop      = Nothing+                           }               fork_state_in = (initCgState us) { cgs_binds = cgs_binds state }-              ((),fork_state_out) = doFCode body_code body_info_down fork_state_in+              ((),fork_state_out) = doFCode body_code cfg fcs fork_state_in         ; setState $ state `addCodeBlocksFrom` fork_state_out }  forkLneBody :: FCode a -> FCode a@@ -636,11 +592,12 @@ -- the successor.  In particular, any heap usage from the enclosed -- code is discarded; it should deal with its own heap consumption. forkLneBody body_code-  = do  { info_down <- getInfoDown-        ; us        <- newUniqSupply-        ; state     <- getState+  = do  { cfg   <- getStgToCmmConfig+        ; us    <- newUniqSupply+        ; state <- getState+        ; fstate <- getFCodeState         ; let fork_state_in = (initCgState us) { cgs_binds = cgs_binds state }-              (result, fork_state_out) = doFCode body_code info_down fork_state_in+              (result, fork_state_out) = doFCode body_code cfg fstate fork_state_in         ; setState $ state `addCodeBlocksFrom` fork_state_out         ; return result } @@ -649,12 +606,13 @@ -- Do not affect anything else in the outer state -- Used in almost-circular code to prevent false loop dependencies codeOnly body_code-  = do  { info_down <- getInfoDown-        ; us        <- newUniqSupply-        ; state     <- getState+  = do  { cfg   <- getStgToCmmConfig+        ; us    <- newUniqSupply+        ; state <- getState+        ; fstate <- getFCodeState         ; let   fork_state_in = (initCgState us) { cgs_binds   = cgs_binds state                                                  , cgs_hp_usg  = cgs_hp_usg state }-                ((), fork_state_out) = doFCode body_code info_down fork_state_in+                ((), fork_state_out) = doFCode body_code cfg fstate fork_state_in         ; setState $ state `addCodeBlocksFrom` fork_state_out }  forkAlts :: [FCode a] -> FCode [a]@@ -664,11 +622,12 @@ -- that the virtual Hp is moved on to the worst virtual Hp for the branches  forkAlts branch_fcodes-  = do  { info_down <- getInfoDown-        ; us <- newUniqSupply+  = do  { cfg   <- getStgToCmmConfig+        ; us    <- newUniqSupply         ; state <- getState+        ; fstate <- getFCodeState         ; let compile us branch-                = (us2, doFCode branch info_down branch_state)+                = (us2, doFCode branch cfg fstate branch_state)                 where                   (us1,us2) = splitUniqSupply us                   branch_state = (initCgState us1) {@@ -693,7 +652,7 @@ getCodeR :: FCode a -> FCode (a, CmmAGraph) getCodeR fcode   = do  { state1 <- getState-        ; (a, state2) <- withState fcode (state1 { cgs_stmts = mkNop })+        ; (a, state2) <- withCgState fcode (state1 { cgs_stmts = mkNop })         ; setState $ state2 { cgs_stmts = cgs_stmts state1  }         ; return (a, cgs_stmts state2) } @@ -706,7 +665,7 @@   = do  { state1 <- getState         ; ((a, tscope), state2) <-             tickScope $-            flip withState state1 { cgs_stmts = mkNop } $+            flip withCgState state1 { cgs_stmts = mkNop } $             do { a   <- fcode                ; scp <- getTickScope                ; return (a, scp) }@@ -725,10 +684,11 @@  getHeapUsage :: (VirtualHpOffset -> FCode a) -> FCode a getHeapUsage fcode-  = do  { info_down <- getInfoDown+  = do  { cfg <- getStgToCmmConfig         ; state <- getState+        ; fcstate <- getFCodeState         ; let   fstate_in = state { cgs_hp_usg  = initHpUsage }-                (r, fstate_out) = doFCode (fcode hp_hw) info_down fstate_in+                (r, fstate_out) = doFCode (fcode hp_hw) cfg fcstate fstate_in                 hp_hw = heapHWM (cgs_hp_usg fstate_out)        -- Loop here!          ; setState $ fstate_out { cgs_hp_usg = cgs_hp_usg state }@@ -757,8 +717,8 @@  emitUnwind :: [(GlobalReg, Maybe CmmExpr)] -> FCode () emitUnwind regs = do-  dflags <- getDynFlags-  when (debugLevel dflags > 0) $+  debug_level <- stgToCmmDebugLevel <$> getStgToCmmConfig+  when (debug_level > 0) $      emitCgStmt $ CgStmt $ CmmUnwind regs  emitAssign :: CmmReg  -> CmmExpr -> FCode ()@@ -842,7 +802,7 @@ -- object splitting (at a later stage) getCmm code   = do  { state1 <- getState-        ; (a, state2) <- withState code (state1 { cgs_tops  = nilOL })+        ; (a, state2) <- withCgState code (state1 { cgs_tops  = nilOL })         ; setState $ state2 { cgs_tops = cgs_tops state1 }         ; return (a, fromOL (cgs_tops state2)) }
GHC/StgToCmm/Prim.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-}  {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}@@ -16,14 +15,12 @@    shouldInlinePrimOp  ) where -#include "HsVersions.h"-#include "MachDeps.h"- import GHC.Prelude hiding ((<*>))  import GHC.Platform import GHC.Platform.Profile +import GHC.StgToCmm.Config import GHC.StgToCmm.Layout import GHC.StgToCmm.Foreign import GHC.StgToCmm.Monad@@ -32,26 +29,27 @@ import GHC.StgToCmm.Heap import GHC.StgToCmm.Prof ( costCentreFrom ) -import GHC.Driver.Session-import GHC.Driver.Backend import GHC.Types.Basic import GHC.Cmm.BlockId import GHC.Cmm.Graph import GHC.Stg.Syntax import GHC.Cmm import GHC.Unit         ( rtsUnit )-import GHC.Core.Type    ( Type, tyConAppTyCon )+import GHC.Core.Type    ( Type, tyConAppTyCon_maybe ) import GHC.Core.TyCon import GHC.Cmm.CLabel+import GHC.Cmm.Info     ( closureInfoPtr ) import GHC.Cmm.Utils import GHC.Builtin.PrimOps import GHC.Runtime.Heap.Layout import GHC.Data.FastString import GHC.Utils.Misc import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import Data.Maybe  import Control.Monad (liftM, when, unless)+import GHC.Utils.Outputable  ------------------------------------------------------------------------ --      Primitive operations and foreign calls@@ -76,21 +74,21 @@ -- Foreign calls cgOpApp (StgFCallOp fcall ty) stg_args res_ty   = cgForeignCall fcall ty stg_args res_ty-      -- Note [Foreign call results]+      -- See Note [Foreign call results]  cgOpApp (StgPrimOp primop) args res_ty = do-    dflags <- getDynFlags+    cfg <- getStgToCmmConfig     cmm_args <- getNonVoidArgAmodes args-    cmmPrimOpApp dflags primop cmm_args (Just res_ty)+    cmmPrimOpApp cfg primop cmm_args (Just res_ty)  cgOpApp (StgPrimCallOp primcall) args _res_ty   = do  { cmm_args <- getNonVoidArgAmodes args         ; let fun = CmmLit (CmmLabel (mkPrimCallLabel primcall))         ; emitCall (NativeNodeCall, NativeReturn) fun cmm_args } -cmmPrimOpApp :: DynFlags -> PrimOp -> [CmmExpr] -> Maybe Type -> FCode ReturnKind-cmmPrimOpApp dflags primop cmm_args mres_ty =-  case emitPrimOp dflags primop cmm_args of+cmmPrimOpApp :: StgToCmmConfig -> PrimOp -> [CmmExpr] -> Maybe Type -> FCode ReturnKind+cmmPrimOpApp cfg primop cmm_args mres_ty =+  case emitPrimOp cfg primop cmm_args of     PrimopCmmEmit_Internal f ->       let          -- if the result type isn't explicitly given, we directly use the@@ -121,8 +119,8 @@ --      Emitting code for a primop ------------------------------------------------------------------------ -shouldInlinePrimOp :: DynFlags -> PrimOp -> [CmmExpr] -> Bool-shouldInlinePrimOp dflags op args = case emitPrimOp dflags op args of+shouldInlinePrimOp :: StgToCmmConfig -> PrimOp -> [CmmExpr] -> Bool+shouldInlinePrimOp cfg op args = case emitPrimOp cfg op args of   PrimopCmmEmit_External -> False   PrimopCmmEmit_Internal _ -> True @@ -145,20 +143,22 @@ -- might happen e.g. if there's enough static information, such as statically -- know arguments. emitPrimOp-  :: DynFlags+  :: StgToCmmConfig   -> PrimOp            -- ^ The primop   -> [CmmExpr]         -- ^ The primop arguments   -> PrimopCmmEmit-emitPrimOp dflags primop = case primop of+emitPrimOp cfg primop =+  let max_inl_alloc_size = fromIntegral (stgToCmmMaxInlAllocSize cfg)+  in case primop of   NewByteArrayOp_Char -> \case     [(CmmLit (CmmInt n w))]-      | asUnsigned w n <= fromIntegral (maxInlineAllocSize dflags)+      | asUnsigned w n <= max_inl_alloc_size       -> opIntoRegs  $ \ [res] -> doNewByteArrayOp res (fromInteger n)     _ -> PrimopCmmEmit_External    NewArrayOp -> \case     [(CmmLit (CmmInt n w)), init]-      | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)+      | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size       -> opIntoRegs $ \[res] -> doNewArrayOp res (arrPtrsRep platform (fromInteger n)) mkMAP_DIRTY_infoLabel         [ (mkIntExpr platform (fromInteger n),            fixedHdrSize profile + pc_OFFSET_StgMutArrPtrs_ptrs (platformConstants platform))@@ -178,43 +178,33 @@       opIntoRegs $ \ [] -> doCopyMutableArrayOp src src_off dst dst_off (fromInteger n)     _ -> PrimopCmmEmit_External -  CopyArrayArrayOp -> \case-    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] ->-      opIntoRegs $ \ [] -> doCopyArrayOp src src_off dst dst_off (fromInteger n)-    _ -> PrimopCmmEmit_External--  CopyMutableArrayArrayOp -> \case-    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] ->-      opIntoRegs $ \ [] -> doCopyMutableArrayOp src src_off dst dst_off (fromInteger n)-    _ -> PrimopCmmEmit_External-   CloneArrayOp -> \case     [src, src_off, (CmmLit (CmmInt n w))]-      | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)+      | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size       -> opIntoRegs $ \ [res] -> emitCloneArray mkMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)     _ -> PrimopCmmEmit_External    CloneMutableArrayOp -> \case     [src, src_off, (CmmLit (CmmInt n w))]-      | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)+      | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size       -> opIntoRegs $ \ [res] -> emitCloneArray mkMAP_DIRTY_infoLabel res src src_off (fromInteger n)     _ -> PrimopCmmEmit_External    FreezeArrayOp -> \case     [src, src_off, (CmmLit (CmmInt n w))]-      | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)+      | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size       -> opIntoRegs $ \ [res] -> emitCloneArray mkMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)     _ -> PrimopCmmEmit_External    ThawArrayOp -> \case     [src, src_off, (CmmLit (CmmInt n w))]-      | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)+      | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size       -> opIntoRegs $ \ [res] -> emitCloneArray mkMAP_DIRTY_infoLabel res src src_off (fromInteger n)     _ -> PrimopCmmEmit_External    NewSmallArrayOp -> \case     [(CmmLit (CmmInt n w)), init]-      | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)+      | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size       -> opIntoRegs $ \ [res] ->         doNewArrayOp res (smallArrPtrsRep (fromInteger n)) mkSMAP_DIRTY_infoLabel         [ (mkIntExpr platform (fromInteger n),@@ -235,25 +225,25 @@    CloneSmallArrayOp -> \case     [src, src_off, (CmmLit (CmmInt n w))]-      | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)+      | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size       -> opIntoRegs $ \ [res] -> emitCloneSmallArray mkSMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)     _ -> PrimopCmmEmit_External    CloneSmallMutableArrayOp -> \case     [src, src_off, (CmmLit (CmmInt n w))]-      | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)+      | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size       -> opIntoRegs $ \ [res] -> emitCloneSmallArray mkSMAP_DIRTY_infoLabel res src src_off (fromInteger n)     _ -> PrimopCmmEmit_External    FreezeSmallArrayOp -> \case     [src, src_off, (CmmLit (CmmInt n w))]-      | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)+      | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size       -> opIntoRegs $ \ [res] -> emitCloneSmallArray mkSMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)     _ -> PrimopCmmEmit_External    ThawSmallArrayOp -> \case     [src, src_off, (CmmLit (CmmInt n w))]-      | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)+      | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size       -> opIntoRegs $ \ [res] -> emitCloneSmallArray mkSMAP_DIRTY_infoLabel res src src_off (fromInteger n)     _ -> PrimopCmmEmit_External @@ -306,11 +296,17 @@     -- MutVar's value.     emitPrimCall res MO_WriteBarrier []     emitStore (cmmOffsetW platform mutv (fixedHdrSizeW profile)) var-    emitCCall-            [{-no results-}]-            (CmmLit (CmmLabel mkDirty_MUT_VAR_Label))-            [(baseExpr, AddrHint), (mutv, AddrHint), (CmmReg old_val, AddrHint)] +    platform <- getPlatform+    mkdirtyMutVarCCall <- getCode $! emitCCall+      [{-no results-}]+      (CmmLit (CmmLabel mkDirty_MUT_VAR_Label))+      [(baseExpr, AddrHint), (mutv, AddrHint), (CmmReg old_val, AddrHint)]+    emit =<< mkCmmIfThen+      (cmmEqWord platform (mkLblExpr mkMUT_VAR_CLEAN_infoLabel)+       (closureInfoPtr platform (stgToCmmAlignCheck cfg) mutv))+      mkdirtyMutVarCCall+ --  #define sizzeofByteArrayzh(r,a) \ --     r = ((StgArrBytes *)(a))->bytes   SizeofByteArrayOp -> \[arg] -> opIntoRegs $ \[res] ->@@ -318,7 +314,7 @@  --  #define sizzeofMutableByteArrayzh(r,a) \ --      r = ((StgArrBytes *)(a))->bytes-  SizeofMutableByteArrayOp -> emitPrimOp dflags SizeofByteArrayOp+  SizeofMutableByteArrayOp -> emitPrimOp cfg SizeofByteArrayOp  --  #define getSizzeofMutableByteArrayzh(r,a) \ --      r = ((StgArrBytes *)(a))->bytes@@ -342,6 +338,8 @@   StableNameToIntOp -> \[arg] -> opIntoRegs $ \[res] ->     emitAssign (CmmLocal res) (cmmLoadIndexW platform arg (fixedHdrSizeW profile) (bWord platform)) +  EqStablePtrOp -> \args -> opTranslate args (mo_wordEq platform)+   ReallyUnsafePtrEqualityOp -> \[arg1, arg2] -> opIntoRegs $ \[res] ->     emitAssign (CmmLocal res) (CmmMachOp (mo_wordEq platform) [arg1,arg2]) @@ -367,10 +365,6 @@     emit $ catAGraphs       [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_DIRTY_infoLabel)),         mkAssign (CmmLocal res) arg ]-  UnsafeFreezeArrayArrayOp -> \[arg] -> opIntoRegs $ \[res] ->-    emit $ catAGraphs-      [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_DIRTY_infoLabel)),-        mkAssign (CmmLocal res) arg ]   UnsafeFreezeSmallArrayOp -> \[arg] -> opIntoRegs $ \[res] ->     emit $ catAGraphs       [ setInfo arg (CmmLit (CmmLabel mkSMAP_FROZEN_DIRTY_infoLabel)),@@ -389,27 +383,6 @@   WriteArrayOp -> \[obj, ix, v] -> opIntoRegs $ \[] ->     doWritePtrArrayOp obj ix v -  IndexArrayArrayOp_ByteArray -> \[obj, ix] -> opIntoRegs $ \[res] ->-    doReadPtrArrayOp res obj ix-  IndexArrayArrayOp_ArrayArray -> \[obj, ix] -> opIntoRegs $ \[res] ->-    doReadPtrArrayOp res obj ix-  ReadArrayArrayOp_ByteArray -> \[obj, ix] -> opIntoRegs $ \[res] ->-    doReadPtrArrayOp res obj ix-  ReadArrayArrayOp_MutableByteArray -> \[obj, ix] -> opIntoRegs $ \[res] ->-    doReadPtrArrayOp res obj ix-  ReadArrayArrayOp_ArrayArray -> \[obj, ix] -> opIntoRegs $ \[res] ->-    doReadPtrArrayOp res obj ix-  ReadArrayArrayOp_MutableArrayArray -> \[obj, ix] -> opIntoRegs $ \[res] ->-    doReadPtrArrayOp res obj ix-  WriteArrayArrayOp_ByteArray -> \[obj,ix,v] -> opIntoRegs $ \[] ->-    doWritePtrArrayOp obj ix v-  WriteArrayArrayOp_MutableByteArray -> \[obj,ix,v] -> opIntoRegs $ \[] ->-    doWritePtrArrayOp obj ix v-  WriteArrayArrayOp_ArrayArray -> \[obj,ix,v] -> opIntoRegs $ \[] ->-    doWritePtrArrayOp obj ix v-  WriteArrayArrayOp_MutableArrayArray -> \[obj,ix,v] -> opIntoRegs $ \[] ->-    doWritePtrArrayOp obj ix v-   ReadSmallArrayOp -> \[obj, ix] -> opIntoRegs $ \[res] ->     doReadSmallPtrArrayOp res obj ix   IndexSmallArrayOp -> \[obj, ix] -> opIntoRegs $ \[res] ->@@ -423,17 +396,15 @@     emit $ mkAssign (CmmLocal res) (cmmLoadIndexW platform arg       (fixedHdrSizeW profile + bytesToWordsRoundUp platform (pc_OFFSET_StgMutArrPtrs_ptrs (platformConstants platform)))         (bWord platform))-  SizeofMutableArrayOp -> emitPrimOp dflags SizeofArrayOp-  SizeofArrayArrayOp -> emitPrimOp dflags SizeofArrayOp-  SizeofMutableArrayArrayOp -> emitPrimOp dflags SizeofArrayOp+  SizeofMutableArrayOp      -> emitPrimOp cfg SizeofArrayOp   SizeofSmallArrayOp -> \[arg] -> opIntoRegs $ \[res] ->     emit $ mkAssign (CmmLocal res)      (cmmLoadIndexW platform arg      (fixedHdrSizeW profile + bytesToWordsRoundUp platform (pc_OFFSET_StgSmallMutArrPtrs_ptrs (platformConstants platform)))         (bWord platform)) -  SizeofSmallMutableArrayOp -> emitPrimOp dflags SizeofSmallArrayOp-  GetSizeofSmallMutableArrayOp -> emitPrimOp dflags SizeofSmallArrayOp+  SizeofSmallMutableArrayOp    -> emitPrimOp cfg SizeofSmallArrayOp+  GetSizeofSmallMutableArrayOp -> emitPrimOp cfg SizeofSmallArrayOp  -- IndexXXXoffAddr @@ -870,10 +841,18 @@     emitPrimCall [res] (MO_Cmpxchg (wordWidth platform)) [dst, expected, new]   CasAddrOp_Word -> \[dst, expected, new] -> opIntoRegs $ \[res] ->     emitPrimCall [res] (MO_Cmpxchg (wordWidth platform)) [dst, expected, new]+  CasAddrOp_Word8 -> \[dst, expected, new] -> opIntoRegs $ \[res] ->+    emitPrimCall [res] (MO_Cmpxchg W8) [dst, expected, new]+  CasAddrOp_Word16 -> \[dst, expected, new] -> opIntoRegs $ \[res] ->+    emitPrimCall [res] (MO_Cmpxchg W16) [dst, expected, new]+  CasAddrOp_Word32 -> \[dst, expected, new] -> opIntoRegs $ \[res] ->+    emitPrimCall [res] (MO_Cmpxchg W32) [dst, expected, new]+  CasAddrOp_Word64 -> \[dst, expected, new] -> opIntoRegs $ \[res] ->+    emitPrimCall [res] (MO_Cmpxchg W64) [dst, expected, new]  -- SIMD primops   (VecBroadcastOp vcat n w) -> \[e] -> opIntoRegs $ \[res] -> do-    checkVecCompatibility dflags vcat n w+    checkVecCompatibility cfg vcat n w     doVecPackOp (vecElemInjectCast platform vcat w) ty zeros (replicate n e) res    where     zeros :: CmmExpr@@ -889,7 +868,7 @@     ty = vecVmmType vcat n w    (VecPackOp vcat n w) -> \es -> opIntoRegs $ \[res] -> do-    checkVecCompatibility dflags vcat n w+    checkVecCompatibility cfg vcat n w     when (es `lengthIsNot` n) $         panic "emitPrimOp: VecPackOp has wrong number of arguments"     doVecPackOp (vecElemInjectCast platform vcat w) ty zeros es res@@ -907,7 +886,7 @@     ty = vecVmmType vcat n w    (VecUnpackOp vcat n w) -> \[arg] -> opIntoRegs $ \res -> do-    checkVecCompatibility dflags vcat n w+    checkVecCompatibility cfg vcat n w     when (res `lengthIsNot` n) $         panic "emitPrimOp: VecUnpackOp has wrong number of results"     doVecUnpackOp (vecElemProjectCast platform vcat w) ty arg res@@ -916,56 +895,56 @@     ty = vecVmmType vcat n w    (VecInsertOp vcat n w) -> \[v,e,i] -> opIntoRegs $ \[res] -> do-    checkVecCompatibility dflags vcat n w+    checkVecCompatibility cfg vcat n w     doVecInsertOp (vecElemInjectCast platform vcat w) ty v e i res    where     ty :: CmmType     ty = vecVmmType vcat n w    (VecIndexByteArrayOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do-    checkVecCompatibility dflags vcat n w+    checkVecCompatibility cfg vcat n w     doIndexByteArrayOp Nothing ty res0 args    where     ty :: CmmType     ty = vecVmmType vcat n w    (VecReadByteArrayOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do-    checkVecCompatibility dflags vcat n w+    checkVecCompatibility cfg vcat n w     doIndexByteArrayOp Nothing ty res0 args    where     ty :: CmmType     ty = vecVmmType vcat n w    (VecWriteByteArrayOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do-    checkVecCompatibility dflags vcat n w+    checkVecCompatibility cfg vcat n w     doWriteByteArrayOp Nothing ty res0 args    where     ty :: CmmType     ty = vecVmmType vcat n w    (VecIndexOffAddrOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do-    checkVecCompatibility dflags vcat n w+    checkVecCompatibility cfg vcat n w     doIndexOffAddrOp Nothing ty res0 args    where     ty :: CmmType     ty = vecVmmType vcat n w    (VecReadOffAddrOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do-    checkVecCompatibility dflags vcat n w+    checkVecCompatibility cfg vcat n w     doIndexOffAddrOp Nothing ty res0 args    where     ty :: CmmType     ty = vecVmmType vcat n w    (VecWriteOffAddrOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do-    checkVecCompatibility dflags vcat n w+    checkVecCompatibility cfg vcat n w     doWriteOffAddrOp Nothing ty res0 args    where     ty :: CmmType     ty = vecVmmType vcat n w    (VecIndexScalarByteArrayOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do-    checkVecCompatibility dflags vcat n w+    checkVecCompatibility cfg vcat n w     doIndexByteArrayOpAs Nothing vecty ty res0 args    where     vecty :: CmmType@@ -975,7 +954,7 @@     ty = vecCmmCat vcat w    (VecReadScalarByteArrayOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do-    checkVecCompatibility dflags vcat n w+    checkVecCompatibility cfg vcat n w     doIndexByteArrayOpAs Nothing vecty ty res0 args    where     vecty :: CmmType@@ -985,14 +964,14 @@     ty = vecCmmCat vcat w    (VecWriteScalarByteArrayOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do-    checkVecCompatibility dflags vcat n w+    checkVecCompatibility cfg vcat n w     doWriteByteArrayOp Nothing ty res0 args    where     ty :: CmmType     ty = vecCmmCat vcat w    (VecIndexScalarOffAddrOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do-    checkVecCompatibility dflags vcat n w+    checkVecCompatibility cfg vcat n w     doIndexOffAddrOpAs Nothing vecty ty res0 args    where     vecty :: CmmType@@ -1002,7 +981,7 @@     ty = vecCmmCat vcat w    (VecReadScalarOffAddrOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do-    checkVecCompatibility dflags vcat n w+    checkVecCompatibility cfg vcat n w     doIndexOffAddrOpAs Nothing vecty ty res0 args    where     vecty :: CmmType@@ -1012,7 +991,7 @@     ty = vecCmmCat vcat w    (VecWriteScalarOffAddrOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do-    checkVecCompatibility dflags vcat n w+    checkVecCompatibility cfg vcat n w     doWriteOffAddrOp Nothing ty res0 args    where     ty :: CmmType@@ -1073,6 +1052,14 @@     doAtomicWriteByteArray mba ix (bWord platform) val   CasByteArrayOp_Int -> \[mba, ix, old, new] -> opIntoRegs $ \[res] ->     doCasByteArray res mba ix (bWord platform) old new+  CasByteArrayOp_Int8 -> \[mba, ix, old, new] -> opIntoRegs $ \[res] ->+    doCasByteArray res mba ix b8 old new+  CasByteArrayOp_Int16 -> \[mba, ix, old, new] -> opIntoRegs $ \[res] ->+    doCasByteArray res mba ix b16 old new+  CasByteArrayOp_Int32 -> \[mba, ix, old, new] -> opIntoRegs $ \[res] ->+    doCasByteArray res mba ix b32 old new+  CasByteArrayOp_Int64 -> \[mba, ix, old, new] -> opIntoRegs $ \[res] ->+    doCasByteArray res mba ix b64 old new  -- The rest just translate straightforwardly @@ -1082,10 +1069,8 @@   Word16ToInt16Op -> \args -> opNop args   Int32ToWord32Op -> \args -> opNop args   Word32ToInt32Op -> \args -> opNop args-#if WORD_SIZE_IN_BITS < 64   Int64ToWord64Op -> \args -> opNop args   Word64ToInt64Op -> \args -> opNop args-#endif   IntToWordOp     -> \args -> opNop args   WordToIntOp     -> \args -> opNop args   IntToAddrOp     -> \args -> opNop args@@ -1338,7 +1323,6 @@   Word32LtOp     -> \args -> opTranslate args (MO_U_Lt W32)   Word32NeOp     -> \args -> opTranslate args (MO_Ne W32) -#if WORD_SIZE_IN_BITS < 64 -- Int64# signed ops    Int64ToIntOp   -> \args -> opTranslate64 args (\w -> MO_SS_Conv w (wordWidth platform)) MO_I64_ToI@@ -1384,7 +1368,6 @@   Word64LeOp     -> \args -> opTranslate64 args MO_U_Le   MO_W64_Le   Word64LtOp     -> \args -> opTranslate64 args MO_U_Lt   MO_W64_Lt   Word64NeOp     -> \args -> opTranslate64 args MO_Ne     MO_x64_Ne-#endif  -- Char# ops @@ -1462,107 +1445,93 @@   FloatToDoubleOp -> \args -> opTranslate args (MO_FF_Conv W32 W64)   DoubleToFloatOp -> \args -> opTranslate args (MO_FF_Conv W64 W32) --- Word comparisons masquerading as more exotic things.--  SameMutVarOp            -> \args -> opTranslate args (mo_wordEq platform)-  SameMVarOp              -> \args -> opTranslate args (mo_wordEq platform)-  SameIOPortOp            -> \args -> opTranslate args (mo_wordEq platform)-  SameMutableArrayOp      -> \args -> opTranslate args (mo_wordEq platform)-  SameMutableByteArrayOp  -> \args -> opTranslate args (mo_wordEq platform)-  SameMutableArrayArrayOp -> \args -> opTranslate args (mo_wordEq platform)-  SameSmallMutableArrayOp -> \args -> opTranslate args (mo_wordEq platform)-  SameTVarOp              -> \args -> opTranslate args (mo_wordEq platform)-  EqStablePtrOp           -> \args -> opTranslate args (mo_wordEq platform)--- See Note [Comparing stable names]-  EqStableNameOp          -> \args -> opTranslate args (mo_wordEq platform)-   IntQuotRemOp -> \args -> opCallishHandledLater args $-    if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args)+    if allowQuotRem && not (quotRemCanBeOptimized args)     then Left (MO_S_QuotRem  (wordWidth platform))     else Right (genericIntQuotRemOp (wordWidth platform))    Int8QuotRemOp -> \args -> opCallishHandledLater args $-    if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args)+    if allowQuotRem && not (quotRemCanBeOptimized args)     then Left (MO_S_QuotRem W8)     else Right (genericIntQuotRemOp W8)    Int16QuotRemOp -> \args -> opCallishHandledLater args $-    if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args)+    if allowQuotRem && not (quotRemCanBeOptimized args)     then Left (MO_S_QuotRem W16)     else Right (genericIntQuotRemOp W16)    Int32QuotRemOp -> \args -> opCallishHandledLater args $-    if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args)+    if allowQuotRem && not (quotRemCanBeOptimized args)     then Left (MO_S_QuotRem W32)     else Right (genericIntQuotRemOp W32)    WordQuotRemOp -> \args -> opCallishHandledLater args $-    if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args)+    if allowQuotRem && not (quotRemCanBeOptimized args)     then Left (MO_U_QuotRem  (wordWidth platform))     else Right (genericWordQuotRemOp (wordWidth platform))    WordQuotRem2Op -> \args -> opCallishHandledLater args $-    if (ncg && (x86ish || ppc)) || llvm+    if allowQuotRem2     then Left (MO_U_QuotRem2 (wordWidth platform))     else Right (genericWordQuotRem2Op platform)    Word8QuotRemOp -> \args -> opCallishHandledLater args $-    if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args)+    if allowQuotRem && not (quotRemCanBeOptimized args)     then Left (MO_U_QuotRem W8)     else Right (genericWordQuotRemOp W8)    Word16QuotRemOp -> \args -> opCallishHandledLater args $-    if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args)+    if allowQuotRem && not (quotRemCanBeOptimized args)     then Left (MO_U_QuotRem W16)     else Right (genericWordQuotRemOp W16)    Word32QuotRemOp -> \args -> opCallishHandledLater args $-    if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args)+    if allowQuotRem && not (quotRemCanBeOptimized args)     then Left (MO_U_QuotRem W32)     else Right (genericWordQuotRemOp W32)    WordAdd2Op -> \args -> opCallishHandledLater args $-    if (ncg && (x86ish || ppc)) || llvm+    if allowExtAdd     then Left (MO_Add2       (wordWidth platform))     else Right genericWordAdd2Op    WordAddCOp -> \args -> opCallishHandledLater args $-    if (ncg && (x86ish || ppc)) || llvm+    if allowExtAdd     then Left (MO_AddWordC   (wordWidth platform))     else Right genericWordAddCOp    WordSubCOp -> \args -> opCallishHandledLater args $-    if (ncg && (x86ish || ppc)) || llvm+    if allowExtAdd     then Left (MO_SubWordC   (wordWidth platform))     else Right genericWordSubCOp    IntAddCOp -> \args -> opCallishHandledLater args $-    if (ncg && (x86ish || ppc)) || llvm+    if allowExtAdd     then Left (MO_AddIntC    (wordWidth platform))     else Right genericIntAddCOp    IntSubCOp -> \args -> opCallishHandledLater args $-    if (ncg && (x86ish || ppc)) || llvm+    if allowExtAdd     then Left (MO_SubIntC    (wordWidth platform))     else Right genericIntSubCOp    WordMul2Op -> \args -> opCallishHandledLater args $-    if ncg && (x86ish || ppc) || llvm+    if allowExtAdd     then Left (MO_U_Mul2     (wordWidth platform))     else Right genericWordMul2Op    IntMul2Op  -> \args -> opCallishHandledLater args $-    if ncg && x86ish || llvm+    if allowInt2Mul     then Left (MO_S_Mul2     (wordWidth platform))     else Right genericIntMul2Op    FloatFabsOp -> \args -> opCallishHandledLater args $-    if (ncg && (x86ish || ppc || aarch64)) || llvm+    if allowFab     then Left MO_F32_Fabs     else Right $ genericFabsOp W32    DoubleFabsOp -> \args -> opCallishHandledLater args $-    if (ncg && (x86ish || ppc || aarch64)) || llvm+    if allowFab     then Left MO_F64_Fabs     else Right $ genericFabsOp W64 @@ -1574,8 +1543,8 @@     -- you used tagToEnum# in a non-monomorphic setting, e.g.,     --         intToTg :: Enum a => Int -> a ; intToTg (I# x#) = tagToEnum# x#     -- That won't work.-    let tycon = tyConAppTyCon res_ty-    MASSERT(isEnumerationTyCon tycon)+    let tycon = fromMaybe (pprPanic "tagToEnum#: Applied to non-concrete type" (ppr res_ty)) (tyConAppTyCon_maybe res_ty)+    massert (isEnumerationTyCon tycon)     platform <- getPlatform     pure [tagToClosure platform tycon amode] @@ -1596,7 +1565,6 @@   ShrinkMutableByteArrayOp_Char -> alwaysExternal   ResizeMutableByteArrayOp_Char -> alwaysExternal   ShrinkSmallMutableArrayOp_Char -> alwaysExternal-  NewArrayArrayOp -> alwaysExternal   NewMutVarOp -> alwaysExternal   AtomicModifyMutVar2Op -> alwaysExternal   AtomicModifyMutVar_Op -> alwaysExternal@@ -1624,7 +1592,7 @@   ReadMVarOp -> alwaysExternal   TryReadMVarOp -> alwaysExternal   IsEmptyMVarOp -> alwaysExternal-  NewIOPortrOp -> alwaysExternal+  NewIOPortOp -> alwaysExternal   ReadIOPortOp -> alwaysExternal   WriteIOPortOp -> alwaysExternal   DelayOp -> alwaysExternal@@ -1675,8 +1643,8 @@   KeepAliveOp -> alwaysExternal   where-  profile = targetProfile dflags-  platform = profilePlatform profile+  profile  = stgToCmmProfile  cfg+  platform = stgToCmmPlatform cfg   result_info = getPrimOpResultInfo primop    opNop :: [CmmExpr] -> PrimopCmmEmit@@ -1691,7 +1659,7 @@     CmmMachOp (mop rep (wordWidth platform)) [CmmMachOp (mop (wordWidth platform) rep) [arg]]     where [arg] = args -  -- | These primops are implemented by CallishMachOps, because they sometimes+  -- These primops are implemented by CallishMachOps, because they sometimes   -- turn into foreign calls depending on the backend.   opCallish :: [CmmExpr] -> CallishMachOp -> PrimopCmmEmit   opCallish args prim = opIntoRegs $ \[res] -> emitPrimCall [res] prim args@@ -1701,7 +1669,6 @@     let stmt = mkAssign (CmmLocal res) (CmmMachOp mop args)     emit stmt -#if WORD_SIZE_IN_BITS < 64   opTranslate64     :: [CmmExpr]     -> (Width -> MachOp)@@ -1710,12 +1677,11 @@   opTranslate64 args mkMop callish =     case platformWordSize platform of       -- LLVM and C `can handle larger than native size arithmetic natively.-      _ | not ncg -> opTranslate args $ mkMop W64+      _ | stgToCmmAllowBigArith cfg -> opTranslate args $ mkMop W64       PW4 -> opCallish args callish       PW8 -> opTranslate args $ mkMop W64-#endif -  -- | Basically a "manual" case, rather than one of the common repetitive forms+  -- Basically a "manual" case, rather than one of the common repetitive forms   -- above. The results are a parameter to the returned function so we know the   -- choice of variant never depends on them.   opCallishHandledLater@@ -1748,7 +1714,6 @@   alwaysExternal = \_ -> PrimopCmmEmit_External   -- Note [QuotRem optimization]   -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~-  --   -- `quot` and `rem` with constant divisor can be implemented with fast bit-ops   -- (shift, .&.).   --@@ -1765,17 +1730,11 @@     [_, CmmLit (CmmInt n _) ] -> isJust (exactLog2 n)     _                         -> False -  ncg  = backend dflags == NCG-  llvm = backend dflags == LLVM-  x86ish = case platformArch platform of-             ArchX86    -> True-             ArchX86_64 -> True-             _          -> False-  ppc = case platformArch platform of-          ArchPPC      -> True-          ArchPPC_64 _ -> True-          _            -> False-  aarch64 = platformArch platform == ArchAArch64+  allowQuotRem  = stgToCmmAllowQuotRemInstr         cfg+  allowQuotRem2 = stgToCmmAllowQuotRem2             cfg+  allowExtAdd   = stgToCmmAllowExtendedAddSubInstrs cfg+  allowInt2Mul  = stgToCmmAllowIntMul2Instr         cfg+  allowFab      = stgToCmmAllowFabsInstrs           cfg  data PrimopCmmEmit   -- | Out of line fake primop that's actually just a foreign call to other@@ -2042,14 +2001,14 @@  genericIntMul2Op :: GenericOp genericIntMul2Op [res_c, res_h, res_l] both_args@[arg_x, arg_y]- = do dflags <- getDynFlags-      platform <- getPlatform+ = do cfg <- getStgToCmmConfig       -- Implement algorithm from Hacker's Delight, 2nd edition, p.174-      let t = cmmExprType platform arg_x+      let t        = cmmExprType platform arg_x+          platform = stgToCmmPlatform cfg       p   <- newTemp t       -- 1) compute the multiplication as if numbers were unsigned       _ <- withSequel (AssignTo [p, res_l] False) $-             cmmPrimOpApp dflags WordMul2Op both_args Nothing+             cmmPrimOpApp cfg WordMul2Op both_args Nothing       -- 2) correct the high bits of the unsigned result       let carryFill x = CmmMachOp (MO_S_Shr ww) [x, wwm1]           sub x y     = CmmMachOp (MO_Sub   ww) [x, y]@@ -2093,17 +2052,6 @@  genericFabsOp _ _ _ = panic "genericFabsOp" --- Note [Comparing stable names]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~------ A StableName# is actually a pointer to a stable name object (SNO)--- containing an index into the stable name table (SNT). We--- used to compare StableName#s by following the pointers to the--- SNOs and checking whether they held the same SNT indices. However,--- this is not necessary: there is a one-to-one correspondence--- between SNOs and entries in the SNT, so simple pointer equality--- does the trick.- ------------------------------------------------------------------------------ -- Helpers for translating various minor variants of array indexing. @@ -2355,14 +2303,13 @@ --    it may very well be a design perspective that helps guide improving the NCG.  -checkVecCompatibility :: DynFlags -> PrimOpVecCat -> Length -> Width -> FCode ()-checkVecCompatibility dflags vcat l w = do-    when (backend dflags /= LLVM) $-        sorry $ unlines ["SIMD vector instructions require the LLVM back-end."-                         ,"Please use -fllvm."]-    check vecWidth vcat l w+checkVecCompatibility :: StgToCmmConfig -> PrimOpVecCat -> Length -> Width -> FCode ()+checkVecCompatibility cfg vcat l w =+  case stgToCmmVecInstrsErr cfg of+    Nothing  -> check vecWidth vcat l w  -- We are in a compatible backend+    Just err -> sorry err                -- incompatible backend, do panic   where-    platform = targetPlatform dflags+    platform = stgToCmmPlatform cfg     check :: Width -> PrimOpVecCat -> Length -> Width -> FCode ()     check W128 FloatVec 4 W32 | not (isSseEnabled platform) =         sorry $ "128-bit wide single-precision floating point " ++@@ -2370,13 +2317,13 @@     check W128 _ _ _ | not (isSse2Enabled platform) =         sorry $ "128-bit wide integer and double precision " ++                 "SIMD vector instructions require at least -msse2."-    check W256 FloatVec _ _ | not (isAvxEnabled dflags) =+    check W256 FloatVec _ _ | not (stgToCmmAvx cfg) =         sorry $ "256-bit wide floating point " ++                 "SIMD vector instructions require at least -mavx."-    check W256 _ _ _ | not (isAvx2Enabled dflags) =+    check W256 _ _ _ | not (stgToCmmAvx2 cfg) =         sorry $ "256-bit wide integer " ++                 "SIMD vector instructions require at least -mavx2."-    check W512 _ _ _ | not (isAvx512fEnabled dflags) =+    check W512 _ _ _ | not (stgToCmmAvx512f cfg) =         sorry $ "512-bit wide " ++                 "SIMD vector instructions require -mavx512f."     check _ _ _ _ = return ()@@ -3294,9 +3241,9 @@               -> CmmExpr  -- ^ array size (in elements)               -> FCode () doBoundsCheck idx sz = do-    dflags <- getDynFlags-    platform <- getPlatform-    when (gopt Opt_DoBoundsChecking dflags) (doCheck platform)+    do_bounds_check <- stgToCmmDoBoundsCheck <$> getStgToCmmConfig+    platform        <- getPlatform+    when do_bounds_check (doCheck platform)   where     doCheck platform = do         boundsCheckFailed <- getCode $ emitCCall [] (mkLblExpr mkOutOfBoundsAccessLabel) []
GHC/StgToCmm/Prof.hs view
@@ -28,12 +28,10 @@  import GHC.Prelude -import GHC.Driver.Session-import GHC.Driver.Ppr- import GHC.Platform import GHC.Platform.Profile import GHC.StgToCmm.Closure+import GHC.StgToCmm.Config import GHC.StgToCmm.Utils import GHC.StgToCmm.Monad import GHC.StgToCmm.Lit@@ -56,7 +54,9 @@ import GHC.Utils.Encoding  import Control.Monad-import Data.Char (ord)+import Data.Char       (ord)+import Data.Bifunctor  (first)+import GHC.Utils.Monad (whenM)  ----------------------------------------------------------------------------- --@@ -72,7 +72,7 @@ ccType = bWord  storeCurCCS :: CmmExpr -> CmmAGraph-storeCurCCS e = mkAssign cccsReg e+storeCurCCS = mkAssign cccsReg  mkCCostCentre :: CostCentre -> CmmLit mkCCostCentre cc = CmmLabel (mkCCLabel cc)@@ -139,9 +139,9 @@ saveCurrentCostCentre :: FCode (Maybe LocalReg)         -- Returns Nothing if profiling is off saveCurrentCostCentre-  = do dflags <- getDynFlags-       platform <- getPlatform-       if not (sccProfilingEnabled dflags)+  = do sccProfilingEnabled <- stgToCmmSCCProfiling <$> getStgToCmmConfig+       platform            <- getPlatform+       if not sccProfilingEnabled            then return Nothing            else do local_cc <- newTemp (ccType platform)                    emitAssign (CmmLocal local_cc) cccsExpr@@ -163,7 +163,7 @@ profDynAlloc :: SMRep -> CmmExpr -> FCode () profDynAlloc rep ccs   = ifProfiling $-    do profile <- targetProfile <$> getDynFlags+    do profile <- getProfile        let platform = profilePlatform profile        profAlloc (mkIntExpr platform (heapClosureSizeW profile rep)) ccs @@ -173,12 +173,12 @@ profAlloc :: CmmExpr -> CmmExpr -> FCode () profAlloc words ccs   = ifProfiling $-        do profile <- targetProfile <$> getDynFlags+        do profile <- getProfile            let platform = profilePlatform profile            let alloc_rep = rEP_CostCentreStack_mem_alloc platform            emit $ addToMemE alloc_rep                        (cmmOffsetB platform ccs (pc_OFFSET_CostCentreStack_mem_alloc (platformConstants platform)))-                       (CmmMachOp (MO_UU_Conv (wordWidth platform) (typeWidth alloc_rep)) $+                       (CmmMachOp (MO_UU_Conv (wordWidth platform) (typeWidth alloc_rep))                            -- subtract the "profiling overhead", which is the                            -- profiling header in a closure.                            [CmmMachOp (mo_wordSub platform) [ words, mkIntExpr platform (profHdrSize profile)]]@@ -194,21 +194,18 @@       emit $ storeCurCCS (costCentreFrom platform closure)  enterCostCentreFun :: CostCentreStack -> CmmExpr -> FCode ()-enterCostCentreFun ccs closure =-  ifProfiling $-    if isCurrentCCS ccs-       then do platform <- getPlatform-               emitRtsCall rtsUnitId (fsLit "enterFunCCS")-                   [(baseExpr, AddrHint),-                    (costCentreFrom platform closure, AddrHint)] False-       else return () -- top-level function, nothing to do+enterCostCentreFun ccs closure = ifProfiling $+    when (isCurrentCCS ccs) $+    do platform <- getPlatform+       emitRtsCall+         rtsUnitId+         (fsLit "enterFunCCS")+         [(baseExpr, AddrHint), (costCentreFrom platform closure, AddrHint)]+         False+       -- otherwise we have a top-level function, nothing to do  ifProfiling :: FCode () -> FCode ()-ifProfiling code-  = do profile <- targetProfile <$> getDynFlags-       if profileIsProfiling profile-           then code-           else return ()+ifProfiling = whenM (stgToCmmSCCProfiling <$> getStgToCmmConfig)  --------------------------------------------------------------- --        Initialising Cost Centres & CCSs@@ -224,7 +221,7 @@  emitCostCentreDecl :: CostCentre -> FCode () emitCostCentreDecl cc = do-  { dflags <- getDynFlags+  { ctx      <- stgToCmmContext <$> getStgToCmmConfig   ; platform <- getPlatform   ; let is_caf | isCafCC cc = mkIntCLit platform (ord 'c') -- 'c' == is a CAF                | otherwise  = zero platform@@ -234,7 +231,7 @@                                         $ moduleName                                         $ cc_mod cc)   ; loc <- newByteStringCLit $ utf8EncodeString $-                   showPpr dflags (costCentreSrcSpan cc)+                   renderWithContext ctx (ppr $! costCentreSrcSpan cc)   ; let      lits = [ zero platform,  -- StgInt ccID,               label,          -- char *label,@@ -278,37 +275,39 @@    (ws,ms) = pc_SIZEOF_CostCentreStack (platformConstants platform) `divMod` platformWordSizeInBytes platform  -initInfoTableProv ::  [CmmInfoTable] -> InfoTableProvMap -> Module -> FCode CStub+initInfoTableProv ::  [CmmInfoTable] -> InfoTableProvMap -> FCode CStub -- Emit the declarations-initInfoTableProv infos itmap this_mod+initInfoTableProv infos itmap   = do-       dflags <- getDynFlags-       let ents = convertInfoProvMap dflags infos this_mod itmap-       --pprTraceM "UsedInfo" (ppr (length infos))-       --pprTraceM "initInfoTable" (ppr (length ents))+       cfg <- getStgToCmmConfig+       let ents       = convertInfoProvMap infos this_mod itmap+           info_table = stgToCmmInfoTableMap cfg+           platform   = stgToCmmPlatform     cfg+           this_mod   = stgToCmmThisModule   cfg        -- Output the actual IPE data        mapM_ emitInfoTableProv ents-       -- Create the C stub which initialises the IPE_LIST-       return (ipInitCode dflags this_mod ents)+       -- Create the C stub which initialises the IPE map+       return (ipInitCode info_table platform this_mod ents)  --- Info Table Prov stuff emitInfoTableProv :: InfoProvEnt  -> FCode () emitInfoTableProv ip = do-  { dflags <- getDynFlags-  ; let mod = infoProvModule ip-  ; let (src, label) = maybe ("", "") (\(s, l) -> (showPpr dflags s, l)) (infoTableProv ip)-  ; platform <- getPlatform-  ; let mk_string = newByteStringCLit . utf8EncodeString+  { cfg <- getStgToCmmConfig+  ; let mod      = infoProvModule ip+        ctx      = stgToCmmContext  cfg+        platform = stgToCmmPlatform cfg+  ; let (src, label) = maybe ("", "") (first (renderWithContext ctx . ppr)) (infoTableProv ip)+        mk_string    = newByteStringCLit . utf8EncodeString   ; label <- mk_string label   ; modl  <- newByteStringCLit (bytesFS $ moduleNameFS-                                        $ moduleName-                                        $ mod)+                                        $ moduleName mod)    ; ty_string  <- mk_string (infoTableType ip)-  ; loc <- mk_string src-  ; table_name <- mk_string (showPpr dflags (pprCLabel platform CStyle (infoTablePtr ip)))-  ; closure_type <- mk_string-                      (showPpr dflags (text $ show $ infoProvEntClosureType ip))+  ; loc        <- mk_string src+  ; table_name <- mk_string (renderWithContext ctx+                             (pprCLabel platform CStyle (infoTablePtr ip)))+  ; closure_type <- mk_string (renderWithContext ctx+                               (text $ show $ infoProvEntClosureType ip))   ; let      lits = [ CmmLabel (infoTablePtr ip), -- Info table pointer               table_name,     -- char *table_name@@ -325,15 +324,12 @@ -- Set the current cost centre stack  emitSetCCC :: CostCentre -> Bool -> Bool -> FCode ()-emitSetCCC cc tick push- = do profile <- targetProfile <$> getDynFlags-      let platform = profilePlatform profile-      if not (profileIsProfiling profile)-          then return ()-          else do tmp <- newTemp (ccsType platform)-                  pushCostCentre tmp cccsExpr cc-                  when tick $ emit (bumpSccCount platform (CmmReg (CmmLocal tmp)))-                  when push $ emit (storeCurCCS (CmmReg (CmmLocal tmp)))+emitSetCCC cc tick push = ifProfiling $+  do platform <- getPlatform+     tmp      <- newTemp (ccsType platform)+     pushCostCentre tmp cccsExpr cc+     when tick $ emit (bumpSccCount platform (CmmReg (CmmLocal tmp)))+     when push $ emit (storeCurCCS (CmmReg (CmmLocal tmp)))  pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> FCode () pushCostCentre result ccs cc
+ GHC/StgToCmm/Sequel.hs view
@@ -0,0 +1,46 @@+-----------------------------------------------------------------------------+--+-- Sequel type for Stg to C-- code generation+--+-- (c) The University of Glasgow 2004-2006+--+-- This module is just a bucket of types used in StgToCmm.Monad and+-- StgToCmm.Closure. Its sole purpose is to break a cyclic dependency between+-- StgToCmm.Monad and StgToCmm.Closure which derives from coupling around+-- the BlockId and LocalReg types+-----------------------------------------------------------------------------++module GHC.StgToCmm.Sequel+  ( Sequel(..)+  , SelfLoopInfo+  ) where++import GHC.Cmm.BlockId+import GHC.Cmm+import GHC.Cmm.Ppr()++import GHC.Types.Id+import GHC.Utils.Outputable++import GHC.Prelude++--------------------------------------------------------------------------------+-- | A Sequel tells what to do with the result of this expression+data Sequel+  = Return              -- ^ Return result(s) to continuation found on the stack.++  | AssignTo+        [LocalReg]      -- ^ Put result(s) in these regs and fall through+                        -- NB: no void arguments here+                        --+        Bool            -- ^ Should we adjust the heap pointer back to recover+                        -- space that's unused on this path? We need to do this+                        -- only if the expression may allocate (e.g. it's a+                        -- foreign call or allocating primOp)++instance Outputable Sequel where+    ppr Return = text "Return"+    ppr (AssignTo regs b) = text "AssignTo" <+> ppr regs <+> ppr b++type SelfLoopInfo = (Id, BlockId, [LocalReg])+--------------------------------------------------------------------------------
+ GHC/StgToCmm/TagCheck.hs view
@@ -0,0 +1,180 @@+{-# LANGUAGE CPP #-}++-----------------------------------------------------------------------------+--+-- Code generator utilities; mostly monadic+--+-- (c) The University of Glasgow 2004-2006+--+-----------------------------------------------------------------------------++module GHC.StgToCmm.TagCheck+  ( emitTagAssertion, emitArgTagCheck, checkArg, whenCheckTags,+    checkArgStatic, checkFunctionArgTags,checkConArgsStatic,checkConArgsDyn) where++#include "ClosureTypes.h"++import GHC.Prelude++import GHC.StgToCmm.Env+import GHC.StgToCmm.Monad+import GHC.StgToCmm.Utils+import GHC.Cmm+import GHC.Cmm.BlockId+import GHC.Cmm.Graph as CmmGraph++import GHC.Core.Type+import GHC.Types.Id+import GHC.Utils.Misc+import GHC.Utils.Outputable++import GHC.Core.DataCon+import Control.Monad+import GHC.StgToCmm.Types+import GHC.Utils.Panic (pprPanic)+import GHC.Utils.Panic.Plain (panic)+import GHC.Stg.Syntax+import GHC.StgToCmm.Closure+import GHC.Cmm.Switch (mkSwitchTargets)+import GHC.Cmm.Info (cmmGetClosureType)+import GHC.Types.RepType (dataConRuntimeRepStrictness)+import GHC.Types.Basic+import GHC.Data.FastString (mkFastString)++import qualified Data.Map as M++-- | Check all arguments marked as already tagged for a function+-- are tagged by inserting runtime checks.+checkFunctionArgTags :: SDoc -> Id -> [Id] -> FCode ()+checkFunctionArgTags msg f args = whenCheckTags $ do+  onJust (return ()) (idCbvMarks_maybe f) $ \marks -> do+    -- Only check args marked as strict, and only lifted ones.+    let cbv_args = filter (isLiftedRuntimeRep . idType) $ filterByList (map isMarkedCbv marks) args+    -- Get their (cmm) address+    arg_infos <- mapM getCgIdInfo cbv_args+    let arg_cmms = map idInfoToAmode arg_infos+    mapM_ (emitTagAssertion (showPprUnsafe msg))  (arg_cmms)++-- | Check all required-tagged arguments of a constructor are tagged *at compile time*.+checkConArgsStatic :: SDoc -> DataCon -> [StgArg] -> FCode ()+checkConArgsStatic msg con args = whenCheckTags $ do+  let marks = dataConRuntimeRepStrictness con+  zipWithM_ (checkArgStatic msg) marks args++-- Check all required arguments of a constructor are tagged.+-- Possible by emitting checks at runtime.+checkConArgsDyn :: SDoc -> DataCon -> [StgArg] -> FCode ()+checkConArgsDyn msg con args = whenCheckTags $ do+  let marks = dataConRuntimeRepStrictness con+  zipWithM_ (checkArg msg) (map cbvFromStrictMark marks) args++whenCheckTags :: FCode () -> FCode ()+whenCheckTags act = do+  check_tags <- stgToCmmDoTagCheck <$> getStgToCmmConfig+  when check_tags act++-- | Call barf if we failed to predict a tag correctly.+-- This is immensly useful when debugging issues in tag inference+-- as it will result in a program abort when we encounter an invalid+-- call/heap object, rather than leaving it be and segfaulting arbitrary+-- or producing invalid results.+-- We check if either:+-- * A tag is present+-- * Or the object is a PAP (for which zero is the proper tag)+emitTagAssertion :: String -> CmmExpr -> FCode ()+emitTagAssertion onWhat fun = do+  { platform <- getPlatform+  ; lret <- newBlockId+  ; lno_tag <- newBlockId+  ; lbarf <- newBlockId+  -- Check for presence of any tag.+  ; emit $ mkCbranch (cmmIsTagged platform fun)+                     lret lno_tag (Just True)+  -- If there is no tag check if we are dealing with a PAP+  ; emitLabel lno_tag+  ; emitComment (mkFastString "closereTypeCheck")+  ; needsArgTag fun lbarf lret++  ; emitLabel lbarf+  ; emitBarf ("Tag inference failed on:" ++ onWhat)+  ; emitLabel lret+  }++-- | Jump to the first block if the argument closure is subject+--   to tagging requirements. Otherwise jump to the 2nd one.+needsArgTag :: CmmExpr -> BlockId -> BlockId -> FCode ()+needsArgTag closure fail lpass = do+  profile <- getProfile+  align_check <- stgToCmmAlignCheck <$> getStgToCmmConfig+  let clo_ty_e = cmmGetClosureType profile align_check closure+  -- The ENTER macro doesn't evaluate FUN/PAP/BCO objects. So we+  -- have to accept them not being tagged. See #21193+  -- See Note [TagInfo of functions]+  let targets = mkSwitchTargets+        False+        (INVALID_OBJECT, N_CLOSURE_TYPES)+        (Just fail)+        (M.fromList [(PAP,lpass)+                    ,(BCO,lpass)+                    ,(FUN,lpass)+                    ,(FUN_1_0,lpass)+                    ,(FUN_0_1,lpass)+                    ,(FUN_2_0,lpass)+                    ,(FUN_1_1,lpass)+                    ,(FUN_0_2,lpass)+                    ,(FUN_STATIC,lpass)+                    ])++  emit $ mkSwitch clo_ty_e targets++  emit $ mkBranch lpass+++emitArgTagCheck :: SDoc -> [CbvMark] -> [Id] -> FCode ()+emitArgTagCheck info marks args = whenCheckTags $ do+  mod <- getModuleName+  let cbv_args = filter (isLiftedRuntimeRep . idType) $ filterByList (map isMarkedCbv marks) args+  arg_infos <- mapM getCgIdInfo cbv_args+  let arg_cmms = map idInfoToAmode arg_infos+      mk_msg arg = showPprUnsafe (text "Untagged arg:" <> (ppr mod) <> char ':' <> info <+> ppr arg)+  zipWithM_ emitTagAssertion (map mk_msg args) (arg_cmms)++taggedCgInfo :: CgIdInfo -> Bool+taggedCgInfo cg_info+  = case lf of+      LFCon {} -> True+      LFReEntrant {} -> True+      LFUnlifted {} -> True+      LFThunk {} -> False+      LFUnknown {} -> False+      LFLetNoEscape -> panic "Let no escape binding passed to top level con"+  where+    lf = cg_lf cg_info++-- Check that one argument is properly tagged.+checkArg :: SDoc -> CbvMark -> StgArg -> FCode ()+checkArg _ NotMarkedCbv _ = return ()+checkArg msg MarkedCbv arg = whenCheckTags $+  case arg of+    StgLitArg _ -> return ()+    StgVarArg v -> do+      info <- getCgIdInfo v+      if taggedCgInfo info+          then return ()+          else case (cg_loc info) of+            CmmLoc loc -> emitTagAssertion (showPprUnsafe $ msg <+> text "arg:" <> ppr arg) loc+            LneLoc {} -> panic "LNE-arg"++-- Check that argument is properly tagged.+checkArgStatic :: SDoc -> StrictnessMark  -> StgArg -> FCode ()+checkArgStatic _   NotMarkedStrict _ = return ()+checkArgStatic msg MarkedStrict arg = whenCheckTags $+  case arg of+    StgLitArg _ -> return ()+    StgVarArg v -> do+      info <- getCgIdInfo v+      if taggedCgInfo info+          then return ()+          else pprPanic "Arg not tagged as expectd" (ppr msg <+> ppr arg)++
GHC/StgToCmm/Ticky.hs view
@@ -29,12 +29,12 @@   * GHC.Cmm.Parser expands some macros using generators defined in     this module -  * includes/stg/Ticky.h declares all of the global counters+  * rts/include/stg/Ticky.h declares all of the global counters -  * includes/rts/Ticky.h declares the C data type for an+  * rts/include/rts/Ticky.h declares the C data type for an     STG-declaration's counters -  * some macros defined in includes/Cmm.h (and used within the RTS's+  * some macros defined in rts/include/Cmm.h (and used within the RTS's     CMM code) update the global ticky counters    * at the end of execution rts/Ticky.c generates the final report@@ -64,6 +64,15 @@    * someone else might know how to repair it! ++Note [Ticky counters are static]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Currently GHC only supports static ticky events. That is -ticky emits+code containing labels containing counters which then get bumped at runtime.++There are currently only *static* ticky counters. Either we bump one of the+static counters included in the RTS. Or we emit StgEntCounter structures in+the object code and bump these. -}  module GHC.StgToCmm.Ticky (@@ -72,6 +81,7 @@   withNewTickyCounterThunk,   withNewTickyCounterStdThunk,   withNewTickyCounterCon,+  emitTickyCounterTag,    tickyDynAlloc,   tickyAllocHeap,@@ -97,7 +107,10 @@   tickyUnboxedTupleReturn,   tickyReturnOldCon, tickyReturnNewCon, -  tickySlowCall+  tickyKnownCallTooFewArgs, tickyKnownCallExact, tickyKnownCallExtraArgs,+  tickySlowCall, tickySlowCallPat,++  tickyTagged, tickyUntagged, tickyTagSkip   ) where  import GHC.Prelude@@ -107,10 +120,11 @@  import GHC.StgToCmm.ArgRep    ( slowCallPattern , toArgRep , argRepString ) import GHC.StgToCmm.Closure-import GHC.StgToCmm.Utils-import GHC.StgToCmm.Monad+import GHC.StgToCmm.Config import {-# SOURCE #-} GHC.StgToCmm.Foreign   ( emitPrimCall ) import GHC.StgToCmm.Lit       ( newStringCLit )+import GHC.StgToCmm.Monad+import GHC.StgToCmm.Utils  import GHC.Stg.Syntax import GHC.Cmm.Expr@@ -119,6 +133,7 @@ import GHC.Cmm.CLabel import GHC.Runtime.Heap.Layout + import GHC.Types.Name import GHC.Types.Id import GHC.Types.Basic@@ -126,9 +141,7 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Misc--import GHC.Driver.Session-import GHC.Driver.Ppr+import GHC.Utils.Monad (whenM)  -- Turgid imports for showTypeCategory import GHC.Builtin.Names@@ -139,7 +152,12 @@  import Data.Maybe import qualified Data.Char-import Control.Monad ( when )+import Control.Monad ( when, unless )+import GHC.Types.Id.Info+import GHC.Utils.Trace+import GHC.StgToCmm.Env (getCgInfo_maybe)+import Data.Coerce (coerce)+import GHC.Utils.Json  ----------------------------------------------------------------------------- --@@ -147,122 +165,290 @@ -- ----------------------------------------------------------------------------- +-- | Number of arguments for a ticky counter.+--+-- Ticky currently treats args to constructor allocations differently than those for functions/LNE bindings.+tickyArgArity :: TickyClosureType -> Int+tickyArgArity (TickyFun _ _fvs args) = length args+tickyArgArity (TickyLNE args) = length args+tickyArgArity (TickyCon{}) = 0+tickyArgArity (TickyThunk{}) = 0++tickyArgDesc :: TickyClosureType -> String+tickyArgDesc arg_info =+  case arg_info of+    TickyFun _ _fvs args -> map (showTypeCategory . idType . fromNonVoid) args+    TickyLNE args -> map (showTypeCategory . idType . fromNonVoid) args+    TickyThunk{} -> ""+    TickyCon{} -> ""++tickyFvDesc :: TickyClosureType -> String+tickyFvDesc arg_info =+  case arg_info of+    TickyFun _ fvs _args -> map (showTypeCategory . idType . fromNonVoid) fvs+    TickyLNE{} -> ""+    TickyThunk _ _ fvs -> map (showTypeCategory . stgArgType) fvs+    TickyCon{} -> ""++instance ToJson TickyClosureType where+    json info = case info of+      (TickyFun {})   -> mkInfo (tickyFvDesc info) (tickyArgDesc info) "fun"+      (TickyLNE {})   -> mkInfo []                 (tickyArgDesc info) "lne"+      (TickyThunk uf _ _) -> mkInfo (tickyFvDesc info) []              ("thk" ++ if uf then "_u" else "")+      (TickyCon{})    -> mkInfo []                 []                  "con"+      where+        mkInfo :: String -> String -> String -> JsonDoc+        mkInfo fvs args ty =+          JSObject+              [("type", json "entCntr")+              ,("subTy", json ty)+              ,("fvs_c", json (length fvs))+              ,("fvs" , json fvs)+              ,("args", json args)+              ]++tickyEntryDescJson :: (SDocContext -> TickyClosureType -> String)+tickyEntryDescJson ctxt = renderWithContext ctxt . renderJSON . json+ data TickyClosureType     = TickyFun         Bool -- True <-> single entry+        [NonVoid Id] -- ^ FVs+        [NonVoid Id] -- ^ Args     | TickyCon         DataCon -- the allocated constructor+        ConstructorNumber     | TickyThunk         Bool -- True <-> updateable         Bool -- True <-> standard thunk (AP or selector), has no entry counter+        [StgArg] -- ^ FVS, StgArg because for thunks these can also be literals.     | TickyLNE+        [NonVoid Id] -- ^ Args -withNewTickyCounterFun :: Bool -> Name  -> [NonVoid Id] -> FCode a -> FCode a-withNewTickyCounterFun single_entry = withNewTickyCounter (TickyFun single_entry)+withNewTickyCounterFun :: Bool -> Id -> [NonVoid Id] -> [NonVoid Id] -> FCode a -> FCode a+withNewTickyCounterFun single_entry f fvs args = withNewTickyCounter (TickyFun single_entry fvs args) f -withNewTickyCounterLNE :: Name  -> [NonVoid Id] -> FCode a -> FCode a+withNewTickyCounterLNE :: Id  ->  [NonVoid Id] -> FCode a -> FCode a withNewTickyCounterLNE nm args code = do-  b <- tickyLNEIsOn-  if not b then code else withNewTickyCounter TickyLNE nm args code+  b <- isEnabled stgToCmmTickyLNE+  if not b then code else withNewTickyCounter (TickyLNE args) nm code  thunkHasCounter :: Bool -> FCode Bool-thunkHasCounter isStatic = do-  b <- tickyDynThunkIsOn-  pure (not isStatic && b)+thunkHasCounter isStatic = (not isStatic &&) <$> isEnabled stgToCmmTickyDynThunk  withNewTickyCounterThunk   :: Bool -- ^ static   -> Bool -- ^ updateable-  -> Name+  -> Id+  -> [NonVoid Id] -- ^ Free vars   -> FCode a   -> FCode a-withNewTickyCounterThunk isStatic isUpdatable name code = do+withNewTickyCounterThunk isStatic isUpdatable name fvs code = do     has_ctr <- thunkHasCounter isStatic     if not has_ctr       then code-      else withNewTickyCounter (TickyThunk isUpdatable False) name [] code+      else withNewTickyCounter (TickyThunk isUpdatable False (map StgVarArg $ coerce fvs)) name code  withNewTickyCounterStdThunk   :: Bool -- ^ updateable-  -> Name+  -> Id+  -> [StgArg] -- ^ Free vars + function   -> FCode a   -> FCode a-withNewTickyCounterStdThunk isUpdatable name code = do+withNewTickyCounterStdThunk isUpdatable name fvs code = do     has_ctr <- thunkHasCounter False     if not has_ctr       then code-      else withNewTickyCounter (TickyThunk isUpdatable True) name [] code+      else withNewTickyCounter (TickyThunk isUpdatable True fvs) name code  withNewTickyCounterCon-  :: Name+  :: Id   -> DataCon+  -> ConstructorNumber   -> FCode a   -> FCode a-withNewTickyCounterCon name datacon code = do+withNewTickyCounterCon name datacon info code = do     has_ctr <- thunkHasCounter False     if not has_ctr       then code-      else withNewTickyCounter (TickyCon datacon) name [] code+      else withNewTickyCounter (TickyCon datacon info) name code  -- args does not include the void arguments-withNewTickyCounter :: TickyClosureType -> Name -> [NonVoid Id] -> FCode a -> FCode a-withNewTickyCounter cloType name args m = do-  lbl <- emitTickyCounter cloType name args+withNewTickyCounter :: TickyClosureType -> Id -> FCode a -> FCode a+withNewTickyCounter cloType name m = do+  lbl <- emitTickyCounter cloType name   setTickyCtrLabel lbl m -emitTickyCounter :: TickyClosureType -> Name -> [NonVoid Id] -> FCode CLabel-emitTickyCounter cloType name args-  = let ctr_lbl = mkRednCountsLabel name in+emitTickyData :: Platform+              -> CLabel -- ^ lbl for the counter+              -> Arity -- ^ arity+              -> CmmLit -- ^ fun desc+              -> CmmLit -- ^ arg desc+              -> CmmLit -- ^ json desc+              -> CmmLit -- ^ info table lbl+              -> FCode ()+emitTickyData platform ctr_lbl arity fun_desc arg_desc json_desc info_tbl =+  emitDataLits ctr_lbl+    -- Must match layout of rts/include/rts/Ticky.h's StgEntCounter+    --+    -- krc: note that all the fields are I32 now; some were I16+    -- before, but the code generator wasn't handling that+    -- properly and it led to chaos, panic and disorder.+        [ zeroCLit platform,               -- registered?+          mkIntCLit platform arity,   -- Arity+          zeroCLit platform,               -- Heap allocated for this thing+          fun_desc,+          arg_desc,+          json_desc,+          info_tbl,+          zeroCLit platform,          -- Entries into this thing+          zeroCLit platform,          -- Heap allocated by this thing+          zeroCLit platform           -- Link to next StgEntCounter+        ]+++emitTickyCounter :: TickyClosureType -> Id -> FCode CLabel+emitTickyCounter cloType tickee+  = let name = idName tickee in+    let ctr_lbl = mkRednCountsLabel name in     (>> return ctr_lbl) $     ifTicky $ do-        { dflags <- getDynFlags-        ; platform <- getPlatform+        { cfg    <- getStgToCmmConfig         ; parent <- getTickyCtrLabel         ; mod_name <- getModuleName            -- When printing the name of a thing in a ticky file, we           -- want to give the module name even for *local* things.  We           -- print just "x (M)" rather that "M.x" to distinguish them-          -- from the global kind.-        ; let ppr_for_ticky_name :: SDoc+          -- from the global kind by calling to @pprTickyName@+        ; let platform = stgToCmmPlatform cfg+              ppr_for_ticky_name :: SDoc               ppr_for_ticky_name =-                let n = ppr name-                    ext = case cloType of-                              TickyFun single_entry -> parens $ hcat $ punctuate comma $+                let ext = case cloType of+                              TickyFun single_entry _ _-> parens $ hcat $ punctuate comma $                                   [text "fun"] ++ [text "se"|single_entry]-                              TickyCon datacon -> parens (text "con:" <+> ppr (dataConName datacon))-                              TickyThunk upd std -> parens $ hcat $ punctuate comma $+                              TickyCon datacon _cn -> parens (text "con:" <+> ppr (dataConName datacon))+                              TickyThunk upd std _-> parens $ hcat $ punctuate comma $                                   [text "thk"] ++ [text "se"|not upd] ++ [text "std"|std]-                              TickyLNE | isInternalName name -> parens (text "LNE")-                                       | otherwise -> panic "emitTickyCounter: how is this an external LNE?"+                              TickyLNE _ | isInternalName name -> parens (text "LNE")+                                         | otherwise -> panic "emitTickyCounter: how is this an external LNE?"                     p = case hasHaskellName parent of                             -- NB the default "top" ticky ctr does not                             -- have a Haskell name                           Just pname -> text "in" <+> ppr (nameUnique pname)                           _ -> empty+                in pprTickyName mod_name name <+> ext <+> p+        ; this_mod <- getModuleName+        ; let t = case cloType of+                    TickyCon {} -> "C"+                    TickyFun {} -> "F"+                    TickyThunk {} -> "T"+                    TickyLNE {} -> "L"+        ; info_lbl <- case cloType of+                            TickyCon dc mn -> case mn of+                                               NoNumber -> return $! CmmLabel $ mkConInfoTableLabel (dataConName dc) DefinitionSite+                                               (Numbered n) -> return $! CmmLabel $ mkConInfoTableLabel (dataConName dc) (UsageSite this_mod n)+                            TickyFun {} ->+                              return $! CmmLabel $ mkInfoTableLabel name NoCafRefs++                            TickyThunk _ std_thunk _fvs+                              | not std_thunk+                              -> return $! CmmLabel $ mkInfoTableLabel name NoCafRefs+                              -- IPE Maps have no entry for std thunks.+                              | otherwise+                              -> do+                                    lf_info <- getCgInfo_maybe name+                                    profile <- getProfile+                                    case lf_info of+                                      Just (CgIdInfo { cg_lf = cg_lf })+                                          | isLFThunk cg_lf+                                          -> return $! CmmLabel $ mkClosureInfoTableLabel (profilePlatform profile) tickee cg_lf+                                      _   -> pprTraceDebug "tickyThunkUnknown" (text t <> colon <> ppr name <+> ppr (mkInfoTableLabel name NoCafRefs))+                                            return $! zeroCLit platform++                            TickyLNE {} -> return $! zeroCLit platform++        ; let ctx = defaultSDocContext {sdocPprDebug = True}+        ; fun_descr_lit <- newStringCLit $ renderWithContext ctx ppr_for_ticky_name+        ; arg_descr_lit <- newStringCLit $ tickyArgDesc cloType+        ; json_descr_lit <- newStringCLit $ tickyEntryDescJson ctx cloType+        ; emitTickyData platform ctr_lbl (tickyArgArity cloType) fun_descr_lit arg_descr_lit json_descr_lit info_lbl+        }++{- Note [TagSkip ticky counters]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+These counters keep track how often we execute code where we+would have performed a tag check if we hadn't run tag inference.++If we have some code of the form:+    case v[tagged] of ...+and we want to record how often we avoid a tag check on v+through tag inference we have to emit a new StgEntCounter for+each such case statement in order to record how often it's executed.++In theory we could emit one per *binding*. But then we+would have to either keep track of the bindings which+already have a StgEntCounter associated with them in the+code gen state or preallocate such a structure for each binding+in the code unconditionally (since ticky-code can call non-ticky code)++The first makes the compiler slower, even when ticky is not+used (a big no no). The later is fairly complex but increases code size+unconditionally. See also Note [Ticky counters are static].++So instead we emit a new StgEntCounter for each use site of a binding+where we infered a tag to be present. And increment the counter whenever+this use site is executed.++We use the fields as follows:++entry_count: Entries avoided.+str:       : Name of the id.++We use emitTickyCounterTag to emit the counter.++Unlike the closure counters each *use* site of v has it's own+counter. So there is no need to keep track of the closure/case we are+in.++We also have to pass a unique for the counter. An Id might be+scrutinized in more than one place, so the ID alone isn't enough+to distinguish between use sites.+-}++emitTickyCounterTag :: Unique -> NonVoid Id -> FCode CLabel+emitTickyCounterTag unique (NonVoid id) =+  let name = idName id+      ctr_lbl = mkTagHitLabel name unique in+    (>> return ctr_lbl) $+    ifTickyTag $ do+        { platform <- getPlatform+        ; parent <- getTickyCtrLabel+        ; mod_name <- getModuleName++          -- When printing the name of a thing in a ticky file, we+          -- want to give the module name even for *local* things.  We+          -- print just "x (M)" rather that "M.x" to distinguish them+          -- from the global kind.+        ; let ppr_for_ticky_name :: SDoc+              ppr_for_ticky_name =+                let n = ppr name+                    ext = empty -- parens (text "tagged")+                    p = case hasHaskellName parent of+                            -- NB the default "top" ticky ctr does not+                            -- have a Haskell name+                          Just pname -> text "at" <+> ppr (nameSrcLoc pname) <+>+                                          text "in" <+> pprNameUnqualified name+                          _ -> empty                 in if isInternalName name                    then n <+> parens (ppr mod_name) <+> ext <+> p                    else n <+> ext <+> p--        ; fun_descr_lit <- newStringCLit $ showSDocDebug dflags ppr_for_ticky_name-        ; arg_descr_lit <- newStringCLit $ map (showTypeCategory . idType . fromNonVoid) args-        ; emitDataLits ctr_lbl-        -- Must match layout of includes/rts/Ticky.h's StgEntCounter-        ---        -- krc: note that all the fields are I32 now; some were I16-        -- before, but the code generator wasn't handling that-        -- properly and it led to chaos, panic and disorder.-            [ mkIntCLit platform 0,               -- registered?-              mkIntCLit platform (length args),   -- Arity-              mkIntCLit platform 0,               -- Heap allocated for this thing-              fun_descr_lit,-              arg_descr_lit,-              zeroCLit platform,          -- Entries into this thing-              zeroCLit platform,          -- Heap allocated by this thing-              zeroCLit platform           -- Link to next StgEntCounter-            ]+        ; sdoc_context <- stgToCmmContext <$> getStgToCmmConfig+        ; fun_descr_lit <- newStringCLit $ renderWithContext sdoc_context ppr_for_ticky_name+        ; arg_descr_lit <- newStringCLit $ "infer"+        ; json_descr_lit <- newStringCLit $ "infer"+        ; emitTickyData platform ctr_lbl 0 fun_descr_lit arg_descr_lit json_descr_lit (zeroCLit platform)         }- -- ----------------------------------------------------------------------------- -- Ticky stack frames @@ -336,8 +522,8 @@ -- since the counter was registered already upon being alloc'd registerTickyCtrAtEntryDyn :: CLabel -> FCode () registerTickyCtrAtEntryDyn ctr_lbl = do-  already_registered <- tickyAllocdIsOn-  when (not already_registered) $ registerTickyCtr ctr_lbl+  already_registered <- isEnabled stgToCmmTickyAllocd+  unless already_registered $ registerTickyCtr ctr_lbl  -- | Register a ticky counter. --@@ -563,35 +749,55 @@ tickyStackCheck = ifTicky $ bumpTickyCounter (fsLit "STK_CHK_ctr")  -- -----------------------------------------------------------------------------+-- Ticky for tag inference characterisation++-- | Predicted a pointer would be tagged correctly (GHC will crash if not so no miss case)+tickyTagged :: FCode ()+tickyTagged         = ifTickyTag $ bumpTickyCounter (fsLit "TAG_TAGGED_pred")++-- | Pass a boolean expr indicating if tag was present.+tickyUntagged :: CmmExpr -> FCode ()+tickyUntagged e     = do+    ifTickyTag $ bumpTickyCounter (fsLit "TAG_UNTAGGED_pred")+    ifTickyTag $ bumpTickyCounterByE (fsLit "TAG_UNTAGGED_miss") e++-- | Called when for `case v of ...` we can avoid entering v based on+-- tag inference information.+tickyTagSkip :: Unique -> Id -> FCode ()+tickyTagSkip unique id = ifTickyTag $ do+  let ctr_lbl = mkTagHitLabel (idName id) unique+  registerTickyCtr ctr_lbl+  bumpTickyTagSkip ctr_lbl++-- ----------------------------------------------------------------------------- -- Ticky utils -ifTicky :: FCode () -> FCode ()-ifTicky code =-  getDynFlags >>= \dflags -> when (gopt Opt_Ticky dflags) code+isEnabled :: (StgToCmmConfig -> Bool) -> FCode Bool+isEnabled = flip fmap getStgToCmmConfig -tickyAllocdIsOn :: FCode Bool-tickyAllocdIsOn = gopt Opt_Ticky_Allocd `fmap` getDynFlags+runIfFlag :: (StgToCmmConfig -> Bool) -> FCode () -> FCode ()+runIfFlag f = whenM (f <$> getStgToCmmConfig) -tickyLNEIsOn :: FCode Bool-tickyLNEIsOn = gopt Opt_Ticky_LNE `fmap` getDynFlags+ifTicky :: FCode () -> FCode ()+ifTicky = runIfFlag stgToCmmDoTicky -tickyDynThunkIsOn :: FCode Bool-tickyDynThunkIsOn = gopt Opt_Ticky_Dyn_Thunk `fmap` getDynFlags+ifTickyTag :: FCode () -> FCode ()+ifTickyTag = runIfFlag stgToCmmTickyTag  ifTickyAllocd :: FCode () -> FCode ()-ifTickyAllocd code = tickyAllocdIsOn >>= \b -> when b code+ifTickyAllocd = runIfFlag stgToCmmTickyAllocd  ifTickyLNE :: FCode () -> FCode ()-ifTickyLNE code = tickyLNEIsOn >>= \b -> when b code+ifTickyLNE = runIfFlag stgToCmmTickyLNE  ifTickyDynThunk :: FCode () -> FCode ()-ifTickyDynThunk code = tickyDynThunkIsOn >>= \b -> when b code+ifTickyDynThunk = runIfFlag stgToCmmTickyDynThunk  bumpTickyCounter :: FastString -> FCode ()-bumpTickyCounter lbl = bumpTickyLbl (mkRtsCmmDataLabel lbl)+bumpTickyCounter = bumpTickyLbl . mkRtsCmmDataLabel  bumpTickyCounterBy :: FastString -> Int -> FCode ()-bumpTickyCounterBy lbl = bumpTickyLblBy (mkRtsCmmDataLabel lbl)+bumpTickyCounterBy = bumpTickyLblBy . mkRtsCmmDataLabel  bumpTickyCounterByE :: FastString -> CmmExpr -> FCode () bumpTickyCounterByE lbl = bumpTickyLblByE (mkRtsCmmDataLabel lbl)@@ -604,8 +810,13 @@ bumpTickyAllocd :: CLabel -> Int -> FCode () bumpTickyAllocd lbl bytes = do   platform <- getPlatform-  bumpTickyLitBy (cmmLabelOffB lbl (pc_OFFSET_StgEntCounter_allocd (platformConstants platform))) bytes+  bumpTickyLitBy (cmmLabelOffB lbl (pc_OFFSET_StgEntCounter_entry_count (platformConstants platform))) bytes +bumpTickyTagSkip :: CLabel -> FCode ()+bumpTickyTagSkip lbl = do+  platform <- getPlatform+  bumpTickyLitBy (cmmLabelOffB lbl (pc_OFFSET_StgEntCounter_entry_count (platformConstants platform))) 1+ bumpTickyLbl :: CLabel -> FCode () bumpTickyLbl lhs = bumpTickyLitBy (cmmLabelOffB lhs 0) 1 @@ -674,20 +885,21 @@   | otherwise = case tcSplitTyConApp_maybe ty of   Nothing -> '.'   Just (tycon, _) ->-    (if isUnliftedTyCon tycon then Data.Char.toLower else id) $     let anyOf us = getUnique tycon `elem` us in     case () of       _ | anyOf [funTyConKey] -> '>'-        | anyOf [charPrimTyConKey, charTyConKey] -> 'C'-        | anyOf [doublePrimTyConKey, doubleTyConKey] -> 'D'-        | anyOf [floatPrimTyConKey, floatTyConKey] -> 'F'-        | anyOf [intPrimTyConKey, int32PrimTyConKey, int64PrimTyConKey,-                 intTyConKey, int8TyConKey, int16TyConKey, int32TyConKey, int64TyConKey-                ] -> 'I'-        | anyOf [wordPrimTyConKey, word32PrimTyConKey, word64PrimTyConKey, wordTyConKey,-                 word8TyConKey, word16TyConKey, word32TyConKey, word64TyConKey-                ] -> 'W'+        | anyOf [charTyConKey] -> 'C'+        | anyOf [charPrimTyConKey] -> 'c'+        | anyOf [doubleTyConKey] -> 'D'+        | anyOf [doublePrimTyConKey] -> 'd'+        | anyOf [floatTyConKey] -> 'F'+        | anyOf [floatPrimTyConKey] -> 'f'+        | anyOf [intTyConKey, int8TyConKey, int16TyConKey, int32TyConKey, int64TyConKey] -> 'I'+        | anyOf [intPrimTyConKey, int8PrimTyConKey, int16PrimTyConKey, int32PrimTyConKey, int64PrimTyConKey] -> 'i'+        | anyOf [wordTyConKey, word8TyConKey, word16TyConKey, word32TyConKey, word64TyConKey] -> 'W'+        | anyOf [wordPrimTyConKey, word8PrimTyConKey, word16PrimTyConKey, word32PrimTyConKey, word64PrimTyConKey] -> 'w'         | anyOf [listTyConKey] -> 'L'+        | isUnboxedTupleTyCon tycon -> 't'         | isTupleTyCon tycon       -> 'T'         | isPrimTyCon tycon        -> 'P'         | isEnumerationTyCon tycon -> 'E'
GHC/StgToCmm/Types.hs view
@@ -1,24 +1,27 @@-{-# LANGUAGE CPP #-} + module GHC.StgToCmm.Types   ( CgInfos (..)   , LambdaFormInfo (..)   , ModuleLFInfos-  , Liveness-  , ArgDescr (..)   , StandardFormInfo (..)-  , WordOff+  , DoSCCProfiling+  , DoExtDynRefs   ) where -#include "HsVersions.h"- import GHC.Prelude +import GHC.Core.DataCon++import GHC.Stg.InferTags.TagSig++import GHC.Runtime.Heap.Layout+ import GHC.Types.Basic import GHC.Types.ForeignStubs-import GHC.Core.DataCon import GHC.Types.Name.Env import GHC.Types.Name.Set+ import GHC.Utils.Outputable  @@ -90,6 +93,7 @@       -- ^ LambdaFormInfos of exported closures in the current module.   , cgIPEStub :: !CStub       -- ^ The C stub which is used for IPE information+  , cgTagSigs :: !(NameEnv TagSig)   }  --------------------------------------------------------------------------------@@ -166,39 +170,6 @@ pprUpdateable False = text "oneshot"  ------------------------------------------------------------------------------------ | We represent liveness bitmaps as a Bitmap (whose internal representation--- really is a bitmap).  These are pinned onto case return vectors to indicate--- the state of the stack for the garbage collector.------ In the compiled program, liveness bitmaps that fit inside a single word--- (StgWord) are stored as a single word, while larger bitmaps are stored as a--- pointer to an array of words.--type Liveness = [Bool]   -- One Bool per word; True  <=> non-ptr or dead-                         --                    False <=> ptr------------------------------------------------------------------------------------- | An ArgDescr describes the argument pattern of a function--data ArgDescr-  = ArgSpec             -- Fits one of the standard patterns-        !Int            -- RTS type identifier ARG_P, ARG_N, ...--  | ArgGen              -- General case-        Liveness        -- Details about the arguments--  | ArgUnknown          -- For imported binds.-                        -- Invariant: Never Unknown for binds of the module-                        -- we are compiling.-  deriving (Eq)--instance Outputable ArgDescr where-  ppr (ArgSpec n) = text "ArgSpec" <+> ppr n-  ppr (ArgGen ls) = text "ArgGen" <+> ppr ls-  ppr ArgUnknown = text "ArgUnknown"---------------------------------------------------------------------------------- -- | StandardFormInfo tells whether this thunk has one of a small number of -- standard forms @@ -224,10 +195,13 @@         !RepArity       -- Arity, n   deriving (Eq) --- | Word offset, or word count-type WordOff = Int- instance Outputable StandardFormInfo where   ppr NonStandardThunk = text "RegThunk"   ppr (SelectorThunk w) = text "SelThunk:" <> ppr w   ppr (ApThunk n) = text "ApThunk:" <> ppr n++--------------------------------------------------------------------------------+--                Gaining sight in a sea of blindness+--------------------------------------------------------------------------------+type DoSCCProfiling = Bool+type DoExtDynRefs   = Bool
GHC/StgToCmm/Utils.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE CPP #-} + ----------------------------------------------------------------------------- -- -- Code generator utilities; mostly monadic@@ -12,7 +12,8 @@         emitDataLits, emitRODataLits,         emitDataCon,         emitRtsCall, emitRtsCallWithResult, emitRtsCallGen,-        assignTemp,+        emitBarf,+        assignTemp, newTemp,          newUnboxedTupleRegs, @@ -45,14 +46,12 @@         convertInfoProvMap, cmmInfoTableToInfoProvEnt   ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Platform import GHC.StgToCmm.Monad import GHC.StgToCmm.Closure-import GHC.StgToCmm.Lit (mkSimpleLit)+import GHC.StgToCmm.Lit (mkSimpleLit, newStringCLit) import GHC.Cmm import GHC.Cmm.BlockId import GHC.Cmm.Graph as CmmGraph@@ -72,10 +71,10 @@ import GHC.Data.Graph.Directed import GHC.Utils.Misc import GHC.Types.Unique-import GHC.Driver.Session import GHC.Data.FastString import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Types.RepType import GHC.Types.CostCentre import GHC.Types.IPE@@ -85,12 +84,12 @@ import Data.Ord import GHC.Types.Unique.Map import Data.Maybe-import GHC.Driver.Ppr import qualified Data.List.NonEmpty as NE import GHC.Core.DataCon import GHC.Types.Unique.FM import GHC.Data.Maybe import Control.Monad+import qualified Data.Map.Strict as Map  -------------------------------------------------------------------------- --@@ -99,7 +98,7 @@ --------------------------------------------------------------------------  addToMemLbl :: CmmType -> CLabel -> Int -> CmmAGraph-addToMemLbl rep lbl n = addToMem rep (CmmLit (CmmLabel lbl)) n+addToMemLbl rep lbl = addToMem rep (CmmLit (CmmLabel lbl))  addToMemLblE :: CmmType -> CLabel -> CmmExpr -> CmmAGraph addToMemLblE rep lbl = addToMemE rep (CmmLit (CmmLabel lbl))@@ -159,13 +158,17 @@ -- ------------------------------------------------------------------------- +emitBarf :: String -> FCode ()+emitBarf msg = do+  strLbl <- newStringCLit msg+  emitRtsCall rtsUnitId (fsLit "barf") [(CmmLit strLbl,AddrHint)] False+ emitRtsCall :: UnitId -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()-emitRtsCall pkg fun args safe = emitRtsCallGen [] (mkCmmCodeLabel pkg fun) args safe+emitRtsCall pkg fun = emitRtsCallGen [] (mkCmmCodeLabel pkg fun)  emitRtsCallWithResult :: LocalReg -> ForeignHint -> UnitId -> FastString         -> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()-emitRtsCallWithResult res hint pkg fun args safe-   = emitRtsCallGen [(res,hint)] (mkCmmCodeLabel pkg fun) args safe+emitRtsCallWithResult res hint pkg = emitRtsCallGen [(res,hint)] . mkCmmCodeLabel pkg  -- Make a call to an RTS C procedure emitRtsCallGen@@ -175,7 +178,7 @@    -> Bool -- True <=> CmmSafe call    -> FCode () emitRtsCallGen res lbl args safe-  = do { platform <- targetPlatform <$> getDynFlags+  = do { platform <- getPlatform        ; updfr_off <- getUpdFrameOff        ; let (caller_save, caller_load) = callerSaveVolatileRegs platform        ; emit caller_save@@ -202,7 +205,7 @@ -- Here we generate the sequence of saves/restores required around a -- foreign call instruction. --- TODO: reconcile with includes/Regs.h+-- TODO: reconcile with rts/include/Regs.h --  * Regs.h claims that BaseReg should be saved last and loaded first --    * This might not have been tickled before since BaseReg is callee save --  * Regs.h saves SparkHd, ParkT1, SparkBase and SparkLim@@ -210,7 +213,7 @@ -- This code isn't actually used right now, because callerSaves -- only ever returns true in the current universe for registers NOT in -- system_regs (just do a grep for CALLER_SAVES in--- includes/stg/MachRegs.h).  It's all one giant no-op, and for+-- rts/include/stg/MachRegs.h).  It's all one giant no-op, and for -- good reason: having to save system registers on every foreign call -- would be very expensive, so we avoid assigning them to those -- registers when we add support for an architecture.@@ -291,19 +294,17 @@ -- the Sequel.  If the Sequel is a join point, using the -- regs it wants will save later assignments. newUnboxedTupleRegs res_ty-  = ASSERT( isUnboxedTupleType res_ty )+  = assert (isUnboxedTupleType res_ty) $     do  { platform <- getPlatform         ; sequel <- getSequel         ; regs <- choose_regs platform sequel-        ; ASSERT( regs `equalLength` reps )-          return (regs, map primRepForeignHint reps) }+        ; massert (regs `equalLength` reps)+        ; return (regs, map primRepForeignHint reps) }   where     reps = typePrimRep res_ty     choose_regs _ (AssignTo regs _) = return regs     choose_regs platform _          = mapM (newTemp . primRepCmmType platform) reps -- ------------------------------------------------------------------------- --      emitMultiAssign -------------------------------------------------------------------------@@ -327,7 +328,7 @@ emitMultiAssign [reg] [rhs] = emitAssign (CmmLocal reg) rhs emitMultiAssign regs rhss   = do   platform <- getPlatform-  ASSERT2( equalLength regs rhss, ppr regs $$ pdoc platform rhss )+  assertPpr (equalLength regs rhss) (ppr regs $$ pdoc platform rhss) $     unscramble platform ([1..] `zip` (regs `zip` rhss))  unscramble :: Platform -> [Vrtx] -> FCode ()@@ -415,7 +416,7 @@ -- SINGLETON TAG RANGE: no case analysis to do mk_discrete_switch _ _tag_expr [(tag, lbl)] _ (lo_tag, hi_tag)   | lo_tag == hi_tag-  = ASSERT( tag == lo_tag )+  = assert (tag == lo_tag) $     mkBranch lbl  -- SINGLETON BRANCH, NO DEFAULT: no case analysis to do@@ -459,12 +460,19 @@         rep = typeWidth cmm_ty      -- We find the necessary type information in the literals in the branches-    let signed = case head branches of-                    (LitNumber nt _, _) -> litNumIsSigned nt-                    _ -> False--    let range | signed    = (platformMinInt platform, platformMaxInt platform)-              | otherwise = (0, platformMaxWord platform)+    let (signed,range) = case head branches of+          (LitNumber nt _, _) -> (signed,range)+            where+              signed = litNumIsSigned nt+              range  = case litNumRange platform nt of+                        (Just mi, Just ma) -> (mi,ma)+                                              -- unbounded literals (Natural and+                                              -- Integer) must have been+                                              -- lowered at this point+                        partial_bounds     -> pprPanic "Unexpected unbounded literal range"+                                                       (ppr partial_bounds)+               -- assuming native word range+          _ -> (False, (0, platformMaxWord platform))      if isFloatType cmm_ty     then emit =<< mk_float_switch rep scrut' deflt_lbl noBound branches_lbls@@ -597,14 +605,14 @@  -- | Convert source information collected about identifiers in 'GHC.STG.Debug' -- to entries suitable for placing into the info table provenenance table.-convertInfoProvMap :: DynFlags -> [CmmInfoTable] -> Module -> InfoTableProvMap -> [InfoProvEnt]-convertInfoProvMap dflags defns this_mod (InfoTableProvMap (UniqMap dcenv) denv) =+convertInfoProvMap :: [CmmInfoTable] -> Module -> InfoTableProvMap -> [InfoProvEnt]+convertInfoProvMap defns this_mod (InfoTableProvMap (UniqMap dcenv) denv infoTableToSourceLocationMap) =   map (\cmit ->     let cl = cit_lbl cmit         cn  = rtsClosureType (cit_rep cmit)          tyString :: Outputable a => a -> String-        tyString t = showPpr dflags t+        tyString = renderWithContext defaultSDocContext . ppr          lookupClosureMap :: Maybe InfoProvEnt         lookupClosureMap = case hasHaskellName cl >>= lookupUniqMap denv of@@ -614,12 +622,20 @@         lookupDataConMap = do             UsageSite _ n <- hasIdLabelInfo cl >>= getConInfoTableLocation             -- This is a bit grimy, relies on the DataCon and Name having the same Unique, which they do-            (dc, ns) <- (hasHaskellName cl >>= lookupUFM_Directly dcenv . getUnique)+            (dc, ns) <- hasHaskellName cl >>= lookupUFM_Directly dcenv . getUnique             -- Lookup is linear but lists will be small (< 100)             return $ InfoProvEnt cl cn (tyString (dataConTyCon dc)) this_mod (join $ lookup n (NE.toList ns)) +        lookupInfoTableToSourceLocation = do+            sourceNote <- Map.lookup (cit_lbl cmit) infoTableToSourceLocationMap+            return $ InfoProvEnt cl cn "" this_mod sourceNote+         -- This catches things like prim closure types and anything else which doesn't have a         -- source location         simpleFallback = cmmInfoTableToInfoProvEnt this_mod cmit -    in fromMaybe simpleFallback (lookupDataConMap `firstJust` lookupClosureMap)) defns+  in+    if (isStackRep . cit_rep) cmit then+      fromMaybe simpleFallback lookupInfoTableToSourceLocation+    else+      fromMaybe simpleFallback (lookupDataConMap `firstJust` lookupClosureMap)) defns
GHC/SysTools.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP                 #-}+ {-# LANGUAGE ScopedTypeVariables #-}  {-@@ -20,7 +20,9 @@         module GHC.SysTools.Tasks,         module GHC.SysTools.Info, -        copy,+        -- * Fast file copy+        copyFile,+        copyHandle,         copyWithHeader,          -- * General utilities@@ -28,27 +30,26 @@         expandTopDir,  ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Settings.Utils -import GHC.Utils.Error import GHC.Utils.Panic-import GHC.Utils.Logger import GHC.Driver.Session -import Control.Monad.Trans.Except (runExceptT)-import System.FilePath-import System.IO-import System.IO.Unsafe (unsafeInterleaveIO) import GHC.Linker.ExtraObj import GHC.SysTools.Info import GHC.SysTools.Tasks import GHC.SysTools.BaseDir import GHC.Settings.IO +import Control.Monad.Trans.Except (runExceptT)+import System.FilePath+import System.IO+import System.IO.Unsafe (unsafeInterleaveIO)+import Foreign.Marshal.Alloc (allocaBytes)+import System.Directory (copyFile)+ {- Note [How GHC finds toolchain utilities] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -155,8 +156,8 @@     Left (SettingsError_MissingData msg) -> pgmError msg     Left (SettingsError_BadData msg) -> pgmError msg -{- Note [Windows stack usage]-+{- Note [Windows stack allocations]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ See: #8870 (and #8834 for related info) and #12186  On Windows, occasionally we need to grow the stack. In order to do@@ -186,26 +187,25 @@  -} -copy :: Logger -> DynFlags -> String -> FilePath -> FilePath -> IO ()-copy logger dflags purpose from to = copyWithHeader logger dflags purpose Nothing from to--copyWithHeader :: Logger -> DynFlags -> String -> Maybe String -> FilePath -> FilePath-               -> IO ()-copyWithHeader logger dflags purpose maybe_header from to = do-  showPass logger dflags purpose+-- | Copy remaining bytes from the first Handle to the second one+copyHandle :: Handle -> Handle -> IO ()+copyHandle hin hout = do+  let buf_size = 8192+  allocaBytes buf_size $ \ptr -> do+    let go = do+          c <- hGetBuf hin ptr buf_size+          hPutBuf hout ptr c+          if c == 0 then return () else go+    go -  hout <- openBinaryFile to   WriteMode-  hin  <- openBinaryFile from ReadMode-  ls <- hGetContents hin -- inefficient, but it'll do for now. ToDo: speed up-  maybe (return ()) (header hout) maybe_header-  hPutStr hout ls-  hClose hout-  hClose hin- where-  -- write the header string in UTF-8.  The header is something like-  --   {-# LINE "foo.hs" #-}-  -- and we want to make sure a Unicode filename isn't mangled.-  header h str = do-   hSetEncoding h utf8-   hPutStr h str-   hSetBinaryMode h True+-- | Copy file after printing the given header+copyWithHeader :: String -> FilePath -> FilePath -> IO ()+copyWithHeader header from to =+  withBinaryFile to WriteMode $ \hout -> do+    -- write the header string in UTF-8.  The header is something like+    --   {-# LINE "foo.hs" #-}+    -- and we want to make sure a Unicode filename isn't mangled.+    hSetEncoding hout utf8+    hPutStr hout header+    withBinaryFile from ReadMode $ \hin ->+      copyHandle hin hout
GHC/SysTools/Ar.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving, CPP #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving #-} {- Note: [The need for Ar.hs] Building `-staticlib` required the presence of libtool, and was a such restricted to mach-o only. As libtool on macOS and gnu libtool are very
GHC/SysTools/BaseDir.hs view
@@ -17,11 +17,9 @@   , tryFindTopDir   ) where -#include "HsVersions.h"- import GHC.Prelude --- See note [Base Dir] for why some of this logic is shared with ghc-pkg.+-- See Note [Base Dir] for why some of this logic is shared with ghc-pkg. import GHC.BaseDir  import GHC.Utils.Panic@@ -37,7 +35,6 @@ {- Note [topdir: How GHC finds its files] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~- GHC needs various support files (library packages, RTS etc), plus various auxiliary programs (cp, gcc, etc).  It starts by finding topdir, the root of GHC's support files@@ -56,7 +53,7 @@   Note [tooldir: How GHC finds mingw on Windows]-+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ GHC has some custom logic on Windows for finding the mingw toolchain and perl. Depending on whether GHC is built with the make build system or Hadrian, and on whether we're@@ -102,7 +99,7 @@   set in `aclocal.m4`. This allows the rest of the build system to have access   to these and other values determined by configure. -  Based on this file, `includes/ghc.mk` when ran will produce the settings file+  Based on this file, `rts/include/ghc.mk` when ran will produce the settings file   by echoing the values into a the final file.  Coincidentally this is also   where `ghcplatform.h` and `ghcversion.h` generated which contains information   about the build platform and sets CPP for use by the entire build.@@ -120,7 +117,7 @@    The last part of this is the `generateSettings` in `src/Rules/Generate.hs`   which produces the desired settings file out of Hadrian. This is the-  equivalent to `includes/ghc.mk`.+  equivalent to `rts/include/ghc.mk`.  -- @@ -141,12 +138,16 @@  -- | Expand occurrences of the @$tooldir@ interpolation in a string -- on Windows, leave the string untouched otherwise.-expandToolDir :: Maybe FilePath -> String -> String-#if defined(mingw32_HOST_OS) && !defined(USE_INPLACE_MINGW_TOOLCHAIN)-expandToolDir (Just tool_dir) s = expandPathVar "tooldir" tool_dir s-expandToolDir Nothing         _ = panic "Could not determine $tooldir"+expandToolDir+  :: Bool -- ^ whether we are use the ambiant mingw toolchain+  -> Maybe FilePath -- ^ tooldir+  -> String -> String+#if defined(mingw32_HOST_OS)+expandToolDir False (Just tool_dir) s = expandPathVar "tooldir" tool_dir s+expandToolDir False Nothing         _ = panic "Could not determine $tooldir"+expandToolDir True  _               s = s #else-expandToolDir _ s = s+expandToolDir _ _ s = s #endif  -- | Returns a Unix-format path pointing to TopDir.@@ -182,10 +183,11 @@ -- tooldir can't be located, or returns @Just tooldirpath@. -- If the distro toolchain is being used we treat Windows the same as Linux findToolDir-  :: FilePath -- ^ topdir+  :: Bool -- ^ whether we are use the ambiant mingw toolchain+  -> FilePath -- ^ topdir   -> IO (Maybe FilePath)-#if defined(mingw32_HOST_OS) && !defined(USE_INPLACE_MINGW_TOOLCHAIN)-findToolDir top_dir = go 0 (top_dir </> "..") []+#if defined(mingw32_HOST_OS)+findToolDir False top_dir = go 0 (top_dir </> "..") []   where maxDepth = 3         go :: Int -> FilePath -> [FilePath] -> IO (Maybe FilePath)         go k path tried@@ -193,11 +195,12 @@               InstallationError $ "could not detect mingw toolchain in the following paths: " ++ show tried           | otherwise = do               let try = path </> "mingw"-              let tried = tried ++ [try]+              let tried' = tried ++ [try]               oneLevel <- doesDirectoryExist try               if oneLevel                 then return (Just path)-                else go (k+1) (path </> "..") tried+                else go (k+1) (path </> "..") tried'+findToolDir True _ = return Nothing #else-findToolDir _ = return Nothing+findToolDir _ _ = return Nothing #endif
GHC/SysTools/Elf.hs view
@@ -18,7 +18,6 @@  import GHC.Utils.Asm import GHC.Utils.Exception-import GHC.Driver.Session import GHC.Platform import GHC.Utils.Error import GHC.Data.Maybe       (MaybeT(..),runMaybeT)@@ -142,9 +141,9 @@   -- | Read the ELF header-readElfHeader :: Logger -> DynFlags -> ByteString -> IO (Maybe ElfHeader)-readElfHeader logger dflags bs = runGetOrThrow getHeader bs `catchIO` \_ -> do-    debugTraceMsg logger dflags 3 $+readElfHeader :: Logger -> ByteString -> IO (Maybe ElfHeader)+readElfHeader logger bs = runGetOrThrow getHeader bs `catchIO` \_ -> do+    debugTraceMsg logger 3 $       text ("Unable to read ELF header")     return Nothing   where@@ -196,13 +195,12 @@  -- | Read the ELF section table readElfSectionTable :: Logger-                    -> DynFlags                     -> ElfHeader                     -> ByteString                     -> IO (Maybe SectionTable) -readElfSectionTable logger dflags hdr bs = action `catchIO` \_ -> do-    debugTraceMsg logger dflags 3 $+readElfSectionTable logger hdr bs = action `catchIO` \_ -> do+    debugTraceMsg logger 3 $       text ("Unable to read ELF section table")     return Nothing   where@@ -248,15 +246,14 @@  -- | Read a ELF section readElfSectionByIndex :: Logger-                      -> DynFlags                       -> ElfHeader                       -> SectionTable                       -> Word64                       -> ByteString                       -> IO (Maybe Section) -readElfSectionByIndex logger dflags hdr secTable i bs = action `catchIO` \_ -> do-    debugTraceMsg logger dflags 3 $+readElfSectionByIndex logger hdr secTable i bs = action `catchIO` \_ -> do+    debugTraceMsg logger 3 $       text ("Unable to read ELF section")     return Nothing   where@@ -293,13 +290,12 @@ -- -- We do not perform any check on the section type. findSectionFromName :: Logger-                    -> DynFlags                     -> ElfHeader                     -> SectionTable                     -> String                     -> ByteString                     -> IO (Maybe ByteString)-findSectionFromName logger dflags hdr secTable name bs =+findSectionFromName logger hdr secTable name bs =     rec [0..sectionEntryCount secTable - 1]   where     -- convert the required section name into a ByteString to perform@@ -310,7 +306,7 @@     -- the matching one, if any     rec []     = return Nothing     rec (x:xs) = do-      me <- readElfSectionByIndex logger dflags hdr secTable x bs+      me <- readElfSectionByIndex logger hdr secTable x bs       case me of         Just e | entryName e == name' -> return (Just (entryBS e))         _                             -> rec xs@@ -321,20 +317,19 @@ -- If the section isn't found or if there is any parsing error, we return -- Nothing readElfSectionByName :: Logger-                     -> DynFlags                      -> ByteString                      -> String                      -> IO (Maybe LBS.ByteString) -readElfSectionByName logger dflags bs name = action `catchIO` \_ -> do-    debugTraceMsg logger dflags 3 $+readElfSectionByName logger bs name = action `catchIO` \_ -> do+    debugTraceMsg logger 3 $       text ("Unable to read ELF section \"" ++ name ++ "\"")     return Nothing   where     action = runMaybeT $ do-      hdr      <- MaybeT $ readElfHeader logger dflags bs-      secTable <- MaybeT $ readElfSectionTable logger dflags hdr bs-      MaybeT $ findSectionFromName logger dflags hdr secTable name bs+      hdr      <- MaybeT $ readElfHeader logger bs+      secTable <- MaybeT $ readElfSectionTable logger hdr bs+      MaybeT $ findSectionFromName logger hdr secTable name bs  ------------------ -- NOTE SECTIONS@@ -345,14 +340,13 @@ -- If you try to read a note from a section which does not support the Note -- format, the parsing is likely to fail and Nothing will be returned readElfNoteBS :: Logger-              -> DynFlags               -> ByteString               -> String               -> String               -> IO (Maybe LBS.ByteString) -readElfNoteBS logger dflags bs sectionName noteId = action `catchIO`  \_ -> do-    debugTraceMsg logger dflags 3 $+readElfNoteBS logger bs sectionName noteId = action `catchIO`  \_ -> do+    debugTraceMsg logger 3 $          text ("Unable to read ELF note \"" ++ noteId ++                "\" in section \"" ++ sectionName ++ "\"")     return Nothing@@ -386,8 +380,8 @@       action = runMaybeT $ do-      hdr  <- MaybeT $ readElfHeader logger dflags bs-      sec  <- MaybeT $ readElfSectionByName logger dflags bs sectionName+      hdr  <- MaybeT $ readElfHeader logger bs+      sec  <- MaybeT $ readElfSectionByName logger bs sectionName       MaybeT $ runGetOrThrow (findNote hdr) sec  -- | read a Note as a String@@ -395,21 +389,20 @@ -- If you try to read a note from a section which does not support the Note -- format, the parsing is likely to fail and Nothing will be returned readElfNoteAsString :: Logger-                    -> DynFlags                     -> FilePath                     -> String                     -> String                     -> IO (Maybe String) -readElfNoteAsString logger dflags path sectionName noteId = action `catchIO`  \_ -> do-    debugTraceMsg logger dflags 3 $+readElfNoteAsString logger path sectionName noteId = action `catchIO`  \_ -> do+    debugTraceMsg logger 3 $          text ("Unable to read ELF note \"" ++ noteId ++                "\" in section \"" ++ sectionName ++ "\"")     return Nothing   where     action = do       bs   <- LBS.readFile path-      note <- readElfNoteBS logger dflags bs sectionName noteId+      note <- readElfNoteBS logger bs sectionName noteId       return (fmap B8.unpack note)
GHC/SysTools/Info.hs view
@@ -26,14 +26,12 @@ import GHC.SysTools.Process  {- Note [Run-time linker info]-+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~ See also: #5240, #6063, #10110  Before 'runLink', we need to be sure to get the relevant information about the linker we're using at runtime to see if we need any extra-options. For example, GNU ld requires '--reduce-memory-overheads' and-'--hash-size=31' in order to use reasonable amounts of memory (see-trac #5240.) But this isn't supported in GNU gold.+options.  Generally, the linker changing from what was detected at ./configure time has always been possible using -pgml, but on Linux it can happen@@ -57,7 +55,7 @@ -}  {- Note [ELF needed shared libs]-+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Some distributions change the link editor's default handling of ELF DT_NEEDED tags to include only those shared objects that are needed to resolve undefined symbols. For Template Haskell we need@@ -70,30 +68,6 @@  -} -{- Note [Windows static libGCC]--The GCC versions being upgraded to in #10726 are configured with-dynamic linking of libgcc supported. This results in libgcc being-linked dynamically when a shared library is created.--This introduces thus an extra dependency on GCC dll that was not-needed before by shared libraries created with GHC. This is a particular-issue on Windows because you get a non-obvious error due to this missing-dependency. This dependent dll is also not commonly on your path.--For this reason using the static libgcc is preferred as it preserves-the same behaviour that existed before. There are however some very good-reasons to have the shared version as well as described on page 181 of-https://gcc.gnu.org/onlinedocs/gcc-5.2.0/gcc.pdf :--"There are several situations in which an application should use the- shared ‘libgcc’ instead of the static version. The most common of these- is when the application wishes to throw and catch exceptions across different- shared libraries. In that case, each of the libraries as well as the application- itself should use the shared ‘libgcc’. "---}- neededLinkArgs :: LinkerInfo -> [Option] neededLinkArgs (GnuLD o)     = o neededLinkArgs (GnuGold o)   = o@@ -127,13 +101,8 @@       -- Try to grab the info from the process output.       parseLinkerInfo stdo _stde _exitc         | any ("GNU ld" `isPrefixOf`) stdo =-          -- GNU ld specifically needs to use less memory. This especially-          -- hurts on small object files. #5240.           -- Set DT_NEEDED for all shared libraries. #10110.-          -- TODO: Investigate if these help or hurt when using split sections.-          return (GnuLD $ map Option ["-Wl,--hash-size=31",-                                      "-Wl,--reduce-memory-overheads",-                                      -- ELF specific flag+          return (GnuLD $ map Option [-- ELF specific flag                                       -- see Note [ELF needed shared libs]                                       "-Wl,--no-as-needed"]) @@ -173,15 +142,10 @@         -- Process creation is also fairly expensive on win32, so         -- we short-circuit here.         return $ GnuLD $ map Option-          [ -- Reduce ld memory usage-            "-Wl,--hash-size=31"-          , "-Wl,--reduce-memory-overheads"-            -- Emit gcc stack checks-            -- Note [Windows stack usage]-          , "-fstack-check"-            -- Force static linking of libGCC-            -- Note [Windows static libGCC]-          , "-static-libgcc" ]+          [ -- Emit stack checks+            -- See Note [Windows stack allocations]+           "-fstack-check"+          ]       _ -> do         -- In practice, we use the compiler as the linker here. Pass         -- -Wl,--version to get linker version info.@@ -195,32 +159,44 @@         parseLinkerInfo (lines stdo) (lines stde) exitc     )     (\err -> do-        debugTraceMsg logger dflags 2+        debugTraceMsg logger 2             (text "Error (figuring out linker information):" <+>              text (show err))-        errorMsg logger dflags $ hang (text "Warning:") 9 $+        errorMsg logger $ hang (text "Warning:") 9 $           text "Couldn't figure out linker information!" $$           text "Make sure you're using GNU ld, GNU gold" <+>           text "or the built in OS X linker, etc."         return UnknownLD     ) --- Grab compiler info and cache it in DynFlags.+-- | Grab compiler info and cache it in DynFlags. getCompilerInfo :: Logger -> DynFlags -> IO CompilerInfo getCompilerInfo logger dflags = do   info <- readIORef (rtccInfo dflags)   case info of     Just v  -> return v     Nothing -> do-      v <- getCompilerInfo' logger dflags+      let pgm = pgm_c dflags+      v <- getCompilerInfo' logger pgm       writeIORef (rtccInfo dflags) (Just v)       return v +-- | Grab assembler info and cache it in DynFlags.+getAssemblerInfo :: Logger -> DynFlags -> IO CompilerInfo+getAssemblerInfo logger dflags = do+  info <- readIORef (rtasmInfo dflags)+  case info of+    Just v  -> return v+    Nothing -> do+      let (pgm, _) = pgm_a dflags+      v <- getCompilerInfo' logger pgm+      writeIORef (rtasmInfo dflags) (Just v)+      return v+ -- See Note [Run-time linker info].-getCompilerInfo' :: Logger -> DynFlags -> IO CompilerInfo-getCompilerInfo' logger dflags = do-  let pgm = pgm_c dflags-      -- Try to grab the info from the process output.+getCompilerInfo' :: Logger -> String -> IO CompilerInfo+getCompilerInfo' logger pgm = do+  let -- Try to grab the info from the process output.       parseCompilerInfo _stdo stde _exitc         -- Regular GCC         | any ("gcc version" `isInfixOf`) stde =@@ -240,8 +216,8 @@         -- Xcode 4.1 clang         | any ("Apple clang version" `isPrefixOf`) stde =           return AppleClang-         -- Unknown linker.-        | otherwise = fail $ "invalid -v output, or compiler is unsupported: " ++ unlines stde+         -- Unknown compiler.+        | otherwise = fail $ "invalid -v output, or compiler is unsupported (" ++ pgm ++ "): " ++ unlines stde    -- Process the executable call   catchIO (do@@ -252,10 +228,10 @@       parseCompilerInfo (lines stdo) (lines stde) exitc       )       (\err -> do-          debugTraceMsg logger dflags 2+          debugTraceMsg logger 2               (text "Error (figuring out C compiler information):" <+>                text (show err))-          errorMsg logger dflags $ hang (text "Warning:") 9 $+          errorMsg logger $ hang (text "Warning:") 9 $             text "Couldn't figure out C compiler information!" $$             text "Make sure you're using GNU gcc, or clang"           return UnknownCC
GHC/SysTools/Process.hs view
@@ -8,8 +8,6 @@ ----------------------------------------------------------------------------- module GHC.SysTools.Process where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Driver.Session@@ -133,7 +131,6 @@ -- Running an external program  runSomething :: Logger-             -> DynFlags              -> String          -- For -v message              -> String          -- Command name (possibly a full path)                                 --      assumed already dos-ified@@ -141,8 +138,8 @@                                 --      runSomething will dos-ify them              -> IO () -runSomething logger dflags phase_name pgm args =-  runSomethingFiltered logger dflags id phase_name pgm args Nothing Nothing+runSomething logger phase_name pgm args =+  runSomethingFiltered logger id phase_name pgm args Nothing Nothing  -- | Run a command, placing the arguments in an external response file. --@@ -164,14 +161,14 @@   -> Maybe [(String,String)]   -> IO () runSomethingResponseFile logger tmpfs dflags filter_fn phase_name pgm args mb_env =-    runSomethingWith logger dflags phase_name pgm args $ \real_args -> do+    runSomethingWith logger phase_name pgm args $ \real_args -> do         fp <- getResponseFile real_args         let args = ['@':fp]-        r <- builderMainLoop logger dflags filter_fn pgm args Nothing mb_env+        r <- builderMainLoop logger filter_fn pgm args Nothing mb_env         return (r,())   where     getResponseFile args = do-      fp <- newTempName logger tmpfs dflags TFL_CurrentModule "rsp"+      fp <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "rsp"       withFile fp WriteMode $ \h -> do #if defined(mingw32_HOST_OS)           hSetEncoding h latin1@@ -207,23 +204,23 @@         ]  runSomethingFiltered-  :: Logger -> DynFlags -> (String->String) -> String -> String -> [Option]+  :: Logger -> (String->String) -> String -> String -> [Option]   -> Maybe FilePath -> Maybe [(String,String)] -> IO () -runSomethingFiltered logger dflags filter_fn phase_name pgm args mb_cwd mb_env =-    runSomethingWith logger dflags phase_name pgm args $ \real_args -> do-        r <- builderMainLoop logger dflags filter_fn pgm real_args mb_cwd mb_env+runSomethingFiltered logger filter_fn phase_name pgm args mb_cwd mb_env =+    runSomethingWith logger phase_name pgm args $ \real_args -> do+        r <- builderMainLoop logger filter_fn pgm real_args mb_cwd mb_env         return (r,())  runSomethingWith-  :: Logger -> DynFlags -> String -> String -> [Option]+  :: Logger -> String -> String -> [Option]   -> ([String] -> IO (ExitCode, a))   -> IO a -runSomethingWith logger dflags phase_name pgm args io = do+runSomethingWith logger phase_name pgm args io = do   let real_args = filter notNull (map showOpt args)       cmdLine = showCommandForUser pgm real_args-  traceCmd logger dflags phase_name cmdLine $ handleProc pgm phase_name $ io real_args+  traceCmd logger phase_name cmdLine $ handleProc pgm phase_name $ io real_args  handleProc :: String -> String -> IO (ExitCode, r) -> IO r handleProc pgm phase_name proc = do@@ -243,10 +240,10 @@     does_not_exist = throwGhcExceptionIO (InstallationError ("could not execute: " ++ pgm))  -builderMainLoop :: Logger -> DynFlags -> (String -> String) -> FilePath+builderMainLoop :: Logger -> (String -> String) -> FilePath                 -> [String] -> Maybe FilePath -> Maybe [(String, String)]                 -> IO ExitCode-builderMainLoop logger dflags filter_fn pgm real_args mb_cwd mb_env = do+builderMainLoop logger filter_fn pgm real_args mb_cwd mb_env = do   chan <- newChan    -- We use a mask here rather than a bracket because we want@@ -307,10 +304,10 @@       msg <- readChan chan       case msg of         BuildMsg msg -> do-          logInfo logger dflags $ withPprStyle defaultUserStyle msg+          logInfo logger $ withPprStyle defaultUserStyle msg           log_loop chan t         BuildError loc msg -> do-          putLogMsg logger dflags NoReason SevError (mkSrcSpan loc loc)+          logMsg logger errorDiagnostic (mkSrcSpan loc loc)               $ withPprStyle defaultUserStyle msg           log_loop chan t         EOF ->
GHC/SysTools/Tasks.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE CPP #-}+ ----------------------------------------------------------------------------- -- -- Tasks running external programs for SysTools@@ -12,8 +12,10 @@ import GHC.Prelude import GHC.Platform import GHC.ForeignSrcLang+import GHC.IO (catchException) -import GHC.CmmToLlvm.Base (LlvmVersion, llvmVersionStr, supportedLlvmVersionLowerBound, supportedLlvmVersionUpperBound, llvmVersionStr, parseLlvmVersion)+import GHC.CmmToLlvm.Base   (llvmVersionStr, supportedLlvmVersionUpperBound, parseLlvmVersion, supportedLlvmVersionLowerBound)+import GHC.CmmToLlvm.Config (LlvmVersion)  import GHC.SysTools.Process import GHC.SysTools.Info@@ -26,8 +28,11 @@ import GHC.Utils.Misc import GHC.Utils.Logger import GHC.Utils.TmpFs+import GHC.Utils.Constants (isWindowsHost)+import GHC.Utils.Panic  import Data.List (tails, isPrefixOf)+import Data.Maybe (fromMaybe) import System.IO import System.Process @@ -40,38 +45,49 @@ -}  runUnlit :: Logger -> DynFlags -> [Option] -> IO ()-runUnlit logger dflags args = traceToolCommand logger dflags "unlit" $ do+runUnlit logger dflags args = traceToolCommand logger "unlit" $ do   let prog = pgm_L dflags       opts = getOpts dflags opt_L-  runSomething logger dflags "Literate pre-processor" prog+  runSomething logger "Literate pre-processor" prog                (map Option opts ++ args) +-- | Prepend the working directory to the search path.+-- Note [Filepaths and Multiple Home Units]+augmentImports :: DynFlags  -> [FilePath] -> [FilePath]+augmentImports dflags fps | Nothing <- workingDirectory dflags  = fps+augmentImports _ [] = []+augmentImports _ [x] = [x]+augmentImports dflags ("-include":fp:fps) = "-include" : augmentByWorkingDirectory dflags fp  : augmentImports dflags fps+augmentImports dflags (fp1: fp2: fps) = fp1 : augmentImports dflags (fp2:fps)+ runCpp :: Logger -> DynFlags -> [Option] -> IO ()-runCpp logger dflags args = traceToolCommand logger dflags "cpp" $ do+runCpp logger dflags args = traceToolCommand logger "cpp" $ do+  let opts = getOpts dflags opt_P+      modified_imports = augmentImports dflags opts   let (p,args0) = pgm_P dflags-      args1 = map Option (getOpts dflags opt_P)+      args1 = map Option modified_imports       args2 = [Option "-Werror" | gopt Opt_WarnIsError dflags]                 ++ [Option "-Wundef" | wopt Opt_WarnCPPUndef dflags]   mb_env <- getGccEnv args2-  runSomethingFiltered logger dflags id  "C pre-processor" p+  runSomethingFiltered logger id  "C pre-processor" p                        (args0 ++ args1 ++ args2 ++ args) Nothing mb_env  runPp :: Logger -> DynFlags -> [Option] -> IO ()-runPp logger dflags args = traceToolCommand logger dflags "pp" $ do+runPp logger dflags args = traceToolCommand logger "pp" $ do   let prog = pgm_F dflags       opts = map Option (getOpts dflags opt_F)-  runSomething logger dflags "Haskell pre-processor" prog (args ++ opts)+  runSomething logger "Haskell pre-processor" prog (args ++ opts)  -- | Run compiler of C-like languages and raw objects (such as gcc or clang). runCc :: Maybe ForeignSrcLang -> Logger -> TmpFs -> DynFlags -> [Option] -> IO ()-runCc mLanguage logger tmpfs dflags args = traceToolCommand logger dflags "cc" $ do-  let p = pgm_c dflags-      args1 = map Option userOpts+runCc mLanguage logger tmpfs dflags args = traceToolCommand logger "cc" $ do+  let args1 = map Option userOpts       args2 = languageOptions ++ args ++ args1       -- We take care to pass -optc flags in args1 last to ensure that the       -- user can override flags passed by GHC. See #14452.   mb_env <- getGccEnv args2-  runSomethingResponseFile logger tmpfs dflags cc_filter "C Compiler" p args2 mb_env+  runSomethingResponseFile logger tmpfs dflags cc_filter dbgstring prog args2+                           mb_env  where   -- discard some harmless warnings from gcc that we can't turn off   cc_filter = unlines . doFilter . lines@@ -127,17 +143,23 @@   -- compiling .hc files, by adding the -x c option.   -- Also useful for plain .c files, just in case GHC saw a   -- -x c option.-  (languageOptions, userOpts) = case mLanguage of-    Nothing -> ([], userOpts_c)-    Just language -> ([Option "-x", Option languageName], opts)+  (languageOptions, userOpts, prog, dbgstring) = case mLanguage of+    Nothing -> ([], userOpts_c, pgm_c dflags, "C Compiler")+    Just language -> ([Option "-x", Option languageName], opts, prog, dbgstr)       where-        (languageName, opts) = case language of-          LangC      -> ("c",             userOpts_c)-          LangCxx    -> ("c++",           userOpts_cxx)-          LangObjc   -> ("objective-c",   userOpts_c)-          LangObjcxx -> ("objective-c++", userOpts_cxx)-          LangAsm    -> ("assembler",     [])-          RawObject  -> ("c",             []) -- claim C for lack of a better idea+        (languageName, opts, prog, dbgstr) = case language of+          LangC      -> ("c",             userOpts_c+                        ,pgm_c dflags,    "C Compiler")+          LangCxx    -> ("c++",           userOpts_cxx+                        ,pgm_cxx dflags , "C++ Compiler")+          LangObjc   -> ("objective-c",   userOpts_c+                        ,pgm_c dflags   , "Objective C Compiler")+          LangObjcxx -> ("objective-c++", userOpts_cxx+                        ,pgm_cxx dflags,  "Objective C++ Compiler")+          LangAsm    -> ("assembler",     []+                        ,pgm_c dflags,    "Asm Compiler")+          RawObject  -> ("c",             []+                        ,pgm_c dflags,    "C Compiler") -- claim C for lack of a better idea   userOpts_c   = getOpts dflags opt_c   userOpts_cxx = getOpts dflags opt_cxx @@ -146,43 +168,43 @@  -- | Run the linker with some arguments and return the output askLd :: Logger -> DynFlags -> [Option] -> IO String-askLd logger dflags args = traceToolCommand logger dflags "linker" $ do+askLd logger dflags args = traceToolCommand logger "linker" $ do   let (p,args0) = pgm_l dflags       args1     = map Option (getOpts dflags opt_l)       args2     = args0 ++ args1 ++ args   mb_env <- getGccEnv args2-  runSomethingWith logger dflags "gcc" p args2 $ \real_args ->+  runSomethingWith logger "gcc" p args2 $ \real_args ->     readCreateProcessWithExitCode' (proc p real_args){ env = mb_env }  runAs :: Logger -> DynFlags -> [Option] -> IO ()-runAs logger dflags args = traceToolCommand logger dflags "as" $ do+runAs logger dflags args = traceToolCommand logger "as" $ do   let (p,args0) = pgm_a dflags       args1 = map Option (getOpts dflags opt_a)       args2 = args0 ++ args1 ++ args   mb_env <- getGccEnv args2-  runSomethingFiltered logger dflags id "Assembler" p args2 Nothing mb_env+  runSomethingFiltered logger id "Assembler" p args2 Nothing mb_env  -- | Run the LLVM Optimiser runLlvmOpt :: Logger -> DynFlags -> [Option] -> IO ()-runLlvmOpt logger dflags args = traceToolCommand logger dflags "opt" $ do+runLlvmOpt logger dflags args = traceToolCommand logger "opt" $ do   let (p,args0) = pgm_lo dflags       args1 = map Option (getOpts dflags opt_lo)       -- We take care to pass -optlo flags (e.g. args0) last to ensure that the       -- user can override flags passed by GHC. See #14821.-  runSomething logger dflags "LLVM Optimiser" p (args1 ++ args ++ args0)+  runSomething logger "LLVM Optimiser" p (args1 ++ args ++ args0)  -- | Run the LLVM Compiler runLlvmLlc :: Logger -> DynFlags -> [Option] -> IO ()-runLlvmLlc logger dflags args = traceToolCommand logger dflags "llc" $ do+runLlvmLlc logger dflags args = traceToolCommand logger "llc" $ do   let (p,args0) = pgm_lc dflags       args1 = map Option (getOpts dflags opt_lc)-  runSomething logger dflags "LLVM Compiler" p (args0 ++ args1 ++ args)+  runSomething logger "LLVM Compiler" p (args0 ++ args1 ++ args)  -- | Run the clang compiler (used as an assembler for the LLVM -- backend on OS X as LLVM doesn't support the OS X system -- assembler) runClang :: Logger -> DynFlags -> [Option] -> IO ()-runClang logger dflags args = traceToolCommand logger dflags "clang" $ do+runClang logger dflags args = traceToolCommand logger "clang" $ do   let (clang,_) = pgm_lcc dflags       -- be careful what options we call clang with       -- see #5903 and #7617 for bugs caused by this.@@ -190,10 +212,10 @@       args1 = map Option (getOpts dflags opt_a)       args2 = args0 ++ args1 ++ args   mb_env <- getGccEnv args2-  catch-    (runSomethingFiltered logger dflags id "Clang (Assembler)" clang args2 Nothing mb_env)+  catchException+    (runSomethingFiltered logger id "Clang (Assembler)" clang args2 Nothing mb_env)     (\(err :: SomeException) -> do-        errorMsg logger dflags $+        errorMsg logger $             text ("Error running clang! you need clang installed to use the" ++                   " LLVM backend") $+$             text "(or GHC tried to execute clang incorrectly)"@@ -202,7 +224,7 @@  -- | Figure out which version of LLVM we are running this session figureLlvmVersion :: Logger -> DynFlags -> IO (Maybe LlvmVersion)-figureLlvmVersion logger dflags = traceToolCommand logger dflags "llc" $ do+figureLlvmVersion logger dflags = traceToolCommand logger "llc" $ do   let (pgm,opts) = pgm_lc dflags       args = filter notNull (map showOpt opts)       -- we grab the args even though they should be useless just in@@ -229,10 +251,10 @@               return mb_ver             )             (\err -> do-                debugTraceMsg logger dflags 2+                debugTraceMsg logger 2                     (text "Error (figuring out LLVM version):" <+>                       text (show err))-                errorMsg logger dflags $ vcat+                errorMsg logger $ vcat                     [ text "Warning:", nest 9 $                           text "Couldn't figure out LLVM version!" $$                           text ("Make sure you have installed LLVM between ["@@ -245,7 +267,7 @@   runLink :: Logger -> TmpFs -> DynFlags -> [Option] -> IO ()-runLink logger tmpfs dflags args = traceToolCommand logger dflags "linker" $ do+runLink logger tmpfs dflags args = traceToolCommand logger "linker" $ do   -- See Note [Run-time linker info]   --   -- `-optl` args come at the end, so that later `-l` options@@ -309,80 +331,64 @@  -- See Note [Merging object files for GHCi] in GHC.Driver.Pipeline. runMergeObjects :: Logger -> TmpFs -> DynFlags -> [Option] -> IO ()-#if defined(mingw32_HOST_OS)-runMergeObjects logger tmpfs  dflags args =-#else-runMergeObjects logger _tmpfs dflags args =-#endif-  traceToolCommand logger dflags "merge-objects" $ do-    let (p,args0) = pgm_lm dflags+runMergeObjects logger tmpfs dflags args =+  traceToolCommand logger "merge-objects" $ do+    let (p,args0) = fromMaybe err (pgm_lm dflags)+        err = throwGhcException $ UsageError $ unwords+            [ "Attempted to merge object files but the configured linker"+            , "does not support object merging." ]         optl_args = map Option (getOpts dflags opt_lm)         args2     = args0 ++ args ++ optl_args     -- N.B. Darwin's ld64 doesn't support response files. Consequently we only     -- use them on Windows where they are truly necessary.-#if defined(mingw32_HOST_OS)-    mb_env <- getGccEnv args2-    runSomethingResponseFile logger tmpfs dflags id "Merge objects" p args2 mb_env-#else-    runSomething logger dflags "Merge objects" p args2-#endif+    if isWindowsHost+      then do+        mb_env <- getGccEnv args2+        runSomethingResponseFile logger tmpfs dflags id "Merge objects" p args2 mb_env+      else do+        runSomething logger "Merge objects" p args2  runLibtool :: Logger -> DynFlags -> [Option] -> IO ()-runLibtool logger dflags args = traceToolCommand logger dflags "libtool" $ do+runLibtool logger dflags args = traceToolCommand logger "libtool" $ do   linkargs <- neededLinkArgs `fmap` getLinkerInfo logger dflags   let args1      = map Option (getOpts dflags opt_l)       args2      = [Option "-static"] ++ args1 ++ args ++ linkargs       libtool    = pgm_libtool dflags   mb_env <- getGccEnv args2-  runSomethingFiltered logger dflags id "Libtool" libtool args2 Nothing mb_env+  runSomethingFiltered logger id "Libtool" libtool args2 Nothing mb_env  runAr :: Logger -> DynFlags -> Maybe FilePath -> [Option] -> IO ()-runAr logger dflags cwd args = traceToolCommand logger dflags "ar" $ do+runAr logger dflags cwd args = traceToolCommand logger "ar" $ do   let ar = pgm_ar dflags-  runSomethingFiltered logger dflags id "Ar" ar args cwd Nothing+  runSomethingFiltered logger id "Ar" ar args cwd Nothing  askOtool :: Logger -> DynFlags -> Maybe FilePath -> [Option] -> IO String askOtool logger dflags mb_cwd args = do   let otool = pgm_otool dflags-  runSomethingWith logger dflags "otool" otool args $ \real_args ->+  runSomethingWith logger "otool" otool args $ \real_args ->     readCreateProcessWithExitCode' (proc otool real_args){ cwd = mb_cwd }  runInstallNameTool :: Logger -> DynFlags -> [Option] -> IO () runInstallNameTool logger dflags args = do   let tool = pgm_install_name_tool dflags-  runSomethingFiltered logger dflags id "Install Name Tool" tool args Nothing Nothing+  runSomethingFiltered logger id "Install Name Tool" tool args Nothing Nothing  runRanlib :: Logger -> DynFlags -> [Option] -> IO ()-runRanlib logger dflags args = traceToolCommand logger dflags "ranlib" $ do+runRanlib logger dflags args = traceToolCommand logger "ranlib" $ do   let ranlib = pgm_ranlib dflags-  runSomethingFiltered logger dflags id "Ranlib" ranlib args Nothing Nothing+  runSomethingFiltered logger id "Ranlib" ranlib args Nothing Nothing  runWindres :: Logger -> DynFlags -> [Option] -> IO ()-runWindres logger dflags args = traceToolCommand logger dflags "windres" $ do-  let cc = pgm_c dflags-      cc_args = map Option (sOpt_c (settings dflags))+runWindres logger dflags args = traceToolCommand logger "windres" $ do+  let cc_args = map Option (sOpt_c (settings dflags))       windres = pgm_windres dflags       opts = map Option (getOpts dflags opt_windres)-      quote x = "\"" ++ x ++ "\""-      args' = -- If windres.exe and gcc.exe are in a directory containing-              -- spaces then windres fails to run gcc. We therefore need-              -- to tell it what command to use...-              Option ("--preprocessor=" ++-                      unwords (map quote (cc :-                                          map showOpt opts ++-                                          ["-E", "-xc", "-DRC_INVOKED"])))-              -- ...but if we do that then if windres calls popen then-              -- it can't understand the quoting, so we have to use-              -- --use-temp-file so that it interprets it correctly.-              -- See #1828.-            : Option "--use-temp-file"-            : args   mb_env <- getGccEnv cc_args-  runSomethingFiltered logger dflags id "Windres" windres args' Nothing mb_env+  runSomethingFiltered logger id "Windres" windres (opts ++ args) Nothing mb_env  touch :: Logger -> DynFlags -> String -> String -> IO ()-touch logger dflags purpose arg = traceToolCommand logger dflags "touch" $-  runSomething logger dflags purpose (pgm_T dflags) [FileOption "" arg]+touch logger dflags purpose arg = traceToolCommand logger "touch" $+  runSomething logger purpose (pgm_T dflags) [FileOption "" arg]  -- * Tracing utility @@ -393,6 +399,5 @@ -- --   For those events to show up in the eventlog, you need --   to run GHC with @-v2@ or @-ddump-timings@.-traceToolCommand :: Logger -> DynFlags -> String -> IO a -> IO a-traceToolCommand logger dflags tool = withTiming logger-  dflags (text $ "systool:" ++ tool) (const ())+traceToolCommand :: Logger -> String -> IO a -> IO a+traceToolCommand logger tool = withTiming logger (text "systool:" <> text tool) (const ())
GHC/SysTools/Terminal.hs view
@@ -5,13 +5,14 @@ import GHC.Prelude  #if defined(MIN_VERSION_terminfo)-import Control.Exception (catch)+import GHC.IO (catchException) import Data.Maybe (fromMaybe) import System.Console.Terminfo (SetupTermError, Terminal, getCapability,                                 setupTermFromEnv, termColors) import System.Posix (queryTerminal, stdError) #elif defined(mingw32_HOST_OS)-import Control.Exception (catch, try)+import GHC.IO (catchException)+import GHC.Utils.Exception (try) -- import Data.Bits ((.|.), (.&.)) import Foreign (Ptr, peek, with) import qualified Graphics.Win32 as Win32@@ -43,7 +44,7 @@     stderr_available <- queryTerminal stdError     if stderr_available then       fmap termSupportsColors setupTermFromEnv-        `catch` \ (_ :: SetupTermError) -> pure False+        `catchException` \ (_ :: SetupTermError) -> pure False     else       pure False   where@@ -52,7 +53,7 @@  #elif defined(mingw32_HOST_OS)   h <- Win32.getStdHandle Win32.sTD_ERROR_HANDLE-         `catch` \ (_ :: IOError) ->+         `catchException` \ (_ :: IOError) ->            pure Win32.nullHANDLE   if h == Win32.nullHANDLE     then pure False@@ -72,7 +73,7 @@     enableVTP h mode = do         setConsoleMode h (modeAddVTP mode)         modeHasVTP <$> getConsoleMode h-      `catch` \ (_ :: IOError) ->+      `catchException` \ (_ :: IOError) ->         pure False      modeHasVTP :: Win32.DWORD -> Bool
GHC/Tc/Deriv.hs view
@@ -4,7 +4,8 @@  -} -{-# LANGUAGE CPP #-}++{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE TypeFamilies #-} @@ -13,17 +14,15 @@ -- | Handles @deriving@ clauses on @data@ declarations. module GHC.Tc.Deriv ( tcDeriving, DerivInfo(..) ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Hs import GHC.Driver.Session +import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Tc.Instance.Family import GHC.Tc.Types.Origin-import GHC.Core.Predicate import GHC.Tc.Deriv.Infer import GHC.Tc.Deriv.Utils import GHC.Tc.TyCl.Class( instDeclCtxt3, tcATDefault )@@ -61,8 +60,8 @@ import GHC.Utils.Misc import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Utils.Logger-import GHC.Data.FastString import GHC.Data.Bag import GHC.Utils.FV as FV (fvVarList, unionFV, mkFVs) import qualified GHC.LanguageExtensions as LangExt@@ -89,7 +88,7 @@ 3.  Add the derived bindings, generating InstInfos -} -data EarlyDerivSpec = InferTheta (DerivSpec [ThetaOrigin])+data EarlyDerivSpec = InferTheta (DerivSpec ThetaSpec)                     | GivenTheta (DerivSpec ThetaType)         -- InferTheta ds => the context for the instance should be inferred         --      In this case ds_theta is the list of all the sets of@@ -103,7 +102,7 @@         -- See Note [Inferring the instance context] in GHC.Tc.Deriv.Infer  splitEarlyDerivSpec :: [EarlyDerivSpec]-                    -> ([DerivSpec [ThetaOrigin]], [DerivSpec ThetaType])+                    -> ([DerivSpec ThetaSpec], [DerivSpec ThetaType]) splitEarlyDerivSpec [] = ([],[]) splitEarlyDerivSpec (InferTheta spec : specs) =     case splitEarlyDerivSpec specs of (is, gs) -> (spec : is, gs)@@ -171,6 +170,8 @@                              -- or the *representation* tycon for data families                            , di_scoped_tvs :: ![(Name,TyVar)]                              -- ^ Variables that scope over the deriving clause.+                             -- See @Note [Scoped tyvars in a TcTyCon]@ in+                             -- "GHC.Core.TyCon".                            , di_clauses :: [LHsDerivingClause GhcRn]                            , di_ctxt    :: SDoc -- ^ error context                            }@@ -196,71 +197,66 @@         ; traceTc "tcDeriving" (ppr early_specs)          ; let (infer_specs, given_specs) = splitEarlyDerivSpec early_specs-        ; insts1 <- mapM genInst given_specs-        ; insts2 <- mapM genInst infer_specs+        ; famInsts1 <- concatMapM genFamInsts given_specs+        ; famInsts2 <- concatMapM genFamInsts infer_specs+        ; let famInsts = famInsts1 ++ famInsts2          ; dflags <- getDynFlags         ; logger <- getLogger -        ; let (_, deriv_stuff, fvs) = unzip3 (insts1 ++ insts2)-        ; loc <- getSrcSpanM-        ; let (binds, famInsts) = genAuxBinds dflags loc-                                    (unionManyBags deriv_stuff)--        ; let mk_inst_infos1 = map fstOf3 insts1-        ; inst_infos1 <- apply_inst_infos mk_inst_infos1 given_specs-           -- We must put all the derived type family instances (from both           -- infer_specs and given_specs) in the local instance environment           -- before proceeding, or else simplifyInstanceContexts might           -- get stuck if it has to reason about any of those family instances.           -- See Note [Staging of tcDeriving]-        ; tcExtendLocalFamInstEnv (bagToList famInsts) $+        ; tcExtendLocalFamInstEnv famInsts $           -- NB: only call tcExtendLocalFamInstEnv once, as it performs           -- validity checking for all of the family instances you give it.           -- If the family instances have errors, calling it twice will result           -- in duplicate error messages! -     do {-        -- the stand-alone derived instances (@inst_infos1@) are used when+     do { given_inst_binds <- mapM genInstBinds given_specs++        ; let given_inst_infos = map fstOf3 given_inst_binds++        -- the stand-alone derived instances (@given_inst_infos@) are used when         -- inferring the contexts for "deriving" clauses' instances         -- (@infer_specs@)-        ; final_specs <- extendLocalInstEnv (map iSpec inst_infos1) $-                         simplifyInstanceContexts infer_specs+        ; final_infer_specs <-+            extendLocalInstEnv (map iSpec given_inst_infos) $+            simplifyInstanceContexts infer_specs+        ; infer_inst_binds <- mapM genInstBinds final_infer_specs -        ; let mk_inst_infos2 = map fstOf3 insts2-        ; inst_infos2 <- apply_inst_infos mk_inst_infos2 final_specs-        ; let inst_infos = inst_infos1 ++ inst_infos2+        ; let (_, aux_specs, fvs) = unzip3 (given_inst_binds ++ infer_inst_binds)+        ; loc <- getSrcSpanM+        ; let aux_binds = genAuxBinds dflags loc (unionManyBags aux_specs) -        ; (inst_info, rn_binds, rn_dus) <- renameDeriv inst_infos binds+        ; let infer_inst_infos = map fstOf3 infer_inst_binds+        ; let inst_infos = given_inst_infos ++ infer_inst_infos +        ; (inst_info, rn_aux_binds, rn_dus) <- renameDeriv inst_infos aux_binds+         ; unless (isEmptyBag inst_info) $-             liftIO (dumpIfSet_dyn logger dflags Opt_D_dump_deriv "Derived instances"+             liftIO (putDumpFileMaybe logger Opt_D_dump_deriv "Derived instances"                         FormatHaskell-                        (ddump_deriving inst_info rn_binds famInsts))+                        (ddump_deriving inst_info rn_aux_binds famInsts))          ; gbl_env <- tcExtendLocalInstEnv (map iSpec (bagToList inst_info))                                           getGblEnv         ; let all_dus = rn_dus `plusDU` usesOnly (NameSet.mkFVs $ concat fvs)-        ; return (addTcgDUs gbl_env all_dus, inst_info, rn_binds) } }+        ; return (addTcgDUs gbl_env all_dus, inst_info, rn_aux_binds) } }   where     ddump_deriving :: Bag (InstInfo GhcRn) -> HsValBinds GhcRn-                   -> Bag FamInst             -- ^ Rep type family instances+                   -> [FamInst]               -- Associated type family instances                    -> SDoc-    ddump_deriving inst_infos extra_binds repFamInsts+    ddump_deriving inst_infos extra_binds famInsts       =    hang (text "Derived class instances:")               2 (vcat (map (\i -> pprInstInfoDetails i $$ text "") (bagToList inst_infos))                  $$ ppr extra_binds)-        $$ hangP "Derived type family instances:"-             (vcat (map pprRepTy (bagToList repFamInsts)))--    hangP s x = text "" $$ hang (ptext (sLit s)) 2 x+        $$ hangP (text "Derived type family instances:")+             (vcat (map pprRepTy famInsts)) -    -- Apply the suspended computations given by genInst calls.-    -- See Note [Staging of tcDeriving]-    apply_inst_infos :: [ThetaType -> TcM (InstInfo GhcPs)]-                     -> [DerivSpec ThetaType] -> TcM [InstInfo GhcPs]-    apply_inst_infos = zipWithM (\f ds -> f (ds_theta ds))+    hangP s x = text "" $$ hang s 2 x  -- Prints the representable type family instance pprRepTy :: FamInst -> SDoc@@ -358,32 +354,18 @@ it needed in the environment in order to properly simplify instance like the C N instance above. -To avoid this scenario, we carefully structure the order of events in-tcDeriving. We first call genInst on the standalone derived instance specs and-the instance specs obtained from deriving clauses. Note that the return type of-genInst is a triple:--    TcM (ThetaType -> TcM (InstInfo RdrName), BagDerivStuff, Maybe Name)--The type family instances are in the BagDerivStuff. The first field of the-triple is a suspended computation which, given an instance context, produces-the rest of the instance. The fact that it is suspended is important, because-right now, we don't have ThetaTypes for the instances that use deriving clauses-(only the standalone-derived ones).--Now we can collect the type family instances and extend the local instance-environment. At this point, it is safe to run simplifyInstanceContexts on the-deriving-clause instance specs, which gives us the ThetaTypes for the-deriving-clause instances. Now we can feed all the ThetaTypes to the-suspended computations and obtain our InstInfos, at which point-tcDeriving is done.+To avoid this scenario, we generate things in tcDeriving in a specific order: -An alternative design would be to split up genInst so that the-family instances are generated separately from the InstInfos. But this would-require carving up a lot of the GHC deriving internals to accommodate the-change. On the other hand, we can keep all of the InstInfo and type family-instance logic together in genInst simply by converting genInst to-continuation-returning style, so we opt for that route.+1. First, we generate all of the associated type family instances for derived+   instances (using `genFamInsts`).+2. Next, we extend the local instance environment with these type family+   instances.+3. Then, we generate the instance bindings for derived instances+   (using `genInstBinds`).+4. Finally, for instances generated with `deriving` clauses, we infer the+   instance contexts (using `simplifyInstanceContexts`). At this point, we+   already have the necessary type family instances in scope (from step (2)),+   so this is safe to do.  Note [Why we don't pass rep_tc into deriveTyData] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -438,6 +420,7 @@                -> TcM [EarlyDerivSpec] makeDerivSpecs deriv_infos deriv_decls   = do  { eqns1 <- sequenceA+                      -- MP: scoped_tvs here magically converts TyVar into TcTyVar                      [ deriveClause rep_tc scoped_tvs dcs (deriv_clause_preds dct) err_ctxt                      | DerivInfo { di_rep_tc = rep_tc                                  , di_scoped_tvs = scoped_tvs@@ -511,7 +494,7 @@       , text "via_tvs"         <+> ppr via_tvs ]     (cls_tvs, cls, cls_tys, cls_arg_kinds) <- tcHsDeriv deriv_pred     when (cls_arg_kinds `lengthIsNot` 1) $-      failWithTc (nonUnaryErr deriv_pred)+      failWithTc (TcRnNonUnaryTypeclassConstraint deriv_pred)     let [cls_arg_kind] = cls_arg_kinds         mb_deriv_strat = fmap unLoc mb_lderiv_strat     if (className cls == typeableClassName)@@ -632,6 +615,8 @@        ; traceTc "Deriving strategy (standalone deriving)" $            vcat [ppr mb_lderiv_strat, ppr deriv_ty]        ; (mb_lderiv_strat, via_tvs) <- tcDerivStrategy mb_lderiv_strat+       ; traceTc "Deriving strategy (standalone deriving) 2" $+           vcat [ppr mb_lderiv_strat, ppr via_tvs]        ; (cls_tvs, deriv_ctxt, cls, inst_tys)            <- tcExtendTyVarEnv via_tvs $               tcStandaloneDerivInstType ctxt deriv_ty@@ -656,8 +641,8 @@                    mb_match     = tcUnifyTy inst_ty_kind via_kind                 checkTc (isJust mb_match)-                       (derivingViaKindErr cls inst_ty_kind-                                           via_ty via_kind)+                       (TcRnCannotDeriveInstance cls mempty Nothing NoGeneralizedNewtypeDeriving $+                          DerivErrDerivingViaWrongKind inst_ty_kind via_ty via_kind)                 let Just kind_subst = mb_match                    ki_subst_range  = getTCvSubstRangeFVs kind_subst@@ -737,11 +722,7 @@        pure (tvs, SupplyContext theta, cls, inst_tys)  warnUselessTypeable :: TcM ()-warnUselessTypeable-  = do { warn <- woptM Opt_WarnDerivingTypeable-       ; when warn $ addWarnTc (Reason Opt_WarnDerivingTypeable)-                   $ text "Deriving" <+> quotes (ppr typeableClassName) <+>-                     text "has no effect: all types now auto-derive Typeable" }+warnUselessTypeable = addDiagnosticTc TcRnUselessTypeable  ------------------------------------------------------------------ deriveTyData :: TyCon -> [Type] -- LHS of data or data instance@@ -777,7 +758,8 @@          -- Check that the result really is well-kinded         ; checkTc (enough_args && isJust mb_match)-                  (derivingKindErr tc cls cls_tys cls_arg_kind enough_args)+                  (TcRnCannotDeriveInstance cls cls_tys Nothing NoGeneralizedNewtypeDeriving $+                     DerivErrNotWellKinded tc cls_arg_kind n_args_to_keep)          ; let -- Returns a singleton-element list if using ViaStrategy and an               -- empty list otherwise. Useful for free-variable calculations.@@ -822,7 +804,8 @@                     via_match = tcUnifyTy inst_ty_kind via_kind                  checkTc (isJust via_match)-                        (derivingViaKindErr cls inst_ty_kind via_ty via_kind)+                        (TcRnCannotDeriveInstance cls mempty Nothing NoGeneralizedNewtypeDeriving $+                           DerivErrDerivingViaWrongKind inst_ty_kind via_ty via_kind)                  let Just via_subst = via_match                 pure $ propagate_subst via_subst tkvs' cls_tys'@@ -843,7 +826,8 @@         ; let final_tc_app   = mkTyConApp tc final_tc_args               final_cls_args = final_cls_tys ++ [final_tc_app]         ; checkTc (allDistinctTyVars (mkVarSet final_tkvs) args_to_drop) -- (a, b, c)-                  (derivingEtaErr cls final_cls_tys final_tc_app)+                  (TcRnCannotDeriveInstance cls final_cls_tys Nothing NoGeneralizedNewtypeDeriving $+                     DerivErrNoEtaReduce final_tc_app)                 -- Check that                 --  (a) The args to drop are all type variables; eg reject:                 --              data instance T a Int = .... deriving( Monad )@@ -1152,19 +1136,44 @@  mkEqnHelp overlap_mode tvs cls cls_args deriv_ctxt deriv_strat = do   is_boot <- tcIsHsBootOrSig-  when is_boot $-       bale_out (text "Cannot derive instances in hs-boot files"-             $+$ text "Write an instance declaration instead")+  when is_boot $ bale_out DerivErrBootFileFound++  let pred = mkClassPred cls cls_args+  skol_info <- mkSkolemInfo (DerivSkol pred)+  (tvs', cls_args', deriv_strat') <-+    skolemise_when_inferring_context skol_info deriv_ctxt+  let deriv_env = DerivEnv+                    { denv_overlap_mode = overlap_mode+                    , denv_tvs          = tvs'+                    , denv_cls          = cls+                    , denv_inst_tys     = cls_args'+                    , denv_ctxt         = deriv_ctxt+                    , denv_skol_info    = skol_info+                    , denv_strat        = deriv_strat' }   runReaderT mk_eqn deriv_env   where-    deriv_env = DerivEnv { denv_overlap_mode = overlap_mode-                         , denv_tvs          = tvs-                         , denv_cls          = cls-                         , denv_inst_tys     = cls_args-                         , denv_ctxt         = deriv_ctxt-                         , denv_strat        = deriv_strat }+    skolemise_when_inferring_context ::+         SkolemInfo -> DerivContext+      -> TcM ([TcTyVar], [TcType], Maybe (DerivStrategy GhcTc))+    skolemise_when_inferring_context skol_info deriv_ctxt =+      case deriv_ctxt of+        -- In order to infer an instance context, we must later make use of+        -- the constraint solving machinery, which expects TcTyVars rather+        -- than TyVars. We skolemise the type variables with non-overlappable+        -- (vanilla) skolems.+        -- See Note [Overlap and deriving] in GHC.Tc.Deriv.Infer.+        InferContext{} -> do+          (skol_subst, tvs') <- tcInstSkolTyVars skol_info tvs+          let cls_args'    = substTys skol_subst cls_args+              deriv_strat' = fmap (mapDerivStrategy (substTy skol_subst))+                                  deriv_strat+          pure (tvs', cls_args', deriv_strat')+        -- If the instance context is supplied, we don't need to skolemise+        -- at all.+        SupplyContext{} -> pure (tvs, cls_args, deriv_strat) -    bale_out msg = failWithTc $ derivingThingErr False cls cls_args deriv_strat msg+    bale_out =+      failWithTc . TcRnCannotDeriveInstance cls cls_args deriv_strat NoGeneralizedNewtypeDeriving      mk_eqn :: DerivM EarlyDerivSpec     mk_eqn = do@@ -1186,7 +1195,7 @@           (cls_tys, inst_ty) <- expectNonNullaryClsArgs cls_args           dit                <- expectAlgTyConApp cls_tys inst_ty           unless (isNewTyCon (dit_rep_tc dit)) $-            derivingThingFailWith False gndNonNewtypeErr+            derivingThingFailWith NoGeneralizedNewtypeDeriving DerivErrGNDUsedOnData           mkNewTypeEqn True dit          Nothing -> mk_eqn_no_strategy@@ -1198,7 +1207,7 @@ -- property is important. expectNonNullaryClsArgs :: [Type] -> DerivM ([Type], Type) expectNonNullaryClsArgs inst_tys =-  maybe (derivingThingFailWith False derivingNullaryErr) pure $+  maybe (derivingThingFailWith NoGeneralizedNewtypeDeriving DerivErrNullaryClasses) pure $   snocView inst_tys  -- @expectAlgTyConApp cls_tys inst_ty@ checks if @inst_ty@ is an application@@ -1215,9 +1224,7 @@ expectAlgTyConApp cls_tys inst_ty = do   fam_envs <- lift tcGetFamInstEnvs   case mk_deriv_inst_tys_maybe fam_envs cls_tys inst_ty of-    Nothing -> derivingThingFailWith False $-                   text "The last argument of the instance must be a"-               <+> text "data or newtype application"+    Nothing -> derivingThingFailWith NoGeneralizedNewtypeDeriving DerivErrLastArgMustBeApp     Just dit -> do expectNonDataFamTyCon dit                    pure dit @@ -1232,8 +1239,8 @@                                     , dit_rep_tc  = rep_tc }) =   -- If it's still a data family, the lookup failed; i.e no instance exists   when (isDataFamilyTyCon rep_tc) $-    derivingThingFailWith False $-    text "No family instance for" <+> quotes (pprTypeApp tc tc_args)+    derivingThingFailWith NoGeneralizedNewtypeDeriving $+      DerivErrNoFamilyInstance tc tc_args  mk_deriv_inst_tys_maybe :: FamInstEnvs                         -> [Type] -> Type -> Maybe DerivInstTys@@ -1245,11 +1252,13 @@       -- Find the instance of a data family       -- Note [Looking up family instances for deriving]       let (rep_tc, rep_tc_args, _co) = tcLookupDataFamInst fam_envs tc tc_args-      in DerivInstTys { dit_cls_tys     = cls_tys-                      , dit_tc          = tc-                      , dit_tc_args     = tc_args-                      , dit_rep_tc      = rep_tc-                      , dit_rep_tc_args = rep_tc_args }+          dc_inst_arg_env = buildDataConInstArgEnv rep_tc rep_tc_args+      in DerivInstTys { dit_cls_tys         = cls_tys+                      , dit_tc              = tc+                      , dit_tc_args         = tc_args+                      , dit_rep_tc          = rep_tc+                      , dit_rep_tc_args     = rep_tc_args+                      , dit_dc_inst_arg_env = dc_inst_arg_env }  {- Note [Looking up family instances for deriving]@@ -1325,22 +1334,26 @@                 , denv_tvs          = tvs                 , denv_cls          = cls                 , denv_inst_tys     = inst_tys-                , denv_ctxt         = deriv_ctxt } <- ask+                , denv_ctxt         = deriv_ctxt+                , denv_skol_info    = skol_info } <- ask+       user_ctxt <- askDerivUserTypeCtxt        doDerivInstErrorChecks1 mechanism        loc       <- lift getSrcSpanM        dfun_name <- lift $ newDFunName cls inst_tys loc        case deriv_ctxt of         InferContext wildcard ->-          do { (inferred_constraints, tvs', inst_tys')+          do { (inferred_constraints, tvs', inst_tys', mechanism')                  <- inferConstraints mechanism              ; return $ InferTheta $ DS                    { ds_loc = loc                    , ds_name = dfun_name, ds_tvs = tvs'                    , ds_cls = cls, ds_tys = inst_tys'                    , ds_theta = inferred_constraints+                   , ds_skol_info = skol_info+                   , ds_user_ctxt = user_ctxt                    , ds_overlap = overlap_mode                    , ds_standalone_wildcard = wildcard-                   , ds_mechanism = mechanism } }+                   , ds_mechanism = mechanism' } }          SupplyContext theta ->             return $ GivenTheta $ DS@@ -1348,32 +1361,40 @@                    , ds_name = dfun_name, ds_tvs = tvs                    , ds_cls = cls, ds_tys = inst_tys                    , ds_theta = theta+                   , ds_skol_info = skol_info+                   , ds_user_ctxt = user_ctxt                    , ds_overlap = overlap_mode                    , ds_standalone_wildcard = Nothing                    , ds_mechanism = mechanism }  mk_eqn_stock :: DerivInstTys -- Information about the arguments to the class              -> DerivM EarlyDerivSpec-mk_eqn_stock dit@(DerivInstTys { dit_cls_tys = cls_tys-                               , dit_tc      = tc-                               , dit_rep_tc  = rep_tc })-  = do DerivEnv { denv_cls  = cls-                , denv_ctxt = deriv_ctxt } <- ask-       dflags <- getDynFlags-       case checkOriginativeSideConditions dflags deriv_ctxt cls cls_tys-                                           tc rep_tc of-         CanDeriveStock gen_fn -> mk_eqn_from_mechanism $-                                  DerivSpecStock { dsm_stock_dit    = dit-                                                 , dsm_stock_gen_fn = gen_fn }-         StockClassError msg   -> derivingThingFailWith False msg-         _                     -> derivingThingFailWith False (nonStdErr cls)+mk_eqn_stock dit+  = do dflags <- getDynFlags+       let isDeriveAnyClassEnabled =+             deriveAnyClassEnabled (xopt LangExt.DeriveAnyClass dflags)+       checkOriginativeSideConditions dit >>= \case+         CanDeriveStock gen_fns -> mk_eqn_from_mechanism $+                                   DerivSpecStock { dsm_stock_dit     = dit+                                                  , dsm_stock_gen_fns = gen_fns }+         StockClassError why    -> derivingThingFailWith NoGeneralizedNewtypeDeriving why+         CanDeriveAnyClass      -> derivingThingFailWith NoGeneralizedNewtypeDeriving+                                     (DerivErrNotStockDeriveable isDeriveAnyClassEnabled)+         -- In the 'NonDerivableClass' case we can't derive with either stock or anyclass+         -- so we /don't want/ to suggest the user to enabled 'DeriveAnyClass', that's+         -- why we pass 'YesDeriveAnyClassEnabled', so that GHC won't attempt to suggest it.+         NonDerivableClass      -> derivingThingFailWith NoGeneralizedNewtypeDeriving+                                     (DerivErrNotStockDeriveable YesDeriveAnyClassEnabled)  mk_eqn_anyclass :: DerivM EarlyDerivSpec mk_eqn_anyclass   = do dflags <- getDynFlags-       case canDeriveAnyClass dflags of-         IsValid      -> mk_eqn_from_mechanism DerivSpecAnyClass-         NotValid msg -> derivingThingFailWith False msg+       let isDeriveAnyClassEnabled =+             deriveAnyClassEnabled (xopt LangExt.DeriveAnyClass dflags)+       case xopt LangExt.DeriveAnyClass dflags of+         True  -> mk_eqn_from_mechanism DerivSpecAnyClass+         False -> derivingThingFailWith NoGeneralizedNewtypeDeriving+                                        (DerivErrNotDeriveable isDeriveAnyClassEnabled)  mk_eqn_newtype :: DerivInstTys -- Information about the arguments to the class                -> Type         -- The newtype's representation type@@ -1424,30 +1445,26 @@     -- Use heuristics (checkOriginativeSideConditions) to determine whether     -- stock or anyclass deriving should be used.     mk_eqn_originative :: DerivInstTys -> DerivM EarlyDerivSpec-    mk_eqn_originative dit@(DerivInstTys { dit_cls_tys = cls_tys-                                         , dit_tc      = tc-                                         , dit_rep_tc  = rep_tc }) = do-      DerivEnv { denv_cls  = cls-               , denv_ctxt = deriv_ctxt } <- ask+    mk_eqn_originative dit@(DerivInstTys { dit_tc     = tc+                                         , dit_rep_tc = rep_tc }) = do       dflags <- getDynFlags+      let isDeriveAnyClassEnabled =+            deriveAnyClassEnabled (xopt LangExt.DeriveAnyClass dflags)        -- See Note [Deriving instances for classes themselves]-      let dac_error msg+      let dac_error             | isClassTyCon rep_tc-            = quotes (ppr tc) <+> text "is a type class,"-                              <+> text "and can only have a derived instance"-                              $+$ text "if DeriveAnyClass is enabled"+            = DerivErrOnlyAnyClassDeriveable tc isDeriveAnyClassEnabled             | otherwise-            = nonStdErr cls $$ msg+            = DerivErrNotStockDeriveable isDeriveAnyClassEnabled -      case checkOriginativeSideConditions dflags deriv_ctxt cls-             cls_tys tc rep_tc of-        NonDerivableClass   msg -> derivingThingFailWith False (dac_error msg)-        StockClassError msg     -> derivingThingFailWith False msg-        CanDeriveStock gen_fn   -> mk_eqn_from_mechanism $-                                   DerivSpecStock { dsm_stock_dit    = dit-                                                  , dsm_stock_gen_fn = gen_fn }-        CanDeriveAnyClass       -> mk_eqn_from_mechanism DerivSpecAnyClass+      checkOriginativeSideConditions dit >>= \case+        NonDerivableClass      -> derivingThingFailWith NoGeneralizedNewtypeDeriving dac_error+        StockClassError why    -> derivingThingFailWith NoGeneralizedNewtypeDeriving why+        CanDeriveStock gen_fns -> mk_eqn_from_mechanism $+                                  DerivSpecStock { dsm_stock_dit     = dit+                                                 , dsm_stock_gen_fns = gen_fns }+        CanDeriveAnyClass      -> mk_eqn_from_mechanism DerivSpecAnyClass  {- ************************************************************************@@ -1469,22 +1486,16 @@                      -- deriving strategy?              -> DerivInstTys -> DerivM EarlyDerivSpec mkNewTypeEqn newtype_strat dit@(DerivInstTys { dit_cls_tys     = cls_tys-                                             , dit_tc          = tycon                                              , dit_rep_tc      = rep_tycon                                              , dit_rep_tc_args = rep_tc_args }) -- Want: instance (...) => cls (cls_tys ++ [tycon tc_args]) where ...-  = do DerivEnv { denv_cls   = cls-                , denv_ctxt  = deriv_ctxt } <- ask+  = do DerivEnv{denv_cls = cls} <- ask        dflags <- getDynFlags         let newtype_deriving  = xopt LangExt.GeneralizedNewtypeDeriving dflags            deriveAnyClass    = xopt LangExt.DeriveAnyClass             dflags -           bale_out = derivingThingFailWith newtype_deriving--           non_std     = nonStdErr cls-           suggest_gnd = text "Try GeneralizedNewtypeDeriving for GHC's"-                     <+> text "newtype-deriving extension"+           bale_out = derivingThingFailWith (usingGeneralizedNewtypeDeriving newtype_deriving)             -- Here is the plan for newtype derivings.  We see            --        newtype T a1...an = MkT (t ak+1...an)@@ -1553,10 +1564,7 @@              --     And the [a] must not mention 'b'.  That's all handled              --     by nt_eta_rity. -           cant_derive_err = ppUnless eta_ok  eta_msg-           eta_msg = text "cannot eta-reduce the representation type enough"--       MASSERT( cls_tys `lengthIs` (classArity cls - 1) )+       massert (cls_tys `lengthIs` (classArity cls - 1))        if newtype_strat        then            -- Since the user explicitly asked for GeneralizedNewtypeDeriving,@@ -1567,16 +1575,14 @@            -- See Note [Determining whether newtype-deriving is appropriate]            if eta_ok && newtype_deriving              then mk_eqn_newtype dit rep_inst_ty-             else bale_out (cant_derive_err $$-                            if newtype_deriving then empty else suggest_gnd)+             else bale_out (DerivErrCannotEtaReduceEnough eta_ok)        else          if might_be_newtype_derivable              && ((newtype_deriving && not deriveAnyClass)                   || std_class_via_coercible cls)          then mk_eqn_newtype dit rep_inst_ty-         else case checkOriginativeSideConditions dflags deriv_ctxt cls cls_tys-                                                 tycon rep_tycon of-               StockClassError msg+         else checkOriginativeSideConditions dit >>= \case+               StockClassError why                  -- There's a particular corner case where                  --                  -- 1. -XGeneralizedNewtypeDeriving and -XDeriveAnyClass are@@ -1590,18 +1596,18 @@                 -> mk_eqn_newtype dit rep_inst_ty                  -- Otherwise, throw an error for a stock class                  | might_be_newtype_derivable && not newtype_deriving-                -> bale_out (msg $$ suggest_gnd)+                -> bale_out why                  | otherwise-                -> bale_out msg+                -> bale_out why                 -- Must use newtype deriving or DeriveAnyClass-               NonDerivableClass _msg+               NonDerivableClass                  -- Too hard, even with newtype deriving-                 | newtype_deriving           -> bale_out cant_derive_err+                 | newtype_deriving           -> bale_out (DerivErrCannotEtaReduceEnough eta_ok)                  -- Try newtype deriving!                  -- Here we suggest GeneralizedNewtypeDeriving even in cases                  -- where it may not be applicable. See #9600.-                 | otherwise                  -> bale_out (non_std $$ suggest_gnd)+                 | otherwise                  -> bale_out DerivErrNewtypeNonDeriveableClass                 -- DeriveAnyClass                CanDeriveAnyClass -> do@@ -1610,20 +1616,13 @@                  -- DeriveAnyClass, but emitting a warning about the choice.                  -- See Note [Deriving strategies]                  when (newtype_deriving && deriveAnyClass) $-                   lift $ whenWOptM Opt_WarnDerivingDefaults $-                     addWarnTc (Reason Opt_WarnDerivingDefaults) $ sep-                     [ text "Both DeriveAnyClass and"-                       <+> text "GeneralizedNewtypeDeriving are enabled"-                     , text "Defaulting to the DeriveAnyClass strategy"-                       <+> text "for instantiating" <+> ppr cls-                     , text "Use DerivingStrategies to pick"-                       <+> text "a different strategy"-                      ]+                   lift $ addDiagnosticTc+                        $ TcRnDerivingDefaults cls                  mk_eqn_from_mechanism DerivSpecAnyClass                -- CanDeriveStock-               CanDeriveStock gen_fn -> mk_eqn_from_mechanism $-                                        DerivSpecStock { dsm_stock_dit    = dit-                                                       , dsm_stock_gen_fn = gen_fn }+               CanDeriveStock gen_fns -> mk_eqn_from_mechanism $+                                         DerivSpecStock { dsm_stock_dit     = dit+                                                        , dsm_stock_gen_fns = gen_fns }  {- Note [Recursive newtypes]@@ -1830,32 +1829,31 @@ \end{itemize} -} --- Generate the InstInfo for the required instance--- plus any auxiliary bindings required-genInst :: DerivSpec theta-        -> TcM (ThetaType -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])--- We must use continuation-returning style here to get the order in which we--- typecheck family instances and derived instances right.--- See Note [Staging of tcDeriving]-genInst spec@(DS { ds_tvs = tvs, ds_mechanism = mechanism-                 , ds_tys = tys, ds_cls = clas, ds_loc = loc-                 , ds_standalone_wildcard = wildcard })-  = do (meth_binds, meth_sigs, deriv_stuff, unusedNames)-         <- set_span_and_ctxt $-            genDerivStuff mechanism loc clas tys tvs-       let mk_inst_info theta = set_span_and_ctxt $ do-             inst_spec <- newDerivClsInst theta spec-             doDerivInstErrorChecks2 clas inst_spec theta wildcard mechanism-             traceTc "newder" (ppr inst_spec)-             return $ InstInfo-                       { iSpec   = inst_spec-                       , iBinds  = InstBindings-                                     { ib_binds = meth_binds-                                     , ib_tyvars = map Var.varName tvs-                                     , ib_pragmas = meth_sigs-                                     , ib_extensions = extensions-                                     , ib_derived = True } }-       return (mk_inst_info, deriv_stuff, unusedNames)+-- | Generate the 'InstInfo' for the required instance,+-- plus any auxiliary bindings required (see @Note [Auxiliary binders]@ in+-- "GHC.Tc.Deriv.Generate") and any additional free variables+-- that should be marked (see @Note [Deriving and unused record selectors]@+-- in "GHC.Tc.Deriv.Utils").+genInstBinds :: DerivSpec ThetaType+             -> TcM (InstInfo GhcPs, Bag AuxBindSpec, [Name])+genInstBinds spec@(DS { ds_tvs = tyvars, ds_mechanism = mechanism+                      , ds_tys = inst_tys, ds_theta = theta, ds_cls = clas+                      , ds_loc = loc, ds_standalone_wildcard = wildcard })+  = set_spec_span_and_ctxt spec $+    do (meth_binds, meth_sigs, aux_specs, unusedNames) <- gen_inst_binds+       inst_spec <- newDerivClsInst spec+       doDerivInstErrorChecks2 clas inst_spec theta wildcard mechanism+       traceTc "newder" (ppr inst_spec)+       let inst_info =+             InstInfo+               { iSpec   = inst_spec+               , iBinds  = InstBindings+                             { ib_binds = meth_binds+                             , ib_tyvars = map Var.varName tyvars+                             , ib_pragmas = meth_sigs+                             , ib_extensions = extensions+                             , ib_derived = True } }+       return (inst_info, aux_specs, unusedNames)   where     extensions :: [LangExt.Extension]     extensions@@ -1867,13 +1865,83 @@           -- that bring type variables into scope.           -- See Note [Newtype-deriving instances] in GHC.Tc.Deriv.Generate         , LangExt.InstanceSigs+          -- Skip unboxed tuples checking for derived instances when imported+          -- in a different module, see #20524+        , LangExt.UnboxedTuples         ]       | otherwise       = [] -    set_span_and_ctxt :: TcM a -> TcM a-    set_span_and_ctxt = setSrcSpan loc . addErrCtxt (instDeclCtxt3 clas tys)+    gen_inst_binds :: TcM (LHsBinds GhcPs, [LSig GhcPs], Bag AuxBindSpec, [Name])+    gen_inst_binds+      = case mechanism of+          -- See Note [Bindings for Generalised Newtype Deriving]+          DerivSpecNewtype { dsm_newtype_rep_ty = rhs_ty}+            -> gen_newtype_or_via rhs_ty +          -- Try a stock deriver+          DerivSpecStock { dsm_stock_dit = dit+                         , dsm_stock_gen_fns =+                             StockGenFns { stock_gen_binds = gen_fn } }+            -> gen_fn loc dit++          -- Try DeriveAnyClass+          DerivSpecAnyClass+            -> return (emptyBag, [], emptyBag, [])+               -- No method bindings, signatures, auxiliary bindings or free+               -- variable names are needed. The only interesting work happens when+               -- defaulting associated type family instances (see the+               -- DeriveSpecAnyClass case in genFamInsts below).++          -- Try DerivingVia+          DerivSpecVia{dsm_via_ty = via_ty}+            -> gen_newtype_or_via via_ty++    gen_newtype_or_via ty = do+      let (binds, sigs) = gen_Newtype_binds loc clas tyvars inst_tys ty+      return (binds, sigs, emptyBag, [])++-- | Generate the associated type family instances for a derived instance.+genFamInsts :: DerivSpec theta -> TcM [FamInst]+genFamInsts spec@(DS { ds_tvs = tyvars, ds_mechanism = mechanism+                     , ds_tys = inst_tys, ds_cls = clas, ds_loc = loc })+  = set_spec_span_and_ctxt spec $+    case mechanism of+      -- See Note [GND and associated type families]+      DerivSpecNewtype { dsm_newtype_rep_ty = rhs_ty}+        -> gen_newtype_or_via rhs_ty++      -- Try a stock deriver+      DerivSpecStock { dsm_stock_dit = dit+                     , dsm_stock_gen_fns =+                         StockGenFns { stock_gen_fam_insts = gen_fn } }+        -> gen_fn loc dit++      -- See Note [DeriveAnyClass and default family instances]+      DerivSpecAnyClass -> do+        let mini_env   = mkVarEnv (classTyVars clas `zip` inst_tys)+            mini_subst = mkTvSubst (mkInScopeSet (mkVarSet tyvars)) mini_env+        dflags <- getDynFlags+        tyfam_insts <-+          -- canDeriveAnyClass should ensure that this code can't be reached+          -- unless -XDeriveAnyClass is enabled.+          assertPpr (xopt LangExt.DeriveAnyClass dflags)+                    (ppr "genFamInsts: bad derived class" <+> ppr clas) $+          mapM (tcATDefault loc mini_subst emptyNameSet)+               (classATItems clas)+        pure $ concat tyfam_insts++      -- Try DerivingVia+      DerivSpecVia{dsm_via_ty = via_ty}+        -> gen_newtype_or_via via_ty+  where+    gen_newtype_or_via ty = gen_Newtype_fam_insts loc clas tyvars inst_tys ty++-- Set the SrcSpan and error context for an action that uses a DerivSpec.+set_spec_span_and_ctxt :: DerivSpec theta -> TcM a -> TcM a+set_spec_span_and_ctxt (DS{ ds_loc = loc, ds_cls = clas, ds_tys = tys }) =+  setSrcSpan loc . addErrCtxt (instDeclCtxt3 clas tys)+ -- Checks: -- -- * All of the data constructors for a data type are in scope for a@@ -1927,7 +1995,7 @@         lift $ addUsedDataCons rdr_env rep_tc          unless (not hidden_data_cons) $-          bale_out $ derivingHiddenErr tc+          bale_out $ DerivErrDataConsNotAllInScope tc      -- Ensure that a class's associated type variables are suitable for     -- GeneralizedNewtypeDeriving or DerivingVia. Unsurprisingly, this check is@@ -1963,27 +2031,15 @@           at_last_cls_tv_in_kind kind             = last_cls_tv `elemVarSet` exactTyCoVarsOfType kind           at_tcs = classATs cls-          last_cls_tv = ASSERT( notNull cls_tyvars )+          last_cls_tv = assert (notNull cls_tyvars )                         last cls_tyvars -          cant_derive_err-             = vcat [ ppUnless no_adfs adfs_msg-                    , maybe empty at_without_last_cls_tv_msg-                            at_without_last_cls_tv-                    , maybe empty at_last_cls_tv_in_kinds_msg-                            at_last_cls_tv_in_kinds-                    ]-          adfs_msg  = text "the class has associated data types"-          at_without_last_cls_tv_msg at_tc = hang-            (text "the associated type" <+> quotes (ppr at_tc)-             <+> text "is not parameterized over the last type variable")-            2 (text "of the class" <+> quotes (ppr cls))-          at_last_cls_tv_in_kinds_msg at_tc = hang-            (text "the associated type" <+> quotes (ppr at_tc)-             <+> text "contains the last type variable")-           2 (text "of the class" <+> quotes (ppr cls)-             <+> text "in a kind, which is not (yet) allowed")-      unless ats_look_sensible $ bale_out cant_derive_err+      unless ats_look_sensible $+        bale_out (DerivErrHasAssociatedDatatypes+                   (hasAssociatedDataFamInsts (not no_adfs))+                   (associatedTyLastVarInKind at_last_cls_tv_in_kinds)+                   (associatedTyNotParamOverLastTyVar at_without_last_cls_tv)+                 )  doDerivInstErrorChecks2 :: Class -> ClsInst -> ThetaType -> Maybe SrcSpan                         -> DerivSpecMechanism -> TcM ()@@ -2000,82 +2056,33 @@        ; case wildcard of            Nothing -> pure ()            Just span -> setSrcSpan span $ do-             checkTc xpartial_sigs (hang partial_sig_msg 2 pts_suggestion)-             warnTc (Reason Opt_WarnPartialTypeSignatures)-                    wpartial_sigs partial_sig_msg+             let suggParSigs = suggestPartialTypeSignatures xpartial_sigs+             let dia = TcRnPartialTypeSignatures suggParSigs theta+             checkTc xpartial_sigs dia+             diagnosticTc wpartial_sigs dia           -- Check for Generic instances that are derived with an exotic          -- deriving strategy like DAC          -- See Note [Deriving strategies]        ; when (exotic_mechanism && className clas `elem` genericClassNames) $-         do { failIfTc (safeLanguageOn dflags) gen_inst_err-            ; when (safeInferOn dflags) (recordUnsafeInfer emptyBag) } }+         do { failIfTc (safeLanguageOn dflags)+                       (TcRnCannotDeriveInstance clas mempty Nothing NoGeneralizedNewtypeDeriving $+                          DerivErrSafeHaskellGenericInst)+            ; when (safeInferOn dflags) (recordUnsafeInfer emptyMessages) } }   where     exotic_mechanism = not $ isDerivSpecStock mechanism -    partial_sig_msg = text "Found type wildcard" <+> quotes (char '_')-                  <+> text "standing for" <+> quotes (pprTheta theta)--    pts_suggestion-      = text "To use the inferred type, enable PartialTypeSignatures"--    gen_inst_err = text "Generic instances can only be derived in"-               <+> text "Safe Haskell using the stock strategy."--derivingThingFailWith :: Bool -- If True, add a snippet about how not even-                              -- GeneralizedNewtypeDeriving would make this-                              -- declaration work. This only kicks in when-                              -- an explicit deriving strategy is not given.-                      -> SDoc -- The error message+derivingThingFailWith :: UsingGeneralizedNewtypeDeriving+                         -- ^ If 'YesGeneralizedNewtypeDeriving', add a snippet about+                         -- how not even GeneralizedNewtypeDeriving would make this+                         -- declaration work. This only kicks in when+                         -- an explicit deriving strategy is not given.+                      -> DeriveInstanceErrReason -- The reason the derivation failed                       -> DerivM a derivingThingFailWith newtype_deriving msg = do   err <- derivingThingErrM newtype_deriving msg   lift $ failWithTc err -genDerivStuff :: DerivSpecMechanism -> SrcSpan -> Class-              -> [Type] -> [TyVar]-              -> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff, [Name])-genDerivStuff mechanism loc clas inst_tys tyvars-  = case mechanism of-      -- See Note [Bindings for Generalised Newtype Deriving]-      DerivSpecNewtype { dsm_newtype_rep_ty = rhs_ty}-        -> gen_newtype_or_via rhs_ty--      -- Try a stock deriver-      DerivSpecStock { dsm_stock_dit    = DerivInstTys-                        { dit_rep_tc = rep_tc-                        , dit_rep_tc_args = rep_tc_args-                        }-                     , dsm_stock_gen_fn = gen_fn }-        -> gen_fn loc rep_tc rep_tc_args inst_tys--      -- Try DeriveAnyClass-      DerivSpecAnyClass -> do-        let mini_env   = mkVarEnv (classTyVars clas `zip` inst_tys)-            mini_subst = mkTvSubst (mkInScopeSet (mkVarSet tyvars)) mini_env-        dflags <- getDynFlags-        tyfam_insts <--          -- canDeriveAnyClass should ensure that this code can't be reached-          -- unless -XDeriveAnyClass is enabled.-          ASSERT2( isValid (canDeriveAnyClass dflags)-                 , ppr "genDerivStuff: bad derived class" <+> ppr clas )-          mapM (tcATDefault loc mini_subst emptyNameSet)-               (classATItems clas)-        return ( emptyBag, [] -- No method bindings are needed...-               , listToBag (map DerivFamInst (concat tyfam_insts))-               -- ...but we may need to generate binding for associated type-               -- family default instances.-               -- See Note [DeriveAnyClass and default family instances]-               , [] )--      -- Try DerivingVia-      DerivSpecVia{dsm_via_ty = via_ty}-        -> gen_newtype_or_via via_ty-  where-    gen_newtype_or_via ty = do-      (binds, sigs, faminsts) <- gen_Newtype_binds loc clas tyvars inst_tys ty-      return (binds, sigs, faminsts, [])- {- Note [Bindings for Generalised Newtype Deriving] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -2089,7 +2096,7 @@   instance (C [a], Eq a) => C (N a) where      f = coerce (f :: [a] -> [a]) -This generates a cast for each method, but allows the superclasse to+This generates a cast for each method, but allows the superclasses to be worked out in the usual way.  In this case the superclass (Eq (N a)) will be solved by the explicit Eq (N a) instance.  We do *not* create the superclasses by casting the superclass dictionaries for the@@ -2208,95 +2215,26 @@ ************************************************************************ -} -nonUnaryErr :: LHsSigType GhcRn -> SDoc-nonUnaryErr ct = quotes (ppr ct)-  <+> text "is not a unary constraint, as expected by a deriving clause"--nonStdErr :: Class -> SDoc-nonStdErr cls =-      quotes (ppr cls)-  <+> text "is not a stock derivable class (Eq, Show, etc.)"--gndNonNewtypeErr :: SDoc-gndNonNewtypeErr =-  text "GeneralizedNewtypeDeriving cannot be used on non-newtypes"--derivingNullaryErr :: SDoc-derivingNullaryErr = text "Cannot derive instances for nullary classes"--derivingKindErr :: TyCon -> Class -> [Type] -> Kind -> Bool -> SDoc-derivingKindErr tc cls cls_tys cls_kind enough_args-  = sep [ hang (text "Cannot derive well-kinded instance of form"-                      <+> quotes (pprClassPred cls cls_tys-                                    <+> parens (ppr tc <+> text "...")))-               2 gen1_suggestion-        , nest 2 (text "Class" <+> quotes (ppr cls)-                      <+> text "expects an argument of kind"-                      <+> quotes (pprKind cls_kind))-        ]-  where-    gen1_suggestion | cls `hasKey` gen1ClassKey && enough_args-                    = text "(Perhaps you intended to use PolyKinds)"-                    | otherwise = Outputable.empty--derivingViaKindErr :: Class -> Kind -> Type -> Kind -> SDoc-derivingViaKindErr cls cls_kind via_ty via_kind-  = hang (text "Cannot derive instance via" <+> quotes (pprType via_ty))-       2 (text "Class" <+> quotes (ppr cls)-               <+> text "expects an argument of kind"-               <+> quotes (pprKind cls_kind) <> char ','-      $+$ text "but" <+> quotes (pprType via_ty)-               <+> text "has kind" <+> quotes (pprKind via_kind))--derivingEtaErr :: Class -> [Type] -> Type -> SDoc-derivingEtaErr cls cls_tys inst_ty-  = sep [text "Cannot eta-reduce to an instance of form",-         nest 2 (text "instance (...) =>"-                <+> pprClassPred cls (cls_tys ++ [inst_ty]))]--derivingThingErr :: Bool -> Class -> [Type]-                 -> Maybe (DerivStrategy GhcTc) -> SDoc -> SDoc-derivingThingErr newtype_deriving cls cls_args mb_strat why-  = derivingThingErr' newtype_deriving cls cls_args mb_strat-                      (maybe empty derivStrategyName mb_strat) why--derivingThingErrM :: Bool -> SDoc -> DerivM SDoc+derivingThingErrM :: UsingGeneralizedNewtypeDeriving+                  -> DeriveInstanceErrReason+                  -> DerivM TcRnMessage derivingThingErrM newtype_deriving why   = do DerivEnv { denv_cls      = cls                 , denv_inst_tys = cls_args                 , denv_strat    = mb_strat } <- ask-       pure $ derivingThingErr newtype_deriving cls cls_args mb_strat why+       pure $ TcRnCannotDeriveInstance cls cls_args mb_strat newtype_deriving why -derivingThingErrMechanism :: DerivSpecMechanism -> SDoc -> DerivM SDoc+derivingThingErrMechanism :: DerivSpecMechanism -> DeriveInstanceErrReason -> DerivM TcRnMessage derivingThingErrMechanism mechanism why   = do DerivEnv { denv_cls      = cls                 , denv_inst_tys = cls_args                 , denv_strat    = mb_strat } <- ask-       pure $ derivingThingErr' (isDerivSpecNewtype mechanism) cls cls_args mb_strat-                (derivStrategyName $ derivSpecMechanismToStrategy mechanism) why--derivingThingErr' :: Bool -> Class -> [Type]-                  -> Maybe (DerivStrategy GhcTc) -> SDoc -> SDoc -> SDoc-derivingThingErr' newtype_deriving cls cls_args mb_strat strat_msg why-  = sep [(hang (text "Can't make a derived instance of")-             2 (quotes (ppr pred) <+> via_mechanism)-          $$ nest 2 extra) <> colon,-         nest 2 why]+       pure $ TcRnCannotDeriveInstance cls cls_args mb_strat newtype_deriving why   where-    strat_used = isJust mb_strat-    extra | not strat_used, newtype_deriving-          = text "(even with cunning GeneralizedNewtypeDeriving)"-          | otherwise = empty-    pred = mkClassPred cls cls_args-    via_mechanism | strat_used-                  = text "with the" <+> strat_msg <+> text "strategy"-                  | otherwise-                  = empty--derivingHiddenErr :: TyCon -> SDoc-derivingHiddenErr tc-  = hang (text "The data constructors of" <+> quotes (ppr tc) <+> ptext (sLit "are not all in scope"))-       2 (text "so you cannot derive an instance for it")+    newtype_deriving :: UsingGeneralizedNewtypeDeriving+    newtype_deriving+      = if isDerivSpecNewtype mechanism then YesGeneralizedNewtypeDeriving+                                        else NoGeneralizedNewtypeDeriving  standaloneCtxt :: LHsSigWcType GhcRn -> SDoc standaloneCtxt ty = hang (text "In the stand-alone deriving instance for")
GHC/Tc/Deriv/Functor.hs view
@@ -3,7 +3,7 @@  -} -{-# LANGUAGE CPP #-}+ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-}@@ -22,8 +22,6 @@    ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Data.Bag@@ -34,7 +32,7 @@ import GHC.Builtin.Names import GHC.Types.Name.Reader import GHC.Types.SrcLoc-import GHC.Utils.Monad.State+import GHC.Utils.Monad.State.Strict import GHC.Tc.Deriv.Generate import GHC.Tc.Utils.TcType import GHC.Core.TyCon@@ -151,10 +149,10 @@   $(coreplace 'a '(tb -> tc) x) = \(y:tb[b/a]) -> $(coreplace 'a' 'tc' (x $(replace 'a 'tb y))) -} -gen_Functor_binds :: SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff)+gen_Functor_binds :: SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, Bag AuxBindSpec) -- When the argument is phantom, we can use  fmap _ = coerce -- See Note [Phantom types with Functor, Foldable, and Traversable]-gen_Functor_binds loc tycon _+gen_Functor_binds loc (DerivInstTys{dit_rep_tc = tycon})   | Phantom <- last (tyConRoles tycon)   = (unitBag fmap_bind, emptyBag)   where@@ -165,7 +163,8 @@                                coerce_Expr]     fmap_match_ctxt = mkPrefixFunRhs fmap_name -gen_Functor_binds loc tycon tycon_args+gen_Functor_binds loc dit@(DerivInstTys{ dit_rep_tc = tycon+                                       , dit_rep_tc_args = tycon_args })   = (listToBag [fmap_bind, replace_bind], emptyBag)   where     data_cons = getPossibleDataCons tycon tycon_args@@ -178,7 +177,7 @@     fmap_eqn con = flip evalState bs_RDRs $                      match_for_con fmap_match_ctxt [f_Pat] con parts       where-        parts = foldDataConArgs ft_fmap con+        parts = foldDataConArgs ft_fmap con dit      fmap_eqns = map fmap_eqn data_cons @@ -217,7 +216,7 @@     replace_eqn con = flip evalState bs_RDRs $         match_for_con replace_match_ctxt [z_Pat] con parts       where-        parts = foldDataConArgs ft_replace con+        parts = foldDataConArgs ft_replace con dit      replace_eqns = map replace_eqn data_cons @@ -554,10 +553,10 @@             , ft_forall = \v xs -> filterOut ((v `elemVarSet`) . tyCoVarsOfType) xs })  -foldDataConArgs :: FFoldType a -> DataCon -> [a]+foldDataConArgs :: FFoldType a -> DataCon -> DerivInstTys -> [a] -- Fold over the arguments of the datacon-foldDataConArgs ft con-  = map foldArg (map scaledThing $ dataConOrigArgTys con)+foldDataConArgs ft con dit+  = map foldArg (derivDataConInstArgTys con dit)   where     foldArg       = case getTyVar_maybe (last (tyConAppArgs (dataConOrigResTy con))) of@@ -785,10 +784,10 @@ think it's okay to do it for now. -} -gen_Foldable_binds :: SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff)+gen_Foldable_binds :: SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, Bag AuxBindSpec) -- When the parameter is phantom, we can use foldMap _ _ = mempty -- See Note [Phantom types with Functor, Foldable, and Traversable]-gen_Foldable_binds loc tycon _+gen_Foldable_binds loc (DerivInstTys{dit_rep_tc = tycon})   | Phantom <- last (tyConRoles tycon)   = (unitBag foldMap_bind, emptyBag)   where@@ -799,7 +798,8 @@                                   mempty_Expr]     foldMap_match_ctxt = mkPrefixFunRhs foldMap_name -gen_Foldable_binds loc tycon tycon_args+gen_Foldable_binds loc dit@(DerivInstTys{ dit_rep_tc = tycon+                                        , dit_rep_tc_args = tycon_args })   | null data_cons  -- There's no real point producing anything but                     -- foldMap for a type with no constructors.   = (unitBag foldMap_bind, emptyBag)@@ -809,12 +809,15 @@   where     data_cons = getPossibleDataCons tycon tycon_args +    foldr_name = L (noAnnSrcSpan loc) foldable_foldr_RDR+     foldr_bind = mkRdrFunBind (L (noAnnSrcSpan loc) foldable_foldr_RDR) eqns     eqns = map foldr_eqn data_cons     foldr_eqn con       = evalState (match_foldr z_Expr [f_Pat,z_Pat] con =<< parts) bs_RDRs       where-        parts = sequence $ foldDataConArgs ft_foldr con+        parts = sequence $ foldDataConArgs ft_foldr con dit+    foldr_match_ctxt = mkPrefixFunRhs foldr_name      foldMap_name = L (noAnnSrcSpan loc) foldMap_RDR @@ -827,7 +830,8 @@     foldMap_eqn con       = evalState (match_foldMap [f_Pat] con =<< parts) bs_RDRs       where-        parts = sequence $ foldDataConArgs ft_foldMap con+        parts = sequence $ foldDataConArgs ft_foldMap con dit+    foldMap_match_ctxt = mkPrefixFunRhs foldMap_name      -- Given a list of NullM results, produce Nothing if any of     -- them is NotNull, and otherwise produce a list of Maybes@@ -845,7 +849,7 @@     null_eqns = map null_eqn data_cons     null_eqn con       = flip evalState bs_RDRs $ do-          parts <- sequence $ foldDataConArgs ft_null con+          parts <- sequence $ foldDataConArgs ft_null con dit           case convert parts of             Nothing -> return $               mkMatch null_match_ctxt [nlParPat (nlWildConPat con)]@@ -883,7 +887,7 @@                 -> DataCon                 -> [Maybe (LHsExpr GhcPs)]                 -> m (LMatch GhcPs (LHsExpr GhcPs))-    match_foldr z = mkSimpleConMatch2 LambdaExpr $ \_ xs -> return (mkFoldr xs)+    match_foldr z = mkSimpleConMatch2 foldr_match_ctxt $ \_ xs -> return (mkFoldr xs)       where         -- g1 v1 (g2 v2 (.. z))         mkFoldr :: [LHsExpr GhcPs] -> LHsExpr GhcPs@@ -913,7 +917,7 @@                   -> DataCon                   -> [Maybe (LHsExpr GhcPs)]                   -> m (LMatch GhcPs (LHsExpr GhcPs))-    match_foldMap = mkSimpleConMatch2 CaseAlt $ \_ xs -> return (mkFoldMap xs)+    match_foldMap = mkSimpleConMatch2 foldMap_match_ctxt $ \_ xs -> return (mkFoldMap xs)       where         -- mappend v1 (mappend v2 ..)         mkFoldMap :: [LHsExpr GhcPs] -> LHsExpr GhcPs@@ -1014,10 +1018,10 @@ See Note [Generated code for DeriveFoldable and DeriveTraversable]. -} -gen_Traversable_binds :: SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff)+gen_Traversable_binds :: SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, Bag AuxBindSpec) -- When the argument is phantom, we can use traverse = pure . coerce -- See Note [Phantom types with Functor, Foldable, and Traversable]-gen_Traversable_binds loc tycon _+gen_Traversable_binds loc (DerivInstTys{dit_rep_tc = tycon})   | Phantom <- last (tyConRoles tycon)   = (unitBag traverse_bind, emptyBag)   where@@ -1029,7 +1033,8 @@                        (nlHsApps pure_RDR [nlHsApp coerce_Expr z_Expr])]     traverse_match_ctxt = mkPrefixFunRhs traverse_name -gen_Traversable_binds loc tycon tycon_args+gen_Traversable_binds loc dit@(DerivInstTys{ dit_rep_tc = tycon+                                           , dit_rep_tc_args = tycon_args })   = (unitBag traverse_bind, emptyBag)   where     data_cons = getPossibleDataCons tycon tycon_args@@ -1043,7 +1048,8 @@     traverse_eqn con       = evalState (match_for_con [f_Pat] con =<< parts) bs_RDRs       where-        parts = sequence $ foldDataConArgs ft_trav con+        parts = sequence $ foldDataConArgs ft_trav con dit+    traverse_match_ctxt = mkPrefixFunRhs traverse_name      -- Yields 'Just' an expression if we're folding over a type that mentions     -- the last type parameter of the datatype. Otherwise, yields 'Nothing'.@@ -1074,7 +1080,7 @@                   -> DataCon                   -> [Maybe (LHsExpr GhcPs)]                   -> m (LMatch GhcPs (LHsExpr GhcPs))-    match_for_con = mkSimpleConMatch2 CaseAlt $+    match_for_con = mkSimpleConMatch2 traverse_match_ctxt $                                              \con xs -> return (mkApCon con xs)       where         -- liftA2 (\b1 b2 ... -> Con b1 b2 ...) x1 x2 <*> ..
GHC/Tc/Deriv/Generate.hs view
@@ -5,7 +5,7 @@  -} -{-# LANGUAGE CPP, ScopedTypeVariables #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DataKinds #-}@@ -19,7 +19,7 @@ -- -- This is where we do all the grimy bindings' generation. module GHC.Tc.Deriv.Generate (-        BagDerivStuff, DerivStuff(..),+        AuxBindSpec(..),          gen_Eq_binds,         gen_Ord_binds,@@ -31,16 +31,17 @@         gen_Data_binds,         gen_Lift_binds,         gen_Newtype_binds,+        gen_Newtype_fam_insts,         mkCoerceClassMethEqn,         genAuxBinds,         ordOpTbl, boxConTbl, litConTbl,         mkRdrFunBind, mkRdrFunBindEC, mkRdrFunBindSE, error_Expr, -        getPossibleDataCons, tyConInstArgTys+        getPossibleDataCons,+        DerivInstTys(..), buildDataConInstArgEnv,+        derivDataConInstArgTys, substDerivInstTys, zonkDerivInstTys     ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Tc.Utils.Monad@@ -53,38 +54,40 @@ import GHC.Types.SourceText  import GHC.Driver.Session-import GHC.Builtin.Utils import GHC.Tc.Instance.Family import GHC.Core.FamInstEnv import GHC.Builtin.Names import GHC.Builtin.Names.TH import GHC.Types.Id.Make ( coerceId ) import GHC.Builtin.PrimOps+import GHC.Builtin.PrimOps.Ids (primOpId) import GHC.Types.SrcLoc import GHC.Core.TyCon import GHC.Tc.Utils.Env import GHC.Tc.Utils.TcType+import GHC.Tc.Utils.Zonk import GHC.Tc.Validity ( checkValidCoAxBranch ) import GHC.Core.Coercion.Axiom ( coAxiomSingleBranch ) import GHC.Builtin.Types.Prim import GHC.Builtin.Types import GHC.Core.Type-import GHC.Core.Multiplicity import GHC.Core.Class+import GHC.Types.Unique.FM ( lookupUFM, listToUFM ) import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Utils.Misc import GHC.Types.Var import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Utils.Lexeme import GHC.Data.FastString import GHC.Data.Pair import GHC.Data.Bag  import Data.List  ( find, partition, intersperse )--type BagDerivStuff = Bag DerivStuff+import GHC.Data.Maybe ( expectJust )+import GHC.Unit.Module  -- | A declarative description of an auxiliary binding that should be -- generated. See @Note [Auxiliary binders]@ for a more detailed description@@ -135,23 +138,6 @@ auxBindSpecRdrName (DerivDataDataType _ dataT_RDR _) = dataT_RDR auxBindSpecRdrName (DerivDataConstr   _ dataC_RDR _) = dataC_RDR -data DerivStuff     -- Please add this auxiliary stuff-  = DerivAuxBind AuxBindSpec-    -- ^ A new, top-level auxiliary binding. Used for deriving 'Eq', 'Ord',-    --   'Enum', 'Ix', and 'Data'. See Note [Auxiliary binders].--  -- Generics and DeriveAnyClass-  | DerivFamInst FamInst               -- New type family instances-    -- ^ A new type family instance. Used for:-    ---    -- * @DeriveGeneric@, which generates instances of @Rep(1)@-    ---    -- * @DeriveAnyClass@, which can fill in associated type family defaults-    ---    -- * @GeneralizedNewtypeDeriving@, which generates instances of associated-    --   type families for newtypes-- {- ************************************************************************ *                                                                      *@@ -167,6 +153,12 @@    data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ... +* We first attempt to compare the constructor tags. If tags don't+  match - we immediately bail out. Otherwise, we then generate one+  branch per constructor comparing only the fields as we already+  know that the tags match. Note that it only makes sense to check+  the tag if there is more than one data constructor.+ * For the ordinary constructors (if any), we emit clauses to do The   Usual Thing, e.g.,: @@ -179,23 +171,29 @@        case (a1 `eqFloat#` a2) of r -> r   for that particular test. -* For nullary constructors, we emit a-  catch-all clause of the form:+* For nullary constructors, we emit a catch-all clause that always+  returns True since we already know that the tags match. -      (==) a b  = case (dataToTag# a) of { a# ->-                  case (dataToTag# b) of { b# ->-                  case (a# ==# b#)     of {-                    r -> r }}}+* So, given this data type: +    data T = A | B Int | C Char++  We roughly get:++    (==) a b =+      case dataToTag# a /= dataToTag# b of+        True -> False+        False -> case a of       -- Here we already know that tags match+            B a1 -> case b of+                B b1 -> a1 == b1 -- Only one branch+            C a1 -> case b of+                C b1 -> a1 == b1 -- Only one branch+            _ -> True            -- catch-all to match all nullary ctors+   An older approach preferred regular pattern matches in some cases   but with dataToTag# forcing it's argument, and work on improving   join points, this seems no longer necessary. -* If there aren't any nullary constructors, we emit a simpler-  catch-all:--     (==) a b  = False- * For the @(/=)@ method, we normally just use the default method.   If the type is an enumeration type, we could/may/should? generate   special code that calls @dataToTag#@, much like for @(==)@ shown@@ -211,64 +209,75 @@ produced don't get through the typechecker. -} -gen_Eq_binds :: SrcSpan -> TyCon -> [Type] -> TcM (LHsBinds GhcPs, BagDerivStuff)-gen_Eq_binds loc tycon tycon_args = do+gen_Eq_binds :: SrcSpan -> DerivInstTys -> TcM (LHsBinds GhcPs, Bag AuxBindSpec)+gen_Eq_binds loc dit@(DerivInstTys{ dit_rep_tc = tycon+                                  , dit_rep_tc_args = tycon_args }) = do     return (method_binds, emptyBag)   where     all_cons = getPossibleDataCons tycon tycon_args-    (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon all_cons--    -- For nullary constructors, use the getTag stuff.-    (tag_match_cons, pat_match_cons) = (nullary_cons, non_nullary_cons)-    no_tag_match_cons = null tag_match_cons--    -- (LHS patterns, result)-    fall_through_eqn :: [([LPat (GhcPass 'Parsed)] , LHsExpr GhcPs)]-    fall_through_eqn-      | no_tag_match_cons   -- All constructors have arguments-      = case pat_match_cons of-          []  -> []   -- No constructors; no fall-though case-          [_] -> []   -- One constructor; no fall-though case-          _   ->      -- Two or more constructors; add fall-through of-                      --       (==) _ _ = False-                 [([nlWildPat, nlWildPat], false_Expr)]+    non_nullary_cons = filter (not . isNullarySrcDataCon) all_cons -      | otherwise -- One or more tag_match cons; add fall-through of-                  -- extract tags compare for equality,-                  -- The case `(C1 x) == (C1 y)` can no longer happen-                  -- at this point as it's matched earlier.-      = [([a_Pat, b_Pat],-         untag_Expr [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]-                    (genPrimOpApp (nlHsVar ah_RDR) eqInt_RDR (nlHsVar bh_RDR)))]+    -- Generate tag check. See #17240+    eq_expr_with_tag_check = nlHsCase+      (nlHsPar (untag_Expr [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]+                    (nlHsOpApp (nlHsVar ah_RDR) neInt_RDR (nlHsVar bh_RDR))))+      [ mkHsCaseAlt (nlLitPat (HsIntPrim NoSourceText 1)) false_Expr+      , mkHsCaseAlt nlWildPat (+          nlHsCase+            (nlHsVar a_RDR)+            -- Only one branch to match all nullary constructors+            -- as we already know the tags match but do not emit+            -- the branch if there are no nullary constructors+            (let non_nullary_pats = map pats_etc non_nullary_cons+             in if null non_nullary_cons+                then non_nullary_pats+                else non_nullary_pats ++ [mkHsCaseAlt nlWildPat true_Expr]))+      ]      method_binds = unitBag eq_bind-    eq_bind-      = mkFunBindEC 2 loc eq_RDR (const true_Expr)-                    (map pats_etc pat_match_cons-                      ++ fall_through_eqn)+    eq_bind = mkFunBindEC 2 loc eq_RDR (const true_Expr) binds+      where+        binds+          | null all_cons = []+          -- Tag checking is redundant when there is only one data constructor+          | [data_con] <- all_cons+          , (as_needed, bs_needed, tys_needed) <- gen_con_fields_and_tys data_con+          , data_con_RDR <- getRdrName data_con+          , con1_pat <- nlParPat $ nlConVarPat data_con_RDR as_needed+          , con2_pat <- nlParPat $ nlConVarPat data_con_RDR bs_needed+          , eq_expr <- nested_eq_expr tys_needed as_needed bs_needed+          = [([con1_pat, con2_pat], eq_expr)]+          -- This is an enum (all constructors are nullary) - just do a simple tag check+          | all isNullarySrcDataCon all_cons+          = [([a_Pat, b_Pat], untag_Expr [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]+                    (genPrimOpApp (nlHsVar ah_RDR) eqInt_RDR (nlHsVar bh_RDR)))]+          | otherwise+          = [([a_Pat, b_Pat], eq_expr_with_tag_check)]      -------------------------------------------------------------------    pats_etc data_con-      = let-            con1_pat = nlParPat $ nlConVarPat data_con_RDR as_needed-            con2_pat = nlParPat $ nlConVarPat data_con_RDR bs_needed--            data_con_RDR = getRdrName data_con-            con_arity   = length tys_needed-            as_needed   = take con_arity as_RDRs-            bs_needed   = take con_arity bs_RDRs-            tys_needed  = dataConOrigArgTys data_con-        in-        ([con1_pat, con2_pat], nested_eq_expr (map scaledThing tys_needed) as_needed bs_needed)+    nested_eq_expr []  [] [] = true_Expr+    nested_eq_expr tys as bs+      = foldr1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs)+      -- Using 'foldr1' here ensures that the derived code is correctly+      -- associated. See #10859.       where-        nested_eq_expr []  [] [] = true_Expr-        nested_eq_expr tys as bs-          = foldr1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs)-          -- Using 'foldr1' here ensures that the derived code is correctly-          -- associated. See #10859.-          where-            nested_eq ty a b = nlHsPar (eq_Expr ty (nlHsVar a) (nlHsVar b))+        nested_eq ty a b = nlHsPar (eq_Expr ty (nlHsVar a) (nlHsVar b)) +    gen_con_fields_and_tys data_con+      | tys_needed <- derivDataConInstArgTys data_con dit+      , con_arity <- length tys_needed+      , as_needed <- take con_arity as_RDRs+      , bs_needed <- take con_arity bs_RDRs+      = (as_needed, bs_needed, tys_needed)++    pats_etc data_con+      | (as_needed, bs_needed, tys_needed) <- gen_con_fields_and_tys data_con+      , data_con_RDR <- getRdrName data_con+      , con1_pat <- nlParPat $ nlConVarPat data_con_RDR as_needed+      , con2_pat <- nlParPat $ nlConVarPat data_con_RDR bs_needed+      , fields_eq_expr <- nested_eq_expr tys_needed as_needed bs_needed+      = mkHsCaseAlt con1_pat (nlHsCase (nlHsVar b_RDR) [mkHsCaseAlt con2_pat fields_eq_expr])+ {- ************************************************************************ *                                                                      *@@ -387,8 +396,9 @@ gtResult OrdGT      = true_Expr  -------------gen_Ord_binds :: SrcSpan -> TyCon -> [Type] -> TcM (LHsBinds GhcPs, BagDerivStuff)-gen_Ord_binds loc tycon tycon_args = do+gen_Ord_binds :: SrcSpan -> DerivInstTys -> TcM (LHsBinds GhcPs, Bag AuxBindSpec)+gen_Ord_binds loc dit@(DerivInstTys{ dit_rep_tc = tycon+                                   , dit_rep_tc_args = tycon_args }) = do     return $ if null tycon_data_cons -- No data-cons => invoke bale-out case       then ( unitBag $ mkFunBindEC 2 loc compare_RDR (const eqTag_Expr) []            , emptyBag)@@ -506,7 +516,7 @@     -- Returns a case alternative  Ki b1 b2 ... bv -> compare (a1,a2,...) with (b1,b2,...)     mkInnerEqAlt op data_con       = mkHsCaseAlt (nlConVarPat data_con_RDR bs_needed) $-        mkCompareFields op (map scaledThing $ dataConOrigArgTys data_con)+        mkCompareFields op (derivDataConInstArgTys data_con dit)       where         data_con_RDR = getRdrName data_con         bs_needed    = take (dataConSourceArity data_con) bs_RDRs@@ -580,7 +590,7 @@   where     ascribeBool e = noLocA $ ExprWithTySig noAnn e                            $ mkHsWildCardBndrs $ noLocA $ mkHsImplicitSigType-                           $ nlHsTyVar boolTyCon_RDR+                           $ nlHsTyVar NotPromoted boolTyCon_RDR  nlConWildPat :: DataCon -> LPat GhcPs -- The pattern (K {})@@ -635,8 +645,8 @@ For @enumFromTo@ and @enumFromThenTo@, we use the default methods. -} -gen_Enum_binds :: SrcSpan -> TyCon -> [Type] -> TcM (LHsBinds GhcPs, BagDerivStuff)-gen_Enum_binds loc tycon _ = do+gen_Enum_binds :: SrcSpan -> DerivInstTys -> TcM (LHsBinds GhcPs, Bag AuxBindSpec)+gen_Enum_binds loc (DerivInstTys{dit_rep_tc = tycon}) = do     -- See Note [Auxiliary binders]     tag2con_RDR <- new_tag2con_rdr_name loc tycon     maxtag_RDR  <- new_maxtag_rdr_name  loc tycon@@ -652,7 +662,7 @@       , enum_from_then tag2con_RDR maxtag_RDR -- [0, 1 ..]       , from_enum       ]-    aux_binds tag2con_RDR maxtag_RDR = listToBag $ map DerivAuxBind+    aux_binds tag2con_RDR maxtag_RDR = listToBag       [ DerivTag2Con tycon tag2con_RDR       , DerivMaxTag  tycon maxtag_RDR       ]@@ -725,12 +735,12 @@ ************************************************************************ -} -gen_Bounded_binds :: SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff)-gen_Bounded_binds loc tycon _+gen_Bounded_binds :: SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, Bag AuxBindSpec)+gen_Bounded_binds loc (DerivInstTys{dit_rep_tc = tycon})   | isEnumerationTyCon tycon   = (listToBag [ min_bound_enum, max_bound_enum ], emptyBag)   | otherwise-  = ASSERT(isSingleton data_cons)+  = assert (isSingleton data_cons)     (listToBag [ min_bound_1con, max_bound_1con ], emptyBag)   where     data_cons = tyConDataCons tycon@@ -812,14 +822,14 @@ (p.~147). -} -gen_Ix_binds :: SrcSpan -> TyCon -> [Type] -> TcM (LHsBinds GhcPs, BagDerivStuff)+gen_Ix_binds :: SrcSpan -> DerivInstTys -> TcM (LHsBinds GhcPs, Bag AuxBindSpec) -gen_Ix_binds loc tycon _ = do+gen_Ix_binds loc (DerivInstTys{dit_rep_tc = tycon}) = do     -- See Note [Auxiliary binders]     tag2con_RDR <- new_tag2con_rdr_name loc tycon      return $ if isEnumerationTyCon tycon-      then (enum_ixes tag2con_RDR, listToBag $ map DerivAuxBind+      then (enum_ixes tag2con_RDR, listToBag                    [ DerivTag2Con tycon tag2con_RDR                    ])       else (single_con_ixes, emptyBag)@@ -1014,10 +1024,10 @@ we want to be able to parse (Left 3) just fine. -} -gen_Read_binds :: (Name -> Fixity) -> SrcSpan -> TyCon -> [Type]-               -> (LHsBinds GhcPs, BagDerivStuff)+gen_Read_binds :: (Name -> Fixity) -> SrcSpan -> DerivInstTys+               -> (LHsBinds GhcPs, Bag AuxBindSpec) -gen_Read_binds get_fixity loc tycon _+gen_Read_binds get_fixity loc dit@(DerivInstTys{dit_rep_tc = tycon})   = (listToBag [read_prec, default_readlist, default_readlistprec], emptyBag)   where     -----------------------------------------------------------------------@@ -1106,7 +1116,7 @@         is_infix     = dataConIsInfix data_con         is_record    = labels `lengthExceeds` 0         as_needed    = take con_arity as_RDRs-        read_args    = zipWithEqual "gen_Read_binds" read_arg as_needed (map scaledThing $ dataConOrigArgTys data_con)+        read_args    = zipWithEqual "gen_Read_binds" read_arg as_needed (derivDataConInstArgTys data_con dit)         (read_a1:read_a2:_) = read_args          prefix_prec = appPrecedence@@ -1137,7 +1147,7 @@      data_con_str con = occNameString (getOccName con) -    read_arg a ty = ASSERT( not (isUnliftedType ty) )+    read_arg a ty = assert (not (isUnliftedType ty)) $                     noLocA (mkPsBindStmt noAnn (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR]))      -- When reading field labels we might encounter@@ -1198,10 +1208,11 @@                     -- the most tightly-binding operator -} -gen_Show_binds :: (Name -> Fixity) -> SrcSpan -> TyCon -> [Type]-               -> (LHsBinds GhcPs, BagDerivStuff)+gen_Show_binds :: (Name -> Fixity) -> SrcSpan -> DerivInstTys+               -> (LHsBinds GhcPs, Bag AuxBindSpec) -gen_Show_binds get_fixity loc tycon tycon_args+gen_Show_binds get_fixity loc dit@(DerivInstTys{ dit_rep_tc = tycon+                                               , dit_rep_tc_args = tycon_args })   = (unitBag shows_prec, emptyBag)   where     data_cons = getPossibleDataCons tycon tycon_args@@ -1210,7 +1221,7 @@      pats_etc data_con       | nullary_con =  -- skip the showParen junk...-         ASSERT(null bs_needed)+         assert (null bs_needed)          ([nlWildPat, con_pat], mk_showString_app op_con_str)       | otherwise   =          ([a_Pat, con_pat],@@ -1221,7 +1232,7 @@              data_con_RDR  = getRdrName data_con              con_arity     = dataConSourceArity data_con              bs_needed     = take con_arity bs_RDRs-             arg_tys       = dataConOrigArgTys data_con         -- Correspond 1-1 with bs_needed+             arg_tys       = derivDataConInstArgTys data_con dit -- Correspond 1-1 with bs_needed              con_pat       = nlConVarPat data_con_RDR bs_needed              nullary_con   = con_arity == 0              labels        = map flLabel $ dataConFieldLabels data_con@@ -1249,7 +1260,7 @@                  where                    nm       = wrapOpParens (unpackFS l) -             show_args               = zipWithEqual "gen_Show_binds" show_arg bs_needed (map scaledThing arg_tys)+             show_args               = zipWithEqual "gen_Show_binds" show_arg bs_needed arg_tys              (show_arg1:show_arg2:_) = show_args              show_prefix_args        = intersperse (nlHsVar showSpace_RDR) show_args @@ -1369,12 +1380,10 @@ -}  gen_Data_binds :: SrcSpan-               -> TyCon                 -- For data families, this is the-                                        --  *representation* TyCon-               -> [Type]+               -> DerivInstTys                -> TcM (LHsBinds GhcPs,  -- The method bindings-                       BagDerivStuff)   -- Auxiliary bindings-gen_Data_binds loc rep_tc _+                       Bag AuxBindSpec) -- Auxiliary bindings+gen_Data_binds loc (DerivInstTys{dit_rep_tc = rep_tc})   = do { -- See Note [Auxiliary binders]          dataT_RDR  <- new_dataT_rdr_name loc rep_tc        ; dataC_RDRs <- traverse (new_dataC_rdr_name loc) data_cons@@ -1383,7 +1392,7 @@                           , toCon_bind dataC_RDRs, dataTypeOf_bind dataT_RDR ]                 `unionBags` gcast_binds                           -- Auxiliary definitions: the data type and constructors-              , listToBag $ map DerivAuxBind+              , listToBag                   ( DerivDataDataType rep_tc dataT_RDR dataC_RDRs                   : zipWith (\data_con dataC_RDR ->                                DerivDataConstr data_con dataC_RDR dataT_RDR)@@ -1487,7 +1496,7 @@     dataCast1_RDR, dataCast2_RDR, gcast1_RDR, gcast2_RDR,     constr_RDR, dataType_RDR,     eqChar_RDR  , ltChar_RDR  , geChar_RDR  , gtChar_RDR  , leChar_RDR  ,-    eqInt_RDR   , ltInt_RDR   , geInt_RDR   , gtInt_RDR   , leInt_RDR   ,+    eqInt_RDR   , ltInt_RDR   , geInt_RDR   , gtInt_RDR   , leInt_RDR   , neInt_RDR ,     eqInt8_RDR  , ltInt8_RDR  , geInt8_RDR  , gtInt8_RDR  , leInt8_RDR  ,     eqInt16_RDR , ltInt16_RDR , geInt16_RDR , gtInt16_RDR , leInt16_RDR ,     eqInt32_RDR , ltInt32_RDR , geInt32_RDR , gtInt32_RDR , leInt32_RDR ,@@ -1527,6 +1536,7 @@ geChar_RDR     = varQual_RDR  gHC_PRIM (fsLit "geChar#")  eqInt_RDR      = varQual_RDR  gHC_PRIM (fsLit "==#")+neInt_RDR      = varQual_RDR  gHC_PRIM (fsLit "/=#") ltInt_RDR      = varQual_RDR  gHC_PRIM (fsLit "<#" ) leInt_RDR      = varQual_RDR  gHC_PRIM (fsLit "<=#") gtInt_RDR      = varQual_RDR  gHC_PRIM (fsLit ">#" )@@ -1613,7 +1623,6 @@ word32ToWord_RDR = varQual_RDR  gHC_PRIM (fsLit "word32ToWord#") int32ToInt_RDR   = varQual_RDR  gHC_PRIM (fsLit "int32ToInt#") - {- ************************************************************************ *                                                                      *@@ -1639,16 +1648,18 @@ -}  -gen_Lift_binds :: SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff)-gen_Lift_binds loc tycon tycon_args = (listToBag [lift_bind, liftTyped_bind], emptyBag)+gen_Lift_binds :: SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, Bag AuxBindSpec)+gen_Lift_binds loc (DerivInstTys{ dit_rep_tc = tycon+                                , dit_rep_tc_args = tycon_args }) =+  (listToBag [lift_bind, liftTyped_bind], emptyBag)   where     lift_bind      = mkFunBindEC 1 loc lift_RDR (nlHsApp pure_Expr)-                                 (map (pats_etc mk_exp mk_usplice liftName) data_cons)+                                 (map (pats_etc mk_untyped_bracket mk_usplice liftName) data_cons)     liftTyped_bind = mkFunBindEC 1 loc liftTyped_RDR (nlHsApp unsafeCodeCoerce_Expr . nlHsApp pure_Expr)-                                 (map (pats_etc mk_texp mk_tsplice liftTypedName) data_cons)+                                 (map (pats_etc mk_typed_bracket mk_tsplice liftTypedName) data_cons) -    mk_exp = ExpBr noExtField-    mk_texp = TExpBr noExtField+    mk_untyped_bracket = HsUntypedBracket noAnn . ExpBr noExtField+    mk_typed_bracket = HsTypedBracket noAnn      mk_usplice = HsUntypedSplice EpAnnNotUsed DollarSplice     mk_tsplice = HsTypedSplice EpAnnNotUsed DollarSplice@@ -1661,7 +1672,7 @@             data_con_RDR = getRdrName data_con             con_arity    = dataConSourceArity data_con             as_needed    = take con_arity as_RDRs-            lift_Expr    = noLocA (HsBracket noAnn (mk_bracket br_body))+            lift_Expr    = noLocA (mk_bracket br_body)             br_body      = nlHsApps (Exact (dataConName data_con))                                     (map lift_var as_needed) @@ -1966,17 +1977,18 @@                              -- newtype itself)                   -> [Type]  -- instance head parameters (incl. newtype)                   -> Type    -- the representation type-                  -> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff)+                  -> (LHsBinds GhcPs, [LSig GhcPs]) -- See Note [Newtype-deriving instances] gen_Newtype_binds loc' cls inst_tvs inst_tys rhs_ty-  = do let ats = classATs cls-           (binds, sigs) = mapAndUnzip mk_bind_and_sig (classMethods cls)-       atf_insts <- ASSERT( all (not . isDataFamilyTyCon) ats )-                    mapM mk_atf_inst ats-       return ( listToBag binds-              , sigs-              , listToBag $ map DerivFamInst atf_insts )+  = (listToBag binds, sigs)   where+    (binds, sigs) = mapAndUnzip mk_bind_and_sig (classMethods cls)++    -- Same as inst_tys, but with the last argument type replaced by the+    -- representation type.+    underlying_inst_tys :: [Type]+    underlying_inst_tys = changeLast inst_tys rhs_ty+     locn = noAnnSrcSpan loc'     loca = noAnnSrcSpan loc'     -- For each class method, generate its derived binding and instance@@ -2046,6 +2058,33 @@                      -- Filter out any inferred arguments, since they can't be                      -- applied with visible type application. +gen_Newtype_fam_insts :: SrcSpan+                      -> Class   -- the class being derived+                      -> [TyVar] -- the tvs in the instance head (this includes+                                 -- the tvs from both the class types and the+                                 -- newtype itself)+                      -> [Type]  -- instance head parameters (incl. newtype)+                      -> Type    -- the representation type+                      -> TcM [FamInst]+-- See Note [GND and associated type families] in GHC.Tc.Deriv+gen_Newtype_fam_insts loc' cls inst_tvs inst_tys rhs_ty+  = assert (all (not . isDataFamilyTyCon) ats) $+    mapM mk_atf_inst ats+  where+    -- Same as inst_tys, but with the last argument type replaced by the+    -- representation type.+    underlying_inst_tys :: [Type]+    underlying_inst_tys = changeLast inst_tys rhs_ty++    ats       = classATs cls+    locn      = noAnnSrcSpan loc'+    cls_tvs   = classTyVars cls+    in_scope  = mkInScopeSet $ mkVarSet inst_tvs+    lhs_env   = zipTyEnv cls_tvs inst_tys+    lhs_subst = mkTvSubst in_scope lhs_env+    rhs_env   = zipTyEnv cls_tvs underlying_inst_tys+    rhs_subst = mkTvSubst in_scope rhs_env+     mk_atf_inst :: TyCon -> TcM FamInst     mk_atf_inst fam_tc = do         rep_tc_name <- newFamInstTyConName (L locn (tyConName fam_tc))@@ -2056,12 +2095,6 @@         checkValidCoAxBranch fam_tc (coAxiomSingleBranch axiom)         newFamInst SynFamilyInst axiom       where-        cls_tvs     = classTyVars cls-        in_scope    = mkInScopeSet $ mkVarSet inst_tvs-        lhs_env     = zipTyEnv cls_tvs inst_tys-        lhs_subst   = mkTvSubst in_scope lhs_env-        rhs_env     = zipTyEnv cls_tvs underlying_inst_tys-        rhs_subst   = mkTvSubst in_scope rhs_env         fam_tvs     = tyConTyVars fam_tc         rep_lhs_tys = substTyVars lhs_subst fam_tvs         rep_rhs_tys = substTyVars rhs_subst fam_tvs@@ -2071,11 +2104,6 @@         rep_tvs'    = scopedSort rep_tvs         rep_cvs'    = scopedSort rep_cvs -    -- Same as inst_tys, but with the last argument type replaced by the-    -- representation type.-    underlying_inst_tys :: [Type]-    underlying_inst_tys = changeLast inst_tys rhs_ty- nlHsAppType :: LHsExpr GhcPs -> Type -> LHsExpr GhcPs nlHsAppType e s = noLocA (HsAppType noSrcSpan e hs_ty)   where@@ -2153,9 +2181,12 @@     gen_bind (DerivDataDataType tycon dataT_RDR dataC_RDRs)       = mkHsVarBind loc dataT_RDR rhs       where+        tc_name = tyConName tycon+        tc_name_string = occNameString (getOccName tc_name)+        definition_mod_name = moduleNameString (moduleName (expectJust "gen_bind DerivDataDataType" $ nameModule_maybe tc_name))         ctx = initDefaultSDocContext dflags         rhs = nlHsVar mkDataType_RDR-              `nlHsApp` nlHsLit (mkHsString (showSDocOneLine ctx (ppr tycon)))+              `nlHsApp` nlHsLit (mkHsString (showSDocOneLine ctx (text definition_mod_name <> dot <> text tc_name_string)))               `nlHsApp` nlList (map nlHsVar dataC_RDRs)      gen_bind (DerivDataConstr dc dataC_RDR dataT_RDR)@@ -2202,31 +2233,19 @@   DerivMaxTag _ _     -> mk_sig (L (noAnnSrcSpan loc) (XHsType intTy))   DerivDataDataType _ _ _-    -> mk_sig (nlHsTyVar dataType_RDR)+    -> mk_sig (nlHsTyVar NotPromoted dataType_RDR)   DerivDataConstr _ _ _-    -> mk_sig (nlHsTyVar constr_RDR)+    -> mk_sig (nlHsTyVar NotPromoted constr_RDR)   where     mk_sig = mkHsWildCardBndrs . L (noAnnSrcSpan loc) . mkHsImplicitSigType -type SeparateBagsDerivStuff =-  -- DerivAuxBinds-  ( Bag (LHsBind GhcPs, LSig GhcPs)--  -- Extra family instances (used by DeriveGeneric, DeriveAnyClass, and-  -- GeneralizedNewtypeDeriving)-  , Bag FamInst )---- | Take a 'BagDerivStuff' and partition it into 'SeparateBagsDerivStuff'.--- Also generate the code for auxiliary bindings based on the declarative--- descriptions in the supplied 'AuxBindSpec's. See @Note [Auxiliary binders]@.-genAuxBinds :: DynFlags -> SrcSpan -> BagDerivStuff -> SeparateBagsDerivStuff-genAuxBinds dflags loc b = (gen_aux_bind_specs b1, b2) where-  (b1,b2) = partitionBagWith splitDerivAuxBind b-  splitDerivAuxBind (DerivAuxBind x) = Left x-  splitDerivAuxBind (DerivFamInst t) = Right t--  gen_aux_bind_specs = snd . foldr gen_aux_bind_spec (emptyOccEnv, emptyBag)-+-- | Take a 'Bag' of 'AuxBindSpec's and generate the code for auxiliary+-- bindings based on the declarative descriptions in the supplied+-- 'AuxBindSpec's. See @Note [Auxiliary binders]@.+genAuxBinds :: DynFlags -> SrcSpan -> Bag AuxBindSpec+            -> Bag (LHsBind GhcPs, LSig GhcPs)+genAuxBinds dflags loc = snd . foldr gen_aux_bind_spec (emptyOccEnv, emptyBag)+ where   -- Perform a CSE-like pass over the generated auxiliary bindings to avoid   -- code duplication, as described in   -- Note [Auxiliary binders] (Wrinkle: Reducing code duplication).@@ -2651,33 +2670,134 @@ getPossibleDataCons :: TyCon -> [Type] -> [DataCon] getPossibleDataCons tycon tycon_args = filter isPossible $ tyConDataCons tycon   where-    isPossible = not . dataConCannotMatch (tyConInstArgTys tycon tycon_args)+    isPossible dc = not $ dataConCannotMatch (dataConInstUnivs dc tycon_args) dc --- | Given a type constructor @tycon@ of arity /n/ and a list of argument types--- @tycon_args@ of length /m/,+-- | Information about the arguments to the class in a stock- or+-- newtype-derived instance. For a @deriving@-generated instance declaration+-- such as this one: -- -- @--- tyConInstArgTys tycon tycon_args+-- instance Ctx => Cls cls_ty_1 ... cls_ty_m (TC tc_arg_1 ... tc_arg_n) where ... -- @ ----- returns+-- * 'dit_cls_tys' corresponds to @cls_ty_1 ... cls_ty_m@. ----- @--- [tycon_arg_{1}, tycon_arg_{2}, ..., tycon_arg_{m}, extra_arg_{m+1}, ..., extra_arg_{n}]--- @+-- * 'dit_tc' corresponds to @TC@. ----- where @extra_args@ are distinct type variables.+-- * 'dit_tc_args' corresponds to @tc_arg_1 ... tc_arg_n@. ----- Examples:+-- See @Note [DerivEnv and DerivSpecMechanism]@ in "GHC.Tc.Deriv.Utils" for a+-- more in-depth explanation, including the relationship between+-- 'dit_tc'/'dit_rep_tc' and 'dit_tc_args'/'dit_rep_tc_args'. ----- * Given @tycon: Foo a b@ and @tycon_args: [Int, Bool]@, return @[Int, Bool]@.+-- A 'DerivInstTys' value can be seen as a more structured representation of+-- the 'denv_inst_tys' in a 'DerivEnv', as the 'denv_inst_tys' is equal to+-- @dit_cls_tys ++ ['mkTyConApp' dit_tc dit_tc_args]@. Other parts of the+-- instance declaration can be found in the 'DerivEnv'. For example, the @Cls@+-- in the example above corresponds to the 'denv_cls' field of 'DerivEnv'. ----- * Given @tycon: Foo a b@ and @tycon_args: [Int]@, return @[Int, b]@.-tyConInstArgTys :: TyCon -> [Type] -> [Type]-tyConInstArgTys tycon tycon_args = chkAppend tycon_args $ map mkTyVarTy tycon_args_suffix+-- Similarly, the type variables that appear in a 'DerivInstTys' value are the+-- same type variables as the 'denv_tvs' in the parent 'DerivEnv'. Accordingly,+-- if we are inferring an instance context, the type variables will be 'TcTyVar'+-- skolems. Otherwise, they will be ordinary 'TyVar's.+-- See @Note [Overlap and deriving]@ in "GHC.Tc.Deriv.Infer".+data DerivInstTys = DerivInstTys+  { dit_cls_tys     :: [Type]+    -- ^ Other arguments to the class except the last+  , dit_tc          :: TyCon+    -- ^ Type constructor for which the instance is requested+    --   (last arguments to the type class)+  , dit_tc_args     :: [Type]+    -- ^ Arguments to the type constructor+  , dit_rep_tc      :: TyCon+    -- ^ The representation tycon for 'dit_tc'+    --   (for data family instances). Otherwise the same as 'dit_tc'.+  , dit_rep_tc_args :: [Type]+    -- ^ The representation types for 'dit_tc_args'+    --   (for data family instances). Otherwise the same as 'dit_tc_args'.+  , dit_dc_inst_arg_env :: DataConEnv [Type]+    -- ^ The cached results of instantiating each data constructor's field+    --   types using @'dataConInstUnivs' data_con 'dit_rep_tc_args'@.+    --   See @Note [Instantiating field types in stock deriving]@.+    --+    --   This field is only used for stock-derived instances and goes unused+    --   for newtype-derived instances. It is put here mainly for the sake of+    --   convenience.+  }++instance Outputable DerivInstTys where+  ppr (DerivInstTys { dit_cls_tys = cls_tys, dit_tc = tc, dit_tc_args = tc_args+                    , dit_rep_tc = rep_tc, dit_rep_tc_args = rep_tc_args+                    , dit_dc_inst_arg_env = dc_inst_arg_env })+    = hang (text "DerivInstTys")+         2 (vcat [ text "dit_cls_tys"         <+> ppr cls_tys+                 , text "dit_tc"              <+> ppr tc+                 , text "dit_tc_args"         <+> ppr tc_args+                 , text "dit_rep_tc"          <+> ppr rep_tc+                 , text "dit_rep_tc_args"     <+> ppr rep_tc_args+                 , text "dit_dc_inst_arg_env" <+> ppr dc_inst_arg_env ])++-- | Look up a data constructor's instantiated field types in a 'DerivInstTys'.+-- See @Note [Instantiating field types in stock deriving]@.+derivDataConInstArgTys :: DataCon -> DerivInstTys -> [Type]+derivDataConInstArgTys dc dit =+  case lookupUFM (dit_dc_inst_arg_env dit) dc of+    Just inst_arg_tys -> inst_arg_tys+    Nothing           -> pprPanic "derivDataConInstArgTys" (ppr dc)++-- | @'buildDataConInstArgEnv' tycon arg_tys@ constructs a cache that maps+-- each of @tycon@'s data constructors to their field types, with are to be+-- instantiated with @arg_tys@.+-- See @Note [Instantiating field types in stock deriving]@.+buildDataConInstArgEnv :: TyCon -> [Type] -> DataConEnv [Type]+buildDataConInstArgEnv rep_tc rep_tc_args =+  listToUFM [ (dc, inst_arg_tys)+            | dc <- tyConDataCons rep_tc+            , let (_, _, inst_arg_tys) =+                    dataConInstSig dc $ dataConInstUnivs dc rep_tc_args+            ]++-- | Apply a substitution to all of the 'Type's contained in a 'DerivInstTys'.+-- See @Note [Instantiating field types in stock deriving]@ for why we need to+-- substitute into a 'DerivInstTys' in the first place.+substDerivInstTys :: TCvSubst -> DerivInstTys -> DerivInstTys+substDerivInstTys subst+  dit@(DerivInstTys { dit_cls_tys = cls_tys, dit_tc_args = tc_args+                    , dit_rep_tc = rep_tc, dit_rep_tc_args = rep_tc_args })++  | isEmptyTCvSubst subst+  = dit+  | otherwise+  = dit{ dit_cls_tys         = cls_tys'+       , dit_tc_args         = tc_args'+       , dit_rep_tc_args     = rep_tc_args'+       , dit_dc_inst_arg_env = buildDataConInstArgEnv rep_tc rep_tc_args'+       }   where-    tycon_args_suffix = drop (length tycon_args) $ tyConTyVars tycon+    cls_tys'     = substTys subst cls_tys+    tc_args'     = substTys subst tc_args+    rep_tc_args' = substTys subst rep_tc_args +-- | Zonk the 'TcTyVar's in a 'DerivInstTys' value to 'TyVar's.+-- See @Note [What is zonking?]@ in "GHC.Tc.Utils.TcMType".+--+-- This is only used in the final zonking step when inferring+-- the context for a derived instance.+-- See @Note [Overlap and deriving]@ in "GHC.Tc.Deriv.Infer".+zonkDerivInstTys :: ZonkEnv -> DerivInstTys -> TcM DerivInstTys+zonkDerivInstTys ze dit@(DerivInstTys { dit_cls_tys = cls_tys+                                      , dit_tc_args = tc_args+                                      , dit_rep_tc = rep_tc+                                      , dit_rep_tc_args = rep_tc_args }) = do+  cls_tys'     <- zonkTcTypesToTypesX ze cls_tys+  tc_args'     <- zonkTcTypesToTypesX ze tc_args+  rep_tc_args' <- zonkTcTypesToTypesX ze rep_tc_args+  pure dit{ dit_cls_tys         = cls_tys'+          , dit_tc_args         = tc_args'+          , dit_rep_tc_args     = rep_tc_args'+          , dit_dc_inst_arg_env = buildDataConInstArgEnv rep_tc rep_tc_args'+          }+ {- Note [Auxiliary binders] ~~~~~~~~~~~~~~~~~~~~~~~~@@ -2947,4 +3067,82 @@ there is a valid use-case and we have requirements for how they should work.  See #16341 and the T16341.hs test case.++Note [Instantiating field types in stock deriving]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Figuring out what the types of data constructor fields are in `deriving` can+be surprisingly tricky. Here are some examples (adapted from #20375) to set+the scene:++  data Ta = MkTa Int#+  data Tb (x :: TYPE IntRep) = MkTb x++  deriving instance Eq Ta        -- 1.+  deriving instance Eq (Tb a)    -- 2.+  deriving instance Eq (Tb Int#) -- 3.++Example (1) is accepted, as `deriving Eq` has a special case for fields of type+Int#. Example (2) is rejected, however, as the special case for Int# does not+extend to all types of kind (TYPE IntRep).++Example (3) ought to typecheck. If you instantiate the field of type `x` in+MkTb to be Int#, then `deriving Eq` is capable of handling that. We must be+careful, however. If we naïvely use, say, `dataConOrigArgTys` to retrieve the+field types, then we would get `b`, which `deriving Eq` would reject. In+order to handle `deriving Eq` (and, more generally, any stock deriving+strategy) correctly, we /must/ instantiate the field types as needed.+Not doing so led to #20375 and #20387.++In fact, we end up needing to instantiate the field types in quite a few+places:++* When performing validity checks for stock deriving strategies (e.g., in+  GHC.Tc.Deriv.Utils.cond_stdOK)++* When inferring the instance context in+  GHC.Tc.Deriv.Infer.inferConstraintStock++* When generating code for stock-derived instances in+  GHC.Tc.Deriv.{Functor,Generate,Generics}++Repeatedly performing these instantiations in multiple places would be+wasteful, so we build a cache of data constructor field instantiations in+the `dit_dc_inst_arg_env` field of DerivInstTys. Specifically:++1. When beginning to generate code for a stock-derived instance+   `T arg_1 ... arg_n`, the `dit_dc_inst_arg_env` field is created by taking+   each data constructor `dc`, instantiating its field types with+   `dataConInstUnivs dc [arg_1, ..., arg_n]`, and mapping `dc` to the+   instantiated field types in the cache. The `buildDataConInstArgEnv` function+   is responsible for orchestrating this.++2. When a part of the code in GHC.Tc.Deriv.* needs to look up the field+   types, we deliberately avoid using `dataConOrigArgTys`. Instead, we use+   `derivDataConInstArgTys`, which looks up a DataCon's instantiated field+   types in the cache.++StandaloneDeriving is one way for the field types to become instantiated.+Another way is by deriving Functor and related classes, as chronicled in+Note [Inferring the instance context] in GHC.Tc.Deriv.Infer. Here is one such+example:++  newtype Compose (f :: k -> Type) (g :: j -> k) (a :: j) = Compose (f (g a))+    deriving Generic1++This ultimately generates the following instance:++  instance forall (f :: Type -> Type) (g :: j -> Type).+    Functor f => Generic1 (Compose f g) where ...++Note that because of the inferred `Functor f` constraint, `k` was instantiated+to be `Type`. GHC's deriving machinery doesn't realize this until it performs+constraint inference (in GHC.Tc.Deriv.Infer.inferConstraintsStock), however,+which is *after* the initial DerivInstTys has been created. As a result, the+`dit_dc_inst_arg_env` field might need to be updated after constraint inference,+as the inferred constraints might instantiate the field types further.++This is accomplished by way of `substDerivInstTys`, which substitutes all of+the fields in a `DerivInstTys`, including the `dit_dc_inst_arg_env`.+It is important to do this in inferConstraintsStock, as the+deriving/should_compile/T20387 test case will not compile otherwise. -}
GHC/Tc/Deriv/Generics.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP                 #-}+ {-# LANGUAGE FlexibleContexts    #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies        #-}@@ -12,10 +12,11 @@  -- | The deriving code for the Generic class module GHC.Tc.Deriv.Generics-   (canDoGenerics+   ( canDoGenerics    , canDoGenerics1    , GenericKind(..)    , gen_Generic_binds+   , gen_Generic_fam_inst    , get_gen1_constrained_tys    ) where@@ -27,17 +28,16 @@ import GHC.Tc.Utils.TcType import GHC.Tc.Deriv.Generate import GHC.Tc.Deriv.Functor+import GHC.Tc.Errors.Types import GHC.Core.DataCon import GHC.Core.TyCon import GHC.Core.FamInstEnv ( FamInst, FamFlavor(..), mkSingleCoAxiom )-import GHC.Core.Multiplicity import GHC.Tc.Instance.Family import GHC.Unit.Module ( moduleName, moduleNameFS                         , moduleUnit, unitFS, getModule ) import GHC.Iface.Env    ( newGlobalBinder ) import GHC.Types.Name hiding ( varName ) import GHC.Types.Name.Reader-import GHC.Types.Fixity.Env import GHC.Types.SourceText import GHC.Types.Fixity import GHC.Types.Basic@@ -47,13 +47,14 @@ import GHC.Tc.Utils.Env import GHC.Tc.Utils.Monad import GHC.Driver.Session-import GHC.Utils.Error( Validity(..), andValid )+import GHC.Utils.Error( Validity'(..), andValid ) import GHC.Types.SrcLoc import GHC.Data.Bag import GHC.Types.Var.Env import GHC.Types.Var.Set (elemVarSet) import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Data.FastString import GHC.Utils.Misc @@ -61,8 +62,6 @@ import Data.List (zip4, partition) import Data.Maybe (isJust) -#include "HsVersions.h"- {- ************************************************************************ *                                                                      *@@ -78,13 +77,11 @@ \end{itemize} -} -gen_Generic_binds :: GenericKind -> TyCon -> [Type]-                 -> TcM (LHsBinds GhcPs, [LSig GhcPs], FamInst)-gen_Generic_binds gk tc inst_tys = do+gen_Generic_binds :: GenericKind -> SrcSpan -> DerivInstTys+                  -> TcM (LHsBinds GhcPs, [LSig GhcPs])+gen_Generic_binds gk loc dit = do   dflags <- getDynFlags-  repTyInsts <- tc_mkRepFamInsts gk tc inst_tys-  let (binds, sigs) = mkBindsRep dflags gk tc-  return (binds, sigs, repTyInsts)+  return $ mkBindsRep dflags gk loc dit  {- ************************************************************************@@ -119,6 +116,7 @@       alpha-renaming).    (b) D cannot have a "stupid context".+      See Note [The stupid context] in GHC.Core.DataCon.    (c) The right-hand side of D cannot include existential types, universally       quantified types, or "exotic" unlifted types. An exotic unlifted type@@ -147,7 +145,7 @@  -} -canDoGenerics :: TyCon -> Validity+canDoGenerics :: DerivInstTys -> Validity' [DeriveGenericsErrReason] -- canDoGenerics determines if Generic/Rep can be derived. -- -- Check (a) from Note [Requirements for deriving Generic and Rep] is taken@@ -155,18 +153,18 @@ -- -- It returns IsValid if deriving is possible. It returns (NotValid reason) -- if not.-canDoGenerics tc+canDoGenerics dit@(DerivInstTys{dit_rep_tc = tc})   = mergeErrors (           -- Check (b) from Note [Requirements for deriving Generic and Rep].               (if (not (null (tyConStupidTheta tc)))-                then (NotValid (tc_name <+> text "must not have a datatype context"))+                then (NotValid $ DerivErrGenericsMustNotHaveDatatypeContext tc_name)                 else IsValid)           -- See comment below             : (map bad_con (tyConDataCons tc)))   where     -- The tc can be a representation tycon. When we want to display it to the     -- user (in an error message) we should print its parent-    tc_name = ppr $ case tyConFamInst_maybe tc of+    tc_name = case tyConFamInst_maybe tc of         Just (ptc, _) -> ptc         _             -> tc @@ -176,16 +174,16 @@         -- then we can't build the embedding-projection pair, because         -- it relies on instantiating *polymorphic* sum and product types         -- at the argument types of the constructors-    bad_con dc = if (any bad_arg_type (map scaledThing $ dataConOrigArgTys dc))-                  then (NotValid (ppr dc <+> text-                    "must not have exotic unlifted or polymorphic arguments"))-                  else (if (not (isVanillaDataCon dc))-                          then (NotValid (ppr dc <+> text "must be a vanilla data constructor"))-                          else IsValid)+    bad_con :: DataCon -> Validity' DeriveGenericsErrReason+    bad_con dc = if any bad_arg_type (derivDataConInstArgTys dc dit)+                  then NotValid $ DerivErrGenericsMustNotHaveExoticArgs dc+                  else if not (isVanillaDataCon dc)+                          then NotValid $ DerivErrGenericsMustBeVanillaDataCon dc+                          else IsValid          -- Nor can we do the job if it's an existential data constructor,         -- Nor if the args are polymorphic types (I don't think)-    bad_arg_type ty = (isUnliftedType ty && not (allowedUnliftedTy ty))+    bad_arg_type ty = (mightBeUnliftedType ty && not (allowedUnliftedTy ty))                       || not (isTauTy ty)  -- Returns True the Type argument is an unlifted type which has a@@ -195,19 +193,20 @@ allowedUnliftedTy :: Type -> Bool allowedUnliftedTy = isJust . unboxedRepRDRs -mergeErrors :: [Validity] -> Validity+mergeErrors :: [Validity' a] -> Validity' [a] mergeErrors []             = IsValid mergeErrors (NotValid s:t) = case mergeErrors t of-  IsValid     -> NotValid s-  NotValid s' -> NotValid (s <> text ", and" $$ s')+  IsValid     -> NotValid [s]+  NotValid s' -> NotValid (s : s') mergeErrors (IsValid : t) = mergeErrors t+  -- NotValid s' -> NotValid (s <> text ", and" $$ s')  -- A datatype used only inside of canDoGenerics1. It's the result of analysing -- a type term. data Check_for_CanDoGenerics1 = CCDG1   { _ccdg1_hasParam :: Bool       -- does the parameter of interest occurs in                                   -- this type?-  , _ccdg1_errors   :: Validity   -- errors generated by this type+  , _ccdg1_errors   :: Validity' DeriveGenericsErrReason -- errors generated by this type   }  {-@@ -242,32 +241,28 @@ -- -- It returns IsValid if deriving is possible. It returns (NotValid reason) -- if not.-canDoGenerics1 :: TyCon -> Validity-canDoGenerics1 rep_tc =-  canDoGenerics rep_tc `andValid` additionalChecks+canDoGenerics1 :: DerivInstTys -> Validity' [DeriveGenericsErrReason]+canDoGenerics1 dit@(DerivInstTys{dit_rep_tc = rep_tc}) =+  canDoGenerics dit `andValid` additionalChecks   where     additionalChecks         -- check (d) from Note [Requirements for deriving Generic and Rep]-      | null (tyConTyVars rep_tc) = NotValid $-          text "Data type" <+> quotes (ppr rep_tc)-      <+> text "must have some type parameters"+      | null (tyConTyVars rep_tc) = NotValid [+          DerivErrGenericsMustHaveSomeTypeParams rep_tc]        | otherwise = mergeErrors $ concatMap check_con data_cons      data_cons = tyConDataCons rep_tc     check_con con = case check_vanilla con of       j@(NotValid {}) -> [j]-      IsValid -> _ccdg1_errors `map` foldDataConArgs (ft_check con) con--    bad :: DataCon -> SDoc -> SDoc-    bad con msg = text "Constructor" <+> quotes (ppr con) <+> msg+      IsValid -> _ccdg1_errors `map` foldDataConArgs (ft_check con) con dit -    check_vanilla :: DataCon -> Validity+    check_vanilla :: DataCon -> Validity' DeriveGenericsErrReason     check_vanilla con | isVanillaDataCon con = IsValid-                      | otherwise            = NotValid (bad con existential)+                      | otherwise            = NotValid $ DerivErrGenericsMustNotHaveExistentials con -    bmzero      = CCDG1 False IsValid-    bmbad con s = CCDG1 True $ NotValid $ bad con s+    bmzero    = CCDG1 False IsValid+    bmbad con = CCDG1 True $ NotValid (DerivErrGenericsWrongArgKind con)     bmplus (CCDG1 b1 m1) (CCDG1 b2 m2) = CCDG1 (b1 || b2) (m1 `andValid` m2)      -- check (e) from Note [Requirements for deriving Generic and Rep]@@ -280,30 +275,25 @@        -- (component_0,component_1,...,component_n)       , ft_tup = \_ components -> if any _ccdg1_hasParam (init components)-                                  then bmbad con wrong_arg+                                  then bmbad con                                   else foldr bmplus bmzero components        -- (dom -> rng), where the head of ty is not a tuple tycon       , ft_fun = \dom rng -> -- cf #8516           if _ccdg1_hasParam dom-          then bmbad con wrong_arg+          then bmbad con           else bmplus dom rng        -- (ty arg), where head of ty is neither (->) nor a tuple constructor and       -- the parameter of interest does not occur in ty       , ft_ty_app = \_ _ arg -> arg -      , ft_bad_app = bmbad con wrong_arg+      , ft_bad_app = bmbad con       , ft_forall  = \_ body -> body -- polytypes are handled elsewhere       }       where         caseVar = CCDG1 True IsValid --    existential = text "must not have existential arguments"-    wrong_arg   = text "applies a type to an argument involving the last parameter"-               $$ text "but the applied type is not of kind * -> *"- {- ************************************************************************ *                                                                      *@@ -319,26 +309,30 @@ -- Generic1 (Gen1). data GenericKind = Gen0 | Gen1 --- as above, but with a payload of the TyCon's name for "the" parameter-data GenericKind_ = Gen0_ | Gen1_ TyVar---- as above, but using a single datacon's name for "the" parameter+-- Like 'GenericKind', but with a payload of a datacon's last universally+-- quantified 'TyVar' in the 'Generic1' case.+--+-- Note that for GADTs, the last TyVar's Name will be different in each data+-- constructor, so it is not correct to simply use the last TyVar in+-- 'tyConTyVars' in 'Gen1_DC'. (See #21185 for an example of what would happen+-- if you tried.) data GenericKind_DC = Gen0_DC | Gen1_DC TyVar -forgetArgVar :: GenericKind_DC -> GenericKind-forgetArgVar Gen0_DC   = Gen0-forgetArgVar Gen1_DC{} = Gen1---- When working only within a single datacon, "the" parameter's name should--- match that datacon's name for it.-gk2gkDC :: GenericKind_ -> DataCon -> GenericKind_DC-gk2gkDC Gen0_   _ = Gen0_DC-gk2gkDC Gen1_{} d = Gen1_DC $ last $ dataConUnivTyVars d+-- Construct a 'GenericKind_DC', retrieving the last universally quantified+-- type variable of a 'DataCon' in the 'Generic1' case.+gk2gkDC :: GenericKind -> DataCon -> [Type] -> GenericKind_DC+gk2gkDC Gen0 _  _       = Gen0_DC+gk2gkDC Gen1 dc tc_args = Gen1_DC $ assert (isTyVarTy last_dc_inst_univ)+                                  $ getTyVar "gk2gkDC" last_dc_inst_univ+  where+    dc_inst_univs = dataConInstUnivs dc tc_args+    last_dc_inst_univ = assert (not (null dc_inst_univs)) $+                        last dc_inst_univs   -- Bindings for the Generic instance-mkBindsRep :: DynFlags -> GenericKind -> TyCon -> (LHsBinds GhcPs, [LSig GhcPs])-mkBindsRep dflags gk tycon = (binds, sigs)+mkBindsRep :: DynFlags -> GenericKind -> SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, [LSig GhcPs])+mkBindsRep dflags gk loc dit@(DerivInstTys{dit_rep_tc = tycon}) = (binds, sigs)       where         binds = unitBag (mkRdrFunBind (L loc' from01_RDR) [from_eqn])               `unionBags`@@ -374,7 +368,6 @@          from_matches  = [mkHsCaseAlt pat rhs | (pat,rhs) <- from_alts]         to_matches    = [mkHsCaseAlt pat rhs | (pat,rhs) <- to_alts  ]-        loc           = srcLocSpan (getSrcLoc tycon)         loc'          = noAnnSrcSpan loc         loc''         = noAnnSrcSpan loc         datacons      = tyConDataCons tycon@@ -385,12 +378,7 @@          -- Recurse over the sum first         from_alts, to_alts :: [Alt]-        (from_alts, to_alts) = mkSum gk_ (1 :: US) datacons-          where gk_ = case gk of-                  Gen0 -> Gen0_-                  Gen1 -> ASSERT(tyvars `lengthAtLeast` 1)-                          Gen1_ (last tyvars)-                    where tyvars = tyConTyVars tycon+        (from_alts, to_alts) = mkSum gk (1 :: US) dit datacons  -------------------------------------------------------------------------------- -- The type synonym instance and synonym@@ -398,12 +386,17 @@ --       type Rep_D a b = ...representation type for D ... -------------------------------------------------------------------------------- -tc_mkRepFamInsts :: GenericKind   -- Gen0 or Gen1-                 -> TyCon         -- The type to generate representation for-                 -> [Type]        -- The type(s) to which Generic(1) is applied-                                  -- in the generated instance-                 -> TcM FamInst   -- Generated representation0 coercion-tc_mkRepFamInsts gk tycon inst_tys =+gen_Generic_fam_inst :: GenericKind      -- Gen0 or Gen1+                     -> (Name -> Fixity) -- Get the Fixity for a data constructor Name+                     -> SrcSpan          -- The current source location+                     -> DerivInstTys     -- Information about the type(s) to which+                                         -- Generic(1) is applied in the generated+                                         -- instance, including the data type's TyCon+                     -> TcM FamInst      -- Generated representation0 coercion+gen_Generic_fam_inst gk get_fixity loc+       dit@(DerivInstTys{ dit_cls_tys = cls_tys+                        , dit_tc = tc, dit_tc_args = tc_args+                        , dit_rep_tc = tycon }) =        -- Consider the example input tycon `D`, where data D a b = D_ a        -- Also consider `R:DInt`, where { data family D x y :: * -> *        --                               ; data instance D Int a b = D_ a }@@ -412,8 +405,6 @@          Gen0 -> tcLookupTyCon repTyConName          Gen1 -> tcLookupTyCon rep1TyConName -     ; fam_envs <- tcGetFamInstEnvs-      ; let -- If the derived instance is            --   instance Generic (Foo x)            -- then:@@ -423,58 +414,28 @@            --   instance Generic1 (Bar x :: k -> *)            -- then:            --   `arg_k` = k, `inst_ty` = Bar x :: k -> *-           (arg_ki, inst_ty) = case (gk, inst_tys) of-             (Gen0, [inst_t])        -> (liftedTypeKind, inst_t)-             (Gen1, [arg_k, inst_t]) -> (arg_k,          inst_t)-             _ -> pprPanic "tc_mkRepFamInsts" (ppr inst_tys)--     ; let mbFamInst         = tyConFamInst_maybe tycon-           -- If we're examining a data family instance, we grab the parent-           -- TyCon (ptc) and use it to determine the type arguments-           -- (inst_args) for the data family *instance*'s type variables.-           ptc               = maybe tycon fst mbFamInst-           (_, inst_args, _) = tcLookupDataFamInst fam_envs ptc $ snd-                                 $ tcSplitTyConApp inst_ty--     ; let -- `tyvars` = [a,b]-           (tyvars, gk_) = case gk of-             Gen0 -> (all_tyvars, Gen0_)-             Gen1 -> ASSERT(not $ null all_tyvars)-                     (init all_tyvars, Gen1_ $ last all_tyvars)-             where all_tyvars = tyConTyVars tycon+           arg_ki = case (gk, cls_tys) of+             (Gen0, [])      -> liftedTypeKind+             (Gen1, [arg_k]) -> arg_k+             _ -> pprPanic "gen_Generic_fam_insts" (ppr cls_tys)+           inst_ty = mkTyConApp tc tc_args+           inst_tys = cls_tys ++ [inst_ty]         -- `repTy` = D1 ... (C1 ... (S1 ... (Rec0 a))) :: * -> *-     ; repTy <- tc_mkRepTy gk_ tycon arg_ki+     ; repTy <- tc_mkRepTy gk get_fixity dit arg_ki         -- `rep_name` is a name we generate for the synonym      ; mod <- getModule-     ; loc <- getSrcSpanM      ; let tc_occ  = nameOccName (tyConName tycon)            rep_occ = case gk of Gen0 -> mkGenR tc_occ; Gen1 -> mkGen1R tc_occ      ; rep_name <- newGlobalBinder mod rep_occ loc -       -- We make sure to substitute the tyvars with their user-supplied-       -- type arguments before generating the Rep/Rep1 instance, since some-       -- of the tyvars might have been instantiated when deriving.-       -- See Note [Generating a correctly typed Rep instance].-     ; let (env_tyvars, env_inst_args)-             = case gk_ of-                 Gen0_ -> (tyvars, inst_args)-                 Gen1_ last_tv-                          -- See the "wrinkle" in-                          -- Note [Generating a correctly typed Rep instance]-                       -> ( last_tv : tyvars-                          , anyTypeOfKind (tyVarKind last_tv) : inst_args )-           env        = zipTyEnv env_tyvars env_inst_args-           in_scope   = mkInScopeSet (tyCoVarsOfTypes inst_tys)-           subst      = mkTvSubst in_scope env-           repTy'     = substTyUnchecked  subst repTy-           tcv'       = tyCoVarsOfTypeList inst_ty-           (tv', cv') = partition isTyVar tcv'-           tvs'       = scopedSort tv'-           cvs'       = scopedSort cv'-           axiom      = mkSingleCoAxiom Nominal rep_name tvs' [] cvs'-                                        fam_tc inst_tys repTy'+     ; let tcv      = tyCoVarsOfTypeList inst_ty+           (tv, cv) = partition isTyVar tcv+           tvs      = scopedSort tv+           cvs      = scopedSort cv+           axiom    = mkSingleCoAxiom Nominal rep_name tvs [] cvs+                                      fam_tc inst_tys repTy       ; newFamInst SynFamilyInst axiom  } @@ -547,16 +508,19 @@             else mkComp phi `fmap` go beta -- It must be a composition.  -tc_mkRepTy ::  -- Gen0_ or Gen1_, for Rep or Rep1-               GenericKind_-              -- The type to generate representation for-            -> TyCon-              -- The kind of the representation type's argument-              -- See Note [Handling kinds in a Rep instance]+tc_mkRepTy ::  -- Gen0 or Gen1, for Rep or Rep1+               GenericKind+               -- Get the Fixity for a data constructor Name+            -> (Name -> Fixity)+               -- Information about the last type argument to Generic(1)+            -> DerivInstTys+               -- The kind of the representation type's argument+               -- See Note [Handling kinds in a Rep instance]             -> Kind                -- Generated representation0 type             -> TcM Type-tc_mkRepTy gk_ tycon k =+tc_mkRepTy gk get_fixity dit@(DerivInstTys{ dit_rep_tc = tycon+                                          , dit_rep_tc_args = tycon_args }) k =   do     d1      <- tcLookupTyCon d1TyConName     c1      <- tcLookupTyCon c1TyConName@@ -596,8 +560,6 @@     pDStr      <- tcLookupPromDataCon decidedStrictDataConName     pDUpk      <- tcLookupPromDataCon decidedUnpackDataConName -    fix_env <- getFixityEnv-     let mkSum' a b = mkTyConApp plus  [k,a,b]         mkProd a b = mkTyConApp times [k,a,b]         mkRec0 a   = mkBoxTy uAddr uChar uDouble uFloat uInt uWord rec0 k a@@ -606,8 +568,8 @@         mkD    a   = mkTyConApp d1 [ k, metaDataTy, sumP (tyConDataCons a) ]         mkC      a = mkTyConApp c1 [ k                                    , metaConsTy a-                                   , prod (map scaledThing . dataConInstOrigArgTys a-                                            . mkTyVarTys . tyConTyVars $ tycon)+                                   , prod (gk2gkDC gk a tycon_args)+                                          (derivDataConInstArgTys a dit)                                           (dataConSrcBangs    a)                                           (dataConImplBangs   a)                                           (dataConFieldLabels a)]@@ -616,28 +578,38 @@         -- Sums and products are done in the same way for both Rep and Rep1         sumP l = foldBal mkSum' (mkTyConApp v1 [k]) . map mkC $ l         -- The Bool is True if this constructor has labelled fields-        prod :: [Type] -> [HsSrcBang] -> [HsImplBang] -> [FieldLabel] -> Type-        prod l sb ib fl = foldBal mkProd (mkTyConApp u1 [k])-                                  [ ASSERT(null fl || lengthExceeds fl j)-                                    arg t sb' ib' (if null fl-                                                      then Nothing-                                                      else Just (fl !! j))+        prod :: GenericKind_DC -> [Type] -> [HsSrcBang] -> [HsImplBang] -> [FieldLabel] -> Type+        prod gk_ l sb ib fl = foldBal mkProd (mkTyConApp u1 [k])+                                  [ assert (null fl || lengthExceeds fl j) $+                                    arg gk_ t sb' ib' (if null fl+                                                       then Nothing+                                                       else Just (fl !! j))                                   | (t,sb',ib',j) <- zip4 l sb ib [0..] ] -        arg :: Type -> HsSrcBang -> HsImplBang -> Maybe FieldLabel -> Type-        arg t (HsSrcBang _ su ss) ib fl = mkS fl su ss ib $ case gk_ of+        arg :: GenericKind_DC -> Type -> HsSrcBang -> HsImplBang -> Maybe FieldLabel -> Type+        arg gk_ t (HsSrcBang _ su ss) ib fl = mkS fl su ss ib $ case gk_ of             -- Here we previously used Par0 if t was a type variable, but we             -- realized that we can't always guarantee that we are wrapping-up             -- all type variables in Par0. So we decided to stop using Par0             -- altogether, and use Rec0 all the time.-                      Gen0_        -> mkRec0 t-                      Gen1_ argVar -> argPar argVar t+                      Gen0_DC        -> mkRec0 t+                      Gen1_DC argVar -> argPar argVar t           where             -- Builds argument representation for Rep1 (more complicated due to             -- the presence of composition).-            argPar argVar = argTyFold argVar $ ArgTyAlg+            argPar argVar =+              let -- If deriving Generic1, make sure to substitute the last+                  -- type variable with Any in the generated Rep1 instance.+                  -- This avoids issues like what is documented in the+                  -- "wrinkle" section of+                  -- Note [Generating a correctly typed Rep instance].+                  env      = zipTyEnv [argVar] [anyTypeOfKind (tyVarKind argVar)]+                  in_scope = mkInScopeSet (tyCoVarsOfTypes tycon_args)+                  subst    = mkTvSubst in_scope env in++              substTy subst . argTyFold argVar (ArgTyAlg               {ata_rec0 = mkRec0, ata_par1 = mkPar1,-               ata_rec1 = mkRec1, ata_comp = mkComp comp k}+               ata_rec1 = mkRec1, ata_comp = mkComp comp k})          tyConName_user = case tyConFamInst_maybe tycon of                            Just (ptycon, _) -> tyConName ptycon@@ -655,7 +627,7 @@         ctName = mkStrLitTy . occNameFS . nameOccName . dataConName         ctFix c             | dataConIsInfix c-            = case lookupFixity fix_env (dataConName c) of+            = case get_fixity (dataConName c) of                    Fixity _ n InfixL -> buildFix n pLA                    Fixity _ n InfixR -> buildFix n pRA                    Fixity _ n InfixN -> buildFix n pNA@@ -737,42 +709,45 @@ -- Dealing with sums -------------------------------------------------------------------------------- -mkSum :: GenericKind_ -- Generic or Generic1?-      -> US          -- Base for generating unique names-      -> [DataCon]   -- The data constructors-      -> ([Alt],     -- Alternatives for the T->Trep "from" function-          [Alt])     -- Alternatives for the Trep->T "to" function+mkSum :: GenericKind  -- Generic or Generic1?+      -> US           -- Base for generating unique names+      -> DerivInstTys -- Information about the last type argument to Generic(1)+      -> [DataCon]    -- The data constructors+      -> ([Alt],      -- Alternatives for the T->Trep "from" function+          [Alt])      -- Alternatives for the Trep->T "to" function  -- Datatype without any constructors-mkSum _ _ [] = ([from_alt], [to_alt])+mkSum _ _ _ [] = ([from_alt], [to_alt])   where     from_alt = (x_Pat, nlHsCase x_Expr [])     to_alt   = (x_Pat, nlHsCase x_Expr [])                -- These M1s are meta-information for the datatype  -- Datatype with at least one constructor-mkSum gk_ us datacons =+mkSum gk us dit datacons =   -- switch the payload of gk_ to be datacon-centric instead of tycon-centric- unzip [ mk1Sum (gk2gkDC gk_ d) us i (length datacons) d+ unzip [ mk1Sum gk us i (length datacons) dit d            | (d,i) <- zip datacons [1..] ]  -- Build the sum for a particular constructor-mk1Sum :: GenericKind_DC -- Generic or Generic1?-       -> US        -- Base for generating unique names-       -> Int       -- The index of this constructor-       -> Int       -- Total number of constructors-       -> DataCon   -- The data constructor-       -> (Alt,     -- Alternative for the T->Trep "from" function-           Alt)     -- Alternative for the Trep->T "to" function-mk1Sum gk_ us i n datacon = (from_alt, to_alt)+mk1Sum :: GenericKind  -- Generic or Generic1?+       -> US           -- Base for generating unique names+       -> Int          -- The index of this constructor+       -> Int          -- Total number of constructors+       -> DerivInstTys -- Information about the last type argument to Generic(1)+       -> DataCon      -- The data constructor+       -> (Alt,        -- Alternative for the T->Trep "from" function+           Alt)        -- Alternative for the Trep->T "to" function+mk1Sum gk us i n dit@(DerivInstTys{dit_rep_tc_args = tc_args}) datacon+  = (from_alt, to_alt)   where-    gk = forgetArgVar gk_+    gk_ = gk2gkDC gk datacon tc_args      -- Existentials already excluded-    argTys = dataConOrigArgTys datacon+    argTys = derivDataConInstArgTys datacon dit     n_args = dataConSourceArity datacon -    datacon_varTys = zip (map mkGenericLocal [us .. us+n_args-1]) (map scaledThing argTys)+    datacon_varTys = zip (map mkGenericLocal [us .. us+n_args-1]) argTys     datacon_vars = map fst datacon_varTys      datacon_rdr  = getRdrName datacon@@ -930,59 +905,55 @@ Note [Generating a correctly typed Rep instance] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ tc_mkRepTy derives the RHS of the Rep(1) type family instance when deriving-Generic(1). That is, it derives the ellipsis in the following:--    instance Generic Foo where-      type Rep Foo = ...+Generic(1). For example, given the following data declaration: -However, tc_mkRepTy only has knowledge of the *TyCon* of the type for which-a Generic(1) instance is being derived, not the fully instantiated type. As a-result, tc_mkRepTy builds the most generalized Rep(1) instance possible using-the type variables it learns from the TyCon (i.e., it uses tyConTyVars). This-can cause problems when the instance has instantiated type variables-(see #11732). As an example:+    data Foo a = MkFoo a+      deriving stock Generic -    data T a = MkT a-    deriving instance Generic (T Int)-    ==>-    instance Generic (T Int) where-      type Rep (T Int) = (... (Rec0 a)) -- wrong!+tc_mkRepTy would generate the `Rec0 a` portion of this instance: --XStandaloneDeriving is one way for the type variables to become instantiated.-Another way is when Generic1 is being derived for a datatype with a visible-kind binder, e.g.,+    instance Generic (Foo a) where+      type Rep (Foo a) = Rec0 a+      ... -   data P k (a :: k) = MkP k deriving Generic1-   ==>-   instance Generic1 (P *) where-     type Rep1 (P *) = (... (Rec0 k)) -- wrong!+(The full `Rep` instance is more complicated than this, but we have simplified+it for presentation purposes.) -See Note [Unify kinds in deriving] in GHC.Tc.Deriv.+`tc_mkRepTy` figures out the field types to use in the RHS by inspecting a+DerivInstTys, which contains the instantiated field types for each data+constructor. (See Note [Instantiating field types in stock deriving] for a+description of how this works.) As a result, `tc_mkRepTy` "just works" even+when dealing with StandaloneDeriving, such as in this example: -In any such scenario, we must prevent a discrepancy between the LHS and RHS of-a Rep(1) instance. To do so, we create a type variable substitution that maps-the tyConTyVars of the TyCon to their counterparts in the fully instantiated-type. (For example, using T above as example, you'd map a :-> Int.) We then-apply the substitution to the RHS before generating the instance.+    deriving stock instance Generic (Foo Int)+      ===>+    instance Generic (Foo Int) where+      type Rep (Foo Int) = Rec0 Int -- The `a` has been instantiated here -A wrinkle in all of this: when forming the type variable substitution for-Generic1 instances, we map the last type variable of the tycon to Any. Why?-It's because of wily data types like this one (#15012):+A wrinkle in all of this: what happens when deriving a Generic1 instance where+the last type variable appears in a type synonym that discards it? That is,+what should happen in this example (taken from #15012)? -   data T a = MkT (FakeOut a)-   type FakeOut a = Int+    type FakeOut a = Int+    data T a = MkT (FakeOut a)+      deriving Generic1 -If we ignore a, then we'll produce the following Rep1 instance:+MkT is a particularly wily data constructor. Although the last type variable+`a` technically appears in `FakeOut a`, it's just a smokescreen, as `FakeOut a`+simply expands to `Int`. As a result, `MkT` doesn't really *use* the last type+variable. Therefore, T's `Rep` instance would use Rec0 to represent MkT's+field. But we must be careful not to produce code like this:     instance Generic1 T where-     type Rep1 T = ... (Rec0 (FakeOut a))+     type Rep1 T = Rec0 (FakeOut a)      ... -Oh no! Now we have `a` on the RHS, but it's completely unbound. Instead, we-ensure that `a` is mapped to Any:+Oh no! Now we have `a` on the RHS, but it's completely unbound. This can cause+issues like what was observed in #15012. To avoid this, we ensure that `a` is+instantiated to Any:     instance Generic1 T where-     type Rep1 T = ... (Rec0 (FakeOut Any))+     type Rep1 T = Rec0 (FakeOut Any)      ...  And now all is good.
GHC/Tc/Deriv/Infer.hs view
@@ -4,7 +4,7 @@  -} -{-# LANGUAGE CPP #-}+ {-# LANGUAGE MultiWayIf #-}  -- | Functions for inferring (and simplifying) the context for derived instances.@@ -14,8 +14,6 @@    ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Data.Bag@@ -23,9 +21,9 @@ import GHC.Core.Class import GHC.Core.DataCon import GHC.Utils.Error-import GHC.Tc.Utils.Instantiate import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Data.Pair import GHC.Builtin.Names import GHC.Tc.Deriv.Utils@@ -43,8 +41,9 @@ import GHC.Core.TyCo.Ppr (pprTyVars) import GHC.Core.Type import GHC.Tc.Solver+import GHC.Tc.Solver.Monad ( runTcS ) import GHC.Tc.Validity (validDerivPred)-import GHC.Tc.Utils.Unify (buildImplicationFor, checkConstraints)+import GHC.Tc.Utils.Unify (buildImplicationFor) import GHC.Builtin.Types (typeToTypeKind) import GHC.Core.Unify (tcUnifyTy) import GHC.Utils.Misc@@ -60,7 +59,7 @@ ----------------------  inferConstraints :: DerivSpecMechanism-                 -> DerivM ([ThetaOrigin], [TyVar], [TcType])+                 -> DerivM (ThetaSpec, [TyVar], [TcType], DerivSpecMechanism) -- inferConstraints figures out the constraints needed for the -- instance declaration generated by a 'deriving' clause on a -- data type declaration. It also returns the new in-scope type@@ -81,11 +80,13 @@                   , denv_cls      = main_cls                   , denv_inst_tys = inst_tys } <- ask        ; wildcard <- isStandaloneWildcardDeriv-       ; let infer_constraints :: DerivM ([ThetaOrigin], [TyVar], [TcType])+       ; let infer_constraints :: DerivM (ThetaSpec, [TyVar], [TcType], DerivSpecMechanism)              infer_constraints =                case mechanism of                  DerivSpecStock{dsm_stock_dit = dit}-                   -> inferConstraintsStock dit+                   -> do (thetas, tvs, inst_tys, dit') <- inferConstraintsStock dit+                         pure ( thetas, tvs, inst_tys+                              , mechanism{dsm_stock_dit = dit'} )                  DerivSpecAnyClass                    -> infer_constraints_simple inferConstraintsAnyclass                  DerivSpecNewtype { dsm_newtype_dit =@@ -104,30 +105,31 @@              -- this rule is stock deriving. See              -- Note [Inferring the instance context].              infer_constraints_simple-               :: DerivM [ThetaOrigin]-               -> DerivM ([ThetaOrigin], [TyVar], [TcType])+               :: DerivM ThetaSpec+               -> DerivM (ThetaSpec, [TyVar], [TcType], DerivSpecMechanism)              infer_constraints_simple infer_thetas = do                thetas <- infer_thetas-               pure (thetas, tvs, inst_tys)+               pure (thetas, tvs, inst_tys, mechanism)               -- Constraints arising from superclasses              -- See Note [Superclasses of derived instance]              cls_tvs  = classTyVars main_cls-             sc_constraints = ASSERT2( equalLength cls_tvs inst_tys-                                     , ppr main_cls <+> ppr inst_tys )-                              [ mkThetaOrigin (mkDerivOrigin wildcard)-                                              TypeLevel [] [] [] $-                                substTheta cls_subst (classSCTheta main_cls) ]-             cls_subst = ASSERT( equalLength cls_tvs inst_tys )+             sc_constraints = assertPpr (equalLength cls_tvs inst_tys)+                                        (ppr main_cls <+> ppr inst_tys) $+                              mkDirectThetaSpec+                                (mkDerivOrigin wildcard) TypeLevel+                                (substTheta cls_subst (classSCTheta main_cls))+             cls_subst = assert (equalLength cls_tvs inst_tys) $                          zipTvSubst cls_tvs inst_tys -       ; (inferred_constraints, tvs', inst_tys') <- infer_constraints+       ; (inferred_constraints, tvs', inst_tys', mechanism')+           <- infer_constraints        ; lift $ traceTc "inferConstraints" $ vcat               [ ppr main_cls <+> ppr inst_tys'               , ppr inferred_constraints               ]        ; return ( sc_constraints ++ inferred_constraints-                , tvs', inst_tys' ) }+                , tvs', inst_tys', mechanism' ) }  -- | Like 'inferConstraints', but used only in the case of the @stock@ deriving -- strategy. The constraints are inferred by inspecting the fields of each data@@ -135,7 +137,7 @@ -- -- > data Foo = MkFoo Int Char deriving Show ----- We would infer the following constraints ('ThetaOrigin's):+-- We would infer the following constraints ('ThetaSpec's): -- -- > (Show Int, Show Char) --@@ -153,12 +155,12 @@ -- 'TyVar's/'TcType's, /not/ @[k]@/@[k, f, g]@. -- See Note [Inferring the instance context]. inferConstraintsStock :: DerivInstTys-                      -> DerivM ([ThetaOrigin], [TyVar], [TcType])-inferConstraintsStock (DerivInstTys { dit_cls_tys     = cls_tys-                                    , dit_tc          = tc-                                    , dit_tc_args     = tc_args-                                    , dit_rep_tc      = rep_tc-                                    , dit_rep_tc_args = rep_tc_args })+                      -> DerivM (ThetaSpec, [TyVar], [TcType], DerivInstTys)+inferConstraintsStock dit@(DerivInstTys { dit_cls_tys     = cls_tys+                                        , dit_tc          = tc+                                        , dit_tc_args     = tc_args+                                        , dit_rep_tc      = rep_tc+                                        , dit_rep_tc_args = rep_tc_args })   = do DerivEnv { denv_tvs      = tvs                 , denv_cls      = main_cls                 , denv_inst_tys = inst_tys } <- ask@@ -176,22 +178,36 @@            con_arg_constraints              :: (CtOrigin -> TypeOrKind                           -> Type-                          -> [([PredOrigin], Maybe TCvSubst)])-             -> ([ThetaOrigin], [TyVar], [TcType])+                          -> [(ThetaSpec, Maybe TCvSubst)])+             -> (ThetaSpec, [TyVar], [TcType], DerivInstTys)            con_arg_constraints get_arg_constraints-             = let (predss, mbSubsts) = unzip+             = let -- Constraints from the fields of each data constructor.+                   (predss, mbSubsts) = unzip                      [ preds_and_mbSubst                      | data_con <- tyConDataCons rep_tc                      , (arg_n, arg_t_or_k, arg_ty)                          <- zip3 [1..] t_or_ks $-                            dataConInstOrigArgTys data_con all_rep_tc_args+                            derivDataConInstArgTys data_con dit                        -- No constraints for unlifted types                        -- See Note [Deriving and unboxed types]-                     , not (isUnliftedType (irrelevantMult arg_ty))+                     , not (isUnliftedType arg_ty)                      , let orig = DerivOriginDC data_con arg_n wildcard                      , preds_and_mbSubst-                         <- get_arg_constraints orig arg_t_or_k (irrelevantMult arg_ty)+                         <- get_arg_constraints orig arg_t_or_k arg_ty                      ]+                   -- Stupid constraints from DatatypeContexts. Note that we+                   -- must gather these constraints from the data constructors,+                   -- not from the parent type constructor, as the latter could+                   -- lead to redundant constraints due to thinning.+                   -- See Note [The stupid context] in GHC.Core.DataCon.+                   stupid_theta =+                     [ substTyWith (dataConUnivTyVars data_con)+                                   (dataConInstUnivs data_con rep_tc_args)+                                   stupid_pred+                     | data_con <- tyConDataCons rep_tc+                     , stupid_pred <- dataConStupidTheta data_con+                     ]+                    preds = concat predss                    -- If the constraints require a subtype to be of kind                    -- (* -> *) (which is the case for functor-like@@ -203,10 +219,15 @@                    unmapped_tvs = filter (\v -> v `notElemTCvSubst` subst                                              && not (v `isInScope` subst)) tvs                    (subst', _)  = substTyVarBndrs subst unmapped_tvs-                   preds'       = map (substPredOrigin subst') preds+                   stupid_theta_origin = mkDirectThetaSpec+                                           deriv_origin TypeLevel+                                           (substTheta subst' stupid_theta)+                   preds'       = map (substPredSpec subst') preds                    inst_tys'    = substTys subst' inst_tys+                   dit'         = substDerivInstTys subst' dit                    tvs'         = tyCoVarsOfTypesWellScoped inst_tys'-               in ([mkThetaOriginFromPreds preds'], tvs', inst_tys')+               in ( stupid_theta_origin ++ preds'+                  , tvs', inst_tys', dit' )             is_generic  = main_cls `hasKey` genClassKey            is_generic1 = main_cls `hasKey` gen1ClassKey@@ -215,13 +236,13 @@                           || is_generic1             get_gen1_constraints :: Class -> CtOrigin -> TypeOrKind -> Type-                                -> [([PredOrigin], Maybe TCvSubst)]+                                -> [(ThetaSpec, Maybe TCvSubst)]            get_gen1_constraints functor_cls orig t_or_k ty               = mk_functor_like_constraints orig t_or_k functor_cls $                 get_gen1_constrained_tys last_tv ty             get_std_constrained_tys :: CtOrigin -> TypeOrKind -> Type-                                   -> [([PredOrigin], Maybe TCvSubst)]+                                   -> [(ThetaSpec, Maybe TCvSubst)]            get_std_constrained_tys orig t_or_k ty                | is_functor_like                = mk_functor_like_constraints orig t_or_k main_cls $@@ -232,7 +253,7 @@             mk_functor_like_constraints :: CtOrigin -> TypeOrKind                                        -> Class -> [Type]-                                       -> [([PredOrigin], Maybe TCvSubst)]+                                       -> [(ThetaSpec, Maybe TCvSubst)]            -- 'cls' is usually main_cls (Functor or Traversable etc), but if            -- main_cls = Generic1, then 'cls' can be Functor; see            -- get_gen1_constraints@@ -247,31 +268,18 @@            mk_functor_like_constraints orig t_or_k cls               = map $ \ty -> let ki = tcTypeKind ty in                              ( [ mk_cls_pred orig t_or_k cls ty-                               , mkPredOrigin orig KindLevel-                                   (mkPrimEqPred ki typeToTypeKind) ]+                               , SimplePredSpec+                                   { sps_pred = mkPrimEqPred ki typeToTypeKind+                                   , sps_origin = orig+                                   , sps_type_or_kind = KindLevel+                                   }+                               ]                              , tcUnifyTy ki typeToTypeKind                              )             rep_tc_tvs      = tyConTyVars rep_tc            last_tv         = last rep_tc_tvs-           -- When we first gather up the constraints to solve, most of them-           -- contain rep_tc_tvs, i.e., the type variables from the derived-           -- datatype's type constructor. We don't want these type variables-           -- to appear in the final instance declaration, so we must-           -- substitute each type variable with its counterpart in the derived-           -- instance. rep_tc_args lists each of these counterpart types in-           -- the same order as the type variables.-           all_rep_tc_args = tyConInstArgTys rep_tc rep_tc_args -               -- Stupid constraints-           stupid_constraints-             = [ mkThetaOrigin deriv_origin TypeLevel [] [] [] $-                 substTheta tc_subst (tyConStupidTheta rep_tc) ]-           tc_subst = -- See the comment with all_rep_tc_args for an-                      -- explanation of this assertion-                      ASSERT( equalLength rep_tc_tvs all_rep_tc_args )-                      zipTvSubst rep_tc_tvs all_rep_tc_args-            -- Extra Data constraints            -- The Data class (only) requires that for            --    instance (...) => Data (T t1 t2)@@ -280,9 +288,7 @@            -- Reason: when the IF holds, we generate a method            --             dataCast2 f = gcast2 f            --         and we need the Data constraints to typecheck the method-           extra_constraints = [mkThetaOriginFromPreds constrs]-             where-               constrs+           extra_constraints                  | main_cls `hasKey` dataClassKey                  , all (isLiftedTypeKind . tcTypeKind) rep_tc_args                  = [ mk_cls_pred deriv_origin t_or_k main_cls ty@@ -292,7 +298,11 @@             mk_cls_pred orig t_or_k cls ty                 -- Don't forget to apply to cls_tys' too-              = mkPredOrigin orig t_or_k (mkClassPred cls (cls_tys' ++ [ty]))+              = SimplePredSpec+                  { sps_pred = mkClassPred cls (cls_tys' ++ [ty])+                  , sps_origin = orig+                  , sps_type_or_kind = t_or_k+                  }            cls_tys' | is_generic1 = []                       -- In the awkward Generic1 case, cls_tys' should be                       -- empty, since we are applying the class Functor.@@ -303,34 +313,28 @@         if    -- Generic constraints are easy           |  is_generic-           -> return ([], tvs, inst_tys)+           -> return ([], tvs, inst_tys, dit)               -- Generic1 needs Functor              -- See Note [Getting base classes]           |  is_generic1-           -> ASSERT( rep_tc_tvs `lengthExceeds` 0 )+           -> assert (rep_tc_tvs `lengthExceeds` 0) $               -- Generic1 has a single kind variable-              ASSERT( cls_tys `lengthIs` 1 )+              assert (cls_tys `lengthIs` 1) $               do { functorClass <- lift $ tcLookupClass functorClassName                  ; pure $ con_arg_constraints                         $ get_gen1_constraints functorClass }               -- The others are a bit more complicated           |  otherwise-           -> -- See the comment with all_rep_tc_args for an explanation of-              -- this assertion-              ASSERT2( equalLength rep_tc_tvs all_rep_tc_args-                     , ppr main_cls <+> ppr rep_tc-                       $$ ppr rep_tc_tvs $$ ppr all_rep_tc_args )-                do { let (arg_constraints, tvs', inst_tys')-                           = con_arg_constraints get_std_constrained_tys-                   ; lift $ traceTc "inferConstraintsStock" $ vcat-                          [ ppr main_cls <+> ppr inst_tys'-                          , ppr arg_constraints-                          ]-                   ; return ( stupid_constraints ++ extra_constraints-                                                 ++ arg_constraints-                            , tvs', inst_tys') }+           -> do { let (arg_constraints, tvs', inst_tys', dit')+                         = con_arg_constraints get_std_constrained_tys+                 ; lift $ traceTc "inferConstraintsStock" $ vcat+                        [ ppr main_cls <+> ppr inst_tys'+                        , ppr arg_constraints+                        ]+                 ; return ( extra_constraints ++ arg_constraints+                          , tvs', inst_tys', dit' ) }  -- | Like 'inferConstraints', but used only in the case of @DeriveAnyClass@, -- which gathers its constraints based on the type signatures of the class's@@ -339,36 +343,32 @@ -- See Note [Gathering and simplifying constraints for DeriveAnyClass] -- for an explanation of how these constraints are used to determine the -- derived instance context.-inferConstraintsAnyclass :: DerivM [ThetaOrigin]+inferConstraintsAnyclass :: DerivM ThetaSpec inferConstraintsAnyclass-  = do { DerivEnv { denv_cls      = cls-                  , denv_inst_tys = inst_tys } <- ask-       ; wildcard <- isStandaloneWildcardDeriv-+  = do { DerivEnv { denv_cls       = cls+                  , denv_inst_tys  = inst_tys } <- ask        ; let gen_dms = [ (sel_id, dm_ty)                        | (sel_id, Just (_, GenericDM dm_ty)) <- classOpItems cls ]--             cls_tvs = classTyVars cls+       ; wildcard <- isStandaloneWildcardDeriv -             do_one_meth :: (Id, Type) -> TcM ThetaOrigin+       ; let meth_pred :: (Id, Type) -> PredSpec                -- (Id,Type) are the selector Id and the generic default method type                -- NB: the latter is /not/ quantified over the class variables                -- See Note [Gathering and simplifying constraints for DeriveAnyClass]-             do_one_meth (sel_id, gen_dm_ty)-               = do { let (sel_tvs, _cls_pred, meth_ty)-                                   = tcSplitMethodTy (varType sel_id)-                          meth_ty' = substTyWith sel_tvs inst_tys meth_ty-                          (meth_tvs, meth_theta, meth_tau)-                                   = tcSplitNestedSigmaTys meth_ty'--                          gen_dm_ty' = substTyWith cls_tvs inst_tys gen_dm_ty-                          (dm_tvs, dm_theta, dm_tau)-                                     = tcSplitNestedSigmaTys gen_dm_ty'-                          tau_eq     = mkPrimEqPred meth_tau dm_tau-                    ; return (mkThetaOrigin (mkDerivOrigin wildcard) TypeLevel-                                meth_tvs dm_tvs meth_theta (tau_eq:dm_theta)) }+             meth_pred (sel_id, gen_dm_ty)+               = let (sel_tvs, _cls_pred, meth_ty) = tcSplitMethodTy (varType sel_id)+                     meth_ty'   = substTyWith sel_tvs inst_tys meth_ty+                     gen_dm_ty' = substTyWith sel_tvs inst_tys gen_dm_ty in+                 -- This is the only place where a SubTypePredSpec is+                 -- constructed instead of a SimplePredSpec. See+                 -- Note [Gathering and simplifying constraints for DeriveAnyClass]+                 -- for a more in-depth explanation.+                 SubTypePredSpec { stps_ty_actual = gen_dm_ty'+                                 , stps_ty_expected = meth_ty'+                                 , stps_origin = mkDerivOrigin wildcard+                                 } -       ; lift $ mapM do_one_meth gen_dms }+       ; pure $ map meth_pred gen_dms }  -- Like 'inferConstraints', but used only for @GeneralizedNewtypeDeriving@ and -- @DerivingVia@. Since both strategies generate code involving 'coerce', the@@ -377,11 +377,11 @@ -- -- > newtype Age = MkAge Int deriving newtype Num ----- We would infer the following constraints ('ThetaOrigin's):+-- We would infer the following constraints ('ThetaSpec'): -- -- > (Num Int, Coercible Age Int) inferConstraintsCoerceBased :: [Type] -> Type-                            -> DerivM [ThetaOrigin]+                            -> DerivM ThetaSpec inferConstraintsCoerceBased cls_tys rep_ty = do   DerivEnv { denv_tvs      = tvs            , denv_cls      = cls@@ -393,7 +393,10 @@       -- (for DerivingVia).       rep_tys ty  = cls_tys ++ [ty]       rep_pred ty = mkClassPred cls (rep_tys ty)-      rep_pred_o ty = mkPredOrigin deriv_origin TypeLevel (rep_pred ty)+      rep_pred_o ty = SimplePredSpec { sps_pred = rep_pred ty+                                     , sps_origin = deriv_origin+                                     , sps_type_or_kind = TypeLevel+                                     }               -- rep_pred is the representation dictionary, from where               -- we are going to get all the methods for the final               -- dictionary@@ -403,23 +406,23 @@       -- If there are no methods, we don't need any constraints       -- Otherwise we need (C rep_ty), for the representation methods,       -- and constraints to coerce each individual method-      meth_preds :: Type -> [PredOrigin]+      meth_preds :: Type -> ThetaSpec       meth_preds ty         | null meths = [] -- No methods => no constraints                           -- (#12814)         | otherwise = rep_pred_o ty : coercible_constraints ty       meths = classMethods cls       coercible_constraints ty-        = [ mkPredOrigin (DerivOriginCoerce meth t1 t2 sa_wildcard)-                         TypeLevel (mkReprPrimEqPred t1 t2)+        = [ SimplePredSpec+              { sps_pred = mkReprPrimEqPred t1 t2+              , sps_origin = DerivOriginCoerce meth t1 t2 sa_wildcard+              , sps_type_or_kind = TypeLevel+              }           | meth <- meths           , let (Pair t1 t2) = mkCoerceClassMethEqn cls tvs                                        inst_tys ty meth ] -      all_thetas :: Type -> [ThetaOrigin]-      all_thetas ty = [mkThetaOriginFromPreds $ meth_preds ty]--  pure (all_thetas rep_ty)+  pure (meth_preds rep_ty)  {- Note [Inferring the instance context] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -633,7 +636,7 @@ -}  -simplifyInstanceContexts :: [DerivSpec [ThetaOrigin]]+simplifyInstanceContexts :: [DerivSpec ThetaSpec]                          -> TcM [DerivSpec ThetaType] -- Used only for deriving clauses or standalone deriving with an -- extra-constraints wildcard (InferContext)@@ -643,7 +646,10 @@  simplifyInstanceContexts infer_specs   = do  { traceTc "simplifyInstanceContexts" $ vcat (map pprDerivSpec infer_specs)-        ; iterate_deriv 1 initial_solutions }+        ; final_specs <- iterate_deriv 1 initial_solutions+          -- After simplification finishes, zonk the TcTyVars as described+          -- in Note [Overlap and deriving].+        ; traverse zonkDerivSpec final_specs }   where     ------------------------------------------------------------------         -- The initial solutions for the equations claim that each@@ -667,13 +673,14 @@       | otherwise       = do {      -- Extend the inst info from the explicit instance decls                   -- with the current set of solutions, and simplify each RHS-             inst_specs <- zipWithM newDerivClsInst current_solns infer_specs+             inst_specs <- zipWithM (\soln -> newDerivClsInst . setDerivSpecTheta soln)+                                    current_solns infer_specs            ; new_solns <- checkNoErrs $                           extendLocalInstEnv inst_specs $                           mapM gen_soln infer_specs             ; if (current_solns `eqSolution` new_solns) then-                return [ spec { ds_theta = soln }+                return [ setDerivSpecTheta soln spec                        | (spec, soln) <- zip infer_specs current_solns ]              else                 iterate_deriv (n+1) new_solns }@@ -683,12 +690,13 @@        -- See Note [Deterministic simplifyInstanceContexts]     canSolution = map (sortBy nonDetCmpType)     -------------------------------------------------------------------    gen_soln :: DerivSpec [ThetaOrigin] -> TcM ThetaType+    gen_soln :: DerivSpec ThetaSpec -> TcM ThetaType     gen_soln (DS { ds_loc = loc, ds_tvs = tyvars-                 , ds_cls = clas, ds_tys = inst_tys, ds_theta = deriv_rhs })+                 , ds_cls = clas, ds_tys = inst_tys, ds_theta = deriv_rhs+                 , ds_skol_info = skol_info, ds_user_ctxt = user_ctxt })       = setSrcSpan loc  $         addErrCtxt (derivInstCtxt the_pred) $-        do { theta <- simplifyDeriv the_pred tyvars deriv_rhs+        do { theta <- simplifyDeriv skol_info user_ctxt tyvars deriv_rhs                 -- checkValidInstance tyvars theta clas inst_tys                 -- Not necessary; see Note [Exotic derived instance contexts] @@ -714,87 +722,35 @@  -- | Given @instance (wanted) => C inst_ty@, simplify 'wanted' as much -- as possible. Fail if not possible.-simplifyDeriv :: PredType -- ^ @C inst_ty@, head of the instance we are-                          -- deriving.  Only used for SkolemInfo.-              -> [TyVar]  -- ^ The tyvars bound by @inst_ty@.-              -> [ThetaOrigin] -- ^ Given and wanted constraints+simplifyDeriv :: SkolemInfo -- ^ The 'SkolemInfo' used to skolemise the+                            -- 'TcTyVar' arguments+              -> UserTypeCtxt -- ^ Used to inform error messages as to whether+                              -- we are in a @deriving@ clause or a standalone+                              -- @deriving@ declaration+              -> [TcTyVar]  -- ^ The tyvars bound by @inst_ty@.+              -> ThetaSpec -- ^ The constraints to solve and simplify               -> TcM ThetaType -- ^ Needed constraints (after simplification),                                -- i.e. @['PredType']@.-simplifyDeriv pred tvs thetas-  = do { (skol_subst, tvs_skols) <- tcInstSkolTyVars tvs -- Skolemize-                -- The constraint solving machinery-                -- expects *TcTyVars* not TyVars.-                -- We use *non-overlappable* (vanilla) skolems-                -- See Note [Overlap and deriving]--       ; let skol_set  = mkVarSet tvs_skols-             skol_info = DerivSkol pred-             doc = text "deriving" <+> parens (ppr pred)--             mk_given_ev :: PredType -> TcM EvVar-             mk_given_ev given =-               let given_pred = substTy skol_subst given-               in newEvVar given_pred--             emit_wanted_constraints :: [TyVar] -> [PredOrigin] -> TcM ()-             emit_wanted_constraints metas_to_be preds-               = do { -- We instantiate metas_to_be with fresh meta type-                      -- variables. Currently, these can only be type variables-                      -- quantified in generic default type signatures.-                      -- See Note [Gathering and simplifying constraints for-                      -- DeriveAnyClass]-                      (meta_subst, _meta_tvs) <- newMetaTyVars metas_to_be--                    -- Now make a constraint for each of the instantiated predicates-                    ; let wanted_subst = skol_subst `unionTCvSubst` meta_subst-                          mk_wanted_ct (PredOrigin wanted orig t_or_k)-                            = do { ev <- newWanted orig (Just t_or_k) $-                                         substTyUnchecked wanted_subst wanted-                                 ; return (mkNonCanonical ev) }-                    ; cts <- mapM mk_wanted_ct preds--                    -- And emit them into the monad-                    ; emitSimples (listToCts cts) }--             -- Create the implications we need to solve. For stock and newtype-             -- deriving, these implication constraints will be simple class-             -- constraints like (C a, Ord b).-             -- But with DeriveAnyClass, we make an implication constraint.-             -- See Note [Gathering and simplifying constraints for DeriveAnyClass]-             mk_wanteds :: ThetaOrigin -> TcM WantedConstraints-             mk_wanteds (ThetaOrigin { to_anyclass_skols  = ac_skols-                                     , to_anyclass_metas  = ac_metas-                                     , to_anyclass_givens = ac_givens-                                     , to_wanted_origins  = preds })-               = do { ac_given_evs <- mapM mk_given_ev ac_givens-                    ; (_, wanteds)-                        <- captureConstraints $-                           checkConstraints skol_info ac_skols ac_given_evs $-                              -- The checkConstraints bumps the TcLevel, and-                              -- wraps the wanted constraints in an implication,-                              -- when (but only when) necessary-                           emit_wanted_constraints ac_metas preds-                    ; pure wanteds }+simplifyDeriv skol_info user_ctxt tvs theta+  = do { let skol_set = mkVarSet tvs         -- See [STEP DAC BUILD]        -- Generate the implication constraints, one for each method, to solve        -- with the skolemized variables.  Start "one level down" because-       -- we are going to wrap the result in an implication with tvs_skols,+       -- we are going to wrap the result in an implication with tvs,        -- in step [DAC RESIDUAL]-       ; (tc_lvl, wanteds) <- pushTcLevelM $-                              mapM mk_wanteds thetas+       ; (tc_lvl, wanteds) <- captureThetaSpecConstraints user_ctxt theta         ; traceTc "simplifyDeriv inputs" $-         vcat [ pprTyVars tvs $$ ppr thetas $$ ppr wanteds, doc ]+         vcat [ pprTyVars tvs $$ ppr theta $$ ppr wanteds, ppr skol_info ]         -- See [STEP DAC SOLVE]        -- Simplify the constraints, starting at the same level at which        -- they are generated (c.f. the call to runTcSWithEvBinds in        -- simplifyInfer)-       ; solved_wanteds <- setTcLevel tc_lvl   $-                           runTcSDeriveds      $-                           solveWantedsAndDrop $-                           unionsWC wanteds+       ; (solved_wanteds, _) <- setTcLevel tc_lvl $+                                runTcS            $+                                solveWanteds wanteds         -- It's not yet zonked!  Obviously zonk it before peering at it        ; solved_wanteds <- zonkWC solved_wanteds@@ -812,19 +768,13 @@              -- constitutes an exotic constraint.              get_good :: Ct -> Maybe PredType              get_good ct | validDerivPred skol_set p-                         , isWantedCt ct                          = Just p-                          -- TODO: This is wrong-                          -- NB re 'isWantedCt': residual_wanted may contain-                          -- unsolved CtDerived and we stick them into the-                          -- bad set so that reportUnsolved may decide what-                          -- to do with them                          | otherwise                          = Nothing-                           where p = ctPred ct+               where p = ctPred ct         ; traceTc "simplifyDeriv outputs" $-         vcat [ ppr tvs_skols, ppr residual_simple, ppr good ]+         vcat [ ppr tvs, ppr residual_simple, ppr good ]         -- Return the good unsolved constraints (unskolemizing on the way out.)        ; let min_theta = mkMinimalBySCs id (bagToList good)@@ -834,8 +784,6 @@              -- constraints.              -- See Note [Gathering and simplifying constraints for              --           DeriveAnyClass]-             subst_skol = zipTvSubst tvs_skols $ mkTyVarTys tvs-                          -- The reverse substitution (sigh)         -- See [STEP DAC RESIDUAL]        -- Ensure that min_theta is enough to solve /all/ the constraints in@@ -844,7 +792,7 @@        --    forall tvs. min_theta => solved_wanteds        ; min_theta_vars <- mapM newEvVar min_theta        ; (leftover_implic, _)-           <- buildImplicationFor tc_lvl skol_info tvs_skols+           <- buildImplicationFor tc_lvl (getSkolemInfo skol_info) tvs                                   min_theta_vars solved_wanteds        -- This call to simplifyTop is purely for error reporting        -- See Note [Error reporting for deriving clauses]@@ -852,7 +800,7 @@        -- in this line of code.        ; simplifyTopImplic leftover_implic -       ; return (substTheta subst_skol min_theta) }+       ; return min_theta }  {- Note [Overlap and deriving]@@ -876,10 +824,21 @@ and we want to infer    f :: Show [a] => a -> String -BOTTOM LINE: use vanilla, non-overlappable skolems when inferring-             the context for the derived instance.-             Hence tcInstSkolTyVars not tcInstSuperSkolTyVars+As a result, we use vanilla, non-overlappable skolems when inferring the+context for the derived instances. Hence, we instantiate the type variables+using tcInstSkolTyVars, not tcInstSuperSkolTyVars. +We do this skolemisation in GHC.Tc.Deriv.mkEqnHelp, a function which occurs+very early in the deriving pipeline, so that by the time GHC needs to infer the+instance context, all of the types in the computed DerivSpec have been+skolemised appropriately. After the instance context inference has completed,+GHC zonks the TcTyVars in the DerivSpec to ensure that types like+a[sk:1] do not appear in -ddump-deriv output.++All of this is only needed when inferring an instance context, i.e., the+InferContext case. For the SupplyContext case, we don't bother skolemising+at all.+ Note [Gathering and simplifying constraints for DeriveAnyClass] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ DeriveAnyClass works quite differently from stock and newtype deriving in@@ -909,7 +868,7 @@   $gdm_bar x y = show x ++ show (range (y,y))  (and similarly for baz).  Now consider a 'deriving' clause-  data Maybe s = ... deriving Foo+  data Maybe s = ... deriving anyclass Foo  This derives an instance of the form:   instance (CX) => Foo (Maybe s) where@@ -918,15 +877,35 @@  Now it is GHC's job to fill in a suitable instance context (CX).  If GHC were typechecking the binding-   bar = $gdm bar+   bar = $gdm_bar it would    * skolemise the expected type of bar    * instantiate the type of $gdm_bar with meta-type variables    * build an implication constraint  [STEP DAC BUILD]-So that's what we do.  We build the constraint (call it C1)+So that's what we do. Fortunately, there is already functionality within GHC+to that does all of the above—namely, tcSubTypeSigma. In the example above,+we want to use tcSubTypeSigma to check the following subtyping relation: +     forall c. (Show a, Ix c) => Maybe s -> c -> String -- actual type+  <= forall b.         (Ix b) => Maybe s -> b -> String -- expected type++That is, we check that the type of $gdm_bar (the actual type) is more+polymorphic than the type of bar (the expected type). We use SubTypePredSpec,+a special form of PredSpec that is only used by DeriveAnyClass, to store+the actual and expected types.++(Aside: having a separate SubTypePredSpec is not strictly necessary, as we+could theoretically construct this implication constraint by hand and store it+in a SimplePredSpec. In fact, GHC used to do this. However, this is easier+said than done, and there were numerous subtle bugs that resulted from getting+this step wrong, such as #20719. Ultimately, we decided that special-casing a+PredSpec specifically for DeriveAnyClass was worth it.)++tcSubTypeSigma will ultimately spit out an implication constraint, which will+look something like this (call it C1):+    forall[2] b. Ix b => (Show (Maybe s), Ix cc,                         Maybe s -> b -> String                             ~ Maybe s -> cc -> String)@@ -936,15 +915,32 @@   going to wrap it in a forall[1] in [STEP DAC RESIDUAL]  * The 'b' comes from the quantified type variable in the expected type-  of bar (i.e., 'to_anyclass_skols' in 'ThetaOrigin'). The 'cc' is a unification-  variable that comes from instantiating the quantified type variable 'c' in-  $gdm_bar's type (i.e., 'to_anyclass_metas' in 'ThetaOrigin).+  of bar. The 'cc' is a unification variable that comes from instantiating the+  quantified type variable 'c' in $gdm_bar's type. The finer details of+  skolemisation and metavariable instantiation are handled behind the scenes+  by tcSubTypeSigma. -* The (Ix b) constraint comes from the context of bar's type-  (i.e., 'to_wanted_givens' in 'ThetaOrigin'). The (Show (Maybe s)) and (Ix cc)-  constraints come from the context of $gdm_bar's type-  (i.e., 'to_anyclass_givens' in 'ThetaOrigin').+* It is important that `b` be distinct from `cc`. In this example, this is+  clearly the case, but it is not always so obvious when the type variables are+  hidden behind type synonyms. Suppose the example were written like this,+  for example: +    type Method a = forall b. Ix b => a -> b -> String+    class Foo a where+      bar :: Method a+      default bar :: Show a => Method a+      bar = ...++  Both method signatures quantify a `b` once the `Method` type synonym is+  expanded. To ensure that GHC doesn't confuse the two `b`s during+  typechecking, tcSubTypeSigma instantiates the `b` in the original signature+  with a fresh skolem and the `b` in the default signature with a fresh+  unification variable. Doing so prevents #20719 from happening.++* The (Ix b) constraint comes from the context of bar's type. The+  (Show (Maybe s)) and (Ix cc) constraints come from the context of $gdm_bar's+  type.+ * The equality constraint (Maybe s -> b -> String) ~ (Maybe s -> cc -> String)   comes from marrying up the instantiated type of $gdm_bar with the specified   type of bar. Notice that the type variables from the instance, 's' in this@@ -955,7 +951,7 @@ unification variable across multiple iterations, then bad things can happen, such as #14933. -Similarly for 'baz', giving the constraint C2+Similarly for 'baz', tcSubTypeSigma gives the constraint C2     forall[2]. Eq (Maybe s) => (Ord a, Show a,                               Maybe s -> Maybe s -> Bool
GHC/Tc/Deriv/Utils.hs view
@@ -4,20 +4,22 @@  -} +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE TypeFamilies #-}  -- | Error-checking and other utilities for @deriving@ clauses or declarations. module GHC.Tc.Deriv.Utils (         DerivM, DerivEnv(..),-        DerivSpec(..), pprDerivSpec, DerivInstTys(..),+        DerivSpec(..), pprDerivSpec, setDerivSpecTheta, zonkDerivSpec,         DerivSpecMechanism(..), derivSpecMechanismToStrategy, isDerivSpecStock,-        isDerivSpecNewtype, isDerivSpecAnyClass, isDerivSpecVia,-        DerivContext(..), OriginativeDerivStatus(..),-        isStandaloneDeriv, isStandaloneWildcardDeriv, mkDerivOrigin,-        PredOrigin(..), ThetaOrigin(..), mkPredOrigin,-        mkThetaOrigin, mkThetaOriginFromPreds, substPredOrigin,+        isDerivSpecNewtype, isDerivSpecAnyClass,+        isDerivSpecVia, zonkDerivSpecMechanism,+        DerivContext(..), OriginativeDerivStatus(..), StockGenFns(..),+        isStandaloneDeriv, isStandaloneWildcardDeriv,+        askDerivUserTypeCtxt, mkDerivOrigin,+        PredSpec(..), ThetaSpec,+        mkDirectThetaSpec, substPredSpec, captureThetaSpecConstraints,         checkOriginativeSideConditions, hasStockDeriving,-        canDeriveAnyClass,         std_class_via_coercible, non_coercible_class,         newDerivClsInst, extendLocalInstEnv     ) where@@ -28,6 +30,7 @@ import GHC.Types.Basic import GHC.Core.Class import GHC.Core.DataCon+import GHC.Core.FamInstEnv import GHC.Driver.Session import GHC.Utils.Error import GHC.Types.Fixity.Env (lookupFixity)@@ -45,18 +48,21 @@ import GHC.Tc.Deriv.Generate import GHC.Tc.Deriv.Functor import GHC.Tc.Deriv.Generics+import GHC.Tc.Errors.Types+import GHC.Tc.Types.Constraint (WantedConstraints, mkNonCanonical) import GHC.Tc.Types.Origin import GHC.Tc.Utils.Monad import GHC.Tc.Utils.TcType+import GHC.Tc.Utils.Unify (tcSubTypeSigma)+import GHC.Tc.Utils.Zonk import GHC.Builtin.Names.TH (liftClassKey) import GHC.Core.TyCon-import GHC.Core.Multiplicity-import GHC.Core.TyCo.Ppr (pprSourceTyCon) import GHC.Core.Type import GHC.Utils.Misc import GHC.Types.Var.Set  import Control.Monad.Trans.Reader+import Data.Foldable (traverse_) import Data.Maybe import qualified GHC.LanguageExtensions as LangExt import GHC.Data.List.SetOps (assocMaybe)@@ -84,6 +90,16 @@     go (InferContext wildcard) = isJust wildcard     go (SupplyContext {})      = False +-- | Return 'InstDeclCtxt' if processing with a standalone @deriving@+-- declaration or 'DerivClauseCtxt' if processing a @deriving@ clause.+askDerivUserTypeCtxt :: DerivM UserTypeCtxt+askDerivUserTypeCtxt = asks (go . denv_ctxt)+  where+    go :: DerivContext -> UserTypeCtxt+    go (SupplyContext {})     = InstDeclCtxt True+    go (InferContext Just{})  = InstDeclCtxt True+    go (InferContext Nothing) = DerivClauseCtxt+ -- | @'mkDerivOrigin' wc@ returns 'StandAloneDerivOrigin' if @wc@ is 'True', -- and 'DerivClauseOrigin' if @wc@ is 'False'. Useful for error-reporting. mkDerivOrigin :: Bool -> CtOrigin@@ -98,7 +114,13 @@   { denv_overlap_mode :: Maybe OverlapMode     -- ^ Is this an overlapping instance?   , denv_tvs          :: [TyVar]-    -- ^ Universally quantified type variables in the instance+    -- ^ Universally quantified type variables in the instance. If the+    --   @denv_ctxt@ is 'InferContext', these will be 'TcTyVar' skolems.+    --   If the @denv_ctxt@ is 'SupplyContext', these will be ordinary 'TyVar's.+    --   See @Note [Overlap and deriving]@ in "GHC.Tc.Deriv.Infer".+    --+    --   All type variables that appear in the 'denv_inst_tys', 'denv_ctxt',+    --   'denv_skol_info', and 'denv_strat' should come from 'denv_tvs'.   , denv_cls          :: Class     -- ^ Class for which we need to derive an instance   , denv_inst_tys     :: [Type]@@ -109,6 +131,9 @@     --   'InferContext' for @deriving@ clauses, or for standalone deriving that     --   uses a wildcard constraint.     --   See @Note [Inferring the instance context]@.+  , denv_skol_info    :: SkolemInfo+    -- ^ The 'SkolemInfo' used to skolemise the @denv_tvs@ in the case where+    --   the 'denv_ctxt' is 'InferContext'.   , denv_strat        :: Maybe (DerivStrategy GhcTc)     -- ^ 'Just' if user requests a particular deriving strategy.     --   Otherwise, 'Nothing'.@@ -120,6 +145,7 @@                 , denv_cls          = cls                 , denv_inst_tys     = inst_tys                 , denv_ctxt         = ctxt+                , denv_skol_info    = skol_info                 , denv_strat        = mb_strat })     = hang (text "DerivEnv")          2 (vcat [ text "denv_overlap_mode" <+> ppr overlap_mode@@ -127,6 +153,7 @@                  , text "denv_cls"          <+> ppr cls                  , text "denv_inst_tys"     <+> ppr inst_tys                  , text "denv_ctxt"         <+> ppr ctxt+                 , text "denv_skol_info"    <+> ppr skol_info                  , text "denv_strat"        <+> ppr mb_strat ])  data DerivSpec theta = DS { ds_loc                 :: SrcSpan@@ -135,6 +162,8 @@                           , ds_theta               :: theta                           , ds_cls                 :: Class                           , ds_tys                 :: [Type]+                          , ds_skol_info           :: SkolemInfo+                          , ds_user_ctxt           :: UserTypeCtxt                           , ds_overlap             :: Maybe OverlapMode                           , ds_standalone_wildcard :: Maybe SrcSpan                               -- See Note [Inferring the instance context]@@ -143,11 +172,20 @@         -- This spec implies a dfun declaration of the form         --       df :: forall tvs. theta => C tys         -- The Name is the name for the DFun we'll build-        -- The tyvars bind all the variables in the theta+        -- The tyvars bind all the variables in the rest of the DerivSpec.+        -- If we are inferring an instance context, the tyvars will be TcTyVar+        -- skolems. After the instance context inference is over, the tyvars+        -- will be zonked to TyVars. See+        -- Note [Overlap and deriving] in GHC.Tc.Deriv.Infer.          -- the theta is either the given and final theta, in standalone deriving,         -- or the not-yet-simplified list of constraints together with their origin +        -- The ds_skol_info is the SkolemInfo that was used to skolemise the+        -- TcTyVars (if we are inferring an instance context). The ds_user_ctxt+        -- is the UserTypeCtxt that allows error messages to know if we are in+        -- a deriving clause or a standalone deriving declaration.+         -- ds_mechanism specifies the means by which GHC derives the instance.         -- See Note [Deriving strategies] in GHC.Tc.Deriv @@ -165,7 +203,7 @@  pprDerivSpec :: Outputable theta => DerivSpec theta -> SDoc pprDerivSpec (DS { ds_loc = l, ds_name = n, ds_tvs = tvs, ds_cls = c,-                   ds_tys = tys, ds_theta = rhs,+                   ds_tys = tys, ds_theta = rhs, ds_skol_info = skol_info,                    ds_standalone_wildcard = wildcard, ds_mechanism = mech })   = hang (text "DerivSpec")        2 (vcat [ text "ds_loc                  =" <+> ppr l@@ -174,40 +212,34 @@                , text "ds_cls                  =" <+> ppr c                , text "ds_tys                  =" <+> ppr tys                , text "ds_theta                =" <+> ppr rhs+               , text "ds_skol_info            =" <+> ppr skol_info                , text "ds_standalone_wildcard  =" <+> ppr wildcard                , text "ds_mechanism            =" <+> ppr mech ])  instance Outputable theta => Outputable (DerivSpec theta) where   ppr = pprDerivSpec --- | Information about the arguments to the class in a stock- or--- newtype-derived instance.--- See @Note [DerivEnv and DerivSpecMechanism]@.-data DerivInstTys = DerivInstTys-  { dit_cls_tys     :: [Type]-    -- ^ Other arguments to the class except the last-  , dit_tc          :: TyCon-    -- ^ Type constructor for which the instance is requested-    --   (last arguments to the type class)-  , dit_tc_args     :: [Type]-    -- ^ Arguments to the type constructor-  , dit_rep_tc      :: TyCon-    -- ^ The representation tycon for 'dit_tc'-    --   (for data family instances). Otherwise the same as 'dit_tc'.-  , dit_rep_tc_args :: [Type]-    -- ^ The representation types for 'dit_tc_args'-    --   (for data family instances). Otherwise the same as 'dit_tc_args'.-  }+-- | Set the 'ds_theta' in a 'DerivSpec'.+setDerivSpecTheta :: theta' -> DerivSpec theta -> DerivSpec theta'+setDerivSpecTheta theta ds = ds{ds_theta = theta} -instance Outputable DerivInstTys where-  ppr (DerivInstTys { dit_cls_tys = cls_tys, dit_tc = tc, dit_tc_args = tc_args-                    , dit_rep_tc = rep_tc, dit_rep_tc_args = rep_tc_args })-    = hang (text "DITTyConHead")-         2 (vcat [ text "dit_cls_tys"     <+> ppr cls_tys-                 , text "dit_tc"          <+> ppr tc-                 , text "dit_tc_args"     <+> ppr tc_args-                 , text "dit_rep_tc"      <+> ppr rep_tc-                 , text "dit_rep_tc_args" <+> ppr rep_tc_args ])+-- | Zonk the 'TcTyVar's in a 'DerivSpec' to 'TyVar's.+-- See @Note [What is zonking?]@ in "GHC.Tc.Utils.TcMType".+--+-- This is only used in the final zonking step when inferring+-- the context for a derived instance.+-- See @Note [Overlap and deriving]@ in "GHC.Tc.Deriv.Infer".+zonkDerivSpec :: DerivSpec ThetaType -> TcM (DerivSpec ThetaType)+zonkDerivSpec ds@(DS { ds_tvs = tvs, ds_theta = theta+                     , ds_tys = tys, ds_mechanism = mechanism+                     }) = do+  (ze, tvs') <- zonkTyBndrs tvs+  theta'     <- zonkTcTypesToTypesX ze theta+  tys'       <- zonkTcTypesToTypesX ze tys+  mechanism' <- zonkDerivSpecMechanism ze mechanism+  pure ds{ ds_tvs = tvs', ds_theta = theta'+         , ds_tys = tys', ds_mechanism = mechanism'+         }  -- | What action to take in order to derive a class instance. -- See @Note [DerivEnv and DerivSpecMechanism]@, as well as@@ -219,29 +251,9 @@       -- ^ Information about the arguments to the class in the derived       -- instance, including what type constructor the last argument is       -- headed by. See @Note [DerivEnv and DerivSpecMechanism]@.-    , dsm_stock_gen_fn ::-        SrcSpan -> TyCon  -- dit_rep_tc-                -> [Type] -- dit_rep_tc_args-                -> [Type] -- inst_tys-                -> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff, [Name])-      -- ^ This function returns four things:-      ---      -- 1. @LHsBinds GhcPs@: The derived instance's function bindings-      --    (e.g., @compare (T x) (T y) = compare x y@)-      ---      -- 2. @[LSig GhcPs]@: A list of instance specific signatures/pragmas.-      --    Most likely INLINE pragmas for class methods.-      ---      -- 3. @BagDerivStuff@: Auxiliary bindings needed to support the derived-      --    instance. As examples, derived 'Generic' instances require-      --    associated type family instances, and derived 'Eq' and 'Ord'-      --    instances require top-level @con2tag@ functions.-      --    See @Note [Auxiliary binders]@ in "GHC.Tc.Deriv.Generate".-      ---      -- 4. @[Name]@: A list of Names for which @-Wunused-binds@ should be-      --    suppressed. This is used to suppress unused warnings for record-      --    selectors when deriving 'Read', 'Show', or 'Generic'.-      --    See @Note [Deriving and unused record selectors]@.+    , dsm_stock_gen_fns :: StockGenFns+      -- ^ How to generate the instance bindings and associated type family+      -- instances.     }      -- | @GeneralizedNewtypeDeriving@@@ -288,6 +300,44 @@ isDerivSpecVia (DerivSpecVia{}) = True isDerivSpecVia _                = False +-- | Zonk the 'TcTyVar's in a 'DerivSpecMechanism' to 'TyVar's.+-- See @Note [What is zonking?]@ in "GHC.Tc.Utils.TcMType".+--+-- This is only used in the final zonking step when inferring+-- the context for a derived instance.+-- See @Note [Overlap and deriving]@ in "GHC.Tc.Deriv.Infer".+zonkDerivSpecMechanism :: ZonkEnv -> DerivSpecMechanism -> TcM DerivSpecMechanism+zonkDerivSpecMechanism ze mechanism =+  case mechanism of+    DerivSpecStock { dsm_stock_dit     = dit+                   , dsm_stock_gen_fns = gen_fns+                   } -> do+      dit' <- zonkDerivInstTys ze dit+      pure $ DerivSpecStock { dsm_stock_dit     = dit'+                            , dsm_stock_gen_fns = gen_fns+                            }+    DerivSpecNewtype { dsm_newtype_dit    = dit+                     , dsm_newtype_rep_ty = rep_ty+                     } -> do+      dit'    <- zonkDerivInstTys ze dit+      rep_ty' <- zonkTcTypeToTypeX ze rep_ty+      pure $ DerivSpecNewtype { dsm_newtype_dit    = dit'+                              , dsm_newtype_rep_ty = rep_ty'+                              }+    DerivSpecAnyClass ->+      pure DerivSpecAnyClass+    DerivSpecVia { dsm_via_cls_tys = cls_tys+                 , dsm_via_inst_ty = inst_ty+                 , dsm_via_ty      = via_ty+                 } -> do+      cls_tys' <- zonkTcTypesToTypesX ze cls_tys+      inst_ty' <- zonkTcTypeToTypeX ze inst_ty+      via_ty'  <- zonkTcTypeToTypeX ze via_ty+      pure $ DerivSpecVia { dsm_via_cls_tys = cls_tys'+                          , dsm_via_inst_ty = inst_ty'+                          , dsm_via_ty      = via_ty'+                          }+ instance Outputable DerivSpecMechanism where   ppr (DerivSpecStock{dsm_stock_dit = dit})     = hang (text "DerivSpecStock")@@ -334,13 +384,16 @@    This extra structure is witnessed by the DerivInstTys data type, which stores   arg_1 through arg_(n-1) (dit_cls_tys), the algebraic type constructor-  (dit_tc), and its arguments (dit_tc_args). If dit_tc is an ordinary data type-  constructor, then dit_rep_tc/dit_rep_tc_args are the same as-  dit_tc/dit_tc_args. If dit_tc is a data family type constructor, then-  dit_rep_tc is the representation type constructor for the data family-  instance, and dit_rep_tc_args are the arguments to the representation type-  constructor in the corresponding instance.+  (dit_tc), and its arguments (dit_tc_args). A DerivInstTys value can be seen+  as a more structured representation of the denv_inst_tys field of DerivEnv. +  If dit_tc is an ordinary data type constructor, then+  dit_rep_tc/dit_rep_tc_args are the same as dit_tc/dit_tc_args. If dit_tc is a+  data family type constructor, then dit_rep_tc is the representation type+  constructor for the data family instance, and dit_rep_tc_args are the+  arguments to the representation type constructor in the corresponding+  instance.+ * newtype (DerivSpecNewtype):    Newtype deriving imposes the same DerivInstTys requirements as stock@@ -429,45 +482,102 @@ -- -- See @Note [Deriving strategies]@ in "GHC.Tc.Deriv". data OriginativeDerivStatus-  = CanDeriveStock            -- Stock class, can derive-      (SrcSpan -> TyCon -> [Type] -> [Type]-               -> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff, [Name]))-  | StockClassError SDoc      -- Stock class, but can't do it+  = CanDeriveStock StockGenFns -- Stock class, can derive+  | StockClassError !DeriveInstanceErrReason -- Stock class, but can't do it   | CanDeriveAnyClass         -- See Note [Deriving any class]-  | NonDerivableClass SDoc    -- Cannot derive with either stock or anyclass+  | NonDerivableClass -- Cannot derive with either stock or anyclass +-- | Describes how to generate instance bindings ('stock_gen_binds') and+-- associated type family instances ('stock_gen_fam_insts') for a particular+-- stock-derived instance.+data StockGenFns = StockGenFns+  { stock_gen_binds ::+         SrcSpan -> DerivInstTys+      -> TcM (LHsBinds GhcPs, [LSig GhcPs], Bag AuxBindSpec, [Name])+    -- ^ Describes how to generate instance bindings for a stock-derived+    -- instance.+    --+    -- This function takes two arguments:+    --+    -- 1. 'SrcSpan': the source location where the instance is being derived.+    --    This will eventually be instantiated with the 'ds_loc' field of a+    --    'DerivSpec'.+    --+    -- 2. 'DerivInstTys': information about the argument types to which a+    --    class is applied in a derived instance. This will eventually be+    --    instantiated with the 'dsm_stock_dit' field of a+    --    'DerivSpecMechanism'.+    --+    -- This function returns four things:+    --+    -- 1. @'LHsBinds' 'GhcPs'@: The derived instance's function bindings+    --    (e.g., @compare (T x) (T y) = compare x y@)+    --+    -- 2. @['LSig' 'GhcPs']@: A list of instance specific signatures/pragmas.+    --    Most likely @INLINE@ pragmas for class methods.+    --+    -- 3. @'Bag' 'AuxBindSpec'@: Auxiliary bindings needed to support the+    --    derived instance. As examples, derived 'Eq' and 'Ord' instances+    --    sometimes require top-level @con2tag@ functions.+    --    See @Note [Auxiliary binders]@ in "GHC.Tc.Deriv.Generate".+    --+    -- 4. @['Name']@: A list of Names for which @-Wunused-binds@ should be+    --    suppressed. This is used to suppress unused warnings for record+    --    selectors when deriving 'Read', 'Show', or 'Generic'.+    --    See @Note [Deriving and unused record selectors]@.+  , stock_gen_fam_insts ::+         SrcSpan -> DerivInstTys+      -> TcM [FamInst]+    -- ^ Describes how to generate associated type family instances for a+    -- stock-derived instance. This function takes the same arguments as the+    -- 'stock_gen_binds' function but returns a list of 'FamInst's instead.+    -- Generating type family instances is done separately from+    -- 'stock_gen_binds' since the type family instances must be generated+    -- before the instance bindings can be typechecked. See+    -- @Note [Staging of tcDeriving]@ in "GHC.Tc.Deriv".+  }+ -- A stock class is one either defined in the Haskell report or for which GHC -- otherwise knows how to generate code for (possibly requiring the use of a -- language extension), such as Eq, Ord, Ix, Data, Generic, etc.) --- | A 'PredType' annotated with the origin of the constraint 'CtOrigin',--- and whether or the constraint deals in types or kinds.-data PredOrigin = PredOrigin PredType CtOrigin TypeOrKind+-- | A 'PredSpec' specifies a constraint to emitted when inferring the+-- instance context for a derived instance in 'GHC.Tc.Deriv.simplifyInfer'.+data PredSpec+  = -- | An ordinary 'PredSpec' that directly stores a 'PredType', which+    -- will be emitted as a wanted constraint in the constraint solving+    -- machinery. This is the simple case, as there are no skolems,+    -- metavariables, or given constraints involved.+    SimplePredSpec+      { sps_pred :: TcPredType+        -- ^ The constraint to emit as a wanted+      , sps_origin :: CtOrigin+        -- ^ The origin of the constraint+      , sps_type_or_kind :: TypeOrKind+        -- ^ Whether the constraint is a type or kind+      }+  | -- | A special 'PredSpec' that is only used by @DeriveAnyClass@. This+    -- will check if @stps_ty_actual@ is a subtype of (i.e., more polymorphic+    -- than) @stps_ty_expected@ in the constraint solving machinery, emitting an+    -- implication constraint as a side effect. For more details on how this+    -- works, see @Note [Gathering and simplifying constraints for DeriveAnyClass]@+    -- in "GHC.Tc.Deriv.Infer".+    SubTypePredSpec+      { stps_ty_actual :: TcSigmaType+        -- ^ The actual type. In the context of @DeriveAnyClass@, this is the+        -- default method type signature.+      , stps_ty_expected :: TcSigmaType+        -- ^ The expected type. In the context of @DeriveAnyClass@, this is the+        -- original method type signature.+      , stps_origin :: CtOrigin+        -- ^ The origin of the constraint+      } --- | A list of wanted 'PredOrigin' constraints ('to_wanted_origins') to--- simplify when inferring a derived instance's context. These are used in all--- deriving strategies, but in the particular case of @DeriveAnyClass@, we--- need extra information. In particular, we need:------ * 'to_anyclass_skols', the list of type variables bound by a class method's---   regular type signature, which should be rigid.------ * 'to_anyclass_metas', the list of type variables bound by a class method's---   default type signature. These can be unified as necessary.------ * 'to_anyclass_givens', the list of constraints from a class method's---   regular type signature, which can be used to help solve constraints---   in the 'to_wanted_origins'.------ (Note that 'to_wanted_origins' will likely contain type variables from the--- derived type class or data type, neither of which will appear in--- 'to_anyclass_skols' or 'to_anyclass_metas'.)------ For all other deriving strategies, it is always the case that--- 'to_anyclass_skols', 'to_anyclass_metas', and 'to_anyclass_givens' are--- empty.------ Here is an example to illustrate this:+-- | A list of 'PredSpec' constraints to simplify when inferring a+-- derived instance's context. For the @stock@, @newtype@, and @via@ deriving+-- strategies, these will consist of 'SimplePredSpec's, and for+-- @DeriveAnyClass@, these will consist of 'SubTypePredSpec's. Here is an+-- example to illustrate the latter: -- -- @ -- class Foo a where@@ -482,71 +592,120 @@ -- data Quux q = Quux deriving anyclass Foo -- @ ----- Then it would generate two 'ThetaOrigin's, one for each method:+-- Then it would generate two 'SubTypePredSpec's, one for each method: -- -- @--- [ ThetaOrigin { to_anyclass_skols  = [b]---               , to_anyclass_metas  = [y]---               , to_anyclass_givens = [Ix b]---               , to_wanted_origins  = [ Show (Quux q), Ix y---                                      , (Quux q -> b -> String) ~---                                        (Quux q -> y -> String)---                                      ] }--- , ThetaOrigin { to_anyclass_skols  = []---               , to_anyclass_metas  = []---               , to_anyclass_givens = [Eq (Quux q)]---               , to_wanted_origins  = [ Ord (Quux q)---                                      , (Quux q -> Quux q -> Bool) ~---                                        (Quux q -> Quux q -> Bool)---                                      ] }+-- [ SubTypePredSpec+--     { stps_ty_actual   = forall y. (Show (Quux q), Ix y) => Quux q -> y -> String+--     , stps_ty_expected = forall b.                (Ix b) => Quux q -> b -> String+--     , stps_ty_origin   = DerivClauseCtxt+--     }+-- , SubTypePredSpec+--     { stps_ty_actual   = Ord (Quux q) => Quux q -> Quux q -> Bool+--     , stps_ty_expected = Eq  (Quux q) => Quux q -> Quux q -> Bool+--     , stps_ty_origin   = DerivClauseCtxt+--     } -- ] -- @ -- -- (Note that the type variable @q@ is bound by the data type @Quux@, and thus--- it appears in neither 'to_anyclass_skols' nor 'to_anyclass_metas'.)+-- appears free in the 'stps_ty_actual's and 'stps_ty_expected's.) -- -- See @Note [Gathering and simplifying constraints for DeriveAnyClass]@--- in "GHC.Tc.Deriv.Infer" for an explanation of how 'to_wanted_origins' are--- determined in @DeriveAnyClass@, as well as how 'to_anyclass_skols',--- 'to_anyclass_metas', and 'to_anyclass_givens' are used.-data ThetaOrigin-  = ThetaOrigin { to_anyclass_skols  :: [TyVar]-                , to_anyclass_metas  :: [TyVar]-                , to_anyclass_givens :: ThetaType-                , to_wanted_origins  :: [PredOrigin] }+-- in "GHC.Tc.Deriv.Infer" for an explanation of how these 'SubTypePredSpec's+-- are used to compute implication constraints.+type ThetaSpec = [PredSpec] -instance Outputable PredOrigin where-  ppr (PredOrigin ty _ _) = ppr ty -- The origin is not so interesting when debugging+instance Outputable PredSpec where+  ppr (SimplePredSpec{sps_pred = ty}) =+    hang (text "SimplePredSpec")+       2 (vcat [ text "sps_pred" <+> ppr ty ])+  ppr (SubTypePredSpec { stps_ty_actual = ty_actual+                       , stps_ty_expected = ty_expected }) =+    hang (text "SubTypePredSpec")+       2 (vcat [ text "stps_ty_actual"   <+> ppr ty_actual+               , text "stps_ty_expected" <+> ppr ty_expected+               ]) -instance Outputable ThetaOrigin where-  ppr (ThetaOrigin { to_anyclass_skols  = ac_skols-                   , to_anyclass_metas  = ac_metas-                   , to_anyclass_givens = ac_givens-                   , to_wanted_origins  = wanted_origins })-    = hang (text "ThetaOrigin")-         2 (vcat [ text "to_anyclass_skols  =" <+> ppr ac_skols-                 , text "to_anyclass_metas  =" <+> ppr ac_metas-                 , text "to_anyclass_givens =" <+> ppr ac_givens-                 , text "to_wanted_origins  =" <+> ppr wanted_origins ])+-- | Build a list of 'SimplePredSpec's, using the supplied 'CtOrigin' and+-- 'TypeOrKind' values for each 'PredType'.+mkDirectThetaSpec :: CtOrigin -> TypeOrKind -> ThetaType -> ThetaSpec+mkDirectThetaSpec origin t_or_k =+  map (\p -> SimplePredSpec+               { sps_pred = p+               , sps_origin = origin+               , sps_type_or_kind = t_or_k+               }) -mkPredOrigin :: CtOrigin -> TypeOrKind -> PredType -> PredOrigin-mkPredOrigin origin t_or_k pred = PredOrigin pred origin t_or_k+substPredSpec :: HasCallStack => TCvSubst -> PredSpec -> PredSpec+substPredSpec subst ps =+  case ps of+    SimplePredSpec { sps_pred = pred+                   , sps_origin = origin+                   , sps_type_or_kind = t_or_k+                   }+      -> SimplePredSpec { sps_pred = substTy subst pred+                        , sps_origin = origin+                        , sps_type_or_kind = t_or_k+                        } -mkThetaOrigin :: CtOrigin -> TypeOrKind-              -> [TyVar] -> [TyVar] -> ThetaType -> ThetaType-              -> ThetaOrigin-mkThetaOrigin origin t_or_k skols metas givens-  = ThetaOrigin skols metas givens . map (mkPredOrigin origin t_or_k)+    SubTypePredSpec { stps_ty_actual = ty_actual+                    , stps_ty_expected = ty_expected+                    , stps_origin = origin+                    }+      -> SubTypePredSpec { stps_ty_actual = substTy subst ty_actual+                         , stps_ty_expected = substTy subst ty_expected+                         , stps_origin = origin+                         } --- A common case where the ThetaOrigin only contains wanted constraints, with--- no givens or locally scoped type variables.-mkThetaOriginFromPreds :: [PredOrigin] -> ThetaOrigin-mkThetaOriginFromPreds = ThetaOrigin [] [] []+-- | Capture wanted constraints from a 'ThetaSpec'.+captureThetaSpecConstraints ::+     UserTypeCtxt -- ^ Used to inform error messages as to whether+                  -- we are in a @deriving@ clause or a standalone+                  -- @deriving@ declaration+  -> ThetaSpec    -- ^ The specs from which constraints will be created+  -> TcM (TcLevel, WantedConstraints)+captureThetaSpecConstraints user_ctxt theta =+  pushTcLevelM $ mk_wanteds theta+  where+    -- Create the constraints we need to solve. For stock and newtype+    -- deriving, these constraints will be simple wanted constraints+    -- like (C a, Ord b).+    -- But with DeriveAnyClass, we make an implication constraint.+    -- See Note [Gathering and simplifying constraints for DeriveAnyClass]+    -- in GHC.Tc.Deriv.Infer.+    mk_wanteds :: ThetaSpec -> TcM WantedConstraints+    mk_wanteds preds+      = do { (_, wanteds) <- captureConstraints $+                             traverse_ emit_constraints preds+           ; pure wanteds } -substPredOrigin :: HasCallStack => TCvSubst -> PredOrigin -> PredOrigin-substPredOrigin subst (PredOrigin pred origin t_or_k)-  = PredOrigin (substTy subst pred) origin t_or_k+    -- Emit the appropriate constraints depending on what sort of+    -- PredSpec we are dealing with.+    emit_constraints :: PredSpec -> TcM ()+    emit_constraints ps =+      case ps of+        -- For constraints like (C a, Ord b), emit the+        -- constraints directly as simple wanted constraints.+        SimplePredSpec { sps_pred = wanted+                       , sps_origin = orig+                       , sps_type_or_kind = t_or_k+                       } -> do+          ev <- newWanted orig (Just t_or_k) wanted+          emitSimple (mkNonCanonical ev) +        -- For DeriveAnyClass, check if ty_actual is a subtype of+        -- ty_expected, which emits an implication constraint as a+        -- side effect. See+        -- Note [Gathering and simplifying constraints for DeriveAnyClass].+        -- in GHC.Tc.Deriv.Infer.+        SubTypePredSpec { stps_ty_actual   = ty_actual+                        , stps_ty_expected = ty_expected+                        , stps_origin      = orig+                        } -> do+          _ <- tcSubTypeSigma orig user_ctxt ty_actual ty_expected+          return ()+ {- ************************************************************************ *                                                                      *@@ -561,63 +720,70 @@ stock class to be able to be derived successfully.  A class might be able to be used in a deriving clause if -XDeriveAnyClass-is willing to support it. The canDeriveAnyClass function checks if this is the-case.+is willing to support it. -}  hasStockDeriving-  :: Class -> Maybe (SrcSpan-                     -> TyCon-                     -> [Type]-                     -> [Type]-                     -> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff, [Name]))+  :: Class -> Maybe StockGenFns hasStockDeriving clas   = assocMaybe gen_list (getUnique clas)   where-    gen_list-      :: [(Unique, SrcSpan-                   -> TyCon-                   -> [Type]-                   -> [Type]-                   -> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff, [Name]))]-    gen_list = [ (eqClassKey,          simpleM gen_Eq_binds)-               , (ordClassKey,         simpleM gen_Ord_binds)-               , (enumClassKey,        simpleM gen_Enum_binds)-               , (boundedClassKey,     simple gen_Bounded_binds)-               , (ixClassKey,          simpleM gen_Ix_binds)-               , (showClassKey,        read_or_show gen_Show_binds)-               , (readClassKey,        read_or_show gen_Read_binds)-               , (dataClassKey,        simpleM gen_Data_binds)-               , (functorClassKey,     simple gen_Functor_binds)-               , (foldableClassKey,    simple gen_Foldable_binds)-               , (traversableClassKey, simple gen_Traversable_binds)-               , (liftClassKey,        simple gen_Lift_binds)-               , (genClassKey,         generic (gen_Generic_binds Gen0))-               , (gen1ClassKey,        generic (gen_Generic_binds Gen1)) ]+    gen_list :: [(Unique, StockGenFns)]+    gen_list =+      [ (eqClassKey,          mk (simple_bindsM gen_Eq_binds) no_fam_insts)+      , (ordClassKey,         mk (simple_bindsM gen_Ord_binds) no_fam_insts)+      , (enumClassKey,        mk (simple_bindsM gen_Enum_binds) no_fam_insts)+      , (boundedClassKey,     mk (simple_binds gen_Bounded_binds) no_fam_insts)+      , (ixClassKey,          mk (simple_bindsM gen_Ix_binds) no_fam_insts)+      , (showClassKey,        mk (read_or_show_binds gen_Show_binds) no_fam_insts)+      , (readClassKey,        mk (read_or_show_binds gen_Read_binds) no_fam_insts)+      , (dataClassKey,        mk (simple_bindsM gen_Data_binds) no_fam_insts)+      , (functorClassKey,     mk (simple_binds gen_Functor_binds) no_fam_insts)+      , (foldableClassKey,    mk (simple_binds gen_Foldable_binds) no_fam_insts)+      , (traversableClassKey, mk (simple_binds gen_Traversable_binds) no_fam_insts)+      , (liftClassKey,        mk (simple_binds gen_Lift_binds) no_fam_insts)+      , (genClassKey,         mk (generic_binds Gen0) (generic_fam_inst Gen0))+      , (gen1ClassKey,        mk (generic_binds Gen1) (generic_fam_inst Gen1))+      ] -    simple gen_fn loc tc tc_args _-      = let (binds, deriv_stuff) = gen_fn loc tc tc_args-        in return (binds, [], deriv_stuff, [])+    mk gen_binds_fn gen_fam_insts_fn = StockGenFns+      { stock_gen_binds     = gen_binds_fn+      , stock_gen_fam_insts = gen_fam_insts_fn+      } +    simple_binds gen_fn loc dit+      = let (binds, aux_specs) = gen_fn loc dit+        in return (binds, [], aux_specs, [])+     -- Like `simple`, but monadic. The only monadic thing that these functions     -- do is allocate new Uniques, which are used for generating the names of     -- auxiliary bindings.     -- See Note [Auxiliary binders] in GHC.Tc.Deriv.Generate.-    simpleM gen_fn loc tc tc_args _-      = do { (binds, deriv_stuff) <- gen_fn loc tc tc_args-           ; return (binds, [], deriv_stuff, []) }+    simple_bindsM gen_fn loc dit+      = do { (binds, aux_specs) <- gen_fn loc dit+           ; return (binds, [], aux_specs, []) } -    read_or_show gen_fn loc tc tc_args _-      = do { fix_env <- getDataConFixityFun tc-           ; let (binds, deriv_stuff) = gen_fn fix_env loc tc tc_args-                 field_names          = all_field_names tc-           ; return (binds, [], deriv_stuff, field_names) }+    read_or_show_binds gen_fn loc dit+      = do { let tc = dit_rep_tc dit+           ; fix_env <- getDataConFixityFun tc+           ; let (binds, aux_specs) = gen_fn fix_env loc dit+                 field_names        = all_field_names tc+           ; return (binds, [], aux_specs, field_names) } -    generic gen_fn _ tc _ inst_tys-      = do { (binds, sigs, faminst) <- gen_fn tc inst_tys+    generic_binds gk loc dit+      = do { let tc = dit_rep_tc dit+           ; (binds, sigs) <- gen_Generic_binds gk loc dit            ; let field_names = all_field_names tc-           ; return (binds, sigs, unitBag (DerivFamInst faminst), field_names) }+           ; return (binds, sigs, emptyBag, field_names) } +    generic_fam_inst gk loc dit+      = do { let tc = dit_rep_tc dit+           ; fix_env <- getDataConFixityFun tc+           ; faminst <- gen_Generic_fam_inst gk fix_env loc dit+           ; return [faminst] }++    no_fam_insts _ _ = pure []+     -- See Note [Deriving and unused record selectors]     all_field_names = map flSelector . concatMap dataConFieldLabels                                      . tyConDataCons@@ -648,7 +814,7 @@ Show, and Generic, as their derived code all depend on the record selectors of the derived data type's constructors. -See also Note [Newtype deriving and unused constructors] in GHC.Tc.Deriv for+See also Note [Unused constructors and deriving clauses] in GHC.Tc.Deriv for another example of a similar trick. -} @@ -656,7 +822,7 @@ -- If the TyCon is locally defined, we want the local fixity env; -- but if it is imported (which happens for standalone deriving) -- we need to get the fixity env from the interface file--- c.f. GHC.Rename.Env.lookupFixity, and #9830+-- c.f. GHC.Rename.Env.lookupFixity, #9830, and #20994 getDataConFixityFun tc   = do { this_mod <- getModule        ; if nameIsLocalOrFrom this_mod name@@ -681,36 +847,39 @@ -- the data constructors - but we need to be careful to fall back to the -- family tycon (with indexes) in error messages. -checkOriginativeSideConditions-  :: DynFlags -> DerivContext -> Class -> [TcType]-  -> TyCon -> TyCon-  -> OriginativeDerivStatus-checkOriginativeSideConditions dflags deriv_ctxt cls cls_tys tc rep_tc-    -- First, check if stock deriving is possible...-  | Just cond <- stockSideConditions deriv_ctxt cls-  = case (cond dflags tc rep_tc) of-        NotValid err -> StockClassError err  -- Class-specific error-        IsValid  | null (filterOutInvisibleTypes (classTyCon cls) cls_tys)-                   -- All stock derivable classes are unary in the sense that-                   -- there should be not types in cls_tys (i.e., no type args-                   -- other than last). Note that cls_types can contain-                   -- invisible types as well (e.g., for Generic1, which is-                   -- poly-kinded), so make sure those are not counted.-                 , Just gen_fn <- hasStockDeriving cls-                   -> CanDeriveStock gen_fn-                 | otherwise -> StockClassError (classArgsErr cls cls_tys)-                   -- e.g. deriving( Eq s )+checkOriginativeSideConditions :: DerivInstTys -> DerivM OriginativeDerivStatus+checkOriginativeSideConditions dit@(DerivInstTys{dit_cls_tys = cls_tys}) =+  do DerivEnv { denv_cls  = cls+              , denv_ctxt = deriv_ctxt } <- ask+     dflags <- getDynFlags -    -- ...if not, try falling back on DeriveAnyClass.-  | NotValid err <- canDeriveAnyClass dflags-  = NonDerivableClass err  -- Neither anyclass nor stock work+     if    -- First, check if stock deriving is possible...+        |  Just cond <- stockSideConditions deriv_ctxt cls+        -> case cond dflags dit of+             NotValid err -> pure $ StockClassError err  -- Class-specific error+             IsValid  |  null (filterOutInvisibleTypes (classTyCon cls) cls_tys)+                         -- All stock derivable classes are unary in the sense that+                         -- there should be not types in cls_tys (i.e., no type args+                         -- other than last). Note that cls_types can contain+                         -- invisible types as well (e.g., for Generic1, which is+                         -- poly-kinded), so make sure those are not counted.+                      ,  Just gen_fn <- hasStockDeriving cls+                      -> pure $ CanDeriveStock gen_fn+                      |  otherwise+                      -> pure $ StockClassError $ classArgsErr cls cls_tys+                        -- e.g. deriving( Eq s ) -  | otherwise-  = CanDeriveAnyClass   -- DeriveAnyClass should work+           -- ...if not, try falling back on DeriveAnyClass.+        |  xopt LangExt.DeriveAnyClass dflags+        -> pure CanDeriveAnyClass   -- DeriveAnyClass should work -classArgsErr :: Class -> [Type] -> SDoc-classArgsErr cls cls_tys = quotes (ppr (mkClassPred cls cls_tys)) <+> text "is not a class"+        |  otherwise+        -> pure NonDerivableClass -- Neither anyclass nor stock work ++classArgsErr :: Class -> [Type] -> DeriveInstanceErrReason+classArgsErr cls cls_tys = DerivErrNotAClass (mkClassPred cls cls_tys)+ -- Side conditions (whether the datatype must have at least one constructor, -- required language extensions, etc.) for using GHC's stock deriving -- mechanism on certain classes (as opposed to classes that require@@ -756,39 +925,19 @@     cond_vanilla = cond_stdOK deriv_ctxt True       -- Vanilla data constructors but allow no data cons or polytype arguments -canDeriveAnyClass :: DynFlags -> Validity--- IsValid: we can (try to) derive it via an empty instance declaration--- NotValid s:  we can't, reason s-canDeriveAnyClass dflags-  | not (xopt LangExt.DeriveAnyClass dflags)-  = NotValid (text "Try enabling DeriveAnyClass")-  | otherwise-  = IsValid   -- OK!- type Condition    = DynFlags -  -> TyCon    -- ^ The data type's 'TyCon'. For data families, this is the-              -- family 'TyCon'.--  -> TyCon    -- ^ For data families, this is the representation 'TyCon'.-              -- Otherwise, this is the same as the other 'TyCon' argument.--  -> Validity -- ^ 'IsValid' if deriving an instance for this 'TyCon' is-              -- possible. Otherwise, it's @'NotValid' err@, where @err@-              -- explains what went wrong.+  -> DerivInstTys -- ^ Information about the type arguments to the class. -orCond :: Condition -> Condition -> Condition-orCond c1 c2 dflags tc rep_tc-  = case (c1 dflags tc rep_tc, c2 dflags tc rep_tc) of-     (IsValid,    _)          -> IsValid    -- c1 succeeds-     (_,          IsValid)    -> IsValid    -- c21 succeeds-     (NotValid x, NotValid y) -> NotValid (x $$ text "  or" $$ y)-                                            -- Both fail+  -> Validity' DeriveInstanceErrReason+     -- ^ 'IsValid' if deriving an instance for this type is+     -- possible. Otherwise, it's @'NotValid' err@, where @err@+     -- explains what went wrong.  andCond :: Condition -> Condition -> Condition-andCond c1 c2 dflags tc rep_tc-  = c1 dflags tc rep_tc `andValid` c2 dflags tc rep_tc+andCond c1 c2 dflags dit+  = c1 dflags dit `andValid` c2 dflags dit  -- | Some common validity checks shared among stock derivable classes. One -- check that absolutely must hold is that if an instance @C (T a)@ is being@@ -818,18 +967,18 @@                   -- the -XEmptyDataDeriving extension.    -> Condition-cond_stdOK deriv_ctxt permissive dflags tc rep_tc+cond_stdOK deriv_ctxt permissive dflags+           dit@(DerivInstTys{dit_tc = tc, dit_rep_tc = rep_tc})   = valid_ADT `andValid` valid_misc   where-    valid_ADT, valid_misc :: Validity+    valid_ADT, valid_misc :: Validity' DeriveInstanceErrReason     valid_ADT       | isAlgTyCon tc || isDataFamilyTyCon tc       = IsValid       | otherwise         -- Complain about functions, primitive types, and other tycons that         -- stock deriving can't handle.-      = NotValid $ text "The last argument of the instance must be a"-               <+> text "data or newtype application"+      = NotValid DerivErrLastArgMustBeApp      valid_misc       = case deriv_ctxt of@@ -840,68 +989,77 @@          InferContext wildcard            | null data_cons -- 1.            , not permissive-           -> checkFlag LangExt.EmptyDataDeriving dflags tc rep_tc `orValid`-              NotValid (no_cons_why rep_tc $$ empty_data_suggestion)+           , not (xopt LangExt.EmptyDataDeriving dflags)+           -> NotValid (no_cons_why rep_tc)            | not (null con_whys)-           -> NotValid (vcat con_whys $$ possible_fix_suggestion wildcard)+           -> NotValid $ DerivErrBadConstructor (Just $ has_wildcard wildcard) con_whys            | otherwise            -> IsValid -    empty_data_suggestion =-      text "Use EmptyDataDeriving to enable deriving for empty data types"-    possible_fix_suggestion wildcard+    has_wildcard wildcard       = case wildcard of-          Just _ ->-            text "Possible fix: fill in the wildcard constraint yourself"-          Nothing ->-            text "Possible fix: use a standalone deriving declaration instead"+          Just _  -> YesHasWildcard+          Nothing -> NoHasWildcard     data_cons  = tyConDataCons rep_tc     con_whys   = getInvalids (map check_con data_cons) -    check_con :: DataCon -> Validity+    check_con :: DataCon -> Validity' DeriveInstanceBadConstructor     check_con con       | not (null eq_spec) -- 2.-      = bad "is a GADT"+      = bad DerivErrBadConIsGADT       | not (null ex_tvs) -- 3.-      = bad "has existential type variables in its type"+      = bad DerivErrBadConHasExistentials       | not (null theta) -- 4.-      = bad "has constraints in its type"-      | not (permissive || all isTauTy (map scaledThing $ dataConOrigArgTys con)) -- 5.-      = bad "has a higher-rank type"+      = bad DerivErrBadConHasConstraints+      | not (permissive || all isTauTy (derivDataConInstArgTys con dit)) -- 5.+      = bad DerivErrBadConHasHigherRankType       | otherwise       = IsValid       where         (_, ex_tvs, eq_spec, theta, _, _) = dataConFullSig con-        bad msg = NotValid (badCon con (text msg))+        bad mkErr = NotValid $ mkErr con -no_cons_why :: TyCon -> SDoc-no_cons_why rep_tc = quotes (pprSourceTyCon rep_tc) <+>-                     text "must have at least one data constructor"+no_cons_why :: TyCon -> DeriveInstanceErrReason+no_cons_why = DerivErrNoConstructors  cond_RepresentableOk :: Condition-cond_RepresentableOk _ _ rep_tc = canDoGenerics rep_tc+cond_RepresentableOk _ dit =+  case canDoGenerics dit of+    IsValid -> IsValid+    NotValid generic_errs -> NotValid $ DerivErrGenerics generic_errs  cond_Representable1Ok :: Condition-cond_Representable1Ok _ _ rep_tc = canDoGenerics1 rep_tc+cond_Representable1Ok _ dit =+  case canDoGenerics1 dit of+    IsValid -> IsValid+    NotValid generic_errs -> NotValid $ DerivErrGenerics generic_errs  cond_enumOrProduct :: Class -> Condition cond_enumOrProduct cls = cond_isEnumeration `orCond`                          (cond_isProduct `andCond` cond_args cls)+  where+    orCond :: Condition -> Condition -> Condition+    orCond c1 c2 dflags dit+      = case (c1 dflags dit, c2 dflags dit) of+         (IsValid,    _)          -> IsValid    -- c1 succeeds+         (_,          IsValid)    -> IsValid    -- c21 succeeds+         (NotValid x, NotValid y) -> NotValid $ DerivErrEnumOrProduct x y+                                                -- Both fail + cond_args :: Class -> Condition -- ^ For some classes (eg 'Eq', 'Ord') we allow unlifted arg types -- by generating specialised code.  For others (eg 'Data') we don't. -- For even others (eg 'Lift'), unlifted types aren't even a special -- consideration!-cond_args cls _ _ rep_tc+cond_args cls _ dit@(DerivInstTys{dit_rep_tc = rep_tc})   = case bad_args of       []     -> IsValid-      (ty:_) -> NotValid (hang (text "Don't know how to derive" <+> quotes (ppr cls))-                             2 (text "for type" <+> quotes (ppr ty)))+      (ty:_) -> NotValid $ DerivErrDunnoHowToDeriveForType ty   where     bad_args = [ arg_ty | con <- tyConDataCons rep_tc-                        , Scaled _ arg_ty <- dataConOrigArgTys con-                        , isLiftedType_maybe arg_ty /= Just True+                        , arg_ty <- derivDataConInstArgTys con dit+                        , mightBeUnliftedType arg_ty                         , not (ok_ty arg_ty) ]      cls_key = classKey cls@@ -909,7 +1067,7 @@      | cls_key == eqClassKey   = check_in arg_ty ordOpTbl      | cls_key == ordClassKey  = check_in arg_ty ordOpTbl      | cls_key == showClassKey = check_in arg_ty boxConTbl-     | cls_key == liftClassKey = True     -- Lift is levity-polymorphic+     | cls_key == liftClassKey = True     -- Lift is representation-polymorphic      | otherwise               = False    -- Read, Ix etc      check_in :: Type -> [(Type,a)] -> Bool@@ -917,22 +1075,16 @@   cond_isEnumeration :: Condition-cond_isEnumeration _ _ rep_tc+cond_isEnumeration _ (DerivInstTys{dit_rep_tc = rep_tc})   | isEnumerationTyCon rep_tc = IsValid-  | otherwise                 = NotValid why-  where-    why = sep [ quotes (pprSourceTyCon rep_tc) <+>-                  text "must be an enumeration type"-              , text "(an enumeration consists of one or more nullary, non-GADT constructors)" ]-                  -- See Note [Enumeration types] in GHC.Core.TyCon+  | otherwise                 = NotValid $ DerivErrMustBeEnumType rep_tc  cond_isProduct :: Condition-cond_isProduct _ _ rep_tc-  | Just _ <- tyConSingleDataCon_maybe rep_tc = IsValid-  | otherwise                                 = NotValid why-  where-    why = quotes (pprSourceTyCon rep_tc) <+>-          text "must have precisely one constructor"+cond_isProduct _ (DerivInstTys{dit_rep_tc = rep_tc})+  | Just _ <- tyConSingleDataCon_maybe rep_tc+  = IsValid+  | otherwise+  = NotValid $ DerivErrMustHaveExactlyOneConstructor rep_tc  cond_functorOK :: Bool -> Bool -> Condition -- OK for Functor/Foldable/Traversable class@@ -941,14 +1093,16 @@ --            (c) don't use argument in the wrong place, e.g. data T a = T (X a a) --            (d) optionally: don't use function types --            (e) no "stupid context" on data type-cond_functorOK allowFunctions allowExQuantifiedLastTyVar _ _ rep_tc+cond_functorOK allowFunctions allowExQuantifiedLastTyVar _+               dit@(DerivInstTys{dit_rep_tc = rep_tc})   | null tc_tvs-  = NotValid (text "Data type" <+> quotes (ppr rep_tc)-              <+> text "must have some type parameters")+  = NotValid $ DerivErrMustHaveSomeParameters rep_tc +    -- We can't handle stupid contexts that mention the last type argument,+    -- so error out if we encounter one.+    -- See Note [The stupid context] in GHC.Core.DataCon.   | not (null bad_stupid_theta)-  = NotValid (text "Data type" <+> quotes (ppr rep_tc)-              <+> text "must not have a class context:" <+> pprTheta bad_stupid_theta)+  = NotValid $ DerivErrMustNotHaveClassContext rep_tc bad_stupid_theta    | otherwise   = allValid (map check_con data_cons)@@ -960,9 +1114,9 @@       -- See Note [Check that the type variable is truly universal]      data_cons = tyConDataCons rep_tc-    check_con con = allValid (check_universal con : foldDataConArgs (ft_check con) con)+    check_con con = allValid (check_universal con : foldDataConArgs (ft_check con) con dit) -    check_universal :: DataCon -> Validity+    check_universal :: DataCon -> Validity' DeriveInstanceErrReason     check_universal con       | allowExQuantifiedLastTyVar       = IsValid -- See Note [DeriveFoldable with ExistentialQuantification]@@ -972,31 +1126,26 @@       , not (tv `elemVarSet` exactTyCoVarsOfTypes (dataConTheta con))       = IsValid   -- See Note [Check that the type variable is truly universal]       | otherwise-      = NotValid (badCon con existential)+      = NotValid $ DerivErrBadConstructor Nothing [DerivErrBadConExistential con] -    ft_check :: DataCon -> FFoldType Validity+    ft_check :: DataCon -> FFoldType (Validity' DeriveInstanceErrReason)     ft_check con = FT { ft_triv = IsValid, ft_var = IsValid-                      , ft_co_var = NotValid (badCon con covariant)+                      , ft_co_var = NotValid $ DerivErrBadConstructor Nothing [DerivErrBadConCovariant con]                       , ft_fun = \x y -> if allowFunctions then x `andValid` y-                                                           else NotValid (badCon con functions)+                                                           else NotValid $ DerivErrBadConstructor Nothing [DerivErrBadConFunTypes con]                       , ft_tup = \_ xs  -> allValid xs                       , ft_ty_app = \_ _ x -> x-                      , ft_bad_app = NotValid (badCon con wrong_arg)+                      , ft_bad_app = NotValid $ DerivErrBadConstructor Nothing [DerivErrBadConWrongArg con]                       , ft_forall = \_ x   -> x } -    existential = text "must be truly polymorphic in the last argument of the data type"-    covariant   = text "must not use the type variable in a function argument"-    functions   = text "must not contain function types"-    wrong_arg   = text "must use the type variable only as the last argument of a data type"  checkFlag :: LangExt.Extension -> Condition-checkFlag flag dflags _ _+checkFlag flag dflags _   | xopt flag dflags = IsValid   | otherwise        = NotValid why   where-    why = text "You need " <> text flag_str-          <+> text "to derive an instance for this class"-    flag_str = case [ flagSpecName f | f <- xFlags , flagSpecFlag f == flag ] of+    why = DerivErrLangExtRequired the_flag+    the_flag = case [ flagSpecFlag f | f <- xFlags , flagSpecFlag f == flag ] of                  [s]   -> s                  other -> pprPanic "checkFlag" (ppr other) @@ -1021,14 +1170,12 @@                          , genClassKey, gen1ClassKey, typeableClassKey                          , traversableClassKey, liftClassKey ]) -badCon :: DataCon -> SDoc -> SDoc-badCon con msg = text "Constructor" <+> quotes (ppr con) <+> msg- ------------------------------------------------------------------ -newDerivClsInst :: ThetaType -> DerivSpec theta -> TcM ClsInst-newDerivClsInst theta (DS { ds_name = dfun_name, ds_overlap = overlap_mode-                          , ds_tvs = tvs, ds_cls = clas, ds_tys = tys })+newDerivClsInst :: DerivSpec ThetaType -> TcM ClsInst+newDerivClsInst (DS { ds_name = dfun_name, ds_overlap = overlap_mode+                    , ds_tvs = tvs, ds_theta = theta+                    , ds_cls = clas, ds_tys = tys })   = newClsInst overlap_mode dfun_name tvs theta clas tys  extendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a
GHC/Tc/Errors.hs view
@@ -1,3145 +1,2495 @@-{-# LANGUAGE CPP                 #-}-{-# LANGUAGE LambdaCase          #-}-{-# LANGUAGE ScopedTypeVariables #-}--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}-{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}--module GHC.Tc.Errors(-       reportUnsolved, reportAllUnsolved, warnAllUnsolved,-       warnDefaulting,--       solverDepthErrorTcS-  ) where--#include "HsVersions.h"--import GHC.Prelude--import GHC.Tc.Types-import GHC.Tc.Utils.Monad-import GHC.Tc.Types.Constraint-import GHC.Core.Predicate-import GHC.Tc.Utils.TcMType-import GHC.Tc.Utils.Env( tcInitTidyEnv )-import GHC.Tc.Utils.TcType-import GHC.Tc.Utils.Unify ( checkTyVarEq )-import GHC.Tc.Types.Origin-import GHC.Rename.Unbound ( unknownNameSuggestions )-import GHC.Core.Type-import GHC.Core.Coercion-import GHC.Core.TyCo.Rep-import GHC.Core.TyCo.Ppr  ( pprTyVars, pprWithExplicitKindsWhen, pprSourceTyCon, pprWithTYPE )-import GHC.Core.Unify     ( tcMatchTys, flattenTys )-import GHC.Unit.Module-import GHC.Tc.Instance.Family-import GHC.Tc.Utils.Instantiate-import GHC.Core.InstEnv-import GHC.Core.TyCon-import GHC.Core.Class-import GHC.Core.DataCon-import GHC.Tc.Types.Evidence-import GHC.Tc.Types.EvTerm-import GHC.Hs.Binds ( PatSynBind(..) )-import GHC.Types.Name-import GHC.Types.Name.Reader ( lookupGRE_Name, GlobalRdrEnv, mkRdrUnqual )-import GHC.Builtin.Names ( typeableClassName )-import GHC.Types.Id-import GHC.Types.Var-import GHC.Types.Var.Set-import GHC.Types.Var.Env-import GHC.Types.Name.Env-import GHC.Types.Name.Set-import GHC.Data.Bag-import GHC.Utils.Error  ( pprLocMsgEnvelope )-import GHC.Types.Basic-import GHC.Types.Error-import GHC.Types.Unique.Set ( nonDetEltsUniqSet )-import GHC.Core.ConLike ( ConLike(..))-import GHC.Utils.Misc-import GHC.Data.FastString-import GHC.Utils.Outputable as O-import GHC.Utils.Panic-import GHC.Types.SrcLoc-import GHC.Driver.Session-import GHC.Driver.Ppr-import GHC.Data.List.SetOps ( equivClasses )-import GHC.Data.Maybe-import qualified GHC.LanguageExtensions as LangExt-import GHC.Utils.FV ( fvVarList, unionFV )--import Control.Monad    ( when, foldM, forM_ )-import Data.Foldable    ( toList )-import Data.List        ( partition, mapAccumL, sortBy, unfoldr )--import {-# SOURCE #-} GHC.Tc.Errors.Hole ( findValidHoleFits )---- import Data.Semigroup   ( Semigroup )-import qualified Data.Semigroup as Semigroup---{--************************************************************************-*                                                                      *-\section{Errors and contexts}-*                                                                      *-************************************************************************--ToDo: for these error messages, should we note the location as coming-from the insts, or just whatever seems to be around in the monad just-now?--Note [Deferring coercion errors to runtime]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-While developing, sometimes it is desirable to allow compilation to succeed even-if there are type errors in the code. Consider the following case:--  module Main where--  a :: Int-  a = 'a'--  main = print "b"--Even though `a` is ill-typed, it is not used in the end, so if all that we're-interested in is `main` it is handy to be able to ignore the problems in `a`.--Since we treat type equalities as evidence, this is relatively simple. Whenever-we run into a type mismatch in GHC.Tc.Utils.Unify, we normally just emit an error. But it-is always safe to defer the mismatch to the main constraint solver. If we do-that, `a` will get transformed into--  co :: Int ~ Char-  co = ...--  a :: Int-  a = 'a' `cast` co--The constraint solver would realize that `co` is an insoluble constraint, and-emit an error with `reportUnsolved`. But we can also replace the right-hand side-of `co` with `error "Deferred type error: Int ~ Char"`. This allows the program-to compile, and it will run fine unless we evaluate `a`. This is what-`deferErrorsToRuntime` does.--It does this by keeping track of which errors correspond to which coercion-in GHC.Tc.Errors. GHC.Tc.Errors.reportTidyWanteds does not print the errors-and does not fail if -fdefer-type-errors is on, so that we can continue-compilation. The errors are turned into warnings in `reportUnsolved`.--}---- | Report unsolved goals as errors or warnings. We may also turn some into--- deferred run-time errors if `-fdefer-type-errors` is on.-reportUnsolved :: WantedConstraints -> TcM (Bag EvBind)-reportUnsolved wanted-  = do { binds_var <- newTcEvBinds-       ; defer_errors <- goptM Opt_DeferTypeErrors-       ; warn_errors <- woptM Opt_WarnDeferredTypeErrors -- implement #10283-       ; let type_errors | not defer_errors = TypeError-                         | warn_errors      = TypeWarn (Reason Opt_WarnDeferredTypeErrors)-                         | otherwise        = TypeDefer--       ; defer_holes <- goptM Opt_DeferTypedHoles-       ; warn_holes  <- woptM Opt_WarnTypedHoles-       ; let expr_holes | not defer_holes = HoleError-                        | warn_holes      = HoleWarn-                        | otherwise       = HoleDefer--       ; partial_sigs      <- xoptM LangExt.PartialTypeSignatures-       ; warn_partial_sigs <- woptM Opt_WarnPartialTypeSignatures-       ; let type_holes | not partial_sigs  = HoleError-                        | warn_partial_sigs = HoleWarn-                        | otherwise         = HoleDefer--       ; defer_out_of_scope <- goptM Opt_DeferOutOfScopeVariables-       ; warn_out_of_scope <- woptM Opt_WarnDeferredOutOfScopeVariables-       ; let out_of_scope_holes | not defer_out_of_scope = HoleError-                                | warn_out_of_scope      = HoleWarn-                                | otherwise              = HoleDefer--       ; report_unsolved type_errors expr_holes-                         type_holes out_of_scope_holes-                         binds_var wanted--       ; ev_binds <- getTcEvBindsMap binds_var-       ; return (evBindMapBinds ev_binds)}---- | Report *all* unsolved goals as errors, even if -fdefer-type-errors is on--- However, do not make any evidence bindings, because we don't--- have any convenient place to put them.--- NB: Type-level holes are OK, because there are no bindings.--- See Note [Deferring coercion errors to runtime]--- Used by solveEqualities for kind equalities---      (see Note [Fail fast on kind errors] in "GHC.Tc.Solver")-reportAllUnsolved :: WantedConstraints -> TcM ()-reportAllUnsolved wanted-  = do { ev_binds <- newNoTcEvBinds--       ; partial_sigs      <- xoptM LangExt.PartialTypeSignatures-       ; warn_partial_sigs <- woptM Opt_WarnPartialTypeSignatures-       ; let type_holes | not partial_sigs  = HoleError-                        | warn_partial_sigs = HoleWarn-                        | otherwise         = HoleDefer--       ; report_unsolved TypeError HoleError type_holes HoleError-                         ev_binds wanted }---- | Report all unsolved goals as warnings (but without deferring any errors to--- run-time). See Note [Safe Haskell Overlapping Instances Implementation] in--- "GHC.Tc.Solver"-warnAllUnsolved :: WantedConstraints -> TcM ()-warnAllUnsolved wanted-  = do { ev_binds <- newTcEvBinds-       ; report_unsolved (TypeWarn NoReason) HoleWarn HoleWarn HoleWarn-                         ev_binds wanted }---- | Report unsolved goals as errors or warnings.-report_unsolved :: TypeErrorChoice   -- Deferred type errors-                -> HoleChoice        -- Expression holes-                -> HoleChoice        -- Type holes-                -> HoleChoice        -- Out of scope holes-                -> EvBindsVar        -- cec_binds-                -> WantedConstraints -> TcM ()-report_unsolved type_errors expr_holes-    type_holes out_of_scope_holes binds_var wanted-  | isEmptyWC wanted-  = return ()-  | otherwise-  = do { traceTc "reportUnsolved {" $-         vcat [ text "type errors:" <+> ppr type_errors-              , text "expr holes:" <+> ppr expr_holes-              , text "type holes:" <+> ppr type_holes-              , text "scope holes:" <+> ppr out_of_scope_holes ]-       ; traceTc "reportUnsolved (before zonking and tidying)" (ppr wanted)--       ; wanted <- zonkWC wanted   -- Zonk to reveal all information-       ; let tidy_env = tidyFreeTyCoVars emptyTidyEnv free_tvs-             free_tvs = filterOut isCoVar $-                        tyCoVarsOfWCList wanted-                        -- tyCoVarsOfWC returns free coercion *holes*, even though-                        -- they are "bound" by other wanted constraints. They in-                        -- turn may mention variables bound further in, which makes-                        -- no sense. Really we should not return those holes at all;-                        -- for now we just filter them out.--       ; traceTc "reportUnsolved (after zonking):" $-         vcat [ text "Free tyvars:" <+> pprTyVars free_tvs-              , text "Tidy env:" <+> ppr tidy_env-              , text "Wanted:" <+> ppr wanted ]--       ; warn_redundant <- woptM Opt_WarnRedundantConstraints-       ; exp_syns <- goptM Opt_PrintExpandedSynonyms-       ; let err_ctxt = CEC { cec_encl  = []-                            , cec_tidy  = tidy_env-                            , cec_defer_type_errors = type_errors-                            , cec_expr_holes = expr_holes-                            , cec_type_holes = type_holes-                            , cec_out_of_scope_holes = out_of_scope_holes-                            , cec_suppress = insolubleWC wanted-                                 -- See Note [Suppressing error messages]-                                 -- Suppress low-priority errors if there-                                 -- are insoluble errors anywhere;-                                 -- See #15539 and c.f. setting ic_status-                                 -- in GHC.Tc.Solver.setImplicationStatus-                            , cec_warn_redundant = warn_redundant-                            , cec_expand_syns = exp_syns-                            , cec_binds    = binds_var }--       ; tc_lvl <- getTcLevel-       ; reportWanteds err_ctxt tc_lvl wanted-       ; traceTc "reportUnsolved }" empty }-------------------------------------------------      Internal functions------------------------------------------------- | An error Report collects messages categorised by their importance.--- See Note [Error report] for details.-data Report-  = Report { report_important :: [SDoc]-           , report_relevant_bindings :: [SDoc]-           , report_valid_hole_fits :: [SDoc]-           }--instance Outputable Report where   -- Debugging only-  ppr (Report { report_important = imp-              , report_relevant_bindings = rel-              , report_valid_hole_fits = val })-    = vcat [ text "important:" <+> vcat imp-           , text "relevant:"  <+> vcat rel-           , text "valid:"  <+> vcat val ]--{- Note [Error report]-The idea is that error msgs are divided into three parts: the main msg, the-context block (\"In the second argument of ...\"), and the relevant bindings-block, which are displayed in that order, with a mark to divide them.  The-idea is that the main msg ('report_important') varies depending on the error-in question, but context and relevant bindings are always the same, which-should simplify visual parsing.--The context is added when the Report is passed off to 'mkErrorReport'.-Unfortunately, unlike the context, the relevant bindings are added in-multiple places so they have to be in the Report.--}--instance Semigroup Report where-    Report a1 b1 c1 <> Report a2 b2 c2 = Report (a1 ++ a2) (b1 ++ b2) (c1 ++ c2)--instance Monoid Report where-    mempty = Report [] [] []-    mappend = (Semigroup.<>)---- | Put a doc into the important msgs block.-important :: SDoc -> Report-important doc = mempty { report_important = [doc] }---- | Put a doc into the relevant bindings block.-mk_relevant_bindings :: SDoc -> Report-mk_relevant_bindings doc = mempty { report_relevant_bindings = [doc] }---- | Put a doc into the valid hole fits block.-valid_hole_fits :: SDoc -> Report-valid_hole_fits docs = mempty { report_valid_hole_fits = [docs] }--data TypeErrorChoice   -- What to do for type errors found by the type checker-  = TypeError     -- A type error aborts compilation with an error message-  | TypeWarn WarnReason-                  -- A type error is deferred to runtime, plus a compile-time warning-                  -- The WarnReason should usually be (Reason Opt_WarnDeferredTypeErrors)-                  -- but it isn't for the Safe Haskell Overlapping Instances warnings-                  -- see warnAllUnsolved-  | TypeDefer     -- A type error is deferred to runtime; no error or warning at compile time--data HoleChoice-  = HoleError     -- A hole is a compile-time error-  | HoleWarn      -- Defer to runtime, emit a compile-time warning-  | HoleDefer     -- Defer to runtime, no warning--instance Outputable HoleChoice where-  ppr HoleError = text "HoleError"-  ppr HoleWarn  = text "HoleWarn"-  ppr HoleDefer = text "HoleDefer"--instance Outputable TypeErrorChoice  where-  ppr TypeError         = text "TypeError"-  ppr (TypeWarn reason) = text "TypeWarn" <+> ppr reason-  ppr TypeDefer         = text "TypeDefer"--data ReportErrCtxt-    = CEC { cec_encl :: [Implication]  -- Enclosing implications-                                       --   (innermost first)-                                       -- ic_skols and givens are tidied, rest are not-          , cec_tidy  :: TidyEnv--          , cec_binds :: EvBindsVar    -- Make some errors (depending on cec_defer)-                                       -- into warnings, and emit evidence bindings-                                       -- into 'cec_binds' for unsolved constraints--          , cec_defer_type_errors :: TypeErrorChoice -- Defer type errors until runtime--          -- cec_expr_holes is a union of:-          --   cec_type_holes - a set of typed holes: '_', '_a', '_foo'-          --   cec_out_of_scope_holes - a set of variables which are-          --                            out of scope: 'x', 'y', 'bar'-          , cec_expr_holes :: HoleChoice           -- Holes in expressions-          , cec_type_holes :: HoleChoice           -- Holes in types-          , cec_out_of_scope_holes :: HoleChoice   -- Out of scope holes--          , cec_warn_redundant :: Bool    -- True <=> -Wredundant-constraints-          , cec_expand_syns    :: Bool    -- True <=> -fprint-expanded-synonyms--          , cec_suppress :: Bool    -- True <=> More important errors have occurred,-                                    --          so create bindings if need be, but-                                    --          don't issue any more errors/warnings-                                    -- See Note [Suppressing error messages]-      }--instance Outputable ReportErrCtxt where-  ppr (CEC { cec_binds              = bvar-           , cec_defer_type_errors  = dte-           , cec_expr_holes         = eh-           , cec_type_holes         = th-           , cec_out_of_scope_holes = osh-           , cec_warn_redundant     = wr-           , cec_expand_syns        = es-           , cec_suppress           = sup })-    = text "CEC" <+> braces (vcat-         [ text "cec_binds"              <+> equals <+> ppr bvar-         , text "cec_defer_type_errors"  <+> equals <+> ppr dte-         , text "cec_expr_holes"         <+> equals <+> ppr eh-         , text "cec_type_holes"         <+> equals <+> ppr th-         , text "cec_out_of_scope_holes" <+> equals <+> ppr osh-         , text "cec_warn_redundant"     <+> equals <+> ppr wr-         , text "cec_expand_syns"        <+> equals <+> ppr es-         , text "cec_suppress"           <+> equals <+> ppr sup ])---- | Returns True <=> the ReportErrCtxt indicates that something is deferred-deferringAnyBindings :: ReportErrCtxt -> Bool-  -- Don't check cec_type_holes, as these don't cause bindings to be deferred-deferringAnyBindings (CEC { cec_defer_type_errors  = TypeError-                          , cec_expr_holes         = HoleError-                          , cec_out_of_scope_holes = HoleError }) = False-deferringAnyBindings _                                            = True--maybeSwitchOffDefer :: EvBindsVar -> ReportErrCtxt -> ReportErrCtxt--- Switch off defer-type-errors inside CoEvBindsVar--- See Note [Failing equalities with no evidence bindings]-maybeSwitchOffDefer evb ctxt- | CoEvBindsVar{} <- evb- = ctxt { cec_defer_type_errors  = TypeError-        , cec_expr_holes         = HoleError-        , cec_out_of_scope_holes = HoleError }- | otherwise- = ctxt--{- Note [Failing equalities with no evidence bindings]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If we go inside an implication that has no term evidence-(e.g. unifying under a forall), we can't defer type errors.  You could-imagine using the /enclosing/ bindings (in cec_binds), but that may-not have enough stuff in scope for the bindings to be well typed.  So-we just switch off deferred type errors altogether.  See #14605.--This is done by maybeSwitchOffDefer.  It's also useful in one other-place: see Note [Wrapping failing kind equalities] in GHC.Tc.Solver.--Note [Suppressing error messages]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The cec_suppress flag says "don't report any errors".  Instead, just create-evidence bindings (as usual).  It's used when more important errors have occurred.--Specifically (see reportWanteds)-  * If there are insoluble Givens, then we are in unreachable code and all bets-    are off.  So don't report any further errors.-  * If there are any insolubles (eg Int~Bool), here or in a nested implication,-    then suppress errors from the simple constraints here.  Sometimes the-    simple-constraint errors are a knock-on effect of the insolubles.--This suppression behaviour is controlled by the Bool flag in-ReportErrorSpec, as used in reportWanteds.--But we need to take care: flags can turn errors into warnings, and we-don't want those warnings to suppress subsequent errors (including-suppressing the essential addTcEvBind for them: #15152). So in-tryReporter we use askNoErrs to see if any error messages were-/actually/ produced; if not, we don't switch on suppression.--A consequence is that warnings never suppress warnings, so turning an-error into a warning may allow subsequent warnings to appear that were-previously suppressed.   (e.g. partial-sigs/should_fail/T14584)--}--reportImplic :: ReportErrCtxt -> Implication -> TcM ()-reportImplic ctxt implic@(Implic { ic_skols = tvs-                                 , ic_given = given-                                 , ic_wanted = wanted, ic_binds = evb-                                 , ic_status = status, ic_info = info-                                 , ic_tclvl = tc_lvl })-  | BracketSkol <- info-  , not insoluble-  = return ()        -- For Template Haskell brackets report only-                     -- definite errors. The whole thing will be re-checked-                     -- later when we plug it in, and meanwhile there may-                     -- certainly be un-satisfied constraints--  | otherwise-  = do { traceTc "reportImplic" (ppr implic')-       ; when bad_telescope $ reportBadTelescope ctxt tcl_env info tvs-               -- Do /not/ use the tidied tvs because then are in the-               -- wrong order, so tidying will rename things wrongly-       ; reportWanteds ctxt' tc_lvl wanted-       ; when (cec_warn_redundant ctxt) $-         warnRedundantConstraints ctxt' tcl_env info' dead_givens }-  where-    tcl_env      = ic_env implic-    insoluble    = isInsolubleStatus status-    (env1, tvs') = mapAccumL tidyVarBndr (cec_tidy ctxt) $-                   scopedSort tvs-        -- scopedSort: the ic_skols may not be in dependency order-        -- (see Note [Skolems in an implication] in GHC.Tc.Types.Constraint)-        -- but tidying goes wrong on out-of-order constraints;-        -- so we sort them here before tidying-    info'   = tidySkolemInfo env1 info-    implic' = implic { ic_skols = tvs'-                     , ic_given = map (tidyEvVar env1) given-                     , ic_info  = info' }--    ctxt1 = maybeSwitchOffDefer evb ctxt-    ctxt' = ctxt1 { cec_tidy     = env1-                  , cec_encl     = implic' : cec_encl ctxt--                  , cec_suppress = insoluble || cec_suppress ctxt-                        -- Suppress inessential errors if there-                        -- are insolubles anywhere in the-                        -- tree rooted here, or we've come across-                        -- a suppress-worthy constraint higher up (#11541)--                  , cec_binds    = evb }--    dead_givens = case status of-                    IC_Solved { ics_dead = dead } -> dead-                    _                             -> []--    bad_telescope = case status of-              IC_BadTelescope -> True-              _               -> False--warnRedundantConstraints :: ReportErrCtxt -> TcLclEnv -> SkolemInfo -> [EvVar] -> TcM ()--- See Note [Tracking redundant constraints] in GHC.Tc.Solver-warnRedundantConstraints ctxt env info ev_vars- | null redundant_evs- = return ()-- | SigSkol {} <- info- = setLclEnv env $  -- We want to add "In the type signature for f"-                    -- to the error context, which is a bit tiresome-   addErrCtxt (text "In" <+> ppr info) $-   do { env <- getLclEnv-      ; msg <- mkErrorReport ctxt env (important doc)-      ; reportWarning (Reason Opt_WarnRedundantConstraints) msg }-- | otherwise  -- But for InstSkol there already *is* a surrounding-              -- "In the instance declaration for Eq [a]" context-              -- and we don't want to say it twice. Seems a bit ad-hoc- = do { msg <- mkErrorReport ctxt env (important doc)-      ; reportWarning (Reason Opt_WarnRedundantConstraints) msg }- where-   doc = text "Redundant constraint" <> plural redundant_evs <> colon-         <+> pprEvVarTheta redundant_evs--   redundant_evs =-       filterOut is_type_error $-       case info of -- See Note [Redundant constraints in instance decls]-         InstSkol -> filterOut (improving . idType) ev_vars-         _        -> ev_vars--   -- See #15232-   is_type_error = isJust . userTypeError_maybe . idType--   improving pred -- (transSuperClasses p) does not include p-     = any isImprovementPred (pred : transSuperClasses pred)--reportBadTelescope :: ReportErrCtxt -> TcLclEnv -> SkolemInfo -> [TcTyVar] -> TcM ()-reportBadTelescope ctxt env (ForAllSkol telescope) skols-  = do { msg <- mkErrorReport ctxt env (important doc)-       ; reportError msg }-  where-    doc = hang (text "These kind and type variables:" <+> telescope $$-                text "are out of dependency order. Perhaps try this ordering:")-             2 (pprTyVars sorted_tvs)--    sorted_tvs = scopedSort skols--reportBadTelescope _ _ skol_info skols-  = pprPanic "reportBadTelescope" (ppr skol_info $$ ppr skols)--{- Note [Redundant constraints in instance decls]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-For instance declarations, we don't report unused givens if-they can give rise to improvement.  Example (#10100):-    class Add a b ab | a b -> ab, a ab -> b-    instance Add Zero b b-    instance Add a b ab => Add (Succ a) b (Succ ab)-The context (Add a b ab) for the instance is clearly unused in terms-of evidence, since the dictionary has no fields.  But it is still-needed!  With the context, a wanted constraint-   Add (Succ Zero) beta (Succ Zero)-we will reduce to (Add Zero beta Zero), and thence we get beta := Zero.-But without the context we won't find beta := Zero.--This only matters in instance declarations..--}--reportWanteds :: ReportErrCtxt -> TcLevel -> WantedConstraints -> TcM ()-reportWanteds ctxt tc_lvl (WC { wc_simple = simples, wc_impl = implics-                              , wc_holes = holes })-  = do { traceTc "reportWanteds" (vcat [ text "Simples =" <+> ppr simples-                                       , text "Suppress =" <+> ppr (cec_suppress ctxt)-                                       , text "tidy_cts =" <+> ppr tidy_cts-                                       , text "tidy_holes = " <+> ppr tidy_holes ])--         -- First, deal with any out-of-scope errors:-       ; let (out_of_scope, other_holes) = partition isOutOfScopeHole tidy_holes-               -- don't suppress out-of-scope errors-             ctxt_for_scope_errs = ctxt { cec_suppress = False }-       ; (_, no_out_of_scope) <- askNoErrs $-                                 reportHoles tidy_cts ctxt_for_scope_errs out_of_scope--         -- Next, deal with things that are utterly wrong-         -- Like Int ~ Bool (incl nullary TyCons)-         -- or  Int ~ t a   (AppTy on one side)-         -- These /ones/ are not suppressed by the incoming context-         -- (but will be by out-of-scope errors)-       ; let ctxt_for_insols = ctxt { cec_suppress = not no_out_of_scope }-       ; reportHoles tidy_cts ctxt_for_insols other_holes-          -- holes never suppress--       ; (ctxt1, cts1) <- tryReporters ctxt_for_insols report1 tidy_cts--         -- Now all the other constraints.  We suppress errors here if-         -- any of the first batch failed, or if the enclosing context-         -- says to suppress-       ; let ctxt2 = ctxt { cec_suppress = cec_suppress ctxt || cec_suppress ctxt1 }-       ; (_, leftovers) <- tryReporters ctxt2 report2 cts1-       ; MASSERT2( null leftovers, ppr leftovers )--            -- All the Derived ones have been filtered out of simples-            -- by the constraint solver. This is ok; we don't want-            -- to report unsolved Derived goals as errors-            -- See Note [Do not report derived but soluble errors]--     ; mapBagM_ (reportImplic ctxt2) implics }-            -- NB ctxt2: don't suppress inner insolubles if there's only a-            -- wanted insoluble here; but do suppress inner insolubles-            -- if there's a *given* insoluble here (= inaccessible code)- where-    env = cec_tidy ctxt-    tidy_cts   = bagToList (mapBag (tidyCt env)   simples)-    tidy_holes = bagToList (mapBag (tidyHole env) holes)--    -- report1: ones that should *not* be suppressed by-    --          an insoluble somewhere else in the tree-    -- It's crucial that anything that is considered insoluble-    -- (see GHC.Tc.Utils.insolubleCt) is caught here, otherwise-    -- we might suppress its error message, and proceed on past-    -- type checking to get a Lint error later-    report1 = [ ("custom_error", unblocked is_user_type_error, True,  mkUserTypeErrorReporter)--              , given_eq_spec-              , ("insoluble2",   unblocked utterly_wrong,  True, mkGroupReporter mkEqErr)-              , ("skolem eq1",   unblocked very_wrong,     True, mkSkolReporter)-              , ("skolem eq2",   unblocked skolem_eq,      True, mkSkolReporter)-              , ("non-tv eq",    unblocked non_tv_eq,      True, mkSkolReporter)--                  -- The only remaining equalities are alpha ~ ty,-                  -- where alpha is untouchable; and representational equalities-                  -- Prefer homogeneous equalities over hetero, because the-                  -- former might be holding up the latter.-                  -- See Note [Equalities with incompatible kinds] in GHC.Tc.Solver.Canonical-              , ("Homo eqs",      unblocked is_homo_equality, True,  mkGroupReporter mkEqErr)-              , ("Other eqs",     unblocked is_equality,      True,  mkGroupReporter mkEqErr)-              , ("Blocked eqs",   is_equality,           False, mkSuppressReporter mkBlockedEqErr)]--    -- report2: we suppress these if there are insolubles elsewhere in the tree-    report2 = [ ("Implicit params", is_ip,           False, mkGroupReporter mkIPErr)-              , ("Irreds",          is_irred,        False, mkGroupReporter mkIrredErr)-              , ("Dicts",           is_dict,         False, mkGroupReporter mkDictErr) ]--    -- also checks to make sure the constraint isn't HoleBlockerReason-    -- See TcCanonical Note [Equalities with incompatible kinds], (4)-    unblocked :: (Ct -> Pred -> Bool) -> Ct -> Pred -> Bool-    unblocked _ (CIrredCan { cc_reason = HoleBlockerReason {}}) _ = False-    unblocked checker ct pred = checker ct pred--    -- rigid_nom_eq, rigid_nom_tv_eq,-    is_dict, is_equality, is_ip, is_irred :: Ct -> Pred -> Bool--    is_given_eq ct pred-       | EqPred {} <- pred = arisesFromGivens ct-       | otherwise         = False-       -- I think all given residuals are equalities--    -- Things like (Int ~N Bool)-    utterly_wrong _ (EqPred NomEq ty1 ty2) = isRigidTy ty1 && isRigidTy ty2-    utterly_wrong _ _                      = False--    -- Things like (a ~N Int)-    very_wrong _ (EqPred NomEq ty1 ty2) = isSkolemTy tc_lvl ty1 && isRigidTy ty2-    very_wrong _ _                      = False--    -- Things like (a ~N b) or (a  ~N  F Bool)-    skolem_eq _ (EqPred NomEq ty1 _) = isSkolemTy tc_lvl ty1-    skolem_eq _ _                    = False--    -- Things like (F a  ~N  Int)-    non_tv_eq _ (EqPred NomEq ty1 _) = not (isTyVarTy ty1)-    non_tv_eq _ _                    = False--    is_user_type_error ct _ = isUserTypeErrorCt ct--    is_homo_equality _ (EqPred _ ty1 ty2) = tcTypeKind ty1 `tcEqType` tcTypeKind ty2-    is_homo_equality _ _                  = False--    is_equality _ (EqPred {}) = True-    is_equality _ _           = False--    is_dict _ (ClassPred {}) = True-    is_dict _ _              = False--    is_ip _ (ClassPred cls _) = isIPClass cls-    is_ip _ _                 = False--    is_irred _ (IrredPred {}) = True-    is_irred _ _              = False--    given_eq_spec  -- See Note [Given errors]-      | has_gadt_match (cec_encl ctxt)-      = ("insoluble1a", is_given_eq, True,  mkGivenErrorReporter)-      | otherwise-      = ("insoluble1b", is_given_eq, False, ignoreErrorReporter)-          -- False means don't suppress subsequent errors-          -- Reason: we don't report all given errors-          --         (see mkGivenErrorReporter), and we should only suppress-          --         subsequent errors if we actually report this one!-          --         #13446 is an example--    -- See Note [Given errors]-    has_gadt_match [] = False-    has_gadt_match (implic : implics)-      | PatSkol {} <- ic_info implic-      , ic_given_eqs implic /= NoGivenEqs-      , ic_warn_inaccessible implic-          -- Don't bother doing this if -Winaccessible-code isn't enabled.-          -- See Note [Avoid -Winaccessible-code when deriving] in GHC.Tc.TyCl.Instance.-      = True-      | otherwise-      = has_gadt_match implics------------------isSkolemTy :: TcLevel -> Type -> Bool--- The type is a skolem tyvar-isSkolemTy tc_lvl ty-  | Just tv <- getTyVar_maybe ty-  =  isSkolemTyVar tv-  || (isTyVarTyVar tv && isTouchableMetaTyVar tc_lvl tv)-     -- The last case is for touchable TyVarTvs-     -- we postpone untouchables to a latter test (too obscure)--  | otherwise-  = False--isTyFun_maybe :: Type -> Maybe TyCon-isTyFun_maybe ty = case tcSplitTyConApp_maybe ty of-                      Just (tc,_) | isTypeFamilyTyCon tc -> Just tc-                      _ -> Nothing-------------------------------------------------      Reporters-----------------------------------------------type Reporter-  = ReportErrCtxt -> [Ct] -> TcM ()-type ReporterSpec-  = ( String                     -- Name-    , Ct -> Pred -> Bool         -- Pick these ones-    , Bool                       -- True <=> suppress subsequent reporters-    , Reporter)                  -- The reporter itself--mkSkolReporter :: Reporter--- Suppress duplicates with either the same LHS, or same location-mkSkolReporter ctxt cts-  = mapM_ (reportGroup mkEqErr ctxt) (group cts)-  where-     group [] = []-     group (ct:cts) = (ct : yeses) : group noes-        where-          (yeses, noes) = partition (group_with ct) cts--     group_with ct1 ct2-       | EQ <- cmp_loc ct1 ct2 = True-       | eq_lhs_type   ct1 ct2 = True-       | otherwise             = False--reportHoles :: [Ct]  -- other (tidied) constraints-            -> ReportErrCtxt -> [Hole] -> TcM ()-reportHoles tidy_cts ctxt holes-  = do-      let holes' = filter (keepThisHole ctxt) holes-      -- Zonk and tidy all the TcLclEnvs before calling `mkHoleError`-      -- because otherwise types will be zonked and tidied many times over.-      (tidy_env', lcl_name_cache) <- zonkTidyTcLclEnvs (cec_tidy ctxt) (map (ctl_env . hole_loc) holes')-      let ctxt' = ctxt { cec_tidy = tidy_env' }-      forM_ holes' $ \hole ->-        do { err <- mkHoleError lcl_name_cache tidy_cts ctxt' hole-           ; maybeReportHoleError ctxt hole err-           ; maybeAddDeferredHoleBinding ctxt err hole }--keepThisHole :: ReportErrCtxt -> Hole -> Bool--- See Note [Skip type holes rapidly]-keepThisHole ctxt hole-  = case hole_sort hole of-       ExprHole {}    -> True-       TypeHole       -> keep_type_hole-       ConstraintHole -> keep_type_hole-  where-    keep_type_hole = case cec_type_holes ctxt of-                         HoleDefer -> False-                         _         -> True---- | zonkTidyTcLclEnvs takes a bunch of 'TcLclEnv's, each from a Hole.--- It returns a ('Name' :-> 'Type') mapping which gives the zonked, tidied--- type for each Id in any of the binder stacks in the  'TcLclEnv's.--- Since there is a huge overlap between these stacks, is is much,--- much faster to do them all at once, avoiding duplication.-zonkTidyTcLclEnvs :: TidyEnv -> [TcLclEnv] -> TcM (TidyEnv, NameEnv Type)-zonkTidyTcLclEnvs tidy_env lcls = foldM go (tidy_env, emptyNameEnv) (concatMap tcl_bndrs lcls)-  where-    go envs tc_bndr = case tc_bndr of-          TcTvBndr {} -> return envs-          TcIdBndr id _top_lvl -> go_one (idName id) (idType id) envs-          TcIdBndr_ExpType name et _top_lvl ->-            do { mb_ty <- readExpType_maybe et-                   -- et really should be filled in by now. But there's a chance-                   -- it hasn't, if, say, we're reporting a kind error en route to-                   -- checking a term. See test indexed-types/should_fail/T8129-                   -- Or we are reporting errors from the ambiguity check on-                   -- a local type signature-               ; case mb_ty of-                   Just ty -> go_one name ty envs-                   Nothing -> return envs-               }-    go_one name ty (tidy_env, name_env) = do-            if name `elemNameEnv` name_env-              then return (tidy_env, name_env)-              else do-                (tidy_env', tidy_ty) <- zonkTidyTcType tidy_env ty-                return (tidy_env',  extendNameEnv name_env name tidy_ty)--{- Note [Skip type holes rapidly]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we have module with a /lot/ of partial type signatures, and we-compile it while suppressing partial-type-signature warnings.  Then-we don't want to spend ages constructing error messages and lists of-relevant bindings that we never display! This happened in #14766, in-which partial type signatures in a Happy-generated parser cause a huge-increase in compile time.--The function ignoreThisHole short-circuits the error/warning generation-machinery, in cases where it is definitely going to be a no-op.--}--mkUserTypeErrorReporter :: Reporter-mkUserTypeErrorReporter ctxt-  = mapM_ $ \ct -> do { err <- mkUserTypeError ctxt ct-                      ; maybeReportError ctxt err-                      ; addDeferredBinding ctxt err ct }--mkUserTypeError :: ReportErrCtxt -> Ct -> TcM (MsgEnvelope DecoratedSDoc)-mkUserTypeError ctxt ct = mkErrorMsgFromCt ctxt ct-                        $ important-                        $ pprUserTypeErrorTy-                        $ case getUserTypeErrorMsg ct of-                            Just msg -> msg-                            Nothing  -> pprPanic "mkUserTypeError" (ppr ct)---mkGivenErrorReporter :: Reporter--- See Note [Given errors]-mkGivenErrorReporter ctxt cts-  = do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct-       ; dflags <- getDynFlags-       ; let (implic:_) = cec_encl ctxt-                 -- Always non-empty when mkGivenErrorReporter is called-             ct' = setCtLoc ct (setCtLocEnv (ctLoc ct) (ic_env implic))-                   -- For given constraints we overwrite the env (and hence src-loc)-                   -- with one from the immediately-enclosing implication.-                   -- See Note [Inaccessible code]--             inaccessible_msg = hang (text "Inaccessible code in")-                                   2 (ppr (ic_info implic))-             report = important inaccessible_msg `mappend`-                      mk_relevant_bindings binds_msg--       ; err <- mkEqErr_help dflags ctxt report ct' ty1 ty2--       ; traceTc "mkGivenErrorReporter" (ppr ct)-       ; reportWarning (Reason Opt_WarnInaccessibleCode) err }-  where-    (ct : _ )  = cts    -- Never empty-    (ty1, ty2) = getEqPredTys (ctPred ct)--ignoreErrorReporter :: Reporter--- Discard Given errors that don't come from--- a pattern match; maybe we should warn instead?-ignoreErrorReporter ctxt cts-  = do { traceTc "mkGivenErrorReporter no" (ppr cts $$ ppr (cec_encl ctxt))-       ; return () }---{- Note [Given errors]-~~~~~~~~~~~~~~~~~~~~~~-Given constraints represent things for which we have (or will have)-evidence, so they aren't errors.  But if a Given constraint is-insoluble, this code is inaccessible, and we might want to at least-warn about that.  A classic case is--   data T a where-     T1 :: T Int-     T2 :: T a-     T3 :: T Bool--   f :: T Int -> Bool-   f T1 = ...-   f T2 = ...-   f T3 = ...  -- We want to report this case as inaccessible--We'd like to point out that the T3 match is inaccessible. It-will have a Given constraint [G] Int ~ Bool.--But we don't want to report ALL insoluble Given constraints.  See Trac-#12466 for a long discussion.  For example, if we aren't careful-we'll complain about-   f :: ((Int ~ Bool) => a -> a) -> Int-which arguably is OK.  It's more debatable for-   g :: (Int ~ Bool) => Int -> Int-but it's tricky to distinguish these cases so we don't report-either.--The bottom line is this: has_gadt_match looks for an enclosing-pattern match which binds some equality constraints.  If we-find one, we report the insoluble Given.--}--mkGroupReporter :: (ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DecoratedSDoc))-                             -- Make error message for a group-                -> Reporter  -- Deal with lots of constraints--- Group together errors from same location,--- and report only the first (to avoid a cascade)-mkGroupReporter mk_err ctxt cts-  = mapM_ (reportGroup mk_err ctxt . toList) (equivClasses cmp_loc cts)---- Like mkGroupReporter, but doesn't actually print error messages-mkSuppressReporter :: (ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DecoratedSDoc)) -> Reporter-mkSuppressReporter mk_err ctxt cts-  = mapM_ (suppressGroup mk_err ctxt . toList) (equivClasses cmp_loc cts)--eq_lhs_type :: Ct -> Ct -> Bool-eq_lhs_type ct1 ct2-  = case (classifyPredType (ctPred ct1), classifyPredType (ctPred ct2)) of-       (EqPred eq_rel1 ty1 _, EqPred eq_rel2 ty2 _) ->-         (eq_rel1 == eq_rel2) && (ty1 `eqType` ty2)-       _ -> pprPanic "mkSkolReporter" (ppr ct1 $$ ppr ct2)--cmp_loc :: Ct -> Ct -> Ordering-cmp_loc ct1 ct2 = get ct1 `compare` get ct2-  where-    get ct = realSrcSpanStart (ctLocSpan (ctLoc ct))-             -- Reduce duplication by reporting only one error from each-             -- /starting/ location even if the end location differs--reportGroup :: (ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DecoratedSDoc)) -> Reporter-reportGroup mk_err ctxt cts =-  ASSERT( not (null cts))-  do { err <- mk_err ctxt cts-     ; traceTc "About to maybeReportErr" $-       vcat [ text "Constraint:"             <+> ppr cts-            , text "cec_suppress ="          <+> ppr (cec_suppress ctxt)-            , text "cec_defer_type_errors =" <+> ppr (cec_defer_type_errors ctxt) ]-     ; maybeReportError ctxt err-         -- But see Note [Always warn with -fdefer-type-errors]-     ; traceTc "reportGroup" (ppr cts)-     ; mapM_ (addDeferredBinding ctxt err) cts }-         -- Add deferred bindings for all-         -- Redundant if we are going to abort compilation,-         -- but that's hard to know for sure, and if we don't-         -- abort, we need bindings for all (e.g. #12156)---- like reportGroup, but does not actually report messages. It still adds--- -fdefer-type-errors bindings, though.-suppressGroup :: (ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DecoratedSDoc)) -> Reporter-suppressGroup mk_err ctxt cts- = do { err <- mk_err ctxt cts-      ; traceTc "Suppressing errors for" (ppr cts)-      ; mapM_ (addDeferredBinding ctxt err) cts }--maybeReportHoleError :: ReportErrCtxt -> Hole -> MsgEnvelope DecoratedSDoc -> TcM ()-maybeReportHoleError ctxt hole err-  | isOutOfScopeHole hole-  -- Always report an error for out-of-scope variables-  -- Unless -fdefer-out-of-scope-variables is on,-  -- in which case the messages are discarded.-  -- See #12170, #12406-  = -- If deferring, report a warning only if -Wout-of-scope-variables is on-    case cec_out_of_scope_holes ctxt of-      HoleError -> reportError err-      HoleWarn  ->-        reportWarning (Reason Opt_WarnDeferredOutOfScopeVariables) err-      HoleDefer -> return ()---- Unlike maybeReportError, these "hole" errors are--- /not/ suppressed by cec_suppress.  We want to see them!-maybeReportHoleError ctxt (Hole { hole_sort = hole_sort }) err-  | case hole_sort of TypeHole       -> True-                      ConstraintHole -> True-                      _              -> False-  -- When -XPartialTypeSignatures is on, warnings (instead of errors) are-  -- generated for holes in partial type signatures.-  -- Unless -fwarn-partial-type-signatures is not on,-  -- in which case the messages are discarded.-  = -- For partial type signatures, generate warnings only, and do that-    -- only if -fwarn-partial-type-signatures is on-    case cec_type_holes ctxt of-       HoleError -> reportError err-       HoleWarn  -> reportWarning (Reason Opt_WarnPartialTypeSignatures) err-       HoleDefer -> return ()--maybeReportHoleError ctxt hole err-  -- Otherwise this is a typed hole in an expression,-  -- but not for an out-of-scope variable (because that goes through a-  -- different function)-  = -- If deferring, report a warning only if -Wtyped-holes is on-    ASSERT( not (isOutOfScopeHole hole) )-    case cec_expr_holes ctxt of-       HoleError -> reportError err-       HoleWarn  -> reportWarning (Reason Opt_WarnTypedHoles) err-       HoleDefer -> return ()--maybeReportError :: ReportErrCtxt -> MsgEnvelope DecoratedSDoc -> TcM ()--- Report the error and/or make a deferred binding for it-maybeReportError ctxt err-  | cec_suppress ctxt    -- Some worse error has occurred;-  = return ()            -- so suppress this error/warning--  | otherwise-  = case cec_defer_type_errors ctxt of-      TypeDefer       -> return ()-      TypeWarn reason -> reportWarning reason err-      TypeError       -> reportError err--addDeferredBinding :: ReportErrCtxt -> MsgEnvelope DecoratedSDoc -> Ct -> TcM ()--- See Note [Deferring coercion errors to runtime]-addDeferredBinding ctxt err ct-  | deferringAnyBindings ctxt-  , CtWanted { ctev_pred = pred, ctev_dest = dest } <- ctEvidence ct-    -- Only add deferred bindings for Wanted constraints-  = do { dflags <- getDynFlags-       ; let err_tm       = mkErrorTerm dflags pred err-             ev_binds_var = cec_binds ctxt--       ; case dest of-           EvVarDest evar-             -> addTcEvBind ev_binds_var $ mkWantedEvBind evar err_tm-           HoleDest hole-             -> do { -- See Note [Deferred errors for coercion holes]-                     let co_var = coHoleCoVar hole-                   ; addTcEvBind ev_binds_var $ mkWantedEvBind co_var err_tm-                   ; fillCoercionHole hole (mkTcCoVarCo co_var) }}--  | otherwise   -- Do not set any evidence for Given/Derived-  = return ()--mkErrorTerm :: DynFlags -> Type  -- of the error term-            -> MsgEnvelope DecoratedSDoc -> EvTerm-mkErrorTerm dflags ty err = evDelayedError ty err_fs-  where-    err_msg = pprLocMsgEnvelope err-    err_fs  = mkFastString $ showSDoc dflags $-              err_msg $$ text "(deferred type error)"--maybeAddDeferredHoleBinding :: ReportErrCtxt -> MsgEnvelope DecoratedSDoc -> Hole -> TcM ()-maybeAddDeferredHoleBinding ctxt err (Hole { hole_sort = ExprHole (HER ref ref_ty _) })--- Only add bindings for holes in expressions--- not for holes in partial type signatures--- cf. addDeferredBinding-  | deferringAnyBindings ctxt-  = do { dflags <- getDynFlags-       ; let err_tm = mkErrorTerm dflags ref_ty err-           -- NB: ref_ty, not hole_ty. hole_ty might be rewritten.-           -- See Note [Holes] in GHC.Tc.Types.Constraint-       ; writeMutVar ref err_tm }-  | otherwise-  = return ()-maybeAddDeferredHoleBinding _ _ (Hole { hole_sort = TypeHole })-  = return ()-maybeAddDeferredHoleBinding _ _ (Hole { hole_sort = ConstraintHole })-  = return ()--tryReporters :: ReportErrCtxt -> [ReporterSpec] -> [Ct] -> TcM (ReportErrCtxt, [Ct])--- Use the first reporter in the list whose predicate says True-tryReporters ctxt reporters cts-  = do { let (vis_cts, invis_cts) = partition (isVisibleOrigin . ctOrigin) cts-       ; traceTc "tryReporters {" (ppr vis_cts $$ ppr invis_cts)-       ; (ctxt', cts') <- go ctxt reporters vis_cts invis_cts-       ; traceTc "tryReporters }" (ppr cts')-       ; return (ctxt', cts') }-  where-    go ctxt [] vis_cts invis_cts-      = return (ctxt, vis_cts ++ invis_cts)--    go ctxt (r : rs) vis_cts invis_cts-       -- always look at *visible* Origins before invisible ones-       -- this is the whole point of isVisibleOrigin-      = do { (ctxt', vis_cts') <- tryReporter ctxt r vis_cts-           ; (ctxt'', invis_cts') <- tryReporter ctxt' r invis_cts-           ; go ctxt'' rs vis_cts' invis_cts' }-                -- Carry on with the rest, because we must make-                -- deferred bindings for them if we have -fdefer-type-errors-                -- But suppress their error messages--tryReporter :: ReportErrCtxt -> ReporterSpec -> [Ct] -> TcM (ReportErrCtxt, [Ct])-tryReporter ctxt (str, keep_me,  suppress_after, reporter) cts-  | null yeses-  = return (ctxt, cts)-  | otherwise-  = do { traceTc "tryReporter{ " (text str <+> ppr yeses)-       ; (_, no_errs) <- askNoErrs (reporter ctxt yeses)-       ; let suppress_now = not no_errs && suppress_after-                            -- See Note [Suppressing error messages]-             ctxt' = ctxt { cec_suppress = suppress_now || cec_suppress ctxt }-       ; traceTc "tryReporter end }" (text str <+> ppr (cec_suppress ctxt) <+> ppr suppress_after)-       ; return (ctxt', nos) }-  where-    (yeses, nos) = partition (\ct -> keep_me ct (classifyPredType (ctPred ct))) cts--pprArising :: CtOrigin -> SDoc--- Used for the main, top-level error message--- We've done special processing for TypeEq, KindEq, givens-pprArising (TypeEqOrigin {})         = empty-pprArising (KindEqOrigin {})         = empty-pprArising orig | isGivenOrigin orig = empty-                | otherwise          = pprCtOrigin orig---- Add the "arising from..." part to a message about bunch of dicts-addArising :: CtOrigin -> SDoc -> SDoc-addArising orig msg = hang msg 2 (pprArising orig)--pprWithArising :: [Ct] -> (CtLoc, SDoc)--- Print something like---    (Eq a) arising from a use of x at y---    (Show a) arising from a use of p at q--- Also return a location for the error message--- Works for Wanted/Derived only-pprWithArising []-  = panic "pprWithArising"-pprWithArising (ct:cts)-  | null cts-  = (loc, addArising (ctLocOrigin loc)-                     (pprTheta [ctPred ct]))-  | otherwise-  = (loc, vcat (map ppr_one (ct:cts)))-  where-    loc = ctLoc ct-    ppr_one ct' = hang (parens (pprType (ctPred ct')))-                     2 (pprCtLoc (ctLoc ct'))--mkErrorMsgFromCt :: ReportErrCtxt -> Ct -> Report -> TcM (MsgEnvelope DecoratedSDoc)-mkErrorMsgFromCt ctxt ct report-  = mkErrorReport ctxt (ctLocEnv (ctLoc ct)) report--mkErrorReport :: ReportErrCtxt -> TcLclEnv -> Report -> TcM (MsgEnvelope DecoratedSDoc)-mkErrorReport ctxt tcl_env (Report important relevant_bindings valid_subs)-  = do { context <- mkErrInfo (cec_tidy ctxt) (tcl_ctxt tcl_env)-       ; mkDecoratedSDocAt (RealSrcSpan (tcl_loc tcl_env) Nothing)-                           (vcat important)-                           context-                           (vcat $ relevant_bindings ++ valid_subs)-       }--type UserGiven = Implication--getUserGivens :: ReportErrCtxt -> [UserGiven]--- One item for each enclosing implication-getUserGivens (CEC {cec_encl = implics}) = getUserGivensFromImplics implics--getUserGivensFromImplics :: [Implication] -> [UserGiven]-getUserGivensFromImplics implics-  = reverse (filterOut (null . ic_given) implics)--{- Note [Always warn with -fdefer-type-errors]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When -fdefer-type-errors is on we warn about *all* type errors, even-if cec_suppress is on.  This can lead to a lot more warnings than you-would get errors without -fdefer-type-errors, but if we suppress any of-them you might get a runtime error that wasn't warned about at compile-time.--This is an easy design choice to change; just flip the order of the-first two equations for maybeReportError--To be consistent, we should also report multiple warnings from a single-location in mkGroupReporter, when -fdefer-type-errors is on.  But that-is perhaps a bit *over*-consistent! Again, an easy choice to change.--With #10283, you can now opt out of deferred type error warnings.--Note [Deferred errors for coercion holes]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we need to defer a type error where the destination for the evidence-is a coercion hole. We can't just put the error in the hole, because we can't-make an erroneous coercion. (Remember that coercions are erased for runtime.)-Instead, we invent a new EvVar, bind it to an error and then make a coercion-from that EvVar, filling the hole with that coercion. Because coercions'-types are unlifted, the error is guaranteed to be hit before we get to the-coercion.--Note [Do not report derived but soluble errors]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The wc_simples include Derived constraints that have not been solved,-but are not insoluble (in that case they'd be reported by 'report1').-We do not want to report these as errors:--* Superclass constraints. If we have an unsolved [W] Ord a, we'll also have-  an unsolved [D] Eq a, and we do not want to report that; it's just noise.--* Functional dependencies.  For givens, consider-      class C a b | a -> b-      data T a where-         MkT :: C a d => [d] -> T a-      f :: C a b => T a -> F Int-      f (MkT xs) = length xs-  Then we get a [D] b~d.  But there *is* a legitimate call to-  f, namely   f (MkT [True]) :: T Bool, in which b=d.  So we should-  not reject the program.--  For wanteds, something similar-      data T a where-        MkT :: C Int b => a -> b -> T a-      g :: C Int c => c -> ()-      f :: T a -> ()-      f (MkT x y) = g x-  Here we get [G] C Int b, [W] C Int a, hence [D] a~b.-  But again f (MkT True True) is a legitimate call.--(We leave the Deriveds in wc_simple until reportErrors, so that we don't lose-derived superclasses between iterations of the solver.)--For functional dependencies, here is a real example,-stripped off from libraries/utf8-string/Codec/Binary/UTF8/Generic.hs--  class C a b | a -> b-  g :: C a b => a -> b -> ()-  f :: C a b => a -> b -> ()-  f xa xb =-      let loop = g xa-      in loop xb--We will first try to infer a type for loop, and we will succeed:-    C a b' => b' -> ()-Subsequently, we will type check (loop xb) and all is good. But,-recall that we have to solve a final implication constraint:-    C a b => (C a b' => .... cts from body of loop .... ))-And now we have a problem as we will generate an equality b ~ b' and fail to-solve it.---************************************************************************-*                                                                      *-                Irreducible predicate errors-*                                                                      *-************************************************************************--}--mkIrredErr :: ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DecoratedSDoc)-mkIrredErr ctxt cts-  = do { (ctxt, binds_msg, ct1) <- relevantBindings True ctxt ct1-       ; let orig = ctOrigin ct1-             msg  = couldNotDeduce (getUserGivens ctxt) (map ctPred cts, orig)-       ; mkErrorMsgFromCt ctxt ct1 $-         msg `mappend` mk_relevant_bindings binds_msg }-  where-    (ct1:_) = cts-------------------mkHoleError :: NameEnv Type -> [Ct] -> ReportErrCtxt -> Hole -> TcM (MsgEnvelope DecoratedSDoc)-mkHoleError _ _tidy_simples _ctxt hole@(Hole { hole_occ = occ-                                           , hole_ty = hole_ty-                                           , hole_loc = ct_loc })-  | isOutOfScopeHole hole-  = do { dflags  <- getDynFlags-       ; rdr_env <- getGlobalRdrEnv-       ; imp_info <- getImports-       ; curr_mod <- getModule-       ; hpt <- getHpt-       ; mkDecoratedSDocAt (RealSrcSpan (tcl_loc lcl_env) Nothing)-                           out_of_scope_msg O.empty-                           (unknownNameSuggestions dflags hpt curr_mod rdr_env-                            (tcl_rdr lcl_env) imp_info (mkRdrUnqual occ)) }-  where-    herald | isDataOcc occ = text "Data constructor not in scope:"-           | otherwise     = text "Variable not in scope:"--    out_of_scope_msg -- Print v :: ty only if the type has structure-      | boring_type = hang herald 2 (ppr occ)-      | otherwise   = hang herald 2 (pp_occ_with_type occ hole_ty)--    lcl_env     = ctLocEnv ct_loc-    boring_type = isTyVarTy hole_ty-- -- general case: not an out-of-scope error-mkHoleError lcl_name_cache tidy_simples ctxt hole@(Hole { hole_occ = occ-                                         , hole_ty = hole_ty-                                         , hole_sort = sort-                                         , hole_loc = ct_loc })-  = do { binds_msg-           <- relevant_bindings False lcl_env lcl_name_cache (tyCoVarsOfType hole_ty)-               -- The 'False' means "don't filter the bindings"; see Trac #8191--       ; show_hole_constraints <- goptM Opt_ShowHoleConstraints-       ; let constraints_msg-               | ExprHole _ <- sort, show_hole_constraints-               = givenConstraintsMsg ctxt-               | otherwise-               = empty--       ; show_valid_hole_fits <- goptM Opt_ShowValidHoleFits-       ; (ctxt, sub_msg) <- if show_valid_hole_fits-                            then validHoleFits ctxt tidy_simples hole-                            else return (ctxt, empty)--       ; mkErrorReport ctxt lcl_env $-            important hole_msg `mappend`-            mk_relevant_bindings (binds_msg $$ constraints_msg) `mappend`-            valid_hole_fits sub_msg }--  where-    lcl_env     = ctLocEnv ct_loc-    hole_kind   = tcTypeKind hole_ty-    tyvars      = tyCoVarsOfTypeList hole_ty--    hole_msg = case sort of-      ExprHole _ -> vcat [ hang (text "Found hole:")-                            2 (pp_occ_with_type occ hole_ty)-                         , tyvars_msg, expr_hole_hint ]-      TypeHole -> vcat [ hang (text "Found type wildcard" <+> quotes (ppr occ))-                            2 (text "standing for" <+> quotes pp_hole_type_with_kind)-                       , tyvars_msg, type_hole_hint ]-      ConstraintHole -> vcat [ hang (text "Found extra-constraints wildcard standing for")-                                  2 (quotes $ pprType hole_ty)  -- always kind constraint-                             , tyvars_msg, type_hole_hint ]--    pp_hole_type_with_kind-      | isLiftedTypeKind hole_kind-        || isCoVarType hole_ty -- Don't print the kind of unlifted-                               -- equalities (#15039)-      = pprType hole_ty-      | otherwise-      = pprType hole_ty <+> dcolon <+> pprKind hole_kind--    tyvars_msg = ppUnless (null tyvars) $-                 text "Where:" <+> (vcat (map loc_msg other_tvs)-                                    $$ pprSkols ctxt skol_tvs)-       where-         (skol_tvs, other_tvs) = partition is_skol tyvars-         is_skol tv = isTcTyVar tv && isSkolemTyVar tv-                      -- Coercion variables can be free in the-                      -- hole, via kind casts--    type_hole_hint-         | HoleError <- cec_type_holes ctxt-         = text "To use the inferred type, enable PartialTypeSignatures"-         | otherwise-         = empty--    expr_hole_hint                       -- Give hint for, say,   f x = _x-         | lengthFS (occNameFS occ) > 1  -- Don't give this hint for plain "_"-         = text "Or perhaps" <+> quotes (ppr occ)-           <+> text "is mis-spelled, or not in scope"-         | otherwise-         = empty--    loc_msg tv-       | isTyVar tv-       = case tcTyVarDetails tv of-           MetaTv {} -> quotes (ppr tv) <+> text "is an ambiguous type variable"-           _         -> empty  -- Skolems dealt with already-       | otherwise  -- A coercion variable can be free in the hole type-       = ppWhenOption sdocPrintExplicitCoercions $-           quotes (ppr tv) <+> text "is a coercion variable"--pp_occ_with_type :: OccName -> Type -> SDoc-pp_occ_with_type occ hole_ty = hang (pprPrefixOcc occ) 2 (dcolon <+> pprType hole_ty)---- We unwrap the ReportErrCtxt here, to avoid introducing a loop in module--- imports-validHoleFits :: ReportErrCtxt -- The context we're in, i.e. the-                                        -- implications and the tidy environment-                       -> [Ct]          -- Unsolved simple constraints-                       -> Hole          -- The hole-                       -> TcM (ReportErrCtxt, SDoc) -- We return the new context-                                                    -- with a possibly updated-                                                    -- tidy environment, and-                                                    -- the message.-validHoleFits ctxt@(CEC {cec_encl = implics-                             , cec_tidy = lcl_env}) simps hole-  = do { (tidy_env, msg) <- findValidHoleFits lcl_env implics simps hole-       ; return (ctxt {cec_tidy = tidy_env}, msg) }---- See Note [Constraints include ...]-givenConstraintsMsg :: ReportErrCtxt -> SDoc-givenConstraintsMsg ctxt =-    let constraints :: [(Type, RealSrcSpan)]-        constraints =-          do { implic@Implic{ ic_given = given } <- cec_encl ctxt-             ; constraint <- given-             ; return (varType constraint, tcl_loc (ic_env implic)) }--        pprConstraint (constraint, loc) =-          ppr constraint <+> nest 2 (parens (text "from" <+> ppr loc))--    in ppUnless (null constraints) $-         hang (text "Constraints include")-            2 (vcat $ map pprConstraint constraints)-------------------mkIPErr :: ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DecoratedSDoc)-mkIPErr ctxt cts-  = do { (ctxt, binds_msg, ct1) <- relevantBindings True ctxt ct1-       ; let orig    = ctOrigin ct1-             preds   = map ctPred cts-             givens  = getUserGivens ctxt-             msg | null givens-                 = important $ addArising orig $-                   sep [ text "Unbound implicit parameter" <> plural cts-                       , nest 2 (pprParendTheta preds) ]-                 | otherwise-                 = couldNotDeduce givens (preds, orig)--       ; mkErrorMsgFromCt ctxt ct1 $-         msg `mappend` mk_relevant_bindings binds_msg }-  where-    (ct1:_) = cts--{--Note [Constraints include ...]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-'givenConstraintsMsg' returns the "Constraints include ..." message enabled by--fshow-hole-constraints. For example, the following hole:--    foo :: (Eq a, Show a) => a -> String-    foo x = _--would generate the message:--    Constraints include-      Eq a (from foo.hs:1:1-36)-      Show a (from foo.hs:1:1-36)--Constraints are displayed in order from innermost (closest to the hole) to-outermost. There's currently no filtering or elimination of duplicates.--************************************************************************-*                                                                      *-                Equality errors-*                                                                      *-************************************************************************--Note [Inaccessible code]-~~~~~~~~~~~~~~~~~~~~~~~~-Consider-   data T a where-     T1 :: T a-     T2 :: T Bool--   f :: (a ~ Int) => T a -> Int-   f T1 = 3-   f T2 = 4   -- Unreachable code--Here the second equation is unreachable. The original constraint-(a~Int) from the signature gets rewritten by the pattern-match to-(Bool~Int), so the danger is that we report the error as coming from-the *signature* (#7293).  So, for Given errors we replace the-env (and hence src-loc) on its CtLoc with that from the immediately-enclosing implication.--Note [Error messages for untouchables]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider (#9109)-  data G a where { GBool :: G Bool }-  foo x = case x of GBool -> True--Here we can't solve (t ~ Bool), where t is the untouchable result-meta-var 't', because of the (a ~ Bool) from the pattern match.-So we infer the type-   f :: forall a t. G a -> t-making the meta-var 't' into a skolem.  So when we come to report-the unsolved (t ~ Bool), t won't look like an untouchable meta-var-any more.  So we don't assert that it is.--}---- Don't have multiple equality errors from the same location--- E.g.   (Int,Bool) ~ (Bool,Int)   one error will do!-mkEqErr :: ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DecoratedSDoc)-mkEqErr ctxt (ct:_) = mkEqErr1 ctxt ct-mkEqErr _ [] = panic "mkEqErr"--mkEqErr1 :: ReportErrCtxt -> Ct -> TcM (MsgEnvelope DecoratedSDoc)-mkEqErr1 ctxt ct   -- Wanted or derived;-                   -- givens handled in mkGivenErrorReporter-  = do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct-       ; rdr_env <- getGlobalRdrEnv-       ; fam_envs <- tcGetFamInstEnvs-       ; let coercible_msg = case ctEqRel ct of-               NomEq  -> empty-               ReprEq -> mkCoercibleExplanation rdr_env fam_envs ty1 ty2-       ; dflags <- getDynFlags-       ; traceTc "mkEqErr1" (ppr ct $$ pprCtOrigin (ctOrigin ct))-       ; let report = mconcat [ important coercible_msg-                              , mk_relevant_bindings binds_msg]-       ; mkEqErr_help dflags ctxt report ct ty1 ty2 }-  where-    (ty1, ty2) = getEqPredTys (ctPred ct)---- | This function tries to reconstruct why a "Coercible ty1 ty2" constraint--- is left over.-mkCoercibleExplanation :: GlobalRdrEnv -> FamInstEnvs-                       -> TcType -> TcType -> SDoc-mkCoercibleExplanation rdr_env fam_envs ty1 ty2-  | Just (tc, tys) <- tcSplitTyConApp_maybe ty1-  , (rep_tc, _, _) <- tcLookupDataFamInst fam_envs tc tys-  , Just msg <- coercible_msg_for_tycon rep_tc-  = msg-  | Just (tc, tys) <- splitTyConApp_maybe ty2-  , (rep_tc, _, _) <- tcLookupDataFamInst fam_envs tc tys-  , Just msg <- coercible_msg_for_tycon rep_tc-  = msg-  | Just (s1, _) <- tcSplitAppTy_maybe ty1-  , Just (s2, _) <- tcSplitAppTy_maybe ty2-  , s1 `eqType` s2-  , has_unknown_roles s1-  = hang (text "NB: We cannot know what roles the parameters to" <+>-          quotes (ppr s1) <+> text "have;")-       2 (text "we must assume that the role is nominal")-  | otherwise-  = empty-  where-    coercible_msg_for_tycon tc-        | isAbstractTyCon tc-        = Just $ hsep [ text "NB: The type constructor"-                      , quotes (pprSourceTyCon tc)-                      , text "is abstract" ]-        | isNewTyCon tc-        , [data_con] <- tyConDataCons tc-        , let dc_name = dataConName data_con-        , isNothing (lookupGRE_Name rdr_env dc_name)-        = Just $ hang (text "The data constructor" <+> quotes (ppr dc_name))-                    2 (sep [ text "of newtype" <+> quotes (pprSourceTyCon tc)-                           , text "is not in scope" ])-        | otherwise = Nothing--    has_unknown_roles ty-      | Just (tc, tys) <- tcSplitTyConApp_maybe ty-      = tys `lengthAtLeast` tyConArity tc  -- oversaturated tycon-      | Just (s, _) <- tcSplitAppTy_maybe ty-      = has_unknown_roles s-      | isTyVarTy ty-      = True-      | otherwise-      = False--mkEqErr_help :: DynFlags -> ReportErrCtxt -> Report-             -> Ct-             -> TcType -> TcType -> TcM (MsgEnvelope DecoratedSDoc)-mkEqErr_help dflags ctxt report ct ty1 ty2-  | Just (tv1, _) <- tcGetCastedTyVar_maybe ty1-  = mkTyVarEqErr dflags ctxt report ct tv1 ty2-  | Just (tv2, _) <- tcGetCastedTyVar_maybe ty2-  = mkTyVarEqErr dflags ctxt report ct tv2 ty1-  | otherwise-  = reportEqErr ctxt report ct ty1 ty2--reportEqErr :: ReportErrCtxt -> Report-            -> Ct-            -> TcType -> TcType -> TcM (MsgEnvelope DecoratedSDoc)-reportEqErr ctxt report ct ty1 ty2-  = mkErrorMsgFromCt ctxt ct (mconcat [misMatch, report, eqInfo])-  where-    misMatch = misMatchOrCND False ctxt ct ty1 ty2-    eqInfo   = mkEqInfoMsg ct ty1 ty2--mkTyVarEqErr, mkTyVarEqErr'-  :: DynFlags -> ReportErrCtxt -> Report -> Ct-             -> TcTyVar -> TcType -> TcM (MsgEnvelope DecoratedSDoc)--- tv1 and ty2 are already tidied-mkTyVarEqErr dflags ctxt report ct tv1 ty2-  = do { traceTc "mkTyVarEqErr" (ppr ct $$ ppr tv1 $$ ppr ty2)-       ; mkTyVarEqErr' dflags ctxt report ct tv1 ty2 }--mkTyVarEqErr' dflags ctxt report ct tv1 ty2-     -- impredicativity is a simple error to understand; try it first-  | check_eq_result `cterHasProblem` cteImpredicative-  = let msg = vcat [ (if isSkolemTyVar tv1-                      then text "Cannot equate type variable"-                      else text "Cannot instantiate unification variable")-                     <+> quotes (ppr tv1)-                   , hang (text "with a" <+> what <+> text "involving polytypes:") 2 (ppr ty2) ]-    in-       -- Unlike the other reports, this discards the old 'report_important'-       -- instead of augmenting it.  This is because the details are not likely-       -- to be helpful since this is just an unimplemented feature.-    mkErrorMsgFromCt ctxt ct $ mconcat-        [ headline_msg-        , important msg-        , if isSkolemTyVar tv1 then extraTyVarEqInfo ctxt tv1 ty2 else mempty-        , report ]--  | isSkolemTyVar tv1  -- ty2 won't be a meta-tyvar; we would have-                       -- swapped in Solver.Canonical.canEqTyVarHomo-    || isTyVarTyVar tv1 && not (isTyVarTy ty2)-    || ctEqRel ct == ReprEq-     -- The cases below don't really apply to ReprEq (except occurs check)-  = mkErrorMsgFromCt ctxt ct $ mconcat-        [ headline_msg-        , extraTyVarEqInfo ctxt tv1 ty2-        , suggestAddSig ctxt ty1 ty2-        , report-        ]--  | cterHasOccursCheck check_eq_result-    -- We report an "occurs check" even for  a ~ F t a, where F is a type-    -- function; it's not insoluble (because in principle F could reduce)-    -- but we have certainly been unable to solve it-    -- See Note [Occurs check error] in GHC.Tc.Solver.Canonical-  = do { let extra2   = mkEqInfoMsg ct ty1 ty2--             interesting_tyvars = filter (not . noFreeVarsOfType . tyVarKind) $-                                  filter isTyVar $-                                  fvVarList $-                                  tyCoFVsOfType ty1 `unionFV` tyCoFVsOfType ty2-             extra3 = mk_relevant_bindings $-                      ppWhen (not (null interesting_tyvars)) $-                      hang (text "Type variable kinds:") 2 $-                      vcat (map (tyvar_binding . tidyTyCoVarOcc (cec_tidy ctxt))-                                interesting_tyvars)--             tyvar_binding tv = ppr tv <+> dcolon <+> ppr (tyVarKind tv)-       ; mkErrorMsgFromCt ctxt ct $-         mconcat [headline_msg, extra2, extra3, report] }--  -- If the immediately-enclosing implication has 'tv' a skolem, and-  -- we know by now its an InferSkol kind of skolem, then presumably-  -- it started life as a TyVarTv, else it'd have been unified, given-  -- that there's no occurs-check or forall problem-  | (implic:_) <- cec_encl ctxt-  , Implic { ic_skols = skols } <- implic-  , tv1 `elem` skols-  = mkErrorMsgFromCt ctxt ct $ mconcat-        [ misMatchMsg ctxt ct ty1 ty2-        , extraTyVarEqInfo ctxt tv1 ty2-        , report-        ]--  -- Check for skolem escape-  | (implic:_) <- cec_encl ctxt   -- Get the innermost context-  , Implic { ic_skols = skols, ic_info = skol_info } <- implic-  , let esc_skols = filter (`elemVarSet` (tyCoVarsOfType ty2)) skols-  , not (null esc_skols)-  = do { let msg = misMatchMsg ctxt ct ty1 ty2-             esc_doc = sep [ text "because" <+> what <+> text "variable" <> plural esc_skols-                             <+> pprQuotedList esc_skols-                           , text "would escape" <+>-                             if isSingleton esc_skols then text "its scope"-                                                      else text "their scope" ]-             tv_extra = important $-                        vcat [ nest 2 $ esc_doc-                             , sep [ (if isSingleton esc_skols-                                      then text "This (rigid, skolem)" <+>-                                           what <+> text "variable is"-                                      else text "These (rigid, skolem)" <+>-                                           what <+> text "variables are")-                               <+> text "bound by"-                             , nest 2 $ ppr skol_info-                             , nest 2 $ text "at" <+>-                               ppr (tcl_loc (ic_env implic)) ] ]-       ; mkErrorMsgFromCt ctxt ct (mconcat [msg, tv_extra, report]) }--  -- Nastiest case: attempt to unify an untouchable variable-  -- So tv is a meta tyvar (or started that way before we-  -- generalised it).  So presumably it is an *untouchable*-  -- meta tyvar or a TyVarTv, else it'd have been unified-  -- See Note [Error messages for untouchables]-  | (implic:_) <- cec_encl ctxt   -- Get the innermost context-  , Implic { ic_given = given, ic_tclvl = lvl, ic_info = skol_info } <- implic-  = ASSERT2( not (isTouchableMetaTyVar lvl tv1)-           , ppr tv1 $$ ppr lvl )  -- See Note [Error messages for untouchables]-    do { let msg = misMatchMsg ctxt ct ty1 ty2-             tclvl_extra = important $-                  nest 2 $-                  sep [ quotes (ppr tv1) <+> text "is untouchable"-                      , nest 2 $ text "inside the constraints:" <+> pprEvVarTheta given-                      , nest 2 $ text "bound by" <+> ppr skol_info-                      , nest 2 $ text "at" <+>-                        ppr (tcl_loc (ic_env implic)) ]-             tv_extra = extraTyVarEqInfo ctxt tv1 ty2-             add_sig  = suggestAddSig ctxt ty1 ty2-       ; mkErrorMsgFromCt ctxt ct $ mconcat-            [msg, tclvl_extra, tv_extra, add_sig, report] }--  | otherwise-  = reportEqErr ctxt report ct (mkTyVarTy tv1) ty2-        -- This *can* happen (#6123)-        -- Consider an ambiguous top-level constraint (a ~ F a)-        -- Not an occurs check, because F is a type function.-  where-    headline_msg = misMatchOrCND insoluble_occurs_check ctxt ct ty1 ty2--    ty1 = mkTyVarTy tv1--    check_eq_result = case ct of-      CIrredCan { cc_reason = NonCanonicalReason result } -> result-      CIrredCan { cc_reason = HoleBlockerReason {} }      -> cteProblem cteHoleBlocker-      _ -> checkTyVarEq dflags tv1 ty2-        -- in T2627b, we report an error for F (F a0) ~ a0. Note that the type-        -- variable is on the right, so we don't get useful info for the CIrredCan,-        -- and have to compute the result of checkTyVarEq here.---    insoluble_occurs_check = check_eq_result `cterHasProblem` cteInsolubleOccurs--    what = text $ levelString $-           ctLocTypeOrKind_maybe (ctLoc ct) `orElse` TypeLevel--levelString :: TypeOrKind -> String-levelString TypeLevel = "type"-levelString KindLevel = "kind"--mkEqInfoMsg :: Ct -> TcType -> TcType -> Report--- Report (a) ambiguity if either side is a type function application---            e.g. F a0 ~ Int---        (b) warning about injectivity if both sides are the same---            type function application   F a ~ F b---            See Note [Non-injective type functions]-mkEqInfoMsg ct ty1 ty2-  = important (tyfun_msg $$ ambig_msg)-  where-    mb_fun1 = isTyFun_maybe ty1-    mb_fun2 = isTyFun_maybe ty2--    ambig_msg | isJust mb_fun1 || isJust mb_fun2-              = snd (mkAmbigMsg False ct)-              | otherwise = empty--    tyfun_msg | Just tc1 <- mb_fun1-              , Just tc2 <- mb_fun2-              , tc1 == tc2-              , not (isInjectiveTyCon tc1 Nominal)-              = text "NB:" <+> quotes (ppr tc1)-                <+> text "is a non-injective type family"-              | otherwise = empty--misMatchOrCND :: Bool -> ReportErrCtxt -> Ct-              -> TcType -> TcType -> Report--- If oriented then ty1 is actual, ty2 is expected-misMatchOrCND insoluble_occurs_check ctxt ct ty1 ty2-  | insoluble_occurs_check  -- See Note [Insoluble occurs check]-    || (isRigidTy ty1 && isRigidTy ty2)-    || isGivenCt ct-    || null givens-  = -- If the equality is unconditionally insoluble-    -- or there is no context, don't report the context-    misMatchMsg ctxt ct ty1 ty2--  | otherwise-  = mconcat [ couldNotDeduce givens ([eq_pred], orig)-            , important $ mk_supplementary_ea_msg ctxt level ty1 ty2 orig ]-  where-    ev      = ctEvidence ct-    eq_pred = ctEvPred ev-    orig    = ctEvOrigin ev-    level   = ctLocTypeOrKind_maybe (ctEvLoc ev) `orElse` TypeLevel-    givens  = [ given | given <- getUserGivens ctxt, ic_given_eqs given /= NoGivenEqs ]-              -- Keep only UserGivens that have some equalities.-              -- See Note [Suppress redundant givens during error reporting]--couldNotDeduce :: [UserGiven] -> (ThetaType, CtOrigin) -> Report-couldNotDeduce givens (wanteds, orig)-  = important $-    vcat [ addArising orig (text "Could not deduce:" <+> pprTheta wanteds)-         , vcat (pp_givens givens)]--pp_givens :: [UserGiven] -> [SDoc]-pp_givens givens-   = case givens of-         []     -> []-         (g:gs) ->      ppr_given (text "from the context:") g-                 : map (ppr_given (text "or from:")) gs-    where-       ppr_given herald implic@(Implic { ic_given = gs, ic_info = skol_info })-           = hang (herald <+> pprEvVarTheta (mkMinimalBySCs evVarPred gs))-             -- See Note [Suppress redundant givens during error reporting]-             -- for why we use mkMinimalBySCs above.-                2 (sep [ text "bound by" <+> ppr skol_info-                       , text "at" <+> ppr (tcl_loc (ic_env implic)) ])---- These are for the "blocked" equalities, as described in TcCanonical--- Note [Equalities with incompatible kinds], wrinkle (2). There should--- always be another unsolved wanted around, which will ordinarily suppress--- this message. But this can still be printed out with -fdefer-type-errors--- (sigh), so we must produce a message.-mkBlockedEqErr :: ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DecoratedSDoc)-mkBlockedEqErr ctxt (ct:_) = mkErrorMsgFromCt ctxt ct report-  where-    report = important msg-    msg = vcat [ hang (text "Cannot use equality for substitution:")-                   2 (ppr (ctPred ct))-               , text "Doing so would be ill-kinded." ]-          -- This is a terrible message. Perhaps worse, if the user-          -- has -fprint-explicit-kinds on, they will see that the two-          -- sides have the same kind, as there is an invisible cast.-          -- I really don't know how to do better.-mkBlockedEqErr _ [] = panic "mkBlockedEqErr no constraints"--{--Note [Suppress redundant givens during error reporting]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When GHC is unable to solve a constraint and prints out an error message, it-will print out what given constraints are in scope to provide some context to-the programmer. But we shouldn't print out /every/ given, since some of them-are not terribly helpful to diagnose type errors. Consider this example:--  foo :: Int :~: Int -> a :~: b -> a :~: c-  foo Refl Refl = Refl--When reporting that GHC can't solve (a ~ c), there are two givens in scope:-(Int ~ Int) and (a ~ b). But (Int ~ Int) is trivially soluble (i.e.,-redundant), so it's not terribly useful to report it in an error message.-To accomplish this, we discard any Implications that do not bind any-equalities by filtering the `givens` selected in `misMatchOrCND` (based on-the `ic_given_eqs` field of the Implication). Note that we discard givens-that have no equalities whatsoever, but we want to keep ones with only *local*-equalities, as these may be helpful to the user in understanding what went-wrong.--But this is not enough to avoid all redundant givens! Consider this example,-from #15361:--  goo :: forall (a :: Type) (b :: Type) (c :: Type).-         a :~~: b -> a :~~: c-  goo HRefl = HRefl--Matching on HRefl brings the /single/ given (* ~ *, a ~ b) into scope.-The (* ~ *) part arises due the kinds of (:~~:) being unified. More-importantly, (* ~ *) is redundant, so we'd like not to report it. However,-the Implication (* ~ *, a ~ b) /does/ bind an equality (as reported by its-ic_given_eqs field), so the test above will keep it wholesale.--To refine this given, we apply mkMinimalBySCs on it to extract just the (a ~ b)-part. This works because mkMinimalBySCs eliminates reflexive equalities in-addition to superclasses (see Note [Remove redundant provided dicts]-in GHC.Tc.TyCl.PatSyn).--}--extraTyVarEqInfo :: ReportErrCtxt -> TcTyVar -> TcType -> Report--- Add on extra info about skolem constants--- NB: The types themselves are already tidied-extraTyVarEqInfo ctxt tv1 ty2-  = important (extraTyVarInfo ctxt tv1 $$ ty_extra ty2)-  where-    ty_extra ty = case tcGetCastedTyVar_maybe ty of-                    Just (tv, _) -> extraTyVarInfo ctxt tv-                    Nothing      -> empty--extraTyVarInfo :: ReportErrCtxt -> TcTyVar -> SDoc-extraTyVarInfo ctxt tv-  = ASSERT2( isTyVar tv, ppr tv )-    case tcTyVarDetails tv of-          SkolemTv {}   -> pprSkols ctxt [tv]-          RuntimeUnk {} -> quotes (ppr tv) <+> text "is an interactive-debugger skolem"-          MetaTv {}     -> empty--suggestAddSig :: ReportErrCtxt -> TcType -> TcType -> Report--- See Note [Suggest adding a type signature]-suggestAddSig ctxt ty1 _ty2-  | null inferred_bndrs   -- No let-bound inferred binders in context-  = mempty-  | [bndr] <- inferred_bndrs-  = important $ text "Possible fix: add a type signature for" <+> quotes (ppr bndr)-  | otherwise-  = important $ text "Possible fix: add type signatures for some or all of" <+> (ppr inferred_bndrs)-  where-    inferred_bndrs = case tcGetTyVar_maybe ty1 of-                       Just tv | isSkolemTyVar tv -> find (cec_encl ctxt) False tv-                       _                          -> []--    -- 'find' returns the binders of an InferSkol for 'tv',-    -- provided there is an intervening implication with-    -- ic_given_eqs /= NoGivenEqs (i.e. a GADT match)-    find [] _ _ = []-    find (implic:implics) seen_eqs tv-       | tv `elem` ic_skols implic-       , InferSkol prs <- ic_info implic-       , seen_eqs-       = map fst prs-       | otherwise-       = find implics (seen_eqs || ic_given_eqs implic /= NoGivenEqs) tv-----------------------misMatchMsg :: ReportErrCtxt -> Ct -> TcType -> TcType -> Report--- Types are already tidy--- If oriented then ty1 is actual, ty2 is expected-misMatchMsg ctxt ct ty1 ty2-  = important $-    addArising orig $-    pprWithExplicitKindsWhenMismatch ty1 ty2 orig $-    sep [ case orig of-            TypeEqOrigin {} -> tk_eq_msg ctxt ct ty1 ty2 orig-            KindEqOrigin {} -> tk_eq_msg ctxt ct ty1 ty2 orig-            _ -> headline_eq_msg False ct ty1 ty2-        , sameOccExtra ty2 ty1 ]-  where-    orig = ctOrigin ct--headline_eq_msg :: Bool -> Ct -> Type -> Type -> SDoc--- Generates the main "Could't match 't1' against 't2'--- headline message-headline_eq_msg add_ea ct ty1 ty2--  | (isLiftedRuntimeRep ty1 && isUnliftedRuntimeRep ty2) ||-    (isLiftedRuntimeRep ty2 && isUnliftedRuntimeRep ty1) ||-    (isLiftedLevity ty1 && isUnliftedLevity ty2) ||-    (isLiftedLevity ty2 && isUnliftedLevity ty1)-  = text "Couldn't match a lifted type with an unlifted type"--  | isAtomicTy ty1 || isAtomicTy ty2-  = -- Print with quotes-    sep [ text herald1 <+> quotes (ppr ty1)-        , nest padding $-          text herald2 <+> quotes (ppr ty2) ]--  | otherwise-  = -- Print with vertical layout-    vcat [ text herald1 <> colon <+> ppr ty1-         , nest padding $-           text herald2 <> colon <+> ppr ty2 ]-  where-    herald1 = conc [ "Couldn't match"-                   , if is_repr then "representation of" else ""-                   , if add_ea then "expected"          else ""-                   , what ]-    herald2 = conc [ "with"-                   , if is_repr then "that of"          else ""-                   , if add_ea then ("actual " ++ what) else "" ]--    padding = length herald1 - length herald2--    is_repr = case ctEqRel ct of { ReprEq -> True; NomEq -> False }--    what = levelString (ctLocTypeOrKind_maybe (ctLoc ct) `orElse` TypeLevel)--    conc :: [String] -> String-    conc = foldr1 add_space--    add_space :: String -> String -> String-    add_space s1 s2 | null s1   = s2-                    | null s2   = s1-                    | otherwise = s1 ++ (' ' : s2)---tk_eq_msg :: ReportErrCtxt-          -> Ct -> Type -> Type -> CtOrigin -> SDoc-tk_eq_msg ctxt ct ty1 ty2 orig@(TypeEqOrigin { uo_actual = act-                                             , uo_expected = exp-                                             , uo_thing = mb_thing })-  -- We can use the TypeEqOrigin to-  -- improve the error message quite a lot--  | isUnliftedTypeKind act, isLiftedTypeKind exp-  = sep [ text "Expecting a lifted type, but"-        , thing_msg mb_thing (text "an") (text "unlifted") ]--  | isLiftedTypeKind act, isUnliftedTypeKind exp-  = sep [ text "Expecting an unlifted type, but"-        , thing_msg mb_thing (text "a") (text "lifted") ]--  | tcIsLiftedTypeKind exp-  = maybe_num_args_msg $$-    sep [ text "Expected a type, but"-        , case mb_thing of-            Nothing    -> text "found something with kind"-            Just thing -> quotes thing <+> text "has kind"-        , quotes (pprWithTYPE act) ]--  | Just nargs_msg <- num_args_msg-  = nargs_msg $$-    mk_ea_msg ctxt (Just ct) level orig--  | -- pprTrace "check" (ppr ea_looks_same $$ ppr exp $$ ppr act $$ ppr ty1 $$ ppr ty2) $-    ea_looks_same ty1 ty2 exp act-  = mk_ea_msg ctxt (Just ct) level orig--  | otherwise  -- The mismatched types are /inside/ exp and act-  = vcat [ headline_eq_msg False ct ty1 ty2-         , mk_ea_msg ctxt Nothing level orig ]--  where-    ct_loc = ctLoc ct-    level  = ctLocTypeOrKind_maybe ct_loc `orElse` TypeLevel--    thing_msg (Just thing) _  levity = quotes thing <+> text "is" <+> levity-    thing_msg Nothing      an levity = text "got" <+> an <+> levity <+> text "type"--    num_args_msg = case level of-      KindLevel-        | not (isMetaTyVarTy exp) && not (isMetaTyVarTy act)-           -- if one is a meta-tyvar, then it's possible that the user-           -- has asked for something impredicative, and we couldn't unify.-           -- Don't bother with counting arguments.-        -> let n_act = count_args act-               n_exp = count_args exp in-           case n_act - n_exp of-             n | n > 0   -- we don't know how many args there are, so don't-                         -- recommend removing args that aren't-               , Just thing <- mb_thing-               -> Just $ text "Expecting" <+> speakN (abs n) <+>-                         more <+> quotes thing-               where-                 more-                  | n == 1    = text "more argument to"-                  | otherwise = text "more arguments to"  -- n > 1-             _ -> Nothing--      _ -> Nothing--    maybe_num_args_msg = num_args_msg `orElse` empty--    count_args ty = count isVisibleBinder $ fst $ splitPiTys ty--tk_eq_msg ctxt ct ty1 ty2-          (KindEqOrigin cty1 cty2 sub_o mb_sub_t_or_k)-  = vcat [ headline_eq_msg False ct ty1 ty2-         , supplementary_msg ]-  where-    sub_t_or_k = mb_sub_t_or_k `orElse` TypeLevel-    sub_whats  = text (levelString sub_t_or_k) <> char 's'-                 -- "types" or "kinds"--    supplementary_msg-      = sdocOption sdocPrintExplicitCoercions $ \printExplicitCoercions ->-        if printExplicitCoercions-           || not (cty1 `pickyEqType` cty2)-          then vcat [ hang (text "When matching" <+> sub_whats)-                          2 (vcat [ ppr cty1 <+> dcolon <+>-                                   ppr (tcTypeKind cty1)-                                 , ppr cty2 <+> dcolon <+>-                                   ppr (tcTypeKind cty2) ])-                    , mk_supplementary_ea_msg ctxt sub_t_or_k cty1 cty2 sub_o ]-          else text "When matching the kind of" <+> quotes (ppr cty1)--tk_eq_msg _ _ _ _ _ = panic "typeeq_mismatch_msg"--ea_looks_same :: Type -> Type -> Type -> Type -> Bool--- True if the faulting types (ty1, ty2) look the same as--- the expected/actual types (exp, act).--- If so, we don't want to redundantly report the latter-ea_looks_same ty1 ty2 exp act-  = (act `looks_same` ty1 && exp `looks_same` ty2) ||-    (exp `looks_same` ty1 && act `looks_same` ty2)-  where-    looks_same t1 t2 = t1 `pickyEqType` t2-                    || t1 `eqType` liftedTypeKind && t2 `eqType` liftedTypeKind-      -- pickyEqType is sensitive to synonyms, so only replies True-      -- when the types really look the same.  However,-      -- (TYPE 'LiftedRep) and Type both print the same way.--mk_supplementary_ea_msg :: ReportErrCtxt -> TypeOrKind-                        -> Type -> Type -> CtOrigin -> SDoc-mk_supplementary_ea_msg ctxt level ty1 ty2 orig-  | TypeEqOrigin { uo_expected = exp, uo_actual = act } <- orig-  , not (ea_looks_same ty1 ty2 exp act)-  = mk_ea_msg ctxt Nothing level orig-  | otherwise-  = empty--mk_ea_msg :: ReportErrCtxt -> Maybe Ct -> TypeOrKind -> CtOrigin -> SDoc--- Constructs a "Couldn't match" message--- The (Maybe Ct) says whether this is the main top-level message (Just)---     or a supplementary message (Nothing)-mk_ea_msg ctxt at_top level-          (TypeEqOrigin { uo_actual = act, uo_expected = exp, uo_thing = mb_thing })-  | Just thing <- mb_thing-  , KindLevel <- level-  = hang (text "Expected" <+> kind_desc <> comma)-       2 (text "but" <+> quotes thing <+> text "has kind" <+>-          quotes (ppr act))--  | otherwise-  = vcat [ case at_top of-              Just ct -> headline_eq_msg True ct exp act-              Nothing -> supplementary_ea_msg-         , ppWhen expand_syns expandedTys ]--  where-    supplementary_ea_msg = vcat [ text "Expected:" <+> ppr exp-                                , text "  Actual:" <+> ppr act ]--    kind_desc | tcIsConstraintKind exp = text "a constraint"-              | Just arg <- kindRep_maybe exp  -- TYPE t0-              , tcIsTyVarTy arg = sdocOption sdocPrintExplicitRuntimeReps $ \case-                                   True  -> text "kind" <+> quotes (ppr exp)-                                   False -> text "a type"-              | otherwise       = text "kind" <+> quotes (ppr exp)--    expand_syns = cec_expand_syns ctxt--    expandedTys = ppUnless (expTy1 `pickyEqType` exp && expTy2 `pickyEqType` act) $ vcat-                  [ text "Type synonyms expanded:"-                  , text "Expected type:" <+> ppr expTy1-                  , text "  Actual type:" <+> ppr expTy2 ]--    (expTy1, expTy2) = expandSynonymsToMatch exp act--mk_ea_msg _ _ _ _ = empty---- | Prints explicit kinds (with @-fprint-explicit-kinds@) in an 'SDoc' when a--- type mismatch occurs to due invisible kind arguments.------ This function first checks to see if the 'CtOrigin' argument is a--- 'TypeEqOrigin', and if so, uses the expected/actual types from that to--- check for a kind mismatch (as these types typically have more surrounding--- types and are likelier to be able to glean information about whether a--- mismatch occurred in an invisible argument position or not). If the--- 'CtOrigin' is not a 'TypeEqOrigin', fall back on the actual mismatched types--- themselves.-pprWithExplicitKindsWhenMismatch :: Type -> Type -> CtOrigin-                                 -> SDoc -> SDoc-pprWithExplicitKindsWhenMismatch ty1 ty2 ct-  = pprWithExplicitKindsWhen show_kinds-  where-    (act_ty, exp_ty) = case ct of-      TypeEqOrigin { uo_actual = act-                   , uo_expected = exp } -> (act, exp)-      _                                  -> (ty1, ty2)-    show_kinds = tcEqTypeVis act_ty exp_ty-                 -- True when the visible bit of the types look the same,-                 -- so we want to show the kinds in the displayed type--{- Note [Insoluble occurs check]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider [G] a ~ [a],  [W] a ~ [a] (#13674).  The Given is insoluble-so we don't use it for rewriting.  The Wanted is also insoluble, and-we don't solve it from the Given.  It's very confusing to say-    Cannot solve a ~ [a] from given constraints a ~ [a]--And indeed even thinking about the Givens is silly; [W] a ~ [a] is-just as insoluble as Int ~ Bool.--Conclusion: if there's an insoluble occurs check (cteInsolubleOccurs)-then report it directly, not in the "cannot deduce X from Y" form.-This is done in misMatchOrCND (via the insoluble_occurs_check arg)--(NB: there are potentially-soluble ones, like (a ~ F a b), and we don't-want to be as draconian with them.)--Note [Expanding type synonyms to make types similar]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--In type error messages, if -fprint-expanded-types is used, we want to expand-type synonyms to make expected and found types as similar as possible, but we-shouldn't expand types too much to make type messages even more verbose and-harder to understand. The whole point here is to make the difference in expected-and found types clearer.--`expandSynonymsToMatch` does this, it takes two types, and expands type synonyms-only as much as necessary. Given two types t1 and t2:--  * If they're already same, it just returns the types.--  * If they're in form `C1 t1_1 .. t1_n` and `C2 t2_1 .. t2_m` (C1 and C2 are-    type constructors), it expands C1 and C2 if they're different type synonyms.-    Then it recursively does the same thing on expanded types. If C1 and C2 are-    same, then it applies the same procedure to arguments of C1 and arguments of-    C2 to make them as similar as possible.--    Most important thing here is to keep number of synonym expansions at-    minimum. For example, if t1 is `T (T3, T5, Int)` and t2 is `T (T5, T3,-    Bool)` where T5 = T4, T4 = T3, ..., T1 = X, it returns `T (T3, T3, Int)` and-    `T (T3, T3, Bool)`.--  * Otherwise types don't have same shapes and so the difference is clearly-    visible. It doesn't do any expansions and show these types.--Note that we only expand top-layer type synonyms. Only when top-layer-constructors are the same we start expanding inner type synonyms.--Suppose top-layer type synonyms of t1 and t2 can expand N and M times,-respectively. If their type-synonym-expanded forms will meet at some point (i.e.-will have same shapes according to `sameShapes` function), it's possible to find-where they meet in O(N+M) top-layer type synonym expansions and O(min(N,M))-comparisons. We first collect all the top-layer expansions of t1 and t2 in two-lists, then drop the prefix of the longer list so that they have same lengths.-Then we search through both lists in parallel, and return the first pair of-types that have same shapes. Inner types of these two types with same shapes-are then expanded using the same algorithm.--In case they don't meet, we return the last pair of types in the lists, which-has top-layer type synonyms completely expanded. (in this case the inner types-are not expanded at all, as the current form already shows the type error)--}---- | Expand type synonyms in given types only enough to make them as similar as--- possible. Returned types are the same in terms of used type synonyms.------ To expand all synonyms, see 'Type.expandTypeSynonyms'.------ See `ExpandSynsFail` tests in tests testsuite/tests/typecheck/should_fail for--- some examples of how this should work.-expandSynonymsToMatch :: Type -> Type -> (Type, Type)-expandSynonymsToMatch ty1 ty2 = (ty1_ret, ty2_ret)-  where-    (ty1_ret, ty2_ret) = go ty1 ty2--    -- | Returns (type synonym expanded version of first type,-    --            type synonym expanded version of second type)-    go :: Type -> Type -> (Type, Type)-    go t1 t2-      | t1 `pickyEqType` t2 =-        -- Types are same, nothing to do-        (t1, t2)--    go (TyConApp tc1 tys1) (TyConApp tc2 tys2)-      | tc1 == tc2-      , tys1 `equalLength` tys2 =-        -- Type constructors are same. They may be synonyms, but we don't-        -- expand further. The lengths of tys1 and tys2 must be equal;-        -- for example, with type S a = a, we don't want-        -- to zip (S Monad Int) and (S Bool).-        let (tys1', tys2') =-              unzip (zipWithEqual "expandSynonymsToMatch" go tys1 tys2)-         in (TyConApp tc1 tys1', TyConApp tc2 tys2')--    go (AppTy t1_1 t1_2) (AppTy t2_1 t2_2) =-      let (t1_1', t2_1') = go t1_1 t2_1-          (t1_2', t2_2') = go t1_2 t2_2-       in (mkAppTy t1_1' t1_2', mkAppTy t2_1' t2_2')--    go ty1@(FunTy _ w1 t1_1 t1_2) ty2@(FunTy _ w2 t2_1 t2_2) | w1 `eqType` w2 =-      let (t1_1', t2_1') = go t1_1 t2_1-          (t1_2', t2_2') = go t1_2 t2_2-       in ( ty1 { ft_arg = t1_1', ft_res = t1_2' }-          , ty2 { ft_arg = t2_1', ft_res = t2_2' })--    go (ForAllTy b1 t1) (ForAllTy b2 t2) =-      -- NOTE: We may have a bug here, but we just can't reproduce it easily.-      -- See D1016 comments for details and our attempts at producing a test-      -- case. Short version: We probably need RnEnv2 to really get this right.-      let (t1', t2') = go t1 t2-       in (ForAllTy b1 t1', ForAllTy b2 t2')--    go (CastTy ty1 _) ty2 = go ty1 ty2-    go ty1 (CastTy ty2 _) = go ty1 ty2--    go t1 t2 =-      -- See Note [Expanding type synonyms to make types similar] for how this-      -- works-      let-        t1_exp_tys = t1 : tyExpansions t1-        t2_exp_tys = t2 : tyExpansions t2-        t1_exps    = length t1_exp_tys-        t2_exps    = length t2_exp_tys-        dif        = abs (t1_exps - t2_exps)-      in-        followExpansions $-          zipEqual "expandSynonymsToMatch.go"-            (if t1_exps > t2_exps then drop dif t1_exp_tys else t1_exp_tys)-            (if t2_exps > t1_exps then drop dif t2_exp_tys else t2_exp_tys)--    -- | Expand the top layer type synonyms repeatedly, collect expansions in a-    -- list. The list does not include the original type.-    ---    -- Example, if you have:-    ---    --   type T10 = T9-    --   type T9  = T8-    --   ...-    --   type T0  = Int-    ---    -- `tyExpansions T10` returns [T9, T8, T7, ... Int]-    ---    -- This only expands the top layer, so if you have:-    ---    --   type M a = Maybe a-    ---    -- `tyExpansions (M T10)` returns [Maybe T10] (T10 is not expanded)-    tyExpansions :: Type -> [Type]-    tyExpansions = unfoldr (\t -> (\x -> (x, x)) `fmap` tcView t)--    -- | Drop the type pairs until types in a pair look alike (i.e. the outer-    -- constructors are the same).-    followExpansions :: [(Type, Type)] -> (Type, Type)-    followExpansions [] = pprPanic "followExpansions" empty-    followExpansions [(t1, t2)]-      | sameShapes t1 t2 = go t1 t2 -- expand subtrees-      | otherwise        = (t1, t2) -- the difference is already visible-    followExpansions ((t1, t2) : tss)-      -- Traverse subtrees when the outer shapes are the same-      | sameShapes t1 t2 = go t1 t2-      -- Otherwise follow the expansions until they look alike-      | otherwise = followExpansions tss--    sameShapes :: Type -> Type -> Bool-    sameShapes AppTy{}          AppTy{}          = True-    sameShapes (TyConApp tc1 _) (TyConApp tc2 _) = tc1 == tc2-    sameShapes (FunTy {})       (FunTy {})       = True-    sameShapes (ForAllTy {})    (ForAllTy {})    = True-    sameShapes (CastTy ty1 _)   ty2              = sameShapes ty1 ty2-    sameShapes ty1              (CastTy ty2 _)   = sameShapes ty1 ty2-    sameShapes _                _                = False--sameOccExtra :: TcType -> TcType -> SDoc--- See Note [Disambiguating (X ~ X) errors]-sameOccExtra ty1 ty2-  | Just (tc1, _) <- tcSplitTyConApp_maybe ty1-  , Just (tc2, _) <- tcSplitTyConApp_maybe ty2-  , let n1 = tyConName tc1-        n2 = tyConName tc2-        same_occ = nameOccName n1                   == nameOccName n2-        same_pkg = moduleUnit (nameModule n1) == moduleUnit (nameModule n2)-  , n1 /= n2   -- Different Names-  , same_occ   -- but same OccName-  = text "NB:" <+> (ppr_from same_pkg n1 $$ ppr_from same_pkg n2)-  | otherwise-  = empty-  where-    ppr_from same_pkg nm-      | isGoodSrcSpan loc-      = hang (quotes (ppr nm) <+> text "is defined at")-           2 (ppr loc)-      | otherwise  -- Imported things have an UnhelpfulSrcSpan-      = hang (quotes (ppr nm))-           2 (sep [ text "is defined in" <+> quotes (ppr (moduleName mod))-                  , ppUnless (same_pkg || pkg == mainUnit) $-                    nest 4 $ text "in package" <+> quotes (ppr pkg) ])-       where-         pkg = moduleUnit mod-         mod = nameModule nm-         loc = nameSrcSpan nm--{- Note [Suggest adding a type signature]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The OutsideIn algorithm rejects GADT programs that don't have a principal-type, and indeed some that do.  Example:-   data T a where-     MkT :: Int -> T Int--   f (MkT n) = n--Does this have type f :: T a -> a, or f :: T a -> Int?-The error that shows up tends to be an attempt to unify an-untouchable type variable.  So suggestAddSig sees if the offending-type variable is bound by an *inferred* signature, and suggests-adding a declared signature instead.--More specifically, we suggest adding a type sig if we have p ~ ty, and-p is a skolem bound by an InferSkol.  Those skolems were created from-unification variables in simplifyInfer.  Why didn't we unify?  It must-have been because of an intervening GADT or existential, making it-untouchable. Either way, a type signature would help.  For GADTs, it-might make it typeable; for existentials the attempt to write a-signature will fail -- or at least will produce a better error message-next time--This initially came up in #8968, concerning pattern synonyms.--Note [Disambiguating (X ~ X) errors]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-See #8278--Note [Reporting occurs-check errors]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Given (a ~ [a]), if 'a' is a rigid type variable bound by a user-supplied-type signature, then the best thing is to report that we can't unify-a with [a], because a is a skolem variable.  That avoids the confusing-"occur-check" error message.--But nowadays when inferring the type of a function with no type signature,-even if there are errors inside, we still generalise its signature and-carry on. For example-   f x = x:x-Here we will infer something like-   f :: forall a. a -> [a]-with a deferred error of (a ~ [a]).  So in the deferred unsolved constraint-'a' is now a skolem, but not one bound by the programmer in the context!-Here we really should report an occurs check.--So isUserSkolem distinguishes the two.--Note [Non-injective type functions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-It's very confusing to get a message like-     Couldn't match expected type `Depend s'-            against inferred type `Depend s1'-so mkTyFunInfoMsg adds:-       NB: `Depend' is type function, and hence may not be injective--Warn of loopy local equalities that were dropped.---************************************************************************-*                                                                      *-                 Type-class errors-*                                                                      *-************************************************************************--}--mkDictErr :: ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DecoratedSDoc)-mkDictErr ctxt cts-  = ASSERT( not (null cts) )-    do { inst_envs <- tcGetInstEnvs-       ; let (ct1:_) = cts  -- ct1 just for its location-             min_cts = elim_superclasses cts-             lookups = map (lookup_cls_inst inst_envs) min_cts-             (no_inst_cts, overlap_cts) = partition is_no_inst lookups--       -- Report definite no-instance errors,-       -- or (iff there are none) overlap errors-       -- But we report only one of them (hence 'head') because they all-       -- have the same source-location origin, to try avoid a cascade-       -- of error from one location-       ; (ctxt, err) <- mk_dict_err ctxt (head (no_inst_cts ++ overlap_cts))-       ; mkErrorMsgFromCt ctxt ct1 (important err) }-  where-    no_givens = null (getUserGivens ctxt)--    is_no_inst (ct, (matches, unifiers, _))-      =  no_givens-      && null matches-      && (null unifiers || all (not . isAmbiguousTyVar) (tyCoVarsOfCtList ct))--    lookup_cls_inst inst_envs ct-                -- Note [Flattening in error message generation]-      = (ct, lookupInstEnv True inst_envs clas (flattenTys emptyInScopeSet tys))-      where-        (clas, tys) = getClassPredTys (ctPred ct)---    -- When simplifying [W] Ord (Set a), we need-    --    [W] Eq a, [W] Ord a-    -- but we really only want to report the latter-    elim_superclasses cts = mkMinimalBySCs ctPred cts---- [Note: mk_dict_err]--- ~~~~~~~~~~~~~~~~~~~--- Different dictionary error messages are reported depending on the number of--- matches and unifiers:------   - No matches, regardless of unifiers: report "No instance for ...".---   - Two or more matches, regardless of unifiers: report "Overlapping instances for ...",---     and show the matching and unifying instances.---   - One match, one or more unifiers: report "Overlapping instances for", show the---     matching and unifying instances, and say "The choice depends on the instantion of ...,---     and the result of evaluating ...".-mk_dict_err :: ReportErrCtxt -> (Ct, ClsInstLookupResult)-            -> TcM (ReportErrCtxt, SDoc)--- Report an overlap error if this class constraint results--- from an overlap (returning Left clas), otherwise return (Right pred)-mk_dict_err ctxt@(CEC {cec_encl = implics}) (ct, (matches, unifiers, unsafe_overlapped))-  | null matches  -- No matches but perhaps several unifiers-  = do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct-       ; candidate_insts <- get_candidate_instances-       ; return (ctxt, cannot_resolve_msg ct candidate_insts binds_msg) }--  | null unsafe_overlapped   -- Some matches => overlap errors-  = return (ctxt, overlap_msg)--  | otherwise-  = return (ctxt, safe_haskell_msg)-  where-    orig          = ctOrigin ct-    pred          = ctPred ct-    (clas, tys)   = getClassPredTys pred-    ispecs        = [ispec | (ispec, _) <- matches]-    unsafe_ispecs = [ispec | (ispec, _) <- unsafe_overlapped]-    useful_givens = discardProvCtxtGivens orig (getUserGivensFromImplics implics)-         -- useful_givens are the enclosing implications with non-empty givens,-         -- modulo the horrid discardProvCtxtGivens--    get_candidate_instances :: TcM [ClsInst]-    -- See Note [Report candidate instances]-    get_candidate_instances-      | [ty] <- tys   -- Only try for single-parameter classes-      = do { instEnvs <- tcGetInstEnvs-           ; return (filter (is_candidate_inst ty)-                            (classInstances instEnvs clas)) }-      | otherwise = return []--    is_candidate_inst ty inst -- See Note [Report candidate instances]-      | [other_ty] <- is_tys inst-      , Just (tc1, _) <- tcSplitTyConApp_maybe ty-      , Just (tc2, _) <- tcSplitTyConApp_maybe other_ty-      = let n1 = tyConName tc1-            n2 = tyConName tc2-            different_names = n1 /= n2-            same_occ_names = nameOccName n1 == nameOccName n2-        in different_names && same_occ_names-      | otherwise = False--    cannot_resolve_msg :: Ct -> [ClsInst] -> SDoc -> SDoc-    cannot_resolve_msg ct candidate_insts binds_msg-      = vcat [ no_inst_msg-             , nest 2 extra_note-             , vcat (pp_givens useful_givens)-             , mb_patsyn_prov `orElse` empty-             , ppWhen (has_ambig_tvs && not (null unifiers && null useful_givens))-               (vcat [ ppUnless lead_with_ambig ambig_msg, binds_msg, potential_msg ])--             , ppWhen (isNothing mb_patsyn_prov) $-                   -- Don't suggest fixes for the provided context of a pattern-                   -- synonym; the right fix is to bind more in the pattern-               show_fixes (ctxtFixes has_ambig_tvs pred implics-                           ++ drv_fixes)-             , ppWhen (not (null candidate_insts))-               (hang (text "There are instances for similar types:")-                   2 (vcat (map ppr candidate_insts))) ]-                   -- See Note [Report candidate instances]-      where-        orig = ctOrigin ct-        -- See Note [Highlighting ambiguous type variables]-        lead_with_ambig = has_ambig_tvs && not (any isRuntimeUnkSkol ambig_tvs)-                        && not (null unifiers) && null useful_givens--        (has_ambig_tvs, ambig_msg) = mkAmbigMsg lead_with_ambig ct-        ambig_tvs = uncurry (++) (getAmbigTkvs ct)--        no_inst_msg-          | lead_with_ambig-          = ambig_msg <+> pprArising orig-              $$ text "prevents the constraint" <+>  quotes (pprParendType pred)-              <+> text "from being solved."--          | null useful_givens-          = addArising orig $ text "No instance for"-            <+> pprParendType pred--          | otherwise-          = addArising orig $ text "Could not deduce"-            <+> pprParendType pred--        potential_msg-          = ppWhen (not (null unifiers) && want_potential orig) $-            sdocOption sdocPrintPotentialInstances $ \print_insts ->-            getPprStyle $ \sty ->-            pprPotentials (PrintPotentialInstances print_insts) sty potential_hdr unifiers--        potential_hdr-          = vcat [ ppWhen lead_with_ambig $-                     text "Probable fix: use a type annotation to specify what"-                     <+> pprQuotedList ambig_tvs <+> text "should be."-                 , text "These potential instance" <> plural unifiers-                   <+> text "exist:"]--        mb_patsyn_prov :: Maybe SDoc-        mb_patsyn_prov-          | not lead_with_ambig-          , ProvCtxtOrigin PSB{ psb_def = L _ pat } <- orig-          = Just (vcat [ text "In other words, a successful match on the pattern"-                       , nest 2 $ ppr pat-                       , text "does not provide the constraint" <+> pprParendType pred ])-          | otherwise = Nothing--    -- Report "potential instances" only when the constraint arises-    -- directly from the user's use of an overloaded function-    want_potential (TypeEqOrigin {}) = False-    want_potential _                 = True--    extra_note | any isFunTy (filterOutInvisibleTypes (classTyCon clas) tys)-               = text "(maybe you haven't applied a function to enough arguments?)"-               | className clas == typeableClassName  -- Avoid mysterious "No instance for (Typeable T)-               , [_,ty] <- tys                        -- Look for (Typeable (k->*) (T k))-               , Just (tc,_) <- tcSplitTyConApp_maybe ty-               , not (isTypeFamilyTyCon tc)-               = hang (text "GHC can't yet do polykinded")-                    2 (text "Typeable" <+>-                       parens (ppr ty <+> dcolon <+> ppr (tcTypeKind ty)))-               | otherwise-               = empty--    drv_fixes = case orig of-                   DerivClauseOrigin                  -> [drv_fix False]-                   StandAloneDerivOrigin              -> [drv_fix True]-                   DerivOriginDC _ _       standalone -> [drv_fix standalone]-                   DerivOriginCoerce _ _ _ standalone -> [drv_fix standalone]-                   _                -> []--    drv_fix standalone_wildcard-      | standalone_wildcard-      = text "fill in the wildcard constraint yourself"-      | otherwise-      = hang (text "use a standalone 'deriving instance' declaration,")-           2 (text "so you can specify the instance context yourself")--    -- Normal overlap error-    overlap_msg-      = ASSERT( not (null matches) )-        vcat [  addArising orig (text "Overlapping instances for"-                                <+> pprType (mkClassPred clas tys))--             ,  ppUnless (null matching_givens) $-                  sep [text "Matching givens (or their superclasses):"-                      , nest 2 (vcat matching_givens)]--             ,  sdocOption sdocPrintPotentialInstances $ \print_insts ->-                getPprStyle $ \sty ->-                pprPotentials (PrintPotentialInstances print_insts) sty (text "Matching instances:") $-                ispecs ++ unifiers--             ,  ppWhen (null matching_givens && isSingleton matches && null unifiers) $-                -- Intuitively, some given matched the wanted in their-                -- flattened or rewritten (from given equalities) form-                -- but the matcher can't figure that out because the-                -- constraints are non-flat and non-rewritten so we-                -- simply report back the whole given-                -- context. Accelerate Smart.hs showed this problem.-                  sep [ text "There exists a (perhaps superclass) match:"-                      , nest 2 (vcat (pp_givens useful_givens))]--             ,  ppWhen (isSingleton matches) $-                parens (vcat [ ppUnless (null tyCoVars) $-                                 text "The choice depends on the instantiation of" <+>-                                   quotes (pprWithCommas ppr tyCoVars)-                             , ppUnless (null famTyCons) $-                                 if (null tyCoVars)-                                   then-                                     text "The choice depends on the result of evaluating" <+>-                                       quotes (pprWithCommas ppr famTyCons)-                                   else-                                     text "and the result of evaluating" <+>-                                       quotes (pprWithCommas ppr famTyCons)-                             , ppWhen (null (matching_givens)) $-                               vcat [ text "To pick the first instance above, use IncoherentInstances"-                                    , text "when compiling the other instance declarations"]-                        ])]-      where-        tyCoVars = tyCoVarsOfTypesList tys-        famTyCons = filter isFamilyTyCon $ concatMap (nonDetEltsUniqSet . tyConsOfType) tys--    matching_givens = mapMaybe matchable useful_givens--    matchable implic@(Implic { ic_given = evvars, ic_info = skol_info })-      = case ev_vars_matching of-             [] -> Nothing-             _  -> Just $ hang (pprTheta ev_vars_matching)-                            2 (sep [ text "bound by" <+> ppr skol_info-                                   , text "at" <+>-                                     ppr (tcl_loc (ic_env implic)) ])-        where ev_vars_matching = [ pred-                                 | ev_var <- evvars-                                 , let pred = evVarPred ev_var-                                 , any can_match (pred : transSuperClasses pred) ]-              can_match pred-                 = case getClassPredTys_maybe pred of-                     Just (clas', tys') -> clas' == clas-                                          && isJust (tcMatchTys tys tys')-                     Nothing -> False--    -- Overlap error because of Safe Haskell (first-    -- match should be the most specific match)-    safe_haskell_msg-     = ASSERT( matches `lengthIs` 1 && not (null unsafe_ispecs) )-       vcat [ addArising orig (text "Unsafe overlapping instances for"-                       <+> pprType (mkClassPred clas tys))-            , sep [text "The matching instance is:",-                   nest 2 (pprInstance $ head ispecs)]-            , vcat [ text "It is compiled in a Safe module and as such can only"-                   , text "overlap instances from the same module, however it"-                   , text "overlaps the following instances from different" <+>-                     text "modules:"-                   , nest 2 (vcat [pprInstances $ unsafe_ispecs])-                   ]-            ]---ctxtFixes :: Bool -> PredType -> [Implication] -> [SDoc]-ctxtFixes has_ambig_tvs pred implics-  | not has_ambig_tvs-  , isTyVarClassPred pred-  , (skol:skols) <- usefulContext implics pred-  , let what | null skols-             , SigSkol (PatSynCtxt {}) _ _ <- skol-             = text "\"required\""-             | otherwise-             = empty-  = [sep [ text "add" <+> pprParendType pred-           <+> text "to the" <+> what <+> text "context of"-         , nest 2 $ ppr_skol skol $$-                    vcat [ text "or" <+> ppr_skol skol-                         | skol <- skols ] ] ]-  | otherwise = []-  where-    ppr_skol (PatSkol (RealDataCon dc) _) = text "the data constructor" <+> quotes (ppr dc)-    ppr_skol (PatSkol (PatSynCon ps)   _) = text "the pattern synonym"  <+> quotes (ppr ps)-    ppr_skol skol_info = ppr skol_info--discardProvCtxtGivens :: CtOrigin -> [UserGiven] -> [UserGiven]-discardProvCtxtGivens orig givens  -- See Note [discardProvCtxtGivens]-  | ProvCtxtOrigin (PSB {psb_id = L _ name}) <- orig-  = filterOut (discard name) givens-  | otherwise-  = givens-  where-    discard n (Implic { ic_info = SigSkol (PatSynCtxt n') _ _ }) = n == n'-    discard _ _                                                  = False--usefulContext :: [Implication] -> PredType -> [SkolemInfo]--- usefulContext picks out the implications whose context--- the programmer might plausibly augment to solve 'pred'-usefulContext implics pred-  = go implics-  where-    pred_tvs = tyCoVarsOfType pred-    go [] = []-    go (ic : ics)-       | implausible ic = rest-       | otherwise      = ic_info ic : rest-       where-          -- Stop when the context binds a variable free in the predicate-          rest | any (`elemVarSet` pred_tvs) (ic_skols ic) = []-               | otherwise                                 = go ics--    implausible ic-      | null (ic_skols ic)            = True-      | implausible_info (ic_info ic) = True-      | otherwise                     = False--    implausible_info (SigSkol (InfSigCtxt {}) _ _) = True-    implausible_info _                             = False-    -- Do not suggest adding constraints to an *inferred* type signature--{- Note [Report candidate instances]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If we have an unsolved (Num Int), where `Int` is not the Prelude Int,-but comes from some other module, then it may be helpful to point out-that there are some similarly named instances elsewhere.  So we get-something like-    No instance for (Num Int) arising from the literal ‘3’-    There are instances for similar types:-      instance Num GHC.Types.Int -- Defined in ‘GHC.Num’-Discussion in #9611.--Note [Highlighting ambiguous type variables]-~--------------------------------------------When we encounter ambiguous type variables (i.e. type variables-that remain metavariables after type inference), we need a few more-conditions before we can reason that *ambiguity* prevents constraints-from being solved:-  - We can't have any givens, as encountering a typeclass error-    with given constraints just means we couldn't deduce-    a solution satisfying those constraints and as such couldn't-    bind the type variable to a known type.-  - If we don't have any unifiers, we don't even have potential-    instances from which an ambiguity could arise.-  - Lastly, I don't want to mess with error reporting for-    unknown runtime types so we just fall back to the old message there.-Once these conditions are satisfied, we can safely say that ambiguity prevents-the constraint from being solved.--Note [discardProvCtxtGivens]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-In most situations we call all enclosing implications "useful". There is one-exception, and that is when the constraint that causes the error is from the-"provided" context of a pattern synonym declaration:--  pattern Pat :: (Num a, Eq a) => Show a   => a -> Maybe a-             --  required      => provided => type-  pattern Pat x <- (Just x, 4)--When checking the pattern RHS we must check that it does actually bind all-the claimed "provided" constraints; in this case, does the pattern (Just x, 4)-bind the (Show a) constraint.  Answer: no!--But the implication we generate for this will look like-   forall a. (Num a, Eq a) => [W] Show a-because when checking the pattern we must make the required-constraints available, since they are needed to match the pattern (in-this case the literal '4' needs (Num a, Eq a)).--BUT we don't want to suggest adding (Show a) to the "required" constraints-of the pattern synonym, thus:-  pattern Pat :: (Num a, Eq a, Show a) => Show a => a -> Maybe a-It would then typecheck but it's silly.  We want the /pattern/ to bind-the alleged "provided" constraints, Show a.--So we suppress that Implication in discardProvCtxtGivens.  It's-painfully ad-hoc but the truth is that adding it to the "required"-constraints would work.  Suppressing it solves two problems.  First,-we never tell the user that we could not deduce a "provided"-constraint from the "required" context. Second, we never give a-possible fix that suggests to add a "provided" constraint to the-"required" context.--For example, without this distinction the above code gives a bad error-message (showing both problems):--  error: Could not deduce (Show a) ... from the context: (Eq a)-         ... Possible fix: add (Show a) to the context of-         the signature for pattern synonym `Pat' ...---}--show_fixes :: [SDoc] -> SDoc-show_fixes []     = empty-show_fixes (f:fs) = sep [ text "Possible fix:"-                        , nest 2 (vcat (f : map (text "or" <+>) fs))]----- Avoid boolean blindness-newtype PrintPotentialInstances = PrintPotentialInstances Bool--pprPotentials :: PrintPotentialInstances -> PprStyle -> SDoc -> [ClsInst] -> SDoc--- See Note [Displaying potential instances]-pprPotentials (PrintPotentialInstances show_potentials) sty herald insts-  | null insts-  = empty--  | null show_these-  = hang herald-       2 (vcat [ not_in_scope_msg empty-               , flag_hint ])--  | otherwise-  = hang herald-       2 (vcat [ pprInstances show_these-               , ppWhen (n_in_scope_hidden > 0) $-                 text "...plus"-                   <+> speakNOf n_in_scope_hidden (text "other")-               , not_in_scope_msg (text "...plus")-               , flag_hint ])-  where-    n_show = 3 :: Int--    (in_scope, not_in_scope) = partition inst_in_scope insts-    sorted = sortBy fuzzyClsInstCmp in_scope-    show_these | show_potentials = sorted-               | otherwise       = take n_show sorted-    n_in_scope_hidden = length sorted - length show_these--       -- "in scope" means that all the type constructors-       -- are lexically in scope; these instances are likely-       -- to be more useful-    inst_in_scope :: ClsInst -> Bool-    inst_in_scope cls_inst = nameSetAll name_in_scope $-                             orphNamesOfTypes (is_tys cls_inst)--    name_in_scope name-      | isBuiltInSyntax name-      = True -- E.g. (->)-      | Just mod <- nameModule_maybe name-      = qual_in_scope (qualName sty mod (nameOccName name))-      | otherwise-      = True--    qual_in_scope :: QualifyName -> Bool-    qual_in_scope NameUnqual    = True-    qual_in_scope (NameQual {}) = True-    qual_in_scope _             = False--    not_in_scope_msg herald-      | null not_in_scope-      = empty-      | otherwise-      = hang (herald <+> speakNOf (length not_in_scope) (text "instance")-                     <+> text "involving out-of-scope types")-           2 (ppWhen show_potentials (pprInstances not_in_scope))--    flag_hint = ppUnless (show_potentials || equalLength show_these insts) $-                text "(use -fprint-potential-instances to see them all)"--{- Note [Displaying potential instances]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When showing a list of instances for-  - overlapping instances (show ones that match)-  - no such instance (show ones that could match)-we want to give it a bit of structure.  Here's the plan--* Say that an instance is "in scope" if all of the-  type constructors it mentions are lexically in scope.-  These are the ones most likely to be useful to the programmer.--* Show at most n_show in-scope instances,-  and summarise the rest ("plus 3 others")--* Summarise the not-in-scope instances ("plus 4 not in scope")--* Add the flag -fshow-potential-instances which replaces the-  summary with the full list--}--{--Note [Flattening in error message generation]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider (C (Maybe (F x))), where F is a type function, and we have-instances-                C (Maybe Int) and C (Maybe a)-Since (F x) might turn into Int, this is an overlap situation, and-indeed the main solver will have refrained-from solving.  But by the time we get to error message generation, we've-un-flattened the constraint.  So we must *re*-flatten it before looking-up in the instance environment, lest we only report one matching-instance when in fact there are two.--Note [Kind arguments in error messages]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-It can be terribly confusing to get an error message like (#9171)--    Couldn't match expected type ‘GetParam Base (GetParam Base Int)’-                with actual type ‘GetParam Base (GetParam Base Int)’--The reason may be that the kinds don't match up.  Typically you'll get-more useful information, but not when it's as a result of ambiguity.--To mitigate this, GHC attempts to enable the -fprint-explicit-kinds flag-whenever any error message arises due to a kind mismatch. This means that-the above error message would instead be displayed as:--    Couldn't match expected type-                  ‘GetParam @* @k2 @* Base (GetParam @* @* @k2 Base Int)’-                with actual type-                  ‘GetParam @* @k20 @* Base (GetParam @* @* @k20 Base Int)’--Which makes it clearer that the culprit is the mismatch between `k2` and `k20`.--}--mkAmbigMsg :: Bool -- True when message has to be at beginning of sentence-           -> Ct -> (Bool, SDoc)-mkAmbigMsg prepend_msg ct-  | null ambig_kvs && null ambig_tvs = (False, empty)-  | otherwise                        = (True,  msg)-  where-    (ambig_kvs, ambig_tvs) = getAmbigTkvs ct--    msg |  any isRuntimeUnkSkol ambig_kvs  -- See Note [Runtime skolems]-        || any isRuntimeUnkSkol ambig_tvs-        = vcat [ text "Cannot resolve unknown runtime type"-                 <> plural ambig_tvs <+> pprQuotedList ambig_tvs-               , text "Use :print or :force to determine these types"]--        | not (null ambig_tvs)-        = pp_ambig (text "type") ambig_tvs--        | otherwise-        = pp_ambig (text "kind") ambig_kvs--    pp_ambig what tkvs-      | prepend_msg -- "Ambiguous type variable 't0'"-      = text "Ambiguous" <+> what <+> text "variable"-        <> plural tkvs <+> pprQuotedList tkvs--      | otherwise -- "The type variable 't0' is ambiguous"-      = text "The" <+> what <+> text "variable" <> plural tkvs-        <+> pprQuotedList tkvs <+> isOrAre tkvs <+> text "ambiguous"--pprSkols :: ReportErrCtxt -> [TcTyVar] -> SDoc-pprSkols ctxt tvs-  = vcat (map pp_one (getSkolemInfo (cec_encl ctxt) tvs))-  where-    pp_one (UnkSkol, tvs)-      = hang (pprQuotedList tvs)-           2 (is_or_are tvs "an" "unknown")-    pp_one (RuntimeUnkSkol, tvs)-      = hang (pprQuotedList tvs)-           2 (is_or_are tvs "an" "unknown runtime")-    pp_one (skol_info, tvs)-      = vcat [ hang (pprQuotedList tvs)-                  2 (is_or_are tvs "a"  "rigid" <+> text "bound by")-             , nest 2 (pprSkolInfo skol_info)-             , nest 2 (text "at" <+> ppr (foldr1 combineSrcSpans (map getSrcSpan tvs))) ]--    is_or_are [_] article adjective = text "is" <+> text article <+> text adjective-                                      <+> text "type variable"-    is_or_are _   _       adjective = text "are" <+> text adjective-                                      <+> text "type variables"--getAmbigTkvs :: Ct -> ([Var],[Var])-getAmbigTkvs ct-  = partition (`elemVarSet` dep_tkv_set) ambig_tkvs-  where-    tkvs       = tyCoVarsOfCtList ct-    ambig_tkvs = filter isAmbiguousTyVar tkvs-    dep_tkv_set = tyCoVarsOfTypes (map tyVarKind tkvs)--getSkolemInfo :: [Implication] -> [TcTyVar]-              -> [(SkolemInfo, [TcTyVar])]                    -- #14628--- Get the skolem info for some type variables--- from the implication constraints that bind them.------ In the returned (skolem, tvs) pairs, the 'tvs' part is non-empty-getSkolemInfo _ []-  = []--getSkolemInfo [] tvs-  | all isRuntimeUnkSkol tvs = [(RuntimeUnkSkol, tvs)]        -- #14628-  | otherwise = pprPanic "No skolem info:" (ppr tvs)--getSkolemInfo (implic:implics) tvs-  | null tvs_here =                            getSkolemInfo implics tvs-  | otherwise   = (ic_info implic, tvs_here) : getSkolemInfo implics tvs_other-  where-    (tvs_here, tvs_other) = partition (`elem` ic_skols implic) tvs---------------------------- relevantBindings looks at the value environment and finds values whose--- types mention any of the offending type variables.  It has to be--- careful to zonk the Id's type first, so it has to be in the monad.--- We must be careful to pass it a zonked type variable, too.------ We always remove closed top-level bindings, though,--- since they are never relevant (cf #8233)--relevantBindings :: Bool  -- True <=> filter by tyvar; False <=> no filtering-                          -- See #8191-                 -> ReportErrCtxt -> Ct-                 -> TcM (ReportErrCtxt, SDoc, Ct)--- Also returns the zonked and tidied CtOrigin of the constraint-relevantBindings want_filtering ctxt ct-  = do { traceTc "relevantBindings" (ppr ct)-       ; (env1, tidy_orig) <- zonkTidyOrigin (cec_tidy ctxt) (ctLocOrigin loc)--             -- For *kind* errors, report the relevant bindings of the-             -- enclosing *type* equality, because that's more useful for the programmer-       ; let extra_tvs = case tidy_orig of-                             KindEqOrigin t1 t2 _ _ -> tyCoVarsOfTypes [t1,t2]-                             _                        -> emptyVarSet-             ct_fvs = tyCoVarsOfCt ct `unionVarSet` extra_tvs--             -- Put a zonked, tidied CtOrigin into the Ct-             loc'   = setCtLocOrigin loc tidy_orig-             ct'    = setCtLoc ct loc'--       ; (env2, lcl_name_cache) <- zonkTidyTcLclEnvs env1 [lcl_env]--       ; doc <- relevant_bindings want_filtering lcl_env lcl_name_cache ct_fvs-       ; let ctxt'  = ctxt { cec_tidy = env2 }-       ; return (ctxt', doc, ct') }-  where-    loc     = ctLoc ct-    lcl_env = ctLocEnv loc---- slightly more general version, to work also with holes-relevant_bindings :: Bool-                  -> TcLclEnv-                  -> NameEnv Type -- Cache of already zonked and tidied types-                  -> TyCoVarSet-                  -> TcM SDoc-relevant_bindings want_filtering lcl_env lcl_name_env ct_tvs-  = do { dflags <- getDynFlags-       ; traceTc "relevant_bindings" $-           vcat [ ppr ct_tvs-                , pprWithCommas id [ ppr id <+> dcolon <+> ppr (idType id)-                                   | TcIdBndr id _ <- tcl_bndrs lcl_env ]-                , pprWithCommas id-                    [ ppr id | TcIdBndr_ExpType id _ _ <- tcl_bndrs lcl_env ] ]--       ; (docs, discards)-              <- go dflags (maxRelevantBinds dflags)-                    emptyVarSet [] False-                    (removeBindingShadowing $ tcl_bndrs lcl_env)-         -- tcl_bndrs has the innermost bindings first,-         -- which are probably the most relevant ones--       ; let doc = ppUnless (null docs) $-                   hang (text "Relevant bindings include")-                      2 (vcat docs $$ ppWhen discards discardMsg)--       ; return doc }-  where-    run_out :: Maybe Int -> Bool-    run_out Nothing = False-    run_out (Just n) = n <= 0--    dec_max :: Maybe Int -> Maybe Int-    dec_max = fmap (\n -> n - 1)---    go :: DynFlags -> Maybe Int -> TcTyVarSet -> [SDoc]-       -> Bool                          -- True <=> some filtered out due to lack of fuel-       -> [TcBinder]-       -> TcM ([SDoc], Bool)   -- The bool says if we filtered any out-                                        -- because of lack of fuel-    go _ _ _ docs discards []-      = return (reverse docs, discards)-    go dflags n_left tvs_seen docs discards (tc_bndr : tc_bndrs)-      = case tc_bndr of-          TcTvBndr {} -> discard_it-          TcIdBndr id top_lvl -> go2 (idName id) top_lvl-          TcIdBndr_ExpType name et top_lvl ->-            do { mb_ty <- readExpType_maybe et-                   -- et really should be filled in by now. But there's a chance-                   -- it hasn't, if, say, we're reporting a kind error en route to-                   -- checking a term. See test indexed-types/should_fail/T8129-                   -- Or we are reporting errors from the ambiguity check on-                   -- a local type signature-               ; case mb_ty of-                   Just _ty -> go2 name top_lvl-                   Nothing -> discard_it  -- No info; discard-               }-      where-        discard_it = go dflags n_left tvs_seen docs-                        discards tc_bndrs-        go2 id_name top_lvl-          = do { let tidy_ty = case lookupNameEnv lcl_name_env id_name of-                                  Just tty -> tty-                                  Nothing -> pprPanic "relevant_bindings" (ppr id_name)-               ; traceTc "relevantBindings 1" (ppr id_name <+> dcolon <+> ppr tidy_ty)-               ; let id_tvs = tyCoVarsOfType tidy_ty-                     doc = sep [ pprPrefixOcc id_name <+> dcolon <+> ppr tidy_ty-                               , nest 2 (parens (text "bound at"-                                    <+> ppr (getSrcLoc id_name)))]-                     new_seen = tvs_seen `unionVarSet` id_tvs--               ; if (want_filtering && not (hasPprDebug dflags)-                                    && id_tvs `disjointVarSet` ct_tvs)-                          -- We want to filter out this binding anyway-                          -- so discard it silently-                 then discard_it--                 else if isTopLevel top_lvl && not (isNothing n_left)-                          -- It's a top-level binding and we have not specified-                          -- -fno-max-relevant-bindings, so discard it silently-                 then discard_it--                 else if run_out n_left && id_tvs `subVarSet` tvs_seen-                          -- We've run out of n_left fuel and this binding only-                          -- mentions already-seen type variables, so discard it-                 then go dflags n_left tvs_seen docs-                         True      -- Record that we have now discarded something-                         tc_bndrs--                          -- Keep this binding, decrement fuel-                 else go dflags (dec_max n_left) new_seen-                         (doc:docs) discards tc_bndrs }---discardMsg :: SDoc-discardMsg = text "(Some bindings suppressed;" <+>-             text "use -fmax-relevant-binds=N or -fno-max-relevant-binds)"--------------------------warnDefaulting :: [Ct] -> Type -> TcM ()-warnDefaulting wanteds default_ty-  = do { warn_default <- woptM Opt_WarnTypeDefaults-       ; env0 <- tcInitTidyEnv-       ; let tidy_env = tidyFreeTyCoVars env0 $-                        tyCoVarsOfCtsList (listToBag wanteds)-             tidy_wanteds = map (tidyCt tidy_env) wanteds-             (loc, ppr_wanteds) = pprWithArising tidy_wanteds-             warn_msg =-                hang (hsep [ text "Defaulting the following"-                           , text "constraint" <> plural tidy_wanteds-                           , text "to type"-                           , quotes (ppr default_ty) ])-                     2-                     ppr_wanteds-       ; setCtLocM loc $ warnTc (Reason Opt_WarnTypeDefaults) warn_default warn_msg }--{--Note [Runtime skolems]-~~~~~~~~~~~~~~~~~~~~~~-We want to give a reasonably helpful error message for ambiguity-arising from *runtime* skolems in the debugger.  These-are created by in GHC.Runtime.Heap.Inspect.zonkRTTIType.--************************************************************************-*                                                                      *-                 Error from the canonicaliser-         These ones are called *during* constraint simplification-*                                                                      *-************************************************************************--}--solverDepthErrorTcS :: CtLoc -> TcType -> TcM a-solverDepthErrorTcS loc ty-  = setCtLocM loc $-    do { ty <- zonkTcType ty-       ; env0 <- tcInitTidyEnv-       ; let tidy_env     = tidyFreeTyCoVars env0 (tyCoVarsOfTypeList ty)-             tidy_ty      = tidyType tidy_env ty-             msg-               = vcat [ text "Reduction stack overflow; size =" <+> ppr depth-                      , hang (text "When simplifying the following type:")-                           2 (ppr tidy_ty)-                      , note ]-       ; failWithTcM (tidy_env, msg) }-  where-    depth = ctLocDepth loc-    note = vcat-      [ text "Use -freduction-depth=0 to disable this check"-      , text "(any upper bound you could choose might fail unpredictably with"-      , text " minor updates to GHC, so disabling the check is recommended if"-      , text " you're sure that type checking should terminate)" ]++{-# LANGUAGE LambdaCase          #-}+{-# LANGUAGE NamedFieldPuns      #-}+{-# LANGUAGE ScopedTypeVariables #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}+{-# LANGUAGE ParallelListComp #-}++module GHC.Tc.Errors(+       reportUnsolved, reportAllUnsolved, warnAllUnsolved,+       warnDefaulting,++       -- * GHC API helper functions+       solverReportMsg_ExpectedActuals,+       solverReportInfo_ExpectedActuals+  ) where++import GHC.Prelude++import GHC.Driver.Env (hsc_units)+import GHC.Driver.Session+import GHC.Driver.Ppr+import GHC.Driver.Config.Diagnostic++import GHC.Rename.Unbound++import GHC.Tc.Types+import GHC.Tc.Utils.Monad+import GHC.Tc.Errors.Types+import GHC.Tc.Errors.Ppr+import GHC.Tc.Types.Constraint+import GHC.Tc.Utils.TcMType+import GHC.Tc.Utils.Env( tcInitTidyEnv )+import GHC.Tc.Utils.TcType+import GHC.Tc.Utils.Unify ( checkTyVarEq )+import GHC.Tc.Types.Origin+import GHC.Tc.Types.Evidence+import GHC.Tc.Types.EvTerm+import GHC.Tc.Instance.Family+import GHC.Tc.Utils.Instantiate+import {-# SOURCE #-} GHC.Tc.Errors.Hole ( findValidHoleFits, getHoleFitDispConfig, pprHoleFit )++import GHC.Types.Name+import GHC.Types.Name.Reader ( lookupGRE_Name, GlobalRdrEnv, mkRdrUnqual+                             , emptyLocalRdrEnv, lookupGlobalRdrEnv , lookupLocalRdrOcc )+import GHC.Types.Id+import GHC.Types.Var+import GHC.Types.Var.Set+import GHC.Types.Var.Env+import GHC.Types.Name.Env+import GHC.Types.SrcLoc+import GHC.Types.Basic+import GHC.Types.Error+import qualified GHC.Types.Unique.Map as UM++--import GHC.Rename.Unbound ( unknownNameSuggestions, WhatLooking(..) )+import GHC.Unit.Module+import qualified GHC.LanguageExtensions as LangExt++import GHC.Core.Predicate+import GHC.Core.Type+import GHC.Core.Coercion+import GHC.Core.TyCo.Ppr  ( pprTyVars+                           )+import GHC.Core.InstEnv+import GHC.Core.TyCon+import GHC.Core.DataCon++import GHC.Utils.Error  (diagReasonSeverity,  pprLocMsgEnvelope )+import GHC.Utils.Misc+import GHC.Utils.Outputable as O+import GHC.Utils.Panic+import GHC.Utils.Panic.Plain+import GHC.Utils.FV ( fvVarList, unionFV )++import GHC.Data.Bag+import GHC.Data.List.SetOps ( equivClasses, nubOrdBy )+import GHC.Data.Maybe+import qualified GHC.Data.Strict as Strict++import Control.Monad    ( unless, when, foldM, forM_ )+import Data.Foldable    ( toList )+import Data.Function    ( on )+import Data.List        ( partition, sort, sortBy )+import Data.List.NonEmpty ( NonEmpty(..), (<|) )+import qualified Data.List.NonEmpty as NE ( map, reverse )+import Data.Ord         ( comparing )+import qualified Data.Semigroup as S++{-+************************************************************************+*                                                                      *+\section{Errors and contexts}+*                                                                      *+************************************************************************++ToDo: for these error messages, should we note the location as coming+from the insts, or just whatever seems to be around in the monad just+now?++Note [Deferring coercion errors to runtime]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+While developing, sometimes it is desirable to allow compilation to succeed even+if there are type errors in the code. Consider the following case:++  module Main where++  a :: Int+  a = 'a'++  main = print "b"++Even though `a` is ill-typed, it is not used in the end, so if all that we're+interested in is `main` it is handy to be able to ignore the problems in `a`.++Since we treat type equalities as evidence, this is relatively simple. Whenever+we run into a type mismatch in GHC.Tc.Utils.Unify, we normally just emit an error. But it+is always safe to defer the mismatch to the main constraint solver. If we do+that, `a` will get transformed into++  co :: Int ~ Char+  co = ...++  a :: Int+  a = 'a' `cast` co++The constraint solver would realize that `co` is an insoluble constraint, and+emit an error with `reportUnsolved`. But we can also replace the right-hand side+of `co` with `error "Deferred type error: Int ~ Char"`. This allows the program+to compile, and it will run fine unless we evaluate `a`. This is what+`deferErrorsToRuntime` does.++It does this by keeping track of which errors correspond to which coercion+in GHC.Tc.Errors. GHC.Tc.Errors.reportTidyWanteds does not print the errors+and does not fail if -fdefer-type-errors is on, so that we can continue+compilation. The errors are turned into warnings in `reportUnsolved`.+-}++-- | Report unsolved goals as errors or warnings. We may also turn some into+-- deferred run-time errors if `-fdefer-type-errors` is on.+reportUnsolved :: WantedConstraints -> TcM (Bag EvBind)+reportUnsolved wanted+  = do { binds_var <- newTcEvBinds+       ; defer_errors <- goptM Opt_DeferTypeErrors+       ; let type_errors | not defer_errors = ErrorWithoutFlag+                         | otherwise        = WarningWithFlag Opt_WarnDeferredTypeErrors++       ; defer_holes <- goptM Opt_DeferTypedHoles+       ; let expr_holes | not defer_holes = ErrorWithoutFlag+                        | otherwise       = WarningWithFlag Opt_WarnTypedHoles++       ; partial_sigs      <- xoptM LangExt.PartialTypeSignatures+       ; let type_holes | not partial_sigs+                        = ErrorWithoutFlag+                        | otherwise+                        = WarningWithFlag Opt_WarnPartialTypeSignatures++       ; defer_out_of_scope <- goptM Opt_DeferOutOfScopeVariables+       ; let out_of_scope_holes | not defer_out_of_scope+                                = ErrorWithoutFlag+                                | otherwise+                                = WarningWithFlag Opt_WarnDeferredOutOfScopeVariables++       ; report_unsolved type_errors expr_holes+                         type_holes out_of_scope_holes+                         binds_var wanted++       ; ev_binds <- getTcEvBindsMap binds_var+       ; return (evBindMapBinds ev_binds)}++-- | Report *all* unsolved goals as errors, even if -fdefer-type-errors is on+-- However, do not make any evidence bindings, because we don't+-- have any convenient place to put them.+-- NB: Type-level holes are OK, because there are no bindings.+-- See Note [Deferring coercion errors to runtime]+-- Used by solveEqualities for kind equalities+--      (see Note [Fail fast on kind errors] in "GHC.Tc.Solver")+reportAllUnsolved :: WantedConstraints -> TcM ()+reportAllUnsolved wanted+  = do { ev_binds <- newNoTcEvBinds++       ; partial_sigs      <- xoptM LangExt.PartialTypeSignatures+       ; let type_holes | not partial_sigs  = ErrorWithoutFlag+                        | otherwise         = WarningWithFlag Opt_WarnPartialTypeSignatures++       ; report_unsolved ErrorWithoutFlag+                         ErrorWithoutFlag type_holes ErrorWithoutFlag+                         ev_binds wanted }++-- | Report all unsolved goals as warnings (but without deferring any errors to+-- run-time). See Note [Safe Haskell Overlapping Instances Implementation] in+-- "GHC.Tc.Solver"+warnAllUnsolved :: WantedConstraints -> TcM ()+warnAllUnsolved wanted+  = do { ev_binds <- newTcEvBinds+       ; report_unsolved WarningWithoutFlag+                         WarningWithoutFlag+                         WarningWithoutFlag+                         WarningWithoutFlag+                         ev_binds wanted }++-- | Report unsolved goals as errors or warnings.+report_unsolved :: DiagnosticReason -- Deferred type errors+                -> DiagnosticReason -- Expression holes+                -> DiagnosticReason -- Type holes+                -> DiagnosticReason -- Out of scope holes+                -> EvBindsVar        -- cec_binds+                -> WantedConstraints -> TcM ()+report_unsolved type_errors expr_holes+    type_holes out_of_scope_holes binds_var wanted+  | isEmptyWC wanted+  = return ()+  | otherwise+  = do { traceTc "reportUnsolved {" $+         vcat [ text "type errors:" <+> ppr type_errors+              , text "expr holes:" <+> ppr expr_holes+              , text "type holes:" <+> ppr type_holes+              , text "scope holes:" <+> ppr out_of_scope_holes ]+       ; traceTc "reportUnsolved (before zonking and tidying)" (ppr wanted)++       ; wanted <- zonkWC wanted   -- Zonk to reveal all information++       ; let tidy_env = tidyFreeTyCoVars emptyTidyEnv free_tvs+             free_tvs = filterOut isCoVar $+                        tyCoVarsOfWCList wanted+                        -- tyCoVarsOfWC returns free coercion *holes*, even though+                        -- they are "bound" by other wanted constraints. They in+                        -- turn may mention variables bound further in, which makes+                        -- no sense. Really we should not return those holes at all;+                        -- for now we just filter them out.++       ; traceTc "reportUnsolved (after zonking):" $+         vcat [ text "Free tyvars:" <+> pprTyVars free_tvs+              , text "Tidy env:" <+> ppr tidy_env+              , text "Wanted:" <+> ppr wanted ]++       ; warn_redundant <- woptM Opt_WarnRedundantConstraints+       ; exp_syns <- goptM Opt_PrintExpandedSynonyms+       ; let err_ctxt = CEC { cec_encl  = []+                            , cec_tidy  = tidy_env+                            , cec_defer_type_errors = type_errors+                            , cec_expr_holes = expr_holes+                            , cec_type_holes = type_holes+                            , cec_out_of_scope_holes = out_of_scope_holes+                            , cec_suppress = insolubleWC wanted+                                 -- See Note [Suppressing error messages]+                                 -- Suppress low-priority errors if there+                                 -- are insoluble errors anywhere;+                                 -- See #15539 and c.f. setting ic_status+                                 -- in GHC.Tc.Solver.setImplicationStatus+                            , cec_warn_redundant = warn_redundant+                            , cec_expand_syns = exp_syns+                            , cec_binds    = binds_var }++       ; tc_lvl <- getTcLevel+       ; reportWanteds err_ctxt tc_lvl wanted+       ; traceTc "reportUnsolved }" empty }++--------------------------------------------+--      Internal functions+--------------------------------------------++-- | Make a report from a single 'TcSolverReportMsg'.+important :: SolverReportErrCtxt -> TcSolverReportMsg -> SolverReport+important ctxt doc = mempty { sr_important_msgs = [SolverReportWithCtxt ctxt doc] }++mk_relevant_bindings :: RelevantBindings -> SolverReport+mk_relevant_bindings binds = mempty { sr_supplementary = [SupplementaryBindings binds] }++mk_report_hints :: [GhcHint] -> SolverReport+mk_report_hints hints = mempty { sr_hints = hints }++-- | Returns True <=> the SolverReportErrCtxt indicates that something is deferred+deferringAnyBindings :: SolverReportErrCtxt -> Bool+  -- Don't check cec_type_holes, as these don't cause bindings to be deferred+deferringAnyBindings (CEC { cec_defer_type_errors  = ErrorWithoutFlag+                          , cec_expr_holes         = ErrorWithoutFlag+                          , cec_out_of_scope_holes = ErrorWithoutFlag }) = False+deferringAnyBindings _                                                   = True++maybeSwitchOffDefer :: EvBindsVar -> SolverReportErrCtxt -> SolverReportErrCtxt+-- Switch off defer-type-errors inside CoEvBindsVar+-- See Note [Failing equalities with no evidence bindings]+maybeSwitchOffDefer evb ctxt+ | CoEvBindsVar{} <- evb+ = ctxt { cec_defer_type_errors  = ErrorWithoutFlag+        , cec_expr_holes         = ErrorWithoutFlag+        , cec_out_of_scope_holes = ErrorWithoutFlag }+ | otherwise+ = ctxt++{- Note [Failing equalities with no evidence bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we go inside an implication that has no term evidence+(e.g. unifying under a forall), we can't defer type errors.  You could+imagine using the /enclosing/ bindings (in cec_binds), but that may+not have enough stuff in scope for the bindings to be well typed.  So+we just switch off deferred type errors altogether.  See #14605.++This is done by maybeSwitchOffDefer.  It's also useful in one other+place: see Note [Wrapping failing kind equalities] in GHC.Tc.Solver.++Note [Suppressing error messages]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The cec_suppress flag says "don't report any errors".  Instead, just create+evidence bindings (as usual).  It's used when more important errors have occurred.++Specifically (see reportWanteds)+  * If there are insoluble Givens, then we are in unreachable code and all bets+    are off.  So don't report any further errors.+  * If there are any insolubles (eg Int~Bool), here or in a nested implication,+    then suppress errors from the simple constraints here.  Sometimes the+    simple-constraint errors are a knock-on effect of the insolubles.++This suppression behaviour is controlled by the Bool flag in+ReportErrorSpec, as used in reportWanteds.++But we need to take care: flags can turn errors into warnings, and we+don't want those warnings to suppress subsequent errors (including+suppressing the essential addTcEvBind for them: #15152). So in+tryReporter we use askNoErrs to see if any error messages were+/actually/ produced; if not, we don't switch on suppression.++A consequence is that warnings never suppress warnings, so turning an+error into a warning may allow subsequent warnings to appear that were+previously suppressed.   (e.g. partial-sigs/should_fail/T14584)+-}++reportImplic :: SolverReportErrCtxt -> Implication -> TcM ()+reportImplic ctxt implic@(Implic { ic_skols  = tvs+                                 , ic_given  = given+                                 , ic_wanted = wanted, ic_binds = evb+                                 , ic_status = status, ic_info = info+                                 , ic_env    = tcl_env+                                 , ic_tclvl  = tc_lvl })+  | BracketSkol <- info+  , not insoluble+  = return ()        -- For Template Haskell brackets report only+                     -- definite errors. The whole thing will be re-checked+                     -- later when we plug it in, and meanwhile there may+                     -- certainly be un-satisfied constraints++  | otherwise+  = do { traceTc "reportImplic" $ vcat+           [ text "tidy env:"   <+> ppr (cec_tidy ctxt)+           , text "skols:     " <+> pprTyVars tvs+           , text "tidy skols:" <+> pprTyVars tvs' ]++       ; when bad_telescope $ reportBadTelescope ctxt tcl_env info tvs+               -- Do /not/ use the tidied tvs because then are in the+               -- wrong order, so tidying will rename things wrongly+       ; reportWanteds ctxt' tc_lvl wanted+       ; when (cec_warn_redundant ctxt) $+         warnRedundantConstraints ctxt' tcl_env info' dead_givens }+  where+    insoluble    = isInsolubleStatus status+    (env1, tvs') = tidyVarBndrs (cec_tidy ctxt) $+                   scopedSort tvs+        -- scopedSort: the ic_skols may not be in dependency order+        -- (see Note [Skolems in an implication] in GHC.Tc.Types.Constraint)+        -- but tidying goes wrong on out-of-order constraints;+        -- so we sort them here before tidying+    info'   = tidySkolemInfoAnon env1 info+    implic' = implic { ic_skols = tvs'+                     , ic_given = map (tidyEvVar env1) given+                     , ic_info  = info' }++    ctxt1 = maybeSwitchOffDefer evb ctxt+    ctxt' = ctxt1 { cec_tidy     = env1+                  , cec_encl     = implic' : cec_encl ctxt++                  , cec_suppress = insoluble || cec_suppress ctxt+                        -- Suppress inessential errors if there+                        -- are insolubles anywhere in the+                        -- tree rooted here, or we've come across+                        -- a suppress-worthy constraint higher up (#11541)++                  , cec_binds    = evb }++    dead_givens = case status of+                    IC_Solved { ics_dead = dead } -> dead+                    _                             -> []++    bad_telescope = case status of+              IC_BadTelescope -> True+              _               -> False++warnRedundantConstraints :: SolverReportErrCtxt -> TcLclEnv -> SkolemInfoAnon -> [EvVar] -> TcM ()+-- See Note [Tracking redundant constraints] in GHC.Tc.Solver+warnRedundantConstraints ctxt env info ev_vars+ | null redundant_evs+ = return ()++ | SigSkol user_ctxt _ _ <- info+ -- When dealing with a user-written type signature,+ -- we want to add "In the type signature for f".+ = restoreLclEnv env $+   setSrcSpan (redundantConstraintsSpan user_ctxt) $+   report_redundant_msg True+                  --  ^^^^ add "In the type signature..."++ | otherwise+ -- But for InstSkol there already *is* a surrounding+ -- "In the instance declaration for Eq [a]" context+ -- and we don't want to say it twice. Seems a bit ad-hoc+ = restoreLclEnv env+ $ report_redundant_msg False+                 --   ^^^^^ don't add "In the type signature..."+ where+   report_redundant_msg :: Bool -- whether to add "In the type signature..." to the diagnostic+                        -> TcRn ()+   report_redundant_msg show_info+     = do { lcl_env <- getLclEnv+          ; msg <-+              mkErrorReport+                lcl_env+                (TcRnRedundantConstraints redundant_evs (info, show_info))+                (Just ctxt)+                []+          ; reportDiagnostic msg }++   redundant_evs =+       filterOut is_type_error $+       case info of -- See Note [Redundant constraints in instance decls]+         InstSkol -> filterOut (improving . idType) ev_vars+         _        -> ev_vars++   -- See #15232+   is_type_error = isJust . userTypeError_maybe . idType++   improving pred -- (transSuperClasses p) does not include p+     = any isImprovementPred (pred : transSuperClasses pred)++reportBadTelescope :: SolverReportErrCtxt -> TcLclEnv -> SkolemInfoAnon -> [TcTyVar] -> TcM ()+reportBadTelescope ctxt env (ForAllSkol telescope) skols+  = do { msg <- mkErrorReport+                  env+                  (TcRnSolverReport [report] ErrorWithoutFlag noHints)+                  (Just ctxt)+                  []+       ; reportDiagnostic msg }+  where+    report = SolverReportWithCtxt ctxt $ BadTelescope telescope skols++reportBadTelescope _ _ skol_info skols+  = pprPanic "reportBadTelescope" (ppr skol_info $$ ppr skols)++{- Note [Redundant constraints in instance decls]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For instance declarations, we don't report unused givens if+they can give rise to improvement.  Example (#10100):+    class Add a b ab | a b -> ab, a ab -> b+    instance Add Zero b b+    instance Add a b ab => Add (Succ a) b (Succ ab)+The context (Add a b ab) for the instance is clearly unused in terms+of evidence, since the dictionary has no fields.  But it is still+needed!  With the context, a wanted constraint+   Add (Succ Zero) beta (Succ Zero)+we will reduce to (Add Zero beta Zero), and thence we get beta := Zero.+But without the context we won't find beta := Zero.++This only matters in instance declarations..+-}++-- | Should we completely ignore this constraint in error reporting?+-- It *must* be the case that any constraint for which this returns True+-- somehow causes an error to be reported elsewhere.+-- See Note [Constraints to ignore].+ignoreConstraint :: Ct -> Bool+ignoreConstraint ct+  | AssocFamPatOrigin <- ctOrigin ct+  = True+  | otherwise+  = False++-- | Makes an error item from a constraint, calculating whether or not+-- the item should be suppressed. See Note [Wanteds rewrite Wanteds]+-- in GHC.Tc.Types.Constraint. Returns Nothing if we should just ignore+-- a constraint. See Note [Constraints to ignore].+mkErrorItem :: Ct -> TcM (Maybe ErrorItem)+mkErrorItem ct+  | ignoreConstraint ct+  = do { traceTc "Ignoring constraint:" (ppr ct)+       ; return Nothing }   -- See Note [Constraints to ignore]++  | otherwise+  = do { let loc = ctLoc ct+             flav = ctFlavour ct++       ; (suppress, m_evdest) <- case ctEvidence ct of+           CtGiven {} -> return (False, Nothing)+           CtWanted { ctev_rewriters = rewriters, ctev_dest = dest }+             -> do { supp <- anyUnfilledCoercionHoles rewriters+                   ; return (supp, Just dest) }++       ; let m_reason = case ct of CIrredCan { cc_reason = reason } -> Just reason+                                   _                                -> Nothing++       ; return $ Just $ EI { ei_pred     = ctPred ct+                            , ei_evdest   = m_evdest+                            , ei_flavour  = flav+                            , ei_loc      = loc+                            , ei_m_reason = m_reason+                            , ei_suppress = suppress }}++----------------------------------------------------------------+reportWanteds :: SolverReportErrCtxt -> TcLevel -> WantedConstraints -> TcM ()+reportWanteds ctxt tc_lvl wc@(WC { wc_simple = simples, wc_impl = implics+                                 , wc_errors = errs })+  | isEmptyWC wc = traceTc "reportWanteds empty WC" empty+  | otherwise+  = do { tidy_items <- mapMaybeM mkErrorItem tidy_cts+       ; traceTc "reportWanteds 1" (vcat [ text "Simples =" <+> ppr simples+                                         , text "Suppress =" <+> ppr (cec_suppress ctxt)+                                         , text "tidy_cts   =" <+> ppr tidy_cts+                                         , text "tidy_items =" <+> ppr tidy_items+                                         , text "tidy_errs =" <+> ppr tidy_errs ])++       -- This check makes sure that we aren't suppressing the only error that will+       -- actually stop compilation+       ; assertPprM+           ( do { errs_already <- ifErrsM (return True) (return False)+                ; return $+                    errs_already ||                  -- we already reported an error (perhaps from an outer implication)+                    null simples ||                  -- no errors to report here+                    any ignoreConstraint simples ||  -- one error is ignorable (is reported elsewhere)+                    not (all ei_suppress tidy_items) -- not all errors are suppressed+                } )+           (vcat [text "reportWanteds is suppressing all errors"])++         -- First, deal with any out-of-scope errors:+       ; let (out_of_scope, other_holes, not_conc_errs) = partition_errors tidy_errs+               -- don't suppress out-of-scope errors+             ctxt_for_scope_errs = ctxt { cec_suppress = False }+       ; (_, no_out_of_scope) <- askNoErrs $+                                 reportHoles tidy_items ctxt_for_scope_errs out_of_scope++         -- Next, deal with things that are utterly wrong+         -- Like Int ~ Bool (incl nullary TyCons)+         -- or  Int ~ t a   (AppTy on one side)+         -- These /ones/ are not suppressed by the incoming context+         -- (but will be by out-of-scope errors)+       ; let ctxt_for_insols = ctxt { cec_suppress = not no_out_of_scope }+       ; reportHoles tidy_items ctxt_for_insols other_holes+          -- holes never suppress++       ; reportNotConcreteErrs ctxt_for_insols not_conc_errs++          -- See Note [Suppressing confusing errors]+       ; let (suppressed_items, items0) = partition suppress tidy_items+       ; traceTc "reportWanteds suppressed:" (ppr suppressed_items)+       ; (ctxt1, items1) <- tryReporters ctxt_for_insols report1 items0++         -- Now all the other constraints.  We suppress errors here if+         -- any of the first batch failed, or if the enclosing context+         -- says to suppress+       ; let ctxt2 = ctxt1 { cec_suppress = cec_suppress ctxt || cec_suppress ctxt1 }+       ; (ctxt3, leftovers) <- tryReporters ctxt2 report2 items1+       ; massertPpr (null leftovers)+           (text "The following unsolved Wanted constraints \+                 \have not been reported to the user:"+           $$ ppr leftovers)++       ; mapBagM_ (reportImplic ctxt2) implics+            -- NB ctxt2: don't suppress inner insolubles if there's only a+            -- wanted insoluble here; but do suppress inner insolubles+            -- if there's a *given* insoluble here (= inaccessible code)++            -- Only now, if there are no errors, do we report suppressed ones+            -- See Note [Suppressing confusing errors]+            -- We don't need to update the context further because of the+            -- whenNoErrs guard+       ; whenNoErrs $+         do { (_, more_leftovers) <- tryReporters ctxt3 report3 suppressed_items+            ; massertPpr (null more_leftovers) (ppr more_leftovers) } }+ where+    env       = cec_tidy ctxt+    tidy_cts  = bagToList (mapBag (tidyCt env)   simples)+    tidy_errs = bagToList (mapBag (tidyDelayedError env) errs)++    partition_errors :: [DelayedError] -> ([Hole], [Hole], [NotConcreteError])+    partition_errors = go [] [] []+      where+        go out_of_scope other_holes syn_eqs []+          = (out_of_scope, other_holes, syn_eqs)+        go es1 es2 es3 (err:errs)+          | (es1, es2, es3) <- go es1 es2 es3 errs+          = case err of+              DE_Hole hole+                | isOutOfScopeHole hole+                -> (hole : es1, es2, es3)+                | otherwise+                -> (es1, hole : es2, es3)+              DE_NotConcrete err+                -> (es1, es2, err : es3)++      -- See Note [Suppressing confusing errors]+    suppress :: ErrorItem -> Bool+    suppress item+      | Wanted <- ei_flavour item+      = is_ww_fundep_item item+      | otherwise+      = False++    -- report1: ones that should *not* be suppressed by+    --          an insoluble somewhere else in the tree+    -- It's crucial that anything that is considered insoluble+    -- (see GHC.Tc.Utils.insolublWantedCt) is caught here, otherwise+    -- we might suppress its error message, and proceed on past+    -- type checking to get a Lint error later+    report1 = [ ("custom_error", is_user_type_error, True,  mkUserTypeErrorReporter)++              , given_eq_spec+              , ("insoluble2",      utterly_wrong,  True, mkGroupReporter mkEqErr)+              , ("skolem eq1",      very_wrong,     True, mkSkolReporter)+              , ("FixedRuntimeRep", is_FRR,         True, mkGroupReporter mkFRRErr)+              , ("skolem eq2",      skolem_eq,      True, mkSkolReporter)+              , ("non-tv eq",       non_tv_eq,      True, mkSkolReporter)++                  -- The only remaining equalities are alpha ~ ty,+                  -- where alpha is untouchable; and representational equalities+                  -- Prefer homogeneous equalities over hetero, because the+                  -- former might be holding up the latter.+                  -- See Note [Equalities with incompatible kinds] in GHC.Tc.Solver.Canonical+              , ("Homo eqs",      is_homo_equality,  True,  mkGroupReporter mkEqErr)+              , ("Other eqs",     is_equality,       True,  mkGroupReporter mkEqErr)+              ]++    -- report2: we suppress these if there are insolubles elsewhere in the tree+    report2 = [ ("Implicit params", is_ip,           False, mkGroupReporter mkIPErr)+              , ("Irreds",          is_irred,        False, mkGroupReporter mkIrredErr)+              , ("Dicts",           is_dict,         False, mkGroupReporter mkDictErr) ]++    -- report3: suppressed errors should be reported as categorized by either report1+    -- or report2. Keep this in sync with the suppress function above+    report3 = [ ("wanted/wanted fundeps", is_ww_fundep, True, mkGroupReporter mkEqErr)+              ]++    -- rigid_nom_eq, rigid_nom_tv_eq,+    is_dict, is_equality, is_ip, is_FRR, is_irred :: ErrorItem -> Pred -> Bool++    is_given_eq item pred+       | Given <- ei_flavour item+       , EqPred {} <- pred = True+       | otherwise         = False+       -- I think all given residuals are equalities++    -- Things like (Int ~N Bool)+    utterly_wrong _ (EqPred NomEq ty1 ty2) = isRigidTy ty1 && isRigidTy ty2+    utterly_wrong _ _                      = False++    -- Things like (a ~N Int)+    very_wrong _ (EqPred NomEq ty1 ty2) = isSkolemTy tc_lvl ty1 && isRigidTy ty2+    very_wrong _ _                      = False++    -- Representation-polymorphism errors, to be reported using mkFRRErr.+    is_FRR item _ = isJust $ fixedRuntimeRepOrigin_maybe item++    -- Things like (a ~N b) or (a  ~N  F Bool)+    skolem_eq _ (EqPred NomEq ty1 _) = isSkolemTy tc_lvl ty1+    skolem_eq _ _                    = False++    -- Things like (F a  ~N  Int)+    non_tv_eq _ (EqPred NomEq ty1 _) = not (isTyVarTy ty1)+    non_tv_eq _ _                    = False++    is_user_type_error item _ = isUserTypeError (errorItemPred item)++    is_homo_equality _ (EqPred _ ty1 ty2)+      = tcTypeKind ty1 `tcEqType` tcTypeKind ty2+    is_homo_equality _ _+      = False++    is_equality _(EqPred {}) = True+    is_equality _ _          = False++    is_dict _ (ClassPred {}) = True+    is_dict _ _              = False++    is_ip _ (ClassPred cls _) = isIPClass cls+    is_ip _ _                 = False++    is_irred _ (IrredPred {}) = True+    is_irred _ _              = False++     -- See situation (1) of Note [Suppressing confusing errors]+    is_ww_fundep item _ = is_ww_fundep_item item+    is_ww_fundep_item = isWantedWantedFunDepOrigin . errorItemOrigin++    given_eq_spec  -- See Note [Given errors]+      | has_gadt_match_here+      = ("insoluble1a", is_given_eq, True,  mkGivenErrorReporter)+      | otherwise+      = ("insoluble1b", is_given_eq, False, ignoreErrorReporter)+          -- False means don't suppress subsequent errors+          -- Reason: we don't report all given errors+          --         (see mkGivenErrorReporter), and we should only suppress+          --         subsequent errors if we actually report this one!+          --         #13446 is an example++    -- See Note [Given errors]+    has_gadt_match_here = has_gadt_match (cec_encl ctxt)+    has_gadt_match [] = False+    has_gadt_match (implic : implics)+      | PatSkol {} <- ic_info implic+      , ic_given_eqs implic /= NoGivenEqs+      , ic_warn_inaccessible implic+          -- Don't bother doing this if -Winaccessible-code isn't enabled.+          -- See Note [Avoid -Winaccessible-code when deriving] in GHC.Tc.TyCl.Instance.+      = True+      | otherwise+      = has_gadt_match implics++---------------+isSkolemTy :: TcLevel -> Type -> Bool+-- The type is a skolem tyvar+isSkolemTy tc_lvl ty+  | Just tv <- getTyVar_maybe ty+  =  isSkolemTyVar tv+  || (isTyVarTyVar tv && isTouchableMetaTyVar tc_lvl tv)+     -- The last case is for touchable TyVarTvs+     -- we postpone untouchables to a latter test (too obscure)++  | otherwise+  = False++isTyFun_maybe :: Type -> Maybe TyCon+isTyFun_maybe ty = case tcSplitTyConApp_maybe ty of+                      Just (tc,_) | isTypeFamilyTyCon tc -> Just tc+                      _ -> Nothing++{- Note [Suppressing confusing errors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Certain errors we might encounter are potentially confusing to users.+If there are any other errors to report, at all, we want to suppress these.++Which errors (only 1 case right now):++1) Errors which arise from the interaction of two Wanted fun-dep constraints.+   Example:++     class C a b | a -> b where+       op :: a -> b -> b++     foo _ = op True Nothing++     bar _ = op False []++   Here, we could infer+     foo :: C Bool (Maybe a) => p -> Maybe a+     bar :: C Bool [a]       => p -> [a]++   (The unused arguments suppress the monomorphism restriction.) The problem+   is that these types can't both be correct, as they violate the functional+   dependency. Yet reporting an error here is awkward: we must+   non-deterministically choose either foo or bar to reject. We thus want+   to report this problem only when there is nothing else to report.+   See typecheck/should_fail/T13506 for an example of when to suppress+   the error. The case above is actually accepted, because foo and bar+   are checked separately, and thus the two fundep constraints never+   encounter each other. It is test case typecheck/should_compile/FunDepOrigin1.++   This case applies only when both fundeps are *Wanted* fundeps; when+   both are givens, the error represents unreachable code. For+   a Given/Wanted case, see #9612.++Mechanism:++We use the `suppress` function within reportWanteds to filter out these two+cases, then report all other errors. Lastly, we return to these suppressed+ones and report them only if there have been no errors so far.++Note [Constraints to ignore]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Some constraints are meant only to aid the solver by unification; a failure+to solve them is not necessarily an error to report to the user. It is critical+that compilation is aborted elsewhere if there are any ignored constraints here;+they will remain unfilled, and might have been used to rewrite another constraint.++Currently, the constraints to ignore are:++1) Constraints generated in order to unify associated type instance parameters+   with class parameters. Here are two illustrative examples:++     class C (a :: k) where+       type F (b :: k)++     instance C True where+       type F a = Int++     instance C Left where+       type F (Left :: a -> Either a b) = Bool++   In the first instance, we want to infer that `a` has type Bool. So we emit+   a constraint unifying kappa (the guessed type of `a`) with Bool. All is well.++   In the second instance, we process the associated type instance only+   after fixing the quantified type variables of the class instance. We thus+   have skolems a1 and b1 such that the class instance is for (Left :: a1 -> Either a1 b1).+   Unifying a1 and b1 with a and b in the type instance will fail, but harmlessly so.+   checkConsistentFamInst checks for this, and will fail if anything has gone+   awry. Really the equality constraints emitted are just meant as an aid, not+   a requirement. This is test case T13972.++   We detect this case by looking for an origin of AssocFamPatOrigin; constraints+   with this origin are dropped entirely during error message reporting.++   If there is any trouble, checkValidFamInst bleats, aborting compilation.++-}++++--------------------------------------------+--      Reporters+--------------------------------------------++type Reporter+  = SolverReportErrCtxt -> [ErrorItem] -> TcM ()+type ReporterSpec+  = ( String                      -- Name+    , ErrorItem -> Pred -> Bool  -- Pick these ones+    , Bool                        -- True <=> suppress subsequent reporters+    , Reporter)                   -- The reporter itself++mkSkolReporter :: Reporter+-- Suppress duplicates with either the same LHS, or same location+-- Pre-condition: all items are equalities+mkSkolReporter ctxt items+  = mapM_ (reportGroup mkEqErr ctxt) (group items)+  where+     group [] = []+     group (item:items) = (item : yeses) : group noes+        where+          (yeses, noes) = partition (group_with item) items++     group_with item1 item2+       | EQ <- cmp_loc item1 item2 = True+       | eq_lhs_type   item1 item2 = True+       | otherwise                 = False++reportHoles :: [ErrorItem]  -- other (tidied) constraints+            -> SolverReportErrCtxt -> [Hole] -> TcM ()+reportHoles tidy_items ctxt holes+  = do+      diag_opts <- initDiagOpts <$> getDynFlags+      let severity = diagReasonSeverity diag_opts (cec_type_holes ctxt)+          holes'   = filter (keepThisHole severity) holes+      -- Zonk and tidy all the TcLclEnvs before calling `mkHoleError`+      -- because otherwise types will be zonked and tidied many times over.+      (tidy_env', lcl_name_cache) <- zonkTidyTcLclEnvs (cec_tidy ctxt) (map (ctl_env . hole_loc) holes')+      let ctxt' = ctxt { cec_tidy = tidy_env' }+      forM_ holes' $ \hole -> do { msg <- mkHoleError lcl_name_cache tidy_items ctxt' hole+                                 ; reportDiagnostic msg }++keepThisHole :: Severity -> Hole -> Bool+-- See Note [Skip type holes rapidly]+keepThisHole sev hole+  = case hole_sort hole of+       ExprHole {}    -> True+       TypeHole       -> keep_type_hole+       ConstraintHole -> keep_type_hole+  where+    keep_type_hole = case sev of+                         SevIgnore -> False+                         _         -> True++-- | zonkTidyTcLclEnvs takes a bunch of 'TcLclEnv's, each from a Hole.+-- It returns a ('Name' :-> 'Type') mapping which gives the zonked, tidied+-- type for each Id in any of the binder stacks in the  'TcLclEnv's.+-- Since there is a huge overlap between these stacks, is is much,+-- much faster to do them all at once, avoiding duplication.+zonkTidyTcLclEnvs :: TidyEnv -> [TcLclEnv] -> TcM (TidyEnv, NameEnv Type)+zonkTidyTcLclEnvs tidy_env lcls = foldM go (tidy_env, emptyNameEnv) (concatMap tcl_bndrs lcls)+  where+    go envs tc_bndr = case tc_bndr of+          TcTvBndr {} -> return envs+          TcIdBndr id _top_lvl -> go_one (idName id) (idType id) envs+          TcIdBndr_ExpType name et _top_lvl ->+            do { mb_ty <- readExpType_maybe et+                   -- et really should be filled in by now. But there's a chance+                   -- it hasn't, if, say, we're reporting a kind error en route to+                   -- checking a term. See test indexed-types/should_fail/T8129+                   -- Or we are reporting errors from the ambiguity check on+                   -- a local type signature+               ; case mb_ty of+                   Just ty -> go_one name ty envs+                   Nothing -> return envs+               }+    go_one name ty (tidy_env, name_env) = do+            if name `elemNameEnv` name_env+              then return (tidy_env, name_env)+              else do+                (tidy_env', tidy_ty) <- zonkTidyTcType tidy_env ty+                return (tidy_env',  extendNameEnv name_env name tidy_ty)++reportNotConcreteErrs :: SolverReportErrCtxt -> [NotConcreteError] -> TcM ()+reportNotConcreteErrs _ [] = return ()+reportNotConcreteErrs ctxt errs@(err0:_)+  = do { msg <- mkErrorReport (ctLocEnv (nce_loc err0)) diag (Just ctxt) []+       ; reportDiagnostic msg }++  where++    frr_origins = acc_errors errs+    diag = TcRnSolverReport+             [SolverReportWithCtxt ctxt (FixedRuntimeRepError frr_origins)]+             ErrorWithoutFlag noHints++    -- Accumulate the different kind of errors arising from syntactic equality.+    -- (Only SynEq_FRR origin for the moment.)+    acc_errors = go []+      where+        go frr_errs [] = frr_errs+        go frr_errs (err:errs)+          | frr_errs <- go frr_errs errs+          = case err of+              NCE_FRR+                { nce_frr_origin = frr_orig+                , nce_reasons = _not_conc } ->+                FRR_Info+                  { frr_info_origin       = frr_orig+                  , frr_info_not_concrete = Nothing }+                : frr_errs++{- Note [Skip type holes rapidly]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have module with a /lot/ of partial type signatures, and we+compile it while suppressing partial-type-signature warnings.  Then+we don't want to spend ages constructing error messages and lists of+relevant bindings that we never display! This happened in #14766, in+which partial type signatures in a Happy-generated parser cause a huge+increase in compile time.++The function ignoreThisHole short-circuits the error/warning generation+machinery, in cases where it is definitely going to be a no-op.+-}++mkUserTypeErrorReporter :: Reporter+mkUserTypeErrorReporter ctxt+  = mapM_ $ \item -> do { let err = important ctxt $ mkUserTypeError item+                        ; maybeReportError ctxt [item] err+                        ; addDeferredBinding ctxt err item }++mkUserTypeError :: ErrorItem -> TcSolverReportMsg+mkUserTypeError item =+  case getUserTypeErrorMsg (errorItemPred item) of+    Just msg -> UserTypeError msg+    Nothing  -> pprPanic "mkUserTypeError" (ppr item)++mkGivenErrorReporter :: Reporter+-- See Note [Given errors]+mkGivenErrorReporter ctxt items+  = do { (ctxt, relevant_binds, item) <- relevantBindings True ctxt item+       ; let (implic:_) = cec_encl ctxt+                 -- Always non-empty when mkGivenErrorReporter is called+             loc'  = setCtLocEnv (ei_loc item) (ic_env implic)+             item' = item { ei_loc = loc' }+                   -- For given constraints we overwrite the env (and hence src-loc)+                   -- with one from the immediately-enclosing implication.+                   -- See Note [Inaccessible code]++       ; (eq_err_msgs, _hints) <- mkEqErr_help ctxt item' ty1 ty2+       -- The hints wouldn't help in this situation, so we discard them.+       ; let supplementary = [ SupplementaryBindings relevant_binds ]+             msg = TcRnInaccessibleCode implic (NE.reverse . NE.map (SolverReportWithCtxt ctxt) $ eq_err_msgs)+       ; msg <- mkErrorReport (ctLocEnv loc') msg (Just ctxt) supplementary+       ; reportDiagnostic msg }+  where+    (item : _ )  = items    -- Never empty+    (ty1, ty2)   = getEqPredTys (errorItemPred item)++ignoreErrorReporter :: Reporter+-- Discard Given errors that don't come from+-- a pattern match; maybe we should warn instead?+ignoreErrorReporter ctxt items+  = do { traceTc "mkGivenErrorReporter no" (ppr items $$ ppr (cec_encl ctxt))+       ; return () }+++{- Note [Given errors]+~~~~~~~~~~~~~~~~~~~~~~+Given constraints represent things for which we have (or will have)+evidence, so they aren't errors.  But if a Given constraint is+insoluble, this code is inaccessible, and we might want to at least+warn about that.  A classic case is++   data T a where+     T1 :: T Int+     T2 :: T a+     T3 :: T Bool++   f :: T Int -> Bool+   f T1 = ...+   f T2 = ...+   f T3 = ...  -- We want to report this case as inaccessible++We'd like to point out that the T3 match is inaccessible. It+will have a Given constraint [G] Int ~ Bool.++But we don't want to report ALL insoluble Given constraints.  See Trac+#12466 for a long discussion.  For example, if we aren't careful+we'll complain about+   f :: ((Int ~ Bool) => a -> a) -> Int+which arguably is OK.  It's more debatable for+   g :: (Int ~ Bool) => Int -> Int+but it's tricky to distinguish these cases so we don't report+either.++The bottom line is this: has_gadt_match looks for an enclosing+pattern match which binds some equality constraints.  If we+find one, we report the insoluble Given.+-}++mkGroupReporter :: (SolverReportErrCtxt -> [ErrorItem] -> TcM SolverReport)+                             -- Make error message for a group+                -> Reporter  -- Deal with lots of constraints+-- Group together errors from same location,+-- and report only the first (to avoid a cascade)+mkGroupReporter mk_err ctxt items+  = mapM_ (reportGroup mk_err ctxt . toList) (equivClasses cmp_loc items)++eq_lhs_type :: ErrorItem -> ErrorItem -> Bool+eq_lhs_type item1 item2+  = case (classifyPredType (errorItemPred item1), classifyPredType (errorItemPred item2)) of+       (EqPred eq_rel1 ty1 _, EqPred eq_rel2 ty2 _) ->+         (eq_rel1 == eq_rel2) && (ty1 `eqType` ty2)+       _ -> pprPanic "mkSkolReporter" (ppr item1 $$ ppr item2)++cmp_loc :: ErrorItem -> ErrorItem -> Ordering+cmp_loc item1 item2 = get item1 `compare` get item2+  where+    get ei = realSrcSpanStart (ctLocSpan (errorItemCtLoc ei))+             -- Reduce duplication by reporting only one error from each+             -- /starting/ location even if the end location differs++reportGroup :: (SolverReportErrCtxt -> [ErrorItem] -> TcM SolverReport) -> Reporter+reportGroup mk_err ctxt items+  = do { err <- mk_err ctxt items+       ; traceTc "About to maybeReportErr" $+         vcat [ text "Constraint:"             <+> ppr items+              , text "cec_suppress ="          <+> ppr (cec_suppress ctxt)+              , text "cec_defer_type_errors =" <+> ppr (cec_defer_type_errors ctxt) ]+       ; maybeReportError ctxt items err+           -- But see Note [Always warn with -fdefer-type-errors]+       ; traceTc "reportGroup" (ppr items)+       ; mapM_ (addDeferredBinding ctxt err) items }+           -- Add deferred bindings for all+           -- Redundant if we are going to abort compilation,+           -- but that's hard to know for sure, and if we don't+           -- abort, we need bindings for all (e.g. #12156)++-- See Note [No deferring for multiplicity errors]+nonDeferrableOrigin :: CtOrigin -> Bool+nonDeferrableOrigin NonLinearPatternOrigin  = True+nonDeferrableOrigin (UsageEnvironmentOf {}) = True+nonDeferrableOrigin (FRROrigin {})          = True+nonDeferrableOrigin _                       = False++maybeReportError :: SolverReportErrCtxt+                 -> [ErrorItem]     -- items covered by the Report+                 -> SolverReport -> TcM ()+maybeReportError ctxt items@(item1:_) (SolverReport { sr_important_msgs = important+                                                    , sr_supplementary = supp+                                                    , sr_hints = hints })+  = unless (cec_suppress ctxt  -- Some worse error has occurred, so suppress this diagnostic+         || all ei_suppress items) $+                           -- if they're all to be suppressed, report nothing+                           -- if at least one is not suppressed, do report:+                           -- the function that generates the error message+                           -- should look for an unsuppressed error item+    do let reason | any (nonDeferrableOrigin . errorItemOrigin) items = ErrorWithoutFlag+                  | otherwise                                         = cec_defer_type_errors ctxt+                  -- See Note [No deferring for multiplicity errors]+           diag = TcRnSolverReport important reason hints+       msg <- mkErrorReport (ctLocEnv (errorItemCtLoc item1)) diag (Just ctxt) supp+       reportDiagnostic msg+maybeReportError _ _ _ = panic "maybeReportError"++addDeferredBinding :: SolverReportErrCtxt -> SolverReport -> ErrorItem -> TcM ()+-- See Note [Deferring coercion errors to runtime]+addDeferredBinding ctxt err (EI { ei_evdest = Just dest, ei_pred = item_ty+                                , ei_loc = loc })+     -- if evdest is Just, then the constraint was from a wanted+  | deferringAnyBindings ctxt+  = do { err_tm <- mkErrorTerm ctxt loc item_ty err+       ; let ev_binds_var = cec_binds ctxt++       ; case dest of+           EvVarDest evar+             -> addTcEvBind ev_binds_var $ mkWantedEvBind evar err_tm+           HoleDest hole+             -> do { -- See Note [Deferred errors for coercion holes]+                     let co_var = coHoleCoVar hole+                   ; addTcEvBind ev_binds_var $ mkWantedEvBind co_var err_tm+                   ; fillCoercionHole hole (mkTcCoVarCo co_var) } }+addDeferredBinding _ _ _ = return ()    -- Do not set any evidence for Given++mkErrorTerm :: SolverReportErrCtxt -> CtLoc -> Type  -- of the error term+            -> SolverReport -> TcM EvTerm+mkErrorTerm ctxt ct_loc ty (SolverReport { sr_important_msgs = important, sr_supplementary = supp })+  = do { msg <- mkErrorReport+                  (ctLocEnv ct_loc)+                  (TcRnSolverReport important ErrorWithoutFlag noHints) (Just ctxt) supp+         -- This will be reported at runtime, so we always want "error:" in the report, never "warning:"+       ; dflags <- getDynFlags+       ; let err_msg = pprLocMsgEnvelope msg+             err_str = showSDoc dflags $+                       err_msg $$ text "(deferred type error)"++       ; return $ evDelayedError ty err_str }++tryReporters :: SolverReportErrCtxt -> [ReporterSpec] -> [ErrorItem] -> TcM (SolverReportErrCtxt, [ErrorItem])+-- Use the first reporter in the list whose predicate says True+tryReporters ctxt reporters items+  = do { let (vis_items, invis_items)+               = partition (isVisibleOrigin . errorItemOrigin) items+       ; traceTc "tryReporters {" (ppr vis_items $$ ppr invis_items)+       ; (ctxt', items') <- go ctxt reporters vis_items invis_items+       ; traceTc "tryReporters }" (ppr items')+       ; return (ctxt', items') }+  where+    go ctxt [] vis_items invis_items+      = return (ctxt, vis_items ++ invis_items)++    go ctxt (r : rs) vis_items invis_items+       -- always look at *visible* Origins before invisible ones+       -- this is the whole point of isVisibleOrigin+      = do { (ctxt', vis_items') <- tryReporter ctxt r vis_items+           ; (ctxt'', invis_items') <- tryReporter ctxt' r invis_items+           ; go ctxt'' rs vis_items' invis_items' }+                -- Carry on with the rest, because we must make+                -- deferred bindings for them if we have -fdefer-type-errors+                -- But suppress their error messages++tryReporter :: SolverReportErrCtxt -> ReporterSpec -> [ErrorItem] -> TcM (SolverReportErrCtxt, [ErrorItem])+tryReporter ctxt (str, keep_me,  suppress_after, reporter) items+  | null yeses+  = return (ctxt, items)+  | otherwise+  = do { traceTc "tryReporter{ " (text str <+> ppr yeses)+       ; (_, no_errs) <- askNoErrs (reporter ctxt yeses)+       ; let suppress_now   = not no_errs && suppress_after+                            -- See Note [Suppressing error messages]+             ctxt' = ctxt { cec_suppress = suppress_now || cec_suppress ctxt }+       ; traceTc "tryReporter end }" (text str <+> ppr (cec_suppress ctxt) <+> ppr suppress_after)+       ; return (ctxt', nos) }+  where+    (yeses, nos) = partition keep items+    keep item = keep_me item (classifyPredType (errorItemPred item))++-- | Wrap an input 'TcRnMessage' with additional contextual information,+-- such as relevant bindings or valid hole fits.+mkErrorReport :: TcLclEnv+              -> TcRnMessage+                  -- ^ The main payload of the message.+              -> Maybe SolverReportErrCtxt+                  -- ^ The context to add, after the main diagnostic+                  -- but before the supplementary information.+                  -- Nothing <=> don't add any context.+              -> [SolverReportSupplementary]+                  -- ^ Supplementary information, to be added at the end of the message.+              -> TcM (MsgEnvelope TcRnMessage)+mkErrorReport tcl_env msg mb_ctxt supplementary+  = do { mb_context <- traverse (\ ctxt -> mkErrInfo (cec_tidy ctxt) (tcl_ctxt tcl_env)) mb_ctxt+       ; unit_state <- hsc_units <$> getTopEnv+       ; hfdc <- getHoleFitDispConfig+       ; let+           err_info =+             ErrInfo+               (fromMaybe empty mb_context)+               (vcat $ map (pprSolverReportSupplementary hfdc) supplementary)+       ; mkTcRnMessage+           (RealSrcSpan (tcl_loc tcl_env) Strict.Nothing)+           (TcRnMessageWithInfo unit_state $ TcRnMessageDetailed err_info msg) }++-- | Pretty-print supplementary information, to add to an error report.+pprSolverReportSupplementary :: HoleFitDispConfig -> SolverReportSupplementary -> SDoc+-- This function should be in "GHC.Tc.Errors.Ppr",+-- but we need it here because 'TcRnMessageDetails' needs an 'SDoc'.+pprSolverReportSupplementary hfdc = \case+  SupplementaryBindings binds -> pprRelevantBindings binds+  SupplementaryHoleFits fits  -> pprValidHoleFits hfdc fits+  SupplementaryCts      cts   -> pprConstraintsInclude cts++-- | Display a collection of valid hole fits.+pprValidHoleFits :: HoleFitDispConfig -> ValidHoleFits -> SDoc+-- This function should be in "GHC.Tc.Errors.Ppr",+-- but we need it here because 'TcRnMessageDetails' needs an 'SDoc'.+pprValidHoleFits hfdc (ValidHoleFits (Fits fits discarded_fits) (Fits refs discarded_refs))+  = fits_msg $$ refs_msg++  where+    fits_msg, refs_msg, fits_discard_msg, refs_discard_msg :: SDoc+    fits_msg = ppUnless (null fits) $+                    hang (text "Valid hole fits include") 2 $+                    vcat (map (pprHoleFit hfdc) fits)+                      $$ ppWhen  discarded_fits fits_discard_msg+    refs_msg = ppUnless (null refs) $+                  hang (text "Valid refinement hole fits include") 2 $+                  vcat (map (pprHoleFit hfdc) refs)+                    $$ ppWhen discarded_refs refs_discard_msg+    fits_discard_msg =+      text "(Some hole fits suppressed;" <+>+      text "use -fmax-valid-hole-fits=N" <+>+      text "or -fno-max-valid-hole-fits)"+    refs_discard_msg =+      text "(Some refinement hole fits suppressed;" <+>+      text "use -fmax-refinement-hole-fits=N" <+>+      text "or -fno-max-refinement-hole-fits)"++-- | Add a "Constraints include..." message.+--+-- See Note [Constraints include ...]+pprConstraintsInclude :: [(PredType, RealSrcSpan)] -> SDoc+-- This function should be in "GHC.Tc.Errors.Ppr",+-- but we need it here because 'TcRnMessageDetails' needs an 'SDoc'.+pprConstraintsInclude cts+  = ppUnless (null cts) $+     hang (text "Constraints include")+        2 (vcat $ map pprConstraint cts)+  where+    pprConstraint (constraint, loc) =+      ppr constraint <+> nest 2 (parens (text "from" <+> ppr loc))++{- Note [Always warn with -fdefer-type-errors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When -fdefer-type-errors is on we warn about *all* type errors, even+if cec_suppress is on.  This can lead to a lot more warnings than you+would get errors without -fdefer-type-errors, but if we suppress any of+them you might get a runtime error that wasn't warned about at compile+time.++To be consistent, we should also report multiple warnings from a single+location in mkGroupReporter, when -fdefer-type-errors is on.  But that+is perhaps a bit *over*-consistent!++With #10283, you can now opt out of deferred type error warnings.++Note [No deferring for multiplicity errors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+As explained in Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify,+linear types do not support casts and any nontrivial coercion will raise+an error during desugaring.++This means that even if we defer a multiplicity mismatch during typechecking,+the desugarer will refuse to compile anyway. Worse: the error raised+by the desugarer would shadow the type mismatch warnings (#20083).+As a solution, we refuse to defer submultiplicity constraints. Test: T20083.++To determine whether a constraint arose from a submultiplicity check, we+look at the CtOrigin. All calls to tcSubMult use one of two origins,+UsageEnvironmentOf and NonLinearPatternOrigin. Those origins are not+used outside of linear types.++In the future, we should compile 'WpMultCoercion' to a runtime error with+-fdefer-type-errors, but the current implementation does not always+place the wrapper in the right place and the resulting program can fail Lint.+This plan is tracked in #20083.++Note [Deferred errors for coercion holes]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we need to defer a type error where the destination for the evidence+is a coercion hole. We can't just put the error in the hole, because we can't+make an erroneous coercion. (Remember that coercions are erased for runtime.)+Instead, we invent a new EvVar, bind it to an error and then make a coercion+from that EvVar, filling the hole with that coercion. Because coercions'+types are unlifted, the error is guaranteed to be hit before we get to the+coercion.++************************************************************************+*                                                                      *+                Irreducible predicate errors+*                                                                      *+************************************************************************+-}++mkIrredErr :: SolverReportErrCtxt -> [ErrorItem] -> TcM SolverReport+mkIrredErr ctxt items+  = do { (ctxt, binds_msg, item1) <- relevantBindings True ctxt item1+       ; let msg = important ctxt $+                   CouldNotDeduce (getUserGivens ctxt) (item1 :| others) Nothing+       ; return $ msg `mappend` mk_relevant_bindings binds_msg }+  where+    (item1:others) = final_items++    filtered_items = filter (not . ei_suppress) items+    final_items | null filtered_items = items+                    -- they're all suppressed; must report *something*+                    -- NB: even though reportWanteds asserts that not+                    -- all items are suppressed, it's possible all the+                    -- irreducibles are suppressed, and so this function+                    -- might get all suppressed items+                | otherwise           = filtered_items++{- Note [Constructing Hole Errors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Whether or not 'mkHoleError' returns an error is not influenced by cec_suppress. In other terms,+these "hole" errors are /not/ suppressed by cec_suppress. We want to see them!++There are two cases to consider:++1. For out-of-scope variables we always report an error, unless -fdefer-out-of-scope-variables is on,+   in which case the messages are discarded. See also #12170 and #12406. If deferring, report a warning+   only if -Wout-of-scope-variables is on.++2. For the general case, when -XPartialTypeSignatures is on, warnings (instead of errors) are generated+   for holes in partial type signatures, unless -Wpartial-type-signatures is not on, in which case+   the messages are discarded. If deferring, report a warning only if -Wtyped-holes is on.++The above can be summarised into the following table:++| Hole Type    | Active Flags                                             | Outcome          |+|--------------|----------------------------------------------------------|------------------|+| out-of-scope | None                                                     | Error            |+| out-of-scope | -fdefer-out-of-scope-variables, -Wout-of-scope-variables | Warning          |+| out-of-scope | -fdefer-out-of-scope-variables                           | Ignore (discard) |+| type         | None                                                     | Error            |+| type         | -XPartialTypeSignatures, -Wpartial-type-signatures       | Warning          |+| type         | -XPartialTypeSignatures                                  | Ignore (discard) |+| expression   | None                                                     | Error            |+| expression   | -Wdefer-typed-holes, -Wtyped-holes                       | Warning          |+| expression   | -Wdefer-typed-holes                                      | Ignore (discard) |++See also 'reportUnsolved'.++-}++----------------+-- | Constructs a new hole error, unless this is deferred. See Note [Constructing Hole Errors].+mkHoleError :: NameEnv Type -> [ErrorItem] -> SolverReportErrCtxt -> Hole -> TcM (MsgEnvelope TcRnMessage)+mkHoleError _ _tidy_simples ctxt hole@(Hole { hole_occ = occ, hole_loc = ct_loc })+  | isOutOfScopeHole hole+  = do { dflags  <- getDynFlags+       ; rdr_env <- getGlobalRdrEnv+       ; imp_info <- getImports+       ; curr_mod <- getModule+       ; hpt <- getHpt+       ; let (imp_errs, hints)+                = unknownNameSuggestions WL_Anything+                    dflags hpt curr_mod rdr_env+                    (tcl_rdr lcl_env) imp_info (mkRdrUnqual occ)+             errs   = [SolverReportWithCtxt ctxt (ReportHoleError hole $ OutOfScopeHole imp_errs)]+             report = SolverReport errs [] hints++       ; maybeAddDeferredBindings ctxt hole report+       ; mkErrorReport lcl_env (TcRnSolverReport errs (cec_out_of_scope_holes ctxt) hints) Nothing []+          -- Pass the value 'Nothing' for the context, as it's generally not helpful+          -- to include the context here.+       }+  where+    lcl_env = ctLocEnv ct_loc++ -- general case: not an out-of-scope error+mkHoleError lcl_name_cache tidy_simples ctxt+  hole@(Hole { hole_ty = hole_ty+             , hole_sort = sort+             , hole_loc = ct_loc })+  = do { rel_binds+           <- relevant_bindings False lcl_env lcl_name_cache (tyCoVarsOfType hole_ty)+               -- The 'False' means "don't filter the bindings"; see Trac #8191++       ; show_hole_constraints <- goptM Opt_ShowHoleConstraints+       ; let relevant_cts+               | ExprHole _ <- sort, show_hole_constraints+               = givenConstraints ctxt+               | otherwise+               = []++       ; show_valid_hole_fits <- goptM Opt_ShowValidHoleFits+       ; (ctxt, hole_fits) <- if show_valid_hole_fits+                              then validHoleFits ctxt tidy_simples hole+                              else return (ctxt, noValidHoleFits)+       ; (grouped_skvs, other_tvs) <- zonkAndGroupSkolTvs hole_ty+       ; let reason | ExprHole _ <- sort = cec_expr_holes ctxt+                    | otherwise          = cec_type_holes ctxt+             errs = [SolverReportWithCtxt ctxt $ ReportHoleError hole $ HoleError sort other_tvs grouped_skvs]+             supp = [ SupplementaryBindings rel_binds+                    , SupplementaryCts      relevant_cts+                    , SupplementaryHoleFits hole_fits ]++       ; maybeAddDeferredBindings ctxt hole (SolverReport errs supp [])++       ; mkErrorReport lcl_env (TcRnSolverReport errs reason noHints) (Just ctxt) supp+       }++  where+    lcl_env = ctLocEnv ct_loc++-- | For all the skolem type variables in a type, zonk the skolem info and group together+-- all the type variables with the same origin.+zonkAndGroupSkolTvs :: Type -> TcM ([(SkolemInfoAnon, [TcTyVar])], [TcTyVar])+zonkAndGroupSkolTvs hole_ty = do+  zonked_info <- mapM (\(sk, tv) -> (,) <$> (zonkSkolemInfoAnon . getSkolemInfo $ sk) <*> pure (fst <$> tv)) skolem_list+  return (zonked_info, other_tvs)+  where+    tvs = tyCoVarsOfTypeList hole_ty+    (skol_tvs, other_tvs) = partition (\tv -> isTcTyVar tv && isSkolemTyVar tv) tvs++    group_skolems :: UM.UniqMap SkolemInfo ([(TcTyVar, Int)])+    group_skolems = bagToList <$> UM.listToUniqMap_C unionBags [(skolemSkolInfo tv, unitBag (tv, n)) | tv <- skol_tvs | n <- [0..]]++    skolem_list = sortBy (comparing (sort . map snd . snd)) (UM.nonDetEltsUniqMap group_skolems)++{- Note [Adding deferred bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++When working with typed holes we have to deal with the case where+we want holes to be reported as warnings to users during compile time but+as errors during runtime. Therefore, we have to call 'maybeAddDeferredBindings'+so that the correct 'Severity' can be computed out of that later on.++-}+++-- | Adds deferred bindings (as errors).+-- See Note [Adding deferred bindings].+maybeAddDeferredBindings :: SolverReportErrCtxt+                         -> Hole+                         -> SolverReport+                         -> TcM ()+maybeAddDeferredBindings ctxt hole report = do+  case hole_sort hole of+    ExprHole (HER ref ref_ty _) -> do+      -- Only add bindings for holes in expressions+      -- not for holes in partial type signatures+      -- cf. addDeferredBinding+      when (deferringAnyBindings ctxt) $ do+        err_tm <- mkErrorTerm ctxt (hole_loc hole) ref_ty report+          -- NB: ref_ty, not hole_ty. hole_ty might be rewritten.+          -- See Note [Holes] in GHC.Tc.Types.Constraint+        writeMutVar ref err_tm+    _ -> pure ()++-- We unwrap the SolverReportErrCtxt here, to avoid introducing a loop in module+-- imports+validHoleFits :: SolverReportErrCtxt    -- ^ The context we're in, i.e. the+                                        -- implications and the tidy environment+              -> [ErrorItem]      -- ^ Unsolved simple constraints+              -> Hole             -- ^ The hole+              -> TcM (SolverReportErrCtxt, ValidHoleFits)+                -- ^ We return the new context+                -- with a possibly updated+                -- tidy environment, and+                -- the valid hole fits.+validHoleFits ctxt@(CEC { cec_encl = implics+                        , cec_tidy = lcl_env}) simps hole+  = do { (tidy_env, fits) <- findValidHoleFits lcl_env implics (map mk_wanted simps) hole+       ; return (ctxt {cec_tidy = tidy_env}, fits) }+  where+    mk_wanted :: ErrorItem -> CtEvidence+    mk_wanted (EI { ei_pred = pred, ei_evdest = Just dest, ei_loc = loc })+         = CtWanted { ctev_pred      = pred+                    , ctev_dest      = dest+                    , ctev_loc       = loc+                    , ctev_rewriters = emptyRewriterSet }+    mk_wanted item = pprPanic "validHoleFits no evdest" (ppr item)++-- See Note [Constraints include ...]+givenConstraints :: SolverReportErrCtxt -> [(Type, RealSrcSpan)]+givenConstraints ctxt+  = do { implic@Implic{ ic_given = given } <- cec_encl ctxt+       ; constraint <- given+       ; return (varType constraint, tcl_loc (ic_env implic)) }++----------------++mkIPErr :: SolverReportErrCtxt -> [ErrorItem] -> TcM SolverReport+-- What would happen if an item is suppressed because of+-- Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint? Very unclear+-- what's best. Let's not worry about this.+mkIPErr ctxt items+  = do { (ctxt, binds_msg, item1) <- relevantBindings True ctxt item1+       ; let msg = important ctxt $ UnboundImplicitParams (item1 :| others)+       ; return $ msg `mappend` mk_relevant_bindings binds_msg }+  where+    item1:others = items++----------------++-- | Report a representation-polymorphism error to the user:+-- a type is required to havehave a fixed runtime representation,+-- but doesn't.+--+-- See Note [Reporting representation-polymorphism errors] in GHC.Tc.Types.Origin.+mkFRRErr :: HasDebugCallStack => SolverReportErrCtxt -> [ErrorItem] -> TcM SolverReport+mkFRRErr ctxt items+  = do { -- Process the error items.+       ; (_tidy_env, frr_infos) <-+          zonkTidyFRRInfos (cec_tidy ctxt) $+            -- Zonk/tidy to show useful variable names.+          nubOrdBy (nonDetCmpType `on` (frr_type . frr_info_origin)) $+            -- Remove duplicates: only one representation-polymorphism error per type.+          map (expectJust "mkFRRErr" . fixedRuntimeRepOrigin_maybe)+          items+       ; return $ important ctxt $ FixedRuntimeRepError frr_infos }++-- | Whether to report something using the @FixedRuntimeRep@ mechanism.+fixedRuntimeRepOrigin_maybe :: HasDebugCallStack => ErrorItem -> Maybe FixedRuntimeRepErrorInfo+fixedRuntimeRepOrigin_maybe item+  -- An error that arose directly from a representation-polymorphism check.+  | FRROrigin frr_orig <- errorItemOrigin item+  = Just $ FRR_Info { frr_info_origin = frr_orig+                    , frr_info_not_concrete = Nothing }+  -- Unsolved nominal equalities involving a concrete type variable,+  -- such as @alpha[conc] ~# rr[sk]@ or @beta[conc] ~# RR@ for a+  -- type family application @RR@, are handled by 'mkTyVarEqErr''.+  | otherwise+  = Nothing++{-+Note [Constraints include ...]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+'givenConstraintsMsg' returns the "Constraints include ..." message enabled by+-fshow-hole-constraints. For example, the following hole:++    foo :: (Eq a, Show a) => a -> String+    foo x = _++would generate the message:++    Constraints include+      Eq a (from foo.hs:1:1-36)+      Show a (from foo.hs:1:1-36)++Constraints are displayed in order from innermost (closest to the hole) to+outermost. There's currently no filtering or elimination of duplicates.++************************************************************************+*                                                                      *+                Equality errors+*                                                                      *+************************************************************************++Note [Inaccessible code]+~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   data T a where+     T1 :: T a+     T2 :: T Bool++   f :: (a ~ Int) => T a -> Int+   f T1 = 3+   f T2 = 4   -- Unreachable code++Here the second equation is unreachable. The original constraint+(a~Int) from the signature gets rewritten by the pattern-match to+(Bool~Int), so the danger is that we report the error as coming from+the *signature* (#7293).  So, for Given errors we replace the+env (and hence src-loc) on its CtLoc with that from the immediately+enclosing implication.++Note [Error messages for untouchables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider (#9109)+  data G a where { GBool :: G Bool }+  foo x = case x of GBool -> True++Here we can't solve (t ~ Bool), where t is the untouchable result+meta-var 't', because of the (a ~ Bool) from the pattern match.+So we infer the type+   f :: forall a t. G a -> t+making the meta-var 't' into a skolem.  So when we come to report+the unsolved (t ~ Bool), t won't look like an untouchable meta-var+any more.  So we don't assert that it is.+-}++-- Don't have multiple equality errors from the same location+-- E.g.   (Int,Bool) ~ (Bool,Int)   one error will do!+mkEqErr :: SolverReportErrCtxt -> [ErrorItem] -> TcM SolverReport+mkEqErr ctxt items+  | item:_ <- filter (not . ei_suppress) items+  = mkEqErr1 ctxt item++  | item:_ <- items  -- they're all suppressed. still need an error message+                     -- for -fdefer-type-errors though+  = mkEqErr1 ctxt item++  | otherwise+  = panic "mkEqErr"  -- guaranteed to have at least one item++mkEqErr1 :: SolverReportErrCtxt -> ErrorItem -> TcM SolverReport+mkEqErr1 ctxt item   -- Wanted only+                     -- givens handled in mkGivenErrorReporter+  = do { (ctxt, binds_msg, item) <- relevantBindings True ctxt item+       ; rdr_env <- getGlobalRdrEnv+       ; fam_envs <- tcGetFamInstEnvs+       ; let mb_coercible_msg = case errorItemEqRel item of+               NomEq  -> Nothing+               ReprEq -> ReportCoercibleMsg <$> mkCoercibleExplanation rdr_env fam_envs ty1 ty2+       ; traceTc "mkEqErr1" (ppr item $$ pprCtOrigin (errorItemOrigin item))+       ; (last_msg :| prev_msgs, hints) <- mkEqErr_help ctxt item ty1 ty2+       ; let+           report = foldMap (important ctxt) (reverse prev_msgs)+                  `mappend` (important ctxt $ mkTcReportWithInfo last_msg $ maybeToList mb_coercible_msg)+                  `mappend` (mk_relevant_bindings binds_msg)+                  `mappend` (mk_report_hints hints)+       ; return report }+  where+    (ty1, ty2) = getEqPredTys (errorItemPred item)++-- | This function tries to reconstruct why a "Coercible ty1 ty2" constraint+-- is left over.+mkCoercibleExplanation :: GlobalRdrEnv -> FamInstEnvs+                       -> TcType -> TcType -> Maybe CoercibleMsg+mkCoercibleExplanation rdr_env fam_envs ty1 ty2+  | Just (tc, tys) <- tcSplitTyConApp_maybe ty1+  , (rep_tc, _, _) <- tcLookupDataFamInst fam_envs tc tys+  , Just msg <- coercible_msg_for_tycon rep_tc+  = Just msg+  | Just (tc, tys) <- splitTyConApp_maybe ty2+  , (rep_tc, _, _) <- tcLookupDataFamInst fam_envs tc tys+  , Just msg <- coercible_msg_for_tycon rep_tc+  = Just msg+  | Just (s1, _) <- tcSplitAppTy_maybe ty1+  , Just (s2, _) <- tcSplitAppTy_maybe ty2+  , s1 `eqType` s2+  , has_unknown_roles s1+  = Just $ UnknownRoles s1+  | otherwise+  = Nothing+  where+    coercible_msg_for_tycon tc+        | isAbstractTyCon tc+        = Just $ TyConIsAbstract tc+        | isNewTyCon tc+        , [data_con] <- tyConDataCons tc+        , let dc_name = dataConName data_con+        , isNothing (lookupGRE_Name rdr_env dc_name)+        = Just $ OutOfScopeNewtypeConstructor tc data_con+        | otherwise = Nothing++    has_unknown_roles ty+      | Just (tc, tys) <- tcSplitTyConApp_maybe ty+      = tys `lengthAtLeast` tyConArity tc  -- oversaturated tycon+      | Just (s, _) <- tcSplitAppTy_maybe ty+      = has_unknown_roles s+      | isTyVarTy ty+      = True+      | otherwise+      = False++-- | Accumulated messages in reverse order.+type AccReportMsgs = NonEmpty TcSolverReportMsg++mkEqErr_help :: SolverReportErrCtxt+             -> ErrorItem+             -> TcType -> TcType -> TcM (AccReportMsgs, [GhcHint])+mkEqErr_help ctxt item ty1 ty2+  | Just casted_tv1 <- tcGetCastedTyVar_maybe ty1+  = mkTyVarEqErr ctxt item casted_tv1 ty2+  | Just casted_tv2 <- tcGetCastedTyVar_maybe ty2+  = mkTyVarEqErr ctxt item casted_tv2 ty1+  | otherwise+  = return (reportEqErr ctxt item ty1 ty2 :| [], [])++reportEqErr :: SolverReportErrCtxt+            -> ErrorItem+            -> TcType -> TcType -> TcSolverReportMsg+reportEqErr ctxt item ty1 ty2+  = mkTcReportWithInfo mismatch eqInfos+  where+    mismatch = misMatchOrCND False ctxt item ty1 ty2+    eqInfos  = eqInfoMsgs ty1 ty2++mkTyVarEqErr :: SolverReportErrCtxt -> ErrorItem+             -> (TcTyVar, TcCoercionN) -> TcType -> TcM (AccReportMsgs, [GhcHint])+-- tv1 and ty2 are already tidied+mkTyVarEqErr ctxt item casted_tv1 ty2+  = do { traceTc "mkTyVarEqErr" (ppr item $$ ppr casted_tv1 $$ ppr ty2)+       ; mkTyVarEqErr' ctxt item casted_tv1 ty2 }++mkTyVarEqErr' :: SolverReportErrCtxt -> ErrorItem+              -> (TcTyVar, TcCoercionN) -> TcType -> TcM (AccReportMsgs, [GhcHint])+mkTyVarEqErr' ctxt item (tv1, co1) ty2++  -- Is this a representation-polymorphism error, e.g.+  -- alpha[conc] ~# rr[sk] ? If so, handle that first.+  | Just frr_info <- mb_concrete_reason+  = do+      (_, infos) <- zonkTidyFRRInfos (cec_tidy ctxt) [frr_info]+      return (FixedRuntimeRepError infos :| [], [])++  -- Impredicativity is a simple error to understand; try it before+  -- anything more complicated.+  | check_eq_result `cterHasProblem` cteImpredicative+  = do+    tyvar_eq_info <- extraTyVarEqInfo tv1 ty2+    let+        poly_msg = CannotUnifyWithPolytype item tv1 ty2+        poly_msg_with_info+          | isSkolemTyVar tv1+          = mkTcReportWithInfo poly_msg tyvar_eq_info+          | otherwise+          = poly_msg+        -- Unlike the other reports, this discards the old 'report_important'+        -- instead of augmenting it.  This is because the details are not likely+        -- to be helpful since this is just an unimplemented feature.+    return (poly_msg_with_info <| headline_msg :| [], [])++  | isSkolemTyVar tv1  -- ty2 won't be a meta-tyvar; we would have+                       -- swapped in Solver.Canonical.canEqTyVarHomo+    || isTyVarTyVar tv1 && not (isTyVarTy ty2)+    || errorItemEqRel item == ReprEq+     -- The cases below don't really apply to ReprEq (except occurs check)+  = do+    tv_extra     <- extraTyVarEqInfo tv1 ty2+    return (mkTcReportWithInfo headline_msg tv_extra :| [], add_sig)++  | cterHasOccursCheck check_eq_result+    -- We report an "occurs check" even for  a ~ F t a, where F is a type+    -- function; it's not insoluble (because in principle F could reduce)+    -- but we have certainly been unable to solve it+  = let extras2 = eqInfoMsgs ty1 ty2++        interesting_tyvars = filter (not . noFreeVarsOfType . tyVarKind) $+                             filter isTyVar $+                             fvVarList $+                             tyCoFVsOfType ty1 `unionFV` tyCoFVsOfType ty2++        extras3 = case interesting_tyvars of+          [] -> []+          (tv : tvs) -> [OccursCheckInterestingTyVars (tv :| tvs)]++    in return (mkTcReportWithInfo headline_msg (extras2 ++ extras3) :| [], [])++    -- This is wrinkle (4) in Note [Equalities with incompatible kinds] in+    -- GHC.Tc.Solver.Canonical+  | hasCoercionHoleCo co1 || hasCoercionHoleTy ty2+  = return (mkBlockedEqErr item :| [], [])++  -- If the immediately-enclosing implication has 'tv' a skolem, and+  -- we know by now its an InferSkol kind of skolem, then presumably+  -- it started life as a TyVarTv, else it'd have been unified, given+  -- that there's no occurs-check or forall problem+  | (implic:_) <- cec_encl ctxt+  , Implic { ic_skols = skols } <- implic+  , tv1 `elem` skols+  = do+    tv_extra     <- extraTyVarEqInfo tv1 ty2+    return (mkTcReportWithInfo mismatch_msg tv_extra :| [], [])++  -- Check for skolem escape+  | (implic:_) <- cec_encl ctxt   -- Get the innermost context+  , Implic { ic_skols = skols } <- implic+  , let esc_skols = filter (`elemVarSet` (tyCoVarsOfType ty2)) skols+  , not (null esc_skols)+  = return (SkolemEscape item implic esc_skols :| [mismatch_msg], [])++  -- Nastiest case: attempt to unify an untouchable variable+  -- So tv is a meta tyvar (or started that way before we+  -- generalised it).  So presumably it is an *untouchable*+  -- meta tyvar or a TyVarTv, else it'd have been unified+  -- See Note [Error messages for untouchables]+  | (implic:_) <- cec_encl ctxt   -- Get the innermost context+  , Implic { ic_tclvl = lvl } <- implic+  = assertPpr (not (isTouchableMetaTyVar lvl tv1))+              (ppr tv1 $$ ppr lvl) $ do -- See Note [Error messages for untouchables]+    let tclvl_extra = UntouchableVariable tv1 implic+    tv_extra     <- extraTyVarEqInfo tv1 ty2+    return (mkTcReportWithInfo tclvl_extra tv_extra :| [mismatch_msg], add_sig)++  | otherwise+  = return (reportEqErr ctxt item (mkTyVarTy tv1) ty2 :| [], [])+        -- This *can* happen (#6123)+        -- Consider an ambiguous top-level constraint (a ~ F a)+        -- Not an occurs check, because F is a type function.+  where+    headline_msg = misMatchOrCND insoluble_occurs_check ctxt item ty1 ty2+    mismatch_msg = mkMismatchMsg item ty1 ty2+    add_sig      = maybeToList $ suggestAddSig ctxt ty1 ty2++    -- The following doesn't use the cterHasProblem mechanism because+    -- we need to retrieve the ConcreteTvOrigin. Just knowing whether+    -- there is an error is not sufficient. See #21430.+    mb_concrete_reason+      | Just frr_orig <- isConcreteTyVar_maybe tv1+      , not (isConcrete ty2)+      = Just $ frr_reason frr_orig tv1 ty2+      | Just (tv2, frr_orig) <- isConcreteTyVarTy_maybe ty2+      , not (isConcreteTyVar tv1)+      = Just $ frr_reason frr_orig tv2 ty1+      -- NB: if it's an unsolved equality in which both sides are concrete+      -- (e.g. a concrete type variable on both sides), then it's not a+      -- representation-polymorphism problem.+      | otherwise+      = Nothing+    frr_reason (ConcreteFRR frr_orig) conc_tv not_conc+      = FRR_Info { frr_info_origin = frr_orig+                 , frr_info_not_concrete = Just (conc_tv, not_conc) }++    ty1 = mkTyVarTy tv1++    check_eq_result = case ei_m_reason item of+      Just (NonCanonicalReason result) -> result+      _ -> checkTyVarEq tv1 ty2+        -- in T2627b, we report an error for F (F a0) ~ a0. Note that the type+        -- variable is on the right, so we don't get useful info for the CIrredCan,+        -- and have to compute the result of checkTyVarEq here.++    insoluble_occurs_check = check_eq_result `cterHasProblem` cteInsolubleOccurs++eqInfoMsgs :: TcType -> TcType -> [TcSolverReportInfo]+-- Report (a) ambiguity if either side is a type function application+--            e.g. F a0 ~ Int+--        (b) warning about injectivity if both sides are the same+--            type function application   F a ~ F b+--            See Note [Non-injective type functions]+eqInfoMsgs ty1 ty2+  = catMaybes [tyfun_msg, ambig_msg]+  where+    mb_fun1 = isTyFun_maybe ty1+    mb_fun2 = isTyFun_maybe ty2++      -- if a type isn't headed by a type function, then any ambiguous+      -- variables need not be reported as such. e.g.: F a ~ t0 -> t0, where a is a skolem+    ambig_tkvs1 = maybe mempty (\_ -> ambigTkvsOfTy ty1) mb_fun1+    ambig_tkvs2 = maybe mempty (\_ -> ambigTkvsOfTy ty2) mb_fun2++    ambig_tkvs@(ambig_kvs, ambig_tvs) = ambig_tkvs1 S.<> ambig_tkvs2++    ambig_msg | isJust mb_fun1 || isJust mb_fun2+              , not (null ambig_kvs && null ambig_tvs)+              = Just $ Ambiguity False ambig_tkvs+              | otherwise+              = Nothing++    tyfun_msg | Just tc1 <- mb_fun1+              , Just tc2 <- mb_fun2+              , tc1 == tc2+              , not (isInjectiveTyCon tc1 Nominal)+              = Just $ NonInjectiveTyFam tc1+              | otherwise+              = Nothing++misMatchOrCND :: Bool -> SolverReportErrCtxt -> ErrorItem+              -> TcType -> TcType -> TcSolverReportMsg+-- If oriented then ty1 is actual, ty2 is expected+misMatchOrCND insoluble_occurs_check ctxt item ty1 ty2+  | insoluble_occurs_check  -- See Note [Insoluble occurs check]+    || (isRigidTy ty1 && isRigidTy ty2)+    || (ei_flavour item == Given)+    || null givens+  = -- If the equality is unconditionally insoluble+    -- or there is no context, don't report the context+    mkMismatchMsg item ty1 ty2++  | otherwise+  = CouldNotDeduce givens (item :| []) (Just $ CND_Extra level ty1 ty2)++  where+    level   = ctLocTypeOrKind_maybe (errorItemCtLoc item) `orElse` TypeLevel+    givens  = [ given | given <- getUserGivens ctxt, ic_given_eqs given /= NoGivenEqs ]+              -- Keep only UserGivens that have some equalities.+              -- See Note [Suppress redundant givens during error reporting]++-- These are for the "blocked" equalities, as described in TcCanonical+-- Note [Equalities with incompatible kinds], wrinkle (2). There should+-- always be another unsolved wanted around, which will ordinarily suppress+-- this message. But this can still be printed out with -fdefer-type-errors+-- (sigh), so we must produce a message.+mkBlockedEqErr :: ErrorItem -> TcSolverReportMsg+mkBlockedEqErr item = BlockedEquality item++{-+Note [Suppress redundant givens during error reporting]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When GHC is unable to solve a constraint and prints out an error message, it+will print out what given constraints are in scope to provide some context to+the programmer. But we shouldn't print out /every/ given, since some of them+are not terribly helpful to diagnose type errors. Consider this example:++  foo :: Int :~: Int -> a :~: b -> a :~: c+  foo Refl Refl = Refl++When reporting that GHC can't solve (a ~ c), there are two givens in scope:+(Int ~ Int) and (a ~ b). But (Int ~ Int) is trivially soluble (i.e.,+redundant), so it's not terribly useful to report it in an error message.+To accomplish this, we discard any Implications that do not bind any+equalities by filtering the `givens` selected in `misMatchOrCND` (based on+the `ic_given_eqs` field of the Implication). Note that we discard givens+that have no equalities whatsoever, but we want to keep ones with only *local*+equalities, as these may be helpful to the user in understanding what went+wrong.++But this is not enough to avoid all redundant givens! Consider this example,+from #15361:++  goo :: forall (a :: Type) (b :: Type) (c :: Type).+         a :~~: b -> a :~~: c+  goo HRefl = HRefl++Matching on HRefl brings the /single/ given (* ~ *, a ~ b) into scope.+The (* ~ *) part arises due the kinds of (:~~:) being unified. More+importantly, (* ~ *) is redundant, so we'd like not to report it. However,+the Implication (* ~ *, a ~ b) /does/ bind an equality (as reported by its+ic_given_eqs field), so the test above will keep it wholesale.++To refine this given, we apply mkMinimalBySCs on it to extract just the (a ~ b)+part. This works because mkMinimalBySCs eliminates reflexive equalities in+addition to superclasses (see Note [Remove redundant provided dicts]+in GHC.Tc.TyCl.PatSyn).+-}++extraTyVarEqInfo :: TcTyVar -> TcType -> TcM [TcSolverReportInfo]+-- Add on extra info about skolem constants+-- NB: The types themselves are already tidied+extraTyVarEqInfo tv1 ty2+  = (:) <$> extraTyVarInfo tv1 <*> ty_extra ty2+  where+    ty_extra ty = case tcGetCastedTyVar_maybe ty of+                    Just (tv, _) -> (:[]) <$> extraTyVarInfo tv+                    Nothing      -> return []++extraTyVarInfo :: TcTyVar -> TcM TcSolverReportInfo+extraTyVarInfo tv = assertPpr (isTyVar tv) (ppr tv) $+  case tcTyVarDetails tv of+    SkolemTv skol_info lvl overlaps -> do+      new_skol_info <- zonkSkolemInfo skol_info+      return $ TyVarInfo (mkTcTyVar (tyVarName tv) (tyVarKind tv) (SkolemTv new_skol_info lvl overlaps))+    _ -> return $ TyVarInfo tv+++suggestAddSig :: SolverReportErrCtxt -> TcType -> TcType -> Maybe GhcHint+-- See Note [Suggest adding a type signature]+suggestAddSig ctxt ty1 _ty2+  | bndr : bndrs <- inferred_bndrs+  = Just $ SuggestAddTypeSignatures $ NamedBindings (bndr :| bndrs)+  | otherwise+  = Nothing+  where+    inferred_bndrs =+      case tcGetTyVar_maybe ty1 of+        Just tv | isSkolemTyVar tv -> find (cec_encl ctxt) False tv+        _                          -> []++    -- 'find' returns the binders of an InferSkol for 'tv',+    -- provided there is an intervening implication with+    -- ic_given_eqs /= NoGivenEqs (i.e. a GADT match)+    find [] _ _ = []+    find (implic:implics) seen_eqs tv+       | tv `elem` ic_skols implic+       , InferSkol prs <- ic_info implic+       , seen_eqs+       = map fst prs+       | otherwise+       = find implics (seen_eqs || ic_given_eqs implic /= NoGivenEqs) tv++--------------------+mkMismatchMsg :: ErrorItem -> Type -> Type -> TcSolverReportMsg+mkMismatchMsg item ty1 ty2 =+  case orig of+    TypeEqOrigin { uo_actual, uo_expected, uo_thing = mb_thing } ->+      mkTcReportWithInfo+        (TypeEqMismatch+          { teq_mismatch_ppr_explicit_kinds = ppr_explicit_kinds+          , teq_mismatch_item = item+          , teq_mismatch_ty1  = ty1+          , teq_mismatch_ty2  = ty2+          , teq_mismatch_actual   = uo_actual+          , teq_mismatch_expected = uo_expected+          , teq_mismatch_what     = mb_thing})+        extras+    KindEqOrigin cty1 cty2 sub_o mb_sub_t_or_k ->+      mkTcReportWithInfo (Mismatch False item ty1 ty2)+        (WhenMatching cty1 cty2 sub_o mb_sub_t_or_k : extras)+    _ ->+      mkTcReportWithInfo+        (Mismatch False item ty1 ty2)+        extras+  where+    orig = errorItemOrigin item+    extras = sameOccExtras ty2 ty1+    ppr_explicit_kinds = shouldPprWithExplicitKinds ty1 ty2 orig++-- | Whether to print explicit kinds (with @-fprint-explicit-kinds@)+-- in an 'SDoc' when a type mismatch occurs to due invisible kind arguments.+--+-- This function first checks to see if the 'CtOrigin' argument is a+-- 'TypeEqOrigin'. If so, it first checks whether the equality is a visible+-- equality; if it's not, definitely print the kinds. Even if the equality is+-- a visible equality, check the expected/actual types to see if the types+-- have equal visible components. If the 'CtOrigin' is+-- not a 'TypeEqOrigin', fall back on the actual mismatched types themselves.+shouldPprWithExplicitKinds :: Type -> Type -> CtOrigin -> Bool+shouldPprWithExplicitKinds _ty1 _ty2 (TypeEqOrigin { uo_actual = act+                                                   , uo_expected = exp+                                                   , uo_visible = vis })+  | not vis   = True                  -- See tests T15870, T16204c+  | otherwise = tcEqTypeVis act exp   -- See tests T9171, T9144.+shouldPprWithExplicitKinds ty1 ty2 _ct+  = tcEqTypeVis ty1 ty2++{- Note [Insoluble occurs check]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider [G] a ~ [a],  [W] a ~ [a] (#13674).  The Given is insoluble+so we don't use it for rewriting.  The Wanted is also insoluble, and+we don't solve it from the Given.  It's very confusing to say+    Cannot solve a ~ [a] from given constraints a ~ [a]++And indeed even thinking about the Givens is silly; [W] a ~ [a] is+just as insoluble as Int ~ Bool.++Conclusion: if there's an insoluble occurs check (cteInsolubleOccurs)+then report it directly, not in the "cannot deduce X from Y" form.+This is done in misMatchOrCND (via the insoluble_occurs_check arg)++(NB: there are potentially-soluble ones, like (a ~ F a b), and we don't+want to be as draconian with them.)+-}++sameOccExtras :: TcType -> TcType -> [TcSolverReportInfo]+-- See Note [Disambiguating (X ~ X) errors]+sameOccExtras ty1 ty2+  | Just (tc1, _) <- tcSplitTyConApp_maybe ty1+  , Just (tc2, _) <- tcSplitTyConApp_maybe ty2+  , let n1 = tyConName tc1+        n2 = tyConName tc2+        same_occ = nameOccName n1                   == nameOccName n2+        same_pkg = moduleUnit (nameModule n1) == moduleUnit (nameModule n2)+  , n1 /= n2   -- Different Names+  , same_occ   -- but same OccName+  = [SameOcc same_pkg n1 n2]+  | otherwise+  = []++{- Note [Suggest adding a type signature]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The OutsideIn algorithm rejects GADT programs that don't have a principal+type, and indeed some that do.  Example:+   data T a where+     MkT :: Int -> T Int++   f (MkT n) = n++Does this have type f :: T a -> a, or f :: T a -> Int?+The error that shows up tends to be an attempt to unify an+untouchable type variable.  So suggestAddSig sees if the offending+type variable is bound by an *inferred* signature, and suggests+adding a declared signature instead.++More specifically, we suggest adding a type sig if we have p ~ ty, and+p is a skolem bound by an InferSkol.  Those skolems were created from+unification variables in simplifyInfer.  Why didn't we unify?  It must+have been because of an intervening GADT or existential, making it+untouchable. Either way, a type signature would help.  For GADTs, it+might make it typeable; for existentials the attempt to write a+signature will fail -- or at least will produce a better error message+next time++This initially came up in #8968, concerning pattern synonyms.++Note [Disambiguating (X ~ X) errors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+See #8278++Note [Reporting occurs-check errors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Given (a ~ [a]), if 'a' is a rigid type variable bound by a user-supplied+type signature, then the best thing is to report that we can't unify+a with [a], because a is a skolem variable.  That avoids the confusing+"occur-check" error message.++But nowadays when inferring the type of a function with no type signature,+even if there are errors inside, we still generalise its signature and+carry on. For example+   f x = x:x+Here we will infer something like+   f :: forall a. a -> [a]+with a deferred error of (a ~ [a]).  So in the deferred unsolved constraint+'a' is now a skolem, but not one bound by the programmer in the context!+Here we really should report an occurs check.++So isUserSkolem distinguishes the two.++Note [Non-injective type functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's very confusing to get a message like+     Couldn't match expected type `Depend s'+            against inferred type `Depend s1'+so mkTyFunInfoMsg adds:+       NB: `Depend' is type function, and hence may not be injective++Warn of loopy local equalities that were dropped.+++************************************************************************+*                                                                      *+                 Type-class errors+*                                                                      *+************************************************************************+-}++mkDictErr :: HasDebugCallStack => SolverReportErrCtxt -> [ErrorItem] -> TcM SolverReport+mkDictErr ctxt orig_items+  = assert (not (null items)) $+    do { inst_envs <- tcGetInstEnvs+       ; let min_items = elim_superclasses items+             lookups = map (lookup_cls_inst inst_envs) min_items+             (no_inst_items, overlap_items) = partition is_no_inst lookups++       -- Report definite no-instance errors,+       -- or (iff there are none) overlap errors+       -- But we report only one of them (hence 'head') because they all+       -- have the same source-location origin, to try avoid a cascade+       -- of error from one location+       ; err <- mk_dict_err ctxt (head (no_inst_items ++ overlap_items))+       ; return $ important ctxt err }+  where+    filtered_items = filter (not . ei_suppress) orig_items+    items | null filtered_items = orig_items  -- all suppressed, but must report+                                              -- something for -fdefer-type-errors+          | otherwise           = filtered_items  -- common case++    no_givens = null (getUserGivens ctxt)++    is_no_inst (item, (matches, unifiers, _))+      =  no_givens+      && null matches+      && (nullUnifiers unifiers || all (not . isAmbiguousTyVar) (tyCoVarsOfTypeList (errorItemPred item)))++    lookup_cls_inst inst_envs item+      = (item, lookupInstEnv True inst_envs clas tys)+      where+        (clas, tys) = getClassPredTys (errorItemPred item)+++    -- When simplifying [W] Ord (Set a), we need+    --    [W] Eq a, [W] Ord a+    -- but we really only want to report the latter+    elim_superclasses items = mkMinimalBySCs errorItemPred items++-- Note [mk_dict_err]+-- ~~~~~~~~~~~~~~~~~~~+-- Different dictionary error messages are reported depending on the number of+-- matches and unifiers:+--+--   - No matches, regardless of unifiers: report "No instance for ...".+--   - Two or more matches, regardless of unifiers: report "Overlapping instances for ...",+--     and show the matching and unifying instances.+--   - One match, one or more unifiers: report "Overlapping instances for", show the+--     matching and unifying instances, and say "The choice depends on the instantion of ...,+--     and the result of evaluating ...".+mk_dict_err :: HasCallStack => SolverReportErrCtxt -> (ErrorItem, ClsInstLookupResult)+            -> TcM TcSolverReportMsg+-- Report an overlap error if this class constraint results+-- from an overlap (returning Left clas), otherwise return (Right pred)+mk_dict_err ctxt (item, (matches, unifiers, unsafe_overlapped))+  | null matches  -- No matches but perhaps several unifiers+  = do { (_, rel_binds, item) <- relevantBindings True ctxt item+       ; candidate_insts <- get_candidate_instances+       ; (imp_errs, field_suggestions) <- record_field_suggestions+       ; return (cannot_resolve_msg item candidate_insts rel_binds imp_errs field_suggestions) }++  | null unsafe_overlapped   -- Some matches => overlap errors+  = return $ overlap_msg++  | otherwise+  = return $ safe_haskell_msg+  where+    orig          = errorItemOrigin item+    pred          = errorItemPred item+    (clas, tys)   = getClassPredTys pred+    ispecs        = [ispec | (ispec, _) <- matches]+    unsafe_ispecs = [ispec | (ispec, _) <- unsafe_overlapped]++    get_candidate_instances :: TcM [ClsInst]+    -- See Note [Report candidate instances]+    get_candidate_instances+      | [ty] <- tys   -- Only try for single-parameter classes+      = do { instEnvs <- tcGetInstEnvs+           ; return (filter (is_candidate_inst ty)+                            (classInstances instEnvs clas)) }+      | otherwise = return []++    is_candidate_inst ty inst -- See Note [Report candidate instances]+      | [other_ty] <- is_tys inst+      , Just (tc1, _) <- tcSplitTyConApp_maybe ty+      , Just (tc2, _) <- tcSplitTyConApp_maybe other_ty+      = let n1 = tyConName tc1+            n2 = tyConName tc2+            different_names = n1 /= n2+            same_occ_names = nameOccName n1 == nameOccName n2+        in different_names && same_occ_names+      | otherwise = False++    -- See Note [Out-of-scope fields with -XOverloadedRecordDot]+    record_field_suggestions :: TcM ([ImportError], [GhcHint])+    record_field_suggestions = flip (maybe $ return ([], noHints)) record_field $ \name ->+       do { glb_env <- getGlobalRdrEnv+          ; lcl_env <- getLocalRdrEnv+          ; if occ_name_in_scope glb_env lcl_env name+            then return ([], noHints)+            else do { dflags   <- getDynFlags+                    ; imp_info <- getImports+                    ; curr_mod <- getModule+                    ; hpt      <- getHpt+                    ; return (unknownNameSuggestions WL_RecField dflags hpt curr_mod+                        glb_env emptyLocalRdrEnv imp_info (mkRdrUnqual name)) } }++    occ_name_in_scope glb_env lcl_env occ_name = not $+      null (lookupGlobalRdrEnv glb_env occ_name) &&+      isNothing (lookupLocalRdrOcc lcl_env occ_name)++    record_field = case orig of+      HasFieldOrigin name -> Just (mkVarOccFS name)+      _                   -> Nothing++    cannot_resolve_msg :: ErrorItem -> [ClsInst] -> RelevantBindings+                       -> [ImportError] -> [GhcHint] -> TcSolverReportMsg+    cannot_resolve_msg item candidate_insts binds imp_errs field_suggestions+      = CannotResolveInstance item (getPotentialUnifiers unifiers) candidate_insts imp_errs field_suggestions binds++    -- Overlap errors.+    overlap_msg, safe_haskell_msg :: TcSolverReportMsg+    -- Normal overlap error+    overlap_msg+      = assert (not (null matches)) $ OverlappingInstances item ispecs (getPotentialUnifiers unifiers)++    -- Overlap error because of Safe Haskell (first+    -- match should be the most specific match)+    safe_haskell_msg+     = assert (matches `lengthIs` 1 && not (null unsafe_ispecs)) $+       UnsafeOverlap item ispecs unsafe_ispecs++{- Note [Report candidate instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we have an unsolved (Num Int), where `Int` is not the Prelude Int,+but comes from some other module, then it may be helpful to point out+that there are some similarly named instances elsewhere.  So we get+something like+    No instance for (Num Int) arising from the literal ‘3’+    There are instances for similar types:+      instance Num GHC.Types.Int -- Defined in ‘GHC.Num’+Discussion in #9611.++Note [Highlighting ambiguous type variables]+~-------------------------------------------+When we encounter ambiguous type variables (i.e. type variables+that remain metavariables after type inference), we need a few more+conditions before we can reason that *ambiguity* prevents constraints+from being solved:+  - We can't have any givens, as encountering a typeclass error+    with given constraints just means we couldn't deduce+    a solution satisfying those constraints and as such couldn't+    bind the type variable to a known type.+  - If we don't have any unifiers, we don't even have potential+    instances from which an ambiguity could arise.+  - Lastly, I don't want to mess with error reporting for+    unknown runtime types so we just fall back to the old message there.+Once these conditions are satisfied, we can safely say that ambiguity prevents+the constraint from being solved.++Note [Out-of-scope fields with -XOverloadedRecordDot]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+With -XOverloadedRecordDot, when a field isn't in scope, the error that appears+is produces here, and it says+    No instance for (GHC.Record.HasField "<fieldname>" ...).++Additionally, though, we want to suggest similar field names that are in scope+or could be in scope with different import lists.++However, we can still get an error about a missing HasField instance when a+field is in scope (if the types are wrong), and so it's important that we don't+suggest similar names here if the record field is in scope, either qualified or+unqualified, since qualification doesn't matter for -XOverloadedRecordDot.++Example:++    import Data.Monoid (Alt(..))++    foo = undefined.getAll++results in++     No instance for (GHC.Records.HasField "getAll" r0 a0)+        arising from selecting the field ‘getAll’+      Perhaps you meant ‘getAlt’ (imported from Data.Monoid)+      Perhaps you want to add ‘getAll’ to the import list+      in the import of ‘Data.Monoid’+-}++{-+Note [Kind arguments in error messages]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It can be terribly confusing to get an error message like (#9171)++    Couldn't match expected type ‘GetParam Base (GetParam Base Int)’+                with actual type ‘GetParam Base (GetParam Base Int)’++The reason may be that the kinds don't match up.  Typically you'll get+more useful information, but not when it's as a result of ambiguity.++To mitigate this, GHC attempts to enable the -fprint-explicit-kinds flag+whenever any error message arises due to a kind mismatch. This means that+the above error message would instead be displayed as:++    Couldn't match expected type+                  ‘GetParam @* @k2 @* Base (GetParam @* @* @k2 Base Int)’+                with actual type+                  ‘GetParam @* @k20 @* Base (GetParam @* @* @k20 Base Int)’++Which makes it clearer that the culprit is the mismatch between `k2` and `k20`.+-}++-----------------------+-- relevantBindings looks at the value environment and finds values whose+-- types mention any of the offending type variables.  It has to be+-- careful to zonk the Id's type first, so it has to be in the monad.+-- We must be careful to pass it a zonked type variable, too.+--+-- We always remove closed top-level bindings, though,+-- since they are never relevant (cf #8233)++relevantBindings :: Bool  -- True <=> filter by tyvar; False <=> no filtering+                          -- See #8191+                 -> SolverReportErrCtxt -> ErrorItem+                 -> TcM (SolverReportErrCtxt, RelevantBindings, ErrorItem)+-- Also returns the zonked and tidied CtOrigin of the constraint+relevantBindings want_filtering ctxt item+  = do { traceTc "relevantBindings" (ppr item)+       ; (env1, tidy_orig) <- zonkTidyOrigin (cec_tidy ctxt) (ctLocOrigin loc)++             -- For *kind* errors, report the relevant bindings of the+             -- enclosing *type* equality, because that's more useful for the programmer+       ; let extra_tvs = case tidy_orig of+                             KindEqOrigin t1 t2 _ _ -> tyCoVarsOfTypes [t1,t2]+                             _                      -> emptyVarSet+             ct_fvs = tyCoVarsOfType (errorItemPred item) `unionVarSet` extra_tvs++             -- Put a zonked, tidied CtOrigin into the ErrorItem+             loc'   = setCtLocOrigin loc tidy_orig+             item'  = item { ei_loc = loc' }++       ; (env2, lcl_name_cache) <- zonkTidyTcLclEnvs env1 [lcl_env]++       ; relev_bds <- relevant_bindings want_filtering lcl_env lcl_name_cache ct_fvs+       ; let ctxt'  = ctxt { cec_tidy = env2 }+       ; return (ctxt', relev_bds, item') }+  where+    loc     = errorItemCtLoc item+    lcl_env = ctLocEnv loc++-- slightly more general version, to work also with holes+relevant_bindings :: Bool+                  -> TcLclEnv+                  -> NameEnv Type -- Cache of already zonked and tidied types+                  -> TyCoVarSet+                  -> TcM RelevantBindings+relevant_bindings want_filtering lcl_env lcl_name_env ct_tvs+  = do { dflags <- getDynFlags+       ; traceTc "relevant_bindings" $+           vcat [ ppr ct_tvs+                , pprWithCommas id [ ppr id <+> dcolon <+> ppr (idType id)+                                   | TcIdBndr id _ <- tcl_bndrs lcl_env ]+                , pprWithCommas id+                    [ ppr id | TcIdBndr_ExpType id _ _ <- tcl_bndrs lcl_env ] ]++       ; go dflags (maxRelevantBinds dflags)+                    emptyVarSet (RelevantBindings [] False)+                    (removeBindingShadowing $ tcl_bndrs lcl_env)+         -- tcl_bndrs has the innermost bindings first,+         -- which are probably the most relevant ones+  }+  where+    run_out :: Maybe Int -> Bool+    run_out Nothing = False+    run_out (Just n) = n <= 0++    dec_max :: Maybe Int -> Maybe Int+    dec_max = fmap (\n -> n - 1)+++    go :: DynFlags -> Maybe Int -> TcTyVarSet+       -> RelevantBindings+       -> [TcBinder]+       -> TcM RelevantBindings+    go _ _ _ (RelevantBindings bds discards) []+      = return $ RelevantBindings (reverse bds) discards+    go dflags n_left tvs_seen rels@(RelevantBindings bds discards) (tc_bndr : tc_bndrs)+      = case tc_bndr of+          TcTvBndr {} -> discard_it+          TcIdBndr id top_lvl -> go2 (idName id) top_lvl+          TcIdBndr_ExpType name et top_lvl ->+            do { mb_ty <- readExpType_maybe et+                   -- et really should be filled in by now. But there's a chance+                   -- it hasn't, if, say, we're reporting a kind error en route to+                   -- checking a term. See test indexed-types/should_fail/T8129+                   -- Or we are reporting errors from the ambiguity check on+                   -- a local type signature+               ; case mb_ty of+                   Just _ty -> go2 name top_lvl+                   Nothing -> discard_it  -- No info; discard+               }+      where+        discard_it = go dflags n_left tvs_seen rels tc_bndrs+        go2 id_name top_lvl+          = do { let tidy_ty = case lookupNameEnv lcl_name_env id_name of+                                  Just tty -> tty+                                  Nothing -> pprPanic "relevant_bindings" (ppr id_name)+               ; traceTc "relevantBindings 1" (ppr id_name <+> dcolon <+> ppr tidy_ty)+               ; let id_tvs = tyCoVarsOfType tidy_ty+                     bd = (id_name, tidy_ty)+                     new_seen = tvs_seen `unionVarSet` id_tvs++               ; if (want_filtering && not (hasPprDebug dflags)+                                    && id_tvs `disjointVarSet` ct_tvs)+                          -- We want to filter out this binding anyway+                          -- so discard it silently+                 then discard_it++                 else if isTopLevel top_lvl && not (isNothing n_left)+                          -- It's a top-level binding and we have not specified+                          -- -fno-max-relevant-bindings, so discard it silently+                 then discard_it++                 else if run_out n_left && id_tvs `subVarSet` tvs_seen+                          -- We've run out of n_left fuel and this binding only+                          -- mentions already-seen type variables, so discard it+                 then go dflags n_left tvs_seen (RelevantBindings bds True) -- Record that we have now discarded something+                         tc_bndrs++                          -- Keep this binding, decrement fuel+                 else go dflags (dec_max n_left) new_seen+                         (RelevantBindings (bd:bds) discards) tc_bndrs }++-----------------------+warnDefaulting :: TcTyVar -> [Ct] -> Type -> TcM ()+warnDefaulting _ [] _+  = panic "warnDefaulting: empty Wanteds"+warnDefaulting the_tv wanteds@(ct:_) default_ty+  = do { warn_default <- woptM Opt_WarnTypeDefaults+       ; env0 <- tcInitTidyEnv+            -- don't want to report all the superclass constraints, which+            -- add unhelpful clutter+       ; let filtered = filter (not . isWantedSuperclassOrigin . ctOrigin) wanteds+             tidy_env = tidyFreeTyCoVars env0 $+                        tyCoVarsOfCtsList (listToBag filtered)+             tidy_wanteds = map (tidyCt tidy_env) filtered+             tidy_tv = lookupVarEnv (snd tidy_env) the_tv+             diag = TcRnWarnDefaulting tidy_wanteds tidy_tv default_ty+             loc = ctLoc ct+       ; setCtLocM loc $ diagnosticTc warn_default diag }++{-+Note [Runtime skolems]+~~~~~~~~~~~~~~~~~~~~~~+We want to give a reasonably helpful error message for ambiguity+arising from *runtime* skolems in the debugger.  These+are created by in GHC.Runtime.Heap.Inspect.zonkRTTIType.+-}++{-**********************************************************************+*                                                                      *+                      GHC API helper functions+*                                                                      *+**********************************************************************-}++-- | If the 'TcSolverReportMsg' is a type mismatch between+-- an actual and an expected type, return the actual and expected types+-- (in that order).+--+-- Prefer using this over manually inspecting the 'TcSolverReportMsg' datatype+-- if you just want this information, as the datatype itself is subject to change+-- across GHC versions.+solverReportMsg_ExpectedActuals :: TcSolverReportMsg -> [(Type, Type)]+solverReportMsg_ExpectedActuals+  = \case+    TcReportWithInfo msg infos ->+      solverReportMsg_ExpectedActuals msg+      ++ (solverReportInfo_ExpectedActuals =<< toList infos)+    Mismatch { mismatch_ty1 = exp, mismatch_ty2 = act } ->+      [(exp, act)]+    KindMismatch { kmismatch_expected = exp, kmismatch_actual = act } ->+      [(exp, act)]+    TypeEqMismatch { teq_mismatch_expected = exp, teq_mismatch_actual = act } ->+      [(exp,act)]+    _ -> []++-- | Retrieves all @"expected"/"actual"@ messages from a 'TcSolverReportInfo'.+--+-- Prefer using this over inspecting the 'TcSolverReportInfo' datatype if+-- you just need this information, as the datatype itself is subject to change+-- across GHC versions.+solverReportInfo_ExpectedActuals :: TcSolverReportInfo -> [(Type, Type)]+solverReportInfo_ExpectedActuals+  = \case+    ExpectedActual { ea_expected = exp, ea_actual = act } ->+      [(exp, act)]+    ExpectedActualAfterTySynExpansion+      { ea_expanded_expected = exp, ea_expanded_actual = act } ->+      [(exp, act)]+    _ -> []
GHC/Tc/Errors/Hole.hs view
@@ -1,7 +1,9 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ExistentialQuantification #-}+ {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}+ module GHC.Tc.Errors.Hole    ( findValidHoleFits    , tcCheckHoleFit@@ -16,7 +18,7 @@    , getHoleFitDispConfig    , HoleFitDispConfig (..)    , HoleFitSortingAlg (..)-   , relevantCts+   , relevantCtEvidence    , zonkSubs     , sortHoleFitsByGraph@@ -30,6 +32,8 @@  import GHC.Prelude +import GHC.Tc.Errors.Types ( HoleFitDispConfig(..), FitsMbSuppressed(..)+                           , ValidHoleFits(..), noValidHoleFits ) import GHC.Tc.Types import GHC.Tc.Utils.Monad import GHC.Tc.Types.Constraint@@ -64,18 +68,23 @@ import Data.Graph       ( graphFromEdges, topSort )  -import GHC.Tc.Solver    ( simplifyTopWanteds, runTcSDeriveds )+import GHC.Tc.Solver    ( simplifyTopWanteds )+import GHC.Tc.Solver.Monad ( runTcSEarlyAbort ) import GHC.Tc.Utils.Unify ( tcSubTypeSigma )  import GHC.HsToCore.Docs ( extractDocs )-import qualified Data.Map as Map-import GHC.Hs.Doc      ( unpackHDS, DeclDocMap(..) )+import GHC.Hs.Doc import GHC.Unit.Module.ModIface ( ModIface_(..) )-import GHC.Iface.Load  ( loadInterfaceForNameMaybe )+import GHC.Iface.Load  ( loadInterfaceForName )  import GHC.Builtin.Utils (knownKeyNames)  import GHC.Tc.Errors.Hole.FitTypes+import qualified Data.Set as Set+import GHC.Types.SrcLoc+import GHC.Utils.Trace (warnPprTrace)+import GHC.Data.FastString (unpackFS)+import GHC.Types.Unique.Map   {-@@ -185,7 +194,7 @@       Given = $dShow_a1pc :: Show a_a1pa[sk:2]       Wanted =         WC {wc_simple =-              [WD] $dShow_a1pe {0}:: Show a0_a1pd[tau:2] (CDictCan(psc))}+              [W] $dShow_a1pe {0}:: Show a0_a1pd[tau:2] (CDictCan(psc))}       Binds = EvBindsVar<a1pi>       Needed inner = []       Needed outer = []@@ -201,7 +210,7 @@ `tcCheckHoleFit`, the call to `tcSubType` will end up unifying the meta type variable `a0_a1pd[tau:2] := a_a1pa[sk:2]`. By wrapping the wanted constraints needed by tcSubType_NC and the relevant constraints (see Note [Relevant-Constraints] for more details) in the nested implications, we can pass the+constraints] for more details) in the nested implications, we can pass the information in the givens along to the simplifier. For our example, we end up needing to check whether the following constraints are soluble. @@ -214,7 +223,7 @@           Given = $dShow_a1pc :: Show a_a1pa[sk:2]           Wanted =             WC {wc_simple =-                  [WD] $dShow_a1pe {0}:: Show a0_a1pd[tau:2] (CNonCanonical)}+                  [W] $dShow_a1pe {0}:: Show a0_a1pd[tau:2] (CNonCanonical)}           Binds = EvBindsVar<a1pl>           Needed inner = []           Needed outer = []@@ -357,7 +366,7 @@  Here, the hole is given type a0_a1kv[tau:1]. Then, the emitted constraint is: -  [WD] $dShow_a1kw {0}:: Show a0_a1kv[tau:1] (CNonCanonical)+  [W] $dShow_a1kw {0}:: Show a0_a1kv[tau:1] (CNonCanonical)  However, when there are multiple holes, we need to be more careful. As an example, Let's take a look at the following code:@@ -369,8 +378,8 @@ _b :: a1_a1po[tau:2]. Then, the simple constraints passed to findValidHoleFits are: -  [[WD] $dShow_a1pe {0}:: Show a0_a1pd[tau:2] (CNonCanonical),-    [WD] $dShow_a1pp {0}:: Show a1_a1po[tau:2] (CNonCanonical)]+  [[W] $dShow_a1pe {0}:: Show a0_a1pd[tau:2] (CNonCanonical),+    [W] $dShow_a1pp {0}:: Show a1_a1po[tau:2] (CNonCanonical)]  When we are looking for a match for the hole `_a`, we filter the simple constraints to the "Relevant constraints", by throwing out any constraints@@ -389,14 +398,28 @@ would cause the type checker to error, it is not a valid hole fit, and thus it is discarded. --}+Note [Speeding up valid hole-fits]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+To fix #16875 we noted that a lot of time was being spent on uneccessary work. -data HoleFitDispConfig = HFDC { showWrap :: Bool-                              , showWrapVars :: Bool-                              , showType :: Bool-                              , showProv :: Bool-                              , showMatches :: Bool }+When we'd call `tcCheckHoleFit hole hole_ty ty`, we would end up by generating+a constraint to show that `hole_ty ~ ty`, including any constraints in `ty`. For+example, if `hole_ty = Int` and `ty = Foldable t => (a -> Bool) -> t a -> Bool`,+we'd have `(a_a1pa[sk:1] -> Bool) -> t_t2jk[sk:1] a_a1pa[sk:1] -> Bool ~# Int`+from the coercion, as well as `Foldable t_t2jk[sk:1]`. By adding a flag to+`TcSEnv` and adding a `runTcSEarlyAbort`, we can fail as soon as we hit+an insoluble constraint. Since we don't need the result in the case that it+fails, a boolean `False` (i.e. "it didn't work" from `runTcSEarlyAbort`)+is sufficient. +We also check whether the type of the hole is an immutable type variable (i.e.+a skolem). In that case, the only possible fits are fits of exactly that type,+which can only come from the locals. This speeds things up quite a bit when we+don't know anything about the type of the hole. This also helps with degenerate+fits like (`id (_ :: a)` and `head (_ :: [a])`) when looking for fits of type+`a`, where `a` is a skolem.+-}+ -- We read the various -no-show-*-of-hole-fits flags -- and set the display config accordingly. getHoleFitDispConfig :: TcM HoleFitDispConfig@@ -437,21 +460,40 @@ addHoleFitDocs fits =   do { showDocs <- goptM Opt_ShowDocsOfHoleFits      ; if showDocs-       then do { (_, DeclDocMap lclDocs, _) <- getGblEnv >>= extractDocs-               ; mapM (upd lclDocs) fits }+       then do { dflags <- getDynFlags+               ; mb_local_docs <- extractDocs dflags =<< getGblEnv+               ; (mods_without_docs, fits') <- mapAccumM (upd mb_local_docs) Set.empty fits+               ; report mods_without_docs+               ; return fits' }        else return fits }   where    msg = text "GHC.Tc.Errors.Hole addHoleFitDocs"-   lookupInIface name (ModIface { mi_decl_docs = DeclDocMap dmap })-     = Map.lookup name dmap-   upd lclDocs fit@(HoleFit {hfCand = cand}) =-        do { let name = getName cand-           ; doc <- if hfIsLcl fit-                    then pure (Map.lookup name lclDocs)-                    else do { mbIface <- loadInterfaceForNameMaybe msg name-                            ; return $ mbIface >>= lookupInIface name }-           ; return $ fit {hfDoc = doc} }-   upd _ fit = return fit+   upd mb_local_docs mods_without_docs fit@(HoleFit {hfCand = cand}) =+     let name = getName cand in+     do { mb_docs <- if hfIsLcl fit+                     then pure mb_local_docs+                     else mi_docs <$> loadInterfaceForName msg name+        ; case mb_docs of+            { Nothing -> return (Set.insert (nameOrigin name) mods_without_docs, fit)+            ; Just docs -> do+                { let doc = lookupUniqMap (docs_decls docs) name+                ; return $ (mods_without_docs, fit {hfDoc = map hsDocString <$> doc}) }}}+   upd _ mods_without_docs fit = pure (mods_without_docs, fit)+   nameOrigin name = case nameModule_maybe name of+     Just m  -> Right m+     Nothing ->+       Left $ case nameSrcLoc name of+         RealSrcLoc r _ -> unpackFS $ srcLocFile r+         UnhelpfulLoc s -> unpackFS $ s+   report mods = do+     { let warning =+             text "WARNING: Couldn't find any documentation for the following modules:" $+$+             nest 2+                  (fsep (punctuate comma+                                   (either text ppr <$> Set.toList mods)) $+$+                   text "Make sure the modules are compiled with '-haddock'.")+     ; warnPprTrace (not $ Set.null mods)"addHoleFitDocs" warning (pure ())+     }  -- For pretty printing hole fits, we display the name and type of the fit, -- with added '_' to represent any extra arguments in case of a non-zero@@ -462,12 +504,10 @@  hang display 2 provenance  where tyApp = sep $ zipWithEqual "pprHoleFit" pprArg vars hfWrap          where pprArg b arg = case binderArgFlag b of-                                -- See Note [Explicit Case Statement for Specificity]-                                (Invisible spec) -> case spec of-                                  SpecifiedSpec -> text "@" <> pprParendType arg+                                Specified -> text "@" <> pprParendType arg                                   -- Do not print type application for inferred                                   -- variables (#16456)-                                  InferredSpec  -> empty+                                Inferred  -> empty                                 Required  -> pprPanic "pprHoleFit: bad Required"                                                          (ppr b <+> ppr arg)        tyAppVars = sep $ punctuate comma $@@ -500,9 +540,7 @@                                      then occDisp <+> tyApp                                      else tyAppVars        docs = case hfDoc of-                Just d -> text "{-^" <>-                          (vcat . map text . lines . unpackHDS) d-                          <> text "-}"+                Just d -> pprHsDocStrings d                 _ -> empty        funcInfo = ppWhen (has hfMatches && sTy) $                     text "where" <+> occDisp <+> tyDisp@@ -536,25 +574,24 @@ -- See Note [Valid hole fits include ...] findValidHoleFits :: TidyEnv        -- ^ The tidy_env for zonking                   -> [Implication]  -- ^ Enclosing implications for givens-                  -> [Ct]+                  -> [CtEvidence]                   -- ^ The  unsolved simple constraints in the implication for                   -- the hole.                   -> Hole-                  -> TcM (TidyEnv, SDoc)+                  -> TcM (TidyEnv, ValidHoleFits) findValidHoleFits tidy_env implics simples h@(Hole { hole_sort = ExprHole _                                                    , hole_loc  = ct_loc                                                    , hole_ty   = hole_ty }) =   do { rdr_env <- getGlobalRdrEnv      ; lclBinds <- getLocalBindings tidy_env ct_loc      ; maxVSubs <- maxValidHoleFits <$> getDynFlags-     ; hfdc <- getHoleFitDispConfig      ; sortingAlg <- getHoleFitSortingAlg      ; dflags <- getDynFlags      ; hfPlugs <- tcg_hf_plugins <$> getGblEnv      ; let findVLimit = if sortingAlg > HFSNoSorting then Nothing else maxVSubs            refLevel = refLevelHoleFits dflags            hole = TypedHole { th_relevant_cts =-                                listToBag (relevantCts hole_ty simples)+                                listToBag (relevantCtEvidence hole_ty simples)                             , th_implics      = implics                             , th_hole         = Just h }            (candidatePlugins, fitPlugins) =@@ -572,7 +609,11 @@                       map IdHFCand lclBinds ++ map GreHFCand lcl            globals = map GreHFCand gbl            syntax = map NameHFCand builtIns-           to_check = locals ++ syntax ++ globals+           -- If the hole is a rigid type-variable, then we only check the+           -- locals, since only they can match the type (in a meaningful way).+           only_locals = any isImmutableTyVar $ getTyVar_maybe hole_ty+           to_check = if only_locals then locals+                      else locals ++ syntax ++ globals      ; cands <- foldM (flip ($)) to_check candidatePlugins      ; traceTc "numPlugins are:" $ ppr (length candidatePlugins)      ; (searchDiscards, subs) <-@@ -583,12 +624,11 @@      ; let (pVDisc, limited_subs) = possiblyDiscard maxVSubs plugin_handled_subs            vDiscards = pVDisc || searchDiscards      ; subs_with_docs <- addHoleFitDocs limited_subs-     ; let vMsg = ppUnless (null subs_with_docs) $-                    hang (text "Valid hole fits include") 2 $-                      vcat (map (pprHoleFit hfdc) subs_with_docs)-                        $$ ppWhen vDiscards subsDiscardMsg+     ; let subs = Fits subs_with_docs vDiscards      -- Refinement hole fits. See Note [Valid refinement hole fits include ...]-     ; (tidy_env, refMsg) <- if refLevel >= Just 0 then+     ; (tidy_env, rsubs) <-+       if refLevel >= Just 0+       then          do { maxRSubs <- maxRefHoleFits <$> getDynFlags             -- We can use from just, since we know that Nothing >= _ is False.             ; let refLvls = [1..(fromJust refLevel)]@@ -616,14 +656,11 @@                     possiblyDiscard maxRSubs $ plugin_handled_rsubs                   rDiscards = pRDisc || any fst refDs             ; rsubs_with_docs <- addHoleFitDocs exact_last_rfits-            ; return (tidy_env,-                ppUnless (null rsubs_with_docs) $-                  hang (text "Valid refinement hole fits include") 2 $-                  vcat (map (pprHoleFit hfdc) rsubs_with_docs)-                    $$ ppWhen rDiscards refSubsDiscardMsg) }-       else return (tidy_env, empty)+            ; return (tidy_env, Fits rsubs_with_docs rDiscards) }+       else return (tidy_env, Fits [] False)      ; traceTc "findingValidHoleFitsFor }" empty-     ; return (tidy_env, vMsg $$ refMsg) }+     ; let hole_fits = ValidHoleFits subs rsubs+     ; return (tidy_env, hole_fits) }   where     -- We extract the TcLevel from the constraint.     hole_lvl = ctLocLevel ct_loc@@ -664,19 +701,6 @@                <*> sortHoleFitsByGraph (sort gblFits)         where (lclFits, gblFits) = span hfIsLcl subs -    subsDiscardMsg :: SDoc-    subsDiscardMsg =-        text "(Some hole fits suppressed;" <+>-        text "use -fmax-valid-hole-fits=N" <+>-        text "or -fno-max-valid-hole-fits)"--    refSubsDiscardMsg :: SDoc-    refSubsDiscardMsg =-        text "(Some refinement hole fits suppressed;" <+>-        text "use -fmax-refinement-hole-fits=N" <+>-        text "or -fno-max-refinement-hole-fits)"--     -- Based on the flags, we might possibly discard some or all the     -- fits we've found.     possiblyDiscard :: Maybe Int -> [HoleFit] -> (Bool, [HoleFit])@@ -685,24 +709,23 @@   -- We don't (as of yet) handle holes in types, only in expressions.-findValidHoleFits env _ _ _ = return (env, empty)+findValidHoleFits env _ _ _ = return (env, noValidHoleFits)  -- See Note [Relevant constraints]-relevantCts :: Type -> [Ct] -> [Ct]-relevantCts hole_ty simples = if isEmptyVarSet (fvVarSet hole_fvs) then []-                              else filter isRelevant simples-  where ctFreeVarSet :: Ct -> VarSet-        ctFreeVarSet = fvVarSet . tyCoFVsOfType . ctPred-        hole_fvs = tyCoFVsOfType hole_ty+relevantCtEvidence :: Type -> [CtEvidence] -> [CtEvidence]+relevantCtEvidence hole_ty simples+  = if isEmptyVarSet (fvVarSet hole_fvs)+    then []+    else filter isRelevant simples+  where hole_fvs = tyCoFVsOfType hole_ty         hole_fv_set = fvVarSet hole_fvs-        anyFVMentioned :: Ct -> Bool-        anyFVMentioned ct = ctFreeVarSet ct `intersectsVarSet` hole_fv_set         -- We filter out those constraints that have no variables (since         -- they won't be solved by finding a type for the type variable         -- representing the hole) and also other holes, since we're not         -- trying to find hole fits for many holes at once.-        isRelevant ct = not (isEmptyVarSet (ctFreeVarSet ct))-                        && anyFVMentioned ct+        isRelevant ctev = not (isEmptyVarSet fvs) &&+                          (fvs `intersectsVarSet` hole_fv_set)+          where fvs = tyCoVarsOfCtEv ctev  -- We zonk the hole fits so that the output aligns with the rest -- of the typed hole error message output.@@ -874,7 +897,6 @@          ; traceTc "Did it fit?" $ ppr fits          ; traceTc "wrap is: " $ ppr wrp          ; traceTc "checkingFitOf }" empty-         ; z_wrp_tys <- zonkTcTypes (unfoldWrapper wrp)          -- We'd like to avoid refinement suggestions like `id _ _` or          -- `head _ _`, and only suggest refinements where our all phantom          -- variables got unified during the checking. This can be disabled@@ -883,24 +905,26 @@          -- variables, i.e. zonk them to read their final value to check for          -- abstract refinements, and to report what the type of the simulated          -- holes must be for this to be a match.-         ; if fits-           then if null ref_vars-                then return (Just (z_wrp_tys, []))-                else do { let -- To be concrete matches, matches have to-                              -- be more than just an invented type variable.-                              fvSet = fvVarSet fvs-                              notAbstract :: TcType -> Bool-                              notAbstract t = case getTyVar_maybe t of-                                                Just tv -> tv `elemVarSet` fvSet-                                                _ -> True-                              allConcrete = all notAbstract z_wrp_tys-                        ; z_vars  <- zonkTcTyVars ref_vars-                        ; let z_mtvs = mapMaybe tcGetTyVar_maybe z_vars-                        ; allFilled <- not <$> anyM isFlexiTyVar z_mtvs-                        ; allowAbstract <- goptM Opt_AbstractRefHoleFits-                        ; if allowAbstract || (allFilled && allConcrete )-                          then return $ Just (z_wrp_tys, z_vars)-                          else return Nothing }+         ; if fits then do {+              -- Zonking is expensive, so we only do it if required.+              z_wrp_tys <- zonkTcTypes (unfoldWrapper wrp)+            ; if null ref_vars+              then return (Just (z_wrp_tys, []))+              else do { let -- To be concrete matches, matches have to+                            -- be more than just an invented type variable.+                            fvSet = fvVarSet fvs+                            notAbstract :: TcType -> Bool+                            notAbstract t = case getTyVar_maybe t of+                                              Just tv -> tv `elemVarSet` fvSet+                                              _ -> True+                            allConcrete = all notAbstract z_wrp_tys+                      ; z_vars  <- zonkTcTyVars ref_vars+                      ; let z_mtvs = mapMaybe tcGetTyVar_maybe z_vars+                      ; allFilled <- not <$> anyM isFlexiTyVar z_mtvs+                      ; allowAbstract <- goptM Opt_AbstractRefHoleFits+                      ; if allowAbstract || (allFilled && allConcrete )+                        then return $ Just (z_wrp_tys, z_vars)+                        else return Nothing }}            else return Nothing }      where fvs = mkFVs ref_vars `unionFV` hole_fvs `unionFV` tyCoFVsOfType ty            hole = typed_hole { th_hole = Nothing }@@ -940,7 +964,8 @@ -- constraints on the type of the hole. tcCheckHoleFit :: TypedHole   -- ^ The hole to check against                -> TcSigmaType-               -- ^ The type to check against (possibly modified, e.g. refined)+               -- ^ The type of the hole to check against (possibly modified,+               -- e.g. refined with additional holes for refinement hole-fits.)                -> TcSigmaType -- ^ The type to check whether fits.                -> TcM (Bool, HsWrapper)                -- ^ Whether it was a match, and the wrapper from hole_ty to ty.@@ -958,7 +983,7 @@                           -- imp is the innermost implication                           (imp:_) -> return (ic_tclvl imp)      ; (wrap, wanted) <- setTcLevel innermost_lvl $ captureConstraints $-                         tcSubTypeSigma orig ExprSigCtxt ty hole_ty+                         tcSubTypeSigma orig (ExprSigCtxt NoRRC) ty hole_ty      ; traceTc "Checking hole fit {" empty      ; traceTc "wanteds are: " $ ppr wanted      ; if isEmptyWC wanted && isEmptyBag th_relevant_cts@@ -967,28 +992,28 @@        else do { fresh_binds <- newTcEvBinds                 -- The relevant constraints may contain HoleDests, so we must                 -- take care to clone them as well (to avoid #15370).-               ; cloned_relevants <- mapBagM cloneWanted th_relevant_cts-                 -- We wrap the WC in the nested implications, see+               ; cloned_relevants <- mapBagM cloneWantedCtEv th_relevant_cts+                 -- We wrap the WC in the nested implications, for details, see                  -- Note [Checking hole fits]-               ; let outermost_first = reverse th_implics-                    -- We add the cloned relevants to the wanteds generated by-                    -- the call to tcSubType_NC, see Note [Relevant constraints]-                    -- There's no need to clone the wanteds, because they are-                    -- freshly generated by `tcSubtype_NC`.-                     w_rel_cts = addSimples wanted cloned_relevants-                     final_wc  = foldr (setWCAndBinds fresh_binds) w_rel_cts outermost_first+               ; let wrapInImpls cts = foldl (flip (setWCAndBinds fresh_binds)) cts th_implics+                     final_wc  = wrapInImpls $ addSimples wanted $+                                                          mapBag mkNonCanonical cloned_relevants+                 -- We add the cloned relevants to the wanteds generated+                 -- by the call to tcSubType_NC, for details, see+                 -- Note [Relevant constraints]. There's no need to clone+                 -- the wanteds, because they are freshly generated by the+                 -- call to`tcSubtype_NC`.                ; traceTc "final_wc is: " $ ppr final_wc-               ; rem <- runTcSDeriveds $ simplifyTopWanteds final_wc-               -- We don't want any insoluble or simple constraints left, but-               -- solved implications are ok (and necessary for e.g. undefined)-               ; traceTc "rems was:" $ ppr rem+                 -- See Note [Speeding up valid hole-fits]+               ; (rem, _) <- tryTc $ runTcSEarlyAbort $ simplifyTopWanteds final_wc                ; traceTc "}" empty-               ; return (isSolvedWC rem, wrap) } }-     where-       orig = ExprHoleOrigin (hole_occ <$> th_hole)-       setWCAndBinds :: EvBindsVar         -- Fresh ev binds var.-                     -> Implication        -- The implication to put WC in.-                     -> WantedConstraints  -- The WC constraints to put implic.-                     -> WantedConstraints  -- The new constraints.-       setWCAndBinds binds imp wc-         = mkImplicWC $ unitBag $ imp { ic_wanted = wc , ic_binds = binds }+               ; return (any isSolvedWC rem, wrap) } }+  where+    orig = ExprHoleOrigin (hole_occ <$> th_hole)++    setWCAndBinds :: EvBindsVar         -- Fresh ev binds var.+                  -> Implication        -- The implication to put WC in.+                  -> WantedConstraints  -- The WC constraints to put implic.+                  -> WantedConstraints  -- The new constraints.+    setWCAndBinds binds imp wc+      = mkImplicWC $ unitBag $ imp { ic_wanted = wc , ic_binds = binds }
GHC/Tc/Errors/Hole.hs-boot view
@@ -5,20 +5,21 @@ module GHC.Tc.Errors.Hole where  import GHC.Types.Var ( Id )+import GHC.Tc.Errors.Types ( HoleFitDispConfig, ValidHoleFits ) import GHC.Tc.Types  ( TcM )-import GHC.Tc.Types.Constraint ( Ct, CtLoc, Hole, Implication )+import GHC.Tc.Types.Constraint ( CtEvidence, CtLoc, Hole, Implication ) import GHC.Utils.Outputable ( SDoc ) import GHC.Types.Var.Env ( TidyEnv ) import GHC.Tc.Errors.Hole.FitTypes ( HoleFit, TypedHole, HoleFitCandidate )-import GHC.Tc.Utils.TcType ( TcType, TcSigmaType, Type, TcTyVar )+import GHC.Tc.Utils.TcType ( TcType, TcSigmaType, TcTyVar ) import GHC.Tc.Types.Evidence ( HsWrapper ) import GHC.Utils.FV ( FV ) import Data.Bool ( Bool ) import Data.Maybe ( Maybe ) import Data.Int ( Int ) -findValidHoleFits :: TidyEnv -> [Implication] -> [Ct] -> Hole-                  -> TcM (TidyEnv, SDoc)+findValidHoleFits :: TidyEnv -> [Implication] -> [CtEvidence] -> Hole+                  -> TcM (TidyEnv, ValidHoleFits)  tcCheckHoleFit :: TypedHole -> TcSigmaType -> TcSigmaType                -> TcM (Bool, HsWrapper)@@ -30,14 +31,12 @@ getLocalBindings :: TidyEnv -> CtLoc -> TcM [Id] addHoleFitDocs :: [HoleFit] -> TcM [HoleFit] -data HoleFitDispConfig data HoleFitSortingAlg  pprHoleFit :: HoleFitDispConfig -> HoleFit -> SDoc getHoleFitSortingAlg :: TcM HoleFitSortingAlg getHoleFitDispConfig :: TcM HoleFitDispConfig -relevantCts :: Type -> [Ct] -> [Ct] zonkSubs :: TidyEnv -> [HoleFit] -> TcM (TidyEnv, [HoleFit]) sortHoleFitsBySize :: [HoleFit] -> TcM [HoleFit] sortHoleFitsByGraph :: [HoleFit] -> TcM [HoleFit]
GHC/Tc/Errors/Hole/FitTypes.hs view
@@ -19,15 +19,17 @@ import GHC.Utils.Outputable import GHC.Types.Name +import GHC.Data.Bag+ import Data.Function ( on ) -data TypedHole = TypedHole { th_relevant_cts :: Cts+data TypedHole = TypedHole { th_relevant_cts :: Bag CtEvidence                            -- ^ Any relevant Cts to the hole                            , th_implics :: [Implication]                            -- ^ The nested implications of the hole with the                            --   innermost implication first.                            , th_hole :: Maybe Hole-                           -- ^ The hole itself, if available. Only for debugging.+                           -- ^ The hole itself, if available.                            }  instance Outputable TypedHole where@@ -42,8 +44,13 @@ data HoleFitCandidate = IdHFCand Id             -- An id, like locals.                       | NameHFCand Name         -- A name, like built-in syntax.                       | GreHFCand GlobalRdrElt  -- A global, like imported ids.-                      deriving (Eq) +instance Eq HoleFitCandidate where+  IdHFCand i1 == IdHFCand i2 = i1 == i2+  NameHFCand n1 == NameHFCand n2 = n1 == n2+  GreHFCand gre1 == GreHFCand gre2 = gre_name gre1 == gre_name gre2+  _ == _ = False+ instance Outputable HoleFitCandidate where   ppr = pprHoleFitCand @@ -80,7 +87,7 @@           , hfWrap :: [TcType] -- ^ The wrapper for the match.           , hfMatches :: [TcType]           -- ^ What the refinement variables got matched with, if anything-          , hfDoc :: Maybe HsDocString+          , hfDoc :: Maybe [HsDocString]           -- ^ Documentation of this HoleFit, if available.           }  | RawHoleFit SDoc
GHC/Tc/Errors/Hole/FitTypes.hs-boot view
@@ -4,7 +4,27 @@ -- + which needs 'GHC.Tc.Types' module GHC.Tc.Errors.Hole.FitTypes where --- Build ordering-import GHC.Base()+import GHC.Base (Int, Maybe)+import GHC.Types.Var (Id)+import GHC.Types.Name (Name)+import GHC.Types.Name.Reader (GlobalRdrElt)+import GHC.Tc.Utils.TcType (TcType)+import GHC.Hs.Doc (HsDocString)+import GHC.Utils.Outputable (SDoc) +data HoleFitCandidate+  = IdHFCand Id+  | NameHFCand Name+  | GreHFCand GlobalRdrElt+ data HoleFitPlugin+data HoleFit =+  HoleFit { hfId   :: Id+          , hfCand :: HoleFitCandidate+          , hfType :: TcType+          , hfRefLvl :: Int+          , hfWrap :: [TcType]+          , hfMatches :: [TcType]+          , hfDoc :: Maybe [HsDocString]+          }+ | RawHoleFit SDoc
+ GHC/Tc/Errors/Ppr.hs view
@@ -0,0 +1,3131 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-}++{-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic TcRnMessage++module GHC.Tc.Errors.Ppr+  ( pprTypeDoesNotHaveFixedRuntimeRep+  , pprScopeError+  --+  , tidySkolemInfo+  , tidySkolemInfoAnon+  --+  , withHsDocContext+  , pprHsDocContext+  , inHsDocContext+  )+  where++import GHC.Prelude++import GHC.Builtin.Names++import GHC.Core.Coercion+import GHC.Core.Unify     ( tcMatchTys )+import GHC.Core.TyCon+import GHC.Core.Class+import GHC.Core.DataCon+import GHC.Core.Coercion.Axiom (coAxiomTyCon, coAxiomSingleBranch)+import GHC.Core.ConLike+import GHC.Core.FamInstEnv (famInstAxiom)+import GHC.Core.InstEnv+import GHC.Core.TyCo.Rep (Type(..))+import GHC.Core.TyCo.Ppr (pprWithExplicitKindsWhen,+                          pprSourceTyCon, pprTyVars, pprWithTYPE)+import GHC.Core.PatSyn ( patSynName, pprPatSynType )+import GHC.Core.Predicate+import GHC.Core.Type++import GHC.Driver.Flags++import GHC.Hs++import GHC.Tc.Errors.Types+import GHC.Tc.Types.Constraint+import {-# SOURCE #-} GHC.Tc.Types (getLclEnvLoc)+import GHC.Tc.Types.Origin+import GHC.Tc.Types.Rank (Rank(..))+import GHC.Tc.Utils.TcType+import GHC.Types.Error+import GHC.Types.FieldLabel (flIsOverloaded)+import GHC.Types.Hint (UntickedPromotedThing(..), pprUntickedConstructor, isBareSymbol)+import GHC.Types.Hint.Ppr () -- Outputable GhcHint+import GHC.Types.Basic+import GHC.Types.Id+import GHC.Types.Name+import GHC.Types.Name.Reader ( GreName(..), pprNameProvenance+                             , RdrName, rdrNameOcc, greMangledName )+import GHC.Types.Name.Set+import GHC.Types.SrcLoc+import GHC.Types.TyThing+import GHC.Types.Unique.Set ( nonDetEltsUniqSet )+import GHC.Types.Var+import GHC.Types.Var.Set+import GHC.Types.Var.Env++import GHC.Unit.State (pprWithUnitState, UnitState)+import GHC.Unit.Module++import GHC.Data.Bag+import GHC.Data.FastString+import GHC.Data.List.SetOps ( nubOrdBy )+import GHC.Data.Maybe+import GHC.Utils.Misc+import GHC.Utils.Outputable+import GHC.Utils.Panic++import qualified GHC.LanguageExtensions as LangExt++import Data.List.NonEmpty (NonEmpty(..))+import qualified Data.List.NonEmpty as NE+import Data.Function (on)+import Data.List ( groupBy, sortBy, tails+                 , partition, unfoldr )+import Data.Ord ( comparing )+import Data.Bifunctor+import GHC.Types.Name.Env+++instance Diagnostic TcRnMessage where+  diagnosticMessage = \case+    TcRnUnknownMessage m+      -> diagnosticMessage m+    TcRnMessageWithInfo unit_state msg_with_info+      -> case msg_with_info of+           TcRnMessageDetailed err_info msg+             -> messageWithInfoDiagnosticMessage unit_state err_info (diagnosticMessage msg)+    TcRnSolverReport msgs _ _+      -> mkDecorated $+           map pprSolverReportWithCtxt msgs+    TcRnRedundantConstraints redundants (info, show_info)+      -> mkSimpleDecorated $+         text "Redundant constraint" <> plural redundants <> colon+           <+> pprEvVarTheta redundants+         $$ if show_info then text "In" <+> ppr info else empty+    TcRnInaccessibleCode implic contras+      -> mkSimpleDecorated $+         hang (text "Inaccessible code in")+           2 (ppr (ic_info implic))+         $$ vcat (map pprSolverReportWithCtxt (NE.toList contras))+    TcRnTypeDoesNotHaveFixedRuntimeRep ty prov (ErrInfo extra supplementary)+      -> mkDecorated [pprTypeDoesNotHaveFixedRuntimeRep ty prov, extra, supplementary]+    TcRnImplicitLift id_or_name ErrInfo{..}+      -> mkDecorated $+           ( text "The variable" <+> quotes (ppr id_or_name) <+>+             text "is implicitly lifted in the TH quotation"+           ) : [errInfoContext, errInfoSupplementary]+    TcRnUnusedPatternBinds bind+      -> mkDecorated [hang (text "This pattern-binding binds no variables:") 2 (ppr bind)]+    TcRnDodgyImports name+      -> mkDecorated [dodgy_msg (text "import") name (dodgy_msg_insert name :: IE GhcPs)]+    TcRnDodgyExports name+      -> mkDecorated [dodgy_msg (text "export") name (dodgy_msg_insert name :: IE GhcRn)]+    TcRnMissingImportList ie+      -> mkDecorated [ text "The import item" <+> quotes (ppr ie) <+>+                       text "does not have an explicit import list"+                     ]+    TcRnUnsafeDueToPlugin+      -> mkDecorated [text "Use of plugins makes the module unsafe"]+    TcRnModMissingRealSrcSpan mod+      -> mkDecorated [text "Module does not have a RealSrcSpan:" <+> ppr mod]+    TcRnIdNotExportedFromModuleSig name mod+      -> mkDecorated [ text "The identifier" <+> ppr (occName name) <+>+                       text "does not exist in the signature for" <+> ppr mod+                     ]+    TcRnIdNotExportedFromLocalSig name+      -> mkDecorated [ text "The identifier" <+> ppr (occName name) <+>+                       text "does not exist in the local signature."+                     ]+    TcRnShadowedName occ provenance+      -> let shadowed_locs = case provenance of+               ShadowedNameProvenanceLocal n     -> [text "bound at" <+> ppr n]+               ShadowedNameProvenanceGlobal gres -> map pprNameProvenance gres+         in mkSimpleDecorated $+            sep [text "This binding for" <+> quotes (ppr occ)+             <+> text "shadows the existing binding" <> plural shadowed_locs,+                   nest 2 (vcat shadowed_locs)]+    TcRnDuplicateWarningDecls d rdr_name+      -> mkSimpleDecorated $+           vcat [text "Multiple warning declarations for" <+> quotes (ppr rdr_name),+                 text "also at " <+> ppr (getLocA d)]+    TcRnSimplifierTooManyIterations simples limit wc+      -> mkSimpleDecorated $+           hang (text "solveWanteds: too many iterations"+                   <+> parens (text "limit =" <+> ppr limit))+                2 (vcat [ text "Unsolved:" <+> ppr wc+                        , text "Simples:"  <+> ppr simples+                        ])+    TcRnIllegalPatSynDecl rdrname+      -> mkSimpleDecorated $+           hang (text "Illegal pattern synonym declaration for" <+> quotes (ppr rdrname))+              2 (text "Pattern synonym declarations are only valid at top level")+    TcRnLinearPatSyn ty+      -> mkSimpleDecorated $+           hang (text "Pattern synonyms do not support linear fields (GHC #18806):") 2 (ppr ty)+    TcRnEmptyRecordUpdate+      -> mkSimpleDecorated $ text "Empty record update"+    TcRnIllegalFieldPunning fld+      -> mkSimpleDecorated $ text "Illegal use of punning for field" <+> quotes (ppr fld)+    TcRnIllegalWildcardsInRecord fld_part+      -> mkSimpleDecorated $ text "Illegal `..' in record" <+> pprRecordFieldPart fld_part+    TcRnIllegalWildcardInType mb_name bad mb_ctxt+      -> mkSimpleDecorated $ vcat [ main_msg, context_msg ]+      where+        main_msg :: SDoc+        main_msg = case bad of+          WildcardNotLastInConstraint ->+            hang notAllowed 2 constraint_hint_msg+          ExtraConstraintWildcardNotAllowed allow_sole ->+            case allow_sole of+              SoleExtraConstraintWildcardNotAllowed ->+                notAllowed+              SoleExtraConstraintWildcardAllowed ->+                hang notAllowed 2 sole_msg+          WildcardsNotAllowedAtAll ->+            notAllowed+        context_msg :: SDoc+        context_msg = case mb_ctxt of+          Just ctxt -> nest 2 (text "in" <+> pprHsDocContext ctxt)+          _         -> empty+        notAllowed, what, wildcard, how :: SDoc+        notAllowed = what <+> quotes wildcard <+> how+        wildcard = case mb_name of+          Nothing   -> pprAnonWildCard+          Just name -> ppr name+        what+          | Just _ <- mb_name+          = text "Named wildcard"+          | ExtraConstraintWildcardNotAllowed {} <- bad+          = text "Extra-constraint wildcard"+          | otherwise+          = text "Wildcard"+        how = case bad of+          WildcardNotLastInConstraint+            -> text "not allowed in a constraint"+          _ -> text "not allowed"+        constraint_hint_msg :: SDoc+        constraint_hint_msg+          | Just _ <- mb_name+          = vcat [ text "Extra-constraint wildcards must be anonymous"+                 , nest 2 (text "e.g  f :: (Eq a, _) => blah") ]+          | otherwise+          = vcat [ text "except as the last top-level constraint of a type signature"+                 , nest 2 (text "e.g  f :: (Eq a, _) => blah") ]+        sole_msg :: SDoc+        sole_msg =+          vcat [ text "except as the sole constraint"+               , nest 2 (text "e.g., deriving instance _ => Eq (Foo a)") ]+    TcRnDuplicateFieldName fld_part dups+      -> mkSimpleDecorated $+           hsep [text "duplicate field name",+                 quotes (ppr (NE.head dups)),+                 text "in record", pprRecordFieldPart fld_part]+    TcRnIllegalViewPattern pat+      -> mkSimpleDecorated $ vcat [text "Illegal view pattern: " <+> ppr pat]+    TcRnCharLiteralOutOfRange c+      -> mkSimpleDecorated $ text "character literal out of range: '\\" <> char c  <> char '\''+    TcRnIllegalWildcardsInConstructor con+      -> mkSimpleDecorated $+           vcat [ text "Illegal `..' notation for constructor" <+> quotes (ppr con)+                , nest 2 (text "The constructor has no labelled fields") ]+    TcRnIgnoringAnnotations anns+      -> mkSimpleDecorated $+           text "Ignoring ANN annotation" <> plural anns <> comma+           <+> text "because this is a stage-1 compiler without -fexternal-interpreter or doesn't support GHCi"+    TcRnAnnotationInSafeHaskell+      -> mkSimpleDecorated $+           vcat [ text "Annotations are not compatible with Safe Haskell."+                , text "See https://gitlab.haskell.org/ghc/ghc/issues/10826" ]+    TcRnInvalidTypeApplication fun_ty hs_ty+      -> mkSimpleDecorated $+           text "Cannot apply expression of type" <+> quotes (ppr fun_ty) $$+           text "to a visible type argument" <+> quotes (ppr hs_ty)+    TcRnTagToEnumMissingValArg+      -> mkSimpleDecorated $+           text "tagToEnum# must appear applied to one value argument"+    TcRnTagToEnumUnspecifiedResTy ty+      -> mkSimpleDecorated $+           hang (text "Bad call to tagToEnum# at type" <+> ppr ty)+              2 (vcat [ text "Specify the type by giving a type signature"+                      , text "e.g. (tagToEnum# x) :: Bool" ])+    TcRnTagToEnumResTyNotAnEnum ty+      -> mkSimpleDecorated $+           hang (text "Bad call to tagToEnum# at type" <+> ppr ty)+              2 (text "Result type must be an enumeration type")+    TcRnArrowIfThenElsePredDependsOnResultTy+      -> mkSimpleDecorated $+           text "Predicate type of `ifThenElse' depends on result type"+    TcRnIllegalHsBootFileDecl+      -> mkSimpleDecorated $+           text "Illegal declarations in an hs-boot file"+    TcRnRecursivePatternSynonym binds+      -> mkSimpleDecorated $+            hang (text "Recursive pattern synonym definition with following bindings:")+               2 (vcat $ map pprLBind . bagToList $ binds)+          where+            pprLoc loc = parens (text "defined at" <+> ppr loc)+            pprLBind :: CollectPass GhcRn => GenLocated (SrcSpanAnn' a) (HsBindLR GhcRn idR) -> SDoc+            pprLBind (L loc bind) = pprWithCommas ppr (collectHsBindBinders CollNoDictBinders bind)+                                        <+> pprLoc (locA loc)+    TcRnPartialTypeSigTyVarMismatch n1 n2 fn_name hs_ty+      -> mkSimpleDecorated $+           hang (text "Couldn't match" <+> quotes (ppr n1)+                   <+> text "with" <+> quotes (ppr n2))+                2 (hang (text "both bound by the partial type signature:")+                        2 (ppr fn_name <+> dcolon <+> ppr hs_ty))+    TcRnPartialTypeSigBadQuantifier n fn_name m_unif_ty hs_ty+      -> mkSimpleDecorated $+           hang (text "Can't quantify over" <+> quotes (ppr n))+                2 (vcat [ hang (text "bound by the partial type signature:")+                             2 (ppr fn_name <+> dcolon <+> ppr hs_ty)+                        , extra ])+      where+        extra | Just rhs_ty <- m_unif_ty+              = sep [ quotes (ppr n), text "should really be", quotes (ppr rhs_ty) ]+              | otherwise+              = empty+    TcRnMissingSignature what _ _ ->+      mkSimpleDecorated $+      case what of+        MissingPatSynSig p ->+          hang (text "Pattern synonym with no type signature:")+            2 (text "pattern" <+> pprPrefixName (patSynName p) <+> dcolon <+> pprPatSynType p)+        MissingTopLevelBindingSig name ty ->+          hang (text "Top-level binding with no type signature:")+            2 (pprPrefixName name <+> dcolon <+> pprSigmaType ty)+        MissingTyConKindSig tc cusks_enabled ->+          hang msg+            2 (text "type" <+> pprPrefixName (tyConName tc) <+> dcolon <+> pprKind (tyConKind tc))+          where+            msg | cusks_enabled+                = text "Top-level type constructor with no standalone kind signature or CUSK:"+                | otherwise+                = text "Top-level type constructor with no standalone kind signature:"++    TcRnPolymorphicBinderMissingSig n ty+      -> mkSimpleDecorated $+           sep [ text "Polymorphic local binding with no type signature:"+               , nest 2 $ pprPrefixName n <+> dcolon <+> ppr ty ]+    TcRnOverloadedSig sig+      -> mkSimpleDecorated $+           hang (text "Overloaded signature conflicts with monomorphism restriction")+              2 (ppr sig)+    TcRnTupleConstraintInst _+      -> mkSimpleDecorated $ text "You can't specify an instance for a tuple constraint"+    TcRnAbstractClassInst clas+      -> mkSimpleDecorated $+           text "Cannot define instance for abstract class" <+>+           quotes (ppr (className clas))+    TcRnNoClassInstHead tau+      -> mkSimpleDecorated $+           hang (text "Instance head is not headed by a class:") 2 (pprType tau)+    TcRnUserTypeError ty+      -> mkSimpleDecorated (pprUserTypeErrorTy ty)+    TcRnConstraintInKind ty+      -> mkSimpleDecorated $+           text "Illegal constraint in a kind:" <+> pprType ty+    TcRnUnboxedTupleOrSumTypeFuncArg tuple_or_sum ty+      -> mkSimpleDecorated $+           sep [ text "Illegal unboxed" <+> what <+> text "type as function argument:"+               , pprType ty ]+        where+          what = case tuple_or_sum of+            UnboxedTupleType -> text "tuple"+            UnboxedSumType   -> text "sum"+    TcRnLinearFuncInKind ty+      -> mkSimpleDecorated $+           text "Illegal linear function in a kind:" <+> pprType ty+    TcRnForAllEscapeError ty kind+      -> mkSimpleDecorated $ vcat+           [ hang (text "Quantified type's kind mentions quantified type variable")+                2 (text "type:" <+> quotes (ppr ty))+           , hang (text "where the body of the forall has this kind:")+                2 (quotes (pprKind kind)) ]+    TcRnVDQInTermType ty+      -> mkSimpleDecorated $ vcat+           [ hang (text "Illegal visible, dependent quantification" <+>+                   text "in the type of a term:")+                2 (pprType ty)+           , text "(GHC does not yet support this)" ]+    TcRnBadQuantPredHead ty+      -> mkSimpleDecorated $+           hang (text "Quantified predicate must have a class or type variable head:")+              2 (pprType ty)+    TcRnIllegalTupleConstraint ty+      -> mkSimpleDecorated $+           text "Illegal tuple constraint:" <+> pprType ty+    TcRnNonTypeVarArgInConstraint ty+      -> mkSimpleDecorated $+           hang (text "Non type-variable argument")+              2 (text "in the constraint:" <+> pprType ty)+    TcRnIllegalImplicitParam ty+      -> mkSimpleDecorated $+           text "Illegal implicit parameter" <+> quotes (pprType ty)+    TcRnIllegalConstraintSynonymOfKind kind+      -> mkSimpleDecorated $+           text "Illegal constraint synonym of kind:" <+> quotes (pprKind kind)+    TcRnIllegalClassInst tcf+      -> mkSimpleDecorated $+           vcat [ text "Illegal instance for a" <+> ppr tcf+                , text "A class instance must be for a class" ]+    TcRnOversaturatedVisibleKindArg ty+      -> mkSimpleDecorated $+           text "Illegal oversaturated visible kind argument:" <+>+           quotes (char '@' <> pprParendType ty)+    TcRnBadAssociatedType clas tc+      -> mkSimpleDecorated $+           hsep [ text "Class", quotes (ppr clas)+                , text "does not have an associated type", quotes (ppr tc) ]+    TcRnForAllRankErr rank ty+      -> let herald = case tcSplitForAllTyVars ty of+               ([], _) -> text "Illegal qualified type:"+               _       -> text "Illegal polymorphic type:"+             extra = case rank of+               MonoTypeConstraint -> text "A constraint must be a monotype"+               _                  -> empty+         in mkSimpleDecorated $ vcat [hang herald 2 (pprType ty), extra]+    TcRnMonomorphicBindings bindings+      -> let pp_bndrs = pprBindings bindings+         in mkSimpleDecorated $+              sep [ text "The Monomorphism Restriction applies to the binding"+                  <> plural bindings+                  , text "for" <+> pp_bndrs ]+    TcRnOrphanInstance inst+      -> mkSimpleDecorated $+           hsep [ text "Orphan instance:"+                , pprInstanceHdr inst+                ]+    TcRnFunDepConflict unit_state sorted+      -> let herald = text "Functional dependencies conflict between instance declarations:"+         in mkSimpleDecorated $+              pprWithUnitState unit_state $ (hang herald 2 (pprInstances $ NE.toList sorted))+    TcRnDupInstanceDecls unit_state sorted+      -> let herald = text "Duplicate instance declarations:"+         in mkSimpleDecorated $+              pprWithUnitState unit_state $ (hang herald 2 (pprInstances $ NE.toList sorted))+    TcRnConflictingFamInstDecls sortedNE+      -> let sorted = NE.toList sortedNE+         in mkSimpleDecorated $+              hang (text "Conflicting family instance declarations:")+                 2 (vcat [ pprCoAxBranchUser (coAxiomTyCon ax) (coAxiomSingleBranch ax)+                         | fi <- sorted+                         , let ax = famInstAxiom fi ])+    TcRnFamInstNotInjective rea fam_tc (eqn1 NE.:| rest_eqns)+      -> let (herald, show_kinds) = case rea of+               InjErrRhsBareTyVar tys ->+                 (injectivityErrorHerald $$+                  text "RHS of injective type family equation is a bare" <+>+                  text "type variable" $$+                  text "but these LHS type and kind patterns are not bare" <+>+                  text "variables:" <+> pprQuotedList tys, False)+               InjErrRhsCannotBeATypeFam ->+                 (injectivityErrorHerald $$+                   text "RHS of injective type family equation cannot" <+>+                   text "be a type family:", False)+               InjErrRhsOverlap ->+                  (text "Type family equation right-hand sides overlap; this violates" $$+                   text "the family's injectivity annotation:", False)+               InjErrCannotInferFromRhs tvs has_kinds _ ->+                 let show_kinds = has_kinds == YesHasKinds+                     what = if show_kinds then text "Type/kind" else text "Type"+                     body = sep [ what <+> text "variable" <>+                                  pluralVarSet tvs <+> pprVarSet tvs (pprQuotedList . scopedSort)+                                , text "cannot be inferred from the right-hand side." ]+                     in (injectivityErrorHerald $$ body $$ text "In the type family equation:", show_kinds)++         in mkSimpleDecorated $ pprWithExplicitKindsWhen show_kinds $+              hang herald+                2 (vcat (map (pprCoAxBranchUser fam_tc) (eqn1 : rest_eqns)))+    TcRnBangOnUnliftedType ty+      -> mkSimpleDecorated $+           text "Strictness flag has no effect on unlifted type" <+> quotes (ppr ty)+    TcRnMultipleDefaultDeclarations dup_things+      -> mkSimpleDecorated $+           hang (text "Multiple default declarations")+              2 (vcat (map pp dup_things))+         where+           pp :: LDefaultDecl GhcRn -> SDoc+           pp (L locn (DefaultDecl _ _))+             = text "here was another default declaration" <+> ppr (locA locn)+    TcRnBadDefaultType ty deflt_clss+      -> mkSimpleDecorated $+           hang (text "The default type" <+> quotes (ppr ty) <+> text "is not an instance of")+              2 (foldr1 (\a b -> a <+> text "or" <+> b) (map (quotes. ppr) deflt_clss))+    TcRnPatSynBundledWithNonDataCon+      -> mkSimpleDecorated $+           text "Pattern synonyms can be bundled only with datatypes."+    TcRnPatSynBundledWithWrongType expected_res_ty res_ty+      -> mkSimpleDecorated $+           text "Pattern synonyms can only be bundled with matching type constructors"+               $$ text "Couldn't match expected type of"+               <+> quotes (ppr expected_res_ty)+               <+> text "with actual type of"+               <+> quotes (ppr res_ty)+    TcRnDupeModuleExport mod+      -> mkSimpleDecorated $+           hsep [ text "Duplicate"+                , quotes (text "Module" <+> ppr mod)+                , text "in export list" ]+    TcRnExportedModNotImported mod+      -> mkSimpleDecorated+       $ formatExportItemError+           (text "module" <+> ppr mod)+           "is not imported"+    TcRnNullExportedModule mod+      -> mkSimpleDecorated+       $ formatExportItemError+           (text "module" <+> ppr mod)+           "exports nothing"+    TcRnMissingExportList mod+      -> mkSimpleDecorated+       $ formatExportItemError+           (text "module" <+> ppr mod)+           "is missing an export list"+    TcRnExportHiddenComponents export_item+      -> mkSimpleDecorated+       $ formatExportItemError+           (ppr export_item)+           "attempts to export constructors or class methods that are not visible here"+    TcRnDuplicateExport child ie1 ie2+      -> mkSimpleDecorated $+           hsep [ quotes (ppr child)+                , text "is exported by", quotes (ppr ie1)+                , text "and",            quotes (ppr ie2) ]+    TcRnExportedParentChildMismatch parent_name ty_thing child parent_names+      -> mkSimpleDecorated $+           text "The type constructor" <+> quotes (ppr parent_name)+                 <+> text "is not the parent of the" <+> text what_is+                 <+> quotes thing <> char '.'+                 $$ text (capitalise what_is)+                    <> text "s can only be exported with their parent type constructor."+                 $$ (case parents of+                       [] -> empty+                       [_] -> text "Parent:"+                       _  -> text "Parents:") <+> fsep (punctuate comma parents)+      where+        pp_category :: TyThing -> String+        pp_category (AnId i)+          | isRecordSelector i = "record selector"+        pp_category i = tyThingCategory i+        what_is = pp_category ty_thing+        thing = ppr child+        parents = map ppr parent_names+    TcRnConflictingExports occ child1 gre1 ie1 child2 gre2 ie2+      -> mkSimpleDecorated $+           vcat [ text "Conflicting exports for" <+> quotes (ppr occ) <> colon+                , ppr_export child1 gre1 ie1+                , ppr_export child2 gre2 ie2+                ]+      where+        ppr_export child gre ie = nest 3 (hang (quotes (ppr ie) <+> text "exports" <+>+                                                quotes (ppr_name child))+                                            2 (pprNameProvenance gre))++        -- DuplicateRecordFields means that nameOccName might be a+        -- mangled $sel-prefixed thing, in which case show the correct OccName+        -- alone (but otherwise show the Name so it will have a module+        -- qualifier)+        ppr_name (FieldGreName fl) | flIsOverloaded fl = ppr fl+                                   | otherwise         = ppr (flSelector fl)+        ppr_name (NormalGreName name) = ppr name+    TcRnAmbiguousField rupd parent_type+      -> mkSimpleDecorated $+          vcat [ text "The record update" <+> ppr rupd+                   <+> text "with type" <+> ppr parent_type+                   <+> text "is ambiguous."+               , text "This will not be supported by -XDuplicateRecordFields in future releases of GHC."+               ]+    TcRnMissingFields con fields+      -> mkSimpleDecorated $ vcat [header, nest 2 rest]+         where+           rest | null fields = empty+                | otherwise   = vcat (fmap pprField fields)+           header = text "Fields of" <+> quotes (ppr con) <+>+                    text "not initialised" <>+                    if null fields then empty else colon+    TcRnFieldUpdateInvalidType prs+      -> mkSimpleDecorated $+           hang (text "Record update for insufficiently polymorphic field"+                   <> plural prs <> colon)+              2 (vcat [ ppr f <+> dcolon <+> ppr ty | (f,ty) <- prs ])+    TcRnNoConstructorHasAllFields conflictingFields+      -> mkSimpleDecorated $+           hang (text "No constructor has all these fields:")+              2 (pprQuotedList conflictingFields)+    TcRnMixedSelectors data_name data_sels pat_name pat_syn_sels+      -> mkSimpleDecorated $+           text "Cannot use a mixture of pattern synonym and record selectors" $$+           text "Record selectors defined by"+             <+> quotes (ppr data_name)+             <> colon+             <+> pprWithCommas ppr data_sels $$+           text "Pattern synonym selectors defined by"+             <+> quotes (ppr pat_name)+             <> colon+             <+> pprWithCommas ppr pat_syn_sels+    TcRnMissingStrictFields con fields+      -> mkSimpleDecorated $ vcat [header, nest 2 rest]+         where+           rest | null fields = empty  -- Happens for non-record constructors+                                       -- with strict fields+                | otherwise   = vcat (fmap pprField fields)++           header = text "Constructor" <+> quotes (ppr con) <+>+                    text "does not have the required strict field(s)" <>+                    if null fields then empty else colon+    TcRnNoPossibleParentForFields rbinds+      -> mkSimpleDecorated $+           hang (text "No type has all these fields:")+              2 (pprQuotedList fields)+         where fields = map (hfbLHS . unLoc) rbinds+    TcRnBadOverloadedRecordUpdate _rbinds+      -> mkSimpleDecorated $+           text "Record update is ambiguous, and requires a type signature"+    TcRnStaticFormNotClosed name reason+      -> mkSimpleDecorated $+           quotes (ppr name)+             <+> text "is used in a static form but it is not closed"+             <+> text "because it"+             $$ sep (causes reason)+         where+          causes :: NotClosedReason -> [SDoc]+          causes NotLetBoundReason = [text "is not let-bound."]+          causes (NotTypeClosed vs) =+            [ text "has a non-closed type because it contains the"+            , text "type variables:" <+>+              pprVarSet vs (hsep . punctuate comma . map (quotes . ppr))+            ]+          causes (NotClosed n reason) =+            let msg = text "uses" <+> quotes (ppr n) <+> text "which"+             in case reason of+                  NotClosed _ _ -> msg : causes reason+                  _   -> let (xs0, xs1) = splitAt 1 $ causes reason+                          in fmap (msg <+>) xs0 ++ xs1+    TcRnUselessTypeable+      -> mkSimpleDecorated $+           text "Deriving" <+> quotes (ppr typeableClassName) <+>+           text "has no effect: all types now auto-derive Typeable"+    TcRnDerivingDefaults cls+      -> mkSimpleDecorated $ sep+                     [ text "Both DeriveAnyClass and"+                       <+> text "GeneralizedNewtypeDeriving are enabled"+                     , text "Defaulting to the DeriveAnyClass strategy"+                       <+> text "for instantiating" <+> ppr cls+                     ]+    TcRnNonUnaryTypeclassConstraint ct+      -> mkSimpleDecorated $+           quotes (ppr ct)+           <+> text "is not a unary constraint, as expected by a deriving clause"+    TcRnPartialTypeSignatures _ theta+      -> mkSimpleDecorated $+           text "Found type wildcard" <+> quotes (char '_')+                       <+> text "standing for" <+> quotes (pprTheta theta)+    TcRnCannotDeriveInstance cls cls_tys mb_strat newtype_deriving reason+      -> mkSimpleDecorated $+           derivErrDiagnosticMessage cls cls_tys mb_strat newtype_deriving True reason+    TcRnLazyGADTPattern+      -> mkSimpleDecorated $+           hang (text "An existential or GADT data constructor cannot be used")+              2 (text "inside a lazy (~) pattern")+    TcRnArrowProcGADTPattern+      -> mkSimpleDecorated $+           text "Proc patterns cannot use existential or GADT data constructors"++    TcRnSpecialClassInst cls because_safeHaskell+      -> mkSimpleDecorated $+            text "Class" <+> quotes (ppr $ className cls)+                   <+> text "does not support user-specified instances"+                   <> safeHaskell_msg+          where+            safeHaskell_msg+              | because_safeHaskell+              = text " when Safe Haskell is enabled."+              | otherwise+              = dot+    TcRnForallIdentifier rdr_name+      -> mkSimpleDecorated $+            fsep [ text "The use of" <+> quotes (ppr rdr_name)+                                     <+> text "as an identifier",+                   text "will become an error in a future GHC release." ]+    TcRnTypeEqualityOutOfScope+      -> mkDecorated+           [ text "The" <+> quotes (text "~") <+> text "operator is out of scope." $$+             text "Assuming it to stand for an equality constraint."+           , text "NB:" <+> (quotes (text "~") <+> text "used to be built-in syntax but now is a regular type operator" $$+                             text "exported from Data.Type.Equality and Prelude.") $$+             text "If you are using a custom Prelude, consider re-exporting it."+           , text "This will become an error in a future GHC release." ]+    TcRnTypeEqualityRequiresOperators+      -> mkSimpleDecorated $+            fsep [ text "The use of" <+> quotes (text "~")+                                     <+> text "without TypeOperators",+                   text "will become an error in a future GHC release." ]+    TcRnIllegalTypeOperator overall_ty op+      -> mkSimpleDecorated $+           text "Illegal operator" <+> quotes (ppr op) <+>+           text "in type" <+> quotes (ppr overall_ty)+    TcRnGADTMonoLocalBinds+      -> mkSimpleDecorated $+            fsep [ text "Pattern matching on GADTs without MonoLocalBinds"+                 , text "is fragile." ]+    TcRnIncorrectNameSpace name _+      -> mkSimpleDecorated $ msg+        where+          msg+            -- We are in a type-level namespace,+            -- and the name is incorrectly at the term-level.+            | isValNameSpace ns+            = text "The" <+> what <+> text "does not live in the type-level namespace"++            -- We are in a term-level namespace,+            -- and the name is incorrectly at the type-level.+            | otherwise+            = text "Illegal term-level use of the" <+> what+          ns = nameNameSpace name+          what = pprNameSpace ns <+> quotes (ppr name)+    TcRnNotInScope err name imp_errs _+      -> mkSimpleDecorated $+           pprScopeError name err $$ vcat (map ppr imp_errs)+    TcRnUntickedPromotedThing thing+      -> mkSimpleDecorated $+         text "Unticked promoted" <+> what+           where+             what :: SDoc+             what = case thing of+               UntickedExplicitList -> text "list" <> dot+               UntickedConstructor fixity nm ->+                 let con      = pprUntickedConstructor fixity nm+                     bare_sym = isBareSymbol fixity nm+                 in text "constructor:" <+> con <> if bare_sym then empty else dot+    TcRnIllegalBuiltinSyntax what rdr_name+      -> mkSimpleDecorated $+           hsep [text "Illegal", what, text "of built-in syntax:", ppr rdr_name]+    TcRnWarnDefaulting tidy_wanteds tidy_tv default_ty+      -> mkSimpleDecorated $+           hang (hsep $ [ text "Defaulting" ]+                     +++                     (case tidy_tv of+                         Nothing -> []+                         Just tv -> [text "the type variable"+                                    , quotes (ppr tv)])+                     +++                     [ text "to type"+                     , quotes (ppr default_ty)+                     , text "in the following constraint" <> plural tidy_wanteds ])+             2+             (pprWithArising tidy_wanteds)+++    TcRnForeignImportPrimExtNotSet _decl+      -> mkSimpleDecorated $+           text "`foreign import prim' requires GHCForeignImportPrim."++    TcRnForeignImportPrimSafeAnn _decl+      -> mkSimpleDecorated $+           text "The safe/unsafe annotation should not be used with `foreign import prim'."++    TcRnForeignFunctionImportAsValue _decl+      -> mkSimpleDecorated $+           text "`value' imports cannot have function types"++    TcRnFunPtrImportWithoutAmpersand _decl+      -> mkSimpleDecorated $+           text "possible missing & in foreign import of FunPtr"++    TcRnIllegalForeignDeclBackend _decl _backend expectedBknds+      -> mkSimpleDecorated $ text "Illegal foreign declaration:" <+>+           case expectedBknds of+             COrAsmOrLlvm ->+               text "requires unregisterised, llvm (-fllvm) or native code generation (-fasm)"+             COrAsmOrLlvmOrInterp ->+               text "requires interpreted, unregisterised, llvm or native code generation"++    TcRnUnsupportedCallConv _decl unsupportedCC+      -> mkSimpleDecorated $+           case unsupportedCC of+             StdCallConvUnsupported ->+               text "the 'stdcall' calling convention is unsupported on this platform,"+               $$ text "treating as ccall"+             PrimCallConvUnsupported ->+               text "The `prim' calling convention can only be used with `foreign import'"+             JavaScriptCallConvUnsupported ->+               text "The `javascript' calling convention is unsupported on this platform"++    TcRnIllegalForeignType mArgOrResult reason+      -> mkSimpleDecorated $ hang msg 2 extra+      where+        arg_or_res = case mArgOrResult of+          Nothing -> empty+          Just Arg -> text "argument"+          Just Result -> text "result"+        msg = hsep [ text "Unacceptable", arg_or_res+                   , text "type in foreign declaration:"]+        extra =+          case reason of+            TypeCannotBeMarshaled ty why ->+              let innerMsg = quotes (ppr ty) <+> text "cannot be marshalled in a foreign call"+               in case why of+                NotADataType ->+                  quotes (ppr ty) <+> text "is not a data type"+                NewtypeDataConNotInScope Nothing ->+                  hang innerMsg 2 $ text "because its data constructor is not in scope"+                NewtypeDataConNotInScope (Just tc) ->+                  hang innerMsg 2 $+                    text "because the data constructor for"+                    <+> quotes (ppr tc) <+> text "is not in scope"+                UnliftedFFITypesNeeded ->+                  innerMsg $$ text "UnliftedFFITypes is required to marshal unlifted types"+                NotABoxedMarshalableTyCon -> innerMsg+                ForeignLabelNotAPtr ->+                  innerMsg $$ text "A foreign-imported address (via &foo) must have type (Ptr a) or (FunPtr a)"+                NotSimpleUnliftedType ->+                  innerMsg $$ text "foreign import prim only accepts simple unlifted types"+            ForeignDynNotPtr expected ty ->+              vcat [ text "Expected: Ptr/FunPtr" <+> pprParendType expected <> comma, text "  Actual:" <+> ppr ty ]+            SafeHaskellMustBeInIO ->+              text "Safe Haskell is on, all FFI imports must be in the IO monad"+            IOResultExpected ->+              text "IO result type expected"+            UnexpectedNestedForall ->+              text "Unexpected nested forall"+            LinearTypesNotAllowed ->+              text "Linear types are not supported in FFI declarations, see #18472"+            OneArgExpected ->+              text "One argument expected"+            AtLeastOneArgExpected ->+              text "At least one argument expected"+    TcRnInvalidCIdentifier target+      -> mkSimpleDecorated $+           sep [quotes (ppr target) <+> text "is not a valid C identifier"]++  diagnosticReason = \case+    TcRnUnknownMessage m+      -> diagnosticReason m+    TcRnMessageWithInfo _ msg_with_info+      -> case msg_with_info of+           TcRnMessageDetailed _ m -> diagnosticReason m+    TcRnSolverReport _ reason _+      -> reason -- Error, or a Warning if we are deferring type errors+    TcRnRedundantConstraints {}+      -> WarningWithFlag Opt_WarnRedundantConstraints+    TcRnInaccessibleCode {}+      -> WarningWithFlag Opt_WarnInaccessibleCode+    TcRnTypeDoesNotHaveFixedRuntimeRep{}+      -> ErrorWithoutFlag+    TcRnImplicitLift{}+      -> WarningWithFlag Opt_WarnImplicitLift+    TcRnUnusedPatternBinds{}+      -> WarningWithFlag Opt_WarnUnusedPatternBinds+    TcRnDodgyImports{}+      -> WarningWithFlag Opt_WarnDodgyImports+    TcRnDodgyExports{}+      -> WarningWithFlag Opt_WarnDodgyExports+    TcRnMissingImportList{}+      -> WarningWithFlag Opt_WarnMissingImportList+    TcRnUnsafeDueToPlugin{}+      -> WarningWithoutFlag+    TcRnModMissingRealSrcSpan{}+      -> ErrorWithoutFlag+    TcRnIdNotExportedFromModuleSig{}+      -> ErrorWithoutFlag+    TcRnIdNotExportedFromLocalSig{}+      -> ErrorWithoutFlag+    TcRnShadowedName{}+      -> WarningWithFlag Opt_WarnNameShadowing+    TcRnDuplicateWarningDecls{}+      -> ErrorWithoutFlag+    TcRnSimplifierTooManyIterations{}+      -> ErrorWithoutFlag+    TcRnIllegalPatSynDecl{}+      -> ErrorWithoutFlag+    TcRnLinearPatSyn{}+      -> ErrorWithoutFlag+    TcRnEmptyRecordUpdate+      -> ErrorWithoutFlag+    TcRnIllegalFieldPunning{}+      -> ErrorWithoutFlag+    TcRnIllegalWildcardsInRecord{}+      -> ErrorWithoutFlag+    TcRnIllegalWildcardInType{}+      -> ErrorWithoutFlag+    TcRnDuplicateFieldName{}+      -> ErrorWithoutFlag+    TcRnIllegalViewPattern{}+      -> ErrorWithoutFlag+    TcRnCharLiteralOutOfRange{}+      -> ErrorWithoutFlag+    TcRnIllegalWildcardsInConstructor{}+      -> ErrorWithoutFlag+    TcRnIgnoringAnnotations{}+      -> WarningWithoutFlag+    TcRnAnnotationInSafeHaskell+      -> ErrorWithoutFlag+    TcRnInvalidTypeApplication{}+      -> ErrorWithoutFlag+    TcRnTagToEnumMissingValArg+      -> ErrorWithoutFlag+    TcRnTagToEnumUnspecifiedResTy{}+      -> ErrorWithoutFlag+    TcRnTagToEnumResTyNotAnEnum{}+      -> ErrorWithoutFlag+    TcRnArrowIfThenElsePredDependsOnResultTy+      -> ErrorWithoutFlag+    TcRnIllegalHsBootFileDecl+      -> ErrorWithoutFlag+    TcRnRecursivePatternSynonym{}+      -> ErrorWithoutFlag+    TcRnPartialTypeSigTyVarMismatch{}+      -> ErrorWithoutFlag+    TcRnPartialTypeSigBadQuantifier{}+      -> ErrorWithoutFlag+    TcRnMissingSignature what exported overridden+      -> WarningWithFlag $ missingSignatureWarningFlag what exported overridden+    TcRnPolymorphicBinderMissingSig{}+      -> WarningWithFlag Opt_WarnMissingLocalSignatures+    TcRnOverloadedSig{}+      -> ErrorWithoutFlag+    TcRnTupleConstraintInst{}+      -> ErrorWithoutFlag+    TcRnAbstractClassInst{}+      -> ErrorWithoutFlag+    TcRnNoClassInstHead{}+      -> ErrorWithoutFlag+    TcRnUserTypeError{}+      -> ErrorWithoutFlag+    TcRnConstraintInKind{}+      -> ErrorWithoutFlag+    TcRnUnboxedTupleOrSumTypeFuncArg{}+      -> ErrorWithoutFlag+    TcRnLinearFuncInKind{}+      -> ErrorWithoutFlag+    TcRnForAllEscapeError{}+      -> ErrorWithoutFlag+    TcRnVDQInTermType{}+      -> ErrorWithoutFlag+    TcRnBadQuantPredHead{}+      -> ErrorWithoutFlag+    TcRnIllegalTupleConstraint{}+      -> ErrorWithoutFlag+    TcRnNonTypeVarArgInConstraint{}+      -> ErrorWithoutFlag+    TcRnIllegalImplicitParam{}+      -> ErrorWithoutFlag+    TcRnIllegalConstraintSynonymOfKind{}+      -> ErrorWithoutFlag+    TcRnIllegalClassInst{}+      -> ErrorWithoutFlag+    TcRnOversaturatedVisibleKindArg{}+      -> ErrorWithoutFlag+    TcRnBadAssociatedType{}+      -> ErrorWithoutFlag+    TcRnForAllRankErr{}+      -> ErrorWithoutFlag+    TcRnMonomorphicBindings{}+      -> WarningWithFlag Opt_WarnMonomorphism+    TcRnOrphanInstance{}+      -> WarningWithFlag Opt_WarnOrphans+    TcRnFunDepConflict{}+      -> ErrorWithoutFlag+    TcRnDupInstanceDecls{}+      -> ErrorWithoutFlag+    TcRnConflictingFamInstDecls{}+      -> ErrorWithoutFlag+    TcRnFamInstNotInjective{}+      -> ErrorWithoutFlag+    TcRnBangOnUnliftedType{}+      -> WarningWithFlag Opt_WarnRedundantStrictnessFlags+    TcRnMultipleDefaultDeclarations{}+      -> ErrorWithoutFlag+    TcRnBadDefaultType{}+      -> ErrorWithoutFlag+    TcRnPatSynBundledWithNonDataCon{}+      -> ErrorWithoutFlag+    TcRnPatSynBundledWithWrongType{}+      -> ErrorWithoutFlag+    TcRnDupeModuleExport{}+      -> WarningWithFlag Opt_WarnDuplicateExports+    TcRnExportedModNotImported{}+      -> ErrorWithoutFlag+    TcRnNullExportedModule{}+      -> WarningWithFlag Opt_WarnDodgyExports+    TcRnMissingExportList{}+      -> WarningWithFlag Opt_WarnMissingExportList+    TcRnExportHiddenComponents{}+      -> ErrorWithoutFlag+    TcRnDuplicateExport{}+      -> WarningWithFlag Opt_WarnDuplicateExports+    TcRnExportedParentChildMismatch{}+      -> ErrorWithoutFlag+    TcRnConflictingExports{}+      -> ErrorWithoutFlag+    TcRnAmbiguousField{}+      -> WarningWithFlag Opt_WarnAmbiguousFields+    TcRnMissingFields{}+      -> WarningWithFlag Opt_WarnMissingFields+    TcRnFieldUpdateInvalidType{}+      -> ErrorWithoutFlag+    TcRnNoConstructorHasAllFields{}+      -> ErrorWithoutFlag+    TcRnMixedSelectors{}+      -> ErrorWithoutFlag+    TcRnMissingStrictFields{}+      -> ErrorWithoutFlag+    TcRnNoPossibleParentForFields{}+      -> ErrorWithoutFlag+    TcRnBadOverloadedRecordUpdate{}+      -> ErrorWithoutFlag+    TcRnStaticFormNotClosed{}+      -> ErrorWithoutFlag+    TcRnUselessTypeable+      -> WarningWithFlag Opt_WarnDerivingTypeable+    TcRnDerivingDefaults{}+      -> WarningWithFlag Opt_WarnDerivingDefaults+    TcRnNonUnaryTypeclassConstraint{}+      -> ErrorWithoutFlag+    TcRnPartialTypeSignatures{}+      -> WarningWithFlag Opt_WarnPartialTypeSignatures+    TcRnCannotDeriveInstance _ _ _ _ rea+      -> case rea of+           DerivErrNotWellKinded{}                 -> ErrorWithoutFlag+           DerivErrSafeHaskellGenericInst          -> ErrorWithoutFlag+           DerivErrDerivingViaWrongKind{}          -> ErrorWithoutFlag+           DerivErrNoEtaReduce{}                   -> ErrorWithoutFlag+           DerivErrBootFileFound                   -> ErrorWithoutFlag+           DerivErrDataConsNotAllInScope{}         -> ErrorWithoutFlag+           DerivErrGNDUsedOnData                   -> ErrorWithoutFlag+           DerivErrNullaryClasses                  -> ErrorWithoutFlag+           DerivErrLastArgMustBeApp                -> ErrorWithoutFlag+           DerivErrNoFamilyInstance{}              -> ErrorWithoutFlag+           DerivErrNotStockDeriveable{}            -> ErrorWithoutFlag+           DerivErrHasAssociatedDatatypes{}        -> ErrorWithoutFlag+           DerivErrNewtypeNonDeriveableClass       -> ErrorWithoutFlag+           DerivErrCannotEtaReduceEnough{}         -> ErrorWithoutFlag+           DerivErrOnlyAnyClassDeriveable{}        -> ErrorWithoutFlag+           DerivErrNotDeriveable{}                 -> ErrorWithoutFlag+           DerivErrNotAClass{}                     -> ErrorWithoutFlag+           DerivErrNoConstructors{}                -> ErrorWithoutFlag+           DerivErrLangExtRequired{}               -> ErrorWithoutFlag+           DerivErrDunnoHowToDeriveForType{}       -> ErrorWithoutFlag+           DerivErrMustBeEnumType{}                -> ErrorWithoutFlag+           DerivErrMustHaveExactlyOneConstructor{} -> ErrorWithoutFlag+           DerivErrMustHaveSomeParameters{}        -> ErrorWithoutFlag+           DerivErrMustNotHaveClassContext{}       -> ErrorWithoutFlag+           DerivErrBadConstructor{}                -> ErrorWithoutFlag+           DerivErrGenerics{}                      -> ErrorWithoutFlag+           DerivErrEnumOrProduct{}                 -> ErrorWithoutFlag+    TcRnLazyGADTPattern+      -> ErrorWithoutFlag+    TcRnArrowProcGADTPattern+      -> ErrorWithoutFlag+    TcRnSpecialClassInst {}+      -> ErrorWithoutFlag+    TcRnForallIdentifier {}+      -> WarningWithFlag Opt_WarnForallIdentifier+    TcRnTypeEqualityOutOfScope+      -> WarningWithFlag Opt_WarnTypeEqualityOutOfScope+    TcRnTypeEqualityRequiresOperators+      -> WarningWithFlag Opt_WarnTypeEqualityRequiresOperators+    TcRnIllegalTypeOperator {}+      -> ErrorWithoutFlag+    TcRnGADTMonoLocalBinds {}+      -> WarningWithFlag Opt_WarnGADTMonoLocalBinds+    TcRnIncorrectNameSpace {}+      -> ErrorWithoutFlag+    TcRnNotInScope {}+      -> ErrorWithoutFlag+    TcRnUntickedPromotedThing {}+      -> WarningWithFlag Opt_WarnUntickedPromotedConstructors+    TcRnIllegalBuiltinSyntax {}+      -> ErrorWithoutFlag+    TcRnWarnDefaulting {}+      -> WarningWithFlag Opt_WarnTypeDefaults+    TcRnForeignImportPrimExtNotSet{}+      -> ErrorWithoutFlag+    TcRnForeignImportPrimSafeAnn{}+      -> ErrorWithoutFlag+    TcRnForeignFunctionImportAsValue{}+      -> ErrorWithoutFlag+    TcRnFunPtrImportWithoutAmpersand{}+      -> WarningWithFlag Opt_WarnDodgyForeignImports+    TcRnIllegalForeignDeclBackend{}+      -> ErrorWithoutFlag+    TcRnUnsupportedCallConv _ unsupportedCC+      -> case unsupportedCC of+           StdCallConvUnsupported -> WarningWithFlag Opt_WarnUnsupportedCallingConventions+           _ -> ErrorWithoutFlag+    TcRnIllegalForeignType{}+      -> ErrorWithoutFlag+    TcRnInvalidCIdentifier{}+      -> ErrorWithoutFlag++  diagnosticHints = \case+    TcRnUnknownMessage m+      -> diagnosticHints m+    TcRnMessageWithInfo _ msg_with_info+      -> case msg_with_info of+           TcRnMessageDetailed _ m -> diagnosticHints m+    TcRnSolverReport _ _ hints+      -> hints+    TcRnRedundantConstraints{}+      -> noHints+    TcRnInaccessibleCode{}+      -> noHints+    TcRnTypeDoesNotHaveFixedRuntimeRep{}+      -> noHints+    TcRnImplicitLift{}+      -> noHints+    TcRnUnusedPatternBinds{}+      -> noHints+    TcRnDodgyImports{}+      -> noHints+    TcRnDodgyExports{}+      -> noHints+    TcRnMissingImportList{}+      -> noHints+    TcRnUnsafeDueToPlugin{}+      -> noHints+    TcRnModMissingRealSrcSpan{}+      -> noHints+    TcRnIdNotExportedFromModuleSig name mod+      -> [SuggestAddToHSigExportList name $ Just mod]+    TcRnIdNotExportedFromLocalSig name+      -> [SuggestAddToHSigExportList name Nothing]+    TcRnShadowedName{}+      -> noHints+    TcRnDuplicateWarningDecls{}+      -> noHints+    TcRnSimplifierTooManyIterations{}+      -> [SuggestIncreaseSimplifierIterations]+    TcRnIllegalPatSynDecl{}+      -> noHints+    TcRnLinearPatSyn{}+      -> noHints+    TcRnEmptyRecordUpdate{}+      -> noHints+    TcRnIllegalFieldPunning{}+      -> [suggestExtension LangExt.NamedFieldPuns]+    TcRnIllegalWildcardsInRecord{}+      -> [suggestExtension LangExt.RecordWildCards]+    TcRnIllegalWildcardInType{}+      -> noHints+    TcRnDuplicateFieldName{}+      -> noHints+    TcRnIllegalViewPattern{}+      -> [suggestExtension LangExt.ViewPatterns]+    TcRnCharLiteralOutOfRange{}+      -> noHints+    TcRnIllegalWildcardsInConstructor{}+      -> noHints+    TcRnIgnoringAnnotations{}+      -> noHints+    TcRnAnnotationInSafeHaskell+      -> noHints+    TcRnInvalidTypeApplication{}+      -> noHints+    TcRnTagToEnumMissingValArg+      -> noHints+    TcRnTagToEnumUnspecifiedResTy{}+      -> noHints+    TcRnTagToEnumResTyNotAnEnum{}+      -> noHints+    TcRnArrowIfThenElsePredDependsOnResultTy+      -> noHints+    TcRnIllegalHsBootFileDecl+      -> noHints+    TcRnRecursivePatternSynonym{}+      -> noHints+    TcRnPartialTypeSigTyVarMismatch{}+      -> noHints+    TcRnPartialTypeSigBadQuantifier{}+      -> noHints+    TcRnMissingSignature {}+      -> noHints+    TcRnPolymorphicBinderMissingSig{}+      -> noHints+    TcRnOverloadedSig{}+      -> noHints+    TcRnTupleConstraintInst{}+      -> noHints+    TcRnAbstractClassInst{}+      -> noHints+    TcRnNoClassInstHead{}+      -> noHints+    TcRnUserTypeError{}+      -> noHints+    TcRnConstraintInKind{}+      -> noHints+    TcRnUnboxedTupleOrSumTypeFuncArg tuple_or_sum _+      -> [suggestExtension $ unboxedTupleOrSumExtension tuple_or_sum]+    TcRnLinearFuncInKind{}+      -> noHints+    TcRnForAllEscapeError{}+      -> noHints+    TcRnVDQInTermType{}+      -> noHints+    TcRnBadQuantPredHead{}+      -> noHints+    TcRnIllegalTupleConstraint{}+      -> [suggestExtension LangExt.ConstraintKinds]+    TcRnNonTypeVarArgInConstraint{}+      -> [suggestExtension LangExt.FlexibleContexts]+    TcRnIllegalImplicitParam{}+      -> noHints+    TcRnIllegalConstraintSynonymOfKind{}+      -> [suggestExtension LangExt.ConstraintKinds]+    TcRnIllegalClassInst{}+      -> noHints+    TcRnOversaturatedVisibleKindArg{}+      -> noHints+    TcRnBadAssociatedType{}+      -> noHints+    TcRnForAllRankErr rank _+      -> case rank of+           LimitedRank{}      -> [suggestExtension LangExt.RankNTypes]+           MonoTypeRankZero   -> [suggestExtension LangExt.RankNTypes]+           MonoTypeTyConArg   -> [suggestExtension LangExt.ImpredicativeTypes]+           MonoTypeSynArg     -> [suggestExtension LangExt.LiberalTypeSynonyms]+           MonoTypeConstraint -> [suggestExtension LangExt.QuantifiedConstraints]+           _                  -> noHints+    TcRnMonomorphicBindings bindings+      -> case bindings of+          []     -> noHints+          (x:xs) -> [SuggestAddTypeSignatures $ NamedBindings (x NE.:| xs)]+    TcRnOrphanInstance{}+      -> [SuggestFixOrphanInstance]+    TcRnFunDepConflict{}+      -> noHints+    TcRnDupInstanceDecls{}+      -> noHints+    TcRnConflictingFamInstDecls{}+      -> noHints+    TcRnFamInstNotInjective rea _ _+      -> case rea of+           InjErrRhsBareTyVar{}      -> noHints+           InjErrRhsCannotBeATypeFam -> noHints+           InjErrRhsOverlap          -> noHints+           InjErrCannotInferFromRhs _ _ suggestUndInst+             | YesSuggestUndecidableInstaces <- suggestUndInst+             -> [suggestExtension LangExt.UndecidableInstances]+             | otherwise+             -> noHints+    TcRnBangOnUnliftedType{}+      -> noHints+    TcRnMultipleDefaultDeclarations{}+      -> noHints+    TcRnBadDefaultType{}+      -> noHints+    TcRnPatSynBundledWithNonDataCon{}+      -> noHints+    TcRnPatSynBundledWithWrongType{}+      -> noHints+    TcRnDupeModuleExport{}+      -> noHints+    TcRnExportedModNotImported{}+      -> noHints+    TcRnNullExportedModule{}+      -> noHints+    TcRnMissingExportList{}+      -> noHints+    TcRnExportHiddenComponents{}+      -> noHints+    TcRnDuplicateExport{}+      -> noHints+    TcRnExportedParentChildMismatch{}+      -> noHints+    TcRnConflictingExports{}+      -> noHints+    TcRnAmbiguousField{}+      -> noHints+    TcRnMissingFields{}+      -> noHints+    TcRnFieldUpdateInvalidType{}+      -> noHints+    TcRnNoConstructorHasAllFields{}+      -> noHints+    TcRnMixedSelectors{}+      -> noHints+    TcRnMissingStrictFields{}+      -> noHints+    TcRnNoPossibleParentForFields{}+      -> noHints+    TcRnBadOverloadedRecordUpdate{}+      -> noHints+    TcRnStaticFormNotClosed{}+      -> noHints+    TcRnUselessTypeable+      -> noHints+    TcRnDerivingDefaults{}+      -> [useDerivingStrategies]+    TcRnNonUnaryTypeclassConstraint{}+      -> noHints+    TcRnPartialTypeSignatures suggestParSig _+      -> case suggestParSig of+           YesSuggestPartialTypeSignatures+             -> let info = text "to use the inferred type"+                in [suggestExtensionWithInfo info LangExt.PartialTypeSignatures]+           NoSuggestPartialTypeSignatures+             -> noHints+    TcRnCannotDeriveInstance cls _ _ newtype_deriving rea+      -> deriveInstanceErrReasonHints cls newtype_deriving rea+    TcRnLazyGADTPattern+      -> noHints+    TcRnArrowProcGADTPattern+      -> noHints+    TcRnSpecialClassInst {}+      -> noHints+    TcRnForallIdentifier {}+      -> [SuggestRenameForall]+    TcRnTypeEqualityOutOfScope+      -> noHints+    TcRnTypeEqualityRequiresOperators+      -> [suggestExtension LangExt.TypeOperators]+    TcRnIllegalTypeOperator {}+      -> [suggestExtension LangExt.TypeOperators]+    TcRnGADTMonoLocalBinds {}+      -> [suggestAnyExtension [LangExt.GADTs, LangExt.TypeFamilies]]+    TcRnIncorrectNameSpace nm is_th_use+      | is_th_use+      -> [SuggestAppropriateTHTick $ nameNameSpace nm]+      | otherwise+      -> noHints+    TcRnNotInScope err _ _ hints+      -> scopeErrorHints err ++ hints+    TcRnUntickedPromotedThing thing+      -> [SuggestAddTick thing]+    TcRnIllegalBuiltinSyntax {}+      -> noHints+    TcRnWarnDefaulting {}+      -> noHints+    TcRnForeignImportPrimExtNotSet{}+      -> [suggestExtension LangExt.GHCForeignImportPrim]+    TcRnForeignImportPrimSafeAnn{}+      -> noHints+    TcRnForeignFunctionImportAsValue{}+      -> noHints+    TcRnFunPtrImportWithoutAmpersand{}+      -> noHints+    TcRnIllegalForeignDeclBackend{}+      -> noHints+    TcRnUnsupportedCallConv{}+      -> noHints+    TcRnIllegalForeignType _ reason+      -> case reason of+           TypeCannotBeMarshaled _ why+             | NewtypeDataConNotInScope{} <- why -> [SuggestImportingDataCon]+             | UnliftedFFITypesNeeded <- why -> [suggestExtension LangExt.UnliftedFFITypes]+           _ -> noHints+    TcRnInvalidCIdentifier{}+      -> noHints++deriveInstanceErrReasonHints :: Class+                             -> UsingGeneralizedNewtypeDeriving+                             -> DeriveInstanceErrReason+                             -> [GhcHint]+deriveInstanceErrReasonHints cls newtype_deriving = \case+  DerivErrNotWellKinded _ _ n_args_to_keep+    | cls `hasKey` gen1ClassKey && n_args_to_keep >= 0+    -> [suggestExtension LangExt.PolyKinds]+    | otherwise+    -> noHints+  DerivErrSafeHaskellGenericInst  -> noHints+  DerivErrDerivingViaWrongKind{}  -> noHints+  DerivErrNoEtaReduce{}           -> noHints+  DerivErrBootFileFound           -> noHints+  DerivErrDataConsNotAllInScope{} -> noHints+  DerivErrGNDUsedOnData           -> noHints+  DerivErrNullaryClasses          -> noHints+  DerivErrLastArgMustBeApp        -> noHints+  DerivErrNoFamilyInstance{}      -> noHints+  DerivErrNotStockDeriveable deriveAnyClassEnabled+    | deriveAnyClassEnabled == NoDeriveAnyClassEnabled+    -> [suggestExtension LangExt.DeriveAnyClass]+    | otherwise+    -> noHints+  DerivErrHasAssociatedDatatypes{}+    -> noHints+  DerivErrNewtypeNonDeriveableClass+    | newtype_deriving == NoGeneralizedNewtypeDeriving+    -> [useGND]+    | otherwise+    -> noHints+  DerivErrCannotEtaReduceEnough{}+    | newtype_deriving == NoGeneralizedNewtypeDeriving+    -> [useGND]+    | otherwise+    -> noHints+  DerivErrOnlyAnyClassDeriveable _ deriveAnyClassEnabled+    | deriveAnyClassEnabled == NoDeriveAnyClassEnabled+    -> [suggestExtension LangExt.DeriveAnyClass]+    | otherwise+    -> noHints+  DerivErrNotDeriveable deriveAnyClassEnabled+    | deriveAnyClassEnabled == NoDeriveAnyClassEnabled+    -> [suggestExtension LangExt.DeriveAnyClass]+    | otherwise+    -> noHints+  DerivErrNotAClass{}+    -> noHints+  DerivErrNoConstructors{}+    -> let info = text "to enable deriving for empty data types"+       in [useExtensionInOrderTo info LangExt.EmptyDataDeriving]+  DerivErrLangExtRequired{}+    -- This is a slightly weird corner case of GHC: we are failing+    -- to derive a typeclass instance because a particular 'Extension'+    -- is not enabled (and so we report in the main error), but here+    -- we don't want to /repeat/ to enable the extension in the hint.+    -> noHints+  DerivErrDunnoHowToDeriveForType{}+    -> noHints+  DerivErrMustBeEnumType rep_tc+    -- We want to suggest GND only if this /is/ a newtype.+    | newtype_deriving == NoGeneralizedNewtypeDeriving && isNewTyCon rep_tc+    -> [useGND]+    | otherwise+    -> noHints+  DerivErrMustHaveExactlyOneConstructor{}+    -> noHints+  DerivErrMustHaveSomeParameters{}+    -> noHints+  DerivErrMustNotHaveClassContext{}+    -> noHints+  DerivErrBadConstructor wcard _+    -> case wcard of+         Nothing        -> noHints+         Just YesHasWildcard -> [SuggestFillInWildcardConstraint]+         Just NoHasWildcard  -> [SuggestAddStandaloneDerivation]+  DerivErrGenerics{}+    -> noHints+  DerivErrEnumOrProduct{}+    -> noHints++messageWithInfoDiagnosticMessage :: UnitState+                                 -> ErrInfo+                                 -> DecoratedSDoc+                                 -> DecoratedSDoc+messageWithInfoDiagnosticMessage unit_state ErrInfo{..} important =+  let err_info' = map (pprWithUnitState unit_state) [errInfoContext, errInfoSupplementary]+      in (mapDecoratedSDoc (pprWithUnitState unit_state) important) `unionDecoratedSDoc`+         mkDecorated err_info'++dodgy_msg :: (Outputable a, Outputable b) => SDoc -> a -> b -> SDoc+dodgy_msg kind tc ie+  = sep [ text "The" <+> kind <+> text "item"+                     <+> quotes (ppr ie)+                <+> text "suggests that",+          quotes (ppr tc) <+> text "has (in-scope) constructors or class methods,",+          text "but it has none" ]++dodgy_msg_insert :: forall p . IdP (GhcPass p) -> IE (GhcPass p)+dodgy_msg_insert tc = IEThingAll noAnn ii+  where+    ii :: LIEWrappedName (IdP (GhcPass p))+    ii = noLocA (IEName $ noLocA tc)++pprTypeDoesNotHaveFixedRuntimeRep :: Type -> FixedRuntimeRepProvenance -> SDoc+pprTypeDoesNotHaveFixedRuntimeRep ty prov =+  let what = pprFixedRuntimeRepProvenance prov+  in text "The" <+> what <+> text "does not have a fixed runtime representation:"+  $$ format_frr_err ty++format_frr_err :: Type  -- ^ the type which doesn't have a fixed runtime representation+                -> SDoc+format_frr_err ty+  = (bullet <+> ppr tidy_ty <+> dcolon <+> ppr tidy_ki)+  where+    (tidy_env, tidy_ty) = tidyOpenType emptyTidyEnv ty+    tidy_ki             = tidyType tidy_env (tcTypeKind ty)++pprField :: (FieldLabelString, TcType) -> SDoc+pprField (f,ty) = ppr f <+> dcolon <+> ppr ty++pprRecordFieldPart :: RecordFieldPart -> SDoc+pprRecordFieldPart = \case+  RecordFieldConstructor{} -> text "construction"+  RecordFieldPattern{}     -> text "pattern"+  RecordFieldUpdate        -> text "update"++pprBindings :: [Name] -> SDoc+pprBindings = pprWithCommas (quotes . ppr)++injectivityErrorHerald :: SDoc+injectivityErrorHerald =+  text "Type family equation violates the family's injectivity annotation."++formatExportItemError :: SDoc -> String -> SDoc+formatExportItemError exportedThing reason =+  hsep [ text "The export item"+       , quotes exportedThing+       , text reason ]++-- | What warning flag is associated with the given missing signature?+missingSignatureWarningFlag :: MissingSignature -> Exported -> Bool -> WarningFlag+missingSignatureWarningFlag (MissingTopLevelBindingSig {}) exported overridden+  | IsExported <- exported+  , not overridden+  = Opt_WarnMissingExportedSignatures+  | otherwise+  = Opt_WarnMissingSignatures+missingSignatureWarningFlag (MissingPatSynSig {}) exported overridden+  | IsExported <- exported+  , not overridden+  = Opt_WarnMissingExportedPatternSynonymSignatures+  | otherwise+  = Opt_WarnMissingPatternSynonymSignatures+missingSignatureWarningFlag (MissingTyConKindSig {}) _ _+  = Opt_WarnMissingKindSignatures++useDerivingStrategies :: GhcHint+useDerivingStrategies =+  useExtensionInOrderTo (text "to pick a different strategy") LangExt.DerivingStrategies++useGND :: GhcHint+useGND = let info = text "for GHC's" <+> text "newtype-deriving extension"+         in suggestExtensionWithInfo info LangExt.GeneralizedNewtypeDeriving++cannotMakeDerivedInstanceHerald :: Class+                                -> [Type]+                                -> Maybe (DerivStrategy GhcTc)+                                -> UsingGeneralizedNewtypeDeriving+                                -> Bool -- ^ If False, only prints the why.+                                -> SDoc+                                -> SDoc+cannotMakeDerivedInstanceHerald cls cls_args mb_strat newtype_deriving pprHerald why =+  if pprHerald+     then sep [(hang (text "Can't make a derived instance of")+                   2 (quotes (ppr pred) <+> via_mechanism)+                $$ nest 2 extra) <> colon,+               nest 2 why]+      else why+  where+    strat_used = isJust mb_strat+    extra | not strat_used, (newtype_deriving == YesGeneralizedNewtypeDeriving)+          = text "(even with cunning GeneralizedNewtypeDeriving)"+          | otherwise = empty+    pred = mkClassPred cls cls_args+    via_mechanism | strat_used+                  , Just strat <- mb_strat+                  = text "with the" <+> (derivStrategyName strat) <+> text "strategy"+                  | otherwise+                  = empty++badCon :: DataCon -> SDoc -> SDoc+badCon con msg = text "Constructor" <+> quotes (ppr con) <+> msg++derivErrDiagnosticMessage :: Class+                          -> [Type]+                          -> Maybe (DerivStrategy GhcTc)+                          -> UsingGeneralizedNewtypeDeriving+                          -> Bool -- If True, includes the herald \"can't make a derived..\"+                          -> DeriveInstanceErrReason+                          -> SDoc+derivErrDiagnosticMessage cls cls_tys mb_strat newtype_deriving pprHerald = \case+  DerivErrNotWellKinded tc cls_kind _+    -> sep [ hang (text "Cannot derive well-kinded instance of form"+                         <+> quotes (pprClassPred cls cls_tys+                                       <+> parens (ppr tc <+> text "...")))+                  2 empty+           , nest 2 (text "Class" <+> quotes (ppr cls)+                         <+> text "expects an argument of kind"+                         <+> quotes (pprKind cls_kind))+           ]+  DerivErrSafeHaskellGenericInst+    ->     text "Generic instances can only be derived in"+       <+> text "Safe Haskell using the stock strategy."+  DerivErrDerivingViaWrongKind cls_kind via_ty via_kind+    -> hang (text "Cannot derive instance via" <+> quotes (pprType via_ty))+          2 (text "Class" <+> quotes (ppr cls)+                  <+> text "expects an argument of kind"+                  <+> quotes (pprKind cls_kind) <> char ','+         $+$ text "but" <+> quotes (pprType via_ty)+                  <+> text "has kind" <+> quotes (pprKind via_kind))+  DerivErrNoEtaReduce inst_ty+    -> sep [text "Cannot eta-reduce to an instance of form",+            nest 2 (text "instance (...) =>"+                   <+> pprClassPred cls (cls_tys ++ [inst_ty]))]+  DerivErrBootFileFound+    -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald+         (text "Cannot derive instances in hs-boot files"+          $+$ text "Write an instance declaration instead")+  DerivErrDataConsNotAllInScope tc+    -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald+         (hang (text "The data constructors of" <+> quotes (ppr tc) <+> text "are not all in scope")+            2 (text "so you cannot derive an instance for it"))+  DerivErrGNDUsedOnData+    -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald+         (text "GeneralizedNewtypeDeriving cannot be used on non-newtypes")+  DerivErrNullaryClasses+    -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald+         (text "Cannot derive instances for nullary classes")+  DerivErrLastArgMustBeApp+    -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald+         ( text "The last argument of the instance must be a"+         <+> text "data or newtype application")+  DerivErrNoFamilyInstance tc tc_args+    -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald+         (text "No family instance for" <+> quotes (pprTypeApp tc tc_args))+  DerivErrNotStockDeriveable _+    -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald+         (quotes (ppr cls) <+> text "is not a stock derivable class (Eq, Show, etc.)")+  DerivErrHasAssociatedDatatypes hasAdfs at_last_cls_tv_in_kinds at_without_last_cls_tv+    -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald+         $ vcat [ ppWhen (hasAdfs == YesHasAdfs) adfs_msg+               , case at_without_last_cls_tv of+                    YesAssociatedTyNotParamOverLastTyVar tc -> at_without_last_cls_tv_msg tc+                    NoAssociatedTyNotParamOverLastTyVar     -> empty+               , case at_last_cls_tv_in_kinds of+                   YesAssocTyLastVarInKind tc -> at_last_cls_tv_in_kinds_msg tc+                   NoAssocTyLastVarInKind     -> empty+               ]+       where++         adfs_msg  = text "the class has associated data types"++         at_without_last_cls_tv_msg at_tc = hang+           (text "the associated type" <+> quotes (ppr at_tc)+            <+> text "is not parameterized over the last type variable")+           2 (text "of the class" <+> quotes (ppr cls))++         at_last_cls_tv_in_kinds_msg at_tc = hang+           (text "the associated type" <+> quotes (ppr at_tc)+            <+> text "contains the last type variable")+          2 (text "of the class" <+> quotes (ppr cls)+            <+> text "in a kind, which is not (yet) allowed")+  DerivErrNewtypeNonDeriveableClass+    -> derivErrDiagnosticMessage cls cls_tys mb_strat newtype_deriving pprHerald (DerivErrNotStockDeriveable NoDeriveAnyClassEnabled)+  DerivErrCannotEtaReduceEnough eta_ok+    -> let cant_derive_err = ppUnless eta_ok eta_msg+           eta_msg = text "cannot eta-reduce the representation type enough"+       in cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald+          cant_derive_err+  DerivErrOnlyAnyClassDeriveable tc _+    -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald+         (quotes (ppr tc) <+> text "is a type class,"+                          <+> text "and can only have a derived instance"+                          $+$ text "if DeriveAnyClass is enabled")+  DerivErrNotDeriveable _+    -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald empty+  DerivErrNotAClass predType+    -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald+         (quotes (ppr predType) <+> text "is not a class")+  DerivErrNoConstructors rep_tc+    -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald+         (quotes (pprSourceTyCon rep_tc) <+> text "must have at least one data constructor")+  DerivErrLangExtRequired ext+    -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald+         (text "You need " <> ppr ext+            <+> text "to derive an instance for this class")+  DerivErrDunnoHowToDeriveForType ty+    -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald+        (hang (text "Don't know how to derive" <+> quotes (ppr cls))+              2 (text "for type" <+> quotes (ppr ty)))+  DerivErrMustBeEnumType rep_tc+    -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald+         (sep [ quotes (pprSourceTyCon rep_tc) <+>+                text "must be an enumeration type"+              , text "(an enumeration consists of one or more nullary, non-GADT constructors)" ])++  DerivErrMustHaveExactlyOneConstructor rep_tc+    -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald+         (quotes (pprSourceTyCon rep_tc) <+> text "must have precisely one constructor")+  DerivErrMustHaveSomeParameters rep_tc+    -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald+         (text "Data type" <+> quotes (ppr rep_tc) <+> text "must have some type parameters")+  DerivErrMustNotHaveClassContext rep_tc bad_stupid_theta+    -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald+         (text "Data type" <+> quotes (ppr rep_tc)+           <+> text "must not have a class context:" <+> pprTheta bad_stupid_theta)+  DerivErrBadConstructor _ reasons+    -> let why = vcat $ map renderReason reasons+       in cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald why+         where+           renderReason = \case+                 DerivErrBadConExistential con+                   -> badCon con $ text "must be truly polymorphic in the last argument of the data type"+                 DerivErrBadConCovariant con+                   -> badCon con $ text "must not use the type variable in a function argument"+                 DerivErrBadConFunTypes con+                   -> badCon con $ text "must not contain function types"+                 DerivErrBadConWrongArg con+                   -> badCon con $ text "must use the type variable only as the last argument of a data type"+                 DerivErrBadConIsGADT con+                   -> badCon con $ text "is a GADT"+                 DerivErrBadConHasExistentials con+                   -> badCon con $ text "has existential type variables in its type"+                 DerivErrBadConHasConstraints con+                   -> badCon con $ text "has constraints in its type"+                 DerivErrBadConHasHigherRankType con+                   -> badCon con $ text "has a higher-rank type"+  DerivErrGenerics reasons+    -> let why = vcat $ map renderReason reasons+       in cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald why+         where+           renderReason = \case+             DerivErrGenericsMustNotHaveDatatypeContext tc_name+                -> ppr tc_name <+> text "must not have a datatype context"+             DerivErrGenericsMustNotHaveExoticArgs dc+                -> ppr dc <+> text "must not have exotic unlifted or polymorphic arguments"+             DerivErrGenericsMustBeVanillaDataCon dc+                -> ppr dc <+> text "must be a vanilla data constructor"+             DerivErrGenericsMustHaveSomeTypeParams rep_tc+                ->     text "Data type" <+> quotes (ppr rep_tc)+                   <+> text "must have some type parameters"+             DerivErrGenericsMustNotHaveExistentials con+               -> badCon con $ text "must not have existential arguments"+             DerivErrGenericsWrongArgKind con+               -> badCon con $+                    text "applies a type to an argument involving the last parameter"+                 $$ text "but the applied type is not of kind * -> *"+  DerivErrEnumOrProduct this that+    -> let ppr1 = derivErrDiagnosticMessage cls cls_tys mb_strat newtype_deriving False this+           ppr2 = derivErrDiagnosticMessage cls cls_tys mb_strat newtype_deriving False that+       in cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald+          (ppr1 $$ text "  or" $$ ppr2)++{- *********************************************************************+*                                                                      *+              Outputable SolverReportErrCtxt (for debugging)+*                                                                      *+**********************************************************************-}++instance Outputable SolverReportErrCtxt where+  ppr (CEC { cec_binds              = bvar+           , cec_defer_type_errors  = dte+           , cec_expr_holes         = eh+           , cec_type_holes         = th+           , cec_out_of_scope_holes = osh+           , cec_warn_redundant     = wr+           , cec_expand_syns        = es+           , cec_suppress           = sup })+    = text "CEC" <+> braces (vcat+         [ text "cec_binds"              <+> equals <+> ppr bvar+         , text "cec_defer_type_errors"  <+> equals <+> ppr dte+         , text "cec_expr_holes"         <+> equals <+> ppr eh+         , text "cec_type_holes"         <+> equals <+> ppr th+         , text "cec_out_of_scope_holes" <+> equals <+> ppr osh+         , text "cec_warn_redundant"     <+> equals <+> ppr wr+         , text "cec_expand_syns"        <+> equals <+> ppr es+         , text "cec_suppress"           <+> equals <+> ppr sup ])++{- *********************************************************************+*                                                                      *+                    Outputting TcSolverReportMsg errors+*                                                                      *+**********************************************************************-}++-- | Pretty-print a 'SolverReportWithCtxt', containing a 'TcSolverReportMsg'+-- with its enclosing 'SolverReportErrCtxt'.+pprSolverReportWithCtxt :: SolverReportWithCtxt -> SDoc+pprSolverReportWithCtxt (SolverReportWithCtxt { reportContext = ctxt, reportContent = msg })+   = pprTcSolverReportMsg ctxt msg++-- | Pretty-print a 'TcSolverReportMsg', with its enclosing 'SolverReportErrCtxt'.+pprTcSolverReportMsg :: SolverReportErrCtxt -> TcSolverReportMsg -> SDoc+pprTcSolverReportMsg ctxt (TcReportWithInfo msg (info :| infos)) =+  vcat+    ( pprTcSolverReportMsg ctxt msg+    : pprTcSolverReportInfo ctxt info+    : map (pprTcSolverReportInfo ctxt) infos )+pprTcSolverReportMsg _ (BadTelescope telescope skols) =+  hang (text "These kind and type variables:" <+> ppr telescope $$+       text "are out of dependency order. Perhaps try this ordering:")+    2 (pprTyVars sorted_tvs)+  where+    sorted_tvs = scopedSort skols+pprTcSolverReportMsg _ (UserTypeError ty) =+  pprUserTypeErrorTy ty+pprTcSolverReportMsg ctxt (ReportHoleError hole err) =+  pprHoleError ctxt hole err+pprTcSolverReportMsg _ (CannotUnifyWithPolytype item tv1 ty2) =+  vcat [ (if isSkolemTyVar tv1+          then text "Cannot equate type variable"+          else text "Cannot instantiate unification variable")+         <+> quotes (ppr tv1)+       , hang (text "with a" <+> what <+> text "involving polytypes:") 2 (ppr ty2) ]+  where+    what = text $ levelString $+           ctLocTypeOrKind_maybe (errorItemCtLoc item) `orElse` TypeLevel+pprTcSolverReportMsg _+  (Mismatch { mismatch_ea   = add_ea+            , mismatch_item = item+            , mismatch_ty1  = ty1+            , mismatch_ty2  = ty2 })+  = addArising (errorItemOrigin item) msg+  where+    msg+      | (isLiftedRuntimeRep ty1 && isUnliftedRuntimeRep ty2) ||+        (isLiftedRuntimeRep ty2 && isUnliftedRuntimeRep ty1) ||+        (isLiftedLevity ty1 && isUnliftedLevity ty2) ||+        (isLiftedLevity ty2 && isUnliftedLevity ty1)+      = text "Couldn't match a lifted type with an unlifted type"++      | isAtomicTy ty1 || isAtomicTy ty2+      = -- Print with quotes+        sep [ text herald1 <+> quotes (ppr ty1)+            , nest padding $+              text herald2 <+> quotes (ppr ty2) ]++      | otherwise+      = -- Print with vertical layout+        vcat [ text herald1 <> colon <+> ppr ty1+             , nest padding $+               text herald2 <> colon <+> ppr ty2 ]++    herald1 = conc [ "Couldn't match"+                   , if is_repr then "representation of" else ""+                   , if add_ea then "expected"          else ""+                   , what ]+    herald2 = conc [ "with"+                   , if is_repr then "that of"          else ""+                   , if add_ea then ("actual " ++ what) else "" ]++    padding = length herald1 - length herald2++    is_repr = case errorItemEqRel item of { ReprEq -> True; NomEq -> False }++    what = levelString (ctLocTypeOrKind_maybe (errorItemCtLoc item) `orElse` TypeLevel)++    conc :: [String] -> String+    conc = foldr1 add_space++    add_space :: String -> String -> String+    add_space s1 s2 | null s1   = s2+                    | null s2   = s1+                    | otherwise = s1 ++ (' ' : s2)+pprTcSolverReportMsg _+  (KindMismatch { kmismatch_what     = thing+                , kmismatch_expected = exp+                , kmismatch_actual   = act })+  = hang (text "Expected" <+> kind_desc <> comma)+      2 (text "but" <+> quotes (ppr thing) <+> text "has kind" <+>+        quotes (ppr act))+  where+    kind_desc | tcIsConstraintKind exp = text "a constraint"+              | Just arg <- kindRep_maybe exp  -- TYPE t0+              , tcIsTyVarTy arg = sdocOption sdocPrintExplicitRuntimeReps $ \case+                                   True  -> text "kind" <+> quotes (ppr exp)+                                   False -> text "a type"+              | otherwise       = text "kind" <+> quotes (ppr exp)+++pprTcSolverReportMsg ctxt+  (TypeEqMismatch { teq_mismatch_ppr_explicit_kinds = ppr_explicit_kinds+                  , teq_mismatch_item     = item+                  , teq_mismatch_ty1      = ty1+                  , teq_mismatch_ty2      = ty2+                  , teq_mismatch_expected = exp+                  , teq_mismatch_actual   = act+                  , teq_mismatch_what     = mb_thing })+  = addArising orig $ pprWithExplicitKindsWhen ppr_explicit_kinds msg+  where+    msg+      | isUnliftedTypeKind act, isLiftedTypeKind exp+      = sep [ text "Expecting a lifted type, but"+            , thing_msg mb_thing (text "an") (text "unlifted") ]+      | isLiftedTypeKind act, isUnliftedTypeKind exp+      = sep [ text "Expecting an unlifted type, but"+            , thing_msg mb_thing (text "a") (text "lifted") ]+      | tcIsLiftedTypeKind exp+      = maybe_num_args_msg $$+        sep [ text "Expected a type, but"+            , case mb_thing of+                Nothing    -> text "found something with kind"+                Just thing -> quotes (ppr thing) <+> text "has kind"+            , quotes (pprWithTYPE act) ]+      | Just nargs_msg <- num_args_msg+      , Right ea_msg <- mk_ea_msg ctxt (Just item) level orig+      = nargs_msg $$ pprTcSolverReportMsg ctxt ea_msg+      | -- pprTrace "check" (ppr ea_looks_same $$ ppr exp $$ ppr act $$ ppr ty1 $$ ppr ty2) $+        ea_looks_same ty1 ty2 exp act+      , Right ea_msg <- mk_ea_msg ctxt (Just item) level orig+      = pprTcSolverReportMsg ctxt ea_msg+      -- The mismatched types are /inside/ exp and act+      | let mismatch_err = Mismatch False item ty1 ty2+            errs = case mk_ea_msg ctxt Nothing level orig of+              Left ea_info -> [ mkTcReportWithInfo mismatch_err ea_info ]+              Right ea_err -> [ mismatch_err, ea_err ]+      = vcat $ map (pprTcSolverReportMsg ctxt) errs++    ct_loc = errorItemCtLoc item+    orig   = errorItemOrigin item+    level  = ctLocTypeOrKind_maybe ct_loc `orElse` TypeLevel++    thing_msg (Just thing) _  levity = quotes (ppr thing) <+> text "is" <+> levity+    thing_msg Nothing      an levity = text "got" <+> an <+> levity <+> text "type"++    num_args_msg = case level of+      KindLevel+        | not (isMetaTyVarTy exp) && not (isMetaTyVarTy act)+           -- if one is a meta-tyvar, then it's possible that the user+           -- has asked for something impredicative, and we couldn't unify.+           -- Don't bother with counting arguments.+        -> let n_act = count_args act+               n_exp = count_args exp in+           case n_act - n_exp of+             n | n > 0   -- we don't know how many args there are, so don't+                         -- recommend removing args that aren't+               , Just thing <- mb_thing+               -> Just $ pprTcSolverReportMsg ctxt (ExpectingMoreArguments n thing)+             _ -> Nothing++      _ -> Nothing++    maybe_num_args_msg = num_args_msg `orElse` empty++    count_args ty = count isVisibleBinder $ fst $ splitPiTys ty+pprTcSolverReportMsg _ (FixedRuntimeRepError frr_origs) =+  vcat (map make_msg frr_origs)+  where+    -- Assemble the error message: pair up each origin with the corresponding type, e.g.+    --   • FixedRuntimeRep origin msg 1 ...+    --       a :: TYPE r1+    --   • FixedRuntimeRep origin msg 2 ...+    --       b :: TYPE r2+    make_msg :: FixedRuntimeRepErrorInfo -> SDoc+    make_msg (FRR_Info { frr_info_origin =+                           FixedRuntimeRepOrigin+                             { frr_type    = ty+                             , frr_context = frr_ctxt }+                       , frr_info_not_concrete =+                         mb_not_conc }) =+      -- Add bullet points if there is more than one error.+      (if length frr_origs > 1 then (bullet <+>) else id) $+        vcat [ sep [ pprFixedRuntimeRepContext frr_ctxt+                   , text "does not have a fixed runtime representation." ]+             , type_printout ty+             , case mb_not_conc of+                Nothing -> empty+                Just (conc_tv, not_conc) ->+                  unsolved_concrete_eq_explanation conc_tv not_conc ]++    -- Don't print out the type (only the kind), if the type includes+    -- a confusing cast, unless the user passed -fprint-explicit-coercions.+    --+    -- Example:+    --+    --   In T20363, we have a representation-polymorphism error with a type+    --   of the form+    --+    --     ( (# #) |> co ) :: TYPE NilRep+    --+    --   where NilRep is a nullary type family application which reduces to TupleRep '[].+    --   We prefer avoiding showing the cast to the user, but we also don't want to+    --   print the confusing:+    --+    --     (# #) :: TYPE NilRep+    --+    --  So in this case we simply don't print the type, only the kind.+    confusing_cast :: Type -> Bool+    confusing_cast ty =+      case ty of+        CastTy inner_ty _+          -- A confusing cast is one that is responsible+          -- for a representation-polymorphism error.+          -> isConcrete (typeKind inner_ty)+        _ -> False++    type_printout :: Type -> SDoc+    type_printout ty =+      sdocOption sdocPrintExplicitCoercions $ \ show_coercions ->+        if  confusing_cast ty && not show_coercions+        then vcat [ text "Its kind is:"+                  , nest 2 $ pprWithTYPE (typeKind ty)+                  , text "(Use -fprint-explicit-coercions to see the full type.)" ]+        else vcat [ text "Its type is:"+                  , nest 2 $ ppr ty <+> dcolon <+> pprWithTYPE (typeKind ty) ]++    unsolved_concrete_eq_explanation :: TcTyVar -> Type -> SDoc+    unsolved_concrete_eq_explanation tv not_conc =+          text "Cannot unify" <+> quotes (ppr not_conc)+      <+> text "with the type variable" <+> quotes (ppr tv)+      $$  text "because it is not a concrete" <+> what <> dot+      where+        ki = tyVarKind tv+        what :: SDoc+        what+          | isRuntimeRepTy ki+          = quotes (text "RuntimeRep")+          | isLevityTy ki+          = quotes (text "Levity")+          | otherwise+          = text "type"++pprTcSolverReportMsg _ (SkolemEscape item implic esc_skols) =+  let+    esc_doc = sep [ text "because" <+> what <+> text "variable" <> plural esc_skols+                <+> pprQuotedList esc_skols+              , text "would escape" <+>+                if isSingleton esc_skols then text "its scope"+                                         else text "their scope" ]+  in+  vcat [ nest 2 $ esc_doc+       , sep [ (if isSingleton esc_skols+                then text "This (rigid, skolem)" <+>+                     what <+> text "variable is"+                else text "These (rigid, skolem)" <+>+                     what <+> text "variables are")+         <+> text "bound by"+       , nest 2 $ ppr (ic_info implic)+       , nest 2 $ text "at" <+>+         ppr (getLclEnvLoc (ic_env implic)) ] ]+  where+    what = text $ levelString $+           ctLocTypeOrKind_maybe (errorItemCtLoc item) `orElse` TypeLevel+pprTcSolverReportMsg _ (UntouchableVariable tv implic)+  | Implic { ic_given = given, ic_info = skol_info } <- implic+  = sep [ quotes (ppr tv) <+> text "is untouchable"+        , nest 2 $ text "inside the constraints:" <+> pprEvVarTheta given+        , nest 2 $ text "bound by" <+> ppr skol_info+        , nest 2 $ text "at" <+>+          ppr (getLclEnvLoc (ic_env implic)) ]+pprTcSolverReportMsg _ (BlockedEquality item) =+  vcat [ hang (text "Cannot use equality for substitution:")+           2 (ppr (errorItemPred item))+       , text "Doing so would be ill-kinded." ]+pprTcSolverReportMsg _ (ExpectingMoreArguments n thing) =+  text "Expecting" <+> speakN (abs n) <+>+    more <+> quotes (ppr thing)+  where+    more+     | n == 1    = text "more argument to"+     | otherwise = text "more arguments to" -- n > 1+pprTcSolverReportMsg ctxt (UnboundImplicitParams (item :| items)) =+  let givens = getUserGivens ctxt+  in if null givens+     then addArising (errorItemOrigin item) $+            sep [ text "Unbound implicit parameter" <> plural preds+                , nest 2 (pprParendTheta preds) ]+     else pprTcSolverReportMsg ctxt (CouldNotDeduce givens (item :| items) Nothing)+  where+    preds = map errorItemPred (item : items)+pprTcSolverReportMsg ctxt (CouldNotDeduce useful_givens (item :| others) mb_extra)+  = main_msg $$+     case supplementary of+      Left infos+        -> vcat (map (pprTcSolverReportInfo ctxt) infos)+      Right other_msg+        -> pprTcSolverReportMsg ctxt other_msg+  where+    main_msg+      | null useful_givens+      = addArising orig (no_instance_msg <+> missing)+      | otherwise+      = vcat (addArising orig (no_deduce_msg <+> missing)+              : pp_givens useful_givens)++    supplementary = case mb_extra of+      Nothing+        -> Left []+      Just (CND_Extra level ty1 ty2)+        -> mk_supplementary_ea_msg ctxt level ty1 ty2 orig+    orig = errorItemOrigin item+    wanteds = map errorItemPred (item:others)++    no_instance_msg =+      case wanteds of+        [wanted] | Just (tc, _) <- splitTyConApp_maybe wanted+                 -- Don't say "no instance" for a constraint such as "c" for a type variable c.+                 , isClassTyCon tc -> text "No instance for"+        _ -> text "Could not solve:"++    no_deduce_msg =+      case wanteds of+        [_wanted] -> text "Could not deduce"+        _         -> text "Could not deduce:"++    missing =+      case wanteds of+        [wanted] -> pprParendType wanted+        _        -> pprTheta wanteds++pprTcSolverReportMsg ctxt (AmbiguityPreventsSolvingCt item ambigs) =+  pprTcSolverReportInfo ctxt (Ambiguity True ambigs) <+>+  pprArising (errorItemOrigin item) $$+  text "prevents the constraint" <+> quotes (pprParendType $ errorItemPred item)+  <+> text "from being solved."+pprTcSolverReportMsg ctxt@(CEC {cec_encl = implics})+  (CannotResolveInstance item unifiers candidates imp_errs suggs binds)+  =+    vcat+      [ pprTcSolverReportMsg ctxt no_inst_msg+      , nest 2 extra_note+      , mb_patsyn_prov `orElse` empty+      , ppWhen (has_ambigs && not (null unifiers && null useful_givens))+        (vcat [ ppUnless lead_with_ambig $+                  pprTcSolverReportInfo ctxt (Ambiguity False (ambig_kvs, ambig_tvs))+              , pprRelevantBindings binds+              , potential_msg ])+      , ppWhen (isNothing mb_patsyn_prov) $+            -- Don't suggest fixes for the provided context of a pattern+            -- synonym; the right fix is to bind more in the pattern+        show_fixes (ctxtFixes has_ambigs pred implics+                    ++ drv_fixes)+      , ppWhen (not (null candidates))+        (hang (text "There are instances for similar types:")+            2 (vcat (map ppr candidates)))+            -- See Note [Report candidate instances]+      , vcat $ map ppr imp_errs+      , vcat $ map ppr suggs ]+  where+    orig          = errorItemOrigin item+    pred          = errorItemPred item+    (clas, tys)   = getClassPredTys pred+    -- See Note [Highlighting ambiguous type variables]+    (ambig_kvs, ambig_tvs) = ambigTkvsOfTy pred+    ambigs = ambig_kvs ++ ambig_tvs+    has_ambigs = not (null ambigs)+    useful_givens = discardProvCtxtGivens orig (getUserGivensFromImplics implics)+         -- useful_givens are the enclosing implications with non-empty givens,+         -- modulo the horrid discardProvCtxtGivens+    lead_with_ambig = not (null ambigs)+                   && not (any isRuntimeUnkSkol ambigs)+                   && not (null unifiers)+                   && null useful_givens++    no_inst_msg :: TcSolverReportMsg+    no_inst_msg+      | lead_with_ambig+      = AmbiguityPreventsSolvingCt item (ambig_kvs, ambig_tvs)+      | otherwise+      = CouldNotDeduce useful_givens (item :| []) Nothing++    -- Report "potential instances" only when the constraint arises+    -- directly from the user's use of an overloaded function+    want_potential (TypeEqOrigin {}) = False+    want_potential _                 = True++    potential_msg+      = ppWhen (not (null unifiers) && want_potential orig) $+          potential_hdr $$+          potentialInstancesErrMsg (PotentialInstances { matches = [], unifiers })++    potential_hdr+      = ppWhen lead_with_ambig $+        text "Probable fix: use a type annotation to specify what"+        <+> pprQuotedList ambig_tvs <+> text "should be."++    mb_patsyn_prov :: Maybe SDoc+    mb_patsyn_prov+      | not lead_with_ambig+      , ProvCtxtOrigin PSB{ psb_def = L _ pat } <- orig+      = Just (vcat [ text "In other words, a successful match on the pattern"+                   , nest 2 $ ppr pat+                   , text "does not provide the constraint" <+> pprParendType pred ])+      | otherwise = Nothing++    extra_note | any isFunTy (filterOutInvisibleTypes (classTyCon clas) tys)+               = text "(maybe you haven't applied a function to enough arguments?)"+               | className clas == typeableClassName  -- Avoid mysterious "No instance for (Typeable T)+               , [_,ty] <- tys                        -- Look for (Typeable (k->*) (T k))+               , Just (tc,_) <- tcSplitTyConApp_maybe ty+               , not (isTypeFamilyTyCon tc)+               = hang (text "GHC can't yet do polykinded")+                    2 (text "Typeable" <+>+                       parens (ppr ty <+> dcolon <+> ppr (tcTypeKind ty)))+               | otherwise+               = empty++    drv_fixes = case orig of+                   DerivClauseOrigin                  -> [drv_fix False]+                   StandAloneDerivOrigin              -> [drv_fix True]+                   DerivOriginDC _ _       standalone -> [drv_fix standalone]+                   DerivOriginCoerce _ _ _ standalone -> [drv_fix standalone]+                   _                -> []++    drv_fix standalone_wildcard+      | standalone_wildcard+      = text "fill in the wildcard constraint yourself"+      | otherwise+      = hang (text "use a standalone 'deriving instance' declaration,")+           2 (text "so you can specify the instance context yourself")++pprTcSolverReportMsg (CEC {cec_encl = implics}) (OverlappingInstances item matches unifiers) =+  vcat+    [ addArising orig $+        (text "Overlapping instances for"+        <+> pprType (mkClassPred clas tys))+    , ppUnless (null matching_givens) $+                  sep [text "Matching givens (or their superclasses):"+                      , nest 2 (vcat matching_givens)]+    ,  potentialInstancesErrMsg+        (PotentialInstances { matches, unifiers })+    ,  ppWhen (null matching_givens && isSingleton matches && null unifiers) $+       -- Intuitively, some given matched the wanted in their+       -- flattened or rewritten (from given equalities) form+       -- but the matcher can't figure that out because the+       -- constraints are non-flat and non-rewritten so we+       -- simply report back the whole given+       -- context. Accelerate Smart.hs showed this problem.+         sep [ text "There exists a (perhaps superclass) match:"+             , nest 2 (vcat (pp_givens useful_givens))]++    ,  ppWhen (isSingleton matches) $+       parens (vcat [ ppUnless (null tyCoVars) $+                        text "The choice depends on the instantiation of" <+>+                          quotes (pprWithCommas ppr tyCoVars)+                    , ppUnless (null famTyCons) $+                        if (null tyCoVars)+                          then+                            text "The choice depends on the result of evaluating" <+>+                              quotes (pprWithCommas ppr famTyCons)+                          else+                            text "and the result of evaluating" <+>+                              quotes (pprWithCommas ppr famTyCons)+                    , ppWhen (null (matching_givens)) $+                      vcat [ text "To pick the first instance above, use IncoherentInstances"+                           , text "when compiling the other instance declarations"]+               ])]+  where+    orig            = errorItemOrigin item+    pred            = errorItemPred item+    (clas, tys)     = getClassPredTys pred+    tyCoVars        = tyCoVarsOfTypesList tys+    famTyCons       = filter isFamilyTyCon $ concatMap (nonDetEltsUniqSet . tyConsOfType) tys+    useful_givens   = discardProvCtxtGivens orig (getUserGivensFromImplics implics)+    matching_givens = mapMaybe matchable useful_givens+    matchable implic@(Implic { ic_given = evvars, ic_info = skol_info })+      = case ev_vars_matching of+             [] -> Nothing+             _  -> Just $ hang (pprTheta ev_vars_matching)+                            2 (sep [ text "bound by" <+> ppr skol_info+                                   , text "at" <+>+                                     ppr (getLclEnvLoc (ic_env implic)) ])+        where ev_vars_matching = [ pred+                                 | ev_var <- evvars+                                 , let pred = evVarPred ev_var+                                 , any can_match (pred : transSuperClasses pred) ]+              can_match pred+                 = case getClassPredTys_maybe pred of+                     Just (clas', tys') -> clas' == clas+                                          && isJust (tcMatchTys tys tys')+                     Nothing -> False+pprTcSolverReportMsg _ (UnsafeOverlap item matches unsafe_overlapped) =+  vcat [ addArising orig (text "Unsafe overlapping instances for"+                  <+> pprType (mkClassPred clas tys))+       , sep [text "The matching instance is:",+              nest 2 (pprInstance $ head matches)]+       , vcat [ text "It is compiled in a Safe module and as such can only"+              , text "overlap instances from the same module, however it"+              , text "overlaps the following instances from different" <+>+                text "modules:"+              , nest 2 (vcat [pprInstances $ unsafe_overlapped])+              ]+       ]+  where+    orig        = errorItemOrigin item+    pred        = errorItemPred item+    (clas, tys) = getClassPredTys pred++{- *********************************************************************+*                                                                      *+                 Displaying potential instances+*                                                                      *+**********************************************************************-}++-- | Directly display the given matching and unifying instances,+-- with a header for each: `Matching instances`/`Potentially matching instances`.+pprPotentialInstances :: (ClsInst -> SDoc) -> PotentialInstances -> SDoc+pprPotentialInstances ppr_inst (PotentialInstances { matches, unifiers }) =+  vcat+    [ ppWhen (not $ null matches) $+       text "Matching instance" <> plural matches <> colon $$+         nest 2 (vcat (map ppr_inst matches))+    , ppWhen (not $ null unifiers) $+        (text "Potentially matching instance" <> plural unifiers <> colon) $$+         nest 2 (vcat (map ppr_inst unifiers))+    ]++-- | Display a summary of available instances, omitting those involving+-- out-of-scope types, in order to explain why we couldn't solve a particular+-- constraint, e.g. due to instance overlap or out-of-scope types.+--+-- To directly display a collection of matching/unifying instances,+-- use 'pprPotentialInstances'.+potentialInstancesErrMsg :: PotentialInstances -> SDoc+-- See Note [Displaying potential instances]+potentialInstancesErrMsg potentials =+  sdocOption sdocPrintPotentialInstances $ \print_insts ->+  getPprStyle $ \sty ->+    potentials_msg_with_options potentials print_insts sty++-- | Display a summary of available instances, omitting out-of-scope ones.+--+-- Use 'potentialInstancesErrMsg' to automatically set the pretty-printing+-- options.+potentials_msg_with_options :: PotentialInstances+                            -> Bool -- ^ Whether to print /all/ potential instances+                            -> PprStyle+                            -> SDoc+potentials_msg_with_options+  (PotentialInstances { matches, unifiers })+  show_all_potentials sty+  | null matches && null unifiers+  = empty++  | null show_these_matches && null show_these_unifiers+  = vcat [ not_in_scope_msg empty+         , flag_hint ]++  | otherwise+  = vcat [ pprPotentialInstances+            pprInstance -- print instance + location info+            (PotentialInstances+              { matches  = show_these_matches+              , unifiers = show_these_unifiers })+         , overlapping_but_not_more_specific_msg sorted_matches+         , nest 2 $ vcat+           [ ppWhen (n_in_scope_hidden > 0) $+             text "...plus"+               <+> speakNOf n_in_scope_hidden (text "other")+           , ppWhen (not_in_scopes > 0) $+              not_in_scope_msg (text "...plus")+           , flag_hint ] ]+  where+    n_show_matches, n_show_unifiers :: Int+    n_show_matches  = 3+    n_show_unifiers = 2++    (in_scope_matches, not_in_scope_matches) = partition inst_in_scope matches+    (in_scope_unifiers, not_in_scope_unifiers) = partition inst_in_scope unifiers+    sorted_matches = sortBy fuzzyClsInstCmp in_scope_matches+    sorted_unifiers = sortBy fuzzyClsInstCmp in_scope_unifiers+    (show_these_matches, show_these_unifiers)+       | show_all_potentials = (sorted_matches, sorted_unifiers)+       | otherwise           = (take n_show_matches  sorted_matches+                               ,take n_show_unifiers sorted_unifiers)+    n_in_scope_hidden+      = length sorted_matches + length sorted_unifiers+      - length show_these_matches - length show_these_unifiers++       -- "in scope" means that all the type constructors+       -- are lexically in scope; these instances are likely+       -- to be more useful+    inst_in_scope :: ClsInst -> Bool+    inst_in_scope cls_inst = nameSetAll name_in_scope $+                             orphNamesOfTypes (is_tys cls_inst)++    name_in_scope name+      | pretendNameIsInScope name+      = True -- E.g. (->); see Note [pretendNameIsInScope] in GHC.Builtin.Names+      | Just mod <- nameModule_maybe name+      = qual_in_scope (qualName sty mod (nameOccName name))+      | otherwise+      = True++    qual_in_scope :: QualifyName -> Bool+    qual_in_scope NameUnqual    = True+    qual_in_scope (NameQual {}) = True+    qual_in_scope _             = False++    not_in_scopes :: Int+    not_in_scopes = length not_in_scope_matches + length not_in_scope_unifiers++    not_in_scope_msg herald =+      hang (herald <+> speakNOf not_in_scopes (text "instance")+                     <+> text "involving out-of-scope types")+           2 (ppWhen show_all_potentials $+               pprPotentialInstances+               pprInstanceHdr -- only print the header, not the instance location info+                 (PotentialInstances+                   { matches = not_in_scope_matches+                   , unifiers = not_in_scope_unifiers+                   }))++    flag_hint = ppUnless (show_all_potentials+                         || (equalLength show_these_matches matches+                             && equalLength show_these_unifiers unifiers)) $+                text "(use -fprint-potential-instances to see them all)"++-- | Compute a message informing the user of any instances that are overlapped+-- but were not discarded because the instance overlapping them wasn't+-- strictly more specific.+overlapping_but_not_more_specific_msg :: [ClsInst] -> SDoc+overlapping_but_not_more_specific_msg insts+  -- Only print one example of "overlapping but not strictly more specific",+  -- to avoid information overload.+  | overlap : _ <- overlapping_but_not_more_specific+  = overlap_header $$ ppr_overlapping overlap+  | otherwise+  = empty+    where+      overlap_header :: SDoc+      overlap_header+        | [_] <- overlapping_but_not_more_specific+        = text "An overlapping instance can only be chosen when it is strictly more specific."+        | otherwise+        = text "Overlapping instances can only be chosen when they are strictly more specific."+      overlapping_but_not_more_specific :: [(ClsInst, ClsInst)]+      overlapping_but_not_more_specific+        = nubOrdBy (comparing (is_dfun . fst))+          [ (overlapper, overlappee)+          | these <- groupBy ((==) `on` is_cls_nm) insts+          -- Take all pairs of distinct instances...+          , one:others <- tails these -- if `these = [inst_1, inst_2, ...]`+          , other <- others           -- then we get pairs `(one, other) = (inst_i, inst_j)` with `i < j`+          -- ... such that one instance in the pair overlaps the other...+          , let mb_overlapping+                  | hasOverlappingFlag (overlapMode $ is_flag one)+                  || hasOverlappableFlag (overlapMode $ is_flag other)+                  = [(one, other)]+                  | hasOverlappingFlag (overlapMode $ is_flag other)+                  || hasOverlappableFlag (overlapMode $ is_flag one)+                  = [(other, one)]+                  | otherwise+                  = []+          , (overlapper, overlappee) <- mb_overlapping+          -- ... but the overlapper is not more specific than the overlappee.+          , not (overlapper `more_specific_than` overlappee)+          ]+      more_specific_than :: ClsInst -> ClsInst -> Bool+      is1 `more_specific_than` is2+        = isJust (tcMatchTys (is_tys is1) (is_tys is2))+      ppr_overlapping :: (ClsInst, ClsInst) -> SDoc+      ppr_overlapping (overlapper, overlappee)+        = text "The first instance that follows overlaps the second, but is not more specific than it:"+        $$ nest 2 (vcat $ map pprInstanceHdr [overlapper, overlappee])++{- Note [Displaying potential instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When showing a list of instances for+  - overlapping instances (show ones that match)+  - no such instance (show ones that could match)+we want to give it a bit of structure.  Here's the plan++* Say that an instance is "in scope" if all of the+  type constructors it mentions are lexically in scope.+  These are the ones most likely to be useful to the programmer.++* Show at most n_show in-scope instances,+  and summarise the rest ("plus N others")++* Summarise the not-in-scope instances ("plus 4 not in scope")++* Add the flag -fshow-potential-instances which replaces the+  summary with the full list+-}++{- *********************************************************************+*                                                                      *+                    Outputting TcSolverReportInfo+*                                                                      *+**********************************************************************-}++-- | Pretty-print an informational message, to accompany a 'TcSolverReportMsg'.+pprTcSolverReportInfo :: SolverReportErrCtxt -> TcSolverReportInfo -> SDoc+pprTcSolverReportInfo _ (Ambiguity prepend_msg (ambig_kvs, ambig_tvs)) = msg+  where++    msg |  any isRuntimeUnkSkol ambig_kvs  -- See Note [Runtime skolems]+        || any isRuntimeUnkSkol ambig_tvs+        = vcat [ text "Cannot resolve unknown runtime type"+                 <> plural ambig_tvs <+> pprQuotedList ambig_tvs+               , text "Use :print or :force to determine these types"]++        | not (null ambig_tvs)+        = pp_ambig (text "type") ambig_tvs++        | otherwise+        = pp_ambig (text "kind") ambig_kvs++    pp_ambig what tkvs+      | prepend_msg -- "Ambiguous type variable 't0'"+      = text "Ambiguous" <+> what <+> text "variable"+        <> plural tkvs <+> pprQuotedList tkvs++      | otherwise -- "The type variable 't0' is ambiguous"+      = text "The" <+> what <+> text "variable" <> plural tkvs+        <+> pprQuotedList tkvs <+> isOrAre tkvs <+> text "ambiguous"+pprTcSolverReportInfo ctxt (TyVarInfo tv ) =+  case tcTyVarDetails tv of+    SkolemTv sk_info _ _   -> pprSkols ctxt [(getSkolemInfo sk_info, [tv])]+    RuntimeUnk {} -> quotes (ppr tv) <+> text "is an interactive-debugger skolem"+    MetaTv {}     -> empty+pprTcSolverReportInfo _ (NonInjectiveTyFam tc) =+  text "NB:" <+> quotes (ppr tc)+  <+> text "is a non-injective type family"+pprTcSolverReportInfo _ (ReportCoercibleMsg msg) =+  pprCoercibleMsg msg+pprTcSolverReportInfo _ (ExpectedActual { ea_expected = exp, ea_actual = act }) =+  vcat+    [ text "Expected:" <+> ppr exp+    , text "  Actual:" <+> ppr act ]+pprTcSolverReportInfo _+  (ExpectedActualAfterTySynExpansion+    { ea_expanded_expected = exp+    , ea_expanded_actual   = act } )+  = vcat+      [ text "Type synonyms expanded:"+      , text "Expected type:" <+> ppr exp+      , text "  Actual type:" <+> ppr act ]+pprTcSolverReportInfo ctxt (WhenMatching cty1 cty2 sub_o mb_sub_t_or_k) =+  sdocOption sdocPrintExplicitCoercions $ \printExplicitCoercions ->+    if printExplicitCoercions+       || not (cty1 `pickyEqType` cty2)+      then vcat [ hang (text "When matching" <+> sub_whats)+                      2 (vcat [ ppr cty1 <+> dcolon <+>+                               ppr (tcTypeKind cty1)+                             , ppr cty2 <+> dcolon <+>+                               ppr (tcTypeKind cty2) ])+                , supplementary ]+      else text "When matching the kind of" <+> quotes (ppr cty1)+  where+    sub_t_or_k = mb_sub_t_or_k `orElse` TypeLevel+    sub_whats  = text (levelString sub_t_or_k) <> char 's'+    supplementary =+      case mk_supplementary_ea_msg ctxt sub_t_or_k cty1 cty2 sub_o of+        Left infos -> vcat $ map (pprTcSolverReportInfo ctxt) infos+        Right msg  -> pprTcSolverReportMsg ctxt msg+pprTcSolverReportInfo _ (SameOcc same_pkg n1 n2) =+  text "NB:" <+> (ppr_from same_pkg n1 $$ ppr_from same_pkg n2)+  where+    ppr_from same_pkg nm+      | isGoodSrcSpan loc+      = hang (quotes (ppr nm) <+> text "is defined at")+           2 (ppr loc)+      | otherwise  -- Imported things have an UnhelpfulSrcSpan+      = hang (quotes (ppr nm))+           2 (sep [ text "is defined in" <+> quotes (ppr (moduleName mod))+                  , ppUnless (same_pkg || pkg == mainUnit) $+                    nest 4 $ text "in package" <+> quotes (ppr pkg) ])+      where+        pkg = moduleUnit mod+        mod = nameModule nm+        loc = nameSrcSpan nm+pprTcSolverReportInfo ctxt (OccursCheckInterestingTyVars (tv :| tvs)) =+  hang (text "Type variable kinds:") 2 $+    vcat (map (tyvar_binding . tidyTyCoVarOcc (cec_tidy ctxt))+              (tv:tvs))+  where+    tyvar_binding tyvar = ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)++pprCoercibleMsg :: CoercibleMsg -> SDoc+pprCoercibleMsg (UnknownRoles ty) =+  hang (text "NB: We cannot know what roles the parameters to" <+>+          quotes (ppr ty) <+> text "have;")+       2 (text "we must assume that the role is nominal")+pprCoercibleMsg (TyConIsAbstract tc) =+  hsep [ text "NB: The type constructor"+       , quotes (pprSourceTyCon tc)+       , text "is abstract" ]+pprCoercibleMsg (OutOfScopeNewtypeConstructor tc dc) =+  hang (text "The data constructor" <+> quotes (ppr $ dataConName dc))+    2 (sep [ text "of newtype" <+> quotes (pprSourceTyCon tc)+           , text "is not in scope" ])++{- *********************************************************************+*                                                                      *+                  Outputting HoleError messages+*                                                                      *+**********************************************************************-}++pprHoleError :: SolverReportErrCtxt -> Hole -> HoleError -> SDoc+pprHoleError _ (Hole { hole_ty, hole_occ = occ }) (OutOfScopeHole imp_errs)+  = out_of_scope_msg $$ vcat (map ppr imp_errs)+  where+    herald | isDataOcc occ = text "Data constructor not in scope:"+           | otherwise     = text "Variable not in scope:"+    out_of_scope_msg -- Print v :: ty only if the type has structure+      | boring_type = hang herald 2 (ppr occ)+      | otherwise   = hang herald 2 (pp_occ_with_type occ hole_ty)+    boring_type = isTyVarTy hole_ty+pprHoleError ctxt (Hole { hole_ty, hole_occ}) (HoleError sort other_tvs hole_skol_info) =+  vcat [ hole_msg+       , tyvars_msg+       , case sort of { ExprHole {} -> expr_hole_hint; _ -> type_hole_hint } ]++  where++    hole_msg = case sort of+      ExprHole {} ->+        hang (text "Found hole:")+          2 (pp_occ_with_type hole_occ hole_ty)+      TypeHole ->+        hang (text "Found type wildcard" <+> quotes (ppr hole_occ))+          2 (text "standing for" <+> quotes pp_hole_type_with_kind)+      ConstraintHole ->+        hang (text "Found extra-constraints wildcard standing for")+          2 (quotes $ pprType hole_ty)  -- always kind constraint++    hole_kind = tcTypeKind hole_ty++    pp_hole_type_with_kind+      | isLiftedTypeKind hole_kind+        || isCoVarType hole_ty -- Don't print the kind of unlifted+                               -- equalities (#15039)+      = pprType hole_ty+      | otherwise+      = pprType hole_ty <+> dcolon <+> pprKind hole_kind++    tyvars = tyCoVarsOfTypeList hole_ty+    tyvars_msg = ppUnless (null tyvars) $+                 text "Where:" <+> (vcat (map loc_msg other_tvs)+                                    $$ pprSkols ctxt hole_skol_info)+                      -- Coercion variables can be free in the+                      -- hole, via kind casts+    expr_hole_hint                       -- Give hint for, say,   f x = _x+         | lengthFS (occNameFS hole_occ) > 1  -- Don't give this hint for plain "_"+         = text "Or perhaps" <+> quotes (ppr hole_occ)+           <+> text "is mis-spelled, or not in scope"+         | otherwise+         = empty++    type_hole_hint+         | ErrorWithoutFlag <- cec_type_holes ctxt+         = text "To use the inferred type, enable PartialTypeSignatures"+         | otherwise+         = empty++    loc_msg tv+       | isTyVar tv+       = case tcTyVarDetails tv of+           MetaTv {} -> quotes (ppr tv) <+> text "is an ambiguous type variable"+           _         -> empty  -- Skolems dealt with already+       | otherwise  -- A coercion variable can be free in the hole type+       = ppWhenOption sdocPrintExplicitCoercions $+           quotes (ppr tv) <+> text "is a coercion variable"++pp_occ_with_type :: OccName -> Type -> SDoc+pp_occ_with_type occ hole_ty = hang (pprPrefixOcc occ) 2 (dcolon <+> pprType hole_ty)++{- *********************************************************************+*                                                                      *+                  Outputting ScopeError messages+*                                                                      *+**********************************************************************-}++pprScopeError :: RdrName -> NotInScopeError -> SDoc+pprScopeError rdr_name scope_err =+  case scope_err of+    NotInScope {} ->+      hang (text "Not in scope:")+        2 (what <+> quotes (ppr rdr_name))+    NoExactName name ->+      text "The Name" <+> quotes (ppr name) <+> text "is not in scope."+    SameName gres ->+      assertPpr (length gres >= 2) (text "pprScopeError SameName: fewer than 2 elements" $$ nest 2 (ppr gres))+      $ hang (text "Same Name in multiple name-spaces:")+           2 (vcat (map pp_one sorted_names))+      where+        sorted_names = sortBy (leftmost_smallest `on` nameSrcSpan) (map greMangledName gres)+        pp_one name+          = hang (pprNameSpace (occNameSpace (getOccName name))+                  <+> quotes (ppr name) <> comma)+               2 (text "declared at:" <+> ppr (nameSrcLoc name))+    MissingBinding thing _ ->+      sep [ text "The" <+> thing+               <+> text "for" <+> quotes (ppr rdr_name)+          , nest 2 $ text "lacks an accompanying binding" ]+    NoTopLevelBinding ->+      hang (text "No top-level binding for")+        2 (what <+> quotes (ppr rdr_name) <+> text "in this module")+    UnknownSubordinate doc ->+      quotes (ppr rdr_name) <+> text "is not a (visible)" <+> doc+  where+    what = pprNonVarNameSpace (occNameSpace (rdrNameOcc rdr_name))++scopeErrorHints :: NotInScopeError -> [GhcHint]+scopeErrorHints scope_err =+  case scope_err of+    NotInScope             -> noHints+    NoExactName {}         -> [SuggestDumpSlices]+    SameName {}            -> [SuggestDumpSlices]+    MissingBinding _ hints -> hints+    NoTopLevelBinding      -> noHints+    UnknownSubordinate {}  -> noHints++{- *********************************************************************+*                                                                      *+                  Outputting ImportError messages+*                                                                      *+**********************************************************************-}++instance Outputable ImportError where+  ppr (MissingModule mod_name) =+    hsep+      [ text "NB: no module named"+      , quotes (ppr mod_name)+      , text "is imported."+      ]+  ppr  (ModulesDoNotExport mods occ_name)+    | mod NE.:| [] <- mods+    = hsep+        [ text "NB: the module"+        , quotes (ppr mod)+        , text "does not export"+        , quotes (ppr occ_name) <> dot ]+    | otherwise+    = hsep+        [ text "NB: neither"+        , quotedListWithNor (map ppr $ NE.toList mods)+        , text "export"+        , quotes (ppr occ_name) <> dot ]++{- *********************************************************************+*                                                                      *+             Suggested fixes for implication constraints+*                                                                      *+**********************************************************************-}++-- TODO: these functions should use GhcHint instead.++show_fixes :: [SDoc] -> SDoc+show_fixes []     = empty+show_fixes (f:fs) = sep [ text "Possible fix:"+                        , nest 2 (vcat (f : map (text "or" <+>) fs))]++ctxtFixes :: Bool -> PredType -> [Implication] -> [SDoc]+ctxtFixes has_ambig_tvs pred implics+  | not has_ambig_tvs+  , isTyVarClassPred pred+  , (skol:skols) <- usefulContext implics pred+  , let what | null skols+             , SigSkol (PatSynCtxt {}) _ _ <- skol+             = text "\"required\""+             | otherwise+             = empty+  = [sep [ text "add" <+> pprParendType pred+           <+> text "to the" <+> what <+> text "context of"+         , nest 2 $ ppr_skol skol $$+                    vcat [ text "or" <+> ppr_skol skol+                         | skol <- skols ] ] ]+  | otherwise = []+  where+    ppr_skol (PatSkol (RealDataCon dc) _) = text "the data constructor" <+> quotes (ppr dc)+    ppr_skol (PatSkol (PatSynCon ps)   _) = text "the pattern synonym"  <+> quotes (ppr ps)+    ppr_skol skol_info = ppr skol_info++usefulContext :: [Implication] -> PredType -> [SkolemInfoAnon]+-- usefulContext picks out the implications whose context+-- the programmer might plausibly augment to solve 'pred'+usefulContext implics pred+  = go implics+  where+    pred_tvs = tyCoVarsOfType pred+    go [] = []+    go (ic : ics)+       | implausible ic = rest+       | otherwise      = ic_info ic : rest+       where+          -- Stop when the context binds a variable free in the predicate+          rest | any (`elemVarSet` pred_tvs) (ic_skols ic) = []+               | otherwise                                 = go ics++    implausible ic+      | null (ic_skols ic)            = True+      | implausible_info (ic_info ic) = True+      | otherwise                     = False++    implausible_info (SigSkol (InfSigCtxt {}) _ _) = True+    implausible_info _                             = False+    -- Do not suggest adding constraints to an *inferred* type signature++pp_givens :: [Implication] -> [SDoc]+pp_givens givens+   = case givens of+         []     -> []+         (g:gs) ->      ppr_given (text "from the context:") g+                 : map (ppr_given (text "or from:")) gs+    where+       ppr_given herald implic@(Implic { ic_given = gs, ic_info = skol_info })+           = hang (herald <+> pprEvVarTheta (mkMinimalBySCs evVarPred gs))+             -- See Note [Suppress redundant givens during error reporting]+             -- for why we use mkMinimalBySCs above.+                2 (sep [ text "bound by" <+> ppr skol_info+                       , text "at" <+> ppr (getLclEnvLoc (ic_env implic)) ])++{- *********************************************************************+*                                                                      *+                       CtOrigin information+*                                                                      *+**********************************************************************-}++levelString :: TypeOrKind -> String+levelString TypeLevel = "type"+levelString KindLevel = "kind"++pprArising :: CtOrigin -> SDoc+-- Used for the main, top-level error message+-- We've done special processing for TypeEq, KindEq, givens+pprArising (TypeEqOrigin {})         = empty+pprArising (KindEqOrigin {})         = empty+pprArising (AmbiguityCheckOrigin {}) = empty  -- the "In the ambiguity check" context+                                              -- is sufficient; this would just be+                                              -- repetitive+pprArising orig | isGivenOrigin orig = empty+                | otherwise          = pprCtOrigin orig++-- Add the "arising from..." part to a message+addArising :: CtOrigin -> SDoc -> SDoc+addArising orig msg = hang msg 2 (pprArising orig)++pprWithArising :: [Ct] -> SDoc+-- Print something like+--    (Eq a) arising from a use of x at y+--    (Show a) arising from a use of p at q+-- Also return a location for the error message+-- Works for Wanted/Derived only+pprWithArising []+  = panic "pprWithArising"+pprWithArising (ct:cts)+  | null cts+  = addArising (ctLocOrigin loc) (pprTheta [ctPred ct])+  | otherwise+  = vcat (map ppr_one (ct:cts))+  where+    loc = ctLoc ct+    ppr_one ct' = hang (parens (pprType (ctPred ct')))+                     2 (pprCtLoc (ctLoc ct'))++{- *********************************************************************+*                                                                      *+                           SkolemInfo+*                                                                      *+**********************************************************************-}+++tidySkolemInfo :: TidyEnv -> SkolemInfo -> SkolemInfo+tidySkolemInfo env (SkolemInfo u sk_anon) = SkolemInfo u (tidySkolemInfoAnon env sk_anon)++----------------+tidySkolemInfoAnon :: TidyEnv -> SkolemInfoAnon -> SkolemInfoAnon+tidySkolemInfoAnon env (DerivSkol ty)         = DerivSkol (tidyType env ty)+tidySkolemInfoAnon env (SigSkol cx ty tv_prs) = tidySigSkol env cx ty tv_prs+tidySkolemInfoAnon env (InferSkol ids)        = InferSkol (mapSnd (tidyType env) ids)+tidySkolemInfoAnon env (UnifyForAllSkol ty)   = UnifyForAllSkol (tidyType env ty)+tidySkolemInfoAnon _   info                   = info++tidySigSkol :: TidyEnv -> UserTypeCtxt+            -> TcType -> [(Name,TcTyVar)] -> SkolemInfoAnon+-- We need to take special care when tidying SigSkol+-- See Note [SigSkol SkolemInfo] in "GHC.Tc.Types.Origin"+tidySigSkol env cx ty tv_prs+  = SigSkol cx (tidy_ty env ty) tv_prs'+  where+    tv_prs' = mapSnd (tidyTyCoVarOcc env) tv_prs+    inst_env = mkNameEnv tv_prs'++    tidy_ty env (ForAllTy (Bndr tv vis) ty)+      = ForAllTy (Bndr tv' vis) (tidy_ty env' ty)+      where+        (env', tv') = tidy_tv_bndr env tv++    tidy_ty env ty@(FunTy InvisArg w arg res) -- Look under  c => t+      = ty { ft_mult = tidy_ty env w,+             ft_arg = tidyType env arg,+             ft_res = tidy_ty env res }++    tidy_ty env ty = tidyType env ty++    tidy_tv_bndr :: TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar)+    tidy_tv_bndr env@(occ_env, subst) tv+      | Just tv' <- lookupNameEnv inst_env (tyVarName tv)+      = ((occ_env, extendVarEnv subst tv tv'), tv')++      | otherwise+      = tidyVarBndr env tv++pprSkols :: SolverReportErrCtxt -> [(SkolemInfoAnon, [TcTyVar])] -> SDoc+pprSkols ctxt zonked_ty_vars+  =+      let tidy_ty_vars = map (bimap (tidySkolemInfoAnon (cec_tidy ctxt)) id) zonked_ty_vars+      in vcat (map pp_one tidy_ty_vars)+  where++    no_msg = text "No skolem info - we could not find the origin of the following variables" <+> ppr zonked_ty_vars+       $$ text "This should not happen, please report it as a bug following the instructions at:"+       $$ text "https://gitlab.haskell.org/ghc/ghc/wikis/report-a-bug"+++    pp_one (UnkSkol cs, tvs)+      = vcat [ hang (pprQuotedList tvs)+                 2 (is_or_are tvs "a" "(rigid, skolem)")+             , nest 2 (text "of unknown origin")+             , nest 2 (text "bound at" <+> ppr (skolsSpan tvs))+             , no_msg+             , prettyCallStackDoc cs+             ]+    pp_one (RuntimeUnkSkol, tvs)+      = hang (pprQuotedList tvs)+           2 (is_or_are tvs "an" "unknown runtime")+    pp_one (skol_info, tvs)+      = vcat [ hang (pprQuotedList tvs)+                  2 (is_or_are tvs "a"  "rigid" <+> text "bound by")+             , nest 2 (pprSkolInfo skol_info)+             , nest 2 (text "at" <+> ppr (skolsSpan tvs)) ]++    is_or_are [_] article adjective = text "is" <+> text article <+> text adjective+                                      <+> text "type variable"+    is_or_are _   _       adjective = text "are" <+> text adjective+                                      <+> text "type variables"++skolsSpan :: [TcTyVar] -> SrcSpan+skolsSpan skol_tvs = foldr1 combineSrcSpans (map getSrcSpan skol_tvs)++{- *********************************************************************+*                                                                      *+                Utilities for expected/actual messages+*                                                                      *+**********************************************************************-}++mk_supplementary_ea_msg :: SolverReportErrCtxt -> TypeOrKind+                        -> Type -> Type -> CtOrigin -> Either [TcSolverReportInfo] TcSolverReportMsg+mk_supplementary_ea_msg ctxt level ty1 ty2 orig+  | TypeEqOrigin { uo_expected = exp, uo_actual = act } <- orig+  , not (ea_looks_same ty1 ty2 exp act)+  = mk_ea_msg ctxt Nothing level orig+  | otherwise+  = Left []++ea_looks_same :: Type -> Type -> Type -> Type -> Bool+-- True if the faulting types (ty1, ty2) look the same as+-- the expected/actual types (exp, act).+-- If so, we don't want to redundantly report the latter+ea_looks_same ty1 ty2 exp act+  = (act `looks_same` ty1 && exp `looks_same` ty2) ||+    (exp `looks_same` ty1 && act `looks_same` ty2)+  where+    looks_same t1 t2 = t1 `pickyEqType` t2+                    || t1 `eqType` liftedTypeKind && t2 `eqType` liftedTypeKind+      -- pickyEqType is sensitive to synonyms, so only replies True+      -- when the types really look the same.  However,+      -- (TYPE 'LiftedRep) and Type both print the same way.++mk_ea_msg :: SolverReportErrCtxt -> Maybe ErrorItem -> TypeOrKind+          -> CtOrigin -> Either [TcSolverReportInfo] TcSolverReportMsg+-- Constructs a "Couldn't match" message+-- The (Maybe ErrorItem) says whether this is the main top-level message (Just)+--     or a supplementary message (Nothing)+mk_ea_msg ctxt at_top level+  (TypeEqOrigin { uo_actual = act, uo_expected = exp, uo_thing = mb_thing })+  | Just thing <- mb_thing+  , KindLevel <- level+  = Right $ KindMismatch { kmismatch_what     = thing+                         , kmismatch_expected = exp+                         , kmismatch_actual   = act }+  | Just item <- at_top+  , let mismatch =+          Mismatch+            { mismatch_ea   = True+            , mismatch_item = item+            , mismatch_ty1  = exp+            , mismatch_ty2  = act }+  = Right $+    if expanded_syns+    then mkTcReportWithInfo mismatch [ea_expanded]+    else mismatch+  | otherwise+  = Left $+    if expanded_syns+    then [ea,ea_expanded]+    else [ea]++  where+    ea = ExpectedActual { ea_expected = exp, ea_actual = act }+    ea_expanded =+      ExpectedActualAfterTySynExpansion+        { ea_expanded_expected = expTy1+        , ea_expanded_actual   = expTy2 }++    expanded_syns = cec_expand_syns ctxt+                 && not (expTy1 `pickyEqType` exp && expTy2 `pickyEqType` act)+    (expTy1, expTy2) = expandSynonymsToMatch exp act+mk_ea_msg _ _ _ _ = Left []++{- Note [Expanding type synonyms to make types similar]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++In type error messages, if -fprint-expanded-types is used, we want to expand+type synonyms to make expected and found types as similar as possible, but we+shouldn't expand types too much to make type messages even more verbose and+harder to understand. The whole point here is to make the difference in expected+and found types clearer.++`expandSynonymsToMatch` does this, it takes two types, and expands type synonyms+only as much as necessary. Given two types t1 and t2:++  * If they're already same, it just returns the types.++  * If they're in form `C1 t1_1 .. t1_n` and `C2 t2_1 .. t2_m` (C1 and C2 are+    type constructors), it expands C1 and C2 if they're different type synonyms.+    Then it recursively does the same thing on expanded types. If C1 and C2 are+    same, then it applies the same procedure to arguments of C1 and arguments of+    C2 to make them as similar as possible.++    Most important thing here is to keep number of synonym expansions at+    minimum. For example, if t1 is `T (T3, T5, Int)` and t2 is `T (T5, T3,+    Bool)` where T5 = T4, T4 = T3, ..., T1 = X, it returns `T (T3, T3, Int)` and+    `T (T3, T3, Bool)`.++  * Otherwise types don't have same shapes and so the difference is clearly+    visible. It doesn't do any expansions and show these types.++Note that we only expand top-layer type synonyms. Only when top-layer+constructors are the same we start expanding inner type synonyms.++Suppose top-layer type synonyms of t1 and t2 can expand N and M times,+respectively. If their type-synonym-expanded forms will meet at some point (i.e.+will have same shapes according to `sameShapes` function), it's possible to find+where they meet in O(N+M) top-layer type synonym expansions and O(min(N,M))+comparisons. We first collect all the top-layer expansions of t1 and t2 in two+lists, then drop the prefix of the longer list so that they have same lengths.+Then we search through both lists in parallel, and return the first pair of+types that have same shapes. Inner types of these two types with same shapes+are then expanded using the same algorithm.++In case they don't meet, we return the last pair of types in the lists, which+has top-layer type synonyms completely expanded. (in this case the inner types+are not expanded at all, as the current form already shows the type error)+-}++-- | Expand type synonyms in given types only enough to make them as similar as+-- possible. Returned types are the same in terms of used type synonyms.+--+-- To expand all synonyms, see 'Type.expandTypeSynonyms'.+--+-- See `ExpandSynsFail` tests in tests testsuite/tests/typecheck/should_fail for+-- some examples of how this should work.+expandSynonymsToMatch :: Type -> Type -> (Type, Type)+expandSynonymsToMatch ty1 ty2 = (ty1_ret, ty2_ret)+  where+    (ty1_ret, ty2_ret) = go ty1 ty2++    -- Returns (type synonym expanded version of first type,+    --          type synonym expanded version of second type)+    go :: Type -> Type -> (Type, Type)+    go t1 t2+      | t1 `pickyEqType` t2 =+        -- Types are same, nothing to do+        (t1, t2)++    go (TyConApp tc1 tys1) (TyConApp tc2 tys2)+      | tc1 == tc2+      , tys1 `equalLength` tys2 =+        -- Type constructors are same. They may be synonyms, but we don't+        -- expand further. The lengths of tys1 and tys2 must be equal;+        -- for example, with type S a = a, we don't want+        -- to zip (S Monad Int) and (S Bool).+        let (tys1', tys2') =+              unzip (zipWithEqual "expandSynonymsToMatch" go tys1 tys2)+         in (TyConApp tc1 tys1', TyConApp tc2 tys2')++    go (AppTy t1_1 t1_2) (AppTy t2_1 t2_2) =+      let (t1_1', t2_1') = go t1_1 t2_1+          (t1_2', t2_2') = go t1_2 t2_2+       in (mkAppTy t1_1' t1_2', mkAppTy t2_1' t2_2')++    go ty1@(FunTy _ w1 t1_1 t1_2) ty2@(FunTy _ w2 t2_1 t2_2) | w1 `eqType` w2 =+      let (t1_1', t2_1') = go t1_1 t2_1+          (t1_2', t2_2') = go t1_2 t2_2+       in ( ty1 { ft_arg = t1_1', ft_res = t1_2' }+          , ty2 { ft_arg = t2_1', ft_res = t2_2' })++    go (ForAllTy b1 t1) (ForAllTy b2 t2) =+      -- NOTE: We may have a bug here, but we just can't reproduce it easily.+      -- See D1016 comments for details and our attempts at producing a test+      -- case. Short version: We probably need RnEnv2 to really get this right.+      let (t1', t2') = go t1 t2+       in (ForAllTy b1 t1', ForAllTy b2 t2')++    go (CastTy ty1 _) ty2 = go ty1 ty2+    go ty1 (CastTy ty2 _) = go ty1 ty2++    go t1 t2 =+      -- See Note [Expanding type synonyms to make types similar] for how this+      -- works+      let+        t1_exp_tys = t1 : tyExpansions t1+        t2_exp_tys = t2 : tyExpansions t2+        t1_exps    = length t1_exp_tys+        t2_exps    = length t2_exp_tys+        dif        = abs (t1_exps - t2_exps)+      in+        followExpansions $+          zipEqual "expandSynonymsToMatch.go"+            (if t1_exps > t2_exps then drop dif t1_exp_tys else t1_exp_tys)+            (if t2_exps > t1_exps then drop dif t2_exp_tys else t2_exp_tys)++    -- Expand the top layer type synonyms repeatedly, collect expansions in a+    -- list. The list does not include the original type.+    --+    -- Example, if you have:+    --+    --   type T10 = T9+    --   type T9  = T8+    --   ...+    --   type T0  = Int+    --+    -- `tyExpansions T10` returns [T9, T8, T7, ... Int]+    --+    -- This only expands the top layer, so if you have:+    --+    --   type M a = Maybe a+    --+    -- `tyExpansions (M T10)` returns [Maybe T10] (T10 is not expanded)+    tyExpansions :: Type -> [Type]+    tyExpansions = unfoldr (\t -> (\x -> (x, x)) `fmap` tcView t)++    -- Drop the type pairs until types in a pair look alike (i.e. the outer+    -- constructors are the same).+    followExpansions :: [(Type, Type)] -> (Type, Type)+    followExpansions [] = pprPanic "followExpansions" empty+    followExpansions [(t1, t2)]+      | sameShapes t1 t2 = go t1 t2 -- expand subtrees+      | otherwise        = (t1, t2) -- the difference is already visible+    followExpansions ((t1, t2) : tss)+      -- Traverse subtrees when the outer shapes are the same+      | sameShapes t1 t2 = go t1 t2+      -- Otherwise follow the expansions until they look alike+      | otherwise = followExpansions tss++    sameShapes :: Type -> Type -> Bool+    sameShapes AppTy{}          AppTy{}          = True+    sameShapes (TyConApp tc1 _) (TyConApp tc2 _) = tc1 == tc2+    sameShapes (FunTy {})       (FunTy {})       = True+    sameShapes (ForAllTy {})    (ForAllTy {})    = True+    sameShapes (CastTy ty1 _)   ty2              = sameShapes ty1 ty2+    sameShapes ty1              (CastTy ty2 _)   = sameShapes ty1 ty2+    sameShapes _                _                = False++{-+************************************************************************+*                                                                      *+\subsection{Contexts for renaming errors}+*                                                                      *+************************************************************************+-}++withHsDocContext :: HsDocContext -> SDoc -> SDoc+withHsDocContext ctxt doc = doc $$ inHsDocContext ctxt++inHsDocContext :: HsDocContext -> SDoc+inHsDocContext ctxt = text "In" <+> pprHsDocContext ctxt++pprHsDocContext :: HsDocContext -> SDoc+pprHsDocContext (GenericCtx doc)      = doc+pprHsDocContext (TypeSigCtx doc)      = text "the type signature for" <+> doc+pprHsDocContext (StandaloneKindSigCtx doc) = text "the standalone kind signature for" <+> doc+pprHsDocContext PatCtx                = text "a pattern type-signature"+pprHsDocContext SpecInstSigCtx        = text "a SPECIALISE instance pragma"+pprHsDocContext DefaultDeclCtx        = text "a `default' declaration"+pprHsDocContext DerivDeclCtx          = text "a deriving declaration"+pprHsDocContext (RuleCtx name)        = text "the rewrite rule" <+> doubleQuotes (ftext name)+pprHsDocContext (TyDataCtx tycon)     = text "the data type declaration for" <+> quotes (ppr tycon)+pprHsDocContext (FamPatCtx tycon)     = text "a type pattern of family instance for" <+> quotes (ppr tycon)+pprHsDocContext (TySynCtx name)       = text "the declaration for type synonym" <+> quotes (ppr name)+pprHsDocContext (TyFamilyCtx name)    = text "the declaration for type family" <+> quotes (ppr name)+pprHsDocContext (ClassDeclCtx name)   = text "the declaration for class" <+> quotes (ppr name)+pprHsDocContext ExprWithTySigCtx      = text "an expression type signature"+pprHsDocContext TypBrCtx              = text "a Template-Haskell quoted type"+pprHsDocContext HsTypeCtx             = text "a type argument"+pprHsDocContext HsTypePatCtx          = text "a type argument in a pattern"+pprHsDocContext GHCiCtx               = text "GHCi input"+pprHsDocContext (SpliceTypeCtx hs_ty) = text "the spliced type" <+> quotes (ppr hs_ty)+pprHsDocContext ClassInstanceCtx      = text "GHC.Tc.Gen.Splice.reifyInstances"++pprHsDocContext (ForeignDeclCtx name)+   = text "the foreign declaration for" <+> quotes (ppr name)+pprHsDocContext (ConDeclCtx [name])+   = text "the definition of data constructor" <+> quotes (ppr name)+pprHsDocContext (ConDeclCtx names)+   = text "the definition of data constructors" <+> interpp'SP names
+ GHC/Tc/Errors/Types.hs view
@@ -0,0 +1,2758 @@+{-# LANGUAGE GADTs #-}++module GHC.Tc.Errors.Types (+  -- * Main types+    TcRnMessage(..)+  , TcRnMessageDetailed(..)+  , ErrInfo(..)+  , FixedRuntimeRepProvenance(..)+  , pprFixedRuntimeRepProvenance+  , ShadowedNameProvenance(..)+  , RecordFieldPart(..)+  , InjectivityErrReason(..)+  , HasKinds(..)+  , hasKinds+  , SuggestUndecidableInstances(..)+  , suggestUndecidableInstances+  , NotClosedReason(..)+  , SuggestPartialTypeSignatures(..)+  , suggestPartialTypeSignatures+  , DeriveInstanceErrReason(..)+  , UsingGeneralizedNewtypeDeriving(..)+  , usingGeneralizedNewtypeDeriving+  , DeriveAnyClassEnabled(..)+  , deriveAnyClassEnabled+  , DeriveInstanceBadConstructor(..)+  , HasWildcard(..)+  , hasWildcard+  , BadAnonWildcardContext(..)+  , SoleExtraConstraintWildcardAllowed(..)+  , DeriveGenericsErrReason(..)+  , HasAssociatedDataFamInsts(..)+  , hasAssociatedDataFamInsts+  , AssociatedTyLastVarInKind(..)+  , associatedTyLastVarInKind+  , AssociatedTyNotParamOverLastTyVar(..)+  , associatedTyNotParamOverLastTyVar+  , MissingSignature(..)+  , Exported(..)+  , HsDocContext(..)+  , FixedRuntimeRepErrorInfo(..)++  , ErrorItem(..), errorItemOrigin, errorItemEqRel, errorItemPred, errorItemCtLoc++  , SolverReport(..), SolverReportSupplementary(..)+  , SolverReportWithCtxt(..)+  , SolverReportErrCtxt(..)+  , getUserGivens, discardProvCtxtGivens+  , TcSolverReportMsg(..), TcSolverReportInfo(..)+  , CND_Extra(..)+  , mkTcReportWithInfo+  , FitsMbSuppressed(..)+  , ValidHoleFits(..), noValidHoleFits+  , HoleFitDispConfig(..)+  , RelevantBindings(..), pprRelevantBindings+  , NotInScopeError(..), mkTcRnNotInScope+  , ImportError(..)+  , HoleError(..)+  , CoercibleMsg(..)+  , PotentialInstances(..)+  , UnsupportedCallConvention(..)+  , ExpectedBackends(..)+  , ArgOrResult(..)+  ) where++import GHC.Prelude++import GHC.Hs+import {-# SOURCE #-} GHC.Tc.Types (TcIdSigInfo)+import {-# SOURCE #-} GHC.Tc.Errors.Hole.FitTypes (HoleFit)+import GHC.Tc.Types.Constraint+import GHC.Tc.Types.Evidence (EvBindsVar)+import GHC.Tc.Types.Origin ( CtOrigin (ProvCtxtOrigin), SkolemInfoAnon (SigSkol)+                           , UserTypeCtxt (PatSynCtxt), TyVarBndrs, TypedThing+                           , FixedRuntimeRepOrigin(..) )+import GHC.Tc.Types.Rank (Rank)+import GHC.Tc.Utils.TcType (IllegalForeignTypeReason, TcType)+import GHC.Types.Error+import GHC.Types.Hint (UntickedPromotedThing(..))+import GHC.Types.FieldLabel (FieldLabelString)+import GHC.Types.ForeignCall (CLabelString)+import GHC.Types.Name (Name, OccName, getSrcLoc)+import GHC.Types.Name.Reader+import GHC.Types.SrcLoc+import GHC.Types.TyThing (TyThing)+import GHC.Types.Var (Id, TyCoVar, TyVar, TcTyVar)+import GHC.Types.Var.Env (TidyEnv)+import GHC.Types.Var.Set (TyVarSet, VarSet)+import GHC.Unit.Types (Module)+import GHC.Utils.Outputable+import GHC.Core.Class (Class)+import GHC.Core.Coercion.Axiom (CoAxBranch)+import GHC.Core.ConLike (ConLike)+import GHC.Core.DataCon (DataCon)+import GHC.Core.FamInstEnv (FamInst)+import GHC.Core.InstEnv (ClsInst)+import GHC.Core.PatSyn (PatSyn)+import GHC.Core.Predicate (EqRel, predTypeEqRel)+import GHC.Core.TyCon (TyCon, TyConFlavour)+import GHC.Core.Type (Kind, Type, ThetaType, PredType)+import GHC.Driver.Backend (Backend)+import GHC.Unit.State (UnitState)+import GHC.Unit.Module.Name (ModuleName)+import GHC.Types.Basic+import GHC.Utils.Misc (filterOut)+import qualified GHC.LanguageExtensions as LangExt+import GHC.Data.FastString (FastString)++import qualified Data.List.NonEmpty as NE+import           Data.Typeable hiding (TyCon)+import qualified Data.Semigroup as Semigroup++{-+Note [Migrating TcM Messages]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++As part of #18516, we are slowly migrating the diagnostic messages emitted+and reported in the TcM from SDoc to TcRnMessage. Historically, GHC emitted+some diagnostics in 3 pieces, i.e. there were lots of error-reporting functions+that accepted 3 SDocs an input: one for the important part of the message,+one for the context and one for any supplementary information. Consider the following:++    • Couldn't match expected type ‘Int’ with actual type ‘Char’+    • In the expression: x4+      In a stmt of a 'do' block: return (x2, x4)+      In the expression:++Under the hood, the reporting functions in Tc.Utils.Monad were emitting "Couldn't match"+as the important part, "In the expression" as the context and "In a stmt..In the expression"+as the supplementary, with the context and supplementary usually smashed together so that+the final message would be composed only by two SDoc (which would then be bulletted like in+the example).++In order for us to smooth out the migration to the new diagnostic infrastructure, we+introduce the 'ErrInfo' and 'TcRnMessageDetailed' types, which serve exactly the purpose+of bridging the two worlds together without breaking the external API or the existing+format of messages reported by GHC.++Using 'ErrInfo' and 'TcRnMessageDetailed' also allows us to move away from the SDoc-ridden+diagnostic API inside Tc.Utils.Monad, enabling further refactorings.++In the future, once the conversion will be complete and we will successfully eradicate+any use of SDoc in the diagnostic reporting of GHC, we can surely revisit the usage and+existence of these two types, which for now remain a "necessary evil".++-}++-- The majority of TcRn messages come with extra context about the error,+-- and this newtype captures it. See Note [Migrating TcM Messages].+data ErrInfo = ErrInfo {+    errInfoContext :: !SDoc+    -- ^ Extra context associated to the error.+  , errInfoSupplementary :: !SDoc+    -- ^ Extra supplementary info associated to the error.+  }+++-- | 'TcRnMessageDetailed' is an \"internal\" type (used only inside+-- 'GHC.Tc.Utils.Monad' that wraps a 'TcRnMessage' while also providing+-- any extra info needed to correctly pretty-print this diagnostic later on.+data TcRnMessageDetailed+  = TcRnMessageDetailed !ErrInfo+                        -- ^ Extra info associated with the message+                        !TcRnMessage++-- | An error which might arise during typechecking/renaming.+data TcRnMessage where+  {-| Simply wraps a generic 'Diagnostic' message @a@. It can be used by plugins+      to provide custom diagnostic messages originated during typechecking/renaming.+  -}+  TcRnUnknownMessage :: (Diagnostic a, Typeable a) => a -> TcRnMessage++  {-| TcRnMessageWithInfo is a constructor which is used when extra information is needed+      to be provided in order to qualify a diagnostic and where it was originated (and why).+      It carries an extra 'UnitState' which can be used to pretty-print some names+      and it wraps a 'TcRnMessageDetailed', which includes any extra context associated+      with this diagnostic.+  -}+  TcRnMessageWithInfo :: !UnitState+                      -- ^ The 'UnitState' will allow us to pretty-print+                      -- some diagnostics with more detail.+                      -> !TcRnMessageDetailed+                      -> TcRnMessage++  {-| TcRnSolverReport is the constructor used to report unsolved constraints+      after constraint solving, as well as other errors such as hole fit errors.++      See the documentation of the 'TcSolverReportMsg' datatype for an overview+      of the different errors.+  -}+  TcRnSolverReport :: [SolverReportWithCtxt]+                   -> DiagnosticReason+                   -> [GhcHint]+                   -> TcRnMessage+    -- TODO: split up TcRnSolverReport into several components,+    -- so that we can compute the reason and hints, as opposed+    -- to having to pass them here.++  {-| TcRnRedundantConstraints is a warning that is emitted when a binding+      has a user-written type signature which contains superfluous constraints.++      Example:++        f :: (Eq a, Ord a) => a -> a -> a+        f x y = (x < y) || x == y+          -- `Eq a` is superfluous: the `Ord a` constraint suffices.++      Test cases: T9939, T10632, T18036a, T20602, PluralS, T19296.+  -}+  TcRnRedundantConstraints :: [Id]+                           -> (SkolemInfoAnon, Bool)+                              -- ^ The contextual skolem info.+                              -- The boolean controls whether we+                              -- want to show it in the user message.+                              -- (Nice to keep track of the info in either case,+                              -- for other users of the GHC API.)+                           -> TcRnMessage++  {-| TcRnInaccessibleCode is a warning that is emitted when the RHS of a pattern+      match is inaccessible, because the constraint solver has detected a contradiction.++      Example:++        data B a where { MkTrue :: B True; MkFalse :: B False }++        foo :: B False -> Bool+        foo MkFalse = False+        foo MkTrue  = True -- Inaccessible: requires True ~ False++    Test cases: T7293, T7294, T15558, T17646, T18572, T18610, tcfail167.+  -}+  TcRnInaccessibleCode :: Implication -- ^ The implication containing a contradiction.+                       -> NE.NonEmpty SolverReportWithCtxt -- ^ The contradiction(s).+                       -> TcRnMessage++  {-| A type which was expected to have a fixed runtime representation+      does not have a fixed runtime representation.++      Example:++        data D (a :: TYPE r) = MkD a++      Test cases: T11724, T18534,+                  RepPolyPatSynArg, RepPolyPatSynUnliftedNewtype,+                  RepPolyPatSynRes, T20423+  -}+  TcRnTypeDoesNotHaveFixedRuntimeRep :: !Type+                                     -> !FixedRuntimeRepProvenance+                                     -> !ErrInfo -- Extra info accumulated in the TcM monad+                                     -> TcRnMessage++  {-| TcRnImplicitLift is a warning (controlled with -Wimplicit-lift) that occurs when+      a Template Haskell quote implicitly uses 'lift'.++     Example:+       warning1 :: Lift t => t -> Q Exp+       warning1 x = [| x |]++     Test cases: th/T17804+  -}+  TcRnImplicitLift :: Outputable var => var -> !ErrInfo -> TcRnMessage+  {-| TcRnUnusedPatternBinds is a warning (controlled with -Wunused-pattern-binds)+      that occurs if a pattern binding binds no variables at all, unless it is a+      lone wild-card pattern, or a banged pattern.++     Example:+        Just _ = rhs3    -- Warning: unused pattern binding+        (_, _) = rhs4    -- Warning: unused pattern binding+        _  = rhs3        -- No warning: lone wild-card pattern+        !() = rhs4       -- No warning: banged pattern; behaves like seq++     Test cases: rename/{T13646,T17c,T17e,T7085}+  -}+  TcRnUnusedPatternBinds :: HsBind GhcRn -> TcRnMessage+  {-| TcRnDodgyImports is a warning (controlled with -Wdodgy-imports) that occurs when+      a datatype 'T' is imported with all constructors, i.e. 'T(..)', but has been exported+      abstractly, i.e. 'T'.++     Test cases: rename/should_compile/T7167+  -}+  TcRnDodgyImports :: RdrName -> TcRnMessage+  {-| TcRnDodgyExports is a warning (controlled by -Wdodgy-exports) that occurs when a datatype+      'T' is exported with all constructors, i.e. 'T(..)', but is it just a type synonym or a+      type/data family.++     Example:+       module Foo (+           T(..)  -- Warning: T is a type synonym+         , A(..)  -- Warning: A is a type family+         , C(..)  -- Warning: C is a data family+         ) where++       type T = Int+       type family A :: * -> *+       data family C :: * -> *++     Test cases: warnings/should_compile/DodgyExports01+  -}+  TcRnDodgyExports :: Name -> TcRnMessage+  {-| TcRnMissingImportList is a warning (controlled by -Wmissing-import-lists) that occurs when+      an import declaration does not explicitly list all the names brought into scope.++     Test cases: rename/should_compile/T4489+  -}+  TcRnMissingImportList :: IE GhcPs -> TcRnMessage+  {-| When a module marked trustworthy or unsafe (using -XTrustworthy or -XUnsafe) is compiled+      with a plugin, the TcRnUnsafeDueToPlugin warning (controlled by -Wunsafe) is used as the+      reason the module was inferred to be unsafe. This warning is not raised if the+      -fplugin-trustworthy flag is passed.++     Test cases: plugins/T19926+  -}+  TcRnUnsafeDueToPlugin :: TcRnMessage+  {-| TcRnModMissingRealSrcSpan is an error that occurrs when compiling a module that lacks+      an associated 'RealSrcSpan'.++     Test cases: None+  -}+  TcRnModMissingRealSrcSpan :: Module -> TcRnMessage+  {-| TcRnIdNotExportedFromModuleSig is an error pertaining to backpack that occurs+      when an identifier required by a signature is not exported by the module+      or signature that is being used as a substitution for that signature.++      Example(s): None++     Test cases: backpack/should_fail/bkpfail36+  -}+  TcRnIdNotExportedFromModuleSig :: Name -> Module -> TcRnMessage+  {-| TcRnIdNotExportedFromLocalSig is an error pertaining to backpack that+      occurs when an identifier which is necessary for implementing a module+      signature is not exported from that signature.++      Example(s): None++     Test cases: backpack/should_fail/bkpfail30+                 backpack/should_fail/bkpfail31+                 backpack/should_fail/bkpfail34+  -}+  TcRnIdNotExportedFromLocalSig :: Name -> TcRnMessage++  {-| TcRnShadowedName is a warning (controlled by -Wname-shadowing) that occurs whenever+      an inner-scope value has the same name as an outer-scope value, i.e. the inner+      value shadows the outer one. This can catch typographical errors that turn into+      hard-to-find bugs. The warning is suppressed for names beginning with an underscore.++      Examples(s):+        f = ... let f = id in ... f ...  -- NOT OK, 'f' is shadowed+        f x = do { _ignore <- this; _ignore <- that; return (the other) } -- suppressed via underscore++     Test cases: typecheck/should_compile/T10971a+                 rename/should_compile/rn039+                 rename/should_compile/rn064+                 rename/should_compile/T1972+                 rename/should_fail/T2723+                 rename/should_compile/T3262+                 driver/werror+  -}+  TcRnShadowedName :: OccName -> ShadowedNameProvenance -> TcRnMessage++  {-| TcRnDuplicateWarningDecls is an error that occurs whenever+      a warning is declared twice.++      Examples(s):+        None.++     Test cases:+        None.+  -}+  TcRnDuplicateWarningDecls :: !(LocatedN RdrName) -> !RdrName -> TcRnMessage++  {-| TcRnDuplicateWarningDecls is an error that occurs whenever+      the constraint solver in the simplifier hits the iterations' limit.++      Examples(s):+        None.++     Test cases:+        None.+  -}+  TcRnSimplifierTooManyIterations :: Cts+                                  -> !IntWithInf+                                  -- ^ The limit.+                                  -> WantedConstraints+                                  -> TcRnMessage++  {-| TcRnIllegalPatSynDecl is an error that occurs whenever+      there is an illegal pattern synonym declaration.++      Examples(s):++      varWithLocalPatSyn x = case x of+          P -> ()+        where+          pattern P = ()   -- not valid, it can't be local, it must be defined at top-level.++     Test cases: patsyn/should_fail/local+  -}+  TcRnIllegalPatSynDecl :: !(LIdP GhcPs) -> TcRnMessage++  {-| TcRnLinearPatSyn is an error that occurs whenever a pattern+      synonym signature uses a field that is not unrestricted.++      Example(s): None++     Test cases: linear/should_fail/LinearPatSyn2+  -}+  TcRnLinearPatSyn :: !Type -> TcRnMessage++  {-| TcRnEmptyRecordUpdate is an error that occurs whenever+      a record is updated without specifying any field.++      Examples(s):++      $(deriveJSON defaultOptions{} ''Bad) -- not ok, no fields selected for update of defaultOptions++     Test cases: th/T12788+  -}+  TcRnEmptyRecordUpdate :: TcRnMessage++  {-| TcRnIllegalFieldPunning is an error that occurs whenever+      field punning is used without the 'NamedFieldPuns' extension enabled.++      Examples(s):++      data Foo = Foo { a :: Int }++      foo :: Foo -> Int+      foo Foo{a} = a  -- Not ok, punning used without extension.++     Test cases: parser/should_fail/RecordDotSyntaxFail12+  -}+  TcRnIllegalFieldPunning :: !(Located RdrName) -> TcRnMessage++  {-| TcRnIllegalWildcardsInRecord is an error that occurs whenever+      wildcards (..) are used in a record without the relevant+      extension being enabled.++      Examples(s):++      data Foo = Foo { a :: Int }++      foo :: Foo -> Int+      foo Foo{..} = a  -- Not ok, wildcards used without extension.++     Test cases: parser/should_fail/RecordWildCardsFail+  -}+  TcRnIllegalWildcardsInRecord :: !RecordFieldPart -> TcRnMessage++  {-| TcRnIllegalWildcardInType is an error that occurs+      when a wildcard appears in a type in a location in which+      wildcards aren't allowed.++      Examples:++        Type synonyms:++          type T = _++        Class declarations and instances:++          class C _+          instance C _++        Standalone kind signatures:++          type D :: _+          data D++      Test cases:+        ExtraConstraintsWildcardInTypeSplice2+        ExtraConstraintsWildcardInTypeSpliceUsed+        ExtraConstraintsWildcardNotLast+        ExtraConstraintsWildcardTwice+        NestedExtraConstraintsWildcard+        NestedNamedExtraConstraintsWildcard+        PartialClassMethodSignature+        PartialClassMethodSignature2+        T12039+        T13324_fail1+        UnnamedConstraintWildcard1+        UnnamedConstraintWildcard2+        WildcardInADT1+        WildcardInADT2+        WildcardInADT3+        WildcardInADTContext1+        WildcardInDefault+        WildcardInDefaultSignature+        WildcardInDeriving+        WildcardInForeignExport+        WildcardInForeignImport+        WildcardInGADT1+        WildcardInGADT2+        WildcardInInstanceHead+        WildcardInInstanceSig+        WildcardInNewtype+        WildcardInPatSynSig+        WildcardInStandaloneDeriving+        WildcardInTypeFamilyInstanceRHS+        WildcardInTypeSynonymRHS+        saks_fail003+        T15433a+  -}++  TcRnIllegalWildcardInType+    :: Maybe Name+        -- ^ the wildcard name, or 'Nothing' for an anonymous wildcard+    -> !BadAnonWildcardContext+    -> !(Maybe HsDocContext)+    -> TcRnMessage+++  {-| TcRnDuplicateFieldName is an error that occurs whenever+      there are duplicate field names in a record.++      Examples(s): None.++     Test cases: None.+  -}+  TcRnDuplicateFieldName :: !RecordFieldPart -> NE.NonEmpty RdrName -> TcRnMessage++  {-| TcRnIllegalViewPattern is an error that occurs whenever+      the ViewPatterns syntax is used but the ViewPatterns language extension+      is not enabled.++      Examples(s):+      data Foo = Foo { a :: Int }++      foo :: Foo -> Int+      foo (a -> l) = l -- not OK, the 'ViewPattern' extension is not enabled.++     Test cases: parser/should_fail/ViewPatternsFail+  -}+  TcRnIllegalViewPattern :: !(Pat GhcPs) -> TcRnMessage++  {-| TcRnCharLiteralOutOfRange is an error that occurs whenever+      a character is out of range.++      Examples(s): None++     Test cases: None+  -}+  TcRnCharLiteralOutOfRange :: !Char -> TcRnMessage++  {-| TcRnIllegalWildcardsInConstructor is an error that occurs whenever+      the record wildcards '..' are used inside a constructor without labeled fields.++      Examples(s): None++     Test cases: None+  -}+  TcRnIllegalWildcardsInConstructor :: !Name -> TcRnMessage++  {-| TcRnIgnoringAnnotations is a warning that occurs when the source code+      contains annotation pragmas but the platform in use does not support an+      external interpreter such as GHCi and therefore the annotations are ignored.++      Example(s): None++     Test cases: None+  -}+  TcRnIgnoringAnnotations :: [LAnnDecl GhcRn] -> TcRnMessage++  {-| TcRnAnnotationInSafeHaskell is an error that occurs if annotation pragmas+      are used in conjunction with Safe Haskell.++      Example(s): None++     Test cases: annotations/should_fail/T10826+  -}+  TcRnAnnotationInSafeHaskell :: TcRnMessage++  {-| TcRnInvalidTypeApplication is an error that occurs when a visible type application+      is used with an expression that does not accept "specified" type arguments.++      Example(s):+      foo :: forall {a}. a -> a+      foo x = x+      bar :: ()+      bar = let x = foo @Int 42+            in ()++     Test cases: overloadedrecflds/should_fail/overloadedlabelsfail03+                 typecheck/should_fail/ExplicitSpecificity1+                 typecheck/should_fail/ExplicitSpecificity10+                 typecheck/should_fail/ExplicitSpecificity2+                 typecheck/should_fail/T17173+                 typecheck/should_fail/VtaFail+  -}+  TcRnInvalidTypeApplication :: Type -> LHsWcType GhcRn -> TcRnMessage++  {-| TcRnTagToEnumMissingValArg is an error that occurs when the 'tagToEnum#'+      function is not applied to a single value argument.++      Example(s):+      tagToEnum# 1 2++     Test cases: None+  -}+  TcRnTagToEnumMissingValArg :: TcRnMessage++  {-| TcRnTagToEnumUnspecifiedResTy is an error that occurs when the 'tagToEnum#'+      function is not given a concrete result type.++      Example(s):+      foo :: forall a. a+      foo = tagToEnum# 0#++     Test cases: typecheck/should_fail/tcfail164+  -}+  TcRnTagToEnumUnspecifiedResTy :: Type -> TcRnMessage++  {-| TcRnTagToEnumResTyNotAnEnum is an error that occurs when the 'tagToEnum#'+      function is given a result type that is not an enumeration type.++      Example(s):+      foo :: Int -- not an enumeration TyCon+      foo = tagToEnum# 0#++     Test cases: typecheck/should_fail/tcfail164+  -}+  TcRnTagToEnumResTyNotAnEnum :: Type -> TcRnMessage++  {-| TcRnArrowIfThenElsePredDependsOnResultTy is an error that occurs when the+      predicate type of an ifThenElse expression in arrow notation depends on+      the type of the result.++      Example(s): None++     Test cases: None+  -}+  TcRnArrowIfThenElsePredDependsOnResultTy :: TcRnMessage++  {-| TcRnIllegalHsBootFileDecl is an error that occurs when an hs-boot file+      contains declarations that are not allowed, such as bindings.++      Example(s): None++     Test cases: None+  -}+  TcRnIllegalHsBootFileDecl :: TcRnMessage++  {-| TcRnRecursivePatternSynonym is an error that occurs when a pattern synonym+      is defined in terms of itself, either directly or indirectly.++      Example(s):+      pattern A = B+      pattern B = A++     Test cases: patsyn/should_fail/T16900+  -}+  TcRnRecursivePatternSynonym :: LHsBinds GhcRn -> TcRnMessage++  {-| TcRnPartialTypeSigTyVarMismatch is an error that occurs when a partial type signature+      attempts to unify two different types.++      Example(s):+      f :: a -> b -> _+      f x y = [x, y]++     Test cases: partial-sigs/should_fail/T14449+  -}+  TcRnPartialTypeSigTyVarMismatch+    :: Name -- ^ first type variable+    -> Name -- ^ second type variable+    -> Name -- ^ function name+    -> LHsSigWcType GhcRn -> TcRnMessage++  {-| TcRnPartialTypeSigBadQuantifier is an error that occurs when a type variable+      being quantified over in the partial type signature of a function gets unified+      with a type that is free in that function's context.++      Example(s):+      foo :: Num a => a -> a+      foo xxx = g xxx+        where+          g :: forall b. Num b => _ -> b+          g y = xxx + y++     Test cases: partial-sig/should_fail/T14479+  -}+  TcRnPartialTypeSigBadQuantifier+    :: Name   -- ^ user-written name of type variable being quantified+    -> Name   -- ^ function name+    -> Maybe Type   -- ^ type the variable unified with, if known+    -> LHsSigWcType GhcRn  -- ^ partial type signature+    -> TcRnMessage++  {-| TcRnMissingSignature is a warning that occurs when a top-level binding+      or a pattern synonym does not have a type signature.++      Controlled by the flags:+        -Wmissing-signatures+        -Wmissing-exported-signatures+        -Wmissing-pattern-synonym-signatures+        -Wmissing-exported-pattern-synonym-signatures+        -Wmissing-kind-signatures++      Test cases:+        T11077 (top-level bindings)+        T12484 (pattern synonyms)+        T19564 (kind signatures)+  -}+  TcRnMissingSignature :: MissingSignature+                       -> Exported+                       -> Bool -- ^ True: -Wmissing-signatures overrides -Wmissing-exported-signatures,+                               --     or -Wmissing-pattern-synonym-signatures overrides -Wmissing-exported-pattern-synonym-signatures+                       -> TcRnMessage++  {-| TcRnPolymorphicBinderMissingSig is a warning controlled by -Wmissing-local-signatures+      that occurs when a local polymorphic binding lacks a type signature.++      Example(s):+      id a = a++     Test cases: warnings/should_compile/T12574+  -}+  TcRnPolymorphicBinderMissingSig :: Name -> Type -> TcRnMessage++  {-| TcRnOverloadedSig is an error that occurs when a binding group conflicts+      with the monomorphism restriction.++      Example(s):+      data T a = T a+      mono = ... where+        x :: Applicative f => f a+        T x = ...++     Test cases: typecheck/should_compile/T11339+  -}+  TcRnOverloadedSig :: TcIdSigInfo -> TcRnMessage++  {-| TcRnTupleConstraintInst is an error that occurs whenever an instance+      for a tuple constraint is specified.++      Examples(s):+        class C m a+        class D m a+        f :: (forall a. Eq a => (C m a, D m a)) => m a+        f = undefined++      Test cases: quantified-constraints/T15334+  -}+  TcRnTupleConstraintInst :: !Class -> TcRnMessage++  {-| TcRnAbstractClassInst is an error that occurs whenever an instance+      of an abstract class is specified.++      Examples(s):+        -- A.hs-boot+        module A where+        class C a++        -- B.hs+        module B where+        import {-# SOURCE #-} A+        instance C Int where++        -- A.hs+        module A where+        import B+        class C a where+          f :: a++        -- Main.hs+        import A+        main = print (f :: Int)++      Test cases: typecheck/should_fail/T13068+  -}+  TcRnAbstractClassInst :: !Class -> TcRnMessage++  {-| TcRnNoClassInstHead is an error that occurs whenever an instance+      head is not headed by a class.++      Examples(s):+        instance c++      Test cases: typecheck/rename/T5513+                  typecheck/rename/T16385+  -}+  TcRnNoClassInstHead :: !Type -> TcRnMessage++  {-| TcRnUserTypeError is an error that occurs due to a user's custom type error,+      which can be triggered by adding a `TypeError` constraint in a type signature+      or typeclass instance.++      Examples(s):+        f :: TypeError (Text "This is a type error")+        f = undefined++      Test cases: typecheck/should_fail/CustomTypeErrors02+                  typecheck/should_fail/CustomTypeErrors03+  -}+  TcRnUserTypeError :: !Type -> TcRnMessage++  {-| TcRnConstraintInKind is an error that occurs whenever a constraint is specified+      in a kind.++      Examples(s):+        data Q :: Eq a => Type where {}++      Test cases: dependent/should_fail/T13895+                  polykinds/T16263+                  saks/should_fail/saks_fail004+                  typecheck/should_fail/T16059a+                  typecheck/should_fail/T18714+  -}+  TcRnConstraintInKind :: !Type -> TcRnMessage++  {-| TcRnUnboxedTupleTypeFuncArg is an error that occurs whenever an unboxed tuple+      or unboxed sum type is specified as a function argument, when the appropriate+      extension (`-XUnboxedTuples` or `-XUnboxedSums`) isn't enabled.++      Examples(s):+        -- T15073.hs+        import T15073a+        newtype Foo a = MkFoo a+          deriving P++        -- T15073a.hs+        class P a where+          p :: a -> (# a #)++      Test cases: deriving/should_fail/T15073.hs+                  deriving/should_fail/T15073a.hs+                  typecheck/should_fail/T16059d+  -}+  TcRnUnboxedTupleOrSumTypeFuncArg+    :: UnboxedTupleOrSum -- ^ whether this is an unboxed tuple or an unboxed sum+    -> !Type+    -> TcRnMessage++  {-| TcRnLinearFuncInKind is an error that occurs whenever a linear function is+      specified in a kind.++      Examples(s):+        data A :: * %1 -> *++      Test cases: linear/should_fail/LinearKind+                  linear/should_fail/LinearKind2+                  linear/should_fail/LinearKind3+  -}+  TcRnLinearFuncInKind :: !Type -> TcRnMessage++  {-| TcRnForAllEscapeError is an error that occurs whenever a quantified type's kind+      mentions quantified type variable.++      Examples(s):+        type T :: TYPE (BoxedRep l)+        data T = MkT++      Test cases: unlifted-datatypes/should_fail/UnlDataNullaryPoly+  -}+  TcRnForAllEscapeError :: !Type -> !Kind -> TcRnMessage++  {-| TcRnVDQInTermType is an error that occurs whenever a visible dependent quantification+      is specified in the type of a term.++      Examples(s):+        a = (undefined :: forall k -> k -> Type) @Int++      Test cases: dependent/should_fail/T15859+                  dependent/should_fail/T16326_Fail1+                  dependent/should_fail/T16326_Fail2+                  dependent/should_fail/T16326_Fail3+                  dependent/should_fail/T16326_Fail4+                  dependent/should_fail/T16326_Fail5+                  dependent/should_fail/T16326_Fail6+                  dependent/should_fail/T16326_Fail7+                  dependent/should_fail/T16326_Fail8+                  dependent/should_fail/T16326_Fail9+                  dependent/should_fail/T16326_Fail10+                  dependent/should_fail/T16326_Fail11+                  dependent/should_fail/T16326_Fail12+                  dependent/should_fail/T17687+                  dependent/should_fail/T18271+  -}+  TcRnVDQInTermType :: !Type -> TcRnMessage++  {-| TcRnBadQuantPredHead is an error that occurs whenever a quantified predicate+      lacks a class or type variable head.++      Examples(s):+        class (forall a. A t a => A t [a]) => B t where+          type A t a :: Constraint++      Test cases: quantified-constraints/T16474+  -}+  TcRnBadQuantPredHead :: !Type -> TcRnMessage++  {-| TcRnIllegalTupleConstraint is an error that occurs whenever an illegal tuple+      constraint is specified.++      Examples(s):+        g :: ((Show a, Num a), Eq a) => a -> a+        g = undefined++      Test cases: typecheck/should_fail/tcfail209a+  -}+  TcRnIllegalTupleConstraint :: !Type -> TcRnMessage++  {-| TcRnNonTypeVarArgInConstraint is an error that occurs whenever a non type-variable+      argument is specified in a constraint.++      Examples(s):+        data T+        instance Eq Int => Eq T++      Test cases: ghci/scripts/T13202+                  ghci/scripts/T13202a+                  polykinds/T12055a+                  typecheck/should_fail/T10351+                  typecheck/should_fail/T19187+                  typecheck/should_fail/T6022+                  typecheck/should_fail/T8883+  -}+  TcRnNonTypeVarArgInConstraint :: !Type -> TcRnMessage++  {-| TcRnIllegalImplicitParam is an error that occurs whenever an illegal implicit+      parameter is specified.++      Examples(s):+        type Bla = ?x::Int+        data T = T+        instance Bla => Eq T++      Test cases: polykinds/T11466+                  typecheck/should_fail/T8912+                  typecheck/should_fail/tcfail041+                  typecheck/should_fail/tcfail211+                  typecheck/should_fail/tcrun045+  -}+  TcRnIllegalImplicitParam :: !Type -> TcRnMessage++  {-| TcRnIllegalConstraintSynonymOfKind is an error that occurs whenever an illegal constraint+      synonym of kind is specified.++      Examples(s):+        type Showish = Show+        f :: (Showish a) => a -> a+        f = undefined++      Test cases: typecheck/should_fail/tcfail209+  -}+  TcRnIllegalConstraintSynonymOfKind :: !Type -> TcRnMessage++  {-| TcRnIllegalClassInst is an error that occurs whenever a class instance is specified+      for a non-class.++      Examples(s):+        type C1 a = (Show (a -> Bool))+        instance C1 Int where++      Test cases: polykinds/T13267+  -}+  TcRnIllegalClassInst :: !TyConFlavour -> TcRnMessage++  {-| TcRnOversaturatedVisibleKindArg is an error that occurs whenever an illegal oversaturated+      visible kind argument is specified.++      Examples(s):+        type family+          F2 :: forall (a :: Type). Type where+          F2 @a = Maybe a++      Test cases: typecheck/should_fail/T15793+                  typecheck/should_fail/T16255+  -}+  TcRnOversaturatedVisibleKindArg :: !Type -> TcRnMessage++  {-| TcRnBadAssociatedType is an error that occurs whenever a class doesn't have an+      associated type.++      Examples(s):+        $(do d <- instanceD (cxt []) (conT ''Eq `appT` conT ''Foo)+                    [tySynInstD $ tySynEqn Nothing (conT ''Rep `appT` conT ''Foo) (conT ''Maybe)]+             return [d])+        ======>+        instance Eq Foo where+          type Rep Foo = Maybe++      Test cases: th/T12387a+  -}+  TcRnBadAssociatedType :: {-Class-} !Name -> {-TyCon-} !Name -> TcRnMessage++  {-| TcRnForAllRankErr is an error that occurs whenever an illegal ranked type+      is specified.++      Examples(s):+        foo :: (a,b) -> (a~b => t) -> (a,b)+        foo p x = p++      Test cases:+        - ghci/should_run/T15806+        - indexed-types/should_fail/SimpleFail15+        - typecheck/should_fail/T11355+        - typecheck/should_fail/T12083a+        - typecheck/should_fail/T12083b+        - typecheck/should_fail/T16059c+        - typecheck/should_fail/T16059e+        - typecheck/should_fail/T17213+        - typecheck/should_fail/T18939_Fail+        - typecheck/should_fail/T2538+        - typecheck/should_fail/T5957+        - typecheck/should_fail/T7019+        - typecheck/should_fail/T7019a+        - typecheck/should_fail/T7809+        - typecheck/should_fail/T9196+        - typecheck/should_fail/tcfail127+        - typecheck/should_fail/tcfail184+        - typecheck/should_fail/tcfail196+        - typecheck/should_fail/tcfail197+  -}+  TcRnForAllRankErr :: !Rank -> !Type -> TcRnMessage++  {-| TcRnMonomorphicBindings is a warning (controlled by -Wmonomorphism-restriction)+      that arise when the monomorphism restriction applies to the given bindings.++      Examples(s):+        {-# OPTIONS_GHC -Wmonomorphism-restriction #-}++        bar = 10++        foo :: Int+        foo = bar++        main :: IO ()+        main = print foo++      The example above emits the warning (for 'bar'), because without monomorphism+      restriction the inferred type for 'bar' is 'bar :: Num p => p'. This warning tells us+      that /if/ we were to enable '-XMonomorphismRestriction' we would make 'bar'+      less polymorphic, as its type would become 'bar :: Int', so GHC warns us about that.++      Test cases: typecheck/should_compile/T13785+  -}+  TcRnMonomorphicBindings :: [Name] -> TcRnMessage++  {-| TcRnOrphanInstance is a warning (controlled by -Wwarn-orphans)+      that arises when a typeclass instance is an \"orphan\", i.e. if it appears+      in a module in which neither the class nor the type being instanced are+      declared in the same module.++      Examples(s): None++      Test cases: warnings/should_compile/T9178+                  typecheck/should_compile/T4912+  -}+  TcRnOrphanInstance :: ClsInst -> TcRnMessage++  {-| TcRnFunDepConflict is an error that occurs when there are functional dependencies+      conflicts between instance declarations.++      Examples(s): None++      Test cases: typecheck/should_fail/T2307+                  typecheck/should_fail/tcfail096+                  typecheck/should_fail/tcfail202+  -}+  TcRnFunDepConflict :: !UnitState -> NE.NonEmpty ClsInst -> TcRnMessage++  {-| TcRnDupInstanceDecls is an error that occurs when there are duplicate instance+      declarations.++      Examples(s):+        class Foo a where+          foo :: a -> Int++        instance Foo Int where+          foo = id++        instance Foo Int where+          foo = const 42++      Test cases: cabal/T12733/T12733+                  typecheck/should_fail/tcfail035+                  typecheck/should_fail/tcfail023+                  backpack/should_fail/bkpfail18+                  typecheck/should_fail/TcNullaryTCFail+                  typecheck/should_fail/tcfail036+                  typecheck/should_fail/tcfail073+                  module/mod51+                  module/mod52+                  module/mod44+  -}+  TcRnDupInstanceDecls :: !UnitState -> NE.NonEmpty ClsInst -> TcRnMessage++  {-| TcRnConflictingFamInstDecls is an error that occurs when there are conflicting+      family instance declarations.++      Examples(s): None.++      Test cases: indexed-types/should_fail/ExplicitForAllFams4b+                  indexed-types/should_fail/NoGood+                  indexed-types/should_fail/Over+                  indexed-types/should_fail/OverDirectThisMod+                  indexed-types/should_fail/OverIndirectThisMod+                  indexed-types/should_fail/SimpleFail11a+                  indexed-types/should_fail/SimpleFail11b+                  indexed-types/should_fail/SimpleFail11c+                  indexed-types/should_fail/SimpleFail11d+                  indexed-types/should_fail/SimpleFail2a+                  indexed-types/should_fail/SimpleFail2b+                  indexed-types/should_fail/T13092/T13092+                  indexed-types/should_fail/T13092c/T13092c+                  indexed-types/should_fail/T14179+                  indexed-types/should_fail/T2334A+                  indexed-types/should_fail/T2677+                  indexed-types/should_fail/T3330b+                  indexed-types/should_fail/T4246+                  indexed-types/should_fail/T7102a+                  indexed-types/should_fail/T9371+                  polykinds/T7524+                  typecheck/should_fail/UnliftedNewtypesOverlap+  -}+  TcRnConflictingFamInstDecls :: NE.NonEmpty FamInst -> TcRnMessage++  TcRnFamInstNotInjective :: InjectivityErrReason -> TyCon -> NE.NonEmpty CoAxBranch -> TcRnMessage++  {-| TcRnBangOnUnliftedType is a warning (controlled by -Wredundant-strictness-flags) that+      occurs when a strictness annotation is applied to an unlifted type.++      Example(s):+      data T = MkT !Int# -- Strictness flag has no effect on unlifted types++     Test cases: typecheck/should_compile/T20187a+                 typecheck/should_compile/T20187b+  -}+  TcRnBangOnUnliftedType :: !Type -> TcRnMessage++  {-| TcRnMultipleDefaultDeclarations is an error that occurs when a module has+      more than one default declaration.++      Example:+      default (Integer, Int)+      default (Double, Float) -- 2nd default declaration not allowed++     Text cases: module/mod58+  -}+  TcRnMultipleDefaultDeclarations :: [LDefaultDecl GhcRn] -> TcRnMessage++  {-| TcRnBadDefaultType is an error that occurs when a type used in a default+      declaration does not have an instance for any of the applicable classes.++      Example(s):+      data Foo+      default (Foo)++     Test cases: typecheck/should_fail/T11974b+  -}+  TcRnBadDefaultType :: Type -> [Class] -> TcRnMessage++  {-| TcRnPatSynBundledWithNonDataCon is an error that occurs when a module's+      export list bundles a pattern synonym with a type that is not a proper+      `data` or `newtype` construction.++      Example(s):+      module Foo (MyClass(.., P)) where+      pattern P = Nothing+      class MyClass a where+        foo :: a -> Int++     Test cases: patsyn/should_fail/export-class+  -}+  TcRnPatSynBundledWithNonDataCon :: TcRnMessage++  {-| TcRnPatSynBundledWithWrongType is an error that occurs when the export list+      of a module has a pattern synonym bundled with a type that does not match+      the type of the pattern synonym.++      Example(s):+      module Foo (R(P,x)) where+      data Q = Q Int+      data R = R+      pattern P{x} = Q x++     Text cases: patsyn/should_fail/export-ps-rec-sel+                 patsyn/should_fail/export-type-synonym+                 patsyn/should_fail/export-type+  -}+  TcRnPatSynBundledWithWrongType :: Type -> Type -> TcRnMessage++  {-| TcRnDupeModuleExport is a warning controlled by @-Wduplicate-exports@ that+      occurs when a module appears more than once in an export list.++      Example(s):+      module Foo (module Bar, module Bar)+      import Bar++     Text cases: None+  -}+  TcRnDupeModuleExport :: ModuleName -> TcRnMessage++  {-| TcRnExportedModNotImported is an error that occurs when an export list+      contains a module that is not imported.++      Example(s): None++     Text cases: module/mod135+                 module/mod8+                 rename/should_fail/rnfail028+                 backpack/should_fail/bkpfail48+  -}+  TcRnExportedModNotImported :: ModuleName -> TcRnMessage++  {-| TcRnNullExportedModule is a warning controlled by -Wdodgy-exports that occurs+      when an export list contains a module that has no exports.++      Example(s):+      module Foo (module Bar) where+      import Bar ()++     Test cases: None+  -}+  TcRnNullExportedModule :: ModuleName -> TcRnMessage++  {-| TcRnMissingExportList is a warning controlled by -Wmissing-export-lists that+      occurs when a module does not have an explicit export list.++      Example(s): None++     Test cases: typecheck/should_fail/MissingExportList03+  -}+  TcRnMissingExportList :: ModuleName -> TcRnMessage++  {-| TcRnExportHiddenComponents is an error that occurs when an export contains+      constructor or class methods that are not visible.++      Example(s): None++     Test cases: None+  -}+  TcRnExportHiddenComponents :: IE GhcPs -> TcRnMessage++  {-| TcRnDuplicateExport is a warning (controlled by -Wduplicate-exports) that occurs+      when an identifier appears in an export list more than once.++      Example(s): None++     Test cases: module/MultiExport+                 module/mod128+                 module/mod14+                 module/mod5+                 overloadedrecflds/should_fail/DuplicateExports+                 patsyn/should_compile/T11959+  -}+  TcRnDuplicateExport :: GreName -> IE GhcPs -> IE GhcPs -> TcRnMessage++  {-| TcRnExportedParentChildMismatch is an error that occurs when an export is+      bundled with a parent that it does not belong to++      Example(s):+      module Foo (T(a)) where+      data T+      a = True++     Test cases: module/T11970+                 module/T11970B+                 module/mod17+                 module/mod3+                 overloadedrecflds/should_fail/NoParent+  -}+  TcRnExportedParentChildMismatch :: Name -> TyThing -> GreName -> [Name] -> TcRnMessage++  {-| TcRnConflictingExports is an error that occurs when different identifiers that+      have the same name are being exported by a module.++      Example(s):+      module Foo (Bar.f, module Baz) where+      import qualified Bar (f)+      import Baz (f)++     Test cases: module/mod131+                 module/mod142+                 module/mod143+                 module/mod144+                 module/mod145+                 module/mod146+                 module/mod150+                 module/mod155+                 overloadedrecflds/should_fail/T14953+                 overloadedrecflds/should_fail/overloadedrecfldsfail10+                 rename/should_fail/rnfail029+                 rename/should_fail/rnfail040+                 typecheck/should_fail/T16453E2+                 typecheck/should_fail/tcfail025+                 typecheck/should_fail/tcfail026+  -}+  TcRnConflictingExports+    :: OccName -- ^ Occurrence name shared by both exports+    -> GreName -- ^ Name of first export+    -> GlobalRdrElt -- ^ Provenance for definition site of first export+    -> IE GhcPs -- ^ Export decl of first export+    -> GreName -- ^ Name of second export+    -> GlobalRdrElt -- ^ Provenance for definition site of second export+    -> IE GhcPs -- ^ Export decl of second export+    -> TcRnMessage++  {-| TcRnAmbiguousField is a warning controlled by -Wambiguous-fields occurring+      when a record update's type cannot be precisely determined. This will not+      be supported by -XDuplicateRecordFields in future releases.++      Example(s):+      data Person  = MkPerson  { personId :: Int, name :: String }+      data Address = MkAddress { personId :: Int, address :: String }+      bad1 x = x { personId = 4 } :: Person -- ambiguous+      bad2 (x :: Person) = x { personId = 4 } -- ambiguous+      good x = (x :: Person) { personId = 4 } -- not ambiguous++     Test cases: overloadedrecflds/should_fail/overloadedrecfldsfail06+  -}+  TcRnAmbiguousField+    :: HsExpr GhcRn -- ^ Field update+    -> TyCon -- ^ Record type+    -> TcRnMessage++  {-| TcRnMissingFields is a warning controlled by -Wmissing-fields occurring+      when the intialisation of a record is missing one or more (lazy) fields.++      Example(s):+      data Rec = Rec { a :: Int, b :: String, c :: Bool }+      x = Rec { a = 1, b = "two" } -- missing field 'c'++     Test cases: deSugar/should_compile/T13870+                 deSugar/should_compile/ds041+                 patsyn/should_compile/T11283+                 rename/should_compile/T5334+                 rename/should_compile/T12229+                 rename/should_compile/T5892a+                 warnings/should_fail/WerrorFail2+  -}+  TcRnMissingFields :: ConLike -> [(FieldLabelString, TcType)] -> TcRnMessage++  {-| TcRnFieldUpdateInvalidType is an error occurring when an updated field's+      type mentions something that is outside the universally quantified variables+      of the data constructor, such as an existentially quantified type.++      Example(s):+      data X = forall a. MkX { f :: a }+      x = (MkX ()) { f = False }++      Test cases: patsyn/should_fail/records-exquant+                  typecheck/should_fail/T3323+  -}+  TcRnFieldUpdateInvalidType :: [(FieldLabelString,TcType)] -> TcRnMessage++  {-| TcRnNoConstructorHasAllFields is an error that occurs when a record update+      has fields that no single constructor encompasses.++      Example(s):+      data Foo = A { x :: Bool }+               | B { y :: Int }+      foo = (A False) { x = True, y = 5 }++     Test cases: overloadedrecflds/should_fail/overloadedrecfldsfail08+                 patsyn/should_fail/mixed-pat-syn-record-sels+                 typecheck/should_fail/T7989+  -}+  TcRnNoConstructorHasAllFields :: [FieldLabelString] -> TcRnMessage++  {- TcRnMixedSelectors is an error for when a mixture of pattern synonym and+      record selectors are used in the same record update block.++      Example(s):+      data Rec = Rec { foo :: Int, bar :: String }+      pattern Pat { f1, f2 } = Rec { foo = f1, bar = f2 }+      illegal :: Rec -> Rec+      illegal r = r { f1 = 1, bar = "two" }++     Test cases: patsyn/should_fail/records-mixing-fields+  -}+  TcRnMixedSelectors+    :: Name -- ^ Record+    -> [Id] -- ^ Record selectors+    -> Name -- ^ Pattern synonym+    -> [Id] -- ^ Pattern selectors+    -> TcRnMessage++  {- TcRnMissingStrictFields is an error occurring when a record field marked+     as strict is omitted when constructing said record.++     Example(s):+     data R = R { strictField :: !Bool, nonStrict :: Int }+     x = R { nonStrict = 1 }++    Test cases: typecheck/should_fail/T18869+                typecheck/should_fail/tcfail085+                typecheck/should_fail/tcfail112+  -}+  TcRnMissingStrictFields :: ConLike -> [(FieldLabelString, TcType)] -> TcRnMessage++  {- TcRnNoPossibleParentForFields is an error thrown when the fields used in a+     record update block do not all belong to any one type.++     Example(s):+     data R1 = R1 { x :: Int, y :: Int }+     data R2 = R2 { y :: Int, z :: Int }+     update r = r { x = 1, y = 2, z = 3 }++    Test cases: overloadedrecflds/should_fail/overloadedrecfldsfail01+                overloadedrecflds/should_fail/overloadedrecfldsfail14+  -}+  TcRnNoPossibleParentForFields :: [LHsRecUpdField GhcRn] -> TcRnMessage++  {- TcRnBadOverloadedRecordUpdate is an error for a record update that cannot+     be pinned down to any one constructor and thus must be given a type signature.++     Example(s):+     data R1 = R1 { x :: Int }+     data R2 = R2 { x :: Int }+     update r = r { x = 1 } -- needs a type signature++    Test cases: overloadedrecflds/should_fail/overloadedrecfldsfail01+  -}+  TcRnBadOverloadedRecordUpdate :: [LHsRecUpdField GhcRn] -> TcRnMessage++  {- TcRnStaticFormNotClosed is an error pertaining to terms that are marked static+     using the -XStaticPointers extension but which are not closed terms.++     Example(s):+     f x = static x++    Test cases: rename/should_fail/RnStaticPointersFail01+                rename/should_fail/RnStaticPointersFail03+  -}+  TcRnStaticFormNotClosed :: Name -> NotClosedReason -> TcRnMessage+  {-| TcRnSpecialClassInst is an error that occurs when a user+      attempts to define an instance for a built-in typeclass such as+      'Coercible', 'Typeable', or 'KnownNat', outside of a signature file.++     Test cases: deriving/should_fail/T9687+                 deriving/should_fail/T14916+                 polykinds/T8132+                 typecheck/should_fail/TcCoercibleFail2+                 typecheck/should_fail/T12837+                 typecheck/should_fail/T14390++  -}+  TcRnSpecialClassInst :: !Class+                       -> !Bool -- ^ Whether the error is due to Safe Haskell being enabled+                       -> TcRnMessage++  {-| TcRnUselessTypeable is a warning (controlled by -Wderiving-typeable) that+      occurs when trying to derive an instance of the 'Typeable' class. Deriving+      'Typeable' is no longer necessary (hence the \"useless\") as all types+      automatically derive 'Typeable' in modern GHC versions.++      Example(s): None.++     Test cases: warnings/should_compile/DerivingTypeable+  -}+  TcRnUselessTypeable :: TcRnMessage++  {-| TcRnDerivingDefaults is a warning (controlled by -Wderiving-defaults) that+      occurs when both 'DeriveAnyClass' and 'GeneralizedNewtypeDeriving' are+      enabled, and therefore GHC defaults to 'DeriveAnyClass', which might not+      be what the user wants.++      Example(s): None.++     Test cases: typecheck/should_compile/T15839a+                 deriving/should_compile/T16179+  -}+  TcRnDerivingDefaults :: !Class -> TcRnMessage++  {-| TcRnNonUnaryTypeclassConstraint is an error that occurs when GHC+      encounters a non-unary constraint when trying to derive a typeclass.++      Example(s):+        class A+        deriving instance A+        data B deriving A  -- We cannot derive A, is not unary (i.e. 'class A a').++     Test cases: deriving/should_fail/T7959+                 deriving/should_fail/drvfail005+                 deriving/should_fail/drvfail009+                 deriving/should_fail/drvfail006+  -}+  TcRnNonUnaryTypeclassConstraint :: !(LHsSigType GhcRn) -> TcRnMessage++  {-| TcRnPartialTypeSignatures is a warning (controlled by -Wpartial-type-signatures)+      that occurs when a wildcard '_' is found in place of a type in a signature or a+      type class derivation++      Example(s):+        foo :: _ -> Int+        foo = ...++        deriving instance _ => Eq (Foo a)++     Test cases: dependent/should_compile/T11241+                 dependent/should_compile/T15076+                 dependent/should_compile/T14880-2+                 typecheck/should_compile/T17024+                 typecheck/should_compile/T10072+                 partial-sigs/should_fail/TidyClash2+                 partial-sigs/should_fail/Defaulting1MROff+                 partial-sigs/should_fail/WildcardsInPatternAndExprSig+                 partial-sigs/should_fail/T10615+                 partial-sigs/should_fail/T14584a+                 partial-sigs/should_fail/TidyClash+                 partial-sigs/should_fail/T11122+                 partial-sigs/should_fail/T14584+                 partial-sigs/should_fail/T10045+                 partial-sigs/should_fail/PartialTypeSignaturesDisabled+                 partial-sigs/should_fail/T10999+                 partial-sigs/should_fail/ExtraConstraintsWildcardInExpressionSignature+                 partial-sigs/should_fail/ExtraConstraintsWildcardInPatternSplice+                 partial-sigs/should_fail/WildcardInstantiations+                 partial-sigs/should_run/T15415+                 partial-sigs/should_compile/T10463+                 partial-sigs/should_compile/T15039a+                 partial-sigs/should_compile/T16728b+                 partial-sigs/should_compile/T15039c+                 partial-sigs/should_compile/T10438+                 partial-sigs/should_compile/SplicesUsed+                 partial-sigs/should_compile/T18008+                 partial-sigs/should_compile/ExprSigLocal+                 partial-sigs/should_compile/T11339a+                 partial-sigs/should_compile/T11670+                 partial-sigs/should_compile/WarningWildcardInstantiations+                 partial-sigs/should_compile/T16728+                 partial-sigs/should_compile/T12033+                 partial-sigs/should_compile/T15039b+                 partial-sigs/should_compile/T10403+                 partial-sigs/should_compile/T11192+                 partial-sigs/should_compile/T16728a+                 partial-sigs/should_compile/TypedSplice+                 partial-sigs/should_compile/T15039d+                 partial-sigs/should_compile/T11016+                 partial-sigs/should_compile/T13324_compile2+                 linear/should_fail/LinearPartialSig+                 polykinds/T14265+                 polykinds/T14172+  -}+  TcRnPartialTypeSignatures :: !SuggestPartialTypeSignatures -> !ThetaType -> TcRnMessage++  {-| TcRnCannotDeriveInstance is an error that occurs every time a typeclass instance+      can't be derived. The 'DeriveInstanceErrReason' will contain the specific reason+      this error arose.++      Example(s): None.++      Test cases: generics/T10604/T10604_no_PolyKinds+                  deriving/should_fail/drvfail009+                  deriving/should_fail/drvfail-functor2+                  deriving/should_fail/T10598_fail3+                  deriving/should_fail/deriving-via-fail2+                  deriving/should_fail/deriving-via-fail+                  deriving/should_fail/T16181+  -}+  TcRnCannotDeriveInstance :: !Class+                           -- ^ The typeclass we are trying to derive+                           -- an instance for+                           -> [Type]+                           -- ^ The typeclass arguments, if any.+                           -> !(Maybe (DerivStrategy GhcTc))+                           -- ^ The derivation strategy, if any.+                           -> !UsingGeneralizedNewtypeDeriving+                           -- ^ Is '-XGeneralizedNewtypeDeriving' enabled?+                           -> !DeriveInstanceErrReason+                           -- ^ The specific reason why we couldn't derive+                           -- an instance for the class.+                           -> TcRnMessage++  {-| TcRnLazyGADTPattern is an error that occurs when a user writes a nested+      GADT pattern match inside a lazy (~) pattern.++      Test case: gadt/lazypat+  -}+  TcRnLazyGADTPattern :: TcRnMessage++  {-| TcRnArrowProcGADTPattern is an error that occurs when a user writes a+      GADT pattern inside arrow proc notation.++      Test case: arrows/should_fail/arrowfail004.+  -}+  TcRnArrowProcGADTPattern :: TcRnMessage++  {-| TcRnForallIdentifier is a warning (controlled with -Wforall-identifier) that occurs+     when a definition uses 'forall' as an identifier.++     Example:+       forall x = ()+       g forall = ()++     Test cases: T20609 T20609a T20609b T20609c T20609d+  -}+  TcRnForallIdentifier :: RdrName -> TcRnMessage++  {-| TcRnTypeEqualityOutOfScope is a warning (controlled by -Wtype-equality-out-of-scope)+      that occurs when the type equality (a ~ b) is not in scope.++      Test case: T18862b+  -}+  TcRnTypeEqualityOutOfScope :: TcRnMessage++  {-| TcRnTypeEqualityRequiresOperators is a warning (controlled by -Wtype-equality-requires-operators)+      that occurs when the type equality (a ~ b) is used without the TypeOperators extension.++      Example:+        {-# LANGUAGE NoTypeOperators #-}+        f :: (a ~ b) => a -> b++      Test case: T18862a+  -}+  TcRnTypeEqualityRequiresOperators :: TcRnMessage++  {-| TcRnIllegalTypeOperator is an error that occurs when a type operator+      is used without the TypeOperators extension.++      Example:+        {-# LANGUAGE NoTypeOperators #-}+        f :: Vec a n -> Vec a m -> Vec a (n + m)++      Test case: T12811+  -}+  TcRnIllegalTypeOperator :: !SDoc -> !RdrName -> TcRnMessage++  {-| TcRnGADTMonoLocalBinds is a warning controlled by -Wgadt-mono-local-binds+      that occurs when pattern matching on a GADT when -XMonoLocalBinds is off.++      Example(s): None++      Test cases: T20485, T20485a+  -}+  TcRnGADTMonoLocalBinds :: TcRnMessage+  {-| The TcRnNotInScope constructor is used for various not-in-scope errors.+      See 'NotInScopeError' for more details. -}+  TcRnNotInScope :: NotInScopeError  -- ^ what the problem is+                 -> RdrName          -- ^ the name that is not in scope+                 -> [ImportError]    -- ^ import errors that are relevant+                 -> [GhcHint]        -- ^ hints, e.g. enable DataKinds to refer to a promoted data constructor+                 -> TcRnMessage++  {-| TcRnUntickedPromotedThing is a warning (controlled with -Wunticked-promoted-constructors)+      that is triggered by an unticked occurrence of a promoted data constructor.++      Examples:++        data A = MkA+        type family F (a :: A) where { F MkA = Bool }++        type B = [ Int, Bool ]++      Test cases: T9778, T19984.+  -}+  TcRnUntickedPromotedThing :: UntickedPromotedThing+                            -> TcRnMessage++  {-| TcRnIllegalBuiltinSyntax is an error that occurs when built-in syntax appears+      in an unexpected location, e.g. as a data constructor or in a fixity declaration.++      Examples:++        infixl 5 :++        data P = (,)++      Test cases: rnfail042, T14907b, T15124, T15233.+  -}+  TcRnIllegalBuiltinSyntax :: SDoc -- ^ what kind of thing this is (a binding, fixity declaration, ...)+                           -> RdrName+                           -> TcRnMessage+    -- TODO: remove the SDoc argument.++  {-| TcRnWarnDefaulting is a warning (controlled by -Wtype-defaults)+      that is triggered whenever a Wanted typeclass constraint+      is solving through the defaulting of a type variable.++      Example:++        one = show 1+        -- We get Wanteds Show a0, Num a0, and default a0 to Integer.++      Test cases:+        none (which are really specific to defaulting),+        but see e.g. tcfail204.+   -}+  TcRnWarnDefaulting :: [Ct] -- ^ Wanted constraints in which defaulting occurred+                     -> Maybe TyVar -- ^ The type variable being defaulted+                     -> Type -- ^ The default type+                     -> TcRnMessage++  {-| TcRnIncorrectNameSpace is an error that occurs when a 'Name'+      is used in the incorrect 'NameSpace', e.g. a type constructor+      or class used in a term, or a term variable used in a type.++      Example:++        f x = Int++      Test cases: T18740a, T20884.+  -}+  TcRnIncorrectNameSpace :: Name+                         -> Bool -- ^ whether the error is happening+                                 -- in a Template Haskell tick+                                 -- (so we should give a Template Haskell hint)+                         -> TcRnMessage++  {- TcRnForeignImportPrimExtNotSet is an error occurring when a foreign import+     is declared using the @prim@ calling convention without having turned on+     the -XGHCForeignImportPrim extension.++     Example(s):+     foreign import prim "foo" foo :: ByteArray# -> (# Int#, Int# #)++    Test cases: ffi/should_fail/T20116+  -}+  TcRnForeignImportPrimExtNotSet :: ForeignImport -> TcRnMessage++  {- TcRnForeignImportPrimSafeAnn is an error declaring that the safe/unsafe+     annotation should not be used with @prim@ foreign imports.++     Example(s):+     foreign import prim unsafe "my_primop_cmm" :: ...++    Test cases: None+  -}+  TcRnForeignImportPrimSafeAnn :: ForeignImport -> TcRnMessage++  {- TcRnForeignFunctionImportAsValue is an error explaining that foreign @value@+     imports cannot have function types.++     Example(s):+     foreign import capi "math.h value sqrt" f :: CInt -> CInt++    Test cases: ffi/should_fail/capi_value_function+  -}+  TcRnForeignFunctionImportAsValue :: ForeignImport -> TcRnMessage++  {- TcRnFunPtrImportWithoutAmpersand is a warning controlled by @-Wdodgy-foreign-imports@+     that informs the user of a possible missing @&@ in the declaration of a+     foreign import with a 'FunPtr' return type.++     Example(s):+     foreign import ccall "f" f :: FunPtr (Int -> IO ())++    Test cases: ffi/should_compile/T1357+  -}+  TcRnFunPtrImportWithoutAmpersand :: ForeignImport -> TcRnMessage++  {- TcRnIllegalForeignDeclBackend is an error occurring when a foreign import declaration+     is not compatible with the code generation backend being used.++     Example(s): None++    Test cases: None+  -}+  TcRnIllegalForeignDeclBackend+    :: Either ForeignExport ForeignImport+    -> Backend+    -> ExpectedBackends+    -> TcRnMessage++  {- TcRnUnsupportedCallConv informs the user that the calling convention specified+     for a foreign export declaration is not compatible with the target platform.+     It is a warning controlled by @-Wunsupported-calling-conventions@ in the case of+     @stdcall@ but is otherwise considered an error.++     Example(s): None++    Test cases: None+  -}+  TcRnUnsupportedCallConv :: Either ForeignExport ForeignImport -> UnsupportedCallConvention -> TcRnMessage++  {- TcRnIllegalForeignType is an error for when a type appears in a foreign+     function signature that is not compatible with the FFI.++     Example(s): None++    Test cases: ffi/should_fail/T3066+                ffi/should_fail/ccfail004+                ffi/should_fail/T10461+                ffi/should_fail/T7506+                ffi/should_fail/T5664+                safeHaskell/ghci/p6+                safeHaskell/safeLanguage/SafeLang08+                ffi/should_fail/T16702+                linear/should_fail/LinearFFI+                ffi/should_fail/T7243+  -}+  TcRnIllegalForeignType :: !(Maybe ArgOrResult) -> !IllegalForeignTypeReason -> TcRnMessage++  {- TcRnInvalidCIdentifier indicates a C identifier that is not valid.++     Example(s):+     foreign import prim safe "not valid" cmm_test2 :: Int# -> Int#++    Test cases: th/T10638+  -}+  TcRnInvalidCIdentifier :: !CLabelString -> TcRnMessage++-- | Specifies which backend code generators where expected for an FFI declaration+data ExpectedBackends+  = COrAsmOrLlvm         -- ^ C, Asm, or LLVM+  | COrAsmOrLlvmOrInterp -- ^ C, Asm, LLVM, or interpreted+  deriving Eq++-- | Specifies which calling convention is unsupported on the current platform+data UnsupportedCallConvention+  = StdCallConvUnsupported+  | PrimCallConvUnsupported+  | JavaScriptCallConvUnsupported+  deriving Eq++-- | Whether the error pertains to a function argument or a result.+data ArgOrResult+  = Arg | Result++-- | Which parts of a record field are affected by a particular error or warning.+data RecordFieldPart+  = RecordFieldConstructor !Name+  | RecordFieldPattern !Name+  | RecordFieldUpdate++-- | Where a shadowed name comes from+data ShadowedNameProvenance+  = ShadowedNameProvenanceLocal !SrcLoc+    -- ^ The shadowed name is local to the module+  | ShadowedNameProvenanceGlobal [GlobalRdrElt]+    -- ^ The shadowed name is global, typically imported from elsewhere.++-- | In what context did we require a type to have a fixed runtime representation?+--+-- Used by 'GHC.Tc.Utils.TcMType.checkTypeHasFixedRuntimeRep' for throwing+-- representation polymorphism errors when validity checking.+--+-- See Note [Representation polymorphism checking] in GHC.Tc.Utils.Concrete+data FixedRuntimeRepProvenance+  -- | Data constructor fields must have a fixed runtime representation.+  --+  -- Tests: T11734, T18534.+  = FixedRuntimeRepDataConField++  -- | Pattern synonym signature arguments must have a fixed runtime representation.+  --+  -- Test: RepPolyPatSynArg.+  | FixedRuntimeRepPatSynSigArg++  -- | Pattern synonym signature scrutinee must have a fixed runtime representation.+  --+  -- Test: RepPolyPatSynRes.+  | FixedRuntimeRepPatSynSigRes++pprFixedRuntimeRepProvenance :: FixedRuntimeRepProvenance -> SDoc+pprFixedRuntimeRepProvenance FixedRuntimeRepDataConField = text "data constructor field"+pprFixedRuntimeRepProvenance FixedRuntimeRepPatSynSigArg = text "pattern synonym argument"+pprFixedRuntimeRepProvenance FixedRuntimeRepPatSynSigRes = text "pattern synonym scrutinee"++-- | Why the particular injectivity error arose together with more information,+-- if any.+data InjectivityErrReason+  = InjErrRhsBareTyVar [Type]+  | InjErrRhsCannotBeATypeFam+  | InjErrRhsOverlap+  | InjErrCannotInferFromRhs !TyVarSet !HasKinds !SuggestUndecidableInstances++data HasKinds+  = YesHasKinds+  | NoHasKinds+  deriving (Show, Eq)++hasKinds :: Bool -> HasKinds+hasKinds True  = YesHasKinds+hasKinds False = NoHasKinds++data SuggestUndecidableInstances+  = YesSuggestUndecidableInstaces+  | NoSuggestUndecidableInstaces+  deriving (Show, Eq)++suggestUndecidableInstances :: Bool -> SuggestUndecidableInstances+suggestUndecidableInstances True  = YesSuggestUndecidableInstaces+suggestUndecidableInstances False = NoSuggestUndecidableInstaces++-- | A data type to describe why a variable is not closed.+-- See Note [Not-closed error messages] in GHC.Tc.Gen.Expr+data NotClosedReason = NotLetBoundReason+                     | NotTypeClosed VarSet+                     | NotClosed Name NotClosedReason++data SuggestPartialTypeSignatures+  = YesSuggestPartialTypeSignatures+  | NoSuggestPartialTypeSignatures+  deriving (Show, Eq)++suggestPartialTypeSignatures :: Bool -> SuggestPartialTypeSignatures+suggestPartialTypeSignatures True  = YesSuggestPartialTypeSignatures+suggestPartialTypeSignatures False = NoSuggestPartialTypeSignatures++data UsingGeneralizedNewtypeDeriving+  = YesGeneralizedNewtypeDeriving+  | NoGeneralizedNewtypeDeriving+  deriving Eq++usingGeneralizedNewtypeDeriving :: Bool -> UsingGeneralizedNewtypeDeriving+usingGeneralizedNewtypeDeriving True  = YesGeneralizedNewtypeDeriving+usingGeneralizedNewtypeDeriving False = NoGeneralizedNewtypeDeriving++data DeriveAnyClassEnabled+  = YesDeriveAnyClassEnabled+  | NoDeriveAnyClassEnabled+  deriving Eq++deriveAnyClassEnabled :: Bool -> DeriveAnyClassEnabled+deriveAnyClassEnabled True  = YesDeriveAnyClassEnabled+deriveAnyClassEnabled False = NoDeriveAnyClassEnabled++-- | Why a particular typeclass instance couldn't be derived.+data DeriveInstanceErrReason+  =+    -- | The typeclass instance is not well-kinded.+    DerivErrNotWellKinded !TyCon+                          -- ^ The type constructor that occurs in+                          -- the typeclass instance declaration.+                          !Kind+                          -- ^ The typeclass kind.+                          !Int+                          -- ^ The number of typeclass arguments that GHC+                          -- kept. See Note [tc_args and tycon arity] in+                          -- GHC.Tc.Deriv.+  -- | Generic instances can only be derived using the stock strategy+  -- in Safe Haskell.+  | DerivErrSafeHaskellGenericInst+  | DerivErrDerivingViaWrongKind !Kind !Type !Kind+  | DerivErrNoEtaReduce !Type+                        -- ^ The instance type+  -- | We cannot derive instances in boot files+  | DerivErrBootFileFound+  | DerivErrDataConsNotAllInScope !TyCon+  -- | We cannot use GND on non-newtype types+  | DerivErrGNDUsedOnData+  -- | We cannot derive instances of nullary classes+  | DerivErrNullaryClasses+  -- | Last arg must be newtype or data application+  | DerivErrLastArgMustBeApp+  | DerivErrNoFamilyInstance !TyCon [Type]+  | DerivErrNotStockDeriveable !DeriveAnyClassEnabled+  | DerivErrHasAssociatedDatatypes !HasAssociatedDataFamInsts+                                   !AssociatedTyLastVarInKind+                                   !AssociatedTyNotParamOverLastTyVar+  | DerivErrNewtypeNonDeriveableClass+  | DerivErrCannotEtaReduceEnough !Bool -- Is eta-reduction OK?+  | DerivErrOnlyAnyClassDeriveable !TyCon+                                   -- ^ Type constructor for which the instance+                                   -- is requested+                                   !DeriveAnyClassEnabled+                                   -- ^ Whether or not -XDeriveAnyClass is enabled+                                   -- already.+  -- | Stock deriving won't work, but perhas DeriveAnyClass will.+  | DerivErrNotDeriveable !DeriveAnyClassEnabled+  -- | The given 'PredType' is not a class.+  | DerivErrNotAClass !PredType+  -- | The given (representation of the) 'TyCon' has no+  -- data constructors.+  | DerivErrNoConstructors !TyCon+  | DerivErrLangExtRequired !LangExt.Extension+  -- | GHC simply doesn't how to how derive the input 'Class' for the given+  -- 'Type'.+  | DerivErrDunnoHowToDeriveForType !Type+  -- | The given 'TyCon' must be an enumeration.+  -- See Note [Enumeration types] in GHC.Core.TyCon+  | DerivErrMustBeEnumType !TyCon+  -- | The given 'TyCon' must have /precisely/ one constructor.+  | DerivErrMustHaveExactlyOneConstructor !TyCon+  -- | The given data type must have some parameters.+  | DerivErrMustHaveSomeParameters !TyCon+  -- | The given data type must not have a class context.+  | DerivErrMustNotHaveClassContext !TyCon !ThetaType+  -- | We couldn't derive an instance for a particular data constructor+  -- for a variety of reasons.+  | DerivErrBadConstructor !(Maybe HasWildcard) [DeriveInstanceBadConstructor]+  -- | We couldn't derive a 'Generic' instance for the given type for a+  -- variety of reasons+  | DerivErrGenerics [DeriveGenericsErrReason]+  -- | We couldn't derive an instance either because the type was not an+  -- enum type or because it did have more than one constructor.+  | DerivErrEnumOrProduct !DeriveInstanceErrReason !DeriveInstanceErrReason++data DeriveInstanceBadConstructor+  =+  -- | The given 'DataCon' must be truly polymorphic in the+  -- last argument of the data type.+    DerivErrBadConExistential !DataCon+  -- | The given 'DataCon' must not use the type variable in a function argument"+  | DerivErrBadConCovariant !DataCon+  -- | The given 'DataCon' must not contain function types+  | DerivErrBadConFunTypes !DataCon+  -- | The given 'DataCon' must use the type variable only+  -- as the last argument of a data type+  | DerivErrBadConWrongArg !DataCon+  -- | The given 'DataCon' is a GADT so we cannot directly+  -- derive an istance for it.+  | DerivErrBadConIsGADT !DataCon+  -- | The given 'DataCon' has existentials type vars in its type.+  | DerivErrBadConHasExistentials !DataCon+  -- | The given 'DataCon' has constraints in its type.+  | DerivErrBadConHasConstraints !DataCon+  -- | The given 'DataCon' has a higher-rank type.+  | DerivErrBadConHasHigherRankType !DataCon++data DeriveGenericsErrReason+  = -- | The type must not have some datatype context.+    DerivErrGenericsMustNotHaveDatatypeContext !TyCon+    -- | The data constructor must not have exotic unlifted+    -- or polymorphic arguments.+  | DerivErrGenericsMustNotHaveExoticArgs !DataCon+    -- | The data constructor must be a vanilla constructor.+  | DerivErrGenericsMustBeVanillaDataCon  !DataCon+    -- | The type must have some type parameters.+    -- check (d) from Note [Requirements for deriving Generic and Rep]+    -- in GHC.Tc.Deriv.Generics.+  | DerivErrGenericsMustHaveSomeTypeParams !TyCon+    -- | The data constructor must not have existential arguments.+  | DerivErrGenericsMustNotHaveExistentials !DataCon+    -- | The derivation applies a type to an argument involving+    -- the last parameter but the applied type is not of kind * -> *.+  | DerivErrGenericsWrongArgKind !DataCon++data HasWildcard+  = YesHasWildcard+  | NoHasWildcard+  deriving Eq++hasWildcard :: Bool -> HasWildcard+hasWildcard True  = YesHasWildcard+hasWildcard False = NoHasWildcard++-- | A context in which we don't allow anonymous wildcards.+data BadAnonWildcardContext+  = WildcardNotLastInConstraint+  | ExtraConstraintWildcardNotAllowed+      SoleExtraConstraintWildcardAllowed+  | WildcardsNotAllowedAtAll++-- | Whether a sole extra-constraint wildcard is allowed,+-- e.g. @_ => ..@ as opposed to @( .., _ ) => ..@.+data SoleExtraConstraintWildcardAllowed+  = SoleExtraConstraintWildcardNotAllowed+  | SoleExtraConstraintWildcardAllowed++-- | A type representing whether or not the input type has associated data family instances.+data HasAssociatedDataFamInsts+  = YesHasAdfs+  | NoHasAdfs+  deriving Eq++hasAssociatedDataFamInsts :: Bool -> HasAssociatedDataFamInsts+hasAssociatedDataFamInsts True = YesHasAdfs+hasAssociatedDataFamInsts False = NoHasAdfs++-- | If 'YesAssocTyLastVarInKind', the associated type of a typeclass+-- contains the last type variable of the class in a kind, which is not (yet) allowed+-- by GHC.+data AssociatedTyLastVarInKind+  = YesAssocTyLastVarInKind !TyCon -- ^ The associated type family of the class+  | NoAssocTyLastVarInKind+  deriving Eq++associatedTyLastVarInKind :: Maybe TyCon -> AssociatedTyLastVarInKind+associatedTyLastVarInKind (Just tc) = YesAssocTyLastVarInKind tc+associatedTyLastVarInKind Nothing   = NoAssocTyLastVarInKind++-- | If 'NoAssociatedTyNotParamOverLastTyVar', the associated type of a+-- typeclass is not parameterized over the last type variable of the class+data AssociatedTyNotParamOverLastTyVar+  = YesAssociatedTyNotParamOverLastTyVar !TyCon -- ^ The associated type family of the class+  | NoAssociatedTyNotParamOverLastTyVar+  deriving Eq++associatedTyNotParamOverLastTyVar :: Maybe TyCon -> AssociatedTyNotParamOverLastTyVar+associatedTyNotParamOverLastTyVar (Just tc) = YesAssociatedTyNotParamOverLastTyVar tc+associatedTyNotParamOverLastTyVar Nothing   = NoAssociatedTyNotParamOverLastTyVar++-- | What kind of thing is missing a type signature?+--+-- Used for reporting @"missing signature"@ warnings, see+-- 'tcRnMissingSignature'.+data MissingSignature+  = MissingTopLevelBindingSig Name Type+  | MissingPatSynSig PatSyn+  | MissingTyConKindSig+      TyCon+      Bool -- ^ whether -XCUSKs is enabled++-- | Is the object we are dealing with exported or not?+--+-- Used for reporting @"missing signature"@ warnings, see+-- 'TcRnMissingSignature'.+data Exported+  = IsNotExported+  | IsExported++instance Outputable Exported where+  ppr IsNotExported = text "IsNotExported"+  ppr IsExported    = text "IsExported"++--------------------------------------------------------------------------------+--+--     Errors used in GHC.Tc.Errors+--+--------------------------------------------------------------------------------++{- Note [Error report]+~~~~~~~~~~~~~~~~~~~~~~+The idea is that error msgs are divided into three parts: the main msg, the+context block ("In the second argument of ..."), and the relevant bindings+block, which are displayed in that order, with a mark to divide them. The+the main msg ('report_important') varies depending on the error+in question, but context and relevant bindings are always the same, which+should simplify visual parsing.++See 'GHC.Tc.Errors.Types.SolverReport' and 'GHC.Tc.Errors.mkErrorReport'.+-}++-- | A collection of main error messages and supplementary information.+--+-- In practice, we will:+--  - display the important messages first,+--  - then the error context (e.g. by way of a call to 'GHC.Tc.Errors.mkErrorReport'),+--  - then the supplementary information (e.g. relevant bindings, valid hole fits),+--  - then the hints ("Possible fix: ...").+--+-- So this is mostly just a way of making sure that the error context appears+-- early on rather than at the end of the message.+--+-- See Note [Error report] for details.+data SolverReport+  = SolverReport+  { sr_important_msgs :: [SolverReportWithCtxt]+  , sr_supplementary  :: [SolverReportSupplementary]+  , sr_hints          :: [GhcHint]+  }++-- | Additional information to print in a 'SolverReport', after the+-- important messages and after the error context.+--+-- See Note [Error report].+data SolverReportSupplementary+  = SupplementaryBindings RelevantBindings+  | SupplementaryHoleFits ValidHoleFits+  | SupplementaryCts      [(PredType, RealSrcSpan)]++-- | A 'TcSolverReportMsg', together with context (e.g. enclosing implication constraints)+-- that are needed in order to report it.+data SolverReportWithCtxt =+  SolverReportWithCtxt+    { reportContext :: SolverReportErrCtxt+       -- ^ Context for what we wish to report.+       -- This can change as we enter implications, so is+       -- stored alongside the content.+    , reportContent :: TcSolverReportMsg+      -- ^ The content of the message to report.+    }++instance Semigroup SolverReport where+    SolverReport main1 supp1 hints1 <> SolverReport main2 supp2 hints2+      = SolverReport (main1 ++ main2) (supp1 ++ supp2) (hints1 ++ hints2)++instance Monoid SolverReport where+    mempty = SolverReport [] [] []+    mappend = (Semigroup.<>)++-- | Context needed when reporting a 'TcSolverReportMsg', such as+-- the enclosing implication constraints or whether we are deferring type errors.+data SolverReportErrCtxt+    = CEC { cec_encl :: [Implication]  -- ^ Enclosing implications+                                       --   (innermost first)+                                       -- ic_skols and givens are tidied, rest are not+          , cec_tidy  :: TidyEnv++          , cec_binds :: EvBindsVar    -- ^ We make some errors (depending on cec_defer)+                                       -- into warnings, and emit evidence bindings+                                       -- into 'cec_binds' for unsolved constraints++          , cec_defer_type_errors :: DiagnosticReason -- ^ Whether to defer type errors until runtime++          -- We might throw a warning on an error when encountering a hole,+          -- depending on the type of hole (expression hole, type hole, out of scope hole).+          -- We store the reasons for reporting a diagnostic for each type of hole.+          , cec_expr_holes :: DiagnosticReason -- ^ Reason for reporting holes in expressions.+          , cec_type_holes :: DiagnosticReason -- ^ Reason for reporting holes in types.+          , cec_out_of_scope_holes :: DiagnosticReason -- ^ Reason for reporting out of scope holes.++          , cec_warn_redundant :: Bool    -- ^ True <=> -Wredundant-constraints+          , cec_expand_syns    :: Bool    -- ^ True <=> -fprint-expanded-synonyms++          , cec_suppress :: Bool    -- ^ True <=> More important errors have occurred,+                                    --            so create bindings if need be, but+                                    --            don't issue any more errors/warnings+                                    -- See Note [Suppressing error messages]+      }++getUserGivens :: SolverReportErrCtxt -> [UserGiven]+-- One item for each enclosing implication+getUserGivens (CEC {cec_encl = implics}) = getUserGivensFromImplics implics++----------------------------------------------------------------------------+--+--   ErrorItem+--+----------------------------------------------------------------------------++-- | A predicate with its arising location; used to encapsulate a constraint+-- that will give rise to a diagnostic.+data ErrorItem+-- We could perhaps use Ct here (and indeed used to do exactly that), but+-- having a separate type gives to denote errors-in-formation gives us+-- a nice place to do pre-processing, such as calculating ei_suppress.+-- Perhaps some day, an ErrorItem could eventually evolve to contain+-- the error text (or some representation of it), so we can then have all+-- the errors together when deciding which to report.+  = EI { ei_pred     :: PredType         -- report about this+         -- The ei_pred field will never be an unboxed equality with+         -- a (casted) tyvar on the right; this is guaranteed by the solver+       , ei_evdest   :: Maybe TcEvDest   -- for Wanteds, where to put evidence+       , ei_flavour  :: CtFlavour+       , ei_loc      :: CtLoc+       , ei_m_reason :: Maybe CtIrredReason  -- if this ErrorItem was made from a+                                             -- CtIrred, this stores the reason+       , ei_suppress :: Bool    -- Suppress because of Note [Wanteds rewrite Wanteds]+                                -- in GHC.Tc.Constraint+       }++instance Outputable ErrorItem where+  ppr (EI { ei_pred     = pred+          , ei_evdest   = m_evdest+          , ei_flavour  = flav+          , ei_suppress = supp })+    = pp_supp <+> ppr flav <+> pp_dest m_evdest <+> ppr pred+    where+      pp_dest Nothing   = empty+      pp_dest (Just ev) = ppr ev <+> dcolon++      pp_supp = if supp then text "suppress:" else empty++errorItemOrigin :: ErrorItem -> CtOrigin+errorItemOrigin = ctLocOrigin . ei_loc++errorItemEqRel :: ErrorItem -> EqRel+errorItemEqRel = predTypeEqRel . ei_pred++errorItemCtLoc :: ErrorItem -> CtLoc+errorItemCtLoc = ei_loc++errorItemPred :: ErrorItem -> PredType+errorItemPred = ei_pred++{- Note [discardProvCtxtGivens]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In most situations we call all enclosing implications "useful". There is one+exception, and that is when the constraint that causes the error is from the+"provided" context of a pattern synonym declaration:++  pattern Pat :: (Num a, Eq a) => Show a   => a -> Maybe a+             --  required      => provided => type+  pattern Pat x <- (Just x, 4)++When checking the pattern RHS we must check that it does actually bind all+the claimed "provided" constraints; in this case, does the pattern (Just x, 4)+bind the (Show a) constraint.  Answer: no!++But the implication we generate for this will look like+   forall a. (Num a, Eq a) => [W] Show a+because when checking the pattern we must make the required+constraints available, since they are needed to match the pattern (in+this case the literal '4' needs (Num a, Eq a)).++BUT we don't want to suggest adding (Show a) to the "required" constraints+of the pattern synonym, thus:+  pattern Pat :: (Num a, Eq a, Show a) => Show a => a -> Maybe a+It would then typecheck but it's silly.  We want the /pattern/ to bind+the alleged "provided" constraints, Show a.++So we suppress that Implication in discardProvCtxtGivens.  It's+painfully ad-hoc but the truth is that adding it to the "required"+constraints would work.  Suppressing it solves two problems.  First,+we never tell the user that we could not deduce a "provided"+constraint from the "required" context. Second, we never give a+possible fix that suggests to add a "provided" constraint to the+"required" context.++For example, without this distinction the above code gives a bad error+message (showing both problems):++  error: Could not deduce (Show a) ... from the context: (Eq a)+         ... Possible fix: add (Show a) to the context of+         the signature for pattern synonym `Pat' ...+-}+++discardProvCtxtGivens :: CtOrigin -> [UserGiven] -> [UserGiven]+discardProvCtxtGivens orig givens  -- See Note [discardProvCtxtGivens]+  | ProvCtxtOrigin (PSB {psb_id = L _ name}) <- orig+  = filterOut (discard name) givens+  | otherwise+  = givens+  where+    discard n (Implic { ic_info = SigSkol (PatSynCtxt n') _ _ }) = n == n'+    discard _ _                                                  = False+++-- | An error reported after constraint solving.+-- This is usually, some sort of unsolved constraint error,+-- but we try to be specific about the precise problem we encountered.+data TcSolverReportMsg+  -- NB: this datatype is only a first step in refactoring GHC.Tc.Errors+  -- to use the diagnostic infrastructure (TcRnMessage etc).+  -- If you see possible improvements, please go right ahead!++  -- | Wrap a message with additional information.+  --+  -- Prefer using the 'mkTcReportWithInfo' smart constructor+  = TcReportWithInfo TcSolverReportMsg (NE.NonEmpty TcSolverReportInfo)++  -- | Quantified variables appear out of dependency order.+  --+  -- Example:+  --+  --   forall (a :: k) k. ...+  --+  -- Test cases: BadTelescope2, T16418, T16247, T16726, T18451.+  | BadTelescope TyVarBndrs [TyCoVar]++  -- | We came across a custom type error and we have decided to report it.+  --+  -- Example:+  --+  --   type family F a where+  --     F a = TypeError (Text "error")+  --+  --   err :: F ()+  --   err = ()+  --+  -- Test cases: CustomTypeErrors0{1,2,3,4,5}, T12104.+  | UserTypeError Type++  -- | We want to report an out of scope variable or a typed hole.+  -- See 'HoleError'.+  | ReportHoleError Hole HoleError++  -- | A type equality between a type variable and a polytype.+  --+  -- Test cases: T12427a, T2846b, T10194, ...+  | CannotUnifyWithPolytype ErrorItem TyVar Type++  -- | Couldn't unify two types or kinds.+  --+  --  Example:+  --+  --    3 + 3# -- can't match a lifted type with an unlifted type+  --+  --  Test cases: T1396, T8263, ...+  | Mismatch+      { mismatch_ea   :: Bool        -- ^ Should this be phrased in terms of expected vs actual?+      , mismatch_item :: ErrorItem   -- ^ The constraint in which the mismatch originated.+      , mismatch_ty1  :: Type        -- ^ First type (the expected type if if mismatch_ea is True)+      , mismatch_ty2  :: Type        -- ^ Second type (the actual type if mismatch_ea is True)+      }++  -- | A type has an unexpected kind.+  --+  -- Test cases: T2994, T7609, ...+  | KindMismatch+      { kmismatch_what     :: TypedThing -- ^ What thing is 'kmismatch_actual' the kind of?+      , kmismatch_expected :: Type+      , kmismatch_actual   :: Type+      }+    -- TODO: combine 'Mismatch' and 'KindMismatch' messages.++  -- | A mismatch between two types, which arose from a type equality.+  --+  -- Test cases: T1470, tcfail212.+  | TypeEqMismatch+      { teq_mismatch_ppr_explicit_kinds :: Bool+      , teq_mismatch_item     :: ErrorItem+      , teq_mismatch_ty1      :: Type+      , teq_mismatch_ty2      :: Type+      , teq_mismatch_expected :: Type -- ^ The overall expected type+      , teq_mismatch_actual   :: Type -- ^ The overall actual type+      , teq_mismatch_what     :: Maybe TypedThing -- ^ What thing is 'teq_mismatch_actual' the kind of?+      }+    -- TODO: combine 'Mismatch' and 'TypeEqMismatch' messages.++   -- | A violation of the representation-polymorphism invariants.+   --+   -- See 'FixedRuntimeRepErrorInfo' and 'FixedRuntimeRepContext' for more information.+  | FixedRuntimeRepError [FixedRuntimeRepErrorInfo]++  -- | A skolem type variable escapes its scope.+  --+  -- Example:+  --+  --   data Ex where { MkEx :: a -> MkEx }+  --   foo (MkEx x) = x+  --+  -- Test cases: TypeSkolEscape, T11142.+  | SkolemEscape ErrorItem Implication [TyVar]++  -- | Trying to unify an untouchable variable, e.g. a variable from an outer scope.+  --+  -- Test case: Simple14+  | UntouchableVariable TyVar Implication++  -- | An equality between two types is blocked on a kind equality+  -- beteen their kinds.+  --+  -- Test cases: none.+  | BlockedEquality ErrorItem++  -- | Something was not applied to sufficiently many arguments.+  --+  --  Example:+  --+  --    instance Eq Maybe where {..}+  --+  -- Test case: T11563.+  | ExpectingMoreArguments Int TypedThing++  -- | Trying to use an unbound implicit parameter.+  --+  -- Example:+  --+  --    foo :: Int+  --    foo = ?param+  --+  -- Test case: tcfail130.+  | UnboundImplicitParams+      (NE.NonEmpty ErrorItem)++  -- | Couldn't solve some Wanted constraints using the Givens.+  -- This is the most commonly used constructor, used for generic+  -- @"No instance for ..."@ and @"Could not deduce ... from"@ messages.+  | CouldNotDeduce+     { cnd_user_givens :: [Implication]+        -- | The Wanted constraints we couldn't solve.+        --+        -- N.B.: the 'ErrorItem' at the head of the list has been tidied,+        -- perhaps not the others.+     , cnd_wanted      :: NE.NonEmpty ErrorItem++       -- | Some additional info consumed by 'mk_supplementary_ea_msg'.+     , cnd_extra       :: Maybe CND_Extra+     }++  -- | A constraint couldn't be solved because it contains+  -- ambiguous type variables.+  --+  -- Example:+  --+  --   class C a b where+  --     f :: (a,b)+  --+  --   x = fst f+  --+  --+  -- Test case: T4921.+  | AmbiguityPreventsSolvingCt+      ErrorItem -- ^ always a class constraint+      ([TyVar], [TyVar]) -- ^ ambiguous kind and type variables, respectively++  -- | Could not solve a constraint; there were several unifying candidate instances+  -- but no matching instances. This is used to report as much useful information+  -- as possible about why we couldn't choose any instance, e.g. because of+  -- ambiguous type variables.+  | CannotResolveInstance+    { cannotResolve_item         :: ErrorItem+    , cannotResolve_unifiers     :: [ClsInst]+    , cannotResolve_candidates   :: [ClsInst]+    , cannotResolve_importErrors :: [ImportError]+    , cannotResolve_suggestions  :: [GhcHint]+    , cannotResolve_relevant_bindings :: RelevantBindings }+      -- TODO: remove the fields of type [GhcHint] and RelevantBindings,+      -- in order to handle them uniformly with other diagnostic messages.++  -- | Could not solve a constraint using available instances+  -- because the instances overlap.+  --+  -- Test cases: tcfail118, tcfail121, tcfail218.+  | OverlappingInstances+    { overlappingInstances_item     :: ErrorItem+    , overlappingInstances_matches  :: [ClsInst]+    , overlappingInstances_unifiers :: [ClsInst] }++  -- | Could not solve a constraint from instances because+  -- instances declared in a Safe module cannot overlap instances+  -- from other modules (with -XSafeHaskell).+  --+  -- Test cases: SH_Overlap{1,2,5,6,7,11}.+  | UnsafeOverlap+    { unsafeOverlap_item    :: ErrorItem+    , unsafeOverlap_matches :: [ClsInst]+    , unsafeOverlapped      :: [ClsInst] }++-- | Additional information to be given in a 'CouldNotDeduce' message,+-- which is then passed on to 'mk_supplementary_ea_msg'.+data CND_Extra = CND_Extra TypeOrKind Type Type++-- | Additional information that can be appended to an existing 'TcSolverReportMsg'.+data TcSolverReportInfo+  -- NB: this datatype is only a first step in refactoring GHC.Tc.Errors+  -- to use the diagnostic infrastructure (TcRnMessage etc).+  -- It would be better for these constructors to not be so closely tied+  -- to the constructors of 'TcSolverReportMsg'.+  -- If you see possible improvements, please go right ahead!++  -- | Some type variables remained ambiguous: print them to the user.+  = Ambiguity+    { lead_with_ambig_msg :: Bool -- ^ True <=> start the message with "Ambiguous type variable ..."+                                  --  False <=> create a message of the form "The type variable is ambiguous."+    , ambig_tyvars        :: ([TyVar], [TyVar]) -- ^ Ambiguous kind and type variables, respectively.+                                                -- Guaranteed to not both be empty.+    }++  -- | Specify some information about a type variable,+  -- e.g. its 'SkolemInfo'.+  | TyVarInfo TyVar++  -- | Remind the user that a particular type family is not injective.+  | NonInjectiveTyFam TyCon++  -- | Explain why we couldn't coerce between two types. See 'CoercibleMsg'.+  | ReportCoercibleMsg CoercibleMsg++  -- | Display the expected and actual types.+  | ExpectedActual+     { ea_expected, ea_actual :: Type }++  -- | Display the expected and actual types, after expanding type synonyms.+  | ExpectedActualAfterTySynExpansion+     { ea_expanded_expected, ea_expanded_actual :: Type }++  -- | Explain how a kind equality originated.+  | WhenMatching TcType TcType CtOrigin (Maybe TypeOrKind)++  -- | Add some information to disambiguate errors in which+  -- two 'Names' would otherwise appear to be identical.+  --+  -- See Note [Disambiguating (X ~ X) errors].+  | SameOcc+    { sameOcc_same_pkg :: Bool -- ^ Whether the two 'Name's also came from the same package.+    , sameOcc_lhs :: Name+    , sameOcc_rhs :: Name }++  -- | Report some type variables that might be participating in an occurs-check failure.+  | OccursCheckInterestingTyVars (NE.NonEmpty TyVar)++-- | Some form of @"not in scope"@ error. See also the 'OutOfScopeHole'+-- constructor of 'HoleError'.+data NotInScopeError++  -- | A run-of-the-mill @"not in scope"@ error.+  = NotInScope++  -- | An exact 'Name' was not in scope.+  --+  -- This usually indicates a problem with a Template Haskell splice.+  --+  -- Test cases: T5971, T18263.+  | NoExactName Name++  -- The same exact 'Name' occurs in multiple name-spaces.+  --+  -- This usually indicates a problem with a Template Haskell splice.+  --+  -- Test case: T7241.+  | SameName [GlobalRdrElt] -- ^ always at least 2 elements++  -- A type signature, fixity declaration, pragma, standalone kind signature...+  -- is missing an associated binding.+  | MissingBinding SDoc [GhcHint]+    -- TODO: remove the SDoc argument.++  -- | Couldn't find a top-level binding.+  --+  -- Happens when specifying an annotation for something that+  -- is not in scope.+  --+  -- Test cases: annfail01, annfail02, annfail11.+  | NoTopLevelBinding++  -- | A class doesnt have a method with this name,+  -- or, a class doesn't have an associated type with this name,+  -- or, a record doesn't have a record field with this name.+  | UnknownSubordinate SDoc++-- | Create a @"not in scope"@ error message for the given 'RdrName'.+mkTcRnNotInScope :: RdrName -> NotInScopeError -> TcRnMessage+mkTcRnNotInScope rdr err = TcRnNotInScope err rdr [] noHints++-- | Configuration for pretty-printing valid hole fits.+data HoleFitDispConfig =+  HFDC { showWrap, showWrapVars, showType, showProv, showMatches+          :: Bool }++-- | Report an error involving a 'Hole'.+--+-- This could be an out of scope data constructor or variable,+-- a typed hole, or a wildcard in a type.+data HoleError+  -- | Report an out-of-scope data constructor or variable+  -- masquerading as an expression hole.+  --+  -- See Note [Insoluble holes] in GHC.Tc.Types.Constraint.+  -- See 'NotInScopeError' for other not-in-scope errors.+  --+  -- Test cases: T9177a.+  = OutOfScopeHole [ImportError]+  -- | Report a typed hole, or wildcard, with additional information.+  | HoleError HoleSort+              [TcTyVar]                     -- Other type variables which get computed on the way.+              [(SkolemInfoAnon, [TcTyVar])] -- Zonked and grouped skolems for the type of the hole.++-- | A message that aims to explain why two types couldn't be seen+-- to be representationally equal.+data CoercibleMsg+  -- | Not knowing the role of a type constructor prevents us from+  -- concluding that two types are representationally equal.+  --+  -- Example:+  --+  --   foo :: Applicative m => m (Sum Int)+  --   foo = coerce (pure $ 1 :: Int)+  --+  -- We don't know what role `m` has, so we can't coerce `m Int` to `m (Sum Int)`.+  --+  -- Test cases: T8984, TcCoercibleFail.+  = UnknownRoles Type++  -- | The fact that a 'TyCon' is abstract prevents us from decomposing+  -- a 'TyConApp' and deducing that two types are representationally equal.+  --+  -- Test cases: none.+  | TyConIsAbstract TyCon++  -- | We can't unwrap a newtype whose constructor is not in scope.+  --+  -- Example:+  --+  --   import Data.Ord (Down) -- NB: not importing the constructor+  --   foo :: Int -> Down Int+  --   foo = coerce+  --+  -- Test cases: TcCoercibleFail.+  | OutOfScopeNewtypeConstructor TyCon DataCon++-- | Explain a problem with an import.+data ImportError+  -- | Couldn't find a module with the requested name.+  = MissingModule ModuleName+  -- | The imported modules don't export what we're looking for.+  | ModulesDoNotExport (NE.NonEmpty Module) OccName++-- | This datatype collates instances that match or unifier,+-- in order to report an error message for an unsolved typeclass constraint.+data PotentialInstances+  = PotentialInstances+  { matches  :: [ClsInst]+  , unifiers :: [ClsInst]+  }++-- | Append additional information to a `TcSolverReportMsg`.+mkTcReportWithInfo :: TcSolverReportMsg -> [TcSolverReportInfo] -> TcSolverReportMsg+mkTcReportWithInfo msg []+  = msg+mkTcReportWithInfo (TcReportWithInfo msg (prev NE.:| prevs)) infos+  = TcReportWithInfo msg (prev NE.:| prevs ++ infos)+mkTcReportWithInfo msg (info : infos)+  = TcReportWithInfo msg (info NE.:| infos)++-- | A collection of valid hole fits or refinement fits,+-- in which some fits might have been suppressed.+data FitsMbSuppressed+  = Fits+    { fits           :: [HoleFit]+    , fitsSuppressed :: Bool  -- ^ Whether we have suppressed any fits because there were too many.+    }++-- | A collection of hole fits and refinement fits.+data ValidHoleFits+  = ValidHoleFits+    { holeFits       :: FitsMbSuppressed+    , refinementFits :: FitsMbSuppressed+    }++noValidHoleFits :: ValidHoleFits+noValidHoleFits = ValidHoleFits (Fits [] False) (Fits [] False)++data RelevantBindings+  = RelevantBindings+    { relevantBindingNamesAndTys :: [(Name, Type)]+    , ranOutOfFuel               :: Bool -- ^ Whether we ran out of fuel generating the bindings.+    }++-- | Display some relevant bindings.+pprRelevantBindings :: RelevantBindings -> SDoc+-- This function should be in "GHC.Tc.Errors.Ppr",+-- but's it's here for the moment as it's needed in "GHC.Tc.Errors".+pprRelevantBindings (RelevantBindings bds ran_out_of_fuel) =+  ppUnless (null bds) $+    hang (text "Relevant bindings include")+       2 (vcat (map ppr_binding bds) $$ ppWhen ran_out_of_fuel discardMsg)+  where+    ppr_binding (nm, tidy_ty) =+      sep [ pprPrefixOcc nm <+> dcolon <+> ppr tidy_ty+          , nest 2 (parens (text "bound at"+               <+> ppr (getSrcLoc nm)))]++discardMsg :: SDoc+discardMsg = text "(Some bindings suppressed;" <+>+             text "use -fmax-relevant-binds=N or -fno-max-relevant-binds)"++-- | Stores the information to be reported in a representation-polymorphism+-- error message.+data FixedRuntimeRepErrorInfo+  = FRR_Info+  { frr_info_origin       :: FixedRuntimeRepOrigin+      -- ^ What is the original type we checked for+      -- representation-polymorphism, and what specific+      -- check did we perform?+  , frr_info_not_concrete :: Maybe (TcTyVar, TcType)+      -- ^ Which non-concrete type did we try to+      -- unify this concrete type variable with?+  }++{-+************************************************************************+*                                                                      *+\subsection{Contexts for renaming errors}+*                                                                      *+************************************************************************+-}++-- AZ:TODO: Change these all to be Name instead of RdrName.+--          Merge TcType.UserTypeContext in to it.+data HsDocContext+  = TypeSigCtx SDoc+  | StandaloneKindSigCtx SDoc+  | PatCtx+  | SpecInstSigCtx+  | DefaultDeclCtx+  | ForeignDeclCtx (LocatedN RdrName)+  | DerivDeclCtx+  | RuleCtx FastString+  | TyDataCtx (LocatedN RdrName)+  | TySynCtx (LocatedN RdrName)+  | TyFamilyCtx (LocatedN RdrName)+  | FamPatCtx (LocatedN RdrName)    -- The patterns of a type/data family instance+  | ConDeclCtx [LocatedN Name]+  | ClassDeclCtx (LocatedN RdrName)+  | ExprWithTySigCtx+  | TypBrCtx+  | HsTypeCtx+  | HsTypePatCtx+  | GHCiCtx+  | SpliceTypeCtx (LHsType GhcPs)+  | ClassInstanceCtx+  | GenericCtx SDoc
GHC/Tc/Gen/Annotation.hs view
@@ -15,6 +15,7 @@ import GHC.Driver.Session import GHC.Driver.Env +import GHC.Tc.Errors.Types import {-# SOURCE #-} GHC.Tc.Gen.Splice ( runAnnotation ) import GHC.Tc.Utils.Monad @@ -43,9 +44,7 @@ --- No GHCI; emit a warning (not an error) and ignore. cf #4268 warnAnns [] = return [] warnAnns anns@(L loc _ : _)-  = do { setSrcSpanA loc $ addWarnTc NoReason $-             (text "Ignoring ANN annotation" <> plural anns <> comma-             <+> text "because this is a stage-1 compiler without -fexternal-interpreter or doesn't support GHCi")+  = do { setSrcSpanA loc $ addDiagnosticTc (TcRnIgnoringAnnotations anns)        ; return [] }  tcAnnotation :: LAnnDecl GhcRn -> TcM Annotation@@ -58,11 +57,8 @@     setSrcSpanA loc $ addErrCtxt (annCtxt ann) $ do       -- See #10826 -- Annotations allow one to bypass Safe Haskell.       dflags <- getDynFlags-      when (safeLanguageOn dflags) $ failWithTc safeHsErr+      when (safeLanguageOn dflags) $ failWithTc TcRnAnnotationInSafeHaskell       runAnnotation target expr-    where-      safeHsErr = vcat [ text "Annotations are not compatible with Safe Haskell."-                  , text "See https://gitlab.haskell.org/ghc/ghc/issues/10826" ]  annProvenanceToTarget :: Module -> AnnProvenance GhcRn                       -> AnnTarget Name
GHC/Tc/Gen/App.hs view
@@ -1,7 +1,8 @@-{-# LANGUAGE CPP                 #-}+ {-# LANGUAGE DataKinds           #-} {-# LANGUAGE FlexibleContexts    #-} {-# LANGUAGE GADTs               #-}+{-# LANGUAGE LambdaCase          #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies        #-} {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]@@ -21,12 +22,21 @@  import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcPolyExpr ) -import GHC.Builtin.Types (multiplicityTy)+import GHC.Types.Basic ( Arity, ExprOrPat(Expression) )+import GHC.Types.Id ( idArity, idName, hasNoBinding )+import GHC.Types.Name ( isWiredInName )+import GHC.Types.Var+import GHC.Builtin.Types ( multiplicityTy )+import GHC.Core.ConLike  ( ConLike(..) )+import GHC.Core.DataCon ( dataConRepArity+                        , isNewDataCon, isUnboxedSumDataCon, isUnboxedTupleDataCon ) import GHC.Tc.Gen.Head import GHC.Hs+import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Unify import GHC.Tc.Utils.Instantiate+import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic ) import GHC.Tc.Instance.Family ( tcGetFamInstEnvs, tcLookupDataFamInst_maybe ) import GHC.Tc.Gen.HsType import GHC.Tc.Utils.TcMType@@ -54,8 +64,6 @@ import Control.Monad import Data.Function -#include "HsVersions.h"- import GHC.Prelude  {- *********************************************************************@@ -140,7 +148,7 @@   = addExprCtxt rn_expr $     setSrcSpanA loc     $     do { do_ql <- wantQuickLook rn_fun-       ; (_tc_fun, fun_sigma) <- tcInferAppHead fun rn_args Nothing+       ; (_tc_fun, fun_sigma) <- tcInferAppHead fun rn_args        ; (_delta, inst_args, app_res_sigma) <- tcInstFun do_ql inst fun fun_sigma rn_args        ; _tc_args <- tcValArgs do_ql inst_args        ; return app_res_sigma }@@ -164,12 +172,12 @@      |  ( app )             -- HsPar: parens      |  {-# PRAGMA #-} app  -- HsPragE: pragmas -head ::= f             -- HsVar:    variables-      |  fld           -- HsRecFld: record field selectors-      |  (expr :: ty)  -- ExprWithTySig: expr with user type sig-      |  lit           -- HsOverLit: overloaded literals+head ::= f                -- HsVar:    variables+      |  fld              -- HsRecSel: record field selectors+      |  (expr :: ty)     -- ExprWithTySig: expr with user type sig+      |  lit              -- HsOverLit: overloaded literals       |  $([| head |])    -- HsSpliceE+HsSpliced+HsSplicedExpr: untyped TH expression splices-      |  other_expr    -- Other expressions+      |  other_expr       -- Other expressions  When tcExpr sees something that starts an application chain (namely, any of the constructors in 'app' or 'head'), it invokes tcApp to@@ -239,7 +247,7 @@ 2. Use tcInferAppHead to infer the type of the function,      as an (uninstantiated) TcSigmaType    There are special cases for-     HsVar, HsRecFld, and ExprWithTySig+     HsVar, HsRecSel, and ExprWithTySig    Otherwise, delegate back to tcExpr, which      infers an (instantiated) TcRhoType @@ -282,14 +290,13 @@ * ($): For a long time GHC has had a special typing rule for ($), that   allows it to type (runST $ foo), which requires impredicative instantiation   of ($), without language flags.  It's a bit ad-hoc, but it's been that-  way for ages.  Using quickLookIds is the only special treatment ($) needs+  way for ages.  Using quickLookKeys is the only special treatment ($) needs   now, which is a lot better.  * leftSection, rightSection: these are introduced by the expansion step in   the renamer (Note [Handling overloaded and rebindable constructs] in   GHC.Rename.Expr), and we want them to be instantiated impredicatively   so that (f `op`), say, will work OK even if `f` is higher rank.-  See Note [Left and right sections] in GHC.Rename.Expr.  Note [Unify with expected type before typechecking arguments] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -325,12 +332,27 @@ tcApp rn_expr exp_res_ty   | (fun@(rn_fun, fun_ctxt), rn_args) <- splitHsApps rn_expr   = do { (tc_fun, fun_sigma) <- tcInferAppHead fun rn_args-                                    (checkingExpType_maybe exp_res_ty)         -- Instantiate        ; do_ql <- wantQuickLook rn_fun        ; (delta, inst_args, app_res_rho) <- tcInstFun do_ql True fun fun_sigma rn_args +       -- Check for representation polymorphism in the case that+       -- the head of the application is a primop or data constructor+       -- which has argument types that are representation-polymorphic.+       -- This amounts to checking that the leftover argument types,+       -- up until the arity, are not representation-polymorphic,+       -- so that we can perform eta-expansion later without introducing+       -- representation-polymorphic binders.+       --+       -- See Note [Checking for representation-polymorphic built-ins]+       ; traceTc "tcApp FRR" $+           vcat+             [ text "tc_fun =" <+> ppr tc_fun+             , text "inst_args =" <+> ppr inst_args+             , text "app_res_rho =" <+> ppr app_res_rho ]+       ; hasFixedRuntimeRep_remainingValArgs inst_args app_res_rho tc_fun+        -- Quick look at result        ; app_res_rho <- if do_ql                         then quickLookResultType delta app_res_rho exp_res_ty@@ -350,26 +372,12 @@                  = addFunResCtxt rn_fun rn_args app_res_rho exp_res_ty $                    thing_inside -       -- Match up app_res_rho: the result type of rn_expr-       --     with exp_res_ty:  the expected result type-       ; do_ds <- xoptM LangExt.DeepSubsumption        ; res_wrap <- perhaps_add_res_ty_ctxt $-            if not do_ds-            then -- No deep subsumption-                 -- app_res_rho and exp_res_ty are both rho-types,-                 -- so with simple subsumption we can just unify them-                 -- No need to zonk; the unifier does that-                 do { co <- unifyExpectedType rn_expr app_res_rho exp_res_ty-                    ; return (mkWpCastN co) }--            else -- Deep subsumption-                 -- Even though both app_res_rho and exp_res_ty are rho-types,-                 -- they may have nested polymorphism, so if deep subsumption-                 -- is on we must call tcSubType.-                 -- Zonk app_res_rho first, becuase QL may have instantiated some-                 -- delta variables to polytypes, and tcSubType doesn't expect that-                 do { app_res_rho <- zonkQuickLook do_ql app_res_rho-                    ; tcSubTypeDS rn_expr app_res_rho exp_res_ty }+                     tcSubTypeNC (exprCtOrigin rn_expr) GenSigCtxt (Just $ HsExprRnThing rn_expr)+                                 app_res_rho exp_res_ty+                     -- Need tcSubType because of the possiblity of deep subsumption.+                     -- app_res_rho and exp_res_ty are both rho-types, so without+                     -- deep subsumption unifyExpectedType would be sufficient         ; whenDOptM Opt_D_dump_tc_trace $          do { inst_args <- mapM zonkArg inst_args  -- Only when tracing@@ -385,16 +393,228 @@        -- Typecheck the value arguments        ; tc_args <- tcValArgs do_ql inst_args -       -- Reconstruct, with special case for tagToEnum#-       ; tc_expr <- if isTagToEnum rn_fun-                    then tcTagToEnum tc_fun fun_ctxt tc_args app_res_rho-                    else return (rebuildHsApps tc_fun fun_ctxt tc_args)+       -- Reconstruct, with a special cases for tagToEnum#.+       ; tc_expr <-+          if isTagToEnum rn_fun+          then tcTagToEnum tc_fun fun_ctxt tc_args app_res_rho+          else do return (rebuildHsApps tc_fun fun_ctxt tc_args)         -- Wrap the result        ; return (mkHsWrap res_wrap tc_expr) } +{-+Note [Checking for representation-polymorphic built-ins]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We cannot have representation-polymorphic or levity-polymorphic+function arguments. See Note [Representation polymorphism invariants]+in GHC.Core.  That is checked by the calls to `hasFixedRuntimeRep` in+`tcEValArg`.++But some /built-in/ functions have representation-polymorphic argument+types. Users can't define such Ids; they are all GHC built-ins or data+constructors.  Specifically they are:++1. A few wired-in Ids like unsafeCoerce#, with compulsory unfoldings.+2. Primops, such as raise#.+3. Newtype constructors with `UnliftedNewtypes` that have+   a representation-polymorphic argument.+4. Representation-polymorphic data constructors: unboxed tuples+   and unboxed sums.++For (1) consider+  badId :: forall r (a :: TYPE r). a -> a+  badId = unsafeCoerce# @r @r @a @a++The wired-in function+  unsafeCoerce# :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep)+                   (a :: TYPE r1) (b :: TYPE r2).+                   a -> b+has a convenient but representation-polymorphic type. It has no+binding; instead it has a compulsory unfolding, after which we+would have+  badId = /\r /\(a :: TYPE r). \(x::a). ...body of unsafeCorece#...+And this is no good because of that rep-poly \(x::a).  So we want+to reject this.++On the other hand+  goodId :: forall (a :: Type). a -> a+  goodId = unsafeCoerce# @LiftedRep @LiftedRep @a @a++is absolutely fine, because after we inline the unfolding, the \(x::a)+is representation-monomorphic.++Test cases: T14561, RepPolyWrappedVar2.++For primops (2) the situation is similar; they are eta-expanded in+CorePrep to be saturated, and that eta-expansion must not add a+representation-polymorphic lambda.++Test cases: T14561b, RepPolyWrappedVar, UnliftedNewtypesCoerceFail.++For (3), consider a representation-polymorphic newtype with+UnliftedNewtypes:++  type Id :: forall r. TYPE r -> TYPE r+  newtype Id a where { MkId :: a }++  bad :: forall r (a :: TYPE r). a -> Id a+  bad = MkId @r @a             -- Want to reject++  good :: forall (a :: Type). a -> Id a+  good = MkId @LiftedRep @a   -- Want to accept++Test cases: T18481, UnliftedNewtypesLevityBinder++So these three cases need special treatment. We add a special case+in tcApp to check whether an application of an Id has any remaining+representation-polymorphic arguments, after instantiation and application+of previous arguments.  This is achieved by the hasFixedRuntimeRep_remainingValArgs+function, which computes the types of the remaining value arguments, and checks+that each of these have a fixed runtime representation using hasFixedRuntimeRep.++Wrinkles++* Because of Note [Typechecking data constructors] in GHC.Tc.Gen.Head,+  we desugar a representation-polymorphic data constructor application+  like this:+     (/\(r :: RuntimeRep) (a :: TYPE r) \(x::a). K r a x) @LiftedRep Int 4+  That is, a rep-poly lambda applied to arguments that instantiate it in+  a rep-mono way.  It's a bit like a compulsory unfolding that has been+  inlined, but not yet beta-reduced.++  Because we want to accept this, we switch off Lint's representation+  polymorphism checks when Lint checks the output of the desugarer;+  see the lf_check_fixed_rep flag in GHC.Core.Lint.lintCoreBindings.++  We then rely on the simple optimiser to beta reduce these+  representation-polymorphic lambdas (e.g. GHC.Core.SimpleOpt.simple_app).++* Arity.  We don't want to check for arguments past the+  arity of the function.  For example++      raise# :: forall {r :: RuntimeRep} (a :: Type) (b :: TYPE r). a -> b++  has arity 1, so an instantiation such as:++      foo :: forall w r (z :: TYPE r). w -> z -> z+      foo = raise# @w @(z -> z)++  is unproblematic.  This means we must take care not to perform a+  representation-polymorphism check on `z`.++  To achieve this, we consult the arity of the 'Id' which is the head+  of the application (or just use 1 for a newtype constructor),+  and keep track of how many value-level arguments we have seen,+  to ensure we stop checking once we reach the arity.+  This is slightly complicated by the need to include both visible+  and invisible arguments, as the arity counts both:+  see GHC.Tc.Gen.Head.countVisAndInvisValArgs.++  Test cases: T20330{a,b}++-}++-- | Check for representation-polymorphism in the remaining argument types+-- of a variable or data constructor, after it has been instantiated and applied to some arguments.+--+-- See Note [Checking for representation-polymorphic built-ins]+hasFixedRuntimeRep_remainingValArgs :: [HsExprArg 'TcpInst] -> TcRhoType -> HsExpr GhcTc -> TcM ()+hasFixedRuntimeRep_remainingValArgs applied_args app_res_rho = \case++  HsVar _ (L _ fun_id)++    -- (1): unsafeCoerce#+    -- 'unsafeCoerce#' is peculiar: it is patched in manually as per+    -- Note [Wiring in unsafeCoerce#] in GHC.HsToCore.+    -- Unfortunately, even though its arity is set to 1 in GHC.HsToCore.mkUnsafeCoercePrimPair,+    -- at this stage, if we query idArity, we get 0. This is because+    -- we end up looking at the non-patched version of unsafeCoerce#+    -- defined in Unsafe.Coerce, and that one indeed has arity 0.+    --+    -- We thus manually specify the correct arity of 1 here.+    | idName fun_id == unsafeCoercePrimName+    -> check_thing fun_id 1 (FRRNoBindingResArg fun_id)++    -- (2): primops and other wired-in representation-polymorphic functions,+    -- such as 'rightSection', 'oneShot', etc; see bindings with Compulsory unfoldings+    -- in GHC.Types.Id.Make+    | isWiredInName (idName fun_id) && hasNoBinding fun_id+    -> check_thing fun_id (idArity fun_id) (FRRNoBindingResArg fun_id)+       -- NB: idArity consults the IdInfo of the Id. This can be a problem+       -- in the presence of hs-boot files, as we might not have finished+       -- typechecking; inspecting the IdInfo at this point can cause+       -- strange Core Lint errors (see #20447).+       -- We avoid this entirely by only checking wired-in names,+       -- as those are the only ones this check is applicable to anyway.+++  XExpr (ConLikeTc (RealDataCon con) _ _)+  -- (3): Representation-polymorphic newtype constructors.+    | isNewDataCon con+  -- (4): Unboxed tuples and unboxed sums+    || isUnboxedTupleDataCon con+    || isUnboxedSumDataCon con+    -> check_thing con (dataConRepArity con) (FRRDataConArg Expression con)++  _ -> return ()++  where+    nb_applied_vis_val_args :: Int+    nb_applied_vis_val_args = count isHsValArg applied_args++    nb_applied_val_args :: Int+    nb_applied_val_args = countVisAndInvisValArgs applied_args++    arg_tys :: [(Type,AnonArgFlag)]+    arg_tys = getRuntimeArgTys app_res_rho+    -- We do not need to zonk app_res_rho first, because the number of arrows+    -- in the (possibly instantiated) inferred type of the function will+    -- be at least the arity of the function.++    check_thing :: Outputable thing+                => thing+                -> Arity+                -> (Int -> FixedRuntimeRepContext)+                -> TcM ()+    check_thing thing arity mk_frr_orig = do+      traceTc "tcApp remainingValArgs check_thing" (debug_msg thing arity)+      go (nb_applied_vis_val_args + 1) (nb_applied_val_args + 1) arg_tys+      where+        go :: Int -- visible value argument index, starting from 1+                  -- only used to report the argument position in error messages+           -> Int -- value argument index, starting from 1+                  -- used to count up to the arity to ensure we don't check too many argument types+           -> [(Type, AnonArgFlag)] -- run-time argument types+           -> TcM ()+        go _ i_val _+          | i_val > arity+          = return ()+        go _ _ []+          -- Should never happen: it would mean that the arity is higher+          -- than the number of arguments apparent from the type+          = pprPanic "hasFixedRuntimeRep_remainingValArgs" (debug_msg thing arity)+        go i_visval !i_val ((arg_ty, af) : tys)+          = case af of+              InvisArg ->+                go i_visval (i_val + 1) tys+              VisArg   -> do+                hasFixedRuntimeRep_syntactic (mk_frr_orig i_visval) arg_ty+                go (i_visval + 1) (i_val + 1) tys++    -- A message containing all the relevant info, in case this functions+    -- needs to be debugged again at some point.+    debug_msg :: Outputable thing => thing -> Arity -> SDoc+    debug_msg thing arity =+      vcat+        [ text "thing =" <+> ppr thing+        , text "arity =" <+> ppr arity+        , text "applied_args =" <+> ppr applied_args+        , text "nb_applied_val_args =" <+> ppr nb_applied_val_args+        , text "arg_tys =" <+> ppr arg_tys ]+ -------------------- wantQuickLook :: HsExpr GhcRn -> TcM Bool+-- GHC switches on impredicativity all the time for ($) wantQuickLook (HsVar _ (L _ f))   | getUnique f `elem` quickLookKeys = return True wantQuickLook _                      = xoptM LangExt.ImpredicativeTypes@@ -464,7 +684,7 @@            ; return (eva { eva_arg    = ValArg arg'                          , eva_arg_ty = Scaled mult arg_ty }) } -tcEValArg :: AppCtxt -> EValArg 'TcpInst -> TcSigmaType -> TcM (LHsExpr GhcTc)+tcEValArg :: AppCtxt -> EValArg 'TcpInst -> TcSigmaTypeFRR -> TcM (LHsExpr GhcTc) -- Typecheck one value argument of a function call tcEValArg ctxt (ValArg larg@(L arg_loc arg)) exp_arg_sigma   = addArgCtxt ctxt larg $@@ -479,9 +699,9 @@     do { traceTc "tcEValArgQL {" (vcat [ ppr inner_fun <+> ppr inner_args ])        ; tc_args <- tcValArgs True inner_args        ; co      <- unifyType Nothing app_res_rho exp_arg_sigma-       ; traceTc "tcEValArg }" empty-       ; return (L arg_loc $ mkHsWrapCo co $-                 rebuildHsApps inner_fun fun_ctxt tc_args) }+       ; let arg' = mkHsWrapCo co $ rebuildHsApps inner_fun fun_ctxt tc_args+       ; traceTc "tcEValArgQL }" empty+       ; return (L arg_loc arg') }  {- ********************************************************************* *                                                                      *@@ -530,9 +750,6 @@           VAExpansion orig _ -> addExprCtxt orig thing_inside           VACall {}          -> thing_inside -    herald = sep [ text "The function" <+> quotes (ppr rn_fun)-                 , text "is applied to"]-     -- Count value args only when complaining about a function     -- applied to too many value args     -- See Note [Herald for matchExpectedFunTys] in GHC.Tc.Utils.Unify.@@ -543,25 +760,30 @@           HsUnboundVar {} -> True           _               -> False -    inst_all :: ArgFlag -> Bool+    inst_all, inst_inferred, inst_none :: ArgFlag -> Bool     inst_all (Invisible {}) = True     inst_all Required       = False -    inst_inferred :: ArgFlag -> Bool     inst_inferred (Invisible InferredSpec)  = True     inst_inferred (Invisible SpecifiedSpec) = False     inst_inferred Required                  = False +    inst_none _ = False+     inst_fun :: [HsExprArg 'TcpRn] -> ArgFlag -> Bool     inst_fun [] | inst_final  = inst_all-                | otherwise   = inst_inferred+                | otherwise   = inst_none+                -- Using `inst_none` for `:type` avoids+                -- `forall {r1} (a :: TYPE r1) {r2} (b :: TYPE r2). a -> b`+                -- turning into `forall a {r2} (b :: TYPE r2). a -> b`.+                -- See #21088.     inst_fun (EValArg {} : _) = inst_all     inst_fun _                = inst_inferred      -----------     go, go1 :: Delta-            -> [HsExprArg 'TcpInst]  -- Accumulator, reversed-            -> [Scaled TcSigmaType]  -- Value args to which applied so far+            -> [HsExprArg 'TcpInst]     -- Accumulator, reversed+            -> [Scaled TcSigmaTypeFRR]  -- Value args to which applied so far             -> TcSigmaType -> [HsExprArg 'TcpRn]             -> TcM (Delta, [HsExprArg 'TcpInst], TcSigmaType) @@ -657,10 +879,12 @@      -- Rule IARG from Fig 4 of the QL paper:     go1 delta acc so_far fun_ty-        (eva@(EValArg { eva_arg = ValArg arg, eva_ctxt = ctxt })  : rest_args)-      = do { (wrap, arg_ty, res_ty) <- matchActualFunTySigma herald-                                          (Just (ppr rn_fun))-                                          (n_val_args, so_far) fun_ty+        (eva@(EValArg { eva_arg = ValArg arg, eva_ctxt = ctxt }) : rest_args)+      = do { (wrap, arg_ty, res_ty) <-+                matchActualFunTySigma+                  (ExpectedFunTyArg (HsExprRnThing rn_fun) (unLoc arg))+                  (Just $ HsExprRnThing rn_fun)+                  (n_val_args, so_far) fun_ty           ; (delta', arg') <- if do_ql                               then addArgCtxt ctxt arg $                                    -- Context needed for constraints@@ -725,9 +949,7 @@    | otherwise   = do { (_, fun_ty) <- zonkTidyTcType emptyTidyEnv fun_ty-       ; failWith $-         text "Cannot apply expression of type" <+> quotes (ppr fun_ty) $$-         text "to a visible type argument" <+> quotes (ppr hs_ty) }+       ; failWith $ TcRnInvalidTypeApplication fun_ty hs_ty }  {- Note [Required quantifiers in the type of a term] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -753,7 +975,7 @@ Suppose 'wurble' is not in scope, and we have    (wurble @Int @Bool True 'x') -Then the renamer will make (HsUnboundVar "wurble) for 'wurble',+Then the renamer will make (HsUnboundVar "wurble") for 'wurble', and the typechecker will typecheck it with tcUnboundId, giving it a type 'alpha', and emitting a deferred Hole constraint, to be reported later.@@ -777,7 +999,7 @@ that may abandon an entire instance decl, which (in the presence of -fdefer-type-errors) leads to leading to #17792. -Downside; the typechecked term has lost its visible type arguments; we+Downside: the typechecked term has lost its visible type arguments; we don't even kind-check them.  But let's jump that bridge if we come to it.  Meanwhile, let's not crash! @@ -839,8 +1061,8 @@  ---------------- quickLookArg :: Delta-             -> LHsExpr GhcRn       -- Argument-             -> Scaled TcSigmaType  -- Type expected by the function+             -> LHsExpr GhcRn          -- ^ Argument+             -> Scaled TcSigmaTypeFRR  -- ^ Type expected by the function              -> TcM (Delta, EValArg 'TcpInst) -- See Note [Quick Look at value arguments] --@@ -879,11 +1101,11 @@   | Just {} <- tcSplitAppTy_maybe ty        = True   | otherwise                               = False -quickLookArg1 :: Bool -> Delta -> LHsExpr GhcRn -> TcSigmaType+quickLookArg1 :: Bool -> Delta -> LHsExpr GhcRn -> TcSigmaTypeFRR               -> TcM (Delta, EValArg 'TcpInst) quickLookArg1 guarded delta larg@(L _ arg) arg_ty   = do { let (fun@(rn_fun, fun_ctxt), rn_args) = splitHsApps arg-       ; mb_fun_ty <- tcInferAppHead_maybe rn_fun rn_args (Just arg_ty)+       ; mb_fun_ty <- tcInferAppHead_maybe rn_fun rn_args        ; traceTc "quickLookArg 1" $          vcat [ text "arg:" <+> ppr arg               , text "head:" <+> ppr rn_fun <+> dcolon <+> ppr mb_fun_ty@@ -1020,7 +1242,7 @@      ----------------     go_kappa bvs kappa ty2-      = ASSERT2( isMetaTyVar kappa, ppr kappa )+      = assertPpr (isMetaTyVar kappa) (ppr kappa) $         do { info <- readMetaTyVar kappa            ; case info of                Indirect ty1 -> go bvs ty1 ty2@@ -1037,7 +1259,7 @@           -- Passes the occurs check       = do { let ty2_kind   = typeKind ty2                  kappa_kind = tyVarKind kappa-           ; co <- unifyKind (Just (ppr ty2)) ty2_kind kappa_kind+           ; co <- unifyKind (Just (TypeThing ty2)) ty2_kind kappa_kind                    -- unifyKind: see Note [Actual unification in qlUnify]             ; traceTc "qlUnify:update" $@@ -1187,7 +1409,7 @@         -- Check that the type is algebraic        ; case tcSplitTyConApp_maybe res_ty of {-           Nothing -> do { addErrTc (mk_error res_ty doc1)+           Nothing -> do { addErrTc (TcRnTagToEnumUnspecifiedResTy res_ty)                          ; vanilla_result } ;            Just (tc, tc_args) -> @@ -1207,24 +1429,14 @@        ; return (mkHsWrap df_wrap tc_expr) }}}}}    | otherwise-  = failWithTc (text "tagToEnum# must appear applied to one value argument")+  = failWithTc TcRnTagToEnumMissingValArg    where     vanilla_result = return (rebuildHsApps tc_fun fun_ctxt tc_args)      check_enumeration ty' tc       | isEnumerationTyCon tc = return ()-      | otherwise             = addErrTc (mk_error ty' doc2)--    doc1 = vcat [ text "Specify the type by giving a type signature"-               , text "e.g. (tagToEnum# x) :: Bool" ]-    doc2 = text "Result type must be an enumeration type"--    mk_error :: TcType -> SDoc -> SDoc-    mk_error ty what-      = hang (text "Bad call to tagToEnum#"-               <+> text "at type" <+> ppr ty)-           2 what+      | otherwise             = addErrTc (TcRnTagToEnumResTyNotAnEnum ty')   {- *********************************************************************
GHC/Tc/Gen/Arrow.hs view
@@ -1,5 +1,6 @@-{-# LANGUAGE RankNTypes    #-}-{-# LANGUAGE TypeFamilies  #-}+{-# LANGUAGE RankNTypes     #-}+{-# LANGUAGE TypeFamilies   #-}+{-# LANGUAGE BlockArguments #-}  {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -18,9 +19,10 @@                                        , tcCheckPolyExpr )  import GHC.Hs+import GHC.Tc.Errors.Types import GHC.Tc.Gen.Match import GHC.Tc.Gen.Head( tcCheckId )-import GHC.Tc.Utils.Zonk( hsLPatType )+import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic ) import GHC.Tc.Utils.TcType import GHC.Tc.Utils.TcMType import GHC.Tc.Gen.Bind@@ -37,6 +39,7 @@ import GHC.Types.Var.Set import GHC.Builtin.Types.Prim import GHC.Types.Basic( Arity )+import GHC.Types.Error import GHC.Types.SrcLoc import GHC.Utils.Outputable import GHC.Utils.Panic@@ -89,13 +92,14 @@        -> ExpRhoType                            -- Expected type of whole proc expression        -> TcM (LPat GhcTc, LHsCmdTop GhcTc, TcCoercion) -tcProc pat cmd@(L _ (HsCmdTop names _)) exp_ty+tcProc pat cmd@(L loc (HsCmdTop names _)) exp_ty   = do  { exp_ty <- expTypeToType exp_ty  -- no higher-rank stuff with arrows         ; (co, (exp_ty1, res_ty)) <- matchExpectedAppTy exp_ty         ; (co1, (arr_ty, arg_ty)) <- matchExpectedAppTy exp_ty1         -- start with the names as they are used to desugar the proc itself         -- See #17423-        ; names' <- mapM (tcSyntaxName ProcOrigin arr_ty) names+        ; names' <- setSrcSpanA loc $+            mapM (tcSyntaxName ProcOrigin arr_ty) names         ; let cmd_env = CmdEnv { cmd_arr = arr_ty }         ; (pat', cmd') <- newArrowScope                           $ tcCheckPat (ArrowMatchCtxt ProcExpr) pat (unrestricted arg_ty)@@ -132,40 +136,46 @@          -> TcM (LHsCmdTop GhcTc)  tcCmdTop env names (L loc (HsCmdTop _names cmd)) cmd_ty@(cmd_stk, res_ty)-  = setSrcSpan loc $+  = setSrcSpanA loc $     do  { cmd' <- tcCmd env cmd cmd_ty         ; return (L loc $ HsCmdTop (CmdTopTc cmd_stk res_ty names) cmd') }  ---------------------------------------- tcCmd  :: CmdEnv -> LHsCmd GhcRn -> CmdType -> TcM (LHsCmd GhcTc)         -- The main recursive function-tcCmd env (L loc cmd) res_ty+tcCmd env (L loc cmd) cmd_ty@(_, res_ty)   = setSrcSpan (locA loc) $ do-        { cmd' <- tc_cmd env cmd res_ty+        { cmd' <- tc_cmd env cmd cmd_ty+        ; hasFixedRuntimeRep_syntactic (FRRArrow $ ArrowCmdResTy cmd) res_ty         ; return (L loc cmd') }  tc_cmd :: CmdEnv -> HsCmd GhcRn  -> CmdType -> TcM (HsCmd GhcTc)-tc_cmd env (HsCmdPar x cmd) res_ty+tc_cmd env (HsCmdPar x lpar cmd rpar) res_ty   = do  { cmd' <- tcCmd env cmd res_ty-        ; return (HsCmdPar x cmd') }+        ; return (HsCmdPar x lpar cmd' rpar) } -tc_cmd env (HsCmdLet x binds (L body_loc body)) res_ty+tc_cmd env (HsCmdLet x tkLet binds tkIn (L body_loc body)) res_ty   = do  { (binds', body') <- tcLocalBinds binds         $                              setSrcSpan (locA body_loc) $                              tc_cmd env body res_ty-        ; return (HsCmdLet x binds' (L body_loc body')) }+        ; return (HsCmdLet x tkLet binds' tkIn (L body_loc body')) }  tc_cmd env in_cmd@(HsCmdCase x scrut matches) (stk, res_ty)   = addErrCtxt (cmdCtxt in_cmd) $ do       (scrut', scrut_ty) <- tcInferRho scrut+      hasFixedRuntimeRep_syntactic+        (FRRArrow $ ArrowCmdCase)+        scrut_ty       matches' <- tcCmdMatches env scrut_ty matches (stk, res_ty)       return (HsCmdCase x scrut' matches') -tc_cmd env in_cmd@(HsCmdLamCase x matches) (stk, res_ty)-  = addErrCtxt (cmdCtxt in_cmd) $ do-      (co, [scrut_ty], stk') <- matchExpectedCmdArgs 1 stk-      matches' <- tcCmdMatches env scrut_ty matches (stk', res_ty)-      return (mkHsCmdWrap (mkWpCastN co) (HsCmdLamCase x matches'))+tc_cmd env cmd@(HsCmdLamCase x lc_variant match) cmd_ty+  = addErrCtxt (cmdCtxt cmd)+      do { let match_ctxt = ArrowLamCaseAlt lc_variant+         ; checkPatCounts (ArrowMatchCtxt match_ctxt) match+         ; (wrap, match') <-+             tcCmdMatchLambda env match_ctxt match cmd_ty+         ; return (mkHsCmdWrap wrap (HsCmdLamCase x lc_variant match')) }  tc_cmd env (HsCmdIf x NoSyntaxExprRn pred b1 b2) res_ty    -- Ordinary 'if'   = do  { pred' <- tcCheckMonoExpr pred boolTy@@ -179,14 +189,15 @@         -- For arrows, need ifThenElse :: forall r. T -> r -> r -> r         -- because we're going to apply it to the environment, not         -- the return value.-        ; (_, [r_tv]) <- tcInstSkolTyVars [alphaTyVar]+        ; skol_info <- mkSkolemInfo ArrowReboundIfSkol+        ; (_, [r_tv]) <- tcInstSkolTyVars skol_info [alphaTyVar]         ; let r_ty = mkTyVarTy r_tv         ; checkTc (not (r_tv `elemVarSet` tyCoVarsOfType pred_ty))-                  (text "Predicate type of `ifThenElse' depends on result type")-        ; (pred', fun')-            <- tcSyntaxOp IfOrigin fun (map synKnownType [pred_ty, r_ty, r_ty])-                                       (mkCheckExpType r_ty) $ \ _ _ ->-               tcCheckMonoExpr pred pred_ty+                  TcRnArrowIfThenElsePredDependsOnResultTy+        ; (pred', fun') <- tcSyntaxOp IfThenElseOrigin fun+                              (map synKnownType [pred_ty, r_ty, r_ty])+                              (mkCheckExpType r_ty) $ \ _ _ ->+                           tcCheckMonoExpr pred pred_ty          ; b1'   <- tcCmd env b1 res_ty         ; b2'   <- tcCmd env b2 res_ty@@ -217,6 +228,10 @@          ; arg' <- tcCheckMonoExpr arg arg_ty +        ; hasFixedRuntimeRep_syntactic+            (FRRArrow $ ArrowCmdArrApp (unLoc fun) (unLoc arg) ho_app)+            fun_ty+         ; return (HsCmdArrApp fun_ty fun' arg' ho_app lr) }   where        -- Before type-checking f, use the environment of the enclosing@@ -241,6 +256,9 @@     do  { arg_ty <- newOpenFlexiTyVarTy         ; fun'   <- tcCmd env fun (mkPairTy arg_ty cmd_stk, res_ty)         ; arg'   <- tcCheckMonoExpr arg arg_ty+        ; hasFixedRuntimeRep_syntactic+            (FRRArrow $ ArrowCmdApp (unLoc fun) (unLoc arg))+            arg_ty         ; return (HsCmdApp x fun' arg') }  -------------------------------------------@@ -250,44 +268,9 @@ -- ------------------------------ -- D;G |-a (\x.cmd) : (t,stk) --> res -tc_cmd env-       (HsCmdLam x (MG { mg_alts = L l [L mtch_loc-                                   (match@(Match { m_pats = pats, m_grhss = grhss }))],-                         mg_origin = origin }))-       (cmd_stk, res_ty)-  = addErrCtxt (pprMatchInCtxt match)        $-    do  { (co, arg_tys, cmd_stk') <- matchExpectedCmdArgs n_pats cmd_stk--                -- Check the patterns, and the GRHSs inside-        ; (pats', grhss') <- setSrcSpanA mtch_loc                                 $-                             tcPats (ArrowMatchCtxt KappaExpr)-                               pats (map (unrestricted . mkCheckExpType) arg_tys) $-                             tc_grhss grhss cmd_stk' (mkCheckExpType res_ty)--        ; let match' = L mtch_loc (Match { m_ext = noAnn-                                         , m_ctxt = ArrowMatchCtxt KappaExpr-                                         , m_pats = pats'-                                         , m_grhss = grhss' })-              arg_tys = map (unrestricted . hsLPatType) pats'-              cmd' = HsCmdLam x (MG { mg_alts = L l [match']-                                    , mg_ext = MatchGroupTc arg_tys res_ty-                                    , mg_origin = origin })-        ; return (mkHsCmdWrap (mkWpCastN co) cmd') }-  where-    n_pats     = length pats-    match_ctxt = ArrowMatchCtxt KappaExpr-    pg_ctxt    = PatGuard match_ctxt--    tc_grhss (GRHSs x grhss binds) stk_ty res_ty-        = do { (binds', grhss') <- tcLocalBinds binds $-                                   mapM (wrapLocM (tc_grhs stk_ty res_ty)) grhss-             ; return (GRHSs x grhss' binds') }--    tc_grhs stk_ty res_ty (GRHS x guards body)-        = do { (guards', rhs') <- tcStmtsAndThen pg_ctxt tcGuardStmt guards res_ty $-                                  \ res_ty -> tcCmd env body-                                                (stk_ty, checkingExpType "tc_grhs" res_ty)-             ; return (GRHS x guards' rhs') }+tc_cmd env (HsCmdLam x match) cmd_ty+  = do { (wrap, match') <- tcCmdMatchLambda env KappaExpr match cmd_ty+       ; return (mkHsCmdWrap wrap (HsCmdLam x match')) }  ------------------------------------------- --              Do notation@@ -313,7 +296,7 @@ --      D; G |-a  (| e c1 ... cn |)  :  stk --> t  tc_cmd env cmd@(HsCmdArrForm x expr f fixity cmd_args) (cmd_stk, res_ty)-  = addErrCtxt (cmdCtxt cmd)    $+  = addErrCtxt (cmdCtxt cmd)     do  { (cmd_args', cmd_tys) <- mapAndUnzipM tc_cmd_arg cmd_args                               -- We use alphaTyVar for 'w'         ; let e_ty = mkInfForAllTy alphaTyVar $@@ -324,27 +307,19 @@    where     tc_cmd_arg :: LHsCmdTop GhcRn -> TcM (LHsCmdTop GhcTc, TcType)-    tc_cmd_arg cmd@(L _ (HsCmdTop names _))+    tc_cmd_arg cmd@(L loc (HsCmdTop names _))        = do { arr_ty <- newFlexiTyVarTy arrowTyConKind             ; stk_ty <- newFlexiTyVarTy liftedTypeKind             ; res_ty <- newFlexiTyVarTy liftedTypeKind-            ; names' <- mapM (tcSyntaxName ProcOrigin arr_ty) names+            ; names' <- setSrcSpanA loc $+                mapM (tcSyntaxName ArrowCmdOrigin arr_ty) names             ; let env' = env { cmd_arr = arr_ty }             ; cmd' <- tcCmdTop env' names' cmd (stk_ty, res_ty)             ; return (cmd',  mkCmdArrTy env' (mkPairTy alphaTy stk_ty) res_ty) } ---------------------------------------------------------------------              Base case for illegal commands--- This is where expressions that aren't commands get rejected--tc_cmd _ cmd _-  = failWithTc (vcat [text "The expression", nest 2 (ppr cmd),-                      text "was found where an arrow command was expected"])---- | Typechecking for case command alternatives. Used for both--- 'HsCmdCase' and 'HsCmdLamCase'.+-- | Typechecking for case command alternatives. Used for 'HsCmdCase'. tcCmdMatches :: CmdEnv-             -> TcType                           -- ^ type of the scrutinee+             -> TcTypeFRR -- ^ Type of the scrutinee.              -> MatchGroup GhcRn (LHsCmd GhcRn)  -- ^ case alternatives              -> CmdType              -> TcM (MatchGroup GhcTc (LHsCmd GhcTc))@@ -356,7 +331,57 @@     mc_body body res_ty' = do { res_ty' <- expTypeToType res_ty'                               ; tcCmd env body (stk, res_ty') } -matchExpectedCmdArgs :: Arity -> TcType -> TcM (TcCoercionN, [TcType], TcType)+-- | Typechecking for 'HsCmdLam' and 'HsCmdLamCase'.+tcCmdMatchLambda :: CmdEnv+                 -> HsArrowMatchContext+                 -> MatchGroup GhcRn (LHsCmd GhcRn)+                 -> CmdType+                 -> TcM (HsWrapper, MatchGroup GhcTc (LHsCmd GhcTc))+tcCmdMatchLambda env+                 ctxt+                 mg@MG { mg_alts = L l matches }+                 (cmd_stk, res_ty)+  = do { (co, arg_tys, cmd_stk') <- matchExpectedCmdArgs n_pats cmd_stk++       ; let check_arg_tys = map (unrestricted . mkCheckExpType) arg_tys+       ; matches' <- forM matches $+           addErrCtxt . pprMatchInCtxt . unLoc <*> tc_match check_arg_tys cmd_stk'++       ; let arg_tys' = map unrestricted arg_tys+             mg' = mg { mg_alts = L l matches'+                      , mg_ext = MatchGroupTc arg_tys' res_ty }++       ; return (mkWpCastN co, mg') }+  where+    n_pats | isEmptyMatchGroup mg = 1   -- must be lambda-case+           | otherwise            = matchGroupArity mg++    -- Check the patterns, and the GRHSs inside+    tc_match arg_tys cmd_stk' (L mtch_loc (Match { m_pats = pats, m_grhss = grhss }))+      = do { (pats', grhss') <- setSrcSpanA mtch_loc           $+                                tcPats match_ctxt pats arg_tys $+                                tc_grhss grhss cmd_stk' (mkCheckExpType res_ty)++           ; return $ L mtch_loc (Match { m_ext = noAnn+                                        , m_ctxt = match_ctxt+                                        , m_pats = pats'+                                        , m_grhss = grhss' }) }++    match_ctxt = ArrowMatchCtxt ctxt+    pg_ctxt    = PatGuard match_ctxt++    tc_grhss (GRHSs x grhss binds) stk_ty res_ty+        = do { (binds', grhss') <- tcLocalBinds binds $+                                   mapM (wrapLocMA (tc_grhs stk_ty res_ty)) grhss+             ; return (GRHSs x grhss' binds') }++    tc_grhs stk_ty res_ty (GRHS x guards body)+        = do { (guards', rhs') <- tcStmtsAndThen pg_ctxt tcGuardStmt guards res_ty $+                                  \ res_ty -> tcCmd env body+                                                (stk_ty, checkingExpType "tc_grhs" res_ty)+             ; return (GRHS x guards' rhs') }++matchExpectedCmdArgs :: Arity -> TcType -> TcM (TcCoercionN, [TcTypeFRR], TcType) matchExpectedCmdArgs 0 ty   = return (mkTcNomReflCo ty, [], ty) matchExpectedCmdArgs n ty@@ -410,7 +435,7 @@                 -- NB:  The rec_ids for the recursive things                 --      already scope over this part. This binding may shadow                 --      some of them with polymorphic things with the same Name-                --      (see note [RecStmt] in GHC.Hs.Expr)+                --      (see Note [RecStmt] in GHC.Hs.Expr)          ; let rec_ids = takeList rec_names tup_ids         ; later_ids <- tcLookupLocalIds later_names
GHC/Tc/Gen/Bind.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP                 #-}+ {-# LANGUAGE FlexibleContexts    #-} {-# LANGUAGE RankNTypes          #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -18,7 +18,6 @@    , tcHsBootSigs    , tcPolyCheck    , chooseInferredQuantifiers-   , badBootDeclErr    ) where @@ -33,19 +32,25 @@ import GHC.Driver.Session import GHC.Data.FastString import GHC.Hs+import GHC.Tc.Errors.Types import GHC.Tc.Gen.Sig+import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic ) import GHC.Tc.Utils.Monad import GHC.Tc.Types.Origin import GHC.Tc.Utils.Env import GHC.Tc.Utils.Unify import GHC.Tc.Solver import GHC.Tc.Types.Evidence+import GHC.Tc.Types.Constraint+import GHC.Core.Predicate import GHC.Tc.Gen.HsType import GHC.Tc.Gen.Pat import GHC.Tc.Utils.TcMType+import GHC.Core.Reduction ( Reduction(..) ) import GHC.Core.Multiplicity import GHC.Core.FamInstEnv( normaliseType ) import GHC.Tc.Instance.Family( tcGetFamInstEnvs )+import GHC.Core.Class   ( Class ) import GHC.Tc.Utils.TcType import GHC.Core.Type (mkStrLitTy, tidyOpenType, mkCastTy) import GHC.Builtin.Types ( mkBoxedTupleTy )@@ -79,8 +84,6 @@ import Control.Monad import Data.Foldable (find) -#include "HsVersions.h"- {- ************************************************************************ *                                                                      *@@ -179,13 +182,10 @@ -- The TcLclEnv has an extended type envt for the new bindings tcTopBinds binds sigs   = do  { -- Pattern synonym bindings populate the global environment-          (binds', (tcg_env, tcl_env)) <- tcValBinds TopLevel binds sigs $-            do { gbl <- getGblEnv-               ; lcl <- getLclEnv-               ; return (gbl, lcl) }+          (binds', (tcg_env, tcl_env)) <- tcValBinds TopLevel binds sigs getEnvs         ; specs <- tcImpPrags sigs   -- SPECIALISE prags for imported Ids -        ; complete_matches <- setEnvs (tcg_env, tcl_env) $ tcCompleteSigs sigs+        ; complete_matches <- restoreEnvs (tcg_env, tcl_env) $ tcCompleteSigs sigs         ; traceTc "complete_matches" (ppr binds $$ ppr sigs)         ; traceTc "complete_matches" (ppr complete_matches) @@ -224,20 +224,17 @@ -- A hs-boot file has only one BindGroup, and it only has type -- signatures in it.  The renamer checked all this tcHsBootSigs binds sigs-  = do  { checkTc (null binds) badBootDeclErr+  = do  { checkTc (null binds) TcRnIllegalHsBootFileDecl         ; concatMapM (addLocMA tc_boot_sig) (filter isTypeLSig sigs) }   where     tc_boot_sig (TypeSig _ lnames hs_ty) = mapM f lnames       where         f (L _ name)-          = do { sigma_ty <- tcHsSigWcType (FunSigCtxt name False) hs_ty+          = do { sigma_ty <- tcHsSigWcType (FunSigCtxt name NoRRC) hs_ty                ; return (mkVanillaGlobal name sigma_ty) }         -- Notice that we make GlobalIds, not LocalIds     tc_boot_sig s = pprPanic "tcHsBootSigs/tc_boot_sig" (ppr s) -badBootDeclErr :: SDoc-badBootDeclErr = text "Illegal declarations in an hs-boot file"- ------------------------ tcLocalBinds :: HsLocalBinds GhcRn -> TcM thing              -> TcM (HsLocalBinds GhcTc, thing)@@ -256,48 +253,36 @@         ; (given_ips, ip_binds') <-             mapAndUnzipM (wrapLocSndMA (tc_ip_bind ipClass)) ip_binds -        -- If the binding binds ?x = E, we  must now-        -- discharge any ?x constraints in expr_lie-        -- See Note [Implicit parameter untouchables]+        -- Add all the IP bindings as givens for the body of the 'let'         ; (ev_binds, result) <- checkConstraints (IPSkol ips)                                   [] given_ips thing_inside          ; return (HsIPBinds x (IPBinds ev_binds ip_binds') , result) }   where-    ips = [ip | (L _ (IPBind _ (Left (L _ ip)) _)) <- ip_binds]+    ips = [ip | (L _ (IPBind _ (L _ ip) _)) <- ip_binds]          -- I wonder if we should do these one at a time         -- Consider     ?x = 4         --              ?y = ?x + 1-    tc_ip_bind ipClass (IPBind _ (Left (L _ ip)) expr)+    tc_ip_bind :: Class -> IPBind GhcRn -> TcM (DictId, IPBind GhcTc)+    tc_ip_bind ipClass (IPBind _ l_name@(L _ ip) expr)        = do { ty <- newOpenFlexiTyVarTy             ; let p = mkStrLitTy $ hsIPNameFS ip             ; ip_id <- newDict ipClass [ p, ty ]             ; expr' <- tcCheckMonoExpr expr ty-            ; let d = toDict ipClass p ty `fmap` expr'-            ; return (ip_id, (IPBind noAnn (Right ip_id) d)) }-    tc_ip_bind _ (IPBind _ (Right {}) _) = panic "tc_ip_bind"+            ; let d = mapLoc (toDict ipClass p ty) expr'+            ; return (ip_id, (IPBind ip_id l_name d)) }      -- Coerces a `t` into a dictionary for `IP "x" t`.     -- co : t -> IP "x" t+    toDict :: Class  -- IP class+           -> Type   -- type-level string for name of IP+           -> Type   -- type of IP+           -> HsExpr GhcTc   -- def'n of IP variable+           -> HsExpr GhcTc   -- dictionary for IP     toDict ipClass x ty = mkHsWrap $ mkWpCastR $                           wrapIP $ mkClassPred ipClass [x,ty] -{- Note [Implicit parameter untouchables]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We add the type variables in the types of the implicit parameters-as untouchables, not so much because we really must not unify them,-but rather because we otherwise end up with constraints like this-    Num alpha, Implic { wanted = alpha ~ Int }-The constraint solver solves alpha~Int by unification, but then-doesn't float that solved constraint out (it's not an unsolved-wanted).  Result disaster: the (Num alpha) is again solved, this-time by defaulting.  No no no.--However [Oct 10] this is all handled automatically by the-untouchable-range idea.--}- tcValBinds :: TopLevelFlag            -> [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn]            -> TcM thing@@ -428,23 +413,16 @@     tc_scc (AcyclicSCC bind) = tc_sub_group NonRecursive [bind]     tc_scc (CyclicSCC binds) = tc_sub_group Recursive    binds -    tc_sub_group rec_tc binds =-      tcPolyBinds sig_fn prag_fn Recursive rec_tc closed binds+    tc_sub_group rec_tc binds = tcPolyBinds top_lvl sig_fn prag_fn+                                            Recursive rec_tc closed binds -recursivePatSynErr ::-     (OutputableBndrId p, CollectPass (GhcPass p))-  => SrcSpan -- ^ The location of the first pattern synonym binding+recursivePatSynErr+  :: SrcSpan -- ^ The location of the first pattern synonym binding              --   (for error reporting)-  -> LHsBinds (GhcPass p)+  -> LHsBinds GhcRn   -> TcM a recursivePatSynErr loc binds-  = failAt loc $-    hang (text "Recursive pattern synonym definition with following bindings:")-       2 (vcat $ map pprLBind . bagToList $ binds)-  where-    pprLoc loc  = parens (text "defined at" <+> ppr loc)-    pprLBind (L loc bind) = pprWithCommas ppr (collectHsBindBinders CollNoDictBinders bind)-                                <+> pprLoc (locA loc)+  = failAt loc $ TcRnRecursivePatternSynonym binds  tc_single :: forall thing.             TopLevelFlag -> TcSigFun -> TcPragEnv@@ -459,7 +437,7 @@        }  tc_single top_lvl sig_fn prag_fn lbind closed thing_inside-  = do { (binds1, ids) <- tcPolyBinds sig_fn prag_fn+  = do { (binds1, ids) <- tcPolyBinds top_lvl sig_fn prag_fn                                       NonRecursive NonRecursive                                       closed                                       [lbind]@@ -496,7 +474,7 @@                                      , bndr <- collectHsBindBinders CollNoDictBinders bind ]  -------------------------tcPolyBinds :: TcSigFun -> TcPragEnv+tcPolyBinds :: TopLevelFlag -> TcSigFun -> TcPragEnv             -> RecFlag         -- Whether the group is really recursive             -> RecFlag         -- Whether it's recursive after breaking                                -- dependencies based on type signatures@@ -515,7 +493,7 @@ -- Knows nothing about the scope of the bindings -- None of the bindings are pattern synonyms -tcPolyBinds sig_fn prag_fn rec_group rec_tc closed bind_list+tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc closed bind_list   = setSrcSpan loc                              $     recoverM (recoveryCode binder_names sig_fn) $ do         -- Set up main recover; take advantage of any type sigs@@ -523,13 +501,17 @@     { traceTc "------------------------------------------------" Outputable.empty     ; traceTc "Bindings for {" (ppr binder_names)     ; dflags   <- getDynFlags-    ; let plan = decideGeneralisationPlan dflags bind_list closed sig_fn+    ; let plan = decideGeneralisationPlan dflags top_lvl closed sig_fn bind_list     ; traceTc "Generalisation plan" (ppr plan)     ; result@(_, poly_ids) <- case plan of          NoGen              -> tcPolyNoGen rec_tc prag_fn sig_fn bind_list          InferGen mn        -> tcPolyInfer rec_tc prag_fn sig_fn mn bind_list          CheckGen lbind sig -> tcPolyCheck prag_fn sig lbind +    ; mapM_ (\ poly_id ->+        hasFixedRuntimeRep_syntactic (FRRBinder $ idName poly_id) (idType poly_id))+        poly_ids+     ; traceTc "} End of bindings for" (vcat [ ppr binder_names, ppr rec_group                                             , vcat [ppr id <+> ppr (idType id) | id <- poly_ids]                                           ])@@ -633,7 +615,7 @@                 --    See Note [Relevant bindings and the binder stack]                  setSrcSpanA bind_loc $-                tcMatchesFun (L nm_loc mono_name) matches+                tcMatchesFun (L nm_loc mono_id) matches                              (mkCheckExpType rho_ty)         -- We make a funny AbsBinds, abstracting over nothing,@@ -655,15 +637,13 @@                              , fun_ext     = wrap_gen <.> wrap_res                              , fun_tick    = tick } -             export = ABE { abe_ext   = noExtField-                          , abe_wrap  = idHsWrapper+             export = ABE { abe_wrap  = idHsWrapper                           , abe_poly  = poly_id                           , abe_mono  = poly_id2                           , abe_prags = SpecPrags spec_prags } -             abs_bind = L bind_loc $-                        AbsBinds { abs_ext      = noExtField-                                 , abs_tvs      = []+             abs_bind = L bind_loc $ XHsBindsLR $+                        AbsBinds { abs_tvs      = []                                  , abs_ev_vars  = []                                  , abs_ev_binds = []                                  , abs_exports  = [export]@@ -734,18 +714,24 @@        ; mapM_ (checkOverloadedSig mono) sigs         ; traceTc "simplifyInfer call" (ppr tclvl $$ ppr name_taus $$ ppr wanted)-       ; (qtvs, givens, ev_binds, insoluble)-                 <- simplifyInfer tclvl infer_mode sigs name_taus wanted+       ; ((qtvs, givens, ev_binds, insoluble), residual)+            <- captureConstraints $ simplifyInfer tclvl infer_mode sigs name_taus wanted         ; let inferred_theta = map evVarPred givens        ; exports <- checkNoErrs $-                    mapM (mkExport prag_fn insoluble qtvs inferred_theta) mono_infos+                    mapM (mkExport prag_fn residual insoluble qtvs inferred_theta) mono_infos +         -- NB: *after* the checkNoErrs call above. This ensures that we don't get an error+         -- cascade in case mkExport runs into trouble. In particular, this avoids duplicate+         -- errors when a partial type signature cannot be quantified in chooseInferredQuantifiers.+         -- See Note [Quantification and partial signatures] in GHC.Tc.Solver, Wrinkle 4.+         -- Tested in partial-sigs/should_fail/NamedWilcardExplicitForall.+       ; emitConstraints residual+        ; loc <- getSrcSpanM        ; let poly_ids = map abe_poly exports-             abs_bind = L (noAnnSrcSpan loc) $-                        AbsBinds { abs_ext = noExtField-                                 , abs_tvs = qtvs+             abs_bind = L (noAnnSrcSpan loc) $ XHsBindsLR $+                        AbsBinds { abs_tvs = qtvs                                  , abs_ev_vars = givens, abs_ev_binds = [ev_binds]                                  , abs_exports = exports, abs_binds = binds'                                  , abs_sig = False }@@ -756,11 +742,12 @@  -------------- mkExport :: TcPragEnv+         -> WantedConstraints  -- residual constraints, already emitted (for errors only)          -> Bool                        -- True <=> there was an insoluble type error                                         --          when typechecking the bindings          -> [TyVar] -> TcThetaType      -- Both already zonked          -> MonoBindInfo-         -> TcM (ABExport GhcTc)+         -> TcM ABExport -- Only called for generalisation plan InferGen, not by CheckGen or NoGen -- -- mkExport generates exports with@@ -774,12 +761,12 @@  -- Pre-condition: the qtvs and theta are already zonked -mkExport prag_fn insoluble qtvs theta-         mono_info@(MBI { mbi_poly_name = poly_name-                        , mbi_sig       = mb_sig-                        , mbi_mono_id   = mono_id })+mkExport prag_fn residual insoluble qtvs theta+         (MBI { mbi_poly_name = poly_name+              , mbi_sig       = mb_sig+              , mbi_mono_id   = mono_id })   = do  { mono_ty <- zonkTcType (idType mono_id)-        ; poly_id <- mkInferredPolyId insoluble qtvs theta poly_name mb_sig mono_ty+        ; poly_id <- mkInferredPolyId residual insoluble qtvs theta poly_name mb_sig mono_ty          -- NB: poly_id has a zonked type         ; poly_id <- addInlinePrags poly_id prag_sigs@@ -801,16 +788,20 @@                   then return idHsWrapper  -- Fast path; also avoids complaint when we infer                                            -- an ambiguous type and have AllowAmbiguousType                                            -- e..g infer  x :: forall a. F a -> Int-                  else addErrCtxtM (mk_impedance_match_msg mono_info sel_poly_ty poly_ty) $-                       tcSubTypeSigma GhcBug20076 sig_ctxt sel_poly_ty poly_ty+                  else tcSubTypeSigma GhcBug20076+                                      sig_ctxt sel_poly_ty poly_ty+                       -- as Note [Impedance matching] explains, this should never fail,+                       -- and thus we'll never see an error message. It *may* do+                       -- instantiation, but no message will ever be printed to the+                       -- user, and so we use Shouldn'tHappenOrigin.+                       -- Actually, there is a bug here: #20076. So we tell the user+                       -- that they hit the bug. Once #20076 is fixed, change this+                       -- back to Shouldn'tHappenOrigin. -        ; warn_missing_sigs <- woptM Opt_WarnMissingLocalSignatures-        ; when warn_missing_sigs $-              localSigWarn Opt_WarnMissingLocalSignatures poly_id mb_sig+        ; localSigWarn poly_id mb_sig -        ; return (ABE { abe_ext = noExtField-                      , abe_wrap = wrap-                        -- abe_wrap :: idType poly_id ~ (forall qtvs. theta => mono_ty)+        ; return (ABE { abe_wrap = wrap+                        -- abe_wrap :: (forall qtvs. theta => mono_ty) ~ idType poly_id                       , abe_poly  = poly_id                       , abe_mono  = mono_id                       , abe_prags = SpecPrags spec_prags }) }@@ -818,12 +809,13 @@     prag_sigs = lookupPragEnv prag_fn poly_name     sig_ctxt  = InfSigCtxt poly_name -mkInferredPolyId :: Bool  -- True <=> there was an insoluble error when+mkInferredPolyId :: WantedConstraints   -- the residual constraints, already emitted+                 -> Bool  -- True <=> there was an insoluble error when                           --          checking the binding group for this Id                  -> [TyVar] -> TcThetaType                  -> Name -> Maybe TcIdSigInst -> TcType                  -> TcM TcId-mkInferredPolyId insoluble qtvs inferred_theta poly_name mb_sig_inst mono_ty+mkInferredPolyId residual insoluble qtvs inferred_theta poly_name mb_sig_inst mono_ty   | Just (TISI { sig_inst_sig = sig })  <- mb_sig_inst   , CompleteSig { sig_bndr = poly_id } <- sig   = return poly_id@@ -834,7 +826,7 @@                    -- a duplicate ambiguity error.  There is a similar                    -- checkNoErrs for complete type signatures too.     do { fam_envs <- tcGetFamInstEnvs-       ; let (_co, mono_ty') = normaliseType fam_envs Nominal mono_ty+       ; let mono_ty' = reductionReducedType $ normaliseType fam_envs Nominal mono_ty                -- Unification may not have normalised the type,                -- so do it here to make it as uncomplicated as possible.                -- Example: f :: [F Int] -> Bool@@ -843,7 +835,7 @@                -- We can discard the coercion _co, because we'll reconstruct                -- it in the call to tcSubType below -       ; (binders, theta') <- chooseInferredQuantifiers inferred_theta+       ; (binders, theta') <- chooseInferredQuantifiers residual inferred_theta                                 (tyCoVarsOfType mono_ty') qtvs mb_sig_inst         ; let inferred_poly_ty = mkInvisForAllTys binders (mkPhiTy theta' mono_ty')@@ -861,14 +853,16 @@        ; return (mkLocalId poly_name Many inferred_poly_ty) }  -chooseInferredQuantifiers :: TcThetaType   -- inferred+chooseInferredQuantifiers :: WantedConstraints  -- residual constraints+                          -> TcThetaType   -- inferred                           -> TcTyVarSet    -- tvs free in tau type                           -> [TcTyVar]     -- inferred quantified tvs                           -> Maybe TcIdSigInst                           -> TcM ([InvisTVBinder], TcThetaType)-chooseInferredQuantifiers inferred_theta tau_tvs qtvs Nothing+chooseInferredQuantifiers _residual inferred_theta tau_tvs qtvs Nothing   = -- No type signature (partial or complete) for this binder,     do { let free_tvs = closeOverKinds (growThetaTyVars inferred_theta tau_tvs)+                        -- See Note [growThetaTyVars vs closeWrtFunDeps] in GHC.Tc.Solver                         -- Include kind variables!  #7916              my_theta = pickCapturedPreds free_tvs inferred_theta              binders  = [ mkTyVarBinder InferredSpec tv@@ -876,11 +870,11 @@                         , tv `elemVarSet` free_tvs ]        ; return (binders, my_theta) } -chooseInferredQuantifiers inferred_theta tau_tvs qtvs-                          (Just (TISI { sig_inst_sig   = sig  -- Always PartialSig-                                      , sig_inst_wcx   = wcx-                                      , sig_inst_theta = annotated_theta-                                      , sig_inst_skols = annotated_tvs }))+chooseInferredQuantifiers residual inferred_theta tau_tvs qtvs+  (Just (TISI { sig_inst_sig   = sig@(PartialSig { psig_name = fn_name, psig_hs_ty = hs_ty })+              , sig_inst_wcx   = wcx+              , sig_inst_theta = annotated_theta+              , sig_inst_skols = annotated_tvs }))   = -- Choose quantifiers for a partial type signature     do { let (psig_qtv_nms, psig_qtv_bndrs) = unzip annotated_tvs        ; psig_qtv_bndrs <- mapM zonkInvisTVBinder psig_qtv_bndrs@@ -898,8 +892,8 @@             -- signature is not actually quantified.  How can that happen?             -- See Note [Quantification and partial signatures] Wrinkle 4             --     in GHC.Tc.Solver-       ; mapM_ report_mono_sig_tv_err [ n | (n,tv) <- psig_qtv_prs-                                          , not (tv `elem` qtvs) ]+       ; mapM_ report_mono_sig_tv_err [ pr | pr@(_,tv) <- psig_qtv_prs+                                           , not (tv `elem` qtvs) ]         ; annotated_theta      <- zonkTcTypes annotated_theta        ; (free_tvs, my_theta) <- choose_psig_context psig_qtv_set annotated_theta wcx@@ -915,22 +909,20 @@        ; return (final_qtvs, my_theta) }   where     report_dup_tyvar_tv_err (n1,n2)-      | PartialSig { psig_name = fn_name, psig_hs_ty = hs_ty } <- sig-      = addErrTc (hang (text "Couldn't match" <+> quotes (ppr n1)-                        <+> text "with" <+> quotes (ppr n2))-                     2 (hang (text "both bound by the partial type signature:")-                           2 (ppr fn_name <+> dcolon <+> ppr hs_ty)))--      | otherwise -- Can't happen; by now we know it's a partial sig-      = pprPanic "report_tyvar_tv_err" (ppr sig)+      = addErrTc (TcRnPartialTypeSigTyVarMismatch n1 n2 fn_name hs_ty) -    report_mono_sig_tv_err n-      | PartialSig { psig_name = fn_name, psig_hs_ty = hs_ty } <- sig-      = addErrTc (hang (text "Can't quantify over" <+> quotes (ppr n))-                     2 (hang (text "bound by the partial type signature:")-                           2 (ppr fn_name <+> dcolon <+> ppr hs_ty)))-      | otherwise -- Can't happen; by now we know it's a partial sig-      = pprPanic "report_mono_sig_tv_err" (ppr sig)+    report_mono_sig_tv_err (n,tv)+      = addErrTc (TcRnPartialTypeSigBadQuantifier n fn_name m_unif_ty hs_ty)+      where+        m_unif_ty = listToMaybe+                      [ rhs+                      -- recall that residuals are always implications+                      | residual_implic <- bagToList $ wc_impl residual+                      , residual_ct <- bagToList $ wc_simple (ic_wanted residual_implic)+                      , let residual_pred = ctPred residual_ct+                      , Just (Nominal, lhs, rhs) <- [ getEqPredTys_maybe residual_pred ]+                      , Just lhs_tv <- [ tcGetTyVar_maybe lhs ]+                      , lhs_tv == tv ]      choose_psig_context :: VarSet -> TcThetaType -> Maybe TcType                         -> TcM (VarSet, TcThetaType)@@ -941,7 +933,8 @@      choose_psig_context psig_qtvs annotated_theta (Just wc_var_ty)       = do { let free_tvs = closeOverKinds (growThetaTyVars inferred_theta seed_tvs)-                            -- growThetaVars just like the no-type-sig case+                            -- growThetaTyVars just like the no-type-sig case+                            -- See Note [growThetaTyVars vs closeWrtFunDeps] in GHC.Tc.Solver                             -- Omitting this caused #12844                  seed_tvs = tyCoVarsOfTypes annotated_theta  -- These are put there                             `unionVarSet` tau_tvs            --       by the user@@ -977,25 +970,8 @@        -- Hack alert!  See GHC.Tc.Gen.HsType:        -- Note [Extra-constraint holes in partial type signatures] -mk_impedance_match_msg :: MonoBindInfo-                       -> TcType -> TcType-                       -> TidyEnv -> TcM (TidyEnv, SDoc)--- This is a rare but rather awkward error messages-mk_impedance_match_msg (MBI { mbi_poly_name = name, mbi_sig = mb_sig })-                       inf_ty sig_ty tidy_env- = do { (tidy_env1, inf_ty) <- zonkTidyTcType tidy_env  inf_ty-      ; (tidy_env2, sig_ty) <- zonkTidyTcType tidy_env1 sig_ty-      ; let msg = vcat [ text "When checking that the inferred type"-                       , nest 2 $ ppr name <+> dcolon <+> ppr inf_ty-                       , text "is as general as its" <+> what <+> text "signature"-                       , nest 2 $ ppr name <+> dcolon <+> ppr sig_ty ]-      ; return (tidy_env2, msg) }-  where-    what = case mb_sig of-             Nothing                     -> text "inferred"-             Just sig | isPartialSig sig -> text "(partial)"-                      | otherwise        -> empty-+chooseInferredQuantifiers _ _ _ _ (Just (TISI { sig_inst_sig = sig@(CompleteSig {}) }))+  = pprPanic "chooseInferredQuantifiers" (ppr sig)  mk_inf_msg :: Name -> TcType -> TidyEnv -> TcM (TidyEnv, SDoc) mk_inf_msg poly_name poly_ty tidy_env@@ -1004,23 +980,19 @@                        , nest 2 $ ppr poly_name <+> dcolon <+> ppr poly_ty ]       ; return (tidy_env1, msg) } - -- | Warn the user about polymorphic local binders that lack type signatures.-localSigWarn :: WarningFlag -> Id -> Maybe TcIdSigInst -> TcM ()-localSigWarn flag id mb_sig+localSigWarn :: Id -> Maybe TcIdSigInst -> TcM ()+localSigWarn id mb_sig   | Just _ <- mb_sig               = return ()   | not (isSigmaTy (idType id))    = return ()-  | otherwise                      = warnMissingSignatures flag msg id-  where-    msg = text "Polymorphic local binding with no type signature:"+  | otherwise                      = warnMissingSignatures id -warnMissingSignatures :: WarningFlag -> SDoc -> Id -> TcM ()-warnMissingSignatures flag msg id+warnMissingSignatures :: Id -> TcM ()+warnMissingSignatures id   = do  { env0 <- tcInitTidyEnv         ; let (env1, tidy_ty) = tidyOpenType env0 (idType id)-        ; addWarnTcM (Reason flag) (env1, mk_msg tidy_ty) }-  where-    mk_msg ty = sep [ msg, nest 2 $ pprPrefixName (idName id) <+> dcolon <+> ppr ty ]+        ; let dia = TcRnPolymorphicBinderMissingSig (idName id) tidy_ty+        ; addDiagnosticTcM (env1, dia) }  checkOverloadedSig :: Bool -> TcIdSigInst -> TcM () -- Example:@@ -1034,9 +1006,7 @@   , monomorphism_restriction_applies   , let orig_sig = sig_inst_sig sig   = setSrcSpan (sig_loc orig_sig) $-    failWith $-    hang (text "Overloaded signature conflicts with monomorphism restriction")-       2 (ppr orig_sig)+    failWith $ TcRnOverloadedSig orig_sig   | otherwise   = return () @@ -1124,7 +1094,6 @@                                 or multi-parameter type classes  - an inferred type that includes unboxed tuples - Note [Impedance matching] ~~~~~~~~~~~~~~~~~~~~~~~~~ Consider@@ -1149,8 +1118,8 @@    tuple :: forall a b. (Eq a, Num a) => (a -> Bool -> Bool, [b] -> Bool -> Bool)    tuple a b d1 d1 = let ...bind f_mono, g_mono in (f_mono, g_mono) -   f a d1 d2 = case tuple a Any d1 d2 of (f, g) -> f-   g b = case tuple Integer b dEqInteger dNumInteger of (f,g) -> g+   f a d1 d2 = case tuple a Any d1 d2 of (f_mono, g_mono) -> f_mono+   g b = case tuple Integer b dEqInteger dNumInteger of (f_mono,g_mono) -> g_mono  Suppose the shared quantified tyvars are qtvs and constraints theta. Then we want to check that@@ -1159,13 +1128,10 @@  Notice that the impedance matcher may do defaulting.  See #7173. -It also cleverly does an ambiguity check; for example, rejecting-   f :: F a -> F a-where F is a non-injective type function.--}-+If we've gotten the constraints right during inference (and we assume we have),+this sub-type check should never fail. It's not really a check -- it's more of+a procedure to produce the right wrapper. -{- Note [SPECIALISE pragmas] ~~~~~~~~~~~~~~~~~~~~~~~~~ There is no point in a SPECIALISE pragma for a non-overloaded function:@@ -1208,7 +1174,7 @@             -> [LHsBind GhcRn]             -> TcM (LHsBinds GhcTc, [MonoBindInfo]) --- SPECIAL CASE 1: see Note [Inference for non-recursive function bindings]+-- SPECIAL CASE 1: see Note [Special case for non-recursive function bindings] tcMonoBinds is_rec sig_fn no_gen            [ L b_loc (FunBind { fun_id = L nm_loc name                               , fun_matches = matches })]@@ -1216,15 +1182,19 @@   | NonRecursive <- is_rec   -- ...binder isn't mentioned in RHS   , Nothing <- sig_fn name   -- ...with no type signature   = setSrcSpanA b_loc    $-    do  { ((co_fn, matches'), rhs_ty)-            <- tcInfer $ \ exp_ty ->-               tcExtendBinderStack [TcIdBndr_ExpType name exp_ty NotTopLevel] $-                  -- We extend the error context even for a non-recursive-                  -- function so that in type error messages we show the-                  -- type of the thing whose rhs we are type checking-               tcMatchesFun (L nm_loc name) matches exp_ty+    do  { ((co_fn, matches'), mono_id, _) <- fixM $ \ ~(_, _, rhs_ty) ->+                                          -- See Note [fixM for rhs_ty in tcMonoBinds]+            do  { mono_id <- newLetBndr no_gen name Many rhs_ty+                ; (matches', rhs_ty')+                    <- tcInfer $ \ exp_ty ->+                       tcExtendBinderStack [TcIdBndr_ExpType name exp_ty NotTopLevel] $+                          -- We extend the error context even for a non-recursive+                          -- function so that in type error messages we show the+                          -- type of the thing whose rhs we are type checking+                       tcMatchesFun (L nm_loc mono_id) matches exp_ty+                ; return (matches', mono_id, rhs_ty')+                } -        ; mono_id <- newLetBndr no_gen name Many rhs_ty         ; return (unitBag $ L b_loc $                      FunBind { fun_id = L nm_loc mono_id,                                fun_matches = matches',@@ -1233,7 +1203,7 @@                        , mbi_sig       = Nothing                        , mbi_mono_id   = mono_id }]) } --- SPECIAL CASE 2: see Note [Inference for non-recursive pattern bindings]+-- SPECIAL CASE 2: see Note [Special case for non-recursive pattern bindings] tcMonoBinds is_rec sig_fn no_gen            [L b_loc (PatBind { pat_lhs = pat, pat_rhs = grhss })]   | NonRecursive <- is_rec   -- ...binder isn't mentioned in RHS@@ -1242,7 +1212,7 @@     do { (grhss', pat_ty) <- tcInfer $ \ exp_ty ->                              tcGRHSsPat grhss exp_ty -       ; let exp_pat_ty :: Scaled ExpSigmaType+       ; let exp_pat_ty :: Scaled ExpSigmaTypeFRR              exp_pat_ty = unrestricted (mkCheckExpType pat_ty)        ; (pat', mbis) <- tcLetPat (const Nothing) no_gen pat exp_pat_ty $                          mapM lookupMBI bndrs@@ -1336,6 +1306,20 @@ correctly elaborate 'id'. But we want to /infer/ q's higher rank type.  There seems to be no way to do this.  So currently we only switch to inference when we have no signature for any of the binders.++Note [fixM for rhs_ty in tcMonoBinds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In order to create mono_id we need rhs_ty but we don't have it yet,+we only get it from tcMatchesFun later (which needs mono_id to put+into HsMatchContext for pretty printing). To solve this, create+a thunk of rhs_ty with fixM that we fill in later.++This is fine only because neither newLetBndr or tcMatchesFun look+at the varType field of the Id. tcMatchesFun only looks at idName+of mono_id.++Also see #20415 for the bigger picture of why tcMatchesFun needs+mono_id in the first place. -}  @@ -1358,7 +1342,7 @@ data TcMonoBind         -- Half completed; LHS done, RHS not done   = TcFunBind  MonoBindInfo  SrcSpan (MatchGroup GhcRn (LHsExpr GhcRn))   | TcPatBind [MonoBindInfo] (LPat GhcTc) (GRHSs GhcRn (LHsExpr GhcRn))-              TcSigmaType+              TcSigmaTypeFRR  tcLhs :: TcSigFun -> LetBndrSpec -> HsBind GhcRn -> TcM TcMonoBind -- Only called with plan InferGen (LetBndrSpec = LetLclBndr)@@ -1400,7 +1384,7 @@             -- See Note [Existentials in pattern bindings]         ; ((pat', nosig_mbis), pat_ty)             <- addErrCtxt (patMonoBindsCtxt pat grhss) $-               tcInfer $ \ exp_ty ->+               tcInferFRR FRRPatBind $ \ exp_ty ->                tcLetPat inst_sig_fun no_gen pat (unrestricted exp_ty) $                  -- The above inferred type get an unrestricted multiplicity. It may be                  -- worth it to try and find a finer-grained multiplicity here@@ -1463,7 +1447,7 @@   = tcExtendIdBinderStackForRhs [info]  $     tcExtendTyVarEnvForRhs mb_sig       $     do  { traceTc "tcRhs: fun bind" (ppr mono_id $$ ppr (idType mono_id))-        ; (co_fn, matches') <- tcMatchesFun (L (noAnnSrcSpan loc) (idName mono_id))+        ; (co_fn, matches') <- tcMatchesFun (L (noAnnSrcSpan loc) mono_id)                                  matches (mkCheckExpType $ idType mono_id)         ; return ( FunBind { fun_id = L (noAnnSrcSpan loc) mono_id                            , fun_matches = matches'@@ -1479,6 +1463,7 @@     do  { traceTc "tcRhs: pat bind" (ppr pat' $$ ppr pat_ty)         ; grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $                     tcGRHSsPat grhss (mkCheckExpType pat_ty)+         ; return ( PatBind { pat_lhs = pat', pat_rhs = grhss'                            , pat_ext = pat_ty                            , pat_ticks = ([],[]) } )}@@ -1662,12 +1647,12 @@   ppr (CheckGen _ s) = text "CheckGen" <+> ppr s  decideGeneralisationPlan-   :: DynFlags -> [LHsBind GhcRn] -> IsGroupClosed -> TcSigFun-   -> GeneralisationPlan-decideGeneralisationPlan dflags lbinds closed sig_fn+   :: DynFlags -> TopLevelFlag -> IsGroupClosed -> TcSigFun+   -> [LHsBind GhcRn] -> GeneralisationPlan+decideGeneralisationPlan dflags top_lvl closed sig_fn lbinds   | has_partial_sigs                         = InferGen (and partial_sig_mrs)   | Just (bind, sig) <- one_funbind_with_sig = CheckGen bind sig-  | do_not_generalise closed                 = NoGen+  | do_not_generalise                        = NoGen   | otherwise                                = InferGen mono_restriction   where     binds = map unLoc lbinds@@ -1683,17 +1668,22 @@             <- mapMaybe sig_fn (collectHsBindListBinders CollNoDictBinders lbinds)         , let (mtheta, _) = splitLHsQualTy (hsSigWcType hs_ty) ] -    has_partial_sigs   = not (null partial_sig_mrs)+    has_partial_sigs = not (null partial_sig_mrs)      mono_restriction  = xopt LangExt.MonomorphismRestriction dflags                      && any restricted binds -    do_not_generalise (IsGroupClosed _ True) = False+    do_not_generalise+      | isTopLevel top_lvl             = False+        -- See Note [Always generalise top-level bindings]++      | IsGroupClosed _ True <- closed = False         -- The 'True' means that all of the group's         -- free vars have ClosedTypeId=True; so we can ignore         -- -XMonoLocalBinds, and generalise anyway-    do_not_generalise _ = xopt LangExt.MonoLocalBinds dflags +      | otherwise = xopt LangExt.MonoLocalBinds dflags+     -- With OutsideIn, all nested bindings are monomorphic     -- except a single function binding with a signature     one_funbind_with_sig@@ -1767,6 +1757,21 @@                -- These won't be in the local type env.                -- Ditto class method etc from the current module +{- Note [Always generalise top-level bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It is very confusing to apply NoGen to a top level binding. Consider (#20123):+   module M where+     x = 5+     f y = (x, y)++The MR means that x=5 is not generalise, so f's binding is no Closed.  So we'd+be tempted to use NoGen. But that leads to f :: Any -> (Integer, Any), which+is plain stupid.++NoGen is good when we have call sites, but not at top level, where the+function may be exported.  And it's easier to grok "MonoLocalBinds" as+applying to, well, local bindings.+-}  {- ********************************************************************* *                                                                      *
GHC/Tc/Gen/Default.hs view
@@ -14,6 +14,7 @@ import GHC.Core.Class import GHC.Core.Type ( typeKind ) import GHC.Types.Var( tyVarKind )+import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Env import GHC.Tc.Gen.HsType@@ -22,10 +23,10 @@ import GHC.Tc.Validity import GHC.Tc.Utils.TcType import GHC.Builtin.Names+import GHC.Types.Error import GHC.Types.SrcLoc import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Data.FastString import qualified GHC.LanguageExtensions as LangExt  tcDefaults :: [LDefaultDecl GhcRn]@@ -80,7 +81,7 @@          -- Check that the type is an instance of at least one of the deflt_clss         ; oks <- mapM (check_instance ty) deflt_clss-        ; checkTc (or oks) (badDefaultTy ty deflt_clss)+        ; checkTc (or oks) (TcRnBadDefaultType ty deflt_clss)         ; return ty }  check_instance :: Type -> Class -> TcM Bool@@ -102,17 +103,7 @@ defaultDeclCtxt :: SDoc defaultDeclCtxt = text "When checking the types in a default declaration" -dupDefaultDeclErr :: [LDefaultDecl GhcRn] -> SDoc+dupDefaultDeclErr :: [LDefaultDecl GhcRn] -> TcRnMessage dupDefaultDeclErr (L _ (DefaultDecl _ _) : dup_things)-  = hang (text "Multiple default declarations")-       2 (vcat (map pp dup_things))-  where-    pp :: LDefaultDecl GhcRn -> SDoc-    pp (L locn (DefaultDecl _ _))-      = text "here was another default declaration" <+> ppr (locA locn)+  = TcRnMultipleDefaultDeclarations dup_things dupDefaultDeclErr [] = panic "dupDefaultDeclErr []"--badDefaultTy :: Type -> [Class] -> SDoc-badDefaultTy ty deflt_clss-  = hang (text "The default type" <+> quotes (ppr ty) <+> ptext (sLit "is not an instance of"))-       2 (foldr1 (\a b -> a <+> text "or" <+> b) (map (quotes. ppr) deflt_clss))
GHC/Tc/Gen/Export.hs view
@@ -10,6 +10,7 @@ import GHC.Hs import GHC.Types.FieldLabel import GHC.Builtin.Names+import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Env import GHC.Tc.Utils.TcType@@ -25,11 +26,9 @@ import GHC.Core.ConLike import GHC.Core.PatSyn import GHC.Data.Maybe-import GHC.Utils.Misc (capitalise) import GHC.Data.FastString (fsLit) import GHC.Driver.Env -import GHC.Types.TyThing( tyThingCategory ) import GHC.Types.Unique.Set import GHC.Types.SrcLoc as SrcLoc import GHC.Types.Name@@ -45,6 +44,7 @@ import GHC.Driver.Session import GHC.Parser.PostProcess ( setRdrNameSpace ) import Data.Either            ( partitionEithers )+import GHC.Rename.Doc  {- ************************************************************************@@ -175,7 +175,7 @@                        , tcg_rdr_env = rdr_env                        , tcg_imports = imports                        , tcg_src     = hsc_src } = tcg_env-              default_main | mainModIs hsc_env == this_mod+              default_main | mainModIs (hsc_HUE hsc_env) == this_mod                            , Just main_fun <- mainFunIs dflags                            = mkUnqual varName (fsLit main_fun)                            | otherwise@@ -236,10 +236,8 @@    -- so that's how we handle it, except we also export the data family    -- when a data instance is exported.   = do {-    ; warnMissingExportList <- woptM Opt_WarnMissingExportList-    ; warnIfFlag Opt_WarnMissingExportList-        warnMissingExportList-        (missingModuleExportWarn $ moduleName _this_mod)+    ; addDiagnostic+        (TcRnMissingExportList $ moduleName _this_mod)     ; let avails =             map fix_faminst . gresToAvailInfo               . filter isLocalGRE . globalRdrEnvElts $ rdr_env@@ -284,8 +282,7 @@     exports_from_item (ExportAccum occs earlier_mods)                       (L loc ie@(IEModuleContents _ lmod@(L _ mod)))         | mod `elementOfUniqSet` earlier_mods    -- Duplicate export of M-        = do { warnIfFlag Opt_WarnDuplicateExports True-                          (dupModuleExport mod) ;+        = do { addDiagnostic (TcRnDupeModuleExport mod) ;                return Nothing }          | otherwise@@ -299,10 +296,8 @@                    ; mods        = addOneToUniqSet earlier_mods mod                    } -             ; checkErr exportValid (moduleNotImported mod)-             ; warnIfFlag Opt_WarnDodgyExports-                          (exportValid && null gre_prs)-                          (nullModuleExport mod)+             ; checkErr exportValid (TcRnExportedModNotImported mod)+             ; warnIf (exportValid && null gre_prs) (TcRnNullExportedModule mod)               ; traceRn "efa" (ppr mod $$ ppr all_gres)              ; addUsedGREs all_gres@@ -322,12 +317,12 @@                             , ( L loc (IEModuleContents noExtField lmod)                               , new_exports))) } -    exports_from_item acc@(ExportAccum occs mods) (L loc ie)-        | Just new_ie <- lookup_doc_ie ie-        = return (Just (acc, (L loc new_ie, [])))--        | otherwise-        = do (new_ie, avail) <- lookup_ie ie+    exports_from_item acc@(ExportAccum occs mods) (L loc ie) = do+        m_new_ie <- lookup_doc_ie ie+        case m_new_ie of+          Just new_ie -> return (Just (acc, (L loc new_ie, [])))+          Nothing -> do+             (new_ie, avail) <- lookup_ie ie              if isUnboundName (ieName new_ie)                   then return Nothing    -- Avoid error cascade                   else do@@ -393,23 +388,24 @@              let gres = findChildren kids_env name                  (non_flds, flds) = classifyGREs gres              addUsedKids (ieWrappedName rdr) gres-             warnDodgyExports <- woptM Opt_WarnDodgyExports              when (null gres) $                   if isTyConName name-                  then when warnDodgyExports $-                           addWarn (Reason Opt_WarnDodgyExports)-                                   (dodgyExportWarn name)+                  then addTcRnDiagnostic (TcRnDodgyExports name)                   else -- This occurs when you export T(..), but                        -- only import T abstractly, or T is a synonym.-                       addErr (exportItemErr ie)+                       addErr (TcRnExportHiddenComponents ie)              return (L (locA l) name, non_flds, flds)      --------------    lookup_doc_ie :: IE GhcPs -> Maybe (IE GhcRn)-    lookup_doc_ie (IEGroup _ lev doc) = Just (IEGroup noExtField lev doc)-    lookup_doc_ie (IEDoc _ doc)       = Just (IEDoc noExtField doc)-    lookup_doc_ie (IEDocNamed _ str)  = Just (IEDocNamed noExtField str)-    lookup_doc_ie _ = Nothing+    lookup_doc_ie :: IE GhcPs -> RnM (Maybe (IE GhcRn))+    lookup_doc_ie (IEGroup _ lev doc) = do+      doc' <- rnLHsDoc doc+      pure $ Just (IEGroup noExtField lev doc')+    lookup_doc_ie (IEDoc _ doc)       = do+      doc' <- rnLHsDoc doc+      pure $ Just (IEDoc noExtField doc')+    lookup_doc_ie (IEDocNamed _ str)  = pure $ Just (IEDocNamed noExtField str)+    lookup_doc_ie _ = pure Nothing      -- In an export item M.T(A,B,C), we want to treat the uses of     -- A,B,C as if they were M.A, M.B, M.C@@ -582,7 +578,7 @@ -- | Given a resolved name in the children export list and a parent. Decide -- whether we are allowed to export the child with the parent. -- Invariant: gre_par == NoParent--- See note [Typing Pattern Synonym Exports]+-- See Note [Typing Pattern Synonym Exports] checkPatSynParent :: Name    -- ^ Alleged parent type constructor                              -- User wrote T( P, Q )                   -> Parent  -- The parent of P we discovered@@ -614,19 +610,16 @@     psErr  = exportErrCtxt "pattern synonym"     selErr = exportErrCtxt "pattern synonym record selector" -    assocClassErr :: SDoc-    assocClassErr = text "Pattern synonyms can be bundled only with datatypes."-     handle_pat_syn :: SDoc-                   -> TyCon      -- ^ Parent TyCon-                   -> PatSyn     -- ^ Corresponding bundled PatSyn-                                 --   and pretty printed origin+                   -> TyCon      -- Parent TyCon+                   -> PatSyn     -- Corresponding bundled PatSyn+                                 -- and pretty printed origin                    -> TcM ()     handle_pat_syn doc ty_con pat_syn -      -- 2. See note [Types of TyCon]+      -- 2. See Note [Types of TyCon]       | not $ isTyConWithSrcDataCons ty_con-      = addErrCtxt doc $ failWithTc assocClassErr+      = addErrCtxt doc $ failWithTc TcRnPatSynBundledWithNonDataCon        -- 3. Is the head a type variable?       | Nothing <- mtycon@@ -634,7 +627,8 @@       -- 4. Ok. Check they are actually the same type constructor.        | Just p_ty_con <- mtycon, p_ty_con /= ty_con-      = addErrCtxt doc $ failWithTc typeMismatchError+      = addErrCtxt doc $ failWithTc+          (TcRnPatSynBundledWithWrongType expected_res_ty res_ty)        -- 5. We passed!       | otherwise@@ -644,13 +638,6 @@         expected_res_ty = mkTyConApp ty_con (mkTyVarTys (tyConTyVars ty_con))         (_, _, _, _, _, res_ty) = patSynSig pat_syn         mtycon = fst <$> tcSplitTyConApp_maybe res_ty-        typeMismatchError :: SDoc-        typeMismatchError =-          text "Pattern synonyms can only be bundled with matching type constructors"-              $$ text "Couldn't match expected type of"-              <+> quotes (ppr expected_res_ty)-              <+> text "with actual type of"-              <+> quotes (ppr res_ty)   {-===========================================================================-}@@ -673,9 +660,7 @@             | greNameMangledName child == greNameMangledName child'   -- Duplicate export             -- But we don't want to warn if the same thing is exported             -- by two different module exports. See ticket #4478.-            -> do { warnIfFlag Opt_WarnDuplicateExports-                               (not (dupExport_ok child ie ie'))-                               (dupExportWarn child ie ie')+            -> do { warnIf (not (dupExport_ok child ie ie')) (TcRnDuplicateExport child ie ie')                   ; return occs }              | otherwise    -- Same occ name but different names: an error@@ -737,35 +722,6 @@     single _               = False  -dupModuleExport :: ModuleName -> SDoc-dupModuleExport mod-  = hsep [text "Duplicate",-          quotes (text "Module" <+> ppr mod),-          text "in export list"]--moduleNotImported :: ModuleName -> SDoc-moduleNotImported mod-  = hsep [text "The export item",-          quotes (text "module" <+> ppr mod),-          text "is not imported"]--nullModuleExport :: ModuleName -> SDoc-nullModuleExport mod-  = hsep [text "The export item",-          quotes (text "module" <+> ppr mod),-          text "exports nothing"]--missingModuleExportWarn :: ModuleName -> SDoc-missingModuleExportWarn mod-  = hsep [text "The export item",-          quotes (text "module" <+> ppr mod),-          text "is missing an export list"]---dodgyExportWarn :: Name -> SDoc-dodgyExportWarn item-  = dodgyMsg (text "export") item (dodgyMsgInsert item :: IE GhcRn)- exportErrCtxt :: Outputable o => String -> o -> SDoc exportErrCtxt herald exp =   text "In the" <+> text (herald ++ ":") <+> ppr exp@@ -777,65 +733,21 @@   where     exportCtxt = text "In the export:" <+> ppr ie -exportItemErr :: IE GhcPs -> SDoc-exportItemErr export_item-  = sep [ text "The export item" <+> quotes (ppr export_item),-          text "attempts to export constructors or class methods that are not visible here" ] --dupExportWarn :: GreName -> IE GhcPs -> IE GhcPs -> SDoc-dupExportWarn child ie1 ie2-  = hsep [quotes (ppr child),-          text "is exported by", quotes (ppr ie1),-          text "and",            quotes (ppr ie2)]--dcErrMsg :: Name -> String -> SDoc -> [SDoc] -> SDoc-dcErrMsg ty_con what_is thing parents =-          text "The type constructor" <+> quotes (ppr ty_con)-                <+> text "is not the parent of the" <+> text what_is-                <+> quotes thing <> char '.'-                $$ text (capitalise what_is)-                   <> text "s can only be exported with their parent type constructor."-                $$ (case parents of-                      [] -> empty-                      [_] -> text "Parent:"-                      _  -> text "Parents:") <+> fsep (punctuate comma parents)- failWithDcErr :: Name -> GreName -> [Name] -> TcM a failWithDcErr parent child parents = do   ty_thing <- tcLookupGlobal (greNameMangledName child)-  failWithTc $ dcErrMsg parent (pp_category ty_thing)-                        (ppr child) (map ppr parents)-  where-    pp_category :: TyThing -> String-    pp_category (AnId i)-      | isRecordSelector i = "record selector"-    pp_category i = tyThingCategory i+  failWithTc $ TcRnExportedParentChildMismatch parent ty_thing child parents   exportClashErr :: GlobalRdrEnv                -> GreName -> GreName                -> IE GhcPs -> IE GhcPs-               -> SDoc+               -> TcRnMessage exportClashErr global_env child1 child2 ie1 ie2-  = vcat [ text "Conflicting exports for" <+> quotes (ppr occ) <> colon-         , ppr_export child1' gre1' ie1'-         , ppr_export child2' gre2' ie2'-         ]+  = TcRnConflictingExports occ child1' gre1' ie1' child2' gre2' ie2'   where     occ = occName child1--    ppr_export child gre ie = nest 3 (hang (quotes (ppr ie) <+> text "exports" <+>-                                            quotes (ppr_name child))-                                        2 (pprNameProvenance gre))--    -- DuplicateRecordFields means that nameOccName might be a mangled-    -- $sel-prefixed thing, in which case show the correct OccName alone-    -- (but otherwise show the Name so it will have a module qualifier)-    ppr_name (FieldGreName fl) | flIsOverloaded fl = ppr fl-                               | otherwise         = ppr (flSelector fl)-    ppr_name (NormalGreName name) = ppr name-     -- get_gre finds a GRE for the Name, so that we can show its provenance     gre1 = get_gre child1     gre2 = get_gre child2
GHC/Tc/Gen/Expr.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP                 #-}+ {-# LANGUAGE DataKinds           #-} {-# LANGUAGE FlexibleContexts    #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -23,23 +23,24 @@          tcPolyExpr, tcExpr,          tcSyntaxOp, tcSyntaxOpGen, SyntaxOpType(..), synKnownType,          tcCheckId,-         addAmbiguousNameErr,          getFixedTyVars ) where -#include "HsVersions.h"- import GHC.Prelude  import {-# SOURCE #-}   GHC.Tc.Gen.Splice( tcSpliceExpr, tcTypedBracket, tcUntypedBracket )  import GHC.Hs+import GHC.Hs.Syn.Type import GHC.Rename.Utils import GHC.Tc.Utils.Zonk import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Unify import GHC.Types.Basic+import GHC.Types.Error import GHC.Core.Multiplicity import GHC.Core.UsageEnv+import GHC.Tc.Errors.Types+import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic ) import GHC.Tc.Utils.Instantiate import GHC.Tc.Gen.App import GHC.Tc.Gen.Head@@ -51,7 +52,6 @@ import GHC.Tc.Gen.Arrow import GHC.Tc.Gen.Match import GHC.Tc.Gen.HsType-import GHC.Tc.Gen.Pat import GHC.Tc.Utils.TcMType import GHC.Tc.Types.Origin import GHC.Tc.Utils.TcType as TcType@@ -77,7 +77,7 @@ import GHC.Data.Maybe import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic-import GHC.Data.FastString+import GHC.Utils.Panic.Plain import Control.Monad import GHC.Core.Class(classTyCon) import GHC.Types.Unique.Set ( UniqSet, mkUniqSet, elementOfUniqSet, nonDetEltsUniqSet )@@ -186,7 +186,7 @@ --   - HsApp         value applications --   - HsAppType     type applications --   - ExprWithTySig (e :: type)---   - HsRecFld      overloaded record fields+--   - HsRecSel      overloaded record fields --   - HsExpanded    renamer expansions --   - HsOpApp       operator applications --   - HsOverLit     overloaded literals@@ -199,7 +199,7 @@ tcExpr e@(OpApp {})              res_ty = tcApp e res_ty tcExpr e@(HsAppType {})          res_ty = tcApp e res_ty tcExpr e@(ExprWithTySig {})      res_ty = tcApp e res_ty-tcExpr e@(HsRecFld {})           res_ty = tcApp e res_ty+tcExpr e@(HsRecSel {})           res_ty = tcApp e res_ty tcExpr e@(XExpr (HsExpanded {})) res_ty = tcApp e res_ty  tcExpr e@(HsOverLit _ lit) res_ty@@ -224,9 +224,9 @@   = do { let lit_ty = hsLitType lit        ; tcWrapResult e (HsLit x (convertLit lit)) lit_ty res_ty } -tcExpr (HsPar x expr) res_ty+tcExpr (HsPar x lpar expr rpar) res_ty   = do { expr' <- tcMonoExprNC expr res_ty-       ; return (HsPar x expr') }+       ; return (HsPar x lpar expr' rpar) }  tcExpr (HsPragE x prag expr) res_ty   = do { expr' <- tcMonoExpr expr res_ty@@ -240,11 +240,9 @@         ; return (NegApp x expr' neg_expr') }  tcExpr e@(HsIPVar _ x) res_ty-  = do {   {- Implicit parameters must have a *tau-type* not a-              type scheme.  We enforce this by creating a fresh-              type variable as its type.  (Because res_ty may not-              be a tau-type.) -}-         ip_ty <- newOpenFlexiTyVarTy+  = do { ip_ty <- newFlexiTyVarTy liftedTypeKind+          -- Create a unification type variable of kind 'Type'.+          -- (The type of an implicit parameter must have kind 'Type'.)        ; let ip_name = mkStrLitTy (hsIPNameFS x)        ; ipClass <- tcLookupClass ipClassName        ; ip_var <- emitWantedEvVar origin (mkClassPred ipClass [ip_name, ip_ty])@@ -262,22 +260,15 @@         ; return (mkHsWrap wrap (HsLam noExtField match')) }   where     match_ctxt = MC { mc_what = LambdaExpr, mc_body = tcBody }-    herald = sep [ text "The lambda expression" <+>-                   quotes (pprSetDepth (PartWay 1) $-                           pprMatches match),-                        -- The pprSetDepth makes the abstraction print briefly-                   text "has"]+    herald = ExpectedFunTyLam match -tcExpr e@(HsLamCase x matches) res_ty+tcExpr e@(HsLamCase x lc_variant matches) res_ty   = do { (wrap, matches')-           <- tcMatchLambda msg match_ctxt matches res_ty-           -- The laziness annotation is because we don't want to fail here-           -- if there are multiple arguments-       ; return (mkHsWrap wrap $ HsLamCase x matches') }+           <- tcMatchLambda herald match_ctxt matches res_ty+       ; return (mkHsWrap wrap $ HsLamCase x lc_variant matches') }   where-    msg = sep [ text "The function" <+> quotes (ppr e)-              , text "requires"]-    match_ctxt = MC { mc_what = CaseAlt, mc_body = tcBody }+    match_ctxt = MC { mc_what = LamCaseAlt lc_variant, mc_body = tcBody }+    herald = ExpectedFunTyLamCase lc_variant e   @@ -330,10 +321,9 @@        ; let expr'       = ExplicitTuple x tup_args1 boxity              missing_tys = [Scaled mult ty | (Missing (Scaled mult _), ty) <- zip tup_args1 arg_tys] -             -- See Note [Linear fields generalization] in GHC.Tc.Gen.App-             act_res_ty-                 = mkVisFunTys missing_tys (mkTupleTy1 boxity arg_tys)-                   -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make+             -- See Note [Typechecking data constructors] in GHC.Tc.Gen.Head+             -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make+             act_res_ty = mkVisFunTys missing_tys (mkTupleTy1 boxity arg_tys)         ; traceTc "ExplicitTuple" (ppr act_res_ty $$ ppr res_ty) @@ -345,7 +335,16 @@        ; (coi, arg_tys) <- matchExpectedTyConApp sum_tc res_ty        ; -- Drop levity vars, we don't care about them here          let arg_tys' = drop arity arg_tys-       ; expr' <- tcCheckPolyExpr expr (arg_tys' `getNth` (alt - 1))+             arg_ty   = arg_tys' `getNth` (alt - 1)+       ; expr' <- tcCheckPolyExpr expr arg_ty+       -- Check the whole res_ty, not just the arg_ty, to avoid #20277.+       -- Example:+       --   a :: TYPE rep (representation-polymorphic)+       --   (# 17# | #) :: (# Int# | a #)+       -- This should cause an error, even though (17# :: Int#)+       -- is not representation-polymorphic: we don't know how+       -- wide the concrete representation of the sum type will be.+       ; hasFixedRuntimeRep_syntactic FRRUnboxedSum res_ty        ; return $ mkHsWrapCo coi (ExplicitSum arg_tys' alt arity expr' ) }  @@ -357,10 +356,10 @@ ************************************************************************ -} -tcExpr (HsLet x binds expr) res_ty+tcExpr (HsLet x tkLet binds tkIn expr) res_ty   = do  { (binds', expr') <- tcLocalBinds binds $                              tcMonoExpr expr res_ty-        ; return (HsLet x binds' expr') }+        ; return (HsLet x tkLet binds' tkIn expr') }  tcExpr (HsCase x scrut matches) res_ty   = do  {  -- We used to typecheck the case alternatives first.@@ -383,6 +382,7 @@         ; (scrut', scrut_ty) <- tcScalingUsage mult $ tcInferRho scrut          ; traceTc "HsCase" (ppr scrut_ty)+        ; hasFixedRuntimeRep_syntactic FRRCase scrut_ty         ; matches' <- tcMatchesCase match_ctxt (Scaled mult scrut_ty) matches res_ty         ; return (HsCase x scrut' matches') }  where@@ -397,7 +397,7 @@        ; return (HsIf x pred' b1' b2') }  tcExpr (HsMultiIf _ alts) res_ty-  = do { alts' <- mapM (wrapLocM $ tcGRHS match_ctxt res_ty) alts+  = do { alts' <- mapM (wrapLocMA $ tcGRHS match_ctxt res_ty) alts        ; res_ty <- readExpType res_ty        ; return (HsMultiIf res_ty alts') }   where match_ctxt = MC { mc_what = IfAlt, mc_body = tcBody }@@ -432,11 +432,8 @@         ; mapM_ checkClosedInStaticForm $ nonDetEltsUniqSet fvs          -- Require the type of the argument to be Typeable.-        -- The evidence is not used, but asking the constraint ensures that-        -- the current implementation is as restrictive as future versions-        -- of the StaticPointers extension.         ; typeableClass <- tcLookupClass typeableClassName-        ; _ <- emitWantedEvVar StaticOrigin $+        ; typeable_ev <- emitWantedEvVar StaticOrigin $                   mkTyConApp (classTyCon typeableClass)                              [liftedTypeKind, expr_ty] @@ -447,11 +444,12 @@         -- Wrap the static form with the 'fromStaticPtr' call.         ; fromStaticPtr <- newMethodFromName StaticOrigin fromStaticPtrName                                              [p_ty]-        ; let wrap = mkWpTyApps [expr_ty]+        ; let wrap = mkWpEvVarApps [typeable_ev] <.> mkWpTyApps [expr_ty]         ; loc <- getSrcSpanM+        ; static_ptr_ty_con <- tcLookupTyCon staticPtrTyConName         ; return $ mkHsWrapCo co $ HsApp noComments                             (L (noAnnSrcSpan loc) $ mkHsWrap wrap fromStaticPtr)-                            (L (noAnnSrcSpan loc) (HsStatic fvs expr'))+                            (L (noAnnSrcSpan loc) (HsStatic (fvs, mkTyConApp static_ptr_ty_con [expr_ty]) expr'))         }  {-@@ -644,7 +642,7 @@ -- GHC.Hs.Expr. This is why we match on 'rupd_flds = Left rbnds' here -- and panic otherwise. tcExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = Left rbnds }) res_ty-  = ASSERT( notNull rbnds )+  = assert (notNull rbnds) $     do  { -- STEP -2: typecheck the record_expr, the record to be updated           (record_expr', record_rho) <- tcScalingUsage Many $ tcInferRho record_expr             -- Record update drops some of the content of the record (namely the@@ -664,7 +662,7 @@         -- STEP -1  See Note [Disambiguating record fields] in GHC.Tc.Gen.Head         -- After this we know that rbinds is unambiguous         ; rbinds <- disambiguateRecordBinds record_expr record_rho rbnds res_ty-        ; let upd_flds = map (unLoc . hsRecFieldLbl . unLoc) rbinds+        ; let upd_flds = map (unLoc . hfbLHS . unLoc) rbinds               upd_fld_occs = map (occNameFS . rdrNameOcc . rdrNameAmbiguousFieldOcc) upd_flds               sel_ids      = map selectorAmbiguousFieldOcc upd_flds         -- STEP 0@@ -678,10 +676,10 @@                            not (isRecordSelector sel_id),                            let fld_name = idName sel_id ]         ; unless (null bad_guys) (sequence bad_guys >> failM)-        -- See note [Mixed Record Selectors]+        -- See Note [Mixed Record Selectors]         ; let (data_sels, pat_syn_sels) =                 partition isDataConRecordSelector sel_ids-        ; MASSERT( all isPatSynRecordSelector pat_syn_sels )+        ; massert (all isPatSynRecordSelector pat_syn_sels)         ; checkTc ( null data_sels || null pat_syn_sels )                   ( mixedSelectors data_sels pat_syn_sels ) @@ -715,7 +713,7 @@         ; checkTc (not (null relevant_cons)) (badFieldsUpd rbinds con_likes)          -- Take apart a representative constructor-        ; let con1 = ASSERT( not (null relevant_cons) ) head relevant_cons+        ; let con1 = assert (not (null relevant_cons) ) head relevant_cons               (con1_tvs, _, _, _prov_theta, req_theta, scaled_con1_arg_tys, _)                  = conLikeFullSig con1               con1_arg_tys = map scaledThing scaled_con1_arg_tys@@ -742,7 +740,7 @@               con1_tv_set  = mkVarSet con1_tvs               bad_fld (fld, ty) = fld `elem` upd_fld_occs &&                                       not (tyCoVarsOfType ty `subVarSet` con1_tv_set)-        ; checkTc (null bad_upd_flds) (badFieldTypes bad_upd_flds)+        ; checkTc (null bad_upd_flds) (TcRnFieldUpdateInvalidType bad_upd_flds)          -- STEP 4  Note [Type of a record update]         -- Figure out types for the scrutinee and result@@ -775,7 +773,7 @@               scrut_ty      = TcType.substTy scrut_subst  con1_res_ty               con1_arg_tys' = map (TcType.substTy result_subst) con1_arg_tys -        ; co_scrut <- unifyType (Just (ppr record_expr)) record_rho scrut_ty+        ; co_scrut <- unifyType (Just . HsExprRnThing $ unLoc record_expr) record_rho scrut_ty                 -- NB: normal unification is OK here (as opposed to subsumption),                 -- because for this to work out, both record_rho and scrut_ty have                 -- to be normal datatypes -- no contravariant stuff can go on@@ -784,7 +782,8 @@         -- Typecheck the bindings         ; rbinds'      <- tcRecordUpd con1 con1_arg_tys' rbinds -        -- STEP 6: Deal with the stupid theta+        -- STEP 6: Deal with the stupid theta.+        -- See Note [The stupid context] in GHC.Core.DataCon.         ; let theta' = substThetaUnchecked scrut_subst (conLikeStupidTheta con1)         ; instStupidTheta RecordUpdOrigin theta' @@ -860,8 +859,8 @@   = do addModFinalizersWithLclEnv mod_finalizers        tcExpr expr res_ty tcExpr (HsSpliceE _ splice)          res_ty = tcSpliceExpr splice res_ty-tcExpr e@(HsBracket _ brack)         res_ty = tcTypedBracket e brack res_ty-tcExpr e@(HsRnBracketOut _ brack ps) res_ty = tcUntypedBracket e brack ps res_ty+tcExpr e@(HsTypedBracket _ body) res_ty = tcTypedBracket e body res_ty+tcExpr e@(HsUntypedBracket ps body) res_ty = tcUntypedBracket e body ps res_ty  {- ************************************************************************@@ -871,13 +870,9 @@ ************************************************************************ -} -tcExpr (HsConLikeOut {})   ty = pprPanic "tcExpr:HsConLikeOut" (ppr ty) tcExpr (HsOverLabel {})    ty = pprPanic "tcExpr:HsOverLabel"  (ppr ty) tcExpr (SectionL {})       ty = pprPanic "tcExpr:SectionL"    (ppr ty) tcExpr (SectionR {})       ty = pprPanic "tcExpr:SectionR"    (ppr ty)-tcExpr (HsTcBracketOut {}) ty = pprPanic "tcExpr:HsTcBracketOut"    (ppr ty)-tcExpr (HsTick {})         ty = pprPanic "tcExpr:HsTick"    (ppr ty)-tcExpr (HsBinTick {})      ty = pprPanic "tcExpr:HsBinTick"    (ppr ty)   {-@@ -941,16 +936,26 @@        ; return (idHsWrapper, elt_mult, elt_ty, Just fl') }  -----------------tcTupArgs :: [HsTupArg GhcRn] -> [TcSigmaType] -> TcM [HsTupArg GhcTc]+tcTupArgs :: [HsTupArg GhcRn]+          -> [TcSigmaType]+              -- ^ Argument types.+              -- This function ensures they all have+              -- a fixed runtime representation.+          -> TcM [HsTupArg GhcTc] tcTupArgs args tys-  = do MASSERT( equalLength args tys )+  = do massert (equalLength args tys)        checkTupSize (length args)-       mapM go (args `zip` tys)+       zipWith3M go [1,2..] args tys   where-    go (Missing {},     arg_ty) = do { mult <- newFlexiTyVarTy multiplicityTy-                                     ; return (Missing (Scaled mult arg_ty)) }-    go (Present x expr, arg_ty) = do { expr' <- tcCheckPolyExpr expr arg_ty-                                     ; return (Present x expr') }+    go :: Int -> HsTupArg GhcRn -> TcType -> TcM (HsTupArg GhcTc)+    go i (Missing {})     arg_ty+      = do { mult <- newFlexiTyVarTy multiplicityTy+           ; hasFixedRuntimeRep_syntactic (FRRTupleSection i) arg_ty+           ; return (Missing (Scaled mult arg_ty)) }+    go i (Present x expr) arg_ty+      = do { expr' <- tcCheckPolyExpr expr arg_ty+           ; hasFixedRuntimeRep_syntactic (FRRTupleArg i) arg_ty+           ; return (Present x expr') }  --------------------------- -- See TcType.SyntaxOpType also for commentary@@ -975,14 +980,14 @@               -> SyntaxExprRn               -> [SyntaxOpType]               -> SyntaxOpType-              -> ([TcSigmaType] -> [Mult] -> TcM a)+              -> ([TcSigmaTypeFRR] -> [Mult] -> TcM a)               -> TcM (a, SyntaxExprTc) tcSyntaxOpGen orig (SyntaxExprRn op) arg_tys res_ty thing_inside-  = do { (expr, sigma) <- tcInferAppHead (op, VACall op 0 noSrcSpan) [] Nothing+  = do { (expr, sigma) <- tcInferAppHead (op, VACall op 0 noSrcSpan) []              -- Ugh!! But all this code is scheduled for demolition anyway        ; traceTc "tcSyntaxOpGen" (ppr op $$ ppr expr $$ ppr sigma)        ; (result, expr_wrap, arg_wraps, res_wrap)-           <- tcSynArgA orig sigma arg_tys res_ty $+           <- tcSynArgA orig op sigma arg_tys res_ty $               thing_inside        ; traceTc "tcSyntaxOpGen" (ppr op $$ ppr expr $$ ppr sigma )        ; return (result, SyntaxExprTc { syn_expr = mkHsWrap expr_wrap expr@@ -1003,12 +1008,13 @@ -- works on "expected" types, skolemising where necessary -- See Note [tcSynArg] tcSynArgE :: CtOrigin+          -> HsExpr GhcRn -- ^ the operator to check (for error messages only)           -> TcSigmaType           -> SyntaxOpType                -- ^ shape it is expected to have-          -> ([TcSigmaType] -> [Mult] -> TcM a) -- ^ check the arguments+          -> ([TcSigmaTypeFRR] -> [Mult] -> TcM a) -- ^ check the arguments           -> TcM (a, HsWrapper)            -- ^ returns a wrapper :: (type of right shape) "->" (type passed in)-tcSynArgE orig sigma_ty syn_ty thing_inside+tcSynArgE orig op sigma_ty syn_ty thing_inside   = do { (skol_wrap, (result, ty_wrapper))            <- tcTopSkolemise GenSigCtxt sigma_ty                 (\ rho_ty -> go rho_ty syn_ty)@@ -1039,27 +1045,27 @@                           -- another nested arrow is too much for now,                          -- but I bet we'll never need this-                     ; MASSERT2( case arg_shape of+                     ; massertPpr (case arg_shape of                                    SynFun {} -> False;-                                   _         -> True-                               , text "Too many nested arrows in SyntaxOpType" $$-                                 pprCtOrigin orig )+                                   _         -> True)+                                  (text "Too many nested arrows in SyntaxOpType" $$+                                   pprCtOrigin orig)                       ; let arg_mult = scaledMult arg_ty-                     ; tcSynArgA orig arg_tc_ty [] arg_shape $+                     ; tcSynArgA orig op arg_tc_ty [] arg_shape $                        \ arg_results arg_res_mults ->-                       tcSynArgE orig res_tc_ty res_shape $+                       tcSynArgE orig op res_tc_ty res_shape $                        \ res_results res_res_mults ->                        do { result <- thing_inside (arg_results ++ res_results) ([arg_mult] ++ arg_res_mults ++ res_res_mults)                           ; return (result, arg_tc_ty, res_tc_ty, arg_mult) }} -           ; return ( result-                    , match_wrapper <.>-                      mkWpFun (arg_wrapper2 <.> arg_wrapper1) res_wrapper-                              (Scaled op_mult arg_ty) res_ty doc ) }+           ; let fun_wrap = mkWpFun (arg_wrapper2 <.> arg_wrapper1) res_wrapper+                              (Scaled op_mult arg_ty) res_ty+               -- NB: arg_ty comes from matchExpectedFunTys, so it has a+               -- fixed RuntimeRep, as needed to call mkWpFun.+           ; return (result, match_wrapper <.> fun_wrap) }       where-        herald = text "This rebindable syntax expects a function with"-        doc = text "When checking a rebindable syntax operator arising from" <+> ppr orig+        herald = ExpectedFunTySyntaxOp orig op      go rho_ty (SynType the_ty)       = do { wrap   <- tcSubTypePat orig GenSigCtxt the_ty rho_ty@@ -1069,15 +1075,16 @@ -- works on "actual" types, instantiating where necessary -- See Note [tcSynArg] tcSynArgA :: CtOrigin+          -> HsExpr GhcRn -- ^ the operator we are checking (for error messages)           -> TcSigmaType           -> [SyntaxOpType]              -- ^ argument shapes           -> SyntaxOpType                -- ^ result shape-          -> ([TcSigmaType] -> [Mult] -> TcM a) -- ^ check the arguments+          -> ([TcSigmaTypeFRR] -> [Mult] -> TcM a) -- ^ check the arguments           -> TcM (a, HsWrapper, [HsWrapper], HsWrapper)             -- ^ returns a wrapper to be applied to the original function,             -- wrappers to be applied to arguments             -- and a wrapper to be applied to the overall expression-tcSynArgA orig sigma_ty arg_shapes res_shape thing_inside+tcSynArgA orig op sigma_ty arg_shapes res_shape thing_inside   = do { (match_wrapper, arg_tys, res_ty)            <- matchActualFunTysRho herald orig Nothing                                    (length arg_shapes) sigma_ty@@ -1088,22 +1095,22 @@               thing_inside (arg_results ++ res_results) (map scaledMult arg_tys ++ arg_res_mults)        ; return (result, match_wrapper, arg_wrappers, res_wrapper) }   where-    herald = text "This rebindable syntax expects a function with"+    herald = ExpectedFunTySyntaxOp orig op -    tc_syn_args_e :: [TcSigmaType] -> [SyntaxOpType]-                  -> ([TcSigmaType] -> [Mult] -> TcM a)+    tc_syn_args_e :: [TcSigmaTypeFRR] -> [SyntaxOpType]+                  -> ([TcSigmaTypeFRR] -> [Mult] -> TcM a)                   -> TcM (a, [HsWrapper])                     -- the wrappers are for arguments     tc_syn_args_e (arg_ty : arg_tys) (arg_shape : arg_shapes) thing_inside       = do { ((result, arg_wraps), arg_wrap)-               <- tcSynArgE     orig arg_ty  arg_shape  $ \ arg1_results arg1_mults ->-                  tc_syn_args_e      arg_tys arg_shapes $ \ args_results args_mults ->+               <- tcSynArgE     orig  op arg_ty  arg_shape  $ \ arg1_results arg1_mults ->+                  tc_syn_args_e          arg_tys arg_shapes $ \ args_results args_mults ->                   thing_inside (arg1_results ++ args_results) (arg1_mults ++ args_mults)            ; return (result, arg_wrap : arg_wraps) }     tc_syn_args_e _ _ thing_inside = (, []) <$> thing_inside [] [] -    tc_syn_arg :: TcSigmaType -> SyntaxOpType-               -> ([TcSigmaType] -> TcM a)+    tc_syn_arg :: TcSigmaTypeFRR -> SyntaxOpType+               -> ([TcSigmaTypeFRR] -> TcM a)                -> TcM (a, HsWrapper)                   -- the wrapper applies to the overall result     tc_syn_arg res_ty SynAny thing_inside@@ -1188,7 +1195,7 @@ -- See Note [Disambiguating record fields] in GHC.Tc.Gen.Head disambiguateRecordBinds :: LHsExpr GhcRn -> TcRhoType                  -> [LHsRecUpdField GhcRn] -> ExpRhoType-                 -> TcM [LHsRecField' GhcTc (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]+                 -> TcM [LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)] disambiguateRecordBinds record_expr record_rho rbnds res_ty     -- Are all the fields unambiguous?   = case mapM isUnambiguous rbnds of@@ -1207,7 +1214,7 @@   where     -- Extract the selector name of a field update if it is unambiguous     isUnambiguous :: LHsRecUpdField GhcRn -> Maybe (LHsRecUpdField GhcRn,Name)-    isUnambiguous x = case unLoc (hsRecFieldLbl (unLoc x)) of+    isUnambiguous x = case unLoc (hfbLHS (unLoc x)) of                         Unambiguous sel_name _ -> Just (x, sel_name)                         Ambiguous{}            -> Nothing @@ -1225,7 +1232,7 @@     identifyParent fam_inst_envs possible_parents       = case foldr1 intersect possible_parents of         -- No parents for all fields: record update is ill-typed-        []  -> failWithTc (noPossibleParents rbnds)+        []  -> failWithTc (TcRnNoPossibleParentForFields rbnds)          -- Exactly one datatype with all the fields: use that         [p] -> return p@@ -1244,7 +1251,7 @@                   ; return (RecSelData tc) }          -- Nothing else we can try...-        _ -> failWithTc badOverloadedUpdate+        _ -> failWithTc (TcRnBadOverloadedRecordUpdate rbnds)      -- Make a field unambiguous by choosing the given parent.     -- Emits an error if the field cannot have that parent,@@ -1253,7 +1260,7 @@     -- where T does not have field x.     pickParent :: RecSelParent                -> (LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])-               -> TcM (LHsRecField' GhcTc (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))+               -> TcM (LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))     pickParent p (upd, xs)       = case lookup p xs of                       -- Phew! The parent is valid for this field.@@ -1262,8 +1269,8 @@                       -- unambiguous ones shouldn't be recorded again                       -- (giving duplicate deprecation warnings).           Just gre -> do { unless (null (tail xs)) $ do-                             let L loc _ = hsRecFieldLbl (unLoc upd)-                             setSrcSpan loc $ addUsedGRE True gre+                             let L loc _ = hfbLHS (unLoc upd)+                             setSrcSpanA loc $ addUsedGRE True gre                          ; lookupSelector (upd, greMangledName gre) }                       -- The field doesn't belong to this parent, so report                       -- an error but keep going through all the fields@@ -1274,31 +1281,24 @@     -- Given a (field update, selector name) pair, look up the     -- selector to give a field update with an unambiguous Id     lookupSelector :: (LHsRecUpdField GhcRn, Name)-                 -> TcM (LHsRecField' GhcRn (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))+                 -> TcM (LHsFieldBind GhcRn (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))     lookupSelector (L l upd, n)       = do { i <- tcLookupId n-           ; let L loc af = hsRecFieldLbl upd+           ; let L loc af = hfbLHS upd                  lbl      = rdrNameAmbiguousFieldOcc af-           -- ; return $ L l upd { hsRecFieldLbl-           --                = L loc (Unambiguous i (L (noAnnSrcSpan loc) lbl)) }-           ; return $ L l HsRecField-               { hsRecFieldAnn = hsRecFieldAnn upd-               , hsRecFieldLbl-                       = L loc (Unambiguous i (L (noAnnSrcSpan loc) lbl))-               , hsRecFieldArg = hsRecFieldArg upd-               , hsRecPun = hsRecPun upd+           ; return $ L l HsFieldBind+               { hfbAnn = hfbAnn upd+               , hfbLHS+                       = L (l2l loc) (Unambiguous i (L (l2l loc) lbl))+               , hfbRHS = hfbRHS upd+               , hfbPun = hfbPun upd                }            }      -- See Note [Deprecating ambiguous fields] in GHC.Tc.Gen.Head     reportAmbiguousField :: TyCon -> TcM ()     reportAmbiguousField parent_type =-        setSrcSpan loc $ warnIfFlag Opt_WarnAmbiguousFields True $-          vcat [ text "The record update" <+> ppr rupd-                   <+> text "with type" <+> ppr parent_type-                   <+> text "is ambiguous."-               , text "This will not be supported by -XDuplicateRecordFields in future releases of GHC."-               ]+        setSrcSpan loc $ addDiagnostic $ TcRnAmbiguousField rupd parent_type       where         rupd = RecordUpd { rupd_expr = record_expr, rupd_flds = Left rbnds, rupd_ext = noExtField }         loc  = getLocA (head rbnds)@@ -1336,24 +1336,24 @@      do_bind :: LHsRecField GhcRn (LHsExpr GhcRn)             -> TcM (Maybe (LHsRecField GhcTc (LHsExpr GhcTc)))-    do_bind (L l fld@(HsRecField { hsRecFieldLbl = f-                                 , hsRecFieldArg = rhs }))+    do_bind (L l fld@(HsFieldBind { hfbLHS = f+                                 , hfbRHS = rhs }))        = do { mb <- tcRecordField con_like flds_w_tys f rhs            ; case mb of                Nothing         -> return Nothing-               -- Just (f', rhs') -> return (Just (L l (fld { hsRecFieldLbl = f'-               --                                            , hsRecFieldArg = rhs' }))) }-               Just (f', rhs') -> return (Just (L l (HsRecField-                                                     { hsRecFieldAnn = hsRecFieldAnn fld-                                                     , hsRecFieldLbl = f'-                                                     , hsRecFieldArg = rhs'-                                                     , hsRecPun = hsRecPun fld}))) }+               -- Just (f', rhs') -> return (Just (L l (fld { hfbLHS = f'+               --                                            , hfbRHS = rhs' }))) }+               Just (f', rhs') -> return (Just (L l (HsFieldBind+                                                     { hfbAnn = hfbAnn fld+                                                     , hfbLHS = f'+                                                     , hfbRHS = rhs'+                                                     , hfbPun = hfbPun fld}))) }  tcRecordUpd         :: ConLike         -> [TcType]     -- Expected type for each field-        -> [LHsRecField' GhcTc (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]+        -> [LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]         -> TcM [LHsRecUpdField GhcTc]  tcRecordUpd con_like arg_tys rbinds = fmap catMaybes $ mapM do_bind rbinds@@ -1361,23 +1361,23 @@     fields = map flSelector $ conLikeFieldLabels con_like     flds_w_tys = zipEqual "tcRecordUpd" fields arg_tys -    do_bind :: LHsRecField' GhcTc (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)+    do_bind :: LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)             -> TcM (Maybe (LHsRecUpdField GhcTc))-    do_bind (L l fld@(HsRecField { hsRecFieldLbl = L loc af-                                 , hsRecFieldArg = rhs }))+    do_bind (L l fld@(HsFieldBind { hfbLHS = L loc af+                                 , hfbRHS = rhs }))       = do { let lbl = rdrNameAmbiguousFieldOcc af                  sel_id = selectorAmbiguousFieldOcc af-                 f = L loc (FieldOcc (idName sel_id) (L (noAnnSrcSpan loc) lbl))+                 f = L loc (FieldOcc (idName sel_id) (L (l2l loc) lbl))            ; mb <- tcRecordField con_like flds_w_tys f rhs            ; case mb of                Nothing         -> return Nothing                Just (f', rhs') ->                  return (Just-                         (L l (fld { hsRecFieldLbl+                         (L l (fld { hfbLHS                                       = L loc (Unambiguous-                                               (extFieldOcc (unLoc f'))-                                               (L (noAnnSrcSpan loc) lbl))-                                   , hsRecFieldArg = rhs' }))) }+                                               (foExt (unLoc f'))+                                               (L (l2l loc) lbl))+                                   , hfbRHS = rhs' }))) }  tcRecordField :: ConLike -> Assoc Name Type               -> LFieldOcc GhcRn -> LHsExpr GhcRn@@ -1386,16 +1386,18 @@   | Just field_ty <- assocMaybe flds_w_tys sel_name       = addErrCtxt (fieldCtxt field_lbl) $         do { rhs' <- tcCheckPolyExprNC rhs field_ty+           ; hasFixedRuntimeRep_syntactic (FRRRecordUpdate (unLoc lbl) (unLoc rhs'))+                field_ty            ; let field_id = mkUserLocal (nameOccName sel_name)                                         (nameUnique sel_name)-                                        Many field_ty loc+                                        Many field_ty (locA loc)                 -- Yuk: the field_id has the *unique* of the selector Id                 --          (so we can find it easily)                 --      but is a LocalId with the appropriate type of the RHS                 --          (so the desugarer knows the type of local binder to make)            ; return (Just (L loc (FieldOcc field_id lbl), rhs')) }       | otherwise-      = do { addErrTc (badFieldCon con_like field_lbl)+      = do { addErrTc (badFieldConErr (getName con_like) field_lbl)            ; return Nothing }   where         field_lbl = occNameFS $ rdrNameOcc (unLoc lbl)@@ -1407,19 +1409,18 @@                         -- But C{} is still valid if no strict fields   = if any isBanged field_strs then         -- Illegal if any arg is strict-        addErrTc (missingStrictFields con_like [])+        addErrTc (TcRnMissingStrictFields con_like [])     else do-        warn <- woptM Opt_WarnMissingFields-        when (warn && notNull field_strs && null field_labels)-             (warnTc (Reason Opt_WarnMissingFields) True-                 (missingFields con_like []))+        when (notNull field_strs && null field_labels) $ do+          let msg = TcRnMissingFields con_like []+          (diagnosticTc True msg)    | otherwise = do              -- A record     unless (null missing_s_fields) $ do         fs <- zonk_fields missing_s_fields         -- It is an error to omit a strict field, because         -- we can't substitute it with (error "Missing field f")-        addErrTc (missingStrictFields con_like fs)+        addErrTc (TcRnMissingStrictFields con_like fs)      warn <- woptM Opt_WarnMissingFields     when (warn && notNull missing_ns_fields) $ do@@ -1427,8 +1428,8 @@         -- It is not an error (though we may want) to omit a         -- lazy field, because we can always use         -- (error "Missing field f") instead.-        warnTc (Reason Opt_WarnMissingFields) True-             (missingFields con_like fs)+        let msg = TcRnMissingFields con_like fs+        diagnosticTc True msg    where     -- we zonk the fields to get better types in error messages (#18869)@@ -1467,22 +1468,15 @@  fieldCtxt :: FieldLabelString -> SDoc fieldCtxt field_name-  = text "In the" <+> quotes (ppr field_name) <+> ptext (sLit "field of a record")--badFieldTypes :: [(FieldLabelString,TcType)] -> SDoc-badFieldTypes prs-  = hang (text "Record update for insufficiently polymorphic field"-                         <> plural prs <> colon)-       2 (vcat [ ppr f <+> dcolon <+> ppr ty | (f,ty) <- prs ])+  = text "In the" <+> quotes (ppr field_name) <+> text "field of a record"  badFieldsUpd-  :: [LHsRecField' GhcTc (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]+  :: [LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]                -- Field names that don't belong to a single datacon   -> [ConLike] -- Data cons of the type which the first field name belongs to-  -> SDoc+  -> TcRnMessage badFieldsUpd rbinds data_cons-  = hang (text "No constructor has all these fields:")-       2 (pprQuotedList conflictingFields)+  = TcRnNoConstructorHasAllFields conflictingFields           -- See Note [Finding the conflicting fields]   where     -- A (preferably small) set of fields such that no constructor contains@@ -1505,14 +1499,14 @@             -- are redundant and can be dropped.             map (fst . head) $ groupBy ((==) `on` snd) growingSets -    aMember = ASSERT( not (null members) ) fst (head members)+    aMember = assert (not (null members) ) fst (head members)     (members, nonMembers) = partition (or . snd) membership      -- For each field, which constructors contain the field?     membership :: [(FieldLabelString, [Bool])]     membership = sortMembership $         map (\fld -> (fld, map (fld `elementOfUniqSet`) fieldLabelSets)) $-          map (occNameFS . rdrNameOcc . rdrNameAmbiguousFieldOcc . unLoc . hsRecFieldLbl . unLoc) rbinds+          map (occNameFS . rdrNameOcc . rdrNameAmbiguousFieldOcc . unLoc . hfbLHS . unLoc) rbinds      fieldLabelSets :: [UniqSet FieldLabelString]     fieldLabelSets = map (mkUniqSet . map flLabel . conLikeFieldLabels) data_cons@@ -1551,60 +1545,14 @@ a decent stab, no more.  See #7989. -} -mixedSelectors :: [Id] -> [Id] -> SDoc+mixedSelectors :: [Id] -> [Id] -> TcRnMessage mixedSelectors data_sels@(dc_rep_id:_) pat_syn_sels@(ps_rep_id:_)-  = ptext-      (sLit "Cannot use a mixture of pattern synonym and record selectors") $$-    text "Record selectors defined by"-      <+> quotes (ppr (tyConName rep_dc))-      <> text ":"-      <+> pprWithCommas ppr data_sels $$-    text "Pattern synonym selectors defined by"-      <+> quotes (ppr (patSynName rep_ps))-      <> text ":"-      <+> pprWithCommas ppr pat_syn_sels+  = TcRnMixedSelectors (tyConName rep_dc) data_sels (patSynName rep_ps) pat_syn_sels   where     RecSelPatSyn rep_ps = recordSelectorTyCon ps_rep_id     RecSelData rep_dc = recordSelectorTyCon dc_rep_id mixedSelectors _ _ = panic "GHC.Tc.Gen.Expr: mixedSelectors emptylists" --missingStrictFields :: ConLike -> [(FieldLabelString, TcType)] -> SDoc-missingStrictFields con fields-  = vcat [header, nest 2 rest]-  where-    pprField (f,ty) = ppr f <+> dcolon <+> ppr ty-    rest | null fields = Outputable.empty  -- Happens for non-record constructors-                                           -- with strict fields-         | otherwise   = vcat (fmap pprField fields)--    header = text "Constructor" <+> quotes (ppr con) <+>-             text "does not have the required strict field(s)" <>-             if null fields then Outputable.empty else colon--missingFields :: ConLike -> [(FieldLabelString, TcType)] -> SDoc-missingFields con fields-  = vcat [header, nest 2 rest]-  where-    pprField (f,ty) = ppr f <+> text "::" <+> ppr ty-    rest | null fields = Outputable.empty-         | otherwise   = vcat (fmap pprField fields)-    header = text "Fields of" <+> quotes (ppr con) <+>-             text "not initialised" <>-             if null fields then Outputable.empty else colon---- callCtxt fun args = text "In the call" <+> parens (ppr (foldl' mkHsApp fun args))--noPossibleParents :: [LHsRecUpdField GhcRn] -> SDoc-noPossibleParents rbinds-  = hang (text "No type has all these fields:")-       2 (pprQuotedList fields)-  where-    fields = map (hsRecFieldLbl . unLoc) rbinds--badOverloadedUpdate :: SDoc-badOverloadedUpdate = text "Record update is ambiguous, and requires a type signature"- {- ************************************************************************ *                                                                      *@@ -1613,11 +1561,6 @@ ************************************************************************ -} --- | A data type to describe why a variable is not closed.-data NotClosedReason = NotLetBoundReason-                     | NotTypeClosed VarSet-                     | NotClosed Name NotClosedReason- -- | Checks if the given name is closed and emits an error if not. -- -- See Note [Not-closed error messages].@@ -1682,26 +1625,8 @@     --     -- when the final node has a non-closed type.     ---    explain :: Name -> NotClosedReason -> SDoc-    explain name reason =-      quotes (ppr name) <+> text "is used in a static form but it is not closed"-                        <+> text "because it"-                        $$-                        sep (causes reason)--    causes :: NotClosedReason -> [SDoc]-    causes NotLetBoundReason = [text "is not let-bound."]-    causes (NotTypeClosed vs) =-      [ text "has a non-closed type because it contains the"-      , text "type variables:" <+>-        pprVarSet vs (hsep . punctuate comma . map (quotes . ppr))-      ]-    causes (NotClosed n reason) =-      let msg = text "uses" <+> quotes (ppr n) <+> text "which"-       in case reason of-            NotClosed _ _ -> msg : causes reason-            _   -> let (xs0, xs1) = splitAt 1 $ causes reason-                    in fmap (msg <+>) xs0 ++ xs1+    explain :: Name -> NotClosedReason -> TcRnMessage+    explain = TcRnStaticFormNotClosed  -- Note [Not-closed error messages] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
GHC/Tc/Gen/Expr.hs-boot view
@@ -1,7 +1,8 @@ module GHC.Tc.Gen.Expr where import GHC.Hs              ( HsExpr, LHsExpr, SyntaxExprRn                            , SyntaxExprTc )-import GHC.Tc.Utils.TcType ( TcRhoType, TcSigmaType, SyntaxOpType+import GHC.Tc.Utils.TcType ( TcRhoType, TcSigmaType, TcSigmaTypeFRR+                           , SyntaxOpType                            , ExpType, ExpRhoType, ExpSigmaType ) import GHC.Tc.Types        ( TcM ) import GHC.Tc.Types.Origin ( CtOrigin )@@ -32,13 +33,13 @@            -> SyntaxExprRn            -> [SyntaxOpType]           -- ^ shape of syntax operator arguments            -> ExpType                  -- ^ overall result type-           -> ([TcSigmaType] -> [Mult] -> TcM a) -- ^ Type check any arguments+           -> ([TcSigmaTypeFRR] -> [Mult] -> TcM a) -- ^ Type check any arguments            -> TcM (a, SyntaxExprTc)  tcSyntaxOpGen :: CtOrigin               -> SyntaxExprRn               -> [SyntaxOpType]               -> SyntaxOpType-              -> ([TcSigmaType] -> [Mult] -> TcM a)+              -> ([TcSigmaTypeFRR] -> [Mult] -> TcM a)               -> TcM (a, SyntaxExprTc)
GHC/Tc/Gen/Foreign.hs view
@@ -4,7 +4,7 @@  -} -{-# LANGUAGE CPP #-}+ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -35,12 +35,11 @@         , tcCheckFEType         ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Hs +import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Tc.Gen.HsType import GHC.Tc.Gen.Expr@@ -49,6 +48,7 @@ import GHC.Tc.Instance.Family import GHC.Core.FamInstEnv import GHC.Core.Coercion+import GHC.Core.Reduction import GHC.Core.Type import GHC.Core.Multiplicity import GHC.Types.ForeignCall@@ -71,7 +71,11 @@ import GHC.Driver.Hooks import qualified GHC.LanguageExtensions as LangExt -import Control.Monad+import Control.Monad ( zipWithM )+import Control.Monad.Trans.Writer.CPS+  ( WriterT, runWriterT, tell )+import Control.Monad.Trans.Class+  ( lift )  -- Defines a binding isForeignImport :: forall name. UnXRec name => LForeignDecl name -> Bool@@ -108,15 +112,15 @@ -- we are only allowed to look through newtypes if the constructor is -- in scope.  We return a bag of all the newtype constructors thus found. -- Always returns a Representational coercion-normaliseFfiType :: Type -> TcM (Coercion, Type, Bag GlobalRdrElt)+normaliseFfiType :: Type -> TcM (Reduction, Bag GlobalRdrElt) normaliseFfiType ty     = do fam_envs <- tcGetFamInstEnvs          normaliseFfiType' fam_envs ty -normaliseFfiType' :: FamInstEnvs -> Type -> TcM (Coercion, Type, Bag GlobalRdrElt)-normaliseFfiType' env ty0 = go Representational initRecTc ty0+normaliseFfiType' :: FamInstEnvs -> Type -> TcM (Reduction, Bag GlobalRdrElt)+normaliseFfiType' env ty0 = runWriterT $ go Representational initRecTc ty0   where-    go :: Role -> RecTcChecker -> Type -> TcM (Coercion, Type, Bag GlobalRdrElt)+    go :: Role -> RecTcChecker -> Type -> WriterT (Bag GlobalRdrElt) TcM Reduction     go role rec_nts ty       | Just ty' <- tcView ty     -- Expand synonyms       = go role rec_nts ty'@@ -126,15 +130,14 @@        | (bndrs, inner_ty) <- splitForAllTyCoVarBinders ty       , not (null bndrs)-      = do (coi, nty1, gres1) <- go role rec_nts inner_ty-           return ( mkHomoForAllCos (binderVars bndrs) coi-                  , mkForAllTys bndrs nty1, gres1 )+      = do redn <- go role rec_nts inner_ty+           return $ mkHomoForAllRedn bndrs redn        | otherwise -- see Note [Don't recur in normaliseFfiType']-      = return (mkReflCo role ty, ty, emptyBag)+      = return $ mkReflRedn role ty      go_tc_app :: Role -> RecTcChecker -> TyCon -> [Type]-              -> TcM (Coercion, Type, Bag GlobalRdrElt)+              -> WriterT (Bag GlobalRdrElt) TcM Reduction     go_tc_app role rec_nts tc tys         -- We don't want to look through the IO newtype, even if it is         -- in scope, so we have a special case for it:@@ -149,32 +152,34 @@                    --   Here, we don't reject the type for being recursive.                    -- If this is a recursive newtype then it will normally                    -- be rejected later as not being a valid FFI type.-        = do { rdr_env <- getGlobalRdrEnv+        = do { rdr_env <- lift $ getGlobalRdrEnv              ; case checkNewtypeFFI rdr_env tc of                  Nothing  -> nothing-                 Just gre -> do { (co', ty', gres) <- go role rec_nts' nt_rhs-                                ; return (mkTransCo nt_co co', ty', gre `consBag` gres) } }+                 Just gre ->+                   do { redn <- go role rec_nts' nt_rhs+                      ; tell (unitBag gre)+                      ; return $ nt_co `mkTransRedn` redn } }          | isFamilyTyCon tc              -- Expand open tycons-        , (co, ty) <- normaliseTcApp env role tc tys+        , Reduction co ty <- normaliseTcApp env role tc tys         , not (isReflexiveCo co)-        = do (co', ty', gres) <- go role rec_nts ty-             return (mkTransCo co co', ty', gres)+        = do redn <- go role rec_nts ty+             return $ co `mkTransRedn` redn          | otherwise         = nothing -- see Note [Don't recur in normaliseFfiType']         where           tc_key = getUnique tc           children_only-            = do xs <- zipWithM (\ty r -> go r rec_nts ty) tys (tyConRolesX role tc)-                 let (cos, tys', gres) = unzip3 xs-                 return ( mkTyConAppCo role tc cos-                        , mkTyConApp tc tys', unionManyBags gres)+            = do { args <- unzipRedns <$>+                            zipWithM ( \ ty r -> go r rec_nts ty )+                                     tys (tyConRolesX role tc)+                 ; return $ mkTyConAppRedn role tc args }           nt_co  = mkUnbranchedAxInstCo role (newTyConCo tc) tys []           nt_rhs = newTyConInstRhs tc tys            ty      = mkTyConApp tc tys-          nothing = return (mkReflCo role ty, ty, emptyBag)+          nothing = return $ mkReflRedn role ty  checkNewtypeFFI :: GlobalRdrEnv -> TyCon -> Maybe GlobalRdrElt checkNewtypeFFI rdr_env tc@@ -237,7 +242,7 @@                                     , fd_fi = imp_decl }))   = setSrcSpanA dloc $ addErrCtxt (foreignDeclCtxt fo)  $     do { sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty-       ; (norm_co, norm_sig_ty, gres) <- normaliseFfiType sig_ty+       ; (Reduction norm_co norm_sig_ty, gres) <- normaliseFfiType sig_ty        ; let            -- Drop the foralls before inspecting the            -- structure of the foreign type.@@ -261,22 +266,23 @@  tcCheckFIType :: [Scaled Type] -> Type -> ForeignImport -> TcM ForeignImport -tcCheckFIType arg_tys res_ty (CImport (L lc cconv) safety mh l@(CLabel _) src)+tcCheckFIType arg_tys res_ty idecl@(CImport (L lc cconv) safety mh l@(CLabel _) src)   -- Foreign import label-  = do checkCg checkCOrAsmOrLlvmOrInterp+  = do checkCg (Right idecl) checkCOrAsmOrLlvmOrInterp        -- NB check res_ty not sig_ty!        --    In case sig_ty is (forall a. ForeignPtr a)-       check (isFFILabelTy (mkVisFunTys arg_tys res_ty)) (illegalForeignTyErr Outputable.empty)-       cconv' <- checkCConv cconv+       check (isFFILabelTy (mkVisFunTys arg_tys res_ty))+             (TcRnIllegalForeignType Nothing)+       cconv' <- checkCConv (Right idecl) cconv        return (CImport (L lc cconv') safety mh l src) -tcCheckFIType arg_tys res_ty (CImport (L lc cconv) safety mh CWrapper src) = do+tcCheckFIType arg_tys res_ty idecl@(CImport (L lc cconv) safety mh CWrapper src) = do         -- Foreign wrapper (former f.e.d.)         -- The type must be of the form ft -> IO (FunPtr ft), where ft is a valid         -- foreign type.  For legacy reasons ft -> IO (Ptr ft) is accepted, too.         -- The use of the latter form is DEPRECATED, though.-    checkCg checkCOrAsmOrLlvmOrInterp-    cconv' <- checkCConv cconv+    checkCg (Right idecl) checkCOrAsmOrLlvmOrInterp+    cconv' <- checkCConv (Right idecl) cconv     case arg_tys of         [Scaled arg1_mult arg1_ty] -> do                         checkNoLinearFFI arg1_mult@@ -285,70 +291,66 @@                         checkForeignRes mustBeIO checkSafe (isFFIDynTy arg1_ty) res_ty                   where                      (arg1_tys, res1_ty) = tcSplitFunTys arg1_ty-        _ -> addErrTc (illegalForeignTyErr Outputable.empty (text "One argument expected"))+        _ -> addErrTc (TcRnIllegalForeignType Nothing OneArgExpected)     return (CImport (L lc cconv') safety mh CWrapper src)  tcCheckFIType arg_tys res_ty idecl@(CImport (L lc cconv) (L ls safety) mh                                             (CFunction target) src)   | isDynamicTarget target = do -- Foreign import dynamic-      checkCg checkCOrAsmOrLlvmOrInterp-      cconv' <- checkCConv cconv+      checkCg (Right idecl) checkCOrAsmOrLlvmOrInterp+      cconv' <- checkCConv (Right idecl) cconv       case arg_tys of           -- The first arg must be Ptr or FunPtr         []                ->-          addErrTc (illegalForeignTyErr Outputable.empty (text "At least one argument expected"))+          addErrTc (TcRnIllegalForeignType Nothing AtLeastOneArgExpected)         (Scaled arg1_mult arg1_ty:arg_tys) -> do           dflags <- getDynFlags           let curried_res_ty = mkVisFunTys arg_tys res_ty           checkNoLinearFFI arg1_mult           check (isFFIDynTy curried_res_ty arg1_ty)-                (illegalForeignTyErr argument)+                (TcRnIllegalForeignType (Just Arg))           checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys           checkForeignRes nonIOok checkSafe (isFFIImportResultTy dflags) res_ty       return $ CImport (L lc cconv') (L ls safety) mh (CFunction target) src   | cconv == PrimCallConv = do       dflags <- getDynFlags       checkTc (xopt LangExt.GHCForeignImportPrim dflags)-              (text "Use GHCForeignImportPrim to allow `foreign import prim'.")-      checkCg checkCOrAsmOrLlvmOrInterp-      checkCTarget target+              (TcRnForeignImportPrimExtNotSet idecl)+      checkCg (Right idecl) checkCOrAsmOrLlvmOrInterp+      checkCTarget idecl target       checkTc (playSafe safety)-              (text "The safe/unsafe annotation should not be used with `foreign import prim'.")+              (TcRnForeignImportPrimSafeAnn idecl)       checkForeignArgs (isFFIPrimArgumentTy dflags) arg_tys       -- prim import result is more liberal, allows (#,,#)       checkForeignRes nonIOok checkSafe (isFFIPrimResultTy dflags) res_ty       return idecl   | otherwise = do              -- Normal foreign import-      checkCg checkCOrAsmOrLlvmOrInterp-      cconv' <- checkCConv cconv-      checkCTarget target+      checkCg (Right idecl) checkCOrAsmOrLlvmOrInterp+      cconv' <- checkCConv (Right idecl) cconv+      checkCTarget idecl target       dflags <- getDynFlags       checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys       checkForeignRes nonIOok checkSafe (isFFIImportResultTy dflags) res_ty-      checkMissingAmpersand dflags (map scaledThing arg_tys) res_ty+      checkMissingAmpersand idecl (map scaledThing arg_tys) res_ty       case target of           StaticTarget _ _ _ False            | not (null arg_tys) ->-              addErrTc (text "`value' imports cannot have function types")+              addErrTc (TcRnForeignFunctionImportAsValue idecl)           _ -> return ()       return $ CImport (L lc cconv') (L ls safety) mh (CFunction target) src - -- This makes a convenient place to check -- that the C identifier is valid for C-checkCTarget :: CCallTarget -> TcM ()-checkCTarget (StaticTarget _ str _ _) = do-    checkCg checkCOrAsmOrLlvmOrInterp-    checkTc (isCLabelString str) (badCName str)--checkCTarget DynamicTarget = panic "checkCTarget DynamicTarget"+checkCTarget :: ForeignImport -> CCallTarget -> TcM ()+checkCTarget idecl (StaticTarget _ str _ _) = do+    checkCg (Right idecl) checkCOrAsmOrLlvmOrInterp+    checkTc (isCLabelString str) (TcRnInvalidCIdentifier str) +checkCTarget _ DynamicTarget = panic "checkCTarget DynamicTarget" -checkMissingAmpersand :: DynFlags -> [Type] -> Type -> TcM ()-checkMissingAmpersand dflags arg_tys res_ty-  | null arg_tys && isFunPtrTy res_ty &&-    wopt Opt_WarnDodgyForeignImports dflags-  = addWarn (Reason Opt_WarnDodgyForeignImports)-        (text "possible missing & in foreign import of FunPtr")+checkMissingAmpersand :: ForeignImport -> [Type] -> Type -> TcM ()+checkMissingAmpersand idecl arg_tys res_ty+  | null arg_tys && isFunPtrTy res_ty+  = addDiagnosticTc $ TcRnFunPtrImportWithoutAmpersand idecl   | otherwise   = return () @@ -387,7 +389,7 @@     sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty     rhs <- tcCheckPolyExpr (nlHsVar nm) sig_ty -    (norm_co, norm_sig_ty, gres) <- normaliseFfiType sig_ty+    (Reduction norm_co norm_sig_ty, gres) <- normaliseFfiType sig_ty      spec' <- tcCheckFEType norm_sig_ty spec @@ -404,17 +406,18 @@     return ( mkVarBind id rhs            , ForeignExport { fd_name = L loc id                            , fd_sig_ty = undefined-                           , fd_e_ext = norm_co, fd_fe = spec' }+                           , fd_e_ext = norm_co+                           , fd_fe = spec' }            , gres) tcFExport d = pprPanic "tcFExport" (ppr d)  -- ------------ Checking argument types for foreign export ----------------------  tcCheckFEType :: Type -> ForeignExport -> TcM ForeignExport-tcCheckFEType sig_ty (CExport (L l (CExportStatic esrc str cconv)) src) = do-    checkCg checkCOrAsmOrLlvm-    checkTc (isCLabelString str) (badCName str)-    cconv' <- checkCConv cconv+tcCheckFEType sig_ty edecl@(CExport (L l (CExportStatic esrc str cconv)) src) = do+    checkCg (Left edecl) checkCOrAsmOrLlvm+    checkTc (isCLabelString str) (TcRnInvalidCIdentifier str)+    cconv' <- checkCConv (Left edecl) cconv     checkForeignArgs isFFIExternalTy arg_tys     checkForeignRes nonIOok noCheckSafe isFFIExportResultTy res_ty     return (CExport (L l (CExportStatic esrc str cconv')) src)@@ -432,16 +435,16 @@ -}  ------------ Checking argument types for foreign import -----------------------checkForeignArgs :: (Type -> Validity) -> [Scaled Type] -> TcM ()+checkForeignArgs :: (Type -> Validity' IllegalForeignTypeReason) -> [Scaled Type] -> TcM () checkForeignArgs pred tys = mapM_ go tys   where     go (Scaled mult ty) = checkNoLinearFFI mult >>-                          check (pred ty) (illegalForeignTyErr argument)+                          check (pred ty) (TcRnIllegalForeignType (Just Arg))  checkNoLinearFFI :: Mult -> TcM ()  -- No linear types in FFI (#18472) checkNoLinearFFI Many = return ()-checkNoLinearFFI _    = addErrTc $ illegalForeignTyErr argument-                                   (text "Linear types are not supported in FFI declarations, see #18472")+checkNoLinearFFI _    = addErrTc $ TcRnIllegalForeignType (Just Arg)+                                   LinearTypesNotAllowed  ------------ Checking result types for foreign calls ---------------------- -- | Check that the type has the form@@ -452,41 +455,39 @@ -- We also check that the Safe Haskell condition of FFI imports having -- results in the IO monad holds. ---checkForeignRes :: Bool -> Bool -> (Type -> Validity) -> Type -> TcM ()+checkForeignRes :: Bool -> Bool -> (Type -> Validity' IllegalForeignTypeReason) -> Type -> TcM () checkForeignRes non_io_result_ok check_safe pred_res_ty ty   | Just (_, res_ty) <- tcSplitIOType_maybe ty   =     -- Got an IO result type, that's always fine!-     check (pred_res_ty res_ty) (illegalForeignTyErr result)+     check (pred_res_ty res_ty)+           (TcRnIllegalForeignType (Just Result))    -- We disallow nested foralls in foreign types   -- (at least, for the time being). See #16702.   | tcIsForAllTy ty-  = addErrTc $ illegalForeignTyErr result (text "Unexpected nested forall")+  = addErrTc $ TcRnIllegalForeignType (Just Result) UnexpectedNestedForall    -- Case for non-IO result type with FFI Import   | not non_io_result_ok-  = addErrTc $ illegalForeignTyErr result (text "IO result type expected")+  = addErrTc $ TcRnIllegalForeignType (Just Result) IOResultExpected    | otherwise   = do { dflags <- getDynFlags        ; case pred_res_ty ty of                 -- Handle normal typecheck fail, we want to handle this first and                 -- only report safe haskell errors if the normal type check is OK.-           NotValid msg -> addErrTc $ illegalForeignTyErr result msg+           NotValid msg -> addErrTc $ TcRnIllegalForeignType (Just Result) msg             -- handle safe infer fail            _ | check_safe && safeInferOn dflags-               -> recordUnsafeInfer emptyBag+               -> recordUnsafeInfer emptyMessages             -- handle safe language typecheck fail            _ | check_safe && safeLanguageOn dflags-               -> addErrTc (illegalForeignTyErr result safeHsErr)+               -> addErrTc (TcRnIllegalForeignType (Just Result) SafeHaskellMustBeInIO)             -- success! non-IO return is fine            _ -> return () }-  where-    safeHsErr =-      text "Safe Haskell is on, all FFI imports must be in the IO monad"  nonIOok, mustBeIO :: Bool nonIOok  = True@@ -497,76 +498,64 @@ noCheckSafe = False  -- | Checking a supported backend is in use-checkCOrAsmOrLlvm :: Backend -> Validity+checkCOrAsmOrLlvm :: Backend -> Validity' ExpectedBackends checkCOrAsmOrLlvm ViaC = IsValid checkCOrAsmOrLlvm NCG  = IsValid checkCOrAsmOrLlvm LLVM = IsValid-checkCOrAsmOrLlvm _-  = NotValid (text "requires unregisterised, llvm (-fllvm) or native code generation (-fasm)")+checkCOrAsmOrLlvm _    = NotValid COrAsmOrLlvm  -- | Checking a supported backend is in use-checkCOrAsmOrLlvmOrInterp :: Backend -> Validity+checkCOrAsmOrLlvmOrInterp :: Backend -> Validity' ExpectedBackends checkCOrAsmOrLlvmOrInterp ViaC        = IsValid checkCOrAsmOrLlvmOrInterp NCG         = IsValid checkCOrAsmOrLlvmOrInterp LLVM        = IsValid checkCOrAsmOrLlvmOrInterp Interpreter = IsValid-checkCOrAsmOrLlvmOrInterp _-  = NotValid (text "requires interpreted, unregisterised, llvm or native code generation")+checkCOrAsmOrLlvmOrInterp _           = NotValid COrAsmOrLlvmOrInterp -checkCg :: (Backend -> Validity) -> TcM ()-checkCg check = do+checkCg :: Either ForeignExport ForeignImport -> (Backend -> Validity' ExpectedBackends) -> TcM ()+checkCg decl check = do     dflags <- getDynFlags     let bcknd = backend dflags     case bcknd of       NoBackend -> return ()       _ ->         case check bcknd of-          IsValid      -> return ()-          NotValid err -> addErrTc (text "Illegal foreign declaration:" <+> err)+          IsValid -> return ()+          NotValid expectedBcknd ->+            addErrTc $ TcRnIllegalForeignDeclBackend decl bcknd expectedBcknd  -- Calling conventions -checkCConv :: CCallConv -> TcM CCallConv-checkCConv CCallConv    = return CCallConv-checkCConv CApiConv     = return CApiConv-checkCConv StdCallConv  = do dflags <- getDynFlags-                             let platform = targetPlatform dflags-                             if platformArch platform == ArchX86-                                 then return StdCallConv-                                 else do -- This is a warning, not an error. see #3336-                                         when (wopt Opt_WarnUnsupportedCallingConventions dflags) $-                                             addWarnTc (Reason Opt_WarnUnsupportedCallingConventions)-                                                 (text "the 'stdcall' calling convention is unsupported on this platform," $$ text "treating as ccall")-                                         return CCallConv-checkCConv PrimCallConv = do addErrTc (text "The `prim' calling convention can only be used with `foreign import'")-                             return PrimCallConv-checkCConv JavaScriptCallConv = do dflags <- getDynFlags-                                   if platformArch (targetPlatform dflags) == ArchJavaScript-                                       then return JavaScriptCallConv-                                       else do addErrTc (text "The `javascript' calling convention is unsupported on this platform")-                                               return JavaScriptCallConv+checkCConv :: Either ForeignExport ForeignImport -> CCallConv -> TcM CCallConv+checkCConv _ CCallConv    = return CCallConv+checkCConv _ CApiConv     = return CApiConv+checkCConv decl StdCallConv = do+  dflags <- getDynFlags+  let platform = targetPlatform dflags+  if platformArch platform == ArchX86+      then return StdCallConv+      else do -- This is a warning, not an error. see #3336+              let msg = TcRnUnsupportedCallConv decl StdCallConvUnsupported+              addDiagnosticTc msg+              return CCallConv+checkCConv decl PrimCallConv = do+  addErrTc $ TcRnUnsupportedCallConv decl PrimCallConvUnsupported+  return PrimCallConv+checkCConv decl JavaScriptCallConv = do+  dflags <- getDynFlags+  if platformArch (targetPlatform dflags) == ArchJavaScript+      then return JavaScriptCallConv+      else do+        addErrTc $ TcRnUnsupportedCallConv decl JavaScriptCallConvUnsupported+        return JavaScriptCallConv  -- Warnings -check :: Validity -> (SDoc -> SDoc) -> TcM ()-check IsValid _             = return ()-check (NotValid doc) err_fn = addErrTc (err_fn doc)--illegalForeignTyErr :: SDoc -> SDoc -> SDoc-illegalForeignTyErr arg_or_res extra-  = hang msg 2 extra-  where-    msg = hsep [ text "Unacceptable", arg_or_res-               , text "type in foreign declaration:"]---- Used for 'arg_or_res' argument to illegalForeignTyErr-argument, result :: SDoc-argument = text "argument"-result   = text "result"--badCName :: CLabelString -> SDoc-badCName target-  = sep [quotes (ppr target) <+> text "is not a valid C identifier"]+check :: Validity' IllegalForeignTypeReason+      -> (IllegalForeignTypeReason -> TcRnMessage)+      -> TcM ()+check IsValid _                   = return ()+check (NotValid reason) mkMessage = addErrTc (mkMessage reason)  foreignDeclCtxt :: ForeignDecl GhcRn -> SDoc foreignDeclCtxt fo
GHC/Tc/Gen/Head.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP                 #-}+ {-# LANGUAGE DataKinds           #-} {-# LANGUAGE FlexibleContexts    #-} {-# LANGUAGE GADTs               #-}@@ -6,6 +6,8 @@ {-# LANGUAGE TupleSections       #-} {-# LANGUAGE TypeFamilies        #-} {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]+{-# LANGUAGE ViewPatterns        #-}+{-# LANGUAGE DisambiguateRecordFields #-}  {-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-} @@ -21,10 +23,11 @@        , splitHsApps, rebuildHsApps        , addArgWrap, isHsValArg        , countLeadingValArgs, isVisibleArg, pprHsExprArgTc+       , countVisAndInvisValArgs, countHsWrapperInvisArgs         , tcInferAppHead, tcInferAppHead_maybe        , tcInferId, tcCheckId-       , obviousSig, addAmbiguousNameErr+       , obviousSig        , tyConOf, tyConOfET, lookupParents, fieldNotInType        , notSelector, nonBidirectionalErr @@ -33,29 +36,31 @@ import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcExpr, tcCheckMonoExprNC, tcCheckPolyExprNC )  import GHC.Tc.Gen.HsType-import GHC.Tc.Gen.Pat import GHC.Tc.Gen.Bind( chooseInferredQuantifiers )-import GHC.Tc.Gen.Sig( tcUserTypeSig, tcInstSig )+import GHC.Tc.Gen.Sig( tcUserTypeSig, tcInstSig, lhsSigWcTypeContextSpan ) import GHC.Tc.TyCl.PatSyn( patSynBuilderOcc ) import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Unify import GHC.Types.Basic+import GHC.Types.Error import GHC.Tc.Utils.Instantiate-import GHC.Tc.Instance.Family ( tcGetFamInstEnvs, tcLookupDataFamInst )+import GHC.Tc.Instance.Family ( tcLookupDataFamInst ) import GHC.Core.FamInstEnv    ( FamInstEnvs ) import GHC.Core.UsageEnv      ( unitUE )-import GHC.Rename.Env         ( addUsedGRE )-import GHC.Rename.Utils       ( addNameClashErrRn, unknownSubordinateErr )+import GHC.Rename.Unbound     ( unknownNameSuggestions, WhatLooking(..) )+import GHC.Unit.Module        ( getModule )+import GHC.Tc.Errors.Types import GHC.Tc.Solver          ( InferMode(..), simplifyInfer ) import GHC.Tc.Utils.Env-import GHC.Tc.Utils.Zonk      ( hsLitType ) import GHC.Tc.Utils.TcMType import GHC.Tc.Types.Origin import GHC.Tc.Utils.TcType as TcType import GHC.Hs+import GHC.Hs.Syn.Type import GHC.Types.Id import GHC.Types.Id.Info-import GHC.Core.ConLike+import GHC.Core.PatSyn( PatSyn )+import GHC.Core.ConLike( ConLike(..) ) import GHC.Core.DataCon import GHC.Types.Name import GHC.Types.Name.Reader@@ -66,19 +71,18 @@ import GHC.Builtin.Types( multiplicityTy ) import GHC.Builtin.Names import GHC.Builtin.Names.TH( liftStringName, liftName )+import GHC.Driver.Env import GHC.Driver.Session import GHC.Types.SrcLoc import GHC.Utils.Misc import GHC.Data.Maybe import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import Control.Monad  import Data.Function-import qualified Data.List.NonEmpty as NE -#include "HsVersions.h"- import GHC.Prelude  @@ -245,7 +249,7 @@ -- See Note [splitHsApps] splitHsApps e = go e (top_ctxt 0 e) []   where-    top_ctxt n (HsPar _ fun)               = top_lctxt n fun+    top_ctxt n (HsPar _ _ fun _)           = top_lctxt n fun     top_ctxt n (HsPragE _ _ fun)           = top_lctxt n fun     top_ctxt n (HsAppType _ fun _)         = top_lctxt (n+1) fun     top_ctxt n (HsApp _ fun _)             = top_lctxt (n+1) fun@@ -256,7 +260,7 @@      go :: HsExpr GhcRn -> AppCtxt -> [HsExprArg 'TcpRn]        -> ((HsExpr GhcRn, AppCtxt), [HsExprArg 'TcpRn])-    go (HsPar _     (L l fun))    ctxt args = go fun (set l ctxt) (EWrap (EPar ctxt)   : args)+    go (HsPar _ _ (L l fun) _)    ctxt args = go fun (set l ctxt) (EWrap (EPar ctxt)   : args)     go (HsPragE _ p (L l fun))    ctxt args = go fun (set l ctxt) (EPrag      ctxt p   : args)     go (HsAppType _ (L l fun) ty) ctxt args = go fun (dec l ctxt) (mkETypeArg ctxt ty  : args)     go (HsApp _ (L l fun) arg)    ctxt args = go fun (dec l ctxt) (mkEValArg  ctxt arg : args)@@ -294,7 +298,7 @@       EPrag ctxt' p         -> rebuildHsApps (HsPragE noExtField p lfun) ctxt' args       EWrap (EPar ctxt')-        -> rebuildHsApps (HsPar noAnn lfun) ctxt' args+        -> rebuildHsApps (gHsPar lfun) ctxt' args       EWrap (EExpand orig)         -> rebuildHsApps (XExpr (ExpansionExpr (HsExpanded orig fun))) ctxt args       EWrap (EHsWrap wrap)@@ -322,6 +326,36 @@ isVisibleArg (ETypeArg {}) = True isVisibleArg _             = False +-- | Count visible and invisible value arguments in a list+-- of 'HsExprArg' arguments.+countVisAndInvisValArgs :: [HsExprArg id] -> Arity+countVisAndInvisValArgs []                  = 0+countVisAndInvisValArgs (EValArg {} : args) = 1 + countVisAndInvisValArgs args+countVisAndInvisValArgs (EWrap wrap : args) =+  case wrap of { EHsWrap hsWrap            -> countHsWrapperInvisArgs hsWrap + countVisAndInvisValArgs args+               ; EPar   {}                 -> countVisAndInvisValArgs args+               ; EExpand {}                -> countVisAndInvisValArgs args }+countVisAndInvisValArgs (EPrag {}   : args) = countVisAndInvisValArgs args+countVisAndInvisValArgs (ETypeArg {}: args) = countVisAndInvisValArgs args++-- | Counts the number of invisible term-level arguments applied by an 'HsWrapper'.+-- Precondition: this wrapper contains no abstractions.+countHsWrapperInvisArgs :: HsWrapper -> Arity+countHsWrapperInvisArgs = go+  where+    go WpHole = 0+    go (WpCompose wrap1 wrap2) = go wrap1 + go wrap2+    go fun@(WpFun {}) = nope fun+    go (WpCast {}) = 0+    go evLam@(WpEvLam {}) = nope evLam+    go (WpEvApp _) = 1+    go tyLam@(WpTyLam {}) = nope tyLam+    go (WpTyApp _) = 0+    go (WpLet _) = 0+    go (WpMultCoercion {}) = 0++    nope x = pprPanic "countHsWrapperInvisApps" (ppr x)+ instance OutputableBndrId (XPass p) => Outputable (HsExprArg p) where   ppr (EValArg { eva_arg = arg })      = text "EValArg" <+> ppr arg   ppr (EPrag _ p)                      = text "EPrag" <+> ppr p@@ -373,22 +407,21 @@ ********************************************************************* -}  tcInferAppHead :: (HsExpr GhcRn, AppCtxt)-               -> [HsExprArg 'TcpRn] -> Maybe TcRhoType-               -- These two args are solely for tcInferRecSelId+               -> [HsExprArg 'TcpRn]                -> TcM (HsExpr GhcTc, TcSigmaType) -- Infer type of the head of an application --   i.e. the 'f' in (f e1 ... en) -- See Note [Application chains and heads] in GHC.Tc.Gen.App -- We get back a /SigmaType/ because we have special cases for --   * A bare identifier (just look it up)---     This case also covers a record selector HsRecFld+--     This case also covers a record selector HsRecSel --   * An expression with a type signature (e :: ty) -- See Note [Application chains and heads] in GHC.Tc.Gen.App ----- Why do we need the arguments to infer the type of the head of--- the application?  For two reasons:---   * (Legitimate) The first arg has the source location of the head---   * (Disgusting) Needed for record disambiguation; see tcInferRecSelId+-- Why do we need the arguments to infer the type of the head of the+-- application? Simply to inform add_head_ctxt about whether or not+-- to put push a new "In the expression..." context. (We don't push a+-- new one if there are no arguments, because we already have.) -- -- Note that [] and (,,) are both HsVar: --   see Note [Empty lists] and [ExplicitTuple] in GHC.Hs.Expr@@ -397,29 +430,28 @@ --     cases are dealt with by splitHsApps. -- -- See Note [tcApp: typechecking applications] in GHC.Tc.Gen.App-tcInferAppHead (fun,ctxt) args mb_res_ty+tcInferAppHead (fun,ctxt) args   = setSrcSpan (appCtxtLoc ctxt) $-    do { mb_tc_fun <- tcInferAppHead_maybe fun args mb_res_ty+    do { mb_tc_fun <- tcInferAppHead_maybe fun args        ; case mb_tc_fun of             Just (fun', fun_sigma) -> return (fun', fun_sigma)             Nothing -> add_head_ctxt fun args $                        tcInfer (tcExpr fun) }  tcInferAppHead_maybe :: HsExpr GhcRn-                     -> [HsExprArg 'TcpRn] -> Maybe TcRhoType-                        -- These two args are solely for tcInferRecSelId+                     -> [HsExprArg 'TcpRn]                      -> TcM (Maybe (HsExpr GhcTc, TcSigmaType)) -- See Note [Application chains and heads] in GHC.Tc.Gen.App -- Returns Nothing for a complicated head-tcInferAppHead_maybe fun args mb_res_ty+tcInferAppHead_maybe fun args   = case fun of       HsVar _ (L _ nm)          -> Just <$> tcInferId nm-      HsRecFld _ f              -> Just <$> tcInferRecSelId f args mb_res_ty+      HsRecSel _ f              -> Just <$> tcInferRecSelId f       ExprWithTySig _ e hs_ty   -> add_head_ctxt fun args $                                    Just <$> tcExprWithSig e hs_ty       HsOverLit _ lit           -> Just <$> tcInferOverLit lit       HsSpliceE _ (HsSpliced _ _ (HsSplicedExpr e))-                                -> tcInferAppHead_maybe e args mb_res_ty+                                -> tcInferAppHead_maybe e args       _                         -> return Nothing  add_head_ctxt :: HsExpr GhcRn -> [HsExprArg 'TcpRn] -> TcM a -> TcM a@@ -436,224 +468,46 @@ *                                                                      * ********************************************************************* -} -{--Note [Deprecating ambiguous fields]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In the future, the -XDuplicateRecordFields extension will no longer support-disambiguating record fields during type-checking (as described in Note-[Disambiguating record fields]).  For now, the -Wambiguous-fields option will-emit a warning whenever an ambiguous field is resolved using type information.-In a subsequent GHC release, this functionality will be removed and the warning-will turn into an ambiguity error in the renamer.--For background information, see GHC proposal #366-(https://github.com/ghc-proposals/ghc-proposals/pull/366).---Note [Disambiguating record fields]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-NB. The following is going to be removed: see-Note [Deprecating ambiguous fields].--When the -XDuplicateRecordFields extension is used, and the renamer-encounters a record selector or update that it cannot immediately-disambiguate (because it involves fields that belong to multiple-datatypes), it will defer resolution of the ambiguity to the-typechecker.  In this case, the `Ambiguous` constructor of-`AmbiguousFieldOcc` is used.--Consider the following definitions:--        data S = MkS { foo :: Int }-        data T = MkT { foo :: Int, bar :: Int }-        data U = MkU { bar :: Int, baz :: Int }--When the renamer sees `foo` as a selector or an update, it will not-know which parent datatype is in use.--For selectors, there are two possible ways to disambiguate:--1. Check if the pushed-in type is a function whose domain is a-   datatype, for example:--       f s = (foo :: S -> Int) s--       g :: T -> Int-       g = foo--    This is checked by `tcCheckRecSelId` when checking `HsRecFld foo`.--2. Check if the selector is applied to an argument that has a type-   signature, for example:--       h = foo (s :: S)--    This is checked by `tcInferRecSelId`.---Updates are slightly more complex.  The `disambiguateRecordBinds`-function tries to determine the parent datatype in three ways:--1. Check for types that have all the fields being updated. For example:--        f x = x { foo = 3, bar = 2 }--   Here `f` must be updating `T` because neither `S` nor `U` have-   both fields. This may also discover that no possible type exists.-   For example the following will be rejected:--        f' x = x { foo = 3, baz = 3 }--2. Use the type being pushed in, if it is already a TyConApp. The-   following are valid updates to `T`:--        g :: T -> T-        g x = x { foo = 3 }--        g' x = x { foo = 3 } :: T--3. Use the type signature of the record expression, if it exists and-   is a TyConApp. Thus this is valid update to `T`:--        h x = (x :: T) { foo = 3 }---Note that we do not look up the types of variables being updated, and-no constraint-solving is performed, so for example the following will-be rejected as ambiguous:--     let bad (s :: S) = foo s--     let r :: T-         r = blah-     in r { foo = 3 }--     \r. (r { foo = 3 },  r :: T )--We could add further tests, of a more heuristic nature. For example,-rather than looking for an explicit signature, we could try to infer-the type of the argument to a selector or the record expression being-updated, in case we are lucky enough to get a TyConApp straight-away. However, it might be hard for programmers to predict whether a-particular update is sufficiently obvious for the signature to be-omitted. Moreover, this might change the behaviour of typechecker in-non-obvious ways.--See also Note [HsRecField and HsRecUpdField] in GHC.Hs.Pat.--}--tcInferRecSelId :: AmbiguousFieldOcc GhcRn-                -> [HsExprArg 'TcpRn] -> Maybe TcRhoType+tcInferRecSelId :: FieldOcc GhcRn                 -> TcM (HsExpr GhcTc, TcSigmaType)-tcInferRecSelId (Unambiguous sel_name lbl) _args _mb_res_ty-   = do { sel_id <- tc_rec_sel_id lbl sel_name-        ; let expr = HsRecFld noExtField (Unambiguous sel_id lbl)-        ; return (expr, idType sel_id) }--tcInferRecSelId (Ambiguous _ lbl) args mb_res_ty-   = do { sel_name <- tcInferAmbiguousRecSelId lbl args mb_res_ty-        ; sel_id   <- tc_rec_sel_id lbl sel_name-        ; let expr = HsRecFld noExtField (Ambiguous sel_id lbl)-        ; return (expr, idType sel_id) }+tcInferRecSelId (FieldOcc sel_name lbl)+   = do { sel_id <- tc_rec_sel_id+        ; let expr = HsRecSel noExtField (FieldOcc sel_id lbl)+        ; return (expr, idType sel_id)+        }+     where+       occ :: OccName+       occ = rdrNameOcc (unLoc lbl) --------------------------tc_rec_sel_id :: LocatedN RdrName -> Name -> TcM TcId--- Like tc_infer_id, but returns an Id not a HsExpr,--- so we can wrap it back up into a HsRecFld-tc_rec_sel_id lbl sel_name-  = do { thing <- tcLookup sel_name-       ; case thing of-             ATcId { tct_id = id }-               -> do { check_naughty occ id-                     ; check_local_id id-                     ; return id }+       tc_rec_sel_id :: TcM TcId+       -- Like tc_infer_id, but returns an Id not a HsExpr,+       -- so we can wrap it back up into a HsRecSel+       tc_rec_sel_id+         = do { thing <- tcLookup sel_name+              ; case thing of+                    ATcId { tct_id = id }+                      -> do { check_naughty occ id  -- See Note [Local record selectors]+                            ; check_local_id id+                            ; return id } -             AGlobal (AnId id)-               -> do { check_naughty occ id-                     ; return id }-                    -- A global cannot possibly be ill-staged-                    -- nor does it need the 'lifting' treatment-                    -- hence no checkTh stuff here+                    AGlobal (AnId id)+                      -> do { check_naughty occ id+                            ; return id }+                           -- A global cannot possibly be ill-staged+                           -- nor does it need the 'lifting' treatment+                           -- hence no checkTh stuff here -             _ -> failWithTc $-                  ppr thing <+> text "used where a value identifier was expected" }-  where-    occ = rdrNameOcc (unLoc lbl)+                    _ -> failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $+                         ppr thing <+> text "used where a value identifier was expected" }  -------------------------tcInferAmbiguousRecSelId :: LocatedN RdrName-                         -> [HsExprArg 'TcpRn] -> Maybe TcRhoType-                         -> TcM Name--- Disgusting special case for ambiguous record selectors--- Given a RdrName that refers to multiple record fields, and the type--- of its argument, try to determine the name of the selector that is--- meant.--- See Note [Disambiguating record fields]-tcInferAmbiguousRecSelId lbl args mb_res_ty-  | arg1 : _ <- dropWhile (not . isVisibleArg) args -- A value arg is first-  , EValArg { eva_arg = ValArg (L _ arg) } <- arg1-  , Just sig_ty <- obviousSig arg  -- A type sig on the arg disambiguates-  = do { sig_tc_ty <- tcHsSigWcType ExprSigCtxt sig_ty-       ; finish_ambiguous_selector lbl sig_tc_ty } -  | Just res_ty <- mb_res_ty-  , Just (arg_ty,_) <- tcSplitFunTy_maybe res_ty-  = finish_ambiguous_selector lbl (scaledThing arg_ty)--  | otherwise-  = ambiguousSelector lbl--finish_ambiguous_selector :: LocatedN RdrName -> Type -> TcM Name-finish_ambiguous_selector lr@(L _ rdr) parent_type- = do { fam_inst_envs <- tcGetFamInstEnvs-      ; case tyConOf fam_inst_envs parent_type of {-          Nothing -> ambiguousSelector lr ;-          Just p  ->--    do { xs <- lookupParents True rdr-       ; let parent = RecSelData p-       ; case lookup parent xs of {-           Nothing  -> failWithTc (fieldNotInType parent rdr) ;-           Just gre ->--    -- See Note [Unused name reporting and HasField] in GHC.Tc.Instance.Class-    do { addUsedGRE True gre-       ; keepAlive (greMangledName gre)-         -- See Note [Deprecating ambiguous fields]-       ; warnIfFlag Opt_WarnAmbiguousFields True $-          vcat [ text "The field" <+> quotes (ppr rdr)-                   <+> text "belonging to type" <+> ppr parent_type-                   <+> text "is ambiguous."-               , text "This will not be supported by -XDuplicateRecordFields in future releases of GHC."-               , if isLocalGRE gre-                 then text "You can use explicit case analysis to resolve the ambiguity."-                 else text "You can use a qualified import or explicit case analysis to resolve the ambiguity."-               ]-       ; return (greMangledName gre) } } } } }---- This field name really is ambiguous, so add a suitable "ambiguous--- occurrence" error, then give up.-ambiguousSelector :: LocatedN RdrName -> TcM a-ambiguousSelector (L _ rdr)-  = do { addAmbiguousNameErr rdr-       ; failM }---- | This name really is ambiguous, so add a suitable "ambiguous--- occurrence" error, then continue-addAmbiguousNameErr :: RdrName -> TcM ()-addAmbiguousNameErr rdr-  = do { env <- getGlobalRdrEnv-       ; let gres = lookupGRE_RdrName rdr env-       ; case gres of-         [] -> panic "addAmbiguousNameErr: not found"-         gre : gres -> setErrCtxt [] $ addNameClashErrRn rdr $ gre NE.:| gres}- -- A type signature on the argument of an ambiguous record selector or -- the record expression in an update must be "obvious", i.e. the -- outermost constructor ignoring parentheses. obviousSig :: HsExpr GhcRn -> Maybe (LHsSigWcType GhcRn) obviousSig (ExprWithTySig _ _ ty) = Just ty-obviousSig (HsPar _ p)            = obviousSig (unLoc p)+obviousSig (HsPar _ _ p _)        = obviousSig (unLoc p) obviousSig (HsPragE _ _ p)        = obviousSig (unLoc p) obviousSig _                      = Nothing @@ -693,17 +547,20 @@                               Nothing -> failWithTc (notSelector (greMangledName gre)) }  -fieldNotInType :: RecSelParent -> RdrName -> SDoc+fieldNotInType :: RecSelParent -> RdrName -> TcRnMessage fieldNotInType p rdr-  = unknownSubordinateErr (text "field of type" <+> quotes (ppr p)) rdr+  = mkTcRnNotInScope rdr $+    UnknownSubordinate (text "field of type" <+> quotes (ppr p)) -notSelector :: Name -> SDoc+notSelector :: Name -> TcRnMessage notSelector field-  = hsep [quotes (ppr field), text "is not a record selector"]+  = TcRnUnknownMessage $ mkPlainError noHints $+  hsep [quotes (ppr field), text "is not a record selector"] -naughtyRecordSel :: OccName -> SDoc+naughtyRecordSel :: OccName -> TcRnMessage naughtyRecordSel lbl-  = text "Cannot use record selector" <+> quotes (ppr lbl) <+>+  = TcRnUnknownMessage $ mkPlainError noHints $+    text "Cannot use record selector" <+> quotes (ppr lbl) <+>     text "as a function due to escaped type variables" $$     text "Probable fix: use pattern-matching syntax instead" @@ -720,20 +577,21 @@ tcExprWithSig expr hs_ty   = do { sig_info <- checkNoErrs $  -- Avoid error cascade                      tcUserTypeSig loc hs_ty Nothing-       ; (expr', poly_ty) <- tcExprSig expr sig_info+       ; (expr', poly_ty) <- tcExprSig ctxt expr sig_info        ; return (ExprWithTySig noExtField expr' hs_ty, poly_ty) }   where     loc = getLocA (dropWildCards hs_ty)+    ctxt = ExprSigCtxt (lhsSigWcTypeContextSpan hs_ty) -tcExprSig :: LHsExpr GhcRn -> TcIdSigInfo -> TcM (LHsExpr GhcTc, TcType)-tcExprSig expr (CompleteSig { sig_bndr = poly_id, sig_loc = loc })+tcExprSig :: UserTypeCtxt -> LHsExpr GhcRn -> TcIdSigInfo -> TcM (LHsExpr GhcTc, TcType)+tcExprSig ctxt expr (CompleteSig { sig_bndr = poly_id, sig_loc = loc })   = setSrcSpan loc $   -- Sets the location for the implication constraint     do { let poly_ty = idType poly_id-       ; (wrap, expr') <- tcSkolemiseScoped ExprSigCtxt poly_ty $ \rho_ty ->+       ; (wrap, expr') <- tcSkolemiseScoped ctxt poly_ty $ \rho_ty ->                           tcCheckMonoExprNC expr rho_ty        ; return (mkLHsWrap wrap expr', poly_ty) } -tcExprSig expr sig@(PartialSig { psig_name = name, sig_loc = loc })+tcExprSig _ expr sig@(PartialSig { psig_name = name, sig_loc = loc })   = setSrcSpan loc $   -- Sets the location for the implication constraint     do { (tclvl, wanted, (expr', sig_inst))              <- pushLevelAndCaptureConstraints  $@@ -749,13 +607,14 @@                         = ApplyMR                         | otherwise                         = NoRestrictions-       ; (qtvs, givens, ev_binds, _)-                 <- simplifyInfer tclvl infer_mode [sig_inst] [(name, tau)] wanted+       ; ((qtvs, givens, ev_binds, _), residual)+           <- captureConstraints $ simplifyInfer tclvl infer_mode [sig_inst] [(name, tau)] wanted+       ; emitConstraints residual         ; tau <- zonkTcType tau        ; let inferred_theta = map evVarPred givens              tau_tvs        = tyCoVarsOfType tau-       ; (binders, my_theta) <- chooseInferredQuantifiers inferred_theta+       ; (binders, my_theta) <- chooseInferredQuantifiers residual inferred_theta                                    tau_tvs qtvs (Just sig_inst)        ; let inferred_sigma = mkInfSigmaTy qtvs inferred_theta tau              my_sigma       = mkInvisForAllTys binders (mkPhiTy  my_theta tau)@@ -763,7 +622,7 @@                  then return idHsWrapper  -- Fast path; also avoids complaint when we infer                                           -- an ambiguous type and have AllowAmbiguousType                                           -- e..g infer  x :: forall a. F a -> Int-                 else tcSubTypeSigma ExprSigOrigin ExprSigCtxt inferred_sigma my_sigma+                 else tcSubTypeSigma ExprSigOrigin (ExprSigCtxt NoRRC) inferred_sigma my_sigma         ; traceTc "tcExpSig" (ppr qtvs $$ ppr givens $$ ppr inferred_sigma $$ ppr my_sigma)        ; let poly_wrap = wrap@@ -810,37 +669,33 @@  tcInferOverLit :: HsOverLit GhcRn -> TcM (HsExpr GhcTc, TcSigmaType) tcInferOverLit lit@(OverLit { ol_val = val-                            , ol_witness = HsVar _ (L loc from_name)-                            , ol_ext = rebindable })+                            , ol_ext = OverLitRn { ol_rebindable = rebindable+                                                 , ol_from_fun = L loc from_name } })   = -- Desugar "3" to (fromInteger (3 :: Integer))     --   where fromInteger is gotten by looking up from_name, and     --   the (3 :: Integer) is returned by mkOverLit     -- Ditto the string literal "foo" to (fromString ("foo" :: String))-    do { from_id <- tcLookupId from_name-       ; (wrap1, from_ty) <- topInstantiate orig (idType from_id)--       ; (wrap2, sarg_ty, res_ty) <- matchActualFunTySigma herald mb_doc+    do { hs_lit <- mkOverLit val+       ; from_id <- tcLookupId from_name+       ; (wrap1, from_ty) <- topInstantiate (LiteralOrigin lit) (idType from_id)+       ; let+           thing    = NameThing from_name+           mb_thing = Just thing+           herald   = ExpectedFunTyArg thing (HsLit noAnn hs_lit)+       ; (wrap2, sarg_ty, res_ty) <- matchActualFunTySigma herald mb_thing                                                            (1, []) from_ty-       ; hs_lit <- mkOverLit val-       ; co <- unifyType mb_doc (hsLitType hs_lit) (scaledThing sarg_ty) +       ; co <- unifyType mb_thing (hsLitType hs_lit) (scaledThing sarg_ty)        ; let lit_expr = L (l2l loc) $ mkHsWrapCo co $                         HsLit noAnn hs_lit              from_expr = mkHsWrap (wrap2 <.> wrap1) $                          HsVar noExtField (L loc from_id)-             lit' = lit { ol_witness = HsApp noAnn (L (l2l loc) from_expr) lit_expr-                        , ol_ext = OverLitTc rebindable res_ty }+             witness = HsApp noAnn (L (l2l loc) from_expr) lit_expr+             lit' = lit { ol_ext = OverLitTc { ol_rebindable = rebindable+                                             , ol_witness = witness+                                             , ol_type = res_ty } }        ; return (HsOverLit noAnn lit', res_ty) }-  where-    orig   = LiteralOrigin lit-    mb_doc = Just (ppr from_name)-    herald = sep [ text "The function" <+> quotes (ppr from_name)-                 , text "is applied to"] -tcInferOverLit lit-  = pprPanic "tcInferOverLit" (ppr lit)-- {- ********************************************************************* *                                                                      *                  tcInferId, tcCheckId@@ -885,95 +740,61 @@ tc_infer_id :: Name -> TcM (HsExpr GhcTc, TcSigmaType) tc_infer_id id_name  = do { thing <- tcLookup id_name-      ; global_env <- getGlobalRdrEnv       ; case thing of              ATcId { tct_id = id }                -> do { check_local_id id                      ; return_id id } -             AGlobal (AnId id)-               -> return_id id+             AGlobal (AnId id) -> return_id id                -- A global cannot possibly be ill-staged                -- nor does it need the 'lifting' treatment                -- Hence no checkTh stuff here -             AGlobal (AConLike cl) -> case cl of-                 RealDataCon con -> return_data_con con-                 PatSynCon ps-                   | Just (expr, ty) <- patSynBuilderOcc ps-                   -> return (expr, ty)-                   | otherwise-                   -> failWithTc (nonBidirectionalErr id_name)--             AGlobal (ATyCon ty_con)-               -> fail_tycon global_env ty_con--             ATyVar name _-                -> failWithTc $-                     text "Illegal term-level use of the type variable"-                       <+> quotes (ppr name)-                       $$ nest 2 (text "bound at" <+> ppr (getSrcLoc name))--             ATcTyCon ty_con-               -> fail_tycon global_env ty_con+             AGlobal (AConLike (RealDataCon con)) -> tcInferDataCon con+             AGlobal (AConLike (PatSynCon ps)) -> tcInferPatSyn id_name ps+             (tcTyThingTyCon_maybe -> Just tc) -> fail_tycon tc -- TyCon or TcTyCon+             ATyVar name _ -> fail_tyvar name -             _ -> failWithTc $+             _ -> failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $                   ppr thing <+> text "used where a value identifier was expected" }   where-    fail_tycon global_env ty_con =-      let pprov = case lookupGRE_Name global_env (tyConName ty_con) of-            Just gre -> nest 2 (pprNameProvenance gre)-            Nothing  -> empty-      in failWithTc (term_level_tycons ty_con $$ pprov)--    term_level_tycons ty_con-      = text "Illegal term-level use of the type constructor"-          <+> quotes (ppr (tyConName ty_con))--    return_id id = return (HsVar noExtField (noLocA id), idType id)+    fail_tycon tc = do+      gre <- getGlobalRdrEnv+      let nm = tyConName tc+          pprov = case lookupGRE_Name gre nm of+                      Just gre -> nest 2 (pprNameProvenance gre)+                      Nothing  -> empty+      fail_with_msg dataName nm pprov -    return_data_con con-      = do { let tvs = dataConUserTyVarBinders con-                 theta = dataConOtherTheta con-                 args = dataConOrigArgTys con-                 res = dataConOrigResTy con+    fail_tyvar nm =+      let pprov = nest 2 (text "bound at" <+> ppr (getSrcLoc nm))+      in fail_with_msg varName nm pprov -           -- See Note [Linear fields generalization]-           ; mul_vars <- newFlexiTyVarTys (length args) multiplicityTy-           ; let scaleArgs args' = zipWithEqual "return_data_con" combine mul_vars args'-                 combine var (Scaled One ty) = Scaled var ty-                 combine _   scaled_ty       = scaled_ty-                   -- The combine function implements the fact that, as-                   -- described in Note [Linear fields generalization], if a-                   -- field is not linear (last line) it isn't made polymorphic.+    fail_with_msg whatName nm pprov = do+      (import_errs, hints) <- get_suggestions whatName+      unit_state <- hsc_units <$> getTopEnv+      let+        -- TODO: unfortunate to have to convert to SDoc here.+        -- This should go away once we refactor ErrInfo.+        hint_msg = vcat $ map ppr hints+        import_err_msg = vcat $ map ppr import_errs+        info = ErrInfo { errInfoContext = pprov, errInfoSupplementary = import_err_msg $$ hint_msg }+        msg = TcRnMessageWithInfo unit_state+            $ TcRnMessageDetailed info (TcRnIncorrectNameSpace nm False)+      failWithTc msg -                 etaWrapper arg_tys = foldr (\scaled_ty wr -> WpFun WpHole wr scaled_ty empty) WpHole arg_tys+    get_suggestions ns = do+       let occ = mkOccNameFS ns (occNameFS (occName id_name))+       dflags  <- getDynFlags+       rdr_env <- getGlobalRdrEnv+       lcl_env <- getLocalRdrEnv+       imp_info <- getImports+       curr_mod <- getModule+       hpt <- getHpt+       return $ unknownNameSuggestions WL_Anything dflags hpt curr_mod rdr_env+         lcl_env imp_info (mkRdrUnqual occ) -           -- See Note [Instantiating stupid theta]-           ; let shouldInstantiate = (not (null (dataConStupidTheta con)) ||-                                      isKindLevPoly (tyConResKind (dataConTyCon con)))-           ; case shouldInstantiate of-               True -> do { (subst, tvs') <- newMetaTyVars (binderVars tvs)-                           ; let tys'   = mkTyVarTys tvs'-                                 theta' = substTheta subst theta-                                 args'  = substScaledTys subst args-                                 res'   = substTy subst res-                           ; wrap <- instCall (OccurrenceOf id_name) tys' theta'-                           ; let scaled_arg_tys = scaleArgs args'-                                 eta_wrap = etaWrapper scaled_arg_tys-                           ; addDataConStupidTheta con tys'-                           ; return ( mkHsWrap (eta_wrap <.> wrap)-                                               (HsConLikeOut noExtField (RealDataCon con))-                                    , mkVisFunTys scaled_arg_tys res')-                           }-               False -> let scaled_arg_tys = scaleArgs args-                            wrap1 = mkWpTyApps (mkTyVarTys $ binderVars tvs)-                            eta_wrap = etaWrapper (map unrestricted theta ++ scaled_arg_tys)-                            wrap2 = mkWpTyLams $ binderVars tvs-                        in return ( mkHsWrap (wrap2 <.> eta_wrap <.> wrap1)-                                             (HsConLikeOut noExtField (RealDataCon con))-                                  , mkInvisForAllTys tvs $ mkInvisFunTysMany theta $ mkVisFunTys scaled_arg_tys res)-           }+    return_id id = return (HsVar noExtField (noLocA id), idType id)  check_local_id :: Id -> TcM () check_local_id id@@ -985,48 +806,119 @@   | isNaughtyRecordSelector id = failWithTc (naughtyRecordSel lbl)   | otherwise                  = return () -nonBidirectionalErr :: Outputable name => name -> SDoc-nonBidirectionalErr name = text "non-bidirectional pattern synonym"-                           <+> quotes (ppr name) <+> text "used in an expression"+tcInferDataCon :: DataCon -> TcM (HsExpr GhcTc, TcSigmaType)+-- See Note [Typechecking data constructors]+tcInferDataCon con+  = do { let tvbs  = dataConUserTyVarBinders con+             tvs   = binderVars tvbs+             theta = dataConOtherTheta con+             args  = dataConOrigArgTys con+             res   = dataConOrigResTy con+             stupid_theta = dataConStupidTheta con -{--Note [Linear fields generalization]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-As per Note [Polymorphisation of linear fields], linear field of data-constructors get a polymorphic type when the data constructor is used as a term.+       ; scaled_arg_tys <- mapM linear_to_poly args -    Just :: forall {p} a. a #p-> Maybe a+       ; let full_theta  = stupid_theta ++ theta+             all_arg_tys = map unrestricted full_theta ++ scaled_arg_tys+                -- stupid-theta must come first+                -- See Note [Instantiating stupid theta] -This rule is known only to the typechecker: Just keeps its linear type in Core.+       ; return ( XExpr (ConLikeTc (RealDataCon con) tvs all_arg_tys)+                , mkInvisForAllTys tvbs $ mkPhiTy full_theta $+                  mkVisFunTys scaled_arg_tys res ) }+  where+    linear_to_poly :: Scaled Type -> TcM (Scaled Type)+    -- linear_to_poly implements point (3,4)+    -- of Note [Typechecking data constructors]+    linear_to_poly (Scaled One ty) = do { mul_var <- newFlexiTyVarTy multiplicityTy+                                        ; return (Scaled mul_var ty) }+    linear_to_poly scaled_ty       = return scaled_ty -In order to desugar this generalised typing rule, we simply eta-expand:+tcInferPatSyn :: Name -> PatSyn -> TcM (HsExpr GhcTc, TcSigmaType)+tcInferPatSyn id_name ps+  = case patSynBuilderOcc ps of+       Just (expr,ty) -> return (expr,ty)+       Nothing        -> failWithTc (nonBidirectionalErr id_name) -    \a (x # p :: a) -> Just @a x+nonBidirectionalErr :: Outputable name => name -> TcRnMessage+nonBidirectionalErr name = TcRnUnknownMessage $ mkPlainError noHints $+  text "non-bidirectional pattern synonym"+  <+> quotes (ppr name) <+> text "used in an expression" -has the appropriate type. We insert these eta-expansion with WpFun wrappers.+{- Note [Typechecking data constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+As per Note [Polymorphisation of linear fields] in+GHC.Core.Multiplicity, linear fields of data constructors get a+polymorphic multiplicity when the data constructor is used as a term: -A small hitch: if the constructor is levity-polymorphic (unboxed tuples, sums,-certain newtypes with -XUnliftedNewtypes) then this strategy produces+    Just :: forall {p} a. a %p -> Maybe a -    \r1 r2 a b (x # p :: a) (y # q :: b) -> (# a, b #)+So at an occurrence of a data constructor we do the following,+mostly in tcInferDataCon: -Which has type+1. Get its type, say+    K :: forall (r :: RuntimeRep) (a :: TYPE r). a %1 -> T r a+   Note the %1: it is linear -    forall r1 r2 a b. a #p-> b #q-> (# a, b #)+2. We are going to return a ConLikeTc, thus:+     XExpr (ConLikeTc K [r,a] [Scaled p a])+      :: forall (r :: RuntimeRep) (a :: TYPE r). a %p -> T r a+   where 'p' is a fresh multiplicity unification variable. -Which violates the levity-polymorphism restriction see Note [Levity polymorphism-checking] in DsMonad.+   To get the returned ConLikeTc, we allocate a fresh multiplicity+   variable for each linear argument, and store the type, scaled by+   the fresh multiplicity variable in the ConLikeTc; along with+   the type of the ConLikeTc. This is done by linear_to_poly. -So we really must instantiate r1 and r2 rather than quantify over them.  For-simplicity, we just instantiate the entire type, as described in Note-[Instantiating stupid theta]. It breaks visible type application with unboxed-tuples, sums and levity-polymorphic newtypes, but this doesn't appear to be used-anywhere.+3. If the argument is not linear (perhaps explicitly declared as+   non-linear by the user), don't bother with this. -A better plan: let's force all representation variable to be *inferred*, so that-they are not subject to visible type applications. Then we can instantiate-inferred argument eagerly.+4. The (ConLikeTc K [r,a] [Scaled p a]) is later desugared by+   GHC.HsToCore.Expr.dsConLike to:+     (/\r (a :: TYPE r). \(x %p :: a). K @r @a x)+   which has the desired type given in the previous bullet.+   The 'p' is the multiplicity unification variable, which+   will by now have been unified to something, or defaulted in+   `GHC.Tc.Utils.Zonk.commitFlexi`. So it won't just be an+   (unbound) variable. +Wrinkles++* Note that the [TcType] is strictly redundant anyway; those are the+  type variables from the dataConUserTyVarBinders of the data constructor.+  Similarly in the [Scaled TcType] field of ConLikeTc, the types come directly+  from the data constructor.  The only bit that /isn't/ redundant is the+  fresh multiplicity variables!++  So an alternative would be to define ConLikeTc like this:+      | ConLikeTc [TcType]    -- Just the multiplicity variables+  But then the desugarer would need to repeat some of the work done here.+  So for now at least ConLikeTc records this strictly-redundant info.++* The lambda expression we produce in (4) can have representation-polymorphic+  arguments, as indeed in (/\r (a :: TYPE r). \(x %p :: a). K @r @a x),+  we have a lambda-bound variable x :: (a :: TYPE r).+  This goes against the representation polymorphism invariants given in+  Note [Representation polymorphism invariants] in GHC.Core. The trick is that+  this this lambda will always be instantiated in a way that upholds the invariants.+  This is achieved as follows:++    A. Any arguments to such lambda abstractions are guaranteed to have+       a fixed runtime representation. This is enforced in 'tcApp' by+       'matchActualFunTySigma'.++    B. If there are fewer arguments than there are bound term variables,+       hasFixedRuntimeRep_remainingValArgs will ensure that we are still+       instantiating at a representation-monomorphic type, e.g.++       ( /\r (a :: TYPE r). \ (x %p :: a). K @r @a x) @IntRep @Int#+         :: Int# -> T IntRep Int#++  We then rely on the simple optimiser to beta reduce the lambda.++* See Note [Instantiating stupid theta] for an extra wrinkle++ Note [Adding the implicit parameter to 'assert'] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The typechecker transforms (assert e1 e2) to (assertError e1 e2).@@ -1038,15 +930,33 @@  Note [Instantiating stupid theta] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Normally, when we infer the type of an Id, we don't instantiate,-because we wish to allow for visible type application later on.-But if a datacon has a stupid theta, we're a bit stuck. We need-to emit the stupid theta constraints with instantiated types. It's-difficult to defer this to the lazy instantiation, because a stupid-theta has no spot to put it in a type. So we just instantiate eagerly-in this case. Thus, users cannot use visible type application with-a data constructor sporting a stupid theta. I won't feel so bad for-the users that complain.+Consider a data type with a "stupid theta" (see+Note [The stupid context] in GHC.Core.DataCon):++  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++So we generate (ConLikeTc MkT [a] [Ord a, Maybe a]), with type+   forall a. Ord a => Maybe a -> T a++Now visible type application will work fine. But we desugar the+ConLikeTc to+   /\a \(d:Ord a) (x:Maybe a). MkT x+Notice that 'd' is dropped in this desugaring. We don't need it;+it was only there to generate a Wanted constraint. (That is why+it is stupid.)  To achieve this:++* We put the stupid-thata at the front of the list of argument+  types in ConLikeTc++* GHC.HsToCore.Expr.dsConLike generates /lambdas/ for all the+  arguments, but drops the stupid-theta arguments when building the+  /application/.++Nice. -}  {-@@ -1116,10 +1026,7 @@                                        [getRuntimeRep id_ty, id_ty]                     -- Warning for implicit lift (#17804)-        ; whenWOptM Opt_WarnImplicitLift $-            addWarnTc (Reason Opt_WarnImplicitLift)-                       (text "The variable" <+> quotes (ppr id) <+>-                        text "is implicitly lifted in the TH quotation")+        ; addDetailedDiagnostic (TcRnImplicitLift id)                     -- Update the pending splices         ; ps <- readMutVar ps_var@@ -1134,9 +1041,10 @@  checkCrossStageLifting _ _ _ = return () -polySpliceErr :: Id -> SDoc+polySpliceErr :: Id -> TcRnMessage polySpliceErr id-  = text "Can't splice the polymorphic local variable" <+> quotes (ppr id)+  = TcRnUnknownMessage $ mkPlainError noHints $+  text "Can't splice the polymorphic local variable" <+> quotes (ppr id)  {- Note [Lifting strings]@@ -1151,11 +1059,11 @@ If this check fails (which isn't impossible) we get another chance; see Note [Converting strings] in Convert.hs -Local record selectors-~~~~~~~~~~~~~~~~~~~~~~+Note [Local record selectors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Record selectors for TyCons in this module are ordinary local bindings, which show up as ATcIds rather than AGlobals.  So we need to check for-naughtiness in both branches.  c.f. TcTyClsBindings.mkAuxBinds.+naughtiness in both branches.  c.f. GHC.Tc.TyCl.Utils.mkRecSelBinds. -}  @@ -1186,7 +1094,7 @@                            Just env_ty -> zonkTcType env_ty                            Nothing     ->                              do { dumping <- doptM Opt_D_dump_tc_trace-                                ; MASSERT( dumping )+                                ; massert dumping                                 ; newFlexiTyVarTy liftedTypeKind }            ; let -- See Note [Splitting nested sigma types in mismatched                  --           function types]
GHC/Tc/Gen/HsType.hs view
@@ -1,4231 +1,4414 @@-{-# LANGUAGE CPP                 #-}-{-# LANGUAGE DataKinds           #-}-{-# LANGUAGE FlexibleContexts    #-}-{-# LANGUAGE RankNTypes          #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies        #-}-{-# LANGUAGE ViewPatterns        #-}--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}--{--(c) The University of Glasgow 2006-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998---}---- | Typechecking user-specified @MonoTypes@-module GHC.Tc.Gen.HsType (-        -- Type signatures-        kcClassSigType, tcClassSigType,-        tcHsSigType, tcHsSigWcType,-        tcHsPartialSigType,-        tcStandaloneKindSig,-        funsSigCtxt, addSigCtxt, pprSigCtxt,--        tcHsClsInstType,-        tcHsDeriv, tcDerivStrategy,-        tcHsTypeApp,-        UserTypeCtxt(..),-        bindImplicitTKBndrs_Tv, bindImplicitTKBndrs_Skol,-            bindImplicitTKBndrs_Q_Tv, bindImplicitTKBndrs_Q_Skol,-        bindExplicitTKBndrs_Tv, bindExplicitTKBndrs_Skol,-            bindExplicitTKBndrs_Q_Tv, bindExplicitTKBndrs_Q_Skol,--        bindOuterFamEqnTKBndrs, bindOuterFamEqnTKBndrs_Q_Tv,-        tcOuterTKBndrs, scopedSortOuter,-        bindOuterSigTKBndrs_Tv,-        tcExplicitTKBndrs,-        bindNamedWildCardBinders,--        -- Type checking type and class decls, and instances thereof-        bindTyClTyVars, tcFamTyPats,-        etaExpandAlgTyCon, tcbVisibilities,--          -- tyvars-        zonkAndScopedSort,--        -- Kind-checking types-        -- No kind generalisation, no checkValidType-        InitialKindStrategy(..),-        SAKS_or_CUSK(..),-        ContextKind(..),-        kcDeclHeader,-        tcHsLiftedType,   tcHsOpenType,-        tcHsLiftedTypeNC, tcHsOpenTypeNC,-        tcInferLHsType, tcInferLHsTypeKind, tcInferLHsTypeUnsaturated,-        tcCheckLHsType,-        tcHsContext, tcLHsPredType,--        kindGeneralizeAll, kindGeneralizeSome, kindGeneralizeNone,--        -- Sort-checking kinds-        tcLHsKindSig, checkDataKindSig, DataSort(..),-        checkClassKindSig,--        -- Multiplicity-        tcMult,--        -- Pattern type signatures-        tcHsPatSigType,-        HoleMode(..),--        -- Error messages-        funAppCtxt, addTyConFlavCtxt-   ) where--#include "HsVersions.h"--import GHC.Prelude--import GHC.Hs-import GHC.Rename.Utils-import GHC.Tc.Utils.Monad-import GHC.Tc.Types.Origin-import GHC.Core.Predicate-import GHC.Tc.Types.Constraint-import GHC.Tc.Utils.Env-import GHC.Tc.Utils.TcMType-import GHC.Tc.Validity-import GHC.Tc.Utils.Unify-import GHC.IfaceToCore-import GHC.Tc.Solver-import GHC.Tc.Utils.Zonk-import GHC.Core.TyCo.Rep-import GHC.Core.TyCo.Ppr-import GHC.Tc.Utils.TcType-import GHC.Tc.Utils.Instantiate ( tcInstInvisibleTyBinders, tcInstInvisibleTyBindersN,-                                  tcInstInvisibleTyBinder )-import GHC.Core.Type-import GHC.Builtin.Types.Prim-import GHC.Types.Name.Env-import GHC.Types.Name.Reader( lookupLocalRdrOcc )-import GHC.Types.Var-import GHC.Types.Var.Set-import GHC.Core.TyCon-import GHC.Core.ConLike-import GHC.Core.DataCon-import GHC.Core.Class-import GHC.Types.Name--- import GHC.Types.Name.Set-import GHC.Types.Var.Env-import GHC.Builtin.Types-import GHC.Types.Basic-import GHC.Types.SrcLoc-import GHC.Types.Unique-import GHC.Types.Unique.FM-import GHC.Types.Unique.Set-import GHC.Utils.Misc-import GHC.Types.Unique.Supply-import GHC.Utils.Outputable-import GHC.Utils.Panic-import GHC.Data.FastString-import GHC.Builtin.Names hiding ( wildCardName )-import GHC.Driver.Session-import qualified GHC.LanguageExtensions as LangExt--import GHC.Data.Maybe-import GHC.Data.Bag( unitBag )-import Data.List ( find )-import Control.Monad--{--        -----------------------------                General notes-        ------------------------------Unlike with expressions, type-checking types both does some checking and-desugars at the same time. This is necessary because we often want to perform-equality checks on the types right away, and it would be incredibly painful-to do this on un-desugared types. Luckily, desugared types are close enough-to HsTypes to make the error messages sane.--During type-checking, we perform as little validity checking as possible.-Generally, after type-checking, you will want to do validity checking, say-with GHC.Tc.Validity.checkValidType.--Validity checking-~~~~~~~~~~~~~~~~~-Some of the validity check could in principle be done by the kind checker,-but not all:--- During desugaring, we normalise by expanding type synonyms.  Only-  after this step can we check things like type-synonym saturation-  e.g.  type T k = k Int-        type S a = a-  Then (T S) is ok, because T is saturated; (T S) expands to (S Int);-  and then S is saturated.  This is a GHC extension.--- Similarly, also a GHC extension, we look through synonyms before complaining-  about the form of a class or instance declaration--- Ambiguity checks involve functional dependencies--Also, in a mutually recursive group of types, we can't look at the TyCon until we've-finished building the loop.  So to keep things simple, we postpone most validity-checking until step (3).--%************************************************************************-%*                                                                      *-              Check types AND do validity checking-*                                                                      *-************************************************************************--Note [Keeping implicitly quantified variables in order]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When the user implicitly quantifies over variables (say, in a type-signature), we need to come up with some ordering on these variables.-This is done by bumping the TcLevel, bringing the tyvars into scope,-and then type-checking the thing_inside. The constraints are all-wrapped in an implication, which is then solved. Finally, we can-zonk all the binders and then order them with scopedSort.--It's critical to solve before zonking and ordering in order to uncover-any unifications. You might worry that this eager solving could cause-trouble elsewhere. I don't think it will. Because it will solve only-in an increased TcLevel, it can't unify anything that was mentioned-elsewhere. Additionally, we require that the order of implicitly-quantified variables is manifest by the scope of these variables, so-we're not going to learn more information later that will help order-these variables.--Note [Recipe for checking a signature]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Kind-checking a user-written signature requires several steps:-- 0. Bump the TcLevel- 1.   Bind any lexically-scoped type variables.- 2.   Generate constraints.- 3. Solve constraints.- 4. Sort any implicitly-bound variables into dependency order- 5. Promote tyvars and/or kind-generalize.- 6. Zonk.- 7. Check validity.--Very similar steps also apply when kind-checking a type or class-declaration.--The general pattern looks something like this.  (But NB every-specific instance varies in one way or another!)--    do { (tclvl, wanted, (spec_tkvs, ty))-              <- pushLevelAndSolveEqualitiesX "tc_top_lhs_type" $-                 bindImplicitTKBndrs_Skol sig_vars              $-                 <kind-check the type>--       ; spec_tkvs <- zonkAndScopedSort spec_tkvs--       ; reportUnsolvedEqualities skol_info spec_tkvs tclvl wanted--       ; let ty1 = mkSpecForAllTys spec_tkvs ty-       ; kvs <- kindGeneralizeAll ty1--       ; final_ty <- zonkTcTypeToType (mkInfForAllTys kvs ty1)--       ; checkValidType final_ty--This pattern is repeated many times in GHC.Tc.Gen.HsType,-GHC.Tc.Gen.Sig, and GHC.Tc.TyCl, with variations.  In more detail:--* pushLevelAndSolveEqualitiesX (Step 0, step 3) bumps the TcLevel,-  calls the thing inside to generate constraints, solves those-  constraints as much as possible, returning the residual unsolved-  constraints in 'wanted'.--* bindImplicitTKBndrs_Skol (Step 1) binds the user-specified type-  variables E.g.  when kind-checking f :: forall a. F a -> a we must-  bring 'a' into scope before kind-checking (F a -> a)--* zonkAndScopedSort (Step 4) puts those user-specified variables in-  the dependency order.  (For "implicit" variables the order is no-  user-specified.  E.g.  forall (a::k1) (b::k2). blah k1 and k2 are-  implicitly brought into scope.--* reportUnsolvedEqualities (Step 3 continued) reports any unsolved-  equalities, carefully wrapping them in an implication that binds the-  skolems.  We can't do that in pushLevelAndSolveEqualitiesX because-  that function doesn't have access to the skolems.--* kindGeneralize (Step 5). See Note [Kind generalisation]--* The final zonkTcTypeToType must happen after promoting/generalizing,-  because promoting and generalizing fill in metavariables.---Doing Step 3 (constraint solving) eagerly (rather than building an-implication constraint and solving later) is necessary for several-reasons:--* Exactly as for Solver.simplifyInfer: when generalising, we solve all-  the constraints we can so that we don't have to quantify over them-  or, since we don't quantify over constraints in kinds, float them-  and inhibit generalisation.--* Most signatures also bring implicitly quantified variables into-  scope, and solving is necessary to get these in the right order-  (Step 4) see Note [Keeping implicitly quantified variables in-  order]).--Note [Kind generalisation]-~~~~~~~~~~~~~~~~~~~~~~~~~~-Step 5 of Note [Recipe for checking a signature], namely-kind-generalisation, is done by-    kindGeneraliseAll-    kindGeneraliseSome-    kindGeneraliseNone--Here, we have to deal with the fact that metatyvars generated in the-type will have a bumped TcLevel, because explicit foralls raise the-TcLevel. To avoid these variables from ever being visible in the-surrounding context, we must obey the following dictum:--  Every metavariable in a type must either be-    (A) generalized, or-    (B) promoted, or        See Note [Promotion in signatures]-    (C) a cause to error    See Note [Naughty quantification candidates]-                            in GHC.Tc.Utils.TcMType--There are three steps (look at kindGeneraliseSome):--1. candidateQTyVarsOfType finds the free variables of the type or kind,-   to generalise--2. filterConstrainedCandidates filters out candidates that appear-   in the unsolved 'wanteds', and promotes the ones that get filtered out-   thereby.--3. quantifyTyVars quantifies the remaining type variables--The kindGeneralize functions do not require pre-zonking; they zonk as they-go.--kindGeneraliseAll specialises for the case where step (2) is vacuous.-kindGeneraliseNone specialises for the case where we do no quantification,-but we must still promote.--If you are actually doing kind-generalization, you need to bump the-level before generating constraints, as we will only generalize-variables with a TcLevel higher than the ambient one.-Hence the "pushLevel" in pushLevelAndSolveEqualities.--Note [Promotion in signatures]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If an unsolved metavariable in a signature is not generalized-(because we're not generalizing the construct -- e.g., pattern-sig -- or because the metavars are constrained -- see kindGeneralizeSome)-we need to promote to maintain (WantedTvInv) of Note [TcLevel invariants]-in GHC.Tc.Utils.TcType. Note that promotion is identical in effect to generalizing-and the reinstantiating with a fresh metavariable at the current level.-So in some sense, we generalize *all* variables, but then re-instantiate-some of them.--Here is an example of why we must promote:-  foo (x :: forall a. a -> Proxy b) = ...--In the pattern signature, `b` is unbound, and will thus be brought into-scope. We do not know its kind: it will be assigned kappa[2]. Note that-kappa is at TcLevel 2, because it is invented under a forall. (A priori,-the kind kappa might depend on `a`, so kappa rightly has a higher TcLevel-than the surrounding context.) This kappa cannot be solved for while checking-the pattern signature (which is not kind-generalized). When we are checking-the *body* of foo, though, we need to unify the type of x with the argument-type of bar. At this point, the ambient TcLevel is 1, and spotting a-matavariable with level 2 would violate the (WantedTvInv) invariant of-Note [TcLevel invariants]. So, instead of kind-generalizing,-we promote the metavariable to level 1. This is all done in kindGeneralizeNone.---}--funsSigCtxt :: [LocatedN Name] -> UserTypeCtxt--- Returns FunSigCtxt, with no redundant-context-reporting,--- form a list of located names-funsSigCtxt (L _ name1 : _) = FunSigCtxt name1 False-funsSigCtxt []              = panic "funSigCtxt"--addSigCtxt :: Outputable hs_ty => UserTypeCtxt -> LocatedA hs_ty -> TcM a -> TcM a-addSigCtxt ctxt hs_ty thing_inside-  = setSrcSpan (getLocA hs_ty) $-    addErrCtxt (pprSigCtxt ctxt hs_ty) $-    thing_inside--pprSigCtxt :: Outputable hs_ty => UserTypeCtxt -> LocatedA hs_ty -> SDoc--- (pprSigCtxt ctxt <extra> <type>)--- prints    In the type signature for 'f':---              f :: <type>--- The <extra> is either empty or "the ambiguity check for"-pprSigCtxt ctxt hs_ty-  | Just n <- isSigMaybe ctxt-  = hang (text "In the type signature:")-       2 (pprPrefixOcc n <+> dcolon <+> ppr hs_ty)--  | otherwise-  = hang (text "In" <+> pprUserTypeCtxt ctxt <> colon)-       2 (ppr hs_ty)--tcHsSigWcType :: UserTypeCtxt -> LHsSigWcType GhcRn -> TcM Type--- This one is used when we have a LHsSigWcType, but in--- a place where wildcards aren't allowed. The renamer has--- already checked this, so we can simply ignore it.-tcHsSigWcType ctxt sig_ty = tcHsSigType ctxt (dropWildCards sig_ty)--kcClassSigType :: [LocatedN Name] -> LHsSigType GhcRn -> TcM ()--- This is a special form of tcClassSigType that is used during the--- kind-checking phase to infer the kind of class variables. Cf. tc_lhs_sig_type.--- Importantly, this does *not* kind-generalize. Consider---   class SC f where---     meth :: forall a (x :: f a). Proxy x -> ()--- When instantiating Proxy with kappa, we must unify kappa := f a. But we're--- still working out the kind of f, and thus f a will have a coercion in it.--- Coercions block unification (Note [Equalities with incompatible kinds] in--- TcCanonical) and so we fail to unify. If we try to kind-generalize, we'll--- end up promoting kappa to the top level (because kind-generalization is--- normally done right before adding a binding to the context), and then we--- can't set kappa := f a, because a is local.-kcClassSigType names-    sig_ty@(L _ (HsSig { sig_bndrs = hs_outer_bndrs, sig_body = hs_ty }))-  = addSigCtxt (funsSigCtxt names) sig_ty $-    do { _ <- bindOuterSigTKBndrs_Tv hs_outer_bndrs    $-              tcLHsType hs_ty liftedTypeKind-       ; return () }--tcClassSigType :: [LocatedN Name] -> LHsSigType GhcRn -> TcM Type--- Does not do validity checking-tcClassSigType names sig_ty-  = addSigCtxt sig_ctxt sig_ty $-    do { (implic, ty) <- tc_lhs_sig_type skol_info sig_ty (TheKind liftedTypeKind)-       ; emitImplication implic-       ; return ty }-       -- Do not zonk-to-Type, nor perform a validity check-       -- We are in a knot with the class and associated types-       -- Zonking and validity checking is done by tcClassDecl-       ---       -- No need to fail here if the type has an error:-       --   If we're in the kind-checking phase, the solveEqualities-       --     in kcTyClGroup catches the error-       --   If we're in the type-checking phase, the solveEqualities-       --     in tcClassDecl1 gets it-       -- Failing fast here degrades the error message in, e.g., tcfail135:-       --   class Foo f where-       --     baa :: f a -> f-       -- If we fail fast, we're told that f has kind `k1` when we wanted `*`.-       -- It should be that f has kind `k2 -> *`, but we never get a chance-       -- to run the solver where the kind of f is touchable. This is-       -- painfully delicate.-  where-    sig_ctxt = funsSigCtxt names-    skol_info = SigTypeSkol sig_ctxt--tcHsSigType :: UserTypeCtxt -> LHsSigType GhcRn -> TcM Type--- Does validity checking--- See Note [Recipe for checking a signature]-tcHsSigType ctxt sig_ty-  = addSigCtxt ctxt sig_ty $-    do { traceTc "tcHsSigType {" (ppr sig_ty)--          -- Generalise here: see Note [Kind generalisation]-       ; (implic, ty) <- tc_lhs_sig_type skol_info sig_ty  (expectedKindInCtxt ctxt)--       -- Float out constraints, failing fast if not possible-       -- See Note [Failure in local type signatures] in GHC.Tc.Solver-       ; traceTc "tcHsSigType 2" (ppr implic)-       ; simplifyAndEmitFlatConstraints (mkImplicWC (unitBag implic))--       ; ty <- zonkTcType ty-       ; checkValidType ctxt ty-       ; traceTc "end tcHsSigType }" (ppr ty)-       ; return ty }-  where-    skol_info = SigTypeSkol ctxt--tc_lhs_sig_type :: SkolemInfo -> LHsSigType GhcRn-               -> ContextKind -> TcM (Implication, TcType)--- Kind-checks/desugars an 'LHsSigType',---   solve equalities,---   and then kind-generalizes.--- This will never emit constraints, as it uses solveEqualities internally.--- No validity checking or zonking--- Returns also an implication for the unsolved constraints-tc_lhs_sig_type skol_info (L loc (HsSig { sig_bndrs = hs_outer_bndrs-                                       , sig_body = hs_ty })) ctxt_kind-  = setSrcSpanA loc $-    do { (tc_lvl, wanted, (outer_bndrs, ty))-              <- pushLevelAndSolveEqualitiesX "tc_lhs_sig_type" $-                 -- See Note [Failure in local type signatures]-                 tcOuterTKBndrs skol_info hs_outer_bndrs $-                 do { kind <- newExpectedKind ctxt_kind-                    ; tcLHsType hs_ty kind }-       -- Any remaining variables (unsolved in the solveEqualities)-       -- should be in the global tyvars, and therefore won't be quantified--       ; traceTc "tc_lhs_sig_type" (ppr hs_outer_bndrs $$ ppr outer_bndrs)-       ; (outer_tv_bndrs :: [InvisTVBinder]) <- scopedSortOuter outer_bndrs--       ; let ty1 = mkInvisForAllTys outer_tv_bndrs ty--       ; kvs <- kindGeneralizeSome wanted ty1--       -- Build an implication for any as-yet-unsolved kind equalities-       -- See Note [Skolem escape in type signatures]-       ; implic <- buildTvImplication skol_info kvs tc_lvl wanted--       ; return (implic, mkInfForAllTys kvs ty1) }--{- Note [Skolem escape in type signatures]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-tcHsSigType is tricky.  Consider (T11142)-  foo :: forall b. (forall k (a :: k). SameKind a b) -> ()-This is ill-kinded because of a nested skolem-escape.--That will show up as an un-solvable constraint in the implication-returned by buildTvImplication in tc_lhs_sig_type.  See Note [Skolem-escape prevention] in GHC.Tc.Utils.TcType for why it is unsolvable-(the unification variable for b's kind is untouchable).--Then, in GHC.Tc.Solver.simplifyAndEmitFlatConstraints (called from tcHsSigType)-we'll try to float out the constraint, be unable to do so, and fail.-See GHC.Tc.Solver Note [Failure in local type signatures] for more-detail on this.--The separation between tcHsSigType and tc_lhs_sig_type is because-tcClassSigType wants to use the latter, but *not* fail fast, because-there are skolems from the class decl which are in scope; but it's fine-not to because tcClassDecl1 has a solveEqualities wrapped around all-the tcClassSigType calls.--That's why tcHsSigType does simplifyAndEmitFlatConstraints (which-fails fast) but tcClassSigType just does emitImplication (which does-not).  Ugh.--c.f. see also Note [Skolem escape and forall-types]. The difference-is that we don't need to simplify at a forall type, only at the-top level of a signature.--}---- Does validity checking and zonking.-tcStandaloneKindSig :: LStandaloneKindSig GhcRn -> TcM (Name, Kind)-tcStandaloneKindSig (L _ (StandaloneKindSig _ (L _ name) ksig))-  = addSigCtxt ctxt ksig $-    do { kind <- tc_top_lhs_type KindLevel ctxt ksig-       ; checkValidType ctxt kind-       ; return (name, kind) }-  where-   ctxt = StandaloneKindSigCtxt name--tcTopLHsType :: UserTypeCtxt -> LHsSigType GhcRn -> TcM Type-tcTopLHsType ctxt lsig_ty-  = tc_top_lhs_type TypeLevel ctxt lsig_ty--tc_top_lhs_type :: TypeOrKind -> UserTypeCtxt -> LHsSigType GhcRn -> TcM Type--- tc_top_lhs_type is used for kind-checking top-level LHsSigTypes where---   we want to fully solve /all/ equalities, and report errors--- Does zonking, but not validity checking because it's used---   for things (like deriving and instances) that aren't---   ordinary types--- Used for both types and kinds-tc_top_lhs_type tyki ctxt (L loc sig_ty@(HsSig { sig_bndrs = hs_outer_bndrs-                                               , sig_body = body }))-  = setSrcSpanA loc $-    do { traceTc "tc_top_lhs_type {" (ppr sig_ty)-       ; (tclvl, wanted, (outer_bndrs, ty))-              <- pushLevelAndSolveEqualitiesX "tc_top_lhs_type"    $-                 tcOuterTKBndrs skol_info hs_outer_bndrs $-                 do { kind <- newExpectedKind (expectedKindInCtxt ctxt)-                    ; tc_lhs_type (mkMode tyki) body kind }--       ; outer_tv_bndrs <- scopedSortOuter outer_bndrs-       ; let ty1 = mkInvisForAllTys outer_tv_bndrs ty--       ; kvs <- kindGeneralizeAll ty1  -- "All" because it's a top-level type-       ; reportUnsolvedEqualities skol_info kvs tclvl wanted--       ; ze       <- mkEmptyZonkEnv NoFlexi-       ; final_ty <- zonkTcTypeToTypeX ze (mkInfForAllTys kvs ty1)-       ; traceTc "tc_top_lhs_type }" (vcat [ppr sig_ty, ppr final_ty])-       ; return final_ty }-  where-    skol_info = SigTypeSkol ctxt--------------------tcHsDeriv :: LHsSigType GhcRn -> TcM ([TyVar], Class, [Type], [Kind])--- Like tcHsSigType, but for the ...deriving( C t1 ty2 ) clause--- Returns the C, [ty1, ty2, and the kinds of C's remaining arguments--- E.g.    class C (a::*) (b::k->k)---         data T a b = ... deriving( C Int )---    returns ([k], C, [k, Int], [k->k])--- Return values are fully zonked-tcHsDeriv hs_ty-  = do { ty <- checkNoErrs $  -- Avoid redundant error report-                              -- with "illegal deriving", below-               tcTopLHsType DerivClauseCtxt hs_ty-       ; let (tvs, pred)    = splitForAllTyCoVars ty-             (kind_args, _) = splitFunTys (tcTypeKind pred)-       ; case getClassPredTys_maybe pred of-           Just (cls, tys) -> return (tvs, cls, tys, map scaledThing kind_args)-           Nothing -> failWithTc (text "Illegal deriving item" <+> quotes (ppr hs_ty)) }---- | Typecheck a deriving strategy. For most deriving strategies, this is a--- no-op, but for the @via@ strategy, this requires typechecking the @via@ type.-tcDerivStrategy ::-     Maybe (LDerivStrategy GhcRn)-     -- ^ The deriving strategy-  -> TcM (Maybe (LDerivStrategy GhcTc), [TyVar])-     -- ^ The typechecked deriving strategy and the tyvars that it binds-     -- (if using 'ViaStrategy').-tcDerivStrategy mb_lds-  = case mb_lds of-      Nothing -> boring_case Nothing-      Just (L loc ds) ->-        setSrcSpan loc $ do-          (ds', tvs) <- tc_deriv_strategy ds-          pure (Just (L loc ds'), tvs)-  where-    tc_deriv_strategy :: DerivStrategy GhcRn-                      -> TcM (DerivStrategy GhcTc, [TyVar])-    tc_deriv_strategy (StockStrategy    _)-                                     = boring_case (StockStrategy noExtField)-    tc_deriv_strategy (AnyclassStrategy _)-                                     = boring_case (AnyclassStrategy noExtField)-    tc_deriv_strategy (NewtypeStrategy  _)-                                     = boring_case (NewtypeStrategy noExtField)-    tc_deriv_strategy (ViaStrategy ty) = do-      ty' <- checkNoErrs $ tcTopLHsType DerivClauseCtxt ty-      let (via_tvs, via_pred) = splitForAllTyCoVars ty'-      pure (ViaStrategy via_pred, via_tvs)--    boring_case :: ds -> TcM (ds, [TyVar])-    boring_case ds = pure (ds, [])--tcHsClsInstType :: UserTypeCtxt    -- InstDeclCtxt or SpecInstCtxt-                -> LHsSigType GhcRn-                -> TcM Type--- Like tcHsSigType, but for a class instance declaration-tcHsClsInstType user_ctxt hs_inst_ty-  = setSrcSpan (getLocA hs_inst_ty) $-    do { -- Fail eagerly if tcTopLHsType fails.  We are at top level so-         -- these constraints will never be solved later. And failing-         -- eagerly avoids follow-on errors when checkValidInstance-         -- sees an unsolved coercion hole-         inst_ty <- checkNoErrs $-                    tcTopLHsType user_ctxt hs_inst_ty-       ; checkValidInstance user_ctxt hs_inst_ty inst_ty-       ; return inst_ty }--------------------------------------------------- | Type-check a visible type application-tcHsTypeApp :: LHsWcType GhcRn -> Kind -> TcM Type--- See Note [Recipe for checking a signature] in GHC.Tc.Gen.HsType-tcHsTypeApp wc_ty kind-  | HsWC { hswc_ext = sig_wcs, hswc_body = hs_ty } <- wc_ty-  = do { mode <- mkHoleMode TypeLevel HM_VTA-                 -- HM_VTA: See Note [Wildcards in visible type application]-       ; ty <- addTypeCtxt hs_ty                  $-               solveEqualities "tcHsTypeApp" $-               -- We are looking at a user-written type, very like a-               -- signature so we want to solve its equalities right now-               bindNamedWildCardBinders sig_wcs $ \ _ ->-               tc_lhs_type mode hs_ty kind--       -- We do not kind-generalize type applications: we just-       -- instantiate with exactly what the user says.-       -- See Note [No generalization in type application]-       -- We still must call kindGeneralizeNone, though, according-       -- to Note [Recipe for checking a signature]-       ; kindGeneralizeNone ty-       ; ty <- zonkTcType ty-       ; checkValidType TypeAppCtxt ty-       ; return ty }--{- Note [Wildcards in visible type application]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-A HsWildCardBndrs's hswc_ext now only includes /named/ wildcards, so-any unnamed wildcards stay unchanged in hswc_body.  When called in-tcHsTypeApp, tcCheckLHsType will call emitAnonTypeHole-on these anonymous wildcards. However, this would trigger-error/warning when an anonymous wildcard is passed in as a visible type-argument, which we do not want because users should be able to write-@_ to skip a instantiating a type variable variable without fuss. The-solution is to switch the PartialTypeSignatures flags here to let the-typechecker know that it's checking a '@_' and do not emit hole-constraints on it.  See related Note [Wildcards in visible kind-application] and Note [The wildcard story for types] in GHC.Hs.Type--Ugh!--Note [No generalization in type application]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We do not kind-generalize type applications. Imagine--  id @(Proxy Nothing)--If we kind-generalized, we would get--  id @(forall {k}. Proxy @(Maybe k) (Nothing @k))--which is very sneakily impredicative instantiation.--There is also the possibility of mentioning a wildcard-(`id @(Proxy _)`), which definitely should not be kind-generalized.---}--tcFamTyPats :: TyCon-            -> HsTyPats GhcRn                -- Patterns-            -> TcM (TcType, TcKind)          -- (lhs_type, lhs_kind)--- Check the LHS of a type/data family instance--- e.g.   type instance F ty1 .. tyn = ...--- Used for both type and data families-tcFamTyPats fam_tc hs_pats-  = do { traceTc "tcFamTyPats {" $-         vcat [ ppr fam_tc, text "arity:" <+> ppr fam_arity ]--       ; mode <- mkHoleMode TypeLevel HM_FamPat-                 -- HM_FamPat: See Note [Wildcards in family instances] in-                 -- GHC.Rename.Module-       ; let fun_ty = mkTyConApp fam_tc []-       ; (fam_app, res_kind) <- tcInferTyApps mode lhs_fun fun_ty hs_pats--       -- Hack alert: see Note [tcFamTyPats: zonking the result kind]-       ; res_kind <- zonkTcType res_kind--       ; traceTc "End tcFamTyPats }" $-         vcat [ ppr fam_tc, text "res_kind:" <+> ppr res_kind ]--       ; return (fam_app, res_kind) }-  where-    fam_name  = tyConName fam_tc-    fam_arity = tyConArity fam_tc-    lhs_fun   = noLocA (HsTyVar noAnn NotPromoted (noLocA fam_name))--{- Note [tcFamTyPats: zonking the result kind]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider (#19250)-    F :: forall k. k -> k-    type instance F (x :: Constraint) = ()--The tricky point is this:-  is that () an empty type tuple (() :: Type), or-  an empty constraint tuple (() :: Constraint)?-We work this out in a hacky way, by looking at the expected kind:-see Note [Inferring tuple kinds].--In this case, we kind-check the RHS using the kind gotten from the LHS:-see the call to tcCheckLHsType in tcTyFamInstEqnGuts in GHC.Tc.Tycl.--But we want the kind from the LHS to be /zonked/, so that when-kind-checking the RHS (tcCheckLHsType) we can "see" what we learned-from kind-checking the LHS (tcFamTyPats).  In our example above, the-type of the LHS is just `kappa` (by instantiating the forall k), but-then we learn (from x::Constraint) that kappa ~ Constraint.  We want-that info when kind-checking the RHS.--Easy solution: just zonk that return kind.  Of course this won't help-if there is lots of type-family reduction to do, but it works fine in-common cases.--}---{--************************************************************************-*                                                                      *-            The main kind checker: no validity checks here-*                                                                      *-************************************************************************--}------------------------------tcHsOpenType, tcHsLiftedType,-  tcHsOpenTypeNC, tcHsLiftedTypeNC :: LHsType GhcRn -> TcM TcType--- Used for type signatures--- Do not do validity checking-tcHsOpenType   hs_ty = addTypeCtxt hs_ty $ tcHsOpenTypeNC hs_ty-tcHsLiftedType hs_ty = addTypeCtxt hs_ty $ tcHsLiftedTypeNC hs_ty--tcHsOpenTypeNC   hs_ty = do { ek <- newOpenTypeKind; tcLHsType hs_ty ek }-tcHsLiftedTypeNC hs_ty = tcLHsType hs_ty liftedTypeKind---- Like tcHsType, but takes an expected kind-tcCheckLHsType :: LHsType GhcRn -> ContextKind -> TcM TcType-tcCheckLHsType hs_ty exp_kind-  = addTypeCtxt hs_ty $-    do { ek <- newExpectedKind exp_kind-       ; tcLHsType hs_ty ek }--tcInferLHsType :: LHsType GhcRn -> TcM TcType-tcInferLHsType hs_ty-  = do { (ty,_kind) <- tcInferLHsTypeKind hs_ty-       ; return ty }--tcInferLHsTypeKind :: LHsType GhcRn -> TcM (TcType, TcKind)--- Called from outside: set the context--- Eagerly instantiate any trailing invisible binders-tcInferLHsTypeKind lhs_ty@(L loc hs_ty)-  = addTypeCtxt lhs_ty $-    setSrcSpanA loc    $  -- Cover the tcInstInvisibleTyBinders-    do { (res_ty, res_kind) <- tc_infer_hs_type typeLevelMode hs_ty-       ; tcInstInvisibleTyBinders res_ty res_kind }-  -- See Note [Do not always instantiate eagerly in types]---- Used to check the argument of GHCi :kind--- Allow and report wildcards, e.g. :kind T _--- Do not saturate family applications: see Note [Dealing with :kind]--- Does not instantiate eagerly; See Note [Do not always instantiate eagerly in types]-tcInferLHsTypeUnsaturated :: LHsType GhcRn -> TcM (TcType, TcKind)-tcInferLHsTypeUnsaturated hs_ty-  = addTypeCtxt hs_ty $-    do { mode <- mkHoleMode TypeLevel HM_Sig  -- Allow and report holes-       ; case splitHsAppTys (unLoc hs_ty) of-           Just (hs_fun_ty, hs_args)-              -> do { (fun_ty, _ki) <- tcInferTyAppHead mode hs_fun_ty-                    ; tcInferTyApps_nosat mode hs_fun_ty fun_ty hs_args }-                      -- Notice the 'nosat'; do not instantiate trailing-                      -- invisible arguments of a type family.-                      -- See Note [Dealing with :kind]-           Nothing -> tc_infer_lhs_type mode hs_ty }--{- Note [Dealing with :kind]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this GHCi command-  ghci> type family F :: Either j k-  ghci> :kind F-  F :: forall {j,k}. Either j k--We will only get the 'forall' if we /refrain/ from saturating those-invisible binders. But generally we /do/ saturate those invisible-binders (see tcInferTyApps), and we want to do so for nested application-even in GHCi.  Consider for example (#16287)-  ghci> type family F :: k-  ghci> data T :: (forall k. k) -> Type-  ghci> :kind T F-We want to reject this. It's just at the very top level that we want-to switch off saturation.--So tcInferLHsTypeUnsaturated does a little special case for top level-applications.  Actually the common case is a bare variable, as above.--Note [Do not always instantiate eagerly in types]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Terms are eagerly instantiated. This means that if you say--  x = id--then `id` gets instantiated to have type alpha -> alpha. The variable-alpha is then unconstrained and regeneralized. But we cannot do this-in types, as we have no type-level lambda. So, when we are sure-that we will not want to regeneralize later -- because we are done-checking a type, for example -- we can instantiate. But we do not-instantiate at variables, nor do we in tcInferLHsTypeUnsaturated,-which is used by :kind in GHCi.--************************************************************************-*                                                                      *-      Type-checking modes-*                                                                      *-************************************************************************--The kind-checker is parameterised by a TcTyMode, which contains some-information about where we're checking a type.--The renamer issues errors about what it can. All errors issued here must-concern things that the renamer can't handle.---}--tcMult :: HsArrow GhcRn -> TcM Mult-tcMult hc = tc_mult typeLevelMode hc---- | Info about the context in which we're checking a type. Currently,--- differentiates only between types and kinds, but this will likely--- grow, at least to include the distinction between patterns and--- not-patterns.------ To find out where the mode is used, search for 'mode_tyki'------ This data type is purely local, not exported from this module-data TcTyMode-  = TcTyMode { mode_tyki :: TypeOrKind-             , mode_holes :: HoleInfo   }---- See Note [Levels for wildcards]--- Nothing <=> no wildcards expected-type HoleInfo = Maybe (TcLevel, HoleMode)---- HoleMode says how to treat the occurrences--- of anonymous wildcards; see tcAnonWildCardOcc-data HoleMode = HM_Sig      -- Partial type signatures: f :: _ -> Int-              | HM_FamPat   -- Family instances: F _ Int = Bool-              | HM_VTA      -- Visible type and kind application:-                            --   f @(Maybe _)-                            --   Maybe @(_ -> _)-              | HM_TyAppPat -- Visible type applications in patterns:-                            --   foo (Con @_ @t x) = ...-                            --   case x of Con @_ @t v -> ...--mkMode :: TypeOrKind -> TcTyMode-mkMode tyki = TcTyMode { mode_tyki = tyki, mode_holes = Nothing }--typeLevelMode, kindLevelMode :: TcTyMode--- These modes expect no wildcards (holes) in the type-kindLevelMode = mkMode KindLevel-typeLevelMode = mkMode TypeLevel--mkHoleMode :: TypeOrKind -> HoleMode -> TcM TcTyMode-mkHoleMode tyki hm-  = do { lvl <- getTcLevel-       ; return (TcTyMode { mode_tyki  = tyki-                          , mode_holes = Just (lvl,hm) }) }--instance Outputable HoleMode where-  ppr HM_Sig      = text "HM_Sig"-  ppr HM_FamPat   = text "HM_FamPat"-  ppr HM_VTA      = text "HM_VTA"-  ppr HM_TyAppPat = text "HM_TyAppPat"--instance Outputable TcTyMode where-  ppr (TcTyMode { mode_tyki = tyki, mode_holes = hm })-    = text "TcTyMode" <+> braces (sep [ ppr tyki <> comma-                                      , ppr hm ])--{--Note [Bidirectional type checking]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In expressions, whenever we see a polymorphic identifier, say `id`, we are-free to instantiate it with metavariables, knowing that we can always-re-generalize with type-lambdas when necessary. For example:--  rank2 :: (forall a. a -> a) -> ()-  x = rank2 id--When checking the body of `x`, we can instantiate `id` with a metavariable.-Then, when we're checking the application of `rank2`, we notice that we really-need a polymorphic `id`, and then re-generalize over the unconstrained-metavariable.--In types, however, we're not so lucky, because *we cannot re-generalize*!-There is no lambda. So, we must be careful only to instantiate at the last-possible moment, when we're sure we're never going to want the lost polymorphism-again. This is done in calls to tcInstInvisibleTyBinders.--To implement this behavior, we use bidirectional type checking, where we-explicitly think about whether we know the kind of the type we're checking-or not. Note that there is a difference between not knowing a kind and-knowing a metavariable kind: the metavariables are TauTvs, and cannot become-forall-quantified kinds. Previously (before dependent types), there were-no higher-rank kinds, and so we could instantiate early and be sure that-no types would have polymorphic kinds, and so we could always assume that-the kind of a type was a fresh metavariable. Not so anymore, thus the-need for two algorithms.--For HsType forms that can never be kind-polymorphic, we implement only the-"down" direction, where we safely assume a metavariable kind. For HsType forms-that *can* be kind-polymorphic, we implement just the "up" (functions with-"infer" in their name) version, as we gain nothing by also implementing the-"down" version.--Note [Future-proofing the type checker]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-As discussed in Note [Bidirectional type checking], each HsType form is-handled in *either* tc_infer_hs_type *or* tc_hs_type. These functions-are mutually recursive, so that either one can work for any type former.-But, we want to make sure that our pattern-matches are complete. So,-we have a bunch of repetitive code just so that we get warnings if we're-missing any patterns.---}----------------------------------------------- | Check and desugar a type, returning the core type and its--- possibly-polymorphic kind. Much like 'tcInferRho' at the expression--- level.-tc_infer_lhs_type :: TcTyMode -> LHsType GhcRn -> TcM (TcType, TcKind)-tc_infer_lhs_type mode (L span ty)-  = setSrcSpanA span $-    tc_infer_hs_type mode ty-------------------------------- | Call 'tc_infer_hs_type' and check its result against an expected kind.-tc_infer_hs_type_ek :: HasDebugCallStack => TcTyMode -> HsType GhcRn -> TcKind -> TcM TcType-tc_infer_hs_type_ek mode hs_ty ek-  = do { (ty, k) <- tc_infer_hs_type mode hs_ty-       ; checkExpectedKind hs_ty ty k ek }-------------------------------- | Infer the kind of a type and desugar. This is the "up" type-checker,--- as described in Note [Bidirectional type checking]-tc_infer_hs_type :: TcTyMode -> HsType GhcRn -> TcM (TcType, TcKind)--tc_infer_hs_type mode (HsParTy _ t)-  = tc_infer_lhs_type mode t--tc_infer_hs_type mode ty-  | Just (hs_fun_ty, hs_args) <- splitHsAppTys ty-  = do { (fun_ty, _ki) <- tcInferTyAppHead mode hs_fun_ty-       ; tcInferTyApps mode hs_fun_ty fun_ty hs_args }--tc_infer_hs_type mode (HsKindSig _ ty sig)-  = do { let mode' = mode { mode_tyki = KindLevel }-       ; sig' <- tc_lhs_kind_sig mode' KindSigCtxt sig-                 -- We must typecheck the kind signature, and solve all-                 -- its equalities etc; from this point on we may do-                 -- things like instantiate its foralls, so it needs-                 -- to be fully determined (#14904)-       ; traceTc "tc_infer_hs_type:sig" (ppr ty $$ ppr sig')-       ; ty' <- tc_lhs_type mode ty sig'-       ; return (ty', sig') }---- HsSpliced is an annotation produced by 'GHC.Rename.Splice.rnSpliceType' to communicate--- the splice location to the typechecker. Here we skip over it in order to have--- the same kind inferred for a given expression whether it was produced from--- splices or not.------ See Note [Delaying modFinalizers in untyped splices].-tc_infer_hs_type mode (HsSpliceTy _ (HsSpliced _ _ (HsSplicedTy ty)))-  = tc_infer_hs_type mode ty--tc_infer_hs_type mode (HsDocTy _ ty _) = tc_infer_lhs_type mode ty---- See Note [Typechecking HsCoreTys]-tc_infer_hs_type _ (XHsType ty)-  = do env <- getLclEnv-       -- Raw uniques since we go from NameEnv to TvSubstEnv.-       let subst_prs :: [(Unique, TcTyVar)]-           subst_prs = [ (getUnique nm, tv)-                       | ATyVar nm tv <- nameEnvElts (tcl_env env) ]-           subst = mkTvSubst-                     (mkInScopeSet $ mkVarSet $ map snd subst_prs)-                     (listToUFM_Directly $ map (liftSnd mkTyVarTy) subst_prs)-           ty' = substTy subst ty-       return (ty', tcTypeKind ty')--tc_infer_hs_type _ (HsExplicitListTy _ _ tys)-  | null tys  -- this is so that we can use visible kind application with '[]-              -- e.g ... '[] @Bool-  = return (mkTyConTy promotedNilDataCon,-            mkSpecForAllTys [alphaTyVar] $ mkListTy alphaTy)--tc_infer_hs_type mode other_ty-  = do { kv <- newMetaKindVar-       ; ty' <- tc_hs_type mode other_ty kv-       ; return (ty', kv) }--{--Note [Typechecking HsCoreTys]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-HsCoreTy is an escape hatch that allows embedding Core Types in HsTypes.-As such, there's not much to be done in order to typecheck an HsCoreTy,-since it's already been typechecked to some extent. There is one thing that-we must do, however: we must substitute the type variables from the tcl_env.-To see why, consider GeneralizedNewtypeDeriving, which is one of the main-clients of HsCoreTy (example adapted from #14579):--  newtype T a = MkT a deriving newtype Eq--This will produce an InstInfo GhcPs that looks roughly like this:--  instance forall a_1. Eq a_1 => Eq (T a_1) where-    (==) = coerce @(  a_1 ->   a_1 -> Bool) -- The type within @(...) is an HsCoreTy-                  @(T a_1 -> T a_1 -> Bool) -- So is this-                  (==)--This is then fed into the renamer. Since all of the type variables in this-InstInfo use Exact RdrNames, the resulting InstInfo GhcRn looks basically-identical. Things get more interesting when the InstInfo is fed into the-typechecker, however. GHC will first generate fresh skolems to instantiate-the instance-bound type variables with. In the example above, we might generate-the skolem a_2 and use that to instantiate a_1, which extends the local type-environment (tcl_env) with [a_1 :-> a_2]. This gives us:--  instance forall a_2. Eq a_2 => Eq (T a_2) where ...--To ensure that the body of this instance is well scoped, every occurrence of-the `a` type variable should refer to a_2, the new skolem. However, the-HsCoreTys mention a_1, not a_2. Luckily, the tcl_env provides exactly the-substitution we need ([a_1 :-> a_2]) to fix up the scoping. We apply this-substitution to each HsCoreTy and all is well:--  instance forall a_2. Eq a_2 => Eq (T a_2) where-    (==) = coerce @(  a_2 ->   a_2 -> Bool)-                  @(T a_2 -> T a_2 -> Bool)-                  (==)--}---------------------------------------------tcLHsType :: LHsType GhcRn -> TcKind -> TcM TcType-tcLHsType hs_ty exp_kind-  = tc_lhs_type typeLevelMode hs_ty exp_kind--tc_lhs_type :: TcTyMode -> LHsType GhcRn -> TcKind -> TcM TcType-tc_lhs_type mode (L span ty) exp_kind-  = setSrcSpanA span $-    tc_hs_type mode ty exp_kind--tc_hs_type :: TcTyMode -> HsType GhcRn -> TcKind -> TcM TcType--- See Note [Bidirectional type checking]--tc_hs_type mode (HsParTy _ ty)   exp_kind = tc_lhs_type mode ty exp_kind-tc_hs_type mode (HsDocTy _ ty _) exp_kind = tc_lhs_type mode ty exp_kind-tc_hs_type _ ty@(HsBangTy _ bang _) _-    -- While top-level bangs at this point are eliminated (eg !(Maybe Int)),-    -- other kinds of bangs are not (eg ((!Maybe) Int)). These kinds of-    -- bangs are invalid, so fail. (#7210, #14761)-    = do { let bangError err = failWith $-                 text "Unexpected" <+> text err <+> text "annotation:" <+> ppr ty $$-                 text err <+> text "annotation cannot appear nested inside a type"-         ; case bang of-             HsSrcBang _ SrcUnpack _           -> bangError "UNPACK"-             HsSrcBang _ SrcNoUnpack _         -> bangError "NOUNPACK"-             HsSrcBang _ NoSrcUnpack SrcLazy   -> bangError "laziness"-             HsSrcBang _ _ _                   -> bangError "strictness" }-tc_hs_type _ ty@(HsRecTy {})      _-      -- Record types (which only show up temporarily in constructor-      -- signatures) should have been removed by now-    = failWithTc (text "Record syntax is illegal here:" <+> ppr ty)---- HsSpliced is an annotation produced by 'GHC.Rename.Splice.rnSpliceType'.--- Here we get rid of it and add the finalizers to the global environment--- while capturing the local environment.------ See Note [Delaying modFinalizers in untyped splices].-tc_hs_type mode (HsSpliceTy _ (HsSpliced _ mod_finalizers (HsSplicedTy ty)))-           exp_kind-  = do addModFinalizersWithLclEnv mod_finalizers-       tc_hs_type mode ty exp_kind---- This should never happen; type splices are expanded by the renamer-tc_hs_type _ ty@(HsSpliceTy {}) _exp_kind-  = failWithTc (text "Unexpected type splice:" <+> ppr ty)------------ Functions and applications-tc_hs_type mode (HsFunTy _ mult ty1 ty2) exp_kind-  = tc_fun_type mode mult ty1 ty2 exp_kind--tc_hs_type mode (HsOpTy _ ty1 (L _ op) ty2) exp_kind-  | op `hasKey` funTyConKey-  = tc_fun_type mode (HsUnrestrictedArrow NormalSyntax) ty1 ty2 exp_kind----------- Foralls-tc_hs_type mode (HsForAllTy { hst_tele = tele, hst_body = ty }) exp_kind-  = do { (tv_bndrs, ty') <- tcTKTelescope mode tele $-                            tc_lhs_type mode ty exp_kind-                 -- Pass on the mode from the type, to any wildcards-                 -- in kind signatures on the forall'd variables-                 -- e.g.      f :: _ -> Int -> forall (a :: _). blah-                 -- Why exp_kind?  See Note [Body kind of HsForAllTy]--       -- Do not kind-generalise here!  See Note [Kind generalisation]--       ; return (mkForAllTys tv_bndrs ty') }--tc_hs_type mode (HsQualTy { hst_ctxt = ctxt, hst_body = rn_ty }) exp_kind-  | null (fromMaybeContext ctxt)-  = tc_lhs_type mode rn_ty exp_kind--  -- See Note [Body kind of a HsQualTy]-  | tcIsConstraintKind exp_kind-  = do { ctxt' <- tc_hs_context mode ctxt-       ; ty'   <- tc_lhs_type mode rn_ty constraintKind-       ; return (mkPhiTy ctxt' ty') }--  | otherwise-  = do { ctxt' <- tc_hs_context mode ctxt--       ; ek <- newOpenTypeKind  -- The body kind (result of the function) can-                                -- be TYPE r, for any r, hence newOpenTypeKind-       ; ty' <- tc_lhs_type mode rn_ty ek-       ; checkExpectedKind (unLoc rn_ty) (mkPhiTy ctxt' ty')-                           liftedTypeKind exp_kind }----------- Lists, arrays, and tuples-tc_hs_type mode rn_ty@(HsListTy _ elt_ty) exp_kind-  = do { tau_ty <- tc_lhs_type mode elt_ty liftedTypeKind-       ; checkWiredInTyCon listTyCon-       ; checkExpectedKind rn_ty (mkListTy tau_ty) liftedTypeKind exp_kind }---- See Note [Distinguishing tuple kinds] in GHC.Hs.Type--- See Note [Inferring tuple kinds]-tc_hs_type mode rn_ty@(HsTupleTy _ HsBoxedOrConstraintTuple hs_tys) exp_kind-     -- (NB: not zonking before looking at exp_k, to avoid left-right bias)-  | Just tup_sort <- tupKindSort_maybe exp_kind-  = traceTc "tc_hs_type tuple" (ppr hs_tys) >>-    tc_tuple rn_ty mode tup_sort hs_tys exp_kind-  | otherwise-  = do { traceTc "tc_hs_type tuple 2" (ppr hs_tys)-       ; (tys, kinds) <- mapAndUnzipM (tc_infer_lhs_type mode) hs_tys-       ; kinds <- mapM zonkTcType kinds-           -- Infer each arg type separately, because errors can be-           -- confusing if we give them a shared kind.  Eg #7410-           -- (Either Int, Int), we do not want to get an error saying-           -- "the second argument of a tuple should have kind *->*"--       ; let (arg_kind, tup_sort)-               = case [ (k,s) | k <- kinds-                              , Just s <- [tupKindSort_maybe k] ] of-                    ((k,s) : _) -> (k,s)-                    [] -> (liftedTypeKind, BoxedTuple)-         -- In the [] case, it's not clear what the kind is, so guess *--       ; tys' <- sequence [ setSrcSpanA loc $-                            checkExpectedKind hs_ty ty kind arg_kind-                          | ((L loc hs_ty),ty,kind) <- zip3 hs_tys tys kinds ]--       ; finish_tuple rn_ty tup_sort tys' (map (const arg_kind) tys') exp_kind }---tc_hs_type mode rn_ty@(HsTupleTy _ HsUnboxedTuple tys) exp_kind-  = tc_tuple rn_ty mode UnboxedTuple tys exp_kind--tc_hs_type mode rn_ty@(HsSumTy _ hs_tys) exp_kind-  = do { let arity = length hs_tys-       ; arg_kinds <- mapM (\_ -> newOpenTypeKind) hs_tys-       ; tau_tys   <- zipWithM (tc_lhs_type mode) hs_tys arg_kinds-       ; let arg_reps = map kindRep arg_kinds-             arg_tys  = arg_reps ++ tau_tys-             sum_ty   = mkTyConApp (sumTyCon arity) arg_tys-             sum_kind = unboxedSumKind arg_reps-       ; checkExpectedKind rn_ty sum_ty sum_kind exp_kind-       }----------- Promoted lists and tuples-tc_hs_type mode rn_ty@(HsExplicitListTy _ _ tys) exp_kind-  = do { tks <- mapM (tc_infer_lhs_type mode) tys-       ; (taus', kind) <- unifyKinds tys tks-       ; let ty = (foldr (mk_cons kind) (mk_nil kind) taus')-       ; checkExpectedKind rn_ty ty (mkListTy kind) exp_kind }-  where-    mk_cons k a b = mkTyConApp (promoteDataCon consDataCon) [k, a, b]-    mk_nil  k     = mkTyConApp (promoteDataCon nilDataCon) [k]--tc_hs_type mode rn_ty@(HsExplicitTupleTy _ tys) exp_kind-  -- using newMetaKindVar means that we force instantiations of any polykinded-  -- types. At first, I just used tc_infer_lhs_type, but that led to #11255.-  = do { ks   <- replicateM arity newMetaKindVar-       ; taus <- zipWithM (tc_lhs_type mode) tys ks-       ; let kind_con   = tupleTyCon           Boxed arity-             ty_con     = promotedTupleDataCon Boxed arity-             tup_k      = mkTyConApp kind_con ks-       ; checkTupSize arity-       ; checkExpectedKind rn_ty (mkTyConApp ty_con (ks ++ taus)) tup_k exp_kind }-  where-    arity = length tys----------- Constraint types-tc_hs_type mode rn_ty@(HsIParamTy _ (L _ n) ty) exp_kind-  = do { MASSERT( isTypeLevel (mode_tyki mode) )-       ; ty' <- tc_lhs_type mode ty liftedTypeKind-       ; let n' = mkStrLitTy $ hsIPNameFS n-       ; ipClass <- tcLookupClass ipClassName-       ; checkExpectedKind rn_ty (mkClassPred ipClass [n',ty'])-                           constraintKind exp_kind }--tc_hs_type _ rn_ty@(HsStarTy _ _) exp_kind-  -- Desugaring 'HsStarTy' to 'Data.Kind.Type' here means that we don't have to-  -- handle it in 'coreView' and 'tcView'.-  = checkExpectedKind rn_ty liftedTypeKind liftedTypeKind exp_kind----------- Literals-tc_hs_type _ rn_ty@(HsTyLit _ (HsNumTy _ n)) exp_kind-  = do { checkWiredInTyCon naturalTyCon-       ; checkExpectedKind rn_ty (mkNumLitTy n) naturalTy exp_kind }--tc_hs_type _ rn_ty@(HsTyLit _ (HsStrTy _ s)) exp_kind-  = do { checkWiredInTyCon typeSymbolKindCon-       ; checkExpectedKind rn_ty (mkStrLitTy s) typeSymbolKind exp_kind }-tc_hs_type _ rn_ty@(HsTyLit _ (HsCharTy _ c)) exp_kind-  = do { checkWiredInTyCon charTyCon-       ; checkExpectedKind rn_ty (mkCharLitTy c) charTy exp_kind }----------- Wildcards--tc_hs_type mode ty@(HsWildCardTy _)        ek-  = tcAnonWildCardOcc NoExtraConstraint mode ty ek----------- Potentially kind-polymorphic types: call the "up" checker--- See Note [Future-proofing the type checker]-tc_hs_type mode ty@(HsTyVar {})            ek = tc_infer_hs_type_ek mode ty ek-tc_hs_type mode ty@(HsAppTy {})            ek = tc_infer_hs_type_ek mode ty ek-tc_hs_type mode ty@(HsAppKindTy{})         ek = tc_infer_hs_type_ek mode ty ek-tc_hs_type mode ty@(HsOpTy {})             ek = tc_infer_hs_type_ek mode ty ek-tc_hs_type mode ty@(HsKindSig {})          ek = tc_infer_hs_type_ek mode ty ek-tc_hs_type mode ty@(XHsType {})            ek = tc_infer_hs_type_ek mode ty ek--{--Note [Variable Specificity and Forall Visibility]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-A HsForAllTy contains an HsForAllTelescope to denote the visibility of the forall-binder. Furthermore, each invisible type variable binder also has a-Specificity. Together, these determine the variable binders (ArgFlag) for each-variable in the generated ForAllTy type.--This table summarises this relation:------------------------------------------------------------------------------| User-written type         HsForAllTelescope   Specificity        ArgFlag-|----------------------------------------------------------------------------| f :: forall a. type       HsForAllInvis       SpecifiedSpec      Specified-| f :: forall {a}. type     HsForAllInvis       InferredSpec       Inferred-| f :: forall a -> type     HsForAllVis         SpecifiedSpec      Required-| f :: forall {a} -> type   HsForAllVis         InferredSpec       /-|   This last form is non-sensical and is thus rejected.-------------------------------------------------------------------------------For more information regarding the interpretation of the resulting ArgFlag, see-Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in "GHC.Core.TyCo.Rep".--}---------------------------------------------tc_mult :: TcTyMode -> HsArrow GhcRn -> TcM Mult-tc_mult mode ty = tc_lhs_type mode (arrowToHsType ty) multiplicityTy--------------------------------------------tc_fun_type :: TcTyMode -> HsArrow GhcRn -> LHsType GhcRn -> LHsType GhcRn -> TcKind-            -> TcM TcType-tc_fun_type mode mult ty1 ty2 exp_kind = case mode_tyki mode of-  TypeLevel ->-    do { arg_k <- newOpenTypeKind-       ; res_k <- newOpenTypeKind-       ; ty1' <- tc_lhs_type mode ty1 arg_k-       ; ty2' <- tc_lhs_type mode ty2 res_k-       ; mult' <- tc_mult mode mult-       ; checkExpectedKind (HsFunTy noAnn mult ty1 ty2) (mkVisFunTy mult' ty1' ty2')-                           liftedTypeKind exp_kind }-  KindLevel ->  -- no representation polymorphism in kinds. yet.-    do { ty1' <- tc_lhs_type mode ty1 liftedTypeKind-       ; ty2' <- tc_lhs_type mode ty2 liftedTypeKind-       ; mult' <- tc_mult mode mult-       ; checkExpectedKind (HsFunTy noAnn mult ty1 ty2) (mkVisFunTy mult' ty1' ty2')-                           liftedTypeKind exp_kind }--{- Note [Skolem escape and forall-types]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-See also Note [Checking telescopes].--Consider-  f :: forall a. (forall kb (b :: kb). Proxy '[a, b]) -> ()--The Proxy '[a,b] forces a and b to have the same kind.  But a's-kind must be bound outside the 'forall a', and hence escapes.-We discover this by building an implication constraint for-each forall.  So the inner implication constraint will look like-    forall kb (b::kb).  kb ~ ka-where ka is a's kind.  We can't unify these two, /even/ if ka is-unification variable, because it would be untouchable inside-this inner implication.--That's what the pushLevelAndCaptureConstraints, plus subsequent-buildTvImplication/emitImplication is all about, when kind-checking-HsForAllTy.--Note that--* We don't need to /simplify/ the constraints here-  because we aren't generalising. We just capture them.--* We can't use emitResidualTvConstraint, because that has a fast-path-  for empty constraints.  We can't take that fast path here, because-  we must do the bad-telescope check even if there are no inner wanted-  constraints. See Note [Checking telescopes] in-  GHC.Tc.Types.Constraint.  Lacking this check led to #16247.--}--{- *********************************************************************-*                                                                      *-                Tuples-*                                                                      *-********************************************************************* -}------------------------------tupKindSort_maybe :: TcKind -> Maybe TupleSort-tupKindSort_maybe k-  | Just (k', _) <- splitCastTy_maybe k = tupKindSort_maybe k'-  | Just k'      <- tcView k            = tupKindSort_maybe k'-  | tcIsConstraintKind k = Just ConstraintTuple-  | tcIsLiftedTypeKind k   = Just BoxedTuple-  | otherwise            = Nothing--tc_tuple :: HsType GhcRn -> TcTyMode -> TupleSort -> [LHsType GhcRn] -> TcKind -> TcM TcType-tc_tuple rn_ty mode tup_sort tys exp_kind-  = do { arg_kinds <- case tup_sort of-           BoxedTuple      -> return (replicate arity liftedTypeKind)-           UnboxedTuple    -> replicateM arity newOpenTypeKind-           ConstraintTuple -> return (replicate arity constraintKind)-       ; tau_tys <- zipWithM (tc_lhs_type mode) tys arg_kinds-       ; finish_tuple rn_ty tup_sort tau_tys arg_kinds exp_kind }-  where-    arity   = length tys--finish_tuple :: HsType GhcRn-             -> TupleSort-             -> [TcType]    -- ^ argument types-             -> [TcKind]    -- ^ of these kinds-             -> TcKind      -- ^ expected kind of the whole tuple-             -> TcM TcType-finish_tuple rn_ty tup_sort tau_tys tau_kinds exp_kind = do-  traceTc "finish_tuple" (ppr tup_sort $$ ppr tau_kinds $$ ppr exp_kind)-  case tup_sort of-    ConstraintTuple-      |  [tau_ty] <- tau_tys-         -- Drop any uses of 1-tuple constraints here.-         -- See Note [Ignore unary constraint tuples]-      -> check_expected_kind tau_ty constraintKind-      |  otherwise-      -> do let tycon = cTupleTyCon arity-            checkCTupSize arity-            check_expected_kind (mkTyConApp tycon tau_tys) constraintKind-    BoxedTuple -> do-      let tycon = tupleTyCon Boxed arity-      checkTupSize arity-      checkWiredInTyCon tycon-      check_expected_kind (mkTyConApp tycon tau_tys) liftedTypeKind-    UnboxedTuple -> do-      let tycon    = tupleTyCon Unboxed arity-          tau_reps = map kindRep tau_kinds-          -- See also Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon-          arg_tys  = tau_reps ++ tau_tys-          res_kind = unboxedTupleKind tau_reps-      checkTupSize arity-      check_expected_kind (mkTyConApp tycon arg_tys) res_kind-  where-    arity = length tau_tys-    check_expected_kind ty act_kind =-      checkExpectedKind rn_ty ty act_kind exp_kind--{--Note [Ignore unary constraint tuples]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-GHC provides unary tuples and unboxed tuples (see Note [One-tuples] in-GHC.Builtin.Types) but does *not* provide unary constraint tuples. Why? First,-recall the definition of a unary tuple data type:--  data Solo a = Solo a--Note that `Solo a` is *not* the same thing as `a`, since Solo is boxed and-lazy. Therefore, the presence of `Solo` matters semantically. On the other-hand, suppose we had a unary constraint tuple:--  class a => Solo% a--This compiles down a newtype (i.e., a cast) in Core, so `Solo% a` is-semantically equivalent to `a`. Therefore, a 1-tuple constraint would have-no user-visible impact, nor would it allow you to express anything that-you couldn't otherwise.--We could simply add Solo% for consistency with tuples (Solo) and unboxed-tuples (Solo#), but that would require even more magic to wire in another-magical class, so we opt not to do so. We must be careful, however, since-one can try to sneak in uses of unary constraint tuples through Template-Haskell, such as in this program (from #17511):--  f :: $(pure (ForallT [] [TupleT 1 `AppT` (ConT ''Show `AppT` ConT ''Int)]-                       (ConT ''String)))-  -- f :: Solo% (Show Int) => String-  f = "abc"--This use of `TupleT 1` will produce an HsBoxedOrConstraintTuple of arity 1,-and since it is used in a Constraint position, GHC will attempt to treat-it as thought it were a constraint tuple, which can potentially lead to-trouble if one attempts to look up the name of a constraint tuple of arity-1 (as it won't exist). To avoid this trouble, we simply take any unary-constraint tuples discovered when typechecking and drop them—i.e., treat-"Solo% a" as though the user had written "a". This is always safe to do-since the two constraints should be semantically equivalent.--}--{- *********************************************************************-*                                                                      *-                Type applications-*                                                                      *-********************************************************************* -}--splitHsAppTys :: HsType GhcRn -> Maybe (LHsType GhcRn, [LHsTypeArg GhcRn])-splitHsAppTys hs_ty-  | is_app hs_ty = Just (go (noLocA hs_ty) [])-  | otherwise    = Nothing-  where-    is_app :: HsType GhcRn -> Bool-    is_app (HsAppKindTy {})        = True-    is_app (HsAppTy {})            = True-    is_app (HsOpTy _ _ (L _ op) _) = not (op `hasKey` funTyConKey)-      -- I'm not sure why this funTyConKey test is necessary-      -- Can it even happen?  Perhaps for   t1 `(->)` t2-      -- but then maybe it's ok to treat that like a normal-      -- application rather than using the special rule for HsFunTy-    is_app (HsTyVar {})            = True-    is_app (HsParTy _ (L _ ty))    = is_app ty-    is_app _                       = False--    go :: LHsType GhcRn-       -> [HsArg (LHsType GhcRn) (LHsKind GhcRn)]-       -> (LHsType GhcRn,-           [HsArg (LHsType GhcRn) (LHsKind GhcRn)]) -- AZ temp-    go (L _  (HsAppTy _ f a))      as = go f (HsValArg a : as)-    go (L _  (HsAppKindTy l ty k)) as = go ty (HsTypeArg l k : as)-    go (L sp (HsParTy _ f))        as = go f (HsArgPar (locA sp) : as)-    go (L _  (HsOpTy _ l op@(L sp _) r)) as-      = ( L (na2la sp) (HsTyVar noAnn NotPromoted op)-        , HsValArg l : HsValArg r : as )-    go f as = (f, as)------------------------------tcInferTyAppHead :: TcTyMode -> LHsType GhcRn -> TcM (TcType, TcKind)--- Version of tc_infer_lhs_type specialised for the head of an--- application. In particular, for a HsTyVar (which includes type--- constructors, it does not zoom off into tcInferTyApps and family--- saturation-tcInferTyAppHead mode (L _ (HsTyVar _ _ (L _ tv)))-  = tcTyVar mode tv-tcInferTyAppHead mode ty-  = tc_infer_lhs_type mode ty-------------------------------- | Apply a type of a given kind to a list of arguments. This instantiates--- invisible parameters as necessary. Always consumes all the arguments,--- using matchExpectedFunKind as necessary.--- This takes an optional @VarEnv Kind@ which maps kind variables to kinds.---- These kinds should be used to instantiate invisible kind variables;--- they come from an enclosing class for an associated type/data family.------ tcInferTyApps also arranges to saturate any trailing invisible arguments---   of a type-family application, which is usually the right thing to do--- tcInferTyApps_nosat does not do this saturation; it is used only---   by ":kind" in GHCi-tcInferTyApps, tcInferTyApps_nosat-    :: TcTyMode-    -> LHsType GhcRn        -- ^ Function (for printing only)-    -> TcType               -- ^ Function-    -> [LHsTypeArg GhcRn]   -- ^ Args-    -> TcM (TcType, TcKind) -- ^ (f args, args, result kind)-tcInferTyApps mode hs_ty fun hs_args-  = do { (f_args, res_k) <- tcInferTyApps_nosat mode hs_ty fun hs_args-       ; saturateFamApp f_args res_k }--tcInferTyApps_nosat mode orig_hs_ty fun orig_hs_args-  = do { traceTc "tcInferTyApps {" (ppr orig_hs_ty $$ ppr orig_hs_args)-       ; (f_args, res_k) <- go_init 1 fun orig_hs_args-       ; traceTc "tcInferTyApps }" (ppr f_args <+> dcolon <+> ppr res_k)-       ; return (f_args, res_k) }-  where--    -- go_init just initialises the auxiliary-    -- arguments of the 'go' loop-    go_init n fun all_args-      = go n fun empty_subst fun_ki all_args-      where-        fun_ki = tcTypeKind fun-           -- We do (tcTypeKind fun) here, even though the caller-           -- knows the function kind, to absolutely guarantee-           -- INVARIANT for 'go'-           -- Note that in a typical application (F t1 t2 t3),-           -- the 'fun' is just a TyCon, so tcTypeKind is fast--        empty_subst = mkEmptyTCvSubst $ mkInScopeSet $-                      tyCoVarsOfType fun_ki--    go :: Int             -- The # of the next argument-       -> TcType          -- Function applied to some args-       -> TCvSubst        -- Applies to function kind-       -> TcKind          -- Function kind-       -> [LHsTypeArg GhcRn]    -- Un-type-checked args-       -> TcM (TcType, TcKind)  -- Result type and its kind-    -- INVARIANT: in any call (go n fun subst fun_ki args)-    --               tcTypeKind fun  =  subst(fun_ki)-    -- So the 'subst' and 'fun_ki' arguments are simply-    -- there to avoid repeatedly calling tcTypeKind.-    ---    -- Reason for INVARIANT: to support the Purely Kinded Type Invariant-    -- it's important that if fun_ki has a forall, then so does-    -- (tcTypeKind fun), because the next thing we are going to do-    -- is apply 'fun' to an argument type.--    -- Dispatch on all_args first, for performance reasons-    go n fun subst fun_ki all_args = case (all_args, tcSplitPiTy_maybe fun_ki) of--      ---------------- No user-written args left. We're done!-      ([], _) -> return (fun, substTy subst fun_ki)--      ---------------- HsArgPar: We don't care about parens here-      (HsArgPar _ : args, _) -> go n fun subst fun_ki args--      ---------------- HsTypeArg: a kind application (fun @ki)-      (HsTypeArg _ hs_ki_arg : hs_args, Just (ki_binder, inner_ki)) ->-        case ki_binder of--        -- FunTy with PredTy on LHS, or ForAllTy with Inferred-        Named (Bndr _ Inferred) -> instantiate ki_binder inner_ki-        Anon InvisArg _         -> instantiate ki_binder inner_ki--        Named (Bndr _ Specified) ->  -- Visible kind application-          do { traceTc "tcInferTyApps (vis kind app)"-                       (vcat [ ppr ki_binder, ppr hs_ki_arg-                             , ppr (tyBinderType ki_binder)-                             , ppr subst ])--             ; let exp_kind = substTy subst $ tyBinderType ki_binder-             ; arg_mode <- mkHoleMode KindLevel HM_VTA-                   -- HM_VKA: see Note [Wildcards in visible kind application]-             ; ki_arg <- addErrCtxt (funAppCtxt orig_hs_ty hs_ki_arg n) $-                         tc_lhs_type arg_mode hs_ki_arg exp_kind--             ; traceTc "tcInferTyApps (vis kind app)" (ppr exp_kind)-             ; (subst', fun') <- mkAppTyM subst fun ki_binder ki_arg-             ; go (n+1) fun' subst' inner_ki hs_args }--        -- Attempted visible kind application (fun @ki), but fun_ki is-        --   forall k -> blah   or   k1 -> k2-        -- So we need a normal application.  Error.-        _ -> ty_app_err hs_ki_arg $ substTy subst fun_ki--      -- No binder; try applying the substitution, or fail if that's not possible-      (HsTypeArg _ ki_arg : _, Nothing) -> try_again_after_substing_or $-                                           ty_app_err ki_arg substed_fun_ki--      ---------------- HsValArg: a normal argument (fun ty)-      (HsValArg arg : args, Just (ki_binder, inner_ki))-        -- next binder is invisible; need to instantiate it-        | isInvisibleBinder ki_binder   -- FunTy with InvisArg on LHS;-                                        -- or ForAllTy with Inferred or Specified-         -> instantiate ki_binder inner_ki--        -- "normal" case-        | otherwise-         -> do { traceTc "tcInferTyApps (vis normal app)"-                          (vcat [ ppr ki_binder-                                , ppr arg-                                , ppr (tyBinderType ki_binder)-                                , ppr subst ])-                ; let exp_kind = substTy subst $ tyBinderType ki_binder-                ; arg' <- addErrCtxt (funAppCtxt orig_hs_ty arg n) $-                          tc_lhs_type mode arg exp_kind-                ; traceTc "tcInferTyApps (vis normal app) 2" (ppr exp_kind)-                ; (subst', fun') <- mkAppTyM subst fun ki_binder arg'-                ; go (n+1) fun' subst' inner_ki args }--          -- no binder; try applying the substitution, or infer another arrow in fun kind-      (HsValArg _ : _, Nothing)-        -> try_again_after_substing_or $-           do { let arrows_needed = n_initial_val_args all_args-              ; co <- matchExpectedFunKind hs_ty arrows_needed substed_fun_ki--              ; fun' <- zonkTcType (fun `mkTcCastTy` co)-                     -- This zonk is essential, to expose the fruits-                     -- of matchExpectedFunKind to the 'go' loop--              ; traceTc "tcInferTyApps (no binder)" $-                   vcat [ ppr fun <+> dcolon <+> ppr fun_ki-                        , ppr arrows_needed-                        , ppr co-                        , ppr fun' <+> dcolon <+> ppr (tcTypeKind fun')]-              ; go_init n fun' all_args }-                -- Use go_init to establish go's INVARIANT-      where-        instantiate ki_binder inner_ki-          = do { traceTc "tcInferTyApps (need to instantiate)"-                         (vcat [ ppr ki_binder, ppr subst])-               ; (subst', arg') <- tcInstInvisibleTyBinder subst ki_binder-               ; go n (mkAppTy fun arg') subst' inner_ki all_args }-                 -- Because tcInvisibleTyBinder instantiate ki_binder,-                 -- the kind of arg' will have the same shape as the kind-                 -- of ki_binder.  So we don't need mkAppTyM here.--        try_again_after_substing_or fallthrough-          | not (isEmptyTCvSubst subst)-          = go n fun zapped_subst substed_fun_ki all_args-          | otherwise-          = fallthrough--        zapped_subst   = zapTCvSubst subst-        substed_fun_ki = substTy subst fun_ki-        hs_ty          = appTypeToArg orig_hs_ty (take (n-1) orig_hs_args)--    n_initial_val_args :: [HsArg tm ty] -> Arity-    -- Count how many leading HsValArgs we have-    n_initial_val_args (HsValArg {} : args) = 1 + n_initial_val_args args-    n_initial_val_args (HsArgPar {} : args) = n_initial_val_args args-    n_initial_val_args _                    = 0--    ty_app_err arg ty-      = failWith $ text "Cannot apply function of kind" <+> quotes (ppr ty)-                $$ text "to visible kind argument" <+> quotes (ppr arg)---mkAppTyM :: TCvSubst-         -> TcType -> TyCoBinder    -- fun, plus its top-level binder-         -> TcType                  -- arg-         -> TcM (TCvSubst, TcType)  -- Extended subst, plus (fun arg)--- Precondition: the application (fun arg) is well-kinded after zonking---               That is, the application makes sense------ Precondition: for (mkAppTyM subst fun bndr arg)---       tcTypeKind fun  =  Pi bndr. body---  That is, fun always has a ForAllTy or FunTy at the top---           and 'bndr' is fun's pi-binder------ Postcondition: if fun and arg satisfy (PKTI), the purely-kinded type---                invariant, then so does the result type (fun arg)------ We do not require that---    tcTypeKind arg = tyVarKind (binderVar bndr)--- This must be true after zonking (precondition 1), but it's not--- required for the (PKTI).-mkAppTyM subst fun ki_binder arg-  | -- See Note [mkAppTyM]: Nasty case 2-    TyConApp tc args <- fun-  , isTypeSynonymTyCon tc-  , args `lengthIs` (tyConArity tc - 1)-  , any isTrickyTvBinder (tyConTyVars tc) -- We could cache this in the synonym-  = do { arg'  <- zonkTcType  arg-       ; args' <- zonkTcTypes args-       ; let subst' = case ki_binder of-                        Anon {}           -> subst-                        Named (Bndr tv _) -> extendTvSubstAndInScope subst tv arg'-       ; return (subst', mkTyConApp tc (args' ++ [arg'])) }---mkAppTyM subst fun (Anon {}) arg-   = return (subst, mk_app_ty fun arg)--mkAppTyM subst fun (Named (Bndr tv _)) arg-  = do { arg' <- if isTrickyTvBinder tv-                 then -- See Note [mkAppTyM]: Nasty case 1-                      zonkTcType arg-                 else return     arg-       ; return ( extendTvSubstAndInScope subst tv arg'-                , mk_app_ty fun arg' ) }--mk_app_ty :: TcType -> TcType -> TcType--- This function just adds an ASSERT for mkAppTyM's precondition-mk_app_ty fun arg-  = ASSERT2( isPiTy fun_kind-           ,  ppr fun <+> dcolon <+> ppr fun_kind $$ ppr arg )-    mkAppTy fun arg-  where-    fun_kind = tcTypeKind fun--isTrickyTvBinder :: TcTyVar -> Bool--- NB: isTrickyTvBinder is just an optimisation--- It would be absolutely sound to return True always-isTrickyTvBinder tv = isPiTy (tyVarKind tv)--{- Note [The Purely Kinded Type Invariant (PKTI)]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-During type inference, we maintain this invariant-- (PKTI) It is legal to call 'tcTypeKind' on any Type ty,-        on any sub-term of ty, /without/ zonking ty--        Moreover, any such returned kind-        will itself satisfy (PKTI)--By "legal to call tcTypeKind" we mean "tcTypeKind will not crash".-The way in which tcTypeKind can crash is in applications-    (a t1 t2 .. tn)-if 'a' is a type variable whose kind doesn't have enough arrows-or foralls.  (The crash is in piResultTys.)--The loop in tcInferTyApps has to be very careful to maintain the (PKTI).-For example, suppose-    kappa is a unification variable-    We have already unified kappa := Type-      yielding    co :: Refl (Type -> Type)-    a :: kappa-then consider the type-    (a Int)-If we call tcTypeKind on that, we'll crash, because the (un-zonked)-kind of 'a' is just kappa, not an arrow kind.  So we must zonk first.--So the type inference engine is very careful when building applications.-This happens in tcInferTyApps. Suppose we are kind-checking the type (a Int),-where (a :: kappa).  Then in tcInferApps we'll run out of binders on-a's kind, so we'll call matchExpectedFunKind, and unify-   kappa := kappa1 -> kappa2,  with evidence co :: kappa ~ (kappa1 ~ kappa2)-At this point we must zonk the function type to expose the arrrow, so-that (a Int) will satisfy (PKTI).--The absence of this caused #14174 and #14520.--The calls to mkAppTyM is the other place we are very careful; see Note [mkAppTyM].--Wrinkle around FunTy:-Note that the PKTI does *not* guarantee anything about the shape of FunTys.-Specifically, when we have (FunTy vis mult arg res), it should be the case-that arg :: TYPE rr1 and res :: TYPE rr2, for some rr1 and rr2. However, we-might not have this. Example: if the user writes (a -> b), then we might-invent a :: kappa1 and b :: kappa2. We soon will check whether kappa1 ~ TYPE rho1-(for some rho1), and that will lead to kappa1 := TYPE rho1 (ditto for kappa2).-However, when we build the FunTy, we might not have zonked `a`, and so the-FunTy will be built without being able to purely extract the RuntimeReps.--Because the PKTI does not guarantee that the RuntimeReps are available in a FunTy,-we must be aware of this when splitting: splitTyConApp and splitAppTy will *not*-split a FunTy if the RuntimeReps are not available. See also Note [Decomposing FunTy]-in GHC.Tc.Solver.Canonical.--Note [mkAppTyM]-~~~~~~~~~~~~~~~-mkAppTyM is trying to guarantee the Purely Kinded Type Invariant-(PKTI) for its result type (fun arg).  There are two ways it can go wrong:--* Nasty case 1: forall types (polykinds/T14174a)-    T :: forall (p :: *->*). p Int -> p Bool-  Now kind-check (T x), where x::kappa.-  Well, T and x both satisfy the PKTI, but-     T x :: x Int -> x Bool-  and (x Int) does /not/ satisfy the PKTI.--* Nasty case 2: type synonyms-    type S f a = f a-  Even though (S ff aa) would satisfy the (PKTI) if S was a data type-  (i.e. nasty case 1 is dealt with), it might still not satisfy (PKTI)-  if S is a type synonym, because the /expansion/ of (S ff aa) is-  (ff aa), and /that/ does not satisfy (PKTI).  E.g. perhaps-  (ff :: kappa), where 'kappa' has already been unified with (*->*).--  We check for nasty case 2 on the final argument of a type synonym.--Notice that in both cases the trickiness only happens if the-bound variable has a pi-type.  Hence isTrickyTvBinder.--}---saturateFamApp :: TcType -> TcKind -> TcM (TcType, TcKind)--- Precondition for (saturateFamApp ty kind):---     tcTypeKind ty = kind------ If 'ty' is an unsaturated family application with trailing--- invisible arguments, instantiate them.--- See Note [saturateFamApp]--saturateFamApp ty kind-  | Just (tc, args) <- tcSplitTyConApp_maybe ty-  , mustBeSaturated tc-  , let n_to_inst = tyConArity tc - length args-  = do { (extra_args, ki') <- tcInstInvisibleTyBindersN n_to_inst kind-       ; return (ty `mkTcAppTys` extra_args, ki') }-  | otherwise-  = return (ty, kind)--{- Note [saturateFamApp]-~~~~~~~~~~~~~~~~~~~~~~~~-Consider-   type family F :: Either j k-   type instance F @Type = Right Maybe-   type instance F @Type = Right Either```--Then F :: forall {j,k}. Either j k--The two type instances do a visible kind application that instantiates-'j' but not 'k'.  But we want to end up with instances that look like-  type instance F @Type @(*->*) = Right @Type @(*->*) Maybe--so that F has arity 2.  We must instantiate that trailing invisible-binder. In general, Invisible binders precede Specified and Required,-so this is only going to bite for apparently-nullary families.--Note that-  type family F2 :: forall k. k -> *-is quite different and really does have arity 0.--It's not just type instances where we need to saturate those-unsaturated arguments: see #11246.  Hence doing this in tcInferApps.--}--appTypeToArg :: LHsType GhcRn -> [LHsTypeArg GhcRn] -> LHsType GhcRn-appTypeToArg f []                       = f-appTypeToArg f (HsValArg arg    : args) = appTypeToArg (mkHsAppTy f arg) args-appTypeToArg f (HsArgPar _      : args) = appTypeToArg f                 args-appTypeToArg f (HsTypeArg l arg : args)-  = appTypeToArg (mkHsAppKindTy l f arg) args---{- *********************************************************************-*                                                                      *-                checkExpectedKind-*                                                                      *-********************************************************************* -}---- | This instantiates invisible arguments for the type being checked if it must--- be saturated and is not yet saturated. It then calls and uses the result--- from checkExpectedKindX to build the final type-checkExpectedKind :: HasDebugCallStack-                  => HsType GhcRn       -- ^ type we're checking (for printing)-                  -> TcType             -- ^ type we're checking-                  -> TcKind             -- ^ the known kind of that type-                  -> TcKind             -- ^ the expected kind-                  -> TcM TcType--- Just a convenience wrapper to save calls to 'ppr'-checkExpectedKind hs_ty ty act_kind exp_kind-  = do { traceTc "checkExpectedKind" (ppr ty $$ ppr act_kind)--       ; (new_args, act_kind') <- tcInstInvisibleTyBindersN n_to_inst act_kind--       ; let origin = TypeEqOrigin { uo_actual   = act_kind'-                                   , uo_expected = exp_kind-                                   , uo_thing    = Just (ppr hs_ty)-                                   , uo_visible  = True } -- the hs_ty is visible--       ; traceTc "checkExpectedKindX" $-         vcat [ ppr hs_ty-              , text "act_kind':" <+> ppr act_kind'-              , text "exp_kind:" <+> ppr exp_kind ]--       ; let res_ty = ty `mkTcAppTys` new_args--       ; if act_kind' `tcEqType` exp_kind-         then return res_ty  -- This is very common-         else do { co_k <- uType KindLevel origin act_kind' exp_kind-                 ; traceTc "checkExpectedKind" (vcat [ ppr act_kind-                                                     , ppr exp_kind-                                                     , ppr co_k ])-                ; return (res_ty `mkTcCastTy` co_k) } }-    where-      -- We need to make sure that both kinds have the same number of implicit-      -- foralls out front. If the actual kind has more, instantiate accordingly.-      -- Otherwise, just pass the type & kind through: the errors are caught-      -- in unifyType.-      n_exp_invis_bndrs = invisibleTyBndrCount exp_kind-      n_act_invis_bndrs = invisibleTyBndrCount act_kind-      n_to_inst         = n_act_invis_bndrs - n_exp_invis_bndrs-------------------------------tcHsContext :: Maybe (LHsContext GhcRn) -> TcM [PredType]-tcHsContext cxt = tc_hs_context typeLevelMode cxt--tcLHsPredType :: LHsType GhcRn -> TcM PredType-tcLHsPredType pred = tc_lhs_pred typeLevelMode pred--tc_hs_context :: TcTyMode -> Maybe (LHsContext GhcRn) -> TcM [PredType]-tc_hs_context _ Nothing = return []-tc_hs_context mode (Just ctxt) = mapM (tc_lhs_pred mode) (unLoc ctxt)--tc_lhs_pred :: TcTyMode -> LHsType GhcRn -> TcM PredType-tc_lhs_pred mode pred = tc_lhs_type mode pred constraintKind------------------------------tcTyVar :: TcTyMode -> Name -> TcM (TcType, TcKind)--- See Note [Type checking recursive type and class declarations]--- in GHC.Tc.TyCl--- This does not instantiate. See Note [Do not always instantiate eagerly in types]-tcTyVar mode name         -- Could be a tyvar, a tycon, or a datacon-  = do { traceTc "lk1" (ppr name)-       ; thing <- tcLookup name-       ; case thing of-           ATyVar _ tv -> return (mkTyVarTy tv, tyVarKind tv)--           -- See Note [Recursion through the kinds]-           ATcTyCon tc_tc-             -> do { check_tc tc_tc-                   ; return (mkTyConTy tc_tc, tyConKind tc_tc) }--           AGlobal (ATyCon tc)-             -> do { check_tc tc-                   ; return (mkTyConTy tc, tyConKind tc) }--           AGlobal (AConLike (RealDataCon dc))-             -> do { data_kinds <- xoptM LangExt.DataKinds-                   ; unless (data_kinds || specialPromotedDc dc) $-                       promotionErr name NoDataKindsDC-                   ; when (isFamInstTyCon (dataConTyCon dc)) $-                       -- see #15245-                       promotionErr name FamDataConPE-                   ; let (_, _, _, theta, _, _) = dataConFullSig dc-                   ; traceTc "tcTyVar" (ppr dc <+> ppr theta $$ ppr (dc_theta_illegal_constraint theta))-                   ; case dc_theta_illegal_constraint theta of-                       Just pred -> promotionErr name $-                                    ConstrainedDataConPE pred-                       Nothing   -> pure ()-                   ; let tc = promoteDataCon dc-                   ; return (mkTyConApp tc [], tyConKind tc) }--           APromotionErr err -> promotionErr name err--           _  -> wrongThingErr "type" thing name }-  where-    check_tc :: TyCon -> TcM ()-    check_tc tc = do { data_kinds   <- xoptM LangExt.DataKinds-                     ; unless (isTypeLevel (mode_tyki mode) ||-                               data_kinds ||-                               isKindTyCon tc) $-                       promotionErr name NoDataKindsTC }--    -- We cannot promote a data constructor with a context that contains-    -- constraints other than equalities, so error if we find one.-    -- See Note [Constraints in kinds] in GHC.Core.TyCo.Rep-    dc_theta_illegal_constraint :: ThetaType -> Maybe PredType-    dc_theta_illegal_constraint = find (not . isEqPred)--{--Note [Recursion through the kinds]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider these examples--Ticket #11554:-  data P (x :: k) = Q-  data A :: Type where-    MkA :: forall (a :: A). P a -> A--Ticket #12174-  data V a-  data T = forall (a :: T). MkT (V a)--The type is recursive (which is fine) but it is recursive /through the-kinds/.  In earlier versions of GHC this caused a loop in the compiler-(to do with knot-tying) but there is nothing fundamentally wrong with-the code (kinds are types, and the recursive declarations are OK). But-it's hard to distinguish "recursion through the kinds" from "recursion-through the types". Consider this (also #11554):--  data PB k (x :: k) = Q-  data B :: Type where-    MkB :: P B a -> B--Here the occurrence of B is not obviously in a kind position.--So now GHC allows all these programs.  #12081 and #15942 are other-examples.--Note [Body kind of a HsForAllTy]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The body of a forall is usually a type, but in principle-there's no reason to prohibit *unlifted* types.-In fact, GHC can itself construct a function with an-unboxed tuple inside a for-all (via CPR analysis; see-typecheck/should_compile/tc170).--Moreover in instance heads we get forall-types with-kind Constraint.--It's tempting to check that the body kind is either * or #. But this is-wrong. For example:--  class C a b-  newtype N = Mk Foo deriving (C a)--We're doing newtype-deriving for C. But notice how `a` isn't in scope in-the predicate `C a`. So we quantify, yielding `forall a. C a` even though-`C a` has kind `* -> Constraint`. The `forall a. C a` is a bit cheeky, but-convenient. Bottom line: don't check for * or # here.--Note [Body kind of a HsQualTy]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If ctxt is non-empty, the HsQualTy really is a /function/, so the-kind of the result really is '*', and in that case the kind of the-body-type can be lifted or unlifted.--However, consider-    instance Eq a => Eq [a] where ...-or-    f :: (Eq a => Eq [a]) => blah-Here both body-kind of the HsQualTy is Constraint rather than *.-Rather crudely we tell the difference by looking at exp_kind. It's-very convenient to typecheck instance types like any other HsSigType.--Admittedly the '(Eq a => Eq [a]) => blah' case is erroneous, but it's-better to reject in checkValidType.  If we say that the body kind-should be '*' we risk getting TWO error messages, one saying that Eq-[a] doesn't have kind '*', and one saying that we need a Constraint to-the left of the outer (=>).--How do we figure out the right body kind?  Well, it's a bit of a-kludge: I just look at the expected kind.  If it's Constraint, we-must be in this instance situation context. It's a kludge because it-wouldn't work if any unification was involved to compute that result-kind -- but it isn't.  (The true way might be to use the 'mode'-parameter, but that seemed like a sledgehammer to crack a nut.)--Note [Inferring tuple kinds]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Give a tuple type (a,b,c), which the parser labels as HsBoxedOrConstraintTuple,-we try to figure out whether it's a tuple of kind * or Constraint.-  Step 1: look at the expected kind-  Step 2: infer argument kinds--If after Step 2 it's not clear from the arguments that it's-Constraint, then it must be *.  Once having decided that we re-check-the arguments to give good error messages in-  e.g.  (Maybe, Maybe)--Note that we will still fail to infer the correct kind in this case:--  type T a = ((a,a), D a)-  type family D :: Constraint -> Constraint--While kind checking T, we do not yet know the kind of D, so we will default the-kind of T to * -> *. It works if we annotate `a` with kind `Constraint`.--Note [Desugaring types]-~~~~~~~~~~~~~~~~~~~~~~~-The type desugarer is phase 2 of dealing with HsTypes.  Specifically:--  * It transforms from HsType to Type--  * It zonks any kinds.  The returned type should have no mutable kind-    or type variables (hence returning Type not TcType):-      - any unconstrained kind variables are defaulted to (Any *) just-        as in GHC.Tc.Utils.Zonk.-      - there are no mutable type variables because we are-        kind-checking a type-    Reason: the returned type may be put in a TyCon or DataCon where-    it will never subsequently be zonked.--You might worry about nested scopes:-        ..a:kappa in scope..-            let f :: forall b. T '[a,b] -> Int-In this case, f's type could have a mutable kind variable kappa in it;-and we might then default it to (Any *) when dealing with f's type-signature.  But we don't expect this to happen because we can't get a-lexically scoped type variable with a mutable kind variable in it.  A-delicate point, this.  If it becomes an issue we might need to-distinguish top-level from nested uses.--Moreover-  * it cannot fail,-  * it does no unifications-  * it does no validity checking, except for structural matters, such as-        (a) spurious ! annotations.-        (b) a class used as a type--Note [Kind of a type splice]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider these terms, each with TH type splice inside:-     [| e1 :: Maybe $(..blah..) |]-     [| e2 :: $(..blah..) |]-When kind-checking the type signature, we'll kind-check the splice-$(..blah..); we want to give it a kind that can fit in any context,-as if $(..blah..) :: forall k. k.--In the e1 example, the context of the splice fixes kappa to *.  But-in the e2 example, we'll desugar the type, zonking the kind unification-variables as we go.  When we encounter the unconstrained kappa, we-want to default it to '*', not to (Any *).---}--addTypeCtxt :: LHsType GhcRn -> TcM a -> TcM a-        -- Wrap a context around only if we want to show that contexts.-        -- Omit invisible ones and ones user's won't grok-addTypeCtxt (L _ (HsWildCardTy _)) thing = thing   -- "In the type '_'" just isn't helpful.-addTypeCtxt (L _ ty) thing-  = addErrCtxt doc thing-  where-    doc = text "In the type" <+> quotes (ppr ty)---{- *********************************************************************-*                                                                      *-                Type-variable binders-*                                                                      *-********************************************************************* -}--bindNamedWildCardBinders :: [Name]-                         -> ([(Name, TcTyVar)] -> TcM a)-                         -> TcM a--- Bring into scope the /named/ wildcard binders.  Remember that--- plain wildcards _ are anonymous and dealt with by HsWildCardTy--- Soe Note [The wildcard story for types] in GHC.Hs.Type-bindNamedWildCardBinders wc_names thing_inside-  = do { wcs <- mapM newNamedWildTyVar wc_names-       ; let wc_prs = wc_names `zip` wcs-       ; tcExtendNameTyVarEnv wc_prs $-         thing_inside wc_prs }--newNamedWildTyVar :: Name -> TcM TcTyVar--- ^ New unification variable '_' for a wildcard-newNamedWildTyVar _name   -- Currently ignoring the "_x" wildcard name used in the type-  = do { kind <- newMetaKindVar-       ; details <- newMetaDetails TauTv-       ; wc_name <- newMetaTyVarName (fsLit "w")   -- See Note [Wildcard names]-       ; let tyvar = mkTcTyVar wc_name kind details-       ; traceTc "newWildTyVar" (ppr tyvar)-       ; return tyvar }------------------------------tcAnonWildCardOcc :: IsExtraConstraint-                  -> TcTyMode -> HsType GhcRn -> Kind -> TcM TcType-tcAnonWildCardOcc is_extra (TcTyMode { mode_holes = Just (hole_lvl, hole_mode) })-                  ty exp_kind-    -- hole_lvl: see Note [Checking partial type signatures]-    --           esp the bullet on nested forall types-  = do { kv_details <- newTauTvDetailsAtLevel hole_lvl-       ; kv_name    <- newMetaTyVarName (fsLit "k")-       ; wc_details <- newTauTvDetailsAtLevel hole_lvl-       ; wc_name    <- newMetaTyVarName (fsLit wc_nm)-       ; let kv      = mkTcTyVar kv_name liftedTypeKind kv_details-             wc_kind = mkTyVarTy kv-             wc_tv   = mkTcTyVar wc_name wc_kind wc_details--       ; traceTc "tcAnonWildCardOcc" (ppr hole_lvl <+> ppr emit_holes)-       ; when emit_holes $-         emitAnonTypeHole is_extra wc_tv-         -- Why the 'when' guard?-         -- See Note [Wildcards in visible kind application]--       -- You might think that this would always just unify-       -- wc_kind with exp_kind, so we could avoid even creating kv-       -- But the level numbers might not allow that unification,-       -- so we have to do it properly (T14140a)-       ; checkExpectedKind ty (mkTyVarTy wc_tv) wc_kind exp_kind }-  where-     -- See Note [Wildcard names]-     wc_nm = case hole_mode of-               HM_Sig      -> "w"-               HM_FamPat   -> "_"-               HM_VTA      -> "w"-               HM_TyAppPat -> "_"--     emit_holes = case hole_mode of-                     HM_Sig     -> True-                     HM_FamPat  -> False-                     HM_VTA     -> False-                     HM_TyAppPat -> False--tcAnonWildCardOcc _ mode ty _--- mode_holes is Nothing.  Should not happen, because renamer--- should already have rejected holes in unexpected places-  = pprPanic "tcWildCardOcc" (ppr mode $$ ppr ty)--{- Note [Wildcard names]-~~~~~~~~~~~~~~~~~~~~~~~~-So we hackily use the mode_holes flag to control the name used-for wildcards:--* For proper holes (whether in a visible type application (VTA) or no),-  we rename the '_' to 'w'. This is so that we see variables like 'w0'-  or 'w1' in error messages, a vast improvement upon '_0' and '_1'. For-  example, we prefer-       Found type wildcard ‘_’ standing for ‘w0’-  over-       Found type wildcard ‘_’ standing for ‘_1’--  Even in the VTA case, where we do not emit an error to be printed, we-  want to do the renaming, as the variables may appear in other,-  non-wildcard error messages.--* However, holes in the left-hand sides of type families ("type-  patterns") stand for type variables which we do not care to name ---  much like the use of an underscore in an ordinary term-level-  pattern. When we spot these, we neither wish to generate an error-  message nor to rename the variable.  We don't rename the variable so-  that we can pretty-print a type family LHS as, e.g.,-    F _ Int _ = ...-  and not-     F w1 Int w2 = ...--  See also Note [Wildcards in family instances] in-  GHC.Rename.Module. The choice of HM_FamPat is made in-  tcFamTyPats. There is also some unsavory magic, relying on that-  underscore, in GHC.Core.Coercion.tidyCoAxBndrsForUser.--Note [Wildcards in visible kind application]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-There are cases where users might want to pass in a wildcard as a visible kind-argument, for instance:--data T :: forall k1 k2. k1 → k2 → Type where-  MkT :: T a b-x :: T @_ @Nat False n-x = MkT--So we should allow '@_' without emitting any hole constraints, and-regardless of whether PartialTypeSignatures is enabled or not. But how-would the typechecker know which '_' is being used in VKA and which is-not when it calls emitNamedTypeHole in-tcHsPartialSigType on all HsWildCardBndrs?  The solution is to neither-rename nor include unnamed wildcards in HsWildCardBndrs, but instead-give every anonymous wildcard a fresh wild tyvar in tcAnonWildCardOcc.--And whenever we see a '@', we set mode_holes to HM_VKA, so that-we do not call emitAnonTypeHole in tcAnonWildCardOcc.-See related Note [Wildcards in visible type application] here and-Note [The wildcard story for types] in GHC.Hs.Type--}--{- *********************************************************************-*                                                                      *-             Kind inference for type declarations-*                                                                      *-********************************************************************* -}---- See Note [kcCheckDeclHeader vs kcInferDeclHeader]-data InitialKindStrategy-  = InitialKindCheck SAKS_or_CUSK-  | InitialKindInfer---- Does the declaration have a standalone kind signature (SAKS) or a complete--- user-specified kind (CUSK)?-data SAKS_or_CUSK-  = SAKS Kind  -- Standalone kind signature, fully zonked! (zonkTcTypeToType)-  | CUSK       -- Complete user-specified kind (CUSK)--instance Outputable SAKS_or_CUSK where-  ppr (SAKS k) = text "SAKS" <+> ppr k-  ppr CUSK = text "CUSK"---- See Note [kcCheckDeclHeader vs kcInferDeclHeader]-kcDeclHeader-  :: InitialKindStrategy-  -> Name              -- ^ of the thing being checked-  -> TyConFlavour      -- ^ What sort of 'TyCon' is being checked-  -> LHsQTyVars GhcRn  -- ^ Binders in the header-  -> TcM ContextKind   -- ^ The result kind-  -> TcM TcTyCon       -- ^ A suitably-kinded TcTyCon-kcDeclHeader (InitialKindCheck msig) = kcCheckDeclHeader msig-kcDeclHeader InitialKindInfer = kcInferDeclHeader--{- Note [kcCheckDeclHeader vs kcInferDeclHeader]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-kcCheckDeclHeader and kcInferDeclHeader are responsible for getting the initial kind-of a type constructor.--* kcCheckDeclHeader: the TyCon has a standalone kind signature or a CUSK. In that-  case, find the full, final, poly-kinded kind of the TyCon.  It's very like a-  term-level binding where we have a complete type signature for the function.--* kcInferDeclHeader: the TyCon has neither a standalone kind signature nor a-  CUSK. Find a monomorphic kind, with unification variables in it; they will be-  generalised later.  It's very like a term-level binding where we do not have a-  type signature (or, more accurately, where we have a partial type signature),-  so we infer the type and generalise.--}---------------------------------kcCheckDeclHeader-  :: SAKS_or_CUSK-  -> Name              -- ^ of the thing being checked-  -> TyConFlavour      -- ^ What sort of 'TyCon' is being checked-  -> LHsQTyVars GhcRn  -- ^ Binders in the header-  -> TcM ContextKind   -- ^ The result kind. AnyKind == no result signature-  -> TcM TcTyCon       -- ^ A suitably-kinded generalized TcTyCon-kcCheckDeclHeader (SAKS sig) = kcCheckDeclHeader_sig sig-kcCheckDeclHeader CUSK       = kcCheckDeclHeader_cusk--kcCheckDeclHeader_cusk-  :: Name              -- ^ of the thing being checked-  -> TyConFlavour      -- ^ What sort of 'TyCon' is being checked-  -> LHsQTyVars GhcRn  -- ^ Binders in the header-  -> TcM ContextKind   -- ^ The result kind-  -> TcM TcTyCon       -- ^ A suitably-kinded generalized TcTyCon-kcCheckDeclHeader_cusk name flav-              (HsQTvs { hsq_ext = kv_ns-                      , hsq_explicit = hs_tvs }) kc_res_ki-  -- CUSK case-  -- See note [Required, Specified, and Inferred for types] in GHC.Tc.TyCl-  = addTyConFlavCtxt name flav $-    do { (tclvl, wanted, (scoped_kvs, (tc_tvs, res_kind)))-           <- pushLevelAndSolveEqualitiesX "kcCheckDeclHeader_cusk" $-              bindImplicitTKBndrs_Q_Skol kv_ns                      $-              bindExplicitTKBndrs_Q_Skol ctxt_kind hs_tvs           $-              newExpectedKind =<< kc_res_ki--           -- Now, because we're in a CUSK,-           -- we quantify over the mentioned kind vars-       ; let spec_req_tkvs = scoped_kvs ++ tc_tvs-             all_kinds     = res_kind : map tyVarKind spec_req_tkvs--       ; candidates' <- candidateQTyVarsOfKinds all_kinds-             -- 'candidates' are all the variables that we are going to-             -- skolemise and then quantify over.  We do not include spec_req_tvs-             -- because they are /already/ skolems--       ; let non_tc_candidates = filter (not . isTcTyVar) (nonDetEltsUniqSet (tyCoVarsOfTypes all_kinds))-             candidates = candidates' { dv_kvs = dv_kvs candidates' `extendDVarSetList` non_tc_candidates }-             inf_candidates = candidates `delCandidates` spec_req_tkvs--       ; inferred <- quantifyTyVars inf_candidates-                     -- NB: 'inferred' comes back sorted in dependency order--       ; scoped_kvs <- mapM zonkTyCoVarKind scoped_kvs-       ; tc_tvs     <- mapM zonkTyCoVarKind tc_tvs-       ; res_kind   <- zonkTcType           res_kind--       ; let mentioned_kv_set = candidateKindVars candidates-             specified        = scopedSort scoped_kvs-                                -- NB: maintain the L-R order of scoped_kvs--             final_tc_binders =  mkNamedTyConBinders Inferred  inferred-                              ++ mkNamedTyConBinders Specified specified-                              ++ map (mkRequiredTyConBinder mentioned_kv_set) tc_tvs--             all_tv_prs =  mkTyVarNamePairs (scoped_kvs ++ tc_tvs)-             tycon = mkTcTyCon name final_tc_binders res_kind all_tv_prs-                               True -- it is generalised-                               flav--       ; reportUnsolvedEqualities skol_info (binderVars final_tc_binders)-                                  tclvl wanted--         -- If the ordering from-         -- Note [Required, Specified, and Inferred for types] in GHC.Tc.TyCl-         -- doesn't work, we catch it here, before an error cascade-       ; checkTyConTelescope tycon--       ; traceTc "kcCheckDeclHeader_cusk " $-         vcat [ text "name" <+> ppr name-              , text "kv_ns" <+> ppr kv_ns-              , text "hs_tvs" <+> ppr hs_tvs-              , text "scoped_kvs" <+> ppr scoped_kvs-              , text "tc_tvs" <+> ppr tc_tvs-              , text "res_kind" <+> ppr res_kind-              , text "candidates" <+> ppr candidates-              , text "inferred" <+> ppr inferred-              , text "specified" <+> ppr specified-              , text "final_tc_binders" <+> ppr final_tc_binders-              , text "mkTyConKind final_tc_bndrs res_kind"-                <+> ppr (mkTyConKind final_tc_binders res_kind)-              , text "all_tv_prs" <+> ppr all_tv_prs ]--       ; return tycon }-  where-    skol_info = TyConSkol flav name-    ctxt_kind | tcFlavourIsOpen flav = TheKind liftedTypeKind-              | otherwise            = AnyKind---- | Kind-check a 'LHsQTyVars'. Used in 'inferInitialKind' (for tycon kinds and--- other kinds).------ This function does not do telescope checking.-kcInferDeclHeader-  :: Name              -- ^ of the thing being checked-  -> TyConFlavour      -- ^ What sort of 'TyCon' is being checked-  -> LHsQTyVars GhcRn-  -> TcM ContextKind   -- ^ The result kind-  -> TcM TcTyCon       -- ^ A suitably-kinded non-generalized TcTyCon-kcInferDeclHeader name flav-              (HsQTvs { hsq_ext = kv_ns-                      , hsq_explicit = hs_tvs }) kc_res_ki-  -- No standalane kind signature and no CUSK.-  -- See note [Required, Specified, and Inferred for types] in GHC.Tc.TyCl-  = addTyConFlavCtxt name flav $-    do { (scoped_kvs, (tc_tvs, res_kind))-           -- Why bindImplicitTKBndrs_Q_Tv which uses newTyVarTyVar?-           -- See Note [Inferring kinds for type declarations] in GHC.Tc.TyCl-           <- bindImplicitTKBndrs_Q_Tv kv_ns            $-              bindExplicitTKBndrs_Q_Tv ctxt_kind hs_tvs $-              newExpectedKind =<< kc_res_ki-              -- Why "_Tv" not "_Skol"? See third wrinkle in-              -- Note [Inferring kinds for type declarations] in GHC.Tc.TyCl,--       ; let   -- NB: Don't add scoped_kvs to tyConTyVars, because they-               -- might unify with kind vars in other types in a mutually-               -- recursive group.-               -- See Note [Inferring kinds for type declarations] in GHC.Tc.TyCl--             tc_binders = mkAnonTyConBinders VisArg tc_tvs-               -- Also, note that tc_binders has the tyvars from only the-               -- user-written tyvarbinders. See S1 in Note [How TcTyCons work]-               -- in GHC.Tc.TyCl-               ---               -- mkAnonTyConBinder: see Note [No polymorphic recursion]--             all_tv_prs = mkTyVarNamePairs (scoped_kvs ++ tc_tvs)-               -- NB: bindExplicitTKBndrs_Q_Tv does not clone;-               --     ditto Implicit-               -- See Note [Cloning for type variable binders]--             tycon = mkTcTyCon name tc_binders res_kind all_tv_prs-                               False -- not yet generalised-                               flav--       ; traceTc "kcInferDeclHeader: not-cusk" $-         vcat [ ppr name, ppr kv_ns, ppr hs_tvs-              , ppr scoped_kvs-              , ppr tc_tvs, ppr (mkTyConKind tc_binders res_kind) ]-       ; return tycon }-  where-    ctxt_kind | tcFlavourIsOpen flav = TheKind liftedTypeKind-              | otherwise            = AnyKind---- | Kind-check a declaration header against a standalone kind signature.--- See Note [Arity inference in kcCheckDeclHeader_sig]-kcCheckDeclHeader_sig-  :: Kind              -- ^ Standalone kind signature, fully zonked! (zonkTcTypeToType)-  -> Name              -- ^ of the thing being checked-  -> TyConFlavour      -- ^ What sort of 'TyCon' is being checked-  -> LHsQTyVars GhcRn  -- ^ Binders in the header-  -> TcM ContextKind   -- ^ The result kind. AnyKind == no result signature-  -> TcM TcTyCon       -- ^ A suitably-kinded TcTyCon-kcCheckDeclHeader_sig kisig name flav-          (HsQTvs { hsq_ext      = implicit_nms-                  , hsq_explicit = explicit_nms }) kc_res_ki-  = addTyConFlavCtxt name flav $-    do {  -- Step 1: zip user-written binders with quantifiers from the kind signature.-          -- For example:-          ---          --   type F :: forall k -> k -> forall j. j -> Type-          --   data F i a b = ...-          ---          -- Results in the following 'zipped_binders':-          ---          --                   TyBinder      LHsTyVarBndr-          --    ----------------------------------------          --    ZippedBinder   forall k ->   i-          --    ZippedBinder   k ->          a-          --    ZippedBinder   forall j.-          --    ZippedBinder   j ->          b-          ---          let (zipped_binders, excess_bndrs, kisig') = zipBinders kisig explicit_nms--          -- Report binders that don't have a corresponding quantifier.-          -- For example:-          ---          --   type T :: Type -> Type-          --   data T b1 b2 b3 = ...-          ---          -- Here, b1 is zipped with Type->, while b2 and b3 are excess binders.-          ---        ; unless (null excess_bndrs) $ failWithTc (tooManyBindersErr kisig' excess_bndrs)--          -- Convert each ZippedBinder to TyConBinder        for  tyConBinders-          --                       and to [(Name, TcTyVar)]  for  tcTyConScopedTyVars-        ; (vis_tcbs, concat -> explicit_tv_prs) <- mapAndUnzipM zipped_to_tcb zipped_binders--        ; (tclvl, wanted, (implicit_tvs, (invis_binders, r_ki)))-             <- pushLevelAndSolveEqualitiesX "kcCheckDeclHeader_sig" $  -- #16687-                bindImplicitTKBndrs_Tv implicit_nms                  $-                tcExtendNameTyVarEnv explicit_tv_prs                 $-                do { -- Check that inline kind annotations on binders are valid.-                     -- For example:-                     ---                     --   type T :: Maybe k -> Type-                     --   data T (a :: Maybe j) = ...-                     ---                     -- Here we unify   Maybe k ~ Maybe j-                     mapM_ check_zipped_binder zipped_binders--                     -- Kind-check the result kind annotation, if present:-                     ---                     --    data T a b :: res_ki where-                     --               ^^^^^^^^^-                     -- We do it here because at this point the environment has been-                     -- extended with both 'implicit_tcv_prs' and 'explicit_tv_prs'.-                   ; ctx_k    <- kc_res_ki-                   ; m_res_ki <- case ctx_k of-                                  AnyKind -> return Nothing-                                  _ -> Just <$> newExpectedKind ctx_k--                     -- Step 2: split off invisible binders.-                     -- For example:-                     ---                     --   type F :: forall k1 k2. (k1, k2) -> Type-                     --   type family F-                     ---                     -- Does 'forall k1 k2' become a part of 'tyConBinders' or 'tyConResKind'?-                     -- See Note [Arity inference in kcCheckDeclHeader_sig]-                   ; let (invis_binders, r_ki) = split_invis kisig' m_res_ki--                     -- Check that the inline result kind annotation is valid.-                     -- For example:-                     ---                     --   type T :: Type -> Maybe k-                     --   type family T a :: Maybe j where-                     ---                     -- Here we unify   Maybe k ~ Maybe j-                   ; whenIsJust m_res_ki $ \res_ki ->-                      discardResult $ -- See Note [discardResult in kcCheckDeclHeader_sig]-                      unifyKind Nothing r_ki res_ki--                   ; return (invis_binders, r_ki) }--        -- Convert each invisible TyCoBinder to TyConBinder for tyConBinders.-        ; invis_tcbs <- mapM invis_to_tcb invis_binders--        -- Zonk the implicitly quantified variables.-        ; implicit_tvs <- mapM zonkTcTyVarToTyVar implicit_tvs--        -- Build the final, generalized TcTyCon-        ; let tcbs            = vis_tcbs ++ invis_tcbs-              implicit_tv_prs = implicit_nms `zip` implicit_tvs-              all_tv_prs      = implicit_tv_prs ++ explicit_tv_prs-              tc              = mkTcTyCon name tcbs r_ki all_tv_prs True flav-              skol_info       = TyConSkol flav name--        -- Check that there are no unsolved equalities-        ; reportUnsolvedEqualities skol_info (binderVars tcbs) tclvl wanted--        ; traceTc "kcCheckDeclHeader_sig done:" $ vcat-          [ text "tyConName = " <+> ppr (tyConName tc)-          , text "kisig =" <+> debugPprType kisig-          , text "tyConKind =" <+> debugPprType (tyConKind tc)-          , text "tyConBinders = " <+> ppr (tyConBinders tc)-          , text "tcTyConScopedTyVars" <+> ppr (tcTyConScopedTyVars tc)-          , text "tyConResKind" <+> debugPprType (tyConResKind tc)-          ]-        ; return tc }-  where-    -- Consider this declaration:-    ---    --    type T :: forall a. forall b -> (a~b) => Proxy a -> Type-    --    data T x p = MkT-    ---    -- Here, we have every possible variant of ZippedBinder:-    ---    --                   TyBinder           LHsTyVarBndr-    --    -----------------------------------------------    --    ZippedBinder   forall {k}.-    --    ZippedBinder   forall (a::k).-    --    ZippedBinder   forall (b::k) ->   x-    --    ZippedBinder   (a~b) =>-    --    ZippedBinder   Proxy a ->         p-    ---    -- Given a ZippedBinder zipped_to_tcb produces:-    ---    --  * TyConBinder      for  tyConBinders-    --  * (Name, TcTyVar)  for  tcTyConScopedTyVars, if there's a user-written LHsTyVarBndr-    ---    zipped_to_tcb :: ZippedBinder -> TcM (TyConBinder, [(Name, TcTyVar)])-    zipped_to_tcb zb = case zb of--      -- Inferred variable, no user-written binder.-      -- Example:   forall {k}.-      ZippedBinder (Named (Bndr v Specified)) Nothing ->-        return (mkNamedTyConBinder Specified v, [])--      -- Specified variable, no user-written binder.-      -- Example:   forall (a::k).-      ZippedBinder (Named (Bndr v Inferred)) Nothing ->-        return (mkNamedTyConBinder Inferred v, [])--      -- Constraint, no user-written binder.-      -- Example:   (a~b) =>-      ZippedBinder (Anon InvisArg bndr_ki) Nothing -> do-        name <- newSysName (mkTyVarOccFS (fsLit "ev"))-        let tv = mkTyVar name (scaledThing bndr_ki)-        return (mkAnonTyConBinder InvisArg tv, [])--      -- Non-dependent visible argument with a user-written binder.-      -- Example:   Proxy a ->-      ZippedBinder (Anon VisArg bndr_ki) (Just b) ->-        return $-          let v_name = getName b-              tv = mkTyVar v_name (scaledThing bndr_ki)-              tcb = mkAnonTyConBinder VisArg tv-          in (tcb, [(v_name, tv)])--      -- Dependent visible argument with a user-written binder.-      -- Example:   forall (b::k) ->-      ZippedBinder (Named (Bndr v Required)) (Just b) ->-        return $-          let v_name = getName b-              tcb = mkNamedTyConBinder Required v-          in (tcb, [(v_name, v)])--      -- 'zipBinders' does not produce any other variants of ZippedBinder.-      _ -> panic "goVis: invalid ZippedBinder"--    -- Given an invisible binder that comes from 'split_invis',-    -- convert it to TyConBinder.-    invis_to_tcb :: TyCoBinder -> TcM TyConBinder-    invis_to_tcb tb = do-      (tcb, stv) <- zipped_to_tcb (ZippedBinder tb Nothing)-      MASSERT(null stv)-      return tcb--    -- Check that the inline kind annotation on a binder is valid-    -- by unifying it with the kind of the quantifier.-    check_zipped_binder :: ZippedBinder -> TcM ()-    check_zipped_binder (ZippedBinder _ Nothing) = return ()-    check_zipped_binder (ZippedBinder tb (Just b)) =-      case unLoc b of-        UserTyVar _ _ _ -> return ()-        KindedTyVar _ _ v v_hs_ki -> do-          v_ki <- tcLHsKindSig (TyVarBndrKindCtxt (unLoc v)) v_hs_ki-          discardResult $ -- See Note [discardResult in kcCheckDeclHeader_sig]-            unifyKind (Just (ppr v))-                      (tyBinderType tb)-                      v_ki--    -- Split the invisible binders that should become a part of 'tyConBinders'-    -- rather than 'tyConResKind'.-    -- See Note [Arity inference in kcCheckDeclHeader_sig]-    split_invis :: Kind -> Maybe Kind -> ([TyCoBinder], Kind)-    split_invis sig_ki Nothing =-      -- instantiate all invisible binders-      splitInvisPiTys sig_ki-    split_invis sig_ki (Just res_ki) =-      -- subtraction a la checkExpectedKind-      let n_res_invis_bndrs = invisibleTyBndrCount res_ki-          n_sig_invis_bndrs = invisibleTyBndrCount sig_ki-          n_inst = n_sig_invis_bndrs - n_res_invis_bndrs-      in splitInvisPiTysN n_inst sig_ki---- A quantifier from a kind signature zipped with a user-written binder for it.-data ZippedBinder = ZippedBinder TyBinder (Maybe (LHsTyVarBndr () GhcRn))---- See Note [Arity inference in kcCheckDeclHeader_sig]-zipBinders-  :: Kind                      -- Kind signature-  -> [LHsTyVarBndr () GhcRn]   -- User-written binders-  -> ( [ZippedBinder]          -- Zipped binders-     , [LHsTyVarBndr () GhcRn] -- Leftover user-written binders-     , Kind )                  -- Remainder of the kind signature-zipBinders = zip_binders [] emptyTCvSubst-  where-    -- subst: we substitute as we go, to ensure that the resulting-    -- binders in the [ZippedBndr] all have distinct uniques.-    -- If not, the TyCon may get multiple binders with the same unique,-    -- which results in chaos (see #19092,3,4)-    -- (The incoming kind might be forall k. k -> forall k. k -> Type-    --  where those two k's have the same unique. Without the substitution-    --  we'd get a repeated 'k'.)-    zip_binders acc subst ki bs-      | (b:bs') <- bs  -- Stop as soon as 'bs' becomes empty-      , Just (tb,ki') <- tcSplitPiTy_maybe ki-      , let (subst', tb') = substTyCoBndr subst tb-      = if isInvisibleBinder tb-        then zip_binders (ZippedBinder tb' Nothing  : acc) subst' ki' bs-        else zip_binders (ZippedBinder tb' (Just b) : acc) subst' ki' bs'--      | otherwise-      = (reverse acc, bs, substTy subst ki)--tooManyBindersErr :: Kind -> [LHsTyVarBndr () GhcRn] -> SDoc-tooManyBindersErr ki bndrs =-   hang (text "Not a function kind:")-      4 (ppr ki) $$-   hang (text "but extra binders found:")-      4 (fsep (map ppr bndrs))--{- Note [Arity inference in kcCheckDeclHeader_sig]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Given a kind signature 'kisig' and a declaration header, kcCheckDeclHeader_sig-verifies that the declaration conforms to the signature. The end result is a-TcTyCon 'tc' such that:--  tyConKind tc == kisig--This TcTyCon would be rather easy to produce if we didn't have to worry about-arity. Consider these declarations:--  type family S1 :: forall k. k -> Type-  type family S2 (a :: k) :: Type--Both S1 and S2 can be given the same standalone kind signature:--  type S2 :: forall k. k -> Type--And, indeed, tyConKind S1 == tyConKind S2. However, tyConKind is built from-tyConBinders and tyConResKind, such that--  tyConKind tc == mkTyConKind (tyConBinders tc) (tyConResKind tc)--For S1 and S2, tyConBinders and tyConResKind are different:--  tyConBinders S1  ==  []-  tyConResKind S1  ==  forall k. k -> Type-  tyConKind    S1  ==  forall k. k -> Type--  tyConBinders S2  ==  [spec k, anon-vis (a :: k)]-  tyConResKind S2  ==  Type-  tyConKind    S1  ==  forall k. k -> Type--This difference determines the arity:--  tyConArity tc == length (tyConBinders tc)--That is, the arity of S1 is 0, while the arity of S2 is 2.--'kcCheckDeclHeader_sig' needs to infer the desired arity to split the standalone-kind signature into binders and the result kind. It does so in two rounds:--1. zip user-written binders (vis_tcbs)-2. split off invisible binders (invis_tcbs)--Consider the following declarations:--    type F :: Type -> forall j. j -> forall k1 k2. (k1, k2) -> Type-    type family F a b--    type G :: Type -> forall j. j -> forall k1 k2. (k1, k2) -> Type-    type family G a b :: forall r2. (r1, r2) -> Type--In step 1 (zip user-written binders), we zip the quantifiers in the signature-with the binders in the header using 'zipBinders'. In both F and G, this results in-the following zipped binders:--                   TyBinder     LHsTyVarBndr-    ----------------------------------------    ZippedBinder   Type ->      a-    ZippedBinder   forall j.-    ZippedBinder   j ->         b---At this point, we have accumulated three zipped binders which correspond to a-prefix of the standalone kind signature:--  Type -> forall j. j -> ...--In step 2 (split off invisible binders), we have to decide how much remaining-invisible binders of the standalone kind signature to split off:--    forall k1 k2. (k1, k2) -> Type-    ^^^^^^^^^^^^^-    split off or not?--This decision is made in 'split_invis':--* If a user-written result kind signature is not provided, as in F,-  then split off all invisible binders. This is why we need special treatment-  for AnyKind.-* If a user-written result kind signature is provided, as in G,-  then do as checkExpectedKind does and split off (n_sig - n_res) binders.-  That is, split off such an amount of binders that the remainder of the-  standalone kind signature and the user-written result kind signature have the-  same amount of invisible quantifiers.--For F, split_invis splits away all invisible binders, and we have 2:--    forall k1 k2. (k1, k2) -> Type-    ^^^^^^^^^^^^^-    split away both binders--The resulting arity of F is 3+2=5.  (length vis_tcbs = 3,-                                     length invis_tcbs = 2,-                                     length tcbs = 5)--For G, split_invis decides to split off 1 invisible binder, so that we have the-same amount of invisible quantifiers left:--    res_ki  =  forall    r2. (r1, r2) -> Type-    kisig   =  forall k1 k2. (k1, k2) -> Type-                     ^^^-                     split off this one.--The resulting arity of G is 3+1=4. (length vis_tcbs = 3,-                                    length invis_tcbs = 1,-                                    length tcbs = 4)---}--{- Note [discardResult in kcCheckDeclHeader_sig]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We use 'unifyKind' to check inline kind annotations in declaration headers-against the signature.--  type T :: [i] -> Maybe j -> Type-  data T (a :: [k1]) (b :: Maybe k2) :: Type where ...--Here, we will unify:--       [k1] ~ [i]-  Maybe k2  ~ Maybe j-      Type  ~ Type--The end result is that we fill in unification variables k1, k2:--    k1  :=  i-    k2  :=  j--We also validate that the user isn't confused:--  type T :: Type -> Type-  data T (a :: Bool) = ...--This will report that (Type ~ Bool) failed to unify.--Now, consider the following example:--  type family Id a where Id x = x-  type T :: Bool -> Type-  type T (a :: Id Bool) = ...--We will unify (Bool ~ Id Bool), and this will produce a non-reflexive coercion.-However, we are free to discard it, as the kind of 'T' is determined by the-signature, not by the inline kind annotation:--      we have   T ::    Bool -> Type-  rather than   T :: Id Bool -> Type--This (Id Bool) will not show up anywhere after we're done validating it, so we-have no use for the produced coercion.--}--{- Note [No polymorphic recursion]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Should this kind-check?-  data T ka (a::ka) b  = MkT (T Type           Int   Bool)-                             (T (Type -> Type) Maybe Bool)--Notice that T is used at two different kinds in its RHS.  No!-This should not kind-check.  Polymorphic recursion is known to-be a tough nut.--Previously, we laboriously (with help from the renamer)-tried to give T the polymorphic kind-   T :: forall ka -> ka -> kappa -> Type-where kappa is a unification variable, even in the inferInitialKinds-phase (which is what kcInferDeclHeader is all about).  But-that is dangerously fragile (see the ticket).--Solution: make kcInferDeclHeader give T a straightforward-monomorphic kind, with no quantification whatsoever. That's why-we use mkAnonTyConBinder for all arguments when figuring out-tc_binders.--But notice that (#16322 comment:3)--* The algorithm successfully kind-checks this declaration:-    data T2 ka (a::ka) = MkT2 (T2 Type a)--  Starting with (inferInitialKinds)-    T2 :: (kappa1 :: kappa2 :: *) -> (kappa3 :: kappa4 :: *) -> *-  we get-    kappa4 := kappa1   -- from the (a:ka) kind signature-    kappa1 := Type     -- From application T2 Type--  These constraints are soluble so generaliseTcTyCon gives-    T2 :: forall (k::Type) -> k -> *--  But now the /typechecking/ (aka desugaring, tcTyClDecl) phase-  fails, because the call (T2 Type a) in the RHS is ill-kinded.--  We'd really prefer all errors to show up in the kind checking-  phase.--* This algorithm still accepts (in all phases)-     data T3 ka (a::ka) = forall b. MkT3 (T3 Type b)-  although T3 is really polymorphic-recursive too.-  Perhaps we should somehow reject that.--Note [Kind variable ordering for associated types]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-What should be the kind of `T` in the following example? (#15591)--  class C (a :: Type) where-    type T (x :: f a)--As per Note [Ordering of implicit variables] in GHC.Rename.HsType, we want to quantify-the kind variables in left-to-right order of first occurrence in order to-support visible kind application. But we cannot perform this analysis on just-T alone, since its variable `a` actually occurs /before/ `f` if you consider-the fact that `a` was previously bound by the parent class `C`. That is to say,-the kind of `T` should end up being:--  T :: forall a f. f a -> Type--(It wouldn't necessarily be /wrong/ if the kind ended up being, say,-forall f a. f a -> Type, but that would not be as predictable for users of-visible kind application.)--In contrast, if `T` were redefined to be a top-level type family, like `T2`-below:--  type family T2 (x :: f (a :: Type))--Then `a` first appears /after/ `f`, so the kind of `T2` should be:--  T2 :: forall f a. f a -> Type--In order to make this distinction, we need to know (in kcCheckDeclHeader) which-type variables have been bound by the parent class (if there is one). With-the class-bound variables in hand, we can ensure that we always quantify-these first.--}---{- *********************************************************************-*                                                                      *-             Expected kinds-*                                                                      *-********************************************************************* -}---- | Describes the kind expected in a certain context.-data ContextKind = TheKind Kind   -- ^ a specific kind-                 | AnyKind        -- ^ any kind will do-                 | OpenKind       -- ^ something of the form @TYPE _@--------------------------newExpectedKind :: ContextKind -> TcM Kind-newExpectedKind (TheKind k)   = return k-newExpectedKind AnyKind       = newMetaKindVar-newExpectedKind OpenKind      = newOpenTypeKind--------------------------expectedKindInCtxt :: UserTypeCtxt -> ContextKind--- Depending on the context, we might accept any kind (for instance, in a TH--- splice), or only certain kinds (like in type signatures).-expectedKindInCtxt (TySynCtxt _)   = AnyKind-expectedKindInCtxt (GhciCtxt {})   = AnyKind--- The types in a 'default' decl can have varying kinds--- See Note [Extended defaults]" in GHC.Tc.Utils.Env-expectedKindInCtxt DefaultDeclCtxt     = AnyKind-expectedKindInCtxt DerivClauseCtxt     = AnyKind-expectedKindInCtxt TypeAppCtxt         = AnyKind-expectedKindInCtxt (ForSigCtxt _)      = TheKind liftedTypeKind-expectedKindInCtxt (InstDeclCtxt {})   = TheKind constraintKind-expectedKindInCtxt SpecInstCtxt        = TheKind constraintKind-expectedKindInCtxt _                   = OpenKind---{- *********************************************************************-*                                                                      *-             Bringing type variables into scope-*                                                                      *-********************************************************************* -}-------------------------------------------    HsForAllTelescope-----------------------------------------tcTKTelescope :: TcTyMode-              -> HsForAllTelescope GhcRn-              -> TcM a-              -> TcM ([TcTyVarBinder], a)-tcTKTelescope mode tele thing_inside = case tele of-  HsForAllVis { hsf_vis_bndrs = bndrs }-    -> do { (req_tv_bndrs, thing) <- tcExplicitTKBndrsX skol_mode bndrs thing_inside-            -- req_tv_bndrs :: [VarBndr TyVar ()],-            -- but we want [VarBndr TyVar ArgFlag]-          ; return (tyVarReqToBinders req_tv_bndrs, thing) }--  HsForAllInvis { hsf_invis_bndrs = bndrs }-    -> do { (inv_tv_bndrs, thing) <- tcExplicitTKBndrsX skol_mode bndrs thing_inside-            -- inv_tv_bndrs :: [VarBndr TyVar Specificity],-            -- but we want [VarBndr TyVar ArgFlag]-          ; return (tyVarSpecToBinders inv_tv_bndrs, thing) }-  where-    skol_mode = smVanilla { sm_clone = False, sm_holes = mode_holes mode }-------------------------------------------    HsOuterTyVarBndrs-----------------------------------------bindOuterTKBndrsX :: OutputableBndrFlag flag 'Renamed-                  => SkolemMode-                  -> HsOuterTyVarBndrs flag GhcRn-                  -> TcM a-                  -> TcM (HsOuterTyVarBndrs flag GhcTc, a)-bindOuterTKBndrsX skol_mode outer_bndrs thing_inside-  = case outer_bndrs of-      HsOuterImplicit{hso_ximplicit = imp_tvs} ->-        do { (imp_tvs', thing) <- bindImplicitTKBndrsX skol_mode imp_tvs thing_inside-           ; return ( HsOuterImplicit{hso_ximplicit = imp_tvs'}-                    , thing) }-      HsOuterExplicit{hso_bndrs = exp_bndrs} ->-        do { (exp_tvs', thing) <- bindExplicitTKBndrsX skol_mode exp_bndrs thing_inside-           ; return ( HsOuterExplicit { hso_xexplicit = exp_tvs'-                                      , hso_bndrs     = exp_bndrs }-                    , thing) }--getOuterTyVars :: HsOuterTyVarBndrs flag GhcTc -> [TcTyVar]--- The returned [TcTyVar] is not necessarily in dependency order--- at least for the HsOuterImplicit case-getOuterTyVars (HsOuterImplicit { hso_ximplicit = tvs })  = tvs-getOuterTyVars (HsOuterExplicit { hso_xexplicit = tvbs }) = binderVars tvbs------------------scopedSortOuter :: HsOuterTyVarBndrs Specificity GhcTc -> TcM [InvisTVBinder]--- Sort any /implicit/ binders into dependency order---     (zonking first so we can see the dependencies)--- /Explicit/ ones are already in the right order-scopedSortOuter (HsOuterImplicit{hso_ximplicit = imp_tvs})-  = do { imp_tvs <- zonkAndScopedSort imp_tvs-       ; return [Bndr tv SpecifiedSpec | tv <- imp_tvs] }-scopedSortOuter (HsOuterExplicit{hso_xexplicit = exp_tvs})-  = -- No need to dependency-sort (or zonk) explicit quantifiers-    return exp_tvs------------------bindOuterSigTKBndrs_Tv :: HsOuterSigTyVarBndrs GhcRn-                       -> TcM a -> TcM (HsOuterSigTyVarBndrs GhcTc, a)-bindOuterSigTKBndrs_Tv-  = bindOuterTKBndrsX (smVanilla { sm_clone = True, sm_tvtv = True })--bindOuterSigTKBndrs_Tv_M :: TcTyMode-                         -> HsOuterSigTyVarBndrs GhcRn-                         -> TcM a -> TcM (HsOuterSigTyVarBndrs GhcTc, a)--- Do not push level; do not make implication constraint; use Tvs--- Two major clients of this "bind-only" path are:---    Note [Using TyVarTvs for kind-checking GADTs] in GHC.Tc.TyCl---    Note [Checking partial type signatures]-bindOuterSigTKBndrs_Tv_M mode-  = bindOuterTKBndrsX (smVanilla { sm_clone = True, sm_tvtv = True-                                 , sm_holes = mode_holes mode })--bindOuterFamEqnTKBndrs_Q_Tv :: HsOuterFamEqnTyVarBndrs GhcRn-                            -> TcM a-                            -> TcM ([TcTyVar], a)-bindOuterFamEqnTKBndrs_Q_Tv hs_bndrs thing_inside-  = liftFstM getOuterTyVars $-    bindOuterTKBndrsX (smVanilla { sm_clone = False, sm_parent = True-                                 , sm_tvtv = True })-                      hs_bndrs thing_inside-    -- sm_clone=False: see Note [Cloning for type variable binders]--bindOuterFamEqnTKBndrs :: HsOuterFamEqnTyVarBndrs GhcRn-                       -> TcM a-                       -> TcM ([TcTyVar], a)-bindOuterFamEqnTKBndrs hs_bndrs thing_inside-  = liftFstM getOuterTyVars $-    bindOuterTKBndrsX (smVanilla { sm_clone = False, sm_parent = True })-                      hs_bndrs thing_inside-    -- sm_clone=False: see Note [Cloning for type variable binders]------------------tcOuterTKBndrs :: OutputableBndrFlag flag 'Renamed-               => SkolemInfo-               -> HsOuterTyVarBndrs flag GhcRn-               -> TcM a -> TcM (HsOuterTyVarBndrs flag GhcTc, a)-tcOuterTKBndrs = tcOuterTKBndrsX (smVanilla { sm_clone = False })-  -- Do not clone the outer binders-  -- See Note [Cloning for type variable binder] under "must not"--tcOuterTKBndrsX :: OutputableBndrFlag flag 'Renamed-                => SkolemMode -> SkolemInfo-                -> HsOuterTyVarBndrs flag GhcRn-                -> TcM a -> TcM (HsOuterTyVarBndrs flag GhcTc, a)--- Push level, capture constraints, make implication-tcOuterTKBndrsX skol_mode skol_info outer_bndrs thing_inside-  = case outer_bndrs of-      HsOuterImplicit{hso_ximplicit = imp_tvs} ->-        do { (imp_tvs', thing) <- tcImplicitTKBndrsX skol_mode skol_info imp_tvs thing_inside-           ; return ( HsOuterImplicit{hso_ximplicit = imp_tvs'}-                    , thing) }-      HsOuterExplicit{hso_bndrs = exp_bndrs} ->-        do { (exp_tvs', thing) <- tcExplicitTKBndrsX skol_mode exp_bndrs thing_inside-           ; return ( HsOuterExplicit { hso_xexplicit = exp_tvs'-                                      , hso_bndrs     = exp_bndrs }-                    , thing) }-------------------------------------------    Explicit tyvar binders-----------------------------------------tcExplicitTKBndrs :: OutputableBndrFlag flag 'Renamed-                  => [LHsTyVarBndr flag GhcRn]-                  -> TcM a-                  -> TcM ([VarBndr TyVar flag], a)-tcExplicitTKBndrs = tcExplicitTKBndrsX (smVanilla { sm_clone = True })--tcExplicitTKBndrsX :: OutputableBndrFlag flag 'Renamed-                   => SkolemMode-                   -> [LHsTyVarBndr flag GhcRn]-                   -> TcM a-                   -> TcM ([VarBndr TyVar flag], a)--- Push level, capture constraints,--- and emit an implication constraint with a ForAllSkol ic_info,--- so that it is subject to a telescope test.-tcExplicitTKBndrsX skol_mode bndrs thing_inside-  = do { (tclvl, wanted, (skol_tvs, res))-             <- pushLevelAndCaptureConstraints $-                bindExplicitTKBndrsX skol_mode bndrs $-                thing_inside--       ; let skol_info = ForAllSkol (fsep (map ppr bndrs))-             -- Notice that we use ForAllSkol here, ignoring the enclosing-             -- skol_info unlike tc_implicit_tk_bndrs, because the bad-telescope-             -- test applies only to ForAllSkol-       ; emitResidualTvConstraint skol_info (binderVars skol_tvs) tclvl wanted--       ; return (skol_tvs, res) }--------------------- | Skolemise the 'HsTyVarBndr's in an 'HsForAllTelescope' with the supplied--- 'TcTyMode'.-bindExplicitTKBndrs_Skol, bindExplicitTKBndrs_Tv-    :: (OutputableBndrFlag flag 'Renamed)-    => [LHsTyVarBndr flag GhcRn]-    -> TcM a-    -> TcM ([VarBndr TyVar flag], a)--bindExplicitTKBndrs_Skol = bindExplicitTKBndrsX (smVanilla { sm_clone = False })-bindExplicitTKBndrs_Tv   = bindExplicitTKBndrsX (smVanilla { sm_clone = True, sm_tvtv = True })-   -- sm_clone: see Note [Cloning for type variable binders]--bindExplicitTKBndrs_Q_Skol, bindExplicitTKBndrs_Q_Tv-    :: ContextKind-    -> [LHsTyVarBndr () GhcRn]-    -> TcM a-    -> TcM ([TcTyVar], a)--- These do not clone: see Note [Cloning for type variable binders]-bindExplicitTKBndrs_Q_Skol ctxt_kind hs_bndrs thing_inside-  = liftFstM binderVars $-    bindExplicitTKBndrsX (smVanilla { sm_clone = False, sm_parent = True-                                    , sm_kind = ctxt_kind })-                         hs_bndrs thing_inside-    -- sm_clone=False: see Note [Cloning for type variable binders]--bindExplicitTKBndrs_Q_Tv ctxt_kind hs_bndrs thing_inside-  = liftFstM binderVars $-    bindExplicitTKBndrsX (smVanilla { sm_clone = False, sm_parent = True-                                    , sm_tvtv = True, sm_kind = ctxt_kind })-                         hs_bndrs thing_inside-    -- sm_clone=False: see Note [Cloning for type variable binders]--bindExplicitTKBndrsX :: (OutputableBndrFlag flag 'Renamed)-    => SkolemMode-    -> [LHsTyVarBndr flag GhcRn]-    -> TcM a-    -> TcM ([VarBndr TyVar flag], a)  -- Returned [TcTyVar] are in 1-1 correspondence-                                      -- with the passed-in [LHsTyVarBndr]-bindExplicitTKBndrsX skol_mode@(SM { sm_parent = check_parent, sm_kind = ctxt_kind-                                   , sm_holes = hole_info })-                     hs_tvs thing_inside-  = do { traceTc "bindExplicitTKBndrs" (ppr hs_tvs)-       ; go hs_tvs }-  where-    tc_ki_mode = TcTyMode { mode_tyki = KindLevel, mode_holes = hole_info }-                 -- Inherit the HoleInfo from the context--    go [] = do { res <- thing_inside-               ; return ([], res) }-    go (L _ hs_tv : hs_tvs)-       = do { lcl_env <- getLclTypeEnv-            ; tv <- tc_hs_bndr lcl_env hs_tv-            -- Extend the environment as we go, in case a binder-            -- is mentioned in the kind of a later binder-            --   e.g. forall k (a::k). blah-            -- NB: tv's Name may differ from hs_tv's-            -- See Note [Cloning for type variable binders]-            ; (tvs,res) <- tcExtendNameTyVarEnv [(hsTyVarName hs_tv, tv)] $-                           go hs_tvs-            ; return (Bndr tv (hsTyVarBndrFlag hs_tv):tvs, res) }---    tc_hs_bndr lcl_env (UserTyVar _ _ (L _ name))-      | check_parent-      , Just (ATyVar _ tv) <- lookupNameEnv lcl_env name-      = return tv-      | otherwise-      = do { kind <- newExpectedKind ctxt_kind-           ; newTyVarBndr skol_mode name kind }--    tc_hs_bndr lcl_env (KindedTyVar _ _ (L _ name) lhs_kind)-      | check_parent-      , Just (ATyVar _ tv) <- lookupNameEnv lcl_env name-      = do { kind <- tc_lhs_kind_sig tc_ki_mode (TyVarBndrKindCtxt name) lhs_kind-           ; discardResult $-             unifyKind (Just (ppr name)) kind (tyVarKind tv)-                          -- This unify rejects:-                          --    class C (m :: * -> *) where-                          --      type F (m :: *) = ...-           ; return tv }--      | otherwise-      = do { kind <- tc_lhs_kind_sig tc_ki_mode (TyVarBndrKindCtxt name) lhs_kind-           ; newTyVarBndr skol_mode name kind }--newTyVarBndr :: SkolemMode -> Name -> Kind -> TcM TcTyVar-newTyVarBndr (SM { sm_clone = clone, sm_tvtv = tvtv }) name kind-  = do { name <- case clone of-              True -> do { uniq <- newUnique-                         ; return (setNameUnique name uniq) }-              False -> return name-       ; details <- case tvtv of-                 True  -> newMetaDetails TyVarTv-                 False -> do { lvl <- getTcLevel-                             ; return (SkolemTv lvl False) }-       ; return (mkTcTyVar name kind details) }-------------------------------------------    Implicit tyvar binders-----------------------------------------tcImplicitTKBndrsX :: SkolemMode -> SkolemInfo-                   -> [Name]-                   -> TcM a-                   -> TcM ([TcTyVar], a)--- The workhorse:---    push level, capture constraints,---    and emit an implication constraint with a ForAllSkol ic_info,---    so that it is subject to a telescope test.-tcImplicitTKBndrsX skol_mode skol_info bndrs thing_inside-  = do { (tclvl, wanted, (skol_tvs, res))-             <- pushLevelAndCaptureConstraints       $-                bindImplicitTKBndrsX skol_mode bndrs $-                thing_inside--       ; emitResidualTvConstraint skol_info skol_tvs tclvl wanted--       ; return (skol_tvs, res) }---------------------bindImplicitTKBndrs_Skol, bindImplicitTKBndrs_Tv,-  bindImplicitTKBndrs_Q_Skol, bindImplicitTKBndrs_Q_Tv-  :: [Name] -> TcM a -> TcM ([TcTyVar], a)-bindImplicitTKBndrs_Skol   = bindImplicitTKBndrsX (smVanilla { sm_clone = True })-bindImplicitTKBndrs_Tv     = bindImplicitTKBndrsX (smVanilla { sm_clone = True, sm_tvtv = True })-bindImplicitTKBndrs_Q_Skol = bindImplicitTKBndrsX (smVanilla { sm_clone = False, sm_parent = True })-bindImplicitTKBndrs_Q_Tv   = bindImplicitTKBndrsX (smVanilla { sm_clone = False, sm_parent = True, sm_tvtv = True })--bindImplicitTKBndrsX-   :: SkolemMode-   -> [Name]-   -> TcM a-   -> TcM ([TcTyVar], a)   -- Returned [TcTyVar] are in 1-1 correspondence-                           -- with the passed in [Name]-bindImplicitTKBndrsX skol_mode@(SM { sm_parent = check_parent, sm_kind = ctxt_kind })-                     tv_names thing_inside-  = do { lcl_env <- getLclTypeEnv-       ; tkvs <- mapM (new_tv lcl_env) tv_names-       ; traceTc "bindImplicitTKBndrsX" (ppr tv_names $$ ppr tkvs)-       ; res <- tcExtendNameTyVarEnv (tv_names `zip` tkvs)-                thing_inside-       ; return (tkvs, res) }-  where-    new_tv lcl_env name-      | check_parent-      , Just (ATyVar _ tv) <- lookupNameEnv lcl_env name-      = return tv-      | otherwise-      = do { kind <- newExpectedKind ctxt_kind-           ; newTyVarBndr skol_mode name kind }-------------------------------------------           SkolemMode------------------------------------------- | 'SkolemMode' describes how to typecheck an explicit ('HsTyVarBndr') or--- implicit ('Name') binder in a type. It is just a record of flags--- that describe what sort of 'TcTyVar' to create.-data SkolemMode-  = SM { sm_parent :: Bool    -- True <=> check the in-scope parent type variable-                              -- Used only for asssociated types--       , sm_clone  :: Bool    -- True <=> fresh unique-                              -- See Note [Cloning for type variable binders]--       , sm_tvtv   :: Bool    -- True <=> use a TyVarTv, rather than SkolemTv-                              -- Why?  See Note [Inferring kinds for type declarations]-                              -- in GHC.Tc.TyCl, and (in this module)-                              -- Note [Checking partial type signatures]--       , sm_kind   :: ContextKind  -- Use this for the kind of any new binders--       , sm_holes  :: HoleInfo     -- What to do for wildcards in the kind-       }--smVanilla :: SkolemMode-smVanilla = SM { sm_clone  = panic "sm_clone"  -- We always override this-               , sm_parent = False-               , sm_tvtv   = False-               , sm_kind   = AnyKind-               , sm_holes  = Nothing }--{- Note [Cloning for type variable binders]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Sometimes we must clone the Name of a type variable binder (written in-the source program); and sometimes we must not. This is controlled by-the sm_clone field of SkolemMode.--In some cases it doesn't matter whether or not we clone. Perhaps-it'd be better to use MustClone/MayClone/MustNotClone.--When we /must not/ clone-* In the binders of a type signature (tcOuterTKBndrs)-      f :: forall a{27}. blah-      f = rhs-  Then 'a' scopes over 'rhs'. When we kind-check the signature (tcHsSigType),-  we must get the type (forall a{27}. blah) for the Id f, because-  we bring that type variable into scope when we typecheck 'rhs'.--* In the binders of a data family instance (bindOuterFamEqnTKBndrs)-     data instance-       forall p q. D (p,q) = D1 p | D2 q-  We kind-check the LHS in tcDataFamInstHeader, and then separately-  (in tcDataFamInstDecl) bring p,q into scope before looking at the-  the constructor decls.--* bindExplicitTKBndrs_Q_Tv/bindImplicitTKBndrs_Q_Tv do not clone-  We take advantage of this in kcInferDeclHeader:-     all_tv_prs = mkTyVarNamePairs (scoped_kvs ++ tc_tvs)-  If we cloned, we'd need to take a bit more care here; not hard.--* bindExplicitTKBndrs_Q_Skol, bindExplicitTKBndrs_Skol, do not clone.-  There is no need, I think.--  The payoff here is that avoiding gratuitous cloning means that we can-  almost always take the fast path in swizzleTcTyConBndrs.--When we /must/ clone.-* bindOuterSigTKBndrs_Tv, bindExplicitTKBndrs_Tv do cloning--  This for a narrow and tricky reason which, alas, I couldn't find a-  simpler way round.  #16221 is the poster child:--     data SameKind :: k -> k -> *-     data T a = forall k2 (b :: k2). MkT (SameKind a b) !Int--  When kind-checking T, we give (a :: kappa1). Then:--  - In kcConDecl we make a TyVarTv unification variable kappa2 for k2-    (as described in Note [Using TyVarTvs for kind-checking GADTs],-    even though this example is an existential)-  - So we get (b :: kappa2) via bindExplicitTKBndrs_Tv-  - We end up unifying kappa1 := kappa2, because of the (SameKind a b)--  Now we generalise over kappa2. But if kappa2's Name is precisely k2-  (i.e. we did not clone) we'll end up giving T the utterly final kind-    T :: forall k2. k2 -> *-  Nothing directly wrong with that but when we typecheck the data constructor-  we have k2 in scope; but then it's brought into scope /again/ when we find-  the forall k2.  This is chaotic, and we end up giving it the type-    MkT :: forall k2 (a :: k2) k2 (b :: k2).-           SameKind @k2 a b -> Int -> T @{k2} a-  which is bogus -- because of the shadowing of k2, we can't-  apply T to the kind or a!--  And there no reason /not/ to clone the Name when making a unification-  variable.  So that's what we do.--}------------------------------------------- Binding type/class variables in the--- kind-checking and typechecking phases-----------------------------------------bindTyClTyVars :: Name-               -> (TcTyCon -> [TyConBinder] -> Kind -> TcM a) -> TcM a--- ^ Used for the type variables of a type or class decl--- in the "kind checking" and "type checking" pass,--- but not in the initial-kind run.-bindTyClTyVars tycon_name thing_inside-  = do { tycon <- tcLookupTcTyCon tycon_name-       ; let scoped_prs = tcTyConScopedTyVars tycon-             res_kind   = tyConResKind tycon-             binders    = tyConBinders tycon-       ; traceTc "bindTyClTyVars" (ppr tycon_name <+> ppr binders $$ ppr scoped_prs)-       ; tcExtendNameTyVarEnv scoped_prs $-         thing_inside tycon binders res_kind }---{- *********************************************************************-*                                                                      *-             Kind generalisation-*                                                                      *-********************************************************************* -}--zonkAndScopedSort :: [TcTyVar] -> TcM [TcTyVar]-zonkAndScopedSort spec_tkvs-  = do { spec_tkvs <- mapM zonkTcTyVarToTyVar spec_tkvs-         -- Zonk the kinds, to we can do the dependency analayis--       -- Do a stable topological sort, following-       -- Note [Ordering of implicit variables] in GHC.Rename.HsType-       ; return (scopedSort spec_tkvs) }---- | Generalize some of the free variables in the given type.--- All such variables should be *kind* variables; any type variables--- should be explicitly quantified (with a `forall`) before now.------ The WantedConstraints are un-solved kind constraints. Generally--- they'll be reported as errors later, but meanwhile we refrain--- from quantifying over any variable free in these unsolved--- constraints. See Note [Failure in local type signatures].------ But in all cases, generalize only those variables whose TcLevel is--- strictly greater than the ambient level. This "strictly greater--- than" means that you likely need to push the level before creating--- whatever type gets passed here.------ Any variable whose level is greater than the ambient level but is--- not selected to be generalized will be promoted. (See [Promoting--- unification variables] in "GHC.Tc.Solver" and Note [Recipe for--- checking a signature].)------ The resulting KindVar are the variables to quantify over, in the--- correct, well-scoped order. They should generally be Inferred, not--- Specified, but that's really up to the caller of this function.-kindGeneralizeSome :: WantedConstraints-                   -> TcType    -- ^ needn't be zonked-                   -> TcM [KindVar]-kindGeneralizeSome wanted kind_or_type-  = do { -- Use the "Kind" variant here, as any types we see-         -- here will already have all type variables quantified;-         -- thus, every free variable is really a kv, never a tv.-       ; dvs <- candidateQTyVarsOfKind kind_or_type-       ; dvs <- filterConstrainedCandidates wanted dvs-       ; quantifyTyVars dvs }--filterConstrainedCandidates-  :: WantedConstraints    -- Don't quantify over variables free in these-                          --   Not necessarily fully zonked-  -> CandidatesQTvs       -- Candidates for quantification-  -> TcM CandidatesQTvs--- filterConstrainedCandidates removes any candidates that are free in--- 'wanted'; instead, it promotes them.  This bit is very much like--- decideMonoTyVars in GHC.Tc.Solver, but constraints are so much--- simpler in kinds, it is much easier here. (In particular, we never--- quantify over a constraint in a type.)-filterConstrainedCandidates wanted dvs-  | isEmptyWC wanted   -- Fast path for a common case-  = return dvs-  | otherwise-  = do { wc_tvs <- zonkTyCoVarsAndFV (tyCoVarsOfWC wanted)-       ; let (to_promote, dvs') = partitionCandidates dvs (`elemVarSet` wc_tvs)-       ; _ <- promoteTyVarSet to_promote-       ; return dvs' }---- |- Specialised version of 'kindGeneralizeSome', but with empty--- WantedConstraints, so no filtering is needed--- i.e.   kindGeneraliseAll = kindGeneralizeSome emptyWC-kindGeneralizeAll :: TcType -> TcM [KindVar]-kindGeneralizeAll kind_or_type-  = do { traceTc "kindGeneralizeAll" (ppr kind_or_type)-       ; dvs <- candidateQTyVarsOfKind kind_or_type-       ; quantifyTyVars dvs }---- | Specialized version of 'kindGeneralizeSome', but where no variables--- can be generalized, but perhaps some may need to be promoted.--- Use this variant when it is unknowable whether metavariables might--- later be constrained.------ To see why this promotion is needed, see--- Note [Recipe for checking a signature], and especially--- Note [Promotion in signatures].-kindGeneralizeNone :: TcType  -- needn't be zonked-                   -> TcM ()-kindGeneralizeNone kind_or_type-  = do { traceTc "kindGeneralizeNone" (ppr kind_or_type)-       ; dvs <- candidateQTyVarsOfKind kind_or_type-       ; _ <- promoteTyVarSet (candidateKindVars dvs)-       ; return () }--{- Note [Levels and generalisation]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-  f x = e-with no type signature. We are currently at level i.-We must-  * Push the level to level (i+1)-  * Allocate a fresh alpha[i+1] for the result type-  * Check that e :: alpha[i+1], gathering constraint WC-  * Solve WC as far as possible-  * Zonking the result type alpha[i+1], say to beta[i-1] -> gamma[i]-  * Find the free variables with level > i, in this case gamma[i]-  * Skolemise those free variables and quantify over them, giving-       f :: forall g. beta[i-1] -> g-  * Emit the residiual constraint wrapped in an implication for g,-    thus   forall g. WC--All of this happens for types too.  Consider-  f :: Int -> (forall a. Proxy a -> Int)--Note [Kind generalisation]-~~~~~~~~~~~~~~~~~~~~~~~~~~-We do kind generalisation only at the outer level of a type signature.-For example, consider-  T :: forall k. k -> *-  f :: (forall a. T a -> Int) -> Int-When kind-checking f's type signature we generalise the kind at-the outermost level, thus:-  f1 :: forall k. (forall (a:k). T k a -> Int) -> Int  -- YES!-and *not* at the inner forall:-  f2 :: (forall k. forall (a:k). T k a -> Int) -> Int  -- NO!-Reason: same as for HM inference on value level declarations,-we want to infer the most general type.  The f2 type signature-would be *less applicable* than f1, because it requires a more-polymorphic argument.--NB: There are no explicit kind variables written in f's signature.-When there are, the renamer adds these kind variables to the list of-variables bound by the forall, so you can indeed have a type that's-higher-rank in its kind. But only by explicit request.--Note [Kinds of quantified type variables]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-tcTyVarBndrsGen quantifies over a specified list of type variables,-*and* over the kind variables mentioned in the kinds of those tyvars.--Note that we must zonk those kinds (obviously) but less obviously, we-must return type variables whose kinds are zonked too. Example-    (a :: k7)  where  k7 := k9 -> k9-We must return-    [k9, a:k9->k9]-and NOT-    [k9, a:k7]-Reason: we're going to turn this into a for-all type,-   forall k9. forall (a:k7). blah-which the type checker will then instantiate, and instantiate does not-look through unification variables!--Hence using zonked_kinds when forming tvs'.---}--------------------------------------etaExpandAlgTyCon :: [TyConBinder]-                  -> Kind   -- must be zonked-                  -> TcM ([TyConBinder], Kind)--- GADT decls can have a (perhaps partial) kind signature---      e.g.  data T a :: * -> * -> * where ...--- This function makes up suitable (kinded) TyConBinders for the--- argument kinds.  E.g. in this case it might return---   ([b::*, c::*], *)--- Never emits constraints.--- It's a little trickier than you might think: see--- Note [TyConBinders for the result kind signature of a data type]--- See Note [Datatype return kinds] in GHC.Tc.TyCl-etaExpandAlgTyCon tc_bndrs kind-  = do  { loc     <- getSrcSpanM-        ; uniqs   <- newUniqueSupply-        ; !rdr_env <- getLocalRdrEnv-        ; let new_occs = [ occ-                         | str <- allNameStrings-                         , let occ = mkOccName tvName str-                         , isNothing (lookupLocalRdrOcc rdr_env occ)-                         -- Note [Avoid name clashes for associated data types]-                         , not (occ `elem` lhs_occs) ]-              new_uniqs = uniqsFromSupply uniqs-              subst = mkEmptyTCvSubst (mkInScopeSet (mkVarSet lhs_tvs))-        ; return (go loc new_occs new_uniqs subst [] kind) }-  where-    lhs_tvs  = map binderVar tc_bndrs-    lhs_occs = map getOccName lhs_tvs--    go loc occs uniqs subst acc kind-      = case splitPiTy_maybe kind of-          Nothing -> (reverse acc, substTy subst kind)--          Just (Anon af arg, kind')-            -> go loc occs' uniqs' subst' (tcb : acc) kind'-            where-              arg'   = substTy subst (scaledThing arg)-              -- Force the occ before making the TyVar as otherwise it retains the TcLclEnv-              tv     = occ `seq` mkTyVar (mkInternalName uniq occ loc) arg'-              subst' = extendTCvInScope subst tv-              tcb    = Bndr tv (AnonTCB af)-              (uniq:uniqs') = uniqs-              (!occ:occs')   = occs--          Just (Named (Bndr tv vis), kind')-            -> go loc occs uniqs subst' (tcb : acc) kind'-            where-              (subst', tv') = substTyVarBndr subst tv-              tcb = Bndr tv' (NamedTCB vis)---- | A description of whether something is a------ * @data@ or @newtype@ ('DataDeclSort')------ * @data instance@ or @newtype instance@ ('DataInstanceSort')------ * @data family@ ('DataFamilySort')------ At present, this data type is only consumed by 'checkDataKindSig'.-data DataSort-  = DataDeclSort     NewOrData-  | DataInstanceSort NewOrData-  | DataFamilySort---- | Local helper type used in 'checkDataKindSig'.------ Superficially similar to 'ContextKind', but it lacks 'AnyKind'--- and 'AnyBoxedKind', and instead of @'TheKind' liftedTypeKind@--- provides 'LiftedKind', which is much simpler to match on and--- handle in 'isAllowedDataResKind'.-data AllowedDataResKind-  = AnyTYPEKind-  | AnyBoxedKind-  | LiftedKind--isAllowedDataResKind :: AllowedDataResKind -> Kind -> Bool-isAllowedDataResKind AnyTYPEKind  kind = tcIsRuntimeTypeKind kind-isAllowedDataResKind AnyBoxedKind kind = tcIsBoxedTypeKind kind-isAllowedDataResKind LiftedKind   kind = tcIsLiftedTypeKind kind---- | Checks that the return kind in a data declaration's kind signature is--- permissible. There are three cases:------ If dealing with a @data@, @newtype@, @data instance@, or @newtype instance@--- declaration, check that the return kind is @Type@.------ If the declaration is a @newtype@ or @newtype instance@ and the--- @UnliftedNewtypes@ extension is enabled, this check is slightly relaxed so--- that a return kind of the form @TYPE r@ (for some @r@) is permitted.--- See @Note [Implementation of UnliftedNewtypes]@ in "GHC.Tc.TyCl".------ If dealing with a @data family@ declaration, check that the return kind is--- either of the form:------ 1. @TYPE r@ (for some @r@), or------ 2. @k@ (where @k@ is a bare kind variable; see #12369)------ See also Note [Datatype return kinds] in "GHC.Tc.TyCl"-checkDataKindSig :: DataSort -> Kind  -- any arguments in the kind are stripped off-                 -> TcM ()-checkDataKindSig data_sort kind-  = do { dflags <- getDynFlags-       ; traceTc "checkDataKindSig" (ppr kind)-       ; checkTc (tYPE_ok dflags || is_kind_var)-                 (err_msg dflags) }-  where-    res_kind = snd (tcSplitPiTys kind)-       -- Look for the result kind after-       -- peeling off any foralls and arrows--    pp_dec :: SDoc-    pp_dec = text $-      case data_sort of-        DataDeclSort     DataType -> "Data type"-        DataDeclSort     NewType  -> "Newtype"-        DataInstanceSort DataType -> "Data instance"-        DataInstanceSort NewType  -> "Newtype instance"-        DataFamilySort            -> "Data family"--    is_newtype :: Bool-    is_newtype =-      case data_sort of-        DataDeclSort     new_or_data -> new_or_data == NewType-        DataInstanceSort new_or_data -> new_or_data == NewType-        DataFamilySort               -> False--    is_datatype :: Bool-    is_datatype =-      case data_sort of-        DataDeclSort     DataType -> True-        DataInstanceSort DataType -> True-        _                         -> False--    is_data_family :: Bool-    is_data_family =-      case data_sort of-        DataDeclSort{}     -> False-        DataInstanceSort{} -> False-        DataFamilySort     -> True--    allowed_kind :: DynFlags -> AllowedDataResKind-    allowed_kind dflags-      | is_newtype && xopt LangExt.UnliftedNewtypes dflags-        -- With UnliftedNewtypes, we allow kinds other than Type, but they-        -- must still be of the form `TYPE r` since we don't want to accept-        -- Constraint or Nat.-        -- See Note [Implementation of UnliftedNewtypes] in GHC.Tc.TyCl.-      = AnyTYPEKind-      | is_data_family-        -- If this is a `data family` declaration, we don't need to check if-        -- UnliftedNewtypes is enabled, since data family declarations can-        -- have return kind `TYPE r` unconditionally (#16827).-      = AnyTYPEKind-      | is_datatype && xopt LangExt.UnliftedDatatypes dflags-        -- With UnliftedDatatypes, we allow kinds other than Type, but they-        -- must still be of the form `TYPE (BoxedRep l)`, so that we don't-        -- accept result kinds like `TYPE IntRep`.-        -- See Note [Implementation of UnliftedDatatypes] in GHC.Tc.TyCl.-      = AnyBoxedKind-      | otherwise-      = LiftedKind--    tYPE_ok :: DynFlags -> Bool-    tYPE_ok dflags = isAllowedDataResKind (allowed_kind dflags) res_kind--    -- In the particular case of a data family, permit a return kind of the-    -- form `:: k` (where `k` is a bare kind variable).-    is_kind_var :: Bool-    is_kind_var | is_data_family = isJust (tcGetCastedTyVar_maybe res_kind)-                | otherwise      = False--    pp_allowed_kind dflags =-      case allowed_kind dflags of-        AnyTYPEKind  -> ppr tYPETyCon-        AnyBoxedKind -> ppr boxedRepDataConTyCon-        LiftedKind   -> ppr liftedTypeKind--    err_msg :: DynFlags -> SDoc-    err_msg dflags =-      sep [ sep [ pp_dec <+>-                  text "has non-" <>-                  pp_allowed_kind dflags-                , (if is_data_family then text "and non-variable" else empty) <+>-                  text "return kind" <+> quotes (ppr kind) ]-          , ext_hint dflags ]--    ext_hint dflags-      | tcIsRuntimeTypeKind kind-      , is_newtype-      , not (xopt LangExt.UnliftedNewtypes dflags)-      = text "Perhaps you intended to use UnliftedNewtypes"-      | tcIsBoxedTypeKind kind-      , is_datatype-      , not (xopt LangExt.UnliftedDatatypes dflags)-      = text "Perhaps you intended to use UnliftedDatatypes"-      | otherwise-      = empty---- | Checks that the result kind of a class is exactly `Constraint`, rejecting--- type synonyms and type families that reduce to `Constraint`. See #16826.-checkClassKindSig :: Kind -> TcM ()-checkClassKindSig kind = checkTc (tcIsConstraintKind kind) err_msg-  where-    err_msg :: SDoc-    err_msg =-      text "Kind signature on a class must end with" <+> ppr constraintKind $$-      text "unobscured by type families"--tcbVisibilities :: TyCon -> [Type] -> [TyConBndrVis]--- Result is in 1-1 correspondence with orig_args-tcbVisibilities tc orig_args-  = go (tyConKind tc) init_subst orig_args-  where-    init_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfTypes orig_args))-    go _ _ []-      = []--    go fun_kind subst all_args@(arg : args)-      | Just (tcb, inner_kind) <- splitPiTy_maybe fun_kind-      = case tcb of-          Anon af _           -> AnonTCB af   : go inner_kind subst  args-          Named (Bndr tv vis) -> NamedTCB vis : go inner_kind subst' args-                 where-                    subst' = extendTCvSubst subst tv arg--      | not (isEmptyTCvSubst subst)-      = go (substTy subst fun_kind) init_subst all_args--      | otherwise-      = pprPanic "addTcbVisibilities" (ppr tc <+> ppr orig_args)---{- Note [TyConBinders for the result kind signature of a data type]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Given-  data T (a::*) :: * -> forall k. k -> *-we want to generate the extra TyConBinders for T, so we finally get-  (a::*) (b::*) (k::*) (c::k)-The function etaExpandAlgTyCon generates these extra TyConBinders from-the result kind signature.--We need to take care to give the TyConBinders-  (a) OccNames that are fresh (because the TyConBinders of a TyCon-      must have distinct OccNames--  (b) Uniques that are fresh (obviously)--For (a) we need to avoid clashes with the tyvars declared by-the user before the "::"; in the above example that is 'a'.-And also see Note [Avoid name clashes for associated data types].--For (b) suppose we have-   data T :: forall k. k -> forall k. k -> *-where the two k's are identical even up to their uniques.  Surprisingly,-this can happen: see #14515.--It's reasonably easy to solve all this; just run down the list with a-substitution; hence the recursive 'go' function.  But it has to be-done.--Note [Avoid name clashes for associated data types]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider    class C a b where-               data D b :: * -> *-When typechecking the decl for D, we'll invent an extra type variable-for D, to fill out its kind.  Ideally we don't want this type variable-to be 'a', because when pretty printing we'll get-            class C a b where-               data D b a0-(NB: the tidying happens in the conversion to Iface syntax, which happens-as part of pretty-printing a TyThing.)--That's why we look in the LocalRdrEnv to see what's in scope. This is-important only to get nice-looking output when doing ":info C" in GHCi.-It isn't essential for correctness.---************************************************************************-*                                                                      *-             Partial signatures-*                                                                      *-************************************************************************---}--tcHsPartialSigType-  :: UserTypeCtxt-  -> LHsSigWcType GhcRn       -- The type signature-  -> TcM ( [(Name, TcTyVar)]  -- Wildcards-         , Maybe TcType       -- Extra-constraints wildcard-         , [(Name,InvisTVBinder)] -- Original tyvar names, in correspondence with-                              --   the implicitly and explicitly bound type variables-         , TcThetaType        -- Theta part-         , TcType )           -- Tau part--- See Note [Checking partial type signatures]-tcHsPartialSigType ctxt sig_ty-  | HsWC { hswc_ext  = sig_wcs, hswc_body = sig_ty } <- sig_ty-  , L _ (HsSig{sig_bndrs = hs_outer_bndrs, sig_body = body_ty}) <- sig_ty-  , (hs_ctxt, hs_tau) <- splitLHsQualTy body_ty-  = addSigCtxt ctxt sig_ty $-    do { mode <- mkHoleMode TypeLevel HM_Sig-       ; (outer_bndrs, (wcs, wcx, theta, tau))-            <- solveEqualities "tcHsPartialSigType" $-               -- See Note [Failure in local type signatures]-               bindNamedWildCardBinders sig_wcs             $ \ wcs ->-               bindOuterSigTKBndrs_Tv_M mode hs_outer_bndrs $-               do {   -- Instantiate the type-class context; but if there-                      -- is an extra-constraints wildcard, just discard it here-                    (theta, wcx) <- tcPartialContext mode hs_ctxt--                  ; ek <- newOpenTypeKind-                  ; tau <- addTypeCtxt hs_tau $-                           tc_lhs_type mode hs_tau ek--                  ; return (wcs, wcx, theta, tau) }--       ; traceTc "tcHsPartialSigType 2" empty-       ; outer_tv_bndrs <- scopedSortOuter outer_bndrs-       ; traceTc "tcHsPartialSigType 3" empty--         -- No kind-generalization here:-       ; kindGeneralizeNone (mkInvisForAllTys outer_tv_bndrs $-                             mkPhiTy theta $-                             tau)--       -- Spit out the wildcards (including the extra-constraints one)-       -- as "hole" constraints, so that they'll be reported if necessary-       -- See Note [Extra-constraint holes in partial type signatures]-       ; mapM_ emitNamedTypeHole wcs--       -- Zonk, so that any nested foralls can "see" their occurrences-       -- See Note [Checking partial type signatures], and in particular-       -- Note [Levels for wildcards]-       ; outer_tv_bndrs <- mapM zonkInvisTVBinder outer_tv_bndrs-       ; theta          <- mapM zonkTcType theta-       ; tau            <- zonkTcType tau--         -- We return a proper (Name,InvisTVBinder) environment, to be sure that-         -- we bring the right name into scope in the function body.-         -- Test case: partial-sigs/should_compile/LocalDefinitionBug-       ; let outer_bndr_names :: [Name]-             outer_bndr_names = hsOuterTyVarNames hs_outer_bndrs-             tv_prs :: [(Name,InvisTVBinder)]-             tv_prs = outer_bndr_names `zip` outer_tv_bndrs--      -- NB: checkValidType on the final inferred type will be-      --     done later by checkInferredPolyId.  We can't do it-      --     here because we don't have a complete type to check--       ; traceTc "tcHsPartialSigType" (ppr tv_prs)-       ; return (wcs, wcx, tv_prs, theta, tau) }--tcPartialContext :: TcTyMode -> Maybe (LHsContext GhcRn) -> TcM (TcThetaType, Maybe TcType)-tcPartialContext _ Nothing = return ([], Nothing)-tcPartialContext mode (Just (L _ hs_theta))-  | Just (hs_theta1, hs_ctxt_last) <- snocView hs_theta-  , L wc_loc ty@(HsWildCardTy _) <- ignoreParens hs_ctxt_last-  = do { wc_tv_ty <- setSrcSpanA wc_loc $-                     tcAnonWildCardOcc YesExtraConstraint mode ty constraintKind-       ; theta <- mapM (tc_lhs_pred mode) hs_theta1-       ; return (theta, Just wc_tv_ty) }-  | otherwise-  = do { theta <- mapM (tc_lhs_pred mode) hs_theta-       ; return (theta, Nothing) }--{- Note [Checking partial type signatures]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-This Note is about tcHsPartialSigType.  See also-Note [Recipe for checking a signature]--When we have a partial signature like-   f :: forall a. a -> _-we do the following--* tcHsPartialSigType does not make quantified type (forall a. blah)-  and then instantiate it -- it makes no sense to instantiate a type-  with wildcards in it.  Rather, tcHsPartialSigType just returns the-  'a' and the 'blah' separately.--  Nor, for the same reason, do we push a level in tcHsPartialSigType.--* We instantiate 'a' to a unification variable, a TyVarTv, and /not/-  a skolem; hence the "_Tv" in bindExplicitTKBndrs_Tv.  Consider-    f :: forall a. a -> _-    g :: forall b. _ -> b-    f = g-    g = f-  They are typechecked as a recursive group, with monomorphic types,-  so 'a' and 'b' will get unified together.  Very like kind inference-  for mutually recursive data types (sans CUSKs or SAKS); see-  Note [Cloning for type variable binders]--* In GHC.Tc.Gen.Sig.tcUserSigType we return a PartialSig, which (unlike-  the companion CompleteSig) contains the original, as-yet-unchecked-  source-code LHsSigWcType--* Then, for f and g /separately/, we call tcInstSig, which in turn-  call tchsPartialSig (defined near this Note).  It kind-checks the-  LHsSigWcType, creating fresh unification variables for each "_"-  wildcard.  It's important that the wildcards for f and g are distinct-  because they might get instantiated completely differently.  E.g.-     f,g :: forall a. a -> _-     f x = a-     g x = True-  It's really as if we'd written two distinct signatures.--* Nested foralls. See Note [Levels for wildcards]--* Just as for ordinary signatures, we must solve local equalities and-  zonk the type after kind-checking it, to ensure that all the nested-  forall binders can "see" their occurrenceds--  Just as for ordinary signatures, this zonk also gets any Refl casts-  out of the way of instantiation.  Example: #18008 had-       foo :: (forall a. (Show a => blah) |> Refl) -> _-  and that Refl cast messed things up.  See #18062.--Note [Levels for wildcards]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-     f :: forall b. (forall a. a -> _) -> b-We do /not/ allow the "_" to be instantiated to 'a'; although we do-(as before) allow it to be instantiated to the (top level) 'b'.-Why not?  Suppose-   f x = (x True, x 'c')--During typecking the RHS we must instantiate that (forall a. a -> _),-so we must know /precisely/ where all the a's are; they must not be-hidden under (possibly-not-yet-filled-in) unification variables!--We achieve this as follows:--- For /named/ wildcards such sas-     g :: forall b. (forall la. a -> _x) -> b-  there is no problem: we create them at the outer level (ie the-  ambient level of the signature itself), and push the level when we-  go inside a forall.  So now the unification variable for the "_x"-  can't unify with skolem 'a'.--- For /anonymous/ wildcards, such as 'f' above, we carry the ambient-  level of the signature to the hole in the TcLevel part of the-  mode_holes field of TcTyMode.  Then, in tcAnonWildCardOcc we us that-  level (and /not/ the level ambient at the occurrence of "_") to-  create the unification variable for the wildcard.  That is the sole-  purpose of the TcLevel in the mode_holes field: to transport the-  ambient level of the signature down to the anonymous wildcard-  occurrences.--Note [Extra-constraint holes in partial type signatures]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-  f :: (_) => a -> a-  f x = ...--* The renamer leaves '_' untouched.--* Then, in tcHsPartialSigType, we make a new hole TcTyVar, in-  tcWildCardBinders.--* GHC.Tc.Gen.Bind.chooseInferredQuantifiers fills in that hole TcTyVar-  with the inferred constraints, e.g. (Eq a, Show a)--* GHC.Tc.Errors.mkHoleError finally reports the error.--An annoying difficulty happens if there are more than 64 inferred-constraints. Then we need to fill in the TcTyVar with (say) a 70-tuple.-Where do we find the TyCon?  For good reasons we only have constraint-tuples up to 62 (see Note [How tuples work] in GHC.Builtin.Types).  So how-can we make a 70-tuple?  This was the root cause of #14217.--It's incredibly tiresome, because we only need this type to fill-in the hole, to communicate to the error reporting machinery.  Nothing-more.  So I use a HACK:--* I make an /ordinary/ tuple of the constraints, in-  GHC.Tc.Gen.Bind.chooseInferredQuantifiers. This is ill-kinded because-  ordinary tuples can't contain constraints, but it works fine. And for-  ordinary tuples we don't have the same limit as for constraint-  tuples (which need selectors and an associated class).--* Because it is ill-kinded, it trips an assert in writeMetaTyVar,-  so now I disable the assertion if we are writing a type of-  kind Constraint.  (That seldom/never normally happens so we aren't-  losing much.)--Result works fine, but it may eventually bite us.--See also Note [Do not simplify ConstraintHoles] in GHC.Tc.Solver for-information about how these are printed.--************************************************************************-*                                                                      *-      Pattern signatures (i.e signatures that occur in patterns)-*                                                                      *-********************************************************************* -}--tcHsPatSigType :: UserTypeCtxt-               -> HoleMode -- HM_Sig when in a SigPat, HM_TyAppPat when in a ConPat checking type applications.-               -> HsPatSigType GhcRn          -- The type signature-               -> ContextKind                -- What kind is expected-               -> TcM ( [(Name, TcTyVar)]     -- Wildcards-                      , [(Name, TcTyVar)]     -- The new bit of type environment, binding-                                              -- the scoped type variables-                      , TcType)       -- The type--- Used for type-checking type signatures in--- (a) patterns           e.g  f (x::Int) = e--- (b) RULE forall bndrs  e.g. forall (x::Int). f x = x--- See Note [Pattern signature binders and scoping] in GHC.Hs.Type------ This may emit constraints--- See Note [Recipe for checking a signature]-tcHsPatSigType ctxt hole_mode-  (HsPS { hsps_ext  = HsPSRn { hsps_nwcs = sig_wcs, hsps_imp_tvs = sig_ns }-        , hsps_body = hs_ty })-  ctxt_kind-  = addSigCtxt ctxt hs_ty $-    do { sig_tkv_prs <- mapM new_implicit_tv sig_ns-       ; mode <- mkHoleMode TypeLevel hole_mode-       ; (wcs, sig_ty)-            <- addTypeCtxt hs_ty                     $-               solveEqualities "tcHsPatSigType" $-                 -- See Note [Failure in local type signatures]-                 -- and c.f #16033-               bindNamedWildCardBinders sig_wcs $ \ wcs ->-               tcExtendNameTyVarEnv sig_tkv_prs $-               do { ek     <- newExpectedKind ctxt_kind-                  ; sig_ty <- tc_lhs_type mode hs_ty ek-                  ; return (wcs, sig_ty) }--        ; mapM_ emitNamedTypeHole wcs--          -- sig_ty might have tyvars that are at a higher TcLevel (if hs_ty-          -- contains a forall). Promote these.-          -- Ex: f (x :: forall a. Proxy a -> ()) = ... x ...-          -- When we instantiate x, we have to compare the kind of the argument-          -- to a's kind, which will be a metavariable.-          -- kindGeneralizeNone does this:-        ; kindGeneralizeNone sig_ty-        ; sig_ty <- zonkTcType sig_ty-        ; checkValidType ctxt sig_ty--        ; traceTc "tcHsPatSigType" (ppr sig_tkv_prs)-        ; return (wcs, sig_tkv_prs, sig_ty) }-  where-    new_implicit_tv name-      = do { kind <- newMetaKindVar-           ; tv   <- case ctxt of-                       RuleSigCtxt {} -> newSkolemTyVar name kind-                       _              -> newPatSigTyVar name kind-                       -- See Note [Typechecking pattern signature binders]-             -- NB: tv's Name may be fresh (in the case of newPatSigTyVar)-           ; return (name, tv) }--{- Note [Typechecking pattern signature binders]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-See also Note [Type variables in the type environment] in GHC.Tc.Utils.-Consider--  data T where-    MkT :: forall a. a -> (a -> Int) -> T--  f :: T -> ...-  f (MkT x (f :: b -> c)) = <blah>--Here- * The pattern (MkT p1 p2) creates a *skolem* type variable 'a_sk',-   It must be a skolem so that it retains its identity, and-   GHC.Tc.Errors.getSkolemInfo can thereby find the binding site for the skolem.-- * The type signature pattern (f :: b -> c) makes fresh meta-tyvars-   beta and gamma (TauTvs), and binds "b" :-> beta, "c" :-> gamma in the-   environment-- * Then unification makes beta := a_sk, gamma := Int-   That's why we must make beta and gamma a MetaTv,-   not a SkolemTv, so that it can unify to a_sk (or Int, respectively).-- * Finally, in '<blah>' we have the envt "b" :-> beta, "c" :-> gamma,-   so we return the pairs ("b" :-> beta, "c" :-> gamma) from tcHsPatSigType,--Another example (#13881):-   fl :: forall (l :: [a]). Sing l -> Sing l-   fl (SNil :: Sing (l :: [y])) = SNil-When we reach the pattern signature, 'l' is in scope from the-outer 'forall':-   "a" :-> a_sk :: *-   "l" :-> l_sk :: [a_sk]-We make up a fresh meta-TauTv, y_sig, for 'y', and kind-check-the pattern signature-   Sing (l :: [y])-That unifies y_sig := a_sk.  We return from tcHsPatSigType with-the pair ("y" :-> y_sig).--For RULE binders, though, things are a bit different (yuk).-  RULE "foo" forall (x::a) (y::[a]).  f x y = ...-Here this really is the binding site of the type variable so we'd like-to use a skolem, so that we get a complaint if we unify two of them-together.  Hence the new_implicit_tv function in tcHsPatSigType.---************************************************************************-*                                                                      *-        Checking kinds-*                                                                      *-************************************************************************---}--unifyKinds :: [LHsType GhcRn] -> [(TcType, TcKind)] -> TcM ([TcType], TcKind)-unifyKinds rn_tys act_kinds-  = do { kind <- newMetaKindVar-       ; let check rn_ty (ty, act_kind)-               = checkExpectedKind (unLoc rn_ty) ty act_kind kind-       ; tys' <- zipWithM check rn_tys act_kinds-       ; return (tys', kind) }--{--************************************************************************-*                                                                      *-        Sort checking kinds-*                                                                      *-************************************************************************--tcLHsKindSig converts a user-written kind to an internal, sort-checked kind.-It does sort checking and desugaring at the same time, in one single pass.--}--tcLHsKindSig :: UserTypeCtxt -> LHsKind GhcRn -> TcM Kind-tcLHsKindSig ctxt hs_kind-  = tc_lhs_kind_sig kindLevelMode ctxt hs_kind--tc_lhs_kind_sig :: TcTyMode -> UserTypeCtxt -> LHsKind GhcRn -> TcM Kind-tc_lhs_kind_sig mode ctxt hs_kind--- See  Note [Recipe for checking a signature] in GHC.Tc.Gen.HsType--- Result is zonked-  = do { kind <- addErrCtxt (text "In the kind" <+> quotes (ppr hs_kind)) $-                 solveEqualities "tcLHsKindSig" $-                 tc_lhs_type mode hs_kind liftedTypeKind-       ; traceTc "tcLHsKindSig" (ppr hs_kind $$ ppr kind)-       -- No generalization:-       ; kindGeneralizeNone kind-       ; kind <- zonkTcType kind-         -- This zonk is very important in the case of higher rank kinds-         -- E.g. #13879    f :: forall (p :: forall z (y::z). <blah>).-         --                          <more blah>-         --      When instantiating p's kind at occurrences of p in <more blah>-         --      it's crucial that the kind we instantiate is fully zonked,-         --      else we may fail to substitute properly--       ; checkValidType ctxt kind-       ; traceTc "tcLHsKindSig2" (ppr kind)-       ; return kind }--promotionErr :: Name -> PromotionErr -> TcM a-promotionErr name err-  = failWithTc (hang (pprPECategory err <+> quotes (ppr name) <+> text "cannot be used here")-                   2 (parens reason))-  where-    reason = case err of-               ConstrainedDataConPE pred-                              -> text "it has an unpromotable context"-                                 <+> quotes (ppr pred)-               FamDataConPE   -> text "it comes from a data family instance"-               NoDataKindsTC  -> text "perhaps you intended to use DataKinds"-               NoDataKindsDC  -> text "perhaps you intended to use DataKinds"-               PatSynPE       -> text "pattern synonyms cannot be promoted"-               RecDataConPE   -> same_rec_group_msg-               ClassPE        -> same_rec_group_msg-               TyConPE        -> same_rec_group_msg--    same_rec_group_msg = text "it is defined and used in the same recursive group"--{--************************************************************************-*                                                                      *-          Error messages and such-*                                                                      *-************************************************************************--}----- | Make an appropriate message for an error in a function argument.--- Used for both expressions and types.-funAppCtxt :: (Outputable fun, Outputable arg) => fun -> arg -> Int -> SDoc-funAppCtxt fun arg arg_no-  = hang (hsep [ text "In the", speakNth arg_no, ptext (sLit "argument of"),++{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies        #-}+{-# LANGUAGE ViewPatterns        #-}+{-# LANGUAGE RecursiveDo        #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++-}++-- | Typechecking user-specified @MonoTypes@+module GHC.Tc.Gen.HsType (+        -- Type signatures+        kcClassSigType, tcClassSigType,+        tcHsSigType, tcHsSigWcType,+        tcHsPartialSigType,+        tcStandaloneKindSig,+        funsSigCtxt, addSigCtxt, pprSigCtxt,++        tcHsClsInstType,+        tcHsDeriv, tcDerivStrategy,+        tcHsTypeApp,+        UserTypeCtxt(..),+        bindImplicitTKBndrs_Tv, bindImplicitTKBndrs_Skol,+            bindImplicitTKBndrs_Q_Tv, bindImplicitTKBndrs_Q_Skol,+        bindExplicitTKBndrs_Tv, bindExplicitTKBndrs_Skol,+            bindExplicitTKBndrs_Q_Tv, bindExplicitTKBndrs_Q_Skol,++        bindOuterFamEqnTKBndrs_Q_Tv, bindOuterFamEqnTKBndrs,+        tcOuterTKBndrs, scopedSortOuter, outerTyVars, outerTyVarBndrs,+        bindOuterSigTKBndrs_Tv,+        tcExplicitTKBndrs,+        bindNamedWildCardBinders,++        -- Type checking type and class decls, and instances thereof+        bindTyClTyVars, bindTyClTyVarsAndZonk,+        tcFamTyPats,+        etaExpandAlgTyCon, tcbVisibilities,++          -- tyvars+        zonkAndScopedSort,++        -- Kind-checking types+        -- No kind generalisation, no checkValidType+        InitialKindStrategy(..),+        SAKS_or_CUSK(..),+        ContextKind(..),+        kcDeclHeader, checkForDuplicateScopedTyVars,+        tcHsLiftedType,   tcHsOpenType,+        tcHsLiftedTypeNC, tcHsOpenTypeNC,+        tcInferLHsType, tcInferLHsTypeKind, tcInferLHsTypeUnsaturated,+        tcCheckLHsType,+        tcHsContext, tcLHsPredType,++        kindGeneralizeAll,++        -- Sort-checking kinds+        tcLHsKindSig, checkDataKindSig, DataSort(..),+        checkClassKindSig,++        -- Multiplicity+        tcMult,++        -- Pattern type signatures+        tcHsPatSigType,+        HoleMode(..),++        -- Error messages+        funAppCtxt, addTyConFlavCtxt+   ) where++import GHC.Prelude++import GHC.Hs+import GHC.Rename.Utils+import GHC.Tc.Errors.Types+import GHC.Tc.Utils.Monad+import GHC.Tc.Types.Origin+import GHC.Core.Predicate+import GHC.Tc.Types.Constraint+import GHC.Tc.Utils.Env+import GHC.Tc.Utils.TcMType+import GHC.Tc.Validity+import GHC.Tc.Utils.Unify+import GHC.IfaceToCore+import GHC.Tc.Solver+import GHC.Tc.Utils.Zonk+import GHC.Core.TyCo.Rep+import GHC.Core.TyCo.Ppr+import GHC.Tc.Utils.TcType+import GHC.Tc.Utils.Instantiate ( tcInstInvisibleTyBinders, tcInstInvisibleTyBindersN,+                                  tcInstInvisibleTyBinder, tcSkolemiseInvisibleBndrs )+import GHC.Core.Type+import GHC.Builtin.Types.Prim+import GHC.Types.Error+import GHC.Types.Name.Env+import GHC.Types.Name.Reader( lookupLocalRdrOcc )+import GHC.Types.Var+import GHC.Types.Var.Set+import GHC.Core.TyCon+import GHC.Core.ConLike+import GHC.Core.DataCon+import GHC.Core.Class+import GHC.Types.Name+import GHC.Types.Var.Env+import GHC.Builtin.Types+import GHC.Types.Basic+import GHC.Types.SrcLoc+import GHC.Types.Unique+import GHC.Types.Unique.FM+import GHC.Utils.Misc+import GHC.Types.Unique.Supply+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Utils.Panic.Plain+import GHC.Builtin.Names hiding ( wildCardName )+import GHC.Driver.Session+import qualified GHC.LanguageExtensions as LangExt++import GHC.Data.FastString+import GHC.Data.List.SetOps+import GHC.Data.Maybe+import GHC.Data.Bag( unitBag )++import Data.Function ( on )+import Data.List.NonEmpty as NE( NonEmpty(..), nubBy )+import Data.List ( find, mapAccumL )+import Control.Monad+import Data.Tuple( swap )++{-+        ----------------------------+                General notes+        ----------------------------++Unlike with expressions, type-checking types both does some checking and+desugars at the same time. This is necessary because we often want to perform+equality checks on the types right away, and it would be incredibly painful+to do this on un-desugared types. Luckily, desugared types are close enough+to HsTypes to make the error messages sane.++During type-checking, we perform as little validity checking as possible.+Generally, after type-checking, you will want to do validity checking, say+with GHC.Tc.Validity.checkValidType.++Validity checking+~~~~~~~~~~~~~~~~~+Some of the validity check could in principle be done by the kind checker,+but not all:++- During desugaring, we normalise by expanding type synonyms.  Only+  after this step can we check things like type-synonym saturation+  e.g.  type T k = k Int+        type S a = a+  Then (T S) is ok, because T is saturated; (T S) expands to (S Int);+  and then S is saturated.  This is a GHC extension.++- Similarly, also a GHC extension, we look through synonyms before complaining+  about the form of a class or instance declaration++- Ambiguity checks involve functional dependencies++Also, in a mutually recursive group of types, we can't look at the TyCon until we've+finished building the loop.  So to keep things simple, we postpone most validity+checking until step (3).++%************************************************************************+%*                                                                      *+              Check types AND do validity checking+*                                                                      *+************************************************************************++Note [Keeping implicitly quantified variables in order]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When the user implicitly quantifies over variables (say, in a type+signature), we need to come up with some ordering on these variables.+This is done by bumping the TcLevel, bringing the tyvars into scope,+and then type-checking the thing_inside. The constraints are all+wrapped in an implication, which is then solved. Finally, we can+zonk all the binders and then order them with scopedSort.++It's critical to solve before zonking and ordering in order to uncover+any unifications. You might worry that this eager solving could cause+trouble elsewhere. I don't think it will. Because it will solve only+in an increased TcLevel, it can't unify anything that was mentioned+elsewhere. Additionally, we require that the order of implicitly+quantified variables is manifest by the scope of these variables, so+we're not going to learn more information later that will help order+these variables.++Note [Recipe for checking a signature]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Kind-checking a user-written signature requires several steps:++ 0. Bump the TcLevel+ 1.   Bind any lexically-scoped type variables.+ 2.   Generate constraints.+ 3. Solve constraints.+ 4. Sort any implicitly-bound variables into dependency order+ 5. Promote tyvars and/or kind-generalize.+ 6. Zonk.+ 7. Check validity.++Very similar steps also apply when kind-checking a type or class+declaration.++The general pattern looks something like this.  (But NB every+specific instance varies in one way or another!)++    do { (tclvl, wanted, (spec_tkvs, ty))+              <- pushLevelAndSolveEqualitiesX "tc_top_lhs_type" $+                 bindImplicitTKBndrs_Skol sig_vars              $+                 <kind-check the type>++       ; spec_tkvs <- zonkAndScopedSort spec_tkvs++       ; reportUnsolvedEqualities skol_info spec_tkvs tclvl wanted++       ; let ty1 = mkSpecForAllTys spec_tkvs ty+       ; kvs <- kindGeneralizeAll ty1++       ; final_ty <- zonkTcTypeToType (mkInfForAllTys kvs ty1)++       ; checkValidType final_ty++This pattern is repeated many times in GHC.Tc.Gen.HsType,+GHC.Tc.Gen.Sig, and GHC.Tc.TyCl, with variations.  In more detail:++* pushLevelAndSolveEqualitiesX (Step 0, step 3) bumps the TcLevel,+  calls the thing inside to generate constraints, solves those+  constraints as much as possible, returning the residual unsolved+  constraints in 'wanted'.++* bindImplicitTKBndrs_Skol (Step 1) binds the user-specified type+  variables E.g.  when kind-checking f :: forall a. F a -> a we must+  bring 'a' into scope before kind-checking (F a -> a)++* zonkAndScopedSort (Step 4) puts those user-specified variables in+  the dependency order.  (For "implicit" variables the order is no+  user-specified.  E.g.  forall (a::k1) (b::k2). blah k1 and k2 are+  implicitly brought into scope.++* reportUnsolvedEqualities (Step 3 continued) reports any unsolved+  equalities, carefully wrapping them in an implication that binds the+  skolems.  We can't do that in pushLevelAndSolveEqualitiesX because+  that function doesn't have access to the skolems.++* kindGeneralize (Step 5). See Note [Kind generalisation]++* The final zonkTcTypeToType must happen after promoting/generalizing,+  because promoting and generalizing fill in metavariables.+++Doing Step 3 (constraint solving) eagerly (rather than building an+implication constraint and solving later) is necessary for several+reasons:++* Exactly as for Solver.simplifyInfer: when generalising, we solve all+  the constraints we can so that we don't have to quantify over them+  or, since we don't quantify over constraints in kinds, float them+  and inhibit generalisation.++* Most signatures also bring implicitly quantified variables into+  scope, and solving is necessary to get these in the right order+  (Step 4) see Note [Keeping implicitly quantified variables in+  order]).++Note [Kind generalisation]+~~~~~~~~~~~~~~~~~~~~~~~~~~+Step 5 of Note [Recipe for checking a signature], namely+kind-generalisation, is done by+    kindGeneraliseAll+    kindGeneraliseSome+    kindGeneraliseNone++Here, we have to deal with the fact that metatyvars generated in the+type will have a bumped TcLevel, because explicit foralls raise the+TcLevel. To avoid these variables from ever being visible in the+surrounding context, we must obey the following dictum:++  Every metavariable in a type must either be+    (A) generalized, or+    (B) promoted, or        See Note [Promotion in signatures]+    (C) a cause to error    See Note [Naughty quantification candidates]+                            in GHC.Tc.Utils.TcMType++There are three steps (look at kindGeneraliseSome):++1. candidateQTyVarsOfType finds the free variables of the type or kind,+   to generalise++2. filterConstrainedCandidates filters out candidates that appear+   in the unsolved 'wanteds', and promotes the ones that get filtered out+   thereby.++3. quantifyTyVars quantifies the remaining type variables++The kindGeneralize functions do not require pre-zonking; they zonk as they+go.++kindGeneraliseAll specialises for the case where step (2) is vacuous.+kindGeneraliseNone specialises for the case where we do no quantification,+but we must still promote.++If you are actually doing kind-generalization, you need to bump the+level before generating constraints, as we will only generalize+variables with a TcLevel higher than the ambient one.+Hence the "pushLevel" in pushLevelAndSolveEqualities.++Note [Promotion in signatures]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If an unsolved metavariable in a signature is not generalized+(because we're not generalizing the construct -- e.g., pattern+sig -- or because the metavars are constrained -- see kindGeneralizeSome)+we need to promote to maintain (WantedInv) of Note [TcLevel invariants]+in GHC.Tc.Utils.TcType. Note that promotion is identical in effect to generalizing+and the reinstantiating with a fresh metavariable at the current level.+So in some sense, we generalize *all* variables, but then re-instantiate+some of them.++Here is an example of why we must promote:+  foo (x :: forall a. a -> Proxy b) = ...++In the pattern signature, `b` is unbound, and will thus be brought into+scope. We do not know its kind: it will be assigned kappa[2]. Note that+kappa is at TcLevel 2, because it is invented under a forall. (A priori,+the kind kappa might depend on `a`, so kappa rightly has a higher TcLevel+than the surrounding context.) This kappa cannot be solved for while checking+the pattern signature (which is not kind-generalized). When we are checking+the *body* of foo, though, we need to unify the type of x with the argument+type of bar. At this point, the ambient TcLevel is 1, and spotting a+matavariable with level 2 would violate the (WantedInv) invariant of+Note [TcLevel invariants]. So, instead of kind-generalizing,+we promote the metavariable to level 1. This is all done in kindGeneralizeNone.++-}++funsSigCtxt :: [LocatedN Name] -> UserTypeCtxt+-- Returns FunSigCtxt, with no redundant-context-reporting,+-- form a list of located names+funsSigCtxt (L _ name1 : _) = FunSigCtxt name1 NoRRC+funsSigCtxt []              = panic "funSigCtxt"++addSigCtxt :: Outputable hs_ty => UserTypeCtxt -> LocatedA hs_ty -> TcM a -> TcM a+addSigCtxt ctxt hs_ty thing_inside+  = setSrcSpan (getLocA hs_ty) $+    addErrCtxt (pprSigCtxt ctxt hs_ty) $+    thing_inside++pprSigCtxt :: Outputable hs_ty => UserTypeCtxt -> LocatedA hs_ty -> SDoc+-- (pprSigCtxt ctxt <extra> <type>)+-- prints    In the type signature for 'f':+--              f :: <type>+-- The <extra> is either empty or "the ambiguity check for"+pprSigCtxt ctxt hs_ty+  | Just n <- isSigMaybe ctxt+  = hang (text "In the type signature:")+       2 (pprPrefixOcc n <+> dcolon <+> ppr hs_ty)++  | otherwise+  = hang (text "In" <+> pprUserTypeCtxt ctxt <> colon)+       2 (ppr hs_ty)++tcHsSigWcType :: UserTypeCtxt -> LHsSigWcType GhcRn -> TcM Type+-- This one is used when we have a LHsSigWcType, but in+-- a place where wildcards aren't allowed. The renamer has+-- already checked this, so we can simply ignore it.+tcHsSigWcType ctxt sig_ty = tcHsSigType ctxt (dropWildCards sig_ty)++kcClassSigType :: [LocatedN Name] -> LHsSigType GhcRn -> TcM ()+-- This is a special form of tcClassSigType that is used during the+-- kind-checking phase to infer the kind of class variables. Cf. tc_lhs_sig_type.+-- Importantly, this does *not* kind-generalize. Consider+--   class SC f where+--     meth :: forall a (x :: f a). Proxy x -> ()+-- When instantiating Proxy with kappa, we must unify kappa := f a. But we're+-- still working out the kind of f, and thus f a will have a coercion in it.+-- Coercions block unification (Note [Equalities with incompatible kinds] in+-- TcCanonical) and so we fail to unify. If we try to kind-generalize, we'll+-- end up promoting kappa to the top level (because kind-generalization is+-- normally done right before adding a binding to the context), and then we+-- can't set kappa := f a, because a is local.+kcClassSigType names+    sig_ty@(L _ (HsSig { sig_bndrs = hs_outer_bndrs, sig_body = hs_ty }))+  = addSigCtxt (funsSigCtxt names) sig_ty $+    do { _ <- bindOuterSigTKBndrs_Tv hs_outer_bndrs    $+              tcLHsType hs_ty liftedTypeKind+       ; return () }++tcClassSigType :: [LocatedN Name] -> LHsSigType GhcRn -> TcM Type+-- Does not do validity checking+tcClassSigType names sig_ty+  = addSigCtxt sig_ctxt sig_ty $+    do { skol_info <- mkSkolemInfo skol_info_anon+       ; (implic, ty) <- tc_lhs_sig_type skol_info sig_ty (TheKind liftedTypeKind)+       ; emitImplication implic+       ; return ty }+       -- Do not zonk-to-Type, nor perform a validity check+       -- We are in a knot with the class and associated types+       -- Zonking and validity checking is done by tcClassDecl+       --+       -- No need to fail here if the type has an error:+       --   If we're in the kind-checking phase, the solveEqualities+       --     in kcTyClGroup catches the error+       --   If we're in the type-checking phase, the solveEqualities+       --     in tcClassDecl1 gets it+       -- Failing fast here degrades the error message in, e.g., tcfail135:+       --   class Foo f where+       --     baa :: f a -> f+       -- If we fail fast, we're told that f has kind `k1` when we wanted `*`.+       -- It should be that f has kind `k2 -> *`, but we never get a chance+       -- to run the solver where the kind of f is touchable. This is+       -- painfully delicate.+  where+    sig_ctxt = funsSigCtxt names+    skol_info_anon = SigTypeSkol sig_ctxt++tcHsSigType :: UserTypeCtxt -> LHsSigType GhcRn -> TcM Type+-- Does validity checking+-- See Note [Recipe for checking a signature]+tcHsSigType ctxt sig_ty+  = addSigCtxt ctxt sig_ty $+    do { traceTc "tcHsSigType {" (ppr sig_ty)+       ; skol_info <- mkSkolemInfo skol_info+          -- Generalise here: see Note [Kind generalisation]+       ; (implic, ty) <- tc_lhs_sig_type skol_info sig_ty  (expectedKindInCtxt ctxt)++       -- Float out constraints, failing fast if not possible+       -- See Note [Failure in local type signatures] in GHC.Tc.Solver+       ; traceTc "tcHsSigType 2" (ppr implic)+       ; simplifyAndEmitFlatConstraints (mkImplicWC (unitBag implic))++       ; ty <- zonkTcType ty+       ; checkValidType ctxt ty+       ; traceTc "end tcHsSigType }" (ppr ty)+       ; return ty }+  where+    skol_info = SigTypeSkol ctxt++tc_lhs_sig_type :: SkolemInfo -> LHsSigType GhcRn+               -> ContextKind -> TcM (Implication, TcType)+-- Kind-checks/desugars an 'LHsSigType',+--   solve equalities,+--   and then kind-generalizes.+-- This will never emit constraints, as it uses solveEqualities internally.+-- No validity checking or zonking+-- Returns also an implication for the unsolved constraints+tc_lhs_sig_type skol_info full_hs_ty@(L loc (HsSig { sig_bndrs = hs_outer_bndrs+                                                   , sig_body = hs_ty })) ctxt_kind+  = setSrcSpanA loc $+    do { (tc_lvl, wanted, (exp_kind, (outer_bndrs, ty)))+              <- pushLevelAndSolveEqualitiesX "tc_lhs_sig_type" $+                 -- See Note [Failure in local type signatures]+                 do { exp_kind <- newExpectedKind ctxt_kind+                          -- See Note [Escaping kind in type signatures]+                    ; stuff <- tcOuterTKBndrs skol_info hs_outer_bndrs $+                               tcLHsType hs_ty exp_kind+                    ; return (exp_kind, stuff) }++       -- Default any unconstrained variables free in the kind+       -- See Note [Escaping kind in type signatures]+       ; exp_kind_dvs <- candidateQTyVarsOfType exp_kind+       ; doNotQuantifyTyVars exp_kind_dvs (mk_doc exp_kind)++       ; traceTc "tc_lhs_sig_type" (ppr hs_outer_bndrs $$ ppr outer_bndrs)+       ; outer_bndrs <- scopedSortOuter outer_bndrs++       ; let outer_tv_bndrs :: [InvisTVBinder] = outerTyVarBndrs outer_bndrs+             ty1 = mkInvisForAllTys outer_tv_bndrs ty+       ; kvs <- kindGeneralizeSome skol_info wanted ty1++       -- Build an implication for any as-yet-unsolved kind equalities+       -- See Note [Skolem escape in type signatures]+       ; implic <- buildTvImplication (getSkolemInfo skol_info) kvs tc_lvl wanted++       ; return (implic, mkInfForAllTys kvs ty1) }+  where+    mk_doc exp_kind tidy_env+      = do { (tidy_env2, exp_kind) <- zonkTidyTcType tidy_env exp_kind+           ; return (tidy_env2, hang (text "The kind" <+> ppr exp_kind)+                                   2 (text "of type signature:" <+> ppr full_hs_ty)) }++++{- Note [Escaping kind in type signatures]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider kind-checking the signature for `foo` (#19495):+  type family T (r :: RuntimeRep) :: TYPE r++  foo :: forall (r :: RuntimeRep). T r+  foo = ...++We kind-check the type with expected kind `TYPE delta` (see newExpectedKind),+where `delta :: RuntimeRep` is as-yet unknown. (We can't use `TYPE LiftedRep`+because we allow signatures like `foo :: Int#`.)++Suppose we are at level L currently.  We do this+  * pushLevelAndSolveEqualitiesX: moves to level L+1+  * newExpectedKind: allocates delta{L+1}+  * tcOuterTKBndrs: pushes the level again to L+2, binds skolem r{L+2}+  * kind-check the body (T r) :: TYPE delta{L+1}++Then+* We can't unify delta{L+1} with r{L+2}.+  And rightly so: skolem would escape.++* If delta{L+1} is unified with some-kind{L}, that is fine.+  This can happen+      \(x::a) -> let y :: a; y = x in ...(x :: Int#)...+  Here (x :: a :: TYPE gamma) is in the environment when we check+  the signature y::a.  We unify delta := gamma, and all is well.++* If delta{L+1} is unconstrained, we /must not/ quantify over it!+  E.g. Consider f :: Any   where Any :: forall k. k+  We kind-check this with expected kind TYPE kappa. We get+      Any @(TYPE kappa) :: TYPE kappa+  We don't want to generalise to     forall k. Any @k+  because that is ill-kinded: the kind of the body of the forall,+  (Any @k :: k) mentions the bound variable k.++  Instead we want to default it to LiftedRep.++  An alternative would be to promote it, similar to the monomorphism+  restriction, but the MR is pretty confusing.  Defaulting seems better++How does that defaulting happen?  Well, since we /currently/ default+RuntimeRep variables during generalisation, it'll happen in+kindGeneralize. But in principle we might allow generalisation over+RuntimeRep variables in future.  Moreover, what if we had+   kappa{L+1} := F alpha{L+1}+where F :: Type -> RuntimeRep.   Now it's alpha that is free in the kind+and it /won't/ be defaulted.++So we use doNotQuantifyTyVars to either default the free vars of+exp_kind (if possible), or error (if not).++Note [Skolem escape in type signatures]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+tcHsSigType is tricky.  Consider (T11142)+  foo :: forall b. (forall k (a :: k). SameKind a b) -> ()+This is ill-kinded because of a nested skolem-escape.++That will show up as an un-solvable constraint in the implication+returned by buildTvImplication in tc_lhs_sig_type.  See Note [Skolem+escape prevention] in GHC.Tc.Utils.TcType for why it is unsolvable+(the unification variable for b's kind is untouchable).++Then, in GHC.Tc.Solver.simplifyAndEmitFlatConstraints (called from tcHsSigType)+we'll try to float out the constraint, be unable to do so, and fail.+See GHC.Tc.Solver Note [Failure in local type signatures] for more+detail on this.++The separation between tcHsSigType and tc_lhs_sig_type is because+tcClassSigType wants to use the latter, but *not* fail fast, because+there are skolems from the class decl which are in scope; but it's fine+not to because tcClassDecl1 has a solveEqualities wrapped around all+the tcClassSigType calls.++That's why tcHsSigType does simplifyAndEmitFlatConstraints (which+fails fast) but tcClassSigType just does emitImplication (which does+not).  Ugh.++c.f. see also Note [Skolem escape and forall-types]. The difference+is that we don't need to simplify at a forall type, only at the+top level of a signature.+-}++-- Does validity checking and zonking.+tcStandaloneKindSig :: LStandaloneKindSig GhcRn -> TcM (Name, Kind)+tcStandaloneKindSig (L _ (StandaloneKindSig _ (L _ name) ksig))+  = addSigCtxt ctxt ksig $+    do { kind <- tc_top_lhs_type KindLevel ctxt ksig+       ; checkValidType ctxt kind+       ; return (name, kind) }+  where+   ctxt = StandaloneKindSigCtxt name++tcTopLHsType :: UserTypeCtxt -> LHsSigType GhcRn -> TcM Type+tcTopLHsType ctxt lsig_ty+  = checkNoErrs $  -- Fail eagerly to avoid follow-on errors.  We are at+                   -- top level so these constraints will never be solved later.+    tc_top_lhs_type TypeLevel ctxt lsig_ty++tc_top_lhs_type :: TypeOrKind -> UserTypeCtxt -> LHsSigType GhcRn -> TcM Type+-- tc_top_lhs_type is used for kind-checking top-level LHsSigTypes where+--   we want to fully solve /all/ equalities, and report errors+-- Does zonking, but not validity checking because it's used+--   for things (like deriving and instances) that aren't+--   ordinary types+-- Used for both types and kinds+tc_top_lhs_type tyki ctxt (L loc sig_ty@(HsSig { sig_bndrs = hs_outer_bndrs+                                               , sig_body = body }))+  = setSrcSpanA loc $+    do { traceTc "tc_top_lhs_type {" (ppr sig_ty)+       ; skol_info <- mkSkolemInfo skol_info_anon+       ; (tclvl, wanted, (outer_bndrs, ty))+              <- pushLevelAndSolveEqualitiesX "tc_top_lhs_type"    $+                 tcOuterTKBndrs skol_info hs_outer_bndrs $+                 do { kind <- newExpectedKind (expectedKindInCtxt ctxt)+                    ; tc_lhs_type (mkMode tyki) body kind }++       ; outer_bndrs <- scopedSortOuter outer_bndrs+       ; let outer_tv_bndrs = outerTyVarBndrs outer_bndrs+             ty1 = mkInvisForAllTys outer_tv_bndrs ty++       ; kvs <- kindGeneralizeAll skol_info ty1  -- "All" because it's a top-level type+       ; reportUnsolvedEqualities skol_info kvs tclvl wanted++       ; ze       <- mkEmptyZonkEnv NoFlexi+       ; final_ty <- zonkTcTypeToTypeX ze (mkInfForAllTys kvs ty1)+       ; traceTc "tc_top_lhs_type }" (vcat [ppr sig_ty, ppr final_ty])+       ; return final_ty }+  where+    skol_info_anon = SigTypeSkol ctxt++-----------------+tcHsDeriv :: LHsSigType GhcRn -> TcM ([TyVar], Class, [Type], [Kind])+-- Like tcHsSigType, but for the ...deriving( C t1 ty2 ) clause+-- Returns the C, [ty1, ty2, and the kinds of C's remaining arguments+-- E.g.    class C (a::*) (b::k->k)+--         data T a b = ... deriving( C Int )+--    returns ([k], C, [k, Int], [k->k])+-- Return values are fully zonked+tcHsDeriv hs_ty+  = do { ty <- tcTopLHsType DerivClauseCtxt hs_ty+       ; let (tvs, pred)    = splitForAllTyCoVars ty+             (kind_args, _) = splitFunTys (tcTypeKind pred)+       ; case getClassPredTys_maybe pred of+           Just (cls, tys) -> return (tvs, cls, tys, map scaledThing kind_args)+           Nothing -> failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $+             (text "Illegal deriving item" <+> quotes (ppr hs_ty)) }++-- | Typecheck a deriving strategy. For most deriving strategies, this is a+-- no-op, but for the @via@ strategy, this requires typechecking the @via@ type.+tcDerivStrategy :: Maybe (LDerivStrategy GhcRn)+                   -- ^ The deriving strategy+                -> TcM (Maybe (LDerivStrategy GhcTc), [TcTyVar])+                   -- ^ The typechecked deriving strategy and the tyvars that it binds+                   -- (if using 'ViaStrategy').+tcDerivStrategy mb_lds+  = case mb_lds of+      Nothing -> boring_case Nothing+      Just (L loc ds) ->+        setSrcSpanA loc $ do+          (ds', tvs) <- tc_deriv_strategy ds+          pure (Just (L loc ds'), tvs)+  where+    tc_deriv_strategy :: DerivStrategy GhcRn+                      -> TcM (DerivStrategy GhcTc, [TyVar])+    tc_deriv_strategy (StockStrategy    _) = boring_case (StockStrategy    noExtField)+    tc_deriv_strategy (AnyclassStrategy _) = boring_case (AnyclassStrategy noExtField)+    tc_deriv_strategy (NewtypeStrategy  _) = boring_case (NewtypeStrategy  noExtField)+    tc_deriv_strategy (ViaStrategy hs_sig)+      = do { ty <- tcTopLHsType DerivClauseCtxt hs_sig+           ; rec { (via_tvs, via_pred) <- tcSkolemiseInvisibleBndrs (DerivSkol via_pred) ty}+           ; pure (ViaStrategy via_pred, via_tvs) }++    boring_case :: ds -> TcM (ds, [a])+    boring_case ds = pure (ds, [])++tcHsClsInstType :: UserTypeCtxt    -- InstDeclCtxt or SpecInstCtxt+                -> LHsSigType GhcRn+                -> TcM Type+-- Like tcHsSigType, but for a class instance declaration+tcHsClsInstType user_ctxt hs_inst_ty+  = setSrcSpan (getLocA hs_inst_ty) $+    do { inst_ty <- tcTopLHsType user_ctxt hs_inst_ty+       ; checkValidInstance user_ctxt hs_inst_ty inst_ty+       ; return inst_ty }++----------------------------------------------+-- | Type-check a visible type application+tcHsTypeApp :: LHsWcType GhcRn -> Kind -> TcM Type+-- See Note [Recipe for checking a signature] in GHC.Tc.Gen.HsType+tcHsTypeApp wc_ty kind+  | HsWC { hswc_ext = sig_wcs, hswc_body = hs_ty } <- wc_ty+  = do { mode <- mkHoleMode TypeLevel HM_VTA+                 -- HM_VTA: See Note [Wildcards in visible type application]+       ; ty <- addTypeCtxt hs_ty                  $+               solveEqualities "tcHsTypeApp" $+               -- We are looking at a user-written type, very like a+               -- signature so we want to solve its equalities right now+               bindNamedWildCardBinders sig_wcs $ \ _ ->+               tc_lhs_type mode hs_ty kind++       -- We do not kind-generalize type applications: we just+       -- instantiate with exactly what the user says.+       -- See Note [No generalization in type application]+       -- We still must call kindGeneralizeNone, though, according+       -- to Note [Recipe for checking a signature]+       ; kindGeneralizeNone ty+       ; ty <- zonkTcType ty+       ; checkValidType TypeAppCtxt ty+       ; return ty }++{- Note [Wildcards in visible type application]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A HsWildCardBndrs's hswc_ext now only includes /named/ wildcards, so+any unnamed wildcards stay unchanged in hswc_body.  When called in+tcHsTypeApp, tcCheckLHsType will call emitAnonTypeHole+on these anonymous wildcards. However, this would trigger+error/warning when an anonymous wildcard is passed in as a visible type+argument, which we do not want because users should be able to write+@_ to skip a instantiating a type variable variable without fuss. The+solution is to switch the PartialTypeSignatures flags here to let the+typechecker know that it's checking a '@_' and do not emit hole+constraints on it.  See related Note [Wildcards in visible kind+application] and Note [The wildcard story for types] in GHC.Hs.Type++Ugh!++Note [No generalization in type application]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We do not kind-generalize type applications. Imagine++  id @(Proxy Nothing)++If we kind-generalized, we would get++  id @(forall {k}. Proxy @(Maybe k) (Nothing @k))++which is very sneakily impredicative instantiation.++There is also the possibility of mentioning a wildcard+(`id @(Proxy _)`), which definitely should not be kind-generalized.++-}++tcFamTyPats :: TyCon+            -> HsTyPats GhcRn                -- Patterns+            -> TcM (TcType, TcKind)          -- (lhs_type, lhs_kind)+-- Check the LHS of a type/data family instance+-- e.g.   type instance F ty1 .. tyn = ...+-- Used for both type and data families+tcFamTyPats fam_tc hs_pats+  = do { traceTc "tcFamTyPats {" $+         vcat [ ppr fam_tc, text "arity:" <+> ppr fam_arity ]++       ; mode <- mkHoleMode TypeLevel HM_FamPat+                 -- HM_FamPat: See Note [Wildcards in family instances] in+                 -- GHC.Rename.Module+       ; let fun_ty = mkTyConApp fam_tc []+       ; (fam_app, res_kind) <- tcInferTyApps mode lhs_fun fun_ty hs_pats++       -- Hack alert: see Note [tcFamTyPats: zonking the result kind]+       ; res_kind <- zonkTcType res_kind++       ; traceTc "End tcFamTyPats }" $+         vcat [ ppr fam_tc, text "res_kind:" <+> ppr res_kind ]++       ; return (fam_app, res_kind) }+  where+    fam_name  = tyConName fam_tc+    fam_arity = tyConArity fam_tc+    lhs_fun   = noLocA (HsTyVar noAnn NotPromoted (noLocA fam_name))++{- Note [tcFamTyPats: zonking the result kind]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider (#19250)+    F :: forall k. k -> k+    type instance F (x :: Constraint) = ()++The tricky point is this:+  is that () an empty type tuple (() :: Type), or+  an empty constraint tuple (() :: Constraint)?+We work this out in a hacky way, by looking at the expected kind:+see Note [Inferring tuple kinds].++In this case, we kind-check the RHS using the kind gotten from the LHS:+see the call to tcCheckLHsType in tcTyFamInstEqnGuts in GHC.Tc.Tycl.++But we want the kind from the LHS to be /zonked/, so that when+kind-checking the RHS (tcCheckLHsType) we can "see" what we learned+from kind-checking the LHS (tcFamTyPats).  In our example above, the+type of the LHS is just `kappa` (by instantiating the forall k), but+then we learn (from x::Constraint) that kappa ~ Constraint.  We want+that info when kind-checking the RHS.++Easy solution: just zonk that return kind.  Of course this won't help+if there is lots of type-family reduction to do, but it works fine in+common cases.+-}+++{-+************************************************************************+*                                                                      *+            The main kind checker: no validity checks here+*                                                                      *+************************************************************************+-}++---------------------------+tcHsOpenType, tcHsLiftedType,+  tcHsOpenTypeNC, tcHsLiftedTypeNC :: LHsType GhcRn -> TcM TcType+-- Used for type signatures+-- Do not do validity checking+tcHsOpenType   hs_ty = addTypeCtxt hs_ty $ tcHsOpenTypeNC hs_ty+tcHsLiftedType hs_ty = addTypeCtxt hs_ty $ tcHsLiftedTypeNC hs_ty++tcHsOpenTypeNC   hs_ty = do { ek <- newOpenTypeKind; tcLHsType hs_ty ek }+tcHsLiftedTypeNC hs_ty = tcLHsType hs_ty liftedTypeKind++-- Like tcHsType, but takes an expected kind+tcCheckLHsType :: LHsType GhcRn -> ContextKind -> TcM TcType+tcCheckLHsType hs_ty exp_kind+  = addTypeCtxt hs_ty $+    do { ek <- newExpectedKind exp_kind+       ; tcLHsType hs_ty ek }++tcInferLHsType :: LHsType GhcRn -> TcM TcType+tcInferLHsType hs_ty+  = do { (ty,_kind) <- tcInferLHsTypeKind hs_ty+       ; return ty }++tcInferLHsTypeKind :: LHsType GhcRn -> TcM (TcType, TcKind)+-- Called from outside: set the context+-- Eagerly instantiate any trailing invisible binders+tcInferLHsTypeKind lhs_ty@(L loc hs_ty)+  = addTypeCtxt lhs_ty $+    setSrcSpanA loc    $  -- Cover the tcInstInvisibleTyBinders+    do { (res_ty, res_kind) <- tc_infer_hs_type typeLevelMode hs_ty+       ; tcInstInvisibleTyBinders res_ty res_kind }+  -- See Note [Do not always instantiate eagerly in types]++-- Used to check the argument of GHCi :kind+-- Allow and report wildcards, e.g. :kind T _+-- Do not saturate family applications: see Note [Dealing with :kind]+-- Does not instantiate eagerly; See Note [Do not always instantiate eagerly in types]+tcInferLHsTypeUnsaturated :: LHsType GhcRn -> TcM (TcType, TcKind)+tcInferLHsTypeUnsaturated hs_ty+  = addTypeCtxt hs_ty $+    do { mode <- mkHoleMode TypeLevel HM_Sig  -- Allow and report holes+       ; case splitHsAppTys (unLoc hs_ty) of+           Just (hs_fun_ty, hs_args)+              -> do { (fun_ty, _ki) <- tcInferTyAppHead mode hs_fun_ty+                    ; tcInferTyApps_nosat mode hs_fun_ty fun_ty hs_args }+                      -- Notice the 'nosat'; do not instantiate trailing+                      -- invisible arguments of a type family.+                      -- See Note [Dealing with :kind]+           Nothing -> tc_infer_lhs_type mode hs_ty }++{- Note [Dealing with :kind]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this GHCi command+  ghci> type family F :: Either j k+  ghci> :kind F+  F :: forall {j,k}. Either j k++We will only get the 'forall' if we /refrain/ from saturating those+invisible binders. But generally we /do/ saturate those invisible+binders (see tcInferTyApps), and we want to do so for nested application+even in GHCi.  Consider for example (#16287)+  ghci> type family F :: k+  ghci> data T :: (forall k. k) -> Type+  ghci> :kind T F+We want to reject this. It's just at the very top level that we want+to switch off saturation.++So tcInferLHsTypeUnsaturated does a little special case for top level+applications.  Actually the common case is a bare variable, as above.++Note [Do not always instantiate eagerly in types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Terms are eagerly instantiated. This means that if you say++  x = id++then `id` gets instantiated to have type alpha -> alpha. The variable+alpha is then unconstrained and regeneralized. But we cannot do this+in types, as we have no type-level lambda. So, when we are sure+that we will not want to regeneralize later -- because we are done+checking a type, for example -- we can instantiate. But we do not+instantiate at variables, nor do we in tcInferLHsTypeUnsaturated,+which is used by :kind in GHCi.++************************************************************************+*                                                                      *+      Type-checking modes+*                                                                      *+************************************************************************++The kind-checker is parameterised by a TcTyMode, which contains some+information about where we're checking a type.++The renamer issues errors about what it can. All errors issued here must+concern things that the renamer can't handle.++-}++tcMult :: HsArrow GhcRn -> TcM Mult+tcMult hc = tc_mult typeLevelMode hc++-- | Info about the context in which we're checking a type. Currently,+-- differentiates only between types and kinds, but this will likely+-- grow, at least to include the distinction between patterns and+-- not-patterns.+--+-- To find out where the mode is used, search for 'mode_tyki'+--+-- This data type is purely local, not exported from this module+data TcTyMode+  = TcTyMode { mode_tyki :: TypeOrKind+             , mode_holes :: HoleInfo   }++-- See Note [Levels for wildcards]+-- Nothing <=> no wildcards expected+type HoleInfo = Maybe (TcLevel, HoleMode)++-- HoleMode says how to treat the occurrences+-- of anonymous wildcards; see tcAnonWildCardOcc+data HoleMode = HM_Sig      -- Partial type signatures: f :: _ -> Int+              | HM_FamPat   -- Family instances: F _ Int = Bool+              | HM_VTA      -- Visible type and kind application:+                            --   f @(Maybe _)+                            --   Maybe @(_ -> _)+              | HM_TyAppPat -- Visible type applications in patterns:+                            --   foo (Con @_ @t x) = ...+                            --   case x of Con @_ @t v -> ...++mkMode :: TypeOrKind -> TcTyMode+mkMode tyki = TcTyMode { mode_tyki = tyki, mode_holes = Nothing }++typeLevelMode, kindLevelMode :: TcTyMode+-- These modes expect no wildcards (holes) in the type+kindLevelMode = mkMode KindLevel+typeLevelMode = mkMode TypeLevel++mkHoleMode :: TypeOrKind -> HoleMode -> TcM TcTyMode+mkHoleMode tyki hm+  = do { lvl <- getTcLevel+       ; return (TcTyMode { mode_tyki  = tyki+                          , mode_holes = Just (lvl,hm) }) }++instance Outputable HoleMode where+  ppr HM_Sig      = text "HM_Sig"+  ppr HM_FamPat   = text "HM_FamPat"+  ppr HM_VTA      = text "HM_VTA"+  ppr HM_TyAppPat = text "HM_TyAppPat"++instance Outputable TcTyMode where+  ppr (TcTyMode { mode_tyki = tyki, mode_holes = hm })+    = text "TcTyMode" <+> braces (sep [ ppr tyki <> comma+                                      , ppr hm ])++{-+Note [Bidirectional type checking]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In expressions, whenever we see a polymorphic identifier, say `id`, we are+free to instantiate it with metavariables, knowing that we can always+re-generalize with type-lambdas when necessary. For example:++  rank2 :: (forall a. a -> a) -> ()+  x = rank2 id++When checking the body of `x`, we can instantiate `id` with a metavariable.+Then, when we're checking the application of `rank2`, we notice that we really+need a polymorphic `id`, and then re-generalize over the unconstrained+metavariable.++In types, however, we're not so lucky, because *we cannot re-generalize*!+There is no lambda. So, we must be careful only to instantiate at the last+possible moment, when we're sure we're never going to want the lost polymorphism+again. This is done in calls to tcInstInvisibleTyBinders.++To implement this behavior, we use bidirectional type checking, where we+explicitly think about whether we know the kind of the type we're checking+or not. Note that there is a difference between not knowing a kind and+knowing a metavariable kind: the metavariables are TauTvs, and cannot become+forall-quantified kinds. Previously (before dependent types), there were+no higher-rank kinds, and so we could instantiate early and be sure that+no types would have polymorphic kinds, and so we could always assume that+the kind of a type was a fresh metavariable. Not so anymore, thus the+need for two algorithms.++For HsType forms that can never be kind-polymorphic, we implement only the+"down" direction, where we safely assume a metavariable kind. For HsType forms+that *can* be kind-polymorphic, we implement just the "up" (functions with+"infer" in their name) version, as we gain nothing by also implementing the+"down" version.++Note [Future-proofing the type checker]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+As discussed in Note [Bidirectional type checking], each HsType form is+handled in *either* tc_infer_hs_type *or* tc_hs_type. These functions+are mutually recursive, so that either one can work for any type former.+But, we want to make sure that our pattern-matches are complete. So,+we have a bunch of repetitive code just so that we get warnings if we're+missing any patterns.++-}++------------------------------------------+-- | Check and desugar a type, returning the core type and its+-- possibly-polymorphic kind. Much like 'tcInferRho' at the expression+-- level.+tc_infer_lhs_type :: TcTyMode -> LHsType GhcRn -> TcM (TcType, TcKind)+tc_infer_lhs_type mode (L span ty)+  = setSrcSpanA span $+    tc_infer_hs_type mode ty++---------------------------+-- | Call 'tc_infer_hs_type' and check its result against an expected kind.+tc_infer_hs_type_ek :: HasDebugCallStack => TcTyMode -> HsType GhcRn -> TcKind -> TcM TcType+tc_infer_hs_type_ek mode hs_ty ek+  = do { (ty, k) <- tc_infer_hs_type mode hs_ty+       ; checkExpectedKind hs_ty ty k ek }++---------------------------+-- | Infer the kind of a type and desugar. This is the "up" type-checker,+-- as described in Note [Bidirectional type checking]+tc_infer_hs_type :: TcTyMode -> HsType GhcRn -> TcM (TcType, TcKind)++tc_infer_hs_type mode (HsParTy _ t)+  = tc_infer_lhs_type mode t++tc_infer_hs_type mode ty+  | Just (hs_fun_ty, hs_args) <- splitHsAppTys ty+  = do { (fun_ty, _ki) <- tcInferTyAppHead mode hs_fun_ty+       ; tcInferTyApps mode hs_fun_ty fun_ty hs_args }++tc_infer_hs_type mode (HsKindSig _ ty sig)+  = do { let mode' = mode { mode_tyki = KindLevel }+       ; sig' <- tc_lhs_kind_sig mode' KindSigCtxt sig+                 -- We must typecheck the kind signature, and solve all+                 -- its equalities etc; from this point on we may do+                 -- things like instantiate its foralls, so it needs+                 -- to be fully determined (#14904)+       ; traceTc "tc_infer_hs_type:sig" (ppr ty $$ ppr sig')+       ; ty' <- tc_lhs_type mode ty sig'+       ; return (ty', sig') }++-- HsSpliced is an annotation produced by 'GHC.Rename.Splice.rnSpliceType' to communicate+-- the splice location to the typechecker. Here we skip over it in order to have+-- the same kind inferred for a given expression whether it was produced from+-- splices or not.+--+-- See Note [Delaying modFinalizers in untyped splices].+tc_infer_hs_type mode (HsSpliceTy _ (HsSpliced _ _ (HsSplicedTy ty)))+  = tc_infer_hs_type mode ty++tc_infer_hs_type mode (HsDocTy _ ty _) = tc_infer_lhs_type mode ty++-- See Note [Typechecking HsCoreTys]+tc_infer_hs_type _ (XHsType ty)+  = do env <- getLclEnv+       -- Raw uniques since we go from NameEnv to TvSubstEnv.+       let subst_prs :: [(Unique, TcTyVar)]+           subst_prs = [ (getUnique nm, tv)+                       | ATyVar nm tv <- nonDetNameEnvElts (tcl_env env) ]+           subst = mkTvSubst+                     (mkInScopeSet $ mkVarSet $ map snd subst_prs)+                     (listToUFM_Directly $ map (liftSnd mkTyVarTy) subst_prs)+           ty' = substTy subst ty+       return (ty', tcTypeKind ty')++tc_infer_hs_type _ (HsExplicitListTy _ _ tys)+  | null tys  -- this is so that we can use visible kind application with '[]+              -- e.g ... '[] @Bool+  = return (mkTyConTy promotedNilDataCon,+            mkSpecForAllTys [alphaTyVar] $ mkListTy alphaTy)++tc_infer_hs_type mode other_ty+  = do { kv <- newMetaKindVar+       ; ty' <- tc_hs_type mode other_ty kv+       ; return (ty', kv) }++{-+Note [Typechecking HsCoreTys]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+HsCoreTy is an escape hatch that allows embedding Core Types in HsTypes.+As such, there's not much to be done in order to typecheck an HsCoreTy,+since it's already been typechecked to some extent. There is one thing that+we must do, however: we must substitute the type variables from the tcl_env.+To see why, consider GeneralizedNewtypeDeriving, which is one of the main+clients of HsCoreTy (example adapted from #14579):++  newtype T a = MkT a deriving newtype Eq++This will produce an InstInfo GhcPs that looks roughly like this:++  instance forall a_1. Eq a_1 => Eq (T a_1) where+    (==) = coerce @(  a_1 ->   a_1 -> Bool) -- The type within @(...) is an HsCoreTy+                  @(T a_1 -> T a_1 -> Bool) -- So is this+                  (==)++This is then fed into the renamer. Since all of the type variables in this+InstInfo use Exact RdrNames, the resulting InstInfo GhcRn looks basically+identical. Things get more interesting when the InstInfo is fed into the+typechecker, however. GHC will first generate fresh skolems to instantiate+the instance-bound type variables with. In the example above, we might generate+the skolem a_2 and use that to instantiate a_1, which extends the local type+environment (tcl_env) with [a_1 :-> a_2]. This gives us:++  instance forall a_2. Eq a_2 => Eq (T a_2) where ...++To ensure that the body of this instance is well scoped, every occurrence of+the `a` type variable should refer to a_2, the new skolem. However, the+HsCoreTys mention a_1, not a_2. Luckily, the tcl_env provides exactly the+substitution we need ([a_1 :-> a_2]) to fix up the scoping. We apply this+substitution to each HsCoreTy and all is well:++  instance forall a_2. Eq a_2 => Eq (T a_2) where+    (==) = coerce @(  a_2 ->   a_2 -> Bool)+                  @(T a_2 -> T a_2 -> Bool)+                  (==)+-}++------------------------------------------+tcLHsType :: LHsType GhcRn -> TcKind -> TcM TcType+tcLHsType hs_ty exp_kind+  = tc_lhs_type typeLevelMode hs_ty exp_kind++tc_lhs_type :: TcTyMode -> LHsType GhcRn -> TcKind -> TcM TcType+tc_lhs_type mode (L span ty) exp_kind+  = setSrcSpanA span $+    tc_hs_type mode ty exp_kind++tc_hs_type :: TcTyMode -> HsType GhcRn -> TcKind -> TcM TcType+-- See Note [Bidirectional type checking]++tc_hs_type mode (HsParTy _ ty)   exp_kind = tc_lhs_type mode ty exp_kind+tc_hs_type mode (HsDocTy _ ty _) exp_kind = tc_lhs_type mode ty exp_kind+tc_hs_type _ ty@(HsBangTy _ bang _) _+    -- While top-level bangs at this point are eliminated (eg !(Maybe Int)),+    -- other kinds of bangs are not (eg ((!Maybe) Int)). These kinds of+    -- bangs are invalid, so fail. (#7210, #14761)+    = do { let bangError err = failWith $ TcRnUnknownMessage $ mkPlainError noHints $+                 text "Unexpected" <+> text err <+> text "annotation:" <+> ppr ty $$+                 text err <+> text "annotation cannot appear nested inside a type"+         ; case bang of+             HsSrcBang _ SrcUnpack _           -> bangError "UNPACK"+             HsSrcBang _ SrcNoUnpack _         -> bangError "NOUNPACK"+             HsSrcBang _ NoSrcUnpack SrcLazy   -> bangError "laziness"+             HsSrcBang _ _ _                   -> bangError "strictness" }+tc_hs_type _ ty@(HsRecTy {})      _+      -- Record types (which only show up temporarily in constructor+      -- signatures) should have been removed by now+    = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $+       (text "Record syntax is illegal here:" <+> ppr ty)++-- HsSpliced is an annotation produced by 'GHC.Rename.Splice.rnSpliceType'.+-- Here we get rid of it and add the finalizers to the global environment+-- while capturing the local environment.+--+-- See Note [Delaying modFinalizers in untyped splices].+tc_hs_type mode (HsSpliceTy _ (HsSpliced _ mod_finalizers (HsSplicedTy ty)))+           exp_kind+  = do addModFinalizersWithLclEnv mod_finalizers+       tc_hs_type mode ty exp_kind++-- This should never happen; type splices are expanded by the renamer+tc_hs_type _ ty@(HsSpliceTy {}) _exp_kind+  = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $+     (text "Unexpected type splice:" <+> ppr ty)++---------- Functions and applications+tc_hs_type mode (HsFunTy _ mult ty1 ty2) exp_kind+  = tc_fun_type mode mult ty1 ty2 exp_kind++tc_hs_type mode (HsOpTy _ _ ty1 (L _ op) ty2) exp_kind+  | op `hasKey` funTyConKey+  = tc_fun_type mode (HsUnrestrictedArrow noHsUniTok) ty1 ty2 exp_kind++--------- Foralls+tc_hs_type mode (HsForAllTy { hst_tele = tele, hst_body = ty }) exp_kind+  = do { (tv_bndrs, ty') <- tcTKTelescope mode tele $+                            tc_lhs_type mode ty exp_kind+                 -- Pass on the mode from the type, to any wildcards+                 -- in kind signatures on the forall'd variables+                 -- e.g.      f :: _ -> Int -> forall (a :: _). blah+                 -- Why exp_kind?  See Note [Body kind of a HsForAllTy]++       -- Do not kind-generalise here!  See Note [Kind generalisation]++       ; return (mkForAllTys tv_bndrs ty') }++tc_hs_type mode (HsQualTy { hst_ctxt = ctxt, hst_body = rn_ty }) exp_kind+  | null (unLoc ctxt)+  = tc_lhs_type mode rn_ty exp_kind++  -- See Note [Body kind of a HsQualTy]+  | tcIsConstraintKind exp_kind+  = do { ctxt' <- tc_hs_context mode ctxt+       ; ty'   <- tc_lhs_type mode rn_ty constraintKind+       ; return (mkPhiTy ctxt' ty') }++  | otherwise+  = do { ctxt' <- tc_hs_context mode ctxt++       ; ek <- newOpenTypeKind  -- The body kind (result of the function) can+                                -- be TYPE r, for any r, hence newOpenTypeKind+       ; ty' <- tc_lhs_type mode rn_ty ek+       ; checkExpectedKind (unLoc rn_ty) (mkPhiTy ctxt' ty')+                           liftedTypeKind exp_kind }++--------- Lists, arrays, and tuples+tc_hs_type mode rn_ty@(HsListTy _ elt_ty) exp_kind+  = do { tau_ty <- tc_lhs_type mode elt_ty liftedTypeKind+       ; checkWiredInTyCon listTyCon+       ; checkExpectedKind rn_ty (mkListTy tau_ty) liftedTypeKind exp_kind }++-- See Note [Distinguishing tuple kinds] in GHC.Hs.Type+-- See Note [Inferring tuple kinds]+tc_hs_type mode rn_ty@(HsTupleTy _ HsBoxedOrConstraintTuple hs_tys) exp_kind+     -- (NB: not zonking before looking at exp_k, to avoid left-right bias)+  | Just tup_sort <- tupKindSort_maybe exp_kind+  = traceTc "tc_hs_type tuple" (ppr hs_tys) >>+    tc_tuple rn_ty mode tup_sort hs_tys exp_kind+  | otherwise+  = do { traceTc "tc_hs_type tuple 2" (ppr hs_tys)+       ; (tys, kinds) <- mapAndUnzipM (tc_infer_lhs_type mode) hs_tys+       ; kinds <- mapM zonkTcType kinds+           -- Infer each arg type separately, because errors can be+           -- confusing if we give them a shared kind.  Eg #7410+           -- (Either Int, Int), we do not want to get an error saying+           -- "the second argument of a tuple should have kind *->*"++       ; let (arg_kind, tup_sort)+               = case [ (k,s) | k <- kinds+                              , Just s <- [tupKindSort_maybe k] ] of+                    ((k,s) : _) -> (k,s)+                    [] -> (liftedTypeKind, BoxedTuple)+         -- In the [] case, it's not clear what the kind is, so guess *++       ; tys' <- sequence [ setSrcSpanA loc $+                            checkExpectedKind hs_ty ty kind arg_kind+                          | ((L loc hs_ty),ty,kind) <- zip3 hs_tys tys kinds ]++       ; finish_tuple rn_ty tup_sort tys' (map (const arg_kind) tys') exp_kind }+++tc_hs_type mode rn_ty@(HsTupleTy _ HsUnboxedTuple tys) exp_kind+  = tc_tuple rn_ty mode UnboxedTuple tys exp_kind++tc_hs_type mode rn_ty@(HsSumTy _ hs_tys) exp_kind+  = do { let arity = length hs_tys+       ; arg_kinds <- mapM (\_ -> newOpenTypeKind) hs_tys+       ; tau_tys   <- zipWithM (tc_lhs_type mode) hs_tys arg_kinds+       ; let arg_reps = map kindRep arg_kinds+             arg_tys  = arg_reps ++ tau_tys+             sum_ty   = mkTyConApp (sumTyCon arity) arg_tys+             sum_kind = unboxedSumKind arg_reps+       ; checkExpectedKind rn_ty sum_ty sum_kind exp_kind+       }++--------- Promoted lists and tuples+tc_hs_type mode rn_ty@(HsExplicitListTy _ _ tys) exp_kind+  = do { tks <- mapM (tc_infer_lhs_type mode) tys+       ; (taus', kind) <- unifyKinds tys tks+       ; let ty = (foldr (mk_cons kind) (mk_nil kind) taus')+       ; checkExpectedKind rn_ty ty (mkListTy kind) exp_kind }+  where+    mk_cons k a b = mkTyConApp (promoteDataCon consDataCon) [k, a, b]+    mk_nil  k     = mkTyConApp (promoteDataCon nilDataCon) [k]++tc_hs_type mode rn_ty@(HsExplicitTupleTy _ tys) exp_kind+  -- using newMetaKindVar means that we force instantiations of any polykinded+  -- types. At first, I just used tc_infer_lhs_type, but that led to #11255.+  = do { ks   <- replicateM arity newMetaKindVar+       ; taus <- zipWithM (tc_lhs_type mode) tys ks+       ; let kind_con   = tupleTyCon           Boxed arity+             ty_con     = promotedTupleDataCon Boxed arity+             tup_k      = mkTyConApp kind_con ks+       ; checkTupSize arity+       ; checkExpectedKind rn_ty (mkTyConApp ty_con (ks ++ taus)) tup_k exp_kind }+  where+    arity = length tys++--------- Constraint types+tc_hs_type mode rn_ty@(HsIParamTy _ (L _ n) ty) exp_kind+  = do { massert (isTypeLevel (mode_tyki mode))+       ; ty' <- tc_lhs_type mode ty liftedTypeKind+       ; let n' = mkStrLitTy $ hsIPNameFS n+       ; ipClass <- tcLookupClass ipClassName+       ; checkExpectedKind rn_ty (mkClassPred ipClass [n',ty'])+                           constraintKind exp_kind }++tc_hs_type _ rn_ty@(HsStarTy _ _) exp_kind+  -- Desugaring 'HsStarTy' to 'Data.Kind.Type' here means that we don't have to+  -- handle it in 'coreView' and 'tcView'.+  = checkExpectedKind rn_ty liftedTypeKind liftedTypeKind exp_kind++--------- Literals+tc_hs_type _ rn_ty@(HsTyLit _ (HsNumTy _ n)) exp_kind+  = do { checkWiredInTyCon naturalTyCon+       ; checkExpectedKind rn_ty (mkNumLitTy n) naturalTy exp_kind }++tc_hs_type _ rn_ty@(HsTyLit _ (HsStrTy _ s)) exp_kind+  = do { checkWiredInTyCon typeSymbolKindCon+       ; checkExpectedKind rn_ty (mkStrLitTy s) typeSymbolKind exp_kind }+tc_hs_type _ rn_ty@(HsTyLit _ (HsCharTy _ c)) exp_kind+  = do { checkWiredInTyCon charTyCon+       ; checkExpectedKind rn_ty (mkCharLitTy c) charTy exp_kind }++--------- Wildcards++tc_hs_type mode ty@(HsWildCardTy _)        ek+  = tcAnonWildCardOcc NoExtraConstraint mode ty ek++--------- Potentially kind-polymorphic types: call the "up" checker+-- See Note [Future-proofing the type checker]+tc_hs_type mode ty@(HsTyVar {})            ek = tc_infer_hs_type_ek mode ty ek+tc_hs_type mode ty@(HsAppTy {})            ek = tc_infer_hs_type_ek mode ty ek+tc_hs_type mode ty@(HsAppKindTy{})         ek = tc_infer_hs_type_ek mode ty ek+tc_hs_type mode ty@(HsOpTy {})             ek = tc_infer_hs_type_ek mode ty ek+tc_hs_type mode ty@(HsKindSig {})          ek = tc_infer_hs_type_ek mode ty ek+tc_hs_type mode ty@(XHsType {})            ek = tc_infer_hs_type_ek mode ty ek++{-+Note [Variable Specificity and Forall Visibility]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A HsForAllTy contains an HsForAllTelescope to denote the visibility of the forall+binder. Furthermore, each invisible type variable binder also has a+Specificity. Together, these determine the variable binders (ArgFlag) for each+variable in the generated ForAllTy type.++This table summarises this relation:+----------------------------------------------------------------------------+| User-written type         HsForAllTelescope   Specificity        ArgFlag+|---------------------------------------------------------------------------+| f :: forall a. type       HsForAllInvis       SpecifiedSpec      Specified+| f :: forall {a}. type     HsForAllInvis       InferredSpec       Inferred+| f :: forall a -> type     HsForAllVis         SpecifiedSpec      Required+| f :: forall {a} -> type   HsForAllVis         InferredSpec       /+|   This last form is non-sensical and is thus rejected.+----------------------------------------------------------------------------++For more information regarding the interpretation of the resulting ArgFlag, see+Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in "GHC.Core.TyCo.Rep".+-}++------------------------------------------+tc_mult :: TcTyMode -> HsArrow GhcRn -> TcM Mult+tc_mult mode ty = tc_lhs_type mode (arrowToHsType ty) multiplicityTy+------------------------------------------+tc_fun_type :: TcTyMode -> HsArrow GhcRn -> LHsType GhcRn -> LHsType GhcRn -> TcKind+            -> TcM TcType+tc_fun_type mode mult ty1 ty2 exp_kind = case mode_tyki mode of+  TypeLevel ->+    do { arg_k <- newOpenTypeKind+       ; res_k <- newOpenTypeKind+       ; ty1' <- tc_lhs_type mode ty1 arg_k+       ; ty2' <- tc_lhs_type mode ty2 res_k+       ; mult' <- tc_mult mode mult+       ; checkExpectedKind (HsFunTy noAnn mult ty1 ty2) (mkVisFunTy mult' ty1' ty2')+                           liftedTypeKind exp_kind }+  KindLevel ->  -- no representation polymorphism in kinds. yet.+    do { ty1' <- tc_lhs_type mode ty1 liftedTypeKind+       ; ty2' <- tc_lhs_type mode ty2 liftedTypeKind+       ; mult' <- tc_mult mode mult+       ; checkExpectedKind (HsFunTy noAnn mult ty1 ty2) (mkVisFunTy mult' ty1' ty2')+                           liftedTypeKind exp_kind }++{- Note [Skolem escape and forall-types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+See also Note [Checking telescopes].++Consider+  f :: forall a. (forall kb (b :: kb). Proxy '[a, b]) -> ()++The Proxy '[a,b] forces a and b to have the same kind.  But a's+kind must be bound outside the 'forall a', and hence escapes.+We discover this by building an implication constraint for+each forall.  So the inner implication constraint will look like+    forall kb (b::kb).  kb ~ ka+where ka is a's kind.  We can't unify these two, /even/ if ka is+unification variable, because it would be untouchable inside+this inner implication.++That's what the pushLevelAndCaptureConstraints, plus subsequent+buildTvImplication/emitImplication is all about, when kind-checking+HsForAllTy.++Note that++* We don't need to /simplify/ the constraints here+  because we aren't generalising. We just capture them.++* We can't use emitResidualTvConstraint, because that has a fast-path+  for empty constraints.  We can't take that fast path here, because+  we must do the bad-telescope check even if there are no inner wanted+  constraints. See Note [Checking telescopes] in+  GHC.Tc.Types.Constraint.  Lacking this check led to #16247.+-}++{- *********************************************************************+*                                                                      *+                Tuples+*                                                                      *+********************************************************************* -}++---------------------------+tupKindSort_maybe :: TcKind -> Maybe TupleSort+tupKindSort_maybe k+  | Just (k', _) <- splitCastTy_maybe k = tupKindSort_maybe k'+  | Just k'      <- tcView k            = tupKindSort_maybe k'+  | tcIsConstraintKind k = Just ConstraintTuple+  | tcIsLiftedTypeKind k   = Just BoxedTuple+  | otherwise            = Nothing++tc_tuple :: HsType GhcRn -> TcTyMode -> TupleSort -> [LHsType GhcRn] -> TcKind -> TcM TcType+tc_tuple rn_ty mode tup_sort tys exp_kind+  = do { arg_kinds <- case tup_sort of+           BoxedTuple      -> return (replicate arity liftedTypeKind)+           UnboxedTuple    -> replicateM arity newOpenTypeKind+           ConstraintTuple -> return (replicate arity constraintKind)+       ; tau_tys <- zipWithM (tc_lhs_type mode) tys arg_kinds+       ; finish_tuple rn_ty tup_sort tau_tys arg_kinds exp_kind }+  where+    arity   = length tys++finish_tuple :: HsType GhcRn+             -> TupleSort+             -> [TcType]    -- ^ argument types+             -> [TcKind]    -- ^ of these kinds+             -> TcKind      -- ^ expected kind of the whole tuple+             -> TcM TcType+finish_tuple rn_ty tup_sort tau_tys tau_kinds exp_kind = do+  traceTc "finish_tuple" (ppr tup_sort $$ ppr tau_kinds $$ ppr exp_kind)+  case tup_sort of+    ConstraintTuple+      |  [tau_ty] <- tau_tys+         -- Drop any uses of 1-tuple constraints here.+         -- See Note [Ignore unary constraint tuples]+      -> check_expected_kind tau_ty constraintKind+      |  otherwise+      -> do let tycon = cTupleTyCon arity+            checkCTupSize arity+            check_expected_kind (mkTyConApp tycon tau_tys) constraintKind+    BoxedTuple -> do+      let tycon = tupleTyCon Boxed arity+      checkTupSize arity+      checkWiredInTyCon tycon+      check_expected_kind (mkTyConApp tycon tau_tys) liftedTypeKind+    UnboxedTuple -> do+      let tycon    = tupleTyCon Unboxed arity+          tau_reps = map kindRep tau_kinds+          -- See also Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon+          arg_tys  = tau_reps ++ tau_tys+          res_kind = unboxedTupleKind tau_reps+      checkTupSize arity+      check_expected_kind (mkTyConApp tycon arg_tys) res_kind+  where+    arity = length tau_tys+    check_expected_kind ty act_kind =+      checkExpectedKind rn_ty ty act_kind exp_kind++{-+Note [Ignore unary constraint tuples]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+GHC provides unary tuples and unboxed tuples (see Note [One-tuples] in+GHC.Builtin.Types) but does *not* provide unary constraint tuples. Why? First,+recall the definition of a unary tuple data type:++  data Solo a = Solo a++Note that `Solo a` is *not* the same thing as `a`, since Solo is boxed and+lazy. Therefore, the presence of `Solo` matters semantically. On the other+hand, suppose we had a unary constraint tuple:++  class a => Solo% a++This compiles down a newtype (i.e., a cast) in Core, so `Solo% a` is+semantically equivalent to `a`. Therefore, a 1-tuple constraint would have+no user-visible impact, nor would it allow you to express anything that+you couldn't otherwise.++We could simply add Solo% for consistency with tuples (Solo) and unboxed+tuples (Solo#), but that would require even more magic to wire in another+magical class, so we opt not to do so. We must be careful, however, since+one can try to sneak in uses of unary constraint tuples through Template+Haskell, such as in this program (from #17511):++  f :: $(pure (ForallT [] [TupleT 1 `AppT` (ConT ''Show `AppT` ConT ''Int)]+                       (ConT ''String)))+  -- f :: Solo% (Show Int) => String+  f = "abc"++This use of `TupleT 1` will produce an HsBoxedOrConstraintTuple of arity 1,+and since it is used in a Constraint position, GHC will attempt to treat+it as thought it were a constraint tuple, which can potentially lead to+trouble if one attempts to look up the name of a constraint tuple of arity+1 (as it won't exist). To avoid this trouble, we simply take any unary+constraint tuples discovered when typechecking and drop them—i.e., treat+"Solo% a" as though the user had written "a". This is always safe to do+since the two constraints should be semantically equivalent.+-}++{- *********************************************************************+*                                                                      *+                Type applications+*                                                                      *+********************************************************************* -}++splitHsAppTys :: HsType GhcRn -> Maybe (LHsType GhcRn, [LHsTypeArg GhcRn])+splitHsAppTys hs_ty+  | is_app hs_ty = Just (go (noLocA hs_ty) [])+  | otherwise    = Nothing+  where+    is_app :: HsType GhcRn -> Bool+    is_app (HsAppKindTy {})        = True+    is_app (HsAppTy {})            = True+    is_app (HsOpTy _ _ _ (L _ op) _) = not (op `hasKey` funTyConKey)+      -- I'm not sure why this funTyConKey test is necessary+      -- Can it even happen?  Perhaps for   t1 `(->)` t2+      -- but then maybe it's ok to treat that like a normal+      -- application rather than using the special rule for HsFunTy+    is_app (HsTyVar {})            = True+    is_app (HsParTy _ (L _ ty))    = is_app ty+    is_app _                       = False++    go :: LHsType GhcRn+       -> [HsArg (LHsType GhcRn) (LHsKind GhcRn)]+       -> (LHsType GhcRn,+           [HsArg (LHsType GhcRn) (LHsKind GhcRn)]) -- AZ temp+    go (L _  (HsAppTy _ f a))      as = go f (HsValArg a : as)+    go (L _  (HsAppKindTy l ty k)) as = go ty (HsTypeArg l k : as)+    go (L sp (HsParTy _ f))        as = go f (HsArgPar (locA sp) : as)+    go (L _  (HsOpTy _ prom l op@(L sp _) r)) as+      = ( L (na2la sp) (HsTyVar noAnn prom op)+        , HsValArg l : HsValArg r : as )+    go f as = (f, as)++---------------------------+tcInferTyAppHead :: TcTyMode -> LHsType GhcRn -> TcM (TcType, TcKind)+-- Version of tc_infer_lhs_type specialised for the head of an+-- application. In particular, for a HsTyVar (which includes type+-- constructors, it does not zoom off into tcInferTyApps and family+-- saturation+tcInferTyAppHead _ (L _ (HsTyVar _ _ (L _ tv)))+  = tcTyVar tv+tcInferTyAppHead mode ty+  = tc_infer_lhs_type mode ty++---------------------------+-- | Apply a type of a given kind to a list of arguments. This instantiates+-- invisible parameters as necessary. Always consumes all the arguments,+-- using matchExpectedFunKind as necessary.+-- This takes an optional @VarEnv Kind@ which maps kind variables to kinds.-+-- These kinds should be used to instantiate invisible kind variables;+-- they come from an enclosing class for an associated type/data family.+--+-- tcInferTyApps also arranges to saturate any trailing invisible arguments+--   of a type-family application, which is usually the right thing to do+-- tcInferTyApps_nosat does not do this saturation; it is used only+--   by ":kind" in GHCi+tcInferTyApps, tcInferTyApps_nosat+    :: TcTyMode+    -> LHsType GhcRn        -- ^ Function (for printing only)+    -> TcType               -- ^ Function+    -> [LHsTypeArg GhcRn]   -- ^ Args+    -> TcM (TcType, TcKind) -- ^ (f args, result kind)+tcInferTyApps mode hs_ty fun hs_args+  = do { (f_args, res_k) <- tcInferTyApps_nosat mode hs_ty fun hs_args+       ; saturateFamApp f_args res_k }++tcInferTyApps_nosat mode orig_hs_ty fun orig_hs_args+  = do { traceTc "tcInferTyApps {" (ppr orig_hs_ty $$ ppr orig_hs_args)+       ; (f_args, res_k) <- go_init 1 fun orig_hs_args+       ; traceTc "tcInferTyApps }" (ppr f_args <+> dcolon <+> ppr res_k)+       ; return (f_args, res_k) }+  where++    -- go_init just initialises the auxiliary+    -- arguments of the 'go' loop+    go_init n fun all_args+      = go n fun empty_subst fun_ki all_args+      where+        fun_ki = tcTypeKind fun+           -- We do (tcTypeKind fun) here, even though the caller+           -- knows the function kind, to absolutely guarantee+           -- INVARIANT for 'go'+           -- Note that in a typical application (F t1 t2 t3),+           -- the 'fun' is just a TyCon, so tcTypeKind is fast++        empty_subst = mkEmptyTCvSubst $ mkInScopeSet $+                      tyCoVarsOfType fun_ki++    go :: Int             -- The # of the next argument+       -> TcType          -- Function applied to some args+       -> TCvSubst        -- Applies to function kind+       -> TcKind          -- Function kind+       -> [LHsTypeArg GhcRn]    -- Un-type-checked args+       -> TcM (TcType, TcKind)  -- Result type and its kind+    -- INVARIANT: in any call (go n fun subst fun_ki args)+    --               tcTypeKind fun  =  subst(fun_ki)+    -- So the 'subst' and 'fun_ki' arguments are simply+    -- there to avoid repeatedly calling tcTypeKind.+    --+    -- Reason for INVARIANT: to support the Purely Kinded Type Invariant+    -- it's important that if fun_ki has a forall, then so does+    -- (tcTypeKind fun), because the next thing we are going to do+    -- is apply 'fun' to an argument type.++    -- Dispatch on all_args first, for performance reasons+    go n fun subst fun_ki all_args = case (all_args, tcSplitPiTy_maybe fun_ki) of++      ---------------- No user-written args left. We're done!+      ([], _) -> return (fun, substTy subst fun_ki)++      ---------------- HsArgPar: We don't care about parens here+      (HsArgPar _ : args, _) -> go n fun subst fun_ki args++      ---------------- HsTypeArg: a kind application (fun @ki)+      (HsTypeArg _ hs_ki_arg : hs_args, Just (ki_binder, inner_ki)) ->+        case ki_binder of++        -- FunTy with PredTy on LHS, or ForAllTy with Inferred+        Named (Bndr _ Inferred) -> instantiate ki_binder inner_ki+        Anon InvisArg _         -> instantiate ki_binder inner_ki++        Named (Bndr _ Specified) ->  -- Visible kind application+          do { traceTc "tcInferTyApps (vis kind app)"+                       (vcat [ ppr ki_binder, ppr hs_ki_arg+                             , ppr (tyBinderType ki_binder)+                             , ppr subst ])++             ; let exp_kind = substTy subst $ tyBinderType ki_binder+             ; arg_mode <- mkHoleMode KindLevel HM_VTA+                   -- HM_VKA: see Note [Wildcards in visible kind application]+             ; ki_arg <- addErrCtxt (funAppCtxt orig_hs_ty hs_ki_arg n) $+                         tc_lhs_type arg_mode hs_ki_arg exp_kind++             ; traceTc "tcInferTyApps (vis kind app)" (ppr exp_kind)+             ; (subst', fun') <- mkAppTyM subst fun ki_binder ki_arg+             ; go (n+1) fun' subst' inner_ki hs_args }++        -- Attempted visible kind application (fun @ki), but fun_ki is+        --   forall k -> blah   or   k1 -> k2+        -- So we need a normal application.  Error.+        _ -> ty_app_err hs_ki_arg $ substTy subst fun_ki++      -- No binder; try applying the substitution, or fail if that's not possible+      (HsTypeArg _ ki_arg : _, Nothing) -> try_again_after_substing_or $+                                           ty_app_err ki_arg substed_fun_ki++      ---------------- HsValArg: a normal argument (fun ty)+      (HsValArg arg : args, Just (ki_binder, inner_ki))+        -- next binder is invisible; need to instantiate it+        | isInvisibleBinder ki_binder   -- FunTy with InvisArg on LHS;+                                        -- or ForAllTy with Inferred or Specified+         -> instantiate ki_binder inner_ki++        -- "normal" case+        | otherwise+         -> do { traceTc "tcInferTyApps (vis normal app)"+                          (vcat [ ppr ki_binder+                                , ppr arg+                                , ppr (tyBinderType ki_binder)+                                , ppr subst ])+                ; let exp_kind = substTy subst $ tyBinderType ki_binder+                ; arg' <- addErrCtxt (funAppCtxt orig_hs_ty arg n) $+                          tc_lhs_type mode arg exp_kind+                ; traceTc "tcInferTyApps (vis normal app) 2" (ppr exp_kind)+                ; (subst', fun') <- mkAppTyM subst fun ki_binder arg'+                ; go (n+1) fun' subst' inner_ki args }++          -- no binder; try applying the substitution, or infer another arrow in fun kind+      (HsValArg _ : _, Nothing)+        -> try_again_after_substing_or $+           do { let arrows_needed = n_initial_val_args all_args+              ; co <- matchExpectedFunKind (HsTypeRnThing $ unLoc hs_ty) arrows_needed substed_fun_ki++              ; fun' <- zonkTcType (fun `mkTcCastTy` co)+                     -- This zonk is essential, to expose the fruits+                     -- of matchExpectedFunKind to the 'go' loop++              ; traceTc "tcInferTyApps (no binder)" $+                   vcat [ ppr fun <+> dcolon <+> ppr fun_ki+                        , ppr arrows_needed+                        , ppr co+                        , ppr fun' <+> dcolon <+> ppr (tcTypeKind fun')]+              ; go_init n fun' all_args }+                -- Use go_init to establish go's INVARIANT+      where+        instantiate ki_binder inner_ki+          = do { traceTc "tcInferTyApps (need to instantiate)"+                         (vcat [ ppr ki_binder, ppr subst])+               ; (subst', arg') <- tcInstInvisibleTyBinder subst ki_binder+               ; go n (mkAppTy fun arg') subst' inner_ki all_args }+                 -- Because tcInvisibleTyBinder instantiate ki_binder,+                 -- the kind of arg' will have the same shape as the kind+                 -- of ki_binder.  So we don't need mkAppTyM here.++        try_again_after_substing_or fallthrough+          | not (isEmptyTCvSubst subst)+          = go n fun zapped_subst substed_fun_ki all_args+          | otherwise+          = fallthrough++        zapped_subst   = zapTCvSubst subst+        substed_fun_ki = substTy subst fun_ki+        hs_ty          = appTypeToArg orig_hs_ty (take (n-1) orig_hs_args)++    n_initial_val_args :: [HsArg tm ty] -> Arity+    -- Count how many leading HsValArgs we have+    n_initial_val_args (HsValArg {} : args) = 1 + n_initial_val_args args+    n_initial_val_args (HsArgPar {} : args) = n_initial_val_args args+    n_initial_val_args _                    = 0++    ty_app_err arg ty+      = failWith $ TcRnUnknownMessage $ mkPlainError noHints $+          text "Cannot apply function of kind" <+> quotes (ppr ty)+            $$ text "to visible kind argument" <+> quotes (ppr arg)+++mkAppTyM :: TCvSubst+         -> TcType -> TyCoBinder    -- fun, plus its top-level binder+         -> TcType                  -- arg+         -> TcM (TCvSubst, TcType)  -- Extended subst, plus (fun arg)+-- Precondition: the application (fun arg) is well-kinded after zonking+--               That is, the application makes sense+--+-- Precondition: for (mkAppTyM subst fun bndr arg)+--       tcTypeKind fun  =  Pi bndr. body+--  That is, fun always has a ForAllTy or FunTy at the top+--           and 'bndr' is fun's pi-binder+--+-- Postcondition: if fun and arg satisfy (PKTI), the purely-kinded type+--                invariant, then so does the result type (fun arg)+--+-- We do not require that+--    tcTypeKind arg = tyVarKind (binderVar bndr)+-- This must be true after zonking (precondition 1), but it's not+-- required for the (PKTI).+mkAppTyM subst fun ki_binder arg+  | -- See Note [mkAppTyM]: Nasty case 2+    TyConApp tc args <- fun+  , isTypeSynonymTyCon tc+  , args `lengthIs` (tyConArity tc - 1)+  , any isTrickyTvBinder (tyConTyVars tc) -- We could cache this in the synonym+  = do { arg'  <- zonkTcType  arg+       ; args' <- zonkTcTypes args+       ; let subst' = case ki_binder of+                        Anon {}           -> subst+                        Named (Bndr tv _) -> extendTvSubstAndInScope subst tv arg'+       ; return (subst', mkTyConApp tc (args' ++ [arg'])) }+++mkAppTyM subst fun (Anon {}) arg+   = return (subst, mk_app_ty fun arg)++mkAppTyM subst fun (Named (Bndr tv _)) arg+  = do { arg' <- if isTrickyTvBinder tv+                 then -- See Note [mkAppTyM]: Nasty case 1+                      zonkTcType arg+                 else return     arg+       ; return ( extendTvSubstAndInScope subst tv arg'+                , mk_app_ty fun arg' ) }++mk_app_ty :: TcType -> TcType -> TcType+-- This function just adds an ASSERT for mkAppTyM's precondition+mk_app_ty fun arg+  = assertPpr (isPiTy fun_kind)+              (ppr fun <+> dcolon <+> ppr fun_kind $$ ppr arg) $+    mkAppTy fun arg+  where+    fun_kind = tcTypeKind fun++isTrickyTvBinder :: TcTyVar -> Bool+-- NB: isTrickyTvBinder is just an optimisation+-- It would be absolutely sound to return True always+isTrickyTvBinder tv = isPiTy (tyVarKind tv)++{- Note [The Purely Kinded Type Invariant (PKTI)]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+During type inference, we maintain this invariant++ (PKTI) It is legal to call 'tcTypeKind' on any Type ty,+        on any sub-term of ty, /without/ zonking ty++        Moreover, any such returned kind+        will itself satisfy (PKTI)++By "legal to call tcTypeKind" we mean "tcTypeKind will not crash".+The way in which tcTypeKind can crash is in applications+    (a t1 t2 .. tn)+if 'a' is a type variable whose kind doesn't have enough arrows+or foralls.  (The crash is in piResultTys.)++The loop in tcInferTyApps has to be very careful to maintain the (PKTI).+For example, suppose+    kappa is a unification variable+    We have already unified kappa := Type+      yielding    co :: Refl (Type -> Type)+    a :: kappa+then consider the type+    (a Int)+If we call tcTypeKind on that, we'll crash, because the (un-zonked)+kind of 'a' is just kappa, not an arrow kind.  So we must zonk first.++So the type inference engine is very careful when building applications.+This happens in tcInferTyApps. Suppose we are kind-checking the type (a Int),+where (a :: kappa).  Then in tcInferApps we'll run out of binders on+a's kind, so we'll call matchExpectedFunKind, and unify+   kappa := kappa1 -> kappa2,  with evidence co :: kappa ~ (kappa1 ~ kappa2)+At this point we must zonk the function type to expose the arrrow, so+that (a Int) will satisfy (PKTI).++The absence of this caused #14174 and #14520.++The calls to mkAppTyM is the other place we are very careful; see Note [mkAppTyM].++Wrinkle around FunTy:+Note that the PKTI does *not* guarantee anything about the shape of FunTys.+Specifically, when we have (FunTy vis mult arg res), it should be the case+that arg :: TYPE rr1 and res :: TYPE rr2, for some rr1 and rr2. However, we+might not have this. Example: if the user writes (a -> b), then we might+invent a :: kappa1 and b :: kappa2. We soon will check whether kappa1 ~ TYPE rho1+(for some rho1), and that will lead to kappa1 := TYPE rho1 (ditto for kappa2).+However, when we build the FunTy, we might not have zonked `a`, and so the+FunTy will be built without being able to purely extract the RuntimeReps.++Because the PKTI does not guarantee that the RuntimeReps are available in a FunTy,+we must be aware of this when splitting: splitTyConApp and splitAppTy will *not*+split a FunTy if the RuntimeReps are not available. See also Note [Decomposing FunTy]+in GHC.Tc.Solver.Canonical.++Note [mkAppTyM]+~~~~~~~~~~~~~~~+mkAppTyM is trying to guarantee the Purely Kinded Type Invariant+(PKTI) for its result type (fun arg).  There are two ways it can go wrong:++* Nasty case 1: forall types (polykinds/T14174a)+    T :: forall (p :: *->*). p Int -> p Bool+  Now kind-check (T x), where x::kappa.+  Well, T and x both satisfy the PKTI, but+     T x :: x Int -> x Bool+  and (x Int) does /not/ satisfy the PKTI.++* Nasty case 2: type synonyms+    type S f a = f a+  Even though (S ff aa) would satisfy the (PKTI) if S was a data type+  (i.e. nasty case 1 is dealt with), it might still not satisfy (PKTI)+  if S is a type synonym, because the /expansion/ of (S ff aa) is+  (ff aa), and /that/ does not satisfy (PKTI).  E.g. perhaps+  (ff :: kappa), where 'kappa' has already been unified with (*->*).++  We check for nasty case 2 on the final argument of a type synonym.++Notice that in both cases the trickiness only happens if the+bound variable has a pi-type.  Hence isTrickyTvBinder.+-}+++saturateFamApp :: TcType -> TcKind -> TcM (TcType, TcKind)+-- Precondition for (saturateFamApp ty kind):+--     tcTypeKind ty = kind+--+-- If 'ty' is an unsaturated family application with trailing+-- invisible arguments, instantiate them.+-- See Note [saturateFamApp]++saturateFamApp ty kind+  | Just (tc, args) <- tcSplitTyConApp_maybe ty+  , mustBeSaturated tc+  , let n_to_inst = tyConArity tc - length args+  = do { (extra_args, ki') <- tcInstInvisibleTyBindersN n_to_inst kind+       ; return (ty `mkTcAppTys` extra_args, ki') }+  | otherwise+  = return (ty, kind)++{- Note [saturateFamApp]+~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   type family F :: Either j k+   type instance F @Type = Right Maybe+   type instance F @Type = Right Either```++Then F :: forall {j,k}. Either j k++The two type instances do a visible kind application that instantiates+'j' but not 'k'.  But we want to end up with instances that look like+  type instance F @Type @(*->*) = Right @Type @(*->*) Maybe++so that F has arity 2.  We must instantiate that trailing invisible+binder. In general, Invisible binders precede Specified and Required,+so this is only going to bite for apparently-nullary families.++Note that+  type family F2 :: forall k. k -> *+is quite different and really does have arity 0.++It's not just type instances where we need to saturate those+unsaturated arguments: see #11246.  Hence doing this in tcInferApps.+-}++appTypeToArg :: LHsType GhcRn -> [LHsTypeArg GhcRn] -> LHsType GhcRn+appTypeToArg f []                       = f+appTypeToArg f (HsValArg arg    : args) = appTypeToArg (mkHsAppTy f arg) args+appTypeToArg f (HsArgPar _      : args) = appTypeToArg f                 args+appTypeToArg f (HsTypeArg l arg : args)+  = appTypeToArg (mkHsAppKindTy l f arg) args+++{- *********************************************************************+*                                                                      *+                checkExpectedKind+*                                                                      *+********************************************************************* -}++-- | This instantiates invisible arguments for the type being checked if it must+-- be saturated and is not yet saturated. It then calls and uses the result+-- from checkExpectedKindX to build the final type+checkExpectedKind :: HasDebugCallStack+                  => HsType GhcRn       -- ^ type we're checking (for printing)+                  -> TcType             -- ^ type we're checking+                  -> TcKind             -- ^ the known kind of that type+                  -> TcKind             -- ^ the expected kind+                  -> TcM TcType+-- Just a convenience wrapper to save calls to 'ppr'+checkExpectedKind hs_ty ty act_kind exp_kind+  = do { traceTc "checkExpectedKind" (ppr ty $$ ppr act_kind)++       ; (new_args, act_kind') <- tcInstInvisibleTyBindersN n_to_inst act_kind++       ; let origin = TypeEqOrigin { uo_actual   = act_kind'+                                   , uo_expected = exp_kind+                                   , uo_thing    = Just (HsTypeRnThing hs_ty)+                                   , uo_visible  = True } -- the hs_ty is visible++       ; traceTc "checkExpectedKindX" $+         vcat [ ppr hs_ty+              , text "act_kind':" <+> ppr act_kind'+              , text "exp_kind:" <+> ppr exp_kind ]++       ; let res_ty = ty `mkTcAppTys` new_args++       ; if act_kind' `tcEqType` exp_kind+         then return res_ty  -- This is very common+         else do { co_k <- uType KindLevel origin act_kind' exp_kind+                 ; traceTc "checkExpectedKind" (vcat [ ppr act_kind+                                                     , ppr exp_kind+                                                     , ppr co_k ])+                ; return (res_ty `mkTcCastTy` co_k) } }+    where+      -- We need to make sure that both kinds have the same number of implicit+      -- foralls out front. If the actual kind has more, instantiate accordingly.+      -- Otherwise, just pass the type & kind through: the errors are caught+      -- in unifyType.+      n_exp_invis_bndrs = invisibleTyBndrCount exp_kind+      n_act_invis_bndrs = invisibleTyBndrCount act_kind+      n_to_inst         = n_act_invis_bndrs - n_exp_invis_bndrs++---------------------------++tcHsContext :: Maybe (LHsContext GhcRn) -> TcM [PredType]+tcHsContext Nothing    = return []+tcHsContext (Just cxt) = tc_hs_context typeLevelMode cxt++tcLHsPredType :: LHsType GhcRn -> TcM PredType+tcLHsPredType pred = tc_lhs_pred typeLevelMode pred++tc_hs_context :: TcTyMode -> LHsContext GhcRn -> TcM [PredType]+tc_hs_context mode ctxt = mapM (tc_lhs_pred mode) (unLoc ctxt)++tc_lhs_pred :: TcTyMode -> LHsType GhcRn -> TcM PredType+tc_lhs_pred mode pred = tc_lhs_type mode pred constraintKind++---------------------------+tcTyVar :: Name -> TcM (TcType, TcKind)+-- See Note [Type checking recursive type and class declarations]+-- in GHC.Tc.TyCl+-- This does not instantiate. See Note [Do not always instantiate eagerly in types]+tcTyVar name         -- Could be a tyvar, a tycon, or a datacon+  = do { traceTc "lk1" (ppr name)+       ; thing <- tcLookup name+       ; case thing of+           ATyVar _ tv -> return (mkTyVarTy tv, tyVarKind tv)++           -- See Note [Recursion through the kinds]+           (tcTyThingTyCon_maybe -> Just tc) -- TyCon or TcTyCon+             -> return (mkTyConTy tc, tyConKind tc)++           AGlobal (AConLike (RealDataCon dc))+             -> do { data_kinds <- xoptM LangExt.DataKinds+                   ; unless (data_kinds || specialPromotedDc dc) $+                       promotionErr name NoDataKindsDC+                   ; when (isFamInstTyCon (dataConTyCon dc)) $+                       -- see #15245+                       promotionErr name FamDataConPE+                   ; let (_, _, _, theta, _, _) = dataConFullSig dc+                   ; traceTc "tcTyVar" (ppr dc <+> ppr theta $$ ppr (dc_theta_illegal_constraint theta))+                   ; case dc_theta_illegal_constraint theta of+                       Just pred -> promotionErr name $+                                    ConstrainedDataConPE pred+                       Nothing   -> pure ()+                   ; let tc = promoteDataCon dc+                   ; return (mkTyConApp tc [], tyConKind tc) }++           APromotionErr err -> promotionErr name err++           _  -> wrongThingErr "type" thing name }+  where+    -- We cannot promote a data constructor with a context that contains+    -- constraints other than equalities, so error if we find one.+    -- See Note [Constraints in kinds] in GHC.Core.TyCo.Rep+    dc_theta_illegal_constraint :: ThetaType -> Maybe PredType+    dc_theta_illegal_constraint = find (not . isEqPred)++{-+Note [Recursion through the kinds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider these examples++Ticket #11554:+  data P (x :: k) = Q+  data A :: Type where+    MkA :: forall (a :: A). P a -> A++Ticket #12174+  data V a+  data T = forall (a :: T). MkT (V a)++The type is recursive (which is fine) but it is recursive /through the+kinds/.  In earlier versions of GHC this caused a loop in the compiler+(to do with knot-tying) but there is nothing fundamentally wrong with+the code (kinds are types, and the recursive declarations are OK). But+it's hard to distinguish "recursion through the kinds" from "recursion+through the types". Consider this (also #11554):++  data PB k (x :: k) = Q+  data B :: Type where+    MkB :: P B a -> B++Here the occurrence of B is not obviously in a kind position.++So now GHC allows all these programs.  #12081 and #15942 are other+examples.++Note [Body kind of a HsForAllTy]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The body of a forall is usually a type, but in principle+there's no reason to prohibit *unlifted* types.+In fact, GHC can itself construct a function with an+unboxed tuple inside a for-all (via CPR analysis; see+typecheck/should_compile/tc170).++Moreover in instance heads we get forall-types with+kind Constraint.++It's tempting to check that the body kind is either * or #. But this is+wrong. For example:++  class C a b+  newtype N = Mk Foo deriving (C a)++We're doing newtype-deriving for C. But notice how `a` isn't in scope in+the predicate `C a`. So we quantify, yielding `forall a. C a` even though+`C a` has kind `* -> Constraint`. The `forall a. C a` is a bit cheeky, but+convenient. Bottom line: don't check for * or # here.++Note [Body kind of a HsQualTy]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If ctxt is non-empty, the HsQualTy really is a /function/, so the+kind of the result really is '*', and in that case the kind of the+body-type can be lifted or unlifted.++However, consider+    instance Eq a => Eq [a] where ...+or+    f :: (Eq a => Eq [a]) => blah+Here both body-kind of the HsQualTy is Constraint rather than *.+Rather crudely we tell the difference by looking at exp_kind. It's+very convenient to typecheck instance types like any other HsSigType.++Admittedly the '(Eq a => Eq [a]) => blah' case is erroneous, but it's+better to reject in checkValidType.  If we say that the body kind+should be '*' we risk getting TWO error messages, one saying that Eq+[a] doesn't have kind '*', and one saying that we need a Constraint to+the left of the outer (=>).++How do we figure out the right body kind?  Well, it's a bit of a+kludge: I just look at the expected kind.  If it's Constraint, we+must be in this instance situation context. It's a kludge because it+wouldn't work if any unification was involved to compute that result+kind -- but it isn't.  (The true way might be to use the 'mode'+parameter, but that seemed like a sledgehammer to crack a nut.)++Note [Inferring tuple kinds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Give a tuple type (a,b,c), which the parser labels as HsBoxedOrConstraintTuple,+we try to figure out whether it's a tuple of kind * or Constraint.+  Step 1: look at the expected kind+  Step 2: infer argument kinds++If after Step 2 it's not clear from the arguments that it's+Constraint, then it must be *.  Once having decided that we re-check+the arguments to give good error messages in+  e.g.  (Maybe, Maybe)++Note that we will still fail to infer the correct kind in this case:++  type T a = ((a,a), D a)+  type family D :: Constraint -> Constraint++While kind checking T, we do not yet know the kind of D, so we will default the+kind of T to * -> *. It works if we annotate `a` with kind `Constraint`.++Note [Desugaring types]+~~~~~~~~~~~~~~~~~~~~~~~+The type desugarer is phase 2 of dealing with HsTypes.  Specifically:++  * It transforms from HsType to Type++  * It zonks any kinds.  The returned type should have no mutable kind+    or type variables (hence returning Type not TcType):+      - any unconstrained kind variables are defaulted to (Any *) just+        as in GHC.Tc.Utils.Zonk.+      - there are no mutable type variables because we are+        kind-checking a type+    Reason: the returned type may be put in a TyCon or DataCon where+    it will never subsequently be zonked.++You might worry about nested scopes:+        ..a:kappa in scope..+            let f :: forall b. T '[a,b] -> Int+In this case, f's type could have a mutable kind variable kappa in it;+and we might then default it to (Any *) when dealing with f's type+signature.  But we don't expect this to happen because we can't get a+lexically scoped type variable with a mutable kind variable in it.  A+delicate point, this.  If it becomes an issue we might need to+distinguish top-level from nested uses.++Moreover+  * it cannot fail,+  * it does no unifications+  * it does no validity checking, except for structural matters, such as+        (a) spurious ! annotations.+        (b) a class used as a type++Note [Kind of a type splice]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider these terms, each with TH type splice inside:+     [| e1 :: Maybe $(..blah..) |]+     [| e2 :: $(..blah..) |]+When kind-checking the type signature, we'll kind-check the splice+$(..blah..); we want to give it a kind that can fit in any context,+as if $(..blah..) :: forall k. k.++In the e1 example, the context of the splice fixes kappa to *.  But+in the e2 example, we'll desugar the type, zonking the kind unification+variables as we go.  When we encounter the unconstrained kappa, we+want to default it to '*', not to (Any *).++-}++addTypeCtxt :: LHsType GhcRn -> TcM a -> TcM a+        -- Wrap a context around only if we want to show that contexts.+        -- Omit invisible ones and ones user's won't grok+addTypeCtxt (L _ (HsWildCardTy _)) thing = thing   -- "In the type '_'" just isn't helpful.+addTypeCtxt (L _ ty) thing+  = addErrCtxt doc thing+  where+    doc = text "In the type" <+> quotes (ppr ty)+++{- *********************************************************************+*                                                                      *+                Type-variable binders+*                                                                      *+********************************************************************* -}++bindNamedWildCardBinders :: [Name]+                         -> ([(Name, TcTyVar)] -> TcM a)+                         -> TcM a+-- Bring into scope the /named/ wildcard binders.  Remember that+-- plain wildcards _ are anonymous and dealt with by HsWildCardTy+-- Soe Note [The wildcard story for types] in GHC.Hs.Type+bindNamedWildCardBinders wc_names thing_inside+  = do { wcs <- mapM newNamedWildTyVar wc_names+       ; let wc_prs = wc_names `zip` wcs+       ; tcExtendNameTyVarEnv wc_prs $+         thing_inside wc_prs }++newNamedWildTyVar :: Name -> TcM TcTyVar+-- ^ New unification variable '_' for a wildcard+newNamedWildTyVar _name   -- Currently ignoring the "_x" wildcard name used in the type+  = do { kind <- newMetaKindVar+       ; details <- newMetaDetails TauTv+       ; wc_name <- newMetaTyVarName (fsLit "w")   -- See Note [Wildcard names]+       ; let tyvar = mkTcTyVar wc_name kind details+       ; traceTc "newWildTyVar" (ppr tyvar)+       ; return tyvar }++---------------------------+tcAnonWildCardOcc :: IsExtraConstraint+                  -> TcTyMode -> HsType GhcRn -> Kind -> TcM TcType+tcAnonWildCardOcc is_extra (TcTyMode { mode_holes = Just (hole_lvl, hole_mode) })+                  ty exp_kind+    -- hole_lvl: see Note [Checking partial type signatures]+    --           esp the bullet on nested forall types+  = do { kv_details <- newTauTvDetailsAtLevel hole_lvl+       ; kv_name    <- newMetaTyVarName (fsLit "k")+       ; wc_details <- newTauTvDetailsAtLevel hole_lvl+       ; wc_name    <- newMetaTyVarName (fsLit wc_nm)+       ; let kv      = mkTcTyVar kv_name liftedTypeKind kv_details+             wc_kind = mkTyVarTy kv+             wc_tv   = mkTcTyVar wc_name wc_kind wc_details++       ; traceTc "tcAnonWildCardOcc" (ppr hole_lvl <+> ppr emit_holes)+       ; when emit_holes $+         emitAnonTypeHole is_extra wc_tv+         -- Why the 'when' guard?+         -- See Note [Wildcards in visible kind application]++       -- You might think that this would always just unify+       -- wc_kind with exp_kind, so we could avoid even creating kv+       -- But the level numbers might not allow that unification,+       -- so we have to do it properly (T14140a)+       ; checkExpectedKind ty (mkTyVarTy wc_tv) wc_kind exp_kind }+  where+     -- See Note [Wildcard names]+     wc_nm = case hole_mode of+               HM_Sig      -> "w"+               HM_FamPat   -> "_"+               HM_VTA      -> "w"+               HM_TyAppPat -> "_"++     emit_holes = case hole_mode of+                     HM_Sig     -> True+                     HM_FamPat  -> False+                     HM_VTA     -> False+                     HM_TyAppPat -> False++tcAnonWildCardOcc is_extra _ _ _+-- mode_holes is Nothing. This means we have an anonymous wildcard+-- in an unexpected place. The renamer rejects these wildcards in 'checkAnonWildcard',+-- but it is possible for a wildcard to be introduced by a Template Haskell splice,+-- as per #15433. To account for this, we throw a generic catch-all error message.+  = failWith $ TcRnIllegalWildcardInType Nothing reason Nothing+    where+      reason =+        case is_extra of+          YesExtraConstraint ->+            ExtraConstraintWildcardNotAllowed+              SoleExtraConstraintWildcardNotAllowed+          NoExtraConstraint  ->+            WildcardsNotAllowedAtAll++{- Note [Wildcard names]+~~~~~~~~~~~~~~~~~~~~~~~~+So we hackily use the mode_holes flag to control the name used+for wildcards:++* For proper holes (whether in a visible type application (VTA) or no),+  we rename the '_' to 'w'. This is so that we see variables like 'w0'+  or 'w1' in error messages, a vast improvement upon '_0' and '_1'. For+  example, we prefer+       Found type wildcard ‘_’ standing for ‘w0’+  over+       Found type wildcard ‘_’ standing for ‘_1’++  Even in the VTA case, where we do not emit an error to be printed, we+  want to do the renaming, as the variables may appear in other,+  non-wildcard error messages.++* However, holes in the left-hand sides of type families ("type+  patterns") stand for type variables which we do not care to name --+  much like the use of an underscore in an ordinary term-level+  pattern. When we spot these, we neither wish to generate an error+  message nor to rename the variable.  We don't rename the variable so+  that we can pretty-print a type family LHS as, e.g.,+    F _ Int _ = ...+  and not+     F w1 Int w2 = ...++  See also Note [Wildcards in family instances] in+  GHC.Rename.Module. The choice of HM_FamPat is made in+  tcFamTyPats. There is also some unsavory magic, relying on that+  underscore, in GHC.Core.Coercion.tidyCoAxBndrsForUser.++Note [Wildcards in visible kind application]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There are cases where users might want to pass in a wildcard as a visible kind+argument, for instance:++data T :: forall k1 k2. k1 → k2 → Type where+  MkT :: T a b+x :: T @_ @Nat False n+x = MkT++So we should allow '@_' without emitting any hole constraints, and+regardless of whether PartialTypeSignatures is enabled or not. But how+would the typechecker know which '_' is being used in VKA and which is+not when it calls emitNamedTypeHole in+tcHsPartialSigType on all HsWildCardBndrs?  The solution is to neither+rename nor include unnamed wildcards in HsWildCardBndrs, but instead+give every anonymous wildcard a fresh wild tyvar in tcAnonWildCardOcc.++And whenever we see a '@', we set mode_holes to HM_VKA, so that+we do not call emitAnonTypeHole in tcAnonWildCardOcc.+See related Note [Wildcards in visible type application] here and+Note [The wildcard story for types] in GHC.Hs.Type+-}++{- *********************************************************************+*                                                                      *+             Kind inference for type declarations+*                                                                      *+********************************************************************* -}++-- See Note [kcCheckDeclHeader vs kcInferDeclHeader]+data InitialKindStrategy+  = InitialKindCheck SAKS_or_CUSK+  | InitialKindInfer++-- Does the declaration have a standalone kind signature (SAKS) or a complete+-- user-specified kind (CUSK)?+data SAKS_or_CUSK+  = SAKS Kind  -- Standalone kind signature, fully zonked! (zonkTcTypeToType)+  | CUSK       -- Complete user-specified kind (CUSK)++instance Outputable SAKS_or_CUSK where+  ppr (SAKS k) = text "SAKS" <+> ppr k+  ppr CUSK = text "CUSK"++-- See Note [kcCheckDeclHeader vs kcInferDeclHeader]+kcDeclHeader+  :: InitialKindStrategy+  -> Name              -- ^ of the thing being checked+  -> TyConFlavour      -- ^ What sort of 'TyCon' is being checked+  -> LHsQTyVars GhcRn  -- ^ Binders in the header+  -> TcM ContextKind   -- ^ The result kind+  -> TcM TcTyCon       -- ^ A suitably-kinded TcTyCon+kcDeclHeader (InitialKindCheck msig) = kcCheckDeclHeader msig+kcDeclHeader InitialKindInfer = kcInferDeclHeader++{- Note [kcCheckDeclHeader vs kcInferDeclHeader]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+kcCheckDeclHeader and kcInferDeclHeader are responsible for getting the initial kind+of a type constructor.++* kcCheckDeclHeader: the TyCon has a standalone kind signature or a CUSK. In that+  case, find the full, final, poly-kinded kind of the TyCon.  It's very like a+  term-level binding where we have a complete type signature for the function.++* kcInferDeclHeader: the TyCon has neither a standalone kind signature nor a+  CUSK. Find a monomorphic kind, with unification variables in it; they will be+  generalised later.  It's very like a term-level binding where we do not have a+  type signature (or, more accurately, where we have a partial type signature),+  so we infer the type and generalise.+-}++------------------------------+kcCheckDeclHeader+  :: SAKS_or_CUSK+  -> Name              -- ^ of the thing being checked+  -> TyConFlavour      -- ^ What sort of 'TyCon' is being checked+  -> LHsQTyVars GhcRn  -- ^ Binders in the header+  -> TcM ContextKind   -- ^ The result kind. AnyKind == no result signature+  -> TcM PolyTcTyCon   -- ^ A suitably-kinded generalized TcTyCon+kcCheckDeclHeader (SAKS sig) = kcCheckDeclHeader_sig sig+kcCheckDeclHeader CUSK       = kcCheckDeclHeader_cusk++kcCheckDeclHeader_cusk+  :: Name              -- ^ of the thing being checked+  -> TyConFlavour      -- ^ What sort of 'TyCon' is being checked+  -> LHsQTyVars GhcRn  -- ^ Binders in the header+  -> TcM ContextKind   -- ^ The result kind+  -> TcM PolyTcTyCon   -- ^ A suitably-kinded generalized TcTyCon+kcCheckDeclHeader_cusk name flav+              (HsQTvs { hsq_ext = kv_ns+                      , hsq_explicit = hs_tvs }) kc_res_ki+  -- CUSK case+  -- See Note [Required, Specified, and Inferred for types] in GHC.Tc.TyCl+  = addTyConFlavCtxt name flav $+    do { skol_info <- mkSkolemInfo skol_info_anon+       ; (tclvl, wanted, (scoped_kvs, (tc_tvs, res_kind)))+           <- pushLevelAndSolveEqualitiesX "kcCheckDeclHeader_cusk" $+              bindImplicitTKBndrs_Q_Skol skol_info kv_ns                      $+              bindExplicitTKBndrs_Q_Skol skol_info ctxt_kind hs_tvs           $+              newExpectedKind =<< kc_res_ki++           -- Now, because we're in a CUSK,+           -- we quantify over the mentioned kind vars+       ; let spec_req_tkvs = scoped_kvs ++ tc_tvs+             all_kinds     = res_kind : map tyVarKind spec_req_tkvs++       ; candidates <- candidateQTyVarsOfKinds all_kinds+             -- 'candidates' are all the variables that we are going to+             -- skolemise and then quantify over.  We do not include spec_req_tvs+             -- because they are /already/ skolems++       ; inferred <- quantifyTyVars skol_info DefaultNonStandardTyVars $+                     candidates `delCandidates` spec_req_tkvs+                     -- NB: 'inferred' comes back sorted in dependency order++       ; scoped_kvs <- mapM zonkTyCoVarKind scoped_kvs  -- scoped_kvs and tc_tvs are skolems,+       ; tc_tvs     <- mapM zonkTyCoVarKind tc_tvs      -- so zonkTyCoVarKind suffices+       ; res_kind   <- zonkTcType           res_kind++       ; let mentioned_kv_set = candidateKindVars candidates+             specified        = scopedSort scoped_kvs+                                -- NB: maintain the L-R order of scoped_kvs++             all_tcbs =  mkNamedTyConBinders Inferred  inferred+                      ++ mkNamedTyConBinders Specified specified+                      ++ map (mkRequiredTyConBinder mentioned_kv_set) tc_tvs++       -- Eta expand if necessary; we are building a PolyTyCon+       ; (eta_tcbs, res_kind) <- etaExpandAlgTyCon flav skol_info all_tcbs res_kind++       ; let all_tv_prs = mkTyVarNamePairs (scoped_kvs ++ tc_tvs)+             final_tcbs = all_tcbs `chkAppend` eta_tcbs+             tycon = mkTcTyCon name final_tcbs res_kind all_tv_prs+                               True -- it is generalised+                               flav++       ; reportUnsolvedEqualities skol_info (binderVars final_tcbs)+                                  tclvl wanted++         -- If the ordering from+         -- Note [Required, Specified, and Inferred for types] in GHC.Tc.TyCl+         -- doesn't work, we catch it here, before an error cascade+       ; checkTyConTelescope tycon++       ; traceTc "kcCheckDeclHeader_cusk " $+         vcat [ text "name" <+> ppr name+              , text "candidates" <+> ppr candidates+              , text "mentioned_kv_set" <+> ppr mentioned_kv_set+              , text "kv_ns" <+> ppr kv_ns+              , text "hs_tvs" <+> ppr hs_tvs+              , text "scoped_kvs" <+> ppr scoped_kvs+              , text "spec_req_tvs" <+> pprTyVars spec_req_tkvs+              , text "all_kinds" <+> ppr all_kinds+              , text "tc_tvs" <+> pprTyVars tc_tvs+              , text "res_kind" <+> ppr res_kind+              , text "inferred" <+> ppr inferred+              , text "specified" <+> ppr specified+              , text "final_tcbs" <+> ppr final_tcbs+              , text "mkTyConKind final_tc_bndrs res_kind"+                <+> ppr (mkTyConKind final_tcbs res_kind)+              , text "all_tv_prs" <+> ppr all_tv_prs ]++       ; return tycon }+  where+    skol_info_anon = TyConSkol flav name+    ctxt_kind | tcFlavourIsOpen flav = TheKind liftedTypeKind+              | otherwise            = AnyKind++-- | Kind-check a 'LHsQTyVars'. Used in 'inferInitialKind' (for tycon kinds and+-- other kinds).+--+-- This function does not do telescope checking.+kcInferDeclHeader+  :: Name              -- ^ of the thing being checked+  -> TyConFlavour      -- ^ What sort of 'TyCon' is being checked+  -> LHsQTyVars GhcRn+  -> TcM ContextKind   -- ^ The result kind+  -> TcM MonoTcTyCon   -- ^ A suitably-kinded non-generalized TcTyCon+kcInferDeclHeader name flav+              (HsQTvs { hsq_ext = kv_ns+                      , hsq_explicit = hs_tvs }) kc_res_ki+  -- No standalane kind signature and no CUSK.+  -- See Note [Required, Specified, and Inferred for types] in GHC.Tc.TyCl+  = addTyConFlavCtxt name flav $+    do { (scoped_kvs, (tc_tvs, res_kind))+           -- Why bindImplicitTKBndrs_Q_Tv which uses newTyVarTyVar?+           -- See Note [Inferring kinds for type declarations] in GHC.Tc.TyCl+           <- bindImplicitTKBndrs_Q_Tv kv_ns            $+              bindExplicitTKBndrs_Q_Tv ctxt_kind hs_tvs $+              newExpectedKind =<< kc_res_ki+              -- Why "_Tv" not "_Skol"? See third wrinkle in+              -- Note [Inferring kinds for type declarations] in GHC.Tc.TyCl,++       ; let   -- NB: Don't add scoped_kvs to tyConTyVars, because they+               -- might unify with kind vars in other types in a mutually+               -- recursive group.+               -- See Note [Inferring kinds for type declarations] in GHC.Tc.TyCl++             tc_binders = mkAnonTyConBinders VisArg tc_tvs+               -- Also, note that tc_binders has the tyvars from only the+               -- user-written tyvarbinders. See S1 in Note [How TcTyCons work]+               -- in GHC.Tc.TyCl+               --+               -- mkAnonTyConBinder: see Note [No polymorphic recursion]++             all_tv_prs = mkTyVarNamePairs (scoped_kvs ++ tc_tvs)+               -- NB: bindExplicitTKBndrs_Q_Tv does not clone;+               --     ditto Implicit+               -- See Note [Cloning for type variable binders]++             tycon = mkTcTyCon name tc_binders res_kind all_tv_prs+                               False -- not yet generalised+                               flav++       ; traceTc "kcInferDeclHeader: not-cusk" $+         vcat [ ppr name, ppr kv_ns, ppr hs_tvs+              , ppr scoped_kvs+              , ppr tc_tvs, ppr (mkTyConKind tc_binders res_kind) ]+       ; return tycon }+  where+    ctxt_kind | tcFlavourIsOpen flav = TheKind liftedTypeKind+              | otherwise            = AnyKind++-- | Kind-check a declaration header against a standalone kind signature.+-- See Note [kcCheckDeclHeader_sig]+kcCheckDeclHeader_sig+  :: Kind              -- ^ Standalone kind signature, fully zonked! (zonkTcTypeToType)+  -> Name              -- ^ of the thing being checked+  -> TyConFlavour      -- ^ What sort of 'TyCon' is being checked+  -> LHsQTyVars GhcRn  -- ^ Binders in the header+  -> TcM ContextKind   -- ^ The result kind. AnyKind == no result signature+  -> TcM PolyTcTyCon   -- ^ A suitably-kinded, fully generalised TcTyCon+-- Postcondition to (kcCheckDeclHeader_sig sig_kind n f hs_tvs kc_res_ki):+--   kind(returned PolyTcTyCon) = sig_kind+--+kcCheckDeclHeader_sig sig_kind name flav+          (HsQTvs { hsq_ext      = implicit_nms+                  , hsq_explicit = hs_tv_bndrs }) kc_res_ki+  = addTyConFlavCtxt name flav $+    do { skol_info <- mkSkolemInfo (TyConSkol flav name)+       ; (sig_tcbs :: [TcTyConBinder], sig_res_kind :: Kind)+             <- splitTyConKind skol_info emptyInScopeSet+                               (map getOccName hs_tv_bndrs) sig_kind++       ; traceTc "kcCheckDeclHeader_sig {" $+           vcat [ text "sig_kind:" <+> ppr sig_kind+                , text "sig_tcbs:" <+> ppr sig_tcbs+                , text "sig_res_kind:" <+> ppr sig_res_kind ]++       ; (tclvl, wanted, (implicit_tvs, (skol_tcbs, (extra_tcbs, tycon_res_kind))))+           <- pushLevelAndSolveEqualitiesX "kcCheckDeclHeader_sig" $  -- #16687+              bindImplicitTKBndrs_Q_Tv implicit_nms                $  -- Q means don't clone+              matchUpSigWithDecl sig_tcbs sig_res_kind hs_tv_bndrs $ \ excess_sig_tcbs sig_res_kind ->+              do { -- Kind-check the result kind annotation, if present:+                   --    data T a b :: res_ki where ...+                   --               ^^^^^^^^^+                   -- We do it here because at this point the environment has been+                   -- extended with both 'implicit_tcv_prs' and 'explicit_tv_prs'.+                 ; ctx_k <- kc_res_ki++                 -- Work out extra_arity, the number of extra invisible binders from+                 -- the kind signature that should be part of the TyCon's arity.+                 -- See Note [Arity inference in kcCheckDeclHeader_sig]+                 ; let n_invis_tcbs = countWhile isInvisibleTyConBinder excess_sig_tcbs+                       invis_arity = case ctx_k of+                          AnyKind    -> n_invis_tcbs -- No kind signature, so make all the invisible binders+                                                     -- the signature into part of the arity of the TyCon+                          OpenKind   -> n_invis_tcbs -- Result kind is (TYPE rr), so again make all the+                                                     -- invisible binders part of the arity of the TyCon+                          TheKind ki -> 0 `max` (n_invis_tcbs - invisibleTyBndrCount ki)++                 ; let (invis_tcbs, resid_tcbs) = splitAt invis_arity excess_sig_tcbs+                 ; let sig_res_kind' = mkTyConKind resid_tcbs sig_res_kind++                 ; traceTc "kcCheckDeclHeader_sig 2" $ vcat [ ppr excess_sig_tcbs+                                                            , ppr invis_arity, ppr invis_tcbs+                                                            , ppr n_invis_tcbs ]++                 -- Unify res_ki (from the type declaration) with the residual kind from+                 -- the kind signature. Don't forget to apply the skolemising 'subst' first.+                 ; case ctx_k of+                      AnyKind -> return ()   -- No signature+                      _ -> do { res_ki <- newExpectedKind ctx_k+                              ; discardResult (unifyKind Nothing sig_res_kind' res_ki) }++                 -- Add more binders for data/newtype, so the result kind has no arrows+                 -- See Note [Datatype return kinds]+                 ; if null resid_tcbs || not (needsEtaExpansion flav)+                   then return (invis_tcbs,      sig_res_kind')+                   else return (excess_sig_tcbs, sig_res_kind)+          }+++        -- Check that there are no unsolved equalities+        ; let all_tcbs = skol_tcbs ++ extra_tcbs+        ; reportUnsolvedEqualities skol_info (binderVars all_tcbs) tclvl wanted++        -- Check that distinct binders map to distinct tyvars (see #20916). For example+        --    type T :: k -> k -> Type+        --    data T (a::p) (b::q) = ...+        -- Here p and q both map to the same kind variable k.  We don't allow this+        -- so we must check that they are distinct.  A similar thing happens+        -- in GHC.Tc.TyCl.swizzleTcTyConBinders during inference.+        ; implicit_tvs <- zonkTcTyVarsToTcTyVars implicit_tvs+        ; let implicit_prs = implicit_nms `zip` implicit_tvs+        ; checkForDuplicateScopedTyVars implicit_prs++        -- Swizzle the Names so that the TyCon uses the user-declared implicit names+        -- E.g  type T :: k -> Type+        --      data T (a :: j) = ....+        -- We want the TyConBinders of T to be [j, a::j], not [k, a::k]+        -- Why? So that the TyConBinders of the TyCon will lexically scope over the+        -- associated types and methods of a class.+        ; let swizzle_env = mkVarEnv (map swap implicit_prs)+              (subst, swizzled_tcbs) = mapAccumL (swizzleTcb swizzle_env) emptyTCvSubst all_tcbs+              swizzled_kind          = substTy subst tycon_res_kind+              all_tv_prs             = mkTyVarNamePairs (binderVars swizzled_tcbs)++        ; traceTc "kcCheckDeclHeader swizzle" $ vcat+          [ text "implicit_prs = "  <+> ppr implicit_prs+          , text "implicit_nms = "  <+> ppr implicit_nms+          , text "hs_tv_bndrs = "  <+> ppr hs_tv_bndrs+          , text "all_tcbs = "      <+> pprTyVars (binderVars all_tcbs)+          , text "swizzled_tcbs = " <+> pprTyVars (binderVars swizzled_tcbs)+          , text "tycon_res_kind =" <+> ppr tycon_res_kind+          , text "swizzled_kind ="  <+> ppr swizzled_kind ]++        -- Build the final, generalized PolyTcTyCon+        -- NB: all_tcbs must bind the tyvars in the range of all_tv_prs+        --     because the tv_prs is used when (say) typechecking the RHS of+        --     a type synonym.+        ; let tc = mkTcTyCon name swizzled_tcbs swizzled_kind all_tv_prs True flav++        ; traceTc "kcCheckDeclHeader_sig }" $ vcat+          [ text "tyConName = " <+> ppr (tyConName tc)+          , text "sig_kind =" <+> debugPprType sig_kind+          , text "tyConKind =" <+> debugPprType (tyConKind tc)+          , text "tyConBinders = " <+> ppr (tyConBinders tc)+          , text "tyConResKind" <+> debugPprType (tyConResKind tc)+          ]+        ; return tc }++matchUpSigWithDecl+  :: [TcTyConBinder]             -- TcTyConBinders (with skolem TcTyVars) from the separate kind signature+  -> TcKind                      -- The tail end of the kind signature+  -> [LHsTyVarBndr () GhcRn]     -- User-written binders in decl+  -> ([TcTyConBinder] -> TcKind -> TcM a)  -- All user-written binders are in scope+                                           --   Argument is excess TyConBinders and tail kind+  -> TcM ( [TcTyConBinder]       -- Skolemised binders, with TcTyVars+         , a )+-- See Note [Matching a kind sigature with a declaration]+-- Invariant: Length of returned TyConBinders + length of excess TyConBinders+--            = length of incoming TyConBinders+matchUpSigWithDecl sig_tcbs sig_res_kind hs_bndrs thing_inside+  = go emptyTCvSubst sig_tcbs hs_bndrs+  where+    go subst tcbs []+      = do { let (subst', tcbs') = substTyConBindersX subst tcbs+           ; res <- thing_inside tcbs' (substTy subst' sig_res_kind)+           ; return ([], res) }++    go _ [] hs_bndrs+      = failWithTc (tooManyBindersErr sig_res_kind hs_bndrs)++    go subst (tcb : tcbs') hs_bndrs+      | Bndr tv vis <- tcb+      , isVisibleTcbVis vis+      , (L _ hs_bndr : hs_bndrs') <- hs_bndrs  -- hs_bndrs is non-empty+      = -- Visible TyConBinder, so match up with the hs_bndrs+        do { let tv' = updateTyVarKind (substTy subst) $+                       setTyVarName tv (getName hs_bndr)+                   -- Give the skolem the Name of the HsTyVarBndr, so that if it+                   -- appears in an error message it has a name and binding site+                   -- that come from the type declaration, not the kind signature+                 subst' = extendTCvSubstWithClone subst tv tv'+           ; tc_hs_bndr hs_bndr (tyVarKind tv')+           ; (tcbs', res) <- tcExtendTyVarEnv [tv'] $+                             go subst' tcbs' hs_bndrs'+           ; return (Bndr tv' vis : tcbs', res) }++      | otherwise+      = -- Invisible TyConBinder, so do not consume one of the hs_bndrs+        do { let (subst', tcb') = substTyConBinderX subst tcb+           ; (tcbs', res) <- go subst' tcbs' hs_bndrs+                   -- NB: pass on hs_bndrs unchanged; we do not consume a+                   --     HsTyVarBndr for an invisible TyConBinder+           ; return (tcb' : tcbs', res) }++    tc_hs_bndr :: HsTyVarBndr () GhcRn -> TcKind -> TcM ()+    tc_hs_bndr (UserTyVar _ _ _) _+      = return ()+    tc_hs_bndr (KindedTyVar _ _ (L _ hs_nm) lhs_kind) expected_kind+      = do { sig_kind <- tcLHsKindSig (TyVarBndrKindCtxt hs_nm) lhs_kind+           ; discardResult $ -- See Note [discardResult in kcCheckDeclHeader_sig]+             unifyKind (Just (NameThing hs_nm)) sig_kind expected_kind }++substTyConBinderX :: TCvSubst -> TyConBinder -> (TCvSubst, TyConBinder)+substTyConBinderX subst (Bndr tv vis)+  = (subst', Bndr tv' vis)+  where+    (subst', tv') = substTyVarBndr subst tv++substTyConBindersX :: TCvSubst -> [TyConBinder] -> (TCvSubst, [TyConBinder])+substTyConBindersX = mapAccumL substTyConBinderX++swizzleTcb :: VarEnv Name -> TCvSubst -> TyConBinder -> (TCvSubst, TyConBinder)+swizzleTcb swizzle_env subst (Bndr tv vis)+  = (subst', Bndr tv2 vis)+  where+    subst' = extendTCvSubstWithClone subst tv tv2+    tv1 = updateTyVarKind (substTy subst) tv+    tv2 = case lookupVarEnv swizzle_env tv of+             Just user_name -> setTyVarName tv1 user_name+             Nothing        -> tv1+    -- NB: the SrcSpan on an implicitly-bound name deliberately spans+    -- the whole declaration. e.g.+    --    data T (a :: k) (b :: Type -> k) = ....+    -- There is no single binding site for 'k'.+    -- See Note [Source locations for implicitly bound type variables]+    -- in GHC.Tc.Rename.HsType++tooManyBindersErr :: Kind -> [LHsTyVarBndr () GhcRn] -> TcRnMessage+tooManyBindersErr ki bndrs = TcRnUnknownMessage $ mkPlainError noHints $+   hang (text "Not a function kind:")+      4 (ppr ki) $$+   hang (text "but extra binders found:")+      4 (fsep (map ppr bndrs))++{- See Note [kcCheckDeclHeader_sig]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Given a kind signature 'sig_kind' and a declaration header,+kcCheckDeclHeader_sig verifies that the declaration conforms to the+signature. The end result is a PolyTcTyCon 'tc' such that:+  tyConKind tc == sig_kind++Basic plan is this:+  * splitTyConKind: Take the Kind from the separate kind signature, and+    decompose it all the way to a [TyConBinder] and a Kind in the corner.++    NB: these TyConBinders contain TyVars, not TcTyVars.++  * matchUpSigWithDecl: match the [TyConBinder] from the signature with+    the [LHsTyVarBndr () GhcRn] from the declaration.  The latter are the+    explicit, user-written binders.  e.g.+        data T (a :: k) b = ....+    There may be more of the former than the latter, because the former+    include invisible binders.  matchUpSigWithDecl uses isVisibleTcbVis+    to decide which TyConBinders are visible.++  * matchUpSigWithDecl also skolemises the [TyConBinder] to produce+    a [TyConBinder], corresponding 1-1 with the consumed [TyConBinder].+    Each new TyConBinder+      - Uses the Name from the LHsTyVarBndr, if available, both because that's+        what the user expects, and because the binding site accurately comes+        from the data/type declaration.+      - Uses a skolem TcTyVar.  We need these to allow unification.++  * machUpSigWithDecl also unifies the user-supplied kind signature for each+    LHsTyVarBndr with the kind that comes from the TyConBinder (itself coming+    from the separate kind signature).++  * Finally, kcCheckDeclHeader_sig unifies the return kind of the separate+    signature with the kind signature (if any) in the data/type declaration.+    E.g.+           type S :: forall k. k -> k -> Type+           type family S (a :: j) :: j -> Type+    Here we match up the 'k ->' with (a :: j); and then must unify the leftover+    part of the signature (k -> Type) with the kind signature of the decl,+    (j -> Type).  This unification, done in kcCheckDeclHeader, needs TcTyVars.++  * The tricky extra_arity part is described in+    Note [Arity inference in kcCheckDeclHeader_sig]++Note [Arity inference in kcCheckDeclHeader_sig]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider these declarations:+  type family S1 :: forall k2. k1 -> k2 -> Type+  type family S2 (a :: k1) (b :: k2) :: Type++Both S1 and S2 can be given the same standalone kind signature:+  type S1 :: forall k1 k2. k1 -> k2 -> Type+  type S2 :: forall k1 k2. k1 -> k2 -> Type++And, indeed, tyConKind S1 == tyConKind S2. However,+tyConBinders and tyConResKind for S1 and S2 are different:++  tyConBinders S1  ==  [spec k1]+  tyConResKind S1  ==  forall k2. k1 -> k2 -> Type+  tyConKind    S1  ==  forall k1 k2. k1 -> k2 -> Type++  tyConBinders S2  ==  [spec k1, spec k2, anon-vis (a :: k1), anon-vis (b :: k2)]+  tyConResKind S2  ==  Type+  tyConKind    S1  ==  forall k1 k2. k1 -> k2 -> Type++This difference determines the /arity/:+  tyConArity tc == length (tyConBinders tc)+That is, the arity of S1 is 1, while the arity of S2 is 4.++'kcCheckDeclHeader_sig' needs to infer the desired arity, to split the+standalone kind signature into binders and the result kind. It does so+in two rounds:++1. matchUpSigWithDecl matches up+   - the [TyConBinder] from (applying splitTyConKind to) the kind signature+   - with the [LHsTyVarBndr] from the type declaration.+   That may leave some excess TyConBinder: in the case of S2 there are+   no excess TyConBinders, but in the case of S1 there are two (since+   there are no LHsTYVarBndrs.++2. Split off further TyConBinders (in the case of S1, one more) to+   make it possible to unify the residual return kind with the+   signature in the type declaration.  More precisely, split off such+   enough invisible that the remainder of the standalone kind+   signature and the user-written result kind signature have the same+   number of invisible quantifiers.++As another example consider the following declarations:++    type F :: Type -> forall j. j -> forall k1 k2. (k1, k2) -> Type+    type family F a b++    type G :: Type -> forall j. j -> forall k1 k2. (k1, k2) -> Type+    type family G a b :: forall r2. (r1, r2) -> Type++For both F and G, the signature (after splitTyConKind) has+  sig_tcbs :: [TyConBinder]+    = [ anon-vis (@a_aBq), spec (@j_auA), anon-vis (@(b_aBr :: j_auA))+      , spec (@k1_auB), spec (@k2_auC)+      , anon-vis (@(c_aBs :: (k1_auB, k2_auC)))]++matchUpSigWithDecl will consume the first three of these, passing on+  excess_sig_tcbs+    = [ spec (@k1_auB), spec (@k2_auC)+      , anon-vis (@(c_aBs :: (k1_auB, k2_auC)))]++For F, there is no result kind signature in the declaration for F, so+we absorb all invisible binders into F's arity. The resulting arity of+F is 3+2=5.++Now, in the case of G, we have a result kind sig 'forall r2. (r2,r2)->Type'.+This has one invisible binder, so we split of enough extra binders from+our excess_sig_tcbs to leave just one to match 'r2'.++    res_ki  =  forall    r2. (r1, r2) -> Type+    kisig   =  forall k1 k2. (k1, k2) -> Type+                     ^^^+                     split off this one.++The resulting arity of G is 3+1=4.++Note [discardResult in kcCheckDeclHeader_sig]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We use 'unifyKind' to check inline kind annotations in declaration headers+against the signature.++  type T :: [i] -> Maybe j -> Type+  data T (a :: [k1]) (b :: Maybe k2) :: Type where ...++Here, we will unify:++       [k1] ~ [i]+  Maybe k2  ~ Maybe j+      Type  ~ Type++The end result is that we fill in unification variables k1, k2:++    k1  :=  i+    k2  :=  j++We also validate that the user isn't confused:++  type T :: Type -> Type+  data T (a :: Bool) = ...++This will report that (Type ~ Bool) failed to unify.++Now, consider the following example:++  type family Id a where Id x = x+  type T :: Bool -> Type+  type T (a :: Id Bool) = ...++We will unify (Bool ~ Id Bool), and this will produce a non-reflexive coercion.+However, we are free to discard it, as the kind of 'T' is determined by the+signature, not by the inline kind annotation:++      we have   T ::    Bool -> Type+  rather than   T :: Id Bool -> Type++This (Id Bool) will not show up anywhere after we're done validating it, so we+have no use for the produced coercion.+-}++{- Note [No polymorphic recursion]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Should this kind-check?+  data T ka (a::ka) b  = MkT (T Type           Int   Bool)+                             (T (Type -> Type) Maybe Bool)++Notice that T is used at two different kinds in its RHS.  No!+This should not kind-check.  Polymorphic recursion is known to+be a tough nut.++Previously, we laboriously (with help from the renamer)+tried to give T the polymorphic kind+   T :: forall ka -> ka -> kappa -> Type+where kappa is a unification variable, even in the inferInitialKinds+phase (which is what kcInferDeclHeader is all about).  But+that is dangerously fragile (see the ticket).++Solution: make kcInferDeclHeader give T a straightforward+monomorphic kind, with no quantification whatsoever. That's why+we use mkAnonTyConBinder for all arguments when figuring out+tc_binders.++But notice that (#16322 comment:3)++* The algorithm successfully kind-checks this declaration:+    data T2 ka (a::ka) = MkT2 (T2 Type a)++  Starting with (inferInitialKinds)+    T2 :: (kappa1 :: kappa2 :: *) -> (kappa3 :: kappa4 :: *) -> *+  we get+    kappa4 := kappa1   -- from the (a:ka) kind signature+    kappa1 := Type     -- From application T2 Type++  These constraints are soluble so generaliseTcTyCon gives+    T2 :: forall (k::Type) -> k -> *++  But now the /typechecking/ (aka desugaring, tcTyClDecl) phase+  fails, because the call (T2 Type a) in the RHS is ill-kinded.++  We'd really prefer all errors to show up in the kind checking+  phase.++* This algorithm still accepts (in all phases)+     data T3 ka (a::ka) = forall b. MkT3 (T3 Type b)+  although T3 is really polymorphic-recursive too.+  Perhaps we should somehow reject that.++Note [Kind variable ordering for associated types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+What should be the kind of `T` in the following example? (#15591)++  class C (a :: Type) where+    type T (x :: f a)++As per Note [Ordering of implicit variables] in GHC.Rename.HsType, we want to quantify+the kind variables in left-to-right order of first occurrence in order to+support visible kind application. But we cannot perform this analysis on just+T alone, since its variable `a` actually occurs /before/ `f` if you consider+the fact that `a` was previously bound by the parent class `C`. That is to say,+the kind of `T` should end up being:++  T :: forall a f. f a -> Type++(It wouldn't necessarily be /wrong/ if the kind ended up being, say,+forall f a. f a -> Type, but that would not be as predictable for users of+visible kind application.)++In contrast, if `T` were redefined to be a top-level type family, like `T2`+below:++  type family T2 (x :: f (a :: Type))++Then `a` first appears /after/ `f`, so the kind of `T2` should be:++  T2 :: forall f a. f a -> Type++In order to make this distinction, we need to know (in kcCheckDeclHeader) which+type variables have been bound by the parent class (if there is one). With+the class-bound variables in hand, we can ensure that we always quantify+these first.+-}+++{- *********************************************************************+*                                                                      *+             Expected kinds+*                                                                      *+********************************************************************* -}++-- | Describes the kind expected in a certain context.+data ContextKind = TheKind TcKind   -- ^ a specific kind+                 | AnyKind        -- ^ any kind will do+                 | OpenKind       -- ^ something of the form @TYPE _@++-----------------------+newExpectedKind :: ContextKind -> TcM TcKind+newExpectedKind (TheKind k)   = return k+newExpectedKind AnyKind       = newMetaKindVar+newExpectedKind OpenKind      = newOpenTypeKind++-----------------------+expectedKindInCtxt :: UserTypeCtxt -> ContextKind+-- Depending on the context, we might accept any kind (for instance, in a TH+-- splice), or only certain kinds (like in type signatures).+expectedKindInCtxt (TySynCtxt _)   = AnyKind+expectedKindInCtxt (GhciCtxt {})   = AnyKind+-- The types in a 'default' decl can have varying kinds+-- See Note [Extended defaults]" in GHC.Tc.Utils.Env+expectedKindInCtxt DefaultDeclCtxt     = AnyKind+expectedKindInCtxt DerivClauseCtxt     = AnyKind+expectedKindInCtxt TypeAppCtxt         = AnyKind+expectedKindInCtxt (ForSigCtxt _)      = TheKind liftedTypeKind+expectedKindInCtxt (InstDeclCtxt {})   = TheKind constraintKind+expectedKindInCtxt SpecInstCtxt        = TheKind constraintKind+expectedKindInCtxt _                   = OpenKind+++{- *********************************************************************+*                                                                      *+          Scoped tyvars that map to the same thing+*                                                                      *+********************************************************************* -}++checkForDuplicateScopedTyVars :: [(Name,TcTyVar)] -> TcM ()+-- Check for duplicates+-- E.g. data SameKind (a::k) (b::k)+--      data T (a::k1) (b::k2) c = MkT (SameKind a b) c+-- Here k1 and k2 start as TyVarTvs, and get unified with each other+-- If this happens, things get very confused later, so fail fast+--+-- In the CUSK case k1 and k2 are skolems so they won't unify;+-- but in the inference case (see generaliseTcTyCon),+-- and the type-sig case (see kcCheckDeclHeader_sig), they are+-- TcTyVars, so we must check.+checkForDuplicateScopedTyVars scoped_prs+  = unless (null err_prs) $+    do { mapM_ report_dup err_prs; failM }+  where+    -------------- Error reporting ------------+    err_prs :: [(Name,Name)]+    err_prs = [ (n1,n2)+              | prs :: NonEmpty (Name,TyVar) <- findDupsEq ((==) `on` snd) scoped_prs+              , (n1,_) :| ((n2,_) : _) <- [NE.nubBy ((==) `on` fst) prs] ]+              -- This nubBy avoids bogus error reports when we have+              --    [("f", f), ..., ("f",f)....] in swizzle_prs+              -- which happens with  class C f where { type T f }++    report_dup :: (Name,Name) -> TcM ()+    report_dup (n1,n2)+      = setSrcSpan (getSrcSpan n2) $+        addErrTc $ TcRnUnknownMessage $ mkPlainError noHints $+        hang (text "Different names for the same type variable:") 2 info+      where+        info | nameOccName n1 /= nameOccName n2+             = quotes (ppr n1) <+> text "and" <+> quotes (ppr n2)+             | otherwise -- Same OccNames! See C2 in+                         -- Note [Swizzling the tyvars before generaliseTcTyCon]+             = vcat [ quotes (ppr n1) <+> text "bound at" <+> ppr (getSrcLoc n1)+                    , quotes (ppr n2) <+> text "bound at" <+> ppr (getSrcLoc n2) ]+++{- *********************************************************************+*                                                                      *+             Bringing type variables into scope+*                                                                      *+********************************************************************* -}++--------------------------------------+--    HsForAllTelescope+--------------------------------------++tcTKTelescope :: TcTyMode+              -> HsForAllTelescope GhcRn+              -> TcM a+              -> TcM ([TcTyVarBinder], a)+-- A HsForAllTelescope comes only from a HsForAllTy,+-- an explicit, user-written forall type+tcTKTelescope mode tele thing_inside = case tele of+  HsForAllVis { hsf_vis_bndrs = bndrs }+    -> do { skol_info <- mkSkolemInfo (ForAllSkol (HsTyVarBndrsRn (unLoc <$> bndrs)))+          ; let skol_mode = smVanilla { sm_clone = False, sm_holes = mode_holes mode+                                      , sm_tvtv = SMDSkolemTv skol_info }+          ; (req_tv_bndrs, thing) <- tcExplicitTKBndrsX skol_mode bndrs thing_inside+            -- req_tv_bndrs :: [VarBndr TyVar ()],+            -- but we want [VarBndr TyVar ArgFlag]+          ; return (tyVarReqToBinders req_tv_bndrs, thing) }++  HsForAllInvis { hsf_invis_bndrs = bndrs }+    -> do { skol_info <- mkSkolemInfo (ForAllSkol (HsTyVarBndrsRn (unLoc <$> bndrs)))+          ; let skol_mode = smVanilla { sm_clone = False, sm_holes = mode_holes mode+                                      , sm_tvtv = SMDSkolemTv skol_info }+          ; (inv_tv_bndrs, thing) <- tcExplicitTKBndrsX skol_mode bndrs thing_inside+            -- inv_tv_bndrs :: [VarBndr TyVar Specificity],+            -- but we want [VarBndr TyVar ArgFlag]+          ; return (tyVarSpecToBinders inv_tv_bndrs, thing) }++--------------------------------------+--    HsOuterTyVarBndrs+--------------------------------------++bindOuterTKBndrsX :: OutputableBndrFlag flag 'Renamed+                  => SkolemMode+                  -> HsOuterTyVarBndrs flag GhcRn+                  -> TcM a+                  -> TcM (HsOuterTyVarBndrs flag GhcTc, a)+bindOuterTKBndrsX skol_mode outer_bndrs thing_inside+  = case outer_bndrs of+      HsOuterImplicit{hso_ximplicit = imp_tvs} ->+        do { (imp_tvs', thing) <- bindImplicitTKBndrsX skol_mode imp_tvs thing_inside+           ; return ( HsOuterImplicit{hso_ximplicit = imp_tvs'}+                    , thing) }+      HsOuterExplicit{hso_bndrs = exp_bndrs} ->+        do { (exp_tvs', thing) <- bindExplicitTKBndrsX skol_mode exp_bndrs thing_inside+           ; return ( HsOuterExplicit { hso_xexplicit = exp_tvs'+                                      , hso_bndrs     = exp_bndrs }+                    , thing) }++---------------+outerTyVars :: HsOuterTyVarBndrs flag GhcTc -> [TcTyVar]+-- The returned [TcTyVar] is not necessarily in dependency order+-- at least for the HsOuterImplicit case+outerTyVars (HsOuterImplicit { hso_ximplicit = tvs })  = tvs+outerTyVars (HsOuterExplicit { hso_xexplicit = tvbs }) = binderVars tvbs++---------------+outerTyVarBndrs :: HsOuterTyVarBndrs Specificity GhcTc -> [InvisTVBinder]+outerTyVarBndrs (HsOuterImplicit{hso_ximplicit = imp_tvs}) = [Bndr tv SpecifiedSpec | tv <- imp_tvs]+outerTyVarBndrs (HsOuterExplicit{hso_xexplicit = exp_tvs}) = exp_tvs++---------------+scopedSortOuter :: HsOuterTyVarBndrs flag GhcTc -> TcM (HsOuterTyVarBndrs flag GhcTc)+-- Sort any /implicit/ binders into dependency order+--     (zonking first so we can see the dependencies)+-- /Explicit/ ones are already in the right order+scopedSortOuter (HsOuterImplicit{hso_ximplicit = imp_tvs})+  = do { imp_tvs <- zonkAndScopedSort imp_tvs+       ; return (HsOuterImplicit { hso_ximplicit = imp_tvs }) }+scopedSortOuter bndrs@(HsOuterExplicit{})+  = -- No need to dependency-sort (or zonk) explicit quantifiers+    return bndrs++---------------+bindOuterSigTKBndrs_Tv :: HsOuterSigTyVarBndrs GhcRn+                       -> TcM a -> TcM (HsOuterSigTyVarBndrs GhcTc, a)+bindOuterSigTKBndrs_Tv+  = bindOuterTKBndrsX (smVanilla { sm_clone = True, sm_tvtv = SMDTyVarTv })++bindOuterSigTKBndrs_Tv_M :: TcTyMode+                         -> HsOuterSigTyVarBndrs GhcRn+                         -> TcM a -> TcM (HsOuterSigTyVarBndrs GhcTc, a)+-- Do not push level; do not make implication constraint; use Tvs+-- Two major clients of this "bind-only" path are:+--    Note [Using TyVarTvs for kind-checking GADTs] in GHC.Tc.TyCl+--    Note [Checking partial type signatures]+bindOuterSigTKBndrs_Tv_M mode+  = bindOuterTKBndrsX (smVanilla { sm_clone = True, sm_tvtv = SMDTyVarTv+                                 , sm_holes = mode_holes mode })++bindOuterFamEqnTKBndrs_Q_Tv :: HsOuterFamEqnTyVarBndrs GhcRn+                            -> TcM a+                            -> TcM (HsOuterFamEqnTyVarBndrs GhcTc, a)+bindOuterFamEqnTKBndrs_Q_Tv hs_bndrs thing_inside+  = bindOuterTKBndrsX (smVanilla { sm_clone = False, sm_parent = True+                                 , sm_tvtv = SMDTyVarTv })+                      hs_bndrs thing_inside+    -- sm_clone=False: see Note [Cloning for type variable binders]++bindOuterFamEqnTKBndrs :: SkolemInfo+                       -> HsOuterFamEqnTyVarBndrs GhcRn+                       -> TcM a+                       -> TcM (HsOuterFamEqnTyVarBndrs GhcTc, a)+bindOuterFamEqnTKBndrs skol_info+  = bindOuterTKBndrsX (smVanilla { sm_clone = False, sm_parent = True+                                 , sm_tvtv = SMDSkolemTv skol_info })+    -- sm_clone=False: see Note [Cloning for type variable binders]++---------------+tcOuterTKBndrs :: OutputableBndrFlag flag 'Renamed+               => SkolemInfo+               -> HsOuterTyVarBndrs flag GhcRn+               -> TcM a -> TcM (HsOuterTyVarBndrs flag GhcTc, a)+tcOuterTKBndrs skol_info+  = tcOuterTKBndrsX (smVanilla { sm_clone = False+                               , sm_tvtv = SMDSkolemTv skol_info })+                    skol_info+  -- Do not clone the outer binders+  -- See Note [Cloning for type variable binders] under "must not"++tcOuterTKBndrsX :: OutputableBndrFlag flag 'Renamed+                => SkolemMode -> SkolemInfo+                -> HsOuterTyVarBndrs flag GhcRn+                -> TcM a -> TcM (HsOuterTyVarBndrs flag GhcTc, a)+-- Push level, capture constraints, make implication+tcOuterTKBndrsX skol_mode skol_info outer_bndrs thing_inside+  = case outer_bndrs of+      HsOuterImplicit{hso_ximplicit = imp_tvs} ->+        do { (imp_tvs', thing) <- tcImplicitTKBndrsX skol_mode skol_info imp_tvs thing_inside+           ; return ( HsOuterImplicit{hso_ximplicit = imp_tvs'}+                    , thing) }+      HsOuterExplicit{hso_bndrs = exp_bndrs} ->+        do { (exp_tvs', thing) <- tcExplicitTKBndrsX skol_mode exp_bndrs thing_inside+           ; return ( HsOuterExplicit { hso_xexplicit = exp_tvs'+                                      , hso_bndrs     = exp_bndrs }+                    , thing) }++--------------------------------------+--    Explicit tyvar binders+--------------------------------------++tcExplicitTKBndrs :: OutputableBndrFlag flag 'Renamed+                  => SkolemInfo+                  -> [LHsTyVarBndr flag GhcRn]+                  -> TcM a+                  -> TcM ([VarBndr TyVar flag], a)+tcExplicitTKBndrs skol_info+  = tcExplicitTKBndrsX (smVanilla { sm_clone = True, sm_tvtv = SMDSkolemTv skol_info })++tcExplicitTKBndrsX :: OutputableBndrFlag flag 'Renamed+                   => SkolemMode+                   -> [LHsTyVarBndr flag GhcRn]+                   -> TcM a+                   -> TcM ([VarBndr TyVar flag], a)+-- Push level, capture constraints, and emit an implication constraint.+-- The implication constraint has a ForAllSkol ic_info,+--   so that it is subject to a telescope test.+tcExplicitTKBndrsX skol_mode bndrs thing_inside+  | null bndrs+  = do { res <- thing_inside+       ; return ([], res) }++  | otherwise+  = do { (tclvl, wanted, (skol_tvs, res))+             <- pushLevelAndCaptureConstraints $+                bindExplicitTKBndrsX skol_mode bndrs $+                thing_inside++       -- Set up SkolemInfo for telescope test+       ; let bndr_1 = head bndrs; bndr_n = last bndrs+       ; skol_info <- mkSkolemInfo (ForAllSkol (HsTyVarBndrsRn  (unLoc <$> bndrs)))+         -- Notice that we use ForAllSkol here, ignoring the enclosing+         -- skol_info unlike tcImplicitTKBndrs, because the bad-telescope+         -- test applies only to ForAllSkol++       ; setSrcSpan (combineSrcSpans (getLocA bndr_1) (getLocA bndr_n))+       $ emitResidualTvConstraint skol_info (binderVars skol_tvs) tclvl wanted++       ; return (skol_tvs, res) }++----------------+-- | Skolemise the 'HsTyVarBndr's in an 'HsForAllTelescope' with the supplied+-- 'TcTyMode'.+bindExplicitTKBndrs_Skol+    :: (OutputableBndrFlag flag 'Renamed)+    => SkolemInfo+    -> [LHsTyVarBndr flag GhcRn]+    -> TcM a+    -> TcM ([VarBndr TyVar flag], a)++bindExplicitTKBndrs_Tv+    :: (OutputableBndrFlag flag 'Renamed)+    => [LHsTyVarBndr flag GhcRn]+    -> TcM a+    -> TcM ([VarBndr TyVar flag], a)++bindExplicitTKBndrs_Skol skol_info = bindExplicitTKBndrsX (smVanilla { sm_clone = False, sm_tvtv = SMDSkolemTv skol_info })+bindExplicitTKBndrs_Tv   = bindExplicitTKBndrsX (smVanilla { sm_clone = True, sm_tvtv = SMDTyVarTv })+   -- sm_clone: see Note [Cloning for type variable binders]++bindExplicitTKBndrs_Q_Skol+    :: SkolemInfo+    -> ContextKind+    -> [LHsTyVarBndr () GhcRn]+    -> TcM a+    -> TcM ([TcTyVar], a)++bindExplicitTKBndrs_Q_Tv+    :: ContextKind+    -> [LHsTyVarBndr () GhcRn]+    -> TcM a+    -> TcM ([TcTyVar], a)+-- These do not clone: see Note [Cloning for type variable binders]+bindExplicitTKBndrs_Q_Skol skol_info ctxt_kind hs_bndrs thing_inside+  = liftFstM binderVars $+    bindExplicitTKBndrsX (smVanilla { sm_clone = False, sm_parent = True+                                    , sm_kind = ctxt_kind, sm_tvtv = SMDSkolemTv skol_info })+                         hs_bndrs thing_inside+    -- sm_clone=False: see Note [Cloning for type variable binders]++bindExplicitTKBndrs_Q_Tv  ctxt_kind hs_bndrs thing_inside+  = liftFstM binderVars $+    bindExplicitTKBndrsX (smVanilla { sm_clone = False, sm_parent = True+                                    , sm_tvtv = SMDTyVarTv, sm_kind = ctxt_kind })+                         hs_bndrs thing_inside+    -- sm_clone=False: see Note [Cloning for type variable binders]++bindExplicitTKBndrsX :: (OutputableBndrFlag flag 'Renamed)+    => SkolemMode+    -> [LHsTyVarBndr flag GhcRn]+    -> TcM a+    -> TcM ([VarBndr TyVar flag], a)  -- Returned [TcTyVar] are in 1-1 correspondence+                                      -- with the passed-in [LHsTyVarBndr]+bindExplicitTKBndrsX skol_mode@(SM { sm_parent = check_parent, sm_kind = ctxt_kind+                                   , sm_holes = hole_info })+                     hs_tvs thing_inside+  = do { traceTc "bindExplicitTKBndrs" (ppr hs_tvs)+       ; go hs_tvs }+  where+    tc_ki_mode = TcTyMode { mode_tyki = KindLevel, mode_holes = hole_info }+                 -- Inherit the HoleInfo from the context++    go [] = do { res <- thing_inside+               ; return ([], res) }+    go (L _ hs_tv : hs_tvs)+       = do { lcl_env <- getLclTypeEnv+            ; tv <- tc_hs_bndr lcl_env hs_tv+            -- Extend the environment as we go, in case a binder+            -- is mentioned in the kind of a later binder+            --   e.g. forall k (a::k). blah+            -- NB: tv's Name may differ from hs_tv's+            -- See Note [Cloning for type variable binders]+            ; (tvs,res) <- tcExtendNameTyVarEnv [(hsTyVarName hs_tv, tv)] $+                           go hs_tvs+            ; return (Bndr tv (hsTyVarBndrFlag hs_tv):tvs, res) }+++    tc_hs_bndr lcl_env (UserTyVar _ _ (L _ name))+      | check_parent+      , Just (ATyVar _ tv) <- lookupNameEnv lcl_env name+      = return tv+      | otherwise+      = do { kind <- newExpectedKind ctxt_kind+           ; newTyVarBndr skol_mode name kind }++    tc_hs_bndr lcl_env (KindedTyVar _ _ (L _ name) lhs_kind)+      | check_parent+      , Just (ATyVar _ tv) <- lookupNameEnv lcl_env name+      = do { kind <- tc_lhs_kind_sig tc_ki_mode (TyVarBndrKindCtxt name) lhs_kind+           ; discardResult $+             unifyKind (Just . NameThing $ name) kind (tyVarKind tv)+                          -- This unify rejects:+                          --    class C (m :: * -> *) where+                          --      type F (m :: *) = ...+           ; return tv }++      | otherwise+      = do { kind <- tc_lhs_kind_sig tc_ki_mode (TyVarBndrKindCtxt name) lhs_kind+           ; newTyVarBndr skol_mode name kind }++newTyVarBndr :: SkolemMode -> Name -> Kind -> TcM TcTyVar+newTyVarBndr (SM { sm_clone = clone, sm_tvtv = tvtv }) name kind+  = do { name <- case clone of+              True -> do { uniq <- newUnique+                         ; return (setNameUnique name uniq) }+              False -> return name+       ; details <- case tvtv of+                 SMDTyVarTv  -> newMetaDetails TyVarTv+                 SMDSkolemTv skol_info ->+                  do { lvl <- getTcLevel+                     ; return (SkolemTv skol_info lvl False) }+       ; return (mkTcTyVar name kind details) }++--------------------------------------+--    Implicit tyvar binders+--------------------------------------++tcImplicitTKBndrsX :: SkolemMode -> SkolemInfo+                   -> [Name]+                   -> TcM a+                   -> TcM ([TcTyVar], a)+-- The workhorse:+--    push level, capture constraints, and emit an implication constraint+tcImplicitTKBndrsX skol_mode skol_info bndrs thing_inside+  | null bndrs  -- Short-cut the common case with no quantifiers+                -- E.g. f :: Int -> Int+                --      makes a HsOuterImplicit with empty bndrs,+                --      and tcOuterTKBndrsX goes via here+  = do { res <- thing_inside; return ([], res) }+  | otherwise+  = do { (tclvl, wanted, (skol_tvs, res))+             <- pushLevelAndCaptureConstraints       $+                bindImplicitTKBndrsX skol_mode bndrs $+                thing_inside++       ; emitResidualTvConstraint skol_info skol_tvs tclvl wanted++       ; return (skol_tvs, res) }++------------------+bindImplicitTKBndrs_Skol,+  bindImplicitTKBndrs_Q_Skol :: SkolemInfo -> [Name] -> TcM a -> TcM ([TcTyVar], a)++bindImplicitTKBndrs_Tv, bindImplicitTKBndrs_Q_Tv :: [Name] -> TcM a -> TcM ([TcTyVar], a)+bindImplicitTKBndrs_Skol skol_info = bindImplicitTKBndrsX (smVanilla { sm_clone = True, sm_tvtv = SMDSkolemTv skol_info })+bindImplicitTKBndrs_Tv   = bindImplicitTKBndrsX (smVanilla { sm_clone = True, sm_tvtv = SMDTyVarTv })+bindImplicitTKBndrs_Q_Skol skol_info = bindImplicitTKBndrsX (smVanilla { sm_clone = False, sm_parent = True, sm_tvtv = SMDSkolemTv skol_info })+bindImplicitTKBndrs_Q_Tv = bindImplicitTKBndrsX (smVanilla { sm_clone = False, sm_parent = True, sm_tvtv = SMDTyVarTv })++bindImplicitTKBndrsX+   :: SkolemMode+   -> [Name]               -- Generated by renamer; not in dependency order+   -> TcM a+   -> TcM ([TcTyVar], a)   -- Returned [TcTyVar] are in 1-1 correspondence+                           -- with the passed in [Name]+bindImplicitTKBndrsX skol_mode@(SM { sm_parent = check_parent, sm_kind = ctxt_kind })+                     tv_names thing_inside+  = do { lcl_env <- getLclTypeEnv+       ; tkvs <- mapM (new_tv lcl_env) tv_names+       ; traceTc "bindImplicitTKBndrsX" (ppr tv_names $$ ppr tkvs)+       ; res <- tcExtendNameTyVarEnv (tv_names `zip` tkvs)+                thing_inside+       ; return (tkvs, res) }+  where+    new_tv lcl_env name+      | check_parent+      , Just (ATyVar _ tv) <- lookupNameEnv lcl_env name+      = return tv+      | otherwise+      = do { kind <- newExpectedKind ctxt_kind+           ; newTyVarBndr skol_mode name kind }++--------------------------------------+--           SkolemMode+--------------------------------------++-- | 'SkolemMode' describes how to typecheck an explicit ('HsTyVarBndr') or+-- implicit ('Name') binder in a type. It is just a record of flags+-- that describe what sort of 'TcTyVar' to create.+data SkolemMode+  = SM { sm_parent :: Bool    -- True <=> check the in-scope parent type variable+                              -- Used only for asssociated types++       , sm_clone  :: Bool    -- True <=> fresh unique+                              -- See Note [Cloning for type variable binders]++       , sm_tvtv   :: SkolemModeDetails    -- True <=> use a TyVarTv, rather than SkolemTv+                              -- Why?  See Note [Inferring kinds for type declarations]+                              -- in GHC.Tc.TyCl, and (in this module)+                              -- Note [Checking partial type signatures]++       , sm_kind   :: ContextKind  -- Use this for the kind of any new binders++       , sm_holes  :: HoleInfo     -- What to do for wildcards in the kind+       }++data SkolemModeDetails+  = SMDTyVarTv+  | SMDSkolemTv SkolemInfo+++smVanilla :: HasCallStack => SkolemMode+smVanilla = SM { sm_clone  = panic "sm_clone"  -- We always override this+               , sm_parent = False+               , sm_tvtv   = pprPanic "sm_tvtv" callStackDoc -- We always override this+               , sm_kind   = AnyKind+               , sm_holes  = Nothing }++{- Note [Cloning for type variable binders]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Sometimes we must clone the Name of a type variable binder (written in+the source program); and sometimes we must not. This is controlled by+the sm_clone field of SkolemMode.++In some cases it doesn't matter whether or not we clone. Perhaps+it'd be better to use MustClone/MayClone/MustNotClone.++When we /must not/ clone+* In the binders of a type signature (tcOuterTKBndrs)+      f :: forall a{27}. blah+      f = rhs+  Then 'a' scopes over 'rhs'. When we kind-check the signature (tcHsSigType),+  we must get the type (forall a{27}. blah) for the Id f, because+  we bring that type variable into scope when we typecheck 'rhs'.++* In the binders of a data family instance (bindOuterFamEqnTKBndrs)+     data instance+       forall p q. D (p,q) = D1 p | D2 q+  We kind-check the LHS in tcDataFamInstHeader, and then separately+  (in tcDataFamInstDecl) bring p,q into scope before looking at the+  the constructor decls.++* bindExplicitTKBndrs_Q_Tv/bindImplicitTKBndrs_Q_Tv do not clone+  We take advantage of this in kcInferDeclHeader:+     all_tv_prs = mkTyVarNamePairs (scoped_kvs ++ tc_tvs)+  If we cloned, we'd need to take a bit more care here; not hard.++* bindExplicitTKBndrs_Q_Skol, bindExplicitTKBndrs_Skol, do not clone.+  There is no need, I think.++  The payoff here is that avoiding gratuitous cloning means that we can+  almost always take the fast path in swizzleTcTyConBndrs.++When we /must/ clone.+* bindOuterSigTKBndrs_Tv, bindExplicitTKBndrs_Tv do cloning++  This for a narrow and tricky reason which, alas, I couldn't find a+  simpler way round.  #16221 is the poster child:++     data SameKind :: k -> k -> *+     data T a = forall k2 (b :: k2). MkT (SameKind a b) !Int++  When kind-checking T, we give (a :: kappa1). Then:++  - In kcConDecl we make a TyVarTv unification variable kappa2 for k2+    (as described in Note [Using TyVarTvs for kind-checking GADTs],+    even though this example is an existential)+  - So we get (b :: kappa2) via bindExplicitTKBndrs_Tv+  - We end up unifying kappa1 := kappa2, because of the (SameKind a b)++  Now we generalise over kappa2. But if kappa2's Name is precisely k2+  (i.e. we did not clone) we'll end up giving T the utterly final kind+    T :: forall k2. k2 -> *+  Nothing directly wrong with that but when we typecheck the data constructor+  we have k2 in scope; but then it's brought into scope /again/ when we find+  the forall k2.  This is chaotic, and we end up giving it the type+    MkT :: forall k2 (a :: k2) k2 (b :: k2).+           SameKind @k2 a b -> Int -> T @{k2} a+  which is bogus -- because of the shadowing of k2, we can't+  apply T to the kind or a!++  And there no reason /not/ to clone the Name when making a unification+  variable.  So that's what we do.+-}++--------------------------------------+-- Binding type/class variables in the+-- kind-checking and typechecking phases+--------------------------------------++bindTyClTyVars :: Name -> ([TcTyConBinder] -> TcKind -> TcM a) -> TcM a+-- ^ Bring into scope the binders of a PolyTcTyCon+-- Used for the type variables of a type or class decl+-- in the "kind checking" and "type checking" pass,+-- but not in the initial-kind run.+bindTyClTyVars tycon_name thing_inside+  = do { tycon <- tcLookupTcTyCon tycon_name     -- The tycon is a PolyTcTyCon+       ; let res_kind   = tyConResKind tycon+             binders    = tyConBinders tycon+       ; traceTc "bindTyClTyVars" (ppr tycon_name $$ ppr binders)+       ; tcExtendTyVarEnv (binderVars binders) $+         thing_inside binders res_kind }++bindTyClTyVarsAndZonk :: Name -> ([TyConBinder] -> Kind -> TcM a) -> TcM a+-- Like bindTyClTyVars, but in addition+-- zonk the skolem TcTyVars of a PolyTcTyCon to TyVars+bindTyClTyVarsAndZonk tycon_name thing_inside+  = bindTyClTyVars tycon_name $ \ tc_bndrs tc_kind ->+    do { ze          <- mkEmptyZonkEnv NoFlexi+       ; (ze, bndrs) <- zonkTyVarBindersX ze tc_bndrs+       ; kind        <- zonkTcTypeToTypeX ze tc_kind+       ; thing_inside bndrs kind }+++{- *********************************************************************+*                                                                      *+             Kind generalisation+*                                                                      *+********************************************************************* -}++zonkAndScopedSort :: [TcTyVar] -> TcM [TcTyVar]+zonkAndScopedSort spec_tkvs+  = do { spec_tkvs <- zonkTcTyVarsToTcTyVars spec_tkvs+         -- Zonk the kinds, to we can do the dependency analayis++       -- Do a stable topological sort, following+       -- Note [Ordering of implicit variables] in GHC.Rename.HsType+       ; return (scopedSort spec_tkvs) }++-- | Generalize some of the free variables in the given type.+-- All such variables should be *kind* variables; any type variables+-- should be explicitly quantified (with a `forall`) before now.+--+-- The WantedConstraints are un-solved kind constraints. Generally+-- they'll be reported as errors later, but meanwhile we refrain+-- from quantifying over any variable free in these unsolved+-- constraints. See Note [Failure in local type signatures].+--+-- But in all cases, generalize only those variables whose TcLevel is+-- strictly greater than the ambient level. This "strictly greater+-- than" means that you likely need to push the level before creating+-- whatever type gets passed here.+--+-- Any variable whose level is greater than the ambient level but is+-- not selected to be generalized will be promoted. (See [Promoting+-- unification variables] in "GHC.Tc.Solver" and Note [Recipe for+-- checking a signature].)+--+-- The resulting KindVar are the variables to quantify over, in the+-- correct, well-scoped order. They should generally be Inferred, not+-- Specified, but that's really up to the caller of this function.+kindGeneralizeSome :: SkolemInfo+                   -> WantedConstraints+                   -> TcType    -- ^ needn't be zonked+                   -> TcM [KindVar]+kindGeneralizeSome skol_info wanted kind_or_type+  = do { -- Use the "Kind" variant here, as any types we see+         -- here will already have all type variables quantified;+         -- thus, every free variable is really a kv, never a tv.+       ; dvs <- candidateQTyVarsOfKind kind_or_type+       ; dvs <- filterConstrainedCandidates wanted dvs+       ; quantifyTyVars skol_info DefaultNonStandardTyVars dvs }++filterConstrainedCandidates+  :: WantedConstraints    -- Don't quantify over variables free in these+                          --   Not necessarily fully zonked+  -> CandidatesQTvs       -- Candidates for quantification+  -> TcM CandidatesQTvs+-- filterConstrainedCandidates removes any candidates that are free in+-- 'wanted'; instead, it promotes them.  This bit is very much like+-- decideMonoTyVars in GHC.Tc.Solver, but constraints are so much+-- simpler in kinds, it is much easier here. (In particular, we never+-- quantify over a constraint in a type.)+filterConstrainedCandidates wanted dvs+  | isEmptyWC wanted   -- Fast path for a common case+  = return dvs+  | otherwise+  = do { wc_tvs <- zonkTyCoVarsAndFV (tyCoVarsOfWC wanted)+       ; let (to_promote, dvs') = partitionCandidates dvs (`elemVarSet` wc_tvs)+       ; _ <- promoteTyVarSet to_promote+       ; return dvs' }++-- |- Specialised version of 'kindGeneralizeSome', but with empty+-- WantedConstraints, so no filtering is needed+-- i.e.   kindGeneraliseAll = kindGeneralizeSome emptyWC+kindGeneralizeAll :: SkolemInfo -> TcType -> TcM [KindVar]+kindGeneralizeAll skol_info kind_or_type+  = do { traceTc "kindGeneralizeAll" (ppr kind_or_type)+       ; dvs <- candidateQTyVarsOfKind kind_or_type+       ; quantifyTyVars skol_info DefaultNonStandardTyVars dvs }++-- | Specialized version of 'kindGeneralizeSome', but where no variables+-- can be generalized, but perhaps some may need to be promoted.+-- Use this variant when it is unknowable whether metavariables might+-- later be constrained.+--+-- To see why this promotion is needed, see+-- Note [Recipe for checking a signature], and especially+-- Note [Promotion in signatures].+kindGeneralizeNone :: TcType  -- needn't be zonked+                   -> TcM ()+kindGeneralizeNone kind_or_type+  = do { traceTc "kindGeneralizeNone" (ppr kind_or_type)+       ; dvs <- candidateQTyVarsOfKind kind_or_type+       ; _ <- promoteTyVarSet (candidateKindVars dvs)+       ; return () }++{- Note [Levels and generalisation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  f x = e+with no type signature. We are currently at level i.+We must+  * Push the level to level (i+1)+  * Allocate a fresh alpha[i+1] for the result type+  * Check that e :: alpha[i+1], gathering constraint WC+  * Solve WC as far as possible+  * Zonking the result type alpha[i+1], say to beta[i-1] -> gamma[i]+  * Find the free variables with level > i, in this case gamma[i]+  * Skolemise those free variables and quantify over them, giving+       f :: forall g. beta[i-1] -> g+  * Emit the residiual constraint wrapped in an implication for g,+    thus   forall g. WC++All of this happens for types too.  Consider+  f :: Int -> (forall a. Proxy a -> Int)++Note [Kind generalisation]+~~~~~~~~~~~~~~~~~~~~~~~~~~+We do kind generalisation only at the outer level of a type signature.+For example, consider+  T :: forall k. k -> *+  f :: (forall a. T a -> Int) -> Int+When kind-checking f's type signature we generalise the kind at+the outermost level, thus:+  f1 :: forall k. (forall (a:k). T k a -> Int) -> Int  -- YES!+and *not* at the inner forall:+  f2 :: (forall k. forall (a:k). T k a -> Int) -> Int  -- NO!+Reason: same as for HM inference on value level declarations,+we want to infer the most general type.  The f2 type signature+would be *less applicable* than f1, because it requires a more+polymorphic argument.++NB: There are no explicit kind variables written in f's signature.+When there are, the renamer adds these kind variables to the list of+variables bound by the forall, so you can indeed have a type that's+higher-rank in its kind. But only by explicit request.++Note [Kinds of quantified type variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+tcTyVarBndrsGen quantifies over a specified list of type variables,+*and* over the kind variables mentioned in the kinds of those tyvars.++Note that we must zonk those kinds (obviously) but less obviously, we+must return type variables whose kinds are zonked too. Example+    (a :: k7)  where  k7 := k9 -> k9+We must return+    [k9, a:k9->k9]+and NOT+    [k9, a:k7]+Reason: we're going to turn this into a for-all type,+   forall k9. forall (a:k7). blah+which the type checker will then instantiate, and instantiate does not+look through unification variables!++Hence using zonked_kinds when forming tvs'.++-}++-----------------------------------+etaExpandAlgTyCon :: TyConFlavour -> SkolemInfo+                  -> [TcTyConBinder] -> Kind+                  -> TcM ([TcTyConBinder], Kind)+etaExpandAlgTyCon flav skol_info tcbs res_kind+  | needsEtaExpansion flav+  = splitTyConKind skol_info in_scope avoid_occs res_kind+  | otherwise+  = return ([], res_kind)+  where+    tyvars     = binderVars tcbs+    in_scope   = mkInScopeSet (mkVarSet tyvars)+    avoid_occs = map getOccName tyvars++needsEtaExpansion :: TyConFlavour -> Bool+needsEtaExpansion NewtypeFlavour  = True+needsEtaExpansion DataTypeFlavour = True+needsEtaExpansion ClassFlavour    = True+needsEtaExpansion _               = False++splitTyConKind :: SkolemInfo+               -> InScopeSet+               -> [OccName]  -- Avoid these OccNames+               -> Kind       -- Must be zonked+               -> TcM ([TcTyConBinder], TcKind)+-- GADT decls can have a (perhaps partial) kind signature+--      e.g.  data T a :: * -> * -> * where ...+-- This function makes up suitable (kinded) TyConBinders for the+-- argument kinds.  E.g. in this case it might return+--   ([b::*, c::*], *)+-- Skolemises the type as it goes, returning skolem TcTyVars+-- Never emits constraints.+-- It's a little trickier than you might think: see Note [splitTyConKind]+-- See also Note [Datatype return kinds] in GHC.Tc.TyCl+splitTyConKind skol_info in_scope avoid_occs kind+  = do  { loc     <- getSrcSpanM+        ; uniqs   <- newUniqueSupply+        ; rdr_env <- getLocalRdrEnv+        ; lvl     <- getTcLevel+        ; let new_occs = [ occ+                         | str <- allNameStrings+                         , let occ = mkOccName tvName str+                         , isNothing (lookupLocalRdrOcc rdr_env occ)+                         -- Note [Avoid name clashes for associated data types]+                         , not (occ `elem` avoid_occs) ]+              new_uniqs = uniqsFromSupply uniqs+              subst = mkEmptyTCvSubst in_scope+              details = SkolemTv skol_info (pushTcLevel lvl) False+                        -- As always, allocate skolems one level in++              go occs uniqs subst acc kind+                = case splitPiTy_maybe kind of+                    Nothing -> (reverse acc, substTy subst kind)++                    Just (Anon af arg, kind')+                      -> go occs' uniqs' subst' (tcb : acc) kind'+                      where+                        tcb    = Bndr tv (AnonTCB af)+                        arg'   = substTy subst (scaledThing arg)+                        name   = mkInternalName uniq occ loc+                        tv     = mkTcTyVar name arg' details+                        subst' = extendTCvInScope subst tv+                        (uniq:uniqs') = uniqs+                        (occ:occs')   = occs++                    Just (Named (Bndr tv vis), kind')+                      -> go occs uniqs subst' (tcb : acc) kind'+                      where+                        tcb           = Bndr tv' (NamedTCB vis)+                        tc_tyvar      = mkTcTyVar (tyVarName tv) (tyVarKind tv) details+                        (subst', tv') = substTyVarBndr subst tc_tyvar++        ; return (go new_occs new_uniqs subst [] kind) }++-- | A description of whether something is a+--+-- * @data@ or @newtype@ ('DataDeclSort')+--+-- * @data instance@ or @newtype instance@ ('DataInstanceSort')+--+-- * @data family@ ('DataFamilySort')+--+-- At present, this data type is only consumed by 'checkDataKindSig'.+data DataSort+  = DataDeclSort     NewOrData+  | DataInstanceSort NewOrData+  | DataFamilySort++-- | Local helper type used in 'checkDataKindSig'.+--+-- Superficially similar to 'ContextKind', but it lacks 'AnyKind'+-- and 'AnyBoxedKind', and instead of @'TheKind' liftedTypeKind@+-- provides 'LiftedKind', which is much simpler to match on and+-- handle in 'isAllowedDataResKind'.+data AllowedDataResKind+  = AnyTYPEKind+  | AnyBoxedKind+  | LiftedKind++isAllowedDataResKind :: AllowedDataResKind -> Kind -> Bool+isAllowedDataResKind AnyTYPEKind  kind = tcIsRuntimeTypeKind kind+isAllowedDataResKind AnyBoxedKind kind = tcIsBoxedTypeKind kind+isAllowedDataResKind LiftedKind   kind = tcIsLiftedTypeKind kind++-- | Checks that the return kind in a data declaration's kind signature is+-- permissible. There are three cases:+--+-- If dealing with a @data@, @newtype@, @data instance@, or @newtype instance@+-- declaration, check that the return kind is @Type@.+--+-- If the declaration is a @newtype@ or @newtype instance@ and the+-- @UnliftedNewtypes@ extension is enabled, this check is slightly relaxed so+-- that a return kind of the form @TYPE r@ (for some @r@) is permitted.+-- See @Note [Implementation of UnliftedNewtypes]@ in "GHC.Tc.TyCl".+--+-- If dealing with a @data family@ declaration, check that the return kind is+-- either of the form:+--+-- 1. @TYPE r@ (for some @r@), or+--+-- 2. @k@ (where @k@ is a bare kind variable; see #12369)+--+-- See also Note [Datatype return kinds] in "GHC.Tc.TyCl"+checkDataKindSig :: DataSort -> Kind  -- any arguments in the kind are stripped off+                 -> TcM ()+checkDataKindSig data_sort kind+  = do { dflags <- getDynFlags+       ; traceTc "checkDataKindSig" (ppr kind)+       ; checkTc (tYPE_ok dflags || is_kind_var)+                 (err_msg dflags) }+  where+    res_kind = snd (tcSplitPiTys kind)+       -- Look for the result kind after+       -- peeling off any foralls and arrows++    pp_dec :: SDoc+    pp_dec = text $+      case data_sort of+        DataDeclSort     DataType -> "Data type"+        DataDeclSort     NewType  -> "Newtype"+        DataInstanceSort DataType -> "Data instance"+        DataInstanceSort NewType  -> "Newtype instance"+        DataFamilySort            -> "Data family"++    is_newtype :: Bool+    is_newtype =+      case data_sort of+        DataDeclSort     new_or_data -> new_or_data == NewType+        DataInstanceSort new_or_data -> new_or_data == NewType+        DataFamilySort               -> False++    is_datatype :: Bool+    is_datatype =+      case data_sort of+        DataDeclSort     DataType -> True+        DataInstanceSort DataType -> True+        _                         -> False++    is_data_family :: Bool+    is_data_family =+      case data_sort of+        DataDeclSort{}     -> False+        DataInstanceSort{} -> False+        DataFamilySort     -> True++    allowed_kind :: DynFlags -> AllowedDataResKind+    allowed_kind dflags+      | is_newtype && xopt LangExt.UnliftedNewtypes dflags+        -- With UnliftedNewtypes, we allow kinds other than Type, but they+        -- must still be of the form `TYPE r` since we don't want to accept+        -- Constraint or Nat.+        -- See Note [Implementation of UnliftedNewtypes] in GHC.Tc.TyCl.+      = AnyTYPEKind+      | is_data_family+        -- If this is a `data family` declaration, we don't need to check if+        -- UnliftedNewtypes is enabled, since data family declarations can+        -- have return kind `TYPE r` unconditionally (#16827).+      = AnyTYPEKind+      | is_datatype && xopt LangExt.UnliftedDatatypes dflags+        -- With UnliftedDatatypes, we allow kinds other than Type, but they+        -- must still be of the form `TYPE (BoxedRep l)`, so that we don't+        -- accept result kinds like `TYPE IntRep`.+        -- See Note [Implementation of UnliftedDatatypes] in GHC.Tc.TyCl.+      = AnyBoxedKind+      | otherwise+      = LiftedKind++    tYPE_ok :: DynFlags -> Bool+    tYPE_ok dflags = isAllowedDataResKind (allowed_kind dflags) res_kind++    -- In the particular case of a data family, permit a return kind of the+    -- form `:: k` (where `k` is a bare kind variable).+    is_kind_var :: Bool+    is_kind_var | is_data_family = isJust (tcGetCastedTyVar_maybe res_kind)+                | otherwise      = False++    pp_allowed_kind dflags =+      case allowed_kind dflags of+        AnyTYPEKind  -> ppr tYPETyCon+        AnyBoxedKind -> ppr boxedRepDataConTyCon+        LiftedKind   -> ppr liftedTypeKind++    err_msg :: DynFlags -> TcRnMessage+    err_msg dflags = TcRnUnknownMessage $ mkPlainError noHints $+      sep [ sep [ pp_dec <+>+                  text "has non-" <>+                  pp_allowed_kind dflags+                , (if is_data_family then text "and non-variable" else empty) <+>+                  text "return kind" <+> quotes (ppr kind) ]+          , ext_hint dflags ]++    ext_hint dflags+      | tcIsRuntimeTypeKind kind+      , is_newtype+      , not (xopt LangExt.UnliftedNewtypes dflags)+      = text "Perhaps you intended to use UnliftedNewtypes"+      | tcIsBoxedTypeKind kind+      , is_datatype+      , not (xopt LangExt.UnliftedDatatypes dflags)+      = text "Perhaps you intended to use UnliftedDatatypes"+      | otherwise+      = empty++-- | Checks that the result kind of a class is exactly `Constraint`, rejecting+-- type synonyms and type families that reduce to `Constraint`. See #16826.+checkClassKindSig :: Kind -> TcM ()+checkClassKindSig kind = checkTc (tcIsConstraintKind kind) err_msg+  where+    err_msg :: TcRnMessage+    err_msg = TcRnUnknownMessage $ mkPlainError noHints $+      text "Kind signature on a class must end with" <+> ppr constraintKind $$+      text "unobscured by type families"++tcbVisibilities :: TyCon -> [Type] -> [TyConBndrVis]+-- Result is in 1-1 correspondence with orig_args+tcbVisibilities tc orig_args+  = go (tyConKind tc) init_subst orig_args+  where+    init_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfTypes orig_args))+    go _ _ []+      = []++    go fun_kind subst all_args@(arg : args)+      | Just (tcb, inner_kind) <- splitPiTy_maybe fun_kind+      = case tcb of+          Anon af _           -> AnonTCB af   : go inner_kind subst  args+          Named (Bndr tv vis) -> NamedTCB vis : go inner_kind subst' args+                 where+                    subst' = extendTCvSubst subst tv arg++      | not (isEmptyTCvSubst subst)+      = go (substTy subst fun_kind) init_subst all_args++      | otherwise+      = pprPanic "addTcbVisibilities" (ppr tc <+> ppr orig_args)+++{- Note [splitTyConKind]+~~~~~~~~~~~~~~~~~~~~~~~~+Given+  data T (a::*) :: * -> forall k. k -> *+we want to generate the extra TyConBinders for T, so we finally get+  (a::*) (b::*) (k::*) (c::k)+The function splitTyConKind generates these extra TyConBinders from+the result kind signature.  The same function is also used by+kcCheckDeclHeader_sig to get the [TyConBinder] from the Kind of+the TyCon given in a standalone kind signature.  E.g.+  type T :: forall (a::*). * -> forall k. k -> *++We need to take care to give the TyConBinders+  (a) Uniques that are fresh: the TyConBinders of a TyCon+      must have distinct uniques.++  (b) Preferably, OccNames that are fresh. If we happen to re-use+      OccNames that are other TyConBinders, we'll get a TyCon with+      TyConBinders like [a_72, a_53]; same OccName, different Uniques.+      Then when pretty-printing (e.g. in GHCi :info) we'll see+          data T a a0+      whereas we'd prefer+          data T a b+      (NB: the tidying happens in the conversion to Iface syntax,+      which happens as part of pretty-printing a TyThing.)++      Using fresh OccNames is not essential; it's cosmetic.+      And also see Note [Avoid name clashes for associated data types].++For (a) perhaps surprisingly, duplicated uniques can happen, even if+we use fresh uniques for Anon arrows.  Consider+   data T :: forall k. k -> forall k. k -> *+where the two k's are identical even up to their uniques.  Surprisingly,+this can happen: see #14515, #19092,3,4.  Then if we use those k's in+as TyConBinders we'll get duplicated uniques.++For (b) we'd like to avoid OccName clashes with the tyvars declared by+the user before the "::"; in the above example that is 'a'.++It's reasonably easy to solve all this; just run down the list with a+substitution; hence the recursive 'go' function.  But for the Uniques+it has to be done.++Note [Avoid name clashes for associated data types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider    class C a b where+               data D b :: * -> *+When typechecking the decl for D, we'll invent an extra type variable+for D, to fill out its kind.  Ideally we don't want this type variable+to be 'a', because when pretty printing we'll get+            class C a b where+               data D b a0+(NB: the tidying happens in the conversion to Iface syntax, which happens+as part of pretty-printing a TyThing.)++That's why we look in the LocalRdrEnv to see what's in scope. This is+important only to get nice-looking output when doing ":info C" in GHCi.+It isn't essential for correctness.+++************************************************************************+*                                                                      *+             Partial signatures+*                                                                      *+************************************************************************++-}++tcHsPartialSigType+  :: UserTypeCtxt+  -> LHsSigWcType GhcRn       -- The type signature+  -> TcM ( [(Name, TcTyVar)]  -- Wildcards+         , Maybe TcType       -- Extra-constraints wildcard+         , [(Name,InvisTVBinder)] -- Original tyvar names, in correspondence with+                              --   the implicitly and explicitly bound type variables+         , TcThetaType        -- Theta part+         , TcType )           -- Tau part+-- See Note [Checking partial type signatures]+tcHsPartialSigType ctxt sig_ty+  | HsWC { hswc_ext  = sig_wcs, hswc_body = sig_ty } <- sig_ty+  , L _ (HsSig{sig_bndrs = hs_outer_bndrs, sig_body = body_ty}) <- sig_ty+  , (hs_ctxt, hs_tau) <- splitLHsQualTy body_ty+  = addSigCtxt ctxt sig_ty $+    do { mode <- mkHoleMode TypeLevel HM_Sig+       ; (outer_bndrs, (wcs, wcx, theta, tau))+            <- solveEqualities "tcHsPartialSigType" $+               -- See Note [Failure in local type signatures]+               bindNamedWildCardBinders sig_wcs             $ \ wcs ->+               bindOuterSigTKBndrs_Tv_M mode hs_outer_bndrs $+               do {   -- Instantiate the type-class context; but if there+                      -- is an extra-constraints wildcard, just discard it here+                    (theta, wcx) <- tcPartialContext mode hs_ctxt++                  ; ek <- newOpenTypeKind+                  ; tau <- addTypeCtxt hs_tau $+                           tc_lhs_type mode hs_tau ek++                  ; return (wcs, wcx, theta, tau) }++       ; traceTc "tcHsPartialSigType 2" empty+       ; outer_bndrs <- scopedSortOuter outer_bndrs+       ; let outer_tv_bndrs = outerTyVarBndrs outer_bndrs+       ; traceTc "tcHsPartialSigType 3" empty++         -- No kind-generalization here:+       ; kindGeneralizeNone (mkInvisForAllTys outer_tv_bndrs $+                             mkPhiTy theta $+                             tau)++       -- Spit out the wildcards (including the extra-constraints one)+       -- as "hole" constraints, so that they'll be reported if necessary+       -- See Note [Extra-constraint holes in partial type signatures]+       ; mapM_ emitNamedTypeHole wcs++       -- Zonk, so that any nested foralls can "see" their occurrences+       -- See Note [Checking partial type signatures], and in particular+       -- Note [Levels for wildcards]+       ; outer_tv_bndrs <- mapM zonkInvisTVBinder outer_tv_bndrs+       ; theta          <- mapM zonkTcType theta+       ; tau            <- zonkTcType tau++         -- We return a proper (Name,InvisTVBinder) environment, to be sure that+         -- we bring the right name into scope in the function body.+         -- Test case: partial-sigs/should_compile/LocalDefinitionBug+       ; let outer_bndr_names :: [Name]+             outer_bndr_names = hsOuterTyVarNames hs_outer_bndrs+             tv_prs :: [(Name,InvisTVBinder)]+             tv_prs = outer_bndr_names `zip` outer_tv_bndrs++      -- NB: checkValidType on the final inferred type will be+      --     done later by checkInferredPolyId.  We can't do it+      --     here because we don't have a complete type to check++       ; traceTc "tcHsPartialSigType" (ppr tv_prs)+       ; return (wcs, wcx, tv_prs, theta, tau) }++tcPartialContext :: TcTyMode -> Maybe (LHsContext GhcRn) -> TcM (TcThetaType, Maybe TcType)+tcPartialContext _ Nothing = return ([], Nothing)+tcPartialContext mode (Just (L _ hs_theta))+  | Just (hs_theta1, hs_ctxt_last) <- snocView hs_theta+  , L wc_loc ty@(HsWildCardTy _) <- ignoreParens hs_ctxt_last+  = do { wc_tv_ty <- setSrcSpanA wc_loc $+                     tcAnonWildCardOcc YesExtraConstraint mode ty constraintKind+       ; theta <- mapM (tc_lhs_pred mode) hs_theta1+       ; return (theta, Just wc_tv_ty) }+  | otherwise+  = do { theta <- mapM (tc_lhs_pred mode) hs_theta+       ; return (theta, Nothing) }++{- Note [Checking partial type signatures]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+This Note is about tcHsPartialSigType.  See also+Note [Recipe for checking a signature]++When we have a partial signature like+   f :: forall a. a -> _+we do the following++* tcHsPartialSigType does not make quantified type (forall a. blah)+  and then instantiate it -- it makes no sense to instantiate a type+  with wildcards in it.  Rather, tcHsPartialSigType just returns the+  'a' and the 'blah' separately.++  Nor, for the same reason, do we push a level in tcHsPartialSigType.++* We instantiate 'a' to a unification variable, a TyVarTv, and /not/+  a skolem; hence the "_Tv" in bindExplicitTKBndrs_Tv.  Consider+    f :: forall a. a -> _+    g :: forall b. _ -> b+    f = g+    g = f+  They are typechecked as a recursive group, with monomorphic types,+  so 'a' and 'b' will get unified together.  Very like kind inference+  for mutually recursive data types (sans CUSKs or SAKS); see+  Note [Cloning for type variable binders]++* In GHC.Tc.Gen.Sig.tcUserSigType we return a PartialSig, which (unlike+  the companion CompleteSig) contains the original, as-yet-unchecked+  source-code LHsSigWcType++* Then, for f and g /separately/, we call tcInstSig, which in turn+  call tchsPartialSig (defined near this Note).  It kind-checks the+  LHsSigWcType, creating fresh unification variables for each "_"+  wildcard.  It's important that the wildcards for f and g are distinct+  because they might get instantiated completely differently.  E.g.+     f,g :: forall a. a -> _+     f x = a+     g x = True+  It's really as if we'd written two distinct signatures.++* Nested foralls. See Note [Levels for wildcards]++* Just as for ordinary signatures, we must solve local equalities and+  zonk the type after kind-checking it, to ensure that all the nested+  forall binders can "see" their occurrenceds++  Just as for ordinary signatures, this zonk also gets any Refl casts+  out of the way of instantiation.  Example: #18008 had+       foo :: (forall a. (Show a => blah) |> Refl) -> _+  and that Refl cast messed things up.  See #18062.++Note [Levels for wildcards]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+     f :: forall b. (forall a. a -> _) -> b+We do /not/ allow the "_" to be instantiated to 'a'; although we do+(as before) allow it to be instantiated to the (top level) 'b'.+Why not?  Suppose+   f x = (x True, x 'c')++During typecking the RHS we must instantiate that (forall a. a -> _),+so we must know /precisely/ where all the a's are; they must not be+hidden under (possibly-not-yet-filled-in) unification variables!++We achieve this as follows:++- For /named/ wildcards such sas+     g :: forall b. (forall la. a -> _x) -> b+  there is no problem: we create them at the outer level (ie the+  ambient level of the signature itself), and push the level when we+  go inside a forall.  So now the unification variable for the "_x"+  can't unify with skolem 'a'.++- For /anonymous/ wildcards, such as 'f' above, we carry the ambient+  level of the signature to the hole in the TcLevel part of the+  mode_holes field of TcTyMode.  Then, in tcAnonWildCardOcc we us that+  level (and /not/ the level ambient at the occurrence of "_") to+  create the unification variable for the wildcard.  That is the sole+  purpose of the TcLevel in the mode_holes field: to transport the+  ambient level of the signature down to the anonymous wildcard+  occurrences.++Note [Extra-constraint holes in partial type signatures]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  f :: (_) => a -> a+  f x = ...++* The renamer leaves '_' untouched.++* Then, in tcHsPartialSigType, we make a new hole TcTyVar, in+  tcWildCardBinders.++* GHC.Tc.Gen.Bind.chooseInferredQuantifiers fills in that hole TcTyVar+  with the inferred constraints, e.g. (Eq a, Show a)++* GHC.Tc.Errors.mkHoleError finally reports the error.++An annoying difficulty happens if there are more than 64 inferred+constraints. Then we need to fill in the TcTyVar with (say) a 70-tuple.+Where do we find the TyCon?  For good reasons we only have constraint+tuples up to 62 (see Note [How tuples work] in GHC.Builtin.Types).  So how+can we make a 70-tuple?  This was the root cause of #14217.++It's incredibly tiresome, because we only need this type to fill+in the hole, to communicate to the error reporting machinery.  Nothing+more.  So I use a HACK:++* I make an /ordinary/ tuple of the constraints, in+  GHC.Tc.Gen.Bind.chooseInferredQuantifiers. This is ill-kinded because+  ordinary tuples can't contain constraints, but it works fine. And for+  ordinary tuples we don't have the same limit as for constraint+  tuples (which need selectors and an associated class).++* Because it is ill-kinded (unifying something of kind Constraint with+  something of kind Type), it should trip an assert in writeMetaTyVarRef.+  However, writeMetaTyVarRef uses eqType, not tcEqType, to avoid falling+  over in this scenario (and another scenario, as detailed in+  Note [coreView vs tcView] in GHC.Core.Type).++Result works fine, but it may eventually bite us.++See also Note [Do not simplify ConstraintHoles] in GHC.Tc.Solver for+information about how these are printed.++************************************************************************+*                                                                      *+      Pattern signatures (i.e signatures that occur in patterns)+*                                                                      *+********************************************************************* -}++tcHsPatSigType :: UserTypeCtxt+               -> HoleMode -- HM_Sig when in a SigPat, HM_TyAppPat when in a ConPat checking type applications.+               -> HsPatSigType GhcRn          -- The type signature+               -> ContextKind                -- What kind is expected+               -> TcM ( [(Name, TcTyVar)]     -- Wildcards+                      , [(Name, TcTyVar)]     -- The new bit of type environment, binding+                                              -- the scoped type variables+                      , TcType)       -- The type+-- Used for type-checking type signatures in+-- (a) patterns           e.g  f (x::Int) = e+-- (b) RULE forall bndrs  e.g. forall (x::Int). f x = x+-- See Note [Pattern signature binders and scoping] in GHC.Hs.Type+--+-- This may emit constraints+-- See Note [Recipe for checking a signature]+tcHsPatSigType ctxt hole_mode+  (HsPS { hsps_ext  = HsPSRn { hsps_nwcs = sig_wcs, hsps_imp_tvs = sig_ns }+        , hsps_body = hs_ty })+  ctxt_kind+  = addSigCtxt ctxt hs_ty $+    do { sig_tkv_prs <- mapM new_implicit_tv sig_ns+       ; mode <- mkHoleMode TypeLevel hole_mode+       ; (wcs, sig_ty)+            <- addTypeCtxt hs_ty                     $+               solveEqualities "tcHsPatSigType" $+                 -- See Note [Failure in local type signatures]+                 -- and c.f #16033+               bindNamedWildCardBinders sig_wcs $ \ wcs ->+               tcExtendNameTyVarEnv sig_tkv_prs $+               do { ek     <- newExpectedKind ctxt_kind+                  ; sig_ty <- tc_lhs_type mode hs_ty ek+                  ; return (wcs, sig_ty) }++        ; mapM_ emitNamedTypeHole wcs++          -- sig_ty might have tyvars that are at a higher TcLevel (if hs_ty+          -- contains a forall). Promote these.+          -- Ex: f (x :: forall a. Proxy a -> ()) = ... x ...+          -- When we instantiate x, we have to compare the kind of the argument+          -- to a's kind, which will be a metavariable.+          -- kindGeneralizeNone does this:+        ; kindGeneralizeNone sig_ty+        ; sig_ty <- zonkTcType sig_ty+        ; checkValidType ctxt sig_ty++        ; traceTc "tcHsPatSigType" (ppr sig_tkv_prs)+        ; return (wcs, sig_tkv_prs, sig_ty) }+  where+    new_implicit_tv name+      = do { kind <- newMetaKindVar+           ; tv   <- case ctxt of+                       RuleSigCtxt rname _  -> do+                        skol_info <- mkSkolemInfo (RuleSkol rname)+                        newSkolemTyVar skol_info name kind+                       _              -> newPatSigTyVar name kind+                       -- See Note [Typechecking pattern signature binders]+             -- NB: tv's Name may be fresh (in the case of newPatSigTyVar)+           ; return (name, tv) }++{- Note [Typechecking pattern signature binders]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+See also Note [Type variables in the type environment] in GHC.Tc.Utils.+Consider++  data T where+    MkT :: forall a. a -> (a -> Int) -> T++  f :: T -> ...+  f (MkT x (f :: b -> c)) = <blah>++Here+ * The pattern (MkT p1 p2) creates a *skolem* type variable 'a_sk',+   It must be a skolem so that it retains its identity, and+   GHC.Tc.Errors.getSkolemInfo can thereby find the binding site for the skolem.++ * The type signature pattern (f :: b -> c) makes fresh meta-tyvars+   beta and gamma (TauTvs), and binds "b" :-> beta, "c" :-> gamma in the+   environment++ * Then unification makes beta := a_sk, gamma := Int+   That's why we must make beta and gamma a MetaTv,+   not a SkolemTv, so that it can unify to a_sk (or Int, respectively).++ * Finally, in '<blah>' we have the envt "b" :-> beta, "c" :-> gamma,+   so we return the pairs ("b" :-> beta, "c" :-> gamma) from tcHsPatSigType,++Another example (#13881):+   fl :: forall (l :: [a]). Sing l -> Sing l+   fl (SNil :: Sing (l :: [y])) = SNil+When we reach the pattern signature, 'l' is in scope from the+outer 'forall':+   "a" :-> a_sk :: *+   "l" :-> l_sk :: [a_sk]+We make up a fresh meta-TauTv, y_sig, for 'y', and kind-check+the pattern signature+   Sing (l :: [y])+That unifies y_sig := a_sk.  We return from tcHsPatSigType with+the pair ("y" :-> y_sig).++For RULE binders, though, things are a bit different (yuk).+  RULE "foo" forall (x::a) (y::[a]).  f x y = ...+Here this really is the binding site of the type variable so we'd like+to use a skolem, so that we get a complaint if we unify two of them+together.  Hence the new_implicit_tv function in tcHsPatSigType.+++************************************************************************+*                                                                      *+        Checking kinds+*                                                                      *+************************************************************************++-}++unifyKinds :: [LHsType GhcRn] -> [(TcType, TcKind)] -> TcM ([TcType], TcKind)+unifyKinds rn_tys act_kinds+  = do { kind <- newMetaKindVar+       ; let check rn_ty (ty, act_kind)+               = checkExpectedKind (unLoc rn_ty) ty act_kind kind+       ; tys' <- zipWithM check rn_tys act_kinds+       ; return (tys', kind) }++{-+************************************************************************+*                                                                      *+        Sort checking kinds+*                                                                      *+************************************************************************++tcLHsKindSig converts a user-written kind to an internal, sort-checked kind.+It does sort checking and desugaring at the same time, in one single pass.+-}++tcLHsKindSig :: UserTypeCtxt -> LHsKind GhcRn -> TcM Kind+tcLHsKindSig ctxt hs_kind+  = tc_lhs_kind_sig kindLevelMode ctxt hs_kind++tc_lhs_kind_sig :: TcTyMode -> UserTypeCtxt -> LHsKind GhcRn -> TcM Kind+tc_lhs_kind_sig mode ctxt hs_kind+-- See  Note [Recipe for checking a signature] in GHC.Tc.Gen.HsType+-- Result is zonked+  = do { kind <- addErrCtxt (text "In the kind" <+> quotes (ppr hs_kind)) $+                 solveEqualities "tcLHsKindSig" $+                 tc_lhs_type mode hs_kind liftedTypeKind+       ; traceTc "tcLHsKindSig" (ppr hs_kind $$ ppr kind)+       -- No generalization:+       ; kindGeneralizeNone kind+       ; kind <- zonkTcType kind+         -- This zonk is very important in the case of higher rank kinds+         -- E.g. #13879    f :: forall (p :: forall z (y::z). <blah>).+         --                          <more blah>+         --      When instantiating p's kind at occurrences of p in <more blah>+         --      it's crucial that the kind we instantiate is fully zonked,+         --      else we may fail to substitute properly++       ; checkValidType ctxt kind+       ; traceTc "tcLHsKindSig2" (ppr kind)+       ; return kind }++promotionErr :: Name -> PromotionErr -> TcM a+promotionErr name err+  = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $+      (hang (pprPECategory err <+> quotes (ppr name) <+> text "cannot be used here")+                   2 (parens reason))+  where+    reason = case err of+               ConstrainedDataConPE pred+                              -> text "it has an unpromotable context"+                                 <+> quotes (ppr pred)+               FamDataConPE   -> text "it comes from a data family instance"+               NoDataKindsDC  -> text "perhaps you intended to use DataKinds"+               PatSynPE       -> text "pattern synonyms cannot be promoted"+               RecDataConPE   -> same_rec_group_msg+               ClassPE        -> same_rec_group_msg+               TyConPE        -> same_rec_group_msg++    same_rec_group_msg = text "it is defined and used in the same recursive group"++{-+************************************************************************+*                                                                      *+          Error messages and such+*                                                                      *+************************************************************************+-}+++-- | Make an appropriate message for an error in a function argument.+-- Used for both expressions and types.+funAppCtxt :: (Outputable fun, Outputable arg) => fun -> arg -> Int -> SDoc+funAppCtxt fun arg arg_no+  = hang (hsep [ text "In the", speakNth arg_no, text "argument of",                     quotes (ppr fun) <> text ", namely"])        2 (quotes (ppr arg))
GHC/Tc/Gen/Match.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP              #-}+ {-# LANGUAGE ConstraintKinds  #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes       #-}@@ -31,6 +31,7 @@    , tcBody    , tcDoStmt    , tcGuardStmt+   , checkPatCounts    ) where @@ -41,6 +42,7 @@                                        , tcCheckMonoExpr, tcCheckMonoExprNC                                        , tcCheckPolyExpr ) +import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Env import GHC.Tc.Gen.Pat@@ -48,6 +50,7 @@ import GHC.Tc.Utils.TcMType import GHC.Tc.Utils.TcType import GHC.Tc.Gen.Bind+import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic ) import GHC.Tc.Utils.Unify import GHC.Tc.Types.Origin import GHC.Tc.Types.Evidence@@ -68,6 +71,7 @@ import GHC.Utils.Misc import GHC.Driver.Session ( getDynFlags ) +import GHC.Types.Error import GHC.Types.Fixity (LexicalFixity(..)) import GHC.Types.Name import GHC.Types.Id@@ -76,8 +80,6 @@ import Control.Monad import Control.Arrow ( second ) -#include "HsVersions.h"- {- ************************************************************************ *                                                                      *@@ -91,12 +93,12 @@ same number of arguments before using @tcMatches@ to do the work. -} -tcMatchesFun :: LocatedN Name+tcMatchesFun :: LocatedN Id -- MatchContext Id              -> MatchGroup GhcRn (LHsExpr GhcRn)              -> ExpRhoType    -- Expected type of function              -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))                                 -- Returns type of body-tcMatchesFun fn@(L _ fun_name) matches exp_ty+tcMatchesFun fun_id matches exp_ty   = do  {  -- Check that they all have the same no of arguments            -- Location is in the monad, set the caller so that            -- any inter-equation error messages get some vaguely@@ -104,7 +106,9 @@            -- ann-grabbing, because we don't always have annotations in            -- hand when we call tcMatchesFun...           traceTc "tcMatchesFun" (ppr fun_name $$ ppr exp_ty)-        ; checkArgs fun_name matches+           -- We can't easily call checkPatCounts here because fun_id can be an+           -- unfilled thunk+        ; checkArgCounts fun_name matches          ; matchExpectedFunTys herald ctxt arity exp_ty $ \ pat_tys rhs_ty ->              -- NB: exp_type may be polymorphic, but@@ -118,12 +122,17 @@           -- a multiplicity argument, and scale accordingly.           tcMatches match_ctxt pat_tys rhs_ty matches }   where+    fun_name = idName (unLoc fun_id)     arity  = matchGroupArity matches-    herald = text "The equation(s) for"-             <+> quotes (ppr fun_name) <+> text "have"+    herald = ExpectedFunTyMatches (NameThing fun_name) matches     ctxt   = GenSigCtxt  -- Was: FunSigCtxt fun_name True                          -- But that's wrong for f :: Int -> forall a. blah-    what   = FunRhs { mc_fun = fn, mc_fixity = Prefix, mc_strictness = strictness }+    what   = FunRhs { mc_fun = fun_id, mc_fixity = Prefix, mc_strictness = strictness }+                    -- Careful: this fun_id could be an unfilled+                    -- thunk from fixM in tcMonoBinds, so we're+                    -- not allowed to look at it, except for+                    -- idName.+                    -- See Note [fixM for rhs_ty in tcMonoBinds]     match_ctxt = MC { mc_what = what, mc_body = tcBody }     strictness       | [L _ match] <- unLoc $ mg_alts matches@@ -138,10 +147,10 @@ -}  tcMatchesCase :: (AnnoBody body) =>-                TcMatchCtxt body                         -- Case context-             -> Scaled TcSigmaType                       -- Type of scrutinee-             -> MatchGroup GhcRn (LocatedA (body GhcRn)) -- The case alternatives-             -> ExpRhoType                    -- Type of whole case expressions+                TcMatchCtxt body      -- ^ Case context+             -> Scaled TcSigmaTypeFRR -- ^ Type of scrutinee+             -> MatchGroup GhcRn (LocatedA (body GhcRn)) -- ^ The case alternatives+             -> ExpRhoType                               -- ^ Type of the whole case expression              -> TcM (MatchGroup GhcTc (LocatedA (body GhcTc)))                 -- Translated alternatives                 -- wrapper goes from MatchGroup's ty to expected ty@@ -149,14 +158,16 @@ tcMatchesCase ctxt (Scaled scrut_mult scrut_ty) matches res_ty   = tcMatches ctxt [Scaled scrut_mult (mkCheckExpType scrut_ty)] res_ty matches -tcMatchLambda :: SDoc -- see Note [Herald for matchExpectedFunTys] in GHC.Tc.Utils.Unify+tcMatchLambda :: ExpectedFunTyOrigin -- see Note [Herald for matchExpectedFunTys] in GHC.Tc.Utils.Unify               -> TcMatchCtxt HsExpr               -> MatchGroup GhcRn (LHsExpr GhcRn)               -> ExpRhoType               -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc)) tcMatchLambda herald match_ctxt match res_ty-  = matchExpectedFunTys herald GenSigCtxt n_pats res_ty $ \ pat_tys rhs_ty ->-    tcMatches match_ctxt pat_tys rhs_ty match+  =  do { checkPatCounts (mc_what match_ctxt) match+        ; matchExpectedFunTys herald GenSigCtxt n_pats res_ty $ \ pat_tys rhs_ty -> do+            -- checking argument counts since this is also used for \cases+            tcMatches match_ctxt pat_tys rhs_ty match }   where     n_pats | isEmptyMatchGroup match = 1   -- must be lambda-case            | otherwise               = matchGroupArity match@@ -186,7 +197,7 @@ ********************************************************************* -}  data TcMatchCtxt body   -- c.f. TcStmtCtxt, also in this module-  = MC { mc_what :: HsMatchContext GhcRn,  -- What kind of thing this is+  = MC { mc_what :: HsMatchContext GhcTc,  -- What kind of thing this is          mc_body :: LocatedA (body GhcRn)  -- Type checker for a body of                                            -- an alternative                  -> ExpRhoType@@ -198,16 +209,16 @@     , Anno (Match GhcTc (LocatedA (body GhcTc))) ~ SrcSpanAnnA     , Anno [LocatedA (Match GhcRn (LocatedA (body GhcRn)))] ~ SrcSpanAnnL     , Anno [LocatedA (Match GhcTc (LocatedA (body GhcTc)))] ~ SrcSpanAnnL-    , Anno (GRHS GhcRn (LocatedA (body GhcRn))) ~ SrcSpan-    , Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcSpan+    , Anno (GRHS GhcRn (LocatedA (body GhcRn))) ~ SrcAnn NoEpAnns+    , Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcAnn NoEpAnns     , Anno (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))) ~ SrcSpanAnnA     , Anno (StmtLR GhcTc GhcTc (LocatedA (body GhcTc))) ~ SrcSpanAnnA     )  -- | Type-check a MatchGroup. tcMatches :: (AnnoBody body ) => TcMatchCtxt body-          -> [Scaled ExpSigmaType]      -- Expected pattern types-          -> ExpRhoType          -- Expected result-type of the Match.+          -> [Scaled ExpSigmaTypeFRR] -- ^ Expected pattern types.+          -> ExpRhoType               -- ^ Expected result-type of the Match.           -> MatchGroup GhcRn (LocatedA (body GhcRn))           -> TcM (MatchGroup GhcTc (LocatedA (body GhcTc))) @@ -274,7 +285,7 @@ tcGRHSs ctxt (GRHSs _ grhss binds) res_ty   = do  { (binds', ugrhss)             <- tcLocalBinds binds $-               mapM (tcCollectingUsage . wrapLocM (tcGRHS ctxt res_ty)) grhss+               mapM (tcCollectingUsage . wrapLocMA (tcGRHS ctxt res_ty)) grhss         ; let (usages, grhss') = unzip ugrhss         ; tcEmitBindingUsage $ supUEs usages         ; return (GRHSs emptyComments grhss' binds') }@@ -299,7 +310,7 @@ ************************************************************************ -} -tcDoStmts :: HsStmtContext GhcRn+tcDoStmts :: HsDoFlavour           -> LocatedL [LStmt GhcRn (LHsExpr GhcRn)]           -> ExpRhoType           -> TcM (HsExpr GhcTc)          -- Returns a HsDo@@ -307,26 +318,25 @@   = do  { res_ty <- expTypeToType res_ty         ; (co, elt_ty) <- matchExpectedListTy res_ty         ; let list_ty = mkListTy elt_ty-        ; stmts' <- tcStmts ListComp (tcLcStmt listTyCon) stmts+        ; stmts' <- tcStmts (HsDoStmt ListComp) (tcLcStmt listTyCon) stmts                             (mkCheckExpType elt_ty)         ; return $ mkHsWrapCo co (HsDo list_ty ListComp (L l stmts')) }  tcDoStmts doExpr@(DoExpr _) (L l stmts) res_ty-  = do  { stmts' <- tcStmts doExpr tcDoStmt stmts res_ty+  = do  { stmts' <- tcStmts (HsDoStmt doExpr) tcDoStmt stmts res_ty         ; res_ty <- readExpType res_ty         ; return (HsDo res_ty doExpr (L l stmts')) }  tcDoStmts mDoExpr@(MDoExpr _) (L l stmts) res_ty-  = do  { stmts' <- tcStmts mDoExpr tcDoStmt stmts res_ty+  = do  { stmts' <- tcStmts (HsDoStmt mDoExpr) tcDoStmt stmts res_ty         ; res_ty <- readExpType res_ty         ; return (HsDo res_ty mDoExpr (L l stmts')) }  tcDoStmts MonadComp (L l stmts) res_ty-  = do  { stmts' <- tcStmts MonadComp tcMcStmt stmts res_ty+  = do  { stmts' <- tcStmts (HsDoStmt MonadComp) tcMcStmt stmts res_ty         ; res_ty <- readExpType res_ty         ; return (HsDo res_ty MonadComp (L l stmts')) }--tcDoStmts ctxt _ _ = pprPanic "tcDoStmts" (pprStmtContext ctxt)+tcDoStmts ctxt@GhciStmtCtxt _ _ = pprPanic "tcDoStmts" (pprHsDoFlavour ctxt)  tcBody :: LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc) tcBody body res_ty@@ -346,13 +356,13 @@ type TcCmdStmtChecker  = TcStmtChecker HsCmd  TcRhoType  type TcStmtChecker body rho_type-  =  forall thing. HsStmtContext GhcRn+  =  forall thing. HsStmtContext GhcTc                 -> Stmt GhcRn (LocatedA (body GhcRn))                 -> rho_type                 -- Result type for comprehension                 -> (rho_type -> TcM thing)  -- Checker for what follows the stmt                 -> TcM (Stmt GhcTc (LocatedA (body GhcTc)), thing) -tcStmts :: (AnnoBody body) => HsStmtContext GhcRn+tcStmts :: (AnnoBody body) => HsStmtContext GhcTc         -> TcStmtChecker body rho_type   -- NB: higher-rank type         -> [LStmt GhcRn (LocatedA (body GhcRn))]         -> rho_type@@ -362,7 +372,7 @@                         const (return ())        ; return stmts' } -tcStmtsAndThen :: (AnnoBody body) => HsStmtContext GhcRn+tcStmtsAndThen :: (AnnoBody body) => HsStmtContext GhcTc                -> TcStmtChecker body rho_type    -- NB: higher-rank type                -> [LStmt GhcRn (LocatedA (body GhcRn))]                -> rho_type@@ -426,6 +436,7 @@           -- two multiplicity to still be the same.           (rhs', rhs_ty) <- tcScalingUsage Many $ tcInferRhoNC rhs                                    -- Stmt has a context already+        ; hasFixedRuntimeRep_syntactic FRRBindStmtGuard rhs_ty         ; (pat', thing)  <- tcCheckPat_O (StmtCtxt ctxt) (lexprCtOrigin rhs)                                          pat (unrestricted rhs_ty) $                             thing_inside res_ty@@ -578,15 +589,17 @@  tcMcStmt ctxt (BindStmt xbsrn pat rhs) res_ty thing_inside            -- (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty-  = do  { ((rhs', pat_mult, pat', thing, new_res_ty), bind_op')+  = do  { ((rhs_ty, rhs', pat_mult, pat', thing, new_res_ty), bind_op')             <- tcSyntaxOp MCompOrigin (xbsrn_bindOp xbsrn)                           [SynRho, SynFun SynAny SynRho] res_ty $                \ [rhs_ty, pat_ty, new_res_ty] [rhs_mult, fun_mult, pat_mult] ->                do { rhs' <- tcScalingUsage rhs_mult $ tcCheckMonoExprNC rhs rhs_ty                   ; (pat', thing) <- tcScalingUsage fun_mult $ tcCheckPat (StmtCtxt ctxt) pat (Scaled pat_mult pat_ty) $                                      thing_inside (mkCheckExpType new_res_ty)-                  ; return (rhs', pat_mult, pat', thing, new_res_ty) }+                  ; return (rhs_ty, rhs', pat_mult, pat', thing, new_res_ty) } +        ; hasFixedRuntimeRep_syntactic (FRRBindStmt MonadComprehension) rhs_ty+         -- If (but only if) the pattern can fail, typecheck the 'fail' operator         ; fail_op' <- fmap join . forM (xbsrn_failOp xbsrn) $ \fail ->             tcMonadFailOp (MCompPatOrigin pat) pat' fail new_res_ty@@ -608,17 +621,23 @@           --    guard_op :: test_ty -> rhs_ty           --    then_op  :: rhs_ty -> new_res_ty -> res_ty           -- Where test_ty is, for example, Bool-        ; ((thing, rhs', rhs_ty, guard_op'), then_op')+        ; ((thing, rhs', rhs_ty, new_res_ty, test_ty, guard_op'), then_op')             <- tcSyntaxOp MCompOrigin then_op [SynRho, SynRho] res_ty $                \ [rhs_ty, new_res_ty] [rhs_mult, fun_mult] ->-               do { (rhs', guard_op')+               do { ((rhs', test_ty), guard_op')                       <- tcScalingUsage rhs_mult $                          tcSyntaxOp MCompOrigin guard_op [SynAny]                                     (mkCheckExpType rhs_ty) $-                         \ [test_ty] [test_mult] ->-                         tcScalingUsage test_mult $ tcCheckMonoExpr rhs test_ty+                         \ [test_ty] [test_mult] -> do+                           rhs' <- tcScalingUsage test_mult $ tcCheckMonoExpr rhs test_ty+                           return $ (rhs', test_ty)                   ; thing <- tcScalingUsage fun_mult $ thing_inside (mkCheckExpType new_res_ty)-                  ; return (thing, rhs', rhs_ty, guard_op') }+                  ; return (thing, rhs', rhs_ty, new_res_ty, test_ty, guard_op') }++        ; hasFixedRuntimeRep_syntactic FRRBodyStmtGuard test_ty+        ; hasFixedRuntimeRep_syntactic (FRRBodyStmt MonadComprehension 1) rhs_ty+        ; hasFixedRuntimeRep_syntactic (FRRBodyStmt MonadComprehension 2) new_res_ty+         ; return (BodyStmt rhs_ty rhs' then_op' guard_op', thing) }  -- Grouping statements@@ -845,14 +864,16 @@                 -- This level of generality is needed for using do-notation                 -- in full generality; see #1537 -          ((rhs', pat_mult, pat', new_res_ty, thing), bind_op')+          ((rhs_ty, rhs', pat_mult, pat', new_res_ty, thing), bind_op')             <- tcSyntaxOp DoOrigin (xbsrn_bindOp xbsrn) [SynRho, SynFun SynAny SynRho] res_ty $                 \ [rhs_ty, pat_ty, new_res_ty] [rhs_mult,fun_mult,pat_mult] ->                 do { rhs' <-tcScalingUsage rhs_mult $ tcCheckMonoExprNC rhs rhs_ty                    ; (pat', thing) <- tcScalingUsage fun_mult $ tcCheckPat (StmtCtxt ctxt) pat (Scaled pat_mult pat_ty) $                                       thing_inside (mkCheckExpType new_res_ty)-                   ; return (rhs', pat_mult, pat', new_res_ty, thing) }+                   ; return (rhs_ty, rhs', pat_mult, pat', new_res_ty, thing) } +        ; hasFixedRuntimeRep_syntactic (FRRBindStmt DoNotation) rhs_ty+         -- If (but only if) the pattern can fail, typecheck the 'fail' operator         ; fail_op' <- fmap join . forM (xbsrn_failOp xbsrn) $ \fail ->             tcMonadFailOp (DoPatOrigin pat) pat' fail new_res_ty@@ -879,12 +900,14 @@ tcDoStmt _ (BodyStmt _ rhs then_op _) res_ty thing_inside   = do  {       -- Deal with rebindable syntax;                 --   (>>) :: rhs_ty -> new_res_ty -> res_ty-        ; ((rhs', rhs_ty, thing), then_op')+        ; ((rhs', rhs_ty, new_res_ty, thing), then_op')             <- tcSyntaxOp DoOrigin then_op [SynRho, SynRho] res_ty $                \ [rhs_ty, new_res_ty] [rhs_mult,fun_mult] ->                do { rhs' <- tcScalingUsage rhs_mult $ tcCheckMonoExprNC rhs rhs_ty                   ; thing <- tcScalingUsage fun_mult $ thing_inside (mkCheckExpType new_res_ty)-                  ; return (rhs', rhs_ty, thing) }+                  ; return (rhs', rhs_ty, new_res_ty, thing) }+        ; hasFixedRuntimeRep_syntactic (FRRBodyStmt DoNotation 1) rhs_ty+        ; hasFixedRuntimeRep_syntactic (FRRBodyStmt DoNotation 2) new_res_ty         ; return (BodyStmt rhs_ty rhs' then_op' noSyntaxExpr, thing) }  tcDoStmt ctxt (RecStmt { recS_stmts = L l stmts, recS_later_ids = later_names@@ -1000,7 +1023,7 @@ -}  tcApplicativeStmts-  :: HsStmtContext GhcRn+  :: HsStmtContext GhcTc   -> [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]   -> ExpRhoType                         -- rhs_ty   -> (TcRhoType -> TcM t)               -- thing_inside@@ -1068,10 +1091,10 @@      goArg _body_ty (ApplicativeArgMany x stmts ret pat ctxt, pat_ty, exp_ty)       = do { (stmts', (ret',pat')) <--                tcStmtsAndThen ctxt tcDoStmt stmts (mkCheckExpType exp_ty) $+                tcStmtsAndThen (HsDoStmt ctxt) tcDoStmt stmts (mkCheckExpType exp_ty) $                 \res_ty  -> do                   { ret'      <- tcExpr ret res_ty-                  ; (pat', _) <- tcCheckPat (StmtCtxt ctxt) pat (unrestricted pat_ty) $+                  ; (pat', _) <- tcCheckPat (StmtCtxt (HsDoStmt ctxt)) pat (unrestricted pat_ty) $                                  return ()                   ; return (ret', pat')                   }@@ -1114,22 +1137,35 @@ *                                                                      * ************************************************************************ -@sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same+@checkArgCounts@ takes a @[RenamedMatch]@ and decides whether the same number of args are used in each equation. -} -checkArgs :: AnnoBody body-          => Name -> MatchGroup GhcRn (LocatedA (body GhcRn)) -> TcM ()-checkArgs _ (MG { mg_alts = L _ [] })+checkArgCounts :: AnnoBody body+               => Name -> MatchGroup GhcRn (LocatedA (body GhcRn)) -> TcM ()+checkArgCounts = check_match_pats . (text "Equations for" <+>) . quotes . ppr++-- @checkPatCounts@ takes a @[RenamedMatch]@ and decides whether the same+-- number of patterns are used in each alternative+checkPatCounts :: AnnoBody body+               => HsMatchContext GhcTc -> MatchGroup GhcRn (LocatedA (body GhcRn))+               -> TcM ()+checkPatCounts = check_match_pats . pprMatchContextNouns++check_match_pats :: AnnoBody body+                 => SDoc -> MatchGroup GhcRn (LocatedA (body GhcRn))+                 -> TcM ()+check_match_pats _ (MG { mg_alts = L _ [] })     = return ()-checkArgs fun (MG { mg_alts = L _ (match1:matches) })+check_match_pats err_msg (MG { mg_alts = L _ (match1:matches) })     | null bad_matches     = return ()     | otherwise-    = failWithTc (vcat [ text "Equations for" <+> quotes (ppr fun) <+>-                         text "have different numbers of arguments"-                       , nest 2 (ppr (getLocA match1))-                       , nest 2 (ppr (getLocA (head bad_matches)))])+    = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $+      (vcat [ err_msg <+>+              text "have different numbers of arguments"+            , nest 2 (ppr (getLocA match1))+            , nest 2 (ppr (getLocA (head bad_matches)))])   where     n_args1 = args_in_match match1     bad_matches = [m | m <- matches, args_in_match m /= n_args1]
GHC/Tc/Gen/Match.hs-boot view
@@ -1,17 +1,17 @@ module GHC.Tc.Gen.Match where import GHC.Hs           ( GRHSs, MatchGroup, LHsExpr ) import GHC.Tc.Types.Evidence  ( HsWrapper )-import GHC.Types.Name   ( Name ) import GHC.Tc.Utils.TcType( ExpSigmaType, ExpRhoType ) import GHC.Tc.Types     ( TcM ) import GHC.Hs.Extension ( GhcRn, GhcTc ) import GHC.Parser.Annotation ( LocatedN )+import GHC.Types.Id (Id)  tcGRHSsPat    :: GRHSs GhcRn (LHsExpr GhcRn)               -> ExpRhoType               -> TcM (GRHSs GhcTc (LHsExpr GhcTc)) -tcMatchesFun :: LocatedN Name+tcMatchesFun :: LocatedN Id              -> MatchGroup GhcRn (LHsExpr GhcRn)              -> ExpSigmaType              -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
GHC/Tc/Gen/Pat.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-}@@ -21,28 +21,29 @@    , tcCheckPat, tcCheckPat_O, tcInferPat    , tcPats    , addDataConStupidTheta-   , badFieldCon    , polyPatSig    ) where -#include "HsVersions.h"- import GHC.Prelude  import {-# SOURCE #-}   GHC.Tc.Gen.Expr( tcSyntaxOp, tcSyntaxOpGen, tcInferRho )  import GHC.Hs+import GHC.Hs.Syn.Type import GHC.Rename.Utils+import GHC.Tc.Errors.Types import GHC.Tc.Utils.Zonk import GHC.Tc.Gen.Sig( TcPragEnv, lookupPragEnv, addInlinePrags ) import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Instantiate+import GHC.Types.Error import GHC.Types.Id import GHC.Types.Var import GHC.Types.Name import GHC.Types.Name.Reader import GHC.Core.Multiplicity+import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic ) import GHC.Tc.Utils.Env import GHC.Tc.Utils.TcMType import GHC.Tc.Validity( arityErr )@@ -66,6 +67,7 @@ import GHC.Utils.Misc import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import qualified GHC.LanguageExtensions as LangExt import Control.Arrow  ( second ) import Control.Monad@@ -81,7 +83,7 @@  tcLetPat :: (Name -> Maybe TcId)          -> LetBndrSpec-         -> LPat GhcRn -> Scaled ExpSigmaType+         -> LPat GhcRn -> Scaled ExpSigmaTypeFRR          -> TcM a          -> TcM (LPat GhcTc, a) tcLetPat sig_fn no_gen pat pat_ty thing_inside@@ -96,10 +98,10 @@        ; tc_lpat pat_ty penv pat thing_inside }  ------------------tcPats :: HsMatchContext GhcRn-       -> [LPat GhcRn]            -- Patterns,-       -> [Scaled ExpSigmaType]         --   and their types-       -> TcM a                  --   and the checker for the body+tcPats :: HsMatchContext GhcTc+       -> [LPat GhcRn]             -- ^ atterns+       -> [Scaled ExpSigmaTypeFRR] -- ^ types of the patterns+       -> TcM a                    -- ^ checker for the body        -> TcM ([LPat GhcTc], a)  -- This is the externally-callable wrapper function@@ -118,25 +120,27 @@   where     penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt, pe_orig = PatOrigin } -tcInferPat :: HsMatchContext GhcRn -> LPat GhcRn+tcInferPat :: FixedRuntimeRepContext+           -> HsMatchContext GhcTc+           -> LPat GhcRn            -> TcM a-           -> TcM ((LPat GhcTc, a), TcSigmaType)-tcInferPat ctxt pat thing_inside-  = tcInfer $ \ exp_ty ->+           -> TcM ((LPat GhcTc, a), TcSigmaTypeFRR)+tcInferPat frr_orig ctxt pat thing_inside+  = tcInferFRR frr_orig $ \ exp_ty ->     tc_lpat (unrestricted exp_ty) penv pat thing_inside  where     penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt, pe_orig = PatOrigin } -tcCheckPat :: HsMatchContext GhcRn-           -> LPat GhcRn -> Scaled TcSigmaType+tcCheckPat :: HsMatchContext GhcTc+           -> LPat GhcRn -> Scaled TcSigmaTypeFRR            -> TcM a                     -- Checker for body            -> TcM (LPat GhcTc, a) tcCheckPat ctxt = tcCheckPat_O ctxt PatOrigin  -- | A variant of 'tcPat' that takes a custom origin-tcCheckPat_O :: HsMatchContext GhcRn+tcCheckPat_O :: HsMatchContext GhcTc              -> CtOrigin              -- ^ origin to use if the type needs inst'ing-             -> LPat GhcRn -> Scaled TcSigmaType+             -> LPat GhcRn -> Scaled TcSigmaTypeFRR              -> TcM a                 -- Checker for body              -> TcM (LPat GhcTc, a) tcCheckPat_O ctxt orig pat (Scaled pat_mult pat_ty) thing_inside@@ -161,7 +165,7 @@  data PatCtxt   = LamPat   -- Used for lambdas, case etc-       (HsMatchContext GhcRn)+       (HsMatchContext GhcTc)    | LetPat   -- Used only for let(rec) pattern bindings              -- See Note [Typing patterns in pattern bindings]@@ -202,7 +206,7 @@ *                                                                      * ********************************************************************* -} -tcPatBndr :: PatEnv -> Name -> Scaled ExpSigmaType -> TcM (HsWrapper, TcId)+tcPatBndr :: PatEnv -> Name -> Scaled ExpSigmaTypeFRR -> TcM (HsWrapper, TcId) -- (coi, xp) = tcPatBndr penv x pat_ty -- Then coi : pat_ty ~ typeof(xp) --@@ -222,7 +226,7 @@   | otherwise                          -- No signature   = do { (co, bndr_ty) <- case scaledThing exp_pat_ty of              Check pat_ty    -> promoteTcType bind_lvl pat_ty-             Infer infer_res -> ASSERT( bind_lvl == ir_lvl infer_res )+             Infer infer_res -> assert (bind_lvl == ir_lvl infer_res) $                                 -- If we were under a constructor that bumped the                                 -- level, we'd be in checking mode (see tcConArg)                                 -- hence this assertion@@ -322,14 +326,14 @@                                    setErrCtxt err_ctxt $                                    loop penv args                 -- setErrCtxt: restore context before doing the next pattern-                -- See note [Nesting] above+                -- See Note [Nesting] above                       ; return (p':ps', res) }          ; loop penv args }  ---------------------tc_lpat :: Scaled ExpSigmaType+tc_lpat :: Scaled ExpSigmaTypeFRR         -> Checker (LPat GhcRn) (LPat GhcTc) tc_lpat pat_ty penv (L span pat) thing_inside   = setSrcSpanA span $@@ -337,10 +341,10 @@                                           thing_inside         ; return (L span pat', res) } -tc_lpats :: [Scaled ExpSigmaType]+tc_lpats :: [Scaled ExpSigmaTypeFRR]          -> Checker [LPat GhcRn] [LPat GhcTc] tc_lpats tys penv pats-  = ASSERT2( equalLength pats tys, ppr pats $$ ppr tys )+  = assertPpr (equalLength pats tys) (ppr pats $$ ppr tys) $     tcMultiple (\ penv' (p,t) -> tc_lpat t penv' p)                penv                (zipEqual "tc_lpats" pats tys)@@ -350,7 +354,7 @@ checkManyPattern :: Scaled a -> TcM HsWrapper checkManyPattern pat_ty = tcSubMult NonLinearPatternOrigin Many (scaledMult pat_ty) -tc_pat  :: Scaled ExpSigmaType+tc_pat  :: Scaled ExpSigmaTypeFRR         -- ^ Fully refined result type         -> Checker (Pat GhcRn) (Pat GhcTc)         -- ^ Translated pattern@@ -365,9 +369,9 @@         ; pat_ty <- readExpType (scaledThing pat_ty)         ; return (mkHsWrapPat (wrap <.> mult_wrap) (VarPat x (L l id)) pat_ty, res) } -  ParPat x pat -> do+  ParPat x lpar pat rpar -> do         { (pat', res) <- tc_lpat pat_ty penv pat thing_inside-        ; return (ParPat x pat', res) }+        ; return (ParPat x lpar pat' rpar, res) }    BangPat x pat -> do         { (pat', res) <- tc_lpat pat_ty penv pat thing_inside@@ -428,9 +432,9 @@                -- Note [View patterns and polymorphism]           -- Expression must be a function-        ; let herald = text "A view pattern expression expects"+        ; let herald = ExpectedFunTyViewPat $ unLoc expr         ; (expr_wrap1, Scaled _mult inf_arg_ty, inf_res_sigma)-            <- matchActualFunTySigma herald (Just (ppr expr)) (1,[]) expr_ty+            <- matchActualFunTySigma herald (Just . HsExprRnThing $ unLoc expr) (1,[]) expr_ty                -- See Note [View patterns and polymorphism]                -- expr_wrap1 :: expr_ty "->" (inf_arg_ty -> inf_res_sigma) @@ -444,13 +448,16 @@         ; let Scaled w h_pat_ty = pat_ty         ; pat_ty <- readExpType h_pat_ty         ; let expr_wrap2' = mkWpFun expr_wrap2 idHsWrapper-                                    (Scaled w pat_ty) inf_res_sigma doc-               -- expr_wrap2' :: (inf_arg_ty -> inf_res_sigma) "->"-               --                (pat_ty -> inf_res_sigma)+                              (Scaled w pat_ty) inf_res_sigma+          -- expr_wrap2' :: (inf_arg_ty -> inf_res_sigma) "->"+          --                (pat_ty -> inf_res_sigma)+          -- NB: pat_ty comes from matchActualFunTySigma, so it has a+          -- fixed RuntimeRep, as needed to call mkWpFun.+        ; let               expr_wrap = expr_wrap2' <.> expr_wrap1 <.> mult_wrap-              doc = text "When checking the view pattern function:" <+> (ppr expr)-        ; return (ViewPat pat_ty (mkLHsWrap expr_wrap expr') pat', res)} +        ; return $ (ViewPat pat_ty (mkLHsWrap expr_wrap expr') pat', res) }+ {- Note [View patterns and polymorphism] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider this exotic example:@@ -466,7 +473,7 @@  Then, when taking that arrow apart we want to get a *sigma* type (forall b. b->(Int,b)), because that's what we want to bind 'x' to.-Fortunately that's what matchExpectedFunTySigma returns anyway.+Fortunately that's what matchActualFunTySigma returns anyway. -}  -- Type signatures in patterns@@ -486,25 +493,16 @@  ------------------------ -- Lists, tuples, arrays-  ListPat Nothing pats -> do++  -- Necessarily a built-in list pattern, not an overloaded list pattern.+  -- See Note [Desugaring overloaded list patterns].+  ListPat _ pats -> do         { (coi, elt_ty) <- matchExpectedPatTy matchExpectedListTy penv (scaledThing pat_ty)         ; (pats', res) <- tcMultiple (tc_lpat (pat_ty `scaledSet` mkCheckExpType elt_ty))                                      penv pats thing_inside         ; pat_ty <- readExpType (scaledThing pat_ty)         ; return (mkHsWrapPat coi-                         (ListPat (ListPatTc elt_ty Nothing) pats') pat_ty, res)-}--  ListPat (Just e) pats -> do-        { tau_pat_ty <- expTypeToType (scaledThing pat_ty)-        ; ((pats', res, elt_ty), e')-            <- tcSyntaxOpGen ListOrigin e [SynType (mkCheckExpType tau_pat_ty)]-                                          SynList $-                 \ [elt_ty] _ ->-                 do { (pats', res) <- tcMultiple (tc_lpat (pat_ty `scaledSet` mkCheckExpType elt_ty))-                                                 penv pats thing_inside-                    ; return (pats', res, elt_ty) }-        ; return (ListPat (ListPatTc elt_ty (Just (tau_pat_ty,e'))) pats', res)+                         (ListPat elt_ty pats') pat_ty, res) }    TuplePat _ pats boxity -> do@@ -537,8 +535,8 @@                 | otherwise        = unmangled_result          ; pat_ty <- readExpType (scaledThing pat_ty)-        ; ASSERT( con_arg_tys `equalLength` pats ) -- Syntactically enforced-          return (mkHsWrapPat coi possibly_mangled_result pat_ty, res)+        ; massert (con_arg_tys `equalLength` pats) -- Syntactically enforced+        ; return (mkHsWrapPat coi possibly_mangled_result pat_ty, res)         }    SumPat _ pat alt arity  -> do@@ -662,6 +660,7 @@                   ; return (lit2', wrap, bndr_id) }          ; pat_ty <- readExpType pat_exp_ty+         -- The Report says that n+k patterns must be in Integral         -- but it's silly to insist on this in the RebindableSyntax case         ; unlessM (xoptM LangExt.RebindableSyntax) $@@ -696,6 +695,9 @@       ; tc_pat pat_ty penv pat thing_inside }     _ -> panic "invalid splice in splice pat" +  XPat (HsPatExpanded lpat rpat) -> do+    { (rpat', res) <- tc_pat pat_ty penv rpat thing_inside+    ; return (XPat $ ExpansionPat lpat rpat', res) }  {- Note [Hopping the LIE in lazy patterns]@@ -774,9 +776,10 @@                                           2 (ppr res_ty)) ]             ; return (tidy_env, msg) } -patBindSigErr :: [(Name,TcTyVar)] -> SDoc+patBindSigErr :: [(Name,TcTyVar)] -> TcRnMessage patBindSigErr sig_tvs-  = hang (text "You cannot bind scoped type variable" <> plural sig_tvs+  = TcRnUnknownMessage $ mkPlainError noHints $+    hang (text "You cannot bind scoped type variable" <> plural sig_tvs           <+> pprQuotedList (map fst sig_tvs))        2 (text "in a pattern binding signature") @@ -856,7 +859,7 @@ --       with scrutinee of type (T ty)  tcConPat :: PatEnv -> LocatedN Name-         -> Scaled ExpSigmaType    -- Type of the pattern+         -> Scaled ExpSigmaTypeFRR    -- Type of the pattern          -> HsConPatDetails GhcRn -> TcM a          -> TcM (Pat GhcTc, a) tcConPat penv con_lname@(L _ con_name) pat_ty arg_pats thing_inside@@ -868,8 +871,21 @@                                              pat_ty arg_pats thing_inside         } +-- Warn when pattern matching on a GADT or a pattern synonym+-- when MonoLocalBinds is off.+warnMonoLocalBinds :: TcM ()+warnMonoLocalBinds+  = do { mono_local_binds <- xoptM LangExt.MonoLocalBinds+       ; unless mono_local_binds $+           addDiagnostic TcRnGADTMonoLocalBinds+           -- We used to require the GADTs or TypeFamilies extension+           -- to pattern match on a GADT (#2905, #7156)+           --+           -- In #20485 this was made into a warning.+       }+ tcDataConPat :: PatEnv -> LocatedN Name -> DataCon-             -> Scaled ExpSigmaType        -- Type of the pattern+             -> Scaled ExpSigmaTypeFRR        -- Type of the pattern              -> HsConPatDetails GhcRn -> TcM a              -> TcM (Pat GhcTc, a) tcDataConPat penv (L con_span con_name) data_con pat_ty_scaled@@ -899,25 +915,42 @@                   -- We want to create a well-kinded substitution, so                   -- that the instantiated type is well-kinded -        ; (tenv, ex_tvs') <- tcInstSuperSkolTyVarsX tenv1 ex_tvs+        ; let mc = case pe_ctxt penv of+                     LamPat mc -> mc+                     LetPat {} -> PatBindRhs+        ; skol_info <- mkSkolemInfo (PatSkol (RealDataCon data_con) mc)+        ; (tenv, ex_tvs') <- tcInstSuperSkolTyVarsX skol_info tenv1 ex_tvs                      -- Get location from monad, not from ex_tvs                      -- This freshens: See Note [Freshen existentials]-                     -- Why "super"? See Note [Binding when lookup up instances]+                     -- Why "super"? See Note [Binding when looking up instances]                      -- in GHC.Core.InstEnv.          ; let arg_tys' = substScaledTys tenv arg_tys               pat_mult = scaledMult pat_ty_scaled               arg_tys_scaled = map (scaleScaled pat_mult) arg_tys' -        ; traceTc "tcConPat" (vcat [ ppr con_name-                                   , pprTyVars univ_tvs-                                   , pprTyVars ex_tvs-                                   , ppr eq_spec-                                   , ppr theta-                                   , pprTyVars ex_tvs'-                                   , ppr ctxt_res_tys-                                   , ppr arg_tys'-                                   , ppr arg_pats ])+        -- This check is necessary to uphold the invariant that 'tcConArgs'+        -- is given argument types with a fixed runtime representation.+        -- See test case T20363.+        ; zipWithM_+            ( \ i arg_sty ->+              hasFixedRuntimeRep_syntactic+                (FRRDataConArg Pattern data_con i)+                (scaledThing arg_sty)+            )+            [1..]+            arg_tys'++        ; traceTc "tcConPat" (vcat [ text "con_name:" <+> ppr con_name+                                   , text "univ_tvs:" <+> pprTyVars univ_tvs+                                   , text "ex_tvs:" <+> pprTyVars ex_tvs+                                   , text "eq_spec:" <+> ppr eq_spec+                                   , text "theta:" <+> ppr theta+                                   , text "ex_tvs':" <+> pprTyVars ex_tvs'+                                   , text "ctxt_res_tys:" <+> ppr ctxt_res_tys+                                   , text "pat_ty:" <+> ppr pat_ty+                                   , text "arg_tys':" <+> ppr arg_tys'+                                   , text "arg_pats" <+> ppr arg_pats ])         ; if null ex_tvs && null eq_spec && null theta           then do { -- The common case; no class bindings etc                     -- (see Note [Arrows and patterns])@@ -940,24 +973,12 @@         { let theta'     = substTheta tenv (eqSpecPreds eq_spec ++ theta)                            -- order is *important* as we generate the list of                            -- dictionary binders from theta'-              no_equalities = null eq_spec && not (any isEqPred theta)-              skol_info = PatSkol (RealDataCon data_con) mc-              mc = case pe_ctxt penv of-                     LamPat mc -> mc-                     LetPat {} -> PatBindRhs -        ; gadts_on    <- xoptM LangExt.GADTs-        ; families_on <- xoptM LangExt.TypeFamilies-        ; checkTc (no_equalities || gadts_on || families_on)-                  (text "A pattern match on a GADT requires the" <+>-                   text "GADTs or TypeFamilies language extension")-                  -- #2905 decided that a *pattern-match* of a GADT-                  -- should require the GADT language flag.-                  -- Re TypeFamilies see also #7156+        ; when (not (null eq_spec) || any isEqPred theta) warnMonoLocalBinds          ; given <- newEvVars theta'         ; (ev_binds, (arg_pats', res))-             <- checkConstraints skol_info ex_tvs' given $+             <- checkConstraints (getSkolemInfo skol_info) ex_tvs' given $                 tcConArgs (RealDataCon data_con) arg_tys_scaled tenv penv arg_pats thing_inside          ; let res_pat = ConPat@@ -975,7 +996,7 @@         } }  tcPatSynPat :: PatEnv -> LocatedN Name -> PatSyn-            -> Scaled ExpSigmaType         -- Type of the pattern+            -> Scaled ExpSigmaType         -- ^ Type of the pattern             -> HsConPatDetails GhcRn -> TcM a             -> TcM (Pat GhcTc, a) tcPatSynPat penv (L con_span con_name) pat_syn pat_ty arg_pats thing_inside@@ -988,7 +1009,11 @@         ; let all_arg_tys = ty : prov_theta ++ (map scaledThing arg_tys)         ; checkGADT (PatSynCon pat_syn) ex_tvs all_arg_tys penv -        ; (tenv, ex_tvs') <- tcInstSuperSkolTyVarsX subst ex_tvs+        ; skol_info <- case pe_ctxt penv of+                            LamPat mc -> mkSkolemInfo (PatSkol (PatSynCon pat_syn) mc)+                            LetPat {} -> return unkSkol -- Doesn't matter++        ; (tenv, ex_tvs') <- tcInstSuperSkolTyVarsX skol_info subst ex_tvs            -- This freshens: Note [Freshen existentials]          ; let ty'         = substTy tenv ty@@ -998,6 +1023,8 @@               prov_theta' = substTheta tenv prov_theta               req_theta'  = substTheta tenv req_theta +        ; when (any isEqPred prov_theta) warnMonoLocalBinds+         ; mult_wrap <- checkManyPattern pat_ty             -- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify. @@ -1012,18 +1039,28 @@          ; prov_dicts' <- newEvVars prov_theta' -        ; let skol_info = case pe_ctxt penv of-                            LamPat mc -> PatSkol (PatSynCon pat_syn) mc-                            LetPat {} -> UnkSkol -- Doesn't matter          ; req_wrap <- instCall (OccurrenceOf con_name) (mkTyVarTys univ_tvs') req_theta'                       -- Origin (OccurrenceOf con_name):                       -- see Note [Call-stack tracing of pattern synonyms]         ; traceTc "instCall" (ppr req_wrap) +          -- Pattern synonyms can never have representation-polymorphic argument types,+          -- as checked in 'GHC.Tc.Gen.Sig.tcPatSynSig' (see use of 'FixedRuntimeRepPatSynSigArg')+          -- and 'GHC.Tc.TyCl.PatSyn.tcInferPatSynDecl'.+          -- (If you want to lift this restriction, use 'hasFixedRuntimeRep' here, to match+          -- 'tcDataConPat'.)+        ; let+            bad_arg_tys :: [(Int, Scaled Type)]+            bad_arg_tys = filter (\ (_, Scaled _ arg_ty) -> typeLevity_maybe arg_ty == Nothing)+                        $ zip [0..] arg_tys'+        ; massertPpr (null bad_arg_tys) $+            vcat [ text "tcPatSynPat: pattern arguments do not have a fixed RuntimeRep"+                 , text "bad_arg_tys:" <+> ppr bad_arg_tys ]+         ; traceTc "checkConstraints {" Outputable.empty         ; (ev_binds, (arg_pats', res))-             <- checkConstraints skol_info ex_tvs' prov_dicts' $+             <- checkConstraints (getSkolemInfo skol_info) ex_tvs' prov_dicts' $                 tcConArgs (PatSynCon pat_syn) arg_tys_scaled tenv penv arg_pats thing_inside          ; traceTc "checkConstraints }" (ppr ev_binds)@@ -1061,12 +1098,12 @@ whose Origin is (OccurrenceOf f).  See also Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence-and Note [Solving CallStack constraints] in GHC.Tc.Solver.Monad+and Note [Solving CallStack constraints] in GHC.Tc.Solver.Types -} ---------------------------- -- | Convenient wrapper for calling a matchExpectedXXX function matchExpectedPatTy :: (TcRhoType -> TcM (TcCoercionN, a))-                    -> PatEnv -> ExpSigmaType -> TcM (HsWrapper, a)+                    -> PatEnv -> ExpSigmaTypeFRR -> TcM (HsWrapper, a) -- See Note [Matching polytyped patterns] -- Returns a wrapper : pat_ty ~R inner_ty matchExpectedPatTy inner_match (PE { pe_orig = orig }) pat_ty@@ -1078,13 +1115,14 @@  ---------------------------- matchExpectedConTy :: PatEnv-                   -> TyCon      -- The TyCon that this data-                                 -- constructor actually returns-                                 -- In the case of a data family this is-                                 -- the /representation/ TyCon-                   -> Scaled ExpSigmaType  -- The type of the pattern; in the-                                           -- case of a data family this would-                                           -- mention the /family/ TyCon+                   -> TyCon+                       -- ^ The TyCon that this data constructor actually returns.+                       -- In the case of a data family, this is+                       -- the /representation/ TyCon.+                   -> Scaled ExpSigmaTypeFRR+                       -- ^ The type of the pattern.+                       -- In the case of a data family, this would+                       -- mention the /family/ TyCon                    -> TcM (HsWrapper, [TcSigmaType]) -- See Note [Matching constructor patterns] -- Returns a wrapper : pat_ty "->" T ty1 ... tyn@@ -1182,8 +1220,8 @@   these unifications.  The *only* thing the unification does is   to side-effect those unification variables, so that we know   what type x and y stand for; and cause an error if the equality-  is not soluble.  It's a bit like a Derived constraint arising-  from a functional dependency.+  is not soluble.  It's a bit like a constraint arising+  from a functional dependency, where we don't use the evidence.  * Exactly the same works for existential arguments      data T where@@ -1205,7 +1243,7 @@ -}  tcConArgs :: ConLike-          -> [Scaled TcSigmaType]+          -> [Scaled TcSigmaTypeFRR]           -> TCvSubst            -- Instantiating substitution for constructor type           -> Checker (HsConPatDetails GhcRn) (HsConPatDetails GhcTc) tcConArgs con_like arg_tys tenv penv con_args thing_inside = case con_args of@@ -1213,9 +1251,11 @@         { checkTc (con_arity == no_of_args)     -- Check correct arity                   (arityErr (text "constructor") con_like con_arity no_of_args) -        ; let con_binders = conLikeUserTyVarBinders con_like-        ; checkTc (type_args `leLength` con_binders)-                  (conTyArgArityErr con_like (length con_binders) (length type_args))+              -- forgetting to filter out inferred binders led to #20443+        ; let con_spec_binders = filter ((== SpecifiedSpec) . binderArgFlag) $+                                 conLikeUserTyVarBinders con_like+        ; checkTc (type_args `leLength` con_spec_binders)+                  (conTyArgArityErr con_like (length con_spec_binders) (length type_args))          ; let pats_w_tys = zipEqual "tcConArgs" arg_pats arg_tys         ; (type_args', (arg_pats', res))@@ -1225,7 +1265,7 @@           -- This unification is straight from Figure 7 of           -- "Type Variables in Patterns", Haskell'18         ; _ <- zipWithM (unifyType Nothing) type_args' (substTyVars tenv $-                                                        binderVars con_binders)+                                                        binderVars con_spec_binders)           -- OK to drop coercions here. These unifications are all about           -- guiding inference based on a user-written type annotation           -- See Note [Typechecking type applications in patterns]@@ -1252,13 +1292,13 @@       tc_field :: Checker (LHsRecField GhcRn (LPat GhcRn))                           (LHsRecField GhcTc (LPat GhcTc))       tc_field penv-               (L l (HsRecField ann (L loc (FieldOcc sel (L lr rdr))) pat pun))+               (L l (HsFieldBind ann (L loc (FieldOcc sel (L lr rdr))) pat pun))                thing_inside         = do { sel'   <- tcLookupId sel-             ; pat_ty <- setSrcSpan loc $ find_field_ty sel+             ; pat_ty <- setSrcSpanA loc $ find_field_ty sel                                             (occNameFS $ rdrNameOcc rdr)              ; (pat', res) <- tcConArg penv (pat, pat_ty) thing_inside-             ; return (L l (HsRecField ann (L loc (FieldOcc sel' (L lr rdr))) pat'+             ; return (L l (HsFieldBind ann (L loc (FieldOcc sel' (L lr rdr))) pat'                                                                         pun), res) }  @@ -1272,12 +1312,12 @@                 --      f (R { foo = (a,b) }) = a+b                 -- If foo isn't one of R's fields, we don't want to crash when                 -- typechecking the "a+b".-           [] -> failWith (badFieldCon con_like lbl)+           [] -> failWith (badFieldConErr (getName con_like) lbl)                  -- The normal case, when the field comes from the right constructor            (pat_ty : extras) -> do                 traceTc "find_field" (ppr pat_ty <+> ppr extras)-                ASSERT( null extras ) (return pat_ty)+                assert (null extras) (return pat_ty)        field_tys :: [(FieldLabel, Scaled TcType)]       field_tys = zip (conLikeFieldLabels con_like) arg_tys@@ -1295,7 +1335,8 @@                -- by the calls to unifyType in tcConArgs, which will also unify                -- kinds.        ; when (not (null sig_ibs) && inPatBind penv) $-           addErr (text "Binding type variables is not allowed in pattern bindings")+           addErr (TcRnUnknownMessage $ mkPlainError noHints $+                     text "Binding type variables is not allowed in pattern bindings")        ; result <- tcExtendNameTyVarEnv sig_wcs $                    tcExtendNameTyVarEnv sig_ibs $                    thing_inside@@ -1307,7 +1348,8 @@  addDataConStupidTheta :: DataCon -> [TcType] -> TcM () -- Instantiate the "stupid theta" of the data con, and throw--- the constraints into the constraint set+-- the constraints into the constraint set.+-- See Note [The stupid context] in GHC.Core.DataCon. addDataConStupidTheta data_con inst_tys   | null stupid_theta = return ()   | otherwise         = instStupidTheta origin inst_theta@@ -1325,9 +1367,10 @@ conTyArgArityErr :: ConLike                  -> Int   -- expected # of arguments                  -> Int   -- actual # of arguments-                 -> SDoc+                 -> TcRnMessage conTyArgArityErr con_like expected_number actual_number-  = text "Too many type arguments in constructor pattern for" <+> quotes (ppr con_like) $$+  = TcRnUnknownMessage $ mkPlainError noHints $+    text "Too many type arguments in constructor pattern for" <+> quotes (ppr con_like) $$     text "Expected no more than" <+> ppr expected_number <> semi <+> text "got" <+> ppr actual_number  {-@@ -1466,29 +1509,15 @@   PE { pe_ctxt = LamPat (ArrowMatchCtxt {}) }     | not $ isVanillaConLike conlike     -- See Note [Arrows and patterns]-    -> failWithTc existentialProcPat+    -> failWithTc TcRnArrowProcGADTPattern   PE { pe_lazy = True }     | has_existentials     -- See Note [Existential check]-    -> failWithTc existentialLazyPat+    -> failWithTc TcRnLazyGADTPattern   _ -> return ()   where     has_existentials :: Bool     has_existentials = any (`elemVarSet` tyCoVarsOfTypes arg_tys) ex_tvs--existentialLazyPat :: SDoc-existentialLazyPat-  = hang (text "An existential or GADT data constructor cannot be used")-       2 (text "inside a lazy (~) pattern")--existentialProcPat :: SDoc-existentialProcPat-  = text "Proc patterns cannot use existential or GADT data constructors"--badFieldCon :: ConLike -> FieldLabelString -> SDoc-badFieldCon con field-  = hsep [text "Constructor" <+> quotes (ppr con),-          text "does not have field", quotes (ppr field)]  polyPatSig :: TcType -> SDoc polyPatSig sig_ty
GHC/Tc/Gen/Rule.hs view
@@ -15,6 +15,7 @@ import GHC.Tc.Types import GHC.Tc.Utils.Monad import GHC.Tc.Solver+import GHC.Tc.Solver.Monad ( runTcS ) import GHC.Tc.Types.Constraint import GHC.Core.Predicate import GHC.Tc.Types.Origin@@ -28,9 +29,9 @@ import GHC.Core.Type import GHC.Core.TyCon( isTypeFamilyTyCon ) import GHC.Types.Id-import GHC.Types.Var( EvVar )+import GHC.Types.Var( EvVar, tyVarName ) import GHC.Types.Var.Set-import GHC.Types.Basic ( RuleName )+import GHC.Types.Basic ( RuleName, NonStandardDefaultingStrategy(..) ) import GHC.Types.SrcLoc import GHC.Utils.Outputable import GHC.Utils.Panic@@ -119,10 +120,10 @@                , rd_rhs  = rhs })   = addErrCtxt (ruleCtxt name)  $     do { traceTc "---- Rule ------" (pprFullRuleName rname)-+       ; skol_info <- mkSkolemInfo (RuleSkol name)         -- Note [Typechecking rules]        ; (tc_lvl, stuff) <- pushTcLevelM $-                            generateRuleConstraints ty_bndrs tm_bndrs lhs rhs+                            generateRuleConstraints name ty_bndrs tm_bndrs lhs rhs         ; let (id_bndrs, lhs', lhs_wanted                       , rhs', rhs_wanted, rule_ty) = stuff@@ -151,11 +152,20 @@         -- See Note [Re-quantify type variables in rules]        ; forall_tkvs <- candidateQTyVarsOfTypes (rule_ty : map idType tpl_ids)-       ; qtkvs <- quantifyTyVars forall_tkvs+       ; let don't_default = nonDefaultableTyVarsOfWC residual_lhs_wanted+       ; let weed_out = (`dVarSetMinusVarSet` don't_default)+             quant_cands = forall_tkvs { dv_kvs = weed_out (dv_kvs forall_tkvs)+                                       , dv_tvs = weed_out (dv_tvs forall_tkvs) }+       ; qtkvs <- quantifyTyVars skol_info DefaultNonStandardTyVars quant_cands        ; traceTc "tcRule" (vcat [ pprFullRuleName rname-                                , ppr forall_tkvs-                                , ppr qtkvs-                                , ppr rule_ty+                                , text "forall_tkvs:" <+> ppr forall_tkvs+                                , text "quant_cands:" <+> ppr quant_cands+                                , text "don't_default:" <+> ppr don't_default+                                , text "residual_lhs_wanted:" <+> ppr residual_lhs_wanted+                                , text "qtkvs:" <+> ppr qtkvs+                                , text "rule_ty:" <+> ppr rule_ty+                                , text "ty_bndrs:" <+> ppr ty_bndrs+                                , text "qtkvs ++ tpl_ids:" <+> ppr (qtkvs ++ tpl_ids)                                 , vcat [ ppr id <+> dcolon <+> ppr (idType id) | id <- tpl_ids ]                   ]) @@ -164,37 +174,35 @@        -- For the LHS constraints we must solve the remaining constraints        -- (a) so that we report insoluble ones        -- (b) so that we bind any soluble ones-       ; let skol_info = RuleSkol name-       ; (lhs_implic, lhs_binds) <- buildImplicationFor tc_lvl skol_info qtkvs+       ; (lhs_implic, lhs_binds) <- buildImplicationFor tc_lvl (getSkolemInfo skol_info) qtkvs                                          lhs_evs residual_lhs_wanted-       ; (rhs_implic, rhs_binds) <- buildImplicationFor tc_lvl skol_info qtkvs+       ; (rhs_implic, rhs_binds) <- buildImplicationFor tc_lvl (getSkolemInfo skol_info) qtkvs                                          lhs_evs rhs_wanted-        ; emitImplications (lhs_implic `unionBags` rhs_implic)        ; return $ HsRule { rd_ext = ext                          , rd_name = rname                          , rd_act = act                          , rd_tyvs = ty_bndrs -- preserved for ppr-ing-                         , rd_tmvs = map (noLoc . RuleBndr noAnn . noLocA)+                         , rd_tmvs = map (noLocA . RuleBndr noAnn . noLocA)                                          (qtkvs ++ tpl_ids)                          , rd_lhs  = mkHsDictLet lhs_binds lhs'                          , rd_rhs  = mkHsDictLet rhs_binds rhs' } } -generateRuleConstraints :: Maybe [LHsTyVarBndr () GhcRn] -> [LRuleBndr GhcRn]+generateRuleConstraints :: FastString+                        -> Maybe [LHsTyVarBndr () GhcRn] -> [LRuleBndr GhcRn]                         -> LHsExpr GhcRn -> LHsExpr GhcRn                         -> TcM ( [TcId]                                , LHsExpr GhcTc, WantedConstraints                                , LHsExpr GhcTc, WantedConstraints                                , TcType )-generateRuleConstraints ty_bndrs tm_bndrs lhs rhs+generateRuleConstraints rule_name ty_bndrs tm_bndrs lhs rhs   = do { ((tv_bndrs, id_bndrs), bndr_wanted) <- captureConstraints $-                                                tcRuleBndrs ty_bndrs tm_bndrs+                                                tcRuleBndrs rule_name ty_bndrs tm_bndrs               -- bndr_wanted constraints can include wildcard hole               -- constraints, which we should not forget about.               -- It may mention the skolem type variables bound by               -- the RULE.  c.f. #10072--       ; tcExtendTyVarEnv tv_bndrs $+       ; tcExtendNameTyVarEnv [(tyVarName tv, tv) | tv <- tv_bndrs] $          tcExtendIdEnv    id_bndrs $     do { -- See Note [Solve order for RULES]          ((lhs', rule_ty), lhs_wanted) <- captureConstraints (tcInferRho lhs)@@ -204,38 +212,39 @@        ; return (id_bndrs, lhs', all_lhs_wanted, rhs', rhs_wanted, rule_ty) } }  -- See Note [TcLevel in type checking rules]-tcRuleBndrs :: Maybe [LHsTyVarBndr () GhcRn] -> [LRuleBndr GhcRn]+tcRuleBndrs :: FastString -> Maybe [LHsTyVarBndr () GhcRn] -> [LRuleBndr GhcRn]             -> TcM ([TcTyVar], [Id])-tcRuleBndrs (Just bndrs) xs-  = do { (tybndrs1,(tys2,tms)) <- bindExplicitTKBndrs_Skol bndrs $-                                  tcRuleTmBndrs xs+tcRuleBndrs rule_name (Just bndrs) xs+  = do { skol_info <- mkSkolemInfo (RuleSkol rule_name)+       ; (tybndrs1,(tys2,tms)) <- bindExplicitTKBndrs_Skol skol_info bndrs $+                                  tcRuleTmBndrs rule_name xs        ; let tys1 = binderVars tybndrs1        ; return (tys1 ++ tys2, tms) } -tcRuleBndrs Nothing xs-  = tcRuleTmBndrs xs+tcRuleBndrs rule_name Nothing xs+  = tcRuleTmBndrs rule_name xs  -- See Note [TcLevel in type checking rules]-tcRuleTmBndrs :: [LRuleBndr GhcRn] -> TcM ([TcTyVar],[Id])-tcRuleTmBndrs [] = return ([],[])-tcRuleTmBndrs (L _ (RuleBndr _ (L _ name)) : rule_bndrs)+tcRuleTmBndrs :: FastString -> [LRuleBndr GhcRn] -> TcM ([TcTyVar],[Id])+tcRuleTmBndrs _ [] = return ([],[])+tcRuleTmBndrs rule_name (L _ (RuleBndr _ (L _ name)) : rule_bndrs)   = do  { ty <- newOpenFlexiTyVarTy-        ; (tyvars, tmvars) <- tcRuleTmBndrs rule_bndrs+        ; (tyvars, tmvars) <- tcRuleTmBndrs rule_name rule_bndrs         ; return (tyvars, mkLocalId name Many ty : tmvars) }-tcRuleTmBndrs (L _ (RuleBndrSig _ (L _ name) rn_ty) : rule_bndrs)+tcRuleTmBndrs rule_name (L _ (RuleBndrSig _ (L _ name) rn_ty) : rule_bndrs) --  e.g         x :: a->a --  The tyvar 'a' is brought into scope first, just as if you'd written --              a::*, x :: a->a --  If there's an explicit forall, the renamer would have already reported an --   error for each out-of-scope type variable used-  = do  { let ctxt = RuleSigCtxt name+  = do  { let ctxt = RuleSigCtxt rule_name name         ; (_ , tvs, id_ty) <- tcHsPatSigType ctxt HM_Sig rn_ty OpenKind         ; let id  = mkLocalId name Many id_ty                     -- See Note [Typechecking pattern signature binders] in GHC.Tc.Gen.HsType                -- The type variables scope over subsequent bindings; yuk         ; (tyvars, tmvars) <- tcExtendNameTyVarEnv tvs $-                                   tcRuleTmBndrs rule_bndrs+                                   tcRuleTmBndrs rule_name rule_bndrs         ; return (map snd tvs ++ tyvars, id : tmvars) }  ruleCtxt :: FastString -> SDoc@@ -403,7 +412,8 @@        ; lhs_clone <- cloneWC lhs_wanted        ; rhs_clone <- cloneWC rhs_wanted        ; setTcLevel tc_lvl $-         runTcSDeriveds    $+         discardResult     $+         runTcS            $          do { _ <- solveWanteds lhs_clone             ; _ <- solveWanteds rhs_clone                   -- Why do them separately?@@ -462,9 +472,9 @@   = float_wc emptyVarSet wc   where     float_wc :: TcTyCoVarSet -> WantedConstraints -> (Cts, WantedConstraints)-    float_wc skol_tvs (WC { wc_simple = simples, wc_impl = implics, wc_holes = holes })+    float_wc skol_tvs (WC { wc_simple = simples, wc_impl = implics, wc_errors = errs })       = ( simple_yes `andCts` implic_yes-        , emptyWC { wc_simple = simple_no, wc_impl = implics_no, wc_holes = holes })+        , emptyWC { wc_simple = simple_no, wc_impl = implics_no, wc_errors = errs })      where         (simple_yes, simple_no) = partitionBag (rule_quant_ct skol_tvs) simples         (implic_yes, implics_no) = mapAccumBagL (float_implic skol_tvs)@@ -478,12 +488,11 @@         new_skol_tvs = skol_tvs `extendVarSetList` ic_skols imp      rule_quant_ct :: TcTyCoVarSet -> Ct -> Bool-    rule_quant_ct skol_tvs ct-      | EqPred _ t1 t2 <- classifyPredType (ctPred ct)-      , not (ok_eq t1 t2)-       = False        -- Note [RULE quantification over equalities]-      | otherwise-      = tyCoVarsOfCt ct `disjointVarSet` skol_tvs+    rule_quant_ct skol_tvs ct = case classifyPredType (ctPred ct) of+      EqPred _ t1 t2+        | not (ok_eq t1 t2)+        -> False        -- Note [RULE quantification over equalities]+      _ -> tyCoVarsOfCt ct `disjointVarSet` skol_tvs      ok_eq t1 t2        | t1 `tcEqType` t2 = False
GHC/Tc/Gen/Sig.hs view
@@ -4,7 +4,7 @@  -} -{-# LANGUAGE CPP #-}+ {-# LANGUAGE TypeFamilies #-}  module GHC.Tc.Gen.Sig(@@ -15,6 +15,7 @@         isPartialSig, hasCompleteSig, tcIdSigName, tcSigInfoName,        completeSigPolyId_maybe, isCompleteHsSig,+       lhsSigWcTypeContextSpan, lhsSigTypeContextSpan,         tcTySigs, tcUserTypeSig, completeSigFromId,        tcInstSig,@@ -24,43 +25,51 @@        addInlinePrags, addInlinePragArity    ) where -#include "HsVersions.h"- import GHC.Prelude +import GHC.Driver.Session+import GHC.Driver.Backend+ import GHC.Hs+++import GHC.Tc.Errors.Types ( FixedRuntimeRepProvenance(..), TcRnMessage(..) ) import GHC.Tc.Gen.HsType import GHC.Tc.Types import GHC.Tc.Solver( pushLevelAndSolveEqualitiesX, reportUnsolvedEqualities ) import GHC.Tc.Utils.Monad+import GHC.Tc.Utils.TcMType ( checkTypeHasFixedRuntimeRep ) import GHC.Tc.Utils.Zonk import GHC.Tc.Types.Origin import GHC.Tc.Utils.TcType-import GHC.Tc.Utils.TcMType import GHC.Tc.Validity ( checkValidType ) import GHC.Tc.Utils.Unify( tcTopSkolemise, unifyType ) import GHC.Tc.Utils.Instantiate( topInstantiate, tcInstTypeBndrs ) import GHC.Tc.Utils.Env( tcLookupId ) import GHC.Tc.Types.Evidence( HsWrapper, (<.>) )+ import GHC.Core( hasSomeUnfolding ) import GHC.Core.Type ( mkTyVarBinders ) import GHC.Core.Multiplicity -import GHC.Driver.Session-import GHC.Driver.Backend+import GHC.Types.Error import GHC.Types.Var ( TyVar, Specificity(..), tyVarKind, binderVars ) import GHC.Types.Id  ( Id, idName, idType, setInlinePragma                      , mkLocalId, realIdUnfolding )-import GHC.Builtin.Names( mkUnboundName ) import GHC.Types.Basic-import GHC.Unit.Module( getModule ) import GHC.Types.Name import GHC.Types.Name.Env-import GHC.Utils.Outputable-import GHC.Utils.Panic import GHC.Types.SrcLoc++import GHC.Builtin.Names( mkUnboundName )+import GHC.Unit.Module( getModule )+ import GHC.Utils.Misc as Utils ( singleton )+import GHC.Utils.Outputable+import GHC.Utils.Panic+ import GHC.Data.Maybe( orElse )+ import Data.Maybe( mapMaybe ) import Control.Monad( unless ) @@ -180,8 +189,8 @@  tcTySig :: LSig GhcRn -> TcM [TcSigInfo] tcTySig (L _ (IdSig _ id))-  = do { let ctxt = FunSigCtxt (idName id) False-                    -- False: do not report redundant constraints+  = do { let ctxt = FunSigCtxt (idName id) NoRRC+                    -- NoRRC: do not report redundant constraints                     -- The user has no control over the signature!              sig = completeSigFromId ctxt id        ; return [TcIdSig sig] }@@ -216,7 +225,7 @@ -- Nothing => Expression type signature   <expr> :: type tcUserTypeSig loc hs_sig_ty mb_name   | isCompleteHsSig hs_sig_ty-  = do { sigma_ty <- tcHsSigWcType ctxt_F hs_sig_ty+  = do { sigma_ty <- tcHsSigWcType ctxt_no_rrc hs_sig_ty        ; traceTc "tcuser" (ppr sigma_ty)        ; return $          CompleteSig { sig_bndr  = mkLocalId name Many sigma_ty@@ -225,27 +234,45 @@                                    -- anything, it is a top-level                                    -- definition. Which are all unrestricted in                                    -- the current implementation.-                     , sig_ctxt  = ctxt_T+                     , sig_ctxt  = ctxt_rrc  -- Report redundant constraints                      , sig_loc   = loc } }                        -- Location of the <type> in   f :: <type>    -- Partial sig with wildcards   | otherwise   = return (PartialSig { psig_name = name, psig_hs_ty = hs_sig_ty-                       , sig_ctxt = ctxt_F, sig_loc = loc })+                       , sig_ctxt = ctxt_no_rrc, sig_loc = loc })   where     name   = case mb_name of                Just n  -> n                Nothing -> mkUnboundName (mkVarOcc "<expression>")-    ctxt_F = case mb_name of-               Just n  -> FunSigCtxt n False-               Nothing -> ExprSigCtxt-    ctxt_T = case mb_name of-               Just n  -> FunSigCtxt n True-               Nothing -> ExprSigCtxt +    ctxt_rrc    = ctxt_fn (lhsSigWcTypeContextSpan hs_sig_ty)+    ctxt_no_rrc = ctxt_fn NoRRC +    ctxt_fn :: ReportRedundantConstraints -> UserTypeCtxt+    ctxt_fn rcc = case mb_name of+               Just n  -> FunSigCtxt n rcc+               Nothing -> ExprSigCtxt rcc +lhsSigWcTypeContextSpan :: LHsSigWcType GhcRn -> ReportRedundantConstraints+-- | Find the location of the top-level context of a HsType.  For example:+--+-- @+--   forall a b. (Eq a, Ord b) => blah+--               ^^^^^^^^^^^^^+-- @+-- If there is none, return Nothing+lhsSigWcTypeContextSpan (HsWC { hswc_body = sigType }) = lhsSigTypeContextSpan sigType++lhsSigTypeContextSpan :: LHsSigType GhcRn -> ReportRedundantConstraints+lhsSigTypeContextSpan (L _ HsSig { sig_body = sig_ty }) = go sig_ty+  where+    go (L _ (HsQualTy { hst_ctxt = L span _ })) = WantRRC $ locA span -- Found it!+    go (L _ (HsForAllTy { hst_body = hs_ty })) = go hs_ty  -- Look under foralls+    go (L _ (HsParTy _ hs_ty)) = go hs_ty  -- Look under parens+    go _ = NoRRC  -- Did not find it+ completeSigFromId :: UserTypeCtxt -> Id -> TcIdSigInfo -- Used for instance methods and record selectors completeSigFromId ctxt id@@ -274,7 +301,7 @@       HsListTy _ ty                  -> go ty       HsTupleTy _ _ tys              -> gos tys       HsSumTy _ tys                  -> gos tys-      HsOpTy _ ty1 _ ty2             -> go ty1 && go ty2+      HsOpTy _ _ ty1 _ ty2           -> go ty1 && go ty2       HsParTy _ ty                   -> go ty       HsIParamTy _ _ ty              -> go ty       HsKindSig _ ty kind            -> go ty && go kind@@ -287,7 +314,7 @@                  , hst_body = ty } -> no_anon_wc_tele tele                                         && go ty       HsQualTy { hst_ctxt = ctxt-               , hst_body = ty }  -> gos (fromMaybeContext ctxt) && go ty+               , hst_body = ty }  -> gos (unLoc ctxt) && go ty       HsSpliceTy _ (HsSpliced _ _ (HsSplicedTy ty)) -> go $ L noSrcSpanA ty       HsSpliceTy{} -> True       HsTyLit{} -> True@@ -379,12 +406,12 @@   , (ex_hs_tvbndrs, hs_prov, hs_body_ty) <- splitLHsSigmaTyInvis hs_ty1   = do { traceTc "tcPatSynSig 1" (ppr sig_ty) -       ; let skol_info = DataConSkol name+       ; skol_info <- mkSkolemInfo (DataConSkol name)        ; (tclvl, wanted, (outer_bndrs, (ex_bndrs, (req, prov, body_ty))))            <- pushLevelAndSolveEqualitiesX "tcPatSynSig"           $-                     -- See Note [solveEqualities in tcPatSynSig]-              tcOuterTKBndrs skol_info hs_outer_bndrs $-              tcExplicitTKBndrs ex_hs_tvbndrs         $+                     -- See Note [Report unsolved equalities in tcPatSynSig]+              tcOuterTKBndrs skol_info hs_outer_bndrs   $+              tcExplicitTKBndrs skol_info ex_hs_tvbndrs $               do { req     <- tcHsContext hs_req                  ; prov    <- tcHsContext hs_prov                  ; body_ty <- tcHsOpenType hs_body_ty@@ -405,7 +432,7 @@        ; let ungen_patsyn_ty = build_patsyn_type implicit_bndrs univ_bndrs                                                  req ex_bndrs prov body_ty        ; traceTc "tcPatSynSig" (ppr ungen_patsyn_ty)-       ; kvs <- kindGeneralizeAll ungen_patsyn_ty+       ; kvs <- kindGeneralizeAll skol_info ungen_patsyn_ty        ; reportUnsolvedEqualities skol_info kvs tclvl wanted                -- See Note [Report unsolved equalities in tcPatSynSig] @@ -425,10 +452,15 @@        ; checkValidType ctxt $          build_patsyn_type implicit_bndrs univ_bndrs req ex_bndrs prov body_ty -       -- arguments become the types of binders. We thus cannot allow-       -- levity polymorphism here-       ; let (arg_tys, _) = tcSplitFunTys body_ty-       ; mapM_ (checkForLevPoly empty . scaledThing) arg_tys+       -- Neither argument types nor the return type may be representation polymorphic.+       -- This is because, when creating a matcher:+       --   - the argument types become the the binder types (see test RepPolyPatySynArg),+       --   - the return type becomes the scrutinee type (see test RepPolyPatSynRes).+       ; let (arg_tys, res_ty) = tcSplitFunTys body_ty+       ; mapM_+           (\(Scaled _ arg_ty) -> checkTypeHasFixedRuntimeRep FixedRuntimeRepPatSynSigArg arg_ty)+           arg_tys+       ; checkTypeHasFixedRuntimeRep FixedRuntimeRepPatSynSigRes res_ty         ; traceTc "tcTySig }" $          vcat [ text "kvs"          <+> ppr_tvs (binderVars kv_bndrs)@@ -599,10 +631,12 @@          warn_multiple_inlines inl2 inls        | otherwise        = setSrcSpanA loc $-         addWarnTc NoReason-                     (hang (text "Multiple INLINE pragmas for" <+> ppr poly_id)-                       2 (vcat (text "Ignoring all but the first"-                                : map pp_inl (inl1:inl2:inls))))+         let dia = TcRnUnknownMessage $+               mkPlainDiagnostic WarningWithoutFlag noHints $+                 (hang (text "Multiple INLINE pragmas for" <+> ppr poly_id)+                   2 (vcat (text "Ignoring all but the first"+                            : map pp_inl (inl1:inl2:inls))))+         in addDiagnosticTc dia      pp_inl (L loc prag) = ppr prag <+> parens (ppr loc) @@ -751,9 +785,11 @@     is_bad_sig s = not (isSpecLSig s || isInlineLSig s || isSCCFunSig s)      warn_discarded_sigs-      = addWarnTc NoReason-                  (hang (text "Discarding unexpected pragmas for" <+> ppr poly_id)-                      2 (vcat (map (ppr . getLoc) bad_sigs)))+      = let dia = TcRnUnknownMessage $+              mkPlainDiagnostic WarningWithoutFlag noHints $+                (hang (text "Discarding unexpected pragmas for" <+> ppr poly_id)+                    2 (vcat (map (ppr . getLoc) bad_sigs)))+        in addDiagnosticTc dia  -------------- tcSpecPrag :: TcId -> Sig GhcRn -> TcM [TcSpecPrag]@@ -766,10 +802,11 @@ -- However we want to use fun_name in the error message, since that is -- what the user wrote (#8537)   = addErrCtxt (spec_ctxt prag) $-    do  { warnIf (not (isOverloadedTy poly_ty || isInlinePragma inl))-                 (text "SPECIALISE pragma for non-overloaded function"-                  <+> quotes (ppr fun_name))-                  -- Note [SPECIALISE pragmas]+    do  { warnIf (not (isOverloadedTy poly_ty || isInlinePragma inl)) $+                 TcRnUnknownMessage $ mkPlainDiagnostic WarningWithoutFlag noHints+                   (text "SPECIALISE pragma for non-overloaded function"+                    <+> quotes (ppr fun_name))+                    -- Note [SPECIALISE pragmas]         ; spec_prags <- mapM tc_one hs_tys         ; traceTc "tcSpecPrag" (ppr poly_id $$ nest 2 (vcat (map ppr spec_prags)))         ; return spec_prags }@@ -779,8 +816,8 @@     spec_ctxt prag = hang (text "In the pragma:") 2 (ppr prag)      tc_one hs_ty-      = do { spec_ty <- tcHsSigType   (FunSigCtxt name False) hs_ty-           ; wrap    <- tcSpecWrapper (FunSigCtxt name True)  poly_ty spec_ty+      = do { spec_ty <- tcHsSigType   (FunSigCtxt name NoRRC) hs_ty+           ; wrap    <- tcSpecWrapper (FunSigCtxt name (lhsSigTypeContextSpan hs_ty)) poly_ty spec_ty            ; return (SpecPrag poly_id wrap inl) }  tcSpecPrag _ prag = pprPanic "tcSpecPrag" (ppr prag)@@ -834,7 +871,9 @@       ; if hasSomeUnfolding (realIdUnfolding id)            -- See Note [SPECIALISE pragmas for imported Ids]         then tcSpecPrag id prag-        else do { addWarnTc NoReason (impSpecErr name)+        else do { let dia = TcRnUnknownMessage $+                        mkPlainDiagnostic WarningWithoutFlag noHints (impSpecErr name)+                ; addDiagnosticTc dia                 ; return [] } }  impSpecErr :: Name -> SDoc@@ -853,7 +892,7 @@ can't specialise it here; indeed the desugar falls over (#18118).  We used to test whether it had a user-specified INLINABLE pragma but,-because of Note [Worker-wrapper for INLINABLE functions] in+because of Note [Worker/wrapper for INLINABLE functions] in GHC.Core.Opt.WorkWrap, even an INLINABLE function may end up with a wrapper that has no pragma, just an unfolding (#19246).  So now we just test whether the function has an unfolding.
GHC/Tc/Gen/Splice.hs view
@@ -10,6 +10,7 @@  {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+{-# LANGUAGE NamedFieldPuns #-}  {- (c) The University of Glasgow 2006@@ -30,18 +31,20 @@      finishTH, runTopSplice       ) where -#include "HsVersions.h"- import GHC.Prelude +import GHC.Driver.Errors import GHC.Driver.Plugins import GHC.Driver.Main import GHC.Driver.Session import GHC.Driver.Env import GHC.Driver.Hooks+import GHC.Driver.Config.Diagnostic+import GHC.Driver.Config.Finder  import GHC.Hs +import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Tc.Utils.TcType import GHC.Tc.Gen.Expr@@ -81,7 +84,6 @@ import GHC.Rename.Splice( traceSplice, SpliceInfo(..)) import GHC.Rename.Expr import GHC.Rename.Env-import GHC.Rename.Utils  ( HsDocContext(..) ) import GHC.Rename.Fixity ( lookupFixityRn_help ) import GHC.Rename.HsType @@ -109,6 +111,7 @@ import GHC.Types.Fixity as Hs import GHC.Types.Annotations import GHC.Types.Name+import GHC.Types.Unique.Map import GHC.Serialized  import GHC.Unit.Finder@@ -118,9 +121,11 @@  import GHC.Utils.Misc import GHC.Utils.Panic as Panic+import GHC.Utils.Panic.Plain import GHC.Utils.Lexeme import GHC.Utils.Outputable import GHC.Utils.Logger+import GHC.Utils.Exception (throwIO, ErrorCall(..))  import GHC.Utils.TmpFs ( newTempName, TempFileLifetime(..) ) @@ -139,7 +144,6 @@ #endif  import Control.Monad-import Control.Exception import Data.Binary import Data.Binary.Get import Data.List        ( find )@@ -152,6 +156,9 @@ import Data.Typeable ( typeOf, Typeable, TypeRep, typeRep ) import Data.Data (Data) import Data.Proxy    ( Proxy (..) )+import GHC.Parser.HaddockLex (lexHsDoc)+import GHC.Parser (parseIdentifier)+import GHC.Rename.Doc (rnHsDoc)  {- ************************************************************************@@ -161,8 +168,8 @@ ************************************************************************ -} -tcTypedBracket   :: HsExpr GhcRn -> HsBracket GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)-tcUntypedBracket :: HsExpr GhcRn -> HsBracket GhcRn -> [PendingRnSplice] -> ExpRhoType+tcTypedBracket   :: HsExpr GhcRn -> LHsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)+tcUntypedBracket :: HsExpr GhcRn -> HsQuote GhcRn -> [PendingRnSplice] -> ExpRhoType                  -> TcM (HsExpr GhcTc) tcSpliceExpr     :: HsSplice GhcRn  -> ExpRhoType -> TcM (HsExpr GhcTc)         -- None of these functions add constraints to the LIE@@ -182,9 +189,8 @@ -}  -- See Note [How brackets and nested splices are handled]--- tcTypedBracket :: HsBracket Name -> TcRhoType -> TcM (HsExpr TcId)-tcTypedBracket rn_expr brack@(TExpBr _ expr) res_ty-  = addErrCtxt (quotationCtxtDoc brack) $+tcTypedBracket rn_expr expr res_ty+  = addErrCtxt (quotationCtxtDoc expr) $     do { cur_stage <- getStage        ; ps_ref <- newMutVar []        ; lie_var <- getConstraintVar   -- Any constraints arising from nested splices@@ -198,28 +204,27 @@        -- Bundle them together so they can be used in GHC.HsToCore.Quote for desugaring        -- brackets.        ; let wrapper = QuoteWrapper ev_var m_var-       -- Typecheck expr to make sure it is valid,-       -- Throw away the typechecked expression but return its type.+       -- Typecheck expr to make sure it is valid.+       -- The typechecked expression won't be used, but we return it with its type.+       --   (See Note [The life cycle of a TH quotation] in GHC.Hs.Expr)        -- We'll typecheck it again when we splice it in somewhere-       ; (_tc_expr, expr_ty) <- setStage (Brack cur_stage (TcPending ps_ref lie_var wrapper)) $-                                tcScalingUsage Many $-                                -- Scale by Many, TH lifting is currently nonlinear (#18465)-                                tcInferRhoNC expr-                                -- NC for no context; tcBracket does that+       ; (tc_expr, expr_ty) <- setStage (Brack cur_stage (TcPending ps_ref lie_var wrapper)) $+                               tcScalingUsage Many $+                               -- Scale by Many, TH lifting is currently nonlinear (#18465)+                               tcInferRhoNC expr+                               -- NC for no context; tcBracket does that        ; let rep = getRuntimeRep expr_ty        ; meta_ty <- tcTExpTy m_var expr_ty        ; ps' <- readMutVar ps_ref-       ; texpco <- tcLookupId unsafeCodeCoerceName-       ; tcWrapResultO (Shouldn'tHappenOrigin "TExpBr")+       ; codeco <- tcLookupId unsafeCodeCoerceName+       ; bracket_ty <- mkAppTy m_var <$> tcMetaTy expTyConName+       ; tcWrapResultO (Shouldn'tHappenOrigin "TH typed bracket expression")                        rn_expr                        (unLoc (mkHsApp (mkLHsWrap (applyQuoteWrapper wrapper)-                                                  (nlHsTyApp texpco [rep, expr_ty]))-                                      (noLocA (HsTcBracketOut noExtField (Just wrapper) brack ps'))))+                                                  (nlHsTyApp codeco [rep, expr_ty]))+                                      (noLocA (HsTypedBracket (HsBracketTc (ExpBr noExtField expr) bracket_ty (Just wrapper) ps') tc_expr))))                        meta_ty res_ty }-tcTypedBracket _ other_brack _-  = pprPanic "tcTypedBracket" (ppr other_brack) --- tcUntypedBracket :: HsBracket Name -> [PendingRnSplice] -> ExpRhoType -> TcM (HsExpr TcId) -- See Note [Typechecking Overloaded Quotes] tcUntypedBracket rn_expr brack ps res_ty   = do { traceTc "tc_bracket untyped" (ppr brack $$ ppr ps)@@ -236,14 +241,15 @@        -- we want to reflect that in the overall type of the bracket.        ; ps' <- case quoteWrapperTyVarTy <$> brack_info of                   Just m_var -> mapM (tcPendingSplice m_var) ps-                  Nothing -> ASSERT(null ps) return []+                  Nothing -> assert (null ps) $ return []         ; traceTc "tc_bracket done untyped" (ppr expected_type)         -- Unify the overall type of the bracket with the expected result        -- type        ; tcWrapResultO BracketOrigin rn_expr-            (HsTcBracketOut noExtField brack_info brack ps')+            (HsUntypedBracket (HsBracketTc brack expected_type brack_info ps') (XQuote noExtField))+                -- (XQuote noExtField): see Note [The life cycle of a TH quotation] in GHC.Hs.Expr             expected_type res_ty         }@@ -265,7 +271,7 @@ -- | Compute the expected type of a quotation, and also the QuoteWrapper in -- the case where it is an overloaded quotation. All quotation forms are -- overloaded aprt from Variable quotations ('foo)-brackTy :: HsBracket GhcRn -> TcM (Maybe QuoteWrapper, Type)+brackTy :: HsQuote GhcRn -> TcM (Maybe QuoteWrapper, Type) brackTy b =   let mkTy n = do         -- New polymorphic type variable for the bracket@@ -288,7 +294,6 @@     (DecBrG {}) -> mkTy decsTyConName -- Result type is m [Dec]     (PatBr {})  -> mkTy patTyConName  -- Result type is m Pat     (DecBrL {}) -> panic "tcBrackTy: Unexpected DecBrL"-    (TExpBr {}) -> panic "tcUntypedBracket: Unexpected TExpBr"  --------------- -- | Typechecking a pending splice from a untyped bracket@@ -321,14 +326,15 @@        ; return (mkTyConApp codeCon [rep, m_ty, exp_ty]) }   where     err_msg ty-      = vcat [ text "Illegal polytype:" <+> ppr ty+      = TcRnUnknownMessage $ mkPlainError noHints $+      vcat [ text "Illegal polytype:" <+> ppr ty              , text "The type of a Typed Template Haskell expression must" <+>                text "not have any quantification." ] -quotationCtxtDoc :: HsBracket GhcRn -> SDoc+quotationCtxtDoc :: LHsExpr GhcRn -> SDoc quotationCtxtDoc br_body   = hang (text "In the Template Haskell quotation")-         2 (ppr br_body)+         2 (thTyBrackets . ppr $ br_body)     -- The whole of the rest of the file is the else-branch (ie stage2 only)@@ -362,43 +368,46 @@    and untyped   [|  e  |]  The life cycle of a typed bracket:-   * Starts as HsBracket+   * Starts as HsTypedBracket     * When renaming:         * Set the ThStage to (Brack s RnPendingTyped)         * Rename the body-        * Result is still a HsBracket+        * Result is a HsTypedBracket     * When typechecking:         * Set the ThStage to (Brack s (TcPending ps_var lie_var))-        * Typecheck the body, and throw away the elaborated result+        * Typecheck the body, and keep the elaborated result (despite never using it!)         * Nested splices (which must be typed) are typechecked, and           the results accumulated in ps_var; their constraints           accumulate in lie_var-        * Result is a HsTcBracketOut rn_brack pending_splices-          where rn_brack is the incoming renamed bracket+        * Result is a HsTypedBracket (HsBracketTc rn_brack ty quote_wrapper pending_splices) tc_brack+          where rn_brack is the untyped renamed exp quote constructed from the typed renamed expression :: HsQuote GhcRn  The life cycle of a un-typed bracket:-   * Starts as HsBracket+   * Starts as HsUntypedBracket     * When renaming:         * Set the ThStage to (Brack s (RnPendingUntyped ps_var))         * Rename the body         * Nested splices (which must be untyped) are renamed, and the           results accumulated in ps_var-        * Result is still (HsRnBracketOut rn_body pending_splices)+        * Result is a HsUntypedBracket pending_splices rn_body -   * When typechecking a HsRnBracketOut+   * When typechecking:         * Typecheck the pending_splices individually         * Ignore the body of the bracket; just check that the context           expects a bracket of that type (e.g. a [p| pat |] bracket should           be in a context needing a (Q Pat)-        * Result is a HsTcBracketOut rn_brack pending_splices-          where rn_brack is the incoming renamed bracket+        * Result is a HsUntypedBracket (HsBracketTc rn_brack ty quote_wrapper pending_splices) (XQuote noExtField)+          where rn_brack is the incoming renamed bracket :: HsQuote GhcRn+          and (XQuote noExtField) stands for the removal of the `HsQuote GhcTc` field (since `HsQuote GhcTc` isn't possible) +See the related Note [The life cycle of a TH quotation]  In both cases, desugaring happens like this:-  * HsTcBracketOut is desugared by GHC.HsToCore.Quote.dsBracket.  It+  * Hs*Bracket is desugared by GHC.HsToCore.Quote.dsBracket using the renamed+    expression held in `HsBracketTc` (`type instance X*Bracket GhcTc = HsBracketTc`). It        a) Extends the ds_meta environment with the PendingSplices          attached to the bracket@@ -420,11 +429,11 @@  Example:     Source:       f = [| Just $(g 3) |]-      The [| |] part is a HsBracket+      The [| |] part is a HsUntypedBracket GhcPs      Typechecked:  f = [| Just ${s7}(g 3) |]{s7 = g Int 3}-      The [| |] part is a HsBracketOut, containing *renamed*-        (not typechecked) expression+      The [| |] part is a HsUntypedBracket GhcTc, containing *renamed*+        (not typechecked) expression (see Note [The life cycle of a TH quotation])       The "s7" is the "splice point"; the (g Int 3) part         is a typechecked expression @@ -613,7 +622,6 @@  {- Note [Collecting modFinalizers in typed splices]    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~- 'qAddModFinalizer' of the @Quasi TcM@ instance adds finalizers in the local environment (see Note [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice). Thus after executing the splice, we move the finalizers to the@@ -674,12 +682,8 @@ -- See Note [Running typed splices in the zonker] runTopSplice :: DelayedSplice -> TcM (HsExpr GhcTc) runTopSplice (DelayedSplice lcl_env orig_expr res_ty q_expr)-  = do-      errs_var <- getErrsVar-      setLclEnv lcl_env $ setErrsVar errs_var $ do {-         -- Set the errs_var to the errs_var from the current context,-         -- otherwise error messages can go missing in GHCi (#19470)-         zonked_ty <- zonkTcType res_ty+  = restoreLclEnv lcl_env $+    do { zonked_ty <- zonkTcType res_ty        ; zonked_q_expr <- zonkTopLExpr q_expr         -- See Note [Collecting modFinalizers in typed splices].        ; modfinalizers_ref <- newTcRef []@@ -689,7 +693,7 @@        ; mod_finalizers <- readTcRef modfinalizers_ref        ; addModFinalizersWithLclEnv $ ThModFinalizers mod_finalizers        -- We use orig_expr here and not q_expr when tracing as a call to-       -- unsafeTExpCoerce is added to the original expression by the+       -- unsafeCodeCoerce is added to the original expression by the        -- typechecker when typed quotes are type checked.        ; traceSplice (SpliceInfo { spliceDescription = "expression"                                  , spliceIsDecl      = False@@ -923,6 +927,48 @@          -> TcM [LHsDecl GhcPs] runMetaD = runMeta metaRequestD +{- Note [Errors in desugaring a splice]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+What should we do if there are errors when desugaring a splice? We should+abort. There are several cases to consider:++(a) The desugarer hits an unrecoverable error and fails in the monad.+(b) The desugarer hits a recoverable error, reports it, and continues.+(c) The desugarer reports a fatal warning (with -Werror), reports it, and continues.+(d) The desugarer reports a non-fatal warning, and continues.++Each case is tested in th/T19709[abcd].++General principle: we wish to report all messages from dealing with a splice+eagerly, as these messages arise during an earlier stage than type-checking+generally. It's also likely that a compile-time warning from spliced code+will be easier to understand then an error that arises from processing the+code the splice produces. (Rationale: the warning will be about the code the+user actually wrote, not what is generated.)++Case (a): We have no choice but to abort here, but we must make sure that+the messages are printed or logged before aborting. Logging them is annoying,+because we're in the type-checker, and the messages are DsMessages, from the+desugarer. So we report and then fail in the monad. This case is detected+by the fact that initDsTc returns Nothing.++Case (b): We detect this case by looking for errors in the messages returned+from initDsTc and aborting if we spot any (after printing, of course). Note+that initDsTc will return a Just ds_expr in this case, but we don't wish to+use the (likely very bogus) expression.++Case (c): This is functionally the same as (b), except that the expression+isn't bogus. We still don't wish to use it, as the user's request for -Werror+tells us not to.++Case (d): We report the warnings and then carry on with the expression.+This might result in warnings printed out of source order, but this is+appropriate, as the warnings from the splice arise from an earlier stage+of compilation.++Previously, we failed to abort in cases (b) and (c), leading to #19709.+-}+ --------------- runMeta' :: Bool                 -- Whether code should be printed in the exception message          -> (hs_syn -> SDoc)                                    -- how to print the code@@ -938,19 +984,35 @@         -- Check that we've had no errors of any sort so far.         -- For example, if we found an error in an earlier defn f, but         -- recovered giving it type f :: forall a.a, it'd be very dodgy-        -- to carry ont.  Mind you, the staging restrictions mean we won't+        -- to carry on.  Mind you, the staging restrictions mean we won't         -- actually run f, but it still seems wrong. And, more concretely,         -- see #5358 for an example that fell over when trying to-        -- reify a function with a "?" kind in it.  (These don't occur-        -- in type-correct programs.+        -- reify a function with an unlifted kind in it.  (These don't occur+        -- in type-correct programs.)         ; failIfErrsM          -- run plugins         ; hsc_env <- getTopEnv-        ; expr' <- withPlugins hsc_env spliceRunAction expr+        ; expr' <- withPlugins (hsc_plugins hsc_env) spliceRunAction expr          -- Desugar-        ; ds_expr <- initDsTc (dsLExpr expr')+        ; (ds_msgs, mb_ds_expr) <- initDsTc (dsLExpr expr')++        -- Print any messages (even warnings) eagerly: they might be helpful if anything+        -- goes wrong. See Note [Errors in desugaring a splice]. This happens in all+        -- cases.+        ; logger <- getLogger+        ; diag_opts <- initDiagOpts <$> getDynFlags+        ; liftIO $ printMessages logger diag_opts ds_msgs++        ; ds_expr <- case mb_ds_expr of+            Nothing      -> failM   -- Case (a) from Note [Errors in desugaring a splice]+            Just ds_expr ->  -- There still might be a fatal warning or recoverable+                             -- Cases (b) and (c) from Note [Errors in desugaring a splice]+              do { when (errorsOrFatalWarningsFound ds_msgs)+                     failM+                 ; return ds_expr }+         -- Compile and link it; might fail if linking fails         ; src_span <- getSrcSpanM         ; traceTc "About to run (desugared)" (ppr ds_expr)@@ -958,7 +1020,7 @@                          GHC.Driver.Main.hscCompileCoreExpr hsc_env src_span ds_expr         ; case either_hval of {             Left exn   -> fail_with_exn "compile and link" exn ;-            Right hval -> do+            Right (hval, needed_mods, needed_pkgs) -> do          {       -- Coerce it to Q t, and run it @@ -972,12 +1034,13 @@                 --                 -- See Note [Exceptions in TH]           let expr_span = getLocA expr+        ; recordThNeededRuntimeDeps needed_mods needed_pkgs         ; either_tval <- tryAllM $                          setSrcSpan expr_span $ -- Set the span so that qLocation can                                                 -- see where this splice is              do { mb_result <- run_and_convert expr_span hval                 ; case mb_result of-                    Left err     -> failWithTc err+                    Left err     -> failWithTc (TcRnUnknownMessage $ mkPlainError noHints err)                     Right result -> do { traceTc "Got HsSyn result:" (ppr_hs result)                                        ; return $! result } } @@ -995,7 +1058,7 @@         let msg = vcat [text "Exception when trying to" <+> text phase <+> text "compile-time code:",                         nest 2 (text exn_msg),                         if show_code then text "Code:" <+> ppr expr else empty]-        failWithTc msg+        failWithTc (TcRnUnknownMessage $ mkPlainError noHints msg)  {- Note [Running typed splices in the zonker]@@ -1111,8 +1174,9 @@    -- 'msg' is forced to ensure exceptions don't escape,   -- see Note [Exceptions in TH]-  qReport True msg  = seqList msg $ addErr  (text msg)-  qReport False msg = seqList msg $ addWarn NoReason (text msg)+  qReport True msg  = seqList msg $ addErr $ TcRnUnknownMessage $ mkPlainError noHints (text msg)+  qReport False msg = seqList msg $ addDiagnostic $ TcRnUnknownMessage $+    mkPlainDiagnostic WarningWithoutFlag noHints (text msg)    qLocation = do { m <- getModule                  ; l <- getSrcSpanM@@ -1144,6 +1208,10 @@         -- we'll only fail higher up.   qRecover recover main = tryTcDiscardingErrs recover main +  qGetPackageRoot = do+    dflags <- getDynFlags+    return $ fromMaybe "." (workingDirectory dflags)+   qAddDependentFile fp = do     ref <- fmap tcg_dependent_files getGblEnv     dep_files <- readTcRef ref@@ -1153,14 +1221,14 @@     dflags <- getDynFlags     logger <- getLogger     tmpfs  <- hsc_tmpfs <$> getTopEnv-    liftIO $ newTempName logger tmpfs dflags TFL_GhcSession suffix+    liftIO $ newTempName logger tmpfs (tmpDir dflags) TFL_GhcSession suffix    qAddTopDecls thds = do       l <- getSrcSpanM       th_origin <- getThSpliceOrigin       let either_hval = convertToHsDecls th_origin l thds       ds <- case either_hval of-              Left exn -> failWithTc $+              Left exn -> failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $                 hang (text "Error in a declaration passed to addTopDecls:")                    2 exn               Right ds -> return ds@@ -1178,7 +1246,8 @@       checkTopDecl (ForD _ (ForeignImport { fd_name = L _ name }))         = bindName name       checkTopDecl _-        = addErr $ text "Only function, value, annotation, and foreign import declarations may be added with addTopDecl"+        = addErr $ TcRnUnknownMessage $ mkPlainError noHints $+          text "Only function, value, annotation, and foreign import declarations may be added with addTopDecl"        bindName :: RdrName -> TcM ()       bindName (Exact n)@@ -1187,8 +1256,8 @@              }        bindName name =-          addErr $-          hang (text "The binder" <+> quotes (ppr name) <+> ptext (sLit "is not a NameU."))+          addErr $ TcRnUnknownMessage $ mkPlainError noHints $+          hang (text "The binder" <+> quotes (ppr name) <+> text "is not a NameU.")              2 (text "Probable cause: you used mkName instead of newName to generate a binding.")    qAddForeignFilePath lang fp = do@@ -1202,7 +1271,11 @@    qAddCorePlugin plugin = do       hsc_env <- getTopEnv-      r <- liftIO $ findHomeModule hsc_env (mkModuleName plugin)+      let fc        = hsc_FC hsc_env+      let home_unit = hsc_home_unit hsc_env+      let dflags    = hsc_dflags hsc_env+      let fopts     = initFinderOpts dflags+      r <- liftIO $ findHomeModule fc fopts home_unit (mkModuleName plugin)       let err = hang             (text "addCorePlugin: invalid plugin module "                <+> text (show plugin)@@ -1210,8 +1283,8 @@             2             (text "Plugins in the current package can't be specified.")       case r of-        Found {} -> addErr err-        FoundMultiple {} -> addErr err+        Found {} -> addErr $ TcRnUnknownMessage $ mkPlainError noHints err+        FoundMultiple {} -> addErr $ TcRnUnknownMessage $ mkPlainError noHints err         _ -> return ()       th_coreplugins_var <- tcg_th_coreplugins <$> getGblEnv       updTcRef th_coreplugins_var (plugin:)@@ -1236,10 +1309,13 @@     th_doc_var <- tcg_th_docs <$> getGblEnv     resolved_doc_loc <- resolve_loc doc_loc     is_local <- checkLocalName resolved_doc_loc-    unless is_local $ failWithTc $ text+    unless is_local $ failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ text       "Can't add documentation to" <+> ppr_loc doc_loc <+>       text "as it isn't inside the current module"-    updTcRef th_doc_var (Map.insert resolved_doc_loc s)+    let ds = mkGeneratedHsDocString s+        hd = lexHsDoc parseIdentifier ds+    hd' <- rnHsDoc hd+    updTcRef th_doc_var (Map.insert resolved_doc_loc hd')     where       resolve_loc (TH.DeclDoc n) = DeclDoc <$> lookupThName n       resolve_loc (TH.ArgDoc n i) = ArgDoc <$> lookupThName n <*> pure i@@ -1263,40 +1339,41 @@   qGetDoc (TH.InstDoc t) = lookupThInstName t >>= lookupDeclDoc   qGetDoc (TH.ArgDoc n i) = lookupThName n >>= lookupArgDoc i   qGetDoc TH.ModuleDoc = do-    (moduleDoc, _, _) <- getGblEnv >>= extractDocs-    return (fmap unpackHDS moduleDoc)+    df <- getDynFlags+    docs <- getGblEnv >>= extractDocs df+    return (renderHsDocString . hsDocString <$> (docs_mod_hdr =<< docs))  -- | Looks up documentation for a declaration in first the current module, -- otherwise tries to find it in another module via 'hscGetModuleInterface'. lookupDeclDoc :: Name -> TcM (Maybe String) lookupDeclDoc nm = do-  (_, DeclDocMap declDocs, _) <- getGblEnv >>= extractDocs-  fam_insts <- tcg_fam_insts <$> getGblEnv-  traceTc "lookupDeclDoc" (ppr nm <+> ppr declDocs <+> ppr fam_insts)-  case Map.lookup nm declDocs of-    Just doc -> pure $ Just (unpackHDS doc)+  df <- getDynFlags+  Docs{docs_decls} <- fmap (fromMaybe emptyDocs) $ getGblEnv >>= extractDocs df+  case lookupUniqMap docs_decls nm of+    Just doc -> pure $ Just (renderHsDocStrings $ map hsDocString doc)     Nothing -> do       -- Wasn't in the current module. Try searching other external ones!       mIface <- getExternalModIface nm       case mIface of-        Nothing -> pure Nothing-        Just ModIface { mi_decl_docs = DeclDocMap dmap } ->-          pure $ unpackHDS <$> Map.lookup nm dmap+        Just ModIface { mi_docs = Just Docs{docs_decls = dmap} } ->+          pure $ renderHsDocStrings . map hsDocString <$> lookupUniqMap dmap nm+        _ -> pure Nothing  -- | Like 'lookupDeclDoc', looks up documentation for a function argument. If -- it can't find any documentation for a function in this module, it tries to -- find it in another module. lookupArgDoc :: Int -> Name -> TcM (Maybe String) lookupArgDoc i nm = do-  (_, _, ArgDocMap argDocs) <- getGblEnv >>= extractDocs-  case Map.lookup nm argDocs of-    Just m -> pure $ unpackHDS <$> IntMap.lookup i m+  df <- getDynFlags+  Docs{docs_args = argDocs} <- fmap (fromMaybe emptyDocs) $ getGblEnv >>= extractDocs df+  case lookupUniqMap argDocs nm of+    Just m -> pure $ renderHsDocString . hsDocString <$> IntMap.lookup i m     Nothing -> do       mIface <- getExternalModIface nm       case mIface of-        Nothing -> pure Nothing-        Just ModIface { mi_arg_docs = ArgDocMap amap } ->-          pure $ unpackHDS <$> (Map.lookup nm amap >>= IntMap.lookup i)+        Just ModIface { mi_docs = Just Docs{docs_args = amap} } ->+          pure $ renderHsDocString . hsDocString <$> (lookupUniqMap amap nm >>= IntMap.lookup i)+        _ -> pure Nothing  -- | Returns the module a Name belongs to, if it is isn't local. getExternalModIface :: Name -> TcM (Maybe ModIface)@@ -1322,49 +1399,51 @@     Right (_, (inst:_)) -> return $ getName inst     Right (_, [])       -> noMatches   where-    noMatches = failWithTc $+    noMatches = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $       text "Couldn't find any instances of"         <+> ppr_th th_type         <+> text "to add documentation to" -    -- | Get the name of the class for the instance we are documenting+    -- Get the name of the class for the instance we are documenting     -- > inst_cls_name (Monad Maybe) == Monad     -- > inst_cls_name C = C     inst_cls_name :: TH.Type -> TcM TH.Name-    inst_cls_name (TH.AppT t _)           = inst_cls_name t-    inst_cls_name (TH.SigT n _)           = inst_cls_name n-    inst_cls_name (TH.VarT n)             = pure n-    inst_cls_name (TH.ConT n)             = pure n-    inst_cls_name (TH.PromotedT n)        = pure n-    inst_cls_name (TH.InfixT _ n _)       = pure n-    inst_cls_name (TH.UInfixT _ n _)      = pure n-    inst_cls_name (TH.ParensT t)          = inst_cls_name t+    inst_cls_name (TH.AppT t _)              = inst_cls_name t+    inst_cls_name (TH.SigT n _)              = inst_cls_name n+    inst_cls_name (TH.VarT n)                = pure n+    inst_cls_name (TH.ConT n)                = pure n+    inst_cls_name (TH.PromotedT n)           = pure n+    inst_cls_name (TH.InfixT _ n _)          = pure n+    inst_cls_name (TH.UInfixT _ n _)         = pure n+    inst_cls_name (TH.PromotedInfixT _ n _)  = pure n+    inst_cls_name (TH.PromotedUInfixT _ n _) = pure n+    inst_cls_name (TH.ParensT t)             = inst_cls_name t -    inst_cls_name (TH.ForallT _ _ _)      = inst_cls_name_err-    inst_cls_name (TH.ForallVisT _ _)     = inst_cls_name_err-    inst_cls_name (TH.AppKindT _ _)       = inst_cls_name_err-    inst_cls_name (TH.TupleT _)           = inst_cls_name_err-    inst_cls_name (TH.UnboxedTupleT _)    = inst_cls_name_err-    inst_cls_name (TH.UnboxedSumT _)      = inst_cls_name_err-    inst_cls_name TH.ArrowT               = inst_cls_name_err-    inst_cls_name TH.MulArrowT            = inst_cls_name_err-    inst_cls_name TH.EqualityT            = inst_cls_name_err-    inst_cls_name TH.ListT                = inst_cls_name_err-    inst_cls_name (TH.PromotedTupleT _)   = inst_cls_name_err-    inst_cls_name TH.PromotedNilT         = inst_cls_name_err-    inst_cls_name TH.PromotedConsT        = inst_cls_name_err-    inst_cls_name TH.StarT                = inst_cls_name_err-    inst_cls_name TH.ConstraintT          = inst_cls_name_err-    inst_cls_name (TH.LitT _)             = inst_cls_name_err-    inst_cls_name TH.WildCardT            = inst_cls_name_err-    inst_cls_name (TH.ImplicitParamT _ _) = inst_cls_name_err+    inst_cls_name (TH.ForallT _ _ _)         = inst_cls_name_err+    inst_cls_name (TH.ForallVisT _ _)        = inst_cls_name_err+    inst_cls_name (TH.AppKindT _ _)          = inst_cls_name_err+    inst_cls_name (TH.TupleT _)              = inst_cls_name_err+    inst_cls_name (TH.UnboxedTupleT _)       = inst_cls_name_err+    inst_cls_name (TH.UnboxedSumT _)         = inst_cls_name_err+    inst_cls_name TH.ArrowT                  = inst_cls_name_err+    inst_cls_name TH.MulArrowT               = inst_cls_name_err+    inst_cls_name TH.EqualityT               = inst_cls_name_err+    inst_cls_name TH.ListT                   = inst_cls_name_err+    inst_cls_name (TH.PromotedTupleT _)      = inst_cls_name_err+    inst_cls_name TH.PromotedNilT            = inst_cls_name_err+    inst_cls_name TH.PromotedConsT           = inst_cls_name_err+    inst_cls_name TH.StarT                   = inst_cls_name_err+    inst_cls_name TH.ConstraintT             = inst_cls_name_err+    inst_cls_name (TH.LitT _)                = inst_cls_name_err+    inst_cls_name TH.WildCardT               = inst_cls_name_err+    inst_cls_name (TH.ImplicitParamT _ _)    = inst_cls_name_err -    inst_cls_name_err = failWithTc $+    inst_cls_name_err = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $       text "Couldn't work out what instance"         <+> ppr_th th_type         <+> text "is supposed to be" -    -- | Basically does the opposite of 'mkThAppTs'+    -- Basically does the opposite of 'mkThAppTs'     -- > inst_arg_types (Monad Maybe) == [Maybe]     -- > inst_arg_types C == []     inst_arg_types :: TH.Type -> [TH.Type]@@ -1445,7 +1524,7 @@ -- See Note [Remote Template Haskell] in libraries/ghci/GHCi/TH.hs. runRemoteTH   :: IServInstance-  -> [Messages DecoratedSDoc]   --  saved from nested calls to qRecover+  -> [Messages TcRnMessage]   --  saved from nested calls to qRecover   -> TcM () runRemoteTH iserv recovers = do   THMsg msg <- liftIO $ readIServ iserv getTHMessage@@ -1482,7 +1561,7 @@     QFail str -> fail str  {- Note [TH recover with -fexternal-interpreter]-+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Recover is slightly tricky to implement.  The meaning of "recover a b" is@@ -1555,6 +1634,7 @@     wrapTHResult $ (map B.pack <$> getAnnotationsByTypeRep lookup tyrep)   ReifyModule m -> wrapTHResult $ TH.qReifyModule m   ReifyConStrictness nm -> wrapTHResult $ TH.qReifyConStrictness nm+  GetPackageRoot -> wrapTHResult $ TH.qGetPackageRoot   AddDependentFile f -> wrapTHResult $ TH.qAddDependentFile f   AddTempFile s -> wrapTHResult $ TH.qAddTempFile s   AddModFinalizer r -> do@@ -1620,16 +1700,16 @@                rnImplicitTvOccs Nothing tv_rdrs $ \ tv_names ->                do { (rn_ty, fvs) <- rnLHsType doc rdr_ty                   ; return ((tv_names, rn_ty), fvs) }-+        ; skol_info <- mkSkolemInfo ReifySkol         ; (tclvl, wanted, (tvs, ty))             <- pushLevelAndSolveEqualitiesX "reifyInstances"  $-               bindImplicitTKBndrs_Skol tv_names              $+               bindImplicitTKBndrs_Skol skol_info tv_names              $                tcInferLHsType rn_ty          ; tvs <- zonkAndScopedSort tvs          -- Avoid error cascade if there are unsolved-        ; reportUnsolvedEqualities ReifySkol tvs tclvl wanted+        ; reportUnsolvedEqualities skol_info tvs tclvl wanted          ; ty <- zonkTcTypeToType ty                 -- Substitute out the meta type variables@@ -1643,21 +1723,22 @@                -> do { inst_envs <- tcGetInstEnvs                      ; let (matches, unifies, _) = lookupInstEnv False inst_envs cls tys                      ; traceTc "reifyInstances'1" (ppr matches)-                     ; return $ Left (cls, map fst matches ++ unifies) }+                     ; return $ Left (cls, map fst matches ++ getPotentialUnifiers unifies) }                | isOpenFamilyTyCon tc                -> do { inst_envs <- tcGetFamInstEnvs                      ; let matches = lookupFamInstEnv inst_envs tc tys                      ; traceTc "reifyInstances'2" (ppr matches)                      ; return $ Right (tc, map fim_instance matches) }-            _  -> bale_out (hang (text "reifyInstances:" <+> quotes (ppr ty))-                               2 (text "is not a class constraint or type family application")) }+            _  -> bale_out $ TcRnUnknownMessage $ mkPlainError noHints $+                  (hang (text "reifyInstances:" <+> quotes (ppr ty))+                      2 (text "is not a class constraint or type family application")) }   where     doc = ClassInstanceCtx     bale_out msg = failWithTc msg      cvt :: Origin -> SrcSpan -> TH.Type -> TcM (LHsType GhcPs)     cvt origin loc th_ty = case convertToHsType origin loc th_ty of-      Left msg -> failWithTc msg+      Left msg -> failWithTc (TcRnUnknownMessage $ mkPlainError noHints msg)       Right ty -> return ty  {-@@ -1750,17 +1831,18 @@      do { mb_thing <- tcLookupImported_maybe name         ; case mb_thing of             Succeeded thing -> return (AGlobal thing)-            Failed msg      -> failWithTc msg+            Failed msg      -> failWithTc (TcRnUnknownMessage $ mkPlainError noHints msg)     }}}} -notInScope :: TH.Name -> SDoc-notInScope th_name = quotes (text (TH.pprint th_name)) <+>-                     text "is not in scope at a reify"+notInScope :: TH.Name -> TcRnMessage+notInScope th_name = TcRnUnknownMessage $ mkPlainError noHints $+  quotes (text (TH.pprint th_name)) <+>+          text "is not in scope at a reify"         -- Ugh! Rather an indirect way to display the name -notInEnv :: Name -> SDoc-notInEnv name = quotes (ppr name) <+>-                     text "is not in the type environment at a reify"+notInEnv :: Name -> TcRnMessage+notInEnv name = TcRnUnknownMessage $ mkPlainError noHints $+  quotes (ppr name) <+> text "is not in the type environment at a reify"  ------------------------------ reifyRoles :: TH.Name -> TcM [TH.Role]@@ -1768,7 +1850,7 @@   = do { thing <- getThing th_name        ; case thing of            AGlobal (ATyCon tc) -> return (map reify_role (tyConRoles tc))-           _ -> failWithTc (text "No roles associated with" <+> (ppr thing))+           _ -> failWithTc (TcRnUnknownMessage $ mkPlainError noHints $ text "No roles associated with" <+> (ppr thing))        }   where     reify_role Nominal          = TH.NominalR@@ -1842,7 +1924,7 @@    | isPrimTyCon tc   = return (TH.PrimTyConI (reifyName tc) (length (tyConVisibleTyVars tc))-                          (isUnliftedTyCon tc))+                          (isUnliftedTypeKind (tyConResKind tc)))    | isTypeFamilyTyCon tc   = do { let tvs      = tyConTyVars tc@@ -1956,7 +2038,7 @@                 -- constructors can be declared infix.                 -- See Note [Infix GADT constructors] in GHC.Tc.TyCl.               | dataConIsInfix dc && not isGadtDataCon ->-                  ASSERT( r_arg_tys `lengthIs` 2 ) do+                  assert (r_arg_tys `lengthIs` 2) $ do                   { let [r_a1, r_a2] = r_arg_tys                         [s1,   s2]   = dcdBangs                   ; return $ TH.InfixC (s1,r_a1) name (s2,r_a2) }@@ -1967,7 +2049,7 @@                   return $ TH.NormalC name (dcdBangs `zip` r_arg_tys)         ; let (ex_tvs', theta') | isGadtDataCon = (g_user_tvs, g_theta)-                               | otherwise     = ASSERT( all isTyVar ex_tvs )+                               | otherwise     = assert (all isTyVar ex_tvs)                                                  -- no covars for haskell syntax                                                  (map mk_specified ex_tvs, theta)              ret_con | null ex_tvs' && null theta' = return main_con@@ -1975,7 +2057,7 @@                          { cxt <- reifyCxt theta'                          ; ex_tvs'' <- reifyTyVarBndrs ex_tvs'                          ; return (TH.ForallC ex_tvs'' cxt main_con) }-       ; ASSERT( r_arg_tys `equalLength` dcdBangs )+       ; assert (r_arg_tys `equalLength` dcdBangs)          ret_con }   where     mk_specified tv = Bndr tv SpecifiedSpec@@ -2301,11 +2383,11 @@   | otherwise      = do { [r1,r2] <- reifyTypes [t1,t2]                         ; return (TH.ArrowT `TH.AppT` r1 `TH.AppT` r2) } reifyType ty@(FunTy { ft_af = af, ft_mult = tm, ft_arg = t1, ft_res = t2 })-  | InvisArg <- af = noTH (sLit "linear invisible argument") (ppr ty)+  | InvisArg <- af = noTH (text "linear invisible argument") (ppr ty)   | otherwise      = do { [rm,r1,r2] <- reifyTypes [tm,t1,t2]                         ; return (TH.MulArrowT `TH.AppT` rm `TH.AppT` r1 `TH.AppT` r2) } reifyType (CastTy t _)      = reifyType t -- Casts are ignored in TH-reifyType ty@(CoercionTy {})= noTH (sLit "coercions in types") (ppr ty)+reifyType ty@(CoercionTy {})= noTH (text "coercions in types") (ppr ty)  reify_for_all :: TyCoRep.ArgFlag -> TyCoRep.Type -> TcM TH.Type -- Arg of reify_for_all is always ForAllTy or a predicate FunTy@@ -2436,7 +2518,7 @@         -- have free variables, we may need to generate NameL's for them.   where     name    = getName thing-    mod     = ASSERT( isExternalName name ) nameModule name+    mod     = assert (isExternalName name) $ nameModule name     pkg_str = unitString (moduleUnit mod)     mod_str = moduleNameString (moduleName mod)     occ_str = occNameString occ@@ -2454,7 +2536,7 @@   | otherwise = TH.mkNameG_v pkg_str mod_str occ_str   where     name    = flSelector fl-    mod     = ASSERT( isExternalName name ) nameModule name+    mod     = assert (isExternalName name) $ nameModule name     pkg_str = unitString (moduleUnit mod)     mod_str = moduleNameString (moduleName mod)     occ_str = unpackFS (flLabel fl)@@ -2555,15 +2637,17 @@       usageToModule this_pkg (UsageHomeModule { usg_mod_name = mn }) = Just $ mkModule this_pkg mn       usageToModule _ (UsagePackageModule { usg_mod = m }) = Just m       usageToModule _ (UsageMergedRequirement { usg_mod = m }) = Just m+      usageToModule this_pkg (UsageHomeModuleInterface { usg_mod_name = mn }) = Just $ mkModule this_pkg mn  ------------------------------ mkThAppTs :: TH.Type -> [TH.Type] -> TH.Type mkThAppTs fun_ty arg_tys = foldl' TH.AppT fun_ty arg_tys -noTH :: PtrString -> SDoc -> TcM a-noTH s d = failWithTc (hsep [text "Can't represent" <+> ptext s <+>-                                text "in Template Haskell:",-                             nest 2 d])+noTH :: SDoc -> SDoc -> TcM a+noTH s d = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $+  (hsep [text "Can't represent" <+> s <+>+         text "in Template Haskell:",+           nest 2 d])  ppr_th :: TH.Ppr a => a -> SDoc ppr_th x = text (TH.pprint x)
GHC/Tc/Gen/Splice.hs-boot view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-}  module GHC.Tc.Gen.Splice where@@ -11,23 +10,23 @@ import GHC.Types.Annotations ( Annotation, CoreAnnTarget ) import GHC.Hs.Extension ( GhcRn, GhcPs, GhcTc ) -import GHC.Hs     ( HsSplice, HsBracket, HsExpr, LHsExpr, LHsType, LPat,-                    LHsDecl, ThModFinalizers )+import GHC.Hs     ( HsSplice, HsQuote, HsExpr, LHsExpr, LHsType,+                    LPat, LHsDecl, ThModFinalizers ) import qualified Language.Haskell.TH as TH  tcSpliceExpr :: HsSplice GhcRn              -> ExpRhoType              -> TcM (HsExpr GhcTc) +tcTypedBracket :: HsExpr GhcRn+               -> LHsExpr GhcRn+               -> ExpRhoType+               -> TcM (HsExpr GhcTc) tcUntypedBracket :: HsExpr GhcRn-                 -> HsBracket GhcRn+                 -> HsQuote GhcRn                  -> [PendingRnSplice]                  -> ExpRhoType                  -> TcM (HsExpr GhcTc)-tcTypedBracket :: HsExpr GhcRn-               -> HsBracket GhcRn-               -> ExpRhoType-               -> TcM (HsExpr GhcTc)  runTopSplice :: DelayedSplice -> TcM (HsExpr GhcTc)
GHC/Tc/Instance/Class.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-}  {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -6,15 +5,14 @@      matchGlobalInst,      ClsInstResult(..),      InstanceWhat(..), safeOverlap, instanceReturnsDictCon,-     AssocInstInfo(..), isNotAssociated+     AssocInstInfo(..), isNotAssociated,   ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Driver.Session +import GHC.Core.TyCo.Rep  import GHC.Tc.Utils.Env import GHC.Tc.Utils.Monad@@ -27,7 +25,7 @@ import GHC.Rename.Env( addUsedGRE )  import GHC.Builtin.Types-import GHC.Builtin.Types.Prim( eqPrimTyCon, eqReprPrimTyCon )+import GHC.Builtin.Types.Prim import GHC.Builtin.Names  import GHC.Types.Name.Reader( lookupGRE_FieldLabel, greMangledName )@@ -35,18 +33,23 @@ import GHC.Types.Name   ( Name, pprDefinedAt ) import GHC.Types.Var.Env ( VarEnv ) import GHC.Types.Id+import GHC.Types.Var  import GHC.Core.Predicate import GHC.Core.InstEnv import GHC.Core.Type-import GHC.Core.Make ( mkCharExpr, mkStringExprFS, mkNaturalExpr )+import GHC.Core.Make ( mkCharExpr, mkNaturalExpr, mkStringExprFS, mkCoreLams ) import GHC.Core.DataCon import GHC.Core.TyCon import GHC.Core.Class +import GHC.Core ( Expr(Var, App, Cast, Let), Bind (NonRec) )+import GHC.Types.Basic+ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Misc( splitAtList, fstOf3 )+import GHC.Data.FastString  import Data.Maybe @@ -98,14 +101,23 @@    | NotSure      -- Multiple matches and/or one or more unifiers -data InstanceWhat-  = BuiltinInstance-  | BuiltinEqInstance   -- A built-in "equality instance"; see the-                        -- GHC.Tc.Solver.Monad Note [Solved dictionaries]-  | LocalInstance-  | TopLevInstance { iw_dfun_id   :: DFunId-                   , iw_safe_over :: SafeOverlapping }+data InstanceWhat  -- How did we solve this constraint?+  = BuiltinEqInstance    -- Built-in solver for (t1 ~ t2), (t1 ~~ t2), Coercible t1 t2+                         -- See GHC.Tc.Solver.InertSet Note [Solved dictionaries] +  | BuiltinTypeableInstance TyCon   -- Built-in solver for Typeable (T t1 .. tn)+                         -- See Note [Well-staged instance evidence]++  | BuiltinInstance      -- Built-in solver for (C t1 .. tn) where C is+                         --   KnownNat, .. etc (classes with no top-level evidence)++  | LocalInstance        -- Solved by a quantified constraint+                         -- See GHC.Tc.Solver.InertSet Note [Solved dictionaries]++  | TopLevInstance       -- Solved by a top-level instance decl+      { iw_dfun_id   :: DFunId+      , iw_safe_over :: SafeOverlapping }+ instance Outputable ClsInstResult where   ppr NoInstance = text "NoInstance"   ppr NotSure    = text "NotSure"@@ -115,6 +127,7 @@  instance Outputable InstanceWhat where   ppr BuiltinInstance   = text "a built-in instance"+  ppr BuiltinTypeableInstance {} = text "a built-in typeable instance"   ppr BuiltinEqInstance = text "a built-in equality instance"   ppr LocalInstance     = text "a locally-quantified instance"   ppr (TopLevInstance { iw_dfun_id = dfun })@@ -126,9 +139,10 @@ safeOverlap _                                      = True  instanceReturnsDictCon :: InstanceWhat -> Bool--- See Note [Solved dictionaries] in GHC.Tc.Solver.Monad+-- See Note [Solved dictionaries] in GHC.Tc.Solver.InertSet instanceReturnsDictCon (TopLevInstance {}) = True instanceReturnsDictCon BuiltinInstance     = True+instanceReturnsDictCon BuiltinTypeableInstance {} = True instanceReturnsDictCon BuiltinEqInstance   = False instanceReturnsDictCon LocalInstance       = False @@ -145,6 +159,7 @@   = matchKnownChar dflags short_cut clas tys   | isCTupleClass clas                = matchCTuple          clas tys   | cls_name == typeableClassName     = matchTypeable        clas tys+  | cls_name == withDictClassName     = matchWithDict             tys   | clas `hasKey` heqTyConKey         = matchHeteroEquality       tys   | clas `hasKey` eqTyConKey          = matchHomoEquality         tys   | clas `hasKey` coercibleTyConKey   = matchCoercible            tys@@ -174,12 +189,12 @@         ; case (matches, unify, safeHaskFail) of              -- Nothing matches-            ([], [], _)+            ([], NoUnifiers, _)                 -> do { traceTc "matchClass not matching" (ppr pred)                       ; return NoInstance }              -- A single match (& no safe haskell failure)-            ([(ispec, inst_tys)], [], False)+            ([(ispec, inst_tys)], NoUnifiers, False)                 | short_cut_solver      -- Called from the short-cut solver                 , isOverlappable ispec                 -- If the instance has OVERLAPPABLE or OVERLAPS or INCOHERENT@@ -361,8 +376,8 @@               -> Bool      -- True <=> caller is the short-cut solver                            -- See Note [Shortcut solving: overlap]               -> Class -> [Type] -> TcM ClsInstResult-matchKnownNat _ _ clas [ty]     -- clas = KnownNat-  | Just n <- isNumLitTy ty  = makeLitDict clas ty (mkNaturalExpr n)+matchKnownNat dflags _ clas [ty]     -- clas = KnownNat+  | Just n <- isNumLitTy ty  = makeLitDict clas ty (mkNaturalExpr (targetPlatform dflags) n) matchKnownNat df sc clas tys = matchInstEnv df sc clas tys  -- See Note [Fabricating Evidence for Literals in Backpack] for why  -- this lookup into the instance environment is required.@@ -421,6 +436,182 @@  {- ******************************************************************** *                                                                     *+                   Class lookup for WithDict+*                                                                     *+***********************************************************************-}++-- See Note [withDict]+matchWithDict :: [Type] -> TcM ClsInstResult+matchWithDict [cls, mty]+    -- Check that cls is a class constraint `C t_1 ... t_n`, where+    -- `dict_tc = C` and `dict_args = t_1 ... t_n`.+  | Just (dict_tc, dict_args) <- tcSplitTyConApp_maybe cls+    -- Check that C is a class of the form+    -- `class C a_1 ... a_n where op :: meth_ty`+    -- and in that case let+    -- co :: C t1 ..tn ~R# inst_meth_ty+  , Just (inst_meth_ty, co) <- tcInstNewTyCon_maybe dict_tc dict_args+  = do { sv <- mkSysLocalM (fsLit "withDict_s") Many mty+       ; k  <- mkSysLocalM (fsLit "withDict_k") Many (mkInvisFunTyMany cls openAlphaTy)++       ; let evWithDict_type = mkSpecForAllTys [runtimeRep1TyVar, openAlphaTyVar] $+                               mkVisFunTysMany [mty, mkInvisFunTyMany cls openAlphaTy] openAlphaTy++       ; wd_id <- mkSysLocalM (fsLit "withDict_wd") Many evWithDict_type+       ; let wd_id' = wd_id `setInlinePragma` neverInlinePragma+               -- Inlining withDict can cause the specialiser to incorrectly common up+               -- distinct evidence terms. See (WD6) in Note [withDict].++       -- Given co2 : mty ~N# inst_meth_ty, construct the method of+       -- the WithDict dictionary:+       -- \@(r : RuntimeRep) @(a :: TYPE r) (sv : mty) (k :: cls => a) -> k (sv |> (sub co; sym co2))+       ; let evWithDict co2 =+               let wd_rhs = mkCoreLams [ runtimeRep1TyVar, openAlphaTyVar, sv, k ] $+                            Var k `App` Cast (Var sv) (mkTcTransCo (mkTcSubCo co2) (mkTcSymCo co))+               in Let (NonRec wd_id' wd_rhs) (Var wd_id')+         -- Why a Let?  See (WD6) in Note [withDict]++       ; tc <- tcLookupTyCon withDictClassName+       ; let Just withdict_data_con+                 = tyConSingleDataCon_maybe tc    -- "Data constructor"+                                                  -- for WithDict+             mk_ev [c] = evDataConApp withdict_data_con+                            [cls, mty] [evWithDict (evTermCoercion (EvExpr c))]+             mk_ev e   = pprPanic "matchWithDict" (ppr e)++       ; return $ OneInst { cir_new_theta = [mkPrimEqPred mty inst_meth_ty]+                          , cir_mk_ev     = mk_ev+                          , cir_what      = BuiltinInstance }+       }++matchWithDict _+  = return NoInstance++{-+Note [withDict]+~~~~~~~~~~~~~~~+The class `WithDict` is defined as:++    class WithDict cls meth where+        withDict :: forall {rr :: RuntimeRep} (r :: TYPE rr). meth -> (cls => r) -> r++This class is special, like `Typeable`: GHC automatically solves+for instances of `WithDict`, users cannot write their own.++It is used to implement a primitive that we cannot define in Haskell+but we can write in Core.++`WithDict` is used to create dictionaries for classes with a single method.+Consider a class like this:++   class C a where+     f :: T a++We can use `withDict` to cast values of type `T a` into dictionaries for `C a`.+To do this, we can define a function like this in the library:++  withT :: T a -> (C a => b) -> b+  withT t k = withDict @(C a) @(T a) t k++Here:++* The `cls` in `withDict` is instantiated to `C a`.++* The `meth` in `withDict` is instantiated to `T a`.+  The definition of `T` itself is irrelevant, only that `C a` is a class+  with a single method of type `T a`.++* The `r` in `withDict` is instantiated to `b`.++For any single-method class C:+   class C a1 .. an where op :: meth_ty++The solver will solve the constraint `WithDict (C t1 .. tn) mty`+as if the following instance declaration existed:++instance (mty ~# inst_meth_ty) => WithDict (C t1..tn) mty where+  withDict = \@{rr} @(r :: TYPE rr) (sv :: mty) (k :: C t1..tn => r) ->+    k (sv |> (sub co2; sym co))++That is, it matches on the first (constraint) argument of C; if C is+a single-method class, the instance "fires" and emits an equality+constraint `mty ~ inst_meth_ty`, where `inst_meth_ty` is `meth_ty[ti/ai]`.+The coercion `co2` witnesses the equality `mty ~ inst_meth_ty`.++The coercion `co` is a newtype coercion that coerces from `C t1 ... tn`+to `inst_meth_ty`.+This coercion is guaranteed to exist by virtue of the fact that+C is a class with exactly one method and no superclasses, so it+is treated like a newtype when compiled to Core.++The condition that `C` is a single-method class is implemented in the+guards of matchWithDict's definition.+If the conditions are not held, the rewriting will not fire,+and we'll report an unsolved constraint.++Some further observations about `withDict`:++(WD1) The `cls` in the type of withDict must be explicitly instantiated with+      visible type application, as invoking `withDict` would be ambiguous+      otherwise.++      For examples of how `withDict` is used in the `base` library, see `withSNat`+      in GHC.TypeNats, as well as `withSChar` and `withSSymbol` in GHC.TypeLits.++(WD2) The `r` is representation-polymorphic, to support things like+      `withTypeable` in `Data.Typeable.Internal`.++(WD3) As an alternative to `withDict`, one could define functions like `withT`+      above in terms of `unsafeCoerce`. This is more error-prone, however.++(WD4) In order to define things like `reifySymbol` below:++        reifySymbol :: forall r. String -> (forall (n :: Symbol). KnownSymbol n => r) -> r++      `withDict` needs to be instantiated with `Any`, like so:++        reifySymbol n k = withDict @(KnownSymbol Any) @String @r n (k @Any)++      The use of `Any` is explained in Note [NOINLINE someNatVal] in+      base:GHC.TypeNats.++(WD5) In earlier implementations, `withDict` was implemented as an identifier+      with special handling during either constant-folding or desugaring.+      The current approach is more robust, previously the type of `withDict`+      did not have a type-class constraint and was overly polymorphic.+      See #19915.++(WD6) In fact we desugar `withDict @(C t_1 ... t_n) @mty @{rr} @r` to++         let wd = \sv k -> k (sv |> co)+             {-# NOINLINE wd #-}+         in wd++      The local `let` and NOINLINE pragma ensure that the type-class specialiser+      doesn't wrongly common up distinct evidence terms. This is super important!+      Suppose we have calls+          withDict A k+          withDict B k+      where k1, k2 :: C T -> blah.  If we inline those withDict calls we'll get+          k (A |> co1)+          k (B |> co2)+      and the Specialiser will assume that those arguments (of type `C T`) are+      the same, will specialise `k` for that type, and will call the same,+      specialised function from both call sites.  #21575 is a concrete case in point.++      Solution: never inline `withDict`. Note that it is not sufficient to delay+      inlining until after the specialiser (that is, until Phase 2), because if+      we inline withDict in module A but import it in module B, the specialiser+      will try to common up the two distinct evidence terms.+      See test case T21575b.++      This solution is unsatisfactory, as it imposes a performance overhead+      on uses of withDict.++-}++{- ********************************************************************+*                                                                     *                    Class lookup for Typeable *                                                                     * ***********************************************************************-}@@ -464,9 +655,10 @@ doTyConApp :: Class -> Type -> TyCon -> [Kind] -> TcM ClsInstResult doTyConApp clas ty tc kind_args   | tyConIsTypeable tc-  = return $ OneInst { cir_new_theta = (map (mk_typeable_pred clas) kind_args)-                     , cir_mk_ev     = mk_ev-                     , cir_what      = BuiltinInstance }+  = do+     return $ OneInst { cir_new_theta = (map (mk_typeable_pred clas) kind_args)+                      , cir_mk_ev     = mk_ev+                      , cir_what      = BuiltinTypeableInstance tc }   | otherwise   = return NoInstance   where@@ -610,7 +802,6 @@   where     args' = [k, k, t1, t2] matchCoercible args = pprPanic "matchLiftedCoercible" (ppr args)-  {- ******************************************************************** *                                                                     *
GHC/Tc/Instance/Family.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, GADTs, ViewPatterns #-}+{-# LANGUAGE GADTs, ViewPatterns #-}  -- | The @FamInst@ type: family instance heads module GHC.Tc.Instance.Family (@@ -25,10 +25,10 @@ import GHC.Core.DataCon ( dataConName ) import GHC.Core.TyCo.Rep import GHC.Core.TyCo.FVs-import GHC.Core.TyCo.Ppr ( pprWithExplicitKindsWhen )  import GHC.Iface.Load +import GHC.Tc.Errors.Types import GHC.Tc.Types.Evidence import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Instantiate( freshenTyVarBndrs, freshenCoVarBndrsX )@@ -49,19 +49,19 @@ import GHC.Utils.Outputable import GHC.Utils.Misc import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Utils.FV  import GHC.Data.Bag( Bag, unionBags, unitBag ) import GHC.Data.Maybe  import Control.Monad-import Data.List ( sortBy ) import Data.List.NonEmpty ( NonEmpty(..) )+import qualified Data.List.NonEmpty as NE import Data.Function ( on )  import qualified GHC.LanguageExtensions  as LangExt--#include "HsVersions.h"+import GHC.Unit.Env (unitEnv_hpts)  {- Note [The type family instance consistency story] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -294,14 +294,14 @@ -- See Note [The type family instance consistency story]. checkFamInstConsistency :: [Module] -> TcM () checkFamInstConsistency directlyImpMods-  = do { (eps, hpt) <- getEpsAndHpt+  = do { (eps, hug) <- getEpsAndHug        ; traceTc "checkFamInstConsistency" (ppr directlyImpMods)        ; let { -- Fetch the iface of a given module.  Must succeed as                -- all directly imported modules must already have been loaded.                modIface mod =-                 case lookupIfaceByModule hpt (eps_PIT eps) mod of+                 case lookupIfaceByModule hug (eps_PIT eps) mod of                    Nothing    -> panicDoc "FamInst.checkFamInstConsistency"-                                          (ppr mod $$ pprHPT hpt)+                                          (ppr mod $$ ppr hug)                    Just iface -> iface                 -- Which family instance modules were checked for consistency@@ -319,7 +319,8 @@              ; hmiFamInstEnv = extendFamInstEnvList emptyFamInstEnv                                . md_fam_insts . hm_details              ; hpt_fam_insts = mkModuleEnv [ (hmiModule hmi, hmiFamInstEnv hmi)-                                           | hmi <- eltsHpt hpt]+                                           | hpt <- unitEnv_hpts hug+                                           , hmi <- eltsHpt hpt ]               } @@ -511,7 +512,7 @@   , let rep_tc = dataFamInstRepTyCon rep_fam         co     = mkUnbranchedAxInstCo Representational ax rep_args                                       (mkCoVarCos cvs)-  = ASSERT( null rep_cos ) -- See Note [Constrained family instances] in GHC.Core.FamInstEnv+  = assert (null rep_cos) $ -- See Note [Constrained family instances] in GHC.Core.FamInstEnv     Just (rep_tc, rep_args, co)    | otherwise@@ -532,7 +533,7 @@ -- It does not look through type families. -- It does not normalise arguments to a tycon. ----- If the result is Just (rep_ty, (co, gres), rep_ty), then+-- If the result is Just ((gres, co), rep_ty), then --    co : ty ~R rep_ty --    gres are the GREs for the data constructors that --                          had to be in scope@@ -699,7 +700,7 @@ checkForConflicts inst_envs fam_inst   = do { let conflicts = lookupFamInstEnvConflicts inst_envs fam_inst        ; traceTc "checkForConflicts" $-         vcat [ ppr (map fim_instance conflicts)+         vcat [ ppr conflicts               , ppr fam_inst               -- , ppr inst_envs          ]@@ -752,7 +753,7 @@    -> [Bool]       -- ^ Injectivity annotation    -> TcM () reportInjectivityErrors dflags fi_ax axiom inj-  = ASSERT2( any id inj, text "No injective type variables" )+  = assertPpr (any id inj) (text "No injective type variables") $     do let lhs             = coAxBranchLHS axiom            rhs             = coAxBranchRHS axiom            fam_tc          = coAxiomTyCon fi_ax@@ -906,8 +907,8 @@                   -> [Type] -- LHS arguments                   -> Type   -- the RHS                   -> ( TyVarSet-                     , Bool   -- True <=> one or more variable is used invisibly-                     , Bool ) -- True <=> suggest -XUndecidableInstances+                     , HasKinds                     -- YesHasKinds <=> one or more variable is used invisibly+                     , SuggestUndecidableInstances) -- YesSuggestUndecidableInstaces <=> suggest -XUndecidableInstances -- See Note [Verifying injectivity annotation] in GHC.Core.FamInstEnv. -- This function implements check (4) described there, further -- described in Note [Coverage condition for injective type families].@@ -918,7 +919,7 @@ -- precise names of variables that are not mentioned in the RHS. unusedInjTvsInRHS dflags tycon@(tyConInjectivityInfo -> Injective inj_list) lhs rhs =   -- Note [Coverage condition for injective type families], step 5-  (bad_vars, any_invisible, suggest_undec)+  (bad_vars, hasKinds any_invisible, suggestUndecidableInstances suggest_undec)     where       undec_inst = xopt LangExt.UndecidableInstances dflags @@ -939,7 +940,7 @@                       (lhs_vars `subVarSet` fvVarSet (injectiveVarsOfType True rhs))  -- When the type family is not injective in any arguments-unusedInjTvsInRHS _ _ _ _ = (emptyVarSet, False, False)+unusedInjTvsInRHS _ _ _ _ = (emptyVarSet, NoHasKinds, NoSuggestUndecidableInstaces)  --------------------------------------- -- Producing injectivity error messages@@ -950,90 +951,58 @@ reportConflictingInjectivityErrs :: TyCon -> [CoAxBranch] -> CoAxBranch -> TcM () reportConflictingInjectivityErrs _ [] _ = return () reportConflictingInjectivityErrs fam_tc (confEqn1:_) tyfamEqn-  = addErrs [buildInjectivityError fam_tc herald (confEqn1 :| [tyfamEqn])]-  where-    herald = text "Type family equation right-hand sides overlap; this violates" $$-             text "the family's injectivity annotation:"---- | Injectivity error herald common to all injectivity errors.-injectivityErrorHerald :: SDoc-injectivityErrorHerald =-  text "Type family equation violates the family's injectivity annotation."-+  = addErrs [buildInjectivityError (TcRnFamInstNotInjective InjErrRhsOverlap)+                                   fam_tc+                                   (confEqn1 :| [tyfamEqn])]  -- | Report error message for equation with injective type variables unused in -- the RHS. Note [Coverage condition for injective type families], step 6 reportUnusedInjectiveVarsErr :: TyCon                              -> TyVarSet-                             -> Bool   -- True <=> print invisible arguments-                             -> Bool   -- True <=> suggest -XUndecidableInstances+                             -> HasKinds                    -- YesHasKinds <=> print invisible arguments+                             -> SuggestUndecidableInstances -- YesSuggestUndecidableInstaces <=> suggest -XUndecidableInstances                              -> CoAxBranch                              -> TcM () reportUnusedInjectiveVarsErr fam_tc tvs has_kinds undec_inst tyfamEqn-  = let (loc, doc) = buildInjectivityError fam_tc-                                  (injectivityErrorHerald $$-                                   herald $$-                                   text "In the type family equation:")-                                  (tyfamEqn :| [])-    in addErrAt loc (pprWithExplicitKindsWhen has_kinds doc)-    where-      herald = sep [ what <+> text "variable" <>-                  pluralVarSet tvs <+> pprVarSet tvs (pprQuotedList . scopedSort)-                , text "cannot be inferred from the right-hand side." ]-               $$ extra--      what | has_kinds = text "Type/kind"-           | otherwise = text "Type"--      extra | undec_inst = text "Using UndecidableInstances might help"-            | otherwise  = empty+  = let reason     = InjErrCannotInferFromRhs tvs has_kinds undec_inst+        (loc, dia) = buildInjectivityError (TcRnFamInstNotInjective reason) fam_tc (tyfamEqn :| [])+    in addErrAt loc dia  -- | Report error message for equation that has a type family call at the top -- level of RHS reportTfHeadedErr :: TyCon -> CoAxBranch -> TcM () reportTfHeadedErr fam_tc branch-  = addErrs [buildInjectivityError fam_tc-               (injectivityErrorHerald $$-                 text "RHS of injective type family equation cannot" <+>-                 text "be a type family:")-               (branch :| [])]+  = addErrs [buildInjectivityError (TcRnFamInstNotInjective InjErrRhsCannotBeATypeFam)+                                   fam_tc+                                   (branch :| [])]  -- | Report error message for equation that has a bare type variable in the RHS -- but LHS pattern is not a bare type variable. reportBareVariableInRHSErr :: TyCon -> [Type] -> CoAxBranch -> TcM () reportBareVariableInRHSErr fam_tc tys branch-  = addErrs [buildInjectivityError fam_tc-                 (injectivityErrorHerald $$-                  text "RHS of injective type family equation is a bare" <+>-                  text "type variable" $$-                  text "but these LHS type and kind patterns are not bare" <+>-                  text "variables:" <+> pprQuotedList tys)-                 (branch :| [])]+  = addErrs [buildInjectivityError (TcRnFamInstNotInjective (InjErrRhsBareTyVar tys))+                                   fam_tc+                                   (branch :| [])] -buildInjectivityError :: TyCon -> SDoc -> NonEmpty CoAxBranch -> (SrcSpan, SDoc)-buildInjectivityError fam_tc herald (eqn1 :| rest_eqns)-  = ( coAxBranchSpan eqn1-    , hang herald-         2 (vcat (map (pprCoAxBranchUser fam_tc) (eqn1 : rest_eqns))) )+buildInjectivityError :: (TyCon -> NonEmpty CoAxBranch -> TcRnMessage)+                      -> TyCon+                      -> NonEmpty CoAxBranch+                      -> (SrcSpan, TcRnMessage)+buildInjectivityError mkErr fam_tc branches+  = ( coAxBranchSpan (NE.head branches), mkErr fam_tc branches ) -reportConflictInstErr :: FamInst -> [FamInstMatch] -> TcRn ()+reportConflictInstErr :: FamInst -> [FamInst] -> TcRn () reportConflictInstErr _ []   = return ()  -- No conflicts-reportConflictInstErr fam_inst (match1 : _)-  | FamInstMatch { fim_instance = conf_inst } <- match1-  , let sorted  = sortBy (SrcLoc.leftmost_smallest `on` getSpan) [fam_inst, conf_inst]-        fi1     = head sorted-        span    = coAxBranchSpan (coAxiomSingleBranch (famInstAxiom fi1))-  = setSrcSpan span $ addErr $-    hang (text "Conflicting family instance declarations:")-       2 (vcat [ pprCoAxBranchUser (coAxiomTyCon ax) (coAxiomSingleBranch ax)-               | fi <- sorted-               , let ax = famInstAxiom fi ])- where-   getSpan = getSrcSpan . famInstAxiom+reportConflictInstErr fam_inst (conf_inst : _) =    -- The sortBy just arranges that instances are displayed in order    -- of source location, which reduced wobbling in error messages,    -- and is better for users+  let   sorted  = NE.sortBy (SrcLoc.leftmost_smallest `on` getSpan) (fam_inst NE.:| [conf_inst])+        fi1     = NE.head sorted+        span    = coAxBranchSpan (coAxiomSingleBranch (famInstAxiom fi1))+        getSpan = getSrcSpan . famInstAxiom+  in setSrcSpan span $ addErr $ TcRnConflictingFamInstDecls sorted  tcGetFamInstEnvs :: TcM FamInstEnvs -- Gets both the external-package inst-env
GHC/Tc/Instance/FunDeps.hs view
@@ -5,7 +5,7 @@  -} -{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFunctor #-}  -- | Functional dependencies --@@ -18,11 +18,10 @@    , checkInstCoverage    , checkFunDeps    , pprFundeps+   , instFD, closeWrtFunDeps    ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Types.Name@@ -42,7 +41,7 @@  import GHC.Utils.Outputable import GHC.Utils.FV-import GHC.Utils.Error( Validity(..), allValid )+import GHC.Utils.Error( Validity'(..), Validity, allValid ) import GHC.Utils.Misc import GHC.Utils.Panic @@ -120,6 +119,7 @@           , fd_pred1 :: PredType   -- The FunDepEqn arose from           , fd_pred2 :: PredType   --  combining these two constraints           , fd_loc   :: loc  }+    deriving Functor  {- Given a bunch of predicates that must hold, such as@@ -206,16 +206,11 @@  improveFromInstEnv :: InstEnvs                    -> (PredType -> SrcSpan -> loc)-                   -> PredType+                   -> Class -> [Type]                    -> [FunDepEqn loc] -- Needs to be a FunDepEqn because                                       -- of quantified variables -- Post: Equations oriented from the template (matching instance) to the workitem!-improveFromInstEnv inst_env mk_loc pred-  | Just (cls, tys) <- ASSERT2( isClassPred pred, ppr pred )-                       getClassPredTys_maybe pred-  , let (cls_tvs, cls_fds) = classTvsFds cls-        instances          = classInstances inst_env cls-        rough_tcs          = roughMatchTcs tys+improveFromInstEnv inst_env mk_loc cls tys   = [ FDEqn { fd_qtvs = meta_tvs, fd_eqs = eqs             , fd_pred1 = p_inst, fd_pred2 = pred             , fd_loc = mk_loc p_inst (getSrcSpan (is_dfun ispec)) }@@ -231,9 +226,15 @@                                       tys trimmed_tcs -- NB: orientation     , let p_inst = mkClassPred cls (is_tys ispec)     ]-improveFromInstEnv _ _ _ = []+  where+    (cls_tvs, cls_fds) = classTvsFds cls+    instances          = classInstances inst_env cls+    rough_tcs          = RM_KnownTc (className cls) : roughMatchTcs tys+    pred               = mkClassPred cls tys  ++ improveClsFD :: [TyVar] -> FunDep TyVar    -- One functional dependency from the class              -> ClsInst                    -- An instance template              -> [Type] -> [RoughMatchTc]   -- Arguments of this (C tys) predicate@@ -266,9 +267,9 @@   = []          -- Filter out ones that can't possibly match,    | otherwise-  = ASSERT2( equalLength tys_inst tys_actual &&-             equalLength tys_inst clas_tvs-            , ppr tys_inst <+> ppr tys_actual )+  = assertPpr (equalLength tys_inst tys_actual &&+               equalLength tys_inst clas_tvs)+              (ppr tys_inst <+> ppr tys_actual) $      case tcMatchTyKis ltys1 ltys2 of         Nothing  -> []@@ -351,7 +352,7 @@  For the coverage condition, we check    (normal)    fv(t2) `subset` fv(t1)-   (liberal)   fv(t2) `subset` oclose(fv(t1), theta)+   (liberal)   fv(t2) `subset` closeWrtFunDeps(fv(t1), theta)  The liberal version  ensures the self-consistency of the instance, but it does not guarantee termination. Example:@@ -364,7 +365,7 @@    instance Mul a b c => Mul a [b] [c] where x .*. v = map (x.*.) v  In the third instance, it's not the case that fv([c]) `subset` fv(a,[b]).-But it is the case that fv([c]) `subset` oclose( theta, fv(a,[b]) )+But it is the case that fv([c]) `subset` closeWrtFunDeps( theta, fv(a,[b]) )  But it is a mistake to accept the instance because then this defn:         f = \ b x y -> if b then x .*. [y] else y@@ -376,7 +377,7 @@                   -> Class -> [PredType] -> [Type]                   -> Validity -- "be_liberal" flag says whether to use "liberal" coverage of---              See Note [Coverage Condition] below+--              See Note [Coverage condition] below -- -- Return values --    Nothing  => no problems@@ -397,7 +398,7 @@          undetermined_tvs | be_liberal = liberal_undet_tvs                           | otherwise  = conserv_undet_tvs -         closed_ls_tvs = oclose theta ls_tvs+         closed_ls_tvs = closeWrtFunDeps theta ls_tvs          liberal_undet_tvs = (`minusVarSet` closed_ls_tvs) <$> rs_tvs          conserv_undet_tvs = (`minusVarSet` ls_tvs)        <$> rs_tvs @@ -408,7 +409,7 @@                vcat [ -- text "ls_tvs" <+> ppr ls_tvs                       -- , text "closed ls_tvs" <+> ppr (closeOverKinds ls_tvs)                       -- , text "theta" <+> ppr theta-                      -- , text "oclose" <+> ppr (oclose theta (closeOverKinds ls_tvs))+                      -- , text "closeWrtFunDeps" <+> ppr (closeWrtFunDeps theta (closeOverKinds ls_tvs))                       -- , text "rs_tvs" <+> ppr rs_tvs                       sep [ text "The"                             <+> ppWhen be_liberal (text "liberal")@@ -467,17 +468,17 @@     we get {l,k,xs} -> b    * Note the 'k'!! We must call closeOverKinds on the seed set-    ls_tvs = {l,r,xs}, BEFORE doing oclose, else the {l,k,xs}->b+    ls_tvs = {l,r,xs}, BEFORE doing closeWrtFunDeps, else the {l,k,xs}->b     fundep won't fire.  This was the reason for #10564. -  * So starting from seeds {l,r,xs,k} we do oclose to get+  * So starting from seeds {l,r,xs,k} we do closeWrtFunDeps to get     first {l,r,xs,k,b}, via the HMemberM constraint, and then     {l,r,xs,k,b,v}, via the HasFieldM1 constraint.    * And that fixes v.  However, we must closeOverKinds whenever augmenting the seed set-in oclose!  Consider #10109:+in closeWrtFunDeps!  Consider #10109:    data Succ a   -- Succ :: forall k. k -> *   class Add (a :: k1) (b :: k2) (ab :: k3) | a b -> ab@@ -493,25 +494,27 @@ Bottom line:   * closeOverKinds on initial seeds (done automatically     by tyCoVarsOfTypes in checkInstCoverage)-  * and closeOverKinds whenever extending those seeds (in oclose)+  * and closeOverKinds whenever extending those seeds (in closeWrtFunDeps)  Note [The liberal coverage condition] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-(oclose preds tvs) closes the set of type variables tvs,+(closeWrtFunDeps preds tvs) closes the set of type variables tvs, wrt functional dependencies in preds.  The result is a superset of the argument set.  For example, if we have         class C a b | a->b where ... then-        oclose [C (x,y) z, C (x,p) q] {x,y} = {x,y,z}+        closeWrtFunDeps [C (x,y) z, C (x,p) q] {x,y} = {x,y,z} because if we know x and y then that fixes z.  We also use equality predicates in the predicates; if we have an assumption `t1 ~ t2`, then we use the fact that if we know `t1` we also know `t2` and the other way.-  eg    oclose [C (x,y) z, a ~ x] {a,y} = {a,y,z,x}+  eg    closeWrtFunDeps [C (x,y) z, a ~ x] {a,y} = {a,y,z,x} -oclose is used (only) when checking the coverage condition for-an instance declaration+closeWrtFunDeps is used+ - when checking the coverage condition for an instance declaration+ - when determining which tyvars are unquantifiable during generalization, in+   GHC.Tc.Solver.decideMonoTyVars.  Note [Equality superclasses] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -522,10 +525,10 @@   * (a ~~ b) is a superclass of (a ~ b)   * (a ~# b) is a superclass of (a ~~ b) -So when oclose expands superclasses we'll get a (a ~# [b]) superclass.+So when closeWrtFunDeps expands superclasses we'll get a (a ~# [b]) superclass. But that's an EqPred not a ClassPred, and we jolly well do want to account for the mutual functional dependencies implied by (t1 ~# t2).-Hence the EqPred handling in oclose.  See #10778.+Hence the EqPred handling in closeWrtFunDeps.  See #10778.  Note [Care with type functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -535,7 +538,7 @@   type family G c d = r | r -> d  Now consider-  oclose (C (F a b) (G c d)) {a,b}+  closeWrtFunDeps (C (F a b) (G c d)) {a,b}  Knowing {a,b} fixes (F a b) regardless of the injectivity of F. But knowing (G c d) fixes only {d}, because G is only injective@@ -544,12 +547,17 @@ Hence the tyCoVarsOfTypes/injTyVarsOfTypes dance in tv_fds. -} -oclose :: [PredType] -> TyCoVarSet -> TyCoVarSet+closeWrtFunDeps :: [PredType] -> TyCoVarSet -> TyCoVarSet -- See Note [The liberal coverage condition]-oclose preds fixed_tvs+closeWrtFunDeps preds fixed_tvs   | null tv_fds = fixed_tvs -- Fast escape hatch for common case.-  | otherwise   = fixVarSet extend fixed_tvs+  | otherwise   = assertPpr (closeOverKinds fixed_tvs == fixed_tvs)+                    (vcat [ text "closeWrtFunDeps: fixed_tvs is not closed over kinds"+                          , text "fixed_tvs:" <+> ppr fixed_tvs+                          , text "closure:" <+> ppr (closeOverKinds fixed_tvs) ])+                $ fixVarSet extend fixed_tvs   where+     extend fixed_tvs = foldl' add fixed_tvs tv_fds        where           add fixed_tvs (ls,rs)@@ -675,8 +683,9 @@ -- Hence, we Nothing-ise the tb and tc types right here -- -- Result list is same length as input list, just with more Nothings-trimRoughMatchTcs clas_tvs (ltvs, _) mb_tcs-  = zipWith select clas_tvs mb_tcs+trimRoughMatchTcs _clas_tvs _ [] = panic "trimRoughMatchTcs: nullary [RoughMatchTc]"+trimRoughMatchTcs clas_tvs (ltvs, _) (cls:mb_tcs)+  = cls : zipWith select clas_tvs mb_tcs   where     select clas_tv mb_tc | clas_tv `elem` ltvs = mb_tc-                         | otherwise           = OtherTc+                         | otherwise           = RM_WildCard
GHC/Tc/Instance/Typeable.hs view
@@ -3,15 +3,13 @@ (c) The GRASP/AQUA Project, Glasgow University, 1992-1999 -} -{-# LANGUAGE CPP #-}+ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-}  module GHC.Tc.Instance.Typeable(mkTypeableBinds, tyConIsTypeable) where -#include "HsVersions.h"- import GHC.Prelude import GHC.Platform @@ -47,10 +45,9 @@ import GHC.Utils.Panic import GHC.Data.FastString ( FastString, mkFastString, fsLit ) -import Control.Monad.Trans.State+import Control.Monad.Trans.State.Strict import Control.Monad.Trans.Class (lift) import Data.Maybe ( isJust )-import Data.Word( Word64 )  {- Note [Grand plan for Typeable] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -175,7 +172,7 @@        } } }   where     needs_typeable_binds tc-      | tc `elem` ghcTypesTypeableTyCons+      | tc `elem` [runtimeRepTyCon, levityTyCon, vecCountTyCon, vecElemTyCon]       = False       | otherwise =           isAlgTyCon tc@@ -336,15 +333,7 @@                      -- Build TypeRepTodos for types in GHC.Prim                    ; todo2 <- todoForTyCons gHC_PRIM ghc_prim_module_id                                             ghcPrimTypeableTyCons--                   ; tcg_env <- getGblEnv-                   ; let mod_id = case tcg_tr_module tcg_env of  -- Should be set by now-                                   Just mod_id -> mod_id-                                   Nothing     -> pprPanic "tcMkTypeableBinds" empty--                   ; todo3 <- todoForTyCons gHC_TYPES mod_id ghcTypesTypeableTyCons--                   ; return ( gbl_env' , [todo1, todo2, todo3])+                   ; return ( gbl_env' , [todo1, todo2])                    }            else do gbl_env <- getGblEnv                    return (gbl_env, [])@@ -359,18 +348,12 @@ -- Note [Built-in syntax and the OrigNameCache] in "GHC.Iface.Env" for more. ghcPrimTypeableTyCons :: [TyCon] ghcPrimTypeableTyCons = concat-    [ map (tupleTyCon Unboxed) [0..mAX_TUPLE_SIZE]+    [ [ runtimeRepTyCon, levityTyCon, vecCountTyCon, vecElemTyCon ]+    , map (tupleTyCon Unboxed) [0..mAX_TUPLE_SIZE]     , map sumTyCon [2..mAX_SUM_SIZE]     , primTyCons     ] --- | These are types which are defined in GHC.Types but are needed in order to--- typecheck the other generated bindings, therefore to avoid ordering issues we--- generate them up-front along with the bindings from GHC.Prim.-ghcTypesTypeableTyCons :: [TyCon]-ghcTypesTypeableTyCons = [ runtimeRepTyCon, levityTyCon-                         , vecCountTyCon, vecElemTyCon ]- data TypeableStuff     = Stuff { platform       :: Platform        -- ^ Target platform             , trTyConDataCon :: DataCon         -- ^ of @TyCon@@@ -657,11 +640,11 @@                    -> LHsExpr GhcTc mkTyConRepTyConRHS (Stuff {..}) todo tycon kind_rep   =           nlHsDataCon trTyConDataCon-    `nlHsApp` nlHsLit (word64 platform high)-    `nlHsApp` nlHsLit (word64 platform low)+    `nlHsApp` nlHsLit (HsWord64Prim NoSourceText (toInteger high))+    `nlHsApp` nlHsLit (HsWord64Prim NoSourceText (toInteger low))     `nlHsApp` mod_rep_expr todo     `nlHsApp` trNameLit (mkFastString tycon_str)-    `nlHsApp` nlHsLit (int n_kind_vars)+    `nlHsApp` nlHsLit (HsIntPrim NoSourceText (toInteger n_kind_vars))     `nlHsApp` kind_rep   where     n_kind_vars = length $ filter isNamedTyConBinder (tyConBinders tycon)@@ -675,14 +658,6 @@                                                    , mod_fingerprint todo                                                    , fingerprintString tycon_str                                                    ]--    int :: Int -> HsLit GhcTc-    int n = HsIntPrim (SourceText $ show n) (toInteger n)--word64 :: Platform -> Word64 -> HsLit GhcTc-word64 platform n = case platformWordSize platform of-   PW4 -> HsWord64Prim NoSourceText (toInteger n)-   PW8 -> HsWordPrim   NoSourceText (toInteger n)  {- Note [Representing TyCon kinds: KindRep]
GHC/Tc/Module.hs view
@@ -6,6 +6,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE TupleSections #-}  {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -26,6 +27,8 @@         tcRnDeclsi,         isGHCiMonad,         runTcInteractive,    -- Used by GHC API clients (#8878)+        withTcPlugins,       -- Used by GHC API clients (#20499)+        withHoleFitPlugins,  -- Used by GHC API clients (#20499)         tcRnLookupName,         tcRnGetInfo,         tcRnModule, tcRnModuleTcRnM,@@ -52,8 +55,10 @@ import GHC.Driver.Env import GHC.Driver.Plugins import GHC.Driver.Session+import GHC.Driver.Config.Diagnostic  import GHC.Tc.Errors.Hole.FitTypes ( HoleFitPluginR (..) )+import GHC.Tc.Errors.Types import {-# SOURCE #-} GHC.Tc.Gen.Splice ( finishTH, runRemoteModFinalizers ) import GHC.Tc.Gen.HsType import GHC.Tc.Validity( checkValidType )@@ -86,11 +91,11 @@ import GHC.Rename.Splice ( rnTopSpliceDecls, traceSplice, SpliceInfo(..) ) import GHC.Rename.HsType import GHC.Rename.Expr-import GHC.Rename.Utils  ( HsDocContext(..) ) import GHC.Rename.Fixity ( lookupFixityRn ) import GHC.Rename.Names import GHC.Rename.Env import GHC.Rename.Module+import GHC.Rename.Doc  import GHC.Iface.Syntax   ( ShowSub(..), showToHeader ) import GHC.Iface.Type     ( ShowForAllFlag(..) )@@ -115,6 +120,7 @@ import GHC.Core.Type import GHC.Core.Class import GHC.Core.Coercion.Axiom+import GHC.Core.Reduction ( Reduction(..) ) import GHC.Core.Unify( RoughMatchTc(..) ) import GHC.Core.FamInstEnv    ( FamInst, pprFamInst, famInstsRepTyCons@@ -129,6 +135,7 @@ import GHC.Utils.Error import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Utils.Misc import GHC.Utils.Logger @@ -147,9 +154,9 @@ import GHC.Types.Basic hiding( SuccessFlag(..) ) import GHC.Types.Annotations import GHC.Types.SrcLoc-import GHC.Types.SourceText import GHC.Types.SourceFile import GHC.Types.TyThing.Ppr ( pprTyThingInContext )+import GHC.Types.PkgQual import qualified GHC.LanguageExtensions as LangExt  import GHC.Unit.External@@ -176,8 +183,6 @@ import Control.DeepSeq import Control.Monad -#include "HsVersions.h"- {- ************************************************************************ *                                                                      *@@ -191,16 +196,18 @@            -> ModSummary            -> Bool              -- True <=> save renamed syntax            -> HsParsedModule-           -> IO (Messages DecoratedSDoc, Maybe TcGblEnv)+           -> IO (Messages TcRnMessage, Maybe TcGblEnv)  tcRnModule hsc_env mod_sum save_rn_syntax    parsedModule@HsParsedModule {hpm_module= L loc this_module}  | RealSrcSpan real_loc _ <- loc- = withTiming logger dflags+ = withTiming logger               (text "Renamer/typechecker"<+>brackets (ppr this_mod))               (const ()) $    initTc hsc_env hsc_src save_rn_syntax this_mod real_loc $-          withTcPlugins hsc_env $ withHoleFitPlugins hsc_env $+          withTcPlugins hsc_env $+          withDefaultingPlugins hsc_env $+          withHoleFitPlugins hsc_env $            tcRnModuleTcRnM hsc_env mod_sum parsedModule pair @@ -209,11 +216,10 @@    where     hsc_src = ms_hsc_src mod_sum-    dflags  = hsc_dflags hsc_env     logger  = hsc_logger hsc_env     home_unit = hsc_home_unit hsc_env-    err_msg = mkPlainMsgEnvelope loc $-              text "Module does not have a RealSrcSpan:" <+> ppr this_mod+    err_msg = mkPlainErrorMsgEnvelope loc $+              TcRnModMissingRealSrcSpan this_mod      pair :: (Module, SrcSpan)     pair@(this_mod,_)@@ -258,13 +264,15 @@         ; let { prel_imports = mkPrelImports (moduleName this_mod) prel_imp_loc                                implicit_prelude import_decls } -        ; whenWOptM Opt_WarnImplicitPrelude $-             when (notNull prel_imports) $-                addWarn (Reason Opt_WarnImplicitPrelude) (implicitPreludeWarn)+        ; when (notNull prel_imports) $ do+            let msg = TcRnUnknownMessage $+                        mkPlainDiagnostic (WarningWithFlag Opt_WarnImplicitPrelude) noHints (implicitPreludeWarn)+            addDiagnostic msg          ; -- TODO This is a little skeevy; maybe handle a bit more directly           let { simplifyImport (L _ idecl) =-                  ( fmap sl_fs (ideclPkgQual idecl) , reLoc $ ideclName idecl)+                  ( renameRawPkgQual (hsc_unit_env hsc_env) (unLoc $ ideclName idecl) (ideclPkgQual idecl)+                  , reLoc $ ideclName idecl)               }         ; raw_sig_imports <- liftIO                              $ findExtraSigImports hsc_env hsc_src@@ -273,32 +281,35 @@                              $ implicitRequirements hsc_env                                 (map simplifyImport (prel_imports                                                      ++ import_decls))-        ; let { mkImport (Nothing, L _ mod_name) = noLocA+        ; let { mkImport mod_name = noLocA                 $ (simpleImportDecl mod_name)-                  { ideclHiding = Just (False, noLocA [])}-              ; mkImport _ = panic "mkImport" }-        ; let { all_imports = prel_imports ++ import_decls-                       ++ map mkImport (raw_sig_imports ++ raw_req_imports) }+                  { ideclHiding = Just (False, noLocA [])}}+        ; let { withReason t imps = map (,text t) imps }+        ; let { all_imports = withReason "is implicitly imported" prel_imports+                  ++ withReason "is directly imported" import_decls+                  ++ withReason "is an extra sig import" (map mkImport raw_sig_imports)+                  ++ withReason "is an implicit req import" (map mkImport raw_req_imports) }         ; -- OK now finally rename the imports           tcg_env <- {-# SCC "tcRnImports" #-}                      tcRnImports hsc_env all_imports -       ;  -- Don't need to rename the Haddock documentation,-          -- it's not parsed by GHC anymore.-          -- Make sure to do this before 'tcRnSrcDecls', because we need the-          -- module header when we're splicing TH, since it can be accessed via-          -- 'getDoc'.-          tcg_env <- return (tcg_env-                              { tcg_doc_hdr = maybe_doc_hdr })-+        -- Put a version of the header without identifier info into the tcg_env+        -- Make sure to do this before 'tcRnSrcDecls', because we need the+        -- module header when we're splicing TH, since it can be accessed via+        -- 'getDoc'.+        -- We will rename it properly after renaming everything else so that+        -- haddock can link the identifiers+        ; tcg_env <- return (tcg_env+                              { tcg_doc_hdr = fmap (\(WithHsDocIdentifiers str _) -> WithHsDocIdentifiers str [])+                                                                                 <$> maybe_doc_hdr })         ; -- If the whole module is warned about or deprecated           -- (via mod_deprec) record that in tcg_warns. If we do thereby add           -- a WarnAll, it will override any subsequent deprecations added to tcg_warns-          let { tcg_env1 = case mod_deprec of-                             Just (L _ txt) ->-                               tcg_env {tcg_warns = WarnAll txt}-                             Nothing            -> tcg_env-              }+        ; tcg_env1 <- case mod_deprec of+                             Just (L _ txt) -> do { txt' <- rnWarningTxt txt+                                                  ; pure $ tcg_env {tcg_warns = WarnAll txt'}+                                                  }+                             Nothing            -> pure tcg_env         ; setGblEnv tcg_env1           $ do { -- Rename and type check the declarations                  traceRn "rn1a" empty@@ -328,11 +339,17 @@                         -- because the latter might add new bindings for                         -- boot_dfuns, which may be mentioned in imported                         -- unfoldings.-                        -- Report unused names+                      ; -- Report unused names                         -- Do this /after/ typeinference, so that when reporting                         -- a function with no type signature we can give the                         -- inferred type-                        reportUnusedNames tcg_env hsc_src+                      ; reportUnusedNames tcg_env hsc_src++                      -- Rename the module header properly after we have renamed everything else+                      ; maybe_doc_hdr <- traverse rnLHsDoc maybe_doc_hdr;+                      ; tcg_env <- return (tcg_env+                                            { tcg_doc_hdr = maybe_doc_hdr })+                       ; -- add extra source files to tcg_dependent_files                         addDependentFiles src_files                         -- Ensure plugins run with the same tcg_env that we pass in@@ -359,32 +376,31 @@ ************************************************************************ -} -tcRnImports :: HscEnv -> [LImportDecl GhcPs] -> TcM TcGblEnv+tcRnImports :: HscEnv -> [(LImportDecl GhcPs, SDoc)] -> TcM TcGblEnv tcRnImports hsc_env import_decls   = do  { (rn_imports, rdr_env, imports, hpc_info) <- rnImports import_decls ;          ; this_mod <- getModule-        ; let { dep_mods :: ModuleNameEnv ModuleNameWithIsBoot-              ; dep_mods = imp_dep_mods imports--                -- We want instance declarations from all home-package+        ; gbl_env <- getGblEnv+        ; let { -- We want instance declarations from all home-package                 -- modules below this one, including boot modules, except                 -- ourselves.  The 'except ourselves' is so that we don't                 -- get the instances from this module's hs-boot file.  This                 -- filtering also ensures that we don't see instances from                 -- modules batch (@--make@) compiled before this one, but                 -- which are not below this one.-              ; want_instances :: ModuleName -> Bool-              ; want_instances mod = mod `elemUFM` dep_mods-                                   && mod /= moduleName this_mod-              ; (home_insts, home_fam_insts) = hptInstances hsc_env-                                                            want_instances+              ; (home_insts, home_fam_insts) =++                    hptInstancesBelow hsc_env (homeUnitId $ hsc_home_unit hsc_env) (GWIB (moduleName this_mod)(hscSourceToIsBoot (tcg_src gbl_env)))+               } ;                  -- Record boot-file info in the EPS, so that it's                 -- visible to loadHiBootInterface in tcRnSrcDecls,                 -- and any other incrementally-performed imports-        ; updateEps_ (\eps -> eps { eps_is_boot = dep_mods }) ;+              ; when (isOneShot (ghcMode (hsc_dflags hsc_env))) $ do {+                  updateEps_ $ \eps  -> eps { eps_is_boot = imp_boot_mods imports }+               }                  -- Update the gbl env         ; updGblEnv ( \ gbl ->@@ -392,13 +408,13 @@               tcg_rdr_env      = tcg_rdr_env gbl `plusGlobalRdrEnv` rdr_env,               tcg_imports      = tcg_imports gbl `plusImportAvails` imports,               tcg_rn_imports   = rn_imports,-              tcg_inst_env     = extendInstEnvList (tcg_inst_env gbl) home_insts,+              tcg_inst_env     = tcg_inst_env gbl `unionInstEnv` home_insts,               tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env gbl)                                                       home_fam_insts,               tcg_hpc          = hpc_info             }) $ do { -        ; traceRn "rn1" (ppr (imp_dep_mods imports))+        ; traceRn "rn1" (ppr (imp_direct_dep_mods imports))                 -- Fail if there are any errors so far                 -- The error printing (if needed) takes advantage                 -- of the tcg_env we have now set@@ -455,7 +471,7 @@       --  * the local env exposes the local Ids to simplifyTop,       --    so that we get better error messages (monomorphism restriction)       ; new_ev_binds <- {-# SCC "simplifyTop" #-}-                        setEnvs (tcg_env, tcl_env) $+                        restoreEnvs (tcg_env, tcl_env) $                         do { lie_main <- checkMainType tcg_env                            ; simplifyTop (lie `andWC` lie_main) } @@ -464,6 +480,9 @@                    mkTypeableBinds        ; traceTc "Tc9" empty+      ; failIfErrsM    -- Stop now if if there have been errors+                       -- Continuing is a waste of time; and we may get debug+                       -- warnings when zonking about strangely-typed TyCons!          -- Zonk the final code.  This must be done last.         -- Even simplifyTop may do some unification.@@ -496,19 +515,23 @@       --------- Deal with the exports ----------       -- Can't be done earlier, because the export list must "see"       -- the declarations created by the finalizers-      ; tcg_env <- setEnvs (tcg_env, tcl_env) $+      ; tcg_env <- restoreEnvs (tcg_env, tcl_env) $                    rnExports explicit_mod_hdr export_ies        --------- Emit the ':Main.main = runMainIO main' declaration ----------       -- Do this /after/ rnExports, so that it can consult       -- the tcg_exports created by rnExports       ; (tcg_env, main_ev_binds)-           <- setEnvs (tcg_env, tcl_env) $+           <- restoreEnvs (tcg_env, tcl_env) $               do { (tcg_env, lie) <- captureTopConstraints $                                      checkMain explicit_mod_hdr export_ies                  ; ev_binds <- simplifyTop lie                  ; return (tcg_env, ev_binds) } +      ; failIfErrsM    -- Stop now if if there have been errors+                       -- Continuing is a waste of time; and we may get debug+                       -- warnings when zonking about strangely-typed TyCons!+       ---------- Final zonking ---------------       -- Zonk the new bindings arising from running the finalisers,       -- and main. This won't give rise to any more finalisers as you@@ -543,10 +566,7 @@   = {-# SCC "zonkTopDecls" #-}     setGblEnv tcg_env $ -- This sets the GlobalRdrEnv which is used when rendering                         --   error messages during zonking (notably levity errors)-    do { failIfErrsM    -- Don't zonk if there have been errors-                        -- It's a waste of time; and we may get debug warnings-                        -- about strangely-typed TyCons!-       ; let all_ev_binds = cur_ev_binds `unionBags` ev_binds+    do { let all_ev_binds = cur_ev_binds `unionBags` ev_binds        ; zonkTopDecls all_ev_binds binds rules imp_specs fords }  -- | Runs TH finalizers and renames and typechecks the top-level declarations@@ -560,7 +580,7 @@   else do     writeTcRef th_modfinalizers_var []     let run_finalizer (lcl_env, f) =-            setLclEnv lcl_env (runRemoteModFinalizers f)+            restoreLclEnv lcl_env (runRemoteModFinalizers f)      (_, lie_th) <- captureTopConstraints $                    mapM_ run_finalizer th_modfinalizers@@ -569,7 +589,7 @@       -- we have to run tc_rn_src_decls to get them     (tcg_env, tcl_env, lie_top_decls) <- tc_rn_src_decls [] -    setEnvs (tcg_env, tcl_env) $ do+    restoreEnvs (tcg_env, tcl_env) $ do       -- Subsequent rounds of finalizers run after any new constraints are       -- simplified, or some types might not be complete when using reify       -- (see #12777).@@ -608,7 +628,7 @@                         { Nothing -> return ()                         ; Just (SpliceDecl _ (L loc _) _, _) ->                             setSrcSpanA loc-                            $ addErr (text+                            $ addErr (TcRnUnknownMessage $ mkPlainError noHints $ text                                 ("Declaration splices are not "                                   ++ "permitted inside top-level "                                   ++ "declarations added with addTopDecls"))@@ -636,7 +656,7 @@                                       tcTopSrcDecls rn_decls          -- If there is no splice, we're nearly done-      ; setEnvs (tcg_env, tcl_env) $+      ; restoreEnvs (tcg_env, tcl_env) $         case group_tail of           { Nothing -> return (tcg_env, tcl_env, lie1) @@ -698,7 +718,7 @@                  -- Typecheck type/class/instance decls         ; traceTc "Tc2 (boot)" empty-        ; (tcg_env, inst_infos, _deriv_binds)+        ; (tcg_env, inst_infos, _deriv_binds, _th_bndrs)              <- tcTyClsInstDecls tycl_decls deriv_decls val_binds         ; setGblEnv tcg_env     $ do { @@ -730,7 +750,8 @@  badBootDecl :: HscSource -> String -> LocatedA decl -> TcM () badBootDecl hsc_src what (L loc _)-  = addErrAt (locA loc) (char 'A' <+> text what+  = addErrAt (locA loc) $ TcRnUnknownMessage $ mkPlainError noHints $+    (char 'A' <+> text what       <+> text "declaration is not (currently) allowed in a"       <+> (case hsc_src of             HsBootFile -> text "hs-boot"@@ -866,9 +887,6 @@      check_export boot_avail     -- boot_avail is exported by the boot iface       | name `elem` boot_dfun_names = return ()-      | isWiredInName name          = return () -- No checking for wired-in names.  In particular,-                                                -- 'error' is handled by a rather gross hack-                                                -- (see comments in GHC.Err.hs-boot)          -- Check that the actual module exports the same thing       | not (null missing_names)@@ -975,7 +993,7 @@ checkBootDecl :: Bool -> TyThing -> TyThing -> Maybe SDoc  checkBootDecl _ (AnId id1) (AnId id2)-  = ASSERT(id1 == id2)+  = assert (id1 == id2) $     check (idType id1 `eqType` idType id2)           (text "The two types are different") @@ -1115,7 +1133,7 @@   | Just syn_rhs1 <- synTyConRhs_maybe tc1   , Just syn_rhs2 <- synTyConRhs_maybe tc2   , Just env <- eqVarBndrs emptyRnEnv2 (tyConTyVars tc1) (tyConTyVars tc2)-  = ASSERT(tc1 == tc2)+  = assert (tc1 == tc2) $     checkRoles roles1 roles2 `andThenCheck`     check (eqTypeX env syn_rhs1 syn_rhs2) empty   -- nothing interesting to say   -- This allows abstract 'data T a' to be implemented using 'type T = ...'@@ -1145,7 +1163,7 @@    | Just fam_flav1 <- famTyConFlav_maybe tc1   , Just fam_flav2 <- famTyConFlav_maybe tc2-  = ASSERT(tc1 == tc2)+  = assert (tc1 == tc2) $     let eqFamFlav OpenSynFamilyTyCon   OpenSynFamilyTyCon = True         eqFamFlav (DataFamilyTyCon {}) (DataFamilyTyCon {}) = True         -- This case only happens for hsig merging:@@ -1171,7 +1189,7 @@    | isAlgTyCon tc1 && isAlgTyCon tc2   , Just env <- eqVarBndrs emptyRnEnv2 (tyConTyVars tc1) (tyConTyVars tc2)-  = ASSERT(tc1 == tc2)+  = assert (tc1 == tc2) $     checkRoles roles1 roles2 `andThenCheck`     check (eqListBy (eqTypeX env)                      (tyConStupidTheta tc1) (tyConStupidTheta tc2))@@ -1266,7 +1284,7 @@     --     -- See also 'HowAbstract' and Note [Skolem abstract data]. -    -- | Given @type T tvs = ty@, where @ty@ decomposes into @tc2' args@,+    -- Given @type T tvs = ty@, where @ty@ decomposes into @tc2' args@,     -- check that this synonym is an acceptable implementation of @tc1@.     -- See Note [Synonyms implement abstract data]     checkSynAbsData :: [TyVar] -> Type -> TyCon -> [Type] -> Maybe SDoc@@ -1280,7 +1298,7 @@                 `andThenCheck`         -- Don't report roles errors unless the type synonym is nullary         checkUnless (not (null tvs)) $-            ASSERT( null roles2 )+            assert (null roles2) $             -- If we have something like:             --             --  signature H where@@ -1302,7 +1320,7 @@                     Nothing -> Just roles_msg -} -    eqAlgRhs _ AbstractTyCon _rhs2+    eqAlgRhs _ (AbstractTyCon {}) _rhs2       = checkSuccess -- rhs2 is guaranteed to be injective, since it's an AlgTyCon     eqAlgRhs _  tc1@DataTyCon{} tc2@DataTyCon{} =         checkListBy eqCon (data_cons tc1) (data_cons tc2) (text "constructors")@@ -1359,24 +1377,27 @@ emptyRnEnv2 = mkRnEnv2 emptyInScopeSet  -----------------missingBootThing :: Bool -> Name -> String -> SDoc+missingBootThing :: Bool -> Name -> String -> TcRnMessage missingBootThing is_boot name what-  = quotes (ppr name) <+> text "is exported by the"+  = TcRnUnknownMessage $ mkPlainError noHints $+    quotes (ppr name) <+> text "is exported by the"     <+> (if is_boot then text "hs-boot" else text "hsig")     <+> text "file, but not"     <+> text what <+> text "the module" -badReexportedBootThing :: Bool -> Name -> Name -> SDoc+badReexportedBootThing :: Bool -> Name -> Name -> TcRnMessage badReexportedBootThing is_boot name name'-  = withUserStyle alwaysQualify AllTheWay $ vcat+  = TcRnUnknownMessage $ mkPlainError noHints $+    withUserStyle alwaysQualify AllTheWay $ vcat         [ text "The" <+> (if is_boot then text "hs-boot" else text "hsig")            <+> text "file (re)exports" <+> quotes (ppr name)         , text "but the implementing module exports a different identifier" <+> quotes (ppr name')         ] -bootMisMatch :: Bool -> SDoc -> TyThing -> TyThing -> SDoc+bootMisMatch :: Bool -> SDoc -> TyThing -> TyThing -> TcRnMessage bootMisMatch is_boot extra_info real_thing boot_thing-  = pprBootMisMatch is_boot extra_info real_thing real_doc boot_doc+  = TcRnUnknownMessage $ mkPlainError noHints $+    pprBootMisMatch is_boot extra_info real_thing real_doc boot_doc   where     to_doc       = pprTyThingInContext $ showToHeader { ss_forall =@@ -1404,9 +1425,10 @@             extra_info           ] -instMisMatch :: DFunId -> SDoc+instMisMatch :: DFunId -> TcRnMessage instMisMatch dfun-  = hang (text "instance" <+> ppr (idType dfun))+  = TcRnUnknownMessage $ mkPlainError noHints $+    hang (text "instance" <+> ppr (idType dfun))        2 (text "is defined in the hs-boot file, but not in the module itself")  {-@@ -1455,9 +1477,11 @@                 -- Source-language instances, including derivings,                 -- and import the supporting declarations         traceTc "Tc3" empty ;-        (tcg_env, inst_infos, XValBindsLR (NValBinds deriv_binds deriv_sigs))+        (tcg_env, inst_infos, th_bndrs,+         XValBindsLR (NValBinds deriv_binds deriv_sigs))             <- tcTyClsInstDecls tycl_decls deriv_decls val_binds ; +        updLclEnv (\tcl_env -> tcl_env { tcl_th_bndrs = th_bndrs `plusNameEnv` tcl_th_bndrs tcl_env }) $         setGblEnv tcg_env       $ do {                  -- Generate Applicative/Monad proposal (AMP) warnings@@ -1484,14 +1508,14 @@                 -- the bindings produced in a Data instance.)         traceTc "Tc5" empty ;         tc_envs <- tcTopBinds val_binds val_sigs;-        setEnvs tc_envs $ do {+        restoreEnvs tc_envs $ do {                  -- Now GHC-generated derived bindings, generics, and selectors                 -- Do not generate warnings from compiler-generated code;                 -- hence the use of discardWarnings         tc_envs@(tcg_env, tcl_env)             <- discardWarnings (tcTopBinds deriv_binds deriv_sigs) ;-        setEnvs tc_envs $ do {  -- Environment doesn't change now+        restoreEnvs tc_envs $ do {  -- Environment doesn't change now                  -- Second pass over class and instance declarations,                 -- now using the kind-checked decls@@ -1543,10 +1567,13 @@  tcSemigroupWarnings :: TcM () tcSemigroupWarnings = do-    traceTc "tcSemigroupWarnings" empty-    let warnFlag = Opt_WarnSemigroup-    tcPreludeClashWarn warnFlag sappendName-    tcMissingParentClassWarn warnFlag monoidClassName semigroupClassName+    mod <- getModule+    -- ghc-prim doesn't depend on base+    unless (moduleUnit mod == primUnit) $ do+      traceTc "tcSemigroupWarnings" empty+      let warnFlag = Opt_WarnSemigroup+      tcPreludeClashWarn warnFlag sappendName+      tcMissingParentClassWarn warnFlag monoidClassName semigroupClassName   -- | Warn on local definitions of names that would clash with future Prelude@@ -1572,7 +1599,7 @@     -- Continue only the name is imported from Prelude     ; when (importedViaPrelude name rnImports) $ do       -- Handle 2.-4.-    { rdrElts <- fmap (concat . occEnvElts . tcg_rdr_env) getGblEnv+    { rdrElts <- fmap (concat . nonDetOccEnvElts . tcg_rdr_env) getGblEnv      ; let clashes :: GlobalRdrElt -> Bool           clashes x = isLocalDef && nameClashes && isNotInProperModule@@ -1592,7 +1619,9 @@     ; traceTc "tcPreludeClashWarn/prelude_functions"                 (hang (ppr name) 4 (sep [ppr clashingElts])) -    ; let warn_msg x = addWarnAt (Reason warnFlag) (nameSrcSpan (greMangledName x)) (hsep+    ; let warn_msg x = addDiagnosticAt (nameSrcSpan (greMangledName x)) $+            TcRnUnknownMessage $+            mkPlainDiagnostic (WarningWithFlag warnFlag) noHints $ (hsep               [ text "Local definition of"               , (quotes . ppr . nameOccName . greMangledName) x               , text "clashes with a future Prelude name." ]@@ -1686,9 +1715,9 @@        }}   where     -- Check whether the desired superclass exists in a given environment.-    checkShouldInst :: Class   -- ^ Class of existing instance-                    -> Class   -- ^ Class there should be an instance of-                    -> ClsInst -- ^ Existing instance+    checkShouldInst :: Class   -- Class of existing instance+                    -> Class   -- Class there should be an instance of+                    -> ClsInst -- Existing instance                     -> TcM ()     checkShouldInst isClass shouldClass isInst       = do { instEnv <- tcGetInstEnvs@@ -1702,8 +1731,9 @@            -- "<location>: Warning: <type> is an instance of <is> but not            -- <should>" e.g. "Foo is an instance of Monad but not Applicative"            ; let instLoc = srcLocSpan . nameSrcLoc $ getName isInst-                 warnMsg (KnownTc name:_) =-                      addWarnAt (Reason warnFlag) instLoc $+                 warnMsg (RM_KnownTc name:_) =+                      addDiagnosticAt instLoc $+                        TcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag warnFlag) noHints $                            hsep [ (quotes . ppr . nameOccName) name                                 , text "is an instance of"                                 , (ppr . nameOccName . className) isClass@@ -1714,7 +1744,7 @@                            hsep [ text "This will become an error in"                                 , text "a future release." ]                  warnMsg _ = pure ()-           ; when (null shouldInsts && null instanceMatches) $+           ; when (nullUnifiers shouldInsts && null instanceMatches) $                   warnMsg (is_tcs isInst)            } @@ -1732,13 +1762,14 @@                          [InstInfo GhcRn],    -- Source-code instance decls to                                               -- process; contains all dfuns for                                               -- this module+                          ThBindEnv,          -- TH binding levels                           HsValBinds GhcRn)   -- Supporting bindings for derived                                               -- instances  tcTyClsInstDecls tycl_decls deriv_decls binds  = tcAddDataFamConPlaceholders (tycl_decls >>= group_instds) $    tcAddPatSynPlaceholders (getPatSynBinds binds) $-   do { (tcg_env, inst_info, deriv_info)+   do { (tcg_env, inst_info, deriv_info, th_bndrs)           <- tcTyAndClassDecls tycl_decls ;       ; setGblEnv tcg_env $ do {           -- With the @TyClDecl@s and @InstDecl@s checked we're ready to@@ -1752,7 +1783,7 @@               <- tcInstDeclsDeriv deriv_info deriv_decls           ; setGblEnv tcg_env' $ do {                 failIfErrsM-              ; pure (tcg_env', inst_info' ++ inst_info, val_binds)+              ; pure ( tcg_env', inst_info' ++ inst_info, th_bndrs, val_binds )       }}}  {- *********************************************************************@@ -1769,7 +1800,7 @@ -- See Note [Dealing with main] checkMainType tcg_env   = do { hsc_env <- getTopEnv-       ; if tcg_mod tcg_env /= mainModIs hsc_env+       ; if tcg_mod tcg_env /= mainModIs (hsc_HUE hsc_env)          then return emptyWC else      do { rdr_env <- getGlobalRdrEnv@@ -1782,7 +1813,7 @@             [main_gre] ->      do { let main_name = greMangledName main_gre-             ctxt      = FunSigCtxt main_name False+             ctxt      = FunSigCtxt main_name NoRRC        ; main_id   <- tcLookupId main_name        ; (io_ty,_) <- getIOType        ; let main_ty   = idType main_id@@ -1806,7 +1837,7 @@       ; tcg_env <- getGblEnv        ; let dflags      = hsc_dflags hsc_env-            main_mod    = mainModIs hsc_env+            main_mod    = mainModIs (hsc_HUE hsc_env)             main_occ    = getMainOcc dflags              exported_mains :: [Name]@@ -1824,7 +1855,7 @@               generateMainBinding tcg_env main_name             | otherwise-           -> ASSERT( null exported_mains )+           -> assert (null exported_mains) $               -- A fully-checked export list can't contain more               -- than one function with the same OccName               do { complain_no_main dflags main_mod main_occ@@ -1840,7 +1871,8 @@         -- in other modes, add error message and go on with typechecking.      noMainMsg main_mod main_occ-      = text "The" <+> ppMainFn main_occ+      = TcRnUnknownMessage $ mkPlainError noHints $+            text "The" <+> ppMainFn main_occ         <+> text "is not" <+> text defOrExp <+> text "module"         <+> quotes (ppr main_mod) @@ -1881,7 +1913,7 @@     ; (ev_binds, main_expr) <- setMainCtxt main_name io_ty $                                tcCheckMonoExpr main_expr_rn io_ty -            -- See Note [Root-main Id]+            -- See Note [Root-main id]             -- Construct the binding             --      :Main.main :: IO res_ty = runMainIO res_ty main     ; run_main_id <- tcLookupId runMainIOName@@ -1920,7 +1952,7 @@     checkConstraints skol_info [] []  $  -- Builds an implication if necessary     thing_inside                         -- e.g. with -fdefer-type-errors   where-    skol_info = SigSkol (FunSigCtxt main_name False) io_ty []+    skol_info = SigSkol (FunSigCtxt main_name NoRRC) io_ty []     main_ctxt = text "When checking the type of the"                 <+> ppMainFn (nameOccName main_name) @@ -2016,16 +2048,17 @@ ********************************************************* -} -runTcInteractive :: HscEnv -> TcRn a -> IO (Messages DecoratedSDoc, Maybe a)+runTcInteractive :: HscEnv -> TcRn a -> IO (Messages TcRnMessage, Maybe a) -- Initialise the tcg_inst_env with instances from all home modules. -- This mimics the more selective call to hptInstances in tcRnImports runTcInteractive hsc_env thing_inside-  = initTcInteractive hsc_env $ withTcPlugins hsc_env $ withHoleFitPlugins hsc_env $+  = initTcInteractive hsc_env $ withTcPlugins hsc_env $+    withDefaultingPlugins hsc_env $ withHoleFitPlugins hsc_env $     do { traceTc "setInteractiveContext" $             vcat [ text "ic_tythings:" <+> vcat (map ppr (ic_tythings icxt))-                 , text "ic_insts:" <+> vcat (map (pprBndr LetBind . instanceDFunId) ic_insts)-                 , text "ic_rn_gbl_env (LocalDef)" <+>-                      vcat (map ppr [ local_gres | gres <- occEnvElts (ic_rn_gbl_env icxt)+                 , text "ic_insts:" <+> vcat (map (pprBndr LetBind . instanceDFunId) (instEnvElts ic_insts))+                 , text "icReaderEnv (LocalDef)" <+>+                      vcat (map ppr [ local_gres | gres <- nonDetOccEnvElts (icReaderEnv icxt)                                                  , let local_gres = filter isLocalGRE gres                                                  , not (null local_gres) ]) ] @@ -2036,41 +2069,36 @@         ; !orphs <- fmap (force . concat) . forM (ic_imports icxt) $ \i ->             case i of                   -- force above: see #15111-                IIModule n -> getOrphans n Nothing-                IIDecl i ->-                  let mb_pkg = sl_fs <$> ideclPkgQual i in-                  getOrphans (unLoc (ideclName i)) mb_pkg+                IIModule n -> getOrphans n NoPkgQual+                IIDecl i   -> getOrphans (unLoc (ideclName i))+                                         (renameRawPkgQual (hsc_unit_env hsc_env) (unLoc $ ideclName i) (ideclPkgQual i)) -       ; let imports = emptyImportAvails {-                            imp_orphs = orphs-                        }+       ; let imports = emptyImportAvails { imp_orphs = orphs } -       ; (gbl_env, lcl_env) <- getEnvs-       ; let gbl_env' = gbl_env {-                           tcg_rdr_env      = ic_rn_gbl_env icxt-                         , tcg_type_env     = type_env-                         , tcg_inst_env     = extendInstEnvList-                                               (extendInstEnvList (tcg_inst_env gbl_env) ic_insts)-                                               home_insts-                         , tcg_fam_inst_env = extendFamInstEnvList+             upd_envs (gbl_env, lcl_env) = (gbl_env', lcl_env')+               where+                 gbl_env' = gbl_env { tcg_rdr_env      = icReaderEnv icxt+                                    , tcg_type_env     = type_env++                                    , tcg_inst_env     = tcg_inst_env gbl_env `unionInstEnv` ic_insts `unionInstEnv` home_insts+                                    , tcg_fam_inst_env = extendFamInstEnvList                                                (extendFamInstEnvList (tcg_fam_inst_env gbl_env)                                                                      ic_finsts)                                                home_fam_insts-                         , tcg_field_env    = mkNameEnv con_fields-                              -- setting tcg_field_env is necessary-                              -- to make RecordWildCards work (test: ghci049)-                         , tcg_fix_env      = ic_fix_env icxt-                         , tcg_default      = ic_default icxt-                              -- must calculate imp_orphs of the ImportAvails-                              -- so that instance visibility is done correctly-                         , tcg_imports      = imports-                         }+                                    , tcg_field_env    = mkNameEnv con_fields+                                         -- setting tcg_field_env is necessary+                                         -- to make RecordWildCards work (test: ghci049)+                                    , tcg_fix_env      = ic_fix_env icxt+                                    , tcg_default      = ic_default icxt+                                         -- must calculate imp_orphs of the ImportAvails+                                         -- so that instance visibility is done correctly+                                    , tcg_imports      = imports } -             lcl_env' = tcExtendLocalTypeEnv lcl_env lcl_ids+                 lcl_env' = tcExtendLocalTypeEnv lcl_env lcl_ids -       ; setEnvs (gbl_env', lcl_env') thing_inside }+       ; updEnvs upd_envs thing_inside }   where-    (home_insts, home_fam_insts) = hptInstances hsc_env (\_ -> True)+    (home_insts, home_fam_insts) = hptAllInstances hsc_env      icxt                     = hsc_IC hsc_env     (ic_insts, ic_finsts)    = ic_instances icxt@@ -2089,7 +2117,7 @@       = Right thing      type_env1 = mkTypeEnvWithImplicits top_ty_things-    type_env  = extendTypeEnvWithIds type_env1 (map instanceDFunId ic_insts)+    type_env  = extendTypeEnvWithIds type_env1 (map instanceDFunId (instEnvElts ic_insts))                 -- Putting the dfuns in the type_env                 -- is just to keep Core Lint happy @@ -2132,7 +2160,7 @@ -- The returned TypecheckedHsExpr is of type IO [ () ], a list of the bound -- values, coerced to (). tcRnStmt :: HscEnv -> GhciLStmt GhcPs-         -> IO (Messages DecoratedSDoc, Maybe ([Id], LHsExpr GhcTc, FixityEnv))+         -> IO (Messages TcRnMessage, Maybe ([Id], LHsExpr GhcTc, FixityEnv)) tcRnStmt hsc_env rdr_stmt   = runTcInteractive hsc_env $ do { @@ -2141,37 +2169,19 @@     zonked_expr <- zonkTopLExpr tc_expr ;     zonked_ids  <- zonkTopBndrs bound_ids ; -    failIfErrsM ;  -- we can't do the next step if there are levity polymorphism errors+    failIfErrsM ;  -- we can't do the next step if there are+                   -- representation polymorphism errors                    -- test case: ghci/scripts/T13202{,a}          -- None of the Ids should be of unboxed type, because we         -- cast them all to HValues in the end!-    mapM_ bad_unboxed (filter (isUnliftedType . idType) zonked_ids) ;+    mapM_ bad_unboxed (filter (mightBeUnliftedType . idType) zonked_ids) ;      traceTc "tcs 1" empty ;     this_mod <- getModule ;     global_ids <- mapM (externaliseAndTidyId this_mod) zonked_ids ;         -- Note [Interactively-bound Ids in GHCi] in GHC.Driver.Env -{- ----------------------------------------------   At one stage I removed any shadowed bindings from the type_env;-   they are inaccessible but might, I suppose, cause a space leak if we leave them there.-   However, with Template Haskell they aren't necessarily inaccessible.  Consider this-   GHCi session-         Prelude> let f n = n * 2 :: Int-         Prelude> fName <- runQ [| f |]-         Prelude> $(return $ AppE fName (LitE (IntegerL 7)))-         14-         Prelude> let f n = n * 3 :: Int-         Prelude> $(return $ AppE fName (LitE (IntegerL 7)))-   In the last line we use 'fName', which resolves to the *first* 'f'-   in scope. If we delete it from the type env, GHCi crashes because-   it doesn't expect that.--   Hence this code is commented out---------------------------------------------------- -}-     traceOptTcRn Opt_D_dump_tc         (vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids,                text "Typechecked expr" <+> ppr zonked_expr]) ;@@ -2179,7 +2189,8 @@     return (global_ids, zonked_expr, fix_env)     }   where-    bad_unboxed id = addErr (sep [text "GHCi can't bind a variable of unlifted type:",+    bad_unboxed id = addErr $ TcRnUnknownMessage $ mkPlainError noHints $+      (sep [text "GHCi can't bind a variable of unlifted type:",                                   nest 2 (pprPrefixOcc id <+> dcolon <+> ppr (idType id))])  {-@@ -2230,6 +2241,9 @@ -- An expression typed at the prompt is treated very specially tcUserStmt (L loc (BodyStmt _ expr _ _))   = do  { (rn_expr, fvs) <- checkNoErrs (rnLExpr expr)++        ; dumpOptTcRn Opt_D_dump_rn_ast "Renamer" FormatHaskell+            (showAstData NoBlankSrcSpan NoBlankEpAnnotations rn_expr)                -- Don't try to typecheck if the renamer fails!         ; ghciStep <- getGhciStepIO         ; uniq <- newUnique@@ -2326,6 +2340,9 @@                                  then no_it_plans                                  else it_plans +        ; dumpOptTcRn Opt_D_dump_tc_ast "Typechecker AST" FormatHaskell+              (showAstData NoBlankSrcSpan NoBlankEpAnnotations plan)+         ; fix_env <- getFixityEnv         ; return (plan, fix_env) } @@ -2379,7 +2396,7 @@  tcUserStmt rdr_stmt@(L loc _)   = do { (([rn_stmt], fix_env), fvs) <- checkNoErrs $-           rnStmts GhciStmtCtxt rnExpr [rdr_stmt] $ \_ -> do+           rnStmts (HsDoStmt GhciStmtCtxt) rnExpr [rdr_stmt] $ \_ -> do              fix_env <- getFixityEnv              return (fix_env, emptyFVs)             -- Don't try to typecheck if the renamer fails!@@ -2444,7 +2461,7 @@       ; ret_id  <- tcLookupId returnIOName             -- return @ IO       ; let ret_ty      = mkListTy unitTy             io_ret_ty   = mkTyConApp ioTyCon [ret_ty]-            tc_io_stmts = tcStmtsAndThen GhciStmtCtxt tcDoStmt stmts+            tc_io_stmts = tcStmtsAndThen (HsDoStmt GhciStmtCtxt) tcDoStmt stmts                                          (mkCheckExpType io_ret_ty)             names = collectLStmtsBinders CollNoDictBinders stmts @@ -2464,8 +2481,8 @@        ; traceTc "GHC.Tc.Module.tcGhciStmts: done" empty -      -- rec_expr is the expression-      --      returnIO @ [()] [unsafeCoerce# () x, ..,  unsafeCorece# () z]+      -- ret_expr is the expression+      --      returnIO @[()] [unsafeCoerce# () x, ..,  unsafeCoerce# () z]       --       -- Despite the inconvenience of building the type applications etc,       -- this *has* to be done in type-annotated post-typecheck form@@ -2499,8 +2516,8 @@ getGhciStepIO = do     ghciTy <- getGHCiMonad     a_tv <- newName (mkTyVarOccFS (fsLit "a"))-    let ghciM   = nlHsAppTy (nlHsTyVar ghciTy) (nlHsTyVar a_tv)-        ioM     = nlHsAppTy (nlHsTyVar ioTyConName) (nlHsTyVar a_tv)+    let ghciM   = nlHsAppTy (nlHsTyVar NotPromoted ghciTy) (nlHsTyVar NotPromoted a_tv)+        ioM     = nlHsAppTy (nlHsTyVar NotPromoted ioTyConName) (nlHsTyVar NotPromoted a_tv)          step_ty :: LHsSigType GhcRn         step_ty = noLocA $ HsSig@@ -2513,7 +2530,7 @@      return (noLocA $ ExprWithTySig noExtField (nlHsVar ghciStepIoMName) stepTy) -isGHCiMonad :: HscEnv -> String -> IO (Messages DecoratedSDoc, Maybe Name)+isGHCiMonad :: HscEnv -> String -> IO (Messages TcRnMessage, Maybe Name) isGHCiMonad hsc_env ty   = runTcInteractive hsc_env $ do         rdrEnv <- getGlobalRdrEnv@@ -2527,8 +2544,8 @@                 _ <- tcLookupInstance ghciClass [userTy]                 return name -            Just _  -> failWithTc $ text "Ambiguous type!"-            Nothing -> failWithTc $ text ("Can't find type:" ++ ty)+            Just _  -> failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ text "Ambiguous type!"+            Nothing -> failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ text ("Can't find type:" ++ ty)  -- | How should we infer a type? See Note [TcRnExprMode] data TcRnExprMode = TM_Inst     -- ^ Instantiate inferred quantifiers only (:type)@@ -2540,7 +2557,7 @@ tcRnExpr :: HscEnv          -> TcRnExprMode          -> LHsExpr GhcPs-         -> IO (Messages DecoratedSDoc, Maybe Type)+         -> IO (Messages TcRnMessage, Maybe Type) tcRnExpr hsc_env mode rdr_expr   = runTcInteractive hsc_env $     do {@@ -2574,7 +2591,7 @@      -- See Note [Normalising the type in :type]     fam_envs <- tcGetFamInstEnvs ;-    let { normalised_type = snd $ normaliseType fam_envs Nominal ty+    let { normalised_type = reductionReducedType $ normaliseType fam_envs Nominal ty           -- normaliseType returns a coercion which we discard, so the Role is irrelevant.         ; final_type = if isSigmaTy res_ty then ty else normalised_type } ;     return final_type }@@ -2632,13 +2649,13 @@ -------------------------- tcRnImportDecls :: HscEnv                 -> [LImportDecl GhcPs]-                -> IO (Messages DecoratedSDoc, Maybe GlobalRdrEnv)+                -> IO (Messages TcRnMessage, Maybe GlobalRdrEnv) -- Find the new chunk of GlobalRdrEnv created by this list of import -- decls.  In contract tcRnImports *extends* the TcGblEnv. tcRnImportDecls hsc_env import_decls  =  runTcInteractive hsc_env $     do { gbl_env <- updGblEnv zap_rdr_env $-                    tcRnImports hsc_env import_decls+                    tcRnImports hsc_env $ map (,text "is directly imported") import_decls        ; return (tcg_rdr_env gbl_env) }   where     zap_rdr_env gbl_env = gbl_env { tcg_rdr_env = emptyGlobalRdrEnv }@@ -2648,7 +2665,7 @@          -> ZonkFlexi          -> Bool        -- Normalise the returned type          -> LHsType GhcPs-         -> IO (Messages DecoratedSDoc, Maybe (Type, Kind))+         -> IO (Messages TcRnMessage, Maybe (Type, Kind)) tcRnType hsc_env flexi normalise rdr_type   = runTcInteractive hsc_env $     setXOptM LangExt.PolyKinds $   -- See Note [Kind-generalise in tcRnType]@@ -2673,10 +2690,10 @@         -- Since all the wanteds are equalities, the returned bindings will be empty        ; empty_binds <- simplifyTop wanted-       ; MASSERT2( isEmptyBag empty_binds, ppr empty_binds )+       ; massertPpr (isEmptyBag empty_binds) (ppr empty_binds)         -- Do kind generalisation; see Note [Kind-generalise in tcRnType]-       ; kvs <- kindGeneralizeAll kind+       ; kvs <- kindGeneralizeAll unkSkol kind         ; e <- mkEmptyZonkEnv flexi        ; ty  <- zonkTcTypeToTypeX e ty@@ -2688,7 +2705,7 @@        --   normaliseType: expand type-family applications        --   expandTypeSynonyms: expand type synonyms (#18828)        ; fam_envs <- tcGetFamInstEnvs-       ; let ty' | normalise = expandTypeSynonyms $ snd $+       ; let ty' | normalise = expandTypeSynonyms $ reductionReducedType $                                normaliseType fam_envs Nominal ty                  | otherwise = ty @@ -2712,7 +2729,7 @@   reverse :: forall a. [a] -> [a]    -- foo :: forall a f b. (Show a, Num b, Foldable f) => a -> f b -> String-  > :type +v foo @Int+  > :type foo @Int   forall f b. (Show Int, Num b, Foldable f) => Int -> f b -> String    Note that Show Int is still reported, because the solver never got a chance@@ -2782,7 +2799,7 @@  tcRnDeclsi :: HscEnv            -> [LHsDecl GhcPs]-           -> IO (Messages DecoratedSDoc, Maybe TcGblEnv)+           -> IO (Messages TcRnMessage, Maybe TcGblEnv) tcRnDeclsi hsc_env local_decls   = runTcInteractive hsc_env $     tcRnSrcDecls False Nothing local_decls@@ -2807,13 +2824,13 @@ -- a package module with an interface on disk.  If neither of these is -- true, then the result will be an error indicating the interface -- could not be found.-getModuleInterface :: HscEnv -> Module -> IO (Messages DecoratedSDoc, Maybe ModIface)+getModuleInterface :: HscEnv -> Module -> IO (Messages TcRnMessage, Maybe ModIface) getModuleInterface hsc_env mod   = runTcInteractive hsc_env $     loadModuleInterface (text "getModuleInterface") mod  tcRnLookupRdrName :: HscEnv -> LocatedN RdrName-                  -> IO (Messages DecoratedSDoc, Maybe [Name])+                  -> IO (Messages TcRnMessage, Maybe [Name]) -- ^ Find all the Names that this RdrName could mean, in GHCi tcRnLookupRdrName hsc_env (L loc rdr_name)   = runTcInteractive hsc_env $@@ -2824,10 +2841,11 @@          let rdr_names = dataTcOccs rdr_name        ; names_s <- mapM lookupInfoOccRn rdr_names        ; let names = concat names_s-       ; when (null names) (addErrTc (text "Not in scope:" <+> quotes (ppr rdr_name)))+       ; when (null names) (addErrTc $ TcRnUnknownMessage $ mkPlainError noHints $+           (text "Not in scope:" <+> quotes (ppr rdr_name)))        ; return names } -tcRnLookupName :: HscEnv -> Name -> IO (Messages DecoratedSDoc, Maybe TyThing)+tcRnLookupName :: HscEnv -> Name -> IO (Messages TcRnMessage, Maybe TyThing) tcRnLookupName hsc_env name   = runTcInteractive hsc_env $     tcRnLookupName' name@@ -2846,7 +2864,7 @@  tcRnGetInfo :: HscEnv             -> Name-            -> IO ( Messages DecoratedSDoc+            -> IO ( Messages TcRnMessage                   , Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))  -- Used to implement :info in GHCi@@ -2914,7 +2932,7 @@     home_unit = hsc_home_unit hsc_env      unqual_mods = [ nameModule name-                  | gre <- globalRdrEnvElts (ic_rn_gbl_env ictxt)+                  | gre <- globalRdrEnvElts (icReaderEnv ictxt)                   , let name = greMangledName gre                   , nameIsFromExternalPackage home_unit name                   , isTcOcc (nameOccName name)   -- Types and classes only@@ -2938,11 +2956,11 @@  tcDump :: TcGblEnv -> TcRn () tcDump env- = do { dflags <- getDynFlags ;-        unit_state <- hsc_units <$> getTopEnv ;+ = do { unit_state <- hsc_units <$> getTopEnv ;+        logger <- getLogger ;          -- Dump short output if -ddump-types or -ddump-tc-        when (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)+        when (logHasDumpFlag logger Opt_D_dump_types || logHasDumpFlag logger Opt_D_dump_tc)           (dumpTcRn True Opt_D_dump_types             "" FormatText (pprWithUnitState unit_state short_dump)) ; @@ -2975,9 +2993,9 @@          , ppr_fam_insts fam_insts          , ppr_rules rules          , text "Dependent modules:" <+>-                pprUFM (imp_dep_mods imports) (ppr . sort)+                (ppr . sort . installedModuleEnvElts $ imp_direct_dep_mods imports)          , text "Dependent packages:" <+>-                ppr (S.toList $ imp_dep_pkgs imports)]+                ppr (S.toList $ imp_dep_direct_pkgs imports)]                 -- The use of sort is just to reduce unnecessary                 -- wobbling in testsuite output @@ -2998,6 +3016,7 @@       | otherwise = hasTopUserName id                     && case idDetails id of                          VanillaId    -> True+                         WorkerLikeId{} -> True                          RecSelId {}  -> True                          ClassOpId {} -> True                          FCallId {}   -> True@@ -3093,33 +3112,51 @@  withTcPlugins :: HscEnv -> TcM a -> TcM a withTcPlugins hsc_env m =-    case getTcPlugins hsc_env of+    case catMaybes $ mapPlugins (hsc_plugins hsc_env) tcPlugin of        []      -> m  -- Common fast case        plugins -> do-                ev_binds_var <- newTcEvBinds-                (solvers,stops) <- unzip `fmap` mapM (startPlugin ev_binds_var) plugins-                -- This ensures that tcPluginStop is called even if a type+                (solvers, rewriters, stops) <-+                  unzip3 `fmap` mapM start_plugin plugins+                let+                  rewritersUniqFM :: UniqFM TyCon [TcPluginRewriter]+                  !rewritersUniqFM = sequenceUFMList rewriters+                -- The following ensures that tcPluginStop is called even if a type                 -- error occurs during compilation (Fix of #10078)                 eitherRes <- tryM $-                  updGblEnv (\e -> e { tcg_tc_plugins = solvers }) m-                mapM_ (flip runTcPluginM ev_binds_var) stops+                  updGblEnv (\e -> e { tcg_tc_plugin_solvers   = solvers+                                     , tcg_tc_plugin_rewriters = rewritersUniqFM }) m+                mapM_ runTcPluginM stops                 case eitherRes of                   Left _ -> failM                   Right res -> return res   where-  startPlugin ev_binds_var (TcPlugin start solve stop) =-    do s <- runTcPluginM start ev_binds_var-       return (solve s, stop s)--getTcPlugins :: HscEnv -> [GHC.Tc.Utils.Monad.TcPlugin]-getTcPlugins hsc_env = catMaybes $ mapPlugins hsc_env (\p args -> tcPlugin p args)+  start_plugin (TcPlugin start solve rewrite stop) =+    do s <- runTcPluginM start+       return (solve s, rewrite s, stop s) +withDefaultingPlugins :: HscEnv -> TcM a -> TcM a+withDefaultingPlugins hsc_env m =+  do case catMaybes $ mapPlugins (hsc_plugins hsc_env) defaultingPlugin of+       [] -> m  -- Common fast case+       plugins  -> do (plugins,stops) <- mapAndUnzipM start_plugin plugins+                      -- This ensures that dePluginStop is called even if a type+                      -- error occurs during compilation+                      eitherRes <- tryM $ do+                        updGblEnv (\e -> e { tcg_defaulting_plugins = plugins }) m+                      mapM_ runTcPluginM stops+                      case eitherRes of+                        Left _ -> failM+                        Right res -> return res+  where+  start_plugin (DefaultingPlugin start fill stop) =+    do s <- runTcPluginM start+       return (fill s, stop s)  withHoleFitPlugins :: HscEnv -> TcM a -> TcM a withHoleFitPlugins hsc_env m =-  case getHfPlugins hsc_env of+  case catMaybes $ mapPlugins (hsc_plugins hsc_env) holeFitPlugin of     [] -> m  -- Common fast case-    plugins -> do (plugins,stops) <- unzip `fmap` mapM startPlugin plugins+    plugins -> do (plugins,stops) <- mapAndUnzipM start_plugin plugins                   -- This ensures that hfPluginStop is called even if a type                   -- error occurs during compilation.                   eitherRes <- tryM $@@ -3129,21 +3166,17 @@                     Left _ -> failM                     Right res -> return res   where-    startPlugin (HoleFitPluginR init plugin stop) =+    start_plugin (HoleFitPluginR init plugin stop) =       do ref <- init          return (plugin ref, stop ref) -getHfPlugins :: HscEnv -> [HoleFitPluginR]-getHfPlugins hsc_env =-  catMaybes $ mapPlugins hsc_env (\p args -> holeFitPlugin p args) - runRenamerPlugin :: TcGblEnv                  -> HsGroup GhcRn                  -> TcM (TcGblEnv, HsGroup GhcRn) runRenamerPlugin gbl_env hs_group = do     hsc_env <- getTopEnv-    withPlugins hsc_env+    withPlugins (hsc_plugins hsc_env)       (\p opts (e, g) -> ( mark_plugin_unsafe (hsc_dflags hsc_env)                             >> renamedResultAction p opts e g))       (gbl_env, hs_group)@@ -3154,7 +3187,7 @@ -- exception/signal an error. type RenamedStuff =         (Maybe (HsGroup GhcRn, [LImportDecl GhcRn], Maybe [(LIE GhcRn, Avails)],-                Maybe LHsDocString))+                Maybe (LHsDoc GhcRn)))  -- | Extract the renamed information from TcGblEnv. getRenamedStuff :: TcGblEnv -> RenamedStuff@@ -3166,7 +3199,7 @@ runTypecheckerPlugin :: ModSummary -> TcGblEnv -> TcM TcGblEnv runTypecheckerPlugin sum gbl_env = do     hsc_env <- getTopEnv-    withPlugins hsc_env+    withPlugins (hsc_plugins hsc_env)       (\p opts env -> mark_plugin_unsafe (hsc_dflags hsc_env)                         >> typeCheckResultAction p opts sum env)       gbl_env@@ -3175,6 +3208,7 @@ mark_plugin_unsafe dflags = unless (gopt Opt_PluginTrustworthy dflags) $   recordUnsafeInfer pluginUnsafe   where-    unsafeText = "Use of plugins makes the module unsafe"-    pluginUnsafe = unitBag ( mkPlainWarnMsg noSrcSpan-                                   (Outputable.text unsafeText) )+    !diag_opts = initDiagOpts dflags+    pluginUnsafe =+      singleMessage $+      mkPlainMsgEnvelope diag_opts noSrcSpan TcRnUnsafeDueToPlugin
GHC/Tc/Module.hs-boot view
@@ -2,11 +2,11 @@  import GHC.Prelude import GHC.Types.TyThing(TyThing)+import GHC.Tc.Errors.Types (TcRnMessage) import GHC.Tc.Types (TcM)-import GHC.Utils.Outputable (SDoc) import GHC.Types.Name (Name)  checkBootDeclM :: Bool  -- ^ True <=> an hs-boot file (could also be a sig)                -> TyThing -> TyThing -> TcM ()-missingBootThing :: Bool -> Name -> String -> SDoc-badReexportedBootThing :: Bool -> Name -> Name -> SDoc+missingBootThing :: Bool -> Name -> String -> TcRnMessage+badReexportedBootThing :: Bool -> Name -> Name -> TcRnMessage
GHC/Tc/Plugin.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ -- | This module provides an interface for typechecker plugins to -- access select functions of the 'TcM', principally those to do with -- reading parts of the state.@@ -24,6 +24,7 @@          -- * Getting the TcM state         getTopEnv,+        getTargetPlatform,         getEnvs,         getInstEnvs,         getFamInstEnvs,@@ -40,18 +41,18 @@          -- * Creating constraints         newWanted,-        newDerived,         newGiven,         newCoercionHole,          -- * Manipulating evidence bindings         newEvVar,         setEvBind,-        getEvBindsTcPluginM     ) where  import GHC.Prelude +import GHC.Platform (Platform)+ import qualified GHC.Tc.Utils.Monad     as TcM import qualified GHC.Tc.Solver.Monad    as TcS import qualified GHC.Tc.Utils.Env       as TcM@@ -62,28 +63,29 @@  import GHC.Core.FamInstEnv     ( FamInstEnv ) import GHC.Tc.Utils.Monad      ( TcGblEnv, TcLclEnv, TcPluginM-                               , unsafeTcPluginTcM, getEvBindsTcPluginM+                               , unsafeTcPluginTcM                                , liftIO, traceTc )-import GHC.Tc.Types.Constraint ( Ct, CtLoc, CtEvidence(..), ctLocOrigin )+import GHC.Tc.Types.Constraint ( Ct, CtLoc, CtEvidence(..) ) import GHC.Tc.Utils.TcMType    ( TcTyVar, TcType ) import GHC.Tc.Utils.Env        ( TcTyThing )-import GHC.Tc.Types.Evidence   ( TcCoercion, CoercionHole, EvTerm(..)-                               , EvExpr, EvBind, mkGivenEvBind )+import GHC.Tc.Types.Evidence   ( CoercionHole, EvTerm(..)+                               , EvExpr, EvBindsVar, EvBind, mkGivenEvBind ) import GHC.Types.Var           ( EvVar ) -import GHC.Unit.Module-import GHC.Types.Name-import GHC.Types.TyThing-import GHC.Core.TyCon-import GHC.Core.DataCon-import GHC.Core.Class-import GHC.Driver.Env-import GHC.Utils.Outputable-import GHC.Core.Type-import GHC.Types.Id-import GHC.Core.InstEnv-import GHC.Data.FastString-import GHC.Types.Unique+import GHC.Unit.Module    ( ModuleName, Module )+import GHC.Types.Name     ( OccName, Name )+import GHC.Types.TyThing  ( TyThing )+import GHC.Core.Reduction ( Reduction )+import GHC.Core.TyCon     ( TyCon )+import GHC.Core.DataCon   ( DataCon )+import GHC.Core.Class     ( Class )+import GHC.Driver.Env       ( HscEnv(..) )+import GHC.Utils.Outputable ( SDoc )+import GHC.Core.Type        ( Kind, Type, PredType )+import GHC.Types.Id         ( Id )+import GHC.Core.InstEnv     ( InstEnvs )+import GHC.Types.Unique     ( Unique )+import GHC.Types.PkgQual    ( PkgQual )   -- | Perform some IO, typically to interact with an external tool.@@ -95,7 +97,7 @@ tcPluginTrace a b = unsafeTcPluginTcM (traceTc a b)  -findImportedModule :: ModuleName -> Maybe FastString -> TcPluginM Finder.FindResult+findImportedModule :: ModuleName -> PkgQual -> TcPluginM Finder.FindResult findImportedModule mod_name mb_pkg = do     hsc_env <- getTopEnv     tcPluginIO $ Finder.findImportedModule hsc_env mod_name mb_pkg@@ -126,6 +128,10 @@ getTopEnv :: TcPluginM HscEnv getTopEnv = unsafeTcPluginTcM TcM.getTopEnv +getTargetPlatform :: TcPluginM Platform+getTargetPlatform = unsafeTcPluginTcM TcM.getPlatform++ getEnvs :: TcPluginM (TcGblEnv, TcLclEnv) getEnvs = unsafeTcPluginTcM TcM.getEnvs @@ -136,7 +142,7 @@ getFamInstEnvs = unsafeTcPluginTcM TcM.tcGetFamInstEnvs  matchFam :: TyCon -> [Type]-         -> TcPluginM (Maybe (TcCoercion, TcType))+         -> TcPluginM (Maybe Reduction) matchFam tycon args = unsafeTcPluginTcM $ TcS.matchFamTcM tycon args  newUnique :: TcPluginM Unique@@ -155,36 +161,34 @@ zonkCt :: Ct -> TcPluginM Ct zonkCt = unsafeTcPluginTcM . TcM.zonkCt ---- | Create a new wanted constraint.-newWanted  :: CtLoc -> PredType -> TcPluginM CtEvidence+-- | Create a new Wanted constraint with the given 'CtLoc'.+newWanted :: CtLoc -> PredType -> TcPluginM CtEvidence newWanted loc pty-  = unsafeTcPluginTcM (TcM.newWanted (ctLocOrigin loc) Nothing pty)---- | Create a new derived constraint.-newDerived :: CtLoc -> PredType -> TcPluginM CtEvidence-newDerived loc pty = return CtDerived { ctev_pred = pty, ctev_loc = loc }+  = unsafeTcPluginTcM (TcM.newWantedWithLoc loc pty) --- | Create a new given constraint, with the supplied evidence.  This--- must not be invoked from 'tcPluginInit' or 'tcPluginStop', or it--- will panic.-newGiven :: CtLoc -> PredType -> EvExpr -> TcPluginM CtEvidence-newGiven loc pty evtm = do+-- | Create a new given constraint, with the supplied evidence.+--+-- This should only be invoked within 'tcPluginSolve'.+newGiven :: EvBindsVar -> CtLoc -> PredType -> EvExpr -> TcPluginM CtEvidence+newGiven tc_evbinds loc pty evtm = do    new_ev <- newEvVar pty-   setEvBind $ mkGivenEvBind new_ev (EvExpr evtm)+   setEvBind tc_evbinds $ mkGivenEvBind new_ev (EvExpr evtm)    return CtGiven { ctev_pred = pty, ctev_evar = new_ev, ctev_loc = loc }  -- | Create a fresh evidence variable.+--+-- This should only be invoked within 'tcPluginSolve'. newEvVar :: PredType -> TcPluginM EvVar newEvVar = unsafeTcPluginTcM . TcM.newEvVar  -- | Create a fresh coercion hole.+-- This should only be invoked within 'tcPluginSolve'. newCoercionHole :: PredType -> TcPluginM CoercionHole newCoercionHole = unsafeTcPluginTcM . TcM.newCoercionHole --- | Bind an evidence variable.  This must not be invoked from--- 'tcPluginInit' or 'tcPluginStop', or it will panic.-setEvBind :: EvBind -> TcPluginM ()-setEvBind ev_bind = do-    tc_evbinds <- getEvBindsTcPluginM+-- | Bind an evidence variable.+--+-- This should only be invoked within 'tcPluginSolve'.+setEvBind :: EvBindsVar -> EvBind -> TcPluginM ()+setEvBind tc_evbinds ev_bind = do     unsafeTcPluginTcM $ TcM.addTcEvBind tc_evbinds ev_bind
GHC/Tc/Solver.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE RecursiveDo #-}  module GHC.Tc.Solver(        InferMode(..), simplifyInfer, findInferredDiff,@@ -22,16 +22,15 @@        promoteTyVarSet, simplifyAndEmitFlatConstraints,         -- For Rules we need these-       solveWanteds, solveWantedsAndDrop,-       approximateWC, runTcSDeriveds-  ) where+       solveWanteds,+       approximateWC -#include "HsVersions.h"+  ) where  import GHC.Prelude  import GHC.Data.Bag-import GHC.Core.Class ( Class, classKey, classTyCon )+import GHC.Core.Class import GHC.Driver.Session import GHC.Tc.Utils.Instantiate import GHC.Data.List.SetOps@@ -41,6 +40,7 @@ import GHC.Builtin.Utils import GHC.Builtin.Names import GHC.Tc.Errors+import GHC.Tc.Errors.Types import GHC.Tc.Types.Evidence import GHC.Tc.Solver.Interact import GHC.Tc.Solver.Canonical   ( makeSuperClasses, solveCallStack )@@ -48,20 +48,24 @@ import GHC.Tc.Utils.Unify        ( buildTvImplication ) import GHC.Tc.Utils.TcMType as TcM import GHC.Tc.Utils.Monad   as TcM+import GHC.Tc.Solver.InertSet import GHC.Tc.Solver.Monad  as TcS import GHC.Tc.Types.Constraint+import GHC.Tc.Instance.FunDeps import GHC.Core.Predicate import GHC.Tc.Types.Origin import GHC.Tc.Utils.TcType import GHC.Core.Type import GHC.Core.Ppr-import GHC.Builtin.Types ( liftedRepTy, manyDataConTy )+import GHC.Core.TyCon    ( TyConBinder, isTypeFamilyTyCon )+import GHC.Builtin.Types ( liftedRepTy, manyDataConTy, liftedDataConTy ) import GHC.Core.Unify    ( tcMatchTyKi ) import GHC.Utils.Misc import GHC.Utils.Panic import GHC.Types.Var import GHC.Types.Var.Set-import GHC.Types.Basic    ( IntWithInf, intGtLimit )+import GHC.Types.Basic    ( IntWithInf, intGtLimit+                          , DefaultingStrategy(..), NonStandardDefaultingStrategy(..) ) import GHC.Types.Error import qualified GHC.LanguageExtensions as LangExt @@ -69,6 +73,7 @@ import Data.Foldable      ( toList ) import Data.List          ( partition ) import Data.List.NonEmpty ( NonEmpty(..) )+import GHC.Data.Maybe     ( mapMaybe )  {- *********************************************************************************@@ -121,7 +126,7 @@   = do { empty_binds <- simplifyTop (mkImplicWC implics)         -- Since all the inputs are implications the returned bindings will be empty-       ; MASSERT2( isEmptyBag empty_binds, ppr empty_binds )+       ; massertPpr (isEmptyBag empty_binds) (ppr empty_binds)         ; return () } @@ -153,23 +158,23 @@             ; whyUnsafe <- getWarningMessages <$> TcM.readTcRef errs_var            ; TcM.writeTcRef errs_var saved_msg-           ; recordUnsafeInfer whyUnsafe+           ; recordUnsafeInfer (mkMessages whyUnsafe)            }        ; traceTc "reportUnsolved (unsafe overlapping) }" empty         ; return (evBindMapBinds binds1 `unionBags` binds2) } -pushLevelAndSolveEqualities :: SkolemInfo -> [TcTyVar] -> TcM a -> TcM a+pushLevelAndSolveEqualities :: SkolemInfoAnon -> [TyConBinder] -> TcM a -> TcM a -- Push level, and solve all resulting equalities -- If there are any unsolved equalities, report them -- and fail (in the monad) -- -- Panics if we solve any non-equality constraints.  (In runTCSEqualities -- we use an error thunk for the evidence bindings.)-pushLevelAndSolveEqualities skol_info skol_tvs thing_inside+pushLevelAndSolveEqualities skol_info_anon tcbs thing_inside   = do { (tclvl, wanted, res) <- pushLevelAndSolveEqualitiesX                                       "pushLevelAndSolveEqualities" thing_inside-       ; reportUnsolvedEqualities skol_info skol_tvs tclvl wanted+       ; report_unsolved_equalities skol_info_anon (binderVars tcbs) tclvl wanted        ; return res }  pushLevelAndSolveEqualitiesX :: String -> TcM a@@ -212,7 +217,7 @@ simplifyAndEmitFlatConstraints :: WantedConstraints -> TcM () -- See Note [Failure in local type signatures] simplifyAndEmitFlatConstraints wanted-  = do { -- Solve and zonk to esablish the+  = do { -- Solve and zonk to establish the          -- preconditions for floatKindEqualities          wanted <- runTcSEqualities (solveWanteds wanted)        ; wanted <- TcM.zonkWC wanted@@ -223,22 +228,23 @@                          -- Emit the bad constraints, wrapped in an implication                          -- See Note [Wrapping failing kind equalities]                          ; tclvl  <- TcM.getTcLevel-                         ; implic <- buildTvImplication UnkSkol [] (pushTcLevel tclvl) wanted-                                    --                  ^^^^^^   |  ^^^^^^^^^^^^^^^^^-                                    -- it's OK to use UnkSkol    |  we must increase the TcLevel,-                                    -- because we don't bind     |  as explained in-                                    -- any skolem variables here |  Note [Wrapping failing kind equalities]+                         ; implic <- buildTvImplication unkSkolAnon [] (pushTcLevel tclvl) wanted+                                        --                  ^^^^^^   |  ^^^^^^^^^^^^^^^^^+                                        -- it's OK to use unkSkol    |  we must increase the TcLevel,+                                        -- because we don't bind     |  as explained in+                                        -- any skolem variables here |  Note [Wrapping failing kind equalities]                          ; emitImplication implic                          ; failM }-           Just (simples, holes)+           Just (simples, errs)               -> do { _ <- promoteTyVarSet (tyCoVarsOfCts simples)                     ; traceTc "emitFlatConstraints }" $                       vcat [ text "simples:" <+> ppr simples-                           , text "holes:  " <+> ppr holes ]-                    ; emitHoles holes -- Holes don't need promotion+                           , text "errs:   " <+> ppr errs ]+                      -- Holes and other delayed errors don't need promotion+                    ; emitDelayedErrors errs                     ; emitSimples simples } } -floatKindEqualities :: WantedConstraints -> Maybe (Bag Ct, Bag Hole)+floatKindEqualities :: WantedConstraints -> Maybe (Bag Ct, Bag DelayedError) -- Float out all the constraints from the WantedConstraints, -- Return Nothing if any constraints can't be floated (captured -- by skolems), or if there is an insoluble constraint, or@@ -251,15 +257,15 @@ -- See Note [floatKindEqualities vs approximateWC] floatKindEqualities wc = float_wc emptyVarSet wc   where-    float_wc :: TcTyCoVarSet -> WantedConstraints -> Maybe (Bag Ct, Bag Hole)+    float_wc :: TcTyCoVarSet -> WantedConstraints -> Maybe (Bag Ct, Bag DelayedError)     float_wc trapping_tvs (WC { wc_simple = simples                               , wc_impl = implics-                              , wc_holes = holes })+                              , wc_errors = errs })       | all is_floatable simples-      = do { (inner_simples, inner_holes)+      = do { (inner_simples, inner_errs)                 <- flatMapBagPairM (float_implic trapping_tvs) implics            ; return ( simples `unionBags` inner_simples-                    , holes `unionBags` inner_holes) }+                    , errs `unionBags` inner_errs) }       | otherwise       = Nothing       where@@ -267,7 +273,7 @@            | insolubleEqCt ct = False            | otherwise        = tyCoVarsOfCt ct `disjointVarSet` trapping_tvs -    float_implic :: TcTyCoVarSet -> Implication -> Maybe (Bag Ct, Bag Hole)+    float_implic :: TcTyCoVarSet -> Implication -> Maybe (Bag Ct, Bag DelayedError)     float_implic trapping_tvs (Implic { ic_wanted = wanted, ic_given_eqs = given_eqs                                       , ic_skols = skols, ic_status = status })       | isInsolubleStatus status@@ -456,13 +462,20 @@ -- -- The provided SkolemInfo and [TcTyVar] arguments are used in an implication to -- provide skolem info for any errors.--- reportUnsolvedEqualities skol_info skol_tvs tclvl wanted+  = report_unsolved_equalities (getSkolemInfo skol_info) skol_tvs tclvl wanted++report_unsolved_equalities :: SkolemInfoAnon -> [TcTyVar] -> TcLevel+                           -> WantedConstraints -> TcM ()+report_unsolved_equalities skol_info_anon skol_tvs tclvl wanted   | isEmptyWC wanted   = return ()-  | otherwise++  | otherwise  -- NB: we build an implication /even if skol_tvs is empty/,+               -- just to ensure that our level invariants hold, specifically+               -- (WantedInv).  See Note [TcLevel invariants].   = checkNoErrs $   -- Fail-    do { implic <- buildTvImplication skol_info skol_tvs tclvl wanted+    do { implic <- buildTvImplication skol_info_anon skol_tvs tclvl wanted        ; reportAllUnsolved (mkImplicWC (unitBag implic)) }  @@ -471,7 +484,7 @@ simplifyTopWanteds :: WantedConstraints -> TcS WantedConstraints     -- See Note [Top-level Defaulting Plan] simplifyTopWanteds wanteds-  = do { wc_first_go <- nestTcS (solveWantedsAndDrop wanteds)+  = do { wc_first_go <- nestTcS (solveWanteds wanteds)                             -- This is where the main work happens        ; dflags <- getDynFlags        ; try_tyvar_defaulting dflags wc_first_go }@@ -484,14 +497,22 @@       , gopt Opt_PrintExplicitRuntimeReps dflags -- See Note [Defaulting insolubles]       = try_class_defaulting wc       | otherwise-      = do { free_tvs <- TcS.zonkTyCoVarsAndFVList (tyCoVarsOfWCList wc)-           ; let meta_tvs = filter (isTyVar <&&> isMetaTyVar) free_tvs-                   -- zonkTyCoVarsAndFV: the wc_first_go is not yet zonked-                   -- filter isMetaTyVar: we might have runtime-skolems in GHCi,-                   -- and we definitely don't want to try to assign to those!-                   -- The isTyVar is needed to weed out coercion variables+      = do { -- Need to zonk first, as the WantedConstraints are not yet zonked.+           ; free_tvs <- TcS.zonkTyCoVarsAndFVList (tyCoVarsOfWCList wc)+           ; let defaultable_tvs = filter can_default free_tvs+                 can_default tv+                   =   isTyVar tv+                       -- Weed out coercion variables. -           ; defaulted <- mapM defaultTyVarTcS meta_tvs   -- Has unification side effects+                    && isMetaTyVar tv+                       -- Weed out runtime-skolems in GHCi, which we definitely+                       -- shouldn't try to default.++                    && not (tv `elemVarSet` nonDefaultableTyVarsOfWC wc)+                       -- Weed out variables for which defaulting would be unhelpful,+                       -- e.g. alpha appearing in [W] alpha[conc] ~# rr[sk].++           ; defaulted <- mapM defaultTyVarTcS defaultable_tvs -- Has unification side effects            ; if or defaulted              then do { wc_residual <- nestTcS (solveWanteds wc)                             -- See Note [Must simplify after defaulting]@@ -501,12 +522,12 @@     try_class_defaulting :: WantedConstraints -> TcS WantedConstraints     try_class_defaulting wc       | isEmptyWC wc || insolubleWC wc -- See Note [Defaulting insolubles]-      = return wc+      = try_callstack_defaulting wc       | otherwise  -- See Note [When to do type-class defaulting]       = do { something_happened <- applyDefaultingRules wc                                    -- See Note [Top-level Defaulting Plan]            ; if something_happened-             then do { wc_residual <- nestTcS (solveWantedsAndDrop wc)+             then do { wc_residual <- nestTcS (solveWanteds wc)                      ; try_class_defaulting wc_residual }                   -- See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence              else try_callstack_defaulting wc }@@ -582,6 +603,20 @@ errors if there are *any* insoluble errors, anywhere, but that seems too drastic. +Note [Don't default in syntactic equalities]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When there are unsolved syntactic equalities such as++  rr[sk] ~S# alpha[conc]++we should not default alpha, lest we obtain a poor error message such as++  Couldn't match kind `rr' with `LiftedRep'++We would rather preserve the original syntactic equality to be+reported to the user, especially as the concrete metavariable alpha+might store an informative origin for the user.+ Note [Must simplify after defaulting] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We may have a deeply buried constraint@@ -664,7 +699,7 @@ Secondly, when should these heuristics be enforced? We enforced them when the type-class method call site is in a module marked `-XSafe` or `-XTrustworthy`. This allows `-XUnsafe` modules to operate without restriction, and for Safe-Haskell inferrence to infer modules with unsafe overlaps as unsafe.+Haskell inference to infer modules with unsafe overlaps as unsafe.  One alternative design would be to also consider if an instance was imported as a `safe` import or not and only apply the restriction to instances imported@@ -728,17 +763,17 @@     available and how they overlap. So we once again call `lookupInstEnv` to     figure that out so we can generate a helpful error message. - 6) `GHC.Tc.Utils.Monad.recordUnsafeInfer` -- Save the unsafe result and reason in an-      IORef called `tcg_safeInfer`.+ 6) `GHC.Tc.Utils.Monad.recordUnsafeInfer` -- Save the unsafe result and reason in+      IORefs called `tcg_safe_infer` and `tcg_safe_infer_reason`. - 7) `GHC.Driver.Main.tcRnModule'` -- Reads `tcg_safeInfer` after type-checking, calling-    `GHC.Driver.Main.markUnsafeInfer` (passing the reason along) when safe-inferrence+ 7) `GHC.Driver.Main.tcRnModule'` -- Reads `tcg_safe_infer` after type-checking, calling+    `GHC.Driver.Main.markUnsafeInfer` (passing the reason along) when safe-inference     failed.  Note [No defaulting in the ambiguity check] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When simplifying constraints for the ambiguity check, we use-solveWantedsAndDrop, not simplifyTopWanteds, so that we do no defaulting.+solveWanteds, not simplifyTopWanteds, so that we do no defaulting. #11947 was an example:    f :: Num a => Int -> Int This is ambiguous of course, but we don't want to default the@@ -785,16 +820,32 @@  which is just plain wrong. -Conclusion: we should do RuntimeRep-defaulting on insolubles only when the user does not-want to hear about RuntimeRep stuff -- that is, when -fprint-explicit-runtime-reps-is not set.+Another situation in which we don't want to default involves concrete metavariables.++In equalities such as   alpha[conc] ~# rr[sk]  ,  alpha[conc] ~# RR beta[tau]+for a type family RR (all at kind RuntimeRep), we would prefer to report a+representation-polymorphism error rather than default alpha and get error:++  Could not unify `rr` with `Lifted` / Could not unify `RR b0` with `Lifted`++which is very confusing. For this reason, we weed out the concrete+metavariables participating in such equalities in nonDefaultableTyVarsOfWC.+Just looking at insolublity is not enough, as `alpha[conc] ~# RR beta[tau]` could+become soluble after defaulting beta (see also #21430).++Conclusion: we should do RuntimeRep-defaulting on insolubles only when the+user does not want to hear about RuntimeRep stuff -- that is, when+-fprint-explicit-runtime-reps is not set.+However, we must still take care not to default concrete type variables+participating in an equality with a non-concrete type, as seen in the+last example above. -}  ------------------ simplifyAmbiguityCheck :: Type -> WantedConstraints -> TcM () simplifyAmbiguityCheck ty wanteds   = do { traceTc "simplifyAmbiguityCheck {" (text "type = " <+> ppr ty $$ text "wanted = " <+> ppr wanteds)-       ; (final_wc, _) <- runTcS $ solveWantedsAndDrop wanteds+       ; (final_wc, _) <- runTcS $ solveWanteds wanteds              -- NB: no defaulting!  See Note [No defaulting in the ambiguity check]         ; traceTc "End simplifyAmbiguityCheck }" empty@@ -822,18 +873,83 @@ simplifyDefault theta   = do { traceTc "simplifyDefault" empty        ; wanteds  <- newWanteds DefaultOrigin theta-       ; unsolved <- runTcSDeriveds (solveWantedsAndDrop (mkSimpleWC wanteds))+       ; (unsolved, _) <- runTcS (solveWanteds (mkSimpleWC wanteds))        ; return (isEmptyWC unsolved) }  ------------------+{- Note [Pattern match warnings with insoluble Givens]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A pattern match on a GADT can introduce new type-level information, which needs+to be analysed in order to get the expected pattern match warnings.++For example:++> type IsBool :: Type -> Constraint+> type family IsBool a where+>   IsBool Bool = ()+>   IsBool b    = b ~ Bool+>+> data T a where+>   MkTInt  :: Int -> T Int+>   MkTBool :: IsBool b => b -> T b+>+> f :: T Int -> Int+> f (MkTInt i) = i++The pattern matching performed by `f` is complete: we can't ever call+`f (MkTBool b)`, as type-checking that application would require producing+evidence for `Int ~ Bool`, which can't be done.++The pattern match checker uses `tcCheckGivens` to accumulate all the Given+constraints, and relies on `tcCheckGivens` to return Nothing if the+Givens become insoluble.   `tcCheckGivens` in turn relies on `insolubleCt`+to identify these insoluble constraints.  So the precise definition of+`insolubleCt` has a big effect on pattern match overlap warnings.++To detect this situation, we check whether there are any insoluble Given+constraints. In the example above, the insoluble constraint was an+equality constraint, but it is also important to detect custom type errors:++> type NotInt :: Type -> Constraint+> type family NotInt a where+>   NotInt Int = TypeError (Text "That's Int, silly.")+>   NotInt _   = ()+>+> data R a where+>   MkT1 :: a -> R a+>   MkT2 :: NotInt a => R a+>+> foo :: R Int -> Int+> foo (MkT1 x) = x++To see that we can't call `foo (MkT2)`, we must detect that `NotInt Int` is insoluble+because it is a custom type error.+Failing to do so proved quite inconvenient for users, as evidence by the+tickets #11503 #14141 #16377 #20180.+Test cases: T11503, T14141.++Examples of constraints that tcCheckGivens considers insoluble:+  - Int ~ Bool,+  - Coercible Float Word,+  - TypeError msg.++Non-examples:+  - constraints which we know aren't satisfied,+    e.g. Show (Int -> Int) when no such instance is in scope,+  - Eq (TypeError msg),+  - C (Int ~ Bool), with @class C (c :: Constraint)@.+-}+ tcCheckGivens :: InertSet -> Bag EvVar -> TcM (Maybe InertSet) -- ^ Return (Just new_inerts) if the Givens are satisfiable, Nothing if definitely--- contradictory+-- contradictory.+--+-- See Note [Pattern match warnings with insoluble Givens] above. tcCheckGivens inerts given_ids = do   (sat, new_inerts) <- runTcSInerts inerts $ do     traceTcS "checkGivens {" (ppr inerts <+> ppr given_ids)     lcl_env <- TcS.getLclEnv-    let given_loc = mkGivenLoc topTcLevel UnkSkol lcl_env+    let given_loc = mkGivenLoc topTcLevel (getSkolemInfo unkSkol) lcl_env     let given_cts = mkGivens given_loc (bagToList given_ids)     -- See Note [Superclasses and satisfiability]     solveSimpleGivens given_cts@@ -863,7 +979,7 @@   (sat, _new_inerts) <- runTcSInerts inerts $ do     traceTcS "checkWanteds {" (ppr inerts <+> ppr wanteds)     -- See Note [Superclasses and satisfiability]-    wcs <- solveWantedsAndDrop (mkSimpleWC cts)+    wcs <- solveWanteds (mkSimpleWC cts)     traceTcS "checkWanteds }" (ppr wcs)     return (isSolvedWC wcs)   return sat@@ -945,6 +1061,55 @@ has a strictly-increased level compared to the ambient level outside the let binding. +Note [Inferring principal types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We don't always infer principal types. For instance, the inferred type for++> f x = show [x]++is++> f :: Show a => a -> String++This is not the most general type if we allow flexible contexts.+Indeed, if we try to write the following++> g :: Show [a] => a -> String+> g x = f x++we get the error:++  * Could not deduce (Show a) arising from a use of `f'+    from the context: Show [a]++Though replacing f x in the right-hand side of g with the definition+of f x works, the call to f x does not. This is the hallmark of+unprincip{led,al} types.++Another example:++> class C a+> class D a where+>   d :: a+> instance C a => D a where+>   d = undefined+> h _ = d   -- argument is to avoid the monomorphism restriction++The inferred type for h is++> h :: C a => t -> a++even though++> h :: D a => t -> a++is more general.++The fix is easy: don't simplify constraints before inferring a type.+That is, have the inferred type quantify over all constraints that arise+in a definition's right-hand side, even if they are simplifiable.+Unfortunately, this would yield all manner of unwieldy types,+and so we won't do so. -}  -- | How should we choose which constraints to quantify over?@@ -954,7 +1119,7 @@                                   -- the :type +d case; this mode refuses                                   -- to quantify over any defaultable constraint                | NoRestrictions   -- ^ Quantify over any constraint that-                                  -- satisfies 'GHC.Tc.Utils.TcType.pickQuantifiablePreds'+                                  -- satisfies pickQuantifiablePreds  instance Outputable InferMode where   ppr ApplyMR         = text "ApplyMR"@@ -982,7 +1147,9 @@                                    , pred <- sig_inst_theta sig ]         ; dep_vars <- candidateQTyVarsOfTypes (psig_tv_tys ++ psig_theta ++ map snd name_taus)-       ; qtkvs <- quantifyTyVars dep_vars++       ; skol_info <- mkSkolemInfo (InferSkol name_taus)+       ; qtkvs <- quantifyTyVars skol_info DefaultNonStandardTyVars dep_vars        ; traceTc "simplifyInfer: empty WC" (ppr name_taus $$ ppr qtkvs)        ; return (qtkvs, [], emptyTcEvBinds, False) } @@ -1007,11 +1174,12 @@         ; ev_binds_var <- TcM.newTcEvBinds        ; psig_evs     <- newWanteds AnnOrigin psig_theta-       ; wanted_transformed_incl_derivs+       ; wanted_transformed             <- setTcLevel rhs_tclvl $                runTcSWithEvBinds ev_binds_var $                solveWanteds (mkSimpleWC psig_evs `andWC` wanteds)                -- psig_evs : see Note [Add signature contexts as wanteds]+               -- See Note [Inferring principal types]         -- Find quant_pred_candidates, the predicates that        -- we'll consider quantifying over@@ -1019,12 +1187,9 @@        --      the psig_theta; it's just the extra bit        -- NB2: We do not do any defaulting when inferring a type, this can lead        --      to less polymorphic types, see Note [Default while Inferring]-       ; wanted_transformed_incl_derivs <- TcM.zonkWC wanted_transformed_incl_derivs-       ; let definite_error = insolubleWC wanted_transformed_incl_derivs+       ; wanted_transformed <- TcM.zonkWC wanted_transformed+       ; let definite_error = insolubleWC wanted_transformed                               -- See Note [Quantification with errors]-                              -- NB: must include derived errors in this test,-                              --     hence "incl_derivs"-             wanted_transformed = dropDerivedWC wanted_transformed_incl_derivs              quant_pred_candidates                | definite_error = []                | otherwise      = ctsPreds (approximateWC False wanted_transformed)@@ -1034,11 +1199,17 @@        -- NB: bound_theta are constraints we want to quantify over,        --     including the psig_theta, which we always quantify over        -- NB: bound_theta are fully zonked-       ; (qtvs, bound_theta, co_vars) <- decideQuantification infer_mode rhs_tclvl+       ; rec { (qtvs, bound_theta, co_vars) <- decideQuantification skol_info infer_mode rhs_tclvl                                                      name_taus partial_sigs                                                      quant_pred_candidates-       ; bound_theta_vars <- mapM TcM.newEvVar bound_theta+             ;  bound_theta_vars <- mapM TcM.newEvVar bound_theta +             ; let full_theta = map idType bound_theta_vars+             ; skol_info <- mkSkolemInfo (InferSkol [ (name, mkSigmaTy [] full_theta ty)+                                                    | (name, ty) <- name_taus ])+       }++        -- Now emit the residual constraint        ; emitResidualConstraints rhs_tclvl ev_binds_var                                  name_taus co_vars qtvs bound_theta_vars@@ -1060,7 +1231,7 @@ -------------------- emitResidualConstraints :: TcLevel -> EvBindsVar                         -> [(Name, TcTauType)]-                        -> VarSet -> [TcTyVar] -> [EvVar]+                        -> CoVarSet -> [TcTyVar] -> [EvVar]                         -> WantedConstraints -> TcM () -- Emit the remaining constraints from the RHS. emitResidualConstraints rhs_tclvl ev_binds_var@@ -1071,7 +1242,11 @@   | otherwise   = do { wanted_simple <- TcM.zonkSimples (wc_simple wanteds)        ; let (outer_simple, inner_simple) = partitionBag is_mono wanted_simple-             is_mono ct = isWantedCt ct && ctEvId ct `elemVarSet` co_vars+             is_mono ct+               | Just ct_ev_id <- wantedEvId_maybe ct+               = ct_ev_id `elemVarSet` co_vars+               | otherwise+               = False              -- Reason for the partition:              -- see Note [Emitting the residual implication in simplifyInfer] @@ -1119,12 +1294,12 @@     do { lcl_env   <- TcM.getLclEnv        ; given_ids <- mapM TcM.newEvVar annotated_theta        ; wanteds   <- newWanteds AnnOrigin inferred_theta-       ; let given_loc = mkGivenLoc topTcLevel UnkSkol lcl_env+       ; let given_loc = mkGivenLoc topTcLevel (getSkolemInfo unkSkol) lcl_env              given_cts = mkGivens given_loc given_ids -       ; residual <- runTcSDeriveds $-                     do { _ <- solveSimpleGivens given_cts-                        ; solveSimpleWanteds (listToBag (map mkNonCanonical wanteds)) }+       ; (residual, _) <- runTcS $+                          do { _ <- solveSimpleGivens given_cts+                             ; solveSimpleWanteds (listToBag (map mkNonCanonical wanteds)) }          -- NB: There are no meta tyvars fromn this level annotated_theta          -- because we have either promoted them or unified them          -- See `Note [Quantification and partial signatures]` Wrinkle 2@@ -1220,19 +1395,21 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If the monomorphism restriction does not apply, then we quantify as follows: -* Step 1. Take the global tyvars, and "grow" them using the equality-  constraints+* Step 1: decideMonoTyVars.+  Take the global tyvars, and "grow" them using functional dependencies      E.g.  if x:alpha is in the environment, and alpha ~ [beta] (which can           happen because alpha is untouchable here) then do not quantify over           beta, because alpha fixes beta, and beta is effectively free in-          the environment too+          the environment too; this logic extends to general fundeps, not+          just equalities    We also account for the monomorphism restriction; if it applies,   add the free vars of all the constraints.    Result is mono_tvs; we will not quantify over these. -* Step 2. Default any non-mono tyvars (i.e ones that are definitely+* Step 2: defaultTyVarsAndSimplify.+  Default any non-mono tyvars (i.e ones that are definitely   not going to become further constrained), and re-simplify the   candidate constraints. @@ -1244,34 +1421,191 @@    This is all very tiresome. -* Step 3: decide which variables to quantify over, as follows:+  This step also promotes the mono_tvs from Step 1. See+  Note [Promote monomorphic tyvars]. In fact, the *only*+  use of the mono_tvs from Step 1 is to promote them here.+  This promotion effectively stops us from quantifying over them+  later, in Step 3. Because the actual variables to quantify+  over are determined in Step 3 (not in Step 1), it is OK for+  the mono_tvs to be missing some variables free in the+  environment. This is why removing the psig_qtvs is OK in+  decideMonoTyVars. Test case for this scenario: T14479. -  - Take the free vars of the tau-type (zonked_tau_tvs) and "grow"-    them using all the constraints.  These are tau_tvs_plus+* Step 3: decideQuantifiedTyVars.+  Decide which variables to quantify over, as follows: -  - Use quantifyTyVars to quantify over (tau_tvs_plus - mono_tvs), being-    careful to close over kinds, and to skolemise the quantified tyvars.-    (This actually unifies each quantifies meta-tyvar with a fresh skolem.)+  - Take the free vars of the partial-type-signature types and constraints,+    and the tau-type (zonked_tau_tvs), and then "grow"+    them using all the constraints.  These are grown_tcvs.+    See Note [growThetaTyVars vs closeWrtFunDeps]. +  - Use quantifyTyVars to quantify over the free variables of all the types+    involved, but only those in the grown_tcvs.+   Result is qtvs.  * Step 4: Filter the constraints using pickQuantifiablePreds and the   qtvs. We have to zonk the constraints first, so they "see" the   freshly created skolems. +Note [Lift equality constraints when quantifying]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We can't quantify over a constraint (t1 ~# t2) because that isn't a+predicate type; see Note [Types for coercions, predicates, and evidence]+in GHC.Core.TyCo.Rep.++So we have to 'lift' it to (t1 ~ t2).  Similarly (~R#) must be lifted+to Coercible.++This tiresome lifting is the reason that pick_me (in+pickQuantifiablePreds) returns a Maybe rather than a Bool.++Note [Inheriting implicit parameters]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this:++        f x = (x::Int) + ?y++where f is *not* a top-level binding.+From the RHS of f we'll get the constraint (?y::Int).+There are two types we might infer for f:++        f :: Int -> Int++(so we get ?y from the context of f's definition), or++        f :: (?y::Int) => Int -> Int++At first you might think the first was better, because then+?y behaves like a free variable of the definition, rather than+having to be passed at each call site.  But of course, the WHOLE+IDEA is that ?y should be passed at each call site (that's what+dynamic binding means) so we'd better infer the second.++BOTTOM LINE: when *inferring types* you must quantify over implicit+parameters, *even if* they don't mention the bound type variables.+Reason: because implicit parameters, uniquely, have local instance+declarations. See pickQuantifiablePreds.++Note [Quantifying over equality constraints]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Should we quantify over an equality constraint (s ~ t)?  In general, we don't.+Doing so may simply postpone a type error from the function definition site to+its call site.  (At worst, imagine (Int ~ Bool)).++However, consider this+         forall a. (F [a] ~ Int) => blah+Should we quantify over the (F [a] ~ Int).  Perhaps yes, because at the call+site we will know 'a', and perhaps we have instance  F [Bool] = Int.+So we *do* quantify over a type-family equality where the arguments mention+the quantified variables.++Note [Unconditionally resimplify constraints when quantifying]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+During quantification (in defaultTyVarsAndSimplify, specifically), we re-invoke+the solver to simplify the constraints before quantifying them. We do this for+two reasons, enumerated below. We could, in theory, detect when either of these+cases apply and simplify only then, but collecting this information is bothersome,+and simplifying redundantly causes no real harm. Note that this code path+happens only for definitions+  * without a type signature+  * when -XMonoLocalBinds does not apply+  * with unsolved constraints+and so the performance cost will be small.++1. Defaulting++Defaulting the variables handled by defaultTyVar may unlock instance simplifications.+Example (typecheck/should_compile/T20584b):++  with (t :: Double) (u :: String) = printf "..." t u++We know the types of t and u, but we do not know the return type of `with`. So, we+assume `with :: alpha`, where `alpha :: TYPE rho`. The type of printf is+  printf :: PrintfType r => String -> r+The occurrence of printf is instantiated with a fresh var beta. We then get+  beta := Double -> String -> alpha+and+  [W] PrintfType (Double -> String -> alpha)++Module Text.Printf exports+  instance (PrintfArg a, PrintfType r) => PrintfType (a -> r)+and it looks like that instance should apply.++But I have elided some key details: (->) is polymorphic over multiplicity and+runtime representation. Here it is in full glory:+  [W] PrintfType ((Double :: Type) %m1 -> (String :: Type) %m2 -> (alpha :: TYPE rho))+  instance (PrintfArg a, PrintfType r) => PrintfType ((a :: Type) %Many -> (r :: Type))++Because we do not know that m1 is Many, we cannot use the instance. (Perhaps a better instance+would have an explicit equality constraint to the left of =>, but that's not what we have.)+Then, in defaultTyVarsAndSimplify, we get m1 := Many, m2 := Many, and rho := LiftedRep.+Yet it's too late to simplify the quantified constraint, and thus GHC infers+  wait :: PrintfType (Double -> String -> t) => Double -> String -> t+which is silly. Simplifying again after defaulting solves this problem.++2. Interacting functional dependencies++Suppose we have++  class C a b | a -> b++and we are running simplifyInfer over++  forall[2] x. () => [W] C a beta1[1]+  forall[2] y. () => [W] C a beta2[1]++These are two implication constraints, both of which contain a+wanted for the class C. Neither constraint mentions the bound+skolem. We might imagine that these constraint could thus float+out of their implications and then interact, causing beta1 to unify+with beta2, but constraints do not currently float out of implications.++Unifying the beta1 and beta2 is important. Without doing so, then we might+infer a type like (C a b1, C a b2) => a -> a, which will fail to pass the+ambiguity check, which will say (rightly) that it cannot unify b1 with b2, as+required by the fundep interactions. This happens in the parsec library, and+in test case typecheck/should_compile/FloatFDs.++If we re-simplify, however, the two fundep constraints will interact, causing+a unification between beta1 and beta2, and all will be well. The key step+is that this simplification happens *after* the call to approximateWC in+simplifyInfer.++Note [Do not quantify over constraints that determine a variable]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider (typecheck/should_compile/tc231), where we're trying to infer+the type of a top-level declaration. We have+  class Zork s a b | a -> b+and the candidate constraint at the end of simplifyInfer is+  [W] Zork alpha (Z [Char]) beta+We definitely do want to quantify over alpha (which is mentioned in+the tau-type). But we do *not* want to quantify over beta: it is+determined by the functional dependency on Zork: note that the second+argument to Zork in the Wanted is a variable-free Z [Char].++The question here: do we want to quantify over the constraint? Definitely not.+Since we're not quantifying over beta, GHC has no choice but to zap beta+to Any, and then we infer a type involving (Zork a (Z [Char]) Any => ...). No no no.++The no_fixed_dependencies check in pickQuantifiablePreds eliminates this+candidate from the pool. Because there are no Zork instances in scope, this+program is rejected.+ -}  decideQuantification-  :: InferMode+  :: SkolemInfo+  -> InferMode   -> TcLevel   -> [(Name, TcTauType)]   -- Variables to be generalised   -> [TcIdSigInst]         -- Partial type signatures (if any)   -> [PredType]            -- Candidate theta; already zonked   -> TcM ( [TcTyVar]       -- Quantify over these (skolems)          , [PredType]      -- and this context (fully zonked)-         , VarSet)+         , CoVarSet) -- See Note [Deciding quantification]-decideQuantification infer_mode rhs_tclvl name_taus psigs candidates+decideQuantification skol_info infer_mode rhs_tclvl name_taus psigs candidates   = do { -- Step 1: find the mono_tvs        ; (mono_tvs, candidates, co_vars) <- decideMonoTyVars infer_mode                                               name_taus psigs candidates@@ -1281,7 +1615,7 @@        ; candidates <- defaultTyVarsAndSimplify rhs_tclvl mono_tvs candidates         -- Step 3: decide which kind/type variables to quantify over-       ; qtvs <- decideQuantifiedTyVars name_taus psigs candidates+       ; qtvs <- decideQuantifiedTyVars skol_info name_taus psigs candidates         -- Step 4: choose which of the remaining candidate        --         predicates to actually quantify over@@ -1358,7 +1692,7 @@ -- Decide which tyvars and covars cannot be generalised: --   (a) Free in the environment --   (b) Mentioned in a constraint we can't generalise---   (c) Connected by an equality to (a) or (b)+--   (c) Connected by an equality or fundep to (a) or (b) -- Also return CoVars that appear free in the final quantified types --   we can't quantify over these, and we must make sure they are in scope decideMonoTyVars infer_mode name_taus psigs candidates@@ -1366,7 +1700,7 @@         -- If possible, we quantify over partial-sig qtvs, so they are        -- not mono. Need to zonk them because they are meta-tyvar TyVarTvs-       ; psig_qtvs <- mapM zonkTcTyVarToTyVar $ binderVars $+       ; psig_qtvs <-  zonkTcTyVarsToTcTyVars $ binderVars $                       concatMap (map snd . sig_inst_skols) psigs         ; psig_theta <- mapM TcM.zonkTcType $@@ -1377,7 +1711,7 @@        ; tc_lvl <- TcM.getTcLevel        ; let psig_tys = mkTyVarTys psig_qtvs ++ psig_theta -             co_vars = coVarsOfTypes (psig_tys ++ taus)+             co_vars = coVarsOfTypes (psig_tys ++ taus ++ candidates)              co_var_tvs = closeOverKinds co_vars                -- The co_var_tvs are tvs mentioned in the types of covars or                -- coercion holes. We can't quantify over these covars, so we@@ -1388,7 +1722,7 @@              mono_tvs0 = filterVarSet (not . isQuantifiableTv tc_lvl) $                          tyCoVarsOfTypes candidates                -- We need to grab all the non-quantifiable tyvars in the-               -- candidates so that we can grow this set to find other+               -- types so that we can grow this set to find other                -- non-quantifiable tyvars. This can happen with something                -- like                --    f x y = ...@@ -1400,44 +1734,58 @@                -- alpha. Actual test case: typecheck/should_compile/tc213               mono_tvs1 = mono_tvs0 `unionVarSet` co_var_tvs+               -- mono_tvs1 is now the set of variables from an outer scope+               -- (that's mono_tvs0) and the set of covars, closed over kinds.+               -- Given this set of variables we know we will not quantify,+               -- we want to find any other variables that are determined by this+               -- set, by functional dependencies or equalities. We thus use+               -- closeWrtFunDeps to find all further variables determined by this root+               -- set. See Note [growThetaTyVars vs closeWrtFunDeps] -             eq_constraints = filter isEqPrimPred candidates-             mono_tvs2      = growThetaTyVars eq_constraints mono_tvs1+             non_ip_candidates = filterOut isIPLikePred candidates+               -- implicit params don't really determine a type variable+               -- (that is, we might have IP "c" Bool and IP "c" Int in different+               -- places within the same program), and+               -- skipping this causes implicit params to monomorphise too many+               -- variables; see Note [Inheriting implicit parameters] in+               -- GHC.Tc.Solver. Skipping causes typecheck/should_compile/tc219+               -- to fail. +             mono_tvs2 = closeWrtFunDeps non_ip_candidates mono_tvs1+               -- mono_tvs2 now contains any variable determined by the "root+               -- set" of monomorphic tyvars in mono_tvs1.+              constrained_tvs = filterVarSet (isQuantifiableTv tc_lvl) $-                               (growThetaTyVars eq_constraints-                                               (tyCoVarsOfTypes no_quant)-                                `minusVarSet` mono_tvs2)-                               `delVarSetList` psig_qtvs+                               closeWrtFunDeps non_ip_candidates (tyCoVarsOfTypes no_quant)+                                `minusVarSet` mono_tvs2              -- constrained_tvs: the tyvars that we are not going to              -- quantify solely because of the monomorphism restriction              ---             -- (`minusVarSet` mono_tvs2`): a type variable is only+             -- (`minusVarSet` mono_tvs2): a type variable is only              --   "constrained" (so that the MR bites) if it is not-             --   free in the environment (#13785)-             --+             --   free in the environment (#13785) or is determined+             --   by some variable that is free in the env't++             mono_tvs = (mono_tvs2 `unionVarSet` constrained_tvs)+                          `delVarSetList` psig_qtvs              -- (`delVarSetList` psig_qtvs): if the user has explicitly              --   asked for quantification, then that request "wins"-             --   over the MR.  Note: do /not/ delete psig_qtvs from-             --   mono_tvs1, because mono_tvs1 cannot under any circumstances-             --   be quantified (#14479); see-             --   Note [Quantification and partial signatures], Wrinkle 3, 4--             mono_tvs = mono_tvs2 `unionVarSet` constrained_tvs+             --   over the MR.+             --+             -- What if a psig variable is also free in the environment+             -- (i.e. says "no" to isQuantifiableTv)? That's OK: explanation+             -- in Step 2 of Note [Deciding quantification].             -- Warn about the monomorphism restriction-       ; warn_mono <- woptM Opt_WarnMonomorphism-       ; when (case infer_mode of { ApplyMR -> warn_mono; _ -> False}) $-         warnTc (Reason Opt_WarnMonomorphism)-                (constrained_tvs `intersectsVarSet` tyCoVarsOfTypes taus)-                mr_msg+       ; when (case infer_mode of { ApplyMR -> True; _ -> False}) $ do+           let dia = TcRnMonomorphicBindings (map fst name_taus)+           diagnosticTc (constrained_tvs `intersectsVarSet` tyCoVarsOfTypes taus) dia         ; traceTc "decideMonoTyVars" $ vcat            [ text "infer_mode =" <+> ppr infer_mode            , text "mono_tvs0 =" <+> ppr mono_tvs0            , text "no_quant =" <+> ppr no_quant            , text "maybe_quant =" <+> ppr maybe_quant-           , text "eq_constraints =" <+> ppr eq_constraints            , text "mono_tvs =" <+> ppr mono_tvs            , text "co_vars =" <+> ppr co_vars ] @@ -1459,27 +1807,19 @@       | otherwise       = False -    pp_bndrs = pprWithCommas (quotes . ppr . fst) name_taus-    mr_msg =-         hang (sep [ text "The Monomorphism Restriction applies to the binding"-                     <> plural name_taus-                   , text "for" <+> pp_bndrs ])-            2 (hsep [ text "Consider giving"-                    , text (if isSingleton name_taus then "it" else "them")-                    , text "a type signature"])- ------------------- defaultTyVarsAndSimplify :: TcLevel-                         -> TyCoVarSet+                         -> TyCoVarSet          -- Promote these mono-tyvars                          -> [PredType]          -- Assumed zonked                          -> TcM [PredType]      -- Guaranteed zonked--- Default any tyvar free in the constraints,+-- Promote the known-monomorphic tyvars;+-- Default any tyvar free in the constraints; -- and re-simplify in case the defaulting allows further simplification defaultTyVarsAndSimplify rhs_tclvl mono_tvs candidates   = do {  -- Promote any tyvars that we cannot generalise           -- See Note [Promote monomorphic tyvars]        ; traceTc "decideMonoTyVars: promotion:" (ppr mono_tvs)-       ; any_promoted <- promoteTyVarSet mono_tvs+       ; _ <- promoteTyVarSet mono_tvs         -- Default any kind/levity vars        ; DV {dv_kvs = cand_kvs, dv_tvs = cand_tvs}@@ -1489,26 +1829,28 @@                 -- the constraints generated         ; poly_kinds  <- xoptM LangExt.PolyKinds-       ; default_kvs <- mapM (default_one poly_kinds True)-                             (dVarSetElems cand_kvs)-       ; default_tvs <- mapM (default_one poly_kinds False)-                             (dVarSetElems (cand_tvs `minusDVarSet` cand_kvs))-       ; let some_default = or default_kvs || or default_tvs+       ; mapM_ (default_one poly_kinds True) (dVarSetElems cand_kvs)+       ; mapM_ (default_one poly_kinds False) (dVarSetElems (cand_tvs `minusDVarSet` cand_kvs)) -       ; case () of-           _ | some_default -> simplify_cand candidates-             | any_promoted -> mapM TcM.zonkTcType candidates-             | otherwise    -> return candidates+       ; simplify_cand candidates        }   where     default_one poly_kinds is_kind_var tv       | not (isMetaTyVar tv)-      = return False+      = return ()       | tv `elemVarSet` mono_tvs-      = return False+      = return ()       | otherwise-      = defaultTyVar (not poly_kinds && is_kind_var) tv+      = void $ defaultTyVar+          (if not poly_kinds && is_kind_var+           then DefaultKindVars+           else NonStandardDefaulting DefaultNonStandardTyVars)+          -- NB: only pass 'DefaultKindVars' when we know we're dealing with a kind variable.+          tv +       -- this common case (no inferred contraints) should be fast+    simplify_cand [] = return []+       -- see Note [Unconditionally resimplify constraints when quantifying]     simplify_cand candidates       = do { clone_wanteds <- newWanteds DefaultOrigin candidates            ; WC { wc_simple = simples } <- setTcLevel rhs_tclvl $@@ -1523,12 +1865,13 @@  ------------------ decideQuantifiedTyVars-   :: [(Name,TcType)]   -- Annotated theta and (name,tau) pairs+   :: SkolemInfo+   -> [(Name,TcType)]   -- Annotated theta and (name,tau) pairs    -> [TcIdSigInst]     -- Partial signatures    -> [PredType]        -- Candidates, zonked    -> TcM [TyVar] -- Fix what tyvars we are going to quantify over, and quantify them-decideQuantifiedTyVars name_taus psigs candidates+decideQuantifiedTyVars skol_info name_taus psigs candidates   = do {     -- Why psig_tys? We try to quantify over everything free in here              -- See Note [Quantification and partial signatures]              --     Wrinkles 2 and 3@@ -1543,6 +1886,7 @@              seed_tys = psig_tys ++ tau_tys               -- Now "grow" those seeds to find ones reachable via 'candidates'+             -- See Note [growThetaTyVars vs closeWrtFunDeps]              grown_tcvs = growThetaTyVars candidates (tyCoVarsOfTypes seed_tys)         -- Now we have to classify them into kind variables and type variables@@ -1567,18 +1911,93 @@            , text "grown_tcvs =" <+> ppr grown_tcvs            , text "dvs =" <+> ppr dvs_plus]) -       ; quantifyTyVars dvs_plus }+       ; quantifyTyVars skol_info DefaultNonStandardTyVars dvs_plus }  ------------------+-- | When inferring types, should we quantify over a given predicate?+-- Generally true of classes; generally false of equality constraints.+-- Equality constraints that mention quantified type variables and+-- implicit variables complicate the story. See Notes+-- [Inheriting implicit parameters] and [Quantifying over equality constraints]+pickQuantifiablePreds+  :: TyVarSet           -- Quantifying over these+  -> TcThetaType        -- Proposed constraints to quantify+  -> TcThetaType        -- A subset that we can actually quantify+-- This function decides whether a particular constraint should be+-- quantified over, given the type variables that are being quantified+pickQuantifiablePreds qtvs theta+  = let flex_ctxt = True in  -- Quantify over non-tyvar constraints, even without+                             -- -XFlexibleContexts: see #10608, #10351+         -- flex_ctxt <- xoptM Opt_FlexibleContexts+    mapMaybe (pick_me flex_ctxt) theta+  where+    pick_me flex_ctxt pred+      = case classifyPredType pred of++          ClassPred cls tys+            | Just {} <- isCallStackPred cls tys+              -- NEVER infer a CallStack constraint.  Otherwise we let+              -- the constraints bubble up to be solved from the outer+              -- context, or be defaulted when we reach the top-level.+              -- See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence+            -> Nothing++            | isIPClass cls+            -> Just pred -- See Note [Inheriting implicit parameters]++            | pick_cls_pred flex_ctxt cls tys+            -> Just pred++          EqPred eq_rel ty1 ty2+            | quantify_equality eq_rel ty1 ty2+            , Just (cls, tys) <- boxEqPred eq_rel ty1 ty2+              -- boxEqPred: See Note [Lift equality constraints when quantifying]+            , pick_cls_pred flex_ctxt cls tys+            -> Just (mkClassPred cls tys)++          IrredPred ty+            | tyCoVarsOfType ty `intersectsVarSet` qtvs+            -> Just pred++          _ -> Nothing+++    pick_cls_pred flex_ctxt cls tys+      = tyCoVarsOfTypes tys `intersectsVarSet` qtvs+        && (checkValidClsArgs flex_ctxt cls tys)+           -- Only quantify over predicates that checkValidType+           -- will pass!  See #10351.+        && (no_fixed_dependencies cls tys)++    -- See Note [Do not quantify over constraints that determine a variable]+    no_fixed_dependencies cls tys+      = and [ qtvs `intersectsVarSet` tyCoVarsOfTypes fd_lhs_tys+            | fd <- cls_fds+            , let (fd_lhs_tys, _) = instFD fd cls_tvs tys ]+      where+        (cls_tvs, cls_fds) = classTvsFds cls++    -- See Note [Quantifying over equality constraints]+    quantify_equality NomEq  ty1 ty2 = quant_fun ty1 || quant_fun ty2+    quantify_equality ReprEq _   _   = True++    quant_fun ty+      = case tcSplitTyConApp_maybe ty of+          Just (tc, tys) | isTypeFamilyTyCon tc+                         -> tyCoVarsOfTypes tys `intersectsVarSet` qtvs+          _ -> False+++------------------ growThetaTyVars :: ThetaType -> TyCoVarSet -> TyCoVarSet--- See Note [Growing the tau-tvs using constraints]+-- See Note [growThetaTyVars vs closeWrtFunDeps] growThetaTyVars theta tcvs   | null theta = tcvs   | otherwise  = transCloVarSet mk_next seed_tcvs   where     seed_tcvs = tcvs `unionVarSet` tyCoVarsOfTypes ips     (ips, non_ips) = partition isIPLikePred theta-                         -- See Note [Inheriting implicit parameters] in GHC.Tc.Utils.TcType+                         -- See Note [Inheriting implicit parameters]      mk_next :: VarSet -> VarSet -- Maps current set to newly-grown ones     mk_next so_far = foldr (grow_one so_far) emptyVarSet non_ips@@ -1613,7 +2032,7 @@  * not forced to be monomorphic (mono_tvs),    for example by being free in the environment. -However, in the case of a partial type signature, be doing inference+However, in the case of a partial type signature, we are doing inference *in the presence of a type signature*. For example:    f :: _ -> a    f x = ...@@ -1627,7 +2046,7 @@      f :: _ -> Maybe a      f x = True && x   The inferred type of 'f' is f :: Bool -> Bool, but there's a-  left-over error of form (HoleCan (Maybe a ~ Bool)).  The error-reporting+  left-over error of form (Maybe a ~ Bool).  The error-reporting   machine expects to find a binding site for the skolem 'a', so we   add it to the quantified tyvars. @@ -1668,18 +2087,56 @@   refrain from bogusly quantifying, in GHC.Tc.Solver.decideMonoTyVars.  We   report the error later, in GHC.Tc.Gen.Bind.chooseInferredQuantifiers. -Note [Growing the tau-tvs using constraints]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-(growThetaTyVars insts tvs) is the result of extending the set-    of tyvars, tvs, using all conceivable links from pred+Note [growThetaTyVars vs closeWrtFunDeps]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+GHC has two functions, growThetaTyVars and closeWrtFunDeps, both with+the same type and similar behavior. This Note outlines the differences+and why we use one or the other. -E.g. tvs = {a}, preds = {H [a] b, K (b,Int) c, Eq e}-Then growThetaTyVars preds tvs = {a,b,c}+Both functions take a list of constraints. We will call these the+*candidates*. -Notice that-   growThetaTyVars is conservative       if v might be fixed by vs-                                         => v `elem` grow(vs,C)+closeWrtFunDeps takes a set of "determined" type variables and finds the+closure of that set with respect to the functional dependencies+within the class constraints in the set of candidates. So, if we+have +  class C a b | a -> b+  class D a b   -- no fundep+  candidates = {C (Maybe a) (Either b c), D (Maybe a) (Either d e)}++then closeWrtFunDeps {a} will return the set {a,b,c}.+This is because, if `a` is determined, then `b` and `c` are, too,+by functional dependency. closeWrtFunDeps called with any seed set not including+`a` will just return its argument, as only `a` determines any other+type variable (in this example).++growThetaTyVars operates similarly, but it behaves as if every+constraint has a functional dependency among all its arguments.+So, continuing our example, growThetaTyVars {a} will return+{a,b,c,d,e}. Put another way, growThetaTyVars grows the set of+variables to include all variables that are mentioned in the same+constraint (transitively).++We use closeWrtFunDeps in places where we need to know which variables are+*always* determined by some seed set. This includes+  * when determining the mono-tyvars in decideMonoTyVars. If `a`+    is going to be monomorphic, we need b and c to be also: they+    are determined by the choice for `a`.+  * when checking instance coverage, in+    GHC.Tc.Instance.FunDeps.checkInstCoverage++On the other hand, we use growThetaTyVars where we need to know+which variables *might* be determined by some seed set. This includes+  * deciding quantification (GHC.Tc.Gen.Bind.chooseInferredQuantifiers+    and decideQuantifiedTyVars+How can `a` determine (say) `d` in the example above without a fundep?+Suppose we have+  instance (b ~ a, c ~ a) => D (Maybe [a]) (Either b c)+Now, if `a` turns out to be a list, it really does determine b and c.+The danger in overdoing quantification is the creation of an ambiguous+type signature, but this is conveniently caught in the validity checker.+ Note [Quantification with errors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If we find that the RHS of the definition has some absolutely-insoluble@@ -1708,12 +2165,6 @@ the recovery from failM emits no code at all, so there is no function to run!   But -fdefer-type-errors aspires to produce a runnable program. -NB that we must include *derived* errors in the check for insolubles.-Example:-    (a::*) ~ Int#-We get an insoluble derived error *~#, and we don't want to discard-it before doing the isInsolubleWC test!  (#8262)- Note [Default while Inferring] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Our current plan is that defaulting only happens at simplifyTop and@@ -1795,27 +2246,16 @@ simplifyWantedsTcM :: [CtEvidence] -> TcM WantedConstraints -- Solve the specified Wanted constraints -- Discard the evidence binds--- Discards all Derived stuff in result -- Postcondition: fully zonked simplifyWantedsTcM wanted   = do { traceTc "simplifyWantedsTcM {" (ppr wanted)-       ; (result, _) <- runTcS (solveWantedsAndDrop (mkSimpleWC wanted))+       ; (result, _) <- runTcS (solveWanteds (mkSimpleWC wanted))        ; result <- TcM.zonkWC result        ; traceTc "simplifyWantedsTcM }" (ppr result)        ; return result } -solveWantedsAndDrop :: WantedConstraints -> TcS WantedConstraints--- Since solveWanteds returns the residual WantedConstraints,--- it should always be called within a runTcS or something similar,--- Result is not zonked-solveWantedsAndDrop wanted-  = do { wc <- solveWanteds wanted-       ; return (dropDerivedWC wc) }- solveWanteds :: WantedConstraints -> TcS WantedConstraints--- so that the inert set doesn't mindlessly propagate.--- NB: wc_simples may be wanted /or/ derived now-solveWanteds wc@(WC { wc_holes = holes })+solveWanteds wc@(WC { wc_errors = errs })   = do { cur_lvl <- TcS.getTcLevel        ; traceTcS "solveWanteds {" $          vcat [ text "Level =" <+> ppr cur_lvl@@ -1824,8 +2264,8 @@        ; dflags <- getDynFlags        ; solved_wc <- simplify_loop 0 (solverIterations dflags) True wc -       ; holes' <- simplifyHoles holes-       ; let final_wc = solved_wc { wc_holes = holes' }+       ; errs' <- simplifyDelayedErrors errs+       ; let final_wc = solved_wc { wc_errors = errs' }         ; ev_binds_var <- getTcEvBindsVar        ; bb <- TcS.getTcEvBindsMap ev_binds_var@@ -1839,7 +2279,7 @@               -> WantedConstraints -> TcS WantedConstraints -- Do a round of solving, and call maybe_simplify_again to iterate -- The 'definitely_redo_implications' flags is False if the only reason we--- are iterating is that we have added some new Derived superclasses (from Wanteds)+-- are iterating is that we have added some new Wanted superclasses -- hoping for fundeps to help us; see Note [Superclass iteration] -- -- Does not affect wc_holes at all; reason: wc_holes never affects anything@@ -1855,7 +2295,7 @@        ; (unifs1, wc1) <- reportUnifications $  -- See Note [Superclass iteration]                           solveSimpleWanteds simples                 -- Any insoluble constraints are in 'simples' and so get rewritten-                -- See Note [Rewrite insolubles] in GHC.Tc.Solver.Monad+                -- See Note [Rewrite insolubles] in GHC.Tc.Solver.InertSet         ; wc2 <- if not definitely_redo_implications  -- See Note [Superclass iteration]                    && unifs1 == 0                    -- for this conditional@@ -1867,6 +2307,7 @@                                      , wc_impl = implics2 }) }         ; unif_happened <- resetUnificationFlag+       ; csTraceTcS $ text "unif_happened" <+> ppr unif_happened          -- Note [The Unification Level Flag] in GHC.Tc.Solver.Monad        ; maybe_simplify_again (n+1) limit unif_happened wc2 } @@ -1878,11 +2319,7 @@          -- Typically if we blow the limit we are going to report some other error          -- (an unsolved constraint), and we don't want that error to suppress          -- the iteration limit warning!-         addErrTcS (hang (text "solveWanteds: too many iterations"-                   <+> parens (text "limit =" <+> ppr limit))-                2 (vcat [ text "Unsolved:" <+> ppr wc-                        , text "Set limit with -fconstraint-solver-iterations=n; n=0 for no limit"-                  ]))+         addErrTcS $ TcRnSimplifierTooManyIterations simples limit wc        ; return wc }    | unif_happened@@ -1915,15 +2352,15 @@ where   class D a b | a -> b   class D a b => C a b-We will expand d's superclasses, giving [D] D Int beta, in the hope of geting+We will expand d's superclasses, giving [W] D Int beta, in the hope of geting fundeps to unify beta.  Doing so is usually fruitless (no useful fundeps), and if so it seems a pity to waste time iterating the implications (forall b. blah) (If we add new Given superclasses it's a different matter: it's really worth looking at the implications.)  Hence the definitely_redo_implications flag to simplify_loop.  It's usually-True, but False in the case where the only reason to iterate is new Derived-superclasses.  In that case we check whether the new Deriveds actually led to+True, but False in the case where the only reason to iterate is new Wanted+superclasses.  In that case we check whether the new Wanteds actually led to any new unifications, and iterate the implications only if so. -} @@ -1977,9 +2414,6 @@                   ; solveSimpleGivens givens                    ; residual_wanted <- solveWanteds wanteds-                        -- solveWanteds, *not* solveWantedsAndDrop, because-                        -- we want to retain derived equalities so we can float-                        -- them out in floatEqualities.                    ; (has_eqs, given_insols) <- getHasGivenEqs tclvl                         -- Call getHasGivenEqs /after/ solveWanteds, because@@ -2015,21 +2449,21 @@     -- remaining commented out for now.     {-     check_tc_level = do { cur_lvl <- TcS.getTcLevel-                        ; MASSERT2( tclvl == pushTcLevel cur_lvl , text "Cur lvl =" <+> ppr cur_lvl $$ text "Imp lvl =" <+> ppr tclvl ) }+                        ; massertPpr (tclvl == pushTcLevel cur_lvl)+                                     (text "Cur lvl =" <+> ppr cur_lvl $$ text "Imp lvl =" <+> ppr tclvl) }     -}  ---------------------- setImplicationStatus :: Implication -> TcS (Maybe Implication)--- Finalise the implication returned from solveImplication:---    * Set the ic_status field---    * Trim the ic_wanted field to remove Derived constraints+-- Finalise the implication returned from solveImplication,+-- setting the ic_status field -- Precondition: the ic_status field is not already IC_Solved -- Return Nothing if we can discard the implication altogether setImplicationStatus implic@(Implic { ic_status     = status                                     , ic_info       = info                                     , ic_wanted     = wc                                     , ic_given      = givens })- | ASSERT2( not (isSolvedStatus status ), ppr info )+ | assertPpr (not (isSolvedStatus status)) (ppr info) $    -- Precondition: we only set the status if it is not already solved    not (isSolvedWC pruned_wc)  = do { traceTcS "setImplicationStatus(not-all-solved) {" (ppr implic)@@ -2089,13 +2523,12 @@                  then Nothing                  else Just final_implic }  where-   WC { wc_simple = simples, wc_impl = implics, wc_holes = holes } = wc+   WC { wc_simple = simples, wc_impl = implics, wc_errors = errs } = wc -   pruned_simples = dropDerivedSimples simples    pruned_implics = filterBag keep_me implics-   pruned_wc = WC { wc_simple = pruned_simples+   pruned_wc = WC { wc_simple = simples                   , wc_impl   = pruned_implics-                  , wc_holes  = holes }   -- do not prune holes; these should be reported+                  , wc_errors = errs }   -- do not prune holes; these should be reported     keep_me :: Implication -> Bool    keep_me ic@@ -2131,12 +2564,12 @@       | otherwise       = go (later_skols `extendVarSet` one_skol) earlier_skols -warnRedundantGivens :: SkolemInfo -> Bool+warnRedundantGivens :: SkolemInfoAnon -> Bool warnRedundantGivens (SigSkol ctxt _ _)   = case ctxt of-       FunSigCtxt _ warn_redundant -> warn_redundant-       ExprSigCtxt                 -> True-       _                           -> False+       FunSigCtxt _ rrc -> reportRedundantConstraints rrc+       ExprSigCtxt rrc  -> reportRedundantConstraints rrc+       _                -> False    -- To think about: do we want to report redundant givens for   -- pattern synonyms, PatSynSigSkol? c.f #9953, comment:21.@@ -2209,9 +2642,13 @@      | otherwise = evVarsOfTerm rhs `unionVarSet` needs  --------------------------------------------------simplifyHoles :: Bag Hole -> TcS (Bag Hole)-simplifyHoles = mapBagM simpl_hole+simplifyDelayedErrors :: Bag DelayedError -> TcS (Bag DelayedError)+simplifyDelayedErrors = mapBagM simpl_err   where+    simpl_err :: DelayedError -> TcS DelayedError+    simpl_err (DE_Hole hole) = DE_Hole <$> simpl_hole hole+    simpl_err err@(DE_NotConcrete {}) = return err+     simpl_hole :: Hole -> TcS Hole       -- See Note [Do not simplify ConstraintHoles]@@ -2443,18 +2880,20 @@ -- | Like 'defaultTyVar', but in the TcS monad. defaultTyVarTcS :: TcTyVar -> TcS Bool defaultTyVarTcS the_tv-  | isRuntimeRepVar the_tv-  , not (isTyVarTyVar the_tv)+  | isTyVarTyVar the_tv     -- TyVarTvs should only be unified with a tyvar     -- never with a type; c.f. GHC.Tc.Utils.TcMType.defaultTyVar     -- and Note [Inferring kinds for type declarations] in GHC.Tc.TyCl+  = return False+  | isRuntimeRepVar the_tv   = do { traceTcS "defaultTyVarTcS RuntimeRep" (ppr the_tv)        ; unifyTyVar the_tv liftedRepTy        ; return True }+  | isLevityVar the_tv+  = do { traceTcS "defaultTyVarTcS Levity" (ppr the_tv)+       ; unifyTyVar the_tv liftedDataConTy+       ; return True }   | isMultiplicityVar the_tv-  , not (isTyVarTyVar the_tv)  -- TyVarTvs should only be unified with a tyvar-                             -- never with a type; c.f. TcMType.defaultTyVar-                             -- See Note [Kind generalisation and SigTvs]   = do { traceTcS "defaultTyVarTcS Multiplicity" (ppr the_tv)        ; unifyTyVar the_tv manyDataConTy        ; return True }@@ -2462,7 +2901,9 @@   = return False  -- the common case  approximateWC :: Bool -> WantedConstraints -> Cts--- Postcondition: Wanted or Derived Cts+-- Second return value is the depleted wc+-- Third return value is YesFDsCombined <=> multiple constraints for the same fundep floated+-- Postcondition: Wanted Cts -- See Note [ApproximateWC] -- See Note [floatKindEqualities vs approximateWC] approximateWC float_past_equalities wc@@ -2545,7 +2986,6 @@ contamination stuff.  There was zero effect on the testsuite (not even #8155). ------ End of historical note ----------- - Note [DefaultTyVar] ~~~~~~~~~~~~~~~~~~~ defaultTyVar is used on any un-instantiated meta type variables to@@ -2564,7 +3004,7 @@ hand.  However we aren't ready to default them fully to () or whatever, because the type-class defaulting rules have yet to run. -An alternate implementation would be to emit a derived constraint setting+An alternate implementation would be to emit a Wanted constraint setting the RuntimeRep variable to LiftedRep, but this seems unnecessarily indirect.  Note [Promote _and_ default when inferring]@@ -2645,6 +3085,17 @@   = do { info@(default_tys, _) <- getDefaultInfo        ; wanteds               <- TcS.zonkWC wanteds +       ; tcg_env <- TcS.getGblEnv+       ; let plugins = tcg_defaulting_plugins tcg_env++       ; plugin_defaulted <- if null plugins then return [] else+           do {+             ; traceTcS "defaultingPlugins {" (ppr wanteds)+             ; defaultedGroups <- mapM (run_defaulting_plugin wanteds) plugins+             ; traceTcS "defaultingPlugins }" (ppr defaultedGroups)+             ; return defaultedGroups+             }+        ; let groups = findDefaultableGroups info wanteds         ; traceTcS "applyDefaultingRules {" $@@ -2656,12 +3107,25 @@         ; traceTcS "applyDefaultingRules }" (ppr something_happeneds) -       ; return (or something_happeneds) }+       ; return $ or something_happeneds || or plugin_defaulted }+    where run_defaulting_plugin wanteds p =+            do { groups <- runTcPluginTcS (p wanteds)+               ; defaultedGroups <-+                    filterM (\g -> disambigGroup+                                   (deProposalCandidates g)+                                   (deProposalTyVar g, deProposalCts g))+                    groups+               ; traceTcS "defaultingPlugin " $ ppr defaultedGroups+               ; case defaultedGroups of+                 [] -> return False+                 _  -> return True+               } + findDefaultableGroups     :: ( [Type]        , (Bool,Bool) )     -- (Overloaded strings, extended default rules)-    -> WantedConstraints   -- Unsolved (wanted or derived)+    -> WantedConstraints   -- Unsolved     -> [(TyVar, [Ct])] findDefaultableGroups (default_tys, (ovl_strings, extended_defaults)) wanteds   | null default_tys@@ -2712,14 +3176,13 @@         | otherwise         = all is_std_class clss && (any (isNumClass ovl_strings) clss)      -- is_std_class adds IsString to the standard numeric classes,-    -- when -foverloaded-strings is enabled+    -- when -XOverloadedStrings is enabled     is_std_class cls = isStandardClass cls ||                        (ovl_strings && (cls `hasKey` isStringClassKey))  ------------------------------ disambigGroup :: [Type]            -- The default types-              -> (TcTyVar, [Ct])   -- All classes of the form (C a)-                                   --  sharing same type variable+              -> (TcTyVar, [Ct])   -- All constraints sharing same type variable               -> TcS Bool   -- True <=> something happened, reflected in ty_binds  disambigGroup [] _@@ -2733,7 +3196,7 @@        ; if success then              -- Success: record the type variable binding, and return              do { unifyTyVar the_tv default_ty-                ; wrapWarnTcS $ warnDefaulting wanteds default_ty+                ; wrapWarnTcS $ warnDefaulting the_tv wanteds default_ty                 ; traceTcS "disambigGroup succeeded }" (ppr default_ty)                 ; return True }          else@@ -2746,9 +3209,14 @@       | Just subst <- mb_subst       = do { lcl_env <- TcS.getLclEnv            ; tc_lvl <- TcS.getTcLevel-           ; let loc = mkGivenLoc tc_lvl UnkSkol lcl_env-           ; wanted_evs <- mapM (newWantedEvVarNC loc . substTy subst . ctPred)-                                wanteds+           ; let loc = mkGivenLoc tc_lvl (getSkolemInfo unkSkol) lcl_env+           -- Equality constraints are possible due to type defaulting plugins+           ; wanted_evs <- sequence [ newWantedNC loc rewriters pred'+                                    | wanted <- wanteds+                                    , CtWanted { ctev_pred = pred+                                               , ctev_rewriters = rewriters }+                                        <- return (ctEvidence wanted)+                                    , let pred' = substTy subst pred ]            ; fmap isEmptyWC $              solveSimpleWanteds $ listToBag $              map mkNonCanonical wanted_evs }@@ -2764,14 +3232,14 @@       -- ill-kinded defaulting attempts like (Eq []) or (Foldable Int) here.  -- In interactive mode, or with -XExtendedDefaultRules,--- we default Show a to Show () to avoid graututious errors on "show []"+-- we default Show a to Show () to avoid gratuitous errors on "show []" isInteractiveClass :: Bool   -- -XOverloadedStrings?                    -> Class -> Bool isInteractiveClass ovl_strings cls     = isNumClass ovl_strings cls || (classKey cls `elem` interactiveClassKeys)      -- isNumClass adds IsString to the standard numeric classes,-    -- when -foverloaded-strings is enabled+    -- when -XOverloadedStrings is enabled isNumClass :: Bool   -- -XOverloadedStrings?            -> Class -> Bool isNumClass ovl_strings cls
GHC/Tc/Solver/Canonical.hs view
@@ -4,14 +4,12 @@  module GHC.Tc.Solver.Canonical(      canonicalize,-     unifyDerived,+     unifyWanted,      makeSuperClasses,      StopOrContinue(..), stopWith, continueWith, andWhenContinue,      solveCallStack    -- For GHC.Tc.Solver   ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Tc.Types.Constraint@@ -22,14 +20,17 @@ import GHC.Core.Type import GHC.Tc.Solver.Rewrite import GHC.Tc.Solver.Monad+import GHC.Tc.Solver.InertSet import GHC.Tc.Types.Evidence import GHC.Tc.Types.EvTerm import GHC.Core.Class+import GHC.Core.DataCon ( dataConName ) import GHC.Core.TyCon import GHC.Core.Multiplicity import GHC.Core.TyCo.Rep   -- cleverly decomposes types, good for completeness checking import GHC.Core.Coercion import GHC.Core.Coercion.Axiom+import GHC.Core.Reduction import GHC.Core import GHC.Types.Id( mkTemplateLocals ) import GHC.Core.FamInstEnv ( FamInstEnvs )@@ -39,10 +40,13 @@ import GHC.Types.Var.Set( delVarSetList, anyVarSet ) import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Builtin.Types ( anyTypeOfKind ) import GHC.Types.Name.Set import GHC.Types.Name.Reader import GHC.Hs.Type( HsIPName(..) )+import GHC.Types.Unique  ( hasKey )+import GHC.Builtin.Names ( coercibleTyConKey )  import GHC.Data.Pair import GHC.Utils.Misc@@ -53,6 +57,7 @@ import Data.List  ( zip4 ) import GHC.Types.Basic +import qualified Data.Semigroup as S import Data.Bifunctor ( bimap ) import Data.Foldable ( traverse_ ) @@ -107,9 +112,10 @@     --    e.g. a ~ [a], where [G] a ~ [Int], can decompose  canonicalize (CDictCan { cc_ev = ev, cc_class  = cls-                       , cc_tyargs = xis, cc_pend_sc = pend_sc })+                       , cc_tyargs = xis, cc_pend_sc = pend_sc+                       , cc_fundeps = fds })   = {-# SCC "canClass" #-}-    canClass ev cls xis pend_sc+    canClass ev cls xis pend_sc fds  canonicalize (CEqCan { cc_ev     = ev                      , cc_lhs    = lhs@@ -129,6 +135,7 @@                                   canIrred ev       ForAllPred tvs th p   -> do traceTcS "canEvNC:forall" (ppr pred)                                   canForAllNC ev tvs th p+   where     pred = ctEvPred ev @@ -148,39 +155,46 @@   | isGiven ev  -- See Note [Eagerly expand given superclasses]   = do { sc_cts <- mkStrictSuperClasses ev [] [] cls tys        ; emitWork sc_cts-       ; canClass ev cls tys False }+       ; canClass ev cls tys False fds } -  | isWanted ev+  | CtWanted { ctev_rewriters = rewriters } <- ev   , Just ip_name <- isCallStackPred cls tys-  , OccurrenceOf func <- ctLocOrigin loc+  , isPushCallStackOrigin orig   -- If we're given a CallStack constraint that arose from a function   -- call, we need to push the current call-site onto the stack instead   -- of solving it directly from a given.   -- See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence-  -- and Note [Solving CallStack constraints] in GHC.Tc.Solver.Monad+  -- and Note [Solving CallStack constraints] in GHC.Tc.Solver.Types   = do { -- First we emit a new constraint that will capture the          -- given CallStack.        ; let new_loc = setCtLocOrigin loc (IPOccOrigin (HsIPName ip_name))                             -- We change the origin to IPOccOrigin so                             -- this rule does not fire again.                             -- See Note [Overview of implicit CallStacks]+                            -- in GHC.Tc.Types.Evidence -       ; new_ev <- newWantedEvVarNC new_loc pred+       ; new_ev <- newWantedEvVarNC new_loc rewriters pred           -- Then we solve the wanted by pushing the call-site          -- onto the newly emitted CallStack-       ; let ev_cs = EvCsPushCall func (ctLocSpan loc) (ctEvExpr new_ev)+       ; let ev_cs = EvCsPushCall (callStackOriginFS orig)+                                  (ctLocSpan loc) (ctEvExpr new_ev)        ; solveCallStack ev ev_cs -       ; canClass new_ev cls tys False }+       ; canClass new_ev cls tys+                  False -- No superclasses+                  False -- No top level instances for fundeps+       }    | otherwise-  = canClass ev cls tys (has_scs cls)+  = canClass ev cls tys (has_scs cls) fds    where     has_scs cls = not (null (classSCTheta cls))     loc  = ctEvLoc ev+    orig = ctLocOrigin loc     pred = ctEvPred ev+    fds  = classHasFds cls  solveCallStack :: CtEvidence -> EvCallStack -> TcS () -- Also called from GHC.Tc.Solver when defaulting call stacks@@ -195,20 +209,21 @@ canClass :: CtEvidence          -> Class -> [Type]          -> Bool            -- True <=> un-explored superclasses+         -> Bool            -- True <=> unexploited fundep(s)          -> TcS (StopOrContinue Ct) -- Precondition: EvVar is class evidence -canClass ev cls tys pend_sc-  =   -- all classes do *nominal* matching-    ASSERT2( ctEvRole ev == Nominal, ppr ev $$ ppr cls $$ ppr tys )-    do { (xis, cos) <- rewriteArgsNom ev cls_tc tys-       ; let co = mkTcTyConAppCo Nominal cls_tc cos-             xi = mkClassPred cls xis+canClass ev cls tys pend_sc fds+  = -- all classes do *nominal* matching+    assertPpr (ctEvRole ev == Nominal) (ppr ev $$ ppr cls $$ ppr tys) $+    do { (redns@(Reductions _ xis), rewriters) <- rewriteArgsNom ev cls_tc tys+       ; let redn@(Reduction _ xi) = mkClassPredRedn cls redns              mk_ct new_ev = CDictCan { cc_ev = new_ev                                      , cc_tyargs = xis                                      , cc_class = cls-                                     , cc_pend_sc = pend_sc }-       ; mb <- rewriteEvidence ev xi co+                                     , cc_pend_sc = pend_sc+                                     , cc_fundeps = fds }+       ; mb <- rewriteEvidence rewriters ev redn        ; traceTcS "canClass" (vcat [ ppr ev                                    , ppr xi, ppr mb ])        ; return (fmap mk_ct mb) }@@ -225,15 +240,14 @@   We get a Wanted (Eq a), which can only be solved from the superclass   of the Given (Ord a). -* For wanteds [W], and deriveds [WD], [D], they may give useful+* For wanteds [W], they may give useful   functional dependencies.  E.g.      class C a b | a -> b where ...      class C a b => D a b where ...   Now a [W] constraint (D Int beta) has (C Int beta) as a superclass   and that might tell us about beta, via C's fundeps.  We can get this-  by generating a [D] (C Int beta) constraint.  It's derived because-  we don't actually have to cough up any evidence for it; it's only there-  to generate fundep equalities.+  by generating a [W] (C Int beta) constraint. We won't use the evidence,+  but it may lead to unification.  See Note [Why adding superclasses can help]. @@ -283,7 +297,7 @@    GHC.Tc.Solver.simpl_loop and solveWanteds.     This may succeed in generating (a finite number of) extra Givens,-   and extra Deriveds. Both may help the proof.+   and extra Wanteds. Both may help the proof.  3a An important wrinkle: only expand Givens from the current level.    Two reasons:@@ -377,7 +391,7 @@     Suppose we want to solve          [G] C a b          [W] C a beta-    Then adding [D] beta~b will let us solve it.+    Then adding [W] beta~b will let us solve it.      -- Example 2 (similar but using a type-equality superclass)         class (F a ~ b) => C a b@@ -386,8 +400,8 @@          [W] C a beta     Follow the superclass rules to add          [G] F a ~ b-         [D] F a ~ beta-    Now we get [D] beta ~ b, and can solve that.+         [W] F a ~ beta+    Now we get [W] beta ~ b, and can solve that.      -- Example (tcfail138)       class L a b | a -> b@@ -402,9 +416,9 @@       [W] G (Maybe a)     Use the instance decl to get       [W] C a beta-    Generate its derived superclass-      [D] L a beta.  Now using fundeps, combine with [G] L a b to get-      [D] beta ~ b+    Generate its superclass+      [W] L a beta.  Now using fundeps, combine with [G] L a b to get+      [W] beta ~ b     which is what we want.  Note [Danger of adding superclasses during solving]@@ -421,8 +435,8 @@ If we were to be adding the superclasses during simplification we'd get:    [W] RealOf e ~ e    [W] Normed e-   [D] RealOf e ~ fuv-   [D] Num fuv+   [W] RealOf e ~ fuv+   [W] Num fuv ==>    e := fuv, Num fuv, Normed fuv, RealOf fuv ~ fuv @@ -431,9 +445,6 @@ definitely only once, during canonicalisation, this situation can't happen. -Mind you, now that Wanteds cannot rewrite Derived, I think this particular-situation can't happen.- Note [Nested quantified constraint superclasses] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider (typecheck/should_compile/T17202)@@ -476,7 +487,7 @@   -}  makeSuperClasses :: [Ct] -> TcS [Ct]--- Returns strict superclasses, transitively, see Note [The superclasses story]+-- Returns strict superclasses, transitively, see Note [The superclass story] -- See Note [The superclass story] -- The loop-breaking here follows Note [Expanding superclasses] in GHC.Tc.Utils.TcType -- Specifically, for an incoming (C t) constraint, we return all of (C t)'s@@ -494,8 +505,8 @@     go (CDictCan { cc_ev = ev, cc_class = cls, cc_tyargs = tys })       = mkStrictSuperClasses ev [] [] cls tys     go (CQuantCan (QCI { qci_pred = pred, qci_ev = ev }))-      = ASSERT2( isClassPred pred, ppr pred )  -- The cts should all have-                                               -- class pred heads+      = assertPpr (isClassPred pred) (ppr pred) $  -- The cts should all have+                                                   -- class pred heads         mkStrictSuperClasses ev tvs theta cls tys       where         (tvs, theta, cls, tys) = tcSplitDFunTy (ctEvPred ev)@@ -520,19 +531,21 @@ -- nor are repeated mk_strict_superclasses rec_clss (CtGiven { ctev_evar = evar, ctev_loc = loc })                        tvs theta cls tys-  = concatMapM (do_one_given (mk_given_loc loc)) $+  = concatMapM do_one_given $     classSCSelIds cls   where     dict_ids  = mkTemplateLocals theta     size      = sizeTypes tys -    do_one_given given_loc sel_id+    do_one_given sel_id       | isUnliftedType sc_pred+         -- NB: class superclasses are never representation-polymorphic,+         -- so isUnliftedType is OK here.       , not (null tvs && null theta)       = -- See Note [Equality superclasses in quantified constraints]         return []       | otherwise-      = do { given_ev <- newGivenEvVar given_loc $+      = do { given_ev <- newGivenEvVar sc_loc $                          mk_given_desc sel_id sc_pred            ; mk_superclasses rec_clss given_ev tvs theta sc_pred }       where@@ -562,13 +575,20 @@             `App` (evId evar `mkVarApps` (tvs ++ dict_ids))             `mkVarApps` sc_tvs -    mk_given_loc loc+    sc_loc        | isCTupleClass cls        = loc   -- For tuple predicates, just take them apart, without                -- adding their (large) size into the chain.  When we                -- get down to a base predicate, we'll include its size.                -- #10335 +       |  isEqPredClass cls+       || cls `hasKey` coercibleTyConKey+       = loc   -- The only superclasses of ~, ~~, and Coercible are primitive+               -- equalities, and they don't use the InstSCOrigin mechanism+               -- detailed in Note [Solving superclass constraints] in+               -- GHC.Tc.TyCl.Instance. Skip for a tiny performance win.+          -- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance          -- for explantation of InstSCOrigin and Note [Replacement vs keeping] in          -- GHC.Tc.Solver.Interact for why we need OtherSCOrigin and depths@@ -589,18 +609,19 @@  mk_strict_superclasses rec_clss ev tvs theta cls tys   | all noFreeVarsOfType tys-  = return [] -- Wanteds with no variables yield no deriveds.+  = return [] -- Wanteds with no variables yield no superclass constraints.               -- See Note [Improvement from Ground Wanteds] -  | otherwise -- Wanted/Derived case, just add Derived superclasses+  | otherwise -- Wanted case, just add Wanted superclasses               -- that can lead to improvement.-  = ASSERT2( null tvs && null theta, ppr tvs $$ ppr theta )-    concatMapM do_one_derived (immSuperClasses cls tys)+  = assertPpr (null tvs && null theta) (ppr tvs $$ ppr theta) $+    concatMapM do_one (immSuperClasses cls tys)   where-    loc = ctEvLoc ev+    loc = ctEvLoc ev `updateCtLocOrigin` WantedSuperclassOrigin (ctEvPred ev) -    do_one_derived sc_pred-      = do { sc_ev <- newDerivedNC loc sc_pred+    do_one sc_pred+      = do { traceTcS "mk_strict_superclasses Wanted" (ppr (mkClassPred cls tys) $$ ppr sc_pred)+           ; sc_ev <- newWantedNC loc (ctEvRewriters ev) sc_pred            ; mk_superclasses rec_clss sc_ev [] [] sc_pred }  {- Note [Improvement from Ground Wanteds]@@ -608,8 +629,8 @@ Suppose class C b a => D a b and consider   [W] D Int Bool-Is there any point in emitting [D] C Bool Int?  No!  The only point of-emitting superclass constraints for W/D constraints is to get+Is there any point in emitting [W] C Bool Int?  No!  The only point of+emitting superclass constraints for W constraints is to get improvement, extra unifications that result from functional dependencies.  See Note [Why adding superclasses can help] above. @@ -649,7 +670,7 @@      this_ct | null tvs, null theta             = CDictCan { cc_ev = ev, cc_class = cls, cc_tyargs = tys-                       , cc_pend_sc = loop_found }+                       , cc_pend_sc = loop_found, cc_fundeps = classHasFds cls }                  -- NB: If there is a loop, we cut off, so we have not                  --     added the superclasses, hence cc_pend_sc = True             | otherwise@@ -707,15 +728,18 @@ canIrred ev   = do { let pred = ctEvPred ev        ; traceTcS "can_pred" (text "IrredPred = " <+> ppr pred)-       ; (xi,co) <- rewrite ev pred -- co :: xi ~ pred-       ; rewriteEvidence ev xi co `andWhenContinue` \ new_ev ->+       ; (redn, rewriters) <- rewrite ev pred+       ; rewriteEvidence rewriters ev redn `andWhenContinue` \ new_ev ->      do { -- Re-classify, in case rewriting has improved its shape          -- Code is like the canNC, except          -- that the IrredPred branch stops work        ; case classifyPredType (ctEvPred new_ev) of            ClassPred cls tys     -> canClassNC new_ev cls tys-           EqPred eq_rel ty1 ty2 -> canEqNC new_ev eq_rel ty1 ty2+           EqPred eq_rel ty1 ty2 -> -- IrredPreds have kind Constraint, so+                                    -- cannot become EqPreds+                                    pprPanic "canIrred: EqPred"+                                      (ppr ev $$ ppr eq_rel $$ ppr ty1 $$ ppr ty2)            ForAllPred tvs th p   -> -- this is highly suspect; Quick Look                                     -- should never leave a meta-var filled                                     -- in with a polytype. This is #18987.@@ -822,8 +846,8 @@ canForAll ev pend_sc   = do { -- First rewrite it to apply the current substitution          let pred = ctEvPred ev-       ; (xi,co) <- rewrite ev pred -- co :: xi ~ pred-       ; rewriteEvidence ev xi co `andWhenContinue` \ new_ev ->+       ; (redn, rewriters) <- rewrite ev pred+       ; rewriteEvidence rewriters ev redn `andWhenContinue` \ new_ev ->      do { -- Now decompose into its pieces and solve it          -- (It takes a lot less code to rewrite before decomposing.)@@ -835,23 +859,27 @@  solveForAll :: CtEvidence -> [TyVar] -> TcThetaType -> PredType -> Bool             -> TcS (StopOrContinue Ct)-solveForAll ev tvs theta pred pend_sc-  | CtWanted { ctev_dest = dest } <- ev+solveForAll ev@(CtWanted { ctev_dest = dest, ctev_rewriters = rewriters, ctev_loc = loc })+            tvs theta pred _pend_sc   = -- See Note [Solving a Wanted forall-constraint]-    do { let skol_info = QuantCtxtSkol-             empty_subst = mkEmptyTCvSubst $ mkInScopeSet $+    setLclEnv (ctLocEnv loc) $+    -- This setLclEnv is important: the emitImplicationTcS uses that+    -- TcLclEnv for the implication, and that in turn sets the location+    -- for the Givens when solving the constraint (#21006)+    do { skol_info <- mkSkolemInfo QuantCtxtSkol+       ; let empty_subst = mkEmptyTCvSubst $ mkInScopeSet $                            tyCoVarsOfTypes (pred:theta) `delVarSetList` tvs-       ; (subst, skol_tvs) <- tcInstSkolTyVarsX empty_subst tvs+       ; (subst, skol_tvs) <- tcInstSkolTyVarsX skol_info empty_subst tvs        ; given_ev_vars <- mapM newEvVar (substTheta subst theta)         ; (lvl, (w_id, wanteds))              <- pushLevelNoWorkList (ppr skol_info) $-                do { wanted_ev <- newWantedEvVarNC loc $+                do { wanted_ev <- newWantedEvVarNC loc rewriters $                                   substTy subst pred                    ; return ( ctEvEvId wanted_ev                             , unitBag (mkNonCanonical wanted_ev)) } -      ; ev_binds <- emitImplicationTcS lvl skol_info skol_tvs+      ; ev_binds <- emitImplicationTcS lvl (getSkolemInfo skol_info) skol_tvs                                        given_ev_vars wanteds        ; setWantedEvTerm dest $@@ -860,15 +888,11 @@        ; stopWith ev "Wanted forall-constraint" } -  | isGiven ev   -- See Note [Solving a Given forall-constraint]+ -- See Note [Solving a Given forall-constraint]+solveForAll ev@(CtGiven {}) tvs _theta pred pend_sc   = do { addInertForAll qci        ; stopWith ev "Given forall-constraint" }--  | otherwise-  = do { traceTcS "discarding derived forall-constraint" (ppr ev)-       ; stopWith ev "Derived forall-constraint" }   where-    loc = ctEvLoc ev     qci = QCI { qci_ev = ev, qci_tvs = tvs               , qci_pred = pred, qci_pend_sc = pend_sc } @@ -891,7 +915,6 @@ via addInertForall.  Then, if we look up (C x Int Bool), say, we'll find a match in the InstEnv. - ************************************************************************ *                                                                      * *        Equalities@@ -989,7 +1012,7 @@    | ReprEq <- eq_rel   , Just stuff2 <- tcTopNormaliseNewTypeTF_maybe envs rdr_env ty2-  = can_eq_newtype_nc ev IsSwapped  ty2 stuff2 ty1 ps_ty1+  = can_eq_newtype_nc ev IsSwapped ty2 stuff2 ty1 ps_ty1  -- Then, get rid of casts can_eq_nc' rewritten _rdr_env _envs ev eq_rel (CastTy ty1 co1) _ ty2 ps_ty2@@ -1055,9 +1078,9 @@  -- No similarity in type structure detected. Rewrite and try again. can_eq_nc' False rdr_env envs ev eq_rel _ ps_ty1 _ ps_ty2-  = do { (xi1, co1) <- rewrite ev ps_ty1-       ; (xi2, co2) <- rewrite ev ps_ty2-       ; new_ev <- rewriteEqEvidence ev NotSwapped xi1 xi2 co1 co2+  = do { (redn1@(Reduction _ xi1), rewriters1) <- rewrite ev ps_ty1+       ; (redn2@(Reduction _ xi2), rewriters2) <- rewrite ev ps_ty2+       ; new_ev <- rewriteEqEvidence (rewriters1 S.<> rewriters2) ev NotSwapped redn1 redn2        ; can_eq_nc' True rdr_env envs new_ev eq_rel xi1 xi1 xi2 xi2 }  ----------------------------@@ -1175,7 +1198,7 @@ --  so we must proceed one binder at a time (#13879)  can_eq_nc_forall ev eq_rel s1 s2- | CtWanted { ctev_loc = loc, ctev_dest = orig_dest } <- ev+ | CtWanted { ctev_loc = loc, ctev_dest = orig_dest, ctev_rewriters = rewriters } <- ev  = do { let free_tvs       = tyCoVarsOfTypes [s1,s2]             (bndrs1, phi1) = tcSplitForAllTyVarBinders s1             (bndrs2, phi2) = tcSplitForAllTyVarBinders s2@@ -1188,18 +1211,18 @@         else    do { traceTcS "Creating implication for polytype equality" $ ppr ev       ; let empty_subst1 = mkEmptyTCvSubst $ mkInScopeSet free_tvs-      ; (subst1, skol_tvs) <- tcInstSkolTyVarsX empty_subst1 $+      ; skol_info <- mkSkolemInfo (UnifyForAllSkol phi1)+      ; (subst1, skol_tvs) <- tcInstSkolTyVarsX skol_info empty_subst1 $                               binderVars bndrs1 -      ; let skol_info = UnifyForAllSkol phi1-            phi1' = substTy subst1 phi1+      ; let phi1' = substTy subst1 phi1              -- Unify the kinds, extend the substitution             go :: [TcTyVar] -> TCvSubst -> [TyVarBinder]                -> TcS (TcCoercion, Cts)             go (skol_tv:skol_tvs) subst (bndr2:bndrs2)               = do { let tv2 = binderVar bndr2-                   ; (kind_co, wanteds1) <- unify loc Nominal (tyVarKind skol_tv)+                   ; (kind_co, wanteds1) <- unify loc rewriters Nominal (tyVarKind skol_tv)                                                   (substTy subst (tyVarKind tv2))                    ; let subst' = extendTvSubstAndInScope subst tv2                                        (mkCastTy (mkTyVarTy skol_tv) kind_co)@@ -1211,8 +1234,8 @@              -- Done: unify phi1 ~ phi2             go [] subst bndrs2-              = ASSERT( null bndrs2 )-                unify loc (eqRelRole eq_rel) phi1' (substTyUnchecked subst phi2)+              = assert (null bndrs2) $+                unify loc rewriters (eqRelRole eq_rel) phi1' (substTyUnchecked subst phi2)              go _ _ _ = panic "cna_eq_nc_forall"  -- case (s:ss) [] @@ -1220,25 +1243,25 @@        ; (lvl, (all_co, wanteds)) <- pushLevelNoWorkList (ppr skol_info) $                                     go skol_tvs empty_subst2 bndrs2-      ; emitTvImplicationTcS lvl skol_info skol_tvs wanteds+      ; emitTvImplicationTcS lvl (getSkolemInfo skol_info) skol_tvs wanteds        ; setWantedEq orig_dest all_co       ; stopWith ev "Deferred polytype equality" } }   | otherwise  = do { traceTcS "Omitting decomposition of given polytype equality" $-        pprEq s1 s2    -- See Note [Do not decompose given polytype equalities]+        pprEq s1 s2    -- See Note [Do not decompose Given polytype equalities]       ; stopWith ev "Discard given polytype equality" }   where-    unify :: CtLoc -> Role -> TcType -> TcType -> TcS (TcCoercion, Cts)+    unify :: CtLoc -> RewriterSet -> Role -> TcType -> TcType -> TcS (TcCoercion, Cts)     -- This version returns the wanted constraint rather     -- than putting it in the work list-    unify loc role ty1 ty2+    unify loc rewriters role ty1 ty2       | ty1 `tcEqType` ty2       = return (mkTcReflCo role ty1, emptyBag)       | otherwise-      = do { (wanted, co) <- newWantedEq loc role ty1 ty2+      = do { (wanted, co) <- newWantedEq loc rewriters role ty1 ty2            ; return (co, unitBag (mkNonCanonical wanted)) }  ---------------------------------@@ -1456,9 +1479,9 @@                   -> TcType               -- ^ ty2                   -> TcType               -- ^ ty2, with type synonyms                   -> TcS (StopOrContinue Ct)-can_eq_newtype_nc ev swapped ty1 ((gres, co), ty1') ty2 ps_ty2+can_eq_newtype_nc ev swapped ty1 ((gres, co1), ty1') ty2 ps_ty2   = do { traceTcS "can_eq_newtype_nc" $-         vcat [ ppr ev, ppr swapped, ppr co, ppr gres, ppr ty1', ppr ty2 ]+         vcat [ ppr ev, ppr swapped, ppr co1, ppr gres, ppr ty1', ppr ty2 ]           -- check for blowing our stack:          -- See Note [Newtypes can blow the stack]@@ -1474,8 +1497,11 @@          -- module, don't warn about it being unused.          -- See Note [Tracking unused binding and imports] in GHC.Tc.Utils. -       ; new_ev <- rewriteEqEvidence ev swapped ty1' ps_ty2-                                     (mkTcSymCo co) (mkTcReflCo Representational ps_ty2)+       ; let redn1 = mkReduction co1 ty1'++       ; new_ev <- rewriteEqEvidence emptyRewriterSet ev swapped+                     redn1+                     (mkReflRedn Representational ps_ty2)        ; can_eq_nc False new_ev ReprEq ty1' ty1' ty2 ps_ty2 }   where     gre_list = bagToList gres@@ -1493,16 +1519,12 @@ -- to an irreducible constraint; see typecheck/should_compile/T10494 -- See Note [Decomposing AppTy at representational role] can_eq_app ev s1 t1 s2 t2-  | CtDerived {} <- ev-  = do { unifyDeriveds loc [Nominal, Nominal] [s1, t1] [s2, t2]-       ; stopWith ev "Decomposed [D] AppTy" }--  | CtWanted { ctev_dest = dest } <- ev-  = do { co_s <- unifyWanted loc Nominal s1 s2+  | CtWanted { ctev_dest = dest, ctev_rewriters = rewriters } <- ev+  = do { co_s <- unifyWanted rewriters loc Nominal s1 s2        ; let arg_loc                | isNextArgVisible s1 = loc                | otherwise           = updateCtLocOrigin loc toInvisibleOrigin-       ; co_t <- unifyWanted arg_loc Nominal t1 t2+       ; co_t <- unifyWanted rewriters arg_loc Nominal t1 t2        ; let co = mkAppCo co_s co_t        ; setWantedEq dest co        ; stopWith ev "Decomposed [W] AppTy" }@@ -1550,9 +1572,9 @@   = do { traceTcS "Decomposing cast" (vcat [ ppr ev                                            , ppr ty1 <+> text "|>" <+> ppr co1                                            , ppr ps_ty2 ])-       ; new_ev <- rewriteEqEvidence ev swapped ty1 ps_ty2-                                     (mkTcGReflRightCo role ty1 co1)-                                     (mkTcReflCo role ps_ty2)+       ; new_ev <- rewriteEqEvidence emptyRewriterSet ev swapped+                      (mkGReflLeftRedn role ty1 co1)+                      (mkReflRedn role ps_ty2)        ; can_eq_nc rewritten new_ev eq_rel ty1 ty1 ty2 ps_ty2 }   where     role = eqRelRole eq_rel@@ -1659,18 +1681,13 @@ at role X.  Pursuing the details requires exploring three axes:-* Flavour: Given vs. Derived vs. Wanted+* Flavour: Given vs. Wanted * Role: Nominal vs. Representational * TyCon species: datatype vs. newtype vs. data family vs. type family vs. type variable  (A type variable isn't a TyCon, of course, but it's convenient to put the AppTy case in the same table.) -Right away, we can say that Derived behaves just as Wanted for the purposes-of decomposition. The difference between Derived and Wanted is the handling of-evidence. Since decomposition in these cases isn't a matter of soundness but of-guessing, we want the same behaviour regardless of evidence.- Here is a table (discussion following) detailing where decomposition of    (T s1 ... sn) ~r (T t1 .. tn) is allowed.  The first four lines (Data types ... type family) refer@@ -1697,7 +1714,7 @@ {1}: Type families can be injective in some, but not all, of their arguments, so we want to do partial decomposition. This is quite different than the way other decomposition is done, where the decomposed equalities replace the original-one. We thus proceed much like we do with superclasses, emitting new Deriveds+one. We thus proceed much like we do with superclasses, emitting new Wanteds when "decomposing" a partially-injective type family Wanted. Injective type families have no corresponding evidence of their injectivity, so we cannot decompose an injective-type-family Given.@@ -1711,6 +1728,27 @@  {4}: See Note [Decomposing AppTy at representational role] +   Because type variables can stand in for newtypes, we conservatively do not+   decompose AppTys over representational equality. Here are two examples that+   demonstrate why we can't:++   4a: newtype Phant a = MkPhant Int+       [W] alpha Int ~R beta Bool++   If we eventually solve alpha := Phant and beta := Phant, then we can solve+   this equality by unwrapping. But it would have been disastrous to decompose+   the wanted to produce Int ~ Bool, which is definitely insoluble.++   4b: newtype Age = MkAge Int+       [W] alpha Age ~R Maybe Int++   First, a question: if we know that ty1 ~R ty2, can we conclude that+   a ty1 ~R a ty2? Not for all a. This is precisely why we need role annotations+   on type constructors. So, if we were to decompose, we would need to+   decompose to [W] alpha ~R Maybe and [W] Age ~ Int. On the other hand, if we+   later solve alpha := Maybe, then we would decompose to [W] Age ~R Int, and+   that would be soluble.+ In the implementation of can_eq_nc and friends, we don't directly pattern match using lines like in the tables above, as those tables don't cover all cases (what about PrimTyCon? tuples?). Instead we just ask about injectivity,@@ -1848,18 +1886,15 @@                           -> TcS (StopOrContinue Ct) -- Precondition: tys1 and tys2 are the same length, hence "OK" canDecomposableTyConAppOK ev eq_rel tc tys1 tys2-  = ASSERT( tys1 `equalLength` tys2 )+  = assert (tys1 `equalLength` tys2) $     do { traceTcS "canDecomposableTyConAppOK"                   (ppr ev $$ ppr eq_rel $$ ppr tc $$ ppr tys1 $$ ppr tys2)        ; case ev of-           CtDerived {}-             -> unifyDeriveds loc tc_roles tys1 tys2--           CtWanted { ctev_dest = dest }+           CtWanted { ctev_dest = dest, ctev_rewriters = rewriters }                   -- new_locs and tc_roles are both infinite, so                   -- we are guaranteed that cos has the same length                   -- as tys1 and tys2-             -> do { cos <- zipWith4M unifyWanted new_locs tc_roles tys1 tys2+             -> do { cos <- zipWith4M (unifyWanted rewriters) new_locs tc_roles tys1 tys2                    ; setWantedEq dest (mkTyConAppCo role tc cos) }             CtGiven { ctev_evar = evar }@@ -1909,14 +1944,14 @@ canEqFailure ev NomEq ty1 ty2   = canEqHardFailure ev ty1 ty2 canEqFailure ev ReprEq ty1 ty2-  = do { (xi1, co1) <- rewrite ev ty1-       ; (xi2, co2) <- rewrite ev ty2+  = do { (redn1, rewriters1) <- rewrite ev ty1+       ; (redn2, rewriters2) <- rewrite ev ty2             -- We must rewrite the types before putting them in the             -- inert set, so that we are sure to kick them out when             -- new equalities become available        ; traceTcS "canEqFailure with ReprEq" $-         vcat [ ppr ev, ppr ty1, ppr ty2, ppr xi1, ppr xi2 ]-       ; new_ev <- rewriteEqEvidence ev NotSwapped xi1 xi2 co1 co2+         vcat [ ppr ev, ppr redn1, ppr redn2 ]+       ; new_ev <- rewriteEqEvidence (rewriters1 S.<> rewriters2) ev NotSwapped redn1 redn2        ; continueWith (mkIrredCt ReprEqReason new_ev) }  -- | Call when canonicalizing an equality fails with utterly no hope.@@ -1925,9 +1960,9 @@ -- See Note [Make sure that insolubles are fully rewritten] canEqHardFailure ev ty1 ty2   = do { traceTcS "canEqHardFailure" (ppr ty1 $$ ppr ty2)-       ; (s1, co1) <- rewrite ev ty1-       ; (s2, co2) <- rewrite ev ty2-       ; new_ev <- rewriteEqEvidence ev NotSwapped s1 s2 co1 co2+       ; (redn1, rewriters1) <- rewrite ev ty1+       ; (redn2, rewriters2) <- rewrite ev ty2+       ; new_ev <- rewriteEqEvidence (rewriters1 S.<> rewriters2) ev NotSwapped redn1 redn2        ; continueWith (mkIrredCt ShapeMismatchReason new_ev) }  {-@@ -1971,7 +2006,7 @@ all the way down, so that it accurately reflects  (a) the mutable reference substitution in force at start of solving  (b) any ty-binds in force at this point in solving-See Note [Rewrite insolubles] in GHC.Tc.Solver.Monad.+See Note [Rewrite insolubles] in GHC.Tc.Solver.InertSet. And if we don't do this there is a bad danger that GHC.Tc.Solver.applyTyVarDefaulting will find a variable that has in fact been substituted.@@ -1982,21 +2017,6 @@ No -- what would the evidence look like?  So instead we simply discard this given evidence. --Note [Combining insoluble constraints]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-As this point we have an insoluble constraint, like Int~Bool.-- * If it is Wanted, delete it from the cache, so that subsequent-   Int~Bool constraints give rise to separate error messages-- * But if it is Derived, DO NOT delete from cache.  A class constraint-   may get kicked out of the inert set, and then have its functional-   dependency Derived constraints generated a second time. In that-   case we don't want to get two (or more) error messages by-   generating two (or more) insoluble fundep constraints from the same-   class constraint.- Note [No top-level newtypes on RHS of representational equalities] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we're in this situation:@@ -2022,8 +2042,8 @@     g _ = f (undefined :: F a)  For g we get [G]  g1 : UnF (F a) ~ a-             [WD] w1 : UnF (F beta) ~ beta-             [WD] w2 : F a ~ F beta+             [W] w1 : UnF (F beta) ~ beta+             [W] w2 : F a ~ F beta  g1 is canonical (CEqCan). It is oriented as above because a is not touchable. See canEqTyVarFunEq.@@ -2038,17 +2058,16 @@  But if w2 is swapped around, to -    [D] w3 : F beta ~ F a+    [W] w3 : F beta ~ F a -then (after emitting shadow Deriveds, etc. See GHC.Tc.Solver.Monad-Note [The improvement story and derived shadows]) we'll kick w1 out of the inert+then we'll kick w1 out of the inert set (it mentions the LHS of w3). We then rewrite w1 to -    [D] w4 : UnF (F a) ~ beta+    [W] w4 : UnF (F a) ~ beta  and then, using g1, to -    [D] w5 : a ~ beta+    [W] w5 : a ~ beta  at which point we can unify and go on to glory. (This rewriting actually happens all at once, in the call to rewrite during canonicalisation.)@@ -2064,7 +2083,7 @@ -}  ----------------------canEqCanLHS :: CtEvidence          -- ev :: lhs ~ rhs+canEqCanLHS :: CtEvidence            -- ev :: lhs ~ rhs             -> EqRel -> SwapFlag             -> CanEqLHS              -- lhs (or, if swapped, rhs)             -> TcType                -- lhs: pretty lhs, already rewritten@@ -2075,7 +2094,7 @@   = canEqCanLHSHomo ev eq_rel swapped lhs1 ps_xi1 xi2 ps_xi2    | otherwise-  = canEqCanLHSHetero ev eq_rel swapped lhs1 ps_xi1 k1 xi2 ps_xi2 k2+  = canEqCanLHSHetero ev eq_rel swapped lhs1 k1 xi2 k2    where     k1 = canEqLHSKind lhs1@@ -2083,41 +2102,42 @@  canEqCanLHSHetero :: CtEvidence         -- :: (xi1 :: ki1) ~ (xi2 :: ki2)                   -> EqRel -> SwapFlag-                  -> CanEqLHS -> TcType -- xi1, pretty xi1+                  -> CanEqLHS           -- xi1                   -> TcKind             -- ki1-                  -> TcType -> TcType   -- xi2, pretty xi2 :: ki2+                  -> TcType             -- xi2                   -> TcKind             -- ki2                   -> TcS (StopOrContinue Ct)-canEqCanLHSHetero ev eq_rel swapped lhs1 ps_xi1 ki1 xi2 ps_xi2 ki2+canEqCanLHSHetero ev eq_rel swapped lhs1 ki1 xi2 ki2   -- See Note [Equalities with incompatible kinds]-  = do { kind_co <- emit_kind_co   -- :: ki2 ~N ki1+  = do { (kind_ev, kind_co) <- mk_kind_eq   -- :: ki2 ~N ki1         ; let  -- kind_co :: (ki2 :: *) ~N (ki1 :: *)   (whether swapped or not)-              -- co1     :: kind(tv1) ~N ki1-             rhs'    = xi2    `mkCastTy` kind_co   -- :: ki1-             ps_rhs' = ps_xi2 `mkCastTy` kind_co   -- :: ki1-             rhs_co  = mkTcGReflLeftCo role xi2 kind_co-               -- rhs_co :: (xi2 |> kind_co) ~ xi2+             lhs_redn = mkReflRedn role xi1+             rhs_redn = mkGReflRightRedn role xi2 kind_co -             lhs_co = mkTcReflCo role xi1+             -- See Note [Equalities with incompatible kinds], Wrinkle (1)+             -- This will be ignored in rewriteEqEvidence if the work item is a Given+             rewriters = rewriterSetFromCo kind_co         ; traceTcS "Hetero equality gives rise to kind equality"            (ppr kind_co <+> dcolon <+> sep [ ppr ki2, text "~#", ppr ki1 ])-       ; type_ev <- rewriteEqEvidence ev swapped xi1 rhs' lhs_co rhs_co+       ; type_ev <- rewriteEqEvidence rewriters ev swapped lhs_redn rhs_redn -          -- rewriteEqEvidence carries out the swap, so we're NotSwapped any more-       ; canEqCanLHSHomo type_ev eq_rel NotSwapped lhs1 ps_xi1 rhs' ps_rhs' }+       ; emitWorkNC [type_ev]  -- delay the type equality until after we've finished+                               -- the kind equality, which may unlock things+                               -- See Note [Equalities with incompatible kinds]++       ; canEqNC kind_ev NomEq ki2 ki1 }   where-    emit_kind_co :: TcS CoercionN-    emit_kind_co-      | CtGiven { ctev_evar = evar } <- ev-      = do { let kind_co = maybe_sym $ mkTcKindCo (mkTcCoVarCo evar)  -- :: k2 ~ k1-           ; kind_ev <- newGivenEvVar kind_loc (kind_pty, evCoercion kind_co)-           ; emitWorkNC [kind_ev]-           ; return (ctEvCoercion kind_ev) }+    mk_kind_eq :: TcS (CtEvidence, CoercionN)+    mk_kind_eq = case ev of+      CtGiven { ctev_evar = evar }+        -> do { let kind_co = maybe_sym $ mkTcKindCo (mkTcCoVarCo evar)  -- :: k2 ~ k1+              ; kind_ev <- newGivenEvVar kind_loc (kind_pty, evCoercion kind_co)+              ; return (kind_ev, ctEvCoercion kind_ev) } -      | otherwise-      = unifyWanted kind_loc Nominal ki2 ki1+      CtWanted { ctev_rewriters = rewriters }+        -> newWantedEq kind_loc rewriters Nominal ki2 ki1      xi1      = canEqLHSType lhs1     loc      = ctev_loc ev@@ -2187,7 +2207,7 @@   , TyFamLHS fun_tc2 fun_args2 <- lhs2   = do { traceTcS "canEqCanLHS2 two type families" (ppr lhs1 $$ ppr lhs2) -         -- emit derived equalities for injective type families+         -- emit wanted equalities for injective type families        ; let inj_eqns :: [TypeEqn]  -- TypeEqn = Pair Type              inj_eqns                | ReprEq <- eq_rel   = []   -- injectivity applies only for nom. eqs.@@ -2220,11 +2240,13 @@                | otherwise  -- ordinary, non-injective type family                = [] -       ; unless (isGiven ev) $-         mapM_ (unifyDerived (ctEvLoc ev) Nominal) inj_eqns+       ; case ev of+           CtWanted { ctev_rewriters = rewriters } ->+             mapM_ (\ (Pair t1 t2) -> unifyWanted rewriters (ctEvLoc ev) Nominal t1 t2) inj_eqns+           CtGiven {} -> return ()+             -- See Note [No Given/Given fundeps] in GHC.Tc.Solver.Interact         ; tclvl <- getTcLevel-       ; dflags <- getDynFlags        ; let tvs1 = tyCoVarsOfTypes fun_args1              tvs2 = tyCoVarsOfTypes fun_args2 @@ -2235,9 +2257,9 @@                 -- If we have F a ~ F (F a), we want to swap.              swap_for_occurs-               | cterHasNoProblem   $ checkTyFamEq dflags fun_tc2 fun_args2+               | cterHasNoProblem   $ checkTyFamEq fun_tc2 fun_args2                                                    (mkTyConApp fun_tc1 fun_args1)-               , cterHasOccursCheck $ checkTyFamEq dflags fun_tc1 fun_args1+               , cterHasOccursCheck $ checkTyFamEq fun_tc1 fun_args1                                                    (mkTyConApp fun_tc2 fun_args2)                = True @@ -2281,10 +2303,9 @@                 -> TcS (StopOrContinue Ct) canEqTyVarFunEq ev eq_rel swapped tv1 ps_xi1 fun_tc2 fun_args2 ps_xi2 mco   = do { is_touchable <- touchabilityTest (ctEvFlavour ev) tv1 rhs-       ; dflags       <- getDynFlags        ; if | case is_touchable of { Untouchable -> False; _ -> True }             , cterHasNoProblem $-                checkTyVarEq dflags tv1 rhs `cterRemoveProblem` cteTypeFamily+                checkTyVarEq tv1 rhs `cterRemoveProblem` cteTypeFamily             -> canEqCanLHSFinish ev eq_rel swapped (TyVarLHS tv1) rhs              | otherwise@@ -2302,8 +2323,8 @@ -- want to rewrite the LHS to (as per e.g. swapOverTyVars) canEqCanLHSFinish :: CtEvidence                   -> EqRel -> SwapFlag-                  -> CanEqLHS              -- lhs (or, if swapped, rhs)-                  -> TcType          -- rhs, pretty rhs+                  -> CanEqLHS             -- lhs (or, if swapped, rhs)+                  -> TcType               -- rhs (or, if swapped, lhs)                   -> TcS (StopOrContinue Ct) canEqCanLHSFinish ev eq_rel swapped lhs rhs -- RHS is fully rewritten, but with type synonyms@@ -2311,21 +2332,25 @@ -- guaranteed that tyVarKind lhs == typeKind rhs, for (TyEq:K) -- (TyEq:N) is checked in can_eq_nc', and (TyEq:TV) is handled in canEqCanLHS2 -  = do { dflags <- getDynFlags-       ; new_ev <- rewriteEqEvidence ev swapped lhs_ty rhs rewrite_co1 rewrite_co2+  = do {+          -- this performs the swap if necessary+         new_ev <- rewriteEqEvidence emptyRewriterSet ev swapped+                                     (mkReflRedn role lhs_ty)+                                     (mkReflRedn role rhs)       -- by now, (TyEq:K) is already satisfied-       ; MASSERT(canEqLHSKind lhs `eqType` tcTypeKind rhs)+       ; massert (canEqLHSKind lhs `eqType` tcTypeKind rhs)       -- by now, (TyEq:N) is already satisfied (if applicable)-       ; MASSERT(not bad_newtype)+       ; assertPprM ty_eq_N_OK $+           vcat [ text "CanEqCanLHSFinish: (TyEq:N) not satisfied"+                , text "rhs:" <+> ppr rhs+                ]       -- guarantees (TyEq:OC), (TyEq:F)      -- Must do the occurs check even on tyvar/tyvar      -- equalities, in case have  x ~ (y :: ..x...); this is #12593.-     -- This next line checks also for coercion holes (TyEq:H); see-     -- Note [Equalities with incompatible kinds]-       ; let result0 = checkTypeEq dflags lhs rhs `cterRemoveProblem` cteTypeFamily+       ; let result0 = checkTypeEq lhs rhs `cterRemoveProblem` cteTypeFamily      -- type families are OK here      -- NB: no occCheckExpand here; see Note [Rewriting synonyms] in GHC.Tc.Solver.Rewrite @@ -2334,10 +2359,7 @@                         NomEq  -> result0                         ReprEq -> cterSetOccursCheckSoluble result0 -             reason | result `cterHasOnlyProblem` cteHoleBlocker-                    = HoleBlockerReason (coercionHolesOfType rhs)-                    | otherwise-                    = NonCanonicalReason result+             reason = NonCanonicalReason result         ; if cterHasNoProblem result          then do { traceTcS "CEqCan" (ppr lhs $$ ppr rhs)@@ -2352,22 +2374,23 @@                          do { traceTcS "canEqCanLHSFinish can't make a canonical"                                        (ppr lhs $$ ppr rhs)                             ; continueWith (mkIrredCt reason new_ev) }-                     ; Just (co, new_rhs) ->+                     ; Just rhs_redn@(Reduction _ new_rhs) ->               do { traceTcS "canEqCanLHSFinish breaking a cycle" $                             ppr lhs $$ ppr rhs                  ; traceTcS "new RHS:" (ppr new_rhs)                     -- This check is Detail (1) in the Note-                 ; if cterHasOccursCheck (checkTypeEq dflags lhs new_rhs)+                 ; if cterHasOccursCheck (checkTypeEq lhs new_rhs)                     then do { traceTcS "Note [Type equality cycles] Detail (1)"                                       (ppr new_rhs)                            ; continueWith (mkIrredCt reason new_ev) }                     else do { -- See Detail (6) of Note [Type equality cycles]-                             new_new_ev <- rewriteEqEvidence new_ev NotSwapped-                                             lhs_ty new_rhs-                                             (mkTcNomReflCo lhs_ty) co+                             new_new_ev <- rewriteEqEvidence emptyRewriterSet+                                             new_ev NotSwapped+                                             (mkReflRedn Nominal lhs_ty)+                                             rhs_redn                             ; continueWith (CEqCan { cc_ev = new_new_ev                                                   , cc_lhs = lhs@@ -2378,15 +2401,20 @@      lhs_ty = canEqLHSType lhs -    rewrite_co1  = mkTcReflCo role lhs_ty-    rewrite_co2  = mkTcReflCo role rhs--    -- This is about (TyEq:N)-    bad_newtype | ReprEq <- eq_rel-                , Just tc <- tyConAppTyCon_maybe rhs-                = isNewTyCon tc-                | otherwise-                = False+    -- This is about (TyEq:N): check that we don't have a newtype+    -- whose constructor is in scope at the top-level of the RHS.+    ty_eq_N_OK :: TcS Bool+    ty_eq_N_OK+      | ReprEq <- eq_rel+      , Just tc <- tyConAppTyCon_maybe rhs+      , Just con <- newTyConDataCon_maybe tc+      -- #21010: only a problem if the newtype constructor is in scope+      -- yet we didn't rewrite it away.+      = do { rdr_env <- getGlobalRdrEnvTcS+           ; let con_in_scope = isJust $ lookupGRE_Name rdr_env (dataConName con)+           ; return $ not con_in_scope }+      | otherwise+      = return True  -- | Solve a reflexive equality constraint canEqReflexive :: CtEvidence    -- ty ~ ty@@ -2406,13 +2434,10 @@                       -> TcS CtEvidence -- :: (lhs |> sym mco) ~ rhs                                         -- result is independent of SwapFlag rewriteCastedEquality ev eq_rel swapped lhs rhs mco-  = rewriteEqEvidence ev swapped new_lhs new_rhs lhs_co rhs_co+  = rewriteEqEvidence emptyRewriterSet ev swapped lhs_redn rhs_redn   where-    new_lhs = lhs `mkCastTyMCo` sym_mco-    lhs_co  = mkTcGReflLeftMCo role lhs sym_mco--    new_rhs = rhs-    rhs_co  = mkTcGReflRightMCo role rhs mco+    lhs_redn = mkGReflRightMRedn role lhs sym_mco+    rhs_redn = mkGReflLeftMRedn  role rhs mco      sym_mco = mkTcSymMCo mco     role    = eqRelRole eq_rel@@ -2428,78 +2453,38 @@    [X] (tv :: k1) ~ (rhs :: k2) -(where [X] is [G], [W], or [D]), we go to--  [noDerived X] co :: k2 ~ k1-  [X]           (tv :: k1) ~ ((rhs |> co) :: k1)--where+(where [X] is [G] or [W]), we go to -  noDerived G = G-  noDerived _ = W+  [X] co :: k2 ~ k1+  [X] (tv :: k1) ~ ((rhs |> co) :: k1) -For reasons described in Wrinkle (2) below, we want the [X] constraint to be "blocked";-that is, it should be put aside, and not used to rewrite any other constraint,-until the kind-equality on which it depends (namely 'co' above) is solved.-To achieve this-* The [X] constraint is a CIrredCan-* With a cc_reason of HoleBlockerReason bchs-* Where 'bchs' is the set of "blocking coercion holes".  The blocking coercion-  holes are the free coercion holes of [X]'s type-* When all the blocking coercion holes in the CIrredCan are filled (solved),-  we convert [X] to a CNonCanonical and put it in the work list.-All this is described in more detail in Wrinkle (2).+We carry on with the *kind equality*, not the type equality, because+solving the former may unlock the latter. This choice is made in+canEqCanLHSHetero. It is important: otherwise, T13135 loops.  Wrinkles: - (1) The noDerived step is because Derived equalities have no evidence.-     And yet we absolutely need evidence to be able to proceed here.-     Given evidence will use the KindCo coercion; Wanted evidence will-     be a coercion hole. Even a Derived hetero equality begets a Wanted-     kind equality.-- (2) Though it would be sound to do so, we must not mark the rewritten Wanted-       [W] (tv :: k1) ~ ((rhs |> co) :: k1)-     as canonical in the inert set. In particular, we must not unify tv.-     If we did, the Wanted becomes a Given (effectively), and then can-     rewrite other Wanteds. But that's bad: See Note [Wanteds do not rewrite Wanteds]-     in GHC.Tc.Types.Constraint. The problem is about poor error messages. See #11198 for-     tales of destruction.+ (1) When X is W, the new type-level wanted is effectively rewritten by the+     kind-level one. We thus include the kind-level wanted in the RewriterSet+     for the type-level one. See Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint.+     This is done in canEqCanLHSHetero. -     So, we have an invariant on CEqCan (TyEq:H) that the RHS does not have-     any coercion holes. This is checked in checkTypeEq. Any equalities that-     have such an RHS are turned into CIrredCans with a HoleBlockerReason. We also-     must be sure to kick out any such CIrredCan constraints that mention coercion holes-     when those holes get filled in, so that the unification step can now proceed.+ (2) If we have [W] w :: alpha ~ (rhs |> co_hole), should we unify alpha? No.+     The problem is that the wanted w is effectively rewritten by another wanted,+     and unifying alpha effectively promotes this wanted to a given. Doing so+     means we lose track of the rewriter set associated with the wanted. -     The kicking out is done in kickOutAfterFillingCoercionHole, and the inerts-     are stored in the inert_blocked field of InertCans.+     On the other hand, w is perfectly suitable for rewriting, because of the+     way we carefully track rewriter sets. -     However, we must be careful: we kick out only when no coercion holes are-     left. The holes in the type are stored in the HoleBlockerReason CtIrredReason.-     The extra check that there are no more remaining holes avoids-     needless work when rewriting evidence (which fills coercion holes) and-     aids efficiency.+     We thus allow w to be a CEqCan, but we prevent unification. See+     Note [Unification preconditions] in GHC.Tc.Utils.Unify. -     Moreover, kicking out when there are remaining unfilled holes can-     cause a loop in the solver in this case:-          [W] w1 :: (ty1 :: F a) ~ (ty2 :: s)-     After canonicalisation, we discover that this equality is heterogeneous.-     So we emit-          [W] co_abc :: F a ~ s-     and preserve the original as-          [W] w2 :: (ty1 |> co_abc) ~ ty2    (blocked on co_abc)-     Then, co_abc comes becomes the work item. It gets swapped in-     canEqCanLHS2 and then back again in canEqTyVarFunEq. We thus get-     co_abc := sym co_abd, and then co_abd := sym co_abe, with-          [W] co_abe :: F a ~ s-     This process has filled in co_abc. Suppose w2 were kicked out.-     When it gets processed,-     would get this whole chain going again. The solution is to-     kick out a blocked constraint only when the result of filling-     in the blocking coercion involves no further blocking coercions.-     Alternatively, we could be careful not to do unnecessary swaps during-     canonicalisation, but that seems hard to do, in general.+     The only tricky part is that we must later indeed unify if/when the kind-level+     wanted gets solved. This is done in kickOutAfterFillingCoercionHole,+     which kicks out all equalities whose RHS mentions the filled-in coercion hole.+     Note that it looks for type family equalities, too, because of the use of+     unifyTest in canEqTyVarFunEq.   (3) Suppose we have [W] (a :: k1) ~ (rhs :: k2). We duly follow the      algorithm detailed here, producing [W] co :: k2 ~ k1, and adding@@ -2519,25 +2504,6 @@      cast appears opposite a tyvar. This is implemented in the cast case      of can_eq_nc'. - (4) Reporting an error for a constraint that is blocked with HoleBlockerReason-     is hard: what would we say to users? And we don't-     really need to report, because if a constraint is blocked, then-     there is unsolved wanted blocking it; that unsolved wanted will-     be reported. We thus push such errors to the bottom of the queue-     in the error-reporting code; they should never be printed.--     (4a) It would seem possible to do this filtering just based on the-          presence of a blocking coercion hole. However, this is no good,-          as it suppresses e.g. no-instance-found errors. We thus record-          a CtIrredReason in CIrredCan and filter based on this status.-          This happened in T14584. An alternative approach is to expressly-          look for *equalities* with blocking coercion holes, but actually-          recording the blockage in a status field seems nicer.--     (4b) The error message might be printed with -fdefer-type-errors,-          so it still must exist. This is the only reason why there is-          a message at all. Otherwise, we could simply do nothing.- Historical note:  We used to do this via emitting a Derived kind equality and then parking@@ -2597,7 +2563,7 @@ or (typecheck/should_compile/T19682b):    instance C (a -> b)-  *[WD] alpha ~ (Arg alpha -> Res alpha)+  *[W] alpha ~ (Arg alpha -> Res alpha)   [W] C alpha  or (typecheck/should_compile/T21515):@@ -2626,9 +2592,9 @@ or    instance C (a -> b)-  [WD] alpha ~ (cbv1 -> cbv2)-  [WD] Arg alpha ~ cbv1-  [WD] Res alpha ~ cbv2+  [W] alpha ~ (cbv1 -> cbv2)+  [W] Arg alpha ~ cbv1+  [W] Res alpha ~ cbv2   [W] C alpha  or@@ -2640,9 +2606,7 @@ This transformation (creating the new types and emitting new equality constraints) is done in breakTyEqCycle_maybe. -The details depend on whether we're working with a Given or a Derived.-(Note that the Wanteds are really WDs, above. This is because Wanteds-are not used for rewriting.)+The details depend on whether we're working with a Given or a Wanted.  Given -----@@ -2686,19 +2650,19 @@ * This fill-in is done when solving is complete, by restoreTyVarCycles   in nestImplicTcS and runTcSWithEvBinds. -Wanted/Derived---------------+Wanted+------ The fresh cycle-breaker variables here must actually be normal, touchable metavariables. That is, they are TauTvs. Nothing at all unusual. Repeating the example from above, we have -  *[WD] alpha ~ (Arg alpha -> Res alpha)+  *[W] alpha ~ (Arg alpha -> Res alpha)  and we turn this into -  *[WD] alpha ~ (cbv1 -> cbv2)-  [WD] Arg alpha ~ cbv1-  [WD] Res alpha ~ cbv2+  *[W] alpha ~ (cbv1 -> cbv2)+  [W] Arg alpha ~ cbv1+  [W] Res alpha ~ cbv2  where cbv1 and cbv2 are fresh TauTvs. Why TauTvs? See [Why TauTvs] below. @@ -2718,11 +2682,11 @@ Note):    instance C (a -> b)-  [WD] Arg (cbv1 -> cbv2) ~ cbv1-  [WD] Res (cbv1 -> cbv2) ~ cbv2+  [W] Arg (cbv1 -> cbv2) ~ cbv1+  [W] Res (cbv1 -> cbv2) ~ cbv2   [W] C (cbv1 -> cbv2) -The first two WD constraints reduce to reflexivity and are discarded,+The first two W constraints reduce to reflexivity and are discarded, and the last is easily soluble.  [Why TauTvs]:@@ -2740,43 +2704,43 @@     AllEqF '[]      '[]      = ()     AllEqF (x : xs) (y : ys) = (x ~ y, AllEq xs ys) -  [WD] alpha ~ (Head alpha : Tail alpha)-  [WD] AllEqF '[Bool] alpha+  [W] alpha ~ (Head alpha : Tail alpha)+  [W] AllEqF '[Bool] alpha  Without the logic detailed in this Note, we're stuck here, as AllEqF cannot reduce and alpha cannot unify. Let's instead apply our cycle-breaker approach, just as described above. We thus invent cbv1 and cbv2 and unify alpha := cbv1 -> cbv2, yielding (after zonking) -  [WD] Head (cbv1 : cbv2) ~ cbv1-  [WD] Tail (cbv1 : cbv2) ~ cbv2-  [WD] AllEqF '[Bool] (cbv1 : cbv2)+  [W] Head (cbv1 : cbv2) ~ cbv1+  [W] Tail (cbv1 : cbv2) ~ cbv2+  [W] AllEqF '[Bool] (cbv1 : cbv2) -The first two WD constraints simplify to reflexivity and are discarded.+The first two W constraints simplify to reflexivity and are discarded. But the last reduces: -  [WD] Bool ~ cbv1-  [WD] AllEq '[] cbv2+  [W] Bool ~ cbv1+  [W] AllEq '[] cbv2  The first of these is solved by unification: cbv1 := Bool. The second is solved by the instance for AllEq to become -  [WD] AllEqF '[] cbv2-  [WD] SameShapeAs '[] cbv2+  [W] AllEqF '[] cbv2+  [W] SameShapeAs '[] cbv2  While the first of these is stuck, the second makes progress, to lead to -  [WD] AllEqF '[] cbv2-  [WD] cbv2 ~ '[]+  [W] AllEqF '[] cbv2+  [W] cbv2 ~ '[]  This second constraint is solved by unification: cbv2 := '[]. We now have -  [WD] AllEqF '[] '[]+  [W] AllEqF '[] '[]  which reduces to -  [WD] ()+  [W] ()  which is trivially satisfiable. Hooray! @@ -2794,8 +2758,7 @@  - and a nominal equality  - and either     - a Given flavour (but see also Detail (7) below)-    - a Wanted/Derived or just plain Derived flavour, with a touchable metavariable-      on the left+    - a Wanted flavour, with a touchable metavariable on the left  We don't use this trick for representational equalities, as there is no concrete use case where it is helpful (unlike for nominal equalities).@@ -2858,7 +2821,8 @@   (4) The evidence for the produced Givens is all just reflexive, because      we will eventually set the cycle-breaker variable to be the type family,-     and then, after the zonk, all will be well.+     and then, after the zonk, all will be well. See also the notes at the+     end of the Given section of this Note.   (5) The approach here is inefficient because it replaces every (outermost)      type family application with a type variable, regardless of whether that@@ -2922,6 +2886,8 @@      We track these equalities by giving them a special CtOrigin,      CycleBreakerOrigin. This works for both Givens and Wanteds, as      we need the logic in the W case for e.g. typecheck/should_fail/T17139.+     Because this logic needs to work for Wanteds, too, we cannot+     simply look for a CycleBreakerTv on the left: Wanteds don't use them.   (8) We really want to do this all only when there is a soluble occurs-check      failure, not when other problems arise (such as an impredicative@@ -2967,9 +2933,10 @@            ContinueWith ct -> tcs2 ct } infixr 0 `andWhenContinue`    -- allow chaining with ($) -rewriteEvidence :: CtEvidence   -- old evidence-                -> TcPredType   -- new predicate-                -> TcCoercion   -- Of type :: new predicate ~ <type of old evidence>+rewriteEvidence :: RewriterSet  -- ^ See Note [Wanteds rewrite Wanteds]+                                -- in GHC.Tc.Types.Constraint+                -> CtEvidence   -- ^ old evidence+                -> Reduction    -- ^ new predicate + coercion, of type <type of old evidence> ~ new predicate                 -> TcS (StopOrContinue CtEvidence) -- Returns Just new_ev iff either (i)  'co' is reflexivity --                             or (ii) 'co' is not reflexivity, and 'new_pred' not cached@@ -2978,7 +2945,7 @@      rewriteEvidence old_ev new_pred co Main purpose: create new evidence for new_pred;               unless new_pred is cached already-* Returns a new_ev : new_pred, with same wanted/given/derived flag as old_ev+* Returns a new_ev : new_pred, with same wanted/given flag as old_ev * If old_ev was wanted, create a binding for old_ev, in terms of new_ev * If old_ev was given, AND not cached, create a binding for new_ev, in terms of old_ev * Returns Nothing if new_ev is already cached@@ -2987,7 +2954,7 @@         flavour                                        of same flavor         -------------------------------------------------------------------         Wanted          Already solved or in inert     Nothing-        or Derived      Not                            Just new_evidence+                        Not                            Just new_evidence          Given           Already in inert               Nothing                         Not                            Just new_evidence@@ -3002,96 +2969,95 @@  The rewriter preserves type synonyms, so they should appear in new_pred as well as in old_pred; that is important for good error messages.++If we are rewriting with Refl, then there are no new rewriters to add to+the rewriter set. We check this with an assertion.  -}  -rewriteEvidence old_ev@(CtDerived {}) new_pred _co-  = -- If derived, don't even look at the coercion.-    -- This is very important, DO NOT re-order the equations for-    -- rewriteEvidence to put the isTcReflCo test first!-    -- Why?  Because for *Derived* constraints, c, the coercion, which-    -- was produced by rewriting, may contain suspended calls to-    -- (ctEvExpr c), which fails for Derived constraints.-    -- (Getting this wrong caused #7384.)-    continueWith (old_ev { ctev_pred = new_pred })--rewriteEvidence old_ev new_pred co+rewriteEvidence rewriters old_ev (Reduction co new_pred)   | isTcReflCo co -- See Note [Rewriting with Refl]-  = continueWith (old_ev { ctev_pred = new_pred })+  = assert (isEmptyRewriterSet rewriters) $+    continueWith (setCtEvPredType old_ev new_pred) -rewriteEvidence ev@(CtGiven { ctev_evar = old_evar, ctev_loc = loc }) new_pred co-  = do { new_ev <- newGivenEvVar loc (new_pred, new_tm)+rewriteEvidence rewriters ev@(CtGiven { ctev_evar = old_evar, ctev_loc = loc })+                (Reduction co new_pred)+  = assert (isEmptyRewriterSet rewriters) $ -- this is a Given, not a wanted+    do { new_ev <- newGivenEvVar loc (new_pred, new_tm)        ; continueWith new_ev }   where     -- mkEvCast optimises ReflCo-    new_tm = mkEvCast (evId old_evar) (tcDowngradeRole Representational-                                                       (ctEvRole ev)-                                                       (mkTcSymCo co))+    new_tm = mkEvCast (evId old_evar)+                (tcDowngradeRole Representational (ctEvRole ev) co) -rewriteEvidence ev@(CtWanted { ctev_dest = dest-                             , ctev_nosh = si-                             , ctev_loc = loc }) new_pred co-  = do { mb_new_ev <- newWanted_SI si loc new_pred-               -- The "_SI" variant ensures that we make a new Wanted-               -- with the same shadow-info as the existing one-               -- with the same shadow-info as the existing one (#16735)-       ; MASSERT( tcCoercionRole co == ctEvRole ev )+rewriteEvidence new_rewriters+                ev@(CtWanted { ctev_dest = dest+                             , ctev_loc = loc+                             , ctev_rewriters = rewriters })+                (Reduction co new_pred)+  = do { mb_new_ev <- newWanted loc rewriters' new_pred+       ; massert (tcCoercionRole co == ctEvRole ev)        ; setWantedEvTerm dest             (mkEvCast (getEvExpr mb_new_ev)-                      (tcDowngradeRole Representational (ctEvRole ev) co))+                      (tcDowngradeRole Representational (ctEvRole ev) (mkSymCo co)))        ; case mb_new_ev of             Fresh  new_ev -> continueWith new_ev             Cached _      -> stopWith ev "Cached wanted" }+  where+    rewriters' = rewriters S.<> new_rewriters  -rewriteEqEvidence :: CtEvidence         -- Old evidence :: olhs ~ orhs (not swapped)+rewriteEqEvidence :: RewriterSet        -- New rewriters+                                        -- See GHC.Tc.Types.Constraint+                                        -- Note [Wanteds rewrite Wanteds]+                  -> CtEvidence         -- Old evidence :: olhs ~ orhs (not swapped)                                         --              or orhs ~ olhs (swapped)                   -> SwapFlag-                  -> TcType -> TcType   -- New predicate  nlhs ~ nrhs-                  -> TcCoercion         -- lhs_co, of type :: nlhs ~ olhs-                  -> TcCoercion         -- rhs_co, of type :: nrhs ~ orhs+                  -> Reduction          -- lhs_co :: olhs ~ nlhs+                  -> Reduction          -- rhs_co :: orhs ~ nrhs                   -> TcS CtEvidence     -- Of type nlhs ~ nrhs--- For (rewriteEqEvidence (Given g olhs orhs) False nlhs nrhs lhs_co rhs_co)--- we generate+-- With reductions (Reduction lhs_co nlhs) (Reduction rhs_co nrhs),+-- rewriteEqEvidence yields, for a given equality (Given g olhs orhs): -- If not swapped---      g1 : nlhs ~ nrhs = lhs_co ; g ; sym rhs_co--- If 'swapped'---      g1 : nlhs ~ nrhs = lhs_co ; Sym g ; sym rhs_co+--      g1 : nlhs ~ nrhs = sym lhs_co ; g ; rhs_co+-- If swapped+--      g1 : nlhs ~ nrhs = sym lhs_co ; Sym g ; rhs_co ----- For (Wanted w) we do the dual thing.+-- For a wanted equality (Wanted w), we do the dual thing: -- New  w1 : nlhs ~ nrhs -- If not swapped---      w : olhs ~ orhs = sym lhs_co ; w1 ; rhs_co+--      w : olhs ~ orhs = lhs_co ; w1 ; sym rhs_co -- If swapped---      w : orhs ~ olhs = sym rhs_co ; sym w1 ; lhs_co+--      w : orhs ~ olhs = rhs_co ; sym w1 ; sym lhs_co ----- It's all a form of rewwriteEvidence, specialised for equalities-rewriteEqEvidence old_ev swapped nlhs nrhs lhs_co rhs_co-  | CtDerived {} <- old_ev  -- Don't force the evidence for a Derived-  = return (old_ev { ctev_pred = new_pred })-+-- It's all a form of rewriteEvidence, specialised for equalities+rewriteEqEvidence new_rewriters old_ev swapped (Reduction lhs_co nlhs) (Reduction rhs_co nrhs)   | NotSwapped <- swapped   , isTcReflCo lhs_co      -- See Note [Rewriting with Refl]   , isTcReflCo rhs_co-  = return (old_ev { ctev_pred = new_pred })+  = return (setCtEvPredType old_ev new_pred)    | CtGiven { ctev_evar = old_evar } <- old_ev-  = do { let new_tm = evCoercion (lhs_co+  = do { let new_tm = evCoercion ( mkTcSymCo lhs_co                                   `mkTcTransCo` maybeTcSymCo swapped (mkTcCoVarCo old_evar)-                                  `mkTcTransCo` mkTcSymCo rhs_co)+                                  `mkTcTransCo` rhs_co)        ; newGivenEvVar loc' (new_pred, new_tm) } -  | CtWanted { ctev_dest = dest, ctev_nosh = si } <- old_ev-  = do { (new_ev, hole_co) <- newWantedEq_SI si loc'-                                             (ctEvRole old_ev) nlhs nrhs-               -- The "_SI" variant ensures that we make a new Wanted-               -- with the same shadow-info as the existing one (#16735)+  | CtWanted { ctev_dest = dest+             , ctev_rewriters = rewriters } <- old_ev+  , let rewriters' = rewriters S.<> new_rewriters+  = do { (new_ev, hole_co) <- newWantedEq loc' rewriters'+                                          (ctEvRole old_ev) nlhs nrhs        ; let co = maybeTcSymCo swapped $-                  mkSymCo lhs_co+                  lhs_co                   `mkTransCo` hole_co-                  `mkTransCo` rhs_co+                  `mkTransCo` mkTcSymCo rhs_co        ; setWantedEq dest co-       ; traceTcS "rewriteEqEvidence" (vcat [ppr old_ev, ppr nlhs, ppr nrhs, ppr co])+       ; traceTcS "rewriteEqEvidence" (vcat [ ppr old_ev+                                            , ppr nlhs+                                            , ppr nrhs+                                            , ppr co+                                            , ppr new_rewriters ])        ; return new_ev }  #if __GLASGOW_HASKELL__ <= 810@@ -3114,11 +3080,10 @@ *                                                                      * ************************************************************************ -Note [unifyWanted and unifyDerived]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Note [unifyWanted]+~~~~~~~~~~~~~~~~~~ When decomposing equalities we often create new wanted constraints for (s ~ t).  But what if s=t?  Then it'd be faster to return Refl right away.-Similar remarks apply for Derived.  Rather than making an equality test (which traverses the structure of the type, perhaps fruitlessly), unifyWanted traverses the common structure, and@@ -3127,32 +3092,32 @@ to reflect it. -} -unifyWanted :: CtLoc -> Role-            -> TcType -> TcType -> TcS Coercion+unifyWanted :: RewriterSet -> CtLoc+            -> Role -> TcType -> TcType -> TcS Coercion -- Return coercion witnessing the equality of the two types, -- emitting new work equalities where necessary to achieve that -- Very good short-cut when the two types are equal, or nearly so--- See Note [unifyWanted and unifyDerived]+-- See Note [unifyWanted] -- The returned coercion's role matches the input parameter-unifyWanted loc Phantom ty1 ty2-  = do { kind_co <- unifyWanted loc Nominal (tcTypeKind ty1) (tcTypeKind ty2)+unifyWanted rewriters loc Phantom ty1 ty2+  = do { kind_co <- unifyWanted rewriters loc Nominal (tcTypeKind ty1) (tcTypeKind ty2)        ; return (mkPhantomCo kind_co ty1 ty2) } -unifyWanted loc role orig_ty1 orig_ty2+unifyWanted rewriters loc role orig_ty1 orig_ty2   = go orig_ty1 orig_ty2   where     go ty1 ty2 | Just ty1' <- tcView ty1 = go ty1' ty2     go ty1 ty2 | Just ty2' <- tcView ty2 = go ty1 ty2'      go (FunTy _ w1 s1 t1) (FunTy _ w2 s2 t2)-      = do { co_s <- unifyWanted loc role s1 s2-           ; co_t <- unifyWanted loc role t1 t2-           ; co_w <- unifyWanted loc Nominal w1 w2+      = do { co_s <- unifyWanted rewriters loc role s1 s2+           ; co_t <- unifyWanted rewriters loc role t1 t2+           ; co_w <- unifyWanted rewriters loc Nominal w1 w2            ; return (mkFunCo role co_w co_s co_t) }     go (TyConApp tc1 tys1) (TyConApp tc2 tys2)       | tc1 == tc2, tys1 `equalLength` tys2       , isInjectiveTyCon tc1 role -- don't look under newtypes at Rep equality-      = do { cos <- zipWith3M (unifyWanted loc)+      = do { cos <- zipWith3M (unifyWanted rewriters loc)                               (tyConRolesX role tc1) tys1 tys2            ; return (mkTyConAppCo role tc1 cos) } @@ -3175,48 +3140,4 @@     bale_out ty1 ty2        | ty1 `tcEqType` ty2 = return (mkTcReflCo role ty1)         -- Check for equality; e.g. a ~ a, or (m a) ~ (m a)-       | otherwise = emitNewWantedEq loc role orig_ty1 orig_ty2--unifyDeriveds :: CtLoc -> [Role] -> [TcType] -> [TcType] -> TcS ()--- See Note [unifyWanted and unifyDerived]-unifyDeriveds loc roles tys1 tys2 = zipWith3M_ (unify_derived loc) roles tys1 tys2--unifyDerived :: CtLoc -> Role -> Pair TcType -> TcS ()--- See Note [unifyWanted and unifyDerived]-unifyDerived loc role (Pair ty1 ty2) = unify_derived loc role ty1 ty2--unify_derived :: CtLoc -> Role -> TcType -> TcType -> TcS ()--- Create new Derived and put it in the work list--- Should do nothing if the two types are equal--- See Note [unifyWanted and unifyDerived]-unify_derived _   Phantom _        _        = return ()-unify_derived loc role    orig_ty1 orig_ty2-  = go orig_ty1 orig_ty2-  where-    go ty1 ty2 | Just ty1' <- tcView ty1 = go ty1' ty2-    go ty1 ty2 | Just ty2' <- tcView ty2 = go ty1 ty2'--    go (FunTy _ w1 s1 t1) (FunTy _ w2 s2 t2)-      = do { unify_derived loc role s1 s2-           ; unify_derived loc role t1 t2-           ; unify_derived loc Nominal w1 w2 }-    go (TyConApp tc1 tys1) (TyConApp tc2 tys2)-      | tc1 == tc2, tys1 `equalLength` tys2-      , isInjectiveTyCon tc1 role-      = unifyDeriveds loc (tyConRolesX role tc1) tys1 tys2-    go ty1@(TyVarTy tv) ty2-      = do { mb_ty <- isFilledMetaTyVar_maybe tv-           ; case mb_ty of-                Just ty1' -> go ty1' ty2-                Nothing   -> bale_out ty1 ty2 }-    go ty1 ty2@(TyVarTy tv)-      = do { mb_ty <- isFilledMetaTyVar_maybe tv-           ; case mb_ty of-                Just ty2' -> go ty1 ty2'-                Nothing   -> bale_out ty1 ty2 }-    go ty1 ty2 = bale_out ty1 ty2--    bale_out ty1 ty2-       | ty1 `tcEqType` ty2 = return ()-        -- Check for equality; e.g. a ~ a, or (m a) ~ (m a)-       | otherwise = emitNewDerivedEq loc role orig_ty1 orig_ty2+       | otherwise = emitNewWantedEq loc rewriters role orig_ty1 orig_ty2
+ GHC/Tc/Solver/InertSet.hs view
@@ -0,0 +1,1812 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeApplications #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++module GHC.Tc.Solver.InertSet (+    -- * The work list+    WorkList(..), isEmptyWorkList, emptyWorkList,+    extendWorkListNonEq, extendWorkListCt,+    extendWorkListCts, extendWorkListEq,+    appendWorkList, extendWorkListImplic,+    workListSize,+    selectWorkItem,++    -- * The inert set+    InertSet(..),+    InertCans(..),+    InertEqs,+    emptyInert,+    addInertItem,++    matchableGivens,+    mightEqualLater,+    prohibitedSuperClassSolve,++    -- * Inert equalities+    foldTyEqs, delEq, findEq,+    partitionInertEqs, partitionFunEqs,++    -- * Kick-out+    kickOutRewritableLHS,++    -- * Cycle breaker vars+    CycleBreakerVarStack,+    pushCycleBreakerVarStack,+    insertCycleBreakerBinding,+    forAllCycleBreakerBindings_++  ) where++import GHC.Prelude++import GHC.Tc.Solver.Types++import GHC.Tc.Types.Constraint+import GHC.Tc.Types.Origin+import GHC.Tc.Utils.TcType+import GHC.Types.Var+import GHC.Types.Var.Env++import GHC.Core.Reduction+import GHC.Core.Predicate+import GHC.Core.TyCo.FVs+import qualified GHC.Core.TyCo.Rep as Rep+import GHC.Core.TyCon+import GHC.Core.Unify++import GHC.Data.Bag+import GHC.Utils.Misc       ( partitionWith )+import GHC.Utils.Outputable+import GHC.Utils.Panic++import Data.List          ( partition )+import Data.List.NonEmpty ( NonEmpty(..), (<|) )+import qualified Data.List.NonEmpty as NE+import GHC.Utils.Panic.Plain+import GHC.Data.Maybe+import Control.Monad      ( forM_ )++{-+************************************************************************+*                                                                      *+*                            Worklists                                *+*  Canonical and non-canonical constraints that the simplifier has to  *+*  work on. Including their simplification depths.                     *+*                                                                      *+*                                                                      *+************************************************************************++Note [WorkList priorities]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+A WorkList contains canonical and non-canonical items (of all flavours).+Notice that each Ct now has a simplification depth. We may+consider using this depth for prioritization as well in the future.++As a simple form of priority queue, our worklist separates out++* equalities (wl_eqs); see Note [Prioritise equalities]+* all the rest (wl_rest)++Note [Prioritise equalities]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's very important to process equalities /first/:++* (Efficiency)  The general reason to do so is that if we process a+  class constraint first, we may end up putting it into the inert set+  and then kicking it out later.  That's extra work compared to just+  doing the equality first.++* (Avoiding fundep iteration) As #14723 showed, it's possible to+  get non-termination if we+      - Emit the fundep equalities for a class constraint,+        generating some fresh unification variables.+      - That leads to some unification+      - Which kicks out the class constraint+      - Which isn't solved (because there are still some more+        equalities in the work-list), but generates yet more fundeps+  Solution: prioritise equalities over class constraints++* (Class equalities) We need to prioritise equalities even if they+  are hidden inside a class constraint;+  see Note [Prioritise class equalities]++* (Kick-out) We want to apply this priority scheme to kicked-out+  constraints too (see the call to extendWorkListCt in kick_out_rewritable+  E.g. a CIrredCan can be a hetero-kinded (t1 ~ t2), which may become+  homo-kinded when kicked out, and hence we want to prioritise it.++Note [Prioritise class equalities]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We prioritise equalities in the solver (see selectWorkItem). But class+constraints like (a ~ b) and (a ~~ b) are actually equalities too;+see Note [The equality types story] in GHC.Builtin.Types.Prim.++Failing to prioritise these is inefficient (more kick-outs etc).+But, worse, it can prevent us spotting a "recursive knot" among+Wanted constraints.  See comment:10 of #12734 for a worked-out+example.++So we arrange to put these particular class constraints in the wl_eqs.++  NB: since we do not currently apply the substitution to the+  inert_solved_dicts, the knot-tying still seems a bit fragile.+  But this makes it better.++Note [Residual implications]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The wl_implics in the WorkList are the residual implication+constraints that are generated while solving or canonicalising the+current worklist.  Specifically, when canonicalising+   (forall a. t1 ~ forall a. t2)+from which we get the implication+   (forall a. t1 ~ t2)+See GHC.Tc.Solver.Monad.deferTcSForAllEq++-}++-- See Note [WorkList priorities]+data WorkList+  = WL { wl_eqs     :: [Ct]  -- CEqCan, CDictCan, CIrredCan+                             -- Given and Wanted+                       -- Contains both equality constraints and their+                       -- class-level variants (a~b) and (a~~b);+                       -- See Note [Prioritise equalities]+                       -- See Note [Prioritise class equalities]++       , wl_rest    :: [Ct]++       , wl_implics :: Bag Implication  -- See Note [Residual implications]+    }++appendWorkList :: WorkList -> WorkList -> WorkList+appendWorkList+    (WL { wl_eqs = eqs1, wl_rest = rest1+        , wl_implics = implics1 })+    (WL { wl_eqs = eqs2, wl_rest = rest2+        , wl_implics = implics2 })+   = WL { wl_eqs     = eqs1     ++ eqs2+        , wl_rest    = rest1    ++ rest2+        , wl_implics = implics1 `unionBags`   implics2 }++workListSize :: WorkList -> Int+workListSize (WL { wl_eqs = eqs, wl_rest = rest })+  = length eqs + length rest++extendWorkListEq :: Ct -> WorkList -> WorkList+extendWorkListEq ct wl = wl { wl_eqs = ct : wl_eqs wl }++extendWorkListNonEq :: Ct -> WorkList -> WorkList+-- Extension by non equality+extendWorkListNonEq ct wl = wl { wl_rest = ct : wl_rest wl }++extendWorkListImplic :: Implication -> WorkList -> WorkList+extendWorkListImplic implic wl = wl { wl_implics = implic `consBag` wl_implics wl }++extendWorkListCt :: Ct -> WorkList -> WorkList+-- Agnostic+extendWorkListCt ct wl+ = case classifyPredType (ctPred ct) of+     EqPred {}+       -> extendWorkListEq ct wl++     ClassPred cls _  -- See Note [Prioritise class equalities]+       |  isEqPredClass cls+       -> extendWorkListEq ct wl++     _ -> extendWorkListNonEq ct wl++extendWorkListCts :: [Ct] -> WorkList -> WorkList+-- Agnostic+extendWorkListCts cts wl = foldr extendWorkListCt wl cts++isEmptyWorkList :: WorkList -> Bool+isEmptyWorkList (WL { wl_eqs = eqs, wl_rest = rest, wl_implics = implics })+  = null eqs && null rest && isEmptyBag implics++emptyWorkList :: WorkList+emptyWorkList = WL { wl_eqs  = [], wl_rest = [], wl_implics = emptyBag }++selectWorkItem :: WorkList -> Maybe (Ct, WorkList)+-- See Note [Prioritise equalities]+selectWorkItem wl@(WL { wl_eqs = eqs, wl_rest = rest })+  | ct:cts <- eqs  = Just (ct, wl { wl_eqs    = cts })+  | ct:cts <- rest = Just (ct, wl { wl_rest   = cts })+  | otherwise      = Nothing++-- Pretty printing+instance Outputable WorkList where+  ppr (WL { wl_eqs = eqs, wl_rest = rest, wl_implics = implics })+   = text "WL" <+> (braces $+     vcat [ ppUnless (null eqs) $+            text "Eqs =" <+> vcat (map ppr eqs)+          , ppUnless (null rest) $+            text "Non-eqs =" <+> vcat (map ppr rest)+          , ppUnless (isEmptyBag implics) $+            ifPprDebug (text "Implics =" <+> vcat (map ppr (bagToList implics)))+                       (text "(Implics omitted)")+          ])++{- *********************************************************************+*                                                                      *+                InertSet: the inert set+*                                                                      *+*                                                                      *+********************************************************************* -}++type CycleBreakerVarStack = NonEmpty [(TcTyVar, TcType)]+   -- ^ a stack of (CycleBreakerTv, original family applications) lists+   -- first element in the stack corresponds to current implication;+   --   later elements correspond to outer implications+   -- used to undo the cycle-breaking needed to handle+   -- Note [Type equality cycles] in GHC.Tc.Solver.Canonical+   -- Why store the outer implications? For the use in mightEqualLater (only)++data InertSet+  = IS { inert_cans :: InertCans+              -- Canonical Given, Wanted+              -- Sometimes called "the inert set"++       , inert_cycle_breakers :: CycleBreakerVarStack++       , inert_famapp_cache :: FunEqMap Reduction+              -- Just a hash-cons cache for use when reducing family applications+              -- only+              --+              -- If    F tys :-> (co, rhs, flav),+              -- then  co :: F tys ~N rhs+              -- all evidence is from instances or Givens; no coercion holes here+              -- (We have no way of "kicking out" from the cache, so putting+              --  wanteds here means we can end up solving a Wanted with itself. Bad)++       , inert_solved_dicts   :: DictMap CtEvidence+              -- All Wanteds, of form ev :: C t1 .. tn+              -- See Note [Solved dictionaries]+              -- and Note [Do not add superclasses of solved dictionaries]+       }++instance Outputable InertSet where+  ppr (IS { inert_cans = ics+          , inert_solved_dicts = solved_dicts })+      = vcat [ ppr ics+             , ppUnless (null dicts) $+               text "Solved dicts =" <+> vcat (map ppr dicts) ]+         where+           dicts = bagToList (dictsToBag solved_dicts)++emptyInertCans :: InertCans+emptyInertCans+  = IC { inert_eqs          = emptyDVarEnv+       , inert_given_eq_lvl = topTcLevel+       , inert_given_eqs    = False+       , inert_dicts        = emptyDictMap+       , inert_safehask     = emptyDictMap+       , inert_funeqs       = emptyFunEqs+       , inert_insts        = []+       , inert_irreds       = emptyCts }++emptyInert :: InertSet+emptyInert+  = IS { inert_cans           = emptyInertCans+       , inert_cycle_breakers = [] :| []+       , inert_famapp_cache   = emptyFunEqs+       , inert_solved_dicts   = emptyDictMap }+++{- Note [Solved dictionaries]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we apply a top-level instance declaration, we add the "solved"+dictionary to the inert_solved_dicts.  In general, we use it to avoid+creating a new EvVar when we have a new goal that we have solved in+the past.++But in particular, we can use it to create *recursive* dictionaries.+The simplest, degenerate case is+    instance C [a] => C [a] where ...+If we have+    [W] d1 :: C [x]+then we can apply the instance to get+    d1 = $dfCList d+    [W] d2 :: C [x]+Now 'd1' goes in inert_solved_dicts, and we can solve d2 directly from d1.+    d1 = $dfCList d+    d2 = d1++See Note [Example of recursive dictionaries]++VERY IMPORTANT INVARIANT:++ (Solved Dictionary Invariant)+    Every member of the inert_solved_dicts is the result+    of applying an instance declaration that "takes a step"++    An instance "takes a step" if it has the form+        dfunDList d1 d2 = MkD (...) (...) (...)+    That is, the dfun is lazy in its arguments, and guarantees to+    immediately return a dictionary constructor.  NB: all dictionary+    data constructors are lazy in their arguments.++    This property is crucial to ensure that all dictionaries are+    non-bottom, which in turn ensures that the whole "recursive+    dictionary" idea works at all, even if we get something like+        rec { d = dfunDList d dx }+    See Note [Recursive superclasses] in GHC.Tc.TyCl.Instance.++ Reason:+   - All instances, except two exceptions listed below, "take a step"+     in the above sense++   - Exception 1: local quantified constraints have no such guarantee;+     indeed, adding a "solved dictionary" when appling a quantified+     constraint led to the ability to define unsafeCoerce+     in #17267.++   - Exception 2: the magic built-in instance for (~) has no+     such guarantee.  It behaves as if we had+         class    (a ~# b) => (a ~ b) where {}+         instance (a ~# b) => (a ~ b) where {}+     The "dfun" for the instance is strict in the coercion.+     Anyway there's no point in recording a "solved dict" for+     (t1 ~ t2); it's not going to allow a recursive dictionary+     to be constructed.  Ditto (~~) and Coercible.++THEREFORE we only add a "solved dictionary"+  - when applying an instance declaration+  - subject to Exceptions 1 and 2 above++In implementation terms+  - GHC.Tc.Solver.Monad.addSolvedDict adds a new solved dictionary,+    conditional on the kind of instance++  - It is only called when applying an instance decl,+    in GHC.Tc.Solver.Interact.doTopReactDict++  - ClsInst.InstanceWhat says what kind of instance was+    used to solve the constraint.  In particular+      * LocalInstance identifies quantified constraints+      * BuiltinEqInstance identifies the strange built-in+        instances for equality.++  - ClsInst.instanceReturnsDictCon says which kind of+    instance guarantees to return a dictionary constructor++Other notes about solved dictionaries++* See also Note [Do not add superclasses of solved dictionaries]++* The inert_solved_dicts field is not rewritten by equalities,+  so it may get out of date.++* The inert_solved_dicts are all Wanteds, never givens++* We only cache dictionaries from top-level instances, not from+  local quantified constraints.  Reason: if we cached the latter+  we'd need to purge the cache when bringing new quantified+  constraints into scope, because quantified constraints "shadow"+  top-level instances.++Note [Do not add superclasses of solved dictionaries]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Every member of inert_solved_dicts is the result of applying a+dictionary function, NOT of applying superclass selection to anything.+Consider++        class Ord a => C a where+        instance Ord [a] => C [a] where ...++Suppose we are trying to solve+  [G] d1 : Ord a+  [W] d2 : C [a]++Then we'll use the instance decl to give++  [G] d1 : Ord a     Solved: d2 : C [a] = $dfCList d3+  [W] d3 : Ord [a]++We must not add d4 : Ord [a] to the 'solved' set (by taking the+superclass of d2), otherwise we'll use it to solve d3, without ever+using d1, which would be a catastrophe.++Solution: when extending the solved dictionaries, do not add superclasses.+That's why each element of the inert_solved_dicts is the result of applying+a dictionary function.++Note [Example of recursive dictionaries]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--- Example 1++    data D r = ZeroD | SuccD (r (D r));++    instance (Eq (r (D r))) => Eq (D r) where+        ZeroD     == ZeroD     = True+        (SuccD a) == (SuccD b) = a == b+        _         == _         = False;++    equalDC :: D [] -> D [] -> Bool;+    equalDC = (==);++We need to prove (Eq (D [])). Here's how we go:++   [W] d1 : Eq (D [])+By instance decl of Eq (D r):+   [W] d2 : Eq [D []]      where   d1 = dfEqD d2+By instance decl of Eq [a]:+   [W] d3 : Eq (D [])      where   d2 = dfEqList d3+                                   d1 = dfEqD d2+Now this wanted can interact with our "solved" d1 to get:+    d3 = d1++-- Example 2:+This code arises in the context of "Scrap Your Boilerplate with Class"++    class Sat a+    class Data ctx a+    instance  Sat (ctx Char)             => Data ctx Char       -- dfunData1+    instance (Sat (ctx [a]), Data ctx a) => Data ctx [a]        -- dfunData2++    class Data Maybe a => Foo a++    instance Foo t => Sat (Maybe t)                             -- dfunSat++    instance Data Maybe a => Foo a                              -- dfunFoo1+    instance Foo a        => Foo [a]                            -- dfunFoo2+    instance                 Foo [Char]                         -- dfunFoo3++Consider generating the superclasses of the instance declaration+         instance Foo a => Foo [a]++So our problem is this+    [G] d0 : Foo t+    [W] d1 : Data Maybe [t]   -- Desired superclass++We may add the given in the inert set, along with its superclasses+  Inert:+    [G] d0 : Foo t+    [G] d01 : Data Maybe t   -- Superclass of d0+  WorkList+    [W] d1 : Data Maybe [t]++Solve d1 using instance dfunData2; d1 := dfunData2 d2 d3+  Inert:+    [G] d0 : Foo t+    [G] d01 : Data Maybe t   -- Superclass of d0+  Solved:+        d1 : Data Maybe [t]+  WorkList:+    [W] d2 : Sat (Maybe [t])+    [W] d3 : Data Maybe t++Now, we may simplify d2 using dfunSat; d2 := dfunSat d4+  Inert:+    [G] d0 : Foo t+    [G] d01 : Data Maybe t   -- Superclass of d0+  Solved:+        d1 : Data Maybe [t]+        d2 : Sat (Maybe [t])+  WorkList:+    [W] d3 : Data Maybe t+    [W] d4 : Foo [t]++Now, we can just solve d3 from d01; d3 := d01+  Inert+    [G] d0 : Foo t+    [G] d01 : Data Maybe t   -- Superclass of d0+  Solved:+        d1 : Data Maybe [t]+        d2 : Sat (Maybe [t])+  WorkList+    [W] d4 : Foo [t]++Now, solve d4 using dfunFoo2;  d4 := dfunFoo2 d5+  Inert+    [G] d0  : Foo t+    [G] d01 : Data Maybe t   -- Superclass of d0+  Solved:+        d1 : Data Maybe [t]+        d2 : Sat (Maybe [t])+        d4 : Foo [t]+  WorkList:+    [W] d5 : Foo t++Now, d5 can be solved! d5 := d0++Result+   d1 := dfunData2 d2 d3+   d2 := dfunSat d4+   d3 := d01+   d4 := dfunFoo2 d5+   d5 := d0+-}++{- *********************************************************************+*                                                                      *+                InertCans: the canonical inerts+*                                                                      *+*                                                                      *+********************************************************************* -}++{- Note [Tracking Given equalities]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For reasons described in (UNTOUCHABLE) in GHC.Tc.Utils.Unify+Note [Unification preconditions], we can't unify+   alpha[2] ~ Int+under a level-4 implication if there are any Given equalities+bound by the implications at level 3 of 4.  To that end, the+InertCans tracks++  inert_given_eq_lvl :: TcLevel+     -- The TcLevel of the innermost implication that has a Given+     -- equality of the sort that make a unification variable untouchable+     -- (see Note [Unification preconditions] in GHC.Tc.Utils.Unify).++We update inert_given_eq_lvl whenever we add a Given to the+inert set, in updateGivenEqs.++Then a unification variable alpha[n] is untouchable iff+    n < inert_given_eq_lvl+that is, if the unification variable was born outside an+enclosing Given equality.++Exactly which constraints should trigger (UNTOUCHABLE), and hence+should update inert_given_eq_lvl?++* We do /not/ need to worry about let-bound skolems, such ast+     forall[2] a. a ~ [b] => blah+  See Note [Let-bound skolems]++* Consider an implication+      forall[2]. beta[1] => alpha[1] ~ Int+  where beta is a unification variable that has already been unified+  to () in an outer scope.  Then alpha[1] is perfectly touchable and+  we can unify alpha := Int. So when deciding whether the givens contain+  an equality, we should canonicalise first, rather than just looking at+  the /original/ givens (#8644).++ * However, we must take account of *potential* equalities. Consider the+   same example again, but this time we have /not/ yet unified beta:+      forall[2] beta[1] => ...blah...++   Because beta might turn into an equality, updateGivenEqs conservatively+   treats it as a potential equality, and updates inert_give_eq_lvl++ * What about something like forall[2] a b. a ~ F b => [W] alpha[1] ~ X y z?++   That Given cannot affect the Wanted, because the Given is entirely+   *local*: it mentions only skolems bound in the very same+   implication. Such equalities need not make alpha untouchable. (Test+   case typecheck/should_compile/LocalGivenEqs has a real-life+   motivating example, with some detailed commentary.)+   Hence the 'mentionsOuterVar' test in updateGivenEqs.++   However, solely to support better error messages+   (see Note [HasGivenEqs] in GHC.Tc.Types.Constraint) we also track+   these "local" equalities in the boolean inert_given_eqs field.+   This field is used only to set the ic_given_eqs field to LocalGivenEqs;+   see the function getHasGivenEqs.++   Here is a simpler case that triggers this behaviour:++     data T where+       MkT :: F a ~ G b => a -> b -> T++     f (MkT _ _) = True++   Because of this behaviour around local equality givens, we can infer the+   type of f. This is typecheck/should_compile/LocalGivenEqs2.++ * We need not look at the equality relation involved (nominal vs+   representational), because representational equalities can still+   imply nominal ones. For example, if (G a ~R G b) and G's argument's+   role is nominal, then we can deduce a ~N b.++Note [Let-bound skolems]+~~~~~~~~~~~~~~~~~~~~~~~~+If   * the inert set contains a canonical Given CEqCan (a ~ ty)+and  * 'a' is a skolem bound in this very implication,++then:+a) The Given is pretty much a let-binding, like+      f :: (a ~ b->c) => a -> a+   Here the equality constraint is like saying+      let a = b->c in ...+   It is not adding any new, local equality  information,+   and hence can be ignored by has_given_eqs++b) 'a' will have been completely substituted out in the inert set,+   so we can safely discard it.++For an example, see #9211.++See also GHC.Tc.Utils.Unify Note [Deeper level on the left] for how we ensure+that the right variable is on the left of the equality when both are+tyvars.++You might wonder whether the skolem really needs to be bound "in the+very same implication" as the equality constraint.+Consider this (c.f. #15009):++  data S a where+    MkS :: (a ~ Int) => S a++  g :: forall a. S a -> a -> blah+  g x y = let h = \z. ( z :: Int+                      , case x of+                           MkS -> [y,z])+          in ...++From the type signature for `g`, we get `y::a` .  Then when we+encounter the `\z`, we'll assign `z :: alpha[1]`, say.  Next, from the+body of the lambda we'll get++  [W] alpha[1] ~ Int                             -- From z::Int+  [W] forall[2]. (a ~ Int) => [W] alpha[1] ~ a   -- From [y,z]++Now, unify alpha := a.  Now we are stuck with an unsolved alpha~Int!+So we must treat alpha as untouchable under the forall[2] implication.++Note [Detailed InertCans Invariants]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The InertCans represents a collection of constraints with the following properties:++  * All canonical++  * No two dictionaries with the same head+  * No two CIrreds with the same type++  * Family equations inert wrt top-level family axioms++  * Dictionaries have no matching top-level instance++  * Given family or dictionary constraints don't mention touchable+    unification variables++  * Non-CEqCan constraints are fully rewritten with respect+    to the CEqCan equalities (modulo eqCanRewrite of course;+    eg a wanted cannot rewrite a given)++  * CEqCan equalities: see Note [inert_eqs: the inert equalities]+    Also see documentation in Constraint.Ct for a list of invariants++Note [inert_eqs: the inert equalities]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Definition [Can-rewrite relation]+A "can-rewrite" relation between flavours, written f1 >= f2, is a+binary relation with the following properties++  (R1) >= is transitive+  (R2) If f1 >= f, and f2 >= f,+       then either f1 >= f2 or f2 >= f1+  (See Note [Why R2?].)++Lemma (L0). If f1 >= f then f1 >= f1+Proof.      By property (R2), with f1=f2++Definition [Generalised substitution]+A "generalised substitution" S is a set of triples (lhs -f-> t), where+  lhs is a type variable or an exactly-saturated type family application+    (that is, lhs is a CanEqLHS)+  t is a type+  f is a flavour+such that+  (WF1) if (lhs1 -f1-> t1) in S+           (lhs2 -f2-> t2) in S+        then (f1 >= f2) implies that lhs1 does not appear within lhs2+  (WF2) if (lhs -f-> t) is in S, then t /= lhs++Definition [Applying a generalised substitution]+If S is a generalised substitution+   S(f,t0) = t,  if (t0 -fs-> t) in S, and fs >= f+           = apply S to components of t0, otherwise+See also Note [Flavours with roles].++Theorem: S(f,t0) is well defined as a function.+Proof: Suppose (lhs -f1-> t1) and (lhs -f2-> t2) are both in S,+               and  f1 >= f and f2 >= f+       Then by (R2) f1 >= f2 or f2 >= f1, which contradicts (WF1)++Notation: repeated application.+  S^0(f,t)     = t+  S^(n+1)(f,t) = S(f, S^n(t))++Definition: terminating generalised substitution+A generalised substitution S is *terminating* iff++  (IG1) there is an n such that+        for every f,t, S^n(f,t) = S^(n+1)(f,t)++By (IG1) we define S*(f,t) to be the result of exahaustively+applying S(f,_) to t.++-----------------------------------------------------------------------------+Our main invariant:+   the CEqCans in inert_eqs should be a terminating generalised substitution+-----------------------------------------------------------------------------++Note that termination is not the same as idempotence.  To apply S to a+type, you may have to apply it recursively.  But termination does+guarantee that this recursive use will terminate.++Note [Why R2?]+~~~~~~~~~~~~~~+R2 states that, if we have f1 >= f and f2 >= f, then either f1 >= f2 or f2 >=+f1. If we do not have R2, we will easily fall into a loop.++To see why, imagine we have f1 >= f, f2 >= f, and that's it. Then, let our+inert set S = {a -f1-> b, b -f2-> a}. Computing S(f,a) does not terminate. And+yet, we have a hard time noticing an occurs-check problem when building S, as+the two equalities cannot rewrite one another.++R2 actually restricts our ability to accept user-written programs. See+Note [Avoiding rewriting cycles] in GHC.Tc.Types.Constraint for an example.++Note [Rewritable]+~~~~~~~~~~~~~~~~~+This Note defines what it means for a type variable or type family application+(that is, a CanEqLHS) to be rewritable in a type. This definition is used+by the anyRewritableXXX family of functions and is meant to model the actual+behaviour in GHC.Tc.Solver.Rewrite.++Ignoring roles (for now): A CanEqLHS lhs is *rewritable* in a type t if the+lhs tree appears as a subtree within t without traversing any of the following+components of t:+  * coercions (whether they appear in casts CastTy or as arguments CoercionTy)+  * kinds of variable occurrences+The check for rewritability *does* look in kinds of the bound variable of a+ForAllTy.++Goal: If lhs is not rewritable in t, then t is a fixpoint of the generalised+substitution containing only {lhs -f*-> t'}, where f* is a flavour such that f* >= f+for all f.++The reason for this definition is that the rewriter does not rewrite in coercions+or variables' kinds. In turn, the rewriter does not need to rewrite there because+those places are never used for controlling the behaviour of the solver: these+places are not used in matching instances or in decomposing equalities.++There is one exception to the claim that non-rewritable parts of the tree do+not affect the solver: we sometimes do an occurs-check to decide e.g. how to+orient an equality. (See the comments on+GHC.Tc.Solver.Canonical.canEqTyVarFunEq.) Accordingly, the presence of a+variable in a kind or coercion just might influence the solver. Here is an+example:++  type family Const x y where+    Const x y = x++  AxConst :: forall x y. Const x y ~# x++  alpha :: Const Type Nat+  [W] alpha ~ Int |> (sym (AxConst Type alpha) ;;+                      AxConst Type alpha ;;+                      sym (AxConst Type Nat))++The cast is clearly ludicrous (it ties together a cast and its symmetric version),+but we can't quite rule it out. (See (EQ1) from+Note [Respecting definitional equality] in GHC.Core.TyCo.Rep to see why we need+the Const Type Nat bit.) And yet this cast will (quite rightly) prevent alpha+from unifying with the RHS. I (Richard E) don't have an example of where this+problem can arise from a Haskell program, but we don't have an air-tight argument+for why the definition of *rewritable* given here is correct.++Taking roles into account: we must consider a rewrite at a given role. That is,+a rewrite arises from some equality, and that equality has a role associated+with it. As we traverse a type, we track what role we are allowed to rewrite with.++For example, suppose we have an inert [G] b ~R# Int. Then b is rewritable in+Maybe b but not in F b, where F is a type function. This role-aware logic is+present in both the anyRewritableXXX functions and in the rewriter.+See also Note [anyRewritableTyVar must be role-aware] in GHC.Tc.Utils.TcType.++Note [Extending the inert equalities]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Main Theorem [Stability under extension]+   Suppose we have a "work item"+       lhs -fw-> t+   and a terminating generalised substitution S,+   THEN the extended substitution T = S+(lhs -fw-> t)+        is a terminating generalised substitution+   PROVIDED+      (T1) S(fw,lhs) = lhs   -- LHS of work-item is a fixpoint of S(fw,_)+      (T2) S(fw,t)   = t     -- RHS of work-item is a fixpoint of S(fw,_)+      (T3) lhs not in t      -- No occurs check in the work item+          -- If lhs is a type family application, we require only that+          -- lhs is not *rewritable* in t. See Note [Rewritable] and+          -- Note [CEqCan occurs check] in GHC.Tc.Types.Constraint.++      AND, for every (lhs1 -fs-> s) in S:+           (K0) not (fw >= fs)+                Reason: suppose we kick out (lhs1 -fs-> s),+                        and add (lhs -fw-> t) to the inert set.+                        The latter can't rewrite the former,+                        so the kick-out achieved nothing++              -- From here, we can assume fw >= fs+           OR (K4) lhs1 is a tyvar AND fs >= fw++           OR { (K1) lhs is not rewritable in lhs1. See Note [Rewritable].+                     Reason: if fw >= fs, WF1 says we can't have both+                             lhs0 -fw-> t  and  F lhs0 -fs-> s++                AND (K2): guarantees termination of the new substitution+                    {  (K2a) not (fs >= fs)+                    OR (K2b) lhs not in s }++                AND (K3) See Note [K3: completeness of solving]+                    { (K3a) If the role of fs is nominal: s /= lhs+                      (K3b) If the role of fs is representational:+                            s is not of form (lhs t1 .. tn) } }+++Conditions (T1-T3) are established by the canonicaliser+Conditions (K1-K3) are established by GHC.Tc.Solver.Monad.kickOutRewritable++The idea is that+* T1 and T2 are guaranteed by exhaustively rewriting the work-item+  with S(fw,_).++* T3 is guaranteed by an occurs-check on the work item.+  This is done during canonicalisation, in checkTypeEq; invariant+  (TyEq:OC) of CEqCan. See also Note [CEqCan occurs check] in GHC.Tc.Types.Constraint.++* (K1-3) are the "kick-out" criteria.  (As stated, they are really the+  "keep" criteria.) If the current inert S contains a triple that does+  not satisfy (K1-3), then we remove it from S by "kicking it out",+  and re-processing it.++* Note that kicking out is a Bad Thing, because it means we have to+  re-process a constraint.  The less we kick out, the better.+  TODO: Make sure that kicking out really *is* a Bad Thing. We've assumed+  this but haven't done the empirical study to check.++* Assume we have  G>=G, G>=W and that's all.  Then, when performing+  a unification we add a new given  a -G-> ty.  But doing so does NOT require+  us to kick out an inert wanted that mentions a, because of (K2a).  This+  is a common case, hence good not to kick out. See also (K2a) below.++* Lemma (L1): The conditions of the Main Theorem imply that there is no+              (lhs -fs-> t) in S, s.t.  (fs >= fw).+  Proof. Suppose the contrary (fs >= fw).  Then because of (T1),+  S(fw,lhs)=lhs.  But since fs>=fw, S(fw,lhs) = t, hence t=lhs.  But now we+  have (lhs -fs-> lhs) in S, which contradicts (WF2).++* The extended substitution satisfies (WF1) and (WF2)+  - (K1) plus (L1) guarantee that the extended substitution satisfies (WF1).+  - (T3) guarantees (WF2).++* (K2) and (K4) are about termination.  Intuitively, any infinite chain S^0(f,t),+  S^1(f,t), S^2(f,t).... must pass through the new work item infinitely+  often, since the substitution without the work item is terminating; and must+  pass through at least one of the triples in S infinitely often.++  - (K2a): if not(fs>=fs) then there is no f that fs can rewrite (fs>=f)+    (this is Lemma (L0)), and hence this triple never plays a role in application S(f,t).+    It is always safe to extend S with such a triple.++    (NB: we could strengten K1) in this way too, but see K3.++  - (K2b): if lhs not in s, we have no further opportunity to apply the+    work item++  - (K4): See Note [K4]++* Lemma (L3). Suppose we have f* such that, for all f, f* >= f. Then+  if we are adding lhs -fw-> t (where T1, T2, and T3 hold), we will keep a -f*-> s.+  Proof. K4 holds; thus, we keep.++Key lemma to make it watertight.+  Under the conditions of the Main Theorem,+  forall f st fw >= f, a is not in S^k(f,t), for any k++Also, consider roles more carefully. See Note [Flavours with roles]++Note [K4]+~~~~~~~~~+K4 is a "keep" condition of Note [Extending the inert equalities].+Here is the scenario:++* We are considering adding (lhs -fw-> t) to the inert set S.+* S already has (lhs1 -fs-> s).+* We know S(fw, lhs) = lhs, S(fw, t) = t, and lhs is not rewritable in t.+  See Note [Rewritable]. These are (T1), (T2), and (T3).+* We further know fw >= fs. (If not, then we short-circuit via (K0).)++K4 says that we may keep lhs1 -fs-> s in S if:+  lhs1 is a tyvar AND fs >= fw++Why K4 guarantees termination:+  * If fs >= fw, we know a is not rewritable in t, because of (T2).+  * We further know lhs /= a, because of (T1).+  * Accordingly, a use of the new inert item lhs -fw-> t cannot create the conditions+    for a use of a -fs-> s (precisely because t does not mention a), and hence,+    the extended substitution (with lhs -fw-> t in it) is a terminating+    generalised substitution.++Recall that the termination generalised substitution includes only mappings that+pass an occurs check. This is (T3). At one point, we worried that the+argument here would fail if s mentioned a, but (T3) rules out this possibility.+Put another way: the terminating generalised substitution considers only the inert_eqs,+not other parts of the inert set (such as the irreds).++Can we liberalise K4? No.++Why we cannot drop the (fs >= fw) condition:+  * Suppose not (fs >= fw). It might be the case that t mentions a, and this+    can cause a loop. Example:++      Work:  [G] b ~ a+      Inert: [W] a ~ b++    (where G >= G, G >= W, and W >= W)+    If we don't kick out the inert, then we get a loop on e.g. [W] a ~ Int.++  * Note that the above example is different if the inert is a Given G, because+    (T1) won't hold.++Why we cannot drop the tyvar condition:+  * Presume fs >= fw. Thus, F tys is not rewritable in t, because of (T2).+  * Can the use of lhs -fw-> t create the conditions for a use of F tys -fs-> s?+    Yes! This can happen if t appears within tys.++    Here is an example:++      Work:  [G] a ~ Int+      Inert: [G] F Int ~ F a++    Now, if we have [W] F a ~ Bool, we will rewrite ad infinitum on the left-hand+    side. The key reason why K2b works in the tyvar case is that tyvars are atomic:+    if the right-hand side of an equality does not mention a variable a, then it+    cannot allow an equality with an LHS of a to fire. This is not the case for+    type family applications.++Bottom line: K4 can keep only inerts with tyvars on the left. Put differently,+K4 will never prevent an inert with a type family on the left from being kicked+out.++Consequence: We never kick out a Given/Nominal equality with a tyvar on the left.+This is Lemma (L3) of Note [Extending the inert equalities]. It is good because+it means we can effectively model the mutable filling of metavariables with+Given/Nominal equalities. That is: it should be the case that we could rewrite+our solver never to fill in a metavariable; instead, it would "solve" a wanted+like alpha ~ Int by turning it into a Given, allowing it to be used in rewriting.+We would want the solver to behave the same whether it uses metavariables or+Givens. And (L3) says that no Given/Nominals over tyvars are ever kicked out,+just like we never unfill a metavariable. Nice.++Getting this wrong (that is, allowing K4 to apply to situations with the type+family on the left) led to #19042. (At that point, K4 was known as K2b.)++Originally, this condition was part of K2, but #17672 suggests it should be+a top-level K condition.++Note [K3: completeness of solving]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+(K3) is not necessary for the extended substitution+to be terminating.  In fact K1 could be made stronger by saying+   ... then (not (fw >= fs) or not (fs >= fs))+But it's not enough for S to be terminating; we also want completeness.+That is, we want to be able to solve all soluble wanted equalities.+Suppose we have++   work-item   b -G-> a+   inert-item  a -W-> b++Assuming (G >= W) but not (W >= W), this fulfills all the conditions,+so we could extend the inerts, thus:++   inert-items   b -G-> a+                 a -W-> b++But if we kicked-out the inert item, we'd get++   work-item     a -W-> b+   inert-item    b -G-> a++Then rewrite the work-item gives us (a -W-> a), which is soluble via Refl.+So we add one more clause to the kick-out criteria++Another way to understand (K3) is that we treat an inert item+        a -f-> b+in the same way as+        b -f-> a+So if we kick out one, we should kick out the other.  The orientation+is somewhat accidental.++When considering roles, we also need the second clause (K3b). Consider++  work-item    c -G/N-> a+  inert-item   a -W/R-> b c++The work-item doesn't get rewritten by the inert, because (>=) doesn't hold.+But we don't kick out the inert item because not (W/R >= W/R).  So we just+add the work item. But then, consider if we hit the following:++  work-item    b -G/N-> Id+  inert-items  a -W/R-> b c+               c -G/N-> a+where+  newtype Id x = Id x++For similar reasons, if we only had (K3a), we wouldn't kick the+representational inert out. And then, we'd miss solving the inert, which+now reduced to reflexivity.++The solution here is to kick out representational inerts whenever the+lhs of a work item is "exposed", where exposed means being at the+head of the top-level application chain (lhs t1 .. tn).  See+is_can_eq_lhs_head. This is encoded in (K3b).++Beware: if we make this test succeed too often, we kick out too much,+and the solver might loop.  Consider (#14363)+  work item:   [G] a ~R f b+  inert item:  [G] b ~R f a+In GHC 8.2 the completeness tests more aggressive, and kicked out+the inert item; but no rewriting happened and there was an infinite+loop.  All we need is to have the tyvar at the head.++Note [Flavours with roles]+~~~~~~~~~~~~~~~~~~~~~~~~~~+The system described in Note [inert_eqs: the inert equalities]+discusses an abstract+set of flavours. In GHC, flavours have two components: the flavour proper,+taken from {Wanted, Given} and the equality relation (often called+role), taken from {NomEq, ReprEq}.+When substituting w.r.t. the inert set,+as described in Note [inert_eqs: the inert equalities],+we must be careful to respect all components of a flavour.+For example, if we have++  inert set: a -G/R-> Int+             b -G/R-> Bool++  type role T nominal representational++and we wish to compute S(W/R, T a b), the correct answer is T a Bool, NOT+T Int Bool. The reason is that T's first parameter has a nominal role, and+thus rewriting a to Int in T a b is wrong. Indeed, this non-congruence of+substitution means that the proof in Note [inert_eqs: the inert equalities] may+need to be revisited, but we don't think that the end conclusion is wrong.+-}++data InertCans   -- See Note [Detailed InertCans Invariants] for more+  = IC { inert_eqs :: InertEqs+              -- See Note [inert_eqs: the inert equalities]+              -- All CEqCans with a TyVarLHS; index is the LHS tyvar+              -- Domain = skolems and untouchables; a touchable would be unified++       , inert_funeqs :: FunEqMap EqualCtList+              -- All CEqCans with a TyFamLHS; index is the whole family head type.+              -- LHS is fully rewritten (modulo eqCanRewrite constraints)+              --     wrt inert_eqs+              -- Can include both [G] and [W]++       , inert_dicts :: DictMap Ct+              -- Dictionaries only+              -- All fully rewritten (modulo flavour constraints)+              --     wrt inert_eqs++       , inert_insts :: [QCInst]++       , inert_safehask :: DictMap Ct+              -- Failed dictionary resolution due to Safe Haskell overlapping+              -- instances restriction. We keep this separate from inert_dicts+              -- as it doesn't cause compilation failure, just safe inference+              -- failure.+              --+              -- ^ See Note [Safe Haskell Overlapping Instances Implementation]+              -- in GHC.Tc.Solver++       , inert_irreds :: Cts+              -- Irreducible predicates that cannot be made canonical,+              --     and which don't interact with others (e.g.  (c a))+              -- and insoluble predicates (e.g.  Int ~ Bool, or a ~ [a])++       , inert_given_eq_lvl :: TcLevel+              -- The TcLevel of the innermost implication that has a Given+              -- equality of the sort that make a unification variable untouchable+              -- (see Note [Unification preconditions] in GHC.Tc.Utils.Unify).+              -- See Note [Tracking Given equalities]++       , inert_given_eqs :: Bool+              -- True <=> The inert Givens *at this level* (tcl_tclvl)+              --          could includes at least one equality /other than/ a+              --          let-bound skolem equality.+              -- Reason: report these givens when reporting a failed equality+              -- See Note [Tracking Given equalities]+       }++type InertEqs    = DTyVarEnv EqualCtList++instance Outputable InertCans where+  ppr (IC { inert_eqs = eqs+          , inert_funeqs = funeqs+          , inert_dicts = dicts+          , inert_safehask = safehask+          , inert_irreds = irreds+          , inert_given_eq_lvl = ge_lvl+          , inert_given_eqs = given_eqs+          , inert_insts = insts })++    = braces $ vcat+      [ ppUnless (isEmptyDVarEnv eqs) $+        text "Equalities:"+          <+> pprCts (foldDVarEnv folder emptyCts eqs)+      , ppUnless (isEmptyTcAppMap funeqs) $+        text "Type-function equalities =" <+> pprCts (foldFunEqs folder funeqs emptyCts)+      , ppUnless (isEmptyTcAppMap dicts) $+        text "Dictionaries =" <+> pprCts (dictsToBag dicts)+      , ppUnless (isEmptyTcAppMap safehask) $+        text "Safe Haskell unsafe overlap =" <+> pprCts (dictsToBag safehask)+      , ppUnless (isEmptyCts irreds) $+        text "Irreds =" <+> pprCts irreds+      , ppUnless (null insts) $+        text "Given instances =" <+> vcat (map ppr insts)+      , text "Innermost given equalities =" <+> ppr ge_lvl+      , text "Given eqs at this level =" <+> ppr given_eqs+      ]+    where+      folder eqs rest = listToBag eqs `andCts` rest++{- *********************************************************************+*                                                                      *+                   Inert equalities+*                                                                      *+********************************************************************* -}++addTyEq :: InertEqs -> TcTyVar -> Ct -> InertEqs+addTyEq old_eqs tv ct+  = extendDVarEnv_C add_eq old_eqs tv [ct]+  where+    add_eq old_eqs _ = addToEqualCtList ct old_eqs++addCanFunEq :: FunEqMap EqualCtList -> TyCon -> [TcType] -> Ct+            -> FunEqMap EqualCtList+addCanFunEq old_eqs fun_tc fun_args ct+  = alterTcApp old_eqs fun_tc fun_args upd+  where+    upd (Just old_equal_ct_list) = Just $ addToEqualCtList ct old_equal_ct_list+    upd Nothing                  = Just [ct]++foldTyEqs :: (Ct -> b -> b) -> InertEqs -> b -> b+foldTyEqs k eqs z+  = foldDVarEnv (\cts z -> foldr k z cts) z eqs++findTyEqs :: InertCans -> TyVar -> [Ct]+findTyEqs icans tv = concat @Maybe (lookupDVarEnv (inert_eqs icans) tv)++delEq :: InertCans -> CanEqLHS -> TcType -> InertCans+delEq ic lhs rhs = case lhs of+    TyVarLHS tv+      -> ic { inert_eqs = alterDVarEnv upd (inert_eqs ic) tv }+    TyFamLHS tf args+      -> ic { inert_funeqs = alterTcApp (inert_funeqs ic) tf args upd }+  where+    isThisOne :: Ct -> Bool+    isThisOne (CEqCan { cc_rhs = t1 }) = tcEqTypeNoKindCheck rhs t1+    isThisOne other = pprPanic "delEq" (ppr lhs $$ ppr ic $$ ppr other)++    upd :: Maybe EqualCtList -> Maybe EqualCtList+    upd (Just eq_ct_list) = filterEqualCtList (not . isThisOne) eq_ct_list+    upd Nothing           = Nothing++findEq :: InertCans -> CanEqLHS -> [Ct]+findEq icans (TyVarLHS tv) = findTyEqs icans tv+findEq icans (TyFamLHS fun_tc fun_args)+  = concat @Maybe (findFunEq (inert_funeqs icans) fun_tc fun_args)++{-# INLINE partition_eqs_container #-}+partition_eqs_container+  :: forall container+   . container    -- empty container+  -> (forall b. (EqualCtList -> b -> b) -> b -> container -> b) -- folder+  -> (container -> CanEqLHS -> EqualCtList -> container)  -- extender+  -> (Ct -> Bool)+  -> container+  -> ([Ct], container)+partition_eqs_container empty_container fold_container extend_container pred orig_inerts+  = fold_container folder ([], empty_container) orig_inerts+  where+    folder :: EqualCtList -> ([Ct], container) -> ([Ct], container)+    folder eqs (acc_true, acc_false)+      = (eqs_true ++ acc_true, acc_false')+      where+        (eqs_true, eqs_false) = partition pred eqs++        acc_false'+          | CEqCan { cc_lhs = lhs } : _ <- eqs_false+          = extend_container acc_false lhs eqs_false+          | otherwise+          = acc_false++partitionInertEqs :: (Ct -> Bool)   -- Ct will always be a CEqCan with a TyVarLHS+                  -> InertEqs+                  -> ([Ct], InertEqs)+partitionInertEqs = partition_eqs_container emptyDVarEnv foldDVarEnv extendInertEqs++-- precondition: CanEqLHS is a TyVarLHS+extendInertEqs :: InertEqs -> CanEqLHS -> EqualCtList -> InertEqs+extendInertEqs eqs (TyVarLHS tv) new_eqs = extendDVarEnv eqs tv new_eqs+extendInertEqs _ other _ = pprPanic "extendInertEqs" (ppr other)++partitionFunEqs :: (Ct -> Bool)    -- Ct will always be a CEqCan with a TyFamLHS+                -> FunEqMap EqualCtList+                -> ([Ct], FunEqMap EqualCtList)+partitionFunEqs+  = partition_eqs_container emptyFunEqs (\ f z eqs -> foldFunEqs f eqs z) extendFunEqs++-- precondition: CanEqLHS is a TyFamLHS+extendFunEqs :: FunEqMap EqualCtList -> CanEqLHS -> EqualCtList -> FunEqMap EqualCtList+extendFunEqs eqs (TyFamLHS tf args) new_eqs = insertTcApp eqs tf args new_eqs+extendFunEqs _ other _ = pprPanic "extendFunEqs" (ppr other)++{- *********************************************************************+*                                                                      *+                Adding to and removing from the inert set+*                                                                      *+*                                                                      *+********************************************************************* -}++addInertItem :: TcLevel -> InertCans -> Ct -> InertCans+addInertItem tc_lvl+             ics@(IC { inert_funeqs = funeqs, inert_eqs = eqs })+             item@(CEqCan { cc_lhs = lhs })+  = updateGivenEqs tc_lvl item $+    case lhs of+       TyFamLHS tc tys -> ics { inert_funeqs = addCanFunEq funeqs tc tys item }+       TyVarLHS tv     -> ics { inert_eqs    = addTyEq eqs tv item }++addInertItem tc_lvl ics@(IC { inert_irreds = irreds }) item@(CIrredCan {})+  = updateGivenEqs tc_lvl item $   -- An Irred might turn out to be an+                                 -- equality, so we play safe+    ics { inert_irreds = irreds `snocBag` item }++addInertItem _ ics item@(CDictCan { cc_class = cls, cc_tyargs = tys })+  = ics { inert_dicts = addDict (inert_dicts ics) cls tys item }++addInertItem _ _ item+  = pprPanic "upd_inert set: can't happen! Inserting " $+    ppr item   -- Can't be CNonCanonical because they only land in inert_irreds++updateGivenEqs :: TcLevel -> Ct -> InertCans -> InertCans+-- Set the inert_given_eq_level to the current level (tclvl)+-- if the constraint is a given equality that should prevent+-- filling in an outer unification variable.+-- See Note [Tracking Given equalities]+updateGivenEqs tclvl ct inerts@(IC { inert_given_eq_lvl = ge_lvl })+  | not (isGivenCt ct) = inerts+  | not_equality ct    = inerts -- See Note [Let-bound skolems]+  | otherwise          = inerts { inert_given_eq_lvl = ge_lvl'+                                , inert_given_eqs    = True }+  where+    ge_lvl' | mentionsOuterVar tclvl (ctEvidence ct)+              -- Includes things like (c a), which *might* be an equality+            = tclvl+            | otherwise+            = ge_lvl++    not_equality :: Ct -> Bool+    -- True <=> definitely not an equality of any kind+    --          except for a let-bound skolem, which doesn't count+    --          See Note [Let-bound skolems]+    -- NB: no need to spot the boxed CDictCan (a ~ b) because its+    --     superclass (a ~# b) will be a CEqCan+    not_equality (CEqCan { cc_lhs = TyVarLHS tv }) = not (isOuterTyVar tclvl tv)+    not_equality (CDictCan {})                     = True+    not_equality _                                 = False++kickOutRewritableLHS :: CtFlavourRole  -- Flavour/role of the equality that+                                       -- is being added to the inert set+                     -> CanEqLHS       -- The new equality is lhs ~ ty+                     -> InertCans+                     -> (WorkList, InertCans)+-- See Note [kickOutRewritable]+kickOutRewritableLHS new_fr new_lhs+                     ics@(IC { inert_eqs      = tv_eqs+                             , inert_dicts    = dictmap+                             , inert_funeqs   = funeqmap+                             , inert_irreds   = irreds+                             , inert_insts    = old_insts })+  = (kicked_out, inert_cans_in)+  where+    -- inert_safehask stays unchanged; is that right?+    inert_cans_in = ics { inert_eqs      = tv_eqs_in+                        , inert_dicts    = dicts_in+                        , inert_funeqs   = feqs_in+                        , inert_irreds   = irs_in+                        , inert_insts    = insts_in }++    kicked_out :: WorkList+    -- NB: use extendWorkList to ensure that kicked-out equalities get priority+    -- See Note [Prioritise equalities] (Kick-out).+    -- The irreds may include non-canonical (hetero-kinded) equality+    -- constraints, which perhaps may have become soluble after new_lhs+    -- is substituted; ditto the dictionaries, which may include (a~b)+    -- or (a~~b) constraints.+    kicked_out = foldr extendWorkListCt+                          (emptyWorkList { wl_eqs = tv_eqs_out ++ feqs_out })+                          ((dicts_out `andCts` irs_out)+                            `extendCtsList` insts_out)++    (tv_eqs_out, tv_eqs_in) = partitionInertEqs kick_out_eq tv_eqs+    (feqs_out,   feqs_in)   = partitionFunEqs   kick_out_eq funeqmap+    (dicts_out,  dicts_in)  = partitionDicts    kick_out_ct dictmap+    (irs_out,    irs_in)    = partitionBag      kick_out_ct irreds+      -- Kick out even insolubles: See Note [Rewrite insolubles]+      -- Of course we must kick out irreducibles like (c a), in case+      -- we can rewrite 'c' to something more useful++    -- Kick-out for inert instances+    -- See Note [Quantified constraints] in GHC.Tc.Solver.Canonical+    insts_out :: [Ct]+    insts_in  :: [QCInst]+    (insts_out, insts_in)+       | fr_may_rewrite (Given, NomEq)  -- All the insts are Givens+       = partitionWith kick_out_qci old_insts+       | otherwise+       = ([], old_insts)+    kick_out_qci qci+      | let ev = qci_ev qci+      , fr_can_rewrite_ty NomEq (ctEvPred (qci_ev qci))+      = Left (mkNonCanonical ev)+      | otherwise+      = Right qci++    (_, new_role) = new_fr++    fr_tv_can_rewrite_ty :: TyVar -> EqRel -> Type -> Bool+    fr_tv_can_rewrite_ty new_tv role ty+      = anyRewritableTyVar role can_rewrite ty+      where+        can_rewrite :: EqRel -> TyVar -> Bool+        can_rewrite old_role tv = new_role `eqCanRewrite` old_role && tv == new_tv++    fr_tf_can_rewrite_ty :: TyCon -> [TcType] -> EqRel -> Type -> Bool+    fr_tf_can_rewrite_ty new_tf new_tf_args role ty+      = anyRewritableTyFamApp role can_rewrite ty+      where+        can_rewrite :: EqRel -> TyCon -> [TcType] -> Bool+        can_rewrite old_role old_tf old_tf_args+          = new_role `eqCanRewrite` old_role &&+            tcEqTyConApps new_tf new_tf_args old_tf old_tf_args+              -- it's possible for old_tf_args to have too many. This is fine;+              -- we'll only check what we need to.++    {-# INLINE fr_can_rewrite_ty #-}   -- perform the check here only once+    fr_can_rewrite_ty :: EqRel -> Type -> Bool+    fr_can_rewrite_ty = case new_lhs of+      TyVarLHS new_tv             -> fr_tv_can_rewrite_ty new_tv+      TyFamLHS new_tf new_tf_args -> fr_tf_can_rewrite_ty new_tf new_tf_args++    fr_may_rewrite :: CtFlavourRole -> Bool+    fr_may_rewrite fs = new_fr `eqCanRewriteFR` fs+        -- Can the new item rewrite the inert item?++    {-# INLINE kick_out_ct #-}   -- perform case on new_lhs here only once+    kick_out_ct :: Ct -> Bool+    -- Kick it out if the new CEqCan can rewrite the inert one+    -- See Note [kickOutRewritable]+    kick_out_ct = case new_lhs of+      TyVarLHS new_tv -> \ct -> let fs@(_,role) = ctFlavourRole ct in+                                fr_may_rewrite fs+                             && fr_tv_can_rewrite_ty new_tv role (ctPred ct)+      TyFamLHS new_tf new_tf_args+        -> \ct -> let fs@(_, role) = ctFlavourRole ct in+                  fr_may_rewrite fs+               && fr_tf_can_rewrite_ty new_tf new_tf_args role (ctPred ct)++    -- Implements criteria K1-K3 in Note [Extending the inert equalities]+    kick_out_eq :: Ct -> Bool+    kick_out_eq (CEqCan { cc_lhs = lhs, cc_rhs = rhs_ty+                        , cc_ev = ev, cc_eq_rel = eq_rel })+      | not (fr_may_rewrite fs)+      = False  -- (K0) Keep it in the inert set if the new thing can't rewrite it++      -- Below here (fr_may_rewrite fs) is True++      | TyVarLHS _ <- lhs+      , fs `eqCanRewriteFR` new_fr+      = False  -- (K4) Keep it in the inert set if the LHS is a tyvar and+               -- it can rewrite the work item. See Note [K4]++      | fr_can_rewrite_ty eq_rel (canEqLHSType lhs)+      = True   -- (K1)+         -- The above check redundantly checks the role & flavour,+         -- but it's very convenient++      | kick_out_for_inertness    = True   -- (K2)+      | kick_out_for_completeness = True   -- (K3)+      | otherwise                 = False++      where+        fs = (ctEvFlavour ev, eq_rel)+        kick_out_for_inertness+          =    (fs `eqCanRewriteFR` fs)           -- (K2a)+            && fr_can_rewrite_ty eq_rel rhs_ty    -- (K2b)++        kick_out_for_completeness  -- (K3) and Note [K3: completeness of solving]+          = case eq_rel of+              NomEq  -> rhs_ty `eqType` canEqLHSType new_lhs -- (K3a)+              ReprEq -> is_can_eq_lhs_head new_lhs rhs_ty    -- (K3b)++    kick_out_eq ct = pprPanic "kick_out_eq" (ppr ct)++    is_can_eq_lhs_head (TyVarLHS tv) = go+      where+        go (Rep.TyVarTy tv')   = tv == tv'+        go (Rep.AppTy fun _)   = go fun+        go (Rep.CastTy ty _)   = go ty+        go (Rep.TyConApp {})   = False+        go (Rep.LitTy {})      = False+        go (Rep.ForAllTy {})   = False+        go (Rep.FunTy {})      = False+        go (Rep.CoercionTy {}) = False+    is_can_eq_lhs_head (TyFamLHS fun_tc fun_args) = go+      where+        go (Rep.TyVarTy {})       = False+        go (Rep.AppTy {})         = False  -- no TyConApp to the left of an AppTy+        go (Rep.CastTy ty _)      = go ty+        go (Rep.TyConApp tc args) = tcEqTyConApps fun_tc fun_args tc args+        go (Rep.LitTy {})         = False+        go (Rep.ForAllTy {})      = False+        go (Rep.FunTy {})         = False+        go (Rep.CoercionTy {})    = False++{- Note [kickOutRewritable]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+See also Note [inert_eqs: the inert equalities].++When we add a new inert equality (lhs ~N ty) to the inert set,+we must kick out any inert items that could be rewritten by the+new equality, to maintain the inert-set invariants.++  - We want to kick out an existing inert constraint if+    a) the new constraint can rewrite the inert one+    b) 'lhs' is free in the inert constraint (so that it *will*)+       rewrite it if we kick it out.++    For (b) we use anyRewritableCanLHS, which examines the types /and+    kinds/ that are directly visible in the type. Hence+    we will have exposed all the rewriting we care about to make the+    most precise kinds visible for matching classes etc. No need to+    kick out constraints that mention type variables whose kinds+    contain this LHS!++  - We don't kick out constraints from inert_solved_dicts, and+    inert_solved_funeqs optimistically. But when we lookup we have to+    take the substitution into account++NB: we could in principle avoid kick-out:+  a) When unifying a meta-tyvar from an outer level, because+     then the entire implication will be iterated; see+     Note [The Unification Level Flag] in GHC.Tc.Solver.Monad.++  b) For Givens, after a unification.  By (GivenInv) in GHC.Tc.Utils.TcType+     Note [TcLevel invariants], a Given can't include a meta-tyvar from+     its own level, so it falls under (a).  Of course, we must still+     kick out Givens when adding a new non-unification Given.++But kicking out more vigorously may lead to earlier unification and fewer+iterations, so we don't take advantage of these possibilities.++Note [Rewrite insolubles]+~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have an insoluble alpha ~ [alpha], which is insoluble+because an occurs check.  And then we unify alpha := [Int].  Then we+really want to rewrite the insoluble to [Int] ~ [[Int]].  Now it can+be decomposed.  Otherwise we end up with a "Can't match [Int] ~+[[Int]]" which is true, but a bit confusing because the outer type+constructors match.++Hence:+ * In the main simplifier loops in GHC.Tc.Solver (solveWanteds,+   simpl_loop), we feed the insolubles in solveSimpleWanteds,+   so that they get rewritten (albeit not solved).++ * We kick insolubles out of the inert set, if they can be+   rewritten (see GHC.Tc.Solver.Monad.kick_out_rewritable)++ * We rewrite those insolubles in GHC.Tc.Solver.Canonical.+   See Note [Make sure that insolubles are fully rewritten]+   in GHC.Tc.Solver.Canonical.+-}++{- *********************************************************************+*                                                                      *+                 Queries+*                                                                      *+*                                                                      *+********************************************************************* -}++mentionsOuterVar :: TcLevel -> CtEvidence -> Bool+mentionsOuterVar tclvl ev+  = anyFreeVarsOfType (isOuterTyVar tclvl) $+    ctEvPred ev++isOuterTyVar :: TcLevel -> TyCoVar -> Bool+-- True of a type variable that comes from a+-- shallower level than the ambient level (tclvl)+isOuterTyVar tclvl tv+  | isTyVar tv = assertPpr (not (isTouchableMetaTyVar tclvl tv)) (ppr tv <+> ppr tclvl) $+                 tclvl `strictlyDeeperThan` tcTyVarLevel tv+    -- ASSERT: we are dealing with Givens here, and invariant (GivenInv) from+    -- Note Note [TcLevel invariants] in GHC.Tc.Utils.TcType ensures that there can't+    -- be a touchable meta tyvar.   If this wasn't true, you might worry that,+    -- at level 3, a meta-tv alpha[3] gets unified with skolem b[2], and thereby+    -- becomes "outer" even though its level numbers says it isn't.+  | otherwise  = False  -- Coercion variables; doesn't much matter++-- | Returns Given constraints that might,+-- potentially, match the given pred. This is used when checking to see if a+-- Given might overlap with an instance. See Note [Instance and Given overlap]+-- in "GHC.Tc.Solver.Interact"+matchableGivens :: CtLoc -> PredType -> InertSet -> Cts+matchableGivens loc_w pred_w inerts@(IS { inert_cans = inert_cans })+  = filterBag matchable_given all_relevant_givens+  where+    -- just look in class constraints and irreds. matchableGivens does get called+    -- for ~R constraints, but we don't need to look through equalities, because+    -- canonical equalities are used for rewriting. We'll only get caught by+    -- non-canonical -- that is, irreducible -- equalities.+    all_relevant_givens :: Cts+    all_relevant_givens+      | Just (clas, _) <- getClassPredTys_maybe pred_w+      = findDictsByClass (inert_dicts inert_cans) clas+        `unionBags` inert_irreds inert_cans+      | otherwise+      = inert_irreds inert_cans++    matchable_given :: Ct -> Bool+    matchable_given ct+      | CtGiven { ctev_loc = loc_g, ctev_pred = pred_g } <- ctEvidence ct+      = mightEqualLater inerts pred_g loc_g pred_w loc_w++      | otherwise+      = False++mightEqualLater :: InertSet -> TcPredType -> CtLoc -> TcPredType -> CtLoc -> Bool+-- See Note [What might equal later?]+-- Used to implement logic in Note [Instance and Given overlap] in GHC.Tc.Solver.Interact+mightEqualLater inert_set given_pred given_loc wanted_pred wanted_loc+  | prohibitedSuperClassSolve given_loc wanted_loc+  = False++  | otherwise+  = case tcUnifyTysFG bind_fun [flattened_given] [flattened_wanted] of+      SurelyApart              -> False  -- types that are surely apart do not equal later+      MaybeApart MARInfinite _ -> False  -- see Example 7 in the Note.+      _                        -> True++  where+    in_scope  = mkInScopeSet $ tyCoVarsOfTypes [given_pred, wanted_pred]++    -- NB: flatten both at the same time, so that we can share mappings+    -- from type family applications to variables, and also to guarantee+    -- that the fresh variables are really fresh between the given and+    -- the wanted. Flattening both at the same time is needed to get+    -- Example 10 from the Note.+    ([flattened_given, flattened_wanted], var_mapping)+      = flattenTysX in_scope [given_pred, wanted_pred]++    bind_fun :: BindFun+    bind_fun tv rhs_ty+      | isMetaTyVar tv+      , can_unify tv (metaTyVarInfo tv) rhs_ty+         -- this checks for CycleBreakerTvs and TyVarTvs; forgetting+         -- the latter was #19106.+      = BindMe++         -- See Examples 4, 5, and 6 from the Note+      | Just (_fam_tc, fam_args) <- lookupVarEnv var_mapping tv+      , anyFreeVarsOfTypes mentions_meta_ty_var fam_args+      = BindMe++      | otherwise+      = Apart++    -- True for TauTv and TyVarTv (and RuntimeUnkTv) meta-tyvars+    -- (as they can be unified)+    -- and also for CycleBreakerTvs that mentions meta-tyvars+    mentions_meta_ty_var :: TyVar -> Bool+    mentions_meta_ty_var tv+      | isMetaTyVar tv+      = case metaTyVarInfo tv of+          -- See Examples 8 and 9 in the Note+          CycleBreakerTv+            -> anyFreeVarsOfType mentions_meta_ty_var+                 (lookupCycleBreakerVar tv inert_set)+          _ -> True+      | otherwise+      = False++    -- like startSolvingByUnification, but allows cbv variables to unify+    can_unify :: TcTyVar -> MetaInfo -> Type -> Bool+    can_unify _lhs_tv TyVarTv rhs_ty  -- see Example 3 from the Note+      | Just rhs_tv <- tcGetTyVar_maybe rhs_ty+      = case tcTyVarDetails rhs_tv of+          MetaTv { mtv_info = TyVarTv } -> True+          MetaTv {}                     -> False  -- could unify with anything+          SkolemTv {}                   -> True+          RuntimeUnk                    -> True+      | otherwise  -- not a var on the RHS+      = False+    can_unify lhs_tv _other _rhs_ty = mentions_meta_ty_var lhs_tv++prohibitedSuperClassSolve :: CtLoc -> CtLoc -> Bool+-- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance+prohibitedSuperClassSolve from_loc solve_loc+  | InstSCOrigin _ given_size <- ctLocOrigin from_loc+  , ScOrigin wanted_size <- ctLocOrigin solve_loc+  = given_size >= wanted_size+  | otherwise+  = False++{- Note [What might equal later?]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We must determine whether a Given might later equal a Wanted. We+definitely need to account for the possibility that any metavariable+might be arbitrarily instantiated. Yet we do *not* want+to allow skolems in to be instantiated, as we've already rewritten+with respect to any Givens. (We're solving a Wanted here, and so+all Givens have already been processed.)++This is best understood by example.++1. C alpha  ~?  C Int++   That given certainly might match later.++2. C a  ~?  C Int++   No. No new givens are going to arise that will get the `a` to rewrite+   to Int.++3. C alpha[tv]   ~?  C Int++   That alpha[tv] is a TyVarTv, unifiable only with other type variables.+   It cannot equal later.++4. C (F alpha)   ~?   C Int++   Sure -- that can equal later, if we learn something useful about alpha.++5. C (F alpha[tv])  ~?  C Int++   This, too, might equal later. Perhaps we have [G] F b ~ Int elsewhere.+   Or maybe we have C (F alpha[tv] beta[tv]), these unify with each other,+   and F x x = Int. Remember: returning True doesn't commit ourselves to+   anything.++6. C (F a)  ~?  C a++   No, this won't match later. If we could rewrite (F a) or a, we would+   have by now. But see also Red Herring below.++7. C (Maybe alpha)  ~?  C alpha++   We say this cannot equal later, because it would require+   alpha := Maybe (Maybe (Maybe ...)). While such a type can be contrived,+   we choose not to worry about it. See Note [Infinitary substitution in lookup]+   in GHC.Core.InstEnv. Getting this wrong let to #19107, tested in+   typecheck/should_compile/T19107.++8. C cbv   ~?  C Int+   where cbv = F a++   The cbv is a cycle-breaker var which stands for F a. See+   Note [Type equality cycles] in GHC.Tc.Solver.Canonical.+   This is just like case 6, and we say "no". Saying "no" here is+   essential in getting the parser to type-check, with its use of DisambECP.++9. C cbv   ~?   C Int+   where cbv = F alpha++   Here, we might indeed equal later. Distinguishing between+   this case and Example 8 is why we need the InertSet in mightEqualLater.++10. C (F alpha, Int)  ~?  C (Bool, F alpha)++   This cannot equal later, because F a would have to equal both Bool and+   Int.++To deal with type family applications, we use the Core flattener. See+Note [Flattening type-family applications when matching instances] in GHC.Core.Unify.+The Core flattener replaces all type family applications with+fresh variables. The next question: should we allow these fresh+variables in the domain of a unifying substitution?++A type family application that mentions only skolems (example 6) is settled:+any skolems would have been rewritten w.r.t. Givens by now. These type family+applications match only themselves. A type family application that mentions+metavariables, on the other hand, can match anything. So, if the original type+family application contains a metavariable, we use BindMe to tell the unifier+to allow it in the substitution. On the other hand, a type family application+with only skolems is considered rigid.++This treatment fixes #18910 and is tested in+typecheck/should_compile/InstanceGivenOverlap{,2}++Red Herring+~~~~~~~~~~~+In #21208, we have this scenario:++instance forall b. C b+[G] C a[sk]+[W] C (F a[sk])++What should we do with that wanted? According to the logic above, the Given+cannot match later (this is example 6), and so we use the global instance.+But wait, you say: What if we learn later (say by a future type instance F a = a)+that F a unifies with a? That looks like the Given might really match later!++This mechanism described in this Note is *not* about this kind of situation, however.+It is all asking whether a Given might match the Wanted *in this run of the solver*.+It is *not* about whether a variable might be instantiated so that the Given matches,+or whether a type instance introduced in a downstream module might make the Given match.+The reason we care about what might match later is only about avoiding order-dependence.+That is, we don't want to commit to a course of action that depends on seeing constraints+in a certain order. But an instantiation of a variable and a later type instance+don't introduce order dependency in this way, and so mightMatchLater is right to ignore+these possibilities.++Here is an example, with no type families, that is perhaps clearer:++instance forall b. C (Maybe b)+[G] C (Maybe Int)+[W] C (Maybe a)++What to do? We *might* say that the Given could match later and should thus block+us from using the global instance. But we don't do this. Instead, we rely on class+coherence to say that choosing the global instance is just fine, even if later we+call a function with (a := Int). After all, in this run of the solver, [G] C (Maybe Int)+will definitely never match [W] C (Maybe a). (Recall that we process Givens before+Wanteds, so there is no [G] a ~ Int hanging about unseen.)++Interestingly, in the first case (from #21208), the behavior changed between+GHC 8.10.7 and GHC 9.2, with the latter behaving correctly and the former+reporting overlapping instances.++Test case: typecheck/should_compile/T21208.++-}++{- *********************************************************************+*                                                                      *+    Cycle breakers+*                                                                      *+********************************************************************* -}++-- | Return the type family application a CycleBreakerTv maps to.+lookupCycleBreakerVar :: TcTyVar    -- ^ cbv, must be a CycleBreakerTv+                      -> InertSet+                      -> TcType     -- ^ type family application the cbv maps to+lookupCycleBreakerVar cbv (IS { inert_cycle_breakers = cbvs_stack })+-- This function looks at every environment in the stack. This is necessary+-- to avoid #20231. This function (and its one usage site) is the only reason+-- that we store a stack instead of just the top environment.+  | Just tyfam_app <- assert (isCycleBreakerTyVar cbv) $+                      firstJusts (NE.map (lookup cbv) cbvs_stack)+  = tyfam_app+  | otherwise+  = pprPanic "lookupCycleBreakerVar found an unbound cycle breaker" (ppr cbv $$ ppr cbvs_stack)++-- | Push a fresh environment onto the cycle-breaker var stack. Useful+-- when entering a nested implication.+pushCycleBreakerVarStack :: CycleBreakerVarStack -> CycleBreakerVarStack+pushCycleBreakerVarStack = ([] <|)++-- | Add a new cycle-breaker binding to the top environment on the stack.+insertCycleBreakerBinding :: TcTyVar   -- ^ cbv, must be a CycleBreakerTv+                          -> TcType    -- ^ cbv's expansion+                          -> CycleBreakerVarStack -> CycleBreakerVarStack+insertCycleBreakerBinding cbv expansion (top_env :| rest_envs)+  = assert (isCycleBreakerTyVar cbv) $+    ((cbv, expansion) : top_env) :| rest_envs++-- | Perform a monadic operation on all pairs in the top environment+-- in the stack.+forAllCycleBreakerBindings_ :: Monad m+                            => CycleBreakerVarStack+                            -> (TcTyVar -> TcType -> m ()) -> m ()+forAllCycleBreakerBindings_ (top_env :| _rest_envs) action+  = forM_ top_env (uncurry action)+{-# INLINABLE forAllCycleBreakerBindings_ #-}  -- to allow SPECIALISE later
GHC/Tc/Solver/Interact.hs view
@@ -1,15 +1,12 @@-{-# LANGUAGE CPP #-}  {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}  module GHC.Tc.Solver.Interact (      solveSimpleGivens,   -- Solves [Ct]-     solveSimpleWanteds,  -- Solves Cts+     solveSimpleWanteds   -- Solves Cts   ) where -#include "HsVersions.h"- import GHC.Prelude import GHC.Types.Basic ( SwapFlag(..),                          infinity, IntWithInf, intGtLimit )@@ -19,6 +16,7 @@ import GHC.Core.InstEnv         ( DFunInstType )  import GHC.Types.Var+import GHC.Tc.Errors.Types import GHC.Tc.Utils.TcType import GHC.Builtin.Names ( coercibleTyConKey, heqTyConKey, eqTyConKey, ipClassKey ) import GHC.Core.Coercion.Axiom ( CoAxBranch (..), CoAxiom (..), TypeEqn, fromBranches, sfInteractInert, sfInteractTop )@@ -39,22 +37,25 @@ import GHC.Core.Predicate import GHC.Tc.Types.Origin import GHC.Tc.Utils.TcMType( promoteMetaTyVarTo )+import GHC.Tc.Solver.Types+import GHC.Tc.Solver.InertSet import GHC.Tc.Solver.Monad import GHC.Data.Bag import GHC.Utils.Monad ( concatMapM, foldlM )  import GHC.Core-import Data.List( partition, deleteFirstsBy )+import Data.List( deleteFirstsBy )+import Data.Function ( on ) import GHC.Types.SrcLoc import GHC.Types.Var.Env +import qualified Data.Semigroup as S import Control.Monad import GHC.Data.Pair (Pair(..)) import GHC.Types.Unique( hasKey ) import GHC.Driver.Session import GHC.Utils.Misc import qualified GHC.LanguageExtensions as LangExt-import Data.List.NonEmpty ( NonEmpty(..) )  import Control.Monad.Trans.Class import Control.Monad.Trans.Maybe@@ -118,12 +119,7 @@     go :: Int -> IntWithInf -> WantedConstraints -> TcS (Int, WantedConstraints)     go n limit wc       | n `intGtLimit` limit-      = failTcS (hang (text "solveSimpleWanteds: too many iterations"-                       <+> parens (text "limit =" <+> ppr limit))-                    2 (vcat [ text "Set limit with -fconstraint-solver-iterations=n; n=0 for no limit"-                            , text "Simples =" <+> ppr simples-                            , text "WC ="      <+> ppr wc ]))-+      = failTcS $ TcRnSimplifierTooManyIterations simples limit wc      | isEmptyBag (wc_simple wc)      = return (n,wc) @@ -144,13 +140,13 @@ -- Try solving these constraints -- Affects the unification state (of course) but not the inert set -- The result is not necessarily zonked-solve_simple_wanteds (WC { wc_simple = simples1, wc_impl = implics1, wc_holes = holes })+solve_simple_wanteds (WC { wc_simple = simples1, wc_impl = implics1, wc_errors = errs })   = nestTcS $     do { solveSimples simples1        ; (implics2, unsolved) <- getUnsolvedInerts        ; return (WC { wc_simple = unsolved                     , wc_impl   = implics1 `unionBags` implics2-                    , wc_holes  = holes }) }+                    , wc_errors = errs }) }  {- Note [The solveSimpleWanteds loop] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -187,13 +183,13 @@ -- into the main solver. runTcPluginsGiven :: TcS [Ct] runTcPluginsGiven-  = do { plugins <- getTcPlugins-       ; if null plugins then return [] else+  = do { solvers <- getTcPluginSolvers+       ; if null solvers then return [] else     do { givens <- getInertGivens        ; if null givens then return [] else-    do { p <- runTcPlugins plugins (givens,[],[])-       ; let (solved_givens, _, _) = pluginSolvedCts p-             insols                = pluginBadCts p+    do { p <- runTcPluginSolvers solvers (givens,[])+       ; let (solved_givens, _) = pluginSolvedCts p+             insols             = pluginBadCts p        ; updInertCans (removeInertCts solved_givens)        ; updInertIrreds (\irreds -> extendCtsList irreds insols)        ; return (pluginNewCts p) } } }@@ -208,26 +204,24 @@   | isEmptyBag simples1   = return (False, wc)   | otherwise-  = do { plugins <- getTcPlugins-       ; if null plugins then return (False, wc) else+  = do { solvers <- getTcPluginSolvers+       ; if null solvers then return (False, wc) else      do { given <- getInertGivens-       ; simples1 <- zonkSimples simples1    -- Plugin requires zonked inputs-       ; let (wanted, derived) = partition isWantedCt (bagToList simples1)-       ; p <- runTcPlugins plugins (given, derived, wanted)-       ; let (_, _,                solved_wanted)   = pluginSolvedCts p-             (_, unsolved_derived, unsolved_wanted) = pluginInputCts p+       ; wanted <- zonkSimples simples1    -- Plugin requires zonked inputs+       ; p <- runTcPluginSolvers solvers (given, bagToList wanted)+       ; let (_, solved_wanted)   = pluginSolvedCts p+             (_, unsolved_wanted) = pluginInputCts p              new_wanted                             = pluginNewCts p              insols                                 = pluginBadCts p  -- SLPJ: I'm deeply suspicious of this---       ; updInertCans (removeInertCts $ solved_givens ++ solved_deriveds)+--       ; updInertCans (removeInertCts $ solved_givens)         ; mapM_ setEv solved_wanted        ; return ( notNull (pluginNewCts p)                 , wc { wc_simple = listToBag new_wanted       `andCts`                                    listToBag unsolved_wanted  `andCts`-                                   listToBag unsolved_derived `andCts`                                    listToBag insols } ) } }   where     setEv :: (EvTerm,Ct) -> TcS ()@@ -235,11 +229,11 @@       CtWanted { ctev_dest = dest } -> setWantedEvTerm dest ev       _ -> panic "runTcPluginsWanted.setEv: attempt to solve non-wanted!" --- | A triple of (given, derived, wanted) constraints to pass to plugins-type SplitCts  = ([Ct], [Ct], [Ct])+-- | A pair of (given, wanted) constraints to pass to plugins+type SplitCts  = ([Ct], [Ct]) --- | A solved triple of constraints, with evidence for wanteds-type SolvedCts = ([Ct], [Ct], [(EvTerm,Ct)])+-- | A solved pair of constraints, with evidence for wanteds+type SolvedCts = ([Ct], [(EvTerm,Ct)])  -- | Represents collections of constraints generated by typechecker -- plugins@@ -255,11 +249,12 @@       -- ^ New constraints emitted by plugins     } -getTcPlugins :: TcS [TcPluginSolver]-getTcPlugins = do { tcg_env <- getGblEnv; return (tcg_tc_plugins tcg_env) }+getTcPluginSolvers :: TcS [TcPluginSolver]+getTcPluginSolvers+  = do { tcg_env <- getGblEnv; return (tcg_tc_plugin_solvers tcg_env) } --- | Starting from a triple of (given, derived, wanted) constraints,--- invoke each of the typechecker plugins in turn and return+-- | Starting from a pair of (given, wanted) constraints,+-- invoke each of the typechecker constraint-solving plugins in turn and return -- --  * the remaining unmodified constraints, --  * constraints that have been solved,@@ -271,31 +266,35 @@ -- re-invoked and they will see it later).  There is no check that new -- work differs from the original constraints supplied to the plugin: -- the plugin itself should perform this check if necessary.-runTcPlugins :: [TcPluginSolver] -> SplitCts -> TcS TcPluginProgress-runTcPlugins plugins all_cts-  = foldM do_plugin initialProgress plugins+runTcPluginSolvers :: [TcPluginSolver] -> SplitCts -> TcS TcPluginProgress+runTcPluginSolvers solvers all_cts+  = do { ev_binds_var <- getTcEvBindsVar+       ; foldM (do_plugin ev_binds_var) initialProgress solvers }   where-    do_plugin :: TcPluginProgress -> TcPluginSolver -> TcS TcPluginProgress-    do_plugin p solver = do-        result <- runTcPluginTcS (uncurry3 solver (pluginInputCts p))+    do_plugin :: EvBindsVar -> TcPluginProgress -> TcPluginSolver -> TcS TcPluginProgress+    do_plugin ev_binds_var p solver = do+        result <- runTcPluginTcS (uncurry (solver ev_binds_var) (pluginInputCts p))         return $ progress p result -    progress :: TcPluginProgress -> TcPluginResult -> TcPluginProgress-    progress p (TcPluginContradiction bad_cts) =-       p { pluginInputCts = discard bad_cts (pluginInputCts p)-         , pluginBadCts   = bad_cts ++ pluginBadCts p-         }-    progress p (TcPluginOk solved_cts new_cts) =-      p { pluginInputCts  = discard (map snd solved_cts) (pluginInputCts p)-        , pluginSolvedCts = add solved_cts (pluginSolvedCts p)-        , pluginNewCts    = new_cts ++ pluginNewCts p+    progress :: TcPluginProgress -> TcPluginSolveResult -> TcPluginProgress+    progress p+      (TcPluginSolveResult+        { tcPluginInsolubleCts = bad_cts+        , tcPluginSolvedCts    = solved_cts+        , tcPluginNewCts       = new_cts         }+      ) =+        p { pluginInputCts  = discard (bad_cts ++ map snd solved_cts) (pluginInputCts p)+          , pluginSolvedCts = add solved_cts (pluginSolvedCts p)+          , pluginNewCts    = new_cts ++ pluginNewCts p+          , pluginBadCts    = bad_cts ++ pluginBadCts p+          } -    initialProgress = TcPluginProgress all_cts ([], [], []) [] []+    initialProgress = TcPluginProgress all_cts ([], []) [] []      discard :: [Ct] -> SplitCts -> SplitCts-    discard cts (xs, ys, zs) =-        (xs `without` cts, ys `without` cts, zs `without` cts)+    discard cts (xs, ys) =+        (xs `without` cts, ys `without` cts)      without :: [Ct] -> [Ct] -> [Ct]     without = deleteFirstsBy eqCt@@ -308,10 +307,9 @@     add xs scs = foldl' addOne scs xs      addOne :: SolvedCts -> (EvTerm,Ct) -> SolvedCts-    addOne (givens, deriveds, wanteds) (ev,ct) = case ctEvidence ct of-      CtGiven  {} -> (ct:givens, deriveds, wanteds)-      CtDerived{} -> (givens, ct:deriveds, wanteds)-      CtWanted {} -> (givens, deriveds, (ev,ct):wanteds)+    addOne (givens, wanteds) (ev,ct) = case ctEvidence ct of+      CtGiven  {} -> (ct:givens, wanteds)+      CtWanted {} -> (givens, (ev,ct):wanteds)   type WorkItem = Ct@@ -414,7 +412,7 @@    then the inert item must Given or, equivalently,    If the work-item is Given,-   and the inert item is Wanted/Derived+   and the inert item is Wanted    then there is no reaction -} @@ -429,9 +427,9 @@   = do { inerts <- getTcSInerts        ; let ics = inert_cans inerts        ; case wi of-             CEqCan    {} -> interactEq    ics wi-             CIrredCan {} -> interactIrred ics wi-             CDictCan  {} -> interactDict  ics wi+             CEqCan       {} -> interactEq      ics wi+             CIrredCan    {} -> interactIrred   ics wi+             CDictCan     {} -> interactDict    ics wi              _ -> pprPanic "interactWithInerts" (ppr wi) }                 -- CNonCanonical have been canonicalised @@ -440,30 +438,10 @@                  -- (if the latter is Wanted; just discard it if not)    | KeepWork    -- Keep the work item, and solve the inert item from it -   | KeepBoth    -- See Note [KeepBoth]- instance Outputable InteractResult where-  ppr KeepBoth  = text "keep both"   ppr KeepInert = text "keep inert"   ppr KeepWork  = text "keep work-item" -{- Note [KeepBoth]-~~~~~~~~~~~~~~~~~~-Consider-   Inert:     [WD] C ty1 ty2-   Work item: [D]  C ty1 ty2--Here we can simply drop the work item. But what about-   Inert:     [W] C ty1 ty2-   Work item: [D] C ty1 ty2--Here we /cannot/ drop the work item, becuase we lose the [D] form, and-that is essential for e.g. fundeps, see isImprovable.  We could zap-the inert item to [WD], but the simplest thing to do is simply to keep-both. (They probably started as [WD] and got split; this is relatively-rare and it doesn't seem worth trying to put them back together again.)--}- solveOneFromTheOther :: CtEvidence  -- Inert    (Dict or Irred)                      -> CtEvidence  -- WorkItem (same predicate as inert)                      -> TcS InteractResult@@ -476,38 +454,23 @@ -- two wanteds into one by solving one from the other  solveOneFromTheOther ev_i ev_w-  | CtDerived {} <- ev_w         -- Work item is Derived-  = case ev_i of-      CtWanted { ctev_nosh = WOnly } -> return KeepBoth-      _                              -> return KeepInert--  | CtDerived {} <- ev_i         -- Inert item is Derived-  = case ev_w of-      CtWanted { ctev_nosh = WOnly } -> return KeepBoth-      _                              -> return KeepWork-              -- The ev_w is inert wrt earlier inert-set items,-              -- so it's safe to continue on from this point--  -- After this, neither ev_i or ev_w are Derived   | CtWanted { ctev_loc = loc_w } <- ev_w   , prohibitedSuperClassSolve loc_i loc_w   = -- inert must be Given     do { traceTcS "prohibitedClassSolve1" (ppr ev_i $$ ppr ev_w)        ; return KeepWork } -  | CtWanted { ctev_nosh = nosh_w } <- ev_w+  | CtWanted {} <- ev_w        -- Inert is Given or Wanted-  = case ev_i of-      CtWanted { ctev_nosh = WOnly }-          | WDeriv <- nosh_w           -> return KeepWork-      _                                -> return KeepInert-      -- Consider work  item [WD] C ty1 ty2-      --          inert item [W]  C ty1 ty2-      -- Then we must keep the work item.  But if the-      -- work item was       [W]  C ty1 ty2-      -- then we are free to discard the work item in favour of inert-      -- Remember, no Deriveds at this point+  = return $ case ev_i of+               CtWanted {} -> choose_better_loc+                 -- both are Wanted; choice of which to keep is+                 -- arbitrary. So we look at the context to choose+                 -- which would make a better error message +               _           -> KeepInert+                 -- work is Wanted; inert is Given: easy choice.+   -- From here on the work-item is Given    | CtWanted { ctev_loc = loc_i } <- ev_i@@ -535,6 +498,27 @@      lvl_i = ctLocLevel loc_i      lvl_w = ctLocLevel loc_w +     choose_better_loc+       -- if only one is a WantedSuperclassOrigin (arising from expanding+       -- a Wanted class constraint), keep the other: wanted superclasses+       -- may be unexpected by users+       | is_wanted_superclass_loc loc_i+       , not (is_wanted_superclass_loc loc_w) = KeepWork++       | not (is_wanted_superclass_loc loc_i)+       , is_wanted_superclass_loc loc_w = KeepInert++        -- otherwise, just choose the lower span+        -- reason: if we have something like (abs 1) (where the+        -- Num constraint cannot be satisfied), it's better to+        -- get an error about abs than about 1.+        -- This test might become more elaborate if we see an+        -- opportunity to improve the error messages+       | ((<) `on` ctLocSpan) loc_i loc_w = KeepInert+       | otherwise                        = KeepWork++     is_wanted_superclass_loc = isWantedSuperclassOrigin . ctLocOrigin+      different_level_strategy  -- Both Given        | isIPLikePred pred = if lvl_w > lvl_i then KeepWork  else KeepInert        | otherwise         = if lvl_w > lvl_i then KeepInert else KeepWork@@ -665,8 +649,6 @@                -- For insolubles, don't allow the constraint to be dropped                -- which can happen with solveOneFromTheOther, so that                -- we get distinct error messages with -fdefer-type-errors-               -- See Note [Do not add duplicate derived insolubles]-  , not (isDroppableCt workItem)   = continueWith workItem    | let (matching_irreds, others) = findMatchingIrreds (inert_irreds inerts) ev_w@@ -676,7 +658,6 @@   = do { what_next <- solveOneFromTheOther ev_i ev_w        ; traceTcS "iteractIrred" (ppr workItem $$ ppr what_next $$ ppr ct_i)        ; case what_next of-            KeepBoth  -> continueWith workItem             KeepInert -> do { setEvBindIfWanted ev_w (swap_me swap ev_i)                             ; return (Stop ev_w (text "Irred equal" <+> parens (ppr what_next))) }             KeepWork ->  do { setEvBindIfWanted ev_i (swap_me swap ev_w)@@ -735,56 +716,6 @@ lookup, findMatchingIrreds spots the equality case, and matches either way around. It has to return a swap-flag so we can generate evidence that is the right way round too.--Note [Do not add duplicate derived insolubles]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In general we *must* add an insoluble (Int ~ Bool) even if there is-one such there already, because they may come from distinct call-sites.  Not only do we want an error message for each, but with--fdefer-type-errors we must generate evidence for each.  But for-*derived* insolubles, we only want to report each one once.  Why?--(a) A constraint (C r s t) where r -> s, say, may generate the same fundep-    equality many times, as the original constraint is successively rewritten.--(b) Ditto the successive iterations of the main solver itself, as it traverses-    the constraint tree. See example below.--Also for *given* insolubles we may get repeated errors, as we-repeatedly traverse the constraint tree.  These are relatively rare-anyway, so removing duplicates seems ok.  (Alternatively we could take-the SrcLoc into account.)--Note that the test does not need to be particularly efficient because-it is only used if the program has a type error anyway.--Example of (b): assume a top-level class and instance declaration:--  class D a b | a -> b-  instance D [a] [a]--Assume we have started with an implication:--  forall c. Eq c => { wc_simple = [W] D [c] c }--which we have simplified to, with a Derived constraing coming from-D's functional dependency:--  forall c. Eq c => { wc_simple = [W] D [c] c [W]-                                  [D] (c ~ [c]) }--When iterating the solver, we might try to re-solve this-implication. If we do not do a dropDerivedWC, then we will end up-trying to solve the following constraints the second time:--  [W] (D [c] c)-  [D] (c ~ [c])--which will result in two Deriveds to end up in the insoluble set:--  wc_simple = [W] D [c] c-              [D] (c ~ [c])-              [D] (c ~ [c]) -}  {-@@ -999,6 +930,68 @@   and to solve G2 we may need H. If we don't spot this sharing we may   solve H twice; and if this pattern repeats we may get exponentially bad   behaviour.++Note [No Given/Given fundeps]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We do not create constraints from:+* Given/Given interactions via functional dependencies or type family+  injectivity annotations.+* Given/instance fundep interactions via functional dependencies or+  type family injectivity annotations.++In this Note, all these interactions are called just "fundeps".++We ingore such fundeps for several reasons:++1. These fundeps will never serve a purpose in accepting more+   programs: Given constraints do not contain metavariables that could+   be unified via exploring fundeps. They *could* be useful in+   discovering inaccessible code. However, the constraints will be+   Wanteds, and as such will cause errors (not just warnings) if they+   go unsolved. Maybe there is a clever way to get the right+   inaccessible code warnings, but the path forward is far from+   clear. #12466 has further commentary.++2. Furthermore, here is a case where a Given/instance interaction is actively+   harmful (from dependent/should_compile/RaeJobTalk):++       type family a == b :: Bool+       type family Not a = r | r -> a where+         Not False = True+         Not True  = False++       [G] Not (a == b) ~ True++   Reacting this Given with the equations for Not produces++      [W] a == b ~ False++   This is indeed a true consequence, and would make sense as a fresh Given.+   But we don't have a way to produce evidence for fundeps, as a Wanted it+   is /harmful/: we can't prove it, and so we'll report an error and reject+   the program. (Previously fundeps gave rise to Deriveds, which+   carried no evidence, so it didn't matter that they could not be proved.)++3. #20922 showed a subtle different problem with Given/instance fundeps.+      type family ZipCons (as :: [k]) (bssx :: [[k]]) = (r :: [[k]]) | r -> as bssx where+        ZipCons (a ': as) (bs ': bss) = (a ': bs) ': ZipCons as bss+        ...++      tclevel = 4+      [G] ZipCons is1 iss ~ (i : is2) : jss++   (The tclevel=4 means that this Given is at level 4.)  The fundep tells us that+   'iss' must be of form (is2 : beta[4]) where beta[4] is a fresh unification+   variable; we don't know what type it stands for. So we would emit+      [W] iss ~ is2 : beta++   Again we can't prove that equality; and worse we'll rewrite iss to+   (is2:beta) in deeply nested contraints inside this implication,+   where beta is untouchable (under other equality constraints), leading+   to other insoluble constraints.++The bottom line: since we have no evidence for them, we should ignore Given/Given+and Given/instance fundeps entirely. -}  interactDict :: InertCans -> Ct -> TcS (StopOrContinue Ct)@@ -1019,7 +1012,6 @@          what_next <- solveOneFromTheOther ev_i ev_w        ; traceTcS "lookupInertDict" (ppr what_next)        ; case what_next of-           KeepBoth  -> continueWith workItem            KeepInert -> do { setEvBindIfWanted ev_w (ctEvTerm ev_i)                            ; return $ Stop ev_w (text "Dict equal" <+> parens (ppr what_next)) }            KeepWork  -> do { setEvBindIfWanted ev_i (ctEvTerm ev_w)@@ -1062,7 +1054,7 @@  -- Enabled by the -fsolve-constant-dicts flag    = do { ev_binds_var <- getTcEvBindsVar-       ; ev_binds <- ASSERT2( not (isCoEvBindsVar ev_binds_var ), ppr ev_w )+       ; ev_binds <- assertPpr (not (isCoEvBindsVar ev_binds_var )) (ppr ev_w) $                      getTcEvBindsMap ev_binds_var        ; solved_dicts <- getSolvedDicts @@ -1108,7 +1100,7 @@                        ; lift $ checkReductionDepth loc' pred  -                       ; evc_vs <- mapM (new_wanted_cached loc' solved_dicts') preds+                       ; evc_vs <- mapM (new_wanted_cached ev loc' solved_dicts') preds                                   -- Emit work for subgoals but use our local cache                                   -- so we can solve recursive dictionaries. @@ -1127,50 +1119,45 @@     -- Use a local cache of solved dicts while emitting EvVars for new work     -- We bail out of the entire computation if we need to emit an EvVar for     -- a subgoal that isn't a ClassPred.-    new_wanted_cached :: CtLoc -> DictMap CtEvidence -> TcPredType -> MaybeT TcS MaybeNew-    new_wanted_cached loc cache pty+    new_wanted_cached :: CtEvidence -> CtLoc+                      -> DictMap CtEvidence -> TcPredType -> MaybeT TcS MaybeNew+    new_wanted_cached ev_w loc cache pty       | ClassPred cls tys <- classifyPredType pty       = lift $ case findDict cache loc_w cls tys of           Just ctev -> return $ Cached (ctEvExpr ctev)-          Nothing   -> Fresh <$> newWantedNC loc pty+          Nothing   -> Fresh <$> newWantedNC loc (ctEvRewriters ev_w) pty       | otherwise = mzero  addFunDepWork :: InertCans -> CtEvidence -> Class -> TcS ()--- Add derived constraints from type-class functional dependencies.+-- Add wanted constraints from type-class functional dependencies. addFunDepWork inerts work_ev cls-  | isImprovable work_ev   = mapBagM_ add_fds (findDictsByClass (inert_dicts inerts) cls)                -- No need to check flavour; fundeps work between                -- any pair of constraints, regardless of flavour                -- Importantly we don't throw workitem back in the                -- worklist because this can cause loops (see #5236)-  | otherwise-  = return ()   where     work_pred = ctEvPred work_ev     work_loc  = ctEvLoc work_ev      add_fds inert_ct-      | isImprovable inert_ev       = do { traceTcS "addFunDepWork" (vcat                 [ ppr work_ev                 , pprCtLoc work_loc, ppr (isGivenLoc work_loc)                 , pprCtLoc inert_loc, ppr (isGivenLoc inert_loc)-                , pprCtLoc derived_loc, ppr (isGivenLoc derived_loc) ]) ;+                , pprCtLoc derived_loc, ppr (isGivenLoc derived_loc) ]) -        emitFunDepDeriveds $-        improveFromAnother derived_loc inert_pred work_pred+           ; unless (isGiven work_ev && isGiven inert_ev) $+             emitFunDepWanteds (ctEvRewriters work_ev) $+             improveFromAnother (derived_loc, inert_rewriters) inert_pred work_pred                -- We don't really rewrite tys2, see below _rewritten_tys2, so that's ok-               -- NB: We do create FDs for given to report insoluble equations that arise-               -- from pairs of Givens, and also because of floating when we approximate-               -- implications. The relevant test is: typecheck/should_fail/FDsFromGivens.hs+               -- Do not create FDs from Given/Given interactions: See Note [No Given/Given fundeps]         }-      | otherwise-      = return ()       where         inert_ev   = ctEvidence inert_ct         inert_pred = ctEvPred inert_ev         inert_loc  = ctEvLoc inert_ev+        inert_rewriters = ctRewriters inert_ct         derived_loc = work_loc { ctl_depth  = ctl_depth work_loc `maxSubGoalDepth`                                               ctl_depth inert_loc                                , ctl_origin = FunDepOrigin1 work_pred@@ -1280,24 +1267,22 @@  improveLocalFunEqs :: CtEvidence -> InertCans -> TyCon -> [TcType] -> TcType                    -> TcS ()--- Generate derived improvement equalities, by comparing+-- Generate improvement equalities, by comparing -- the current work item with inert CFunEqs--- E.g.   x + y ~ z,   x + y' ~ z   =>   [D] y ~ y'+-- E.g.   x + y ~ z,   x + y' ~ z   =>   [W] y ~ y' -- -- See Note [FunDep and implicit parameter reactions]--- Precondition: isImprovable work_ev improveLocalFunEqs work_ev inerts fam_tc args rhs-  = ASSERT( isImprovable work_ev )-    unless (null improvement_eqns) $+  = unless (null improvement_eqns) $     do { traceTcS "interactFunEq improvements: " $                    vcat [ text "Eqns:" <+> ppr improvement_eqns                         , text "Candidates:" <+> ppr funeqs_for_tc                         , text "Inert eqs:" <+> ppr (inert_eqs inerts) ]-       ; emitFunDepDeriveds improvement_eqns }+       ; emitFunDepWanteds (ctEvRewriters work_ev) improvement_eqns }   where     funeqs        = inert_funeqs inerts-    funeqs_for_tc = [ funeq_ct | EqualCtList (funeq_ct :| _)-                                   <- findFunEqsByTyCon funeqs fam_tc+    funeqs_for_tc = [ funeq_ct | equal_ct_list <- findFunEqsByTyCon funeqs fam_tc+                               , funeq_ct <- equal_ct_list                                , NomEq == ctEqRel funeq_ct ]                                   -- representational equalities don't interact                                   -- with type family dependencies@@ -1306,7 +1291,7 @@     fam_inj_info  = tyConInjectivityInfo fam_tc      ---------------------    improvement_eqns :: [FunDepEqn CtLoc]+    improvement_eqns :: [FunDepEqn (CtLoc, RewriterSet)]     improvement_eqns       | Just ops <- isBuiltInSynFamTyCon_maybe fam_tc       =    -- Try built-in families, notably for arithmethic@@ -1321,15 +1306,19 @@      --------------------     do_one_built_in ops rhs (CEqCan { cc_lhs = TyFamLHS _ iargs, cc_rhs = irhs, cc_ev = inert_ev })+      | not (isGiven inert_ev && isGiven work_ev)  -- See Note [No Given/Given fundeps]       = mk_fd_eqns inert_ev (sfInteractInert ops args rhs iargs irhs) +      | otherwise+      = []+     do_one_built_in _ _ _ = pprPanic "interactFunEq 1" (ppr fam_tc)      --------------------     -- See Note [Type inference for type families with injectivity]     do_one_injective inj_args rhs (CEqCan { cc_lhs = TyFamLHS _ inert_args                                           , cc_rhs = irhs, cc_ev = inert_ev })-      | isImprovable inert_ev+      | not (isGiven inert_ev && isGiven work_ev) -- See Note [No Given/Given fundeps]       , rhs `tcEqType` irhs       = mk_fd_eqns inert_ev $ [ Pair arg iarg                               | (arg, iarg, True) <- zip3 args inert_args inj_args ]@@ -1339,17 +1328,25 @@     do_one_injective _ _ _ = pprPanic "interactFunEq 2" (ppr fam_tc)      ---------------------    mk_fd_eqns :: CtEvidence -> [TypeEqn] -> [FunDepEqn CtLoc]+    mk_fd_eqns :: CtEvidence -> [TypeEqn] -> [FunDepEqn (CtLoc, RewriterSet)]     mk_fd_eqns inert_ev eqns       | null eqns  = []       | otherwise  = [ FDEqn { fd_qtvs = [], fd_eqs = eqns                              , fd_pred1 = work_pred-                             , fd_pred2 = ctEvPred inert_ev-                             , fd_loc   = loc } ]+                             , fd_pred2 = inert_pred+                             , fd_loc   = (loc, inert_rewriters) } ]       where-        inert_loc = ctEvLoc inert_ev-        loc = inert_loc { ctl_depth = ctl_depth inert_loc `maxSubGoalDepth`-                                      ctl_depth work_loc }+        initial_loc  -- start with the location of the Wanted involved+          | isGiven work_ev = inert_loc+          | otherwise       = work_loc+        eqn_orig        = InjTFOrigin1 work_pred (ctLocOrigin work_loc) (ctLocSpan work_loc)+                                       inert_pred (ctLocOrigin inert_loc) (ctLocSpan inert_loc)+        eqn_loc         = setCtLocOrigin initial_loc eqn_orig+        inert_pred      = ctEvPred inert_ev+        inert_loc       = ctEvLoc inert_ev+        inert_rewriters = ctEvRewriters inert_ev+        loc = eqn_loc { ctl_depth = ctl_depth inert_loc `maxSubGoalDepth`+                                    ctl_depth work_loc }  {- Note [Type inference for type families with injectivity] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1357,9 +1354,9 @@     type family F a b = r | r -> b  Then if we have an equality like F s1 t1 ~ F s2 t2,-we can use the injectivity to get a new Derived constraint on+we can use the injectivity to get a new Wanted constraint on the injective argument-  [D] t1 ~ t2+  [W] t1 ~ t2  That in turn can help GHC solve constraints that would otherwise require guessing.  For example, consider the ambiguity check for@@ -1379,15 +1376,15 @@ additional apartness check for the selected equation to check that the selected is guaranteed to fire for given LHS arguments. -These new constraints are simply *Derived* constraints; they have no evidence.+These new constraints are Wanted constraints, but we will not use the evidence. We could go further and offer evidence from decomposing injective type-function applications, but that would require new evidence forms, and an extension to FC, so we don't do that right now (Dec 14). -We generate these Deriveds in three places, depending on how we notice the+We generate these Wanteds in three places, depending on how we notice the injectivity. -1. When we have a [W/D] F tys1 ~ F tys2. This is handled in canEqCanLHS2, and+1. When we have a [W] F tys1 ~ F tys2. This is handled in canEqCanLHS2, and described in Note [Decomposing equality] in GHC.Tc.Solver.Canonical.  2. When we have [W] F tys1 ~ T and [W] F tys2 ~ T. Note that neither of these@@ -1454,10 +1451,7 @@ * We can only do g2 := g1 if g1 can discharge g2; that depends on   (a) the role and (b) the flavour.  E.g. a representational equality   cannot discharge a nominal one; a Wanted cannot discharge a Given.-  The predicate is eqCanDischargeFR.--* If the inert is [W] and the work-item is [WD] we don't want to-  forget the [D] part; hence the Bool result of inertsCanDischarge.+  The predicate is eqCanRewriteFR.  * Visibility. Suppose  S :: forall k. k -> Type, and consider unifying       S @Type (a::Type)  ~   S @(Type->Type) (b::Type->Type)@@ -1478,9 +1472,7 @@  inertsCanDischarge :: InertCans -> Ct                    -> Maybe ( CtEvidence  -- The evidence for the inert-                            , SwapFlag    -- Whether we need mkSymCo-                            , Bool)       -- True <=> keep a [D] version-                                          --          of the [WD] constraint+                            , SwapFlag )  -- Whether we need mkSymCo inertsCanDischarge inerts (CEqCan { cc_lhs = lhs_w, cc_rhs = rhs_w                                   , cc_ev = ev_w, cc_eq_rel = eq_rel })   | (ev_i : _) <- [ ev_i | CEqCan { cc_ev = ev_i, cc_rhs = rhs_i@@ -1490,7 +1482,7 @@                          , inert_beats_wanted ev_i eq_rel ]   =  -- Inert:     a ~ ty      -- Work item: a ~ ty-    Just (ev_i, NotSwapped, keep_deriv ev_i)+    Just (ev_i, NotSwapped)    | Just rhs_lhs <- canEqLHS_maybe rhs_w   , (ev_i : _) <- [ ev_i | CEqCan { cc_ev = ev_i, cc_rhs = rhs_i@@ -1500,7 +1492,7 @@                          , inert_beats_wanted ev_i eq_rel ]   =  -- Inert:     a ~ b      -- Work item: b ~ a-     Just (ev_i, IsSwapped, keep_deriv ev_i)+     Just (ev_i, IsSwapped)    where     loc_w  = ctEvLoc ev_w@@ -1508,22 +1500,14 @@     fr_w   = (flav_w, eq_rel)      inert_beats_wanted ev_i eq_rel-      = -- eqCanDischargeFR:    see second bullet of Note [Combining equalities]+      = -- eqCanRewriteFR:        see second bullet of Note [Combining equalities]         -- strictly_more_visible: see last bullet of Note [Combining equalities]-        fr_i`eqCanDischargeFR` fr_w+        fr_i `eqCanRewriteFR` fr_w         && not ((loc_w `strictly_more_visible` ctEvLoc ev_i)-                 && (fr_w `eqCanDischargeFR` fr_i))+                 && (fr_w `eqCanRewriteFR` fr_i))       where         fr_i = (ctEvFlavour ev_i, eq_rel) -    -- See Note [Combining equalities], third bullet-    keep_deriv ev_i-      | Wanted WOnly  <- ctEvFlavour ev_i  -- inert is [W]-      , Wanted WDeriv <- flav_w            -- work item is [WD]-      = True   -- Keep a derived version of the work item-      | otherwise-      = False  -- Work item is fully discharged-     -- See Note [Combining equalities], final bullet     strictly_more_visible loc1 loc2        = not (isVisibleOrigin (ctLocOrigin loc2)) &&@@ -1537,20 +1521,13 @@                                    , cc_rhs = rhs                                    , cc_ev = ev                                    , cc_eq_rel = eq_rel })-  | Just (ev_i, swapped, keep_deriv) <- inertsCanDischarge inerts workItem+  | Just (ev_i, swapped) <- inertsCanDischarge inerts workItem   = do { setEvBindIfWanted ev $          evCoercion (maybeTcSymCo swapped $                      tcDowngradeRole (eqRelRole eq_rel)                                      (ctEvRole ev_i)                                      (ctEvCoercion ev_i)) -       ; let deriv_ev = CtDerived { ctev_pred = ctEvPred ev-                                  , ctev_loc  = ctEvLoc  ev }-       ; when keep_deriv $-         emitWork [workItem { cc_ev = deriv_ev }]-         -- As a Derived it might not be fully rewritten,-         -- so we emit it as new work-        ; stopWith ev "Solved from inert" }    | ReprEq <- eq_rel   -- See Note [Do not unify representational equalities]@@ -1561,15 +1538,13 @@   = case lhs of        TyVarLHS tv -> tryToSolveByUnification workItem ev tv rhs -       TyFamLHS tc args -> do { when (isImprovable ev) $-                                 -- Try improvement, if possible-                                improveLocalFunEqs ev inerts tc args rhs+       TyFamLHS tc args -> do { improveLocalFunEqs ev inerts tc args rhs                               ; continueWith workItem }  interactEq _ wi = pprPanic "interactEq" (ppr wi)  ------------------------- We have a meta-tyvar on the left, and metaTyVarUpateOK has said "yes"+-- We have a meta-tyvar on the left, and metaTyVarUpdateOK has said "yes" -- So try to solve by unifying. -- Three reasons why not: --    Skolem escape@@ -1596,7 +1571,7 @@ solveByUnification :: CtEvidence -> TcTyVar -> Xi -> TcS (StopOrContinue Ct) -- Solve with the identity coercion -- Precondition: kind(xi) equals kind(tv)--- Precondition: CtEvidence is Wanted or Derived+-- Precondition: CtEvidence is Wanted -- Precondition: CtEvidence is nominal -- Returns: workItem where --        workItem = the new Given constraint@@ -1631,8 +1606,8 @@ At the end we spontaneously solve that guy, *reunifying*  [alpha := Int]  We avoid this problem by orienting the resulting given so that the unification-variable is on the left.  [Note that alternatively we could attempt to-enforce this at canonicalization]+variable is on the left (note that alternatively we could attempt to+enforce this at canonicalization).  See also Note [No touchables as FunEq RHS] in GHC.Tc.Solver.Monad; avoiding double unifications is the main reason we disallow touchable@@ -1709,7 +1684,7 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Currently, our story of interacting two dictionaries (or a dictionary and top-level instances) for functional dependencies, and implicit-parameters, is that we simply produce new Derived equalities.  So for example+parameters, is that we simply produce new Wanted equalities.  So for example          class D a b | a -> b where ...     Inert:@@ -1718,7 +1693,7 @@         d2 :w D Int alpha      We generate the extra work item-        cv :d alpha ~ Bool+        cv :w alpha ~ Bool     where 'cv' is currently unused.  However, this new item can perhaps be     spontaneously solved to become given and react with d2,     discharging it in favour of a new constraint d2' thus:@@ -1727,10 +1702,9 @@     Now d2' can be discharged from d1  We could be more aggressive and try to *immediately* solve the dictionary-using those extra equalities, but that requires those equalities to carry-evidence and derived do not carry evidence.+using those extra equalities. -If that were the case with the same inert set and work item we might dischard+If that were the case with the same inert set and work item we might discard d2 directly:          cv :w alpha ~ Bool@@ -1752,6 +1726,68 @@ It's exactly the same with implicit parameters, except that the "aggressive" approach would be much easier to implement. +Note [Fundeps with instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+doTopFundepImprovement compares the constraint with all the instance+declarations, to see if we can produce any equalities. E.g+   class C2 a b | a -> b+   instance C Int Bool+Then the constraint (C Int ty) generates the equality [W] ty ~ Bool.++There is a nasty corner in #19415 which led to the typechecker looping:+   class C s t b | s -> t+   instance ... => C (T kx x) (T ky y) Int+   T :: forall k. k -> Type++   work_item: dwrk :: C (T @ka (a::ka)) (T @kb0 (b0::kb0)) Char+      where kb0, b0 are unification vars+   ==> {fundeps against instance; k0, y0 fresh unification vars}+       [W] T kb0 (b0::kb0) ~ T k0 (y0::k0)+       Add dwrk to inert set+   ==> {solve that equality kb0 := k0, b0 := y0+   Now kick out dwrk, since it mentions kb0+   But now we are back to the start!  Loop!++NB1: this example relies on an instance that does not satisfy+the coverage condition (although it may satisfy the weak coverage+condition), which is known to lead to termination trouble++NB2: if the unification was the other way round, k0:=kb0, all would be+well.  It's a very delicate problem.++The ticket #19415 discusses various solutions, but the one we adopted+is very simple:++* There is a flag in CDictCan (cc_fundeps :: Bool)++* cc_fundeps = True means+    a) The class has fundeps+    b) We have not had a successful hit against instances yet++* In doTopFundepImprovement, if we emit some constraints we flip the flag+  to False, so that we won't try again with the same CDictCan.  In our+  example, dwrk will have its flag set to False.++* Not that if we have no "hits" we must /not/ flip the flag. We might have+      dwrk :: C alpha beta Char+  which does not yet trigger fundeps from the instance, but later we+  get alpha := T ka a.  We could be cleverer, and spot that the constraint+  is such that we will /never/ get any hits (no unifiers) but we don't do+  that yet.++Easy!  What could go wrong?+* Maybe the class has multiple fundeps, and we get hit with one but not+  the other.  Per-fundep flags?+* Maybe we get a hit against one instance with one fundep but, after+  the work-item is instantiated a bit more, we get a second hit+  against a second instance.  (This is a pretty strange and+  undesirable thing anyway, and can only happen with overlapping+  instances; one example is in Note [Weird fundeps].)++But both of these seem extremely exotic, and ignoring them threatens+completeness (fixable with some type signature), but not termination+(not fixable).  So for now we are just doing the simplest thing.+ Note [Weird fundeps] ~~~~~~~~~~~~~~~~~~~~ Consider   class Het a b | a -> b where@@ -1765,8 +1801,8 @@ although it's pretty strange.  So they are both accepted. Now try   [W] GHet (K Int) (K Bool) This triggers fundeps from both instance decls;-      [D] K Bool ~ K [a]-      [D] K Bool ~ K beta+      [W] K Bool ~ K [a]+      [W] K Bool ~ K beta And there's a risk of complaining about Bool ~ [a].  But in fact the Wanted matches the second instance, so we never get as far as the fundeps.@@ -1774,23 +1810,64 @@ #7875 is a case in point. -} -emitFunDepDeriveds :: [FunDepEqn CtLoc] -> TcS ()+doTopFundepImprovement :: Ct -> TcS (StopOrContinue Ct)+-- Try to functional-dependency improvement betweeen the constraint+-- and the top-level instance declarations+-- See Note [Fundeps with instances]+-- See also Note [Weird fundeps]+doTopFundepImprovement work_item@(CDictCan { cc_ev = ev, cc_class = cls+                                           , cc_tyargs = xis+                                           , cc_fundeps = has_fds })+  | has_fds+  = do { traceTcS "try_fundeps" (ppr work_item)+       ; instEnvs <- getInstEnvs+       ; let fundep_eqns = improveFromInstEnv instEnvs mk_ct_loc cls xis+       ; case fundep_eqns of+           [] -> continueWith work_item  -- No improvement+           _  -> do { emitFunDepWanteds (ctEvRewriters ev) fundep_eqns+                    ; continueWith (work_item { cc_fundeps = False }) } }+  | otherwise+  = continueWith work_item++  where+     dict_pred   = mkClassPred cls xis+     dict_loc    = ctEvLoc ev+     dict_origin = ctLocOrigin dict_loc++     mk_ct_loc :: PredType   -- From instance decl+               -> SrcSpan    -- also from instance deol+               -> (CtLoc, RewriterSet)+     mk_ct_loc inst_pred inst_loc+       = ( dict_loc { ctl_origin = FunDepOrigin2 dict_pred dict_origin+                                                 inst_pred inst_loc }+         , emptyRewriterSet )++doTopFundepImprovement work_item = pprPanic "doTopFundepImprovement" (ppr work_item)++emitFunDepWanteds :: RewriterSet  -- from the work item+                   -> [FunDepEqn (CtLoc, RewriterSet)] -> TcS () -- See Note [FunDep and implicit parameter reactions]-emitFunDepDeriveds fd_eqns+emitFunDepWanteds work_rewriters fd_eqns   = mapM_ do_one_FDEqn fd_eqns   where-    do_one_FDEqn (FDEqn { fd_qtvs = tvs, fd_eqs = eqs, fd_loc = loc })+    do_one_FDEqn (FDEqn { fd_qtvs = tvs, fd_eqs = eqs, fd_loc = (loc, rewriters) })      | null tvs  -- Common shortcut-     = do { traceTcS "emitFunDepDeriveds 1" (ppr (ctl_depth loc) $$ ppr eqs $$ ppr (isGivenLoc loc))-          ; mapM_ (unifyDerived loc Nominal) eqs }+     = do { traceTcS "emitFunDepWanteds 1" (ppr (ctl_depth loc) $$ ppr eqs $$ ppr (isGivenLoc loc))+          ; mapM_ (\(Pair ty1 ty2) -> unifyWanted all_rewriters loc Nominal ty1 ty2)+                  (reverse eqs) }+             -- See Note [Reverse order of fundep equations]+      | otherwise-     = do { traceTcS "emitFunDepDeriveds 2" (ppr (ctl_depth loc) $$ ppr tvs $$ ppr eqs)+     = do { traceTcS "emitFunDepWanteds 2" (ppr (ctl_depth loc) $$ ppr tvs $$ ppr eqs)           ; subst <- instFlexi tvs  -- Takes account of kind substitution-          ; mapM_ (do_one_eq loc subst) eqs }+          ; mapM_ (do_one_eq loc all_rewriters subst) (reverse eqs) }+               -- See Note [Reverse order of fundep equations]+     where+       all_rewriters = work_rewriters S.<> rewriters -    do_one_eq loc subst (Pair ty1 ty2)-       = unifyDerived loc Nominal $-         Pair (Type.substTyUnchecked subst ty1) (Type.substTyUnchecked subst ty2)+    do_one_eq loc rewriters subst (Pair ty1 ty2)+       = unifyWanted rewriters loc Nominal+                     (Type.substTyUnchecked subst ty1) (Type.substTyUnchecked subst ty2)  {- **********************************************************************@@ -1802,18 +1879,24 @@  topReactionsStage :: WorkItem -> TcS (StopOrContinue Ct) -- The work item does not react with the inert set,--- so try interaction with top-level instances. Note:+-- so try interaction with top-level instances. topReactionsStage work_item   = do { traceTcS "doTopReact" (ppr work_item)        ; case work_item of-           CDictCan {}  -> do { inerts <- getTcSInerts-                              ; doTopReactDict inerts work_item }-           CEqCan {}    -> doTopReactEq    work_item-           CIrredCan {} -> doTopReactOther work_item-           _  -> -- Any other work item does not react with any top-level equations-                 continueWith work_item  } +           CDictCan {} ->+             do { inerts <- getTcSInerts+                ; doTopReactDict inerts work_item } +           CEqCan {} ->+             doTopReactEq work_item++           CIrredCan {} ->+             doTopReactOther work_item++           -- Any other work item does not react with any top-level equations+           _  -> continueWith work_item }+ -------------------- doTopReactOther :: Ct -> TcS (StopOrContinue Ct) -- Try local quantified constraints for@@ -1840,6 +1923,12 @@     loc  = ctEvLoc ev     pred = ctEvPred ev +{-********************************************************************+*                                                                    *+          Top-level reaction for equality constraints (CEqCan)+*                                                                    *+********************************************************************-}+ doTopReactEqPred :: Ct -> EqRel -> TcType -> TcType -> TcS (StopOrContinue Ct) doTopReactEqPred work_item eq_rel t1 t2   -- See Note [Looking up primitive equalities in quantified constraints]@@ -1874,6 +1963,47 @@  * Note [Evidence for quantified constraints] in GHC.Core.Predicate  * Note [Equality superclasses in quantified constraints]    in GHC.Tc.Solver.Canonical++Note [Reverse order of fundep equations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this scenario (from dependent/should_fail/T13135_simple):++  type Sig :: Type -> Type+  data Sig a = SigFun a (Sig a)++  type SmartFun :: forall (t :: Type). Sig t -> Type+  type family SmartFun sig = r | r -> sig where+    SmartFun @Type (SigFun @Type a sig) = a -> SmartFun @Type sig++  [W] SmartFun @kappa sigma ~ (Int -> Bool)++The injectivity of SmartFun allows us to produce two new equalities:++  [W] w1 :: Type ~ kappa+  [W] w2 :: SigFun @Type Int beta ~ sigma++for some fresh (beta :: SigType). The second Wanted here is actually+heterogeneous: the LHS has type Sig Type while the RHS has type Sig kappa.+Of course, if we solve the first wanted first, the second becomes homogeneous.++When looking for injectivity-inspired equalities, we work left-to-right,+producing the two equalities in the order written above. However, these+equalities are then passed into unifyWanted, which will fail, adding these+to the work list. However, crucially, the work list operates like a *stack*.+So, because we add w1 and then w2, we process w2 first. This is silly: solving+w1 would unlock w2. So we make sure to add equalities to the work+list in left-to-right order, which requires a few key calls to 'reverse'.++This treatment is also used for class-based functional dependencies, although+we do not have a program yet known to exhibit a loop there. It just seems+like the right thing to do.++When this was originally conceived, it was necessary to avoid a loop in T13135.+That loop is now avoided by continuing with the kind equality (not the type+equality) in canEqCanLHSHetero (see Note [Equalities with incompatible kinds]+in GHC.Tc.Solver.Canonical). However, the idea of working left-to-right still+seems worthwhile, and so the calls to 'reverse' remain.+ -}  --------------------@@ -1887,7 +2017,7 @@ improveTopFunEqs :: CtEvidence -> TyCon -> [TcType] -> TcType -> TcS () -- See Note [FunDep and implicit parameter reactions] improveTopFunEqs ev fam_tc args rhs-  | not (isImprovable ev)+  | isGiven ev  -- See Note [No Given/Given fundeps]   = return ()    | otherwise@@ -1895,11 +2025,15 @@        ; eqns <- improve_top_fun_eqs fam_envs fam_tc args rhs        ; traceTcS "improveTopFunEqs" (vcat [ ppr fam_tc <+> ppr args <+> ppr rhs                                           , ppr eqns ])-       ; mapM_ (unifyDerived loc Nominal) eqns }+       ; mapM_ (\(Pair ty1 ty2) -> unifyWanted rewriters loc Nominal ty1 ty2)+               (reverse eqns) }+         -- Missing that `reverse` causes T13135 and T13135_simple to loop.+         -- See Note [Reverse order of fundep equations]   where     loc = bumpCtLocDepth (ctEvLoc ev)         -- ToDo: this location is wrong; it should be FunDepOrigin2         -- See #14778+    rewriters = ctEvRewriters ev  improve_top_fun_eqs :: FamInstEnvs                     -> TyCon -> [TcType] -> TcType@@ -1982,7 +2116,7 @@  Note [Improvement orientation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-A very delicate point is the orientation of derived equalities+A very delicate point is the orientation of equalities arising from injectivity improvement (#12522).  Suppose we have   type family F x = t | t -> x   type instance F (a, Int) = (Int, G a)@@ -1991,10 +2125,10 @@   [W] TF (alpha, beta) ~ fuv   [W] fuv ~ (Int, <some type>) -The injectivity will give rise to derived constraints+The injectivity will give rise to constraints -  [D] gamma1 ~ alpha-  [D] Int ~ beta+  [W] gamma1 ~ alpha+  [W] Int ~ beta  The fresh unification variable gamma1 comes from the fact that we can only do "partial improvement" here; see Section 5.2 of@@ -2003,7 +2137,7 @@ Now, it's very important to orient the equations this way round, so that the fresh unification variable will be eliminated in favour of alpha.  If we instead had-   [D] alpha ~ gamma1+   [W] alpha ~ gamma1 then we would unify alpha := gamma1; and kick out the wanted constraint.  But when we grough it back in, it'd look like    [W] TF (gamma1, beta) ~ fuv@@ -2014,7 +2148,7 @@ actual argument (alpha, beta) partly matches the improvement template.  But that's a bit tricky, esp when we remember that the kinds much match too; so it's easier to let the normal machinery-handle it.  Instead we are careful to orient the new derived+handle it.  Instead we are careful to orient the new equality with the template on the left.  Delicate, but it works.  -}@@ -2030,14 +2164,14 @@ doTopReactDict inerts work_item@(CDictCan { cc_ev = ev, cc_class = cls                                           , cc_tyargs = xis })   | isGiven ev   -- Never use instances for Given constraints-  = do { try_fundep_improvement-       ; continueWith work_item }+  = continueWith work_item+     -- See Note [No Given/Given fundeps]    | Just solved_ev <- lookupSolvedDict inerts dict_loc cls xis   -- Cached   = do { setEvBindIfWanted ev (ctEvTerm solved_ev)        ; stopWith ev "Dict/Top (cached)" } -  | otherwise  -- Wanted or Derived, but not cached+  | otherwise  -- Wanted, but not cached    = do { dflags <- getDynFlags         ; lkup_res <- matchClassInst dflags inerts cls xis dict_loc         ; case lkup_res of@@ -2045,31 +2179,14 @@                   -> do { insertSafeOverlapFailureTcS what work_item                         ; addSolvedDict what ev cls xis                         ; chooseInstance work_item lkup_res }-               _  ->  -- NoInstance or NotSure-                     do { when (isImprovable ev) $-                          try_fundep_improvement-                        ; continueWith work_item } }+               _  -> -- NoInstance or NotSure+                     -- We didn't solve it; so try functional dependencies with+                     -- the instance environment, and return+                     doTopFundepImprovement work_item }    where-     dict_pred   = mkClassPred cls xis-     dict_loc    = ctEvLoc ev-     dict_origin = ctLocOrigin dict_loc+     dict_loc = ctEvLoc ev -     -- We didn't solve it; so try functional dependencies with-     -- the instance environment, and return-     -- See also Note [Weird fundeps]-     try_fundep_improvement-        = do { traceTcS "try_fundeps" (ppr work_item)-             ; instEnvs <- getInstEnvs-             ; emitFunDepDeriveds $-               improveFromInstEnv instEnvs mk_ct_loc dict_pred } -     mk_ct_loc :: PredType   -- From instance decl-               -> SrcSpan    -- also from instance deol-               -> CtLoc-     mk_ct_loc inst_pred inst_loc-       = dict_loc { ctl_origin = FunDepOrigin2 dict_pred dict_origin-                                               inst_pred inst_loc }- doTopReactDict _ w = pprPanic "doTopReactDict" (ppr w)  @@ -2080,32 +2197,16 @@                         , cir_mk_ev     = mk_ev })   = do { traceTcS "doTopReact/found instance for" $ ppr ev        ; deeper_loc <- checkInstanceOK loc what pred-       ; if isDerived ev-         then -- Use type-class instances for Deriveds, in the hope-              -- of generating some improvements-              -- C.f. Example 3 of Note [The improvement story]-              -- It's easy because no evidence is involved-           do { dflags <- getDynFlags-              ; unless (subGoalDepthExceeded dflags (ctLocDepth deeper_loc)) $-                emitNewDeriveds deeper_loc theta-                  -- If we have a runaway Derived, let's not issue a-                  -- "reduction stack overflow" error, which is not particularly-                  -- friendly. Instead, just drop the Derived.-              ; traceTcS "finish_derived" (ppr (ctl_depth deeper_loc))-              ; stopWith ev "Dict/Top (solved derived)" }--         else -- wanted-           do { checkReductionDepth deeper_loc pred-              ; evb <- getTcEvBindsVar-              ; if isCoEvBindsVar evb-                then continueWith work_item+       ; checkReductionDepth deeper_loc pred+       ; evb <- getTcEvBindsVar+       ; if isCoEvBindsVar evb+         then continueWith work_item                   -- See Note [Instances in no-evidence implications]--                else-           do { evc_vars <- mapM (newWanted deeper_loc) theta+         else+           do { evc_vars <- mapM (newWanted deeper_loc (ctRewriters work_item)) theta               ; setEvBindIfWanted ev (mk_ev (map getEvExpr evc_vars))               ; emitWorkNC (freshGoals evc_vars)-              ; stopWith ev "Dict/Top (solved wanted)" }}}+              ; stopWith ev "Dict/Top (solved wanted)" }}   where      ev         = ctEvidence work_item      pred       = ctEvPred ev@@ -2115,11 +2216,10 @@   = pprPanic "chooseInstance" (ppr work_item $$ ppr lookup_res)  checkInstanceOK :: CtLoc -> InstanceWhat -> TcPredType -> TcS CtLoc--- Check that it's OK to use this insstance:+-- Check that it's OK to use this instance: --    (a) the use is well staged in the Template Haskell sense -- Returns the CtLoc to used for sub-goals--- Probably also want to call checkReductionDepth, but this function--- does not do so to enable special handling for Deriveds in chooseInstance+-- Probably also want to call checkReductionDepth checkInstanceOK loc what pred   = do { checkWellStagedDFun loc what pred        ; return deeper_loc }@@ -2245,7 +2345,7 @@      - natural numbers      - Typeable -* See also Note [What might equal later?] in GHC.Tc.Solver.Monad.+* See also Note [What might equal later?] in GHC.Tc.Solver.InertSet.  * The given-overlap problem is arguably not easy to appear in practice   due to our aggressive prioritization of equality solving over other@@ -2310,7 +2410,7 @@  And less obviously to: -* Tuple classes.  For reasons described in GHC.Tc.Solver.Monad+* Tuple classes.  For reasons described in GHC.Tc.Solver.Types   Note [Tuples hiding implicit parameters], we may have a constraint      [W] (?x::Int, C a)   with an exactly-matching Given constraint.  We must decompose this@@ -2413,8 +2513,8 @@       = (match:matches, unif)        | otherwise-      = ASSERT2( disjointVarSet qtv_set (tyCoVarsOfType pred)-               , ppr qci $$ ppr pred )+      = assertPpr (disjointVarSet qtv_set (tyCoVarsOfType pred))+                  (ppr qci $$ ppr pred)             -- ASSERT: unification relies on the             -- quantified variables being fresh         (matches, unif `combine` this_unif)
GHC/Tc/Solver/Monad.hs view
@@ -1,4255 +1,1998 @@-{-# LANGUAGE CPP, DeriveFunctor, TypeFamilies, ScopedTypeVariables, TypeApplications,-             DerivingStrategies, GeneralizedNewtypeDeriving, ScopedTypeVariables, MultiWayIf, ViewPatterns #-}--{-# OPTIONS_GHC -Wno-incomplete-record-updates -Wno-incomplete-uni-patterns #-}---- | Type definitions for the constraint solver-module GHC.Tc.Solver.Monad (--    -- The work list-    WorkList(..), isEmptyWorkList, emptyWorkList,-    extendWorkListNonEq, extendWorkListCt,-    extendWorkListCts, extendWorkListEq,-    appendWorkList,-    selectNextWorkItem,-    workListSize,-    getWorkList, updWorkListTcS, pushLevelNoWorkList,--    -- The TcS monad-    TcS, runTcS, runTcSDeriveds, runTcSWithEvBinds, runTcSInerts,-    failTcS, warnTcS, addErrTcS, wrapTcS,-    runTcSEqualities,-    nestTcS, nestImplicTcS, setEvBindsTcS,-    emitImplicationTcS, emitTvImplicationTcS,--    runTcPluginTcS, addUsedGRE, addUsedGREs, keepAlive,-    matchGlobalInst, TcM.ClsInstResult(..),--    QCInst(..),--    -- Tracing etc-    panicTcS, traceTcS,-    traceFireTcS, bumpStepCountTcS, csTraceTcS,-    wrapErrTcS, wrapWarnTcS,-    resetUnificationFlag, setUnificationFlag,--    -- Evidence creation and transformation-    MaybeNew(..), freshGoals, isFresh, getEvExpr,--    newTcEvBinds, newNoTcEvBinds,-    newWantedEq, newWantedEq_SI, emitNewWantedEq,-    newWanted, newWanted_SI, newWantedEvVar,-    newWantedNC, newWantedEvVarNC,-    newDerivedNC,-    newBoundEvVarId,-    unifyTyVar, reportUnifications, touchabilityTest, TouchabilityTestResult(..),-    setEvBind, setWantedEq,-    setWantedEvTerm, setEvBindIfWanted,-    newEvVar, newGivenEvVar, newGivenEvVars,-    emitNewDeriveds, emitNewDerivedEq,-    checkReductionDepth,-    getSolvedDicts, setSolvedDicts,--    getInstEnvs, getFamInstEnvs,                -- Getting the environments-    getTopEnv, getGblEnv, getLclEnv,-    getTcEvBindsVar, getTcLevel,-    getTcEvTyCoVars, getTcEvBindsMap, setTcEvBindsMap,-    tcLookupClass, tcLookupId,--    -- Inerts-    InertSet(..), InertCans(..), emptyInert,-    updInertTcS, updInertCans, updInertDicts, updInertIrreds,-    getHasGivenEqs, setInertCans,-    getInertEqs, getInertCans, getInertGivens,-    getInertInsols, getInnermostGivenEqLevel,-    getTcSInerts, setTcSInerts,-    matchableGivens, prohibitedSuperClassSolve, mightEqualLater,-    getUnsolvedInerts,-    removeInertCts, getPendingGivenScs,-    addInertCan, insertFunEq, addInertForAll,-    emitWorkNC, emitWork,-    isImprovable,--    -- The Model-    kickOutAfterUnification,--    -- Inert Safe Haskell safe-overlap failures-    addInertSafehask, insertSafeOverlapFailureTcS, updInertSafehask,-    getSafeOverlapFailures,--    -- Inert CDictCans-    DictMap, emptyDictMap, lookupInertDict, findDictsByClass, addDict,-    addDictsByClass, delDict, foldDicts, filterDicts, findDict,--    -- Inert CEqCans-    EqualCtList(..), findTyEqs, foldTyEqs,-    findEq,--    -- Inert solved dictionaries-    addSolvedDict, lookupSolvedDict,--    -- Irreds-    foldIrreds,--    -- The family application cache-    lookupFamAppInert, lookupFamAppCache, extendFamAppCache,-    pprKicked,--    -- Inert function equalities-    findFunEq, findFunEqsByTyCon,--    instDFunType,                              -- Instantiation--    -- MetaTyVars-    newFlexiTcSTy, instFlexi, instFlexiX,-    cloneMetaTyVar,-    tcInstSkolTyVarsX,--    TcLevel,-    isFilledMetaTyVar_maybe, isFilledMetaTyVar,-    zonkTyCoVarsAndFV, zonkTcType, zonkTcTypes, zonkTcTyVar, zonkCo,-    zonkTyCoVarsAndFVList,-    zonkSimples, zonkWC,-    zonkTyCoVarKind,--    -- References-    newTcRef, readTcRef, writeTcRef, updTcRef,--    -- Misc-    getDefaultInfo, getDynFlags, getGlobalRdrEnvTcS,-    matchFam, matchFamTcM,-    checkWellStagedDFun,-    pprEq,                                   -- Smaller utils, re-exported from TcM-                                             -- TODO (DV): these are only really used in the-                                             -- instance matcher in GHC.Tc.Solver. I am wondering-                                             -- if the whole instance matcher simply belongs-                                             -- here--    breakTyEqCycle_maybe, rewriterView-) where--#include "HsVersions.h"--import GHC.Prelude--import GHC.Driver.Env--import qualified GHC.Tc.Utils.Instantiate as TcM-import GHC.Core.InstEnv-import GHC.Tc.Instance.Family as FamInst-import GHC.Core.FamInstEnv--import qualified GHC.Tc.Utils.Monad    as TcM-import qualified GHC.Tc.Utils.TcMType  as TcM-import qualified GHC.Tc.Instance.Class as TcM( matchGlobalInst, ClsInstResult(..) )-import qualified GHC.Tc.Utils.Env      as TcM-       ( checkWellStaged, tcGetDefaultTys, tcLookupClass, tcLookupId, topIdLvl )-import GHC.Tc.Instance.Class( InstanceWhat(..), safeOverlap, instanceReturnsDictCon )-import GHC.Tc.Utils.TcType-import GHC.Tc.Utils.Unify ( canSolveByUnification )-import GHC.Driver.Session-import GHC.Core.Type-import qualified GHC.Core.TyCo.Rep as Rep  -- this needs to be used only very locally-import GHC.Core.Coercion-import GHC.Core.Unify--import GHC.Tc.Types.Evidence-import GHC.Core.Class-import GHC.Core.TyCon-import GHC.Tc.Errors   ( solverDepthErrorTcS )--import GHC.Types.Name-import GHC.Types.TyThing-import GHC.Unit.Module ( HasModule, getModule )-import GHC.Types.Name.Reader ( GlobalRdrEnv, GlobalRdrElt )-import qualified GHC.Rename.Env as TcM-import GHC.Types.Var-import GHC.Types.Var.Env-import GHC.Types.Var.Set-import GHC.Utils.Outputable-import GHC.Utils.Panic-import GHC.Utils.Logger-import GHC.Data.Bag as Bag-import GHC.Types.Unique.Supply-import GHC.Utils.Misc-import GHC.Tc.Types-import GHC.Tc.Types.Origin-import GHC.Tc.Types.Constraint-import GHC.Core.Predicate--import GHC.Types.Unique.Set-import GHC.Core.TyCon.Env-import GHC.Data.Maybe--import GHC.Core.Map.Type-import GHC.Data.TrieMap--import Control.Monad-import GHC.Utils.Monad-import Data.IORef-import GHC.Exts (oneShot)-import Data.List ( partition, mapAccumL )-import Data.List.NonEmpty ( NonEmpty(..), cons, toList, nonEmpty )-import qualified Data.List.NonEmpty as NE-import Control.Arrow ( first )--#if defined(DEBUG)-import GHC.Data.Graph.Directed-#endif--{--************************************************************************-*                                                                      *-*                            Worklists                                *-*  Canonical and non-canonical constraints that the simplifier has to  *-*  work on. Including their simplification depths.                     *-*                                                                      *-*                                                                      *-************************************************************************--Note [WorkList priorities]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-A WorkList contains canonical and non-canonical items (of all flavours).-Notice that each Ct now has a simplification depth. We may-consider using this depth for prioritization as well in the future.--As a simple form of priority queue, our worklist separates out--* equalities (wl_eqs); see Note [Prioritise equalities]-* all the rest (wl_rest)--Note [Prioritise equalities]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-It's very important to process equalities /first/:--* (Efficiency)  The general reason to do so is that if we process a-  class constraint first, we may end up putting it into the inert set-  and then kicking it out later.  That's extra work compared to just-  doing the equality first.--* (Avoiding fundep iteration) As #14723 showed, it's possible to-  get non-termination if we-      - Emit the Derived fundep equalities for a class constraint,-        generating some fresh unification variables.-      - That leads to some unification-      - Which kicks out the class constraint-      - Which isn't solved (because there are still some more Derived-        equalities in the work-list), but generates yet more fundeps-  Solution: prioritise derived equalities over class constraints--* (Class equalities) We need to prioritise equalities even if they-  are hidden inside a class constraint;-  see Note [Prioritise class equalities]--* (Kick-out) We want to apply this priority scheme to kicked-out-  constraints too (see the call to extendWorkListCt in kick_out_rewritable-  E.g. a CIrredCan can be a hetero-kinded (t1 ~ t2), which may become-  homo-kinded when kicked out, and hence we want to prioritise it.--* (Derived equalities) Originally we tried to postpone processing-  Derived equalities, in the hope that we might never need to deal-  with them at all; but in fact we must process Derived equalities-  eagerly, partly for the (Efficiency) reason, and more importantly-  for (Avoiding fundep iteration).--Note [Prioritise class equalities]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We prioritise equalities in the solver (see selectWorkItem). But class-constraints like (a ~ b) and (a ~~ b) are actually equalities too;-see Note [The equality types story] in GHC.Builtin.Types.Prim.--Failing to prioritise these is inefficient (more kick-outs etc).-But, worse, it can prevent us spotting a "recursive knot" among-Wanted constraints.  See comment:10 of #12734 for a worked-out-example.--So we arrange to put these particular class constraints in the wl_eqs.--  NB: since we do not currently apply the substitution to the-  inert_solved_dicts, the knot-tying still seems a bit fragile.-  But this makes it better.---}---- See Note [WorkList priorities]-data WorkList-  = WL { wl_eqs     :: [Ct]  -- CEqCan, CDictCan, CIrredCan-                             -- Given, Wanted, and Derived-                       -- Contains both equality constraints and their-                       -- class-level variants (a~b) and (a~~b);-                       -- See Note [Prioritise equalities]-                       -- See Note [Prioritise class equalities]--       , wl_rest    :: [Ct]--       , wl_implics :: Bag Implication  -- See Note [Residual implications]-    }--appendWorkList :: WorkList -> WorkList -> WorkList-appendWorkList-    (WL { wl_eqs = eqs1, wl_rest = rest1-        , wl_implics = implics1 })-    (WL { wl_eqs = eqs2, wl_rest = rest2-        , wl_implics = implics2 })-   = WL { wl_eqs     = eqs1     ++ eqs2-        , wl_rest    = rest1    ++ rest2-        , wl_implics = implics1 `unionBags`   implics2 }--workListSize :: WorkList -> Int-workListSize (WL { wl_eqs = eqs, wl_rest = rest })-  = length eqs + length rest--extendWorkListEq :: Ct -> WorkList -> WorkList-extendWorkListEq ct wl = wl { wl_eqs = ct : wl_eqs wl }--extendWorkListNonEq :: Ct -> WorkList -> WorkList--- Extension by non equality-extendWorkListNonEq ct wl = wl { wl_rest = ct : wl_rest wl }--extendWorkListDeriveds :: [CtEvidence] -> WorkList -> WorkList-extendWorkListDeriveds evs wl-  = extendWorkListCts (map mkNonCanonical evs) wl--extendWorkListImplic :: Implication -> WorkList -> WorkList-extendWorkListImplic implic wl = wl { wl_implics = implic `consBag` wl_implics wl }--extendWorkListCt :: Ct -> WorkList -> WorkList--- Agnostic-extendWorkListCt ct wl- = case classifyPredType (ctPred ct) of-     EqPred {}-       -> extendWorkListEq ct wl--     ClassPred cls _  -- See Note [Prioritise class equalities]-       |  isEqPredClass cls-       -> extendWorkListEq ct wl--     _ -> extendWorkListNonEq ct wl--extendWorkListCts :: [Ct] -> WorkList -> WorkList--- Agnostic-extendWorkListCts cts wl = foldr extendWorkListCt wl cts--isEmptyWorkList :: WorkList -> Bool-isEmptyWorkList (WL { wl_eqs = eqs, wl_rest = rest, wl_implics = implics })-  = null eqs && null rest && isEmptyBag implics--emptyWorkList :: WorkList-emptyWorkList = WL { wl_eqs  = [], wl_rest = [], wl_implics = emptyBag }--selectWorkItem :: WorkList -> Maybe (Ct, WorkList)--- See Note [Prioritise equalities]-selectWorkItem wl@(WL { wl_eqs = eqs, wl_rest = rest })-  | ct:cts <- eqs  = Just (ct, wl { wl_eqs    = cts })-  | ct:cts <- rest = Just (ct, wl { wl_rest   = cts })-  | otherwise      = Nothing--getWorkList :: TcS WorkList-getWorkList = do { wl_var <- getTcSWorkListRef-                 ; wrapTcS (TcM.readTcRef wl_var) }--selectNextWorkItem :: TcS (Maybe Ct)--- Pick which work item to do next--- See Note [Prioritise equalities]-selectNextWorkItem-  = do { wl_var <- getTcSWorkListRef-       ; wl <- readTcRef wl_var-       ; case selectWorkItem wl of {-           Nothing -> return Nothing ;-           Just (ct, new_wl) ->-    do { -- checkReductionDepth (ctLoc ct) (ctPred ct)-         -- This is done by GHC.Tc.Solver.Interact.chooseInstance-       ; writeTcRef wl_var new_wl-       ; return (Just ct) } } }---- Pretty printing-instance Outputable WorkList where-  ppr (WL { wl_eqs = eqs, wl_rest = rest, wl_implics = implics })-   = text "WL" <+> (braces $-     vcat [ ppUnless (null eqs) $-            text "Eqs =" <+> vcat (map ppr eqs)-          , ppUnless (null rest) $-            text "Non-eqs =" <+> vcat (map ppr rest)-          , ppUnless (isEmptyBag implics) $-            ifPprDebug (text "Implics =" <+> vcat (map ppr (bagToList implics)))-                       (text "(Implics omitted)")-          ])---{- *********************************************************************-*                                                                      *-                InertSet: the inert set-*                                                                      *-*                                                                      *-********************************************************************* -}--type CycleBreakerVarStack = NonEmpty [(TcTyVar, TcType)]-   -- ^ a stack of (CycleBreakerTv, original family applications) lists-   -- first element in the stack corresponds to current implication;-   --   later elements correspond to outer implications-   -- used to undo the cycle-breaking needed to handle-   -- Note [Type equality cycles] in GHC.Tc.Solver.Canonical-   -- Why store the outer implications? For the use in mightEqualLater (only)--data InertSet-  = IS { inert_cans :: InertCans-              -- Canonical Given, Wanted, Derived-              -- Sometimes called "the inert set"--       , inert_cycle_breakers :: CycleBreakerVarStack--       , inert_famapp_cache :: FunEqMap (TcCoercion, TcType)-              -- Just a hash-cons cache for use when reducing family applications-              -- only-              ---              -- If    F tys :-> (co, rhs, flav),-              -- then  co :: rhs ~N F tys-              -- all evidence is from instances or Givens; no coercion holes here-              -- (We have no way of "kicking out" from the cache, so putting-              --  wanteds here means we can end up solving a Wanted with itself. Bad)--       , inert_solved_dicts   :: DictMap CtEvidence-              -- All Wanteds, of form ev :: C t1 .. tn-              -- See Note [Solved dictionaries]-              -- and Note [Do not add superclasses of solved dictionaries]-       }--instance Outputable InertSet where-  ppr (IS { inert_cans = ics-          , inert_solved_dicts = solved_dicts })-      = vcat [ ppr ics-             , ppUnless (null dicts) $-               text "Solved dicts =" <+> vcat (map ppr dicts) ]-         where-           dicts = bagToList (dictsToBag solved_dicts)--emptyInertCans :: InertCans-emptyInertCans-  = IC { inert_eqs          = emptyDVarEnv-       , inert_given_eq_lvl = topTcLevel-       , inert_given_eqs    = False-       , inert_dicts        = emptyDicts-       , inert_safehask     = emptyDicts-       , inert_funeqs       = emptyFunEqs-       , inert_insts        = []-       , inert_irreds       = emptyCts-       , inert_blocked      = emptyCts }--emptyInert :: InertSet-emptyInert-  = IS { inert_cans           = emptyInertCans-       , inert_cycle_breakers = [] :| []-       , inert_famapp_cache   = emptyFunEqs-       , inert_solved_dicts   = emptyDictMap }---{- Note [Solved dictionaries]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When we apply a top-level instance declaration, we add the "solved"-dictionary to the inert_solved_dicts.  In general, we use it to avoid-creating a new EvVar when we have a new goal that we have solved in-the past.--But in particular, we can use it to create *recursive* dictionaries.-The simplest, degenerate case is-    instance C [a] => C [a] where ...-If we have-    [W] d1 :: C [x]-then we can apply the instance to get-    d1 = $dfCList d-    [W] d2 :: C [x]-Now 'd1' goes in inert_solved_dicts, and we can solve d2 directly from d1.-    d1 = $dfCList d-    d2 = d1--See Note [Example of recursive dictionaries]--VERY IMPORTANT INVARIANT:-- (Solved Dictionary Invariant)-    Every member of the inert_solved_dicts is the result-    of applying an instance declaration that "takes a step"--    An instance "takes a step" if it has the form-        dfunDList d1 d2 = MkD (...) (...) (...)-    That is, the dfun is lazy in its arguments, and guarantees to-    immediately return a dictionary constructor.  NB: all dictionary-    data constructors are lazy in their arguments.--    This property is crucial to ensure that all dictionaries are-    non-bottom, which in turn ensures that the whole "recursive-    dictionary" idea works at all, even if we get something like-        rec { d = dfunDList d dx }-    See Note [Recursive superclasses] in GHC.Tc.TyCl.Instance.-- Reason:-   - All instances, except two exceptions listed below, "take a step"-     in the above sense--   - Exception 1: local quantified constraints have no such guarantee;-     indeed, adding a "solved dictionary" when appling a quantified-     constraint led to the ability to define unsafeCoerce-     in #17267.--   - Exception 2: the magic built-in instance for (~) has no-     such guarantee.  It behaves as if we had-         class    (a ~# b) => (a ~ b) where {}-         instance (a ~# b) => (a ~ b) where {}-     The "dfun" for the instance is strict in the coercion.-     Anyway there's no point in recording a "solved dict" for-     (t1 ~ t2); it's not going to allow a recursive dictionary-     to be constructed.  Ditto (~~) and Coercible.--THEREFORE we only add a "solved dictionary"-  - when applying an instance declaration-  - subject to Exceptions 1 and 2 above--In implementation terms-  - GHC.Tc.Solver.Monad.addSolvedDict adds a new solved dictionary,-    conditional on the kind of instance--  - It is only called when applying an instance decl,-    in GHC.Tc.Solver.Interact.doTopReactDict--  - ClsInst.InstanceWhat says what kind of instance was-    used to solve the constraint.  In particular-      * LocalInstance identifies quantified constraints-      * BuiltinEqInstance identifies the strange built-in-        instances for equality.--  - ClsInst.instanceReturnsDictCon says which kind of-    instance guarantees to return a dictionary constructor--Other notes about solved dictionaries--* See also Note [Do not add superclasses of solved dictionaries]--* The inert_solved_dicts field is not rewritten by equalities,-  so it may get out of date.--* The inert_solved_dicts are all Wanteds, never givens--* We only cache dictionaries from top-level instances, not from-  local quantified constraints.  Reason: if we cached the latter-  we'd need to purge the cache when bringing new quantified-  constraints into scope, because quantified constraints "shadow"-  top-level instances.--Note [Do not add superclasses of solved dictionaries]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Every member of inert_solved_dicts is the result of applying a-dictionary function, NOT of applying superclass selection to anything.-Consider--        class Ord a => C a where-        instance Ord [a] => C [a] where ...--Suppose we are trying to solve-  [G] d1 : Ord a-  [W] d2 : C [a]--Then we'll use the instance decl to give--  [G] d1 : Ord a     Solved: d2 : C [a] = $dfCList d3-  [W] d3 : Ord [a]--We must not add d4 : Ord [a] to the 'solved' set (by taking the-superclass of d2), otherwise we'll use it to solve d3, without ever-using d1, which would be a catastrophe.--Solution: when extending the solved dictionaries, do not add superclasses.-That's why each element of the inert_solved_dicts is the result of applying-a dictionary function.--Note [Example of recursive dictionaries]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~---- Example 1--    data D r = ZeroD | SuccD (r (D r));--    instance (Eq (r (D r))) => Eq (D r) where-        ZeroD     == ZeroD     = True-        (SuccD a) == (SuccD b) = a == b-        _         == _         = False;--    equalDC :: D [] -> D [] -> Bool;-    equalDC = (==);--We need to prove (Eq (D [])). Here's how we go:--   [W] d1 : Eq (D [])-By instance decl of Eq (D r):-   [W] d2 : Eq [D []]      where   d1 = dfEqD d2-By instance decl of Eq [a]:-   [W] d3 : Eq (D [])      where   d2 = dfEqList d3-                                   d1 = dfEqD d2-Now this wanted can interact with our "solved" d1 to get:-    d3 = d1---- Example 2:-This code arises in the context of "Scrap Your Boilerplate with Class"--    class Sat a-    class Data ctx a-    instance  Sat (ctx Char)             => Data ctx Char       -- dfunData1-    instance (Sat (ctx [a]), Data ctx a) => Data ctx [a]        -- dfunData2--    class Data Maybe a => Foo a--    instance Foo t => Sat (Maybe t)                             -- dfunSat--    instance Data Maybe a => Foo a                              -- dfunFoo1-    instance Foo a        => Foo [a]                            -- dfunFoo2-    instance                 Foo [Char]                         -- dfunFoo3--Consider generating the superclasses of the instance declaration-         instance Foo a => Foo [a]--So our problem is this-    [G] d0 : Foo t-    [W] d1 : Data Maybe [t]   -- Desired superclass--We may add the given in the inert set, along with its superclasses-  Inert:-    [G] d0 : Foo t-    [G] d01 : Data Maybe t   -- Superclass of d0-  WorkList-    [W] d1 : Data Maybe [t]--Solve d1 using instance dfunData2; d1 := dfunData2 d2 d3-  Inert:-    [G] d0 : Foo t-    [G] d01 : Data Maybe t   -- Superclass of d0-  Solved:-        d1 : Data Maybe [t]-  WorkList:-    [W] d2 : Sat (Maybe [t])-    [W] d3 : Data Maybe t--Now, we may simplify d2 using dfunSat; d2 := dfunSat d4-  Inert:-    [G] d0 : Foo t-    [G] d01 : Data Maybe t   -- Superclass of d0-  Solved:-        d1 : Data Maybe [t]-        d2 : Sat (Maybe [t])-  WorkList:-    [W] d3 : Data Maybe t-    [W] d4 : Foo [t]--Now, we can just solve d3 from d01; d3 := d01-  Inert-    [G] d0 : Foo t-    [G] d01 : Data Maybe t   -- Superclass of d0-  Solved:-        d1 : Data Maybe [t]-        d2 : Sat (Maybe [t])-  WorkList-    [W] d4 : Foo [t]--Now, solve d4 using dfunFoo2;  d4 := dfunFoo2 d5-  Inert-    [G] d0  : Foo t-    [G] d01 : Data Maybe t   -- Superclass of d0-  Solved:-        d1 : Data Maybe [t]-        d2 : Sat (Maybe [t])-        d4 : Foo [t]-  WorkList:-    [W] d5 : Foo t--Now, d5 can be solved! d5 := d0--Result-   d1 := dfunData2 d2 d3-   d2 := dfunSat d4-   d3 := d01-   d4 := dfunFoo2 d5-   d5 := d0--}--{- *********************************************************************-*                                                                      *-                InertCans: the canonical inerts-*                                                                      *-*                                                                      *-********************************************************************* -}--data InertCans   -- See Note [Detailed InertCans Invariants] for more-  = IC { inert_eqs :: InertEqs-              -- See Note [inert_eqs: the inert equalities]-              -- All CEqCans with a TyVarLHS; index is the LHS tyvar-              -- Domain = skolems and untouchables; a touchable would be unified--       , inert_funeqs :: FunEqMap EqualCtList-              -- All CEqCans with a TyFamLHS; index is the whole family head type.-              -- LHS is fully rewritten (modulo eqCanRewrite constraints)-              --     wrt inert_eqs-              -- Can include all flavours, [G], [W], [WD], [D]--       , inert_dicts :: DictMap Ct-              -- Dictionaries only-              -- All fully rewritten (modulo flavour constraints)-              --     wrt inert_eqs--       , inert_insts :: [QCInst]--       , inert_safehask :: DictMap Ct-              -- Failed dictionary resolution due to Safe Haskell overlapping-              -- instances restriction. We keep this separate from inert_dicts-              -- as it doesn't cause compilation failure, just safe inference-              -- failure.-              ---              -- ^ See Note [Safe Haskell Overlapping Instances Implementation]-              -- in "GHC.Tc.Solver"--       , inert_irreds :: Cts-              -- Irreducible predicates that cannot be made canonical,-              --     and which don't interact with others (e.g.  (c a))-              -- and insoluble predicates (e.g.  Int ~ Bool, or a ~ [a])--       , inert_blocked :: Cts-              -- Equality predicates blocked on a coercion hole.-              -- Each Ct is a CIrredCan with cc_reason = HoleBlockerReason-              -- See Note [Equalities with incompatible kinds] in GHC.Tc.Solver.Canonical-              -- wrinkle (2)-              -- These are stored separately from inert_irreds because-              -- they get kicked out for different reasons---       , inert_given_eq_lvl :: TcLevel-              -- The TcLevel of the innermost implication that has a Given-              -- equality of the sort that make a unification variable untouchable-              -- (see Note [Unification preconditions] in GHC.Tc.Utils.Unify).-              -- See Note [Tracking Given equalities] below--       , inert_given_eqs :: Bool-              -- True <=> The inert Givens *at this level* (tcl_tclvl)-              --          could includes at least one equality /other than/ a-              --          let-bound skolem equality.-              -- Reason: report these givens when reporting a failed equality-              -- See Note [Tracking Given equalities]-       }--type InertEqs    = DTyVarEnv EqualCtList--newtype EqualCtList = EqualCtList (NonEmpty Ct)-  deriving newtype Outputable-  -- See Note [EqualCtList invariants]--unitEqualCtList :: Ct -> EqualCtList-unitEqualCtList ct = EqualCtList (ct :| [])--addToEqualCtList :: Ct -> EqualCtList -> EqualCtList--- NB: This function maintains the "derived-before-wanted" invariant of EqualCtList,--- but not the others. See Note [EqualCtList invariants]-addToEqualCtList ct (EqualCtList old_eqs)-  | isWantedCt ct-  , eq1 :| eqs <- old_eqs-  = EqualCtList (eq1 :| ct : eqs)-  | otherwise-  = EqualCtList (ct `cons` old_eqs)--filterEqualCtList :: (Ct -> Bool) -> EqualCtList -> Maybe EqualCtList-filterEqualCtList pred (EqualCtList cts)-  = fmap EqualCtList (nonEmpty $ NE.filter pred cts)--equalCtListToList :: EqualCtList -> [Ct]-equalCtListToList (EqualCtList cts) = toList cts--listToEqualCtList :: [Ct] -> Maybe EqualCtList--- NB: This does not maintain invariants other than having the EqualCtList be--- non-empty-listToEqualCtList cts = EqualCtList <$> nonEmpty cts--{- Note [Tracking Given equalities]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-For reasons described in (UNTOUCHABLE) in GHC.Tc.Utils.Unify-Note [Unification preconditions], we can't unify-   alpha[2] ~ Int-under a level-4 implication if there are any Given equalities-bound by the implications at level 3 of 4.  To that end, the-InertCans tracks--  inert_given_eq_lvl :: TcLevel-     -- The TcLevel of the innermost implication that has a Given-     -- equality of the sort that make a unification variable untouchable-     -- (see Note [Unification preconditions] in GHC.Tc.Utils.Unify).--We update inert_given_eq_lvl whenever we add a Given to the-inert set, in updateGivenEqs.--Then a unification variable alpha[n] is untouchable iff-    n < inert_given_eq_lvl-that is, if the unification variable was born outside an-enclosing Given equality.--Exactly which constraints should trigger (UNTOUCHABLE), and hence-should update inert_given_eq_lvl?--* We do /not/ need to worry about let-bound skolems, such ast-     forall[2] a. a ~ [b] => blah-  See Note [Let-bound skolems]--* Consider an implication-      forall[2]. beta[1] => alpha[1] ~ Int-  where beta is a unification variable that has already been unified-  to () in an outer scope.  Then alpha[1] is perfectly touchable and-  we can unify alpha := Int. So when deciding whether the givens contain-  an equality, we should canonicalise first, rather than just looking at-  the /original/ givens (#8644).-- * However, we must take account of *potential* equalities. Consider the-   same example again, but this time we have /not/ yet unified beta:-      forall[2] beta[1] => ...blah...--   Because beta might turn into an equality, updateGivenEqs conservatively-   treats it as a potential equality, and updates inert_give_eq_lvl-- * What about something like forall[2] a b. a ~ F b => [W] alpha[1] ~ X y z?--   That Given cannot affect the Wanted, because the Given is entirely-   *local*: it mentions only skolems bound in the very same-   implication. Such equalities need not make alpha untouchable. (Test-   case typecheck/should_compile/LocalGivenEqs has a real-life-   motivating example, with some detailed commentary.)-   Hence the 'mentionsOuterVar' test in updateGivenEqs.--   However, solely to support better error messages-   (see Note [HasGivenEqs] in GHC.Tc.Types.Constraint) we also track-   these "local" equalities in the boolean inert_given_eqs field.-   This field is used only to set the ic_given_eqs field to LocalGivenEqs;-   see the function getHasGivenEqs.--   Here is a simpler case that triggers this behaviour:--     data T where-       MkT :: F a ~ G b => a -> b -> T--     f (MkT _ _) = True--   Because of this behaviour around local equality givens, we can infer the-   type of f. This is typecheck/should_compile/LocalGivenEqs2.-- * We need not look at the equality relation involved (nominal vs-   representational), because representational equalities can still-   imply nominal ones. For example, if (G a ~R G b) and G's argument's-   role is nominal, then we can deduce a ~N b.--Note [Let-bound skolems]-~~~~~~~~~~~~~~~~~~~~~~~~-If   * the inert set contains a canonical Given CEqCan (a ~ ty)-and  * 'a' is a skolem bound in this very implication,--then:-a) The Given is pretty much a let-binding, like-      f :: (a ~ b->c) => a -> a-   Here the equality constraint is like saying-      let a = b->c in ...-   It is not adding any new, local equality  information,-   and hence can be ignored by has_given_eqs--b) 'a' will have been completely substituted out in the inert set,-   so we can safely discard it.--For an example, see #9211.--See also GHC.Tc.Utils.Unify Note [Deeper level on the left] for how we ensure-that the right variable is on the left of the equality when both are-tyvars.--You might wonder whether the skolem really needs to be bound "in the-very same implication" as the equuality constraint.-Consider this (c.f. #15009):--  data S a where-    MkS :: (a ~ Int) => S a--  g :: forall a. S a -> a -> blah-  g x y = let h = \z. ( z :: Int-                      , case x of-                           MkS -> [y,z])-          in ...--From the type signature for `g`, we get `y::a` .  Then when we-encounter the `\z`, we'll assign `z :: alpha[1]`, say.  Next, from the-body of the lambda we'll get--  [W] alpha[1] ~ Int                             -- From z::Int-  [W] forall[2]. (a ~ Int) => [W] alpha[1] ~ a   -- From [y,z]--Now, unify alpha := a.  Now we are stuck with an unsolved alpha~Int!-So we must treat alpha as untouchable under the forall[2] implication.--Note [Detailed InertCans Invariants]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The InertCans represents a collection of constraints with the following properties:--  * All canonical--  * No two dictionaries with the same head-  * No two CIrreds with the same type--  * Family equations inert wrt top-level family axioms--  * Dictionaries have no matching top-level instance--  * Given family or dictionary constraints don't mention touchable-    unification variables--  * Non-CEqCan constraints are fully rewritten with respect-    to the CEqCan equalities (modulo eqCanRewrite of course;-    eg a wanted cannot rewrite a given)--  * CEqCan equalities: see Note [inert_eqs: the inert equalities]-    Also see documentation in Constraint.Ct for a list of invariants--Note [EqualCtList invariants]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-    * All are equalities-    * All these equalities have the same LHS-    * The list is never empty-    * No element of the list can rewrite any other-    * Derived before Wanted--From the fourth invariant it follows that the list is-   - A single [G], or-   - Zero or one [D] or [WD], followed by any number of [W]--The Wanteds can't rewrite anything which is why we put them last--Note [inert_eqs: the inert equalities]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Definition [Can-rewrite relation]-A "can-rewrite" relation between flavours, written f1 >= f2, is a-binary relation with the following properties--  (R1) >= is transitive-  (R2) If f1 >= f, and f2 >= f,-       then either f1 >= f2 or f2 >= f1-  (See Note [Why R2?].)--Lemma (L0). If f1 >= f then f1 >= f1-Proof.      By property (R2), with f1=f2--Definition [Generalised substitution]-A "generalised substitution" S is a set of triples (lhs -f-> t), where-  lhs is a type variable or an exactly-saturated type family application-    (that is, lhs is a CanEqLHS)-  t is a type-  f is a flavour-such that-  (WF1) if (lhs1 -f1-> t1) in S-           (lhs2 -f2-> t2) in S-        then (f1 >= f2) implies that lhs1 does not appear within lhs2-  (WF2) if (lhs -f-> t) is in S, then t /= lhs--Definition [Applying a generalised substitution]-If S is a generalised substitution-   S(f,t0) = t,  if (t0 -fs-> t) in S, and fs >= f-           = apply S to components of t0, otherwise-See also Note [Flavours with roles].--Theorem: S(f,t0) is well defined as a function.-Proof: Suppose (lhs -f1-> t1) and (lhs -f2-> t2) are both in S,-               and  f1 >= f and f2 >= f-       Then by (R2) f1 >= f2 or f2 >= f1, which contradicts (WF1)--Notation: repeated application.-  S^0(f,t)     = t-  S^(n+1)(f,t) = S(f, S^n(t))--Definition: terminating generalised substitution-A generalised substitution S is *terminating* iff--  (IG1) there is an n such that-        for every f,t, S^n(f,t) = S^(n+1)(f,t)--By (IG1) we define S*(f,t) to be the result of exahaustively-applying S(f,_) to t.--------------------------------------------------------------------------------Our main invariant:-   the CEqCans in inert_eqs should be a terminating generalised substitution--------------------------------------------------------------------------------Note that termination is not the same as idempotence.  To apply S to a-type, you may have to apply it recursively.  But termination does-guarantee that this recursive use will terminate.--Note [Why R2?]-~~~~~~~~~~~~~~-R2 states that, if we have f1 >= f and f2 >= f, then either f1 >= f2 or f2 >=-f1. If we do not have R2, we will easily fall into a loop.--To see why, imagine we have f1 >= f, f2 >= f, and that's it. Then, let our-inert set S = {a -f1-> b, b -f2-> a}. Computing S(f,a) does not terminate. And-yet, we have a hard time noticing an occurs-check problem when building S, as-the two equalities cannot rewrite one another.--R2 actually restricts our ability to accept user-written programs. See Note-[Deriveds do rewrite Deriveds] in GHC.Tc.Types.Constraint for an example.--Note [Rewritable]-~~~~~~~~~~~~~~~~~-This Note defines what it means for a type variable or type family application-(that is, a CanEqLHS) to be rewritable in a type. This definition is used-by the anyRewritableXXX family of functions and is meant to model the actual-behaviour in GHC.Tc.Solver.Rewrite.--Ignoring roles (for now): A CanEqLHS lhs is *rewritable* in a type t if the-lhs tree appears as a subtree within t without traversing any of the following-components of t:-  * coercions (whether they appear in casts CastTy or as arguments CoercionTy)-  * kinds of variable occurrences-The check for rewritability *does* look in kinds of the bound variable of a-ForAllTy.--Goal: If lhs is not rewritable in t, then t is a fixpoint of the generalised-substitution containing only {lhs -f*-> t'}, where f* is a flavour such that f* >= f-for all f.--The reason for this definition is that the rewriter does not rewrite in coercions-or variables' kinds. In turn, the rewriter does not need to rewrite there because-those places are never used for controlling the behaviour of the solver: these-places are not used in matching instances or in decomposing equalities.--There is one exception to the claim that non-rewritable parts of the tree do-not affect the solver: we sometimes do an occurs-check to decide e.g. how to-orient an equality. (See the comments on-GHC.Tc.Solver.Canonical.canEqTyVarFunEq.) Accordingly, the presence of a-variable in a kind or coercion just might influence the solver. Here is an-example:--  type family Const x y where-    Const x y = x--  AxConst :: forall x y. Const x y ~# x--  alpha :: Const Type Nat-  [W] alpha ~ Int |> (sym (AxConst Type alpha) ;;-                      AxConst Type alpha ;;-                      sym (AxConst Type Nat))--The cast is clearly ludicrous (it ties together a cast and its symmetric version),-but we can't quite rule it out. (See (EQ1) from-Note [Respecting definitional equality] in GHC.Core.TyCo.Rep to see why we need-the Const Type Nat bit.) And yet this cast will (quite rightly) prevent alpha-from unifying with the RHS. I (Richard E) don't have an example of where this-problem can arise from a Haskell program, but we don't have an air-tight argument-for why the definition of *rewritable* given here is correct.--Taking roles into account: we must consider a rewrite at a given role. That is,-a rewrite arises from some equality, and that equality has a role associated-with it. As we traverse a type, we track what role we are allowed to rewrite with.--For example, suppose we have an inert [G] b ~R# Int. Then b is rewritable in-Maybe b but not in F b, where F is a type function. This role-aware logic is-present in both the anyRewritableXXX functions and in the rewriter.-See also Note [anyRewritableTyVar must be role-aware] in GHC.Tc.Utils.TcType.--Note [Extending the inert equalities]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Main Theorem [Stability under extension]-   Suppose we have a "work item"-       lhs -fw-> t-   and a terminating generalised substitution S,-   THEN the extended substitution T = S+(lhs -fw-> t)-        is a terminating generalised substitution-   PROVIDED-      (T1) S(fw,lhs) = lhs   -- LHS of work-item is a fixpoint of S(fw,_)-      (T2) S(fw,t)   = t     -- RHS of work-item is a fixpoint of S(fw,_)-      (T3) lhs not in t      -- No occurs check in the work item-          -- If lhs is a type family application, we require only that-          -- lhs is not *rewritable* in t. See Note [Rewritable] and-          -- Note [CEqCan occurs check] in GHC.Tc.Types.Constraint.--      AND, for every (lhs1 -fs-> s) in S:-           (K0) not (fw >= fs)-                Reason: suppose we kick out (lhs1 -fs-> s),-                        and add (lhs -fw-> t) to the inert set.-                        The latter can't rewrite the former,-                        so the kick-out achieved nothing--              -- From here, we can assume fw >= fs-           OR (K4) lhs1 is a tyvar AND fs >= fw--           OR { (K1) lhs is not rewritable in lhs1. See Note [Rewritable].-                     Reason: if fw >= fs, WF1 says we can't have both-                             lhs0 -fw-> t  and  F lhs0 -fs-> s--                AND (K2): guarantees termination of the new substitution-                    {  (K2a) not (fs >= fs)-                    OR (K2b) lhs not in s }--                AND (K3) See Note [K3: completeness of solving]-                    { (K3a) If the role of fs is nominal: s /= lhs-                      (K3b) If the role of fs is representational:-                            s is not of form (lhs t1 .. tn) } }---Conditions (T1-T3) are established by the canonicaliser-Conditions (K1-K3) are established by GHC.Tc.Solver.Monad.kickOutRewritable--The idea is that-* T1 and T2 are guaranteed by exhaustively rewriting the work-item-  with S(fw,_).--* T3 is guaranteed by an occurs-check on the work item.-  This is done during canonicalisation, in checkTypeEq; invariant-  (TyEq:OC) of CEqCan. See also Note [CEqCan occurs check] in GHC.Tc.Types.Constraint.--* (K1-3) are the "kick-out" criteria.  (As stated, they are really the-  "keep" criteria.) If the current inert S contains a triple that does-  not satisfy (K1-3), then we remove it from S by "kicking it out",-  and re-processing it.--* Note that kicking out is a Bad Thing, because it means we have to-  re-process a constraint.  The less we kick out, the better.-  TODO: Make sure that kicking out really *is* a Bad Thing. We've assumed-  this but haven't done the empirical study to check.--* Assume we have  G>=G, G>=W and that's all.  Then, when performing-  a unification we add a new given  a -G-> ty.  But doing so does NOT require-  us to kick out an inert wanted that mentions a, because of (K2a).  This-  is a common case, hence good not to kick out. See also (K2a) below.--* Lemma (L2): if not (fw >= fw), then K0 holds and we kick out nothing-  Proof: using Definition [Can-rewrite relation], fw can't rewrite anything-         and so K0 holds.  Intuitively, since fw can't rewrite anything (Lemma (L0)),-         adding it cannot cause any loops-  This is a common case, because Wanteds cannot rewrite Wanteds.-  It's used to avoid even looking for constraint to kick out.--* Lemma (L1): The conditions of the Main Theorem imply that there is no-              (lhs -fs-> t) in S, s.t.  (fs >= fw).-  Proof. Suppose the contrary (fs >= fw).  Then because of (T1),-  S(fw,lhs)=lhs.  But since fs>=fw, S(fw,lhs) = t, hence t=lhs.  But now we-  have (lhs -fs-> lhs) in S, which contradicts (WF2).--* The extended substitution satisfies (WF1) and (WF2)-  - (K1) plus (L1) guarantee that the extended substitution satisfies (WF1).-  - (T3) guarantees (WF2).--* (K2) and (K4) are about termination.  Intuitively, any infinite chain S^0(f,t),-  S^1(f,t), S^2(f,t).... must pass through the new work item infinitely-  often, since the substitution without the work item is terminating; and must-  pass through at least one of the triples in S infinitely often.--  - (K2a): if not(fs>=fs) then there is no f that fs can rewrite (fs>=f)-    (this is Lemma (L0)), and hence this triple never plays a role in application S(f,t).-    It is always safe to extend S with such a triple.--    (NB: we could strengten K1) in this way too, but see K3.--  - (K2b): if lhs not in s, we have no further opportunity to apply the-    work item--  - (K4): See Note [K4]--* Lemma (L3). Suppose we have f* such that, for all f, f* >= f. Then-  if we are adding lhs -fw-> t (where T1, T2, and T3 hold), we will keep a -f*-> s.-  Proof. K4 holds; thus, we keep.--Key lemma to make it watertight.-  Under the conditions of the Main Theorem,-  forall f st fw >= f, a is not in S^k(f,t), for any k--Also, consider roles more carefully. See Note [Flavours with roles]--Note [K4]-~~~~~~~~~-K4 is a "keep" condition of Note [Extending the inert equalities].-Here is the scenario:--* We are considering adding (lhs -fw-> t) to the inert set S.-* S already has (lhs1 -fs-> s).-* We know S(fw, lhs) = lhs, S(fw, t) = t, and lhs is not rewritable in t.-  See Note [Rewritable]. These are (T1), (T2), and (T3).-* We further know fw >= fs. (If not, then we short-circuit via (K0).)--K4 says that we may keep lhs1 -fs-> s in S if:-  lhs1 is a tyvar AND fs >= fw--Why K4 guarantees termination:-  * If fs >= fw, we know a is not rewritable in t, because of (T2).-  * We further know lhs /= a, because of (T1).-  * Accordingly, a use of the new inert item lhs -fw-> t cannot create the conditions-    for a use of a -fs-> s (precisely because t does not mention a), and hence,-    the extended substitution (with lhs -fw-> t in it) is a terminating-    generalised substitution.--Recall that the termination generalised substitution includes only mappings that-pass an occurs check. This is (T3). At one point, we worried that the-argument here would fail if s mentioned a, but (T3) rules out this possibility.-Put another way: the terminating generalised substitution considers only the inert_eqs,-not other parts of the inert set (such as the irreds).--Can we liberalise K4? No.--Why we cannot drop the (fs >= fw) condition:-  * Suppose not (fs >= fw). It might be the case that t mentions a, and this-    can cause a loop. Example:--      Work:  [G] b ~ a-      Inert: [D] a ~ b--    (where G >= G, G >= D, and D >= D)-    If we don't kick out the inert, then we get a loop on e.g. [D] a ~ Int.--  * Note that the above example is different if the inert is a Given G, because-    (T1) won't hold.--Why we cannot drop the tyvar condition:-  * Presume fs >= fw. Thus, F tys is not rewritable in t, because of (T2).-  * Can the use of lhs -fw-> t create the conditions for a use of F tys -fs-> s?-    Yes! This can happen if t appears within tys.--    Here is an example:--      Work:  [G] a ~ Int-      Inert: [G] F Int ~ F a--    Now, if we have [W] F a ~ Bool, we will rewrite ad infinitum on the left-hand-    side. The key reason why K2b works in the tyvar case is that tyvars are atomic:-    if the right-hand side of an equality does not mention a variable a, then it-    cannot allow an equality with an LHS of a to fire. This is not the case for-    type family applications.--Bottom line: K4 can keep only inerts with tyvars on the left. Put differently,-K4 will never prevent an inert with a type family on the left from being kicked-out.--Consequence: We never kick out a Given/Nominal equality with a tyvar on the left.-This is Lemma (L3) of Note [Extending the inert equalities]. It is good because-it means we can effectively model the mutable filling of metavariables with-Given/Nominal equalities. That is: it should be the case that we could rewrite-our solver never to fill in a metavariable; instead, it would "solve" a wanted-like alpha ~ Int by turning it into a Given, allowing it to be used in rewriting.-We would want the solver to behave the same whether it uses metavariables or-Givens. And (L3) says that no Given/Nominals over tyvars are ever kicked out,-just like we never unfill a metavariable. Nice.--Getting this wrong (that is, allowing K4 to apply to situations with the type-family on the left) led to #19042. (At that point, K4 was known as K2b.)--Originally, this condition was part of K2, but #17672 suggests it should be-a top-level K condition.--Note [K3: completeness of solving]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-(K3) is not necessary for the extended substitution-to be terminating.  In fact K1 could be made stronger by saying-   ... then (not (fw >= fs) or not (fs >= fs))-But it's not enough for S to be terminating; we also want completeness.-That is, we want to be able to solve all soluble wanted equalities.-Suppose we have--   work-item   b -G-> a-   inert-item  a -W-> b--Assuming (G >= W) but not (W >= W), this fulfills all the conditions,-so we could extend the inerts, thus:--   inert-items   b -G-> a-                 a -W-> b--But if we kicked-out the inert item, we'd get--   work-item     a -W-> b-   inert-item    b -G-> a--Then rewrite the work-item gives us (a -W-> a), which is soluble via Refl.-So we add one more clause to the kick-out criteria--Another way to understand (K3) is that we treat an inert item-        a -f-> b-in the same way as-        b -f-> a-So if we kick out one, we should kick out the other.  The orientation-is somewhat accidental.--When considering roles, we also need the second clause (K3b). Consider--  work-item    c -G/N-> a-  inert-item   a -W/R-> b c--The work-item doesn't get rewritten by the inert, because (>=) doesn't hold.-But we don't kick out the inert item because not (W/R >= W/R).  So we just-add the work item. But then, consider if we hit the following:--  work-item    b -G/N-> Id-  inert-items  a -W/R-> b c-               c -G/N-> a-where-  newtype Id x = Id x--For similar reasons, if we only had (K3a), we wouldn't kick the-representational inert out. And then, we'd miss solving the inert, which-now reduced to reflexivity.--The solution here is to kick out representational inerts whenever the-lhs of a work item is "exposed", where exposed means being at the-head of the top-level application chain (lhs t1 .. tn).  See-is_can_eq_lhs_head. This is encoded in (K3b).--Beware: if we make this test succeed too often, we kick out too much,-and the solver might loop.  Consider (#14363)-  work item:   [G] a ~R f b-  inert item:  [G] b ~R f a-In GHC 8.2 the completeness tests more aggressive, and kicked out-the inert item; but no rewriting happened and there was an infinite-loop.  All we need is to have the tyvar at the head.--Note [Flavours with roles]-~~~~~~~~~~~~~~~~~~~~~~~~~~-The system described in Note [inert_eqs: the inert equalities]-discusses an abstract-set of flavours. In GHC, flavours have two components: the flavour proper,-taken from {Wanted, Derived, Given} and the equality relation (often called-role), taken from {NomEq, ReprEq}.-When substituting w.r.t. the inert set,-as described in Note [inert_eqs: the inert equalities],-we must be careful to respect all components of a flavour.-For example, if we have--  inert set: a -G/R-> Int-             b -G/R-> Bool--  type role T nominal representational--and we wish to compute S(W/R, T a b), the correct answer is T a Bool, NOT-T Int Bool. The reason is that T's first parameter has a nominal role, and-thus rewriting a to Int in T a b is wrong. Indeed, this non-congruence of-substitution means that the proof in Note [The inert equalities] may need-to be revisited, but we don't think that the end conclusion is wrong.--}--instance Outputable InertCans where-  ppr (IC { inert_eqs = eqs-          , inert_funeqs = funeqs-          , inert_dicts = dicts-          , inert_safehask = safehask-          , inert_irreds = irreds-          , inert_blocked = blocked-          , inert_given_eq_lvl = ge_lvl-          , inert_given_eqs = given_eqs-          , inert_insts = insts })--    = braces $ vcat-      [ ppUnless (isEmptyDVarEnv eqs) $-        text "Equalities:"-          <+> pprCts (foldDVarEnv folder emptyCts eqs)-      , ppUnless (isEmptyTcAppMap funeqs) $-        text "Type-function equalities =" <+> pprCts (foldFunEqs folder funeqs emptyCts)-      , ppUnless (isEmptyTcAppMap dicts) $-        text "Dictionaries =" <+> pprCts (dictsToBag dicts)-      , ppUnless (isEmptyTcAppMap safehask) $-        text "Safe Haskell unsafe overlap =" <+> pprCts (dictsToBag safehask)-      , ppUnless (isEmptyCts irreds) $-        text "Irreds =" <+> pprCts irreds-      , ppUnless (isEmptyCts blocked) $-        text "Blocked =" <+> pprCts blocked-      , ppUnless (null insts) $-        text "Given instances =" <+> vcat (map ppr insts)-      , text "Innermost given equalities =" <+> ppr ge_lvl-      , text "Given eqs at this level =" <+> ppr given_eqs-      ]-    where-      folder (EqualCtList eqs) rest = nonEmptyToBag eqs `andCts` rest--{- *********************************************************************-*                                                                      *-             Shadow constraints and improvement-*                                                                      *-************************************************************************--Note [The improvement story and derived shadows]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Because Wanteds cannot rewrite Wanteds (see Note [Wanteds do not-rewrite Wanteds] in GHC.Tc.Types.Constraint), we may miss some opportunities for-solving.  Here's a classic example (indexed-types/should_fail/T4093a)--    Ambiguity check for f: (Foo e ~ Maybe e) => Foo e--    We get [G] Foo e ~ Maybe e    (CEqCan)-           [W] Foo ee ~ Foo e     (CEqCan)       -- ee is a unification variable-           [W] Foo ee ~ Maybe ee  (CEqCan)--    The first Wanted gets rewritten to--           [W] Foo ee ~ Maybe e--    But now we appear to be stuck, since we don't rewrite Wanteds with-    Wanteds.  This is silly because we can see that ee := e is the-    only solution.--The basic plan is-  * generate Derived constraints that shadow Wanted constraints-  * allow Derived to rewrite Derived-  * in order to cause some unifications to take place-  * that in turn solve the original Wanteds--The ONLY reason for all these Derived equalities is to tell us how to-unify a variable: that is, what Mark Jones calls "improvement".--The same idea is sometimes also called "saturation"; find all the-equalities that must hold in any solution.--Or, equivalently, you can think of the derived shadows as implementing-the "model": a non-idempotent but no-occurs-check substitution,-reflecting *all* *Nominal* equalities (a ~N ty) that are not-immediately soluble by unification.--More specifically, here's how it works (Oct 16):--* Wanted constraints are born as [WD]; this behaves like a-  [W] and a [D] paired together.--* When we are about to add a [WD] to the inert set, if it can-  be rewritten by a [D] a ~ ty, then we split it into [W] and [D],-  putting the latter into the work list (see maybeEmitShadow).--In the example above, we get to the point where we are stuck:-    [WD] Foo ee ~ Foo e-    [WD] Foo ee ~ Maybe ee--But now when [WD] Foo ee ~ Maybe ee is about to be added, we'll-split it into [W] and [D], since the inert [WD] Foo ee ~ Foo e-can rewrite it.  Then:-    work item: [D] Foo ee ~ Maybe ee-    inert:     [W] Foo ee ~ Maybe ee-               [WD] Foo ee ~ Maybe e--See Note [Splitting WD constraints].  Now the work item is rewritten-by the [WD] and we soon get ee := e.--Additional notes:--  * The derived shadow equalities live in inert_eqs, along with-    the Givens and Wanteds; see Note [EqualCtList invariants].--  * We make Derived shadows only for Wanteds, not Givens.  So we-    have only [G], not [GD] and [G] plus splitting.  See-    Note [Add derived shadows only for Wanteds]--  * We also get Derived equalities from functional dependencies-    and type-function injectivity; see calls to unifyDerived.--  * It's worth having [WD] rather than just [W] and [D] because-    * efficiency: silly to process the same thing twice-    * inert_dicts is a finite map keyed by-      the type; it's inconvenient for it to map to TWO constraints--Another example requiring Deriveds is in-Note [Put touchable variables on the left] in GHC.Tc.Solver.Canonical.--Note [Splitting WD constraints]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We are about to add a [WD] constraint to the inert set; and we-know that the inert set has fully rewritten it.  Should we split-it into [W] and [D], and put the [D] in the work list for further-work?--* CDictCan (C tys):-  Yes if the inert set could rewrite tys to make the class constraint,-  or type family, fire.  That is, yes if the inert_eqs intersects-  with the free vars of tys.  For this test we use-  (anyRewritableTyVar True) which ignores casts and coercions in tys,-  because rewriting the casts or coercions won't make the thing fire-  more often.--* CEqCan (lhs ~ ty): Yes if the inert set could rewrite 'lhs' or 'ty'.-  We need to check both 'lhs' and 'ty' against the inert set:-    - Inert set contains  [D] a ~ ty2-      Then we want to put [D] a ~ ty in the worklist, so we'll-      get [D] ty ~ ty2 with consequent good things--    - Inert set contains [D] b ~ a, where b is in ty.-      We can't just add [WD] a ~ ty[b] to the inert set, because-      that breaks the inert-set invariants.  If we tried to-      canonicalise another [D] constraint mentioning 'a', we'd-      get an infinite loop--  Moreover we must use (anyRewritableTyVar False) for the RHS,-  because even tyvars in the casts and coercions could give-  an infinite loop if we don't expose it--* CIrredCan: Yes if the inert set can rewrite the constraint.-  We used to think splitting irreds was unnecessary, but-  see Note [Splitting Irred WD constraints]--* Others: nothing is gained by splitting.--Note [Splitting Irred WD constraints]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Splitting Irred constraints can make a difference. Here is the-scenario:--  a[sk] :: F v     -- F is a type family-  beta :: alpha--  work item: [WD] a ~ beta--This is heterogeneous, so we emit a kind equality and make the work item an-inert Irred.--  work item: [D] F v ~ alpha-  inert: [WD] (a |> co) ~ beta (CIrredCan)--Can't make progress on the work item. Add to inert set. This kicks out the-old inert, because a [D] can rewrite a [WD].--  work item: [WD] (a |> co) ~ beta-  inert: [D] F v ~ alpha (CEqCan)--Can't make progress on this work item either (although GHC tries by-decomposing the cast and rewriting... but that doesn't make a difference),-which is still hetero. Emit a new kind equality and add to inert set. But,-critically, we split the Irred.--  work list:-   [D] F v ~ alpha (CEqCan)-   [D] (a |> co) ~ beta (CIrred) -- this one was split off-  inert:-   [W] (a |> co) ~ beta-   [D] F v ~ alpha--We quickly solve the first work item, as it's the same as an inert.--  work item: [D] (a |> co) ~ beta-  inert:-   [W] (a |> co) ~ beta-   [D] F v ~ alpha--We decompose the cast, yielding--  [D] a ~ beta--We then rewrite the kinds. The lhs kind is F v, which flattens to alpha.--  co' :: F v ~ alpha-  [D] (a |> co') ~ beta--Now this equality is homo-kinded. So we swizzle it around to--  [D] beta ~ (a |> co')--and set beta := a |> co', and go home happy.--If we don't split the Irreds, we loop. This is all dangerously subtle.--This is triggered by test case typecheck/should_compile/SplitWD.--Note [Add derived shadows only for Wanteds]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We only add shadows for Wanted constraints. That is, we have-[WD] but not [GD]; and maybeEmitShaodw looks only at [WD]-constraints.--It does just possibly make sense ot add a derived shadow for a-Given. If we created a Derived shadow of a Given, it could be-rewritten by other Deriveds, and that could, conceivably, lead to a-useful unification.--But (a) I have been unable to come up with an example of this-        happening-    (b) see #12660 for how adding the derived shadows-        of a Given led to an infinite loop.-    (c) It's unlikely that rewriting derived Givens will lead-        to a unification because Givens don't mention touchable-        unification variables--For (b) there may be other ways to solve the loop, but simply-reraining from adding derived shadows of Givens is particularly-simple.  And it's more efficient too!--Still, here's one possible reason for adding derived shadows-for Givens.  Consider-           work-item [G] a ~ [b], inerts has [D] b ~ a.-If we added the derived shadow (into the work list)-         [D] a ~ [b]-When we process it, we'll rewrite to a ~ [a] and get an-occurs check.  Without it we'll miss the occurs check (reporting-inaccessible code); but that's probably OK.--Note [Keep CDictCan shadows as CDictCan]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we have-  class C a => D a b-and [G] D a b, [G] C a in the inert set.  Now we insert-[D] b ~ c.  We want to kick out a derived shadow for [D] D a b,-so we can rewrite it with the new constraint, and perhaps get-instance reduction or other consequences.--BUT we do not want to kick out a *non-canonical* (D a b). If we-did, we would do this:-  - rewrite it to [D] D a c, with pend_sc = True-  - use expandSuperClasses to add C a-  - go round again, which solves C a from the givens-This loop goes on for ever and triggers the simpl_loop limit.--Solution: kick out the CDictCan which will have pend_sc = False,-because we've already added its superclasses.  So we won't re-add-them.  If we forget the pend_sc flag, our cunning scheme for avoiding-generating superclasses repeatedly will fail.--See #11379 for a case of this.--Note [Do not do improvement for WOnly]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We do improvement between two constraints (e.g. for injectivity-or functional dependencies) only if both are "improvable". And-we improve a constraint wrt the top-level instances only if-it is improvable.--Improvable:     [G] [WD] [D}-Not improvable: [W]--Reasons:--* It's less work: fewer pairs to compare--* Every [W] has a shadow [D] so nothing is lost--* Consider [WD] C Int b,  where 'b' is a skolem, and-    class C a b | a -> b-    instance C Int Bool-  We'll do a fundep on it and emit [D] b ~ Bool-  That will kick out constraint [WD] C Int b-  Then we'll split it to [W] C Int b (keep in inert)-                     and [D] C Int b (in work list)-  When processing the latter we'll rewrite it to-        [D] C Int Bool-  At that point it would be /stupid/ to interact it-  with the inert [W] C Int b in the inert set; after all,-  it's the very constraint from which the [D] C Int Bool-  was split!  We can avoid this by not doing improvement-  on [W] constraints. This came up in #12860.--}--maybeEmitShadow :: InertCans -> Ct -> TcS Ct--- See Note [The improvement story and derived shadows]-maybeEmitShadow ics ct-  | let ev = ctEvidence ct-  , CtWanted { ctev_pred = pred, ctev_loc = loc-             , ctev_nosh = WDeriv } <- ev-  , shouldSplitWD (inert_eqs ics) (inert_funeqs ics) ct-  = do { traceTcS "Emit derived shadow" (ppr ct)-       ; let derived_ev = CtDerived { ctev_pred = pred-                                    , ctev_loc  = loc }-             shadow_ct = ct { cc_ev = derived_ev }-               -- Te shadow constraint keeps the canonical shape.-               -- This just saves work, but is sometimes important;-               -- see Note [Keep CDictCan shadows as CDictCan]-       ; emitWork [shadow_ct]--       ; let ev' = ev { ctev_nosh = WOnly }-             ct' = ct { cc_ev = ev' }-                 -- Record that it now has a shadow-                 -- This is /the/ place we set the flag to WOnly-       ; return ct' }--  | otherwise-  = return ct--shouldSplitWD :: InertEqs -> FunEqMap EqualCtList -> Ct -> Bool--- Precondition: 'ct' is [WD], and is inert--- True <=> we should split ct ito [W] and [D] because---          the inert_eqs can make progress on the [D]--- See Note [Splitting WD constraints]--shouldSplitWD inert_eqs fun_eqs (CDictCan { cc_tyargs = tys })-  = should_split_match_args inert_eqs fun_eqs tys-    -- NB True: ignore coercions-    -- See Note [Splitting WD constraints]--shouldSplitWD inert_eqs fun_eqs (CEqCan { cc_lhs = TyVarLHS tv, cc_rhs = ty-                                        , cc_eq_rel = eq_rel })-  =  tv `elemDVarEnv` inert_eqs-  || anyRewritableCanEqLHS eq_rel (canRewriteTv inert_eqs) (canRewriteTyFam fun_eqs) ty-  -- NB False: do not ignore casts and coercions-  -- See Note [Splitting WD constraints]--shouldSplitWD inert_eqs fun_eqs (CEqCan { cc_ev = ev, cc_eq_rel = eq_rel })-  = anyRewritableCanEqLHS eq_rel (canRewriteTv inert_eqs) (canRewriteTyFam fun_eqs)-                          (ctEvPred ev)--shouldSplitWD inert_eqs fun_eqs (CIrredCan { cc_ev = ev })-  = anyRewritableCanEqLHS (ctEvEqRel ev) (canRewriteTv inert_eqs)-                          (canRewriteTyFam fun_eqs) (ctEvPred ev)--shouldSplitWD _ _ _ = False   -- No point in splitting otherwise--should_split_match_args :: InertEqs -> FunEqMap EqualCtList -> [TcType] -> Bool--- True if the inert_eqs can rewrite anything in the argument types-should_split_match_args inert_eqs fun_eqs tys-  = any (anyRewritableCanEqLHS NomEq (canRewriteTv inert_eqs) (canRewriteTyFam fun_eqs)) tys-    -- See Note [Splitting WD constraints]--canRewriteTv :: InertEqs -> EqRel -> TyVar -> Bool-canRewriteTv inert_eqs eq_rel tv-  | Just (EqualCtList (ct :| _)) <- lookupDVarEnv inert_eqs tv-  , CEqCan { cc_eq_rel = eq_rel1 } <- ct-  = eq_rel1 `eqCanRewrite` eq_rel-  | otherwise-  = False--canRewriteTyFam :: FunEqMap EqualCtList -> EqRel -> TyCon -> [Type] -> Bool-canRewriteTyFam fun_eqs eq_rel tf args-  | Just (EqualCtList (ct :| _)) <- findFunEq fun_eqs tf args-  , CEqCan { cc_eq_rel = eq_rel1 } <- ct-  = eq_rel1 `eqCanRewrite` eq_rel-  | otherwise-  = False--isImprovable :: CtEvidence -> Bool--- See Note [Do not do improvement for WOnly]-isImprovable (CtWanted { ctev_nosh = WOnly }) = False-isImprovable _                                = True---{- *********************************************************************-*                                                                      *-                   Inert equalities-*                                                                      *-********************************************************************* -}--addTyEq :: InertEqs -> TcTyVar -> Ct -> InertEqs-addTyEq old_eqs tv ct-  = extendDVarEnv_C add_eq old_eqs tv (unitEqualCtList ct)-  where-    add_eq old_eqs _ = addToEqualCtList ct old_eqs--addCanFunEq :: FunEqMap EqualCtList -> TyCon -> [TcType] -> Ct-            -> FunEqMap EqualCtList-addCanFunEq old_eqs fun_tc fun_args ct-  = alterTcApp old_eqs fun_tc fun_args upd-  where-    upd (Just old_equal_ct_list) = Just $ addToEqualCtList ct old_equal_ct_list-    upd Nothing                  = Just $ unitEqualCtList ct--foldTyEqs :: (Ct -> b -> b) -> InertEqs -> b -> b-foldTyEqs k eqs z-  = foldDVarEnv (\(EqualCtList cts) z -> foldr k z cts) z eqs--findTyEqs :: InertCans -> TyVar -> [Ct]-findTyEqs icans tv = maybe [] id (fmap @Maybe equalCtListToList $-                                  lookupDVarEnv (inert_eqs icans) tv)--delEq :: InertCans -> CanEqLHS -> TcType -> InertCans-delEq ic lhs rhs = case lhs of-    TyVarLHS tv-      -> ic { inert_eqs = alterDVarEnv upd (inert_eqs ic) tv }-    TyFamLHS tf args-      -> ic { inert_funeqs = alterTcApp (inert_funeqs ic) tf args upd }-  where-    isThisOne :: Ct -> Bool-    isThisOne (CEqCan { cc_rhs = t1 }) = tcEqTypeNoKindCheck rhs t1-    isThisOne other = pprPanic "delEq" (ppr lhs $$ ppr ic $$ ppr other)--    upd :: Maybe EqualCtList -> Maybe EqualCtList-    upd (Just eq_ct_list) = filterEqualCtList (not . isThisOne) eq_ct_list-    upd Nothing           = Nothing--findEq :: InertCans -> CanEqLHS -> [Ct]-findEq icans (TyVarLHS tv) = findTyEqs icans tv-findEq icans (TyFamLHS fun_tc fun_args)-  = maybe [] id (fmap @Maybe equalCtListToList $-                 findFunEq (inert_funeqs icans) fun_tc fun_args)--{- *********************************************************************-*                                                                      *-                   Inert instances: inert_insts-*                                                                      *-********************************************************************* -}--addInertForAll :: QCInst -> TcS ()--- Add a local Given instance, typically arising from a type signature-addInertForAll new_qci-  = do { ics  <- getInertCans-       ; ics1 <- add_qci ics--       -- Update given equalities. C.f updateGivenEqs-       ; tclvl <- getTcLevel-       ; let pred         = qci_pred new_qci-             not_equality = isClassPred pred && not (isEqPred pred)-                  -- True <=> definitely not an equality-                  -- A qci_pred like (f a) might be an equality--             ics2 | not_equality = ics1-                  | otherwise    = ics1 { inert_given_eq_lvl = tclvl-                                        , inert_given_eqs    = True }--       ; setInertCans ics2 }-  where-    add_qci :: InertCans -> TcS InertCans-    -- See Note [Do not add duplicate quantified instances]-    add_qci ics@(IC { inert_insts = qcis })-      | any same_qci qcis-      = do { traceTcS "skipping duplicate quantified instance" (ppr new_qci)-           ; return ics }--      | otherwise-      = do { traceTcS "adding new inert quantified instance" (ppr new_qci)-           ; return (ics { inert_insts = new_qci : qcis }) }--    same_qci old_qci = tcEqType (ctEvPred (qci_ev old_qci))-                                (ctEvPred (qci_ev new_qci))--{- Note [Do not add duplicate quantified instances]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this (#15244):--  f :: (C g, D g) => ....-  class S g => C g where ...-  class S g => D g where ...-  class (forall a. Eq a => Eq (g a)) => S g where ...--Then in f's RHS there are two identical quantified constraints-available, one via the superclasses of C and one via the superclasses-of D.  The two are identical, and it seems wrong to reject the program-because of that. But without doing duplicate-elimination we will have-two matching QCInsts when we try to solve constraints arising from f's-RHS.--The simplest thing is simply to eliminate duplicates, which we do here.--}--{- *********************************************************************-*                                                                      *-                  Adding an inert-*                                                                      *-************************************************************************--Note [Adding an equality to the InertCans]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When adding an equality to the inerts:--* Split [WD] into [W] and [D] if the inerts can rewrite the latter;-  done by maybeEmitShadow.--* Kick out any constraints that can be rewritten by the thing-  we are adding.  Done by kickOutRewritable.--* Note that unifying a:=ty, is like adding [G] a~ty; just use-  kickOutRewritable with Nominal, Given.  See kickOutAfterUnification.--}--addInertCan :: Ct -> TcS ()--- Precondition: item /is/ canonical--- See Note [Adding an equality to the InertCans]-addInertCan ct-  = do { traceTcS "addInertCan {" $-         text "Trying to insert new inert item:" <+> ppr ct--       ; ics <- getInertCans-       ; ct  <- maybeEmitShadow ics ct-       ; ics <- maybeKickOut ics ct-       ; tclvl <- getTcLevel-       ; setInertCans (add_item tclvl ics ct)--       ; traceTcS "addInertCan }" $ empty }--maybeKickOut :: InertCans -> Ct -> TcS InertCans--- For a CEqCan, kick out any inert that can be rewritten by the CEqCan-maybeKickOut ics ct-  | CEqCan { cc_lhs = lhs, cc_ev = ev, cc_eq_rel = eq_rel } <- ct-  = do { (_, ics') <- kickOutRewritable (ctEvFlavour ev, eq_rel) lhs ics-       ; return ics' }-  | otherwise-  = return ics--add_item :: TcLevel -> InertCans -> Ct -> InertCans-add_item tc_lvl-         ics@(IC { inert_funeqs = funeqs, inert_eqs = eqs })-         item@(CEqCan { cc_lhs = lhs })-  = updateGivenEqs tc_lvl item $-    case lhs of-       TyFamLHS tc tys -> ics { inert_funeqs = addCanFunEq funeqs tc tys item }-       TyVarLHS tv     -> ics { inert_eqs    = addTyEq eqs tv item }--add_item tc_lvl ics@(IC { inert_blocked = blocked })-         item@(CIrredCan { cc_reason = HoleBlockerReason {}})-  = updateGivenEqs tc_lvl item $  -- this item is always an equality-    ics { inert_blocked = blocked `snocBag` item }--add_item tc_lvl ics@(IC { inert_irreds = irreds }) item@(CIrredCan {})-  = updateGivenEqs tc_lvl item $   -- An Irred might turn out to be an-                                 -- equality, so we play safe-    ics { inert_irreds = irreds `Bag.snocBag` item }--add_item _ ics item@(CDictCan { cc_class = cls, cc_tyargs = tys })-  = ics { inert_dicts = addDictCt (inert_dicts ics) cls tys item }--add_item _ _ item-  = pprPanic "upd_inert set: can't happen! Inserting " $-    ppr item   -- Can't be CNonCanonical because they only land in inert_irreds--updateGivenEqs :: TcLevel -> Ct -> InertCans -> InertCans--- Set the inert_given_eq_level to the current level (tclvl)--- if the constraint is a given equality that should prevent--- filling in an outer unification variable.--- See See Note [Tracking Given equalities]-updateGivenEqs tclvl ct inerts@(IC { inert_given_eq_lvl = ge_lvl })-  | not (isGivenCt ct) = inerts-  | not_equality ct    = inerts -- See Note [Let-bound skolems]-  | otherwise          = inerts { inert_given_eq_lvl = ge_lvl'-                                , inert_given_eqs    = True }-  where-    ge_lvl' | mentionsOuterVar tclvl (ctEvidence ct)-              -- Includes things like (c a), which *might* be an equality-            = tclvl-            | otherwise-            = ge_lvl--    not_equality :: Ct -> Bool-    -- True <=> definitely not an equality of any kind-    --          except for a let-bound skolem, which doesn't count-    --          See Note [Let-bound skolems]-    -- NB: no need to spot the boxed CDictCan (a ~ b) because its-    --     superclass (a ~# b) will be a CEqCan-    not_equality (CEqCan { cc_lhs = TyVarLHS tv }) = not (isOuterTyVar tclvl tv)-    not_equality (CDictCan {})                     = True-    not_equality _                                 = False--------------------------------------------kickOutRewritable  :: CtFlavourRole  -- Flavour/role of the equality that-                                      -- is being added to the inert set-                   -> CanEqLHS        -- The new equality is lhs ~ ty-                   -> InertCans-                   -> TcS (Int, InertCans)-kickOutRewritable new_fr new_lhs ics-  = do { let (kicked_out, ics') = kick_out_rewritable new_fr new_lhs ics-             n_kicked = workListSize kicked_out--       ; unless (n_kicked == 0) $-         do { updWorkListTcS (appendWorkList kicked_out)--              -- The famapp-cache contains Given evidence from the inert set.-              -- If we're kicking out Givens, we need to remove this evidence-              -- from the cache, too.-            ; let kicked_given_ev_vars =-                    [ ev_var | ct <- wl_eqs kicked_out-                             , CtGiven { ctev_evar = ev_var } <- [ctEvidence ct] ]-            ; when (new_fr `eqCanRewriteFR` (Given, NomEq) &&-                   -- if this isn't true, no use looking through the constraints-                    not (null kicked_given_ev_vars)) $-              do { traceTcS "Given(s) have been kicked out; drop from famapp-cache"-                            (ppr kicked_given_ev_vars)-                 ; dropFromFamAppCache (mkVarSet kicked_given_ev_vars) }--            ; csTraceTcS $-              hang (text "Kick out, lhs =" <+> ppr new_lhs)-                 2 (vcat [ text "n-kicked =" <+> int n_kicked-                         , text "kicked_out =" <+> ppr kicked_out-                         , text "Residual inerts =" <+> ppr ics' ]) }--       ; return (n_kicked, ics') }--kick_out_rewritable :: CtFlavourRole  -- Flavour/role of the equality that-                                      -- is being added to the inert set-                    -> CanEqLHS       -- The new equality is lhs ~ ty-                    -> InertCans-                    -> (WorkList, InertCans)--- See Note [kickOutRewritable]-kick_out_rewritable new_fr new_lhs-                    ics@(IC { inert_eqs      = tv_eqs-                            , inert_dicts    = dictmap-                            , inert_funeqs   = funeqmap-                            , inert_irreds   = irreds-                            , inert_insts    = old_insts })-  | not (new_fr `eqMayRewriteFR` new_fr)-  = (emptyWorkList, ics)-        -- If new_fr can't rewrite itself, it can't rewrite-        -- anything else, so no need to kick out anything.-        -- (This is a common case: wanteds can't rewrite wanteds)-        -- Lemma (L2) in Note [Extending the inert equalities]--  | otherwise-  = (kicked_out, inert_cans_in)-  where-    -- inert_safehask stays unchanged; is that right?-    inert_cans_in = ics { inert_eqs      = tv_eqs_in-                        , inert_dicts    = dicts_in-                        , inert_funeqs   = feqs_in-                        , inert_irreds   = irs_in-                        , inert_insts    = insts_in }--    kicked_out :: WorkList-    -- NB: use extendWorkList to ensure that kicked-out equalities get priority-    -- See Note [Prioritise equalities] (Kick-out).-    -- The irreds may include non-canonical (hetero-kinded) equality-    -- constraints, which perhaps may have become soluble after new_lhs-    -- is substituted; ditto the dictionaries, which may include (a~b)-    -- or (a~~b) constraints.-    kicked_out = foldr extendWorkListCt-                          (emptyWorkList { wl_eqs = tv_eqs_out ++ feqs_out })-                          ((dicts_out `andCts` irs_out)-                            `extendCtsList` insts_out)--    (tv_eqs_out, tv_eqs_in) = foldDVarEnv (kick_out_eqs extend_tv_eqs)-                                          ([], emptyDVarEnv) tv_eqs-    (feqs_out,   feqs_in)   = foldFunEqs  (kick_out_eqs extend_fun_eqs)-                                          funeqmap ([], emptyFunEqs)-    (dicts_out,  dicts_in)  = partitionDicts   kick_out_ct dictmap-    (irs_out,    irs_in)    = partitionBag     kick_out_ct irreds-      -- Kick out even insolubles: See Note [Rewrite insolubles]-      -- Of course we must kick out irreducibles like (c a), in case-      -- we can rewrite 'c' to something more useful--    -- Kick-out for inert instances-    -- See Note [Quantified constraints] in GHC.Tc.Solver.Canonical-    insts_out :: [Ct]-    insts_in  :: [QCInst]-    (insts_out, insts_in)-       | fr_may_rewrite (Given, NomEq)  -- All the insts are Givens-       = partitionWith kick_out_qci old_insts-       | otherwise-       = ([], old_insts)-    kick_out_qci qci-      | let ev = qci_ev qci-      , fr_can_rewrite_ty NomEq (ctEvPred (qci_ev qci))-      = Left (mkNonCanonical ev)-      | otherwise-      = Right qci--    (_, new_role) = new_fr--    fr_tv_can_rewrite_ty :: TyVar -> EqRel -> Type -> Bool-    fr_tv_can_rewrite_ty new_tv role ty-      = anyRewritableTyVar True role can_rewrite ty-                  -- True: ignore casts and coercions-      where-        can_rewrite :: EqRel -> TyVar -> Bool-        can_rewrite old_role tv = new_role `eqCanRewrite` old_role && tv == new_tv--    fr_tf_can_rewrite_ty :: TyCon -> [TcType] -> EqRel -> Type -> Bool-    fr_tf_can_rewrite_ty new_tf new_tf_args role ty-      = anyRewritableTyFamApp role can_rewrite ty-      where-        can_rewrite :: EqRel -> TyCon -> [TcType] -> Bool-        can_rewrite old_role old_tf old_tf_args-          = new_role `eqCanRewrite` old_role &&-            tcEqTyConApps new_tf new_tf_args old_tf old_tf_args-              -- it's possible for old_tf_args to have too many. This is fine;-              -- we'll only check what we need to.--    {-# INLINE fr_can_rewrite_ty #-}   -- perform the check here only once-    fr_can_rewrite_ty :: EqRel -> Type -> Bool-    fr_can_rewrite_ty = case new_lhs of-      TyVarLHS new_tv             -> fr_tv_can_rewrite_ty new_tv-      TyFamLHS new_tf new_tf_args -> fr_tf_can_rewrite_ty new_tf new_tf_args--    fr_may_rewrite :: CtFlavourRole -> Bool-    fr_may_rewrite fs = new_fr `eqMayRewriteFR` fs-        -- Can the new item rewrite the inert item?--    {-# INLINE kick_out_ct #-}   -- perform case on new_lhs here only once-    kick_out_ct :: Ct -> Bool-    -- Kick it out if the new CEqCan can rewrite the inert one-    -- See Note [kickOutRewritable]-    kick_out_ct = case new_lhs of-      TyVarLHS new_tv -> \ct -> let fs@(_,role) = ctFlavourRole ct in-                                fr_may_rewrite fs-                             && fr_tv_can_rewrite_ty new_tv role (ctPred ct)-      TyFamLHS new_tf new_tf_args-        -> \ct -> let fs@(_, role) = ctFlavourRole ct in-                  fr_may_rewrite fs-               && fr_tf_can_rewrite_ty new_tf new_tf_args role (ctPred ct)--    extend_tv_eqs :: InertEqs -> CanEqLHS -> EqualCtList -> InertEqs-    extend_tv_eqs eqs (TyVarLHS tv) cts = extendDVarEnv eqs tv cts-    extend_tv_eqs eqs other _cts = pprPanic "extend_tv_eqs" (ppr eqs $$ ppr other)--    extend_fun_eqs :: FunEqMap EqualCtList -> CanEqLHS -> EqualCtList-                   -> FunEqMap EqualCtList-    extend_fun_eqs eqs (TyFamLHS fam_tc fam_args) cts-      = insertTcApp eqs fam_tc fam_args cts-    extend_fun_eqs eqs other _cts = pprPanic "extend_fun_eqs" (ppr eqs $$ ppr other)--    kick_out_eqs :: (container -> CanEqLHS -> EqualCtList -> container)-                 -> EqualCtList -> ([Ct], container)-                 -> ([Ct], container)-    kick_out_eqs extend eqs (acc_out, acc_in)-      = (eqs_out `chkAppend` acc_out, case listToEqualCtList eqs_in of-            Nothing -> acc_in-            Just eqs_in_ecl@(EqualCtList (eq1 :| _))-                    -> extend acc_in (cc_lhs eq1) eqs_in_ecl)-      where-        (eqs_out, eqs_in) = partition kick_out_eq (equalCtListToList eqs)--    -- Implements criteria K1-K3 in Note [Extending the inert equalities]-    kick_out_eq (CEqCan { cc_lhs = lhs, cc_rhs = rhs_ty-                        , cc_ev = ev, cc_eq_rel = eq_rel })-      | not (fr_may_rewrite fs)-      = False  -- (K0) Keep it in the inert set if the new thing can't rewrite it--      -- Below here (fr_may_rewrite fs) is True--      | TyVarLHS _ <- lhs-      , fs `eqMayRewriteFR` new_fr-      = False  -- (K4) Keep it in the inert set if the LHS is a tyvar and-               -- it can rewrite the work item. See Note [K4]--      | fr_can_rewrite_ty eq_rel (canEqLHSType lhs)-      = True   -- (K1)-         -- The above check redundantly checks the role & flavour,-         -- but it's very convenient--      | kick_out_for_inertness    = True   -- (K2)-      | kick_out_for_completeness = True   -- (K3)-      | otherwise                 = False--      where-        fs = (ctEvFlavour ev, eq_rel)-        kick_out_for_inertness-          =    (fs `eqMayRewriteFR` fs)           -- (K2a)-            && fr_can_rewrite_ty eq_rel rhs_ty    -- (K2b)--        kick_out_for_completeness  -- (K3) and Note [K3: completeness of solving]-          = case eq_rel of-              NomEq  -> rhs_ty `eqType` canEqLHSType new_lhs -- (K3a)-              ReprEq -> is_can_eq_lhs_head new_lhs rhs_ty    -- (K3b)--    kick_out_eq ct = pprPanic "keep_eq" (ppr ct)--    is_can_eq_lhs_head (TyVarLHS tv) = go-      where-        go (Rep.TyVarTy tv')   = tv == tv'-        go (Rep.AppTy fun _)   = go fun-        go (Rep.CastTy ty _)   = go ty-        go (Rep.TyConApp {})   = False-        go (Rep.LitTy {})      = False-        go (Rep.ForAllTy {})   = False-        go (Rep.FunTy {})      = False-        go (Rep.CoercionTy {}) = False-    is_can_eq_lhs_head (TyFamLHS fun_tc fun_args) = go-      where-        go (Rep.TyVarTy {})       = False-        go (Rep.AppTy {})         = False  -- no TyConApp to the left of an AppTy-        go (Rep.CastTy ty _)      = go ty-        go (Rep.TyConApp tc args) = tcEqTyConApps fun_tc fun_args tc args-        go (Rep.LitTy {})         = False-        go (Rep.ForAllTy {})      = False-        go (Rep.FunTy {})         = False-        go (Rep.CoercionTy {})    = False--kickOutAfterUnification :: TcTyVar -> TcS Int-kickOutAfterUnification new_tv-  = do { ics <- getInertCans-       ; (n_kicked, ics2) <- kickOutRewritable (Given,NomEq)-                                                 (TyVarLHS new_tv) ics-                     -- Given because the tv := xi is given; NomEq because-                     -- only nominal equalities are solved by unification--       ; setInertCans ics2-       ; return n_kicked }---- See Wrinkle (2) in Note [Equalities with incompatible kinds] in GHC.Tc.Solver.Canonical-kickOutAfterFillingCoercionHole :: CoercionHole -> Coercion -> TcS ()-kickOutAfterFillingCoercionHole hole filled_co-  = do { ics <- getInertCans-       ; let (kicked_out, ics') = kick_out ics-             n_kicked           = workListSize kicked_out--       ; unless (n_kicked == 0) $-         do { updWorkListTcS (appendWorkList kicked_out)-            ; csTraceTcS $-              hang (text "Kick out, hole =" <+> ppr hole)-                 2 (vcat [ text "n-kicked =" <+> int n_kicked-                         , text "kicked_out =" <+> ppr kicked_out-                         , text "Residual inerts =" <+> ppr ics' ]) }--       ; setInertCans ics' }-  where-    holes_of_co = coercionHolesOfCo filled_co--    kick_out :: InertCans -> (WorkList, InertCans)-    kick_out ics@(IC { inert_blocked = blocked })-      = let (to_kick, to_keep) = partitionBagWith kick_ct blocked--            kicked_out = extendWorkListCts (bagToList to_kick) emptyWorkList-            ics'       = ics { inert_blocked = to_keep }-        in-        (kicked_out, ics')--    kick_ct :: Ct -> Either Ct Ct-         -- Left: kick out; Right: keep. But even if we keep, we may need-         -- to update the set of blocking holes-    kick_ct ct@(CIrredCan { cc_reason = HoleBlockerReason holes })-      | hole `elementOfUniqSet` holes-      = let new_holes = holes `delOneFromUniqSet` hole-                              `unionUniqSets` holes_of_co-            updated_ct = ct { cc_reason = HoleBlockerReason new_holes }-        in-        if isEmptyUniqSet new_holes-        then Left updated_ct-        else Right updated_ct--      | otherwise-      = Right ct--    kick_ct other = pprPanic "kickOutAfterFillingCoercionHole" (ppr other)--{- Note [kickOutRewritable]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-See also Note [inert_eqs: the inert equalities].--When we add a new inert equality (lhs ~N ty) to the inert set,-we must kick out any inert items that could be rewritten by the-new equality, to maintain the inert-set invariants.--  - We want to kick out an existing inert constraint if-    a) the new constraint can rewrite the inert one-    b) 'lhs' is free in the inert constraint (so that it *will*)-       rewrite it if we kick it out.--    For (b) we use anyRewritableCanLHS, which examines the types /and-    kinds/ that are directly visible in the type. Hence-    we will have exposed all the rewriting we care about to make the-    most precise kinds visible for matching classes etc. No need to-    kick out constraints that mention type variables whose kinds-    contain this LHS!--  - A Derived equality can kick out [D] constraints in inert_eqs,-    inert_dicts, inert_irreds etc.--  - We don't kick out constraints from inert_solved_dicts, and-    inert_solved_funeqs optimistically. But when we lookup we have to-    take the substitution into account--NB: we could in principle avoid kick-out:-  a) When unifying a meta-tyvar from an outer level, because-     then the entire implication will be iterated; see-     Note [The Unification Level Flag]--  b) For Givens, after a unification.  By (GivenInv) in GHC.Tc.Utils.TcType-     Note [TcLevel invariants], a Given can't include a meta-tyvar from-     its own level, so it falls under (a).  Of course, we must still-     kick out Givens when adding a new non-unification Given.--But kicking out more vigorously may lead to earlier unification and fewer-iterations, so we don't take advantage of these possibilities.--Note [Rewrite insolubles]-~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we have an insoluble alpha ~ [alpha], which is insoluble-because an occurs check.  And then we unify alpha := [Int].  Then we-really want to rewrite the insoluble to [Int] ~ [[Int]].  Now it can-be decomposed.  Otherwise we end up with a "Can't match [Int] ~-[[Int]]" which is true, but a bit confusing because the outer type-constructors match.--Hence:- * In the main simplifier loops in GHC.Tc.Solver (solveWanteds,-   simpl_loop), we feed the insolubles in solveSimpleWanteds,-   so that they get rewritten (albeit not solved).-- * We kick insolubles out of the inert set, if they can be-   rewritten (see GHC.Tc.Solver.Monad.kick_out_rewritable)-- * We rewrite those insolubles in GHC.Tc.Solver.Canonical.-   See Note [Make sure that insolubles are fully rewritten]--}-------------------addInertSafehask :: InertCans -> Ct -> InertCans-addInertSafehask ics item@(CDictCan { cc_class = cls, cc_tyargs = tys })-  = ics { inert_safehask = addDictCt (inert_dicts ics) cls tys item }--addInertSafehask _ item-  = pprPanic "addInertSafehask: can't happen! Inserting " $ ppr item--insertSafeOverlapFailureTcS :: InstanceWhat -> Ct -> TcS ()--- See Note [Safe Haskell Overlapping Instances Implementation] in GHC.Tc.Solver-insertSafeOverlapFailureTcS what item-  | safeOverlap what = return ()-  | otherwise        = updInertCans (\ics -> addInertSafehask ics item)--getSafeOverlapFailures :: TcS Cts--- See Note [Safe Haskell Overlapping Instances Implementation] in GHC.Tc.Solver-getSafeOverlapFailures- = do { IC { inert_safehask = safehask } <- getInertCans-      ; return $ foldDicts consCts safehask emptyCts }-----------------addSolvedDict :: InstanceWhat -> CtEvidence -> Class -> [Type] -> TcS ()--- Conditionally add a new item in the solved set of the monad--- See Note [Solved dictionaries]-addSolvedDict what item cls tys-  | isWanted item-  , instanceReturnsDictCon what-  = do { traceTcS "updSolvedSetTcs:" $ ppr item-       ; updInertTcS $ \ ics ->-             ics { inert_solved_dicts = addDict (inert_solved_dicts ics) cls tys item } }-  | otherwise-  = return ()--getSolvedDicts :: TcS (DictMap CtEvidence)-getSolvedDicts = do { ics <- getTcSInerts; return (inert_solved_dicts ics) }--setSolvedDicts :: DictMap CtEvidence -> TcS ()-setSolvedDicts solved_dicts-  = updInertTcS $ \ ics ->-    ics { inert_solved_dicts = solved_dicts }---{- *********************************************************************-*                                                                      *-                  Other inert-set operations-*                                                                      *-********************************************************************* -}--updInertTcS :: (InertSet -> InertSet) -> TcS ()--- Modify the inert set with the supplied function-updInertTcS upd_fn-  = do { is_var <- getTcSInertsRef-       ; wrapTcS (do { curr_inert <- TcM.readTcRef is_var-                     ; TcM.writeTcRef is_var (upd_fn curr_inert) }) }--getInertCans :: TcS InertCans-getInertCans = do { inerts <- getTcSInerts; return (inert_cans inerts) }--setInertCans :: InertCans -> TcS ()-setInertCans ics = updInertTcS $ \ inerts -> inerts { inert_cans = ics }--updRetInertCans :: (InertCans -> (a, InertCans)) -> TcS a--- Modify the inert set with the supplied function-updRetInertCans upd_fn-  = do { is_var <- getTcSInertsRef-       ; wrapTcS (do { inerts <- TcM.readTcRef is_var-                     ; let (res, cans') = upd_fn (inert_cans inerts)-                     ; TcM.writeTcRef is_var (inerts { inert_cans = cans' })-                     ; return res }) }--updInertCans :: (InertCans -> InertCans) -> TcS ()--- Modify the inert set with the supplied function-updInertCans upd_fn-  = updInertTcS $ \ inerts -> inerts { inert_cans = upd_fn (inert_cans inerts) }--updInertDicts :: (DictMap Ct -> DictMap Ct) -> TcS ()--- Modify the inert set with the supplied function-updInertDicts upd_fn-  = updInertCans $ \ ics -> ics { inert_dicts = upd_fn (inert_dicts ics) }--updInertSafehask :: (DictMap Ct -> DictMap Ct) -> TcS ()--- Modify the inert set with the supplied function-updInertSafehask upd_fn-  = updInertCans $ \ ics -> ics { inert_safehask = upd_fn (inert_safehask ics) }--updInertIrreds :: (Cts -> Cts) -> TcS ()--- Modify the inert set with the supplied function-updInertIrreds upd_fn-  = updInertCans $ \ ics -> ics { inert_irreds = upd_fn (inert_irreds ics) }--getInertEqs :: TcS (DTyVarEnv EqualCtList)-getInertEqs = do { inert <- getInertCans; return (inert_eqs inert) }--getInnermostGivenEqLevel :: TcS TcLevel-getInnermostGivenEqLevel = do { inert <- getInertCans-                              ; return (inert_given_eq_lvl inert) }--getInertInsols :: TcS Cts--- Returns insoluble equality constraints--- specifically including Givens-getInertInsols = do { inert <- getInertCans-                    ; return (filterBag insolubleEqCt (inert_irreds inert)) }--getInertGivens :: TcS [Ct]--- Returns the Given constraints in the inert set-getInertGivens-  = do { inerts <- getInertCans-       ; let all_cts = foldDicts (:) (inert_dicts inerts)-                     $ foldFunEqs (\ecl out -> equalCtListToList ecl ++ out)-                                  (inert_funeqs inerts)-                     $ concatMap equalCtListToList (dVarEnvElts (inert_eqs inerts))-       ; return (filter isGivenCt all_cts) }--getPendingGivenScs :: TcS [Ct]--- Find all inert Given dictionaries, or quantified constraints,---     whose cc_pend_sc flag is True---     and that belong to the current level--- Set their cc_pend_sc flag to False in the inert set, and return that Ct-getPendingGivenScs = do { lvl <- getTcLevel-                        ; updRetInertCans (get_sc_pending lvl) }--get_sc_pending :: TcLevel -> InertCans -> ([Ct], InertCans)-get_sc_pending this_lvl ic@(IC { inert_dicts = dicts, inert_insts = insts })-  = ASSERT2( all isGivenCt sc_pending, ppr sc_pending )-       -- When getPendingScDics is called,-       -- there are never any Wanteds in the inert set-    (sc_pending, ic { inert_dicts = dicts', inert_insts = insts' })-  where-    sc_pending = sc_pend_insts ++ sc_pend_dicts--    sc_pend_dicts = foldDicts get_pending dicts []-    dicts' = foldr add dicts sc_pend_dicts--    (sc_pend_insts, insts') = mapAccumL get_pending_inst [] insts--    get_pending :: Ct -> [Ct] -> [Ct]  -- Get dicts with cc_pend_sc = True-                                       -- but flipping the flag-    get_pending dict dicts-        | Just dict' <- isPendingScDict dict-        , belongs_to_this_level (ctEvidence dict)-        = dict' : dicts-        | otherwise-        = dicts--    add :: Ct -> DictMap Ct -> DictMap Ct-    add ct@(CDictCan { cc_class = cls, cc_tyargs = tys }) dicts-        = addDictCt dicts cls tys ct-    add ct _ = pprPanic "getPendingScDicts" (ppr ct)--    get_pending_inst :: [Ct] -> QCInst -> ([Ct], QCInst)-    get_pending_inst cts qci@(QCI { qci_ev = ev })-       | Just qci' <- isPendingScInst qci-       , belongs_to_this_level ev-       = (CQuantCan qci' : cts, qci')-       | otherwise-       = (cts, qci)--    belongs_to_this_level ev = ctLocLevel (ctEvLoc ev) == this_lvl-    -- We only want Givens from this level; see (3a) in-    -- Note [The superclass story] in GHC.Tc.Solver.Canonical--getUnsolvedInerts :: TcS ( Bag Implication-                         , Cts )   -- All simple constraints--- Return all the unsolved [Wanted] or [Derived] constraints------ Post-condition: the returned simple constraints are all fully zonked---                     (because they come from the inert set)---                 the unsolved implics may not be-getUnsolvedInerts- = do { IC { inert_eqs     = tv_eqs-           , inert_funeqs  = fun_eqs-           , inert_irreds  = irreds-           , inert_blocked = blocked-           , inert_dicts   = idicts-           } <- getInertCans--      ; let unsolved_tv_eqs  = foldTyEqs add_if_unsolved tv_eqs emptyCts-            unsolved_fun_eqs = foldFunEqs add_if_unsolveds fun_eqs emptyCts-            unsolved_irreds  = Bag.filterBag is_unsolved irreds-            unsolved_blocked = blocked  -- all blocked equalities are W/D-            unsolved_dicts   = foldDicts add_if_unsolved idicts emptyCts-            unsolved_others  = unionManyBags [ unsolved_irreds-                                             , unsolved_dicts-                                             , unsolved_blocked ]--      ; implics <- getWorkListImplics--      ; traceTcS "getUnsolvedInerts" $-        vcat [ text " tv eqs =" <+> ppr unsolved_tv_eqs-             , text "fun eqs =" <+> ppr unsolved_fun_eqs-             , text "others =" <+> ppr unsolved_others-             , text "implics =" <+> ppr implics ]--      ; return ( implics, unsolved_tv_eqs `unionBags`-                          unsolved_fun_eqs `unionBags`-                          unsolved_others) }-  where-    add_if_unsolved :: Ct -> Cts -> Cts-    add_if_unsolved ct cts | is_unsolved ct = ct `consCts` cts-                           | otherwise      = cts--    add_if_unsolveds :: EqualCtList -> Cts -> Cts-    add_if_unsolveds new_cts old_cts = foldr add_if_unsolved old_cts-                                             (equalCtListToList new_cts)--    is_unsolved ct = not (isGivenCt ct)   -- Wanted or Derived--getHasGivenEqs :: TcLevel           -- TcLevel of this implication-               -> TcS ( HasGivenEqs -- are there Given equalities?-                      , Cts )       -- Insoluble equalities arising from givens--- See Note [Tracking Given equalities]-getHasGivenEqs tclvl-  = do { inerts@(IC { inert_irreds       = irreds-                    , inert_given_eqs    = given_eqs-                    , inert_given_eq_lvl = ge_lvl })-              <- getInertCans-       ; let insols = filterBag insolubleEqCt irreds-                      -- Specifically includes ones that originated in some-                      -- outer context but were refined to an insoluble by-                      -- a local equality; so do /not/ add ct_given_here.--             -- See Note [HasGivenEqs] in GHC.Tc.Types.Constraint, and-             -- Note [Tracking Given equalities] in this module-             has_ge | ge_lvl == tclvl = MaybeGivenEqs-                    | given_eqs       = LocalGivenEqs-                    | otherwise       = NoGivenEqs--       ; traceTcS "getHasGivenEqs" $-         vcat [ text "given_eqs:" <+> ppr given_eqs-              , text "ge_lvl:" <+> ppr ge_lvl-              , text "ambient level:" <+> ppr tclvl-              , text "Inerts:" <+> ppr inerts-              , text "Insols:" <+> ppr insols]-       ; return (has_ge, insols) }--mentionsOuterVar :: TcLevel -> CtEvidence -> Bool-mentionsOuterVar tclvl ev-  = anyFreeVarsOfType (isOuterTyVar tclvl) $-    ctEvPred ev--isOuterTyVar :: TcLevel -> TyCoVar -> Bool--- True of a type variable that comes from a--- shallower level than the ambient level (tclvl)-isOuterTyVar tclvl tv-  | isTyVar tv = ASSERT2( not (isTouchableMetaTyVar tclvl tv), ppr tv <+> ppr tclvl  )-                 tclvl `strictlyDeeperThan` tcTyVarLevel tv-    -- ASSERT: we are dealing with Givens here, and invariant (GivenInv) from-    -- Note Note [TcLevel invariants] in GHC.Tc.Utils.TcType ensures that there can't-    -- be a touchable meta tyvar.   If this wasn't true, you might worry that,-    -- at level 3, a meta-tv alpha[3] gets unified with skolem b[2], and thereby-    -- becomes "outer" even though its level numbers says it isn't.-  | otherwise  = False  -- Coercion variables; doesn't much matter---- | Returns Given constraints that might,--- potentially, match the given pred. This is used when checking to see if a--- Given might overlap with an instance. See Note [Instance and Given overlap]--- in "GHC.Tc.Solver.Interact"-matchableGivens :: CtLoc -> PredType -> InertSet -> Cts-matchableGivens loc_w pred_w inerts@(IS { inert_cans = inert_cans })-  = filterBag matchable_given all_relevant_givens-  where-    -- just look in class constraints and irreds. matchableGivens does get called-    -- for ~R constraints, but we don't need to look through equalities, because-    -- canonical equalities are used for rewriting. We'll only get caught by-    -- non-canonical -- that is, irreducible -- equalities.-    all_relevant_givens :: Cts-    all_relevant_givens-      | Just (clas, _) <- getClassPredTys_maybe pred_w-      = findDictsByClass (inert_dicts inert_cans) clas-        `unionBags` inert_irreds inert_cans-      | otherwise-      = inert_irreds inert_cans--    matchable_given :: Ct -> Bool-    matchable_given ct-      | CtGiven { ctev_loc = loc_g, ctev_pred = pred_g } <- ctEvidence ct-      = mightEqualLater inerts pred_g loc_g pred_w loc_w--      | otherwise-      = False--mightEqualLater :: InertSet -> TcPredType -> CtLoc -> TcPredType -> CtLoc -> Bool--- See Note [What might equal later?]--- Used to implement logic in Note [Instance and Given overlap] in GHC.Tc.Solver.Interact-mightEqualLater inert_set given_pred given_loc wanted_pred wanted_loc-  | prohibitedSuperClassSolve given_loc wanted_loc-  = False--  | otherwise-  = case tcUnifyTysFG bind_fun [flattened_given] [flattened_wanted] of-      SurelyApart              -> False  -- types that are surely apart do not equal later-      MaybeApart MARInfinite _ -> False  -- see Example 7 in the Note.-      _                        -> True--  where-    in_scope  = mkInScopeSet $ tyCoVarsOfTypes [given_pred, wanted_pred]--    -- NB: flatten both at the same time, so that we can share mappings-    -- from type family applications to variables, and also to guarantee-    -- that the fresh variables are really fresh between the given and-    -- the wanted. Flattening both at the same time is needed to get-    -- Example 10 from the Note.-    ([flattened_given, flattened_wanted], var_mapping)-      = flattenTysX in_scope [given_pred, wanted_pred]--    bind_fun :: BindFun-    bind_fun tv rhs_ty-      | isMetaTyVar tv-      , can_unify tv (metaTyVarInfo tv) rhs_ty-         -- this checks for CycleBreakerTvs and TyVarTvs; forgetting-         -- the latter was #19106.-      = BindMe--         -- See Examples 4, 5, and 6 from the Note-      | Just (_fam_tc, fam_args) <- lookupVarEnv var_mapping tv-      , anyFreeVarsOfTypes mentions_meta_ty_var fam_args-      = BindMe--      | otherwise-      = Apart--    -- True for TauTv and TyVarTv (and RuntimeUnkTv) meta-tyvars-    -- (as they can be unified)-    -- and also for CycleBreakerTvs that mentions meta-tyvars-    mentions_meta_ty_var :: TyVar -> Bool-    mentions_meta_ty_var tv-      | isMetaTyVar tv-      = case metaTyVarInfo tv of-          -- See Examples 8 and 9 in the Note-          CycleBreakerTv-            -> anyFreeVarsOfType mentions_meta_ty_var-                 (lookupCycleBreakerVar tv inert_set)-          _ -> True-      | otherwise-      = False--    -- like canSolveByUnification, but allows cbv variables to unify-    can_unify :: TcTyVar -> MetaInfo -> Type -> Bool-    can_unify _lhs_tv TyVarTv rhs_ty  -- see Example 3 from the Note-      | Just rhs_tv <- tcGetTyVar_maybe rhs_ty-      = case tcTyVarDetails rhs_tv of-          MetaTv { mtv_info = TyVarTv } -> True-          MetaTv {}                     -> False  -- could unify with anything-          SkolemTv {}                   -> True-          RuntimeUnk                    -> True-      | otherwise  -- not a var on the RHS-      = False-    can_unify lhs_tv _other _rhs_ty = mentions_meta_ty_var lhs_tv--prohibitedSuperClassSolve :: CtLoc -> CtLoc -> Bool--- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance-prohibitedSuperClassSolve from_loc solve_loc-  | InstSCOrigin _ given_size <- ctLocOrigin from_loc-  , ScOrigin wanted_size <- ctLocOrigin solve_loc-  = given_size >= wanted_size-  | otherwise-  = False--{- *********************************************************************-*                                                                      *-    Cycle breakers-*                                                                      *-********************************************************************* -}---- | Return the type family application a CycleBreakerTv maps to.-lookupCycleBreakerVar :: TcTyVar    -- ^ cbv, must be a CycleBreakerTv-                      -> InertSet-                      -> TcType     -- ^ type family application the cbv maps to-lookupCycleBreakerVar cbv (IS { inert_cycle_breakers = cbvs_stack })--- This function looks at every environment in the stack. This is necessary--- to avoid #20231. This function (and its one usage site) is the only reason--- that we store a stack instead of just the top environment.-  | Just tyfam_app <- ASSERT( (isCycleBreakerTyVar cbv) )-                      firstJusts (NE.map (lookup cbv) cbvs_stack)-  = tyfam_app-  | otherwise-  = pprPanic "lookupCycleBreakerVar found an unbound cycle breaker" (ppr cbv $$ ppr cbvs_stack)---- | Push a fresh environment onto the cycle-breaker var stack. Useful--- when entering a nested implication.-pushCycleBreakerVarStack :: CycleBreakerVarStack -> CycleBreakerVarStack-pushCycleBreakerVarStack = ([] NE.<|)---- | Add a new cycle-breaker binding to the top environment on the stack.-insertCycleBreakerBinding :: TcTyVar   -- ^ cbv, must be a CycleBreakerTv-                          -> TcType    -- ^ cbv's expansion-                          -> CycleBreakerVarStack -> CycleBreakerVarStack-insertCycleBreakerBinding cbv expansion (top_env :| rest_envs)-  = ASSERT( (isCycleBreakerTyVar cbv) )-    ((cbv, expansion) : top_env) :| rest_envs---- | Perform a monadic operation on all pairs in the top environment--- in the stack.-forAllCycleBreakerBindings_ :: Monad m-                            => CycleBreakerVarStack-                            -> (TcTyVar -> TcType -> m ()) -> m ()-forAllCycleBreakerBindings_ (top_env :| _rest_envs) action-  = forM_ top_env (uncurry action)-{-# INLINABLE forAllCycleBreakerBindings_ #-}  -- to allow SPECIALISE later---{- Note [Unsolved Derived equalities]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In getUnsolvedInerts, we return a derived equality from the inert_eqs-because it is a candidate for floating out of this implication.  We-only float equalities with a meta-tyvar on the left, so we only pull-those out here.--Note [What might equal later?]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We must determine whether a Given might later equal a Wanted. We-definitely need to account for the possibility that any metavariable-might be arbitrarily instantiated. Yet we do *not* want-to allow skolems in to be instantiated, as we've already rewritten-with respect to any Givens. (We're solving a Wanted here, and so-all Givens have already been processed.)--This is best understood by example.--1. C alpha  ~?  C Int--   That given certainly might match later.--2. C a  ~?  C Int--   No. No new givens are going to arise that will get the `a` to rewrite-   to Int.--3. C alpha[tv]   ~?  C Int--   That alpha[tv] is a TyVarTv, unifiable only with other type variables.-   It cannot equal later.--4. C (F alpha)   ~?   C Int--   Sure -- that can equal later, if we learn something useful about alpha.--5. C (F alpha[tv])  ~?  C Int--   This, too, might equal later. Perhaps we have [G] F b ~ Int elsewhere.-   Or maybe we have C (F alpha[tv] beta[tv]), these unify with each other,-   and F x x = Int. Remember: returning True doesn't commit ourselves to-   anything.--6. C (F a)  ~?  C a--   No, this won't match later. If we could rewrite (F a) or a, we would-   have by now.--7. C (Maybe alpha)  ~?  C alpha--   We say this cannot equal later, because it would require-   alpha := Maybe (Maybe (Maybe ...)). While such a type can be contrived,-   we choose not to worry about it. See Note [Infinitary substitution in lookup]-   in GHC.Core.InstEnv. Getting this wrong let to #19107, tested in-   typecheck/should_compile/T19107.--8. C cbv   ~?  C Int-   where cbv = F a--   The cbv is a cycle-breaker var which stands for F a. See-   Note [Type equality cycles] in GHC.Tc.Solver.Canonical.-   This is just like case 6, and we say "no". Saying "no" here is-   essential in getting the parser to type-check, with its use of DisambECP.--9. C cbv   ~?   C Int-   where cbv = F alpha--   Here, we might indeed equal later. Distinguishing between-   this case and Example 8 is why we need the InertSet in mightEqualLater.--10. C (F alpha, Int)  ~?  C (Bool, F alpha)--   This cannot equal later, because F a would have to equal both Bool and-   Int.--To deal with type family applications, we use the Core flattener. See-Note [Flattening type-family applications when matching instances] in GHC.Core.Unify.-The Core flattener replaces all type family applications with-fresh variables. The next question: should we allow these fresh-variables in the domain of a unifying substitution?--A type family application that mentions only skolems (example 6) is settled:-any skolems would have been rewritten w.r.t. Givens by now. These type family-applications match only themselves. A type family application that mentions-metavariables, on the other hand, can match anything. So, if the original type-family application contains a metavariable, we use BindMe to tell the unifier-to allow it in the substitution. On the other hand, a type family application-with only skolems is considered rigid.--This treatment fixes #18910 and is tested in-typecheck/should_compile/InstanceGivenOverlap{,2}--}--removeInertCts :: [Ct] -> InertCans -> InertCans--- ^ Remove inert constraints from the 'InertCans', for use when a--- typechecker plugin wishes to discard a given.-removeInertCts cts icans = foldl' removeInertCt icans cts--removeInertCt :: InertCans -> Ct -> InertCans-removeInertCt is ct =-  case ct of--    CDictCan  { cc_class = cl, cc_tyargs = tys } ->-      is { inert_dicts = delDict (inert_dicts is) cl tys }--    CEqCan    { cc_lhs  = lhs, cc_rhs = rhs } -> delEq is lhs rhs--    CQuantCan {}     -> panic "removeInertCt: CQuantCan"-    CIrredCan {}     -> panic "removeInertCt: CIrredEvCan"-    CNonCanonical {} -> panic "removeInertCt: CNonCanonical"---- | Looks up a family application in the inerts; returned coercion--- is oriented input ~ output-lookupFamAppInert :: TyCon -> [Type] -> TcS (Maybe (TcCoercion, TcType, CtFlavourRole))-lookupFamAppInert fam_tc tys-  = do { IS { inert_cans = IC { inert_funeqs = inert_funeqs } } <- getTcSInerts-       ; return (lookup_inerts inert_funeqs) }-  where-    lookup_inerts inert_funeqs-      | Just (EqualCtList (CEqCan { cc_ev = ctev, cc_rhs = rhs } :| _))-          <- findFunEq inert_funeqs fam_tc tys-      = Just (ctEvCoercion ctev, rhs, ctEvFlavourRole ctev)-      | otherwise = Nothing--lookupInInerts :: CtLoc -> TcPredType -> TcS (Maybe CtEvidence)--- Is this exact predicate type cached in the solved or canonicals of the InertSet?-lookupInInerts loc pty-  | ClassPred cls tys <- classifyPredType pty-  = do { inerts <- getTcSInerts-       ; return (lookupSolvedDict inerts loc cls tys `mplus`-                 fmap ctEvidence (lookupInertDict (inert_cans inerts) loc cls tys)) }-  | otherwise -- NB: No caching for equalities, IPs, holes, or errors-  = return Nothing---- | Look up a dictionary inert.-lookupInertDict :: InertCans -> CtLoc -> Class -> [Type] -> Maybe Ct-lookupInertDict (IC { inert_dicts = dicts }) loc cls tys-  = case findDict dicts loc cls tys of-      Just ct -> Just ct-      _       -> Nothing---- | Look up a solved inert.-lookupSolvedDict :: InertSet -> CtLoc -> Class -> [Type] -> Maybe CtEvidence--- Returns just if exactly this predicate type exists in the solved.-lookupSolvedDict (IS { inert_solved_dicts = solved }) loc cls tys-  = case findDict solved loc cls tys of-      Just ev -> Just ev-      _       -> Nothing------------------------------lookupFamAppCache :: TyCon -> [Type] -> TcS (Maybe (TcCoercion, TcType))-lookupFamAppCache fam_tc tys-  = do { IS { inert_famapp_cache = famapp_cache } <- getTcSInerts-       ; case findFunEq famapp_cache fam_tc tys of-           result@(Just (co, ty)) ->-             do { traceTcS "famapp_cache hit" (vcat [ ppr (mkTyConApp fam_tc tys)-                                                    , ppr ty-                                                    , ppr co ])-                ; return result }-           Nothing -> return Nothing }--extendFamAppCache :: TyCon -> [Type] -> (TcCoercion, TcType) -> TcS ()--- NB: co :: rhs ~ F tys, to match expectations of rewriter-extendFamAppCache tc xi_args stuff@(_, ty)-  = do { dflags <- getDynFlags-       ; when (gopt Opt_FamAppCache dflags) $-    do { traceTcS "extendFamAppCache" (vcat [ ppr tc <+> ppr xi_args-                                            , ppr ty ])-            -- 'co' can be bottom, in the case of derived items-       ; updInertTcS $ \ is@(IS { inert_famapp_cache = fc }) ->-            is { inert_famapp_cache = insertFunEq fc tc xi_args stuff } } }---- Remove entries from the cache whose evidence mentions variables in the--- supplied set-dropFromFamAppCache :: VarSet -> TcS ()-dropFromFamAppCache varset-  = do { inerts@(IS { inert_famapp_cache = famapp_cache }) <- getTcSInerts-       ; let filtered = filterTcAppMap check famapp_cache-       ; setTcSInerts $ inerts { inert_famapp_cache = filtered } }-  where-    check :: (TcCoercion, TcType) -> Bool-    check (co, _) = not (anyFreeVarsOfCo (`elemVarSet` varset) co)--{- *********************************************************************-*                                                                      *-                   Irreds-*                                                                      *-********************************************************************* -}--foldIrreds :: (Ct -> b -> b) -> Cts -> b -> b-foldIrreds k irreds z = foldr k z irreds---{- *********************************************************************-*                                                                      *-                   TcAppMap-*                                                                      *-************************************************************************--Note [Use loose types in inert set]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Whenever we are looking up an inert dictionary (CDictCan) or function-equality (CEqCan), we use a TcAppMap, which uses the Unique of the-class/type family tycon and then a trie which maps the arguments. This-trie does *not* need to match the kinds of the arguments; this Note-explains why.--Consider the types ty0 = (T ty1 ty2 ty3 ty4) and ty0' = (T ty1' ty2' ty3' ty4'),-where ty4 and ty4' have different kinds. Let's further assume that both types-ty0 and ty0' are well-typed. Because the kind of T is closed, it must be that-one of the ty1..ty3 does not match ty1'..ty3' (and that the kind of the fourth-argument to T is dependent on whichever one changed). Since we are matching-all arguments, during the inert-set lookup, we know that ty1..ty3 do indeed-match ty1'..ty3'. Therefore, the kind of ty4 and ty4' must match, too ---without ever looking at it.--Accordingly, we use LooseTypeMap, which skips the kind check when looking-up a type. I (Richard E) believe this is just an optimization, and that-looking at kinds would be harmless.---}--type TcAppMap a = DTyConEnv (ListMap LooseTypeMap a)-    -- Indexed by tycon then the arg types, using "loose" matching, where-    -- we don't require kind equality. This allows, for example, (a |> co)-    -- to match (a).-    -- See Note [Use loose types in inert set]-    -- Used for types and classes; hence UniqDFM-    -- See Note [foldTM determinism] in GHC.Data.TrieMap for why we use DTyConEnv here--isEmptyTcAppMap :: TcAppMap a -> Bool-isEmptyTcAppMap m = isEmptyDTyConEnv m--emptyTcAppMap :: TcAppMap a-emptyTcAppMap = emptyDTyConEnv--findTcApp :: TcAppMap a -> TyCon -> [Type] -> Maybe a-findTcApp m tc tys = do { tys_map <- lookupDTyConEnv m tc-                        ; lookupTM tys tys_map }--delTcApp :: TcAppMap a -> TyCon -> [Type] -> TcAppMap a-delTcApp m tc tys = adjustDTyConEnv (deleteTM tys) m tc--insertTcApp :: TcAppMap a -> TyCon -> [Type] -> a -> TcAppMap a-insertTcApp m tc tys ct = alterDTyConEnv alter_tm m tc-  where-    alter_tm mb_tm = Just (insertTM tys ct (mb_tm `orElse` emptyTM))--alterTcApp :: forall a. TcAppMap a -> TyCon -> [Type] -> XT a -> TcAppMap a-alterTcApp m tc tys upd = alterDTyConEnv alter_tm m tc-  where-    alter_tm :: Maybe (ListMap LooseTypeMap a) -> Maybe (ListMap LooseTypeMap a)-    alter_tm m_elt = Just (alterTM tys upd (m_elt `orElse` emptyTM))--filterTcAppMap :: forall a. (a -> Bool) -> TcAppMap a -> TcAppMap a-filterTcAppMap f m = mapMaybeDTyConEnv one_tycon m-  where-    one_tycon :: ListMap LooseTypeMap a -> Maybe (ListMap LooseTypeMap a)-    one_tycon tm-      | isEmptyTM filtered_tm = Nothing-      | otherwise             = Just filtered_tm-      where-        filtered_tm = filterTM f tm--tcAppMapToBag :: TcAppMap a -> Bag a-tcAppMapToBag m = foldTcAppMap consBag m emptyBag--foldTcAppMap :: (a -> b -> b) -> TcAppMap a -> b -> b-foldTcAppMap k m z = foldDTyConEnv (foldTM k) z m---{- *********************************************************************-*                                                                      *-                   DictMap-*                                                                      *-********************************************************************* -}---{- Note [Tuples hiding implicit parameters]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-   f,g :: (?x::Int, C a) => a -> a-   f v = let ?x = 4 in g v--The call to 'g' gives rise to a Wanted constraint (?x::Int, C a).-We must /not/ solve this from the Given (?x::Int, C a), because of-the intervening binding for (?x::Int).  #14218.--We deal with this by arranging that we always fail when looking up a-tuple constraint that hides an implicit parameter. Not that this applies-  * both to the inert_dicts (lookupInertDict)-  * and to the solved_dicts (looukpSolvedDict)-An alternative would be not to extend these sets with such tuple-constraints, but it seemed more direct to deal with the lookup.--Note [Solving CallStack constraints]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose f :: HasCallStack => blah.  Then--* Each call to 'f' gives rise to-    [W] s1 :: IP "callStack" CallStack    -- CtOrigin = OccurrenceOf f-  with a CtOrigin that says "OccurrenceOf f".-  Remember that HasCallStack is just shorthand for-    IP "callStack CallStack-  See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence--* We cannonicalise such constraints, in GHC.Tc.Solver.Canonical.canClassNC, by-  pushing the call-site info on the stack, and changing the CtOrigin-  to record that has been done.-   Bind:  s1 = pushCallStack <site-info> s2-   [W] s2 :: IP "callStack" CallStack   -- CtOrigin = IPOccOrigin--* Then, and only then, we can solve the constraint from an enclosing-  Given.--So we must be careful /not/ to solve 's1' from the Givens.  Again,-we ensure this by arranging that findDict always misses when looking-up souch constraints.--}--type DictMap a = TcAppMap a--emptyDictMap :: DictMap a-emptyDictMap = emptyTcAppMap--findDict :: DictMap a -> CtLoc -> Class -> [Type] -> Maybe a-findDict m loc cls tys-  | hasIPSuperClasses cls tys -- See Note [Tuples hiding implicit parameters]-  = Nothing--  | Just {} <- isCallStackPred cls tys-  , OccurrenceOf {} <- ctLocOrigin loc-  = Nothing             -- See Note [Solving CallStack constraints]--  | otherwise-  = findTcApp m (classTyCon cls) tys--findDictsByClass :: DictMap a -> Class -> Bag a-findDictsByClass m cls-  | Just tm <- lookupDTyConEnv m (classTyCon cls) = foldTM consBag tm emptyBag-  | otherwise                                     = emptyBag--delDict :: DictMap a -> Class -> [Type] -> DictMap a-delDict m cls tys = delTcApp m (classTyCon cls) tys--addDict :: DictMap a -> Class -> [Type] -> a -> DictMap a-addDict m cls tys item = insertTcApp m (classTyCon cls) tys item--addDictCt :: DictMap Ct -> Class -> [Type] -> Ct -> DictMap Ct--- Like addDict, but combines [W] and [D] to [WD]--- See Note [KeepBoth] in GHC.Tc.Solver.Interact-addDictCt m cls tys new_ct = alterTcApp m (classTyCon cls) tys xt_ct-  where-    new_ct_ev = ctEvidence new_ct--    xt_ct :: Maybe Ct -> Maybe Ct-    xt_ct (Just old_ct)-      | CtWanted { ctev_nosh = WOnly } <- old_ct_ev-      , CtDerived {} <- new_ct_ev-      = Just (old_ct { cc_ev = old_ct_ev { ctev_nosh = WDeriv }})-      | CtDerived {} <- old_ct_ev-      , CtWanted { ctev_nosh = WOnly } <- new_ct_ev-      = Just (new_ct { cc_ev = new_ct_ev { ctev_nosh = WDeriv }})-      where-        old_ct_ev = ctEvidence old_ct--    xt_ct _ = Just new_ct--addDictsByClass :: DictMap Ct -> Class -> Bag Ct -> DictMap Ct-addDictsByClass m cls items-  = extendDTyConEnv m (classTyCon cls) (foldr add emptyTM items)-  where-    add ct@(CDictCan { cc_tyargs = tys }) tm = insertTM tys ct tm-    add ct _ = pprPanic "addDictsByClass" (ppr ct)--filterDicts :: (Ct -> Bool) -> DictMap Ct -> DictMap Ct-filterDicts f m = filterTcAppMap f m--partitionDicts :: (Ct -> Bool) -> DictMap Ct -> (Bag Ct, DictMap Ct)-partitionDicts f m = foldTcAppMap k m (emptyBag, emptyDicts)-  where-    k ct (yeses, noes) | f ct      = (ct `consBag` yeses, noes)-                       | otherwise = (yeses,              add ct noes)-    add ct@(CDictCan { cc_class = cls, cc_tyargs = tys }) m-      = addDict m cls tys ct-    add ct _ = pprPanic "partitionDicts" (ppr ct)--dictsToBag :: DictMap a -> Bag a-dictsToBag = tcAppMapToBag--foldDicts :: (a -> b -> b) -> DictMap a -> b -> b-foldDicts = foldTcAppMap--emptyDicts :: DictMap a-emptyDicts = emptyTcAppMap---{- *********************************************************************-*                                                                      *-                   FunEqMap-*                                                                      *-********************************************************************* -}--type FunEqMap a = TcAppMap a  -- A map whose key is a (TyCon, [Type]) pair--emptyFunEqs :: TcAppMap a-emptyFunEqs = emptyTcAppMap--findFunEq :: FunEqMap a -> TyCon -> [Type] -> Maybe a-findFunEq m tc tys = findTcApp m tc tys--findFunEqsByTyCon :: FunEqMap a -> TyCon -> [a]--- Get inert function equation constraints that have the given tycon--- in their head.  Not that the constraints remain in the inert set.--- We use this to check for derived interactions with built-in type-function--- constructors.-findFunEqsByTyCon m tc-  | Just tm <- lookupDTyConEnv m tc = foldTM (:) tm []-  | otherwise                       = []--foldFunEqs :: (a -> b -> b) -> FunEqMap a -> b -> b-foldFunEqs = foldTcAppMap--insertFunEq :: FunEqMap a -> TyCon -> [Type] -> a -> FunEqMap a-insertFunEq m tc tys val = insertTcApp m tc tys val--{--************************************************************************-*                                                                      *-*              The TcS solver monad                                    *-*                                                                      *-************************************************************************--Note [The TcS monad]-~~~~~~~~~~~~~~~~~~~~-The TcS monad is a weak form of the main Tc monad--All you can do is-    * fail-    * allocate new variables-    * fill in evidence variables--Filling in a dictionary evidence variable means to create a binding-for it, so TcS carries a mutable location where the binding can be-added.  This is initialised from the innermost implication constraint.--}--data TcSEnv-  = TcSEnv {-      tcs_ev_binds    :: EvBindsVar,--      tcs_unified     :: IORef Int,-         -- The number of unification variables we have filled-         -- The important thing is whether it is non-zero--      tcs_unif_lvl  :: IORef (Maybe TcLevel),-         -- The Unification Level Flag-         -- Outermost level at which we have unified a meta tyvar-         -- Starts at Nothing, then (Just i), then (Just j) where j<i-         -- See Note [The Unification Level Flag]--      tcs_count     :: IORef Int, -- Global step count--      tcs_inerts    :: IORef InertSet, -- Current inert set--      -- See Note [WorkList priorities] and-      tcs_worklist  :: IORef WorkList -- Current worklist-    }------------------newtype TcS a = TcS { unTcS :: TcSEnv -> TcM a } deriving (Functor)---- | Smart constructor for 'TcS', as describe in Note [The one-shot state--- monad trick] in "GHC.Utils.Monad".-mkTcS :: (TcSEnv -> TcM a) -> TcS a-mkTcS f = TcS (oneShot f)--instance Applicative TcS where-  pure x = mkTcS $ \_ -> return x-  (<*>) = ap--instance Monad TcS where-  m >>= k   = mkTcS $ \ebs -> do-    unTcS m ebs >>= (\r -> unTcS (k r) ebs)--instance MonadFail TcS where-  fail err  = mkTcS $ \_ -> fail err--instance MonadUnique TcS where-   getUniqueSupplyM = wrapTcS getUniqueSupplyM--instance HasModule TcS where-   getModule = wrapTcS getModule--instance MonadThings TcS where-   lookupThing n = wrapTcS (lookupThing n)---- Basic functionality--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-wrapTcS :: TcM a -> TcS a--- Do not export wrapTcS, because it promotes an arbitrary TcM to TcS,--- and TcS is supposed to have limited functionality-wrapTcS action = mkTcS $ \_env -> action -- a TcM action will not use the TcEvBinds--wrapErrTcS :: TcM a -> TcS a--- The thing wrapped should just fail--- There's no static check; it's up to the user--- Having a variant for each error message is too painful-wrapErrTcS = wrapTcS--wrapWarnTcS :: TcM a -> TcS a--- The thing wrapped should just add a warning, or no-op--- There's no static check; it's up to the user-wrapWarnTcS = wrapTcS--failTcS, panicTcS  :: SDoc -> TcS a-warnTcS   :: WarningFlag -> SDoc -> TcS ()-addErrTcS :: SDoc -> TcS ()-failTcS      = wrapTcS . TcM.failWith-warnTcS flag = wrapTcS . TcM.addWarn (Reason flag)-addErrTcS    = wrapTcS . TcM.addErr-panicTcS doc = pprPanic "GHC.Tc.Solver.Canonical" doc--traceTcS :: String -> SDoc -> TcS ()-traceTcS herald doc = wrapTcS (TcM.traceTc herald doc)-{-# INLINE traceTcS #-}  -- see Note [INLINE conditional tracing utilities]--runTcPluginTcS :: TcPluginM a -> TcS a-runTcPluginTcS m = wrapTcS . runTcPluginM m =<< getTcEvBindsVar--instance HasDynFlags TcS where-    getDynFlags = wrapTcS getDynFlags--getGlobalRdrEnvTcS :: TcS GlobalRdrEnv-getGlobalRdrEnvTcS = wrapTcS TcM.getGlobalRdrEnv--bumpStepCountTcS :: TcS ()-bumpStepCountTcS = mkTcS $ \env ->-  do { let ref = tcs_count env-     ; n <- TcM.readTcRef ref-     ; TcM.writeTcRef ref (n+1) }--csTraceTcS :: SDoc -> TcS ()-csTraceTcS doc-  = wrapTcS $ csTraceTcM (return doc)-{-# INLINE csTraceTcS #-}  -- see Note [INLINE conditional tracing utilities]--traceFireTcS :: CtEvidence -> SDoc -> TcS ()--- Dump a rule-firing trace-traceFireTcS ev doc-  = mkTcS $ \env -> csTraceTcM $-    do { n <- TcM.readTcRef (tcs_count env)-       ; tclvl <- TcM.getTcLevel-       ; return (hang (text "Step" <+> int n-                       <> brackets (text "l:" <> ppr tclvl <> comma <>-                                    text "d:" <> ppr (ctLocDepth (ctEvLoc ev)))-                       <+> doc <> colon)-                     4 (ppr ev)) }-{-# INLINE traceFireTcS #-}  -- see Note [INLINE conditional tracing utilities]--csTraceTcM :: TcM SDoc -> TcM ()--- Constraint-solver tracing, -ddump-cs-trace-csTraceTcM mk_doc-  = do { dflags <- getDynFlags-       ; when (  dopt Opt_D_dump_cs_trace dflags-                  || dopt Opt_D_dump_tc_trace dflags )-              ( do { msg <- mk_doc-                   ; TcM.dumpTcRn False-                       Opt_D_dump_cs_trace-                       "" FormatText-                       msg }) }-{-# INLINE csTraceTcM #-}  -- see Note [INLINE conditional tracing utilities]--runTcS :: TcS a                -- What to run-       -> TcM (a, EvBindMap)-runTcS tcs-  = do { ev_binds_var <- TcM.newTcEvBinds-       ; res <- runTcSWithEvBinds ev_binds_var tcs-       ; ev_binds <- TcM.getTcEvBindsMap ev_binds_var-       ; return (res, ev_binds) }--- | This variant of 'runTcS' will keep solving, even when only Deriveds--- are left around. It also doesn't return any evidence, as callers won't--- need it.-runTcSDeriveds :: TcS a -> TcM a-runTcSDeriveds tcs-  = do { ev_binds_var <- TcM.newTcEvBinds-       ; runTcSWithEvBinds ev_binds_var tcs }---- | This can deal only with equality constraints.-runTcSEqualities :: TcS a -> TcM a-runTcSEqualities thing_inside-  = do { ev_binds_var <- TcM.newNoTcEvBinds-       ; runTcSWithEvBinds ev_binds_var thing_inside }---- | A variant of 'runTcS' that takes and returns an 'InertSet' for--- later resumption of the 'TcS' session.-runTcSInerts :: InertSet -> TcS a -> TcM (a, InertSet)-runTcSInerts inerts tcs = do-  ev_binds_var <- TcM.newTcEvBinds-  runTcSWithEvBinds' False ev_binds_var $ do-    setTcSInerts inerts-    a <- tcs-    new_inerts <- getTcSInerts-    return (a, new_inerts)--runTcSWithEvBinds :: EvBindsVar-                  -> TcS a-                  -> TcM a-runTcSWithEvBinds = runTcSWithEvBinds' True--runTcSWithEvBinds' :: Bool -- ^ Restore type equality cycles afterwards?-                           -- Don't if you want to reuse the InertSet.-                           -- See also Note [Type equality cycles]-                           -- in GHC.Tc.Solver.Canonical-                   -> EvBindsVar-                   -> TcS a-                   -> TcM a-runTcSWithEvBinds' restore_cycles ev_binds_var tcs-  = do { unified_var <- TcM.newTcRef 0-       ; step_count <- TcM.newTcRef 0-       ; inert_var <- TcM.newTcRef emptyInert-       ; wl_var <- TcM.newTcRef emptyWorkList-       ; unif_lvl_var <- TcM.newTcRef Nothing-       ; let env = TcSEnv { tcs_ev_binds      = ev_binds_var-                          , tcs_unified       = unified_var-                          , tcs_unif_lvl      = unif_lvl_var-                          , tcs_count         = step_count-                          , tcs_inerts        = inert_var-                          , tcs_worklist      = wl_var }--             -- Run the computation-       ; res <- unTcS tcs env--       ; count <- TcM.readTcRef step_count-       ; when (count > 0) $-         csTraceTcM $ return (text "Constraint solver steps =" <+> int count)--       ; when restore_cycles $-         do { inert_set <- TcM.readTcRef inert_var-            ; restoreTyVarCycles inert_set }--#if defined(DEBUG)-       ; ev_binds <- TcM.getTcEvBindsMap ev_binds_var-       ; checkForCyclicBinds ev_binds-#endif--       ; return res }-------------------------------#if defined(DEBUG)-checkForCyclicBinds :: EvBindMap -> TcM ()-checkForCyclicBinds ev_binds_map-  | null cycles-  = return ()-  | null coercion_cycles-  = TcM.traceTc "Cycle in evidence binds" $ ppr cycles-  | otherwise-  = pprPanic "Cycle in coercion bindings" $ ppr coercion_cycles-  where-    ev_binds = evBindMapBinds ev_binds_map--    cycles :: [[EvBind]]-    cycles = [c | CyclicSCC c <- stronglyConnCompFromEdgedVerticesUniq edges]--    coercion_cycles = [c | c <- cycles, any is_co_bind c]-    is_co_bind (EvBind { eb_lhs = b }) = isEqPrimPred (varType b)--    edges :: [ Node EvVar EvBind ]-    edges = [ DigraphNode bind bndr (nonDetEltsUniqSet (evVarsOfTerm rhs))-            | bind@(EvBind { eb_lhs = bndr, eb_rhs = rhs}) <- bagToList ev_binds ]-            -- It's OK to use nonDetEltsUFM here as-            -- stronglyConnCompFromEdgedVertices is still deterministic even-            -- if the edges are in nondeterministic order as explained in-            -- Note [Deterministic SCC] in GHC.Data.Graph.Directed.-#endif-------------------------------setEvBindsTcS :: EvBindsVar -> TcS a -> TcS a-setEvBindsTcS ref (TcS thing_inside)- = TcS $ \ env -> thing_inside (env { tcs_ev_binds = ref })--nestImplicTcS :: EvBindsVar-              -> TcLevel -> TcS a-              -> TcS a-nestImplicTcS ref inner_tclvl (TcS thing_inside)-  = TcS $ \ TcSEnv { tcs_unified       = unified_var-                   , tcs_inerts        = old_inert_var-                   , tcs_count         = count-                   , tcs_unif_lvl      = unif_lvl-                   } ->-    do { inerts <- TcM.readTcRef old_inert_var-       ; let nest_inert = inerts { inert_cycle_breakers = pushCycleBreakerVarStack-                                                            (inert_cycle_breakers inerts)-                                 , inert_cans = (inert_cans inerts)-                                                   { inert_given_eqs = False } }-                 -- All other InertSet fields are inherited-       ; new_inert_var <- TcM.newTcRef nest_inert-       ; new_wl_var    <- TcM.newTcRef emptyWorkList-       ; let nest_env = TcSEnv { tcs_count         = count     -- Inherited-                               , tcs_unif_lvl      = unif_lvl  -- Inherited-                               , tcs_ev_binds      = ref-                               , tcs_unified       = unified_var-                               , tcs_inerts        = new_inert_var-                               , tcs_worklist      = new_wl_var }-       ; res <- TcM.setTcLevel inner_tclvl $-                thing_inside nest_env--       ; out_inert_set <- TcM.readTcRef new_inert_var-       ; restoreTyVarCycles out_inert_set--#if defined(DEBUG)-       -- Perform a check that the thing_inside did not cause cycles-       ; ev_binds <- TcM.getTcEvBindsMap ref-       ; checkForCyclicBinds ev_binds-#endif-       ; return res }--nestTcS ::  TcS a -> TcS a--- Use the current untouchables, augmenting the current--- evidence bindings, and solved dictionaries--- But have no effect on the InertCans, or on the inert_famapp_cache--- (we want to inherit the latter from processing the Givens)-nestTcS (TcS thing_inside)-  = TcS $ \ env@(TcSEnv { tcs_inerts = inerts_var }) ->-    do { inerts <- TcM.readTcRef inerts_var-       ; new_inert_var <- TcM.newTcRef inerts-       ; new_wl_var    <- TcM.newTcRef emptyWorkList-       ; let nest_env = env { tcs_inerts   = new_inert_var-                            , tcs_worklist = new_wl_var }--       ; res <- thing_inside nest_env--       ; new_inerts <- TcM.readTcRef new_inert_var--       -- we want to propagate the safe haskell failures-       ; let old_ic = inert_cans inerts-             new_ic = inert_cans new_inerts-             nxt_ic = old_ic { inert_safehask = inert_safehask new_ic }--       ; TcM.writeTcRef inerts_var  -- See Note [Propagate the solved dictionaries]-                        (inerts { inert_solved_dicts = inert_solved_dicts new_inerts-                                , inert_cans = nxt_ic })--       ; return res }--emitImplicationTcS :: TcLevel -> SkolemInfo-                   -> [TcTyVar]        -- Skolems-                   -> [EvVar]          -- Givens-                   -> Cts              -- Wanteds-                   -> TcS TcEvBinds--- Add an implication to the TcS monad work-list-emitImplicationTcS new_tclvl skol_info skol_tvs givens wanteds-  = do { let wc = emptyWC { wc_simple = wanteds }-       ; imp <- wrapTcS $-                do { ev_binds_var <- TcM.newTcEvBinds-                   ; imp <- TcM.newImplication-                   ; return (imp { ic_tclvl  = new_tclvl-                                 , ic_skols  = skol_tvs-                                 , ic_given  = givens-                                 , ic_wanted = wc-                                 , ic_binds  = ev_binds_var-                                 , ic_info   = skol_info }) }--       ; emitImplication imp-       ; return (TcEvBinds (ic_binds imp)) }--emitTvImplicationTcS :: TcLevel -> SkolemInfo-                     -> [TcTyVar]        -- Skolems-                     -> Cts              -- Wanteds-                     -> TcS ()--- Just like emitImplicationTcS but no givens and no bindings-emitTvImplicationTcS new_tclvl skol_info skol_tvs wanteds-  = do { let wc = emptyWC { wc_simple = wanteds }-       ; imp <- wrapTcS $-                do { ev_binds_var <- TcM.newNoTcEvBinds-                   ; imp <- TcM.newImplication-                   ; return (imp { ic_tclvl  = new_tclvl-                                 , ic_skols  = skol_tvs-                                 , ic_wanted = wc-                                 , ic_binds  = ev_binds_var-                                 , ic_info   = skol_info }) }--       ; emitImplication imp }---{- Note [Propagate the solved dictionaries]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-It's really quite important that nestTcS does not discard the solved-dictionaries from the thing_inside.-Consider-   Eq [a]-   forall b. empty =>  Eq [a]-We solve the simple (Eq [a]), under nestTcS, and then turn our attention to-the implications.  It's definitely fine to use the solved dictionaries on-the inner implications, and it can make a significant performance difference-if you do so.--}---- Getters and setters of GHC.Tc.Utils.Env fields--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~---- Getter of inerts and worklist-getTcSInertsRef :: TcS (IORef InertSet)-getTcSInertsRef = TcS (return . tcs_inerts)--getTcSWorkListRef :: TcS (IORef WorkList)-getTcSWorkListRef = TcS (return . tcs_worklist)--getTcSInerts :: TcS InertSet-getTcSInerts = getTcSInertsRef >>= readTcRef--setTcSInerts :: InertSet -> TcS ()-setTcSInerts ics = do { r <- getTcSInertsRef; writeTcRef r ics }--getWorkListImplics :: TcS (Bag Implication)-getWorkListImplics-  = do { wl_var <- getTcSWorkListRef-       ; wl_curr <- readTcRef wl_var-       ; return (wl_implics wl_curr) }--pushLevelNoWorkList :: SDoc -> TcS a -> TcS (TcLevel, a)--- Push the level and run thing_inside--- However, thing_inside should not generate any work items-#if defined(DEBUG)-pushLevelNoWorkList err_doc (TcS thing_inside)-  = TcS (\env -> TcM.pushTcLevelM $-                 thing_inside (env { tcs_worklist = wl_panic })-        )-  where-    wl_panic  = pprPanic "GHC.Tc.Solver.Monad.buildImplication" err_doc-                         -- This panic checks that the thing-inside-                         -- does not emit any work-list constraints-#else-pushLevelNoWorkList _ (TcS thing_inside)-  = TcS (\env -> TcM.pushTcLevelM (thing_inside env))  -- Don't check-#endif--updWorkListTcS :: (WorkList -> WorkList) -> TcS ()-updWorkListTcS f-  = do { wl_var <- getTcSWorkListRef-       ; updTcRef wl_var f }--emitWorkNC :: [CtEvidence] -> TcS ()-emitWorkNC evs-  | null evs-  = return ()-  | otherwise-  = emitWork (map mkNonCanonical evs)--emitWork :: [Ct] -> TcS ()-emitWork [] = return ()   -- avoid printing, among other work-emitWork cts-  = do { traceTcS "Emitting fresh work" (vcat (map ppr cts))-       ; updWorkListTcS (extendWorkListCts cts) }--emitImplication :: Implication -> TcS ()-emitImplication implic-  = updWorkListTcS (extendWorkListImplic implic)--newTcRef :: a -> TcS (TcRef a)-newTcRef x = wrapTcS (TcM.newTcRef x)--readTcRef :: TcRef a -> TcS a-readTcRef ref = wrapTcS (TcM.readTcRef ref)--writeTcRef :: TcRef a -> a -> TcS ()-writeTcRef ref val = wrapTcS (TcM.writeTcRef ref val)--updTcRef :: TcRef a -> (a->a) -> TcS ()-updTcRef ref upd_fn = wrapTcS (TcM.updTcRef ref upd_fn)--getTcEvBindsVar :: TcS EvBindsVar-getTcEvBindsVar = TcS (return . tcs_ev_binds)--getTcLevel :: TcS TcLevel-getTcLevel = wrapTcS TcM.getTcLevel--getTcEvTyCoVars :: EvBindsVar -> TcS TyCoVarSet-getTcEvTyCoVars ev_binds_var-  = wrapTcS $ TcM.getTcEvTyCoVars ev_binds_var--getTcEvBindsMap :: EvBindsVar -> TcS EvBindMap-getTcEvBindsMap ev_binds_var-  = wrapTcS $ TcM.getTcEvBindsMap ev_binds_var--setTcEvBindsMap :: EvBindsVar -> EvBindMap -> TcS ()-setTcEvBindsMap ev_binds_var binds-  = wrapTcS $ TcM.setTcEvBindsMap ev_binds_var binds--unifyTyVar :: TcTyVar -> TcType -> TcS ()--- Unify a meta-tyvar with a type--- We keep track of how many unifications have happened in tcs_unified,------ We should never unify the same variable twice!-unifyTyVar tv ty-  = ASSERT2( isMetaTyVar tv, ppr tv )-    TcS $ \ env ->-    do { TcM.traceTc "unifyTyVar" (ppr tv <+> text ":=" <+> ppr ty)-       ; TcM.writeMetaTyVar tv ty-       ; TcM.updTcRef (tcs_unified env) (+1) }--reportUnifications :: TcS a -> TcS (Int, a)-reportUnifications (TcS thing_inside)-  = TcS $ \ env ->-    do { inner_unified <- TcM.newTcRef 0-       ; res <- thing_inside (env { tcs_unified = inner_unified })-       ; n_unifs <- TcM.readTcRef inner_unified-       ; TcM.updTcRef (tcs_unified env) (+ n_unifs)-       ; return (n_unifs, res) }--data TouchabilityTestResult-  -- See Note [Solve by unification] in GHC.Tc.Solver.Interact-  -- which points out that having TouchableSameLevel is just an optimisation;-  -- we could manage with TouchableOuterLevel alone (suitably renamed)-  = TouchableSameLevel-  | TouchableOuterLevel [TcTyVar]   -- Promote these-                        TcLevel     -- ..to this level-  | Untouchable--instance Outputable TouchabilityTestResult where-  ppr TouchableSameLevel            = text "TouchableSameLevel"-  ppr (TouchableOuterLevel tvs lvl) = text "TouchableOuterLevel" <> parens (ppr lvl <+> ppr tvs)-  ppr Untouchable                   = text "Untouchable"--touchabilityTest :: CtFlavour -> TcTyVar -> TcType -> TcS TouchabilityTestResult--- This is the key test for untouchability:--- See Note [Unification preconditions] in GHC.Tc.Utils.Unify--- and Note [Solve by unification] in GHC.Tc.Solver.Interact-touchabilityTest flav tv1 rhs-  | flav /= Given  -- See Note [Do not unify Givens]-  , MetaTv { mtv_tclvl = tv_lvl, mtv_info = info } <- tcTyVarDetails tv1-  , canSolveByUnification info rhs-  = do { ambient_lvl  <- getTcLevel-       ; given_eq_lvl <- getInnermostGivenEqLevel--       ; if | tv_lvl `sameDepthAs` ambient_lvl-            -> return TouchableSameLevel--            | tv_lvl `deeperThanOrSame` given_eq_lvl   -- No intervening given equalities-            , all (does_not_escape tv_lvl) free_skols  -- No skolem escapes-            -> return (TouchableOuterLevel free_metas tv_lvl)--            | otherwise-            -> return Untouchable }-  | otherwise-  = return Untouchable-  where-     (free_metas, free_skols) = partition isPromotableMetaTyVar $-                                nonDetEltsUniqSet               $-                                tyCoVarsOfType rhs--     does_not_escape tv_lvl fv-       | isTyVar fv = tv_lvl `deeperThanOrSame` tcTyVarLevel fv-       | otherwise  = True-       -- Coercion variables are not an escape risk-       -- If an implication binds a coercion variable, it'll have equalities,-       -- so the "intervening given equalities" test above will catch it-       -- Coercion holes get filled with coercions, so again no problem.--{- Note [Do not unify Givens]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this GADT match-   data T a where-      T1 :: T Int-      ...--   f x = case x of-           T1 -> True-           ...--So we get f :: T alpha[1] -> beta[1]-          x :: T alpha[1]-and from the T1 branch we get the implication-   forall[2] (alpha[1] ~ Int) => beta[1] ~ Bool--Now, clearly we don't want to unify alpha:=Int!  Yet at the moment we-process [G] alpha[1] ~ Int, we don't have any given-equalities in the-inert set, and hence there are no given equalities to make alpha untouchable.--NB: if it were alpha[2] ~ Int, this argument wouldn't hold.  But that-never happens: invariant (GivenInv) in Note [TcLevel invariants]-in GHC.Tc.Utils.TcType.--Simple solution: never unify in Givens!--}--getDefaultInfo ::  TcS ([Type], (Bool, Bool))-getDefaultInfo = wrapTcS TcM.tcGetDefaultTys---- Just get some environments needed for instance looking up and matching--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--getInstEnvs :: TcS InstEnvs-getInstEnvs = wrapTcS $ TcM.tcGetInstEnvs--getFamInstEnvs :: TcS (FamInstEnv, FamInstEnv)-getFamInstEnvs = wrapTcS $ FamInst.tcGetFamInstEnvs--getTopEnv :: TcS HscEnv-getTopEnv = wrapTcS $ TcM.getTopEnv--getGblEnv :: TcS TcGblEnv-getGblEnv = wrapTcS $ TcM.getGblEnv--getLclEnv :: TcS TcLclEnv-getLclEnv = wrapTcS $ TcM.getLclEnv--tcLookupClass :: Name -> TcS Class-tcLookupClass c = wrapTcS $ TcM.tcLookupClass c--tcLookupId :: Name -> TcS Id-tcLookupId n = wrapTcS $ TcM.tcLookupId n---- Setting names as used (used in the deriving of Coercible evidence)--- Too hackish to expose it to TcS? In that case somehow extract the used--- constructors from the result of solveInteract-addUsedGREs :: [GlobalRdrElt] -> TcS ()-addUsedGREs gres = wrapTcS  $ TcM.addUsedGREs gres--addUsedGRE :: Bool -> GlobalRdrElt -> TcS ()-addUsedGRE warn_if_deprec gre = wrapTcS $ TcM.addUsedGRE warn_if_deprec gre--keepAlive :: Name -> TcS ()-keepAlive = wrapTcS . TcM.keepAlive---- Various smaller utilities [TODO, maybe will be absorbed in the instance matcher]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--checkWellStagedDFun :: CtLoc -> InstanceWhat -> PredType -> TcS ()--- Check that we do not try to use an instance before it is available.  E.g.---    instance Eq T where ...---    f x = $( ... (\(p::T) -> p == p)... )--- Here we can't use the equality function from the instance in the splice--checkWellStagedDFun loc what pred-  | TopLevInstance { iw_dfun_id = dfun_id } <- what-  , let bind_lvl = TcM.topIdLvl dfun_id-  , bind_lvl > impLevel-  = wrapTcS $ TcM.setCtLocM loc $-    do { use_stage <- TcM.getStage-       ; TcM.checkWellStaged pp_thing bind_lvl (thLevel use_stage) }--  | otherwise-  = return ()    -- Fast path for common case-  where-    pp_thing = text "instance for" <+> quotes (ppr pred)--pprEq :: TcType -> TcType -> SDoc-pprEq ty1 ty2 = pprParendType ty1 <+> char '~' <+> pprParendType ty2--isFilledMetaTyVar_maybe :: TcTyVar -> TcS (Maybe Type)-isFilledMetaTyVar_maybe tv = wrapTcS (TcM.isFilledMetaTyVar_maybe tv)--isFilledMetaTyVar :: TcTyVar -> TcS Bool-isFilledMetaTyVar tv = wrapTcS (TcM.isFilledMetaTyVar tv)--zonkTyCoVarsAndFV :: TcTyCoVarSet -> TcS TcTyCoVarSet-zonkTyCoVarsAndFV tvs = wrapTcS (TcM.zonkTyCoVarsAndFV tvs)--zonkTyCoVarsAndFVList :: [TcTyCoVar] -> TcS [TcTyCoVar]-zonkTyCoVarsAndFVList tvs = wrapTcS (TcM.zonkTyCoVarsAndFVList tvs)--zonkCo :: Coercion -> TcS Coercion-zonkCo = wrapTcS . TcM.zonkCo--zonkTcType :: TcType -> TcS TcType-zonkTcType ty = wrapTcS (TcM.zonkTcType ty)--zonkTcTypes :: [TcType] -> TcS [TcType]-zonkTcTypes tys = wrapTcS (TcM.zonkTcTypes tys)--zonkTcTyVar :: TcTyVar -> TcS TcType-zonkTcTyVar tv = wrapTcS (TcM.zonkTcTyVar tv)--zonkSimples :: Cts -> TcS Cts-zonkSimples cts = wrapTcS (TcM.zonkSimples cts)--zonkWC :: WantedConstraints -> TcS WantedConstraints-zonkWC wc = wrapTcS (TcM.zonkWC wc)--zonkTyCoVarKind :: TcTyCoVar -> TcS TcTyCoVar-zonkTyCoVarKind tv = wrapTcS (TcM.zonkTyCoVarKind tv)-------------------------------pprKicked :: Int -> SDoc-pprKicked 0 = empty-pprKicked n = parens (int n <+> text "kicked out")--{- *********************************************************************-*                                                                      *-*              The Unification Level Flag                              *-*                                                                      *-********************************************************************* -}--{- Note [The Unification Level Flag]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider a deep tree of implication constraints-   forall[1] a.                              -- Outer-implic-      C alpha[1]                               -- Simple-      forall[2] c. ....(C alpha[1])....        -- Implic-1-      forall[2] b. ....(alpha[1] ~ Int)....    -- Implic-2--The (C alpha) is insoluble until we know alpha.  We solve alpha-by unifying alpha:=Int somewhere deep inside Implic-2. But then we-must try to solve the Outer-implic all over again. This time we can-solve (C alpha) both in Outer-implic, and nested inside Implic-1.--When should we iterate solving a level-n implication?-Answer: if any unification of a tyvar at level n takes place-        in the ic_implics of that implication.--* What if a unification takes place at level n-1? Then don't iterate-  level n, because we'll iterate level n-1, and that will in turn iterate-  level n.--* What if a unification takes place at level n, in the ic_simples of-  level n?  No need to track this, because the kick-out mechanism deals-  with it.  (We can't drop kick-out in favour of iteration, because kick-out-  works for skolem-equalities, not just unifications.)--So the monad-global Unification Level Flag, kept in tcs_unif_lvl keeps-track of-  - Whether any unifications at all have taken place (Nothing => no unifications)-  - If so, what is the outermost level that has seen a unification (Just lvl)--The iteration done in the simplify_loop/maybe_simplify_again loop in GHC.Tc.Solver.--It helpful not to iterate unless there is a chance of progress.  #8474 is-an example:--  * There's a deeply-nested chain of implication constraints.-       ?x:alpha => ?y1:beta1 => ... ?yn:betan => [W] ?x:Int--  * From the innermost one we get a [D] alpha[1] ~ Int,-    so we can unify.--  * It's better not to iterate the inner implications, but go all the-    way out to level 1 before iterating -- because iterating level 1-    will iterate the inner levels anyway.--(In the olden days when we "floated" thse Derived constraints, this was-much, much more important -- we got exponential behaviour, as each iteration-produced the same Derived constraint.)--}---resetUnificationFlag :: TcS Bool--- We are at ambient level i--- If the unification flag = Just i, reset it to Nothing and return True--- Otherwise leave it unchanged and return False-resetUnificationFlag-  = TcS $ \env ->-    do { let ref = tcs_unif_lvl env-       ; ambient_lvl <- TcM.getTcLevel-       ; mb_lvl <- TcM.readTcRef ref-       ; TcM.traceTc "resetUnificationFlag" $-         vcat [ text "ambient:" <+> ppr ambient_lvl-              , text "unif_lvl:" <+> ppr mb_lvl ]-       ; case mb_lvl of-           Nothing       -> return False-           Just unif_lvl | ambient_lvl `strictlyDeeperThan` unif_lvl-                         -> return False-                         | otherwise-                         -> do { TcM.writeTcRef ref Nothing-                               ; return True } }--setUnificationFlag :: TcLevel -> TcS ()--- (setUnificationFlag i) sets the unification level to (Just i)--- unless it already is (Just j) where j <= i-setUnificationFlag lvl-  = TcS $ \env ->-    do { let ref = tcs_unif_lvl env-       ; mb_lvl <- TcM.readTcRef ref-       ; case mb_lvl of-           Just unif_lvl | lvl `deeperThanOrSame` unif_lvl-                         -> return ()-           _ -> TcM.writeTcRef ref (Just lvl) }---{- *********************************************************************-*                                                                      *-*                Instantiation etc.-*                                                                      *-********************************************************************* -}---- Instantiations--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--instDFunType :: DFunId -> [DFunInstType] -> TcS ([TcType], TcThetaType)-instDFunType dfun_id inst_tys-  = wrapTcS $ TcM.instDFunType dfun_id inst_tys--newFlexiTcSTy :: Kind -> TcS TcType-newFlexiTcSTy knd = wrapTcS (TcM.newFlexiTyVarTy knd)--cloneMetaTyVar :: TcTyVar -> TcS TcTyVar-cloneMetaTyVar tv = wrapTcS (TcM.cloneMetaTyVar tv)--instFlexi :: [TKVar] -> TcS TCvSubst-instFlexi = instFlexiX emptyTCvSubst--instFlexiX :: TCvSubst -> [TKVar] -> TcS TCvSubst-instFlexiX subst tvs-  = wrapTcS (foldlM instFlexiHelper subst tvs)--instFlexiHelper :: TCvSubst -> TKVar -> TcM TCvSubst-instFlexiHelper subst tv-  = do { uniq <- TcM.newUnique-       ; details <- TcM.newMetaDetails TauTv-       ; let name = setNameUnique (tyVarName tv) uniq-             kind = substTyUnchecked subst (tyVarKind tv)-             ty'  = mkTyVarTy (mkTcTyVar name kind details)-       ; TcM.traceTc "instFlexi" (ppr ty')-       ; return (extendTvSubst subst tv ty') }--matchGlobalInst :: DynFlags-                -> Bool      -- True <=> caller is the short-cut solver-                             -- See Note [Shortcut solving: overlap]-                -> Class -> [Type] -> TcS TcM.ClsInstResult-matchGlobalInst dflags short_cut cls tys-  = wrapTcS (TcM.matchGlobalInst dflags short_cut cls tys)--tcInstSkolTyVarsX :: TCvSubst -> [TyVar] -> TcS (TCvSubst, [TcTyVar])-tcInstSkolTyVarsX subst tvs = wrapTcS $ TcM.tcInstSkolTyVarsX subst tvs---- Creating and setting evidence variables and CtFlavors--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--data MaybeNew = Fresh CtEvidence | Cached EvExpr--isFresh :: MaybeNew -> Bool-isFresh (Fresh {})  = True-isFresh (Cached {}) = False--freshGoals :: [MaybeNew] -> [CtEvidence]-freshGoals mns = [ ctev | Fresh ctev <- mns ]--getEvExpr :: MaybeNew -> EvExpr-getEvExpr (Fresh ctev) = ctEvExpr ctev-getEvExpr (Cached evt) = evt--setEvBind :: EvBind -> TcS ()-setEvBind ev_bind-  = do { evb <- getTcEvBindsVar-       ; wrapTcS $ TcM.addTcEvBind evb ev_bind }---- | Mark variables as used filling a coercion hole-useVars :: CoVarSet -> TcS ()-useVars co_vars-  = do { ev_binds_var <- getTcEvBindsVar-       ; let ref = ebv_tcvs ev_binds_var-       ; wrapTcS $-         do { tcvs <- TcM.readTcRef ref-            ; let tcvs' = tcvs `unionVarSet` co_vars-            ; TcM.writeTcRef ref tcvs' } }---- | Equalities only-setWantedEq :: TcEvDest -> Coercion -> TcS ()-setWantedEq (HoleDest hole) co-  = do { useVars (coVarsOfCo co)-       ; fillCoercionHole hole co }-setWantedEq (EvVarDest ev) _ = pprPanic "setWantedEq" (ppr ev)---- | Good for both equalities and non-equalities-setWantedEvTerm :: TcEvDest -> EvTerm -> TcS ()-setWantedEvTerm (HoleDest hole) tm-  | Just co <- evTermCoercion_maybe tm-  = do { useVars (coVarsOfCo co)-       ; fillCoercionHole hole co }-  | otherwise-  = -- See Note [Yukky eq_sel for a HoleDest]-    do { let co_var = coHoleCoVar hole-       ; setEvBind (mkWantedEvBind co_var tm)-       ; fillCoercionHole hole (mkTcCoVarCo co_var) }--setWantedEvTerm (EvVarDest ev_id) tm-  = setEvBind (mkWantedEvBind ev_id tm)--{- Note [Yukky eq_sel for a HoleDest]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-How can it be that a Wanted with HoleDest gets evidence that isn't-just a coercion? i.e. evTermCoercion_maybe returns Nothing.--Consider [G] forall a. blah => a ~ T-         [W] S ~# T--Then doTopReactEqPred carefully looks up the (boxed) constraint (S ~-T) in the quantified constraints, and wraps the (boxed) evidence it-gets back in an eq_sel to extract the unboxed (S ~# T).  We can't put-that term into a coercion, so we add a value binding-    h = eq_sel (...)-and the coercion variable h to fill the coercion hole.-We even re-use the CoHole's Id for this binding!--Yuk!--}--fillCoercionHole :: CoercionHole -> Coercion -> TcS ()-fillCoercionHole hole co-  = do { wrapTcS $ TcM.fillCoercionHole hole co-       ; kickOutAfterFillingCoercionHole hole co }--setEvBindIfWanted :: CtEvidence -> EvTerm -> TcS ()-setEvBindIfWanted ev tm-  = case ev of-      CtWanted { ctev_dest = dest } -> setWantedEvTerm dest tm-      _                             -> return ()--newTcEvBinds :: TcS EvBindsVar-newTcEvBinds = wrapTcS TcM.newTcEvBinds--newNoTcEvBinds :: TcS EvBindsVar-newNoTcEvBinds = wrapTcS TcM.newNoTcEvBinds--newEvVar :: TcPredType -> TcS EvVar-newEvVar pred = wrapTcS (TcM.newEvVar pred)--newGivenEvVar :: CtLoc -> (TcPredType, EvTerm) -> TcS CtEvidence--- Make a new variable of the given PredType,--- immediately bind it to the given term--- and return its CtEvidence--- See Note [Bind new Givens immediately] in GHC.Tc.Types.Constraint-newGivenEvVar loc (pred, rhs)-  = do { new_ev <- newBoundEvVarId pred rhs-       ; return (CtGiven { ctev_pred = pred, ctev_evar = new_ev, ctev_loc = loc }) }---- | Make a new 'Id' of the given type, bound (in the monad's EvBinds) to the--- given term-newBoundEvVarId :: TcPredType -> EvTerm -> TcS EvVar-newBoundEvVarId pred rhs-  = do { new_ev <- newEvVar pred-       ; setEvBind (mkGivenEvBind new_ev rhs)-       ; return new_ev }--newGivenEvVars :: CtLoc -> [(TcPredType, EvTerm)] -> TcS [CtEvidence]-newGivenEvVars loc pts = mapM (newGivenEvVar loc) pts--emitNewWantedEq :: CtLoc -> Role -> TcType -> TcType -> TcS Coercion--- | Emit a new Wanted equality into the work-list-emitNewWantedEq loc role ty1 ty2-  = do { (ev, co) <- newWantedEq loc role ty1 ty2-       ; updWorkListTcS (extendWorkListEq (mkNonCanonical ev))-       ; return co }---- | Make a new equality CtEvidence-newWantedEq :: CtLoc -> Role -> TcType -> TcType-            -> TcS (CtEvidence, Coercion)-newWantedEq = newWantedEq_SI WDeriv--newWantedEq_SI :: ShadowInfo -> CtLoc -> Role-               -> TcType -> TcType-               -> TcS (CtEvidence, Coercion)-newWantedEq_SI si loc role ty1 ty2-  = do { hole <- wrapTcS $ TcM.newCoercionHole pty-       ; traceTcS "Emitting new coercion hole" (ppr hole <+> dcolon <+> ppr pty)-       ; return ( CtWanted { ctev_pred = pty, ctev_dest = HoleDest hole-                           , ctev_nosh = si-                           , ctev_loc = loc}-                , mkHoleCo hole ) }-  where-    pty = mkPrimEqPredRole role ty1 ty2---- no equalities here. Use newWantedEq instead-newWantedEvVarNC :: CtLoc -> TcPredType -> TcS CtEvidence-newWantedEvVarNC = newWantedEvVarNC_SI WDeriv--newWantedEvVarNC_SI :: ShadowInfo -> CtLoc -> TcPredType -> TcS CtEvidence--- Don't look up in the solved/inerts; we know it's not there-newWantedEvVarNC_SI si loc pty-  = do { new_ev <- newEvVar pty-       ; traceTcS "Emitting new wanted" (ppr new_ev <+> dcolon <+> ppr pty $$-                                         pprCtLoc loc)-       ; return (CtWanted { ctev_pred = pty, ctev_dest = EvVarDest new_ev-                          , ctev_nosh = si-                          , ctev_loc = loc })}--newWantedEvVar :: CtLoc -> TcPredType -> TcS MaybeNew-newWantedEvVar = newWantedEvVar_SI WDeriv--newWantedEvVar_SI :: ShadowInfo -> CtLoc -> TcPredType -> TcS MaybeNew--- For anything except ClassPred, this is the same as newWantedEvVarNC-newWantedEvVar_SI si loc pty-  = do { mb_ct <- lookupInInerts loc pty-       ; case mb_ct of-            Just ctev-              | not (isDerived ctev)-              -> do { traceTcS "newWantedEvVar/cache hit" $ ppr ctev-                    ; return $ Cached (ctEvExpr ctev) }-            _ -> do { ctev <- newWantedEvVarNC_SI si loc pty-                    ; return (Fresh ctev) } }--newWanted :: CtLoc -> PredType -> TcS MaybeNew--- Deals with both equalities and non equalities. Tries to look--- up non-equalities in the cache-newWanted = newWanted_SI WDeriv--newWanted_SI :: ShadowInfo -> CtLoc -> PredType -> TcS MaybeNew-newWanted_SI si loc pty-  | Just (role, ty1, ty2) <- getEqPredTys_maybe pty-  = Fresh . fst <$> newWantedEq_SI si loc role ty1 ty2-  | otherwise-  = newWantedEvVar_SI si loc pty---- deals with both equalities and non equalities. Doesn't do any cache lookups.-newWantedNC :: CtLoc -> PredType -> TcS CtEvidence-newWantedNC loc pty-  | Just (role, ty1, ty2) <- getEqPredTys_maybe pty-  = fst <$> newWantedEq loc role ty1 ty2-  | otherwise-  = newWantedEvVarNC loc pty--emitNewDeriveds :: CtLoc -> [TcPredType] -> TcS ()-emitNewDeriveds loc preds-  | null preds-  = return ()-  | otherwise-  = do { evs <- mapM (newDerivedNC loc) preds-       ; traceTcS "Emitting new deriveds" (ppr evs)-       ; updWorkListTcS (extendWorkListDeriveds evs) }--emitNewDerivedEq :: CtLoc -> Role -> TcType -> TcType -> TcS ()--- Create new equality Derived and put it in the work list--- There's no caching, no lookupInInerts-emitNewDerivedEq loc role ty1 ty2-  = do { ev <- newDerivedNC loc (mkPrimEqPredRole role ty1 ty2)-       ; traceTcS "Emitting new derived equality" (ppr ev $$ pprCtLoc loc)-       ; updWorkListTcS (extendWorkListEq (mkNonCanonical ev)) }-         -- Very important: put in the wl_eqs-         -- See Note [Prioritise equalities] (Avoiding fundep iteration)--newDerivedNC :: CtLoc -> TcPredType -> TcS CtEvidence-newDerivedNC loc pred-  = return $ CtDerived { ctev_pred = pred, ctev_loc = loc }---- --------- Check done in GHC.Tc.Solver.Interact.selectNewWorkItem???? ------------ | Checks if the depth of the given location is too much. Fails if--- it's too big, with an appropriate error message.-checkReductionDepth :: CtLoc -> TcType   -- ^ type being reduced-                    -> TcS ()-checkReductionDepth loc ty-  = do { dflags <- getDynFlags-       ; when (subGoalDepthExceeded dflags (ctLocDepth loc)) $-         wrapErrTcS $-         solverDepthErrorTcS loc ty }--matchFam :: TyCon -> [Type] -> TcS (Maybe (CoercionN, TcType))--- Given (F tys) return (ty, co), where co :: ty ~N F tys-matchFam tycon args = fmap (fmap (first mkTcSymCo)) $ wrapTcS $ matchFamTcM tycon args--matchFamTcM :: TyCon -> [Type] -> TcM (Maybe (CoercionN, TcType))--- Given (F tys) return (ty, co), where co :: F tys ~N ty-matchFamTcM tycon args-  = do { fam_envs <- FamInst.tcGetFamInstEnvs-       ; let match_fam_result-              = reduceTyFamApp_maybe fam_envs Nominal tycon args-       ; TcM.traceTc "matchFamTcM" $-         vcat [ text "Matching:" <+> ppr (mkTyConApp tycon args)-              , ppr_res match_fam_result ]-       ; return match_fam_result }-  where-    ppr_res Nothing        = text "Match failed"-    ppr_res (Just (co,ty)) = hang (text "Match succeeded:")-                                2 (vcat [ text "Rewrites to:" <+> ppr ty-                                        , text "Coercion:" <+> ppr co ])--{--Note [Residual implications]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The wl_implics in the WorkList are the residual implication-constraints that are generated while solving or canonicalising the-current worklist.  Specifically, when canonicalising-   (forall a. t1 ~ forall a. t2)-from which we get the implication-   (forall a. t1 ~ t2)-See GHC.Tc.Solver.Monad.deferTcSForAllEq--}--{--************************************************************************-*                                                                      *-              Breaking type equality cycles-*                                                                      *-************************************************************************--}---- | Conditionally replace all type family applications in the RHS with fresh--- variables, emitting givens that relate the type family application to the--- variable. See Note [Type equality cycles] in GHC.Tc.Solver.Canonical.--- This only works under conditions as described in the Note; otherwise, returns--- Nothing.-breakTyEqCycle_maybe :: CtEvidence-                      -> CheckTyEqResult   -- result of checkTypeEq-                      -> CanEqLHS-                      -> TcType     -- RHS-                      -> TcS (Maybe (CoercionN, TcType))-                         -- new RHS that doesn't have any type families-                         -- co :: new type ~N old type-                         -- TcTyVar is the LHS tv; convenient for the caller-breakTyEqCycle_maybe (ctLocOrigin . ctEvLoc -> CycleBreakerOrigin _) _ _ _-  -- see Detail (7) of Note-  = return Nothing--breakTyEqCycle_maybe ev cte_result lhs rhs-  | NomEq <- eq_rel--  , cte_result `cterHasOnlyProblem` cteSolubleOccurs-     -- only do this if the only problem is a soluble occurs-check-     -- See Detail (8) of the Note.--  = do { should_break <- final_check-       ; if should_break then do { (co, new_rhs) <- go rhs-                                 ; return (Just (co, new_rhs)) }-                         else return Nothing }-  where-    flavour = ctEvFlavour ev-    eq_rel  = ctEvEqRel ev--    final_check-      | Given <- flavour-      = return True-      | ctFlavourContainsDerived flavour-      , TyVarLHS lhs_tv <- lhs-      = do { result <- touchabilityTest Derived lhs_tv rhs-           ; return $ case result of-               Untouchable -> False-               _           -> True }-      | otherwise-      = return False--    -- This could be considerably more efficient. See Detail (5) of Note.-    go :: TcType -> TcS (CoercionN, TcType)-    go ty | Just ty' <- rewriterView ty = go ty'-    go (Rep.TyConApp tc tys)-      | isTypeFamilyTyCon tc  -- worried about whether this type family is not actually-                              -- causing trouble? See Detail (5) of Note.-      = do { let (fun_args, extra_args) = splitAt (tyConArity tc) tys-                 fun_app                = mkTyConApp tc fun_args-                 fun_app_kind           = tcTypeKind fun_app-           ; (co, new_ty) <- emit_work fun_app_kind fun_app-           ; (extra_args_cos, extra_args') <- mapAndUnzipM go extra_args-           ; return (mkAppCos co extra_args_cos, mkAppTys new_ty extra_args') }-              -- Worried that this substitution will change kinds?-              -- See Detail (3) of Note--      | otherwise-      = do { (cos, tys) <- mapAndUnzipM go tys-           ; return (mkTyConAppCo Nominal tc cos, mkTyConApp tc tys) }--    go (Rep.AppTy ty1 ty2)-      = do { (co1, ty1') <- go ty1-           ; (co2, ty2') <- go ty2-           ; return (mkAppCo co1 co2, mkAppTy ty1' ty2') }-    go (Rep.FunTy vis w arg res)-      = do { (co_w, w') <- go w-           ; (co_arg, arg') <- go arg-           ; (co_res, res') <- go res-           ; return (mkFunCo Nominal co_w co_arg co_res, mkFunTy vis w' arg' res') }-    go (Rep.CastTy ty cast_co)-      = do { (co, ty') <- go ty-             -- co :: ty' ~N ty-             -- return_co :: (ty' |> cast_co) ~ (ty |> cast_co)-           ; return (castCoercionKind1 co Nominal ty' ty cast_co, mkCastTy ty' cast_co) }--    go ty@(Rep.TyVarTy {})    = skip ty-    go ty@(Rep.LitTy {})      = skip ty-    go ty@(Rep.ForAllTy {})   = skip ty  -- See Detail (1) of Note-    go ty@(Rep.CoercionTy {}) = skip ty  -- See Detail (2) of Note--    skip ty = return (mkNomReflCo ty, ty)--    emit_work :: TcKind                   -- of the function application-              -> TcType                   -- original function application-              -> TcS (CoercionN, TcType)  -- rewritten type (the fresh tyvar)-    emit_work fun_app_kind fun_app = case flavour of-      Given ->-        do { new_tv <- wrapTcS (TcM.newCycleBreakerTyVar fun_app_kind)-           ; let new_ty     = mkTyVarTy new_tv-                 given_pred = mkHeteroPrimEqPred fun_app_kind fun_app_kind-                                                 fun_app new_ty-                 given_term = evCoercion $ mkNomReflCo new_ty  -- See Detail (4) of Note-           ; new_given <- newGivenEvVar new_loc (given_pred, given_term)-           ; traceTcS "breakTyEqCycle replacing type family in Given" (ppr new_given)-           ; emitWorkNC [new_given]-           ; updInertTcS $ \is ->-               is { inert_cycle_breakers = insertCycleBreakerBinding new_tv fun_app-                                             (inert_cycle_breakers is) }-           ; return (mkNomReflCo new_ty, new_ty) }-                -- Why reflexive? See Detail (4) of the Note--      _derived_or_wd ->-        do { new_tv <- wrapTcS (TcM.newFlexiTyVar fun_app_kind)-           ; let new_ty = mkTyVarTy new_tv-           ; co <- emitNewWantedEq new_loc Nominal new_ty fun_app-           ; return (co, new_ty) }+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++{-# OPTIONS_GHC -Wno-incomplete-record-updates -Wno-orphans #-}++-- | Monadic definitions for the constraint solver+module GHC.Tc.Solver.Monad (++    -- The TcS monad+    TcS, runTcS, runTcSEarlyAbort, runTcSWithEvBinds, runTcSInerts,+    failTcS, warnTcS, addErrTcS, wrapTcS,+    runTcSEqualities,+    nestTcS, nestImplicTcS, setEvBindsTcS,+    emitImplicationTcS, emitTvImplicationTcS,++    selectNextWorkItem,+    getWorkList,+    updWorkListTcS,+    pushLevelNoWorkList,++    runTcPluginTcS, addUsedGRE, addUsedGREs, keepAlive,+    matchGlobalInst, TcM.ClsInstResult(..),++    QCInst(..),++    -- Tracing etc+    panicTcS, traceTcS,+    traceFireTcS, bumpStepCountTcS, csTraceTcS,+    wrapErrTcS, wrapWarnTcS,+    resetUnificationFlag, setUnificationFlag,++    -- Evidence creation and transformation+    MaybeNew(..), freshGoals, isFresh, getEvExpr,++    newTcEvBinds, newNoTcEvBinds,+    newWantedEq, emitNewWantedEq,+    newWanted,+    newWantedNC, newWantedEvVarNC,+    newBoundEvVarId,+    unifyTyVar, reportUnifications, touchabilityTest, TouchabilityTestResult(..),+    setEvBind, setWantedEq,+    setWantedEvTerm, setEvBindIfWanted,+    newEvVar, newGivenEvVar, newGivenEvVars,+    checkReductionDepth,+    getSolvedDicts, setSolvedDicts,++    getInstEnvs, getFamInstEnvs,                -- Getting the environments+    getTopEnv, getGblEnv, getLclEnv, setLclEnv,+    getTcEvBindsVar, getTcLevel,+    getTcEvTyCoVars, getTcEvBindsMap, setTcEvBindsMap,+    tcLookupClass, tcLookupId,++    -- Inerts+    updInertTcS, updInertCans, updInertDicts, updInertIrreds,+    getHasGivenEqs, setInertCans,+    getInertEqs, getInertCans, getInertGivens,+    getInertInsols, getInnermostGivenEqLevel,+    getTcSInerts, setTcSInerts,+    getUnsolvedInerts,+    removeInertCts, getPendingGivenScs,+    addInertCan, insertFunEq, addInertForAll,+    emitWorkNC, emitWork,+    lookupInertDict,++    -- The Model+    kickOutAfterUnification,++    -- Inert Safe Haskell safe-overlap failures+    addInertSafehask, insertSafeOverlapFailureTcS, updInertSafehask,+    getSafeOverlapFailures,++    -- Inert solved dictionaries+    addSolvedDict, lookupSolvedDict,++    -- Irreds+    foldIrreds,++    -- The family application cache+    lookupFamAppInert, lookupFamAppCache, extendFamAppCache,+    pprKicked,++    instDFunType,                              -- Instantiation++    -- MetaTyVars+    newFlexiTcSTy, instFlexi, instFlexiX,+    cloneMetaTyVar,+    tcInstSkolTyVarsX,++    TcLevel,+    isFilledMetaTyVar_maybe, isFilledMetaTyVar,+    zonkTyCoVarsAndFV, zonkTcType, zonkTcTypes, zonkTcTyVar, zonkCo,+    zonkTyCoVarsAndFVList,+    zonkSimples, zonkWC,+    zonkTyCoVarKind,++    -- References+    newTcRef, readTcRef, writeTcRef, updTcRef,++    -- Misc+    getDefaultInfo, getDynFlags, getGlobalRdrEnvTcS,+    matchFam, matchFamTcM,+    checkWellStagedDFun,+    pprEq,                                   -- Smaller utils, re-exported from TcM+                                             -- TODO (DV): these are only really used in the+                                             -- instance matcher in GHC.Tc.Solver. I am wondering+                                             -- if the whole instance matcher simply belongs+                                             -- here++    breakTyEqCycle_maybe, rewriterView+) where++import GHC.Prelude++import GHC.Driver.Env++import qualified GHC.Tc.Utils.Instantiate as TcM+import GHC.Core.InstEnv+import GHC.Tc.Instance.Family as FamInst+import GHC.Core.FamInstEnv++import qualified GHC.Tc.Utils.Monad    as TcM+import qualified GHC.Tc.Utils.TcMType  as TcM+import qualified GHC.Tc.Instance.Class as TcM( matchGlobalInst, ClsInstResult(..) )+import qualified GHC.Tc.Utils.Env      as TcM+       ( checkWellStaged, tcGetDefaultTys, tcLookupClass, tcLookupId, topIdLvl+       , tcInitTidyEnv )+import GHC.Tc.Instance.Class( InstanceWhat(..), safeOverlap, instanceReturnsDictCon )+import GHC.Tc.Utils.TcType+import GHC.Driver.Session+import GHC.Core.Type+import qualified GHC.Core.TyCo.Rep as Rep  -- this needs to be used only very locally+import GHC.Core.Coercion+import GHC.Core.Reduction++import GHC.Tc.Solver.Types+import GHC.Tc.Solver.InertSet++import GHC.Tc.Types.Evidence+import GHC.Core.Class+import GHC.Core.TyCon+import GHC.Tc.Errors.Types+import GHC.Types.Error ( mkPlainError, noHints )++import GHC.Types.Name+import GHC.Types.TyThing+import GHC.Unit.Module ( HasModule, getModule, extractModule )+import GHC.Types.Name.Reader ( GlobalRdrEnv, GlobalRdrElt )+import qualified GHC.Rename.Env as TcM+import GHC.Types.Var+import GHC.Types.Var.Env+import GHC.Types.Var.Set+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Utils.Logger+import GHC.Utils.Misc (HasDebugCallStack)+import GHC.Data.Bag as Bag+import GHC.Types.Unique.Supply+import GHC.Tc.Types+import GHC.Tc.Types.Origin+import GHC.Tc.Types.Constraint+import GHC.Tc.Utils.Unify+import GHC.Core.Predicate+import GHC.Types.Unique.Set (nonDetEltsUniqSet)++import Control.Monad+import GHC.Utils.Monad+import Data.IORef+import GHC.Exts (oneShot)+import Data.List ( mapAccumL, partition, find )++#if defined(DEBUG)+import GHC.Data.Graph.Directed+#endif++{- *********************************************************************+*                                                                      *+                   Inert instances: inert_insts+*                                                                      *+********************************************************************* -}++addInertForAll :: QCInst -> TcS ()+-- Add a local Given instance, typically arising from a type signature+addInertForAll new_qci+  = do { ics  <- getInertCans+       ; ics1 <- add_qci ics++       -- Update given equalities. C.f updateGivenEqs+       ; tclvl <- getTcLevel+       ; let pred         = qci_pred new_qci+             not_equality = isClassPred pred && not (isEqPred pred)+                  -- True <=> definitely not an equality+                  -- A qci_pred like (f a) might be an equality++             ics2 | not_equality = ics1+                  | otherwise    = ics1 { inert_given_eq_lvl = tclvl+                                        , inert_given_eqs    = True }++       ; setInertCans ics2 }+  where+    add_qci :: InertCans -> TcS InertCans+    -- See Note [Do not add duplicate quantified instances]+    add_qci ics@(IC { inert_insts = qcis })+      | any same_qci qcis+      = do { traceTcS "skipping duplicate quantified instance" (ppr new_qci)+           ; return ics }++      | otherwise+      = do { traceTcS "adding new inert quantified instance" (ppr new_qci)+           ; return (ics { inert_insts = new_qci : qcis }) }++    same_qci old_qci = tcEqType (ctEvPred (qci_ev old_qci))+                                (ctEvPred (qci_ev new_qci))++{- Note [Do not add duplicate quantified instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this (#15244):++  f :: (C g, D g) => ....+  class S g => C g where ...+  class S g => D g where ...+  class (forall a. Eq a => Eq (g a)) => S g where ...++Then in f's RHS there are two identical quantified constraints+available, one via the superclasses of C and one via the superclasses+of D.  The two are identical, and it seems wrong to reject the program+because of that. But without doing duplicate-elimination we will have+two matching QCInsts when we try to solve constraints arising from f's+RHS.++The simplest thing is simply to eliminate duplicates, which we do here.+-}++{- *********************************************************************+*                                                                      *+                  Adding an inert+*                                                                      *+************************************************************************++Note [Adding an equality to the InertCans]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When adding an equality to the inerts:++* Kick out any constraints that can be rewritten by the thing+  we are adding.  Done by kickOutRewritable.++* Note that unifying a:=ty, is like adding [G] a~ty; just use+  kickOutRewritable with Nominal, Given.  See kickOutAfterUnification.++Note [Kick out existing binding for implicit parameter]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have (typecheck/should_compile/ImplicitParamFDs)+  flub :: (?x :: Int) => (Int, Integer)+  flub = (?x, let ?x = 5 in ?x)+When we are checking the last ?x occurrence, we guess its type+to be a fresh unification variable alpha and emit an (IP "x" alpha)+constraint. But the given (?x :: Int) has been translated to an+IP "x" Int constraint, which has a functional dependency from the+name to the type. So fundep interaction tells us that alpha ~ Int,+and we get a type error. This is bad.++Instead, we wish to excise any old given for an IP when adding a+new one. We also must make sure not to float out+any IP constraints outside an implication that binds an IP of+the same name; see GHC.Tc.Solver.floatConstraints.+-}++addInertCan :: Ct -> TcS ()+-- Precondition: item /is/ canonical+-- See Note [Adding an equality to the InertCans]+addInertCan ct =+    do { traceTcS "addInertCan {" $+         text "Trying to insert new inert item:" <+> ppr ct+       ; mkTcS (\TcSEnv{tcs_abort_on_insoluble=abort_flag} ->+                 when (abort_flag && insolubleEqCt ct) TcM.failM)+       ; ics <- getInertCans+       ; ics <- maybeKickOut ics ct+       ; tclvl <- getTcLevel+       ; setInertCans (addInertItem tclvl ics ct)++       ; traceTcS "addInertCan }" $ empty }++maybeKickOut :: InertCans -> Ct -> TcS InertCans+-- For a CEqCan, kick out any inert that can be rewritten by the CEqCan+maybeKickOut ics ct+  | CEqCan { cc_lhs = lhs, cc_ev = ev, cc_eq_rel = eq_rel } <- ct+  = do { (_, ics') <- kickOutRewritable (ctEvFlavour ev, eq_rel) lhs ics+       ; return ics' }++     -- See [Kick out existing binding for implicit parameter]+  | isGivenCt ct+  , CDictCan { cc_class = cls, cc_tyargs = [ip_name_strty, _ip_ty] } <- ct+  , isIPClass cls+  , Just ip_name <- isStrLitTy ip_name_strty+     -- Would this be more efficient if we used findDictsByClass and then delDict?+  = let dict_map = inert_dicts ics+        dict_map' = filterDicts doesn't_match_ip_name dict_map++        doesn't_match_ip_name :: Ct -> Bool+        doesn't_match_ip_name ct+          | Just (inert_ip_name, _inert_ip_ty) <- isIPPred_maybe (ctPred ct)+          = inert_ip_name /= ip_name++          | otherwise+          = True++    in+    return (ics { inert_dicts = dict_map' })++  | otherwise+  = return ics++-----------------------------------------+kickOutRewritable  :: CtFlavourRole  -- Flavour/role of the equality that+                                      -- is being added to the inert set+                   -> CanEqLHS        -- The new equality is lhs ~ ty+                   -> InertCans+                   -> TcS (Int, InertCans)+kickOutRewritable new_fr new_lhs ics+  = do { let (kicked_out, ics') = kickOutRewritableLHS new_fr new_lhs ics+             n_kicked = workListSize kicked_out++       ; unless (n_kicked == 0) $+         do { updWorkListTcS (appendWorkList kicked_out)++              -- The famapp-cache contains Given evidence from the inert set.+              -- If we're kicking out Givens, we need to remove this evidence+              -- from the cache, too.+            ; let kicked_given_ev_vars =+                    [ ev_var | ct <- wl_eqs kicked_out+                             , CtGiven { ctev_evar = ev_var } <- [ctEvidence ct] ]+            ; when (new_fr `eqCanRewriteFR` (Given, NomEq) &&+                   -- if this isn't true, no use looking through the constraints+                    not (null kicked_given_ev_vars)) $+              do { traceTcS "Given(s) have been kicked out; drop from famapp-cache"+                            (ppr kicked_given_ev_vars)+                 ; dropFromFamAppCache (mkVarSet kicked_given_ev_vars) }++            ; csTraceTcS $+              hang (text "Kick out, lhs =" <+> ppr new_lhs)+                 2 (vcat [ text "n-kicked =" <+> int n_kicked+                         , text "kicked_out =" <+> ppr kicked_out+                         , text "Residual inerts =" <+> ppr ics' ]) }++       ; return (n_kicked, ics') }++kickOutAfterUnification :: TcTyVar -> TcS Int+kickOutAfterUnification new_tv+  = do { ics <- getInertCans+       ; (n_kicked, ics2) <- kickOutRewritable (Given,NomEq)+                                                 (TyVarLHS new_tv) ics+                     -- Given because the tv := xi is given; NomEq because+                     -- only nominal equalities are solved by unification++       ; setInertCans ics2+       ; return n_kicked }++-- See Wrinkle (2) in Note [Equalities with incompatible kinds] in GHC.Tc.Solver.Canonical+-- It's possible that this could just go ahead and unify, but could there be occurs-check+-- problems? Seems simpler just to kick out.+kickOutAfterFillingCoercionHole :: CoercionHole -> TcS ()+kickOutAfterFillingCoercionHole hole+  = do { ics <- getInertCans+       ; let (kicked_out, ics') = kick_out ics+             n_kicked           = workListSize kicked_out++       ; unless (n_kicked == 0) $+         do { updWorkListTcS (appendWorkList kicked_out)+            ; csTraceTcS $+              hang (text "Kick out, hole =" <+> ppr hole)+                 2 (vcat [ text "n-kicked =" <+> int n_kicked+                         , text "kicked_out =" <+> ppr kicked_out+                         , text "Residual inerts =" <+> ppr ics' ]) }++       ; setInertCans ics' }+  where+    kick_out :: InertCans -> (WorkList, InertCans)+    kick_out ics@(IC { inert_eqs = eqs, inert_funeqs = funeqs })+      = (kicked_out, ics { inert_eqs = eqs_to_keep, inert_funeqs = funeqs_to_keep })+      where+        (eqs_to_kick, eqs_to_keep)       = partitionInertEqs kick_ct eqs+        (funeqs_to_kick, funeqs_to_keep) = partitionFunEqs kick_ct funeqs+        kicked_out = extendWorkListCts (eqs_to_kick ++ funeqs_to_kick) emptyWorkList++    kick_ct :: Ct -> Bool+         -- True: kick out; False: keep.+    kick_ct (CEqCan { cc_rhs = rhs, cc_ev = ctev })+      = isWanted ctev &&    -- optimisation: givens don't have coercion holes anyway+        rhs `hasThisCoercionHoleTy` hole+    kick_ct other = pprPanic "kick_ct (coercion hole)" (ppr other)++--------------+addInertSafehask :: InertCans -> Ct -> InertCans+addInertSafehask ics item@(CDictCan { cc_class = cls, cc_tyargs = tys })+  = ics { inert_safehask = addDict (inert_dicts ics) cls tys item }++addInertSafehask _ item+  = pprPanic "addInertSafehask: can't happen! Inserting " $ ppr item++insertSafeOverlapFailureTcS :: InstanceWhat -> Ct -> TcS ()+-- See Note [Safe Haskell Overlapping Instances Implementation] in GHC.Tc.Solver+insertSafeOverlapFailureTcS what item+  | safeOverlap what = return ()+  | otherwise        = updInertCans (\ics -> addInertSafehask ics item)++getSafeOverlapFailures :: TcS Cts+-- See Note [Safe Haskell Overlapping Instances Implementation] in GHC.Tc.Solver+getSafeOverlapFailures+ = do { IC { inert_safehask = safehask } <- getInertCans+      ; return $ foldDicts consCts safehask emptyCts }++--------------+addSolvedDict :: InstanceWhat -> CtEvidence -> Class -> [Type] -> TcS ()+-- Conditionally add a new item in the solved set of the monad+-- See Note [Solved dictionaries] in GHC.Tc.Solver.InertSet+addSolvedDict what item cls tys+  | isWanted item+  , instanceReturnsDictCon what+  = do { traceTcS "updSolvedSetTcs:" $ ppr item+       ; updInertTcS $ \ ics ->+             ics { inert_solved_dicts = addDict (inert_solved_dicts ics) cls tys item } }+  | otherwise+  = return ()++getSolvedDicts :: TcS (DictMap CtEvidence)+getSolvedDicts = do { ics <- getTcSInerts; return (inert_solved_dicts ics) }++setSolvedDicts :: DictMap CtEvidence -> TcS ()+setSolvedDicts solved_dicts+  = updInertTcS $ \ ics ->+    ics { inert_solved_dicts = solved_dicts }++{- *********************************************************************+*                                                                      *+                  Other inert-set operations+*                                                                      *+********************************************************************* -}++updInertTcS :: (InertSet -> InertSet) -> TcS ()+-- Modify the inert set with the supplied function+updInertTcS upd_fn+  = do { is_var <- getTcSInertsRef+       ; wrapTcS (do { curr_inert <- TcM.readTcRef is_var+                     ; TcM.writeTcRef is_var (upd_fn curr_inert) }) }++getInertCans :: TcS InertCans+getInertCans = do { inerts <- getTcSInerts; return (inert_cans inerts) }++setInertCans :: InertCans -> TcS ()+setInertCans ics = updInertTcS $ \ inerts -> inerts { inert_cans = ics }++updRetInertCans :: (InertCans -> (a, InertCans)) -> TcS a+-- Modify the inert set with the supplied function+updRetInertCans upd_fn+  = do { is_var <- getTcSInertsRef+       ; wrapTcS (do { inerts <- TcM.readTcRef is_var+                     ; let (res, cans') = upd_fn (inert_cans inerts)+                     ; TcM.writeTcRef is_var (inerts { inert_cans = cans' })+                     ; return res }) }++updInertCans :: (InertCans -> InertCans) -> TcS ()+-- Modify the inert set with the supplied function+updInertCans upd_fn+  = updInertTcS $ \ inerts -> inerts { inert_cans = upd_fn (inert_cans inerts) }++updInertDicts :: (DictMap Ct -> DictMap Ct) -> TcS ()+-- Modify the inert set with the supplied function+updInertDicts upd_fn+  = updInertCans $ \ ics -> ics { inert_dicts = upd_fn (inert_dicts ics) }++updInertSafehask :: (DictMap Ct -> DictMap Ct) -> TcS ()+-- Modify the inert set with the supplied function+updInertSafehask upd_fn+  = updInertCans $ \ ics -> ics { inert_safehask = upd_fn (inert_safehask ics) }++updInertIrreds :: (Cts -> Cts) -> TcS ()+-- Modify the inert set with the supplied function+updInertIrreds upd_fn+  = updInertCans $ \ ics -> ics { inert_irreds = upd_fn (inert_irreds ics) }++getInertEqs :: TcS InertEqs+getInertEqs = do { inert <- getInertCans; return (inert_eqs inert) }++getInnermostGivenEqLevel :: TcS TcLevel+getInnermostGivenEqLevel = do { inert <- getInertCans+                              ; return (inert_given_eq_lvl inert) }++getInertInsols :: TcS Cts+-- Returns insoluble equality constraints and TypeError constraints,+-- specifically including Givens.+--+-- Note that this function only inspects irreducible constraints;+-- a DictCan constraint such as 'Eq (TypeError msg)' is not+-- considered to be an insoluble constraint by this function.+--+-- See Note [Pattern match warnings with insoluble Givens] in GHC.Tc.Solver.+getInertInsols = do { inert <- getInertCans+                    ; return $ filterBag insolubleCt (inert_irreds inert) }++getInertGivens :: TcS [Ct]+-- Returns the Given constraints in the inert set+getInertGivens+  = do { inerts <- getInertCans+       ; let all_cts = foldIrreds (:) (inert_irreds inerts)+                     $ foldDicts (:) (inert_dicts inerts)+                     $ foldFunEqs (++) (inert_funeqs inerts)+                     $ foldDVarEnv (++) [] (inert_eqs inerts)+       ; return (filter isGivenCt all_cts) }++getPendingGivenScs :: TcS [Ct]+-- Find all inert Given dictionaries, or quantified constraints,+--     whose cc_pend_sc flag is True+--     and that belong to the current level+-- Set their cc_pend_sc flag to False in the inert set, and return that Ct+getPendingGivenScs = do { lvl <- getTcLevel+                        ; updRetInertCans (get_sc_pending lvl) }++get_sc_pending :: TcLevel -> InertCans -> ([Ct], InertCans)+get_sc_pending this_lvl ic@(IC { inert_dicts = dicts, inert_insts = insts })+  = assertPpr (all isGivenCt sc_pending) (ppr sc_pending)+       -- When getPendingScDics is called,+       -- there are never any Wanteds in the inert set+    (sc_pending, ic { inert_dicts = dicts', inert_insts = insts' })+  where+    sc_pending = sc_pend_insts ++ sc_pend_dicts++    sc_pend_dicts = foldDicts get_pending dicts []+    dicts' = foldr add dicts sc_pend_dicts++    (sc_pend_insts, insts') = mapAccumL get_pending_inst [] insts++    get_pending :: Ct -> [Ct] -> [Ct]  -- Get dicts with cc_pend_sc = True+                                       -- but flipping the flag+    get_pending dict dicts+        | Just dict' <- isPendingScDict dict+        , belongs_to_this_level (ctEvidence dict)+        = dict' : dicts+        | otherwise+        = dicts++    add :: Ct -> DictMap Ct -> DictMap Ct+    add ct@(CDictCan { cc_class = cls, cc_tyargs = tys }) dicts+        = addDict dicts cls tys ct+    add ct _ = pprPanic "getPendingScDicts" (ppr ct)++    get_pending_inst :: [Ct] -> QCInst -> ([Ct], QCInst)+    get_pending_inst cts qci@(QCI { qci_ev = ev })+       | Just qci' <- isPendingScInst qci+       , belongs_to_this_level ev+       = (CQuantCan qci' : cts, qci')+       | otherwise+       = (cts, qci)++    belongs_to_this_level ev = ctLocLevel (ctEvLoc ev) == this_lvl+    -- We only want Givens from this level; see (3a) in+    -- Note [The superclass story] in GHC.Tc.Solver.Canonical++getUnsolvedInerts :: TcS ( Bag Implication+                         , Cts )   -- All simple constraints+-- Return all the unsolved [Wanted] constraints+--+-- Post-condition: the returned simple constraints are all fully zonked+--                     (because they come from the inert set)+--                 the unsolved implics may not be+getUnsolvedInerts+ = do { IC { inert_eqs     = tv_eqs+           , inert_funeqs  = fun_eqs+           , inert_irreds  = irreds+           , inert_dicts   = idicts+           } <- getInertCans++      ; let unsolved_tv_eqs  = foldTyEqs add_if_unsolved tv_eqs emptyCts+            unsolved_fun_eqs = foldFunEqs add_if_unsolveds fun_eqs emptyCts+            unsolved_irreds  = Bag.filterBag isWantedCt irreds+            unsolved_dicts   = foldDicts add_if_unsolved idicts emptyCts+            unsolved_others  = unionManyBags [ unsolved_irreds+                                             , unsolved_dicts ]++      ; implics <- getWorkListImplics++      ; traceTcS "getUnsolvedInerts" $+        vcat [ text " tv eqs =" <+> ppr unsolved_tv_eqs+             , text "fun eqs =" <+> ppr unsolved_fun_eqs+             , text "others =" <+> ppr unsolved_others+             , text "implics =" <+> ppr implics ]++      ; return ( implics, unsolved_tv_eqs `unionBags`+                          unsolved_fun_eqs `unionBags`+                          unsolved_others) }+  where+    add_if_unsolved :: Ct -> Cts -> Cts+    add_if_unsolved ct cts | isWantedCt ct = ct `consCts` cts+                           | otherwise     = cts++    add_if_unsolveds :: EqualCtList -> Cts -> Cts+    add_if_unsolveds new_cts old_cts = foldr add_if_unsolved old_cts new_cts++getHasGivenEqs :: TcLevel           -- TcLevel of this implication+               -> TcS ( HasGivenEqs -- are there Given equalities?+                      , Cts )       -- Insoluble equalities arising from givens+-- See Note [Tracking Given equalities] in GHC.Tc.Solver.InertSet+getHasGivenEqs tclvl+  = do { inerts@(IC { inert_irreds       = irreds+                    , inert_given_eqs    = given_eqs+                    , inert_given_eq_lvl = ge_lvl })+              <- getInertCans+       ; let given_insols = filterBag insoluble_given_equality irreds+                      -- Specifically includes ones that originated in some+                      -- outer context but were refined to an insoluble by+                      -- a local equality; so no level-check needed++             -- See Note [HasGivenEqs] in GHC.Tc.Types.Constraint, and+             -- Note [Tracking Given equalities] in GHC.Tc.Solver.InertSet+             has_ge | ge_lvl == tclvl = MaybeGivenEqs+                    | given_eqs       = LocalGivenEqs+                    | otherwise       = NoGivenEqs++       ; traceTcS "getHasGivenEqs" $+         vcat [ text "given_eqs:" <+> ppr given_eqs+              , text "ge_lvl:" <+> ppr ge_lvl+              , text "ambient level:" <+> ppr tclvl+              , text "Inerts:" <+> ppr inerts+              , text "Insols:" <+> ppr given_insols]+       ; return (has_ge, given_insols) }+  where+    insoluble_given_equality ct+       = insolubleEqCt ct && isGivenCt ct++removeInertCts :: [Ct] -> InertCans -> InertCans+-- ^ Remove inert constraints from the 'InertCans', for use when a+-- typechecker plugin wishes to discard a given.+removeInertCts cts icans = foldl' removeInertCt icans cts++removeInertCt :: InertCans -> Ct -> InertCans+removeInertCt is ct =+  case ct of++    CDictCan  { cc_class = cl, cc_tyargs = tys } ->+      is { inert_dicts = delDict (inert_dicts is) cl tys }++    CEqCan    { cc_lhs  = lhs, cc_rhs = rhs } -> delEq is lhs rhs++    CIrredCan {}     -> is { inert_irreds = filterBag (not . eqCt ct) $ inert_irreds is }++    CQuantCan {}     -> panic "removeInertCt: CQuantCan"+    CNonCanonical {} -> panic "removeInertCt: CNonCanonical"++eqCt :: Ct -> Ct -> Bool+-- Equality via ctEvId+eqCt c c' = ctEvId c == ctEvId c'++-- | Looks up a family application in the inerts.+lookupFamAppInert :: (CtFlavourRole -> Bool)  -- can it rewrite the target?+                  -> TyCon -> [Type] -> TcS (Maybe (Reduction, CtFlavourRole))+lookupFamAppInert rewrite_pred fam_tc tys+  = do { IS { inert_cans = IC { inert_funeqs = inert_funeqs } } <- getTcSInerts+       ; return (lookup_inerts inert_funeqs) }+  where+    lookup_inerts inert_funeqs+      | Just ecl <- findFunEq inert_funeqs fam_tc tys+      , Just (CEqCan { cc_ev = ctev, cc_rhs = rhs })+          <- find (rewrite_pred . ctFlavourRole) ecl+      = Just (mkReduction (ctEvCoercion ctev) rhs, ctEvFlavourRole ctev)+      | otherwise = Nothing++lookupInInerts :: CtLoc -> TcPredType -> TcS (Maybe CtEvidence)+-- Is this exact predicate type cached in the solved or canonicals of the InertSet?+lookupInInerts loc pty+  | ClassPred cls tys <- classifyPredType pty+  = do { inerts <- getTcSInerts+       ; return (lookupSolvedDict inerts loc cls tys `mplus`+                 fmap ctEvidence (lookupInertDict (inert_cans inerts) loc cls tys)) }+  | otherwise -- NB: No caching for equalities, IPs, holes, or errors+  = return Nothing++-- | Look up a dictionary inert.+lookupInertDict :: InertCans -> CtLoc -> Class -> [Type] -> Maybe Ct+lookupInertDict (IC { inert_dicts = dicts }) loc cls tys+  = case findDict dicts loc cls tys of+      Just ct -> Just ct+      _       -> Nothing++-- | Look up a solved inert.+lookupSolvedDict :: InertSet -> CtLoc -> Class -> [Type] -> Maybe CtEvidence+-- Returns just if exactly this predicate type exists in the solved.+lookupSolvedDict (IS { inert_solved_dicts = solved }) loc cls tys+  = case findDict solved loc cls tys of+      Just ev -> Just ev+      _       -> Nothing++---------------------------+lookupFamAppCache :: TyCon -> [Type] -> TcS (Maybe Reduction)+lookupFamAppCache fam_tc tys+  = do { IS { inert_famapp_cache = famapp_cache } <- getTcSInerts+       ; case findFunEq famapp_cache fam_tc tys of+           result@(Just redn) ->+             do { traceTcS "famapp_cache hit" (vcat [ ppr (mkTyConApp fam_tc tys)+                                                    , ppr redn ])+                ; return result }+           Nothing -> return Nothing }++extendFamAppCache :: TyCon -> [Type] -> Reduction -> TcS ()+-- NB: co :: rhs ~ F tys, to match expectations of rewriter+extendFamAppCache tc xi_args stuff@(Reduction _ ty)+  = do { dflags <- getDynFlags+       ; when (gopt Opt_FamAppCache dflags) $+    do { traceTcS "extendFamAppCache" (vcat [ ppr tc <+> ppr xi_args+                                            , ppr ty ])+       ; updInertTcS $ \ is@(IS { inert_famapp_cache = fc }) ->+            is { inert_famapp_cache = insertFunEq fc tc xi_args stuff } } }++-- Remove entries from the cache whose evidence mentions variables in the+-- supplied set+dropFromFamAppCache :: VarSet -> TcS ()+dropFromFamAppCache varset+  = do { inerts@(IS { inert_famapp_cache = famapp_cache }) <- getTcSInerts+       ; let filtered = filterTcAppMap check famapp_cache+       ; setTcSInerts $ inerts { inert_famapp_cache = filtered } }+  where+    check :: Reduction -> Bool+    check redn+      = not (anyFreeVarsOfCo (`elemVarSet` varset) $ reductionCoercion redn)++{- *********************************************************************+*                                                                      *+                   Irreds+*                                                                      *+********************************************************************* -}++foldIrreds :: (Ct -> b -> b) -> Cts -> b -> b+foldIrreds k irreds z = foldr k z irreds++{-+************************************************************************+*                                                                      *+*              The TcS solver monad                                    *+*                                                                      *+************************************************************************++Note [The TcS monad]+~~~~~~~~~~~~~~~~~~~~+The TcS monad is a weak form of the main Tc monad++All you can do is+    * fail+    * allocate new variables+    * fill in evidence variables++Filling in a dictionary evidence variable means to create a binding+for it, so TcS carries a mutable location where the binding can be+added.  This is initialised from the innermost implication constraint.+-}++data TcSEnv+  = TcSEnv {+      tcs_ev_binds    :: EvBindsVar,++      tcs_unified     :: IORef Int,+         -- The number of unification variables we have filled+         -- The important thing is whether it is non-zero++      tcs_unif_lvl  :: IORef (Maybe TcLevel),+         -- The Unification Level Flag+         -- Outermost level at which we have unified a meta tyvar+         -- Starts at Nothing, then (Just i), then (Just j) where j<i+         -- See Note [The Unification Level Flag]++      tcs_count     :: IORef Int, -- Global step count++      tcs_inerts    :: IORef InertSet, -- Current inert set++      -- Whether to throw an exception if we come across an insoluble constraint.+      -- Used to fail-fast when checking for hole-fits. See Note [Speeding up+      -- valid hole-fits].+      tcs_abort_on_insoluble :: Bool,++      -- See Note [WorkList priorities] in GHC.Tc.Solver.InertSet+      tcs_worklist  :: IORef WorkList -- Current worklist+    }++---------------+newtype TcS a = TcS { unTcS :: TcSEnv -> TcM a } deriving (Functor)++-- | Smart constructor for 'TcS', as describe in Note [The one-shot state+-- monad trick] in "GHC.Utils.Monad".+mkTcS :: (TcSEnv -> TcM a) -> TcS a+mkTcS f = TcS (oneShot f)++instance Applicative TcS where+  pure x = mkTcS $ \_ -> return x+  (<*>) = ap++instance Monad TcS where+  m >>= k   = mkTcS $ \ebs -> do+    unTcS m ebs >>= (\r -> unTcS (k r) ebs)++instance MonadIO TcS where+  liftIO act = TcS $ \_env -> liftIO act++instance MonadFail TcS where+  fail err  = mkTcS $ \_ -> fail err++instance MonadUnique TcS where+   getUniqueSupplyM = wrapTcS getUniqueSupplyM++instance HasModule TcS where+   getModule = wrapTcS getModule++instance MonadThings TcS where+   lookupThing n = wrapTcS (lookupThing n)++-- Basic functionality+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+wrapTcS :: TcM a -> TcS a+-- Do not export wrapTcS, because it promotes an arbitrary TcM to TcS,+-- and TcS is supposed to have limited functionality+wrapTcS action = mkTcS $ \_env -> action -- a TcM action will not use the TcEvBinds++wrap2TcS :: (TcM a -> TcM a) -> TcS a -> TcS a+wrap2TcS fn (TcS thing) = mkTcS $ \env -> fn (thing env)++wrapErrTcS :: TcM a -> TcS a+-- The thing wrapped should just fail+-- There's no static check; it's up to the user+-- Having a variant for each error message is too painful+wrapErrTcS = wrapTcS++wrapWarnTcS :: TcM a -> TcS a+-- The thing wrapped should just add a warning, or no-op+-- There's no static check; it's up to the user+wrapWarnTcS = wrapTcS++panicTcS  :: SDoc -> TcS a+failTcS   :: TcRnMessage -> TcS a+warnTcS, addErrTcS :: TcRnMessage -> TcS ()+failTcS      = wrapTcS . TcM.failWith+warnTcS msg  = wrapTcS (TcM.addDiagnostic msg)+addErrTcS    = wrapTcS . TcM.addErr+panicTcS doc = pprPanic "GHC.Tc.Solver.Canonical" doc++traceTcS :: String -> SDoc -> TcS ()+traceTcS herald doc = wrapTcS (TcM.traceTc herald doc)+{-# INLINE traceTcS #-}  -- see Note [INLINE conditional tracing utilities]++runTcPluginTcS :: TcPluginM a -> TcS a+runTcPluginTcS = wrapTcS . runTcPluginM++instance HasDynFlags TcS where+    getDynFlags = wrapTcS getDynFlags++getGlobalRdrEnvTcS :: TcS GlobalRdrEnv+getGlobalRdrEnvTcS = wrapTcS TcM.getGlobalRdrEnv++bumpStepCountTcS :: TcS ()+bumpStepCountTcS = mkTcS $ \env ->+  do { let ref = tcs_count env+     ; n <- TcM.readTcRef ref+     ; TcM.writeTcRef ref (n+1) }++csTraceTcS :: SDoc -> TcS ()+csTraceTcS doc+  = wrapTcS $ csTraceTcM (return doc)+{-# INLINE csTraceTcS #-}  -- see Note [INLINE conditional tracing utilities]++traceFireTcS :: CtEvidence -> SDoc -> TcS ()+-- Dump a rule-firing trace+traceFireTcS ev doc+  = mkTcS $ \env -> csTraceTcM $+    do { n <- TcM.readTcRef (tcs_count env)+       ; tclvl <- TcM.getTcLevel+       ; return (hang (text "Step" <+> int n+                       <> brackets (text "l:" <> ppr tclvl <> comma <>+                                    text "d:" <> ppr (ctLocDepth (ctEvLoc ev)))+                       <+> doc <> colon)+                     4 (ppr ev)) }+{-# INLINE traceFireTcS #-}  -- see Note [INLINE conditional tracing utilities]++csTraceTcM :: TcM SDoc -> TcM ()+-- Constraint-solver tracing, -ddump-cs-trace+csTraceTcM mk_doc+  = do { logger <- getLogger+       ; when (  logHasDumpFlag logger Opt_D_dump_cs_trace+                  || logHasDumpFlag logger Opt_D_dump_tc_trace)+              ( do { msg <- mk_doc+                   ; TcM.dumpTcRn False+                       Opt_D_dump_cs_trace+                       "" FormatText+                       msg }) }+{-# INLINE csTraceTcM #-}  -- see Note [INLINE conditional tracing utilities]++runTcS :: TcS a                -- What to run+       -> TcM (a, EvBindMap)+runTcS tcs+  = do { ev_binds_var <- TcM.newTcEvBinds+       ; res <- runTcSWithEvBinds ev_binds_var tcs+       ; ev_binds <- TcM.getTcEvBindsMap ev_binds_var+       ; return (res, ev_binds) }++-- | This variant of 'runTcS' will immediatley fail upon encountering an+-- insoluble ct. See Note [Speeding up valid hole-fits]. Its one usage+-- site does not need the ev_binds, so we do not return them.+runTcSEarlyAbort :: TcS a -> TcM a+runTcSEarlyAbort tcs+  = do { ev_binds_var <- TcM.newTcEvBinds+       ; runTcSWithEvBinds' True True ev_binds_var tcs }++-- | This can deal only with equality constraints.+runTcSEqualities :: TcS a -> TcM a+runTcSEqualities thing_inside+  = do { ev_binds_var <- TcM.newNoTcEvBinds+       ; runTcSWithEvBinds ev_binds_var thing_inside }++-- | A variant of 'runTcS' that takes and returns an 'InertSet' for+-- later resumption of the 'TcS' session.+runTcSInerts :: InertSet -> TcS a -> TcM (a, InertSet)+runTcSInerts inerts tcs = do+  ev_binds_var <- TcM.newTcEvBinds+  runTcSWithEvBinds' False False ev_binds_var $ do+    setTcSInerts inerts+    a <- tcs+    new_inerts <- getTcSInerts+    return (a, new_inerts)++runTcSWithEvBinds :: EvBindsVar+                  -> TcS a+                  -> TcM a+runTcSWithEvBinds = runTcSWithEvBinds' True False++runTcSWithEvBinds' :: Bool -- ^ Restore type variable cycles afterwards?+                           -- Don't if you want to reuse the InertSet.+                           -- See also Note [Type equality cycles]+                           -- in GHC.Tc.Solver.Canonical+                   -> Bool+                   -> EvBindsVar+                   -> TcS a+                   -> TcM a+runTcSWithEvBinds' restore_cycles abort_on_insoluble ev_binds_var tcs+  = do { unified_var <- TcM.newTcRef 0+       ; step_count <- TcM.newTcRef 0+       ; inert_var <- TcM.newTcRef emptyInert+       ; wl_var <- TcM.newTcRef emptyWorkList+       ; unif_lvl_var <- TcM.newTcRef Nothing+       ; let env = TcSEnv { tcs_ev_binds           = ev_binds_var+                          , tcs_unified            = unified_var+                          , tcs_unif_lvl           = unif_lvl_var+                          , tcs_count              = step_count+                          , tcs_inerts             = inert_var+                          , tcs_abort_on_insoluble = abort_on_insoluble+                          , tcs_worklist           = wl_var }++             -- Run the computation+       ; res <- unTcS tcs env++       ; count <- TcM.readTcRef step_count+       ; when (count > 0) $+         csTraceTcM $ return (text "Constraint solver steps =" <+> int count)++       ; when restore_cycles $+         do { inert_set <- TcM.readTcRef inert_var+            ; restoreTyVarCycles inert_set }++#if defined(DEBUG)+       ; ev_binds <- TcM.getTcEvBindsMap ev_binds_var+       ; checkForCyclicBinds ev_binds+#endif++       ; return res }++----------------------------+#if defined(DEBUG)+checkForCyclicBinds :: EvBindMap -> TcM ()+checkForCyclicBinds ev_binds_map+  | null cycles+  = return ()+  | null coercion_cycles+  = TcM.traceTc "Cycle in evidence binds" $ ppr cycles+  | otherwise+  = pprPanic "Cycle in coercion bindings" $ ppr coercion_cycles+  where+    ev_binds = evBindMapBinds ev_binds_map++    cycles :: [[EvBind]]+    cycles = [c | CyclicSCC c <- stronglyConnCompFromEdgedVerticesUniq edges]++    coercion_cycles = [c | c <- cycles, any is_co_bind c]+    is_co_bind (EvBind { eb_lhs = b }) = isEqPrimPred (varType b)++    edges :: [ Node EvVar EvBind ]+    edges = [ DigraphNode bind bndr (nonDetEltsUniqSet (evVarsOfTerm rhs))+            | bind@(EvBind { eb_lhs = bndr, eb_rhs = rhs}) <- bagToList ev_binds ]+            -- It's OK to use nonDetEltsUFM here as+            -- stronglyConnCompFromEdgedVertices is still deterministic even+            -- if the edges are in nondeterministic order as explained in+            -- Note [Deterministic SCC] in GHC.Data.Graph.Directed.+#endif++----------------------------+setEvBindsTcS :: EvBindsVar -> TcS a -> TcS a+setEvBindsTcS ref (TcS thing_inside)+ = TcS $ \ env -> thing_inside (env { tcs_ev_binds = ref })++nestImplicTcS :: EvBindsVar+              -> TcLevel -> TcS a+              -> TcS a+nestImplicTcS ref inner_tclvl (TcS thing_inside)+  = TcS $ \ TcSEnv { tcs_unified            = unified_var+                   , tcs_inerts             = old_inert_var+                   , tcs_count              = count+                   , tcs_unif_lvl           = unif_lvl+                   , tcs_abort_on_insoluble = abort_on_insoluble+                   } ->+    do { inerts <- TcM.readTcRef old_inert_var+       ; let nest_inert = inerts { inert_cycle_breakers = pushCycleBreakerVarStack+                                                            (inert_cycle_breakers inerts)+                                 , inert_cans = (inert_cans inerts)+                                                   { inert_given_eqs = False } }+                 -- All other InertSet fields are inherited+       ; new_inert_var <- TcM.newTcRef nest_inert+       ; new_wl_var    <- TcM.newTcRef emptyWorkList+       ; let nest_env = TcSEnv { tcs_count              = count     -- Inherited+                               , tcs_unif_lvl           = unif_lvl  -- Inherited+                               , tcs_ev_binds           = ref+                               , tcs_unified            = unified_var+                               , tcs_inerts             = new_inert_var+                               , tcs_abort_on_insoluble = abort_on_insoluble+                               , tcs_worklist           = new_wl_var }+       ; res <- TcM.setTcLevel inner_tclvl $+                thing_inside nest_env++       ; out_inert_set <- TcM.readTcRef new_inert_var+       ; restoreTyVarCycles out_inert_set++#if defined(DEBUG)+       -- Perform a check that the thing_inside did not cause cycles+       ; ev_binds <- TcM.getTcEvBindsMap ref+       ; checkForCyclicBinds ev_binds+#endif+       ; return res }++nestTcS ::  TcS a -> TcS a+-- Use the current untouchables, augmenting the current+-- evidence bindings, and solved dictionaries+-- But have no effect on the InertCans, or on the inert_famapp_cache+-- (we want to inherit the latter from processing the Givens)+nestTcS (TcS thing_inside)+  = TcS $ \ env@(TcSEnv { tcs_inerts = inerts_var }) ->+    do { inerts <- TcM.readTcRef inerts_var+       ; new_inert_var <- TcM.newTcRef inerts+       ; new_wl_var    <- TcM.newTcRef emptyWorkList+       ; let nest_env = env { tcs_inerts   = new_inert_var+                            , tcs_worklist = new_wl_var }++       ; res <- thing_inside nest_env++       ; new_inerts <- TcM.readTcRef new_inert_var++       -- we want to propagate the safe haskell failures+       ; let old_ic = inert_cans inerts+             new_ic = inert_cans new_inerts+             nxt_ic = old_ic { inert_safehask = inert_safehask new_ic }++       ; TcM.writeTcRef inerts_var  -- See Note [Propagate the solved dictionaries]+                        (inerts { inert_solved_dicts = inert_solved_dicts new_inerts+                                , inert_cans = nxt_ic })++       ; return res }++emitImplicationTcS :: TcLevel -> SkolemInfoAnon+                   -> [TcTyVar]        -- Skolems+                   -> [EvVar]          -- Givens+                   -> Cts              -- Wanteds+                   -> TcS TcEvBinds+-- Add an implication to the TcS monad work-list+emitImplicationTcS new_tclvl skol_info skol_tvs givens wanteds+  = do { let wc = emptyWC { wc_simple = wanteds }+       ; imp <- wrapTcS $+                do { ev_binds_var <- TcM.newTcEvBinds+                   ; imp <- TcM.newImplication+                   ; return (imp { ic_tclvl  = new_tclvl+                                 , ic_skols  = skol_tvs+                                 , ic_given  = givens+                                 , ic_wanted = wc+                                 , ic_binds  = ev_binds_var+                                 , ic_info   = skol_info }) }++       ; emitImplication imp+       ; return (TcEvBinds (ic_binds imp)) }++emitTvImplicationTcS :: TcLevel -> SkolemInfoAnon+                     -> [TcTyVar]        -- Skolems+                     -> Cts              -- Wanteds+                     -> TcS ()+-- Just like emitImplicationTcS but no givens and no bindings+emitTvImplicationTcS new_tclvl skol_info skol_tvs wanteds+  = do { let wc = emptyWC { wc_simple = wanteds }+       ; imp <- wrapTcS $+                do { ev_binds_var <- TcM.newNoTcEvBinds+                   ; imp <- TcM.newImplication+                   ; return (imp { ic_tclvl  = new_tclvl+                                 , ic_skols  = skol_tvs+                                 , ic_wanted = wc+                                 , ic_binds  = ev_binds_var+                                 , ic_info   = skol_info }) }++       ; emitImplication imp }+++{- Note [Propagate the solved dictionaries]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's really quite important that nestTcS does not discard the solved+dictionaries from the thing_inside.+Consider+   Eq [a]+   forall b. empty =>  Eq [a]+We solve the simple (Eq [a]), under nestTcS, and then turn our attention to+the implications.  It's definitely fine to use the solved dictionaries on+the inner implications, and it can make a significant performance difference+if you do so.+-}++-- Getters and setters of GHC.Tc.Utils.Env fields+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++-- Getter of inerts and worklist+getTcSInertsRef :: TcS (IORef InertSet)+getTcSInertsRef = TcS (return . tcs_inerts)++getTcSWorkListRef :: TcS (IORef WorkList)+getTcSWorkListRef = TcS (return . tcs_worklist)++getTcSInerts :: TcS InertSet+getTcSInerts = getTcSInertsRef >>= readTcRef++setTcSInerts :: InertSet -> TcS ()+setTcSInerts ics = do { r <- getTcSInertsRef; writeTcRef r ics }++getWorkListImplics :: TcS (Bag Implication)+getWorkListImplics+  = do { wl_var <- getTcSWorkListRef+       ; wl_curr <- readTcRef wl_var+       ; return (wl_implics wl_curr) }++pushLevelNoWorkList :: SDoc -> TcS a -> TcS (TcLevel, a)+-- Push the level and run thing_inside+-- However, thing_inside should not generate any work items+#if defined(DEBUG)+pushLevelNoWorkList err_doc (TcS thing_inside)+  = TcS (\env -> TcM.pushTcLevelM $+                 thing_inside (env { tcs_worklist = wl_panic })+        )+  where+    wl_panic  = pprPanic "GHC.Tc.Solver.Monad.buildImplication" err_doc+                         -- This panic checks that the thing-inside+                         -- does not emit any work-list constraints+#else+pushLevelNoWorkList _ (TcS thing_inside)+  = TcS (\env -> TcM.pushTcLevelM (thing_inside env))  -- Don't check+#endif++updWorkListTcS :: (WorkList -> WorkList) -> TcS ()+updWorkListTcS f+  = do { wl_var <- getTcSWorkListRef+       ; updTcRef wl_var f }++emitWorkNC :: [CtEvidence] -> TcS ()+emitWorkNC evs+  | null evs+  = return ()+  | otherwise+  = emitWork (map mkNonCanonical evs)++emitWork :: [Ct] -> TcS ()+emitWork [] = return ()   -- avoid printing, among other work+emitWork cts+  = do { traceTcS "Emitting fresh work" (vcat (map ppr cts))+       ; updWorkListTcS (extendWorkListCts cts) }++emitImplication :: Implication -> TcS ()+emitImplication implic+  = updWorkListTcS (extendWorkListImplic implic)++newTcRef :: a -> TcS (TcRef a)+newTcRef x = wrapTcS (TcM.newTcRef x)++readTcRef :: TcRef a -> TcS a+readTcRef ref = wrapTcS (TcM.readTcRef ref)++writeTcRef :: TcRef a -> a -> TcS ()+writeTcRef ref val = wrapTcS (TcM.writeTcRef ref val)++updTcRef :: TcRef a -> (a->a) -> TcS ()+updTcRef ref upd_fn = wrapTcS (TcM.updTcRef ref upd_fn)++getTcEvBindsVar :: TcS EvBindsVar+getTcEvBindsVar = TcS (return . tcs_ev_binds)++getTcLevel :: TcS TcLevel+getTcLevel = wrapTcS TcM.getTcLevel++getTcEvTyCoVars :: EvBindsVar -> TcS TyCoVarSet+getTcEvTyCoVars ev_binds_var+  = wrapTcS $ TcM.getTcEvTyCoVars ev_binds_var++getTcEvBindsMap :: EvBindsVar -> TcS EvBindMap+getTcEvBindsMap ev_binds_var+  = wrapTcS $ TcM.getTcEvBindsMap ev_binds_var++setTcEvBindsMap :: EvBindsVar -> EvBindMap -> TcS ()+setTcEvBindsMap ev_binds_var binds+  = wrapTcS $ TcM.setTcEvBindsMap ev_binds_var binds++unifyTyVar :: TcTyVar -> TcType -> TcS ()+-- Unify a meta-tyvar with a type+-- We keep track of how many unifications have happened in tcs_unified,+--+-- We should never unify the same variable twice!+unifyTyVar tv ty+  = assertPpr (isMetaTyVar tv) (ppr tv) $+    TcS $ \ env ->+    do { TcM.traceTc "unifyTyVar" (ppr tv <+> text ":=" <+> ppr ty)+       ; TcM.writeMetaTyVar tv ty+       ; TcM.updTcRef (tcs_unified env) (+1) }++reportUnifications :: TcS a -> TcS (Int, a)+reportUnifications (TcS thing_inside)+  = TcS $ \ env ->+    do { inner_unified <- TcM.newTcRef 0+       ; res <- thing_inside (env { tcs_unified = inner_unified })+       ; n_unifs <- TcM.readTcRef inner_unified+       ; TcM.updTcRef (tcs_unified env) (+ n_unifs)+       ; return (n_unifs, res) }++data TouchabilityTestResult+  -- See Note [Solve by unification] in GHC.Tc.Solver.Interact+  -- which points out that having TouchableSameLevel is just an optimisation;+  -- we could manage with TouchableOuterLevel alone (suitably renamed)+  = TouchableSameLevel+  | TouchableOuterLevel [TcTyVar]   -- Promote these+                        TcLevel     -- ..to this level+  | Untouchable++instance Outputable TouchabilityTestResult where+  ppr TouchableSameLevel            = text "TouchableSameLevel"+  ppr (TouchableOuterLevel tvs lvl) = text "TouchableOuterLevel" <> parens (ppr lvl <+> ppr tvs)+  ppr Untouchable                   = text "Untouchable"++touchabilityTest :: CtFlavour -> TcTyVar -> TcType -> TcS TouchabilityTestResult+-- This is the key test for untouchability:+-- See Note [Unification preconditions] in GHC.Tc.Utils.Unify+-- and Note [Solve by unification] in GHC.Tc.Solver.Interact+touchabilityTest flav tv1 rhs+  | flav /= Given  -- See Note [Do not unify Givens]+  , MetaTv { mtv_tclvl = tv_lvl, mtv_info = info } <- tcTyVarDetails tv1+  = do { can_continue_solving <- wrapTcS $ startSolvingByUnification info rhs+       ; if not can_continue_solving+         then return Untouchable+         else+    do { ambient_lvl  <- getTcLevel+       ; given_eq_lvl <- getInnermostGivenEqLevel++       ; if | tv_lvl `sameDepthAs` ambient_lvl+            -> return TouchableSameLevel++            | tv_lvl `deeperThanOrSame` given_eq_lvl   -- No intervening given equalities+            , all (does_not_escape tv_lvl) free_skols  -- No skolem escapes+            -> return (TouchableOuterLevel free_metas tv_lvl)++            | otherwise+            -> return Untouchable } }+  | otherwise+  = return Untouchable+  where+     (free_metas, free_skols) = partition isPromotableMetaTyVar $+                                nonDetEltsUniqSet               $+                                tyCoVarsOfType rhs++     does_not_escape tv_lvl fv+       | isTyVar fv = tv_lvl `deeperThanOrSame` tcTyVarLevel fv+       | otherwise  = True+       -- Coercion variables are not an escape risk+       -- If an implication binds a coercion variable, it'll have equalities,+       -- so the "intervening given equalities" test above will catch it+       -- Coercion holes get filled with coercions, so again no problem.++{- Note [Do not unify Givens]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this GADT match+   data T a where+      T1 :: T Int+      ...++   f x = case x of+           T1 -> True+           ...++So we get f :: T alpha[1] -> beta[1]+          x :: T alpha[1]+and from the T1 branch we get the implication+   forall[2] (alpha[1] ~ Int) => beta[1] ~ Bool++Now, clearly we don't want to unify alpha:=Int!  Yet at the moment we+process [G] alpha[1] ~ Int, we don't have any given-equalities in the+inert set, and hence there are no given equalities to make alpha untouchable.++NB: if it were alpha[2] ~ Int, this argument wouldn't hold.  But that+never happens: invariant (GivenInv) in Note [TcLevel invariants]+in GHC.Tc.Utils.TcType.++Simple solution: never unify in Givens!+-}++getDefaultInfo ::  TcS ([Type], (Bool, Bool))+getDefaultInfo = wrapTcS TcM.tcGetDefaultTys++getWorkList :: TcS WorkList+getWorkList = do { wl_var <- getTcSWorkListRef+                 ; wrapTcS (TcM.readTcRef wl_var) }++selectNextWorkItem :: TcS (Maybe Ct)+-- Pick which work item to do next+-- See Note [Prioritise equalities]+selectNextWorkItem+  = do { wl_var <- getTcSWorkListRef+       ; wl <- readTcRef wl_var+       ; case selectWorkItem wl of {+           Nothing -> return Nothing ;+           Just (ct, new_wl) ->+    do { -- checkReductionDepth (ctLoc ct) (ctPred ct)+         -- This is done by GHC.Tc.Solver.Interact.chooseInstance+       ; writeTcRef wl_var new_wl+       ; return (Just ct) } } }++-- Just get some environments needed for instance looking up and matching+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++getInstEnvs :: TcS InstEnvs+getInstEnvs = wrapTcS $ TcM.tcGetInstEnvs++getFamInstEnvs :: TcS (FamInstEnv, FamInstEnv)+getFamInstEnvs = wrapTcS $ FamInst.tcGetFamInstEnvs++getTopEnv :: TcS HscEnv+getTopEnv = wrapTcS $ TcM.getTopEnv++getGblEnv :: TcS TcGblEnv+getGblEnv = wrapTcS $ TcM.getGblEnv++getLclEnv :: TcS TcLclEnv+getLclEnv = wrapTcS $ TcM.getLclEnv++setLclEnv :: TcLclEnv -> TcS a -> TcS a+setLclEnv env = wrap2TcS (TcM.setLclEnv env)++tcLookupClass :: Name -> TcS Class+tcLookupClass c = wrapTcS $ TcM.tcLookupClass c++tcLookupId :: Name -> TcS Id+tcLookupId n = wrapTcS $ TcM.tcLookupId n++-- Setting names as used (used in the deriving of Coercible evidence)+-- Too hackish to expose it to TcS? In that case somehow extract the used+-- constructors from the result of solveInteract+addUsedGREs :: [GlobalRdrElt] -> TcS ()+addUsedGREs gres = wrapTcS  $ TcM.addUsedGREs gres++addUsedGRE :: Bool -> GlobalRdrElt -> TcS ()+addUsedGRE warn_if_deprec gre = wrapTcS $ TcM.addUsedGRE warn_if_deprec gre++keepAlive :: Name -> TcS ()+keepAlive = wrapTcS . TcM.keepAlive++-- Various smaller utilities [TODO, maybe will be absorbed in the instance matcher]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++checkWellStagedDFun :: CtLoc -> InstanceWhat -> PredType -> TcS ()+-- Check that we do not try to use an instance before it is available.  E.g.+--    instance Eq T where ...+--    f x = $( ... (\(p::T) -> p == p)... )+-- Here we can't use the equality function from the instance in the splice++checkWellStagedDFun loc what pred+  = do+      mbind_lvl <- checkWellStagedInstanceWhat what+      case mbind_lvl of+        Just bind_lvl | bind_lvl > impLevel ->+          wrapTcS $ TcM.setCtLocM loc $ do+              { use_stage <- TcM.getStage+              ; TcM.checkWellStaged pp_thing bind_lvl (thLevel use_stage) }+        _ ->+          return ()+  where+    pp_thing = text "instance for" <+> quotes (ppr pred)++-- | Returns the ThLevel of evidence for the solved constraint (if it has evidence)+-- See Note [Well-staged instance evidence]+checkWellStagedInstanceWhat :: InstanceWhat -> TcS (Maybe ThLevel)+checkWellStagedInstanceWhat what+  | TopLevInstance { iw_dfun_id = dfun_id } <- what+    = return $ Just (TcM.topIdLvl dfun_id)+  | BuiltinTypeableInstance tc <- what+    = do+        cur_mod <- extractModule <$> getGblEnv+        return $ Just (if nameIsLocalOrFrom cur_mod (tyConName tc)+                        then outerLevel+                        else impLevel)+  | otherwise = return Nothing++{-+Note [Well-staged instance evidence]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Evidence for instances must obey the same level restrictions as normal bindings.+In particular, it is forbidden to use an instance in a top-level splice in the+module which the instance is defined. This is because the evidence is bound at+the top-level and top-level definitions are forbidden from being using in top-level splices in+the same module.++For example, suppose you have a function..  foo :: Show a => Code Q a -> Code Q ()+then the following program is disallowed,++```+data T a = T a deriving (Show)++main :: IO ()+main =+  let x = $$(foo [|| T () ||])+  in return ()+```++because the `foo` function (used in a top-level splice) requires `Show T` evidence,+which is defined at the top-level and therefore fails with an error that we have violated+the stage restriction.++```+Main.hs:12:14: error:+    • GHC stage restriction:+        instance for ‘Show+                        (T ())’ is used in a top-level splice, quasi-quote, or annotation,+        and must be imported, not defined locally+    • In the expression: foo [|| T () ||]+      In the Template Haskell splice $$(foo [|| T () ||])+      In the expression: $$(foo [|| T () ||])+   |+12 |   let x = $$(foo [|| T () ||])+   |+```++Solving a `Typeable (T t1 ...tn)` constraint generates code that relies on+`$tcT`, the `TypeRep` for `T`; and we must check that this reference to `$tcT`+is well staged.  It's easy to know the stage of `$tcT`: for imported TyCons it+will be `impLevel`, and for local TyCons it will be `toplevel`.++Therefore the `InstanceWhat` type had to be extended with+a special case for `Typeable`, which recorded the TyCon the evidence was for and+could them be used to check that we were not attempting to evidence in a stage incorrect+manner.++-}++pprEq :: TcType -> TcType -> SDoc+pprEq ty1 ty2 = pprParendType ty1 <+> char '~' <+> pprParendType ty2++isFilledMetaTyVar_maybe :: TcTyVar -> TcS (Maybe Type)+isFilledMetaTyVar_maybe tv = wrapTcS (TcM.isFilledMetaTyVar_maybe tv)++isFilledMetaTyVar :: TcTyVar -> TcS Bool+isFilledMetaTyVar tv = wrapTcS (TcM.isFilledMetaTyVar tv)++zonkTyCoVarsAndFV :: TcTyCoVarSet -> TcS TcTyCoVarSet+zonkTyCoVarsAndFV tvs = wrapTcS (TcM.zonkTyCoVarsAndFV tvs)++zonkTyCoVarsAndFVList :: [TcTyCoVar] -> TcS [TcTyCoVar]+zonkTyCoVarsAndFVList tvs = wrapTcS (TcM.zonkTyCoVarsAndFVList tvs)++zonkCo :: Coercion -> TcS Coercion+zonkCo = wrapTcS . TcM.zonkCo++zonkTcType :: TcType -> TcS TcType+zonkTcType ty = wrapTcS (TcM.zonkTcType ty)++zonkTcTypes :: [TcType] -> TcS [TcType]+zonkTcTypes tys = wrapTcS (TcM.zonkTcTypes tys)++zonkTcTyVar :: TcTyVar -> TcS TcType+zonkTcTyVar tv = wrapTcS (TcM.zonkTcTyVar tv)++zonkSimples :: Cts -> TcS Cts+zonkSimples cts = wrapTcS (TcM.zonkSimples cts)++zonkWC :: WantedConstraints -> TcS WantedConstraints+zonkWC wc = wrapTcS (TcM.zonkWC wc)++zonkTyCoVarKind :: TcTyCoVar -> TcS TcTyCoVar+zonkTyCoVarKind tv = wrapTcS (TcM.zonkTyCoVarKind tv)++----------------------------+pprKicked :: Int -> SDoc+pprKicked 0 = empty+pprKicked n = parens (int n <+> text "kicked out")++{- *********************************************************************+*                                                                      *+*              The Unification Level Flag                              *+*                                                                      *+********************************************************************* -}++{- Note [The Unification Level Flag]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider a deep tree of implication constraints+   forall[1] a.                              -- Outer-implic+      C alpha[1]                               -- Simple+      forall[2] c. ....(C alpha[1])....        -- Implic-1+      forall[2] b. ....(alpha[1] ~ Int)....    -- Implic-2++The (C alpha) is insoluble until we know alpha.  We solve alpha+by unifying alpha:=Int somewhere deep inside Implic-2. But then we+must try to solve the Outer-implic all over again. This time we can+solve (C alpha) both in Outer-implic, and nested inside Implic-1.++When should we iterate solving a level-n implication?+Answer: if any unification of a tyvar at level n takes place+        in the ic_implics of that implication.++* What if a unification takes place at level n-1? Then don't iterate+  level n, because we'll iterate level n-1, and that will in turn iterate+  level n.++* What if a unification takes place at level n, in the ic_simples of+  level n?  No need to track this, because the kick-out mechanism deals+  with it.  (We can't drop kick-out in favour of iteration, because kick-out+  works for skolem-equalities, not just unifications.)++So the monad-global Unification Level Flag, kept in tcs_unif_lvl keeps+track of+  - Whether any unifications at all have taken place (Nothing => no unifications)+  - If so, what is the outermost level that has seen a unification (Just lvl)++The iteration done in the simplify_loop/maybe_simplify_again loop in GHC.Tc.Solver.++It helpful not to iterate unless there is a chance of progress.  #8474 is+an example:++  * There's a deeply-nested chain of implication constraints.+       ?x:alpha => ?y1:beta1 => ... ?yn:betan => [W] ?x:Int++  * From the innermost one we get a [W] alpha[1] ~ Int,+    so we can unify.++  * It's better not to iterate the inner implications, but go all the+    way out to level 1 before iterating -- because iterating level 1+    will iterate the inner levels anyway.++(In the olden days when we "floated" thse Derived constraints, this was+much, much more important -- we got exponential behaviour, as each iteration+produced the same Derived constraint.)+-}+++resetUnificationFlag :: TcS Bool+-- We are at ambient level i+-- If the unification flag = Just i, reset it to Nothing and return True+-- Otherwise leave it unchanged and return False+resetUnificationFlag+  = TcS $ \env ->+    do { let ref = tcs_unif_lvl env+       ; ambient_lvl <- TcM.getTcLevel+       ; mb_lvl <- TcM.readTcRef ref+       ; TcM.traceTc "resetUnificationFlag" $+         vcat [ text "ambient:" <+> ppr ambient_lvl+              , text "unif_lvl:" <+> ppr mb_lvl ]+       ; case mb_lvl of+           Nothing       -> return False+           Just unif_lvl | ambient_lvl `strictlyDeeperThan` unif_lvl+                         -> return False+                         | otherwise+                         -> do { TcM.writeTcRef ref Nothing+                               ; return True } }++setUnificationFlag :: TcLevel -> TcS ()+-- (setUnificationFlag i) sets the unification level to (Just i)+-- unless it already is (Just j) where j <= i+setUnificationFlag lvl+  = TcS $ \env ->+    do { let ref = tcs_unif_lvl env+       ; mb_lvl <- TcM.readTcRef ref+       ; case mb_lvl of+           Just unif_lvl | lvl `deeperThanOrSame` unif_lvl+                         -> return ()+           _ -> TcM.writeTcRef ref (Just lvl) }+++{- *********************************************************************+*                                                                      *+*                Instantiation etc.+*                                                                      *+********************************************************************* -}++-- Instantiations+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++instDFunType :: DFunId -> [DFunInstType] -> TcS ([TcType], TcThetaType)+instDFunType dfun_id inst_tys+  = wrapTcS $ TcM.instDFunType dfun_id inst_tys++newFlexiTcSTy :: Kind -> TcS TcType+newFlexiTcSTy knd = wrapTcS (TcM.newFlexiTyVarTy knd)++cloneMetaTyVar :: TcTyVar -> TcS TcTyVar+cloneMetaTyVar tv = wrapTcS (TcM.cloneMetaTyVar tv)++instFlexi :: [TKVar] -> TcS TCvSubst+instFlexi = instFlexiX emptyTCvSubst++instFlexiX :: TCvSubst -> [TKVar] -> TcS TCvSubst+instFlexiX subst tvs+  = wrapTcS (foldlM instFlexiHelper subst tvs)++instFlexiHelper :: TCvSubst -> TKVar -> TcM TCvSubst+instFlexiHelper subst tv+  = do { uniq <- TcM.newUnique+       ; details <- TcM.newMetaDetails TauTv+       ; let name = setNameUnique (tyVarName tv) uniq+             kind = substTyUnchecked subst (tyVarKind tv)+             ty'  = mkTyVarTy (mkTcTyVar name kind details)+       ; TcM.traceTc "instFlexi" (ppr ty')+       ; return (extendTvSubst subst tv ty') }++matchGlobalInst :: DynFlags+                -> Bool      -- True <=> caller is the short-cut solver+                             -- See Note [Shortcut solving: overlap]+                -> Class -> [Type] -> TcS TcM.ClsInstResult+matchGlobalInst dflags short_cut cls tys+  = wrapTcS (TcM.matchGlobalInst dflags short_cut cls tys)++tcInstSkolTyVarsX :: SkolemInfo -> TCvSubst -> [TyVar] -> TcS (TCvSubst, [TcTyVar])+tcInstSkolTyVarsX skol_info subst tvs = wrapTcS $ TcM.tcInstSkolTyVarsX skol_info subst tvs++-- Creating and setting evidence variables and CtFlavors+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++data MaybeNew = Fresh CtEvidence | Cached EvExpr++isFresh :: MaybeNew -> Bool+isFresh (Fresh {})  = True+isFresh (Cached {}) = False++freshGoals :: [MaybeNew] -> [CtEvidence]+freshGoals mns = [ ctev | Fresh ctev <- mns ]++getEvExpr :: MaybeNew -> EvExpr+getEvExpr (Fresh ctev) = ctEvExpr ctev+getEvExpr (Cached evt) = evt++setEvBind :: EvBind -> TcS ()+setEvBind ev_bind+  = do { evb <- getTcEvBindsVar+       ; wrapTcS $ TcM.addTcEvBind evb ev_bind }++-- | Mark variables as used filling a coercion hole+useVars :: CoVarSet -> TcS ()+useVars co_vars+  = do { ev_binds_var <- getTcEvBindsVar+       ; let ref = ebv_tcvs ev_binds_var+       ; wrapTcS $+         do { tcvs <- TcM.readTcRef ref+            ; let tcvs' = tcvs `unionVarSet` co_vars+            ; TcM.writeTcRef ref tcvs' } }++-- | Equalities only+setWantedEq :: HasDebugCallStack => TcEvDest -> Coercion -> TcS ()+setWantedEq (HoleDest hole) co+  = do { useVars (coVarsOfCo co)+       ; fillCoercionHole hole co }+setWantedEq (EvVarDest ev) _ = pprPanic "setWantedEq: EvVarDest" (ppr ev)++-- | Good for both equalities and non-equalities+setWantedEvTerm :: TcEvDest -> EvTerm -> TcS ()+setWantedEvTerm (HoleDest hole) tm+  | Just co <- evTermCoercion_maybe tm+  = do { useVars (coVarsOfCo co)+       ; fillCoercionHole hole co }+  | otherwise+  = -- See Note [Yukky eq_sel for a HoleDest]+    do { let co_var = coHoleCoVar hole+       ; setEvBind (mkWantedEvBind co_var tm)+       ; fillCoercionHole hole (mkTcCoVarCo co_var) }++setWantedEvTerm (EvVarDest ev_id) tm+  = setEvBind (mkWantedEvBind ev_id tm)++{- Note [Yukky eq_sel for a HoleDest]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+How can it be that a Wanted with HoleDest gets evidence that isn't+just a coercion? i.e. evTermCoercion_maybe returns Nothing.++Consider [G] forall a. blah => a ~ T+         [W] S ~# T++Then doTopReactEqPred carefully looks up the (boxed) constraint (S ~+T) in the quantified constraints, and wraps the (boxed) evidence it+gets back in an eq_sel to extract the unboxed (S ~# T).  We can't put+that term into a coercion, so we add a value binding+    h = eq_sel (...)+and the coercion variable h to fill the coercion hole.+We even re-use the CoHole's Id for this binding!++Yuk!+-}++fillCoercionHole :: CoercionHole -> Coercion -> TcS ()+fillCoercionHole hole co+  = do { wrapTcS $ TcM.fillCoercionHole hole co+       ; kickOutAfterFillingCoercionHole hole }++setEvBindIfWanted :: CtEvidence -> EvTerm -> TcS ()+setEvBindIfWanted ev tm+  = case ev of+      CtWanted { ctev_dest = dest } -> setWantedEvTerm dest tm+      _                             -> return ()++newTcEvBinds :: TcS EvBindsVar+newTcEvBinds = wrapTcS TcM.newTcEvBinds++newNoTcEvBinds :: TcS EvBindsVar+newNoTcEvBinds = wrapTcS TcM.newNoTcEvBinds++newEvVar :: TcPredType -> TcS EvVar+newEvVar pred = wrapTcS (TcM.newEvVar pred)++newGivenEvVar :: CtLoc -> (TcPredType, EvTerm) -> TcS CtEvidence+-- Make a new variable of the given PredType,+-- immediately bind it to the given term+-- and return its CtEvidence+-- See Note [Bind new Givens immediately] in GHC.Tc.Types.Constraint+newGivenEvVar loc (pred, rhs)+  = do { new_ev <- newBoundEvVarId pred rhs+       ; return (CtGiven { ctev_pred = pred, ctev_evar = new_ev, ctev_loc = loc }) }++-- | Make a new 'Id' of the given type, bound (in the monad's EvBinds) to the+-- given term+newBoundEvVarId :: TcPredType -> EvTerm -> TcS EvVar+newBoundEvVarId pred rhs+  = do { new_ev <- newEvVar pred+       ; setEvBind (mkGivenEvBind new_ev rhs)+       ; return new_ev }++newGivenEvVars :: CtLoc -> [(TcPredType, EvTerm)] -> TcS [CtEvidence]+newGivenEvVars loc pts = mapM (newGivenEvVar loc) pts++emitNewWantedEq :: CtLoc -> RewriterSet -> Role -> TcType -> TcType -> TcS Coercion+-- | Emit a new Wanted equality into the work-list+emitNewWantedEq loc rewriters role ty1 ty2+  = do { (ev, co) <- newWantedEq loc rewriters role ty1 ty2+       ; updWorkListTcS (extendWorkListEq (mkNonCanonical ev))+       ; return co }++-- | Create a new Wanted constraint holding a coercion hole+-- for an equality between the two types at the given 'Role'.+newWantedEq :: CtLoc -> RewriterSet -> Role -> TcType -> TcType+            -> TcS (CtEvidence, Coercion)+newWantedEq loc rewriters role ty1 ty2+  = do { hole <- wrapTcS $ TcM.newCoercionHole pty+       ; traceTcS "Emitting new coercion hole" (ppr hole <+> dcolon <+> ppr pty)+       ; return ( CtWanted { ctev_pred      = pty+                           , ctev_dest      = HoleDest hole+                           , ctev_loc       = loc+                           , ctev_rewriters = rewriters }+                , mkHoleCo hole ) }+  where+    pty = mkPrimEqPredRole role ty1 ty2++-- | Create a new Wanted constraint holding an evidence variable.+--+-- Don't use this for equality constraints: use 'newWantedEq' instead.+newWantedEvVarNC :: CtLoc -> RewriterSet+                 -> TcPredType -> TcS CtEvidence+-- Don't look up in the solved/inerts; we know it's not there+newWantedEvVarNC loc rewriters pty+  = do { new_ev <- newEvVar pty+       ; traceTcS "Emitting new wanted" (ppr new_ev <+> dcolon <+> ppr pty $$+                                         pprCtLoc loc)+       ; return (CtWanted { ctev_pred      = pty+                          , ctev_dest      = EvVarDest new_ev+                          , ctev_loc       = loc+                          , ctev_rewriters = rewriters })}++-- | Like 'newWantedEvVarNC', except it might look up in the inert set+-- to see if an inert already exists, and uses that instead of creating+-- a new Wanted constraint.+--+-- Don't use this for equality constraints: this function is only for+-- constraints with 'EvVarDest'.+newWantedEvVar :: CtLoc -> RewriterSet+               -> TcPredType -> TcS MaybeNew+-- For anything except ClassPred, this is the same as newWantedEvVarNC+newWantedEvVar loc rewriters pty+  = assertPpr (not (isEqPrimPred pty))+      (vcat [ text "newWantedEvVar: HoleDestPred"+            , text "pty:" <+> ppr pty ]) $+    do { mb_ct <- lookupInInerts loc pty+       ; case mb_ct of+            Just ctev+              -> do { traceTcS "newWantedEvVar/cache hit" $ ppr ctev+                    ; return $ Cached (ctEvExpr ctev) }+            _ -> do { ctev <- newWantedEvVarNC loc rewriters pty+                    ; return (Fresh ctev) } }++-- | Create a new Wanted constraint, potentially looking up+-- non-equality constraints in the cache instead of creating+-- a new one from scratch.+--+-- Deals with both equality and non-equality constraints.+newWanted :: CtLoc -> RewriterSet -> PredType -> TcS MaybeNew+newWanted loc rewriters pty+  | Just (role, ty1, ty2) <- getEqPredTys_maybe pty+  = Fresh . fst <$> newWantedEq loc rewriters role ty1 ty2+  | otherwise+  = newWantedEvVar loc rewriters pty++-- | Create a new Wanted constraint.+--+-- Deals with both equality and non-equality constraints.+--+-- Does not attempt to re-use non-equality constraints that already+-- exist in the inert set.+newWantedNC :: CtLoc -> RewriterSet -> PredType -> TcS CtEvidence+newWantedNC loc rewriters pty+  | Just (role, ty1, ty2) <- getEqPredTys_maybe pty+  = fst <$> newWantedEq loc rewriters role ty1 ty2+  | otherwise+  = newWantedEvVarNC loc rewriters pty++-- --------- Check done in GHC.Tc.Solver.Interact.selectNewWorkItem???? ---------+-- | Checks if the depth of the given location is too much. Fails if+-- it's too big, with an appropriate error message.+checkReductionDepth :: CtLoc -> TcType   -- ^ type being reduced+                    -> TcS ()+checkReductionDepth loc ty+  = do { dflags <- getDynFlags+       ; when (subGoalDepthExceeded dflags (ctLocDepth loc)) $+         wrapErrTcS $ solverDepthError loc ty }++matchFam :: TyCon -> [Type] -> TcS (Maybe ReductionN)+matchFam tycon args = wrapTcS $ matchFamTcM tycon args++matchFamTcM :: TyCon -> [Type] -> TcM (Maybe ReductionN)+-- Given (F tys) return (ty, co), where co :: F tys ~N ty+matchFamTcM tycon args+  = do { fam_envs <- FamInst.tcGetFamInstEnvs+       ; let match_fam_result+              = reduceTyFamApp_maybe fam_envs Nominal tycon args+       ; TcM.traceTc "matchFamTcM" $+         vcat [ text "Matching:" <+> ppr (mkTyConApp tycon args)+              , ppr_res match_fam_result ]+       ; return match_fam_result }+  where+    ppr_res Nothing = text "Match failed"+    ppr_res (Just (Reduction co ty))+      = hang (text "Match succeeded:")+          2 (vcat [ text "Rewrites to:" <+> ppr ty+                  , text "Coercion:" <+> ppr co ])++solverDepthError :: CtLoc -> TcType -> TcM a+solverDepthError loc ty+  = TcM.setCtLocM loc $+    do { ty <- TcM.zonkTcType ty+       ; env0 <- TcM.tcInitTidyEnv+       ; let tidy_env     = tidyFreeTyCoVars env0 (tyCoVarsOfTypeList ty)+             tidy_ty      = tidyType tidy_env ty+             msg = TcRnUnknownMessage $ mkPlainError noHints $+               vcat [ text "Reduction stack overflow; size =" <+> ppr depth+                      , hang (text "When simplifying the following type:")+                           2 (ppr tidy_ty)+                      , note ]+       ; TcM.failWithTcM (tidy_env, msg) }+  where+    depth = ctLocDepth loc+    note = vcat+      [ text "Use -freduction-depth=0 to disable this check"+      , text "(any upper bound you could choose might fail unpredictably with"+      , text " minor updates to GHC, so disabling the check is recommended if"+      , text " you're sure that type checking should terminate)" ]+++{-+************************************************************************+*                                                                      *+              Breaking type variable cycles+*                                                                      *+************************************************************************+-}++-- | Conditionally replace all type family applications in the RHS with fresh+-- variables, emitting givens that relate the type family application to the+-- variable. See Note [Type equality cycles] in GHC.Tc.Solver.Canonical.+-- This only works under conditions as described in the Note; otherwise, returns+-- Nothing.+breakTyEqCycle_maybe :: CtEvidence+                     -> CheckTyEqResult   -- result of checkTypeEq+                     -> CanEqLHS+                     -> TcType     -- RHS+                     -> TcS (Maybe ReductionN)+                         -- new RHS that doesn't have any type families+breakTyEqCycle_maybe (ctLocOrigin . ctEvLoc -> CycleBreakerOrigin _) _ _ _+  -- see Detail (7) of Note+  = return Nothing++breakTyEqCycle_maybe ev cte_result lhs rhs+  | NomEq <- eq_rel++  , cte_result `cterHasOnlyProblem` cteSolubleOccurs+     -- only do this if the only problem is a soluble occurs-check+     -- See Detail (8) of the Note.++  = do { should_break <- final_check+       ; if should_break then do { redn <- go rhs+                                 ; return (Just redn) }+                         else return Nothing }+  where+    flavour = ctEvFlavour ev+    eq_rel  = ctEvEqRel ev++    final_check = case flavour of+      Given  -> return True+      Wanted    -- Wanteds work only with a touchable tyvar on the left+                -- See "Wanted" section of the Note.+        | TyVarLHS lhs_tv <- lhs ->+          do { result <- touchabilityTest Wanted lhs_tv rhs+             ; return $ case result of+                          Untouchable -> False+                          _           -> True }+        | otherwise -> return False++    -- This could be considerably more efficient. See Detail (5) of Note.+    go :: TcType -> TcS ReductionN+    go ty | Just ty' <- rewriterView ty = go ty'+    go (Rep.TyConApp tc tys)+      | isTypeFamilyTyCon tc  -- worried about whether this type family is not actually+                              -- causing trouble? See Detail (5) of Note.+      = do { let (fun_args, extra_args) = splitAt (tyConArity tc) tys+                 fun_app                = mkTyConApp tc fun_args+                 fun_app_kind           = tcTypeKind fun_app+           ; fun_redn <- emit_work fun_app_kind fun_app+           ; arg_redns <- unzipRedns <$> mapM go extra_args+           ; return $ mkAppRedns fun_redn arg_redns }+              -- Worried that this substitution will change kinds?+              -- See Detail (3) of Note++      | otherwise+      = do { arg_redns <- unzipRedns <$> mapM go tys+           ; return $ mkTyConAppRedn Nominal tc arg_redns }++    go (Rep.AppTy ty1 ty2)+      = mkAppRedn <$> go ty1 <*> go ty2+    go (Rep.FunTy vis w arg res)+      = mkFunRedn Nominal vis <$> go w <*> go arg <*> go res+    go (Rep.CastTy ty cast_co)+      = mkCastRedn1 Nominal ty cast_co <$> go ty+    go ty@(Rep.TyVarTy {})    = skip ty+    go ty@(Rep.LitTy {})      = skip ty+    go ty@(Rep.ForAllTy {})   = skip ty  -- See Detail (1) of Note+    go ty@(Rep.CoercionTy {}) = skip ty  -- See Detail (2) of Note++    skip ty = return $ mkReflRedn Nominal ty++    emit_work :: TcKind         -- of the function application+              -> TcType         -- original function application+              -> TcS ReductionN -- rewritten type (the fresh tyvar)+    emit_work fun_app_kind fun_app = case flavour of+      Given ->+        do { new_tv <- wrapTcS (TcM.newCycleBreakerTyVar fun_app_kind)+           ; let new_ty     = mkTyVarTy new_tv+                 given_pred = mkHeteroPrimEqPred fun_app_kind fun_app_kind+                                                 fun_app new_ty+                 given_term = evCoercion $ mkNomReflCo new_ty  -- See Detail (4) of Note+           ; new_given <- newGivenEvVar new_loc (given_pred, given_term)+           ; traceTcS "breakTyEqCycle replacing type family in Given" (ppr new_given)+           ; emitWorkNC [new_given]+           ; updInertTcS $ \is ->+               is { inert_cycle_breakers = insertCycleBreakerBinding new_tv fun_app+                                             (inert_cycle_breakers is) }+           ; return $ mkReflRedn Nominal new_ty }+                -- Why reflexive? See Detail (4) of the Note++      Wanted ->+        do { new_tv <- wrapTcS (TcM.newFlexiTyVar fun_app_kind)+           ; let new_ty = mkTyVarTy new_tv+           ; co <- emitNewWantedEq new_loc (ctEvRewriters ev) Nominal new_ty fun_app+           ; return $ mkReduction (mkSymCo co) new_ty }        -- See Detail (7) of the Note     new_loc = updateCtLocOrigin (ctEvLoc ev) CycleBreakerOrigin
GHC/Tc/Solver/Rewrite.hs view
@@ -1,19 +1,21 @@ {-# LANGUAGE BangPatterns  #-}-{-# LANGUAGE CPP           #-}+ {-# LANGUAGE DeriveFunctor #-}  {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}  module GHC.Tc.Solver.Rewrite(-   rewrite, rewriteKind, rewriteArgsNom,+   rewrite, rewriteArgsNom,    rewriteType  ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Core.TyCo.Ppr ( pprTyVar )+import GHC.Tc.Types ( TcGblEnv(tcg_tc_plugin_rewriters),+                      TcPluginRewriter, TcPluginRewriteResult(..),+                      RewriteEnv(..),+                      runTcPluginM ) import GHC.Tc.Types.Constraint import GHC.Core.Predicate import GHC.Tc.Utils.TcType@@ -22,23 +24,24 @@ import GHC.Core.TyCon import GHC.Core.TyCo.Rep   -- performs delicate algorithm on types import GHC.Core.Coercion+import GHC.Core.Reduction+import GHC.Types.Unique.FM import GHC.Types.Var import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Driver.Session import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Tc.Solver.Monad as TcS  import GHC.Utils.Misc import GHC.Data.Maybe import GHC.Exts (oneShot)-import Data.Bifunctor import Control.Monad-import GHC.Utils.Monad ( zipWith3M )-import Data.List.NonEmpty ( NonEmpty(..) ) import Control.Applicative (liftA3) import GHC.Builtin.Types.Prim (tYPETyCon)+import Data.List ( find )  {- ************************************************************************@@ -49,12 +52,6 @@ ************************************************************************ -} -data RewriteEnv-  = FE { fe_loc     :: !CtLoc             -- See Note [Rewriter CtLoc]-       , fe_flavour :: !CtFlavour-       , fe_eq_rel  :: !EqRel             -- See Note [Rewriter EqRels]-       }- -- | The 'RewriteM' monad is a wrapper around 'TcS' with a 'RewriteEnv' newtype RewriteM a   = RewriteM { runRewriteM :: RewriteEnv -> TcS a }@@ -84,35 +81,44 @@  -- convenient wrapper when you have a CtEvidence describing -- the rewriting operation-runRewriteCtEv :: CtEvidence -> RewriteM a -> TcS a+runRewriteCtEv :: CtEvidence -> RewriteM a -> TcS (a, RewriterSet) runRewriteCtEv ev   = runRewrite (ctEvLoc ev) (ctEvFlavour ev) (ctEvEqRel ev)  -- Run thing_inside (which does the rewriting)-runRewrite :: CtLoc -> CtFlavour -> EqRel -> RewriteM a -> TcS a+-- Also returns the set of Wanteds which rewrote a Wanted;+-- See Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint+runRewrite :: CtLoc -> CtFlavour -> EqRel -> RewriteM a -> TcS (a, RewriterSet) runRewrite loc flav eq_rel thing_inside-  = runRewriteM thing_inside fmode-  where-    fmode = FE { fe_loc  = loc-               , fe_flavour = flav-               , fe_eq_rel = eq_rel }+  = do { rewriters_ref <- newTcRef emptyRewriterSet+       ; let fmode = RE { re_loc  = loc+                        , re_flavour = flav+                        , re_eq_rel = eq_rel+                        , re_rewriters = rewriters_ref }+       ; res <- runRewriteM thing_inside fmode+       ; rewriters <- readTcRef rewriters_ref+       ; return (res, rewriters) }  traceRewriteM :: String -> SDoc -> RewriteM () traceRewriteM herald doc = liftTcS $ traceTcS herald doc {-# INLINE traceRewriteM #-}  -- see Note [INLINE conditional tracing utilities] +getRewriteEnv :: RewriteM RewriteEnv+getRewriteEnv+  = mkRewriteM $ \env -> return env+ getRewriteEnvField :: (RewriteEnv -> a) -> RewriteM a getRewriteEnvField accessor   = mkRewriteM $ \env -> return (accessor env)  getEqRel :: RewriteM EqRel-getEqRel = getRewriteEnvField fe_eq_rel+getEqRel = getRewriteEnvField re_eq_rel  getRole :: RewriteM Role getRole = eqRelRole <$> getEqRel  getFlavour :: RewriteM CtFlavour-getFlavour = getRewriteEnvField fe_flavour+getFlavour = getRewriteEnvField re_flavour  getFlavourRole :: RewriteM CtFlavourRole getFlavourRole@@ -121,7 +127,7 @@        ; return (flavour, eq_rel) }  getLoc :: RewriteM CtLoc-getLoc = getRewriteEnvField fe_loc+getLoc = getRewriteEnvField re_loc  checkStackDepth :: Type -> RewriteM () checkStackDepth ty@@ -132,38 +138,32 @@ setEqRel :: EqRel -> RewriteM a -> RewriteM a setEqRel new_eq_rel thing_inside   = mkRewriteM $ \env ->-    if new_eq_rel == fe_eq_rel env+    if new_eq_rel == re_eq_rel env     then runRewriteM thing_inside env-    else runRewriteM thing_inside (env { fe_eq_rel = new_eq_rel })+    else runRewriteM thing_inside (env { re_eq_rel = new_eq_rel }) {-# INLINE setEqRel #-} --- | Make sure that rewriting actually produces a coercion (in other--- words, make sure our flavour is not Derived)--- Note [No derived kind equalities]-noBogusCoercions :: RewriteM a -> RewriteM a-noBogusCoercions thing_inside-  = mkRewriteM $ \env ->-    -- No new thunk is made if the flavour hasn't changed (note the bang).-    let !env' = case fe_flavour env of-          Derived -> env { fe_flavour = Wanted WDeriv }-          _       -> env-    in-    runRewriteM thing_inside env'- bumpDepth :: RewriteM a -> RewriteM a bumpDepth (RewriteM thing_inside)   = mkRewriteM $ \env -> do       -- bumpDepth can be called a lot during rewriting so we force the       -- new env to avoid accumulating thunks.-      { let !env' = env { fe_loc = bumpCtLocDepth (fe_loc env) }+      { let !env' = env { re_loc = bumpCtLocDepth (re_loc env) }       ; thing_inside env' } +-- See Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint+-- Precondition: the CtEvidence is a CtWanted of an equality+recordRewriter :: CtEvidence -> RewriteM ()+recordRewriter (CtWanted { ctev_dest = HoleDest hole })+  = RewriteM $ \env -> updTcRef (re_rewriters env) (`addRewriterSet` hole)+recordRewriter other = pprPanic "recordRewriter" (ppr other)+ {- Note [Rewriter EqRels] ~~~~~~~~~~~~~~~~~~~~~~~ When rewriting, we need to know which equality relation -- nominal or representation -- we should be respecting. The only difference is-that we rewrite variables by representational equalities when fe_eq_rel+that we rewrite variables by representational equalities when re_eq_rel is ReprEq, and that we unwrap newtypes when rewriting w.r.t. representational equality. @@ -201,14 +201,6 @@ canonicaliser will emit an insoluble, in which case we get a better error message anyway.) -Note [No derived kind equalities]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-A kind-level coercion can appear in types, via mkCastTy. So, whenever-we are generating a coercion in a dependent context (in other words,-in a kind) we need to make sure that our flavour is never Derived-(as Derived constraints have no evidence). The noBogusCoercions function-changes the flavour from Derived just for this purpose.- -}  {- *********************************************************************@@ -219,31 +211,21 @@ -}  -- | See Note [Rewriting].--- If (xi, co) <- rewrite mode ev ty, then co :: xi ~r ty+-- If (xi, co, rewriters) <- rewrite mode ev ty, then co :: xi ~r ty -- where r is the role in @ev@.+-- rewriters is the set of coercion holes that have been used to rewrite+-- See Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint rewrite :: CtEvidence -> TcType-        -> TcS (Xi, TcCoercion)+        -> TcS (Reduction, RewriterSet) rewrite ev ty   = do { traceTcS "rewrite {" (ppr ty)-       ; (ty', co) <- runRewriteCtEv ev (rewrite_one ty)-       ; traceTcS "rewrite }" (ppr ty')-       ; return (ty', co) }---- specialized to rewriting kinds: never Derived, always Nominal--- See Note [No derived kind equalities]--- See Note [Rewriting]-rewriteKind :: CtLoc -> CtFlavour -> TcType -> TcS (Xi, TcCoercionN)-rewriteKind loc flav ty-  = do { traceTcS "rewriteKind {" (ppr flav <+> ppr ty)-       ; let flav' = case flav of-                       Derived -> Wanted WDeriv  -- the WDeriv/WOnly choice matters not-                       _       -> flav-       ; (ty', co) <- runRewrite loc flav' NomEq (rewrite_one ty)-       ; traceTcS "rewriteKind }" (ppr ty' $$ ppr co) -- co is never a panic-       ; return (ty', co) }+       ; result@(redn, _) <- runRewriteCtEv ev (rewrite_one ty)+       ; traceTcS "rewrite }" (ppr $ reductionReducedType redn)+       ; return result }  -- See Note [Rewriting]-rewriteArgsNom :: CtEvidence -> TyCon -> [TcType] -> TcS ([Xi], [TcCoercion])+rewriteArgsNom :: CtEvidence -> TyCon -> [TcType]+               -> TcS (Reductions, RewriterSet) -- Externally-callable, hence runRewrite -- Rewrite a vector of types all at once; in fact they are -- always the arguments of type family or class, so@@ -252,15 +234,15 @@ -- The kind passed in is the kind of the type family or class, call it T -- The kind of T args must be constant (i.e. not depend on the args) ----- For Derived constraints the returned coercion may be undefined--- because rewriting may use a Derived equality ([D] a ~ ty)+-- Final return value returned which Wanteds rewrote another Wanted+-- See Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint rewriteArgsNom ev tc tys   = do { traceTcS "rewrite_args {" (vcat (map ppr tys))-       ; (tys', cos, kind_co)+       ; (ArgsReductions redns@(Reductions _ tys') kind_co, rewriters)            <- runRewriteCtEv ev (rewrite_args_tc tc Nothing tys)-       ; MASSERT( isReflMCo kind_co )+       ; massert (isReflMCo kind_co)        ; traceTcS "rewrite }" (vcat (map ppr tys'))-       ; return (tys', cos) }+       ; return (redns, rewriters) }  -- | Rewrite a type w.r.t. nominal equality. This is useful to rewrite -- a type w.r.t. any givens. It does not do type-family reduction. This@@ -268,13 +250,13 @@ -- only givens. rewriteType :: CtLoc -> TcType -> TcS TcType rewriteType loc ty-  = do { (xi, _) <- runRewrite loc Given NomEq $-                    rewrite_one ty+  = do { (redn, _) <- runRewrite loc Given NomEq $+                       rewrite_one ty                      -- use Given flavor so that it is rewritten-                     -- only w.r.t. Givens, never Wanteds/Deriveds+                     -- only w.r.t. Givens, never Wanteds                      -- (Shouldn't matter, if only Givens are present                      -- anyway)-       ; return xi }+       ; return $ reductionReducedType redn }  {- ********************************************************************* *                                                                      *@@ -284,15 +266,15 @@  {- Note [Rewriting] ~~~~~~~~~~~~~~~~~~~~-  rewrite ty  ==>   (xi, co)+  rewrite ty  ==>  Reduction co xi     where       xi has no reducible type functions          has no skolems that are mapped in the inert set          has no filled-in metavariables-      co :: xi ~ ty+      co :: ty ~ xi (coercions in reductions are always left-to-right)  Key invariants:-  (F0) co :: xi ~ zonk(ty')    where zonk(ty') ~ zonk(ty)+  (F0) co :: zonk(ty') ~ xi   where zonk(ty') ~ zonk(ty)   (F1) tcTypeKind(xi) succeeds and returns a fully zonked kind   (F2) tcTypeKind(xi) `eqType` zonk(tcTypeKind(ty)) @@ -303,18 +285,17 @@   * applies the substitution embodied in the inert set  Because rewriting zonks and the returned coercion ("co" above) is also-zonked, it's possible that (co :: xi ~ ty) isn't quite true. So, instead,+zonked, it's possible that (co :: ty ~ xi) isn't quite true. So, instead, we can rely on this fact: -  (F0) co :: xi ~ zonk(ty'), where zonk(ty') ~ zonk(ty)+  (F0) co :: zonk(ty') ~ xi, where zonk(ty') ~ zonk(ty) -Note that the left-hand type of co is *always* precisely xi. The right-hand+Note that the right-hand type of co is *always* precisely xi. The left-hand type may or may not be ty, however: if ty has unzonked filled-in metavariables,-then the right-hand type of co will be the zonk-equal to ty.-It is for this reason that we-occasionally have to explicitly zonk, when (co :: xi ~ ty) is important-even before we zonk the whole program. For example, see the RTRNotFollowed-case in rewriteTyVar.+then the left-hand type of co will be the zonk-equal to ty.+It is for this reason that we occasionally have to explicitly zonk,+when (co :: ty ~ xi) is important even before we zonk the whole program.+For example, see the RTRNotFollowed case in rewriteTyVar.  Why have these invariants on rewriting? Because we sometimes use tcTypeKind during canonicalisation, and we want this kind to be zonked (e.g., see@@ -323,7 +304,7 @@ Rewriting is always homogeneous. That is, the kind of the result of rewriting is always the same as the kind of the input, modulo zonking. More formally: -  (F2) tcTypeKind(xi) `eqType` zonk(tcTypeKind(ty))+  (F2) zonk(tcTypeKind(ty)) `eqType` tcTypeKind(xi)  This invariant means that the kind of a rewritten type might not itself be rewritten. @@ -335,7 +316,7 @@ unexpanded synonym. See also Note [Rewriting synonyms].  Where do we actually perform rewriting within a type? See Note [Rewritable] in-GHC.Tc.Solver.Monad.+GHC.Tc.Solver.InertSet.  Note [rewrite_args performance] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -389,17 +370,15 @@   :: TyCon         -- T   -> Maybe [Role]  -- Nothing: ambient role is Nominal; all args are Nominal                    -- Otherwise: no assumptions; use roles provided-  -> [Type]        -- Arg types [t1,..,tn]-  -> RewriteM ( [Xi]  -- List of rewritten args [x1,..,xn]-                   -- 1-1 corresp with [t1,..,tn]-           , [Coercion]  -- List of arg coercions [co1,..,con]-                         -- 1-1 corresp with [t1,..,tn]-                         --    coi :: xi ~r ti-           , MCoercionN) -- Result coercion, rco-                         --    rco : (T t1..tn) ~N (T (x1 |> co1) .. (xn |> con))+  -> [Type]+  -> RewriteM ArgsReductions -- See the commentary on rewrite_args rewrite_args_tc tc = rewrite_args all_bndrs any_named_bndrs inner_ki emptyVarSet   -- NB: TyCon kinds are always closed   where+  -- There are many bang patterns in here. It's been observed that they+  -- greatly improve performance of an optimized build.+  -- The T9872 test cases are good witnesses of this fact.+     (bndrs, named)       = ty_con_binders_ty_binders' (tyConBinders tc)     -- it's possible that the result kind has arrows (for, e.g., a type family)@@ -415,13 +394,15 @@              -> Kind -> TcTyCoVarSet -- function kind; kind's free vars              -> Maybe [Role] -> [Type]    -- these are in 1-to-1 correspondence                                           -- Nothing: use all Nominal-             -> RewriteM ([Xi], [Coercion], MCoercionN)--- Coercions :: Xi ~ Type, at roles given--- Third coercion :: tcTypeKind(fun xis) ~N tcTypeKind(fun tys)--- That is, the third coercion relates the kind of some function (whose kind is--- passed as the first parameter) instantiated at xis to the kind of that--- function instantiated at the tys. This is useful in keeping rewriting--- homoegeneous. The list of roles must be at least as long as the list of+             -> RewriteM ArgsReductions+-- This function returns ArgsReductions (Reductions cos xis) res_co+--   coercions: co_i :: ty_i ~ xi_i, at roles given+--   types:     xi_i+--   coercion:  res_co :: tcTypeKind(fun tys) ~N tcTypeKind(fun xis)+-- That is, the result coercion relates the kind of some function (whose kind is+-- passed as the first parameter) instantiated at tys to the kind of that+-- function instantiated at the xis. This is useful in keeping rewriting+-- homogeneous. The list of roles must be at least as long as the list of -- types. rewrite_args orig_binders              any_named_bndrs@@ -437,78 +418,55 @@ {-# INLINE rewrite_args_fast #-} -- | fast path rewrite_args, in which none of the binders are named and -- therefore we can avoid tracking a lifting context.--- There are many bang patterns in here. It's been observed that they--- greatly improve performance of an optimized build.--- The T9872 test cases are good witnesses of this fact.-rewrite_args_fast :: [Type]-                  -> RewriteM ([Xi], [Coercion], MCoercionN)+rewrite_args_fast :: [Type] -> RewriteM ArgsReductions rewrite_args_fast orig_tys   = fmap finish (iterate orig_tys)   where -    iterate :: [Type]-            -> RewriteM ([Xi], [Coercion])-    iterate (ty:tys) = do-      (xi, co)   <- rewrite_one ty-      (xis, cos) <- iterate tys-      pure (xi : xis, co : cos)-    iterate [] = pure ([], [])+    iterate :: [Type] -> RewriteM Reductions+    iterate (ty : tys) = do+      Reduction  co  xi  <- rewrite_one ty+      Reductions cos xis <- iterate tys+      pure $ Reductions (co : cos) (xi : xis)+    iterate [] = pure $ Reductions [] []      {-# INLINE finish #-}-    finish :: ([Xi], [Coercion]) -> ([Xi], [Coercion], MCoercionN)-    finish (xis, cos) = (xis, cos, MRefl)+    finish :: Reductions -> ArgsReductions+    finish redns = ArgsReductions redns MRefl  {-# INLINE rewrite_args_slow #-} -- | Slow path, compared to rewrite_args_fast, because this one must track -- a lifting context. rewrite_args_slow :: [TyCoBinder] -> Kind -> TcTyCoVarSet                   -> [Role] -> [Type]-                  -> RewriteM ([Xi], [Coercion], MCoercionN)+                  -> RewriteM ArgsReductions rewrite_args_slow binders inner_ki fvs roles tys--- Arguments used dependently must be rewritten with proper coercions, but--- we're not guaranteed to get a proper coercion when rewriting with the--- "Derived" flavour. So we must call noBogusCoercions when rewriting arguments--- corresponding to binders that are dependent. However, we might legitimately--- have *more* arguments than binders, in the case that the inner_ki is a variable--- that gets instantiated with a Π-type. We conservatively choose not to produce--- bogus coercions for these, too. Note that this might miss an opportunity for--- a Derived rewriting a Derived. The solution would be to generate evidence for--- Deriveds, thus avoiding this whole noBogusCoercions idea. See also--- Note [No derived kind equalities]-  = do { rewritten_args <- zipWith3M rw (map isNamedBinder binders ++ repeat True)-                                        roles tys+  = do { rewritten_args <- zipWithM rw roles tys        ; return (simplifyArgsWorker binders inner_ki fvs roles rewritten_args) }   where     {-# INLINE rw #-}-    rw :: Bool   -- must we ensure to produce a real coercion here?-                 -- see comment at top of function-       -> Role -> Type -> RewriteM (Xi, Coercion)-    rw True  r ty = noBogusCoercions $ rw1 r ty-    rw False r ty =                    rw1 r ty--    {-# INLINE rw1 #-}-    rw1 :: Role -> Type -> RewriteM (Xi, Coercion)-    rw1 Nominal ty+    rw :: Role -> Type -> RewriteM Reduction+    rw Nominal ty       = setEqRel NomEq $         rewrite_one ty -    rw1 Representational ty+    rw Representational ty       = setEqRel ReprEq $         rewrite_one ty -    rw1 Phantom ty+    rw Phantom ty     -- See Note [Phantoms in the rewriter]       = do { ty <- liftTcS $ zonkTcType ty-           ; return (ty, mkReflCo Phantom ty) }+           ; return $ mkReflRedn Phantom ty }  -------------------rewrite_one :: TcType -> RewriteM (Xi, Coercion)+rewrite_one :: TcType -> RewriteM Reduction -- Rewrite a type to get rid of type function applications, returning -- the new type-function-free type, and a collection of new equality -- constraints.  See Note [Rewriting] for more detail. ----- Postcondition: Coercion :: Xi ~ TcType--- The role on the result coercion matches the EqRel in the RewriteEnv+-- Postcondition:+-- the role on the result coercion matches the EqRel in the RewriteEnv  rewrite_one ty   | Just ty' <- rewriterView ty  -- See Note [Rewriting synonyms]@@ -516,7 +474,7 @@  rewrite_one xi@(LitTy {})   = do { role <- getRole-       ; return (xi, mkReflCo role xi) }+       ; return $ mkReflRedn role xi }  rewrite_one (TyVarTy tv)   = rewriteTyVar tv@@ -536,14 +494,14 @@   = rewrite_ty_con_app tc tys  rewrite_one (FunTy { ft_af = vis, ft_mult = mult, ft_arg = ty1, ft_res = ty2 })-  = do { (arg_xi,arg_co) <- rewrite_one ty1-       ; (res_xi,res_co) <- rewrite_one ty2+  = do { arg_redn <- rewrite_one ty1+       ; res_redn <- rewrite_one ty2          -- Important: look at the *reduced* type, so that any unzonked variables         -- in kinds are gone and the getRuntimeRep succeeds.         -- cf. Note [Decomposing FunTy] in GHC.Tc.Solver.Canonical.-       ; let arg_rep = getRuntimeRep arg_xi-             res_rep = getRuntimeRep res_xi+       ; let arg_rep = getRuntimeRep (reductionReducedType arg_redn)+             res_rep = getRuntimeRep (reductionReducedType res_redn)         ; (w_redn, arg_rep_redn, res_rep_redn) <- setEqRel NomEq $            liftA3 (,,) (rewrite_one mult)@@ -551,31 +509,22 @@                        (rewrite_one res_rep)        ; role <- getRole -       ; let arg_rep_co = mkSymCo (snd arg_rep_redn)+       ; let arg_rep_co = reductionCoercion arg_rep_redn                 -- :: arg_rep ~ arg_rep_xi              arg_ki_co  = mkTyConAppCo Nominal tYPETyCon [arg_rep_co]                 -- :: TYPE arg_rep ~ TYPE arg_rep_xi-             casted_arg_redn =-                 ( mkCastTy arg_xi arg_ki_co-                 , mkCoherenceLeftCo role arg_xi arg_ki_co arg_co-                 )+             casted_arg_redn = mkCoherenceRightRedn role arg_redn arg_ki_co                 -- :: ty1 ~> arg_xi |> arg_ki_co -             res_ki_co  = mkTyConAppCo Nominal tYPETyCon [mkSymCo $ snd res_rep_redn]-             casted_res_redn =-                ( mkCastTy res_xi res_ki_co-                , mkCoherenceLeftCo role res_xi res_ki_co res_co-                )+             res_rep_co = reductionCoercion res_rep_redn+             res_ki_co  = mkTyConAppCo Nominal tYPETyCon [res_rep_co]+             casted_res_redn = mkCoherenceRightRedn role res_redn res_ki_co            -- We must rewrite the representations, because that's what would           -- be done if we used TyConApp instead of FunTy. These rewritten           -- representations are seen only in casts of the arg and res, below.           -- Forgetting this caused #19677.-       ; return-            ( mkFunTy vis (fst w_redn) (fst casted_arg_redn) (fst casted_res_redn)-            , mkFunCo role (snd w_redn) (snd casted_arg_redn) (snd casted_res_redn)-            )-       }+       ; return $ mkFunRedn role vis w_redn casted_arg_redn casted_res_redn }  rewrite_one ty@(ForAllTy {}) -- TODO (RAE): This is inadequate, as it doesn't rewrite the kind of@@ -585,126 +534,116 @@ -- We allow for-alls when, but only when, no type function -- applications inside the forall involve the bound type variables.   = do { let (bndrs, rho) = tcSplitForAllTyVarBinders ty-             tvs           = binderVars bndrs-       ; (rho', co) <- rewrite_one rho-       ; return (mkForAllTys bndrs rho', mkHomoForAllCos tvs co) }+       ; redn <- rewrite_one rho+       ; return $ mkHomoForAllRedn bndrs redn }  rewrite_one (CastTy ty g)-  = do { (xi, co) <- rewrite_one ty-       ; (g', _)  <- rewrite_co g+  = do { redn <- rewrite_one ty+       ; g'   <- rewrite_co g        ; role <- getRole-       ; return (mkCastTy xi g', castCoercionKind1 co role xi ty g') }-         -- It makes a /big/ difference to call castCoercionKind1 not-         -- the more general castCoercionKind2.-         -- See Note [castCoercionKind1] in GHC.Core.Coercion+       ; return $ mkCastRedn1 role ty g' redn }+      -- This calls castCoercionKind1.+      -- It makes a /big/ difference to call castCoercionKind1 not+      -- the more general castCoercionKind2.+      -- See Note [castCoercionKind1] in GHC.Core.Coercion -rewrite_one (CoercionTy co) = first mkCoercionTy <$> rewrite_co co+rewrite_one (CoercionTy co)+  = do { co' <- rewrite_co co+       ; role <- getRole+       ; return $ mkReflCoRedn role co' }  -- | "Rewrite" a coercion. Really, just zonk it so we can uphold -- (F1) of Note [Rewriting]-rewrite_co :: Coercion -> RewriteM (Coercion, Coercion)-rewrite_co co-  = do { co <- liftTcS $ zonkCo co-       ; env_role <- getRole-       ; let co' = mkTcReflCo env_role (mkCoercionTy co)-       ; return (co, co') }+rewrite_co :: Coercion -> RewriteM Coercion+rewrite_co co = liftTcS $ zonkCo co +-- | Rewrite a reduction, composing the resulting coercions.+rewrite_reduction :: Reduction -> RewriteM Reduction+rewrite_reduction (Reduction co xi)+  = do { redn <- bumpDepth $ rewrite_one xi+       ; return $ co `mkTransRedn` redn }+ -- rewrite (nested) AppTys-rewrite_app_tys :: Type -> [Type] -> RewriteM (Xi, Coercion)+rewrite_app_tys :: Type -> [Type] -> RewriteM Reduction -- commoning up nested applications allows us to look up the function's kind -- only once. Without commoning up like this, we would spend a quadratic amount -- of time looking up functions' types rewrite_app_tys (AppTy ty1 ty2) tys = rewrite_app_tys ty1 (ty2:tys) rewrite_app_tys fun_ty arg_tys-  = do { (fun_xi, fun_co) <- rewrite_one fun_ty-       ; rewrite_app_ty_args fun_xi fun_co arg_tys }+  = do { redn <- rewrite_one fun_ty+       ; rewrite_app_ty_args redn arg_tys }  -- Given a rewritten function (with the coercion produced by rewriting) and -- a bunch of unrewritten arguments, rewrite the arguments and apply. -- The coercion argument's role matches the role stored in the RewriteM monad. -- -- The bang patterns used here were observed to improve performance. If you--- wish to remove them, be sure to check for regeressions in allocations.-rewrite_app_ty_args :: Xi -> Coercion -> [Type] -> RewriteM (Xi, Coercion)-rewrite_app_ty_args fun_xi fun_co []+-- wish to remove them, be sure to check for regressions in allocations.+rewrite_app_ty_args :: Reduction -> [Type] -> RewriteM Reduction+rewrite_app_ty_args redn []   -- this will be a common case when called from rewrite_fam_app, so shortcut-  = return (fun_xi, fun_co)-rewrite_app_ty_args fun_xi fun_co arg_tys-  = do { (xi, co, kind_co) <- case tcSplitTyConApp_maybe fun_xi of+  = return redn+rewrite_app_ty_args fun_redn@(Reduction fun_co fun_xi) arg_tys+  = do { het_redn <- case tcSplitTyConApp_maybe fun_xi of            Just (tc, xis) ->              do { let tc_roles  = tyConRolesRepresentational tc                       arg_roles = dropList xis tc_roles-                ; (arg_xis, arg_cos, kind_co)+                ; ArgsReductions (Reductions arg_cos arg_xis) kind_co                     <- rewrite_vector (tcTypeKind fun_xi) arg_roles arg_tys -                  -- Here, we have fun_co :: T xi1 xi2 ~ ty-                  -- and we need to apply fun_co to the arg_cos. The problem is+                  -- We start with a reduction of the form+                  --   fun_co :: ty ~ T xi_1 ... xi_n+                  -- and further arguments a_1, ..., a_m.+                  -- We rewrite these arguments, and obtain coercions:+                  --   arg_co_i :: a_i ~ zeta_i+                  -- Now, we need to apply fun_co to the arg_cos. The problem is                   -- that using mkAppCo is wrong because that function expects                   -- its second coercion to be Nominal, and the arg_cos might                   -- not be. The solution is to use transitivity:-                  -- T <xi1> <xi2> arg_cos ;; fun_co <arg_tys>+                  -- fun_co <a_1> ... <a_m> ;; T <xi_1> .. <xi_n> arg_co_1 ... arg_co_m                 ; eq_rel <- getEqRel                 ; let app_xi = mkTyConApp tc (xis ++ arg_xis)                       app_co = case eq_rel of                         NomEq  -> mkAppCos fun_co arg_cos-                        ReprEq -> mkTcTyConAppCo Representational tc-                                    (zipWith mkReflCo tc_roles xis ++ arg_cos)+                        ReprEq -> mkAppCos fun_co (map mkNomReflCo arg_tys)                                   `mkTcTransCo`-                                  mkAppCos fun_co (map mkNomReflCo arg_tys)-                ; return (app_xi, app_co, kind_co) }+                                  mkTcTyConAppCo Representational tc+                                    (zipWith mkReflCo tc_roles xis ++ arg_cos)++                ; return $+                    mkHetReduction+                      (mkReduction app_co app_xi )+                      kind_co }            Nothing ->-             do { (arg_xis, arg_cos, kind_co)+             do { ArgsReductions redns kind_co                     <- rewrite_vector (tcTypeKind fun_xi) (repeat Nominal) arg_tys-                ; let arg_xi = mkAppTys fun_xi arg_xis-                      arg_co = mkAppCos fun_co arg_cos-                ; return (arg_xi, arg_co, kind_co) }+                ; return $ mkHetReduction (mkAppRedns fun_redn redns) kind_co }         ; role <- getRole-       ; return (homogenise_result xi co role kind_co) }+       ; return (homogeniseHetRedn role het_redn) } -rewrite_ty_con_app :: TyCon -> [TcType] -> RewriteM (Xi, Coercion)+rewrite_ty_con_app :: TyCon -> [TcType] -> RewriteM Reduction rewrite_ty_con_app tc tys   = do { role <- getRole        ; let m_roles | Nominal <- role = Nothing                      | otherwise       = Just $ tyConRolesX role tc-       ; (xis, cos, kind_co) <- rewrite_args_tc tc m_roles tys-       ; let tyconapp_xi = mkTyConApp tc xis-             tyconapp_co = mkTyConAppCo role tc cos-       ; return (homogenise_result tyconapp_xi tyconapp_co role kind_co) }---- Make the result of rewriting homogeneous (Note [Rewriting] (F2))-homogenise_result :: Xi              -- a rewritten type-                  -> Coercion        -- :: xi ~r original ty-                  -> Role            -- r-                  -> MCoercionN      -- kind_co :: tcTypeKind(xi) ~N tcTypeKind(ty)-                  -> (Xi, Coercion)  -- (xi |> kind_co, (xi |> kind_co)-                                     --   ~r original ty)-homogenise_result xi co _ MRefl = (xi, co)-homogenise_result xi co r mco@(MCo kind_co)-  = (xi `mkCastTy` kind_co, (mkSymCo $ GRefl r xi mco) `mkTransCo` co)-{-# INLINE homogenise_result #-}+       ; ArgsReductions redns kind_co <- rewrite_args_tc tc m_roles tys+       ; let tyconapp_redn+                = mkHetReduction+                    (mkTyConAppRedn role tc redns)+                    kind_co+       ; return $ homogeniseHetRedn role tyconapp_redn }  -- Rewrite a vector (list of arguments). rewrite_vector :: Kind   -- of the function being applied to these arguments-               -> [Role] -- If we're rewrite w.r.t. ReprEq, what roles do the+               -> [Role] -- If we're rewriting w.r.t. ReprEq, what roles do the                          -- args have?                -> [Type] -- the args to rewrite-               -> RewriteM ([Xi], [Coercion], MCoercionN)+               -> RewriteM ArgsReductions rewrite_vector ki roles tys   = do { eq_rel <- getEqRel-       ; case eq_rel of-           NomEq  -> rewrite_args bndrs-                                  any_named_bndrs-                                  inner_ki-                                  fvs-                                  Nothing-                                  tys-           ReprEq -> rewrite_args bndrs-                                  any_named_bndrs-                                  inner_ki-                                  fvs-                                  (Just roles)-                                  tys+       ; let mb_roles = case eq_rel of { NomEq -> Nothing; ReprEq -> Just roles }+       ; rewrite_args bndrs any_named_bndrs inner_ki fvs mb_roles tys        }   where     (bndrs, inner_ki, any_named_bndrs) = split_pi_tys' ki@@ -751,9 +690,16 @@ Given an exactly saturated family application, how should we normalise it? This Note spells out the algorithm and its reasoning. -STEP 1. Try the famapp-cache. If we get a cache hit, jump to FINISH.+First, we attempt to directly rewrite the type family application,+without simplifying any of the arguments first, in an attempt to avoid+doing unnecessary work. -STEP 2. Try top-level instances. Note that we haven't simplified the arguments+STEP 1a. Call the rewriting plugins. If any plugin rewrites the type family+application, jump to FINISH.++STEP 1b. Try the famapp-cache. If we get a cache hit, jump to FINISH.++STEP 1c. Try top-level instances. Remember: we haven't simplified the arguments   yet. Example:     type instance F (Maybe a) = Int     target: F (Maybe (G Bool))@@ -762,27 +708,31 @@    If an instance is found, jump to FINISH. -STEP 3. Rewrite all arguments. This might expose more information so that we-  can use a top-level instance.--  Continue to the next step.+STEP 2: At this point we rewrite all arguments. This might expose more+  information, which might allow plugins to make progress, or allow us to+  pick up a top-level instance. -STEP 4. Try the inerts. Note that we try the inerts *after* rewriting the+STEP 3. Try the inerts. Note that we try the inerts *after* rewriting the   arguments, because the inerts will have rewritten LHSs.    If an inert is found, jump to FINISH. -STEP 5. Try the famapp-cache again. Now that we've revealed more information-  in the arguments, the cache might be helpful.+Next, we try STEP 1 again, as we might be able to make further progress after+having rewritten the arguments: +STEP 4a. Query the rewriting plugins again.++  If any plugin supplies a rewriting, jump to FINISH.++STEP 4b. Try the famapp-cache again.+   If we get a cache hit, jump to FINISH. -STEP 6. Try top-level instances, which might trigger now that we know more-  about the argumnents.+STEP 4c. Try top-level instances again.    If an instance is found, jump to FINISH. -STEP 7. No progress to be made. Return what we have. (Do not do FINISH.)+STEP 5: GIVEUP. No progress to be made. Return what we have. (Do not FINISH.)  FINISH 1. We've made a reduction, but the new type may still have more   work to do. So rewrite the new type.@@ -790,142 +740,194 @@ FINISH 2. Add the result to the famapp-cache, connecting the type we started   with to the one we ended with. -Because STEP 1/2 and STEP 5/6 happen the same way, they are abstracted into+Because STEP 1{a,b,c} and STEP 4{a,b,c} happen the same way, they are abstracted into try_to_reduce.  FINISH is naturally implemented in `finish`. But, Note [rewrite_exact_fam_app performance]-tells us that we should not add to the famapp-cache after STEP 1/2. So `finish`+tells us that we should not add to the famapp-cache after STEP 1. So `finish` is inlined in that case, and only FINISH 1 is performed.  -} -rewrite_fam_app :: TyCon -> [TcType] -> RewriteM (Xi, Coercion)+rewrite_fam_app :: TyCon -> [TcType] -> RewriteM Reduction   --   rewrite_fam_app            can be over-saturated   --   rewrite_exact_fam_app      lifts out the application to top level   -- Postcondition: Coercion :: Xi ~ F tys rewrite_fam_app tc tys  -- Can be over-saturated-    = ASSERT2( tys `lengthAtLeast` tyConArity tc-             , ppr tc $$ ppr (tyConArity tc) $$ ppr tys)+    = assertPpr (tys `lengthAtLeast` tyConArity tc)+                (ppr tc $$ ppr (tyConArity tc) $$ ppr tys) $                   -- Type functions are saturated                  -- The type function might be *over* saturated                  -- in which case the remaining arguments should                  -- be dealt with by AppTys       do { let (tys1, tys_rest) = splitAt (tyConArity tc) tys-         ; (xi1, co1) <- rewrite_exact_fam_app tc tys1-               -- co1 :: xi1 ~ F tys1--         ; rewrite_app_ty_args xi1 co1 tys_rest }+         ; redn <- rewrite_exact_fam_app tc tys1+         ; rewrite_app_ty_args redn tys_rest }  -- the [TcType] exactly saturate the TyCon -- See Note [How to normalise a family application]-rewrite_exact_fam_app :: TyCon -> [TcType] -> RewriteM (Xi, Coercion)+rewrite_exact_fam_app :: TyCon -> [TcType] -> RewriteM Reduction rewrite_exact_fam_app tc tys   = do { checkStackDepth (mkTyConApp tc tys) -       -- STEP 1/2. Try to reduce without reducing arguments first.-       ; result1 <- try_to_reduce tc tys+       -- Query the typechecking plugins for all their rewriting functions+       -- which apply to a type family application headed by the TyCon 'tc'.+       ; tc_rewriters <- getTcPluginRewritersForTyCon tc++       -- STEP 1. Try to reduce without reducing arguments first.+       ; result1 <- try_to_reduce tc tys tc_rewriters        ; case result1 of              -- Don't use the cache;              -- See Note [rewrite_exact_fam_app performance]-         { Just (co, xi) -> finish False (xi, co)+         { Just redn -> finish False redn          ; Nothing -> -        -- That didn't work. So reduce the arguments, in STEP 3.+        -- That didn't work. So reduce the arguments, in STEP 2.     do { eq_rel <- getEqRel-           -- checking eq_rel == NomEq saves ~0.5% in T9872a-       ; (xis, cos, kind_co) <- if eq_rel == NomEq-                                then rewrite_args_tc tc Nothing tys-                                else setEqRel NomEq $-                                     rewrite_args_tc tc Nothing tys-           -- kind_co :: tcTypeKind(F xis) ~N tcTypeKind(F tys)+          -- checking eq_rel == NomEq saves ~0.5% in T9872a+       ; ArgsReductions (Reductions cos xis) kind_co <-+            if eq_rel == NomEq+            then rewrite_args_tc tc Nothing tys+            else setEqRel NomEq $+                 rewrite_args_tc tc Nothing tys -       ; let role    = eqRelRole eq_rel-             args_co = mkTyConAppCo role tc cos-           -- args_co :: F xis ~r F tys+         -- If we manage to rewrite the type family application after+         -- rewriting the arguments, we will need to compose these+         -- reductions.+         --+         -- We have:+         --+         --   arg_co_i :: ty_i ~ xi_i+         --   fam_co :: F xi_1 ... xi_n ~ zeta+         --+         -- The full reduction is obtained as a composite:+         --+         --   full_co :: F ty_1 ... ty_n ~ zeta+         --   full_co = F co_1 ... co_n ;; fam_co+       ; let+           role    = eqRelRole eq_rel+           args_co = mkTyConAppCo role tc cos+       ;  let homogenise :: Reduction -> Reduction+              homogenise redn+                = homogeniseHetRedn role+                $ mkHetReduction+                    (args_co `mkTransRedn` redn)+                    kind_co -             homogenise :: TcType -> TcCoercion -> (TcType, TcCoercion)-               -- in (xi', co') = homogenise xi co-               --   assume co :: xi ~r F xis, co is homogeneous-               --   then xi' :: tcTypeKind(F tys)-               --   and co' :: xi' ~r F tys, which is homogeneous-             homogenise xi co = homogenise_result xi (co `mkTcTransCo` args_co) role kind_co+              give_up :: Reduction+              give_up = homogenise $ mkReflRedn role reduced+                where reduced = mkTyConApp tc xis -         -- STEP 4: try the inerts-       ; result2 <- liftTcS $ lookupFamAppInert tc xis+         -- STEP 3: try the inerts        ; flavour <- getFlavour+       ; result2 <- liftTcS $ lookupFamAppInert (`eqCanRewriteFR` (flavour, eq_rel)) tc xis        ; case result2 of-         { Just (co, xi, fr@(_, inert_eq_rel))-             -- co :: F xis ~ir xi--             | fr `eqCanRewriteFR` (flavour, eq_rel) ->-                 do { traceRewriteM "rewrite family application with inert"-                                (ppr tc <+> ppr xis $$ ppr xi)-                    ; finish True (homogenise xi downgraded_co) }+         { Just (redn, (inert_flavour, inert_eq_rel))+             -> do { traceRewriteM "rewrite family application with inert"+                                (ppr tc <+> ppr xis $$ ppr redn)+                   ; finish (inert_flavour == Given) (homogenise downgraded_redn) }                -- this will sometimes duplicate an inert in the cache,                -- but avoiding doing so had no impact on performance, and                -- it seems easier not to weed out that special case              where-               inert_role    = eqRelRole inert_eq_rel-               role          = eqRelRole eq_rel-               downgraded_co = tcDowngradeRole role inert_role (mkTcSymCo co)-                 -- downgraded_co :: xi ~r F xis+               inert_role      = eqRelRole inert_eq_rel+               role            = eqRelRole eq_rel+               downgraded_redn = downgradeRedn role inert_role redn           ; _ -> -         -- inert didn't work. Try to reduce again, in STEP 5/6.-    do { result3 <- try_to_reduce tc xis+         -- inerts didn't work. Try to reduce again, in STEP 4.+    do { result3 <- try_to_reduce tc xis tc_rewriters        ; case result3 of-           Just (co, xi) -> finish True (homogenise xi co)-           Nothing       -> -- we have made no progress at all: STEP 7.-                            return (homogenise reduced (mkTcReflCo role reduced))-             where-               reduced = mkTyConApp tc xis }}}}}+           Just redn -> finish True (homogenise redn)+           -- we have made no progress at all: STEP 5 (GIVEUP).+           _         -> return give_up }}}}}   where       -- call this if the above attempts made progress.       -- This recursively rewrites the result and then adds to the cache     finish :: Bool  -- add to the cache?-           -> (Xi, Coercion) -> RewriteM (Xi, Coercion)-    finish use_cache (xi, co)+                    -- Precondition: True ==> input coercion has+                    --                        no coercion holes+           -> Reduction -> RewriteM Reduction+    finish use_cache redn       = do { -- rewrite the result: FINISH 1-             (fully, fully_co) <- bumpDepth $ rewrite_one xi-           ; let final_co = fully_co `mkTcTransCo` co+             final_redn <- rewrite_reduction redn            ; eq_rel <- getEqRel-           ; flavour <- getFlavour               -- extend the cache: FINISH 2-           ; when (use_cache && eq_rel == NomEq && flavour /= Derived) $+           ; when (use_cache && eq_rel == NomEq) $              -- the cache only wants Nominal eqs-             -- and Wanteds can rewrite Deriveds; the cache-             -- has only Givens-             liftTcS $ extendFamAppCache tc tys (final_co, fully)-           ; return (fully, final_co) }+             liftTcS $ extendFamAppCache tc tys final_redn+           ; return final_redn }     {-# INLINE finish #-} --- Returned coercion is output ~r input, where r is the role in the RewriteM monad+-- Returned coercion is input ~r output, where r is the role in the RewriteM monad -- See Note [How to normalise a family application]-try_to_reduce :: TyCon -> [TcType] -> RewriteM (Maybe (TcCoercion, TcType))-try_to_reduce tc tys-  = do { result <- liftTcS $ firstJustsM [ lookupFamAppCache tc tys  -- STEP 5-                                         , matchFam tc tys ]         -- STEP 6-       ; downgrade result }+try_to_reduce :: TyCon -> [TcType] -> [TcPluginRewriter]+              -> RewriteM (Maybe Reduction)+try_to_reduce tc tys tc_rewriters+  = do { rewrite_env <- getRewriteEnv+       ; result <-+            liftTcS $ firstJustsM+              [ runTcPluginRewriters rewrite_env tc_rewriters tys -- STEP 1a & STEP 4a+              , lookupFamAppCache tc tys                          -- STEP 1b & STEP 4b+              , matchFam tc tys ]                                 -- STEP 1c & STEP 4c+       ; traverse downgrade result }   where     -- The result above is always Nominal. We might want a Representational     -- coercion; this downgrades (and prints, out of convenience).-    downgrade :: Maybe (TcCoercionN, TcType) -> RewriteM (Maybe (TcCoercion, TcType))-    downgrade Nothing = return Nothing-    downgrade result@(Just (co, xi))+    downgrade :: Reduction -> RewriteM Reduction+    downgrade redn       = do { traceRewriteM "Eager T.F. reduction success" $-             vcat [ ppr tc, ppr tys, ppr xi-                  , ppr co <+> dcolon <+> ppr (coercionKind co)+             vcat [ ppr tc+                  , ppr tys+                  , ppr redn                   ]            ; eq_rel <- getEqRel               -- manually doing it this way avoids allocation in the vastly               -- common NomEq case            ; case eq_rel of-               NomEq  -> return result-               ReprEq -> return (Just (mkSubCo co, xi)) }+               NomEq  -> return redn+               ReprEq -> return $ mkSubRedn redn } +-- Retrieve all type-checking plugins that can rewrite a (saturated) type-family application+-- headed by the given 'TyCon`.+getTcPluginRewritersForTyCon :: TyCon -> RewriteM [TcPluginRewriter]+getTcPluginRewritersForTyCon tc+  = liftTcS $ do { rewriters <- tcg_tc_plugin_rewriters <$> getGblEnv+                 ; return (lookupWithDefaultUFM rewriters [] tc) }++-- Run a collection of rewriting functions obtained from type-checking plugins,+-- querying in sequence if any plugin wants to rewrite the type family+-- applied to the given arguments.+--+-- Note that the 'TcPluginRewriter's provided all pertain to the same type family+-- (the 'TyCon' of which has been obtained ahead of calling this function).+runTcPluginRewriters :: RewriteEnv+                     -> [TcPluginRewriter]+                     -> [TcType]+                     -> TcS (Maybe Reduction)+runTcPluginRewriters rewriteEnv rewriterFunctions tys+  | null rewriterFunctions+  = return Nothing -- short-circuit for common case+  | otherwise+  = do { givens <- getInertGivens+       ; runRewriters givens rewriterFunctions }+  where+  runRewriters :: [Ct] -> [TcPluginRewriter] -> TcS (Maybe Reduction)+  runRewriters _ []+    = return Nothing+  runRewriters givens (rewriter:rewriters)+    = do+        rewriteResult <- wrapTcS . runTcPluginM $ rewriter rewriteEnv givens tys+        case rewriteResult of+           TcPluginRewriteTo+             { tcPluginReduction    = redn+             , tcRewriterNewWanteds = wanteds+             } -> do { emitWork wanteds; return $ Just redn }+           TcPluginNoRewrite {} -> runRewriters givens rewriters+ {- ************************************************************************ *                                                                      *@@ -938,31 +940,27 @@   = RTRNotFollowed       -- ^ The inert set doesn't make the tyvar equal to anything else -  | RTRFollowed TcType Coercion+  | RTRFollowed !Reduction       -- ^ The tyvar rewrites to a not-necessarily rewritten other type.-      -- co :: new type ~r old type, where the role is determined by-      -- the RewriteEnv+      -- The role is determined by the RewriteEnv.       --       -- With Quick Look, the returned TcType can be a polytype;       -- that is, in the constraint solver, a unification variable       -- can contain a polytype.  See GHC.Tc.Gen.App       -- Note [Instantiation variables are short lived] -rewriteTyVar :: TyVar -> RewriteM (Xi, Coercion)+rewriteTyVar :: TyVar -> RewriteM Reduction rewriteTyVar tv   = do { mb_yes <- rewrite_tyvar1 tv        ; case mb_yes of-           RTRFollowed ty1 co1  -- Recur-             -> do { (ty2, co2) <- rewrite_one ty1-                   -- ; traceRewriteM "rewriteTyVar2" (ppr tv $$ ppr ty2)-                   ; return (ty2, co2 `mkTransCo` co1) }+           RTRFollowed redn -> rewrite_reduction redn             RTRNotFollowed   -- Done, but make sure the kind is zonked                             -- Note [Rewriting] invariant (F0) and (F1)              -> do { tv' <- liftTcS $ updateTyVarKindM zonkTcType tv                    ; role <- getRole                    ; let ty' = mkTyVarTy tv'-                   ; return (ty', mkTcReflCo role ty') } }+                   ; return $ mkReflRedn role ty' } }  rewrite_tyvar1 :: TcTyVar -> RewriteM RewriteTvResult -- "Rewriting" a type variable means to apply the substitution to it@@ -977,7 +975,8 @@            Just ty -> do { traceRewriteM "Following filled tyvar"                              (ppr tv <+> equals <+> ppr ty)                          ; role <- getRole-                         ; return (RTRFollowed ty (mkReflCo role ty)) } ;+                         ; return $ RTRFollowed $+                             mkReflRedn role ty }            Nothing -> do { traceRewriteM "Unfilled tyvar" (pprTyVar tv)                          ; fr <- getFlavourRole                          ; rewrite_tyvar2 tv fr } }@@ -991,31 +990,34 @@ rewrite_tyvar2 tv fr@(_, eq_rel)   = do { ieqs <- liftTcS $ getInertEqs        ; case lookupDVarEnv ieqs tv of-           Just (EqualCtList (ct :| _))   -- If the first doesn't work,-                                          -- the subsequent ones won't either-             | CEqCan { cc_ev = ctev, cc_lhs = TyVarLHS tv+           Just equal_ct_list+             | Just ct <- find can_rewrite equal_ct_list+             , CEqCan { cc_ev = ctev, cc_lhs = TyVarLHS tv                       , cc_rhs = rhs_ty, cc_eq_rel = ct_eq_rel } <- ct-             , let ct_fr = (ctEvFlavour ctev, ct_eq_rel)-             , ct_fr `eqCanRewriteFR` fr  -- This is THE key call of eqCanRewriteFR-             -> do { traceRewriteM "Following inert tyvar"-                        (ppr tv <+>-                         equals <+>-                         ppr rhs_ty $$ ppr ctev)-                    ; let rewrite_co1 = mkSymCo (ctEvCoercion ctev)-                          rewrite_co  = case (ct_eq_rel, eq_rel) of-                            (ReprEq, _rel)  -> ASSERT( _rel == ReprEq )-                                    -- if this ASSERT fails, then+             -> do { let wrw = isWantedCt ct+                   ; traceRewriteM "Following inert tyvar" $+                        vcat [ ppr tv <+> equals <+> ppr rhs_ty+                             , ppr ctev+                             , text "wanted_rewrite_wanted:" <+> ppr wrw ]+                   ; when wrw $ recordRewriter ctev++                   ; let rewriting_co1 = ctEvCoercion ctev+                         rewriting_co  = case (ct_eq_rel, eq_rel) of+                            (ReprEq, _rel)  -> assert (_rel == ReprEq)+                                    -- if this assert fails, then                                     -- eqCanRewriteFR answered incorrectly-                                               rewrite_co1-                            (NomEq, NomEq)  -> rewrite_co1-                            (NomEq, ReprEq) -> mkSubCo rewrite_co1+                                               rewriting_co1+                            (NomEq, NomEq)  -> rewriting_co1+                            (NomEq, ReprEq) -> mkSubCo rewriting_co1 -                    ; return (RTRFollowed rhs_ty rewrite_co) }-                    -- NB: ct is Derived then fmode must be also, hence-                    -- we are not going to touch the returned coercion-                    -- so ctEvCoercion is fine.+                   ; return $ RTRFollowed $ mkReduction rewriting_co rhs_ty }             _other -> return RTRNotFollowed }++  where+    can_rewrite :: Ct -> Bool+    can_rewrite ct = ctFlavourRole ct `eqCanRewriteFR` fr+      -- This is THE key call of eqCanRewriteFR  {- Note [An alternative story for the inert substitution]
+ GHC/Tc/Solver/Types.hs view
@@ -0,0 +1,302 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GADTs #-}++{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}++-- | Utility types used within the constraint solver+module GHC.Tc.Solver.Types (+    -- Inert CDictCans+    DictMap, emptyDictMap, findDictsByClass, addDict,+    addDictsByClass, delDict, foldDicts, filterDicts, findDict,+    dictsToBag, partitionDicts,++    FunEqMap, emptyFunEqs, foldFunEqs, findFunEq, insertFunEq,+    findFunEqsByTyCon,++    TcAppMap, emptyTcAppMap, isEmptyTcAppMap,+    insertTcApp, alterTcApp, filterTcAppMap,+    tcAppMapToBag, foldTcAppMap,++    EqualCtList, filterEqualCtList, addToEqualCtList+  ) where++import GHC.Prelude++import GHC.Tc.Types.Constraint+import GHC.Tc.Types.Origin+import GHC.Tc.Utils.TcType++import GHC.Core.Class+import GHC.Core.Map.Type+import GHC.Core.Predicate+import GHC.Core.TyCon+import GHC.Core.TyCon.Env++import GHC.Data.Bag+import GHC.Data.Maybe+import GHC.Data.TrieMap+import GHC.Utils.Constants+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Utils.Panic.Plain++{- *********************************************************************+*                                                                      *+                   TcAppMap+*                                                                      *+************************************************************************++Note [Use loose types in inert set]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Whenever we are looking up an inert dictionary (CDictCan) or function+equality (CEqCan), we use a TcAppMap, which uses the Unique of the+class/type family tycon and then a trie which maps the arguments. This+trie does *not* need to match the kinds of the arguments; this Note+explains why.++Consider the types ty0 = (T ty1 ty2 ty3 ty4) and ty0' = (T ty1' ty2' ty3' ty4'),+where ty4 and ty4' have different kinds. Let's further assume that both types+ty0 and ty0' are well-typed. Because the kind of T is closed, it must be that+one of the ty1..ty3 does not match ty1'..ty3' (and that the kind of the fourth+argument to T is dependent on whichever one changed). Since we are matching+all arguments, during the inert-set lookup, we know that ty1..ty3 do indeed+match ty1'..ty3'. Therefore, the kind of ty4 and ty4' must match, too --+without ever looking at it.++Accordingly, we use LooseTypeMap, which skips the kind check when looking+up a type. I (Richard E) believe this is just an optimization, and that+looking at kinds would be harmless.++-}++type TcAppMap a = DTyConEnv (ListMap LooseTypeMap a)+    -- Indexed by tycon then the arg types, using "loose" matching, where+    -- we don't require kind equality. This allows, for example, (a |> co)+    -- to match (a).+    -- See Note [Use loose types in inert set]+    -- Used for types and classes; hence UniqDFM+    -- See Note [foldTM determinism] in GHC.Data.TrieMap for why we use DTyConEnv here++isEmptyTcAppMap :: TcAppMap a -> Bool+isEmptyTcAppMap m = isEmptyDTyConEnv m++emptyTcAppMap :: TcAppMap a+emptyTcAppMap = emptyDTyConEnv++findTcApp :: TcAppMap a -> TyCon -> [Type] -> Maybe a+findTcApp m tc tys = do { tys_map <- lookupDTyConEnv m tc+                        ; lookupTM tys tys_map }++delTcApp :: TcAppMap a -> TyCon -> [Type] -> TcAppMap a+delTcApp m tc tys = adjustDTyConEnv (deleteTM tys) m tc++insertTcApp :: TcAppMap a -> TyCon -> [Type] -> a -> TcAppMap a+insertTcApp m tc tys ct = alterDTyConEnv alter_tm m tc+  where+    alter_tm mb_tm = Just (insertTM tys ct (mb_tm `orElse` emptyTM))++alterTcApp :: forall a. TcAppMap a -> TyCon -> [Type] -> XT a -> TcAppMap a+alterTcApp m tc tys upd = alterDTyConEnv alter_tm m tc+  where+    alter_tm :: Maybe (ListMap LooseTypeMap a) -> Maybe (ListMap LooseTypeMap a)+    alter_tm m_elt = Just (alterTM tys upd (m_elt `orElse` emptyTM))++filterTcAppMap :: forall a. (a -> Bool) -> TcAppMap a -> TcAppMap a+filterTcAppMap f m = mapMaybeDTyConEnv one_tycon m+  where+    one_tycon :: ListMap LooseTypeMap a -> Maybe (ListMap LooseTypeMap a)+    one_tycon tm+      | isEmptyTM filtered_tm = Nothing+      | otherwise             = Just filtered_tm+      where+        filtered_tm = filterTM f tm++tcAppMapToBag :: TcAppMap a -> Bag a+tcAppMapToBag m = foldTcAppMap consBag m emptyBag++foldTcAppMap :: (a -> b -> b) -> TcAppMap a -> b -> b+foldTcAppMap k m z = foldDTyConEnv (foldTM k) z m++{- *********************************************************************+*                                                                      *+                   DictMap+*                                                                      *+********************************************************************* -}++type DictMap a = TcAppMap a++emptyDictMap :: DictMap a+emptyDictMap = emptyTcAppMap++findDict :: DictMap a -> CtLoc -> Class -> [Type] -> Maybe a+findDict m loc cls tys+  | hasIPSuperClasses cls tys -- See Note [Tuples hiding implicit parameters]+  = Nothing++  | Just {} <- isCallStackPred cls tys+  , isPushCallStackOrigin (ctLocOrigin loc)+  = Nothing             -- See Note [Solving CallStack constraints]++  | otherwise+  = findTcApp m (classTyCon cls) tys++findDictsByClass :: DictMap a -> Class -> Bag a+findDictsByClass m cls+  | Just tm <- lookupDTyConEnv m (classTyCon cls) = foldTM consBag tm emptyBag+  | otherwise                                     = emptyBag++delDict :: DictMap a -> Class -> [Type] -> DictMap a+delDict m cls tys = delTcApp m (classTyCon cls) tys++addDict :: DictMap a -> Class -> [Type] -> a -> DictMap a+addDict m cls tys item = insertTcApp m (classTyCon cls) tys item++addDictsByClass :: DictMap Ct -> Class -> Bag Ct -> DictMap Ct+addDictsByClass m cls items+  = extendDTyConEnv m (classTyCon cls) (foldr add emptyTM items)+  where+    add ct@(CDictCan { cc_tyargs = tys }) tm = insertTM tys ct tm+    add ct _ = pprPanic "addDictsByClass" (ppr ct)++filterDicts :: (Ct -> Bool) -> DictMap Ct -> DictMap Ct+filterDicts f m = filterTcAppMap f m++partitionDicts :: (Ct -> Bool) -> DictMap Ct -> (Bag Ct, DictMap Ct)+partitionDicts f m = foldTcAppMap k m (emptyBag, emptyDictMap)+  where+    k ct (yeses, noes) | f ct      = (ct `consBag` yeses, noes)+                       | otherwise = (yeses,              add ct noes)+    add ct@(CDictCan { cc_class = cls, cc_tyargs = tys }) m+      = addDict m cls tys ct+    add ct _ = pprPanic "partitionDicts" (ppr ct)++dictsToBag :: DictMap a -> Bag a+dictsToBag = tcAppMapToBag++foldDicts :: (a -> b -> b) -> DictMap a -> b -> b+foldDicts = foldTcAppMap++{- Note [Tuples hiding implicit parameters]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   f,g :: (?x::Int, C a) => a -> a+   f v = let ?x = 4 in g v++The call to 'g' gives rise to a Wanted constraint (?x::Int, C a).+We must /not/ solve this from the Given (?x::Int, C a), because of+the intervening binding for (?x::Int).  #14218.++We deal with this by arranging that we always fail when looking up a+tuple constraint that hides an implicit parameter. Note that this applies+  * both to the inert_dicts (lookupInertDict)+  * and to the solved_dicts (looukpSolvedDict)+An alternative would be not to extend these sets with such tuple+constraints, but it seemed more direct to deal with the lookup.++Note [Solving CallStack constraints]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+See also Note [Overview of implicit CallStacks] in GHc.Tc.Types.Evidence.++Suppose f :: HasCallStack => blah.  Then++* Each call to 'f' gives rise to+    [W] s1 :: IP "callStack" CallStack    -- CtOrigin = OccurrenceOf f+  with a CtOrigin that says "OccurrenceOf f".+  Remember that HasCallStack is just shorthand for+    IP "callStack" CallStack+  See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence++* We cannonicalise such constraints, in GHC.Tc.Solver.Canonical.canClassNC, by+  pushing the call-site info on the stack, and changing the CtOrigin+  to record that has been done.+   Bind:  s1 = pushCallStack <site-info> s2+   [W] s2 :: IP "callStack" CallStack   -- CtOrigin = IPOccOrigin++* Then, and only then, we can solve the constraint from an enclosing+  Given.++So we must be careful /not/ to solve 's1' from the Givens.  Again,+we ensure this by arranging that findDict always misses when looking+up such constraints.+-}++{- *********************************************************************+*                                                                      *+                   FunEqMap+*                                                                      *+********************************************************************* -}++type FunEqMap a = TcAppMap a  -- A map whose key is a (TyCon, [Type]) pair++emptyFunEqs :: TcAppMap a+emptyFunEqs = emptyTcAppMap++findFunEq :: FunEqMap a -> TyCon -> [Type] -> Maybe a+findFunEq m tc tys = findTcApp m tc tys++findFunEqsByTyCon :: FunEqMap a -> TyCon -> [a]+-- Get inert function equation constraints that have the given tycon+-- in their head.  Not that the constraints remain in the inert set.+-- We use this to check for wanted interactions with built-in type-function+-- constructors.+findFunEqsByTyCon m tc+  | Just tm <- lookupDTyConEnv m tc = foldTM (:) tm []+  | otherwise                       = []++foldFunEqs :: (a -> b -> b) -> FunEqMap a -> b -> b+foldFunEqs = foldTcAppMap++insertFunEq :: FunEqMap a -> TyCon -> [Type] -> a -> FunEqMap a+insertFunEq m tc tys val = insertTcApp m tc tys val++{- *********************************************************************+*                                                                      *+                   EqualCtList+*                                                                      *+********************************************************************* -}++{-+Note [EqualCtList invariants]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+    * All are equalities+    * All these equalities have the same LHS+    * No element of the list can rewrite any other++Accordingly, this list is either empty, contains one element, or+contains a Given representational equality and a Wanted nominal one.+-}++type EqualCtList = [Ct]+  -- See Note [EqualCtList invariants]++addToEqualCtList :: Ct -> EqualCtList -> EqualCtList+-- See Note [EqualCtList invariants]+addToEqualCtList ct old_eqs+  | debugIsOn+  = case ct of+      CEqCan { cc_lhs = TyVarLHS tv } ->+        let shares_lhs (CEqCan { cc_lhs = TyVarLHS old_tv }) = tv == old_tv+            shares_lhs _other                                = False+        in+        assert (all shares_lhs old_eqs) $+        assert (null ([ (ct1, ct2) | ct1 <- ct : old_eqs+                                   , ct2 <- ct : old_eqs+                                   , let { fr1 = ctFlavourRole ct1+                                         ; fr2 = ctFlavourRole ct2 }+                                   , fr1 `eqCanRewriteFR` fr2 ])) $+        (ct : old_eqs)++      _ -> pprPanic "addToEqualCtList not CEqCan" (ppr ct)++  | otherwise+  = ct : old_eqs++-- returns Nothing when the new list is empty, to keep the environments smaller+filterEqualCtList :: (Ct -> Bool) -> EqualCtList -> Maybe EqualCtList+filterEqualCtList pred cts+  | null new_list+  = Nothing+  | otherwise+  = Just new_list+  where+    new_list = filter pred cts
GHC/Tc/TyCl.hs view
@@ -4,7 +4,8 @@  -} -{-# LANGUAGE CPP, TupleSections, ScopedTypeVariables, MultiWayIf #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE TupleSections, ScopedTypeVariables, MultiWayIf #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE LambdaCase #-}@@ -22,18 +23,18 @@         tcFamTyPats, tcTyFamInstEqn,         tcAddTyFamInstCtxt, tcMkDataFamInstCtxt, tcAddDataFamInstCtxt,         unravelFamInstPats, addConsistencyConstraints,-        wrongKindOfFamily+        wrongKindOfFamily, checkFamTelescope     ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Driver.Env import GHC.Driver.Session+import GHC.Driver.Config.HsToCore  import GHC.Hs +import GHC.Tc.Errors.Types ( TcRnMessage(..), FixedRuntimeRepProvenance(..) ) import GHC.Tc.TyCl.Build import GHC.Tc.Solver( pushLevelAndSolveEqualities, pushLevelAndSolveEqualitiesX                     , reportUnsolvedEqualities )@@ -70,7 +71,9 @@ import GHC.Core.DataCon import GHC.Core.Unify +import GHC.Types.Error import GHC.Types.Id+import GHC.Types.Id.Make import GHC.Types.Var import GHC.Types.Var.Env import GHC.Types.Var.Set@@ -85,18 +88,19 @@  import GHC.Data.FastString import GHC.Data.Maybe-import GHC.Data.List.SetOps+import GHC.Data.List.SetOps( minusList, equivClasses )  import GHC.Unit  import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain+import GHC.Utils.Constants (debugIsOn) import GHC.Utils.Misc  import Control.Monad-import Data.Function ( on ) import Data.Functor.Identity-import Data.List (nubBy, partition)+import Data.List ( partition) import Data.List.NonEmpty ( NonEmpty(..) ) import qualified Data.Set as Set import Data.Tuple( swap )@@ -144,31 +148,35 @@                                             -- and their implicit Ids,DataCons                          , [InstInfo GhcRn] -- Source-code instance decls info                          , [DerivInfo]      -- Deriving info+                         , ThBindEnv        -- TH binding levels                          ) -- Fails if there are any errors tcTyAndClassDecls tyclds_s   -- The code recovers internally, but if anything gave rise to   -- an error we'd better stop now, to avoid a cascade   -- Type check each group in dependency order folding the global env-  = checkNoErrs $ fold_env [] [] tyclds_s+  = checkNoErrs $ fold_env [] [] emptyNameEnv tyclds_s   where     fold_env :: [InstInfo GhcRn]              -> [DerivInfo]+             -> ThBindEnv              -> [TyClGroup GhcRn]-             -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo])-    fold_env inst_info deriv_info []+             -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo], ThBindEnv)+    fold_env inst_info deriv_info th_bndrs []       = do { gbl_env <- getGblEnv-           ; return (gbl_env, inst_info, deriv_info) }-    fold_env inst_info deriv_info (tyclds:tyclds_s)-      = do { (tcg_env, inst_info', deriv_info') <- tcTyClGroup tyclds+           ; return (gbl_env, inst_info, deriv_info, th_bndrs) }+    fold_env inst_info deriv_info th_bndrs (tyclds:tyclds_s)+      = do { (tcg_env, inst_info', deriv_info', th_bndrs')+               <- tcTyClGroup tyclds            ; setGblEnv tcg_env $                -- remaining groups are typechecked in the extended global env.              fold_env (inst_info' ++ inst_info)                       (deriv_info' ++ deriv_info)+                      (th_bndrs' `plusNameEnv` th_bndrs)                       tyclds_s }  tcTyClGroup :: TyClGroup GhcRn-            -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo])+            -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo], ThBindEnv) -- Typecheck one strongly-connected component of type, class, and instance decls -- See Note [TyClGroups and dependency analysis] in GHC.Hs.Decls tcTyClGroup (TyClGroup { group_tyclds = tyclds@@ -206,17 +214,18 @@            -- Step 3: Add the implicit things;            -- we want them in the environment because            -- they may be mentioned in interface files-       ; gbl_env <- addTyConsToGblEnv tyclss+       ; (gbl_env, th_bndrs) <- addTyConsToGblEnv tyclss             -- Step 4: check instance declarations-       ; (gbl_env', inst_info, datafam_deriv_info) <-+       ; (gbl_env', inst_info, datafam_deriv_info, th_bndrs') <-          setGblEnv gbl_env $          tcInstDecls1 instds         ; let deriv_info = datafam_deriv_info ++ data_deriv_info        ; let gbl_env'' = gbl_env'                 { tcg_ksigs = tcg_ksigs gbl_env' `unionNameSet` kindless }-       ; return (gbl_env'', inst_info, deriv_info) }+       ; return (gbl_env'', inst_info, deriv_info,+                 th_bndrs' `plusNameEnv` th_bndrs) }  -- Gives the kind for every TyCon that has a standalone kind signature type KindSigEnv = NameEnv Kind@@ -395,32 +404,51 @@     see makeRecoveryTyCon.  2.  When checking a type/class declaration (in module GHC.Tc.TyCl), we come-    upon knowledge of the eventual tycon in bits and pieces.+    upon knowledge of the eventual tycon in bits and pieces, and we use+    a TcTyCon to record what we know before we are ready to build the+    final TyCon. -      S1) First, we use inferInitialKinds to look over the user-provided-          kind signature of a tycon (including, for example, the number-          of parameters written to the tycon) to get an initial shape of-          the tycon's kind.  We record that shape in a TcTyCon.+    We first build a MonoTcTyCon, then generalise to a PolyTcTyCon+    See Note [TcTyCon, MonoTcTyCon, and PolyTcTyCon] in GHC.Tc.Utils.TcType+    Specifically: -          For CUSK tycons, the TcTyCon has the final, generalised kind.-          For non-CUSK tycons, the TcTyCon has as its tyConBinders only-          the explicit arguments given -- no kind variables, etc.+      S1) In kcTyClGroup, we use checkInitialKinds to get the+          utterly-final Kind of all TyCons in the group that+            (a) have a kind signature or+            (b) have a CUSK.+          This produces a PolyTcTyCon, that is, a TcTyCon in which the binders+          and result kind are full of TyVars (not TcTyVars).  No unification+          variables here; everything is in its final form. -      S2) Then, using these initial kinds, we kind-check the body of the-          tycon (class methods, data constructors, etc.), filling in the+      S2) In kcTyClGroup, we use inferInitialKinds to look over the+          declaration of any TyCon that lacks a kind signature or+          CUSK, to determine its "shape"; for example, the number of+          parameters, and any kind signatures.++          We record that shape record that shape in a MonoTcTyCon; it is+          "mono" because it has not been been generalised, and its binders+          and result kind may have free unification variables.++      S3) Still in kcTyClGroup, we use kcLTyClDecl to kind-check the+          body (class methods, data constructors, etc.) of each of+          these MonoTcTyCons, which has the effect of filling in the           metavariables in the tycon's initial kind. -      S3) We then generalize to get the (non-CUSK) tycon's final, fixed-          kind. Finally, once this has happened for all tycons in a-          mutually recursive group, we can desugar the lot.+      S4) Still in kcTyClGroup, we use generaliseTyClDecl to generalize+          each MonoTcTyCon to get a PolyTcTyCon, with final TyVars in it,+          and a final, fixed kind. -    For convenience, we store partially-known tycons in TcTyCons, which-    might store meta-variables. These TcTyCons are stored in the local-    environment in GHC.Tc.TyCl, until the real full TyCons can be created-    during desugaring. A desugared program should never have a TcTyCon.+      S5) Finally, back in TcTyClDecls, we extend the environment with+          the PolyTcTyCons, and typecheck each declaration (regardless+          of kind signatures etc) to get final TyCon. -3.  In a TcTyCon, everything is zonked after the kind-checking pass (S2).+    These TcTyCons are stored in the local environment in GHC.Tc.TyCl,+    until the real full TyCons can be created during desugaring. A+    desugared program should never have a TcTyCon. +3.  A MonoTcTyCon can contain unification variables, but a PolyTcTyCon+    does not: only skolem TcTyVars.+ 4.  tyConScopedTyVars.  A challenging piece in all of this is that we     end up taking three separate passes over every declaration:       - one in inferInitialKind (this pass look only at the head, not the body)@@ -435,8 +463,10 @@     GHC.Tc.Gen.HsType.splitTelescopeTvs!)      Instead of trying, we just store the list of type variables to-    bring into scope, in the tyConScopedTyVars field of the TcTyCon.-    These tyvars are brought into scope in GHC.Tc.Gen.HsType.bindTyClTyVars.+    bring into scope, in the tyConScopedTyVars field of a MonoTcTyCon.+    These tyvars are brought into scope by the calls to+       tcExtendNameTyVarEnv (tcTyConScopedTyVars tycon)+    in kcTyClDecl.      In a TcTyCon, why is tyConScopedTyVars :: [(Name,TcTyVar)] rather     than just [TcTyVar]?  Consider these mutually-recursive decls@@ -633,7 +663,7 @@  -} -kcTyClGroup :: KindSigEnv -> [LTyClDecl GhcRn] -> TcM ([TcTyCon], NameSet)+kcTyClGroup :: KindSigEnv -> [LTyClDecl GhcRn] -> TcM ([PolyTcTyCon], NameSet)  -- Kind check this group, kind generalize, and return the resulting local env -- This binds the TyCons and Classes of the group, but not the DataCons@@ -677,7 +707,7 @@          ; inferred_tcs             <- tcExtendKindEnvWithTyCons checked_tcs  $-               pushLevelAndSolveEqualities UnkSkol [] $+               pushLevelAndSolveEqualities unkSkolAnon [] $                      -- We are going to kind-generalise, so unification                      -- variables in here must be one level in                do {  -- Step 1: Bind kind variables for all decls@@ -717,7 +747,7 @@   --    specified-tvs ++ required-tvs   -- You can distinguish them because there are tyConArity required-tvs -generaliseTyClDecl :: NameEnv TcTyCon -> LTyClDecl GhcRn -> TcM [TcTyCon]+generaliseTyClDecl :: NameEnv MonoTcTyCon -> LTyClDecl GhcRn -> TcM [PolyTcTyCon] -- See Note [Swizzling the tyvars before generaliseTcTyCon] generaliseTyClDecl inferred_tc_env (L _ decl)   = do { let names_in_this_decl :: [Name]@@ -746,35 +776,38 @@     at_names (ClassDecl { tcdATs = ats }) = map (familyDeclName . unLoc) ats     at_names _ = []  -- Only class decls have associated types -    skolemise_tc_tycon :: Name -> TcM (TcTyCon, ScopedPairs)+    skolemise_tc_tycon :: Name -> TcM (TcTyCon, SkolemInfo, ScopedPairs)     -- Zonk and skolemise the Specified and Required binders     skolemise_tc_tycon tc_name       = do { let tc = lookupNameEnv_NF inferred_tc_env tc_name                       -- This lookup should not fail-           ; scoped_prs <- mapSndM zonkAndSkolemise (tcTyConScopedTyVars tc)-           ; return (tc, scoped_prs) }+           ; skol_info <- mkSkolemInfo (TyConSkol (tyConFlavour tc) tc_name )+           ; scoped_prs <- mapSndM (zonkAndSkolemise skol_info) (tcTyConScopedTyVars tc)+           ; return (tc, skol_info, scoped_prs) } -    zonk_tc_tycon :: (TcTyCon, ScopedPairs) -> TcM (TcTyCon, ScopedPairs, TcKind)-    zonk_tc_tycon (tc, scoped_prs)-      = do { scoped_prs <- mapSndM zonkTcTyVarToTyVar scoped_prs+    zonk_tc_tycon :: (TcTyCon, SkolemInfo, ScopedPairs)+                  -> TcM (TcTyCon, SkolemInfo, ScopedPairs, TcKind)+    zonk_tc_tycon (tc, skol_info, scoped_prs)+      = do { scoped_prs <- mapSndM zonkTcTyVarToTcTyVar scoped_prs                            -- We really have to do this again, even though-                           -- we have just done zonkAndSkolemise+                           -- we have just done zonkAndSkolemise, so that+                           -- occurrences in the /kinds/ get zonked to the skolem            ; res_kind   <- zonkTcType (tyConResKind tc)-           ; return (tc, scoped_prs, res_kind) }+           ; return (tc, skol_info, scoped_prs, res_kind) } -swizzleTcTyConBndrs :: [(TcTyCon, ScopedPairs, TcKind)]-                -> TcM [(TcTyCon, ScopedPairs, TcKind)]+swizzleTcTyConBndrs :: [(TcTyCon, SkolemInfo, ScopedPairs, TcKind)]+                -> TcM [(TcTyCon, SkolemInfo, ScopedPairs, TcKind)] swizzleTcTyConBndrs tc_infos   | all no_swizzle swizzle_prs     -- This fast path happens almost all the time     -- See Note [Cloning for type variable binders] in GHC.Tc.Gen.HsType     -- "Almost all the time" means not the case of mutual recursion with     -- polymorphic kinds.-  = do { traceTc "Skipping swizzleTcTyConBndrs for" (ppr (map fstOf3 tc_infos))+  = do { traceTc "Skipping swizzleTcTyConBndrs for" (ppr_infos tc_infos)        ; return tc_infos }    | otherwise-  = do { check_duplicate_tc_binders+  = do { checkForDuplicateScopedTyVars swizzle_prs         ; traceTc "swizzleTcTyConBndrs" $          vcat [ text "before" <+> ppr_infos tc_infos@@ -784,49 +817,19 @@        ; return swizzled_infos }    where-    swizzled_infos =  [ (tc, mapSnd swizzle_var scoped_prs, swizzle_ty kind)-                      | (tc, scoped_prs, kind) <- tc_infos ]+    swizzled_infos =  [ (tc, skol_info, mapSnd swizzle_var scoped_prs, swizzle_ty kind)+                      | (tc, skol_info, scoped_prs, kind) <- tc_infos ]      swizzle_prs :: [(Name,TyVar)]     -- Pairs the user-specified Name with its representative TyVar     -- See Note [Swizzling the tyvars before generaliseTcTyCon]-    swizzle_prs = [ pr | (_, prs, _) <- tc_infos, pr <- prs ]+    swizzle_prs = [ pr | (_, _, prs, _) <- tc_infos, pr <- prs ]      no_swizzle :: (Name,TyVar) -> Bool     no_swizzle (nm, tv) = nm == tyVarName tv      ppr_infos infos = vcat [ ppr tc <+> pprTyVars (map snd prs)-                           | (tc, prs, _) <- infos ]--    -- Check for duplicates-    -- E.g. data SameKind (a::k) (b::k)-    --      data T (a::k1) (b::k2) = MkT (SameKind a b)-    -- Here k1 and k2 start as TyVarTvs, and get unified with each other-    -- If this happens, things get very confused later, so fail fast-    check_duplicate_tc_binders :: TcM ()-    check_duplicate_tc_binders = unless (null err_prs) $-                                 do { mapM_ report_dup err_prs; failM }--    -------------- Error reporting -------------    err_prs :: [(Name,Name)]-    err_prs = [ (n1,n2)-              | pr :| prs <- findDupsEq ((==) `on` snd) swizzle_prs-              , (n1,_):(n2,_):_ <- [nubBy ((==) `on` fst) (pr:prs)] ]-              -- This nubBy avoids bogus error reports when we have-              --    [("f", f), ..., ("f",f)....] in swizzle_prs-              -- which happens with  class C f where { type T f }--    report_dup :: (Name,Name) -> TcM ()-    report_dup (n1,n2)-      = setSrcSpan (getSrcSpan n2) $ addErrTc $-        hang (text "Different names for the same type variable:") 2 info-      where-        info | nameOccName n1 /= nameOccName n2-             = quotes (ppr n1) <+> text "and" <+> quotes (ppr n2)-             | otherwise -- Same OccNames! See C2 in-                         -- Note [Swizzling the tyvars before generaliseTcTyCon]-             = vcat [ quotes (ppr n1) <+> text "bound at" <+> ppr (getSrcLoc n1)-                    , quotes (ppr n2) <+> text "bound at" <+> ppr (getSrcLoc n2) ]+                           | (tc, _, prs, _) <- infos ]      -------------- The swizzler ------------     -- This does a deep traverse, simply doing a@@ -862,8 +865,10 @@     swizzle_ty ty = runIdentity (map_type ty)  -generaliseTcTyCon :: (TcTyCon, ScopedPairs, TcKind) -> TcM TcTyCon-generaliseTcTyCon (tc, scoped_prs, tc_res_kind)+generaliseTcTyCon :: (MonoTcTyCon, SkolemInfo, ScopedPairs, TcKind) -> TcM PolyTcTyCon+generaliseTcTyCon (tc, skol_info, scoped_prs, tc_res_kind)+  -- The scoped_prs are fully zonked skolem TcTyVars+  -- And tc_res_kind is fully zonked too   -- See Note [Required, Specified, and Inferred for types]   = setSrcSpan (getSrcSpan tc) $     addTyConCtxt tc $@@ -885,7 +890,7 @@         -- Step 2b: quantify, mainly meaning skolemise the free variables        -- Returned 'inferred' are scope-sorted and skolemised-       ; inferred <- quantifyTyVars dvs2+       ; inferred <- quantifyTyVars skol_info DefaultNonStandardTyVars dvs2         ; traceTc "generaliseTcTyCon: pre zonk"            (vcat [ text "tycon =" <+> ppr tc@@ -894,21 +899,18 @@                  , text "dvs1 =" <+> ppr dvs1                  , text "inferred =" <+> pprTyVars inferred ]) -       -- Step 3: Final zonk (following kind generalisation)-       -- See Note [Swizzling the tyvars before generaliseTcTyCon]-       ; ze <- mkEmptyZonkEnv NoFlexi-       ; (ze, inferred)        <- zonkTyBndrsX      ze inferred-       ; (ze, sorted_spec_tvs) <- zonkTyBndrsX      ze sorted_spec_tvs-       ; (ze, req_tvs)         <- zonkTyBndrsX      ze req_tvs-       ; tc_res_kind           <- zonkTcTypeToTypeX ze tc_res_kind+       -- Step 3: Final zonk: quantifyTyVars may have done some defaulting+       ; inferred        <- zonkTcTyVarsToTcTyVars inferred+       ; sorted_spec_tvs <- zonkTcTyVarsToTcTyVars sorted_spec_tvs+       ; req_tvs         <- zonkTcTyVarsToTcTyVars req_tvs+       ; tc_res_kind     <- zonkTcType             tc_res_kind         ; traceTc "generaliseTcTyCon: post zonk" $          vcat [ text "tycon =" <+> ppr tc               , text "inferred =" <+> pprTyVars inferred               , text "spec_req_tvs =" <+> pprTyVars spec_req_tvs               , text "sorted_spec_tvs =" <+> pprTyVars sorted_spec_tvs-              , text "req_tvs =" <+> ppr req_tvs-              , text "zonk-env =" <+> ppr ze ]+              , text "req_tvs =" <+> ppr req_tvs ]         -- Step 4: Make the TyConBinders.        ; let dep_fv_set     = candidateKindVars dvs1@@ -917,15 +919,21 @@              required_tcbs  = map (mkRequiredTyConBinder dep_fv_set) req_tvs         -- Step 5: Assemble the final list.-             final_tcbs = concat [ inferred_tcbs-                                 , specified_tcbs-                                 , required_tcbs ]+             all_tcbs = concat [ inferred_tcbs+                               , specified_tcbs+                               , required_tcbs ]+             flav = tyConFlavour tc +       -- Eta expand+       ; (eta_tcbs, tc_res_kind) <- etaExpandAlgTyCon flav skol_info all_tcbs tc_res_kind+        -- Step 6: Make the result TcTyCon-             tycon = mkTcTyCon (tyConName tc) final_tcbs tc_res_kind-                            (mkTyVarNamePairs (sorted_spec_tvs ++ req_tvs))-                            True {- it's generalised now -}-                            (tyConFlavour tc)+       ; let final_tcbs = all_tcbs `chkAppend` eta_tcbs+             tycon = mkTcTyCon (tyConName tc)+                               final_tcbs tc_res_kind+                               (mkTyVarNamePairs (sorted_spec_tvs ++ req_tvs))+                               True {- it's generalised now -}+                               flav         ; traceTc "generaliseTcTyCon done" $          vcat [ text "tycon =" <+> ppr tc@@ -1150,7 +1158,7 @@   Here we will unify k1 with k2, but this time doing so is an error,   because k1 and k2 are bound in the same declaration. -  We spot this during validity checking (findDupTyVarTvs),+  We spot this during validity checking (checkForDuplicateScopeTyVars),   in generaliseTcTyCon.  * Required arguments.  Even the Required arguments should be made@@ -1283,7 +1291,7 @@     -- Works for family declarations too  ---------------inferInitialKinds :: [LTyClDecl GhcRn] -> TcM [TcTyCon]+inferInitialKinds :: [LTyClDecl GhcRn] -> TcM [MonoTcTyCon] -- Returns a TcTyCon for each TyCon bound by the decls, -- each with its initial kind @@ -1297,7 +1305,7 @@  -- Check type/class declarations against their standalone kind signatures or -- CUSKs, producing a generalized TcTyCon for each.-checkInitialKinds :: [(LTyClDecl GhcRn, SAKS_or_CUSK)] -> TcM [TcTyCon]+checkInitialKinds :: [(LTyClDecl GhcRn, SAKS_or_CUSK)] -> TcM [PolyTcTyCon] checkInitialKinds decls   = do { traceTc "checkInitialKinds {" $ ppr (mapFst (tcdName . unLoc) decls)        ; tcs <- concatMapM check_initial_kind decls@@ -1328,18 +1336,17 @@     (ClassDecl { tcdLName = L _ name                , tcdTyVars = ktvs                , tcdATs = ats })-  = do { cls <- kcDeclHeader strategy name ClassFlavour ktvs $+  = do { cls_tc <- kcDeclHeader strategy name ClassFlavour ktvs $                 return (TheKind constraintKind)-       ; let parent_tv_prs = tcTyConScopedTyVars cls             -- See Note [Don't process associated types in getInitialKind]-       ; inner_tcs <--           tcExtendNameTyVarEnv parent_tv_prs $-           mapM (addLocMA (getAssocFamInitialKind cls)) ats-       ; return (cls : inner_tcs) }++       ; at_tcs <- tcExtendTyVarEnv (tyConTyVars cls_tc) $+                      mapM (addLocMA (getAssocFamInitialKind cls_tc)) ats+       ; return (cls_tc : at_tcs) }   where     getAssocFamInitialKind cls =       case strategy of-        InitialKindInfer -> get_fam_decl_initial_kind (Just cls)+        InitialKindInfer   -> get_fam_decl_initial_kind (Just cls)         InitialKindCheck _ -> check_initial_kind_assoc_fam cls  getInitialKind strategy@@ -1519,7 +1526,7 @@   case info of     DataFamily         -> DataFamilyFlavour mb_parent_tycon     OpenTypeFamily     -> OpenTypeFamilyFlavour mb_parent_tycon-    ClosedTypeFamily _ -> ASSERT( isNothing mb_parent_tycon ) -- See Note [Closed type family mb_parent_tycon]+    ClosedTypeFamily _ -> assert (isNothing mb_parent_tycon) -- See Note [Closed type family mb_parent_tycon]                           ClosedTypeFamilyFlavour  {- Note [Closed type family mb_parent_tycon]@@ -1539,7 +1546,7 @@   -- Called only for declarations without a signature (no CUSKs or SAKs here) kcLTyClDecl (L loc decl)   = setSrcSpanA loc $-    do { tycon <- tcLookupTcTyCon tc_name+    do { tycon <- tcLookupTcTyCon tc_name   -- Always a MonoTcTyCon        ; traceTc "kcTyClDecl {" (ppr tc_name)        ; addVDQNote tycon $   -- See Note [Inferring visible dependent quantification]          addErrCtxt (tcMkDeclCtxt decl) $@@ -1548,15 +1555,21 @@   where     tc_name = tcdName decl -kcTyClDecl :: TyClDecl GhcRn -> TcTyCon -> TcM ()+kcTyClDecl :: TyClDecl GhcRn -> MonoTcTyCon -> TcM () -- This function is used solely for its side effect on kind variables -- NB kind signatures on the type variables and --    result kind signature have already been dealt with --    by inferInitialKind, so we can ignore them here. -kcTyClDecl (DataDecl { tcdLName    = (L _ name), tcdDataDefn = defn }) tycon+-- NB these equations just extend the type environment with carefully constructed+-- TcTyVars rather than create skolemised variables for the bound variables.+-- - inferInitialKinds makes the TcTyCon where the  tyvars are TcTyVars+-- - In this function, those TcTyVars are unified with other kind variables during+--   kind inference (see [How TcTyCons work])++kcTyClDecl (DataDecl { tcdLName    = (L _ _name), tcdDataDefn = defn }) tycon   | HsDataDefn { dd_ctxt = ctxt, dd_cons = cons, dd_ND = new_or_data } <- defn-  = bindTyClTyVars name $ \ _ _ _ ->+  = tcExtendNameTyVarEnv (tcTyConScopedTyVars tycon) $        -- NB: binding these tyvars isn't necessary for GADTs, but it does no        -- harm.  For GADTs, each data con brings its own tyvars into scope,        -- and the ones from this bindTyClTyVars are either not mentioned or@@ -1566,15 +1579,16 @@        ; kcConDecls new_or_data (tyConResKind tycon) cons        } -kcTyClDecl (SynDecl { tcdLName = L _ name, tcdRhs = rhs }) _tycon-  = bindTyClTyVars name $ \ _ _ res_kind ->-    discardResult $ tcCheckLHsType rhs (TheKind res_kind)+kcTyClDecl (SynDecl { tcdLName = L _ _name, tcdRhs = rhs }) tycon+  = tcExtendNameTyVarEnv (tcTyConScopedTyVars tycon) $+    let res_kind = tyConResKind tycon+    in discardResult $ tcCheckLHsType rhs (TheKind res_kind)         -- NB: check against the result kind that we allocated         -- in inferInitialKinds. -kcTyClDecl (ClassDecl { tcdLName = L _ name-                      , tcdCtxt = ctxt, tcdSigs = sigs }) _tycon-  = bindTyClTyVars name $ \ _ _ _ ->+kcTyClDecl (ClassDecl { tcdLName = L _ _name+                      , tcdCtxt = ctxt, tcdSigs = sigs }) tycon+  = tcExtendNameTyVarEnv (tcTyConScopedTyVars tycon) $     do  { _ <- tcHsContext ctxt         ; mapM_ (wrapLocMA_ kc_sig) sigs }   where@@ -1594,7 +1608,7 @@ -- This includes doing kind unification if the type is a newtype. -- See Note [Implementation of UnliftedNewtypes] for why we need -- the first two arguments.-kcConArgTys :: NewOrData -> Kind -> [HsScaled GhcRn (LHsType GhcRn)] -> TcM ()+kcConArgTys :: NewOrData -> TcKind -> [HsScaled GhcRn (LHsType GhcRn)] -> TcM () kcConArgTys new_or_data res_kind arg_tys = do   { let exp_kind = getArgExpKind new_or_data res_kind   ; forM_ arg_tys (\(HsScaled mult ty) -> do _ <- tcCheckLHsType (getBangType ty) exp_kind@@ -1603,7 +1617,7 @@   }  -- Kind-check the types of arguments to a Haskell98 data constructor.-kcConH98Args :: NewOrData -> Kind -> HsConDeclH98Details GhcRn -> TcM ()+kcConH98Args :: NewOrData -> TcKind -> HsConDeclH98Details GhcRn -> TcM () kcConH98Args new_or_data res_kind con_args = case con_args of   PrefixCon _ tys   -> kcConArgTys new_or_data res_kind tys   InfixCon ty1 ty2  -> kcConArgTys new_or_data res_kind [ty1, ty2]@@ -1611,14 +1625,14 @@                        map (hsLinear . cd_fld_type . unLoc) flds  -- Kind-check the types of arguments to a GADT data constructor.-kcConGADTArgs :: NewOrData -> Kind -> HsConDeclGADTDetails GhcRn -> TcM ()+kcConGADTArgs :: NewOrData -> TcKind -> HsConDeclGADTDetails GhcRn -> TcM () kcConGADTArgs new_or_data res_kind con_args = case con_args of-  PrefixConGADT tys     -> kcConArgTys new_or_data res_kind tys-  RecConGADT (L _ flds) -> kcConArgTys new_or_data res_kind $-                           map (hsLinear . cd_fld_type . unLoc) flds+  PrefixConGADT tys     ->   kcConArgTys new_or_data res_kind tys+  RecConGADT (L _ flds) _ -> kcConArgTys new_or_data res_kind $+                             map (hsLinear . cd_fld_type . unLoc) flds  kcConDecls :: NewOrData-           -> Kind             -- The result kind signature+           -> TcKind             -- The result kind signature                                --   Used only in H98 case            -> [LConDecl GhcRn] -- The data constructors            -> TcM ()@@ -1632,7 +1646,7 @@ -- this type. See Note [Implementation of UnliftedNewtypes] for why -- we need the first two arguments. kcConDecl :: NewOrData-          -> Kind  -- Result kind of the type constructor+          -> TcKind  -- Result kind of the type constructor                    -- Usually Type but can be TYPE UnliftedRep                    -- or even TYPE r, in the case of unlifted newtype                    -- Used only in H98 case@@ -1658,6 +1672,7 @@   = -- See Note [kcConDecls: kind-checking data type decls]     addErrCtxt (dataConCtxt names) $     discardResult                      $+    -- Not sure this is right, should just extend rather than skolemise but no test     bindOuterSigTKBndrs_Tv outer_bndrs $         -- Why "_Tv"?  See Note [Using TyVarTvs for kind-checking GADTs]     do { _ <- tcHsContext cxt@@ -2159,7 +2174,7 @@  Note that, in the GADT case, we might have a kind signature with arrows (newtype XYZ a b :: Type -> Type where ...). We want only the final-component of the kind for checking in kcConDecl, so we call etaExpandAlgTyCon+component of the kind for checking in kcConDecl, so we call etaExpanAlgTyCon in kcTyClDecl.  STEP 3: Type-checking (desugaring), as done by tcTyClDecl. The key function@@ -2362,7 +2377,7 @@ tcTyClDecl1 _parent roles_info             (SynDecl { tcdLName = L _ tc_name                      , tcdRhs   = rhs })-  = ASSERT( isNothing _parent )+  = assert (isNothing _parent )     fmap noDerivInfos $     tcTySynRhs roles_info tc_name rhs @@ -2370,7 +2385,7 @@ tcTyClDecl1 _parent roles_info             decl@(DataDecl { tcdLName = L _ tc_name                            , tcdDataDefn = defn })-  = ASSERT( isNothing _parent )+  = assert (isNothing _parent) $     tcDataDefn (tcMkDeclCtxt decl) roles_info tc_name defn  tcTyClDecl1 _parent roles_info@@ -2381,7 +2396,7 @@                        , tcdSigs = sigs                        , tcdATs = ats                        , tcdATDefs = at_defs })-  = ASSERT( isNothing _parent )+  = assert (isNothing _parent) $     do { clas <- tcClassDecl1 roles_info class_name hs_ctxt                               meths fundeps sigs ats at_defs        ; return (noDerivInfos (classTyCon clas)) }@@ -2398,16 +2413,15 @@              -> [LFamilyDecl GhcRn] -> [LTyFamDefltDecl GhcRn]              -> TcM Class tcClassDecl1 roles_info class_name hs_ctxt meths fundeps sigs ats at_defs-  = fixM $ \ clas ->-    -- We need the knot because 'clas' is passed into tcClassATs-    bindTyClTyVars class_name $ \ _ binders res_kind ->+  = fixM $ \ clas -> -- We need the knot because 'clas' is passed into tcClassATs+    bindTyClTyVars class_name $ \ binders res_kind ->     do { checkClassKindSig res_kind        ; traceTc "tcClassDecl 1" (ppr class_name $$ ppr binders)        ; let tycon_name = class_name        -- We use the same name              roles = roles_info tycon_name  -- for TyCon and Class         ; (ctxt, fds, sig_stuff, at_stuff)-            <- pushLevelAndSolveEqualities skol_info (binderVars binders) $+            <- pushLevelAndSolveEqualities skol_info binders $                -- The (binderVars binders) is needed bring into scope the                -- skolems bound by the class decl header (#17841)                do { ctxt <- tcHsContext hs_ctxt@@ -2444,7 +2458,15 @@         ; mindef <- tcClassMinimalDef class_name sigs sig_stuff        ; is_boot <- tcIsHsBootOrSig-       ; let body | is_boot, null ctxt, null at_stuff, null sig_stuff+       ; let body | is_boot, isNothing hs_ctxt, null at_stuff, null sig_stuff+                  -- We use @isNothing hs_ctxt@ rather than @null ctxt@,+                  -- so that a declaration in an hs-boot file such as:+                  --+                  -- class () => C a b | a -> b+                  --+                  -- is not considered abstract; it's sometimes useful+                  -- to be able to declare such empty classes in hs-boot files.+                  -- See #20661.                   = Nothing                   | otherwise                   = Just (ctxt, at_stuff, sig_stuff, mindef)@@ -2455,6 +2477,7 @@        ; return clas }   where     skol_info = TyConSkol ClassFlavour class_name+     tc_fundep :: GHC.Hs.FunDep GhcRn -> TcM ([Var],[Var])     tc_fundep (FunDep _ tvs1 tvs2)                            = do { tvs1' <- mapM (tcLookupTyVar . unLoc) tvs1 ;@@ -2483,7 +2506,7 @@            -> TcM [ClassATItem] tcClassATs class_name cls ats at_defs   = do {  -- Complain about associated type defaults for non associated-types-         sequence_ [ failWithTc (badATErr class_name n)+         sequence_ [ failWithTc (TcRnBadAssociatedType class_name n)                    | n <- map at_def_tycon at_defs                    , not (n `elemNameSet` at_names) ]        ; mapM tc_at ats }@@ -2517,7 +2540,8 @@   = return Nothing  -- No default declaration  tcDefaultAssocDecl _ (d1:_:_)-  = failWithTc (text "More than one default declaration for"+  = failWithTc (TcRnUnknownMessage $ mkPlainError noHints $+                text "More than one default declaration for"                 <+> ppr (tyFamInstDeclName (unLoc d1)))  tcDefaultAssocDecl fam_tc@@ -2535,7 +2559,7 @@              vis_pats  = numVisibleArgs hs_pats         -- Kind of family check-       ; ASSERT( fam_tc_name == tc_name )+       ; assert (fam_tc_name == tc_name) $          checkTc (isTypeFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc)         -- Arity check@@ -2677,8 +2701,8 @@                               , fdResultSig = L _ sig                               , fdInjectivityAnn = inj })   | DataFamily <- fam_info-  = bindTyClTyVars tc_name $ \ _ binders res_kind -> do-  { traceTc "data family:" (ppr tc_name)+  = bindTyClTyVarsAndZonk tc_name $ \ binders res_kind -> do+  { traceTc "tcFamDecl1 data family:" (ppr tc_name)   ; checkFamFlag tc_name    -- Check that the result kind is OK@@ -2703,8 +2727,8 @@   ; return tycon }    | OpenTypeFamily <- fam_info-  = bindTyClTyVars tc_name $ \ _ binders res_kind -> do-  { traceTc "open type family:" (ppr tc_name)+  = bindTyClTyVarsAndZonk tc_name $ \ binders res_kind -> do+  { traceTc "tcFamDecl1 open type family:" (ppr tc_name)   ; checkFamFlag tc_name   ; inj' <- tcInjectivity binders inj   ; checkResultSigFlag tc_name sig  -- check after injectivity for better errors@@ -2716,11 +2740,11 @@   | ClosedTypeFamily mb_eqns <- fam_info   = -- Closed type families are a little tricky, because they contain the definition     -- of both the type family and the equations for a CoAxiom.-    do { traceTc "Closed type family:" (ppr tc_name)+    do { traceTc "tcFamDecl1 Closed type family:" (ppr tc_name)          -- the variables in the header scope only over the injectivity          -- declaration but this is not involved here        ; (inj', binders, res_kind)-            <- bindTyClTyVars tc_name $ \ _ binders res_kind ->+            <- bindTyClTyVarsAndZonk tc_name $ \ binders res_kind ->                do { inj' <- tcInjectivity binders inj                   ; return (inj', binders, res_kind) } @@ -2799,14 +2823,15 @@   -- But this does not seem to be useful in any way so we don't do it.  (Another   -- reason is that the implementation would not be straightforward.) tcInjectivity tcbs (Just (L loc (InjectivityAnn _ _ lInjNames)))-  = setSrcSpan loc $+  = setSrcSpanA loc $     do { let tvs = binderVars tcbs        ; dflags <- getDynFlags        ; checkTc (xopt LangExt.TypeFamilyDependencies dflags)-                 (text "Illegal injectivity annotation" $$+                 (TcRnUnknownMessage $ mkPlainError noHints $+                  text "Illegal injectivity annotation" $$                   text "Use TypeFamilyDependencies to allow this")        ; inj_tvs <- mapM (tcLookupTyVar . unLoc) lInjNames-       ; inj_tvs <- mapM zonkTcTyVarToTyVar inj_tvs -- zonk the kinds+       ; inj_tvs <- zonkTcTyVarsToTcTyVars inj_tvs -- zonk the kinds        ; let inj_ktvs = filterVarSet isTyVar $  -- no injective coercion vars                         closeOverKinds (mkVarSet inj_tvs)        ; let inj_bools = map (`elemVarSet` inj_ktvs) tvs@@ -2817,10 +2842,10 @@ tcTySynRhs :: RolesInfo -> Name            -> LHsType GhcRn -> TcM TyCon tcTySynRhs roles_info tc_name hs_ty-  = bindTyClTyVars tc_name $ \ _ binders res_kind ->+  = bindTyClTyVars tc_name $ \ binders res_kind ->     do { env <- getLclEnv        ; traceTc "tc-syn" (ppr tc_name $$ ppr (tcl_env env))-       ; rhs_ty <- pushLevelAndSolveEqualities skol_info (binderVars binders) $+       ; rhs_ty <- pushLevelAndSolveEqualities skol_info binders $                    tcCheckLHsType hs_ty (TheKind res_kind)           -- See Note [Error on unconstrained meta-variables] in GHC.Tc.Utils.TcMType@@ -2834,8 +2859,9 @@                                                  , ppr rhs_ty ] ) }        ; doNotQuantifyTyVars dvs mk_doc -       ; ze <- mkEmptyZonkEnv NoFlexi-       ; rhs_ty <- zonkTcTypeToTypeX ze rhs_ty+       ; ze            <- mkEmptyZonkEnv NoFlexi+       ; (ze, binders) <- zonkTyVarBindersX ze binders+       ; rhs_ty        <- zonkTcTypeToTypeX ze rhs_ty        ; let roles = roles_info tc_name        ; return (buildSynTyCon tc_name binders res_kind roles rhs_ty) }   where@@ -2851,26 +2877,20 @@                                                -- via inferInitialKinds                        , dd_cons = cons                        , dd_derivs = derivs })-  = bindTyClTyVars tc_name $ \ tctc tycon_binders res_kind ->-       -- 'tctc' is a 'TcTyCon' and has the 'tcTyConScopedTyVars' that we need-       -- unlike the finalized 'tycon' defined above which is an 'AlgTyCon'-       --+  = bindTyClTyVars tc_name $ \ tc_bndrs res_kind ->        -- The TyCon tyvars must scope over        --    - the stupid theta (dd_ctxt)        --    - for H98 constructors only, the ConDecl        -- But it does no harm to bring them into scope        -- over GADT ConDecls as well; and it's awkward not to     do { gadt_syntax <- dataDeclChecks tc_name new_or_data ctxt cons-         -- see Note [Datatype return kinds]-       ; (extra_bndrs, final_res_kind) <- etaExpandAlgTyCon tycon_binders res_kind         ; tcg_env <- getGblEnv        ; let hsc_src = tcg_src tcg_env        ; unless (mk_permissive_kind hsc_src cons) $-         checkDataKindSig (DataDeclSort new_or_data) final_res_kind+         checkDataKindSig (DataDeclSort new_or_data) res_kind -       ; let skol_tvs = binderVars tycon_binders-       ; stupid_tc_theta <- pushLevelAndSolveEqualities skol_info skol_tvs $+       ; stupid_tc_theta <- pushLevelAndSolveEqualities skol_info tc_bndrs $                             tcHsContext ctxt         -- See Note [Error on unconstrained meta-variables] in GHC.Tc.Utils.TcMType@@ -2885,36 +2905,39 @@                                    , pprTheta theta ] ) }        ; doNotQuantifyTyVars dvs mk_doc -       ; ze              <- mkEmptyZonkEnv NoFlexi-       ; stupid_theta    <- zonkTcTypesToTypesX ze stupid_tc_theta-              -- Check that we don't use kind signatures without the extension        ; kind_signatures <- xoptM LangExt.KindSignatures        ; when (isJust mb_ksig) $          checkTc (kind_signatures) (badSigTyDecl tc_name) +       ; ze             <- mkEmptyZonkEnv NoFlexi+       ; (ze, bndrs)    <- zonkTyVarBindersX   ze tc_bndrs+       ; stupid_theta   <- zonkTcTypesToTypesX ze stupid_tc_theta+       ; res_kind       <- zonkTcTypeToTypeX   ze res_kind+        ; tycon <- fixM $ \ rec_tycon -> do-             { let final_bndrs = tycon_binders `chkAppend` extra_bndrs-                   roles       = roles_info tc_name-             ; data_cons <- tcConDecls-                              new_or_data DDataType-                              rec_tycon final_bndrs final_res_kind-                              cons+             { data_cons <- tcConDecls new_or_data DDataType rec_tycon+                                       tc_bndrs res_kind cons              ; tc_rhs    <- mk_tc_rhs hsc_src rec_tycon data_cons              ; tc_rep_nm <- newTyConRepName tc_name+              ; return (mkAlgTyCon tc_name-                                  final_bndrs-                                  final_res_kind-                                  roles+                                  bndrs+                                  res_kind+                                  (roles_info tc_name)                                   (fmap unLoc cType)                                   stupid_theta tc_rhs                                   (VanillaAlgTyCon tc_rep_nm)-                                  gadt_syntax) }-       ; let deriv_info = DerivInfo { di_rep_tc = tycon-                                    , di_scoped_tvs = tcTyConScopedTyVars tctc+                                  gadt_syntax)+         }++       ; let scoped_tvs = mkTyVarNamePairs (binderVars tc_bndrs)+                          -- scoped_tvs: still the skolem TcTyVars+             deriv_info = DerivInfo { di_rep_tc = tycon+                                    , di_scoped_tvs = scoped_tvs                                     , di_clauses = derivs                                     , di_ctxt = err_ctxt }-       ; traceTc "tcDataDefn" (ppr tc_name $$ ppr tycon_binders $$ ppr extra_bndrs)+       ; traceTc "tcDataDefn" (ppr tc_name $$ ppr tc_bndrs)        ; return (tycon, [deriv_info]) }   where     skol_info = TyConSkol flav tc_name@@ -2931,21 +2954,21 @@     mk_permissive_kind HsigFile [] = True     mk_permissive_kind _ _ = False -    -- In hs-boot, a 'data' declaration with no constructors+    -- In an hs-boot or a signature file,+    -- a 'data' declaration with no constructors     -- indicates a nominally distinct abstract data type.-    mk_tc_rhs HsBootFile _ []-      = return AbstractTyCon--    mk_tc_rhs HsigFile _ [] -- ditto+    mk_tc_rhs (isHsBootOrSig -> True) _ []       = return AbstractTyCon      mk_tc_rhs _ tycon data_cons       = case new_or_data of-          DataType -> return (mkDataTyConRhs data_cons)-          NewType  -> ASSERT( not (null data_cons) )+          DataType -> return $+                        mkLevPolyDataTyConRhs+                          (isFixedRuntimeRepKind (tyConResKind tycon))+                          data_cons+          NewType  -> assert (not (null data_cons)) $                       mkNewTyConRhs tc_name tycon (head data_cons) - ------------------------- kcTyFamInstEqn :: TcTyCon -> LTyFamInstEqn GhcRn -> TcM () -- Used for the equations of a closed type family only@@ -3060,7 +3083,7 @@  So, we use bindOuterFamEqnTKBndrs (which does not create an implication for the telescope), and generalise over /all/ the variables in the LHS,-without treating the explicitly-quanfitifed ones specially. Wrinkles:+without treating the explicitly-quantifed ones specially. Wrinkles:   - When generalising, include the explicit user-specified forall'd    variables, so that we get an error from Validity.checkFamPatBinders@@ -3091,16 +3114,17 @@                    -> TcM ([TyVar], [TcType], TcType)   -- (tyvars, pats, rhs) -- Used only for type families, not data families tcTyFamInstEqnGuts fam_tc mb_clsinfo outer_hs_bndrs hs_pats hs_rhs_ty-  = do { traceTc "tcTyFamInstEqnGuts {" (ppr fam_tc)+  = do { traceTc "tcTyFamInstEqnGuts {" (ppr fam_tc $$ ppr outer_hs_bndrs $$ ppr hs_pats)         -- By now, for type families (but not data families) we should        -- have checked that the number of patterns matches tyConArity+       ; skol_info <- mkSkolemInfo FamInstSkol         -- This code is closely related to the code        -- in GHC.Tc.Gen.HsType.kcCheckDeclHeader_cusk-       ; (tclvl, wanted, (outer_tvs, (lhs_ty, rhs_ty)))+       ; (tclvl, wanted, (outer_bndrs, (lhs_ty, rhs_ty)))                <- pushLevelAndSolveEqualitiesX "tcTyFamInstEqnGuts" $-                  bindOuterFamEqnTKBndrs outer_hs_bndrs             $+                  bindOuterFamEqnTKBndrs skol_info outer_hs_bndrs   $                   do { (lhs_ty, rhs_kind) <- tcFamTyPats fam_tc hs_pats                        -- Ensure that the instance is consistent with its                        -- parent class (#16008)@@ -3108,6 +3132,12 @@                      ; rhs_ty <- tcCheckLHsType hs_rhs_ty (TheKind rhs_kind)                      ; return (lhs_ty, rhs_ty) } +       ; outer_bndrs <- scopedSortOuter outer_bndrs+       ; let outer_tvs = outerTyVars outer_bndrs+       ; checkFamTelescope tclvl outer_hs_bndrs outer_tvs++       ; traceTc "tcTyFamInstEqnGuts 1" (pprTyVars outer_tvs $$ ppr skol_info)+        -- This code (and the stuff immediately above) is very similar        -- to that in tcDataFamInstHeader.  Maybe we should abstract the        -- common code; but for the moment I concluded that it's@@ -3115,15 +3145,17 @@        -- check there too!         -- See Note [Generalising in tcTyFamInstEqnGuts]-       ; dvs  <- candidateQTyVarsOfTypes (lhs_ty : mkTyVarTys outer_tvs)-       ; qtvs <- quantifyTyVars dvs-       ; reportUnsolvedEqualities FamInstSkol qtvs tclvl wanted-       ; checkFamTelescope tclvl outer_hs_bndrs outer_tvs+       ; dvs  <- candidateQTyVarsWithBinders outer_tvs lhs_ty+       ; qtvs <- quantifyTyVars skol_info TryNotToDefaultNonStandardTyVars dvs+       ; let final_tvs = scopedSort (qtvs ++ outer_tvs)+             -- This scopedSort is important: the qtvs may be /interleaved/ with+             -- the outer_tvs.  See Note [Generalising in tcTyFamInstEqnGuts]+       ; reportUnsolvedEqualities skol_info final_tvs tclvl wanted         ; traceTc "tcTyFamInstEqnGuts 2" $          vcat [ ppr fam_tc-              , text "lhs_ty"     <+> ppr lhs_ty-              , text "qtvs"       <+> pprTyVars qtvs ]+              , text "lhs_ty:"    <+> ppr lhs_ty+              , text "final_tvs:" <+> pprTyVars final_tvs ]         -- See Note [Error on unconstrained meta-variables] in GHC.Tc.Utils.TcMType        -- Example: typecheck/should_fail/T17301@@ -3135,20 +3167,24 @@                                    , ppr rhs_ty ] ) }        ; doNotQuantifyTyVars dvs_rhs mk_doc -       ; ze         <- mkEmptyZonkEnv NoFlexi-       ; (ze, qtvs) <- zonkTyBndrsX      ze qtvs-       ; lhs_ty     <- zonkTcTypeToTypeX ze lhs_ty-       ; rhs_ty     <- zonkTcTypeToTypeX ze rhs_ty+       ; ze              <- mkEmptyZonkEnv NoFlexi+       ; (ze, final_tvs) <- zonkTyBndrsX      ze final_tvs+       ; lhs_ty          <- zonkTcTypeToTypeX ze lhs_ty+       ; rhs_ty          <- zonkTcTypeToTypeX ze rhs_ty         ; let pats = unravelFamInstPats lhs_ty              -- Note that we do this after solveEqualities              -- so that any strange coercions inside lhs_ty              -- have been solved before we attempt to unravel it-       ; traceTc "tcTyFamInstEqnGuts }" (ppr fam_tc <+> pprTyVars qtvs)-       ; return (qtvs, pats, rhs_ty) } +       ; traceTc "tcTyFamInstEqnGuts }" (vcat [ ppr fam_tc, pprTyVars final_tvs ])+                 -- Don't try to print 'pats' here, because lhs_ty involves+                 -- a knot-tied type constructor, so we get a black hole -checkFamTelescope :: TcLevel -> HsOuterFamEqnTyVarBndrs GhcRn+       ; return (final_tvs, pats, rhs_ty) }++checkFamTelescope :: TcLevel+                  -> HsOuterFamEqnTyVarBndrs GhcRn                   -> [TcTyVar] -> TcM () -- Emit a constraint (forall a b c. <empty>), so that -- we will do telescope-checking on a,b,c@@ -3157,9 +3193,9 @@   | HsOuterExplicit { hso_bndrs = bndrs } <- hs_outer_bndrs   , (b_first : _) <- bndrs   , let b_last    = last bndrs-        skol_info = ForAllSkol (fsep (map ppr bndrs))-  = setSrcSpan (combineSrcSpans (getLocA b_first) (getLocA b_last)) $-    emitResidualTvConstraint skol_info outer_tvs tclvl emptyWC+  = do { skol_info <- mkSkolemInfo (ForAllSkol $ HsTyVarBndrsRn (map unLoc bndrs))+       ; setSrcSpan (combineSrcSpans (getLocA b_first) (getLocA b_last)) $ do+         emitResidualTvConstraint skol_info outer_tvs tclvl emptyWC }   | otherwise   = return () @@ -3168,11 +3204,11 @@ -- Decompose fam_app to get the argument patterns -- -- We expect fam_app to look like (F t1 .. tn)--- tcFamTyPats is capable of returning ((F ty1 |> co) ty2),--- but that can't happen here because we already checked the--- arity of F matches the number of pattern+--   tcFamTyPats is capable of returning ((F ty1 |> co) ty2),+--   but that can't happen here because we already checked the+--   arity of F matches the number of pattern unravelFamInstPats fam_app-  = case splitTyConApp_maybe fam_app of+  = case tcSplitTyConApp_maybe fam_app of       Just (_, pats) -> pats       Nothing -> panic "unravelFamInstPats: Ill-typed LHS of family instance"         -- The Nothing case cannot happen for type families, because@@ -3188,11 +3224,6 @@ --             F c x y a :: Type -- Here the first  arg of F should be the same as the third of C --  and the fourth arg of F should be the same as the first of C------ We emit /Derived/ constraints (a bit like fundeps) to encourage--- unification to happen, but without actually reporting errors.--- If, despite the efforts, corresponding positions do not match,--- checkConsistentFamInst will complain addConsistencyConstraints mb_clsinfo fam_app   | InClsInst { ai_inst_env = inst_env } <- mb_clsinfo   , Just (fam_tc, pats) <- tcSplitTyConApp_maybe fam_app@@ -3200,8 +3231,9 @@                    | (fam_tc_tv, pat) <- tyConTyVars fam_tc `zip` pats                    , Just cls_ty <- [lookupVarEnv inst_env fam_tc_tv] ]        ; traceTc "addConsistencyConstraints" (ppr eqs)-       ; emitDerivedEqs AssocFamPatOrigin eqs }-    -- Improve inference+       ; emitWantedEqs AssocFamPatOrigin eqs }+    -- Improve inference; these equalities will not produce errors.+    -- See Note [Constraints to ignore] in GHC.Tc.Errors     -- Any mis-match is reports by checkConsistentFamInst   | otherwise   = return ()@@ -3288,7 +3320,8 @@        ; let gadt_syntax = consUseGadtSyntax cons        ; checkTc (gadtSyntax_ok || not gadt_syntax) (badGadtDecl tc_name) -           -- Check that the stupid theta is empty for a GADT-style declaration+           -- Check that the stupid theta is empty for a GADT-style declaration.+           -- See Note [The stupid context] in GHC.Core.DataCon.        ; checkTc (null stupid_theta || not gadt_syntax) (badStupidTheta tc_name)           -- Check that a newtype has exactly one constructor@@ -3328,7 +3361,7 @@ tcConDecls :: NewOrData            -> DataDeclInfo            -> KnotTied TyCon            -- Representation TyCon-           -> [TyConBinder]             -- Binders of representation TyCon+           -> [TcTyConBinder]           -- Binders of representation TyCon            -> TcKind                    -- Result kind            -> [LConDecl GhcRn] -> TcM [DataCon] tcConDecls new_or_data dd_info rep_tycon tmpl_bndrs res_kind@@ -3341,7 +3374,7 @@ tcConDecl :: NewOrData           -> DataDeclInfo           -> KnotTied TyCon   -- Representation tycon. Knot-tied!-          -> [TyConBinder]    -- Binders of representation TyCon+          -> [TcTyConBinder]  -- Binders of representation TyCon           -> TcKind           -- Result kind           -> NameEnv ConTag           -> ConDecl GhcRn@@ -3361,11 +3394,14 @@          --      hs_qvars = HsQTvs { hsq_implicit = {k}          --                        , hsq_explicit = {f,b} } -       ; traceTc "tcConDecl 1" (vcat [ ppr name, ppr explicit_tkv_nms ])+       ; traceTc "tcConDecl 1" (vcat [ ppr name+                                     , text "explicit_tkv_nms" <+> ppr explicit_tkv_nms+                                     , text "tc_bndrs" <+> ppr tc_bndrs ])+       ; skol_info <- mkSkolemInfo (ForAllSkol (HsTyVarBndrsRn (unLoc <$> explicit_tkv_nms)))         ; (tclvl, wanted, (exp_tvbndrs, (ctxt, arg_tys, field_lbls, stricts)))            <- pushLevelAndSolveEqualitiesX "tcConDecl:H98"  $-              tcExplicitTKBndrs explicit_tkv_nms            $+              tcExplicitTKBndrs skol_info explicit_tkv_nms  $               do { ctxt <- tcHsContext hs_ctxt                  ; let exp_kind = getArgExpKind new_or_data res_kind                  ; btys <- tcConH98Args exp_kind hs_args@@ -3392,10 +3428,10 @@          -- the kvs below are those kind variables entirely unmentioned by the user          --   and discovered only by generalization -       ; kvs <- kindGeneralizeAll fake_ty+       ; kvs <- kindGeneralizeAll skol_info fake_ty -       ; let skol_tvs = tc_tvs ++ kvs ++ binderVars exp_tvbndrs-       ; reportUnsolvedEqualities skol_info skol_tvs tclvl wanted+       ; let all_skol_tvs = tc_tvs ++ kvs+       ; reportUnsolvedEqualities skol_info all_skol_tvs tclvl wanted              -- The skol_info claims that all the variables are bound              -- by the data constructor decl, whereas actually the              -- univ_tvs are bound by the data type decl itself.  It@@ -3404,16 +3440,17 @@              -- See test dependent/should_fail/T13780a         -- Zonk to Types-       ; ze                  <- mkEmptyZonkEnv NoFlexi-       ; (ze, qkvs)          <- zonkTyBndrsX              ze kvs-       ; (ze, user_qtvbndrs) <- zonkTyVarBindersX         ze exp_tvbndrs-       ; arg_tys             <- zonkScaledTcTypesToTypesX ze arg_tys-       ; ctxt                <- zonkTcTypesToTypesX       ze ctxt+       ; ze                <- mkEmptyZonkEnv NoFlexi+       ; (ze, tc_bndrs)    <- zonkTyVarBindersX         ze tc_bndrs+       ; (ze, kvs)         <- zonkTyBndrsX              ze kvs+       ; (ze, exp_tvbndrs) <- zonkTyVarBindersX         ze exp_tvbndrs+       ; arg_tys           <- zonkScaledTcTypesToTypesX ze arg_tys+       ; ctxt              <- zonkTcTypesToTypesX       ze ctxt         -- Can't print univ_tvs, arg_tys etc, because we are inside the knot here        ; traceTc "tcConDecl 2" (ppr name $$ ppr field_lbls)        ; let univ_tvbs = tyConInvisTVBinders tc_bndrs-             ex_tvbs   = mkTyVarBinders InferredSpec qkvs ++ user_qtvbndrs+             ex_tvbs   = mkTyVarBinders InferredSpec kvs ++ exp_tvbndrs              ex_tvs    = binderVars ex_tvbs                 -- For H98 datatypes, the user-written tyvar binders are precisely                 -- the universals followed by the existentials.@@ -3425,8 +3462,10 @@        ; is_infix <- tcConIsInfixH98 name hs_args        ; rep_nm   <- newTyConRepName name        ; fam_envs <- tcGetFamInstEnvs-       ; dc <- buildDataCon fam_envs name is_infix rep_nm-                            stricts Nothing field_lbls+       ; dflags   <- getDynFlags+       ; let bang_opts = SrcBangOpts (initBangOpts dflags)+       ; dc <- buildDataCon fam_envs bang_opts name is_infix rep_nm+                            stricts field_lbls                             tc_tvs ex_tvs user_tvbs                             [{- no eq_preds -}] ctxt arg_tys                             user_res_ty rep_tycon tag_map@@ -3435,8 +3474,6 @@                   --      that way checkValidDataCon can complain if it's wrong.         ; return [dc] }-  where-    skol_info = DataConSkol name  tcConDecl new_or_data dd_info rep_tycon tc_bndrs _res_kind tag_map   -- NB: don't use res_kind here, as it's ill-scoped. Instead,@@ -3448,7 +3485,7 @@   = addErrCtxt (dataConCtxt names) $     do { traceTc "tcConDecl 1 gadt" (ppr names)        ; let (L _ name : _) = names-+       ; skol_info <- mkSkolemInfo (DataConSkol name)        ; (tclvl, wanted, (outer_bndrs, (ctxt, arg_tys, res_ty, field_lbls, stricts)))            <- pushLevelAndSolveEqualitiesX "tcConDecl:GADT" $               tcOuterTKBndrs skol_info outer_hs_bndrs       $@@ -3478,12 +3515,14 @@                  ; return (ctxt, arg_tys, res_ty, field_lbls, stricts)                  } -       ; outer_tv_bndrs <- scopedSortOuter outer_bndrs+       ; outer_bndrs <- scopedSortOuter outer_bndrs+       ; let outer_tv_bndrs = outerTyVarBndrs outer_bndrs -       ; tkvs <- kindGeneralizeAll (mkInvisForAllTys outer_tv_bndrs $-                                    mkPhiTy ctxt $-                                    mkVisFunTys arg_tys $-                                    res_ty)+       ; tkvs <- kindGeneralizeAll skol_info+                    (mkInvisForAllTys outer_tv_bndrs $+                     mkPhiTy ctxt                    $+                     mkVisFunTys arg_tys             $+                     res_ty)        ; traceTc "tcConDecl:GADT" (ppr names $$ ppr res_ty $$ ppr tkvs)        ; reportUnsolvedEqualities skol_info tkvs tclvl wanted @@ -3508,14 +3547,15 @@        -- Can't print univ_tvs, arg_tys etc, because we are inside the knot here        ; traceTc "tcConDecl 2" (ppr names $$ ppr field_lbls)        ; fam_envs <- tcGetFamInstEnvs+       ; dflags <- getDynFlags        ; let            buildOneDataCon (L _ name) = do              { is_infix <- tcConIsInfixGADT name hs_args              ; rep_nm   <- newTyConRepName name -             ; buildDataCon fam_envs name is_infix-                            rep_nm-                            stricts Nothing field_lbls+             ; let bang_opts = SrcBangOpts (initBangOpts dflags)+             ; buildDataCon fam_envs bang_opts name is_infix+                            rep_nm stricts field_lbls                             univ_tvs ex_tvs tvbndrs' eq_preds                             ctxt' arg_tys' res_ty' rep_tycon tag_map                   -- NB:  we put data_tc, the type constructor gotten from the@@ -3523,8 +3563,6 @@                   --      that way checkValidDataCon can complain if it's wrong.              }        ; mapM buildOneDataCon names }-  where-    skol_info = DataConSkol (unLoc (head names))  {- Note [GADT return types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -3611,7 +3649,7 @@ -- it is OpenKind for datatypes and liftedTypeKind. -- Why do we not check for -XUnliftedNewtypes? See point <Error Messages> -- in Note [Implementation of UnliftedNewtypes]-getArgExpKind :: NewOrData -> Kind -> ContextKind+getArgExpKind :: NewOrData -> TcKind -> ContextKind getArgExpKind NewType res_ki = TheKind res_ki getArgExpKind DataType _     = OpenKind @@ -3658,7 +3696,7 @@               -> TcM [(Scaled TcType, HsSrcBang)] tcConGADTArgs exp_kind (PrefixConGADT btys)   = mapM (tcConArg exp_kind) btys-tcConGADTArgs exp_kind (RecConGADT fields)+tcConGADTArgs exp_kind (RecConGADT fields _)   = tcRecConDeclFields exp_kind fields  tcConArg :: ContextKind  -- expected kind for args; always OpenKind for datatypes,@@ -4150,7 +4188,7 @@   to add to the context. The problem is that this also grabs data con   wrapper Ids. These could be filtered out. But, painfully, getting   the wrapper Ids checks the DataConRep, and forcing the DataConRep-  can panic if there is a levity-polymorphic argument. This is #18534.+  can panic if there is a representation-polymorphic argument. This is #18534.   We don't need the wrapper Ids here anyway. So the code just takes what   it needs, via child_tycons. -}@@ -4198,7 +4236,7 @@                ; ClosedSynFamilyTyCon Nothing   -> return ()                ; AbstractClosedSynFamilyTyCon ->                  do { hsBoot <- tcIsHsBootOrSig-                    ; checkTc hsBoot $+                    ; checkTc hsBoot $ TcRnUnknownMessage $ mkPlainError noHints $                       text "You may define an abstract closed type family" $$                       text "only in a .hs-boot file" }                ; DataFamilyTyCon {}           -> return ()@@ -4228,6 +4266,11 @@     data_cons = tyConDataCons tc      groups = equivClasses cmp_fld (concatMap get_fields data_cons)+    -- This spot seems OK with non-determinism. cmp_fld is used only in equivClasses+    -- which produces equivalence classes.+    -- The order of these equivalence classes might conceivably (non-deterministically)+    -- depend on the result of this comparison, but that just affects the order in which+    -- fields are checked for compatibility. It will not affect the compiled binary.     cmp_fld (f1,_) (f2,_) = flLabel f1 `uniqCompareFS` flLabel f2     get_fields con = dataConFieldLabels con `zip` repeat con         -- dataConFieldLabels may return the empty list, which is fine@@ -4270,10 +4313,10 @@ -- See Note [Checking partial record field] checkPartialRecordField all_cons fld   = setSrcSpan loc $-      warnIfFlag Opt_WarnPartialFields-        (not is_exhaustive && not (startsWithUnderscore occ_name))-        (sep [text "Use of partial record field selector" <> colon,-              nest 2 $ quotes (ppr occ_name)])+      warnIf (not is_exhaustive && not (startsWithUnderscore occ_name))+        (TcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag Opt_WarnPartialFields) noHints $+          sep [text "Use of partial record field selector" <> colon,+                nest 2 $ quotes (ppr occ_name)])   where     loc = getSrcSpan (flSelector fld)     occ_name = occName fld@@ -4282,7 +4325,7 @@     has_field con = fld `elem` (dataConFieldLabels con)     is_exhaustive = all (dataConCannotMatch inst_tys) cons_without_field -    con1 = ASSERT( not (null cons_with_field) ) head cons_with_field+    con1 = assert (not (null cons_with_field)) $ head cons_with_field     (univ_tvs, _, eq_spec, _, _, _) = dataConFullSig con1     eq_subst = mkTvSubstPrs (map eqSpecPair eq_spec)     inst_tys = substTyVars eq_subst univ_tvs@@ -4303,7 +4346,9 @@     addErrCtxt (dataConCtxt [L (noAnnSrcSpan con_loc) con_name]) $     do  { let tc_tvs      = tyConTyVars tc               res_ty_tmpl = mkFamilyTyConApp tc (mkTyVarTys tc_tvs)-              orig_res_ty = dataConOrigResTy con+              arg_tys     = dataConOrigArgTys con+              orig_res_ty = dataConOrigResTy  con+         ; traceTc "checkValidDataCon" (vcat               [ ppr con, ppr tc, ppr tc_tvs               , ppr res_ty_tmpl <+> dcolon <+> ppr (tcTypeKind res_ty_tmpl)@@ -4340,16 +4385,22 @@           -- Reason: it's really the argument of an equality constraint         ; checkValidMonoType orig_res_ty -          -- If we are dealing with a newtype, we allow levity polymorphism-          -- regardless of whether or not UnliftedNewtypes is enabled. A-          -- later check in checkNewDataCon handles this, producing a-          -- better error message than checkForLevPoly would.+        -- Check for an escaping result kind+        -- See Note [Check for escaping result kind]+        ; checkEscapingKind con++        -- For /data/ types check that each argument has a fixed runtime rep+        -- If we are dealing with a /newtype/, we allow representation+        -- polymorphism regardless of whether or not UnliftedNewtypes+        -- is enabled. A later check in checkNewDataCon handles this,+        -- producing a better error message than checkTypeHasFixedRuntimeRep would.+        ; let check_rr = checkTypeHasFixedRuntimeRep FixedRuntimeRepDataConField         ; unless (isNewTyCon tc) $-            checkNoErrs $-            mapM_ (checkForLevPoly empty) (map scaledThing $ dataConOrigArgTys con)-            -- the checkNoErrs is to prevent a panic in isVanillaDataCon+          checkNoErrs            $+          mapM_ (check_rr . scaledThing) arg_tys+            -- The checkNoErrs is to prevent a panic in isVanillaDataCon             -- (called a a few lines down), which can fall over if there is a-            -- bang on a levity-polymorphic argument. This is #18534,+            -- bang on a representation-polymorphic argument. This is #18534,             -- typecheck/should_fail/T18534            -- Extra checks for newtype data constructors. Importantly, these@@ -4370,23 +4421,32 @@           -- E.g.  reject   data T = MkT {-# UNPACK #-} Int     -- No "!"           --                data T = MkT {-# UNPACK #-} !a      -- Can't unpack         ; hsc_env <- getTopEnv-        ; let check_bang :: HsSrcBang -> HsImplBang -> Int -> TcM ()-              check_bang bang rep_bang n+        ; let check_bang :: Type -> HsSrcBang -> HsImplBang -> Int -> TcM ()+              check_bang orig_arg_ty bang rep_bang n                | HsSrcBang _ _ SrcLazy <- bang-               , not (xopt LangExt.StrictData dflags)-               = addErrTc (bad_bang n (text "Lazy annotation (~) without StrictData"))+               , not (bang_opt_strict_data bang_opts)+               = addErrTc $ TcRnUnknownMessage $ mkPlainError noHints $+                 (bad_bang n (text "Lazy annotation (~) without StrictData"))                 | HsSrcBang _ want_unpack strict_mark <- bang                , isSrcUnpacked want_unpack, not (is_strict strict_mark)-               = addWarnTc NoReason (bad_bang n (text "UNPACK pragma lacks '!'"))+               , not (isUnliftedType orig_arg_ty)+               = addDiagnosticTc $ TcRnUnknownMessage $+                   mkPlainDiagnostic WarningWithoutFlag noHints (bad_bang n (text "UNPACK pragma lacks '!'")) +               -- Warn about a redundant ! on an unlifted type+               -- e.g.   data T = MkT !Int#+               | HsSrcBang _ _ SrcStrict <- bang+               , isUnliftedType orig_arg_ty+               = addDiagnosticTc $ TcRnBangOnUnliftedType orig_arg_ty+                | HsSrcBang _ want_unpack _ <- bang                , isSrcUnpacked want_unpack                , case rep_bang of { HsUnpack {} -> False; _ -> True }                -- If not optimising, we don't unpack (rep_bang is never                -- HsUnpack), so don't complain!  This happens, e.g., in Haddock.                -- See dataConSrcToImplBang.-               , not (gopt Opt_OmitInterfacePragmas dflags)+               , not (bang_opt_unbox_disable bang_opts)                -- When typechecking an indefinite package in Backpack, we                -- may attempt to UNPACK an abstract type.  The test here will                -- conclude that this is unusable, but it might become usable@@ -4394,12 +4454,14 @@                -- warn in this case (it gives users the wrong idea about whether                -- or not UNPACK on abstract types is supported; it is!)                , isHomeUnitDefinite (hsc_home_unit hsc_env)-               = addWarnTc NoReason (bad_bang n (text "Ignoring unusable UNPACK pragma"))+               = addDiagnosticTc $ TcRnUnknownMessage $+                   mkPlainDiagnostic WarningWithoutFlag noHints (bad_bang n (text "Ignoring unusable UNPACK pragma"))                 | otherwise                = return () -        ; zipWith3M_ check_bang (dataConSrcBangs con) (dataConImplBangs con) [1..]+        ; void $ zipWith4M check_bang (map scaledThing $ dataConOrigArgTys con)+          (dataConSrcBangs con) (dataConImplBangs con) [1..]            -- Check the dcUserTyVarBinders invariant           -- See Note [DataCon user type variable binders] in GHC.Core.DataCon@@ -4411,12 +4473,12 @@                    user_tvbs_invariant                      =    Set.fromList (filterEqSpec eq_spec univs ++ exs)                        == Set.fromList user_tvs-             ; MASSERT2( user_tvbs_invariant-                       , vcat ([ ppr con+             ; massertPpr user_tvbs_invariant+                          $ vcat ([ ppr con                                , ppr univs                                , ppr exs                                , ppr eq_spec-                               , ppr user_tvs ])) }+                               , ppr user_tvs ]) }          ; traceTc "Done validity of data con" $           vcat [ ppr con@@ -4429,11 +4491,12 @@                    Just (f, _) -> ppr (tyConBinders f) ]     }   where-    con_name = dataConName con-    con_loc  = nameSrcSpan con_name-    ctxt = ConArgCtxt con_name+    bang_opts = initBangOpts dflags+    con_name  = dataConName con+    con_loc   = nameSrcSpan con_name+    ctxt      = ConArgCtxt con_name     is_strict = \case-      NoSrcStrict -> xopt LangExt.StrictData dflags+      NoSrcStrict -> bang_opt_strict_data bang_opts       bang        -> isSrcStrict bang      bad_bang n herald@@ -4452,18 +4515,19 @@          ; unlifted_newtypes <- xoptM LangExt.UnliftedNewtypes         ; let allowedArgType =-                unlifted_newtypes || isLiftedType_maybe (scaledThing arg_ty1) == Just True-        ; checkTc allowedArgType $ vcat+                unlifted_newtypes || typeLevity_maybe (scaledThing arg_ty1) == Just Lifted+        ; checkTc allowedArgType $ TcRnUnknownMessage $ mkPlainError noHints $ vcat           [ text "A newtype cannot have an unlifted argument type"           , text "Perhaps you intended to use UnliftedNewtypes"           ]         ; show_linear_types <- xopt LangExt.LinearTypes <$> getDynFlags          ; let check_con what msg =-               checkTc what (msg $$ ppr con <+> dcolon <+> ppr (dataConDisplayType show_linear_types con))+               checkTc what $ TcRnUnknownMessage $ mkPlainError noHints $+                 (msg $$ ppr con <+> dcolon <+> ppr (dataConDisplayType show_linear_types con))          ; checkTc (ok_mult (scaledMult arg_ty1)) $-          text "A newtype constructor must be linear"+          TcRnUnknownMessage $ mkPlainError noHints $ text "A newtype constructor must be linear"          ; check_con (null eq_spec) $           text "A newtype constructor must have a return type of form T a1 ... an"@@ -4493,6 +4557,47 @@     ok_mult One = True     ok_mult _   = False ++-- | Reject nullary data constructors where a type variables+-- would escape through the result kind+-- See Note [Check for escaping result kind]+checkEscapingKind :: DataCon -> TcM ()+checkEscapingKind data_con+  | null eq_spec, null theta, null arg_tys+  , let tau_kind = tcTypeKind res_ty+  , Nothing <- occCheckExpand (univ_tvs ++ ex_tvs) tau_kind+    -- Ensure that none of the tvs occur in the kind of the forall+    -- /after/ expanding type synonyms.+    -- See Note [Phantom type variables in kinds] in GHC.Core.Type+  = failWithTc $ TcRnForAllEscapeError (dataConWrapperType data_con) tau_kind+  | otherwise+  = return ()+  where+    (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, res_ty)+      = dataConFullSig data_con++{- Note [Check for escaping result kind]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider:+  type T :: TYPE (BoxedRep l)+  data T = MkT+This is not OK: we get+  MkT :: forall l. T @l :: TYPE (BoxedRep l)+which is ill-kinded.++For ordinary type signatures f :: blah, we make this check as part of kind-checking+the type signature; see Note [Escaping kind in type signatures] in GHC.Tc.Gen.HsType.+But for data constructors we check the type piecemeal, and there is no very+convenient place to do it.  For example, note that it only applies for /nullary/+constructors.  If we had+  data T = MkT Int+then the type of MkT would be MkT :: forall l. Int -> T @l, which is fine.++So we make the check in checkValidDataCon.++Historical note: we used to do the check in checkValidType (#20929 discusses).+-}+ ------------------------------- checkValidClass :: Class -> TcM () checkValidClass cls@@ -4518,7 +4623,7 @@         ; unless undecidable_super_classes $           case checkClassCycles cls of              Just err -> setSrcSpan (getSrcSpan cls) $-                         addErrTc err+                         addErrTc (TcRnUnknownMessage $ mkPlainError noHints err)              Nothing  -> return ()          -- Check the class operations.@@ -4546,12 +4651,11 @@                 --      newBoard :: MonadState b m => m ()                 -- Here, MonadState has a fundep m->b, so newBoard is fine -           -- a method cannot be levity polymorphic, as we have to store the-           -- method in a dictionary-           -- example of what this prevents:-           --   class BoundedX (a :: TYPE r) where minBound :: a-           -- See Note [Levity polymorphism checking] in GHC.HsToCore.Monad-        ; checkForLevPoly empty tau1+        -- NB: we don't check that the class method is not representation-polymorphic here,+        -- as GHC.TcGen.TyCl.tcClassSigType already includes a subtype check that guarantees+        -- typeclass methods always have kind 'Type'.+        --+        -- Test case: rep-poly/RepPolyClassMethod.          ; unless constrained_class_methods $           mapM_ check_constraint (tail (cls_pred:op_theta))@@ -4559,7 +4663,7 @@         ; check_dm ctxt sel_id cls_pred tau2 dm         }         where-          ctxt    = FunSigCtxt op_name True -- Report redundant class constraints+          ctxt    = FunSigCtxt op_name (WantRRC (getSrcSpan cls)) -- Report redundant class constraints           op_name = idName sel_id           op_ty   = idType sel_id           (_,cls_pred,tau1) = tcSplitMethodTy op_ty@@ -4575,7 +4679,8 @@               pred_tvs = tyCoVarsOfType pred      check_at (ATI fam_tc m_dflt_rhs)-      = do { checkTc (cls_arity == 0 || any (`elemVarSet` cls_tv_set) fam_tvs)+      = do { traceTc "ati" (ppr fam_tc $$ ppr tyvars $$ ppr fam_tvs)+           ; checkTc (cls_arity == 0 || any (`elemVarSet` cls_tv_set) fam_tvs)                      (noClassTyVarErr cls fam_tc)                         -- Check that the associated type mentions at least                         -- one of the class type variables@@ -4661,6 +4766,7 @@           --    default foo2 :: a -> b           unless (isJust $ tcMatchTys [dm_phi_ty, vanilla_phi_ty]                                       [vanilla_phi_ty, dm_phi_ty]) $ addErrTc $+               TcRnUnknownMessage $ mkPlainError noHints $                hang (text "The default type signature for"                      <+> ppr sel_id <> colon)                  2 (ppr dm_ty)@@ -4679,13 +4785,15 @@   = do { idx_tys <- xoptM LangExt.TypeFamilies        ; checkTc idx_tys err_msg }   where-    err_msg = hang (text "Illegal family declaration for" <+> quotes (ppr tc_name))-                 2 (text "Enable TypeFamilies to allow indexed type families")+    err_msg :: TcRnMessage+    err_msg = TcRnUnknownMessage $ mkPlainError noHints $+      hang (text "Illegal family declaration for" <+> quotes (ppr tc_name))+         2 (text "Enable TypeFamilies to allow indexed type families")  checkResultSigFlag :: Name -> FamilyResultSig GhcRn -> TcM () checkResultSigFlag tc_name (TyVarSig _ tvb)   = do { ty_fam_deps <- xoptM LangExt.TypeFamilyDependencies-       ; checkTc ty_fam_deps $+       ; checkTc ty_fam_deps $ TcRnUnknownMessage $ mkPlainError noHints $          hang (text "Illegal result type variable" <+> ppr tvb <+> text "for" <+> quotes (ppr tc_name))             2 (text "Enable TypeFamilyDependencies to allow result variable names") } checkResultSigFlag _ _ = return ()  -- other cases OK@@ -4920,7 +5028,7 @@     check_no_roles       = whenIsJust role_annot_decl_maybe illegalRoleAnnotDecl -checkRoleAnnot :: TyVar -> Located (Maybe Role) -> Role -> TcM ()+checkRoleAnnot :: TyVar -> LocatedAn NoEpAnns (Maybe Role) -> Role -> TcM () checkRoleAnnot _  (L _ Nothing)   _  = return () checkRoleAnnot tv (L _ (Just r1)) r2   = when (r1 /= r2) $@@ -5003,9 +5111,10 @@         check_ty_roles env role ty      report_error doc-      = addErrTc $ vcat [text "Internal error in role inference:",-                         doc,-                         text "Please report this as a GHC bug:  https://www.haskell.org/ghc/reportabug"]+      = addErrTc $ TcRnUnknownMessage $ mkPlainError noHints $+         vcat [text "Internal error in role inference:",+               doc,+               text "Please report this as a GHC bug:  https://www.haskell.org/ghc/reportabug"]  {- ************************************************************************@@ -5023,8 +5132,8 @@ -- See Note [Inferring visible dependent quantification] -- Only types without a signature (CUSK or SAK) here addVDQNote tycon thing_inside-  | ASSERT2( isTcTyCon tycon, ppr tycon )-    ASSERT2( not (tcTyConIsPoly tycon), ppr tycon $$ ppr tc_kind )+  | assertPpr (isTcTyCon tycon) (ppr tycon) $+    assertPpr (not (tcTyConIsPoly tycon)) (ppr tycon $$ ppr tc_kind)     has_vdq   = addLandmarkErrCtxt vdq_warning thing_inside   | otherwise@@ -5084,15 +5193,17 @@     ctxt = text "In the equations for closed type family" <+>            quotes (ppr tc) -resultTypeMisMatch :: FieldLabelString -> DataCon -> DataCon -> SDoc+resultTypeMisMatch :: FieldLabelString -> DataCon -> DataCon -> TcRnMessage resultTypeMisMatch field_name con1 con2-  = vcat [sep [text "Constructors" <+> ppr con1 <+> text "and" <+> ppr con2,+  = TcRnUnknownMessage $ mkPlainError noHints $+    vcat [sep [text "Constructors" <+> ppr con1 <+> text "and" <+> ppr con2,                 text "have a common field" <+> quotes (ppr field_name) <> comma],           nest 2 $ text "but have different result types"] -fieldTypeMisMatch :: FieldLabelString -> DataCon -> DataCon -> SDoc+fieldTypeMisMatch :: FieldLabelString -> DataCon -> DataCon -> TcRnMessage fieldTypeMisMatch field_name con1 con2-  = sep [text "Constructors" <+> ppr con1 <+> text "and" <+> ppr con2,+  = TcRnUnknownMessage $ mkPlainError noHints $+    sep [text "Constructors" <+> ppr con1 <+> text "and" <+> ppr con2,          text "give different types for field", quotes (ppr field_name)]  dataConCtxt :: [LocatedN Name] -> SDoc@@ -5111,88 +5222,101 @@ classOpCtxt sel_id tau = sep [text "When checking the class method:",                               nest 2 (pprPrefixOcc sel_id <+> dcolon <+> ppr tau)] -classArityErr :: Int -> Class -> SDoc+classArityErr :: Int -> Class -> TcRnMessage classArityErr n cls     | n == 0 = mkErr "No" "no-parameter"     | otherwise = mkErr "Too many" "multi-parameter"   where-    mkErr howMany allowWhat =+    mkErr howMany allowWhat = TcRnUnknownMessage $ mkPlainError noHints $         vcat [text (howMany ++ " parameters for class") <+> quotes (ppr cls),               parens (text ("Enable MultiParamTypeClasses to allow "                                     ++ allowWhat ++ " classes"))] -classFunDepsErr :: Class -> SDoc+classFunDepsErr :: Class -> TcRnMessage classFunDepsErr cls-  = vcat [text "Fundeps in class" <+> quotes (ppr cls),+  = TcRnUnknownMessage $ mkPlainError noHints $+    vcat [text "Fundeps in class" <+> quotes (ppr cls),           parens (text "Enable FunctionalDependencies to allow fundeps")] -badMethPred :: Id -> TcPredType -> SDoc+badMethPred :: Id -> TcPredType -> TcRnMessage badMethPred sel_id pred-  = vcat [ hang (text "Constraint" <+> quotes (ppr pred)+  = TcRnUnknownMessage $ mkPlainError noHints $+    vcat [ hang (text "Constraint" <+> quotes (ppr pred)                  <+> text "in the type of" <+> quotes (ppr sel_id))               2 (text "constrains only the class type variables")          , text "Enable ConstrainedClassMethods to allow it" ] -noClassTyVarErr :: Class -> TyCon -> SDoc+noClassTyVarErr :: Class -> TyCon -> TcRnMessage noClassTyVarErr clas fam_tc-  = sep [ text "The associated type" <+> quotes (ppr fam_tc <+> hsep (map ppr (tyConTyVars fam_tc)))+  = TcRnUnknownMessage $ mkPlainError noHints $+    sep [ text "The associated type" <+> quotes (ppr fam_tc <+> hsep (map ppr (tyConTyVars fam_tc)))         , text "mentions none of the type or kind variables of the class" <+>                 quotes (ppr clas <+> hsep (map ppr (classTyVars clas)))] -badDataConTyCon :: DataCon -> Type -> SDoc+badDataConTyCon :: DataCon -> Type -> TcRnMessage badDataConTyCon data_con res_ty_tmpl-  = hang (text "Data constructor" <+> quotes (ppr data_con) <+>+  = TcRnUnknownMessage $ mkPlainError noHints $+    hang (text "Data constructor" <+> quotes (ppr data_con) <+>                 text "returns type" <+> quotes (ppr actual_res_ty))        2 (text "instead of an instance of its parent type" <+> quotes (ppr res_ty_tmpl))   where     actual_res_ty = dataConOrigResTy data_con -badGadtDecl :: Name -> SDoc+badGadtDecl :: Name -> TcRnMessage badGadtDecl tc_name-  = vcat [ text "Illegal generalised algebraic data declaration for" <+> quotes (ppr tc_name)+  = TcRnUnknownMessage $ mkPlainError noHints $+    vcat [ text "Illegal generalised algebraic data declaration for" <+> quotes (ppr tc_name)          , nest 2 (parens $ text "Enable the GADTs extension to allow this") ] -badExistential :: DataCon -> SDoc+badExistential :: DataCon -> TcRnMessage badExistential con-  = sdocOption sdocLinearTypes (\show_linear_types ->+  = TcRnUnknownMessage $ mkPlainError noHints $+    sdocOption sdocLinearTypes (\show_linear_types ->       hang (text "Data constructor" <+> quotes (ppr con) <+>                   text "has existential type variables, a context, or a specialised result type")          2 (vcat [ ppr con <+> dcolon <+> ppr (dataConDisplayType show_linear_types con)                  , parens $ text "Enable ExistentialQuantification or GADTs to allow this" ])) -badStupidTheta :: Name -> SDoc+badStupidTheta :: Name -> TcRnMessage badStupidTheta tc_name-  = text "A data type declared in GADT style cannot have a context:" <+> quotes (ppr tc_name)+  = TcRnUnknownMessage $ mkPlainError noHints $+  text "A data type declared in GADT style cannot have a context:" <+> quotes (ppr tc_name) -newtypeConError :: Name -> Int -> SDoc+newtypeConError :: Name -> Int -> TcRnMessage newtypeConError tycon n-  = sep [text "A newtype must have exactly one constructor,",+  = TcRnUnknownMessage $ mkPlainError noHints $+    sep [text "A newtype must have exactly one constructor,",          nest 2 $ text "but" <+> quotes (ppr tycon) <+> text "has" <+> speakN n ] -newtypeStrictError :: DataCon -> SDoc+newtypeStrictError :: DataCon -> TcRnMessage newtypeStrictError con-  = sep [text "A newtype constructor cannot have a strictness annotation,",+  = TcRnUnknownMessage $ mkPlainError noHints $+  sep [text "A newtype constructor cannot have a strictness annotation,",          nest 2 $ text "but" <+> quotes (ppr con) <+> text "does"] -newtypeFieldErr :: DataCon -> Int -> SDoc+newtypeFieldErr :: DataCon -> Int -> TcRnMessage newtypeFieldErr con_name n_flds-  = sep [text "The constructor of a newtype must have exactly one field",+  = TcRnUnknownMessage $ mkPlainError noHints $+    sep [text "The constructor of a newtype must have exactly one field",          nest 2 $ text "but" <+> quotes (ppr con_name) <+> text "has" <+> speakN n_flds] -badSigTyDecl :: Name -> SDoc+badSigTyDecl :: Name -> TcRnMessage badSigTyDecl tc_name-  = vcat [ text "Illegal kind signature" <+>+  = TcRnUnknownMessage $ mkPlainError noHints $+    vcat [ text "Illegal kind signature" <+>            quotes (ppr tc_name)          , nest 2 (parens $ text "Use KindSignatures to allow kind signatures") ] -emptyConDeclsErr :: Name -> SDoc+emptyConDeclsErr :: Name -> TcRnMessage emptyConDeclsErr tycon-  = sep [quotes (ppr tycon) <+> text "has no constructors",+  = TcRnUnknownMessage $ mkPlainError noHints $+    sep [quotes (ppr tycon) <+> text "has no constructors",          nest 2 $ text "(EmptyDataDecls permits this)"] -wrongKindOfFamily :: TyCon -> SDoc+wrongKindOfFamily :: TyCon -> TcRnMessage wrongKindOfFamily family-  = text "Wrong category of family instance; declaration was for a"+  = TcRnUnknownMessage $ mkPlainError noHints $+    text "Wrong category of family instance; declaration was for a"     <+> kindOfFamily   where     kindOfFamily | isTypeFamilyTyCon family = text "type family"@@ -5202,21 +5326,24 @@ -- | Produce an error for oversaturated type family equations with too many -- required arguments. -- See Note [Oversaturated type family equations] in "GHC.Tc.Validity".-wrongNumberOfParmsErr :: Arity -> SDoc+wrongNumberOfParmsErr :: Arity -> TcRnMessage wrongNumberOfParmsErr max_args-  = text "Number of parameters must match family declaration; expected"+  = TcRnUnknownMessage $ mkPlainError noHints $+    text "Number of parameters must match family declaration; expected"     <+> ppr max_args -badRoleAnnot :: Name -> Role -> Role -> SDoc+badRoleAnnot :: Name -> Role -> Role -> TcRnMessage badRoleAnnot var annot inferred-  = hang (text "Role mismatch on variable" <+> ppr var <> colon)+  = TcRnUnknownMessage $ mkPlainError noHints $+    hang (text "Role mismatch on variable" <+> ppr var <> colon)        2 (sep [ text "Annotation says", ppr annot               , text "but role", ppr inferred               , text "is required" ]) -wrongNumberOfRoles :: [a] -> LRoleAnnotDecl GhcRn -> SDoc+wrongNumberOfRoles :: [a] -> LRoleAnnotDecl GhcRn -> TcRnMessage wrongNumberOfRoles tyvars d@(L _ (RoleAnnotDecl _ _ annots))-  = hang (text "Wrong number of roles listed in role annotation;" $$+  = TcRnUnknownMessage $ mkPlainError noHints $+    hang (text "Wrong number of roles listed in role annotation;" $$           text "Expected" <+> (ppr $ length tyvars) <> comma <+>           text "got" <+> (ppr $ length annots) <> colon)        2 (ppr d)@@ -5226,22 +5353,26 @@ illegalRoleAnnotDecl (L loc (RoleAnnotDecl _ tycon _))   = setErrCtxt [] $     setSrcSpanA loc $-    addErrTc (text "Illegal role annotation for" <+> ppr tycon <> char ';' $$-              text "they are allowed only for datatypes and classes.")+    addErrTc $ TcRnUnknownMessage $ mkPlainError noHints $+      (text "Illegal role annotation for" <+> ppr tycon <> char ';' $$+       text "they are allowed only for datatypes and classes.") -needXRoleAnnotations :: TyCon -> SDoc+needXRoleAnnotations :: TyCon -> TcRnMessage needXRoleAnnotations tc-  = text "Illegal role annotation for" <+> ppr tc <> char ';' $$+  = TcRnUnknownMessage $ mkPlainError noHints $+    text "Illegal role annotation for" <+> ppr tc <> char ';' $$     text "did you intend to use RoleAnnotations?" -incoherentRoles :: SDoc-incoherentRoles = (text "Roles other than" <+> quotes (text "nominal") <+>-                   text "for class parameters can lead to incoherence.") $$-                  (text "Use IncoherentInstances to allow this; bad role found")+incoherentRoles :: TcRnMessage+incoherentRoles = TcRnUnknownMessage $ mkPlainError noHints $+  (text "Roles other than" <+> quotes (text "nominal") <+>+   text "for class parameters can lead to incoherence.") $$+  (text "Use IncoherentInstances to allow this; bad role found") -wrongTyFamName :: Name -> Name -> SDoc+wrongTyFamName :: Name -> Name -> TcRnMessage wrongTyFamName fam_tc_name eqn_tc_name-  = hang (text "Mismatched type name in type family instance.")+  = TcRnUnknownMessage $ mkPlainError noHints $+    hang (text "Mismatched type name in type family instance.")        2 (vcat [ text "Expected:" <+> ppr fam_tc_name                , text "  Actual:" <+> ppr eqn_tc_name ])
GHC/Tc/TyCl/Build.hs view
@@ -3,8 +3,8 @@ (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -} -{-# LANGUAGE CPP #-} + {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}  module GHC.Tc.TyCl.Build (@@ -15,8 +15,6 @@         newImplicitBinder, newTyConRepName     ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Iface.Env@@ -38,7 +36,6 @@ import GHC.Core.Multiplicity  import GHC.Types.SrcLoc( SrcSpan, noSrcSpan )-import GHC.Driver.Session import GHC.Tc.Utils.Monad import GHC.Types.Unique.Supply import GHC.Utils.Misc@@ -54,11 +51,11 @@   = do  { co_tycon_name <- newImplicitBinder tycon_name mkNewTyCoOcc         ; let nt_ax = mkNewTypeCoAxiom co_tycon_name tycon etad_tvs etad_roles etad_rhs         ; traceIf (text "mkNewTyConRhs" <+> ppr nt_ax)-        ; return (NewTyCon { data_con    = con,-                             nt_rhs      = rhs_ty,-                             nt_etad_rhs = (etad_tvs, etad_rhs),-                             nt_co       = nt_ax,-                             nt_lev_poly = isKindLevPoly res_kind } ) }+        ; return (NewTyCon { data_con     = con,+                             nt_rhs       = rhs_ty,+                             nt_etad_rhs  = (etad_tvs, etad_rhs),+                             nt_co        = nt_ax,+                             nt_fixed_rep = isFixedRuntimeRepKind res_kind } ) }                              -- Coreview looks through newtypes with a Nothing                              -- for nt_co, or uses explicit coercions otherwise   where@@ -79,6 +76,8 @@         -- has a single argument (Foo a) that is a *type class*, so         -- dataConInstOrigArgTys returns []. +    -- Eta-reduce the newtype+    -- See Note [Newtype eta] in GHC.Core.TyCon     etad_tvs   :: [TyVar]  -- Matched lazily, so that mkNewTypeCo can     etad_roles :: [Role]   -- return a TyCon without pulling on rhs_ty     etad_rhs   :: Type     -- See Note [Tricky iface loop] in GHC.Iface.Load@@ -89,21 +88,59 @@                -> Type          -- Rhs type                -> ([TyVar], [Role], Type)  -- Eta-reduced version                                            -- (tyvars in normal order)-    eta_reduce (a:as) (_:rs) ty | Just (fun, arg) <- splitAppTy_maybe ty,-                                  Just tv <- getTyVar_maybe arg,-                                  tv == a,-                                  not (a `elemVarSet` tyCoVarsOfType fun)-                                = eta_reduce as rs fun-    eta_reduce tvs rs ty = (reverse tvs, reverse rs, ty)+    eta_reduce (a:as) (_:rs) ty+      | Just (fun, arg) <- splitAppTy_maybe ty+      , Just tv <- getTyVar_maybe arg+      , tv == a+      , not (a `elemVarSet` tyCoVarsOfType fun)+      , typeKind fun `eqType` typeKind (mkTyConApp tycon (mkTyVarTys $ reverse as))+        -- Why this kind-check?  See Note [Newtype eta and homogeneous axioms]+      = eta_reduce as rs fun+    eta_reduce as rs ty = (reverse as, reverse rs, ty) +{- Note [Newtype eta and homogeneous axioms]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When eta-reducing a newtype, we must be careful to make sure the axiom+is homogeneous.  (That is, the two types related by the axiom must+have the same kind.)  All known proofs of type safety for Core rely on+the homogeneity of axioms, so let's not monkey with that.++It is easy to mistakenly make an inhomogeneous axiom (#19739):+  type T :: forall (a :: Type) -> Type+  newtype T a = MkT (Proxy a)++Can we eta-reduce, thus?+  axT :: T ~ Proxy++No!  Because+   T     :: forall a -> Type+   Proxy :: Type     -> Type++This is inhomogeneous. Hence, we have an extra kind-check in eta_reduce,+to make sure the reducts have the same kind. This is simple, although+perhaps quadratic in complexity, if we eta-reduce many arguments (which+seems vanishingly unlikely in practice).  But NB that the free-variable+check, which immediately precedes the kind check, is also potentially+quadratic.++There are other ways we could do the check (discussion on #19739):++* We could look at the sequence of binders on the newtype and on the+  head of the representation type, and make sure the visibilities on+  the binders match up. This is quite a bit more code, and the reasoning+  is subtler.++* We could, say, do the kind-check at the end and then backtrack until the+  kinds match up. Hard to know whether that's more performant or not.+-}+ ------------------------------------------------------ buildDataCon :: FamInstEnvs+            -> DataConBangOpts             -> Name             -> Bool                     -- Declared infix             -> TyConRepName             -> [HsSrcBang]-            -> Maybe [HsImplBang]-                -- See Note [Bangs on imported data constructors] in GHC.Types.Id.Make            -> [FieldLabel]             -- Field labels            -> [TyVar]                  -- Universals            -> [TyCoVar]                -- Existentials@@ -121,7 +158,7 @@ --   a) makes the worker Id --   b) makes the wrapper Id if necessary, including --      allocating its unique (hence monadic)-buildDataCon fam_envs src_name declared_infix prom_info src_bangs impl_bangs+buildDataCon fam_envs dc_bang_opts src_name declared_infix prom_info src_bangs              field_lbls univ_tvs ex_tvs user_tvbs eq_spec ctxt arg_tys res_ty              rep_tycon tag_map   = do  { wrap_name <- newImplicitBinder src_name mkDataConWrapperOcc@@ -132,7 +169,6 @@          ; traceIf (text "buildDataCon 1" <+> ppr src_name)         ; us <- newUniqueSupply-        ; dflags <- getDynFlags         ; let stupid_ctxt = mkDataConStupidTheta rep_tycon (map scaledThing arg_tys) univ_tvs               tag = lookupNameEnv_NF tag_map src_name               -- See Note [Constructor tag allocation], fixes #14657@@ -142,8 +178,7 @@                                    arg_tys res_ty NoRRI rep_tycon tag                                    stupid_ctxt dc_wrk dc_rep               dc_wrk = mkDataConWorkId work_name data_con-              dc_rep = initUs_ us (mkDataConRep dflags fam_envs wrap_name-                                                impl_bangs data_con)+              dc_rep = initUs_ us (mkDataConRep dc_bang_opts fam_envs wrap_name data_con)          ; traceIf (text "buildDataCon 2" <+> ppr src_name)         ; return data_con }@@ -153,6 +188,8 @@ -- the type variables mentioned in the arg_tys -- ToDo: Or functionally dependent on? --       This whole stupid theta thing is, well, stupid.+--+-- See Note [The stupid context] in GHC.Core.DataCon. mkDataConStupidTheta :: TyCon -> [Type] -> [TyVar] -> [PredType] mkDataConStupidTheta tycon arg_tys univ_tvs   | null stupid_theta = []      -- The common case@@ -173,7 +210,7 @@             -> PatSynMatcher -> PatSynBuilder             -> ([InvisTVBinder], ThetaType) -- ^ Univ and req             -> ([InvisTVBinder], ThetaType) -- ^ Ex and prov-            -> [Type]                       -- ^ Argument types+            -> [FRRType]                    -- ^ Argument types             -> Type                         -- ^ Result type             -> [FieldLabel]                 -- ^ Field labels for                                             --   a record pattern synonym@@ -183,19 +220,19 @@             pat_ty field_labels   = -- The assertion checks that the matcher is     -- compatible with the pattern synonym-    ASSERT2((and [ univ_tvs `equalLength` univ_tvs1-                 , ex_tvs `equalLength` ex_tvs1-                 , pat_ty `eqType` substTy subst (scaledThing pat_ty1)-                 , prov_theta `eqTypes` substTys subst prov_theta1-                 , req_theta `eqTypes` substTys subst req_theta1-                 , compareArgTys arg_tys (substTys subst (map scaledThing arg_tys1))-                 ])-            , (vcat [ ppr univ_tvs <+> twiddle <+> ppr univ_tvs1+    assertPpr (and [ univ_tvs `equalLength` univ_tvs1+                   , ex_tvs `equalLength` ex_tvs1+                   , pat_ty `eqType` substTy subst (scaledThing pat_ty1)+                   , prov_theta `eqTypes` substTys subst prov_theta1+                   , req_theta `eqTypes` substTys subst req_theta1+                   , compareArgTys arg_tys (substTys subst (map scaledThing arg_tys1))+                   ])+              (vcat [ ppr univ_tvs <+> twiddle <+> ppr univ_tvs1                     , ppr ex_tvs <+> twiddle <+> ppr ex_tvs1                     , ppr pat_ty <+> twiddle <+> ppr pat_ty1                     , ppr prov_theta <+> twiddle <+> ppr prov_theta1                     , ppr req_theta <+> twiddle <+> ppr req_theta1-                    , ppr arg_tys <+> twiddle <+> ppr arg_tys1]))+                    , ppr arg_tys <+> twiddle <+> ppr arg_tys1]) $     mkPatSyn src_name declared_infix              (univ_tvs, req_theta) (ex_tvs, prov_theta)              arg_tys pat_ty@@ -253,7 +290,8 @@         ; tc_rep_name  <- newTyConRepName tycon_name         ; let univ_tvs = binderVars binders               tycon = mkClassTyCon tycon_name binders roles-                                   AbstractTyCon rec_clas tc_rep_name+                                   AbstractTyCon+                                   rec_clas tc_rep_name               result = mkAbstractClass tycon_name univ_tvs fds tycon         ; traceIf (text "buildClass" <+> ppr tycon)         ; return result }@@ -288,7 +326,7 @@                 --       i.e. exactly one operation or superclass taken together                 --   (b) that value is of lifted type (which they always are, because                 --       we box equality superclasses)-                -- See note [Class newtypes and equality predicates]+                -- See Note [Class newtypes and equality predicates]                  -- We treat the dictionary superclasses as ordinary arguments.                 -- That means that in the case of@@ -301,14 +339,15 @@               rec_tycon  = classTyCon rec_clas               univ_bndrs = tyConInvisTVBinders binders               univ_tvs   = binderVars univ_bndrs+              bang_opts  = FixedBangOpts (map (const HsLazy) args)          ; rep_nm   <- newTyConRepName datacon_name         ; dict_con <- buildDataCon (panic "buildClass: FamInstEnvs")+                                   bang_opts                                    datacon_name                                    False        -- Not declared infix                                    rep_nm                                    (map (const no_bang) args)-                                   (Just (map (const HsLazy) args))                                    [{- No fields -}]                                    univ_tvs                                    [{- no existentials -}]
GHC/Tc/TyCl/Class.hs view
@@ -4,7 +4,7 @@  -} -{-# LANGUAGE CPP #-}+ {-# LANGUAGE TypeFamilies #-}  {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}@@ -26,11 +26,10 @@    ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Hs+import GHC.Tc.Errors.Types import GHC.Tc.Gen.Sig import GHC.Tc.Types.Evidence ( idHsWrapper ) import GHC.Tc.Gen.Bind@@ -51,6 +50,7 @@ import GHC.Driver.Session import GHC.Tc.Instance.Family import GHC.Core.FamInstEnv+import GHC.Types.Error import GHC.Types.Id import GHC.Types.Name import GHC.Types.Name.Env@@ -60,14 +60,13 @@ import GHC.Types.SourceFile (HscSource(..)) import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Types.SrcLoc import GHC.Core.TyCon import GHC.Data.Maybe import GHC.Types.Basic import GHC.Data.Bag-import GHC.Data.FastString import GHC.Data.BooleanFormula-import GHC.Utils.Misc  import Control.Monad import Data.List ( mapAccumL, partition )@@ -113,8 +112,8 @@ ************************************************************************ -} -illegalHsigDefaultMethod :: Name -> SDoc-illegalHsigDefaultMethod n =+illegalHsigDefaultMethod :: Name -> TcRnMessage+illegalHsigDefaultMethod n = TcRnUnknownMessage $ mkPlainError noHints $     text "Illegal default method(s) in class definition of" <+> ppr n <+> text "in hsig file"  tcClassSigs :: Name                -- Name of the class@@ -205,11 +204,16 @@         --      dm1 = \d -> case ds d of (a,b,c) -> a         -- And since ds is big, it doesn't get inlined, so we don't get good         -- default methods.  Better to make separate AbsBinds for each++        ; skol_info <- mkSkolemInfo (TyConSkol ClassFlavour (getName class_name))+        ; tc_lvl    <- getTcLevel         ; let (tyvars, _, _, op_items) = classBigSig clas-              prag_fn     = mkPragEnv sigs default_binds-              sig_fn      = mkHsSigFun sigs-              clas_tyvars = snd (tcSuperSkolTyVars tyvars)-              pred        = mkClassPred clas (mkTyVarTys clas_tyvars)+              prag_fn = mkPragEnv sigs default_binds+              sig_fn  = mkHsSigFun sigs+              (_skol_subst, clas_tyvars) = tcSuperSkolTyVars tc_lvl skol_info tyvars+                    -- This make skolemTcTyVars, but does not clone,+                    -- so we can put them in scope with tcExtendTyVarEnv+              pred = mkClassPred clas (mkTyVarTys clas_tyvars)         ; this_dict <- newEvVar pred          ; let tc_item = tcDefMeth clas clas_tyvars this_dict@@ -258,10 +262,10 @@         ; spec_prags <- discardConstraints $                        tcSpecPrags global_dm_id prags-       ; warnTc NoReason-                (not (null spec_prags))-                (text "Ignoring SPECIALISE pragmas on default method"-                 <+> quotes (ppr sel_name))+       ; let dia = TcRnUnknownMessage $+               mkPlainDiagnostic WarningWithoutFlag noHints $+                (text "Ignoring SPECIALISE pragmas on default method" <+> quotes (ppr sel_name))+       ; diagnosticTc (not (null spec_prags)) dia         ; let hs_ty = hs_sig_fn sel_name                      `orElse` pprPanic "tc_dm" (ppr sel_name)@@ -282,8 +286,8 @@                              -- NB: the binding is always a FunBind               warn_redundant = case dm_spec of-                                GenericDM {} -> True-                                VanillaDM    -> False+                                GenericDM {} -> lhsSigTypeContextSpan hs_ty+                                VanillaDM    -> NoRRC                 -- For GenericDM, warn if the user specifies a signature                 -- with redundant constraints; but not for VanillaDM, where                 -- the default method may well be 'error' or something@@ -300,13 +304,12 @@                   tcPolyCheck no_prag_fn local_dm_sig                               (L bind_loc lm_bind) -       ; let export = ABE { abe_ext   = noExtField-                          , abe_poly  = global_dm_id+       ; let export = ABE { abe_poly  = global_dm_id                           , abe_mono  = local_dm_id                           , abe_wrap  = idHsWrapper                           , abe_prags = IsDefaultMethod }-             full_bind = AbsBinds { abs_ext      = noExtField-                                  , abs_tvs      = tyvars+             full_bind = XHsBindsLR $+                         AbsBinds { abs_tvs      = tyvars                                   , abs_ev_vars  = [this_dict]                                   , abs_exports  = [export]                                   , abs_ev_binds = [ev_binds]@@ -337,7 +340,7 @@         -- since you can't write a default implementation.         when (tcg_src tcg_env /= HsigFile) $             whenIsJust (isUnsatisfied (mindef `impliesAtom`) defMindef) $-                       (\bf -> addWarnTc NoReason (warningMinimalDefIncomplete bf))+                       (\bf -> addDiagnosticTc (warningMinimalDefIncomplete bf))         return mindef   where     -- By default require all methods without a default implementation@@ -352,7 +355,7 @@ -- Return the "local method type": --      forall c. Ix x => (ty2,c) -> ty1 instantiateMethod clas sel_id inst_tys-  = ASSERT( ok_first_pred ) local_meth_ty+  = assert ok_first_pred local_meth_ty   where     rho_ty = piResultTys (idType sel_id) inst_tys     (first_pred, local_meth_ty) = tcSplitPredFunTy_maybe rho_ty@@ -438,14 +441,16 @@ ************************************************************************ -} -badMethodErr :: Outputable a => a -> Name -> SDoc+badMethodErr :: Outputable a => a -> Name -> TcRnMessage badMethodErr clas op-  = hsep [text "Class", quotes (ppr clas),+  = TcRnUnknownMessage $ mkPlainError noHints $+    hsep [text "Class", quotes (ppr clas),           text "does not have a method", quotes (ppr op)] -badGenericMethod :: Outputable a => a -> Name -> SDoc+badGenericMethod :: Outputable a => a -> Name -> TcRnMessage badGenericMethod clas op-  = hsep [text "Class", quotes (ppr clas),+  = TcRnUnknownMessage $ mkPlainError noHints $+    hsep [text "Class", quotes (ppr clas),           text "has a generic-default signature without a binding", quotes (ppr op)]  {-@@ -469,13 +474,15 @@ -} badDmPrag :: TcId -> Sig GhcRn -> TcM () badDmPrag sel_id prag-  = addErrTc (text "The" <+> hsSigDoc prag <+> ptext (sLit "for default method")+  = addErrTc (TcRnUnknownMessage $ mkPlainError noHints $+    text "The" <+> hsSigDoc prag <+> text "for default method"               <+> quotes (ppr sel_id)               <+> text "lacks an accompanying binding") -warningMinimalDefIncomplete :: ClassMinimalDef -> SDoc+warningMinimalDefIncomplete :: ClassMinimalDef -> TcRnMessage warningMinimalDefIncomplete mindef-  = vcat [ text "The MINIMAL pragma does not require:"+  = TcRnUnknownMessage $ mkPlainDiagnostic WarningWithoutFlag noHints $+  vcat [ text "The MINIMAL pragma does not require:"          , nest 2 (pprBooleanFormulaNice mindef)          , text "but there is no default implementation." ] @@ -556,7 +563,10 @@        -- hs-boot and signatures never need to provide complete "definitions"        -- of any sort, as they aren't really defining anything, but just        -- constraining items which are defined elsewhere.-       ; warnTc (Reason Opt_WarnMissingMethods) (warn && hsc_src == HsSrcFile)-                (text "No explicit" <+> text "associated type"-                    <+> text "or default declaration for"-                    <+> quotes (ppr name)) }+       ; let dia = TcRnUnknownMessage $+               mkPlainDiagnostic (WarningWithFlag Opt_WarnMissingMethods) noHints $+                 (text "No explicit" <+> text "associated type"+                                     <+> text "or default declaration for"+                                     <+> quotes (ppr name))+       ; diagnosticTc  (warn && hsc_src == HsSrcFile) dia+                       }
GHC/Tc/TyCl/Instance.hs view
@@ -4,7 +4,7 @@  -} -{-# LANGUAGE CPP #-}+ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} @@ -19,11 +19,10 @@    ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Hs+import GHC.Tc.Errors.Types import GHC.Tc.Gen.Bind import GHC.Tc.TyCl import GHC.Tc.TyCl.Utils ( addTyConsToGblEnv )@@ -62,6 +61,7 @@ import GHC.Core.DataCon import GHC.Core.ConLike import GHC.Core.Class+import GHC.Types.Error import GHC.Types.Var as Var import GHC.Types.Var.Env import GHC.Types.Var.Set@@ -70,7 +70,6 @@ import GHC.Types.Fixity import GHC.Driver.Session import GHC.Driver.Ppr-import GHC.Utils.Error import GHC.Utils.Logger import GHC.Data.FastString import GHC.Types.Id@@ -80,6 +79,7 @@ import GHC.Types.Name.Set import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Types.SrcLoc import GHC.Utils.Misc import GHC.Data.BooleanFormula ( isUnsatisfied, pprBooleanFormulaNice )@@ -388,7 +388,8 @@    -> TcM (TcGblEnv,            -- The full inst env            [InstInfo GhcRn],    -- Source-code instance decls to process;                                 -- contains all dfuns for this module-           [DerivInfo])         -- From data family instances+           [DerivInfo],         -- From data family instances+           ThBindEnv)           -- TH binding levels  tcInstDecls1 inst_decls   = do {    -- Do class and family instance declarations@@ -398,13 +399,14 @@              fam_insts   = concat fam_insts_s              local_infos = concat local_infos_s -       ; gbl_env <- addClsInsts local_infos $-                    addFamInsts fam_insts   $-                    getGblEnv+       ; (gbl_env, th_bndrs) <-+           addClsInsts local_infos $+           addFamInsts fam_insts         ; return ( gbl_env                 , local_infos-                , concat datafam_deriv_infos ) }+                , concat datafam_deriv_infos+                , th_bndrs ) }  -- | Use DerivInfo for data family instances (produced by tcInstDecls1), --   datatype declarations (TyClDecl), and standalone deriving declarations@@ -425,17 +427,18 @@ addClsInsts infos thing_inside   = tcExtendLocalInstEnv (map iSpec infos) thing_inside -addFamInsts :: [FamInst] -> TcM a -> TcM a+addFamInsts :: [FamInst] -> TcM (TcGblEnv, ThBindEnv) -- Extend (a) the family instance envt --        (b) the type envt with stuff from data type decls-addFamInsts fam_insts thing_inside+addFamInsts fam_insts   = tcExtendLocalFamInstEnv fam_insts $     tcExtendGlobalEnv axioms          $     do { traceTc "addFamInsts" (pprFamInsts fam_insts)-       ; gbl_env <- addTyConsToGblEnv data_rep_tycons+       ; (gbl_env, th_bndrs) <- addTyConsToGblEnv data_rep_tycons                     -- Does not add its axiom; that comes                     -- from adding the 'axioms' above-       ; setGblEnv gbl_env thing_inside }+       ; return (gbl_env, th_bndrs)+       }   where     axioms = map (ACoAxiom . toBranchedAxiom . famInstAxiom) fam_insts     data_rep_tycons = famInstsRepTyCons fam_insts@@ -489,8 +492,8 @@     do  { dfun_ty <- tcHsClsInstType (InstDeclCtxt False) hs_ty         ; let (tyvars, theta, clas, inst_tys) = tcSplitDFunTy dfun_ty              -- NB: tcHsClsInstType does checkValidInstance--        ; (subst, skol_tvs) <- tcInstSkolTyVars tyvars+        ; skol_info <- mkSkolemInfo InstSkol+        ; (subst, skol_tvs) <- tcInstSkolTyVars skol_info tyvars         ; let tv_skol_prs = [ (tyVarName tv, skol_tv)                             | (tv, skol_tv) <- tyvars `zip` skol_tvs ]               -- Map from the skolemized Names to the original Names.@@ -553,7 +556,7 @@          -- In hs-boot files there should be no bindings         ; let no_binds = isEmptyLHsBinds binds && null uprags         ; is_boot <- tcIsHsBootOrSig-        ; failIfTc (is_boot && not no_binds) badBootDeclErr+        ; failIfTc (is_boot && not no_binds) TcRnIllegalHsBootFileDecl          ; return ( [inst_info], all_insts, deriv_infos ) }   where@@ -688,8 +691,9 @@        ; gadt_syntax <- dataDeclChecks fam_name new_or_data hs_ctxt hs_cons           -- Do /not/ check that the number of patterns = tyConArity fam_tc           -- See [Arity of data families] in GHC.Core.FamInstEnv-       ; (qtvs, pats, res_kind, stupid_theta)-             <- tcDataFamInstHeader mb_clsinfo fam_tc outer_bndrs fixity+       ; skol_info <- mkSkolemInfo FamInstSkol+       ; (qtvs, pats, tc_res_kind, stupid_theta)+             <- tcDataFamInstHeader mb_clsinfo skol_info fam_tc outer_bndrs fixity                                     hs_ctxt hs_pats m_ksig new_or_data         -- Eta-reduce the axiom if possible@@ -699,7 +703,7 @@              post_eta_qtvs = filterOut (`elem` eta_tvs) qtvs               full_tcbs = mkTyConBindersPreferAnon post_eta_qtvs-                            (tyCoVarsOfType (mkSpecForAllTys eta_tvs res_kind))+                            (tyCoVarsOfType (mkSpecForAllTys eta_tvs tc_res_kind))                          ++ eta_tcbs                  -- Put the eta-removed tyvars at the end                  -- Remember, qtvs is in arbitrary order, except kind vars are@@ -715,15 +719,40 @@        --     we did it before the "extra" tvs from etaExpandAlgTyCon        --     would always be eta-reduced        ---       ; (extra_tcbs, final_res_kind) <- etaExpandAlgTyCon full_tcbs res_kind+       ; let flav = newOrDataToFlavour new_or_data+       ; (extra_tcbs, tc_res_kind) <- etaExpandAlgTyCon flav skol_info full_tcbs tc_res_kind         -- Check the result kind; it may come from a user-written signature.        -- See Note [Datatype return kinds] in GHC.Tc.TyCl point 4(a)-       ; let extra_pats  = map (mkTyVarTy . binderVar) extra_tcbs-             all_pats    = pats `chkAppend` extra_pats-             orig_res_ty = mkTyConApp fam_tc all_pats-             ty_binders  = full_tcbs `chkAppend` extra_tcbs+       ; let extra_pats    = map (mkTyVarTy . binderVar) extra_tcbs+             all_pats      = pats `chkAppend` extra_pats+             orig_res_ty   = mkTyConApp fam_tc all_pats+             tc_ty_binders = full_tcbs `chkAppend` extra_tcbs +       ; traceTc "tcDataFamInstDecl 1" $+         vcat [ text "Fam tycon:" <+> ppr fam_tc+              , text "Pats:" <+> ppr pats+              , text "visibilities:" <+> ppr (tcbVisibilities fam_tc pats)+              , text "all_pats:" <+> ppr all_pats+              , text "tc_ty_binders" <+> ppr tc_ty_binders+              , text "fam_tc_binders:" <+> ppr (tyConBinders fam_tc)+              , text "tc_res_kind:" <+> ppr tc_res_kind+              , text "eta_pats" <+> ppr eta_pats+              , text "eta_tcbs" <+> ppr eta_tcbs ]++       -- Zonk the patterns etc into the Type world+       ; ze                <- mkEmptyZonkEnv NoFlexi+       ; (ze, ty_binders)  <- zonkTyVarBindersX   ze tc_ty_binders+       ; res_kind          <- zonkTcTypeToTypeX   ze tc_res_kind+       ; all_pats          <- zonkTcTypesToTypesX ze all_pats+       ; eta_pats          <- zonkTcTypesToTypesX ze eta_pats+       ; stupid_theta      <- zonkTcTypesToTypesX ze stupid_theta+       ; let zonked_post_eta_qtvs = map (lookupTyVarX ze) post_eta_qtvs+             zonked_eta_tvs       = map (lookupTyVarX ze) eta_tvs+             -- All these qtvs are in ty_binders, and hence will be in+             -- the ZonkEnv, ze.  We need the zonked (TyVar) versions to+             -- put in the CoAxiom that we are about to build.+        ; traceTc "tcDataFamInstDecl" $          vcat [ text "Fam tycon:" <+> ppr fam_tc               , text "Pats:" <+> ppr pats@@ -732,34 +761,36 @@               , text "ty_binders" <+> ppr ty_binders               , text "fam_tc_binders:" <+> ppr (tyConBinders fam_tc)               , text "res_kind:" <+> ppr res_kind-              , text "final_res_kind:" <+> ppr final_res_kind               , text "eta_pats" <+> ppr eta_pats               , text "eta_tcbs" <+> ppr eta_tcbs ]-        ; (rep_tc, axiom) <- fixM $ \ ~(rec_rep_tc, _) ->-           do { data_cons <- tcExtendTyVarEnv qtvs $+           do { data_cons <- tcExtendTyVarEnv (binderVars tc_ty_binders) $                   -- For H98 decls, the tyvars scope                   -- over the data constructors                   tcConDecls new_or_data (DDataInstance orig_res_ty)-                             rec_rep_tc ty_binders final_res_kind+                             rec_rep_tc tc_ty_binders tc_res_kind                              hs_cons                ; rep_tc_name <- newFamInstTyConName lfam_name pats               ; axiom_name  <- newFamInstAxiomName lfam_name [pats]               ; tc_rhs <- case new_or_data of-                     DataType -> return (mkDataTyConRhs data_cons)-                     NewType  -> ASSERT( not (null data_cons) )+                     DataType -> return $+                        mkLevPolyDataTyConRhs+                          (isFixedRuntimeRepKind res_kind)+                          data_cons+                     NewType  -> assert (not (null data_cons)) $                                  mkNewTyConRhs rep_tc_name rec_rep_tc (head data_cons) -              ; let ax_rhs = mkTyConApp rep_tc (mkTyVarTys post_eta_qtvs)+              ; let ax_rhs = mkTyConApp rep_tc (mkTyVarTys zonked_post_eta_qtvs)                     axiom  = mkSingleCoAxiom Representational axiom_name-                                 post_eta_qtvs eta_tvs [] fam_tc eta_pats ax_rhs+                                 zonked_post_eta_qtvs zonked_eta_tvs+                                 [] fam_tc eta_pats ax_rhs                     parent = DataFamInstTyCon axiom fam_tc all_pats                        -- NB: Use the full ty_binders from the pats. See bullet toward                       -- the end of Note [Data type families] in GHC.Core.TyCon                     rep_tc   = mkAlgTyCon rep_tc_name-                                          ty_binders final_res_kind+                                          ty_binders res_kind                                           (map (const Nominal) ty_binders)                                           (fmap unLoc cType) stupid_theta                                           tc_rhs parent@@ -856,21 +887,23 @@  ----------------------- tcDataFamInstHeader-    :: AssocInstInfo -> TyCon -> HsOuterFamEqnTyVarBndrs GhcRn+    :: AssocInstInfo -> SkolemInfo -> TyCon -> HsOuterFamEqnTyVarBndrs GhcRn     -> LexicalFixity -> Maybe (LHsContext GhcRn)     -> HsTyPats GhcRn -> Maybe (LHsKind GhcRn)     -> NewOrData-    -> TcM ([TyVar], [Type], Kind, ThetaType)+    -> TcM ([TcTyVar], [TcType], TcKind, TcThetaType)+         -- All skolem TcTyVars, all zonked so it's clear what the free vars are+ -- The "header" of a data family instance is the part other than -- the data constructors themselves --    e.g.  data instance D [a] :: * -> * where ... -- Here the "header" is the bit before the "where"-tcDataFamInstHeader mb_clsinfo fam_tc outer_bndrs fixity+tcDataFamInstHeader mb_clsinfo skol_info fam_tc hs_outer_bndrs fixity                     hs_ctxt hs_pats m_ksig new_or_data   = do { traceTc "tcDataFamInstHeader {" (ppr fam_tc <+> ppr hs_pats)-       ; (tclvl, wanted, (scoped_tvs, (stupid_theta, lhs_ty, master_res_kind, instance_res_kind)))+       ; (tclvl, wanted, (outer_bndrs, (stupid_theta, lhs_ty, master_res_kind, instance_res_kind)))             <- pushLevelAndSolveEqualitiesX "tcDataFamInstHeader" $-               bindOuterFamEqnTKBndrs outer_bndrs                 $+               bindOuterFamEqnTKBndrs skol_info hs_outer_bndrs    $  -- Binds skolem TcTyVars                do { stupid_theta <- tcHsContext hs_ctxt                   ; (lhs_ty, lhs_kind) <- tcFamTyPats fam_tc hs_pats                   ; (lhs_applied_ty, lhs_applied_kind)@@ -891,16 +924,20 @@                   -- Check that the result kind of the TyCon applied to its args                   -- is compatible with the explicit signature (or Type, if there                   -- is none)-                  ; let hs_lhs = nlHsTyConApp fixity (getName fam_tc) hs_pats-                  ; _ <- unifyKind (Just (ppr hs_lhs)) lhs_applied_kind res_kind+                  ; let hs_lhs = nlHsTyConApp NotPromoted fixity (getName fam_tc) hs_pats+                  ; _ <- unifyKind (Just . HsTypeRnThing $ unLoc hs_lhs) lhs_applied_kind res_kind                    ; traceTc "tcDataFamInstHeader" $-                    vcat [ ppr fam_tc, ppr m_ksig, ppr lhs_applied_kind, ppr res_kind ]+                    vcat [ ppr fam_tc, ppr m_ksig, ppr lhs_applied_kind, ppr res_kind, ppr m_ksig]                   ; return ( stupid_theta                            , lhs_applied_ty                            , lhs_applied_kind                            , res_kind ) } +       ; outer_bndrs <- scopedSortOuter outer_bndrs+       ; let outer_tvs = outerTyVars outer_bndrs+       ; checkFamTelescope tclvl hs_outer_bndrs outer_tvs+        -- This code (and the stuff immediately above) is very similar        -- to that in tcTyFamInstEqnGuts.  Maybe we should abstract the        -- common code; but for the moment I concluded that it's@@ -908,34 +945,30 @@        -- check there too!         -- See GHC.Tc.TyCl Note [Generalising in tcFamTyPatsGuts]-       ; dvs  <- candidateQTyVarsOfTypes (lhs_ty : mkTyVarTys scoped_tvs)-       ; qtvs <- quantifyTyVars dvs-       ; reportUnsolvedEqualities FamInstSkol qtvs tclvl wanted--       -- Zonk the patterns etc into the Type world-       ; ze           <- mkEmptyZonkEnv NoFlexi-       ; (ze, qtvs)   <- zonkTyBndrsX           ze qtvs-       ; lhs_ty       <- zonkTcTypeToTypeX      ze lhs_ty-       ; stupid_theta <- zonkTcTypesToTypesX    ze stupid_theta-       ; master_res_kind   <- zonkTcTypeToTypeX ze master_res_kind-       ; instance_res_kind <- zonkTcTypeToTypeX ze instance_res_kind+       ; dvs  <- candidateQTyVarsWithBinders outer_tvs lhs_ty+       ; qtvs <- quantifyTyVars skol_info TryNotToDefaultNonStandardTyVars dvs+       ; let final_tvs = scopedSort (qtvs ++ outer_tvs)+             -- This scopedSort is important: the qtvs may be /interleaved/ with+             -- the outer_tvs.  See Note [Generalising in tcTyFamInstEqnGuts]+       ; reportUnsolvedEqualities skol_info final_tvs tclvl wanted -       -- We check that res_kind is OK with checkDataKindSig in-       -- tcDataFamInstDecl, after eta-expansion.  We need to check that-       -- it's ok because res_kind can come from a user-written kind signature.-       -- See Note [Datatype return kinds], point (4a)+       ; final_tvs         <- zonkTcTyVarsToTcTyVars final_tvs+       ; lhs_ty            <- zonkTcType  lhs_ty+       ; master_res_kind   <- zonkTcType  master_res_kind+       ; instance_res_kind <- zonkTcType  instance_res_kind+       ; stupid_theta      <- zonkTcTypes stupid_theta +       -- Check that res_kind is OK with checkDataKindSig.  We need to+       -- check that it's ok because res_kind can come from a user-written+       -- kind signature.  See Note [Datatype return kinds], point (4a)        ; checkDataKindSig (DataInstanceSort new_or_data) master_res_kind        ; checkDataKindSig (DataInstanceSort new_or_data) instance_res_kind -       -- Check that type patterns match the class instance head-       -- The call to splitTyConApp_maybe here is just an inlining of-       -- the body of unravelFamInstPats.-       ; pats <- case splitTyConApp_maybe lhs_ty of-           Just (_, pats) -> pure pats-           Nothing -> pprPanic "tcDataFamInstHeader" (ppr lhs_ty)+       -- Split up the LHS type to get the type patterns+       -- For the scopedSort see Note [Generalising in tcTyFamInstEqnGuts]+       ; let pats      = unravelFamInstPats lhs_ty -       ; return (qtvs, pats, master_res_kind, stupid_theta) }+       ; return (final_tvs, pats, master_res_kind, stupid_theta) }   where     fam_name  = tyConName fam_tc     data_ctxt = DataKindCtxt fam_name@@ -954,11 +987,9 @@     -- See Note [Result kind signature for a data family instance]     tc_kind_sig (Just hs_kind)       = do { sig_kind <- tcLHsKindSig data_ctxt hs_kind-           ; lvl <- getTcLevel-           ; let (tvs, inner_kind) = tcSplitForAllInvisTyVars sig_kind-           ; (subst, _tvs') <- tcInstSkolTyVarsAt lvl False emptyTCvSubst tvs-             -- Perhaps surprisingly, we don't need the skolemised tvs themselves-           ; return (substTy subst inner_kind) }+           ; (_tvs', inner_kind') <- tcSkolemiseInvisibleBndrs (SigTypeSkol data_ctxt) sig_kind+                   -- Perhaps surprisingly, we don't need the skolemised tvs themselves+           ; return inner_kind' }  {- Note [Result kind signature for a data family instance] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1054,6 +1085,23 @@   themselves.  Heavy sigh.  But not truly hard; that's what tcbVisibilities   does. +* Happily, we don't need to worry about the possibility of+  building an inhomogeneous axiom, described in GHC.Tc.TyCl.Build+  Note [Newtype eta and homogeneous axioms].   For example+     type F :: Type -> forall (b :: Type) -> Type+     data family F a b+     newtype instance F Int b = MkF (Proxy b)+  we get a newtype, and a eta-reduced axiom connecting the data family+  with the newtype:+     type R:FIntb :: forall (b :: Type) -> Type+     newtype R:FIntb b = MkF (Proxy b)+     axiom Foo.D:R:FIntb0 :: F Int = Foo.R:FIntb+  Now the subtleties of Note [Newtype eta and homogeneous axioms] are+  dealt with by the newtype (via mkNewTyConRhs called in tcDataFamInstDecl)+  while the axiom connecting F Int ~ R:FIntb is eta-reduced, but the+  quantifer 'b' is derived from the original data family F, and so the+  kinds will always match.+ Note [Kind inference for data family instances] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider this GADT-style data type declaration, where I have used@@ -1188,7 +1236,8 @@     setSrcSpan loc                              $     addErrCtxt (instDeclCtxt2 (idType dfun_id)) $     do {  -- Instantiate the instance decl with skolem constants-       ; (inst_tyvars, dfun_theta, inst_head) <- tcSkolDFunType dfun_id+       ; skol_info <- mkSkolemInfo InstSkol+       ; (inst_tyvars, dfun_theta, inst_head) <- tcSkolDFunType skol_info dfun_id        ; dfun_ev_vars <- newEvVars dfun_theta                      -- We instantiate the dfun_id with superSkolems.                      -- See Note [Subtle interaction of recursion and overlap]@@ -1250,8 +1299,8 @@                      --    con_app_tys  = MkD ty1 ty2                      --    con_app_scs  = MkD ty1 ty2 sc1 sc2                      --    con_app_args = MkD ty1 ty2 sc1 sc2 op1 op2-             con_app_tys  = mkHsWrap (mkWpTyApps inst_tys)-                                  (HsConLikeOut noExtField (RealDataCon dict_constr))+             con_app_tys  = mkHsWrap (mkWpTyApps inst_tys) $+                            mkConLikeTc (RealDataCon dict_constr)                        -- NB: We *can* have covars in inst_tys, in the case of                        -- promoted GADT constructors. @@ -1272,14 +1321,13 @@                     -- Newtype dfuns just inline unconditionally,                     -- so don't attempt to specialise them -             export = ABE { abe_ext  = noExtField-                          , abe_wrap = idHsWrapper+             export = ABE { abe_wrap = idHsWrapper                           , abe_poly = dfun_id_w_prags                           , abe_mono = self_dict                           , abe_prags = dfun_spec_prags }                           -- NB: see Note [SPECIALISE instance pragmas]-             main_bind = AbsBinds { abs_ext = noExtField-                                  , abs_tvs = inst_tyvars+             main_bind = XHsBindsLR $+                         AbsBinds { abs_tvs = inst_tyvars                                   , abs_ev_vars = dfun_ev_vars                                   , abs_exports = [export]                                   , abs_ev_binds = []@@ -1313,8 +1361,9 @@  where    con_app    = mkLams dfun_bndrs $                 mkApps (Var (dataConWrapId dict_con)) dict_args-                 -- mkApps is OK because of the checkForLevPoly call in checkValidClass-                 -- See Note [Levity polymorphism checking] in GHC.HsToCore.Monad+                -- This application will satisfy the Core invariants+                -- from Note [Representation polymorphism invariants] in GHC.Core,+                -- because typeclass method types are never unlifted.    dict_args  = map Type inst_tys ++                 [mkVarApps (Var id) dfun_bndrs | id <- sc_meth_ids] @@ -1425,14 +1474,13 @@            ; let sc_top_ty = mkInfForAllTys tyvars $                              mkPhiTy (map idType dfun_evs) sc_pred                  sc_top_id = mkLocalId sc_top_name Many sc_top_ty-                 export = ABE { abe_ext  = noExtField-                              , abe_wrap = idHsWrapper+                 export = ABE { abe_wrap = idHsWrapper                               , abe_poly = sc_top_id                               , abe_mono = sc_ev_id                               , abe_prags = noSpecPrags }                  local_ev_binds = TcEvBinds ev_binds_var-                 bind = AbsBinds { abs_ext      = noExtField-                                 , abs_tvs      = tyvars+                 bind = XHsBindsLR $+                        AbsBinds { abs_tvs      = tyvars                                  , abs_ev_vars  = dfun_evs                                  , abs_exports  = [export]                                  , abs_ev_binds = [dfun_ev_binds, local_ev_binds]@@ -1710,7 +1758,7 @@                -> TcM (TcId, LHsBind GhcTc, Maybe Implication)      tc_default sel_id (Just (dm_name, _))-      = do { (meth_bind, inline_prags) <- mkDefMethBind dfun_id clas sel_id dm_name+      = do { (meth_bind, inline_prags) <- mkDefMethBind inst_loc dfun_id clas sel_id dm_name            ; tcMethodBody clas tyvars dfun_ev_vars inst_tys                           dfun_ev_binds is_derived hs_sig_fn                           spec_inst_prags inline_prags@@ -1860,15 +1908,14 @@        ; spec_prags     <- tcSpecPrags global_meth_id prags          ; let specs  = mk_meth_spec_prags global_meth_id spec_inst_prags spec_prags-              export = ABE { abe_ext   = noExtField-                           , abe_poly  = global_meth_id+              export = ABE { abe_poly  = global_meth_id                            , abe_mono  = local_meth_id                            , abe_wrap  = idHsWrapper                            , abe_prags = specs }                local_ev_binds = TcEvBinds ev_binds_var-              full_bind = AbsBinds { abs_ext      = noExtField-                                   , abs_tvs      = tyvars+              full_bind = XHsBindsLR $+                          AbsBinds { abs_tvs      = tyvars                                    , abs_ev_vars  = dfun_ev_vars                                    , abs_exports  = [export]                                    , abs_ev_binds = [dfun_ev_binds, local_ev_binds]@@ -1894,9 +1941,9 @@              <- setSrcSpan (getLocA hs_sig_ty) $                 do { inst_sigs <- xoptM LangExt.InstanceSigs                    ; checkTc inst_sigs (misplacedInstSig sel_name hs_sig_ty)-                   ; sig_ty  <- tcHsSigType (FunSigCtxt sel_name False) hs_sig_ty+                   ; let ctxt = FunSigCtxt sel_name NoRRC+                   ; sig_ty  <- tcHsSigType ctxt hs_sig_ty                    ; let local_meth_ty = idType local_meth_id-                         ctxt = FunSigCtxt sel_name False                                 -- False <=> do not report redundant constraints when                                 --           checking instance-sig <= class-meth-sig                                 -- The instance-sig is the focus here; the class-meth-sig@@ -1907,8 +1954,8 @@                    ; return (sig_ty, hs_wrap) }         ; inner_meth_name <- newName (nameOccName sel_name)-       ; let ctxt = FunSigCtxt sel_name True-                    -- True <=> check for redundant constraints in the+       ; let ctxt = FunSigCtxt sel_name (lhsSigTypeContextSpan hs_sig_ty)+                    -- WantRCC <=> check for redundant constraints in the                     --          user-specified instance signature              inner_meth_id  = mkLocalId inner_meth_name Many sig_ty              inner_meth_sig = CompleteSig { sig_bndr = inner_meth_id@@ -1918,21 +1965,20 @@         ; (tc_bind, [inner_id]) <- tcPolyCheck no_prag_fn inner_meth_sig meth_bind -       ; let export = ABE { abe_ext   = noExtField-                          , abe_poly  = local_meth_id+       ; let export = ABE { abe_poly  = local_meth_id                           , abe_mono  = inner_id                           , abe_wrap  = hs_wrap                           , abe_prags = noSpecPrags } -       ; return (unitBag $ L (getLoc meth_bind) $-                 AbsBinds { abs_ext = noExtField, abs_tvs = [], abs_ev_vars = []+       ; return (unitBag $ L (getLoc meth_bind) $ XHsBindsLR $+                 AbsBinds { abs_tvs = [], abs_ev_vars = []                           , abs_exports = [export]                           , abs_binds = tc_bind, abs_ev_binds = []                           , abs_sig = True }) }    | otherwise  -- No instance signature-  = do { let ctxt = FunSigCtxt sel_name False-                    -- False <=> don't report redundant constraints+  = do { let ctxt = FunSigCtxt sel_name NoRRC+                    -- NoRRC <=> don't report redundant constraints                     -- The signature is not under the users control!              tc_sig = completeSigFromId ctxt local_meth_id               -- Absent a type sig, there are no new scoped type variables here@@ -1950,7 +1996,6 @@     no_prag_fn = emptyPragEnv   -- No pragmas for local_meth_id;                                 -- they are all for meth_id - ------------------------ mkMethIds :: Class -> [TcTyVar] -> [EvVar]           -> [TcType] -> Id -> TcM (TcId, TcId)@@ -1967,7 +2012,8 @@         ; return (poly_meth_id, local_meth_id) }   where     sel_name      = idName sel_id-    sel_occ       = nameOccName sel_name+    -- Force so that a thunk doesn't end up in a Name (#19619)+    !sel_occ      = nameOccName sel_name     local_meth_ty = instantiateMethod clas sel_id inst_tys     poly_meth_ty  = mkSpecSigmaTy tyvars theta local_meth_ty     theta         = map idType dfun_ev_vars@@ -1982,9 +2028,10 @@                               , text "   Class sig:" <+> ppr meth_ty ])        ; return (env2, msg) } -misplacedInstSig :: Name -> LHsSigType GhcRn -> SDoc+misplacedInstSig :: Name -> LHsSigType GhcRn -> TcRnMessage misplacedInstSig name hs_ty-  = vcat [ hang (text "Illegal type signature in instance declaration:")+  = TcRnUnknownMessage $ mkPlainError noHints $+    vcat [ hang (text "Illegal type signature in instance declaration:")               2 (hang (pprPrefixName name)                     2 (dcolon <+> ppr hs_ty))          , text "(Use InstanceSigs to allow this)" ]@@ -2058,7 +2105,7 @@          | L inst_loc (SpecPrag _       wrap inl) <- spec_inst_prags]  -mkDefMethBind :: DFunId -> Class -> Id -> Name+mkDefMethBind :: SrcSpan -> DFunId -> Class -> Id -> Name               -> TcM (LHsBind GhcRn, [LSig GhcRn]) -- The is a default method (vanailla or generic) defined in the class -- So make a binding   op = $dmop @t1 @t2@@ -2066,9 +2113,8 @@ -- and t1,t2 are the instance types. -- See Note [Default methods in instances] for why we use -- visible type application here-mkDefMethBind dfun_id clas sel_id dm_name-  = do  { dflags <- getDynFlags-        ; logger <- getLogger+mkDefMethBind loc dfun_id clas sel_id dm_name+  = do  { logger <- getLogger         ; dm_id <- tcLookupId dm_name         ; let inline_prag = idInlinePragma dm_id               inline_prags | isAnyInlinePragma inline_prag@@ -2082,10 +2128,11 @@               visible_inst_tys = [ ty | (tcb, ty) <- tyConBinders (classTyCon clas) `zip` inst_tys                                       , tyConBinderArgFlag tcb /= Inferred ]               rhs  = foldl' mk_vta (nlHsVar dm_name) visible_inst_tys-              bind = noLocA $ mkTopFunBind Generated fn $-                             [mkSimpleMatch (mkPrefixFunRhs fn) [] rhs]+              bind = L (noAnnSrcSpan loc)+                    $ mkTopFunBind Generated fn+                        [mkSimpleMatch (mkPrefixFunRhs fn) [] rhs] -        ; liftIO (dumpIfSet_dyn logger dflags Opt_D_dump_deriv "Filling in method body"+        ; liftIO (putDumpFileMaybe logger Opt_D_dump_deriv "Filling in method body"                    FormatHaskell                    (vcat [ppr clas <+> ppr inst_tys,                           nest 2 (ppr sel_id <+> equals <+> ppr rhs)]))@@ -2111,7 +2158,9 @@ warnUnsatisfiedMinimalDefinition :: ClassMinimalDef -> TcM () warnUnsatisfiedMinimalDefinition mindef   = do { warn <- woptM Opt_WarnMissingMethods-       ; warnTc (Reason Opt_WarnMissingMethods) warn message+       ; let msg = TcRnUnknownMessage $+               mkPlainDiagnostic (WarningWithFlag Opt_WarnMissingMethods) noHints message+       ; diagnosticTc warn msg        }   where     message = vcat [text "No explicit implementation for"@@ -2330,26 +2379,30 @@ inst_decl_ctxt doc = hang (text "In the instance declaration for")                         2 (quotes doc) -badBootFamInstDeclErr :: SDoc+badBootFamInstDeclErr :: TcRnMessage badBootFamInstDeclErr-  = text "Illegal family instance in hs-boot file"+  = TcRnUnknownMessage $ mkPlainError noHints $ text "Illegal family instance in hs-boot file" -notFamily :: TyCon -> SDoc+notFamily :: TyCon -> TcRnMessage notFamily tycon-  = vcat [ text "Illegal family instance for" <+> quotes (ppr tycon)+  = TcRnUnknownMessage $ mkPlainError noHints $+    vcat [ text "Illegal family instance for" <+> quotes (ppr tycon)          , nest 2 $ parens (ppr tycon <+> text "is not an indexed type family")] -assocInClassErr :: TyCon -> SDoc+assocInClassErr :: TyCon -> TcRnMessage assocInClassErr name- = text "Associated type" <+> quotes (ppr name) <+>+ = TcRnUnknownMessage $ mkPlainError noHints $+   text "Associated type" <+> quotes (ppr name) <+>    text "must be inside a class instance" -badFamInstDecl :: TyCon -> SDoc+badFamInstDecl :: TyCon -> TcRnMessage badFamInstDecl tc_name-  = vcat [ text "Illegal family instance for" <+>+  = TcRnUnknownMessage $ mkPlainError noHints $+    vcat [ text "Illegal family instance for" <+>            quotes (ppr tc_name)          , nest 2 (parens $ text "Use TypeFamilies to allow indexed type families") ] -notOpenFamily :: TyCon -> SDoc+notOpenFamily :: TyCon -> TcRnMessage notOpenFamily tc-  = text "Illegal instance for closed family" <+> quotes (ppr tc)+  = TcRnUnknownMessage $ mkPlainError noHints $+  text "Illegal instance for closed family" <+> quotes (ppr tc)
GHC/Tc/TyCl/Instance.hs-boot view
@@ -13,4 +13,4 @@ -- We need this because of the mutual recursion -- between GHC.Tc.TyCl and GHC.Tc.TyCl.Instance tcInstDecls1 :: [LInstDecl GhcRn]-             -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo])+             -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo], ThBindEnv)
GHC/Tc/TyCl/PatSyn.hs view
@@ -23,8 +23,9 @@ import GHC.Hs import GHC.Tc.Gen.Pat import GHC.Core.Multiplicity-import GHC.Core.Type ( tidyTyCoVarBinders, tidyTypes, tidyType )+import GHC.Core.Type ( tidyTyCoVarBinders, tidyTypes, tidyType, isManyDataConTy ) import GHC.Core.TyCo.Subst( extendTvSubstWithClone )+import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Tc.Gen.Sig ( TcPragEnv, emptyPragEnv, completeSigFromId, lookupPragEnv                       , addInlinePrags, addInlinePragArity )@@ -32,6 +33,7 @@ import GHC.Tc.Utils.TcMType import GHC.Tc.Utils.Zonk import GHC.Builtin.Types.Prim+import GHC.Types.Error import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.SrcLoc@@ -59,6 +61,7 @@ import GHC.Core.ConLike import GHC.Types.FieldLabel import GHC.Rename.Env+import GHC.Rename.Utils (wrapGenSpan) import GHC.Data.Bag import GHC.Utils.Misc import GHC.Driver.Session ( getDynFlags, xopt_FieldSelectors )@@ -66,8 +69,6 @@ import Control.Monad ( zipWithM ) import Data.List( partition, mapAccumL ) -#include "HsVersions.h"- {- ************************************************************************ *                                                                      *@@ -152,8 +153,8 @@         ; let (arg_names, is_infix) = collectPatSynArgInfo details        ; (tclvl, wanted, ((lpat', args), pat_ty))-            <- pushLevelAndCaptureConstraints  $-               tcInferPat PatSyn lpat          $+            <- pushLevelAndCaptureConstraints      $+               tcInferPat FRRPatSynArg PatSyn lpat $                mapM tcLookupId arg_names         ; let (ex_tvs, prov_dicts) = tcCollectEx lpat'@@ -241,6 +242,7 @@ -- See Note [Coercions that escape] dependentArgErr (arg, bad_cos)   = failWithTc $  -- fail here: otherwise we get downstream errors+    TcRnUnknownMessage $ mkPlainError noHints $     vcat [ text "Iceland Jack!  Iceland Jack! Stop torturing me!"          , hang (text "Pattern-bound variable")               2 (ppr arg <+> dcolon <+> ppr (idType arg))@@ -327,7 +329,7 @@ So in mkProvEvidence we lift (a ~# b) to (a ~ b).  Tiresome, and marginally less efficient, if the builder/martcher are not inlined. -See also Note [Lift equality constraints when quantifying] in GHC.Tc.Utils.TcType+See also Note [Lift equality constraints when quantifying] in GHC.Tc.Solver  Note [Coercions that escape] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -405,7 +407,7 @@        -- The existential 'x' should not appear in the result type        -- Can't check this until we know P's arity (decl_arity above)        ; let bad_tvs = filter (`elemVarSet` tyCoVarsOfType pat_ty) $ binderVars explicit_ex_bndrs-       ; checkTc (null bad_tvs) $+       ; checkTc (null bad_tvs) $ TcRnUnknownMessage $ mkPlainError noHints $          hang (sep [ text "The result type of the signature for" <+> quotes (ppr name) <> comma                    , text "namely" <+> quotes (ppr pat_ty) ])             2 (text "mentions existential type variable" <> plural bad_tvs@@ -420,13 +422,22 @@              univ_tvs   = binderVars univ_bndrs              ex_tvs     = binderVars ex_bndrs +         -- Pattern synonyms currently cannot be linear (#18806)+       ; checkTc (all (isManyDataConTy . scaledMult) arg_tys) $+           TcRnLinearPatSyn sig_body_ty++       ; skol_info <- mkSkolemInfo (SigSkol (PatSynCtxt name) pat_ty [])+                         -- The type here is a bit bogus, but we do not print+                         -- the type for PatSynCtxt, so it doesn't matter+                         -- See Note [Skolem info for pattern synonyms] in "GHC.Tc.Types.Origin"+          -- Skolemise the quantified type variables. This is necessary          -- in order to check the actual pattern type against the          -- expected type. Even though the tyvars in the type are          -- already skolems, this step changes their TcLevels,          -- avoiding level-check errors when unifying.-       ; (skol_subst0, skol_univ_bndrs) <- skolemiseTvBndrsX emptyTCvSubst univ_bndrs-       ; (skol_subst, skol_ex_bndrs)    <- skolemiseTvBndrsX skol_subst0   ex_bndrs+       ; (skol_subst0, skol_univ_bndrs) <- skolemiseTvBndrsX skol_info emptyTCvSubst univ_bndrs+       ; (skol_subst, skol_ex_bndrs)    <- skolemiseTvBndrsX skol_info skol_subst0   ex_bndrs        ; let skol_univ_tvs   = binderVars skol_univ_bndrs              skol_ex_tvs     = binderVars skol_ex_bndrs              skol_req_theta  = substTheta skol_subst0 req_theta@@ -441,7 +452,7 @@        -- See Note [Checking against a pattern signature]        ; req_dicts <- newEvVars skol_req_theta        ; (tclvl, wanted, (lpat', (ex_tvs', prov_dicts, args'))) <--           ASSERT2( equalLength arg_names arg_tys, ppr name $$ ppr arg_names $$ ppr arg_tys )+           assertPpr (equalLength arg_names arg_tys) (ppr name $$ ppr arg_names $$ ppr arg_tys) $            pushLevelAndCaptureConstraints   $            tcExtendNameTyVarEnv univ_tv_prs $            tcCheckPat PatSyn lpat (unrestricted skol_pat_ty)   $@@ -463,11 +474,7 @@                                        skol_arg_tys               ; return (ex_tvs', prov_dicts, args') } -       ; let skol_info = SigSkol (PatSynCtxt name) pat_ty []-                         -- The type here is a bit bogus, but we do not print-                         -- the type for PatSynCtxt, so it doesn't matter-                         -- See Note [Skolem info for pattern synonyms] in "GHC.Tc.Types.Origin"-       ; (implics, ev_binds) <- buildImplicationFor tclvl skol_info skol_univ_tvs+       ; (implics, ev_binds) <- buildImplicationFor tclvl (getSkolemInfo skol_info) skol_univ_tvs                                                     req_dicts wanted         -- Solve the constraints now, because we are about to make a PatSyn,@@ -508,15 +515,15 @@                 -- See Note [Pattern synonyms and higher rank types]            ; return (mkLHsWrap wrap $ nlHsVar arg_id) } -skolemiseTvBndrsX :: TCvSubst -> [VarBndr TyVar flag]+skolemiseTvBndrsX :: SkolemInfo -> TCvSubst -> [VarBndr TyVar flag]                   -> TcM (TCvSubst, [VarBndr TcTyVar flag]) -- Make new TcTyVars, all skolems with levels, but do not clone -- The level is one level deeper than the current level -- See Note [Skolemising when checking a pattern synonym]-skolemiseTvBndrsX orig_subst tvs+skolemiseTvBndrsX skol_info orig_subst tvs   = do { tc_lvl <- getTcLevel        ; let pushed_lvl = pushTcLevel tc_lvl-             details    = SkolemTv pushed_lvl False+             details    = SkolemTv skol_info pushed_lvl False               mk_skol_tv_x :: TCvSubst -> VarBndr TyVar flag                           -> (TCvSubst, VarBndr TcTyVar flag)@@ -545,8 +552,8 @@ GHC.Tc.Utils.Instantiate.tcInstSkolTyVarsX except that the latter does cloning. -[Pattern synonyms and higher rank types]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Note [Pattern synonyms and higher rank types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider   data T = MkT (forall a. a->a) @@ -674,8 +681,8 @@  wrongNumberOfParmsErr :: Name -> Arity -> Arity -> TcM a wrongNumberOfParmsErr name decl_arity missing-  = failWithTc $-    hang (text "Pattern synonym" <+> quotes (ppr name) <+> ptext (sLit "has")+  = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $+    hang (text "Pattern synonym" <+> quotes (ppr name) <+> text "has"           <+> speakNOf decl_arity (text "argument"))        2 (text "but its type signature has" <+> int missing <+> text "fewer arrows") @@ -688,7 +695,10 @@                  -> TcPragEnv                  -> ([TcInvisTVBinder], [PredType], TcEvBinds, [EvVar])                  -> ([TcInvisTVBinder], [TcType], [PredType], [EvTerm])-                 -> ([LHsExpr GhcTc], [TcType])  -- ^ Pattern arguments and types+                 -> ([LHsExpr GhcTc], [TcTypeFRR])+                   -- ^ Pattern arguments and types.+                   -- These must have a syntactically fixed RuntimeRep as per+                   -- Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete.                  -> TcType            -- ^ Pattern type                  -> [FieldLabel]      -- ^ Selector names                  -- ^ Whether fields, empty if not record PatSyn@@ -782,7 +792,7 @@        ; tv_name <- newNameAt (mkTyVarOcc "r")   loc'        ; let rr_tv  = mkTyVar rr_name runtimeRepTy              rr     = mkTyVarTy rr_tv-             res_tv = mkTyVar tv_name (tYPE rr)+             res_tv = mkTyVar tv_name (mkTYPEapp rr)              res_ty = mkTyVarTy res_tv              is_unlifted = null args && null prov_dicts              (cont_args, cont_arg_tys)@@ -802,6 +812,7 @@        ; let matcher_tau   = mkVisFunTysMany [pat_ty, cont_ty, fail_ty] res_ty              matcher_sigma = mkInfSigmaTy (rr_tv:res_tv:univ_tvs) req_theta matcher_tau              matcher_id    = mkExportedVanillaId matcher_name matcher_sigma+             patsyn_id     = mkExportedVanillaId ps_name matcher_sigma                              -- See Note [Exported LocalIds] in GHC.Types.Id               inst_wrap = mkWpEvApps prov_dicts <.> mkWpTyApps ex_tys@@ -829,7 +840,7 @@                        , mg_ext = MatchGroupTc (map unrestricted [pat_ty, cont_ty, fail_ty]) res_ty                        , mg_origin = Generated                        }-             match = mkMatch (mkPrefixFunRhs (L loc ps_name)) []+             match = mkMatch (mkPrefixFunRhs (L loc patsyn_id)) []                              (mkHsLams (rr_tv:res_tv:univ_tvs)                                        req_dicts body')                              (EmptyLocalBinds noExtField)@@ -892,6 +903,8 @@   = do { builder_name <- newImplicitBinder name mkBuilderOcc        ; let theta          = req_theta ++ prov_theta              need_dummy_arg = isUnliftedType pat_ty && null arg_tys && null theta+                              -- NB: pattern arguments cannot be representation-polymorphic,+                              -- as checked in 'tcPatSynSig'. So 'isUnliftedType' is OK here.              builder_sigma  = add_void need_dummy_arg $                               mkInvisForAllTys univ_bndrs $                               mkInvisForAllTys ex_bndrs $@@ -913,7 +926,7 @@   = return emptyBag    | Left why <- mb_match_group       -- Can't invert the pattern-  = setSrcSpan (getLocA lpat) $ failWithTc $+  = setSrcSpan (getLocA lpat) $ failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $     vcat [ hang (text "Invalid right-hand side of bidirectional pattern synonym"                  <+> quotes (ppr ps_name) <> colon)               2 why@@ -997,7 +1010,7 @@ patSynBuilderOcc :: PatSyn -> Maybe (HsExpr GhcTc, TcSigmaType) patSynBuilderOcc ps   | Just (_, builder_ty, add_void_arg) <- patSynBuilder ps-  , let builder_expr = HsConLikeOut noExtField (PatSynCon ps)+  , let builder_expr = mkConLikeTc (PatSynCon ps)   = Just $     if add_void_arg     then ( builder_expr   -- still just return builder_expr; the void# arg@@ -1063,11 +1076,10 @@         = return $ HsVar noExtField (L l var)         | otherwise         = Left (quotes (ppr var) <+> text "is not bound by the LHS of the pattern synonym")-    go1 (ParPat _ pat)          = fmap (HsPar noAnn) $ go pat-    go1 p@(ListPat reb pats)-      | Nothing <- reb = do { exprs <- mapM go pats-                            ; return $ ExplicitList noExtField exprs }-      | otherwise                   = notInvertibleListPat p+    go1 (ParPat _ lpar pat rpar) = fmap (\e -> HsPar noAnn lpar e rpar) $ go pat+    go1 (ListPat _ pats)+      = do { exprs <- mapM go pats+           ; return $ ExplicitList noExtField exprs }     go1 (TuplePat _ pats box)       = do { exprs <- mapM go pats                                          ; return $ ExplicitTuple noExtField                                            (map (Present noAnn) exprs) box }@@ -1084,13 +1096,21 @@     go1 (SplicePat _ (HsSpliced _ _ (HsSplicedPat pat)))                                     = go1 pat     go1 (SplicePat _ (HsSpliced{})) = panic "Invalid splice variety"+    go1 (XPat (HsPatExpanded _ pat))= go1 pat +    -- See Note [Invertible view patterns]+    go1 p@(ViewPat mbInverse _ pat) = case mbInverse of+      Nothing      -> notInvertible p+      Just inverse ->+        fmap+          (\ expr -> HsApp noAnn (wrapGenSpan inverse) (wrapGenSpan expr))+          (go1 (unLoc pat))+     -- The following patterns are not invertible.     go1 p@(BangPat {})                       = notInvertible p -- #14112     go1 p@(LazyPat {})                       = notInvertible p     go1 p@(WildPat {})                       = notInvertible p     go1 p@(AsPat {})                         = notInvertible p-    go1 p@(ViewPat {})                       = notInvertible p     go1 p@(NPlusKPat {})                     = notInvertible p     go1 p@(SplicePat _ (HsTypedSplice {}))   = notInvertible p     go1 p@(SplicePat _ (HsUntypedSplice {})) = notInvertible p@@ -1109,27 +1129,23 @@         pp_name = ppr name         pp_args = hsep (map ppr args) -    -- We should really be able to invert list patterns, even when-    -- rebindable syntax is on, but doing so involves a bit of-    -- refactoring; see #14380.  Until then we reject with a-    -- helpful error message.-    notInvertibleListPat p-      = Left (vcat [ not_invertible_msg p-                   , text "Reason: rebindable syntax is on."-                   , text "This is fixable: add use-case to #14380" ])  {- Note [Builder for a bidirectional pattern synonym] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-For a bidirectional pattern synonym we need to produce an /expression/-that matches the supplied /pattern/, given values for the arguments-of the pattern synonym.  For example+For a bidirectional pattern synonym, the function 'tcPatToExpr'+needs to produce an /expression/ that matches the supplied /pattern/,+given values for the arguments of the pattern synonym. For example:   pattern F x y = (Just x, [y]) The 'builder' for F looks like   $builderF x y = (Just x, [y])  We can't always do this:- * Some patterns aren't invertible; e.g. view patterns-      pattern F x = (reverse -> x:_)+ * Some patterns aren't invertible; e.g. general view patterns+      pattern F x = (f -> x)+   as we don't have the ability to write down an expression that matches+   the view pattern specified by an arbitrary view function `f`.+   It is however sometimes possible to write down an inverse;+     see Note [Invertible view patterns].   * The RHS pattern might bind more variables than the pattern    synonym, so again we can't invert it@@ -1138,7 +1154,22 @@  * Ditto wildcards       pattern F x = (x,_) +Note [Invertible view patterns]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For some view patterns, such as those that arise from expansion of overloaded+patterns (as detailed in Note [Handling overloaded and rebindable patterns]),+we are able to explicitly write out an inverse (in the sense of the previous+Note [Builder for a bidirectional pattern synonym]).+For instance, the inverse to the pattern +  (toList -> [True, False])++is the expression++  (fromListN 2 [True,False])++Keeping track of the inverse for such view patterns fixed #14380.+ Note [Redundant constraints for builder] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The builder can have redundant constraints, which are awkward to eliminate.@@ -1250,7 +1281,7 @@     go1 :: Pat GhcTc -> ([TyVar], [EvVar])     go1 (LazyPat _ p)      = go p     go1 (AsPat _ _ p)      = go p-    go1 (ParPat _ p)       = go p+    go1 (ParPat _ _ p _)   = go p     go1 (BangPat _ p)      = go p     go1 (ListPat _ ps)     = mergeMany . map go $ ps     go1 (TuplePat _ ps _)  = mergeMany . map go $ ps@@ -1260,7 +1291,9 @@                            = merge (cpt_tvs con', cpt_dicts con') $                               goConDetails $ pat_args con     go1 (SigPat _ p _)     = go p-    go1 (XPat (CoPat _ p _)) = go1 p+    go1 (XPat ext) = case ext of+      CoPat _ p _      -> go1 p+      ExpansionPat _ p -> go1 p     go1 (NPlusKPat _ n k _ geq subtract)       = pprPanic "TODO: NPlusKPat" $ ppr n $$ ppr k $$ ppr geq $$ ppr subtract     go1 _                   = empty@@ -1272,7 +1305,7 @@       = mergeMany . map goRecFd $ flds      goRecFd :: LHsRecField GhcTc (LPat GhcTc) -> ([TyVar], [EvVar])-    goRecFd (L _ HsRecField{ hsRecFieldArg = p }) = go p+    goRecFd (L _ HsFieldBind{ hfbRHS = p }) = go p      merge (vs1, evs1) (vs2, evs2) = (vs1 ++ vs2, evs1 ++ evs2)     mergeMany = foldr merge empty
GHC/Tc/TyCl/Utils.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE TypeFamilies #-} @@ -27,10 +27,9 @@         tcRecSelBinds, mkRecSelBinds, mkOneRecordSelector     ) where -#include "HsVersions.h"- import GHC.Prelude +import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Env import GHC.Tc.Gen.Bind( tcValBinds )@@ -55,6 +54,7 @@  import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Utils.Misc import GHC.Utils.FV as FV @@ -65,6 +65,7 @@ import GHC.Unit.Module  import GHC.Types.Basic+import GHC.Types.Error import GHC.Types.FieldLabel import GHC.Types.SrcLoc import GHC.Types.SourceFile@@ -91,11 +92,11 @@ -}  synonymTyConsOfType :: Type -> [TyCon]--- Does not look through type synonyms at all--- Return a list of synonym tycons+-- Does not look through type synonyms at all.+-- Returns a list of synonym tycons in nondeterministic order. -- Keep this synchronized with 'expandTypeSynonyms' synonymTyConsOfType ty-  = nameEnvElts (go ty)+  = nonDetNameEnvElts (go ty)   where      go :: Type -> NameEnv TyCon  -- The NameEnv does duplicate elim      go (TyConApp tc tys) = go_tc tc `plusNameEnv` go_s tys@@ -205,7 +206,7 @@ checkSynCycles :: Unit -> [TyCon] -> [LTyClDecl GhcRn] -> TcM () checkSynCycles this_uid tcs tyclds =     case runSynCycleM (mapM_ (go emptyTyConSet []) tcs) emptyTyConSet of-        Left (loc, err) -> setSrcSpan loc $ failWithTc err+        Left (loc, err) -> setSrcSpan loc $ failWithTc (TcRnUnknownMessage $ mkPlainError noHints err)         Right _  -> return ()   where     -- Try our best to print the LTyClDecl for locally defined things@@ -650,6 +651,8 @@      -- recurring into coercions. Recall: coercions are totally ignored during      -- role inference. See [Coercions in role inference]     get_ty_vars :: Type -> FV+    get_ty_vars t                 | Just t' <- coreView t -- #20999+                                  = get_ty_vars t'     get_ty_vars (TyVarTy tv)      = unitFV tv     get_ty_vars (AppTy t1 t2)     = get_ty_vars t1 `unionFV` get_ty_vars t2     get_ty_vars (FunTy _ w t1 t2) = get_ty_vars w `unionFV` get_ty_vars t1 `unionFV` get_ty_vars t2@@ -715,21 +718,21 @@  setRoleInferenceTc :: Name -> RoleM a -> RoleM a setRoleInferenceTc name thing = RM $ \m_name vps nvps state ->-                                ASSERT( isNothing m_name )-                                ASSERT( isEmptyVarEnv vps )-                                ASSERT( nvps == 0 )+                                assert (isNothing m_name) $+                                assert (isEmptyVarEnv vps) $+                                assert (nvps == 0) $                                 unRM thing (Just name) vps nvps state  addRoleInferenceVar :: TyVar -> RoleM a -> RoleM a addRoleInferenceVar tv thing   = RM $ \m_name vps nvps state ->-    ASSERT( isJust m_name )+    assert (isJust m_name) $     unRM thing m_name (extendVarEnv vps tv nvps) (nvps+1) state  setRoleInferenceVars :: [TyVar] -> RoleM a -> RoleM a setRoleInferenceVars tvs thing   = RM $ \m_name _vps _nvps state ->-    ASSERT( isJust m_name )+    assert (isJust m_name) $     unRM thing m_name (mkVarEnv (zip tvs [0..])) (panic "setRoleInferenceVars")          state @@ -764,12 +767,14 @@ *                                                                      * ********************************************************************* -} -addTyConsToGblEnv :: [TyCon] -> TcM TcGblEnv+addTyConsToGblEnv :: [TyCon] -> TcM (TcGblEnv, ThBindEnv) -- Given a [TyCon], add to the TcGblEnv --   * extend the TypeEnv with the tycons --   * extend the TypeEnv with their implicitTyThings --   * extend the TypeEnv with any default method Ids --   * add bindings for record selectors+-- Return separately the TH levels of these bindings,+-- to be added to a LclEnv later. addTyConsToGblEnv tyclss   = tcExtendTyConEnv tyclss                    $     tcExtendGlobalEnvImplicit implicit_things  $@@ -777,7 +782,10 @@     do { traceTc "tcAddTyCons" $ vcat             [ text "tycons" <+> ppr tyclss             , text "implicits" <+> ppr implicit_things ]-       ; tcRecSelBinds (mkRecSelBinds tyclss) }+       ; gbl_env <- tcRecSelBinds (mkRecSelBinds tyclss)+       ; th_bndrs <- tcTyThBinders implicit_things+       ; return (gbl_env, th_bndrs)+       }  where    implicit_things = concatMap implicitTyConThings tyclss    def_meth_ids    = mkDefaultMethodIds tyclss@@ -880,6 +888,7 @@     loc      = getSrcSpan sel_name     loc'     = noAnnSrcSpan loc     locn     = noAnnSrcSpan loc+    locc     = noAnnSrcSpan loc     lbl      = flLabel fl     sel_name = flSelector fl @@ -888,7 +897,7 @@      -- Find a representative constructor, con1     cons_w_field = conLikesWithFields all_cons [lbl]-    con1 = ASSERT( not (null cons_w_field) ) head cons_w_field+    con1 = assert (not (null cons_w_field)) $ head cons_w_field      -- Selector type; Note [Polymorphic selectors]     field_ty   = conLikeFieldType con1 lbl@@ -899,7 +908,8 @@                     || has_sel == NoFieldSelectors     sel_ty | is_naughty = unitTy  -- See Note [Naughty record selectors]            | otherwise  = mkForAllTys (tyVarSpecToBinders data_tvbs) $-                          mkPhiTy (conLikeStupidTheta con1) $   -- Urgh!+                          -- Urgh! See Note [The stupid context] in GHC.Core.DataCon+                          mkPhiTy (conLikeStupidTheta con1) $                           -- req_theta is empty for normal DataCon                           mkPhiTy req_theta                 $                           mkVisFunTyMany data_ty            $@@ -921,14 +931,14 @@                                  (L loc' (HsVar noExtField (L locn field_var)))     mk_sel_pat con = ConPat NoExtField (L locn (getName con)) (RecCon rec_fields)     rec_fields = HsRecFields { rec_flds = [rec_field], rec_dotdot = Nothing }-    rec_field  = noLocA (HsRecField-                        { hsRecFieldAnn = noAnn-                        , hsRecFieldLbl-                           = L loc (FieldOcc sel_name-                                     (L locn $ mkVarUnqual lbl))-                        , hsRecFieldArg+    rec_field  = noLocA (HsFieldBind+                        { hfbAnn = noAnn+                        , hfbLHS+                           = L locc (FieldOcc sel_name+                                      (L locn $ mkVarUnqual lbl))+                        , hfbRHS                            = L loc' (VarPat noExtField (L locn field_var))-                        , hsRecPun = False })+                        , hfbPun = False })     sel_lname = L locn sel_name     field_var = mkInternalName (mkBuiltinUnique 1) (getOccName sel_name) loc @@ -961,14 +971,14 @@     eq_subst = mkTvSubstPrs (map eqSpecPair eq_spec)     -- inst_tys corresponds to one of the following:     ---    -- * The arguments to the user-written return type (for GADT constructors).-    --   In this scenario, eq_subst provides a mapping from the universally-    --   quantified type variables to the argument types. Note that eq_subst-    --   does not need to be applied to any other part of the DataCon-    --   (see Note [The dcEqSpec domain invariant] in GHC.Core.DataCon).-    -- * The universally quantified type variables-    --   (for Haskell98-style constructors and pattern synonyms). In these-    --   scenarios, eq_subst is an empty substitution.+    --  * The arguments to the user-written return type (for GADT constructors).+    --    In this scenario, eq_subst provides a mapping from the universally+    --    quantified type variables to the argument types. Note that eq_subst+    --    does not need to be applied to any other part of the DataCon+    --    (see Note [The dcEqSpec domain invariant] in GHC.Core.DataCon).+    --  * The universally quantified type variables+    --    (for Haskell98-style constructors and pattern synonyms). In these+    --    scenarios, eq_subst is an empty substitution.     inst_tys = substTyVars eq_subst univ_tvs      unit_rhs = mkLHsTupleExpr [] noExtField
GHC/Tc/Types.hs view
@@ -1,7 +1,9 @@-{-# LANGUAGE CPP                        #-}-{-# LANGUAGE DeriveFunctor              #-}++{-# LANGUAGE DerivingStrategies         #-} {-# LANGUAGE ExistentialQuantification  #-}+{-# LANGUAGE GADTs                      #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE PatternSynonyms            #-}  {- (c) The University of Glasgow 2006-2012@@ -32,6 +34,7 @@         setLclEnvLoc, getLclEnvLoc,         IfGblEnv(..), IfLclEnv(..),         tcVisibleOrphanMods,+        RewriteEnv(..),          -- Frontend types (shouldn't really be here)         FrontendResult(..),@@ -39,14 +42,15 @@         -- Renamer types         ErrCtxt, RecFieldEnv, pushErrCtxt, pushErrCtxtSameOrigin,         ImportAvails(..), emptyImportAvails, plusImportAvails,-        WhereFrom(..), mkModDeps, modDepsElts,+        WhereFrom(..), mkModDeps,          -- Typechecker types         TcTypeEnv, TcBinderStack, TcBinder(..),-        TcTyThing(..), PromotionErr(..),+        TcTyThing(..), tcTyThingTyCon_maybe,+        PromotionErr(..),         IdBindingInfo(..), ClosedTypeId, RhsNames,         IsGroupClosed(..),-        SelfBootInfo(..),+        SelfBootInfo(..), bootExports,         tcTyThingCategory, pprTcTyThingCategory,         peCategory, pprPECategory,         CompleteMatch, CompleteMatches,@@ -56,6 +60,7 @@         topStage, topAnnStage, topSpliceStage,         ThLevel, impLevel, outerLevel, thLevel,         ForeignSrcLang(..), THDocs, DocLoc(..),+        ThBindEnv,          -- Arrows         ArrowCtxt(..),@@ -72,19 +77,26 @@         getPlatform,          -- Constraint solver plugins-        TcPlugin(..), TcPluginResult(..), TcPluginSolver,-        TcPluginM, runTcPluginM, unsafeTcPluginTcM,-        getEvBindsTcPluginM,+        TcPlugin(..),+        TcPluginSolveResult(TcPluginContradiction, TcPluginOk, ..),+        TcPluginRewriteResult(..),+        TcPluginSolver, TcPluginRewriter,+        TcPluginM(runTcPluginM), unsafeTcPluginTcM, +        -- Defaulting plugin+        DefaultingPlugin(..), DefaultingProposal(..),+        FillDefaulting, DefaultingPluginResult,+         -- Role annotations         RoleAnnotEnv, emptyRoleAnnotEnv, mkRoleAnnotEnv,         lookupRoleAnnot, getRoleAnnots,          -- Linting-        lintGblEnv-  ) where+        lintGblEnv, -#include "HsVersions.h"+        -- Diagnostics+        TcRnMessage+  ) where  import GHC.Prelude import GHC.Platform@@ -100,7 +112,9 @@ import GHC.Tc.Types.Origin import GHC.Tc.Types.Evidence import {-# SOURCE #-} GHC.Tc.Errors.Hole.FitTypes ( HoleFitPlugin )+import GHC.Tc.Errors.Types +import GHC.Core.Reduction ( Reduction(..) ) import GHC.Core.Type import GHC.Core.TyCon  ( TyCon, tyConKind ) import GHC.Core.PatSyn ( PatSyn )@@ -108,6 +122,7 @@ import GHC.Core.UsageEnv import GHC.Core.InstEnv import GHC.Core.FamInstEnv+import GHC.Core.Predicate  import GHC.Types.Id         ( idType, idName ) import GHC.Types.FieldLabel ( FieldLabel )@@ -137,7 +152,7 @@  import GHC.Unit import GHC.Unit.Module.Warnings-import GHC.Unit.Module.Imported+import GHC.Unit.Module.Deps import GHC.Unit.Module.ModDetails  import GHC.Utils.Error@@ -149,10 +164,8 @@  import GHC.Builtin.Names ( isUnboundName ) -import Control.Monad (ap) import Data.Set      ( Set ) import qualified Data.Set as S-import Data.List ( sort ) import Data.Map ( Map ) import Data.Dynamic  ( Dynamic ) import Data.Typeable ( TypeRep )@@ -161,6 +174,8 @@ import GHCi.RemoteTypes  import qualified Language.Haskell.TH as TH+import GHC.Driver.Env.KnotVars+import GHC.Linker.Types  -- | A 'NameShape' is a substitution on 'Name's that can be used -- to refine the identities of a hole while we are renaming interfaces@@ -229,7 +244,7 @@                              -- Includes all info about imported things                              -- BangPattern is to fix leak, see #15111 -        env_um   :: !Char,   -- Mask for Uniques+        env_um   :: {-# UNPACK #-} !Char,   -- Mask for Uniques          env_gbl  :: gbl,     -- Info about things defined at the top level                              -- of the module being compiled@@ -249,7 +264,42 @@ instance ContainsModule gbl => ContainsModule (Env gbl lcl) where     extractModule env = extractModule (env_gbl env) +{-+************************************************************************+*                                                                      *+*                            RewriteEnv+*                     The rewriting environment+*                                                                      *+************************************************************************+-} +-- | A 'RewriteEnv' carries the necessary context for performing rewrites+-- (i.e. type family reductions and following filled-in metavariables)+-- in the solver.+data RewriteEnv+  = RE { re_loc     :: !CtLoc+       -- ^ In which context are we rewriting?+       --+       -- Type-checking plugins might want to use this location information+       -- when emitting new Wanted constraints when rewriting type family+       -- applications. This ensures that such Wanted constraints will,+       -- when unsolved, give rise to error messages with the+       -- correct source location.++       -- Within GHC, we use this field to keep track of reduction depth.+       -- See Note [Rewriter CtLoc] in GHC.Tc.Solver.Rewrite.+       , re_flavour :: !CtFlavour+       , re_eq_rel  :: !EqRel+       -- ^ At what role are we rewriting?+       --+       -- See Note [Rewriter EqRels] in GHC.Tc.Solver.Rewrite+       , re_rewriters :: !(TcRef RewriterSet)  -- ^ See Note [Wanteds rewrite Wanteds]+       }+-- RewriteEnv is mostly used in @GHC.Tc.Solver.Rewrite@, but it is defined+-- here so that it can also be passed to rewriting plugins.+-- See the 'tcPluginRewrite' field of 'TcPlugin'.++ {- ************************************************************************ *                                                                      *@@ -270,7 +320,7 @@         -- We need the module name so we can test when it's appropriate         -- to look in this env.         -- See Note [Tying the knot] in GHC.IfaceToCore-        if_rec_types :: Maybe (Module, IfG TypeEnv)+        if_rec_types :: (KnotVars (IfG TypeEnv))                 -- Allows a read effect, so it can be in a mutable                 -- variable; c.f. handling the external package type env                 -- Nothing => interactive stuff, no loops possible@@ -283,7 +333,7 @@         -- it means M.f = \x -> x, where M is the if_mod         -- NB: This is a semantic module, see         -- Note [Identity versus semantic module]-        if_mod :: Module,+        if_mod :: !Module,          -- Whether or not the IfaceDecl came from a boot         -- file or not; we'll use this to choose between@@ -405,7 +455,7 @@           -- NB: for what "things in this module" means, see           -- Note [The interactive package] in "GHC.Runtime.Context" -        tcg_type_env_var :: TcRef TypeEnv,+        tcg_type_env_var :: KnotVars (IORef TypeEnv),                 -- Used only to initialise the interface-file                 -- typechecker in initIfaceTcRn, so that it can see stuff                 -- bound in this module when dealing with hi-boot recursions@@ -473,6 +523,10 @@           --           -- Splices disable recompilation avoidance (see #481) +        tcg_th_needed_deps :: TcRef ([Linkable], PkgsLoaded),+          -- ^ The set of runtime dependencies required by this module+          -- See Note [Object File Dependencies]+         tcg_dfun_n  :: TcRef OccSet,           -- ^ Allows us to choose unique DFun names. @@ -537,7 +591,7 @@         tcg_binds     :: LHsBinds GhcTc,     -- Value bindings in this module         tcg_sigs      :: NameSet,            -- ...Top-level names that *lack* a signature         tcg_imp_specs :: [LTcSpecPrag],      -- ...SPECIALISE prags for imported Ids-        tcg_warns     :: Warnings,           -- ...Warnings and deprecations+        tcg_warns     :: (Warnings GhcRn), -- ...Warnings and deprecations         tcg_anns      :: [Annotation],       -- ...Annotations         tcg_tcs       :: [TyCon],            -- ...TyCons and Classes         tcg_ksigs     :: NameSet,            -- ...Top-level TyCon names that *lack* a signature@@ -547,7 +601,7 @@         tcg_fords     :: [LForeignDecl GhcTc], -- ...Foreign import & exports         tcg_patsyns   :: [PatSyn],            -- ...Pattern synonyms -        tcg_doc_hdr   :: Maybe LHsDocString, -- ^ Maybe Haddock header docs+        tcg_doc_hdr   :: Maybe (LHsDoc GhcRn), -- ^ Maybe Haddock header docs         tcg_hpc       :: !AnyHpcUsage,       -- ^ @True@ if any part of the                                              --  prog uses hpc instrumentation.            -- NB. BangPattern is to fix a leak, see #15111@@ -559,13 +613,28 @@                                              -- function, if this module is                                              -- the main module. -        tcg_safeInfer :: TcRef (Bool, WarningMessages),-        -- ^ Has the typechecker inferred this module as -XSafe (Safe Haskell)+        tcg_safe_infer :: TcRef Bool,+        -- ^ Has the typechecker inferred this module as -XSafe (Safe Haskell)?         -- See Note [Safe Haskell Overlapping Instances Implementation],         -- although this is used for more than just that failure case. -        tcg_tc_plugins :: [TcPluginSolver],-        -- ^ A list of user-defined plugins for the constraint solver.+        tcg_safe_infer_reasons :: TcRef (Messages TcRnMessage),+        -- ^ Unreported reasons why tcg_safe_infer is False.+        -- INVARIANT: If this Messages is non-empty, then tcg_safe_infer is False.+        -- It may be that tcg_safe_infer is False but this is empty, if no reasons+        -- are supplied (#19714), or if those reasons have already been+        -- reported by GHC.Driver.Main.markUnsafeInfer++        tcg_tc_plugin_solvers :: [TcPluginSolver],+        -- ^ A list of user-defined type-checking plugins for constraint solving.++        tcg_tc_plugin_rewriters :: UniqFM TyCon [TcPluginRewriter],+        -- ^ A collection of all the user-defined type-checking plugins for rewriting+        -- type family applications, collated by their type family 'TyCon's.++        tcg_defaulting_plugins :: [FillDefaulting],+        -- ^ A list of user-defined plugins for type defaulting plugins.+         tcg_hf_plugins :: [HoleFitPlugin],         -- ^ A list of user-defined plugins for hole fit suggestions. @@ -578,7 +647,10 @@         tcg_complete_matches :: !CompleteMatches,          -- ^ Tracking indices for cost centre annotations-        tcg_cc_st   :: TcRef CostCentreState+        tcg_cc_st   :: TcRef CostCentreState,++        tcg_next_wrapper_num :: TcRef (ModuleEnv Int)+        -- ^ See Note [Generating fresh names for FFI wrappers]     }  -- NB: topModIdentity, not topModSemantic!@@ -630,7 +702,16 @@ -- What is sb_tcs used for?  See Note [Extra dependencies from .hs-boot files] -- in GHC.Rename.Module +bootExports :: SelfBootInfo -> NameSet+bootExports boot =+  case boot of+    NoSelfBoot -> emptyNameSet+    SelfBoot { sb_mds = mds} ->+      let exports = md_exports mds+      in availsToNameSet exports ++ {- Note [Tracking unused binding and imports] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We gather three sorts of usage information@@ -739,7 +820,7 @@             -- The ThBindEnv records the TH binding level of in-scope Names             -- defined in this module (not imported)             -- We can't put this info in the TypeEnv because it's needed-            -- (and extended) in the renamer, for untyed splices+            -- (and extended) in the renamer, for untyped splices          tcl_arrow_ctxt :: ArrowCtxt,       -- Arrow-notation context @@ -765,7 +846,7 @@                                       -- and for tidying types          tcl_lie  :: TcRef WantedConstraints,    -- Place to accumulate type constraints-        tcl_errs :: TcRef (Messages DecoratedSDoc)     -- Place to accumulate errors+        tcl_errs :: TcRef (Messages TcRnMessage)     -- Place to accumulate diagnostics     }  setLclEnvTcLevel :: TcLclEnv -> TcLevel -> TcLclEnv@@ -980,7 +1061,7 @@ thLevel (RunSplice _) = panic "thLevel: called when running a splice"                         -- See Note [RunSplice ThLevel]. -{- Node [RunSplice ThLevel]+{- Note [RunSplice ThLevel] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The 'RunSplice' stage is set when executing a splice, and only when running a splice. In particular it is not set when the splice is renamed or typechecked.@@ -1060,6 +1141,12 @@    | APromotionErr PromotionErr +-- | Matches on either a global 'TyCon' or a 'TcTyCon'.+tcTyThingTyCon_maybe :: TcTyThing -> Maybe TyCon+tcTyThingTyCon_maybe (AGlobal (ATyCon tc)) = Just tc+tcTyThingTyCon_maybe (ATcTyCon tc_tc)      = Just tc_tc+tcTyThingTyCon_maybe _                     = Nothing+ data PromotionErr   = TyConPE          -- TyCon used in a kind before we are ready                      --     data T :: T -> * where ...@@ -1077,7 +1164,6 @@    | RecDataConPE     -- Data constructor in a recursive loop                      -- See Note [Recursion and promoting data constructors] in GHC.Tc.TyCl-  | NoDataKindsTC    -- -XDataKinds not enabled (for a tycon)   | NoDataKindsDC    -- -XDataKinds not enabled (for a datacon)  instance Outputable TcTyThing where     -- Debugging only@@ -1098,7 +1184,7 @@ -- b) to figure out when a nested binding can be generalised, --    in 'GHC.Tc.Gen.Bind.decideGeneralisationPlan'. ---data IdBindingInfo -- See Note [Meaning of IdBindingInfo and ClosedTypeId]+data IdBindingInfo -- See Note [Meaning of IdBindingInfo]     = NotLetBound     | ClosedLet     | NonClosedLet@@ -1109,7 +1195,7 @@ -- | IsGroupClosed describes a group of mutually-recursive bindings data IsGroupClosed   = IsGroupClosed-      (NameEnv RhsNames)  -- Free var info for the RHS of each binding in the goup+      (NameEnv RhsNames)  -- Free var info for the RHS of each binding in the group                           -- Used only for (static e) checks        ClosedTypeId        -- True <=> all the free vars of the group are@@ -1121,7 +1207,7 @@                           -- a definition, that are not Global or ClosedLet  type ClosedTypeId = Bool-  -- See Note [Meaning of IdBindingInfo and ClosedTypeId]+  -- See Note [Meaning of IdBindingInfo]  {- Note [Meaning of IdBindingInfo] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1272,7 +1358,6 @@   ppr (ConstrainedDataConPE pred) = text "ConstrainedDataConPE"                                       <+> parens (ppr pred)   ppr RecDataConPE                = text "RecDataConPE"-  ppr NoDataKindsTC               = text "NoDataKindsTC"   ppr NoDataKindsDC               = text "NoDataKindsDC"  --------------@@ -1297,7 +1382,6 @@ peCategory FamDataConPE           = "data constructor" peCategory ConstrainedDataConPE{} = "data constructor" peCategory RecDataConPE           = "data constructor"-peCategory NoDataKindsTC          = "type constructor" peCategory NoDataKindsDC          = "data constructor"  {-@@ -1308,92 +1392,35 @@ ************************************************************************ -} --- | 'ImportAvails' summarises what was imported from where, irrespective of--- whether the imported things are actually used or not.  It is used:------  * when processing the export list,------  * when constructing usage info for the interface file,------  * to identify the list of directly imported modules for initialisation---    purposes and for optimised overlap checking of family instances,------  * when figuring out what things are really unused----data ImportAvails-   = ImportAvails {-        imp_mods :: ImportedMods,-          --      = ModuleEnv [ImportedModsVal],-          -- ^ Domain is all directly-imported modules-          ---          -- See the documentation on ImportedModsVal in-          -- "GHC.Unit.Module.Imported" for the meaning of the fields.-          ---          -- We need a full ModuleEnv rather than a ModuleNameEnv here,-          -- because we might be importing modules of the same name from-          -- different packages. (currently not the case, but might be in the-          -- future). -        imp_dep_mods :: ModuleNameEnv ModuleNameWithIsBoot,-          -- ^ Home-package modules needed by the module being compiled-          ---          -- It doesn't matter whether any of these dependencies-          -- are actually /used/ when compiling the module; they-          -- are listed if they are below it at all.  For-          -- example, suppose M imports A which imports X.  Then-          -- compiling M might not need to consult X.hi, but X-          -- is still listed in M's dependencies.--        imp_dep_pkgs :: Set UnitId,-          -- ^ Packages needed by the module being compiled, whether directly,-          -- or via other modules in this package, or via modules imported-          -- from other packages.--        imp_trust_pkgs :: Set UnitId,-          -- ^ This is strictly a subset of imp_dep_pkgs and records the-          -- packages the current module needs to trust for Safe Haskell-          -- compilation to succeed. A package is required to be trusted if-          -- we are dependent on a trustworthy module in that package.-          -- While perhaps making imp_dep_pkgs a tuple of (UnitId, Bool)-          -- where True for the bool indicates the package is required to be-          -- trusted is the more logical  design, doing so complicates a lot-          -- of code not concerned with Safe Haskell.-          -- See Note [Tracking Trust Transitively] in "GHC.Rename.Names"--        imp_trust_own_pkg :: Bool,-          -- ^ Do we require that our own package is trusted?-          -- This is to handle efficiently the case where a Safe module imports-          -- a Trustworthy module that resides in the same package as it.-          -- See Note [Trust Own Package] in "GHC.Rename.Names"--        imp_orphs :: [Module],-          -- ^ Orphan modules below us in the import tree (and maybe including-          -- us for imported modules)--        imp_finsts :: [Module]-          -- ^ Family instance modules below us in the import tree (and maybe-          -- including us for imported modules)-      }--mkModDeps :: [ModuleNameWithIsBoot]-          -> ModuleNameEnv ModuleNameWithIsBoot-mkModDeps deps = foldl' add emptyUFM deps+mkModDeps :: Set (UnitId, ModuleNameWithIsBoot)+          -> InstalledModuleEnv ModuleNameWithIsBoot+mkModDeps deps = S.foldl' add emptyInstalledModuleEnv deps   where-    add env elt = addToUFM env (gwib_mod elt) elt+    add env (uid, elt) = extendInstalledModuleEnv env (mkModule uid (gwib_mod elt)) elt -modDepsElts-  :: ModuleNameEnv ModuleNameWithIsBoot-  -> [ModuleNameWithIsBoot]-modDepsElts = sort . nonDetEltsUFM-  -- It's OK to use nonDetEltsUFM here because sorting by module names-  -- restores determinism+plusModDeps :: InstalledModuleEnv ModuleNameWithIsBoot+            -> InstalledModuleEnv ModuleNameWithIsBoot+            -> InstalledModuleEnv ModuleNameWithIsBoot+plusModDeps = plusInstalledModuleEnv plus_mod_dep+  where+    plus_mod_dep r1@(GWIB { gwib_mod = m1, gwib_isBoot = boot1 })+                 r2@(GWIB {gwib_mod = m2, gwib_isBoot = boot2})+      | assertPpr (m1 == m2) ((ppr m1 <+> ppr m2) $$ (ppr (boot1 == IsBoot) <+> ppr (boot2 == IsBoot)))+        boot1 == IsBoot = r2+      | otherwise = r1+      -- If either side can "see" a non-hi-boot interface, use that+      -- Reusing existing tuples saves 10% of allocations on test+      -- perf/compiler/MultiLayerModules  emptyImportAvails :: ImportAvails emptyImportAvails = ImportAvails { imp_mods          = emptyModuleEnv,-                                   imp_dep_mods      = emptyUFM,-                                   imp_dep_pkgs      = S.empty,+                                   imp_direct_dep_mods = emptyInstalledModuleEnv,+                                   imp_dep_direct_pkgs = S.empty,+                                   imp_sig_mods      = [],                                    imp_trust_pkgs    = S.empty,                                    imp_trust_own_pkg = False,+                                   imp_boot_mods   = emptyInstalledModuleEnv,                                    imp_orphs         = [],                                    imp_finsts        = [] } @@ -1405,29 +1432,28 @@ plusImportAvails ::  ImportAvails ->  ImportAvails ->  ImportAvails plusImportAvails   (ImportAvails { imp_mods = mods1,-                  imp_dep_mods = dmods1, imp_dep_pkgs = dpkgs1,+                  imp_direct_dep_mods = ddmods1,+                  imp_dep_direct_pkgs = ddpkgs1,+                  imp_boot_mods = srs1,+                  imp_sig_mods = sig_mods1,                   imp_trust_pkgs = tpkgs1, imp_trust_own_pkg = tself1,                   imp_orphs = orphs1, imp_finsts = finsts1 })   (ImportAvails { imp_mods = mods2,-                  imp_dep_mods = dmods2, imp_dep_pkgs = dpkgs2,+                  imp_direct_dep_mods = ddmods2,+                  imp_dep_direct_pkgs = ddpkgs2,+                  imp_boot_mods = srcs2,+                  imp_sig_mods = sig_mods2,                   imp_trust_pkgs = tpkgs2, imp_trust_own_pkg = tself2,                   imp_orphs = orphs2, imp_finsts = finsts2 })   = ImportAvails { imp_mods          = plusModuleEnv_C (++) mods1 mods2,-                   imp_dep_mods      = plusUFM_C plus_mod_dep dmods1 dmods2,-                   imp_dep_pkgs      = dpkgs1 `S.union` dpkgs2,+                   imp_direct_dep_mods = ddmods1 `plusModDeps` ddmods2,+                   imp_dep_direct_pkgs      = ddpkgs1 `S.union` ddpkgs2,                    imp_trust_pkgs    = tpkgs1 `S.union` tpkgs2,                    imp_trust_own_pkg = tself1 || tself2,+                   imp_boot_mods   = srs1 `plusModDeps` srcs2,+                   imp_sig_mods      = sig_mods1 `unionLists` sig_mods2,                    imp_orphs         = orphs1 `unionLists` orphs2,                    imp_finsts        = finsts1 `unionLists` finsts2 }-  where-    plus_mod_dep r1@(GWIB { gwib_mod = m1, gwib_isBoot = boot1 })-                 r2@(GWIB {gwib_mod = m2, gwib_isBoot = boot2})-      | ASSERT2( m1 == m2, (ppr m1 <+> ppr m2) $$ (ppr (boot1 == IsBoot) <+> ppr (boot2 == IsBoot)))-        boot1 == IsBoot = r2-      | otherwise = r1-      -- If either side can "see" a non-hi-boot interface, use that-      -- Reusing existing tuples saves 10% of allocations on test-      -- perf/compiler/MultiLayerModules  {- ************************************************************************@@ -1642,66 +1668,161 @@ ------------------------- -} -type TcPluginSolver = [Ct]    -- given-                   -> [Ct]    -- derived-                   -> [Ct]    -- wanted-                   -> TcPluginM TcPluginResult--newtype TcPluginM a = TcPluginM (EvBindsVar -> TcM a) deriving (Functor)--instance Applicative TcPluginM where-  pure x = TcPluginM (const $ pure x)-  (<*>) = ap--instance Monad TcPluginM where-  TcPluginM m >>= k =-    TcPluginM (\ ev -> do a <- m ev-                          runTcPluginM (k a) ev)+-- | The @solve@ function of a type-checking plugin takes in Given+-- and Wanted constraints, and should return a 'TcPluginSolveResult'+-- indicating which Wanted constraints it could solve, or whether any are+-- insoluble.+type TcPluginSolver = EvBindsVar+                   -> [Ct] -- ^ Givens+                   -> [Ct] -- ^ Wanteds+                   -> TcPluginM TcPluginSolveResult -instance MonadFail TcPluginM where-  fail x   = TcPluginM (const $ fail x)+-- | For rewriting type family applications, a type-checking plugin provides+-- a function of this type for each type family 'TyCon'.+--+-- The function is provided with the current set of Given constraints, together+-- with the arguments to the type family.+-- The type family application will always be fully saturated.+type TcPluginRewriter+  =  RewriteEnv -- ^ Rewriter environment+  -> [Ct]       -- ^ Givens+  -> [TcType]   -- ^ type family arguments+  -> TcPluginM TcPluginRewriteResult -runTcPluginM :: TcPluginM a -> EvBindsVar -> TcM a-runTcPluginM (TcPluginM m) = m+-- | 'TcPluginM' is the monad in which type-checking plugins operate.+newtype TcPluginM a = TcPluginM { runTcPluginM :: TcM a }+  deriving newtype (Functor, Applicative, Monad, MonadFail)  -- | This function provides an escape for direct access to -- the 'TcM` monad.  It should not be used lightly, and -- the provided 'TcPluginM' API should be favoured instead. unsafeTcPluginTcM :: TcM a -> TcPluginM a-unsafeTcPluginTcM = TcPluginM . const---- | Access the 'EvBindsVar' carried by the 'TcPluginM' during--- constraint solving.  Returns 'Nothing' if invoked during--- 'tcPluginInit' or 'tcPluginStop'.-getEvBindsTcPluginM :: TcPluginM EvBindsVar-getEvBindsTcPluginM = TcPluginM return-+unsafeTcPluginTcM = TcPluginM  data TcPlugin = forall s. TcPlugin-  { tcPluginInit  :: TcPluginM s+  { tcPluginInit :: TcPluginM s     -- ^ Initialize plugin, when entering type-checker.    , tcPluginSolve :: s -> TcPluginSolver     -- ^ Solve some constraints.-    -- TODO: WRITE MORE DETAILS ON HOW THIS WORKS.+    --+    -- This function will be invoked at two points in the constraint solving+    -- process: once to simplify Given constraints, and once to solve+    -- Wanted constraints. In the first case (and only in the first case),+    -- no Wanted constraints will be passed to the plugin.+    --+    -- The plugin can either return a contradiction,+    -- or specify that it has solved some constraints (with evidence),+    -- and possibly emit additional constraints. These returned constraints+    -- must be Givens in the first case, and Wanteds in the second.+    --+    -- Use @ \\ _ _ _ _ _ -> pure $ TcPluginOK [] [] @ if your plugin+    -- does not provide this functionality. -  , tcPluginStop  :: s -> TcPluginM ()+  , tcPluginRewrite :: s -> UniqFM TyCon TcPluginRewriter+    -- ^ Rewrite saturated type family applications.+    --+    -- The plugin is expected to supply a mapping from type family names to+    -- rewriting functions. For each type family 'TyCon', the plugin should+    -- provide a function which takes in the given constraints and arguments+    -- of a saturated type family application, and return a possible rewriting.+    -- See 'TcPluginRewriter' for the expected shape of such a function.+    --+    -- Use @ \\ _ -> emptyUFM @ if your plugin does not provide this functionality.++  , tcPluginStop :: s -> TcPluginM ()    -- ^ Clean up after the plugin, when exiting the type-checker.   } -data TcPluginResult-  = TcPluginContradiction [Ct]-    -- ^ The plugin found a contradiction.-    -- The returned constraints are removed from the inert set,-    -- and recorded as insoluble.+-- | The plugin found a contradiction.+-- The returned constraints are removed from the inert set,+-- and recorded as insoluble.+--+-- The returned list of constraints should never be empty.+pattern TcPluginContradiction :: [Ct] -> TcPluginSolveResult+pattern TcPluginContradiction insols+  = TcPluginSolveResult+  { tcPluginInsolubleCts = insols+  , tcPluginSolvedCts    = []+  , tcPluginNewCts       = [] } -  | TcPluginOk [(EvTerm,Ct)] [Ct]-    -- ^ The first field is for constraints that were solved.-    -- These are removed from the inert set,-    -- and the evidence for them is recorded.-    -- The second field contains new work, that should be processed by-    -- the constraint solver.+-- | The plugin has not found any contradictions,+--+-- The first field is for constraints that were solved.+-- The second field contains new work, that should be processed by+-- the constraint solver.+pattern TcPluginOk :: [(EvTerm, Ct)] -> [Ct] -> TcPluginSolveResult+pattern TcPluginOk solved new+  = TcPluginSolveResult+  { tcPluginInsolubleCts = []+  , tcPluginSolvedCts    = solved+  , tcPluginNewCts       = new } +-- | Result of running a solver plugin.+data TcPluginSolveResult+  = TcPluginSolveResult+  { -- | Insoluble constraints found by the plugin.+    --+    -- These constraints will be added to the inert set,+    -- and reported as insoluble to the user.+    tcPluginInsolubleCts :: [Ct]+    -- | Solved constraints, together with their evidence.+    --+    -- These are removed from the inert set, and the+    -- evidence for them is recorded.+  , tcPluginSolvedCts :: [(EvTerm, Ct)]+    -- | New constraints that the plugin wishes to emit.+    --+    -- These will be added to the work list.+  , tcPluginNewCts :: [Ct]+  }++data TcPluginRewriteResult+  =+  -- | The plugin does not rewrite the type family application.+    TcPluginNoRewrite++  -- | The plugin rewrites the type family application+  -- providing a rewriting together with evidence: a 'Reduction',+  -- which contains the rewritten type together with a 'Coercion'+  -- whose right-hand-side type is the rewritten type.+  --+  -- The plugin can also emit additional Wanted constraints.+  | TcPluginRewriteTo+    { tcPluginReduction    :: !Reduction+    , tcRewriterNewWanteds :: [Ct]+    }++-- | A collection of candidate default types for a type variable.+data DefaultingProposal+  = DefaultingProposal+    { deProposalTyVar :: TcTyVar+      -- ^ The type variable to default.+    , deProposalCandidates :: [Type]+      -- ^ Candidate types to default the type variable to.+    , deProposalCts :: [Ct]+      -- ^ The constraints against which defaults are checked.+    }++instance Outputable DefaultingProposal where+  ppr p = text "DefaultingProposal"+          <+> ppr (deProposalTyVar p)+          <+> ppr (deProposalCandidates p)+          <+> ppr (deProposalCts p)++type DefaultingPluginResult = [DefaultingProposal]+type FillDefaulting = WantedConstraints -> TcPluginM DefaultingPluginResult++-- | A plugin for controlling defaulting.+data DefaultingPlugin = forall s. DefaultingPlugin+  { dePluginInit :: TcPluginM s+    -- ^ Initialize plugin, when entering type-checker.+  , dePluginRun :: s -> FillDefaulting+    -- ^ Default some types+  , dePluginStop :: s -> TcPluginM ()+   -- ^ Clean up after the plugin, when exiting the type-checker.+  }+ {- ********************************************************************* *                                                                      *                         Role annotations@@ -1753,4 +1874,4 @@  -- | The current collection of docs that Template Haskell has built up via -- putDoc.-type THDocs = Map DocLoc String+type THDocs = Map DocLoc (HsDoc GhcRn)
GHC/Tc/Types.hs-boot view
@@ -2,8 +2,14 @@  import GHC.Tc.Utils.TcType import GHC.Types.SrcLoc+import GHC.Utils.Outputable  data TcLclEnv++data SelfBootInfo++data TcIdSigInfo+instance Outputable TcIdSigInfo  setLclEnvTcLevel :: TcLclEnv -> TcLevel -> TcLclEnv getLclEnvTcLevel :: TcLclEnv -> TcLevel
GHC/Tc/Types/Constraint.hs view
@@ -1,2087 +1,2349 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}---- | This module defines types and simple operations over constraints, as used--- in the type-checker and constraint solver.-module GHC.Tc.Types.Constraint (-        -- QCInst-        QCInst(..), isPendingScInst,--        -- Canonical constraints-        Xi, Ct(..), Cts,-        emptyCts, andCts, andManyCts, pprCts,-        singleCt, listToCts, ctsElts, consCts, snocCts, extendCtsList,-        isEmptyCts,-        isPendingScDict, superClassesMightHelp, getPendingWantedScs,-        isWantedCt, isDerivedCt, isGivenCt,-        isUserTypeErrorCt, getUserTypeErrorMsg,-        ctEvidence, ctLoc, setCtLoc, ctPred, ctFlavour, ctEqRel, ctOrigin,-        ctEvId, mkTcEqPredLikeEv,-        mkNonCanonical, mkNonCanonicalCt, mkGivens,-        mkIrredCt,-        ctEvPred, ctEvLoc, ctEvOrigin, ctEvEqRel,-        ctEvExpr, ctEvTerm, ctEvCoercion, ctEvEvId,-        tyCoVarsOfCt, tyCoVarsOfCts,-        tyCoVarsOfCtList, tyCoVarsOfCtsList,--        CtIrredReason(..), HoleSet, isInsolubleReason,--        CheckTyEqResult, CheckTyEqProblem, cteProblem, cterClearOccursCheck,-        cteOK, cteImpredicative, cteTypeFamily, cteHoleBlocker,-        cteInsolubleOccurs, cteSolubleOccurs, cterSetOccursCheckSoluble,-        cterHasNoProblem, cterHasProblem, cterHasOnlyProblem,-        cterRemoveProblem, cterHasOccursCheck, cterFromKind,--        CanEqLHS(..), canEqLHS_maybe, canEqLHSKind, canEqLHSType,-        eqCanEqLHS,--        Hole(..), HoleSort(..), isOutOfScopeHole,--        WantedConstraints(..), insolubleWC, emptyWC, isEmptyWC,-        isSolvedWC, andWC, unionsWC, mkSimpleWC, mkImplicWC,-        addInsols, dropMisleading, addSimples, addImplics, addHoles,-        tyCoVarsOfWC, dropDerivedWC, dropDerivedSimples,-        tyCoVarsOfWCList, insolubleCt, insolubleEqCt,-        isDroppableCt, insolubleImplic,-        arisesFromGivens,--        Implication(..), implicationPrototype, checkTelescopeSkol,-        ImplicStatus(..), isInsolubleStatus, isSolvedStatus,-        HasGivenEqs(..),-        SubGoalDepth, initialSubGoalDepth, maxSubGoalDepth,-        bumpSubGoalDepth, subGoalDepthExceeded,-        CtLoc(..), ctLocSpan, ctLocEnv, ctLocLevel, ctLocOrigin,-        ctLocTypeOrKind_maybe,-        ctLocDepth, bumpCtLocDepth, isGivenLoc,-        setCtLocOrigin, updateCtLocOrigin, setCtLocEnv, setCtLocSpan,-        pprCtLoc,--        -- CtEvidence-        CtEvidence(..), TcEvDest(..),-        mkKindLoc, toKindLoc, mkGivenLoc,-        isWanted, isGiven, isDerived,-        ctEvRole,--        wrapType,--        CtFlavour(..), ShadowInfo(..), ctFlavourContainsDerived, ctEvFlavour,-        CtFlavourRole, ctEvFlavourRole, ctFlavourRole,-        eqCanRewrite, eqCanRewriteFR, eqMayRewriteFR,-        eqCanDischargeFR,--        -- Pretty printing-        pprEvVarTheta,-        pprEvVars, pprEvVarWithType,--  )-  where--#include "HsVersions.h"--import GHC.Prelude--import {-# SOURCE #-} GHC.Tc.Types ( TcLclEnv, setLclEnvTcLevel, getLclEnvTcLevel-                                   , setLclEnvLoc, getLclEnvLoc )--import GHC.Core.Predicate-import GHC.Core.Type-import GHC.Core.Coercion-import GHC.Core.Class-import GHC.Core.TyCon-import GHC.Types.Var--import GHC.Tc.Utils.TcType-import GHC.Tc.Types.Evidence-import GHC.Tc.Types.Origin--import GHC.Core--import GHC.Core.TyCo.Ppr-import GHC.Types.Name.Occurrence-import GHC.Utils.FV-import GHC.Types.Var.Set-import GHC.Driver.Session-import GHC.Types.Basic--import GHC.Utils.Outputable-import GHC.Types.SrcLoc-import GHC.Data.Bag-import GHC.Utils.Misc-import GHC.Utils.Panic--import Control.Monad ( msum )-import qualified Data.Semigroup ( (<>) )---- these are for CheckTyEqResult-import Data.Word  ( Word8 )-import Data.List  ( intersperse )----{--************************************************************************-*                                                                      *-*                       Canonical constraints                          *-*                                                                      *-*   These are the constraints the low-level simplifier works with      *-*                                                                      *-************************************************************************--Note [CEqCan occurs check]-~~~~~~~~~~~~~~~~~~~~~~~~~~-A CEqCan relates a CanEqLHS (a type variable or type family applications) on-its left to an arbitrary type on its right. It is used for rewriting.-Because it is used for rewriting, it would be disastrous if the RHS-were to mention the LHS: this would cause a loop in rewriting.--We thus perform an occurs-check. There is, of course, some subtlety:--* For type variables, the occurs-check looks deeply. This is because-  a CEqCan over a meta-variable is also used to inform unification,-  in GHC.Tc.Solver.Interact.solveByUnification. If the LHS appears-  anywhere, at all, in the RHS, unification will create an infinite-  structure, which is bad.--* For type family applications, the occurs-check is shallow; it looks-  only in places where we might rewrite. (Specifically, it does not-  look in kinds or coercions.) An occurrence of the LHS in, say, an-  RHS coercion is OK, as we do not rewrite in coercions. No loop to-  be found.--  You might also worry about the possibility that a type family-  application LHS doesn't exactly appear in the RHS, but something-  that reduces to the LHS does. Yet that can't happen: the RHS is-  already inert, with all type family redexes reduced. So a simple-  syntactic check is just fine.--The occurs check is performed in GHC.Tc.Utils.Unify.checkTypeEq-and forms condition T3 in Note [Extending the inert equalities]-in GHC.Tc.Solver.Monad.---}---- | A 'Xi'-type is one that has been fully rewritten with respect--- to the inert set; that is, it has been rewritten by the algorithm--- in GHC.Tc.Solver.Rewrite. (Historical note: 'Xi', for years and years,--- meant that a type was type-family-free. It does *not* mean this--- any more.)-type Xi = TcType--type Cts = Bag Ct--data Ct-  -- Atomic canonical constraints-  = CDictCan {  -- e.g.  Num ty-      cc_ev     :: CtEvidence, -- See Note [Ct/evidence invariant]--      cc_class  :: Class,-      cc_tyargs :: [Xi],   -- cc_tyargs are rewritten w.r.t. inerts, so Xi--      cc_pend_sc :: Bool   -- See Note [The superclass story] in GHC.Tc.Solver.Canonical-                           -- True <=> (a) cc_class has superclasses-                           --          (b) we have not (yet) added those-                           --              superclasses as Givens-    }--  | CIrredCan {  -- These stand for yet-unusable predicates-      cc_ev     :: CtEvidence,   -- See Note [Ct/evidence invariant]-      cc_reason :: CtIrredReason--        -- For the might-be-soluble case, the ctev_pred of the evidence is-        -- of form   (tv xi1 xi2 ... xin)   with a tyvar at the head-        --      or   (lhs1 ~ ty2)  where the CEqCan    kind invariant (TyEq:K) fails-        -- See Note [CIrredCan constraints]--        -- The definitely-insoluble case is for things like-        --    Int ~ Bool      tycons don't match-        --    a ~ [a]         occurs check-    }--  | CEqCan {  -- CanEqLHS ~ rhs-       -- Invariants:-       --   * See Note [inert_eqs: the inert equalities] in GHC.Tc.Solver.Monad-       --   * Many are checked in checkTypeEq in GHC.Tc.Utils.Unify-       --   * (TyEq:OC) lhs does not occur in rhs (occurs check)-       --               Note [CEqCan occurs check]-       --   * (TyEq:F) rhs has no foralls-       --       (this avoids substituting a forall for the tyvar in other types)-       --   * (TyEq:K) tcTypeKind lhs `tcEqKind` tcTypeKind rhs; Note [Ct kind invariant]-       --   * (TyEq:N) If the equality is representational, rhs has no top-level newtype-       --     See Note [No top-level newtypes on RHS of representational equalities]-       --     in GHC.Tc.Solver.Canonical. (Applies only when constructor of newtype is-       --     in scope.)-       --   * (TyEq:TV) If rhs (perhaps under a cast) is also CanEqLHS, then it is oriented-       --     to give best chance of-       --     unification happening; eg if rhs is touchable then lhs is too-       --     Note [TyVar/TyVar orientation] in GHC.Tc.Utils.Unify-       --   * (TyEq:H) The RHS has no blocking coercion holes. See GHC.Tc.Solver.Canonical-       --     Note [Equalities with incompatible kinds], wrinkle (2)-      cc_ev     :: CtEvidence, -- See Note [Ct/evidence invariant]-      cc_lhs    :: CanEqLHS,-      cc_rhs    :: Xi,         -- See invariants above--      cc_eq_rel :: EqRel       -- INVARIANT: cc_eq_rel = ctEvEqRel cc_ev-    }--  | CNonCanonical {        -- See Note [NonCanonical Semantics] in GHC.Tc.Solver.Monad-      cc_ev  :: CtEvidence-    }--  | CQuantCan QCInst       -- A quantified constraint-      -- NB: I expect to make more of the cases in Ct-      --     look like this, with the payload in an-      --     auxiliary type----------------- | 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 TcTyVar-  | TyFamLHS TyCon  -- ^ of the family-             [Xi]   -- ^ 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)---------------data QCInst  -- A much simplified version of ClsInst-             -- See Note [Quantified constraints] in GHC.Tc.Solver.Canonical-  = QCI { qci_ev   :: CtEvidence -- Always of type forall tvs. context => ty-                                 -- Always Given-        , qci_tvs  :: [TcTyVar]  -- The tvs-        , qci_pred :: TcPredType -- The ty-        , qci_pend_sc :: Bool    -- Same as cc_pend_sc flag in CDictCan-                                 -- Invariant: True => qci_pred is a ClassPred-    }--instance Outputable QCInst where-  ppr (QCI { qci_ev = ev }) = ppr ev----------------- | A hole stores the information needed to report diagnostics--- about holes in terms (unbound identifiers or underscores) or--- in types (also called wildcards, as used in partial type--- signatures). See Note [Holes].-data Hole-  = Hole { hole_sort :: HoleSort -- ^ What flavour of hole is this?-         , hole_occ  :: OccName  -- ^ The name of this hole-         , hole_ty   :: TcType   -- ^ Type to be printed to the user-                                 -- For expression holes: type of expr-                                 -- For type holes: the missing type-         , hole_loc  :: CtLoc    -- ^ Where hole was written-         }-           -- For the hole_loc, we usually only want the TcLclEnv stored within.-           -- Except when we rewrite, where we need a whole location. And this-           -- might get reported to the user if reducing type families in a-           -- hole type loops.----- | Used to indicate which sort of hole we have.-data HoleSort = ExprHole HoleExprRef-                 -- ^ Either an out-of-scope variable or a "true" hole in an-                 -- expression (TypedHoles).-                 -- The HoleExprRef says where to write the-                 -- the erroring expression for -fdefer-type-errors.-              | TypeHole-                 -- ^ A hole in a type (PartialTypeSignatures)-              | ConstraintHole-                 -- ^ A hole in a constraint, like @f :: (_, Eq a) => ...-                 -- Differentiated from TypeHole because a ConstraintHole-                 -- is simplified differently. See-                 -- Note [Do not simplify ConstraintHoles] in GHC.Tc.Solver.--instance Outputable Hole where-  ppr (Hole { hole_sort = ExprHole ref-            , hole_occ  = occ-            , hole_ty   = ty })-    = parens $ (braces $ ppr occ <> colon <> ppr ref) <+> dcolon <+> ppr ty-  ppr (Hole { hole_sort = _other-            , hole_occ  = occ-            , hole_ty   = ty })-    = braces $ ppr occ <> colon <> ppr ty--instance Outputable HoleSort where-  ppr (ExprHole ref) = text "ExprHole:" <+> ppr ref-  ppr TypeHole       = text "TypeHole"-  ppr ConstraintHole = text "ConstraintHole"----------------- | Used to indicate extra information about why a CIrredCan is irreducible-data CtIrredReason-  = IrredShapeReason-      -- ^ this constraint has a non-canonical shape (e.g. @c Int@, for a variable @c@)--  | HoleBlockerReason HoleSet-     -- ^ this constraint is blocked on the coercion hole(s) listed-     -- See Note [Equalities with incompatible kinds] in GHC.Tc.Solver.Canonical-     -- Wrinkle (4a). Why store the HoleSet? See Wrinkle (2) of that-     -- same Note.-     -- INVARIANT: A HoleBlockerReason constraint is a homogeneous equality whose-     --   left hand side can fit in a CanEqLHS.--  | NonCanonicalReason CheckTyEqResult-   -- ^ an equality where some invariant other than (TyEq:H) of 'CEqCan' is not satisfied;-   -- the 'CheckTyEqResult' states exactly why-   -- INVARIANT: the 'CheckTyEqResult' has some bit set other than cteHoleBlocker--  | ReprEqReason-    -- ^ an equality that cannot be decomposed because it is representational.-    -- Example: @a b ~R# Int@.-    -- These might still be solved later.-    -- INVARIANT: The constraint is a representational equality constraint--  | ShapeMismatchReason-    -- ^ a nominal equality that relates two wholly different types,-    -- like @Int ~# Bool@ or @a b ~# 3@.-    -- INVARIANT: The constraint is a nominal equality constraint--  | AbstractTyConReason-    -- ^ an equality like @T a b c ~ Q d e@ where either @T@ or @Q@-    -- is an abstract type constructor. See Note [Skolem abstract data]-    -- in GHC.Core.TyCon.-    -- INVARIANT: The constraint is an equality constraint between two TyConApps--instance Outputable CtIrredReason where-  ppr IrredShapeReason          = text "(irred)"-  ppr (HoleBlockerReason holes) = parens (text "blocked on" <+> ppr holes)-  ppr (NonCanonicalReason cter) = ppr cter-  ppr ReprEqReason              = text "(repr)"-  ppr ShapeMismatchReason       = text "(shape)"-  ppr AbstractTyConReason       = text "(abstc)"---- | Are we sure that more solving will never solve this constraint?-isInsolubleReason :: CtIrredReason -> Bool-isInsolubleReason IrredShapeReason          = False-isInsolubleReason (HoleBlockerReason {})    = False-isInsolubleReason (NonCanonicalReason cter) = cterIsInsoluble cter-isInsolubleReason ReprEqReason              = False-isInsolubleReason ShapeMismatchReason       = True-isInsolubleReason AbstractTyConReason       = True-------------------------------------------------------------------------------------- CheckTyEqResult, defined here because it is stored in a CtIrredReason-------------------------------------------------------------------------------------- | A set of problems in checking the validity of a type equality.--- See 'checkTypeEq'.-newtype CheckTyEqResult = CTER Word8---- | No problems in checking the validity of a type equality.-cteOK :: CheckTyEqResult-cteOK = CTER zeroBits---- | Check whether a 'CheckTyEqResult' is marked successful.-cterHasNoProblem :: CheckTyEqResult -> Bool-cterHasNoProblem (CTER 0) = True-cterHasNoProblem _        = False---- | An individual problem that might be logged in a 'CheckTyEqResult'-newtype CheckTyEqProblem = CTEP Word8--cteImpredicative, cteTypeFamily, cteHoleBlocker, cteInsolubleOccurs,-  cteSolubleOccurs :: CheckTyEqProblem-cteImpredicative   = CTEP (bit 0)   -- forall or (=>) encountered-cteTypeFamily      = CTEP (bit 1)   -- type family encountered-cteHoleBlocker     = CTEP (bit 2)   -- blocking coercion hole-      -- See Note [Equalities with incompatible kinds] in GHC.Tc.Solver.Canonical-cteInsolubleOccurs = CTEP (bit 3)   -- occurs-check-cteSolubleOccurs   = CTEP (bit 4)   -- occurs-check under a type function or in a coercion-                                    -- must be one bit to the left of cteInsolubleOccurs--- See also Note [Insoluble occurs check] in GHC.Tc.Errors--cteProblem :: CheckTyEqProblem -> CheckTyEqResult-cteProblem (CTEP mask) = CTER mask--occurs_mask :: Word8-occurs_mask = insoluble_mask .|. soluble_mask-  where-    CTEP insoluble_mask = cteInsolubleOccurs-    CTEP soluble_mask   = cteSolubleOccurs---- | Check whether a 'CheckTyEqResult' has a 'CheckTyEqProblem'-cterHasProblem :: CheckTyEqResult -> CheckTyEqProblem -> Bool-CTER bits `cterHasProblem` CTEP mask = (bits .&. mask) /= 0---- | Check whether a 'CheckTyEqResult' has one 'CheckTyEqProblem' and no other-cterHasOnlyProblem :: CheckTyEqResult -> CheckTyEqProblem -> Bool-CTER bits `cterHasOnlyProblem` CTEP mask = bits == mask--cterRemoveProblem :: CheckTyEqResult -> CheckTyEqProblem -> CheckTyEqResult-cterRemoveProblem (CTER bits) (CTEP mask) = CTER (bits .&. complement mask)--cterHasOccursCheck :: CheckTyEqResult -> Bool-cterHasOccursCheck (CTER bits) = (bits .&. occurs_mask) /= 0--cterClearOccursCheck :: CheckTyEqResult -> CheckTyEqResult-cterClearOccursCheck (CTER bits) = CTER (bits .&. complement occurs_mask)---- | Mark a 'CheckTyEqResult' as not having an insoluble occurs-check: any occurs--- check under a type family or in a representation equality is soluble.-cterSetOccursCheckSoluble :: CheckTyEqResult -> CheckTyEqResult-cterSetOccursCheckSoluble (CTER bits)-  = CTER $ ((bits .&. insoluble_mask) `shift` 1) .|. (bits .&. complement insoluble_mask)-  where-    CTEP insoluble_mask = cteInsolubleOccurs---- | Retain only information about occurs-check failures, because only that--- matters after recurring into a kind.-cterFromKind :: CheckTyEqResult -> CheckTyEqResult-cterFromKind (CTER bits)-  = CTER (bits .&. occurs_mask)--cterIsInsoluble :: CheckTyEqResult -> Bool-cterIsInsoluble (CTER bits) = (bits .&. mask) /= 0-  where-    mask = impredicative_mask .|. insoluble_occurs_mask--    CTEP impredicative_mask    = cteImpredicative-    CTEP insoluble_occurs_mask = cteInsolubleOccurs--instance Semigroup CheckTyEqResult where-  CTER bits1 <> CTER bits2 = CTER (bits1 .|. bits2)-instance Monoid CheckTyEqResult where-  mempty = cteOK--instance Outputable CheckTyEqResult where-  ppr cter | cterHasNoProblem cter = text "cteOK"-           | otherwise-           = parens $ fcat $ intersperse vbar $ set_bits-    where-      all_bits = [ (cteImpredicative,   "cteImpredicative")-                 , (cteTypeFamily,      "cteTypeFamily")-                 , (cteHoleBlocker,     "cteHoleBlocker")-                 , (cteInsolubleOccurs, "cteInsolubleOccurs")-                 , (cteSolubleOccurs,   "cteSolubleOccurs") ]-      set_bits = [ text str-                 | (bitmask, str) <- all_bits-                 , cter `cterHasProblem` bitmask ]--{- Note [CIrredCan constraints]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-CIrredCan constraints are used for constraints that are "stuck"-   - we can't solve them (yet)-   - we can't use them to solve other constraints-   - but they may become soluble if we substitute for some-     of the type variables in the constraint--Example 1:  (c Int), where c :: * -> Constraint.  We can't do anything-            with this yet, but if later c := Num, *then* we can solve it--Example 2:  a ~ b, where a :: *, b :: k, where k is a kind variable-            We don't want to use this to substitute 'b' for 'a', in case-            'k' is subsequently unified with (say) *->*, because then-            we'd have ill-kinded types floating about.  Rather we want-            to defer using the equality altogether until 'k' get resolved.--Note [Ct/evidence invariant]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If  ct :: Ct, then extra fields of 'ct' cache precisely the ctev_pred field-of (cc_ev ct), and is fully rewritten wrt the substitution.   Eg for CDictCan,-   ctev_pred (cc_ev ct) = (cc_class ct) (cc_tyargs ct)-This holds by construction; look at the unique place where CDictCan is-built (in GHC.Tc.Solver.Canonical).--In contrast, the type of the evidence *term* (ctev_dest / ctev_evar) in-the evidence may *not* be fully zonked; we are careful not to look at it-during constraint solving. See Note [Evidence field of CtEvidence].--Note [Ct kind invariant]-~~~~~~~~~~~~~~~~~~~~~~~~-CEqCan requires that the kind of the lhs matches the kind-of the rhs. This is necessary because these constraints are used for substitutions-during solving. If the kinds differed, then the substitution would take a well-kinded-type to an ill-kinded one.--Note [Holes]-~~~~~~~~~~~~-This Note explains how GHC tracks *holes*.--A hole represents one of two conditions:- - A missing bit of an expression. Example: foo x = x + _- - A missing bit of a type. Example: bar :: Int -> _--What these have in common is that both cause GHC to emit a diagnostic to the-user describing the bit that is left out.--When a hole is encountered, a new entry of type Hole is added to the ambient-WantedConstraints. The type (hole_ty) of the hole is then simplified during-solving (with respect to any Givens in surrounding implications). It is-reported with all the other errors in GHC.Tc.Errors.--For expression holes, the user has the option of deferring errors until runtime-with -fdefer-type-errors. In this case, the hole actually has evidence: this-evidence is an erroring expression that prints an error and crashes at runtime.-The ExprHole variant of holes stores an IORef EvTerm that will contain this evidence;-during constraint generation, this IORef was stored in the HsUnboundVar extension-field by the type checker. The desugarer simply dereferences to get the CoreExpr.--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-levity-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.--Type-level holes have no evidence at all.--}--mkNonCanonical :: CtEvidence -> Ct-mkNonCanonical ev = CNonCanonical { cc_ev = ev }--mkNonCanonicalCt :: Ct -> Ct-mkNonCanonicalCt ct = CNonCanonical { cc_ev = cc_ev ct }--mkIrredCt :: CtIrredReason -> CtEvidence -> Ct-mkIrredCt reason ev = CIrredCan { cc_ev = ev, cc_reason = reason }--mkGivens :: CtLoc -> [EvId] -> [Ct]-mkGivens loc ev_ids-  = map mk ev_ids-  where-    mk ev_id = mkNonCanonical (CtGiven { ctev_evar = ev_id-                                       , ctev_pred = evVarPred ev_id-                                       , ctev_loc = loc })--ctEvidence :: Ct -> CtEvidence-ctEvidence (CQuantCan (QCI { qci_ev = ev })) = ev-ctEvidence ct = cc_ev ct--ctLoc :: Ct -> CtLoc-ctLoc = ctEvLoc . ctEvidence--setCtLoc :: Ct -> CtLoc -> Ct-setCtLoc ct loc = ct { cc_ev = (cc_ev ct) { ctev_loc = loc } }--ctOrigin :: Ct -> CtOrigin-ctOrigin = ctLocOrigin . ctLoc--ctPred :: Ct -> PredType--- See Note [Ct/evidence invariant]-ctPred ct = ctEvPred (ctEvidence ct)--ctEvId :: Ct -> EvVar--- The evidence Id for this Ct-ctEvId ct = ctEvEvId (ctEvidence ct)---- | Makes a new equality predicate with the same role as the given--- evidence.-mkTcEqPredLikeEv :: CtEvidence -> TcType -> TcType -> TcType-mkTcEqPredLikeEv ev-  = case predTypeEqRel pred of-      NomEq  -> mkPrimEqPred-      ReprEq -> mkReprPrimEqPred-  where-    pred = ctEvPred ev---- | Get the flavour of the given 'Ct'-ctFlavour :: Ct -> CtFlavour-ctFlavour = ctEvFlavour . ctEvidence---- | Get the equality relation for the given 'Ct'-ctEqRel :: Ct -> EqRel-ctEqRel = ctEvEqRel . ctEvidence--instance Outputable Ct where-  ppr ct = ppr (ctEvidence ct) <+> parens pp_sort-    where-      pp_sort = case ct of-         CEqCan {}        -> text "CEqCan"-         CNonCanonical {} -> text "CNonCanonical"-         CDictCan { cc_pend_sc = pend_sc }-            | pend_sc   -> text "CDictCan(psc)"-            | otherwise -> text "CDictCan"-         CIrredCan { cc_reason = reason } -> text "CIrredCan" <> ppr reason-         CQuantCan (QCI { qci_pend_sc = pend_sc })-            | pend_sc   -> text "CQuantCan(psc)"-            | otherwise -> text "CQuantCan"---------------------------------------- | 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 :: Xi -> Maybe CanEqLHS-canEqLHS_maybe xi-  | Just tv <- tcGetTyVar_maybe xi-  = Just $ TyVarLHS tv--  | 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 -> TcType-canEqLHSType (TyVarLHS tv) = mkTyVarTy tv-canEqLHSType (TyFamLHS fam_tc fam_args) = mkTyConApp fam_tc fam_args---- | Retrieve the kind of a 'CanEqLHS'-canEqLHSKind :: CanEqLHS -> TcKind-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--{--************************************************************************-*                                                                      *-        Simple functions over evidence variables-*                                                                      *-************************************************************************--}------------------ Getting free tyvars ----------------------------- | Returns free variables of constraints as a non-deterministic set-tyCoVarsOfCt :: Ct -> TcTyCoVarSet-tyCoVarsOfCt = fvVarSet . tyCoFVsOfCt---- | Returns free variables of constraints as a deterministically ordered.--- list. See Note [Deterministic FV] in "GHC.Utils.FV".-tyCoVarsOfCtList :: Ct -> [TcTyCoVar]-tyCoVarsOfCtList = fvVarList . tyCoFVsOfCt---- | Returns free variables of constraints as a composable FV computation.--- See Note [Deterministic FV] in "GHC.Utils.FV".-tyCoFVsOfCt :: Ct -> FV-tyCoFVsOfCt ct = tyCoFVsOfType (ctPred ct)-  -- This must consult only the ctPred, so that it gets *tidied* fvs if the-  -- constraint has been tidied. Tidying a constraint does not tidy the-  -- fields of the Ct, only the predicate in the CtEvidence.---- | Returns free variables of a bag of constraints as a non-deterministic--- set. See Note [Deterministic FV] in "GHC.Utils.FV".-tyCoVarsOfCts :: Cts -> TcTyCoVarSet-tyCoVarsOfCts = fvVarSet . tyCoFVsOfCts---- | Returns free variables of a bag of constraints as a deterministically--- ordered list. See Note [Deterministic FV] in "GHC.Utils.FV".-tyCoVarsOfCtsList :: Cts -> [TcTyCoVar]-tyCoVarsOfCtsList = fvVarList . tyCoFVsOfCts---- | Returns free variables of a bag of constraints as a composable FV--- computation. See Note [Deterministic FV] in "GHC.Utils.FV".-tyCoFVsOfCts :: Cts -> FV-tyCoFVsOfCts = foldr (unionFV . tyCoFVsOfCt) emptyFV---- | Returns free variables of WantedConstraints as a non-deterministic--- set. See Note [Deterministic FV] in "GHC.Utils.FV".-tyCoVarsOfWC :: WantedConstraints -> TyCoVarSet--- Only called on *zonked* things-tyCoVarsOfWC = fvVarSet . tyCoFVsOfWC---- | Returns free variables of WantedConstraints as a deterministically--- ordered list. See Note [Deterministic FV] in "GHC.Utils.FV".-tyCoVarsOfWCList :: WantedConstraints -> [TyCoVar]--- Only called on *zonked* things-tyCoVarsOfWCList = fvVarList . tyCoFVsOfWC---- | Returns free variables of WantedConstraints as a composable FV--- computation. See Note [Deterministic FV] in "GHC.Utils.FV".-tyCoFVsOfWC :: WantedConstraints -> FV--- Only called on *zonked* things-tyCoFVsOfWC (WC { wc_simple = simple, wc_impl = implic, wc_holes = holes })-  = tyCoFVsOfCts simple `unionFV`-    tyCoFVsOfBag tyCoFVsOfImplic implic `unionFV`-    tyCoFVsOfBag tyCoFVsOfHole holes---- | Returns free variables of Implication as a composable FV computation.--- See Note [Deterministic FV] in "GHC.Utils.FV".-tyCoFVsOfImplic :: Implication -> FV--- Only called on *zonked* things-tyCoFVsOfImplic (Implic { ic_skols = skols-                        , ic_given = givens-                        , ic_wanted = wanted })-  | isEmptyWC wanted-  = emptyFV-  | otherwise-  = tyCoFVsVarBndrs skols  $-    tyCoFVsVarBndrs givens $-    tyCoFVsOfWC wanted--tyCoFVsOfHole :: Hole -> FV-tyCoFVsOfHole (Hole { hole_ty = ty }) = tyCoFVsOfType ty--tyCoFVsOfBag :: (a -> FV) -> Bag a -> FV-tyCoFVsOfBag tvs_of = foldr (unionFV . tvs_of) emptyFV------------------------------dropDerivedWC :: WantedConstraints -> WantedConstraints--- See Note [Dropping derived constraints]-dropDerivedWC wc@(WC { wc_simple = simples })-  = wc { wc_simple = dropDerivedSimples simples }-    -- The wc_impl implications are already (recursively) filtered-----------------------------dropDerivedSimples :: Cts -> Cts--- Drop all Derived constraints, but make [W] back into [WD],--- so that if we re-simplify these constraints we will get all--- the right derived constraints re-generated.  Forgetting this--- step led to #12936-dropDerivedSimples simples = mapMaybeBag dropDerivedCt simples--dropDerivedCt :: Ct -> Maybe Ct-dropDerivedCt ct-  = case ctEvFlavour ev of-      Wanted WOnly -> Just (ct' { cc_ev = ev_wd })-      Wanted _     -> Just ct'-      _ | isDroppableCt ct -> Nothing-        | otherwise        -> Just ct-  where-    ev    = ctEvidence ct-    ev_wd = ev { ctev_nosh = WDeriv }-    ct'   = setPendingScDict ct -- See Note [Resetting cc_pend_sc]--{- Note [Resetting cc_pend_sc]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-When we discard Derived constraints, in dropDerivedSimples, we must-set the cc_pend_sc flag to True, so that if we re-process this-CDictCan we will re-generate its derived superclasses. Otherwise-we might miss some fundeps.  #13662 showed this up.--See Note [The superclass story] in GHC.Tc.Solver.Canonical.--}--isDroppableCt :: Ct -> Bool-isDroppableCt ct-  = isDerived ev && not keep_deriv-    -- Drop only derived constraints, and then only if they-    -- obey Note [Dropping derived constraints]-  where-    ev   = ctEvidence ct-    loc  = ctEvLoc ev-    orig = ctLocOrigin loc--    keep_deriv-      = case ct of-          CIrredCan { cc_reason = reason } | isInsolubleReason reason -> keep_eq True-          _                                                           -> keep_eq False--    keep_eq definitely_insoluble-       | isGivenOrigin orig    -- Arising only from givens-       = definitely_insoluble  -- Keep only definitely insoluble-       | otherwise-       = case orig of-           -- See Note [Dropping derived constraints]-           -- For fundeps, drop wanted/wanted interactions-           FunDepOrigin2 {} -> True   -- Top-level/Wanted-           FunDepOrigin1 _ orig1 _ _ orig2 _-             | g1 || g2  -> True  -- Given/Wanted errors: keep all-             | otherwise -> False -- Wanted/Wanted errors: discard-             where-               g1 = isGivenOrigin orig1-               g2 = isGivenOrigin orig2--           _ -> False--arisesFromGivens :: Ct -> Bool-arisesFromGivens ct-  = case ctEvidence ct of-      CtGiven {}                   -> True-      CtWanted {}                  -> False-      CtDerived { ctev_loc = loc } -> isGivenLoc loc--isGivenLoc :: CtLoc -> Bool-isGivenLoc loc = isGivenOrigin (ctLocOrigin loc)--{- Note [Dropping derived constraints]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In general we discard derived constraints at the end of constraint solving;-see dropDerivedWC.  For example-- * Superclasses: if we have an unsolved [W] (Ord a), we don't want to-   complain about an unsolved [D] (Eq a) as well.-- * If we have [W] a ~ Int, [W] a ~ Bool, improvement will generate-   [D] Int ~ Bool, and we don't want to report that because it's-   incomprehensible. That is why we don't rewrite wanteds with wanteds!-- * We might float out some Wanteds from an implication, leaving behind-   their insoluble Deriveds. For example:--   forall a[2]. [W] alpha[1] ~ Int-                [W] alpha[1] ~ Bool-                [D] Int ~ Bool--   The Derived is insoluble, but we very much want to drop it when floating-   out.--But (tiresomely) we do keep *some* Derived constraints:-- * Type holes are derived constraints, because they have no evidence-   and we want to keep them, so we get the error report-- * We keep most derived equalities arising from functional dependencies-      - Given/Given interactions (subset of FunDepOrigin1):-        The definitely-insoluble ones reflect unreachable code.--        Others not-definitely-insoluble ones like [D] a ~ Int do not-        reflect unreachable code; indeed if fundeps generated proofs, it'd-        be a useful equality.  See #14763.   So we discard them.--      - Given/Wanted interacGiven or Wanted interacting with an-        instance declaration (FunDepOrigin2)--      - Given/Wanted interactions (FunDepOrigin1); see #9612--      - But for Wanted/Wanted interactions we do /not/ want to report an-        error (#13506).  Consider [W] C Int Int, [W] C Int Bool, with-        a fundep on class C.  We don't want to report an insoluble Int~Bool;-        c.f. "wanteds do not rewrite wanteds".--To distinguish these cases we use the CtOrigin.--NB: we keep *all* derived insolubles under some circumstances:--  * They are looked at by simplifyInfer, to decide whether to-    generalise.  Example: [W] a ~ Int, [W] a ~ Bool-    We get [D] Int ~ Bool, and indeed the constraints are insoluble,-    and we want simplifyInfer to see that, even though we don't-    ultimately want to generate an (inexplicable) error message from it---************************************************************************-*                                                                      *-                    CtEvidence-         The "flavor" of a canonical constraint-*                                                                      *-************************************************************************--}--isWantedCt :: Ct -> Bool-isWantedCt = isWanted . ctEvidence--isGivenCt :: Ct -> Bool-isGivenCt = isGiven . ctEvidence--isDerivedCt :: Ct -> Bool-isDerivedCt = isDerived . ctEvidence--{- Note [Custom type errors in constraints]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--When GHC reports a type-error about an unsolved-constraint, we check-to see if the constraint contains any custom-type errors, and if so-we report them.  Here are some examples of constraints containing type-errors:--TypeError msg           -- The actual constraint is a type error--TypError msg ~ Int      -- Some type was supposed to be Int, but ended up-                        -- being a type error instead--Eq (TypeError msg)      -- A class constraint is stuck due to a type error--F (TypeError msg) ~ a   -- A type function failed to evaluate due to a type err--It is also possible to have constraints where the type error is nested deeper,-for example see #11990, and also:--Eq (F (TypeError msg))  -- Here the type error is nested under a type-function-                        -- call, which failed to evaluate because of it,-                        -- and so the `Eq` constraint was unsolved.-                        -- This may happen when one function calls another-                        -- and the called function produced a custom type error.--}---- | A constraint is considered to be a custom type error, if it contains--- custom type errors anywhere in it.--- See Note [Custom type errors in constraints]-getUserTypeErrorMsg :: Ct -> Maybe Type-getUserTypeErrorMsg ct = findUserTypeError (ctPred ct)-  where-  findUserTypeError t = msum ( userTypeError_maybe t-                             : map findUserTypeError (subTys t)-                             )--  subTys t            = case splitAppTys t of-                          (t,[]) ->-                            case splitTyConApp_maybe t of-                              Nothing     -> []-                              Just (_,ts) -> ts-                          (t,ts) -> t : ts-----isUserTypeErrorCt :: Ct -> Bool-isUserTypeErrorCt ct = case getUserTypeErrorMsg ct of-                         Just _ -> True-                         _      -> False--isPendingScDict :: Ct -> Maybe Ct--- Says whether this is a CDictCan with cc_pend_sc is True,--- AND if so flips the flag-isPendingScDict ct@(CDictCan { cc_pend_sc = True })-                  = Just (ct { cc_pend_sc = False })-isPendingScDict _ = Nothing--isPendingScInst :: QCInst -> Maybe QCInst--- Same as isPendingScDict, but for QCInsts-isPendingScInst qci@(QCI { qci_pend_sc = True })-                  = Just (qci { qci_pend_sc = False })-isPendingScInst _ = Nothing--setPendingScDict :: Ct -> Ct--- Set the cc_pend_sc flag to True-setPendingScDict ct@(CDictCan { cc_pend_sc = False })-                    = ct { cc_pend_sc = True }-setPendingScDict ct = ct--superClassesMightHelp :: WantedConstraints -> Bool--- ^ True if taking superclasses of givens, or of wanteds (to perhaps--- expose more equalities or functional dependencies) might help to--- solve this constraint.  See Note [When superclasses help]-superClassesMightHelp (WC { wc_simple = simples, wc_impl = implics })-  = anyBag might_help_ct simples || anyBag might_help_implic implics-  where-    might_help_implic ic-       | IC_Unsolved <- ic_status ic = superClassesMightHelp (ic_wanted ic)-       | otherwise                   = False--    might_help_ct ct = isWantedCt ct && not (is_ip ct)--    is_ip (CDictCan { cc_class = cls }) = isIPClass cls-    is_ip _                             = False--getPendingWantedScs :: Cts -> ([Ct], Cts)-getPendingWantedScs simples-  = mapAccumBagL get [] simples-  where-    get acc ct | Just ct' <- isPendingScDict ct-               = (ct':acc, ct')-               | otherwise-               = (acc,     ct)--{- Note [When superclasses help]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-First read Note [The superclass story] in GHC.Tc.Solver.Canonical.--We expand superclasses and iterate only if there is at unsolved wanted-for which expansion of superclasses (e.g. from given constraints)-might actually help. The function superClassesMightHelp tells if-doing this superclass expansion might help solve this constraint.-Note that--  * We look inside implications; maybe it'll help to expand the Givens-    at level 2 to help solve an unsolved Wanted buried inside an-    implication.  E.g.-        forall a. Ord a => forall b. [W] Eq a--  * Superclasses help only for Wanted constraints.  Derived constraints-    are not really "unsolved" and we certainly don't want them to-    trigger superclass expansion. This was a good part of the loop-    in  #11523--  * Even for Wanted constraints, we say "no" for implicit parameters.-    we have [W] ?x::ty, expanding superclasses won't help:-      - Superclasses can't be implicit parameters-      - If we have a [G] ?x:ty2, then we'll have another unsolved-        [D] ty ~ ty2 (from the functional dependency)-        which will trigger superclass expansion.--    It's a bit of a special case, but it's easy to do.  The runtime cost-    is low because the unsolved set is usually empty anyway (errors-    aside), and the first non-implicit-parameter will terminate the search.--    The special case is worth it (#11480, comment:2) because it-    applies to CallStack constraints, which aren't type errors. If we have-       f :: (C a) => blah-       f x = ...undefined...-    we'll get a CallStack constraint.  If that's the only unsolved-    constraint it'll eventually be solved by defaulting.  So we don't-    want to emit warnings about hitting the simplifier's iteration-    limit.  A CallStack constraint really isn't an unsolved-    constraint; it can always be solved by defaulting.--}--singleCt :: Ct -> Cts-singleCt = unitBag--andCts :: Cts -> Cts -> Cts-andCts = unionBags--listToCts :: [Ct] -> Cts-listToCts = listToBag--ctsElts :: Cts -> [Ct]-ctsElts = bagToList--consCts :: Ct -> Cts -> Cts-consCts = consBag--snocCts :: Cts -> Ct -> Cts-snocCts = snocBag--extendCtsList :: Cts -> [Ct] -> Cts-extendCtsList cts xs | null xs   = cts-                     | otherwise = cts `unionBags` listToBag xs--andManyCts :: [Cts] -> Cts-andManyCts = unionManyBags--emptyCts :: Cts-emptyCts = emptyBag--isEmptyCts :: Cts -> Bool-isEmptyCts = isEmptyBag--pprCts :: Cts -> SDoc-pprCts cts = vcat (map ppr (bagToList cts))--{--************************************************************************-*                                                                      *-                Wanted constraints-     These are forced to be in GHC.Tc.Types because-           TcLclEnv mentions WantedConstraints-           WantedConstraint mentions CtLoc-           CtLoc mentions ErrCtxt-           ErrCtxt mentions TcM-*                                                                      *-v%************************************************************************--}--data WantedConstraints-  = WC { wc_simple :: Cts              -- Unsolved constraints, all wanted-       , wc_impl   :: Bag Implication-       , wc_holes  :: Bag Hole-    }--emptyWC :: WantedConstraints-emptyWC = WC { wc_simple = emptyBag-             , wc_impl   = emptyBag-             , wc_holes  = emptyBag }--mkSimpleWC :: [CtEvidence] -> WantedConstraints-mkSimpleWC cts-  = emptyWC { wc_simple = listToBag (map mkNonCanonical cts) }--mkImplicWC :: Bag Implication -> WantedConstraints-mkImplicWC implic-  = emptyWC { wc_impl = implic }--isEmptyWC :: WantedConstraints -> Bool-isEmptyWC (WC { wc_simple = f, wc_impl = i, wc_holes = holes })-  = isEmptyBag f && isEmptyBag i && isEmptyBag holes---- | Checks whether a the given wanted constraints are solved, i.e.--- that there are no simple constraints left and all the implications--- are solved.-isSolvedWC :: WantedConstraints -> Bool-isSolvedWC WC {wc_simple = wc_simple, wc_impl = wc_impl, wc_holes = holes} =-  isEmptyBag wc_simple && allBag (isSolvedStatus . ic_status) wc_impl && isEmptyBag holes--andWC :: WantedConstraints -> WantedConstraints -> WantedConstraints-andWC (WC { wc_simple = f1, wc_impl = i1, wc_holes = h1 })-      (WC { wc_simple = f2, wc_impl = i2, wc_holes = h2 })-  = WC { wc_simple = f1 `unionBags` f2-       , wc_impl   = i1 `unionBags` i2-       , wc_holes  = h1 `unionBags` h2 }--unionsWC :: [WantedConstraints] -> WantedConstraints-unionsWC = foldr andWC emptyWC--addSimples :: WantedConstraints -> Bag Ct -> WantedConstraints-addSimples wc cts-  = wc { wc_simple = wc_simple wc `unionBags` cts }-    -- Consider: Put the new constraints at the front, so they get solved first--addImplics :: WantedConstraints -> Bag Implication -> WantedConstraints-addImplics wc implic = wc { wc_impl = wc_impl wc `unionBags` implic }--addInsols :: WantedConstraints -> Bag Ct -> WantedConstraints-addInsols wc cts-  = wc { wc_simple = wc_simple wc `unionBags` cts }--addHoles :: WantedConstraints -> Bag Hole -> WantedConstraints-addHoles wc holes-  = wc { wc_holes = holes `unionBags` wc_holes wc }--dropMisleading :: WantedConstraints -> WantedConstraints--- Drop misleading constraints; really just class constraints--- See Note [Constraints and errors] in GHC.Tc.Utils.Monad---   for why this function is so strange, treating the 'simples'---   and the implications differently.  Sigh.-dropMisleading (WC { wc_simple = simples, wc_impl = implics, wc_holes = holes })-  = WC { wc_simple = filterBag insolubleCt simples-       , wc_impl   = mapBag drop_implic implics-       , wc_holes  = filterBag isOutOfScopeHole holes }-  where-    drop_implic implic-      = implic { ic_wanted = drop_wanted (ic_wanted implic) }-    drop_wanted (WC { wc_simple = simples, wc_impl = implics, wc_holes = holes })-      = WC { wc_simple = filterBag keep_ct simples-           , wc_impl   = mapBag drop_implic implics-           , wc_holes  = filterBag isOutOfScopeHole holes }--    keep_ct ct = case classifyPredType (ctPred ct) of-                    ClassPred {} -> False-                    _ -> True--isSolvedStatus :: ImplicStatus -> Bool-isSolvedStatus (IC_Solved {}) = True-isSolvedStatus _              = False--isInsolubleStatus :: ImplicStatus -> Bool-isInsolubleStatus IC_Insoluble    = True-isInsolubleStatus IC_BadTelescope = True-isInsolubleStatus _               = False--insolubleImplic :: Implication -> Bool-insolubleImplic ic = isInsolubleStatus (ic_status ic)--insolubleWC :: WantedConstraints -> Bool-insolubleWC (WC { wc_impl = implics, wc_simple = simples, wc_holes = holes })-  =  anyBag insolubleCt simples-  || anyBag insolubleImplic implics-  || anyBag isOutOfScopeHole holes  -- See Note [Insoluble holes]--insolubleCt :: Ct -> Bool--- Definitely insoluble, in particular /excluding/ type-hole constraints--- Namely: a) an equality constraint---         b) that is insoluble---         c) and does not arise from a Given-insolubleCt ct-  | not (insolubleEqCt ct) = False-  | arisesFromGivens ct    = False              -- See Note [Given insolubles]-  | otherwise              = True--insolubleEqCt :: Ct -> Bool--- Returns True of /equality/ constraints--- that are /definitely/ insoluble--- It won't detect some definite errors like---       F a ~ T (F a)--- where F is a type family, which actually has an occurs check------ The function is tuned for application /after/ constraint solving---       i.e. assuming canonicalisation has been done--- E.g.  It'll reply True  for     a ~ [a]---               but False for   [a] ~ a--- and---                   True for  Int ~ F a Int---               but False for  Maybe Int ~ F a Int Int---               (where F is an arity-1 type function)-insolubleEqCt (CIrredCan { cc_reason = reason }) = isInsolubleReason reason-insolubleEqCt _                                  = False---- | Does this hole represent an "out of scope" error?--- See Note [Insoluble holes]-isOutOfScopeHole :: Hole -> Bool-isOutOfScopeHole (Hole { hole_occ = occ }) = not (startsWithUnderscore occ)--instance Outputable WantedConstraints where-  ppr (WC {wc_simple = s, wc_impl = i, wc_holes = h})-   = text "WC" <+> braces (vcat-        [ ppr_bag (text "wc_simple") s-        , ppr_bag (text "wc_impl") i-        , ppr_bag (text "wc_holes") h ])--ppr_bag :: Outputable a => SDoc -> Bag a -> SDoc-ppr_bag doc bag- | isEmptyBag bag = empty- | otherwise      = hang (doc <+> equals)-                       2 (foldr (($$) . ppr) empty bag)--{- Note [Given insolubles]-~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider (#14325, comment:)-    class (a~b) => C a b--    foo :: C a c => a -> c-    foo x = x--    hm3 :: C (f b) b => b -> f b-    hm3 x = foo x--In the RHS of hm3, from the [G] C (f b) b we get the insoluble-[G] f b ~# b.  Then we also get an unsolved [W] C b (f b).-Residual implication looks like-    forall b. C (f b) b => [G] f b ~# b-                           [W] C f (f b)--We do /not/ want to set the implication status to IC_Insoluble,-because that'll suppress reports of [W] C b (f b).  But we-may not report the insoluble [G] f b ~# b either (see Note [Given errors]-in GHC.Tc.Errors), so we may fail to report anything at all!  Yikes.--The same applies to Derived constraints that /arise from/ Givens.-E.g.   f :: (C Int [a]) => blah-where a fundep means we get-       [D] Int ~ [a]-By the same reasoning we must not suppress other errors (#15767)--Bottom line: insolubleWC (called in GHC.Tc.Solver.setImplicationStatus)-             should ignore givens even if they are insoluble.--Note [Insoluble holes]-~~~~~~~~~~~~~~~~~~~~~~-Hole constraints that ARE NOT treated as truly insoluble:-  a) type holes, arising from PartialTypeSignatures,-  b) "true" expression holes arising from TypedHoles--An "expression hole" or "type hole" isn't really an error-at all; it's a report saying "_ :: Int" here.  But an out-of-scope-variable masquerading as expression holes IS treated as truly-insoluble, so that it trumps other errors during error reporting.-Yuk!--************************************************************************-*                                                                      *-                Implication constraints-*                                                                      *-************************************************************************--}--data Implication-  = Implic {   -- Invariants for a tree of implications:-               -- see TcType Note [TcLevel invariants]--      ic_tclvl :: TcLevel,       -- TcLevel of unification variables-                                 -- allocated /inside/ this implication--      ic_skols :: [TcTyVar],     -- Introduced skolems-      ic_info  :: SkolemInfo,    -- See Note [Skolems in an implication]-                                 -- See Note [Shadowing in a constraint]--      ic_given  :: [EvVar],      -- Given evidence variables-                                 --   (order does not matter)-                                 -- See Invariant (GivenInv) in GHC.Tc.Utils.TcType--      ic_given_eqs :: HasGivenEqs,  -- Are there Given equalities here?--      ic_warn_inaccessible :: Bool,-                                 -- True  <=> -Winaccessible-code is enabled-                                 -- at construction. See-                                 -- Note [Avoid -Winaccessible-code when deriving]-                                 -- in GHC.Tc.TyCl.Instance--      ic_env   :: TcLclEnv,-                                 -- Records the TcLClEnv at the time of creation.-                                 ---                                 -- The TcLclEnv gives the source location-                                 -- and error context for the implication, and-                                 -- hence for all the given evidence variables.--      ic_wanted :: WantedConstraints,  -- The wanteds-                                       -- See Invariang (WantedInf) in GHC.Tc.Utils.TcType--      ic_binds  :: EvBindsVar,    -- Points to the place to fill in the-                                  -- abstraction and bindings.--      -- The ic_need fields keep track of which Given evidence-      -- is used by this implication or its children-      -- NB: including stuff used by nested implications that have since-      --     been discarded-      -- See Note [Needed evidence variables]-      ic_need_inner :: VarSet,    -- Includes all used Given evidence-      ic_need_outer :: VarSet,    -- Includes only the free Given evidence-                                  --  i.e. ic_need_inner after deleting-                                  --       (a) givens (b) binders of ic_binds--      ic_status   :: ImplicStatus-    }--implicationPrototype :: Implication-implicationPrototype-   = Implic { -- These fields must be initialised-              ic_tclvl      = panic "newImplic:tclvl"-            , ic_binds      = panic "newImplic:binds"-            , ic_info       = panic "newImplic:info"-            , ic_env        = panic "newImplic:env"-            , ic_warn_inaccessible = panic "newImplic:warn_inaccessible"--              -- The rest have sensible default values-            , ic_skols      = []-            , ic_given      = []-            , ic_wanted     = emptyWC-            , ic_given_eqs  = MaybeGivenEqs-            , ic_status     = IC_Unsolved-            , ic_need_inner = emptyVarSet-            , ic_need_outer = emptyVarSet }--data ImplicStatus-  = IC_Solved     -- All wanteds in the tree are solved, all the way down-       { ics_dead :: [EvVar] }  -- Subset of ic_given that are not needed-         -- See Note [Tracking redundant constraints] in GHC.Tc.Solver--  | IC_Insoluble  -- At least one insoluble constraint in the tree--  | IC_BadTelescope  -- Solved, but the skolems in the telescope are out of-                     -- dependency order. See Note [Checking telescopes]--  | IC_Unsolved   -- Neither of the above; might go either way--data HasGivenEqs -- See Note [HasGivenEqs]-  = NoGivenEqs      -- Definitely no given equalities,-                    --   except by Note [Let-bound skolems] in GHC.Tc.Solver.Monad-  | LocalGivenEqs   -- Might have Given equalities, but only ones that affect only-                    --   local skolems e.g. forall a b. (a ~ F b) => ...-  | MaybeGivenEqs   -- Might have any kind of Given equalities; no floating out-                    --   is possible.-  deriving Eq--{- Note [HasGivenEqs]-~~~~~~~~~~~~~~~~~~~~~-The GivenEqs data type describes the Given constraints of an implication constraint:--* NoGivenEqs: definitely no Given equalities, except perhaps let-bound skolems-  which don't count: see Note [Let-bound skolems] in GHC.Tc.Solver.Monad-  Examples: forall a. Eq a => ...-            forall a. (Show a, Num a) => ...-            forall a. a ~ Either Int Bool => ...  -- Let-bound skolem--* LocalGivenEqs: definitely no Given equalities that would affect principal-  types.  But may have equalities that affect only skolems of this implication-  (and hence do not affect princial types)-  Examples: forall a. F a ~ Int => ...-            forall a b. F a ~ G b => ...--* MaybeGivenEqs: may have Given equalities that would affect principal-  types-  Examples: forall. (a ~ b) => ...-            forall a. F a ~ b => ...-            forall a. c a => ...       -- The 'c' might be instantiated to (b ~)-            forall a. C a b => ....-               where class x~y => C a b-               so there is an equality in the superclass of a Given--The HasGivenEqs classifications affect two things:--* Suppressing redundant givens during error reporting; see GHC.Tc.Errors-  Note [Suppress redundant givens during error reporting]--* Floating in approximateWC.--Specifically, here's how it goes:--                 Stops floating    |   Suppresses Givens in errors-                 in approximateWC  |-                 ------------------------------------------------ NoGivenEqs         NO             |         YES- LocalGivenEqs      NO             |         NO- MaybeGivenEqs      YES            |         NO--}--instance Outputable Implication where-  ppr (Implic { ic_tclvl = tclvl, ic_skols = skols-              , ic_given = given, ic_given_eqs = given_eqs-              , ic_wanted = wanted, ic_status = status-              , ic_binds = binds-              , ic_need_inner = need_in, ic_need_outer = need_out-              , ic_info = info })-   = hang (text "Implic" <+> lbrace)-        2 (sep [ text "TcLevel =" <+> ppr tclvl-               , text "Skolems =" <+> pprTyVars skols-               , text "Given-eqs =" <+> ppr given_eqs-               , text "Status =" <+> ppr status-               , hang (text "Given =")  2 (pprEvVars given)-               , hang (text "Wanted =") 2 (ppr wanted)-               , text "Binds =" <+> ppr binds-               , whenPprDebug (text "Needed inner =" <+> ppr need_in)-               , whenPprDebug (text "Needed outer =" <+> ppr need_out)-               , pprSkolInfo info ] <+> rbrace)--instance Outputable ImplicStatus where-  ppr IC_Insoluble    = text "Insoluble"-  ppr IC_BadTelescope = text "Bad telescope"-  ppr IC_Unsolved     = text "Unsolved"-  ppr (IC_Solved { ics_dead = dead })-    = text "Solved" <+> (braces (text "Dead givens =" <+> ppr dead))--checkTelescopeSkol :: SkolemInfo -> Bool--- See Note [Checking telescopes]-checkTelescopeSkol (ForAllSkol {}) = True-checkTelescopeSkol _               = False--instance Outputable HasGivenEqs where-  ppr NoGivenEqs    = text "NoGivenEqs"-  ppr LocalGivenEqs = text "LocalGivenEqs"-  ppr MaybeGivenEqs = text "MaybeGivenEqs"---- Used in GHC.Tc.Solver.Monad.getHasGivenEqs-instance Semigroup HasGivenEqs where-  NoGivenEqs <> other = other-  other <> NoGivenEqs = other--  MaybeGivenEqs <> _other = MaybeGivenEqs-  _other <> MaybeGivenEqs = MaybeGivenEqs--  LocalGivenEqs <> LocalGivenEqs = LocalGivenEqs---- Used in GHC.Tc.Solver.Monad.getHasGivenEqs-instance Monoid HasGivenEqs where-  mempty = NoGivenEqs--{- Note [Checking telescopes]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When kind-checking a /user-written/ type, we might have a "bad telescope"-like this one:-  data SameKind :: forall k. k -> k -> Type-  type Foo :: forall a k (b :: k). SameKind a b -> Type--The kind of 'a' mentions 'k' which is bound after 'a'.  Oops.--One approach to doing this would be to bring each of a, k, and b into-scope, one at a time, creating a separate implication constraint for-each one, and bumping the TcLevel. This would work, because the kind-of, say, a would be untouchable when k is in scope (and the constraint-couldn't float out because k blocks it). However, it leads to terrible-error messages, complaining about skolem escape. While it is indeed a-problem of skolem escape, we can do better.--Instead, our approach is to bring the block of variables into scope-all at once, creating one implication constraint for the lot:--* We make a single implication constraint when kind-checking-  the 'forall' in Foo's kind, something like-      forall a k (b::k). { wanted constraints }--* Having solved {wanted}, before discarding the now-solved implication,-  the constraint solver checks the dependency order of the skolem-  variables (ic_skols).  This is done in setImplicationStatus.--* This check is only necessary if the implication was born from a-  'forall' in a user-written signature (the HsForAllTy case in-  GHC.Tc.Gen.HsType.  If, say, it comes from checking a pattern match-  that binds existentials, where the type of the data constructor is-  known to be valid (it in tcConPat), no need for the check.--  So the check is done /if and only if/ ic_info is ForAllSkol.--* If ic_info is (ForAllSkol dt dvs), the dvs::SDoc displays the-  original, user-written type variables.--* Be careful /NOT/ to discard an implication with a ForAllSkol-  ic_info, even if ic_wanted is empty.  We must give the-  constraint solver a chance to make that bad-telescope test!  Hence-  the extra guard in emitResidualTvConstraint; see #16247--* Don't mix up inferred and explicit variables in the same implication-  constraint.  E.g.-      foo :: forall a kx (b :: kx). SameKind a b-  We want an implication-      Implic { ic_skol = [(a::kx), kx, (b::kx)], ... }-  but GHC will attempt to quantify over kx, since it is free in (a::kx),-  and it's hopelessly confusing to report an error about quantified-  variables   kx (a::kx) kx (b::kx).-  Instead, the outer quantification over kx should be in a separate-  implication. TL;DR: an explicit forall should generate an implication-  quantified only over those explicitly quantified variables.--Note [Needed evidence variables]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Th ic_need_evs field holds the free vars of ic_binds, and all the-ic_binds in nested implications.--  * Main purpose: if one of the ic_givens is not mentioned in here, it-    is redundant.--  * solveImplication may drop an implication altogether if it has no-    remaining 'wanteds'. But we still track the free vars of its-    evidence binds, even though it has now disappeared.--Note [Shadowing in a constraint]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We assume NO SHADOWING in a constraint.  Specifically- * The unification variables are all implicitly quantified at top-   level, and are all unique- * The skolem variables bound in ic_skols are all freah when the-   implication is created.-So we can safely substitute. For example, if we have-   forall a.  a~Int => ...(forall b. ...a...)...-we can push the (a~Int) constraint inwards in the "givens" without-worrying that 'b' might clash.--Note [Skolems in an implication]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The skolems in an implication are used:--* When considering floating a constraint outside the implication in-  GHC.Tc.Solver.floatEqualities or GHC.Tc.Solver.approximateImplications-  For this, we can treat ic_skols as a set.--* When checking that a /user-specified/ forall (ic_info = ForAllSkol tvs)-  has its variables in the correct order; see Note [Checking telescopes].-  Only for these implications does ic_skols need to be a list.--Nota bene: Although ic_skols is a list, it is not necessarily-in dependency order:-- In the ic_info=ForAllSkol case, the user might have written them-  in the wrong order-- In the case of a type signature like-      f :: [a] -> [b]-  the renamer gathers the implicit "outer" forall'd variables {a,b}, but-  does not know what order to put them in.  The type checker can sort them-  into dependency order, but only after solving all the kind constraints;-  and to do that it's convenient to create the Implication!--So we accept that ic_skols may be out of order.  Think of it as a set or-(in the case of ic_info=ForAllSkol, a list in user-specified, and possibly-wrong, order.--Note [Insoluble constraints]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Some of the errors that we get during canonicalization are best-reported when all constraints have been simplified as much as-possible. For instance, assume that during simplification the-following constraints arise:-- [Wanted]   F alpha ~  uf1- [Wanted]   beta ~ uf1 beta--When canonicalizing the wanted (beta ~ uf1 beta), if we eagerly fail-we will simply see a message:-    'Can't construct the infinite type  beta ~ uf1 beta'-and the user has no idea what the uf1 variable is.--Instead our plan is that we will NOT fail immediately, but:-    (1) Record the "frozen" error in the ic_insols field-    (2) Isolate the offending constraint from the rest of the inerts-    (3) Keep on simplifying/canonicalizing--At the end, we will hopefully have substituted uf1 := F alpha, and we-will be able to report a more informative error:-    'Can't construct the infinite type beta ~ F alpha beta'--Insoluble constraints *do* include Derived constraints. For example,-a functional dependency might give rise to [D] Int ~ Bool, and we must-report that.  If insolubles did not contain Deriveds, reportErrors would-never see it.---************************************************************************-*                                                                      *-            Pretty printing-*                                                                      *-************************************************************************--}--pprEvVars :: [EvVar] -> SDoc    -- Print with their types-pprEvVars ev_vars = vcat (map pprEvVarWithType ev_vars)--pprEvVarTheta :: [EvVar] -> SDoc-pprEvVarTheta ev_vars = pprTheta (map evVarPred ev_vars)--pprEvVarWithType :: EvVar -> SDoc-pprEvVarWithType v = ppr v <+> dcolon <+> pprType (evVarPred v)----wrapType :: Type -> [TyVar] -> [PredType] -> Type-wrapType ty skols givens = mkSpecForAllTys skols $ mkPhiTy givens ty---{--************************************************************************-*                                                                      *-            CtEvidence-*                                                                      *-************************************************************************--Note [Evidence field of CtEvidence]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-During constraint solving we never look at the type of ctev_evar/ctev_dest;-instead we look at the ctev_pred field.  The evtm/evar field-may be un-zonked.--Note [Bind new Givens immediately]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-For Givens we make new EvVars and bind them immediately. Two main reasons:-  * Gain sharing.  E.g. suppose we start with g :: C a b, where-       class D a => C a b-       class (E a, F a) => D a-    If we generate all g's superclasses as separate EvTerms we might-    get    selD1 (selC1 g) :: E a-           selD2 (selC1 g) :: F a-           selC1 g :: D a-    which we could do more economically as:-           g1 :: D a = selC1 g-           g2 :: E a = selD1 g1-           g3 :: F a = selD2 g1--  * For *coercion* evidence we *must* bind each given:-      class (a~b) => C a b where ....-      f :: C a b => ....-    Then in f's Givens we have g:(C a b) and the superclass sc(g,0):a~b.-    But that superclass selector can't (yet) appear in a coercion-    (see evTermCoercion), so the easy thing is to bind it to an Id.--So a Given has EvVar inside it rather than (as previously) an EvTerm.---}---- | A place for type-checking evidence to go after it is generated.--- Wanted equalities are always HoleDest; other wanteds are always--- EvVarDest.-data TcEvDest-  = EvVarDest EvVar         -- ^ bind this var to the evidence-              -- EvVarDest is always used for non-type-equalities-              -- e.g. class constraints--  | HoleDest  CoercionHole  -- ^ fill in this hole with the evidence-              -- HoleDest is always used for type-equalities-              -- See Note [Coercion holes] in GHC.Core.TyCo.Rep--data CtEvidence-  = CtGiven    -- Truly given, not depending on subgoals-      { ctev_pred :: TcPredType      -- See Note [Ct/evidence invariant]-      , ctev_evar :: EvVar           -- See Note [Evidence field of CtEvidence]-      , ctev_loc  :: CtLoc }---  | CtWanted   -- Wanted goal-      { ctev_pred :: TcPredType     -- See Note [Ct/evidence invariant]-      , ctev_dest :: TcEvDest-      , ctev_nosh :: ShadowInfo     -- See Note [Constraint flavours]-      , ctev_loc  :: CtLoc }--  | CtDerived  -- A goal that we don't really have to solve and can't-               -- immediately rewrite anything other than a derived-               -- (there's no evidence!) but if we do manage to solve-               -- it may help in solving other goals.-      { ctev_pred :: TcPredType-      , ctev_loc  :: CtLoc }--ctEvPred :: CtEvidence -> TcPredType--- The predicate of a flavor-ctEvPred = ctev_pred--ctEvLoc :: CtEvidence -> CtLoc-ctEvLoc = ctev_loc--ctEvOrigin :: CtEvidence -> CtOrigin-ctEvOrigin = ctLocOrigin . ctEvLoc---- | Get the equality relation relevant for a 'CtEvidence'-ctEvEqRel :: CtEvidence -> EqRel-ctEvEqRel = predTypeEqRel . ctEvPred---- | Get the role relevant for a 'CtEvidence'-ctEvRole :: CtEvidence -> Role-ctEvRole = eqRelRole . ctEvEqRel--ctEvTerm :: CtEvidence -> EvTerm-ctEvTerm ev = EvExpr (ctEvExpr ev)--ctEvExpr :: CtEvidence -> EvExpr-ctEvExpr ev@(CtWanted { ctev_dest = HoleDest _ })-            = Coercion $ ctEvCoercion ev-ctEvExpr ev = evId (ctEvEvId ev)--ctEvCoercion :: HasDebugCallStack => CtEvidence -> TcCoercion-ctEvCoercion (CtGiven { ctev_evar = ev_id })-  = mkTcCoVarCo ev_id-ctEvCoercion (CtWanted { ctev_dest = dest })-  | HoleDest hole <- dest-  = -- ctEvCoercion is only called on type equalities-    -- and they always have HoleDests-    mkHoleCo hole-ctEvCoercion ev-  = pprPanic "ctEvCoercion" (ppr ev)--ctEvEvId :: CtEvidence -> EvVar-ctEvEvId (CtWanted { ctev_dest = EvVarDest ev }) = ev-ctEvEvId (CtWanted { ctev_dest = HoleDest h })   = coHoleCoVar h-ctEvEvId (CtGiven  { ctev_evar = ev })           = ev-ctEvEvId ctev@(CtDerived {}) = pprPanic "ctEvId:" (ppr ctev)--instance Outputable TcEvDest where-  ppr (HoleDest h)   = text "hole" <> ppr h-  ppr (EvVarDest ev) = ppr ev--instance Outputable CtEvidence where-  ppr ev = ppr (ctEvFlavour ev)-           <+> pp_ev <+> braces (ppr (ctl_depth (ctEvLoc ev)))-                         -- Show the sub-goal depth too-               <> dcolon <+> ppr (ctEvPred ev)-    where-      pp_ev = case ev of-             CtGiven { ctev_evar = v } -> ppr v-             CtWanted {ctev_dest = d } -> ppr d-             CtDerived {}              -> text "_"--isWanted :: CtEvidence -> Bool-isWanted (CtWanted {}) = True-isWanted _ = False--isGiven :: CtEvidence -> Bool-isGiven (CtGiven {})  = True-isGiven _ = False--isDerived :: CtEvidence -> Bool-isDerived (CtDerived {}) = True-isDerived _              = False--{--%************************************************************************-%*                                                                      *-            CtFlavour-%*                                                                      *-%************************************************************************--Note [Constraint flavours]-~~~~~~~~~~~~~~~~~~~~~~~~~~-Constraints come in four flavours:--* [G] Given: we have evidence--* [W] Wanted WOnly: we want evidence--* [D] Derived: any solution must satisfy this constraint, but-      we don't need evidence for it.  Examples include:-        - superclasses of [W] class constraints-        - equalities arising from functional dependencies-          or injectivity--* [WD] Wanted WDeriv: a single constraint that represents-                      both [W] and [D]-  We keep them paired as one both for efficiency--The ctev_nosh field of a Wanted distinguishes between [W] and [WD]--Wanted constraints are born as [WD], but are split into [W] and its-"shadow" [D] in GHC.Tc.Solver.Monad.maybeEmitShadow.--See Note [The improvement story and derived shadows] in GHC.Tc.Solver.Monad--}--data CtFlavour  -- See Note [Constraint flavours]-  = Given-  | Wanted ShadowInfo-  | Derived-  deriving Eq--data ShadowInfo-  = WDeriv   -- [WD] This Wanted constraint has no Derived shadow,-             -- so it behaves like a pair of a Wanted and a Derived-  | WOnly    -- [W] It has a separate derived shadow-             -- See Note [The improvement story and derived shadows] in GHC.Tc.Solver.Monad-  deriving( Eq )--instance Outputable CtFlavour where-  ppr Given           = text "[G]"-  ppr (Wanted WDeriv) = text "[WD]"-  ppr (Wanted WOnly)  = text "[W]"-  ppr Derived         = text "[D]"---- | Does this 'CtFlavour' subsumed 'Derived'? True of @[WD]@ and @[D]@.-ctFlavourContainsDerived :: CtFlavour -> Bool-ctFlavourContainsDerived (Wanted WDeriv) = True-ctFlavourContainsDerived Derived         = True-ctFlavourContainsDerived _               = False--ctEvFlavour :: CtEvidence -> CtFlavour-ctEvFlavour (CtWanted { ctev_nosh = nosh }) = Wanted nosh-ctEvFlavour (CtGiven {})                    = Given-ctEvFlavour (CtDerived {})                  = Derived---- | Whether or not one 'Ct' can rewrite another is determined by its--- flavour and its equality relation. See also--- Note [Flavours with roles] in "GHC.Tc.Solver.Monad"-type CtFlavourRole = (CtFlavour, EqRel)---- | Extract the flavour, role, and boxity from a 'CtEvidence'-ctEvFlavourRole :: CtEvidence -> CtFlavourRole-ctEvFlavourRole ev = (ctEvFlavour ev, ctEvEqRel ev)---- | Extract the flavour and role from a 'Ct'-ctFlavourRole :: Ct -> CtFlavourRole--- Uses short-cuts to role for special cases-ctFlavourRole (CDictCan { cc_ev = ev })-  = (ctEvFlavour ev, NomEq)-ctFlavourRole (CEqCan { cc_ev = ev, cc_eq_rel = eq_rel })-  = (ctEvFlavour ev, eq_rel)-ctFlavourRole ct-  = ctEvFlavourRole (ctEvidence ct)--{- Note [eqCanRewrite]-~~~~~~~~~~~~~~~~~~~~~~-(eqCanRewrite ct1 ct2) holds if the constraint ct1 (a CEqCan of form-lhs ~ ty) can be used to rewrite ct2.  It must satisfy the properties of-a can-rewrite relation, see Definition [Can-rewrite relation] in-GHC.Tc.Solver.Monad.--With the solver handling Coercible constraints like equality constraints,-the rewrite conditions must take role into account, never allowing-a representational equality to rewrite a nominal one.--Note [Wanteds do not rewrite Wanteds]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We don't allow Wanteds to rewrite Wanteds, because that can give rise-to very confusing type error messages.  A good example is #8450.-Here's another-   f :: a -> Bool-   f x = ( [x,'c'], [x,True] ) `seq` True-Here we get-  [W] a ~ Char-  [W] a ~ Bool-but we do not want to complain about Bool ~ Char!--Note [Deriveds do rewrite Deriveds]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-However we DO allow Deriveds to rewrite Deriveds, because that's how-improvement works; see Note [The improvement story] in GHC.Tc.Solver.Interact.--However, for now at least I'm only letting (Derived,NomEq) rewrite-(Derived,NomEq) and not doing anything for ReprEq.  If we have-    eqCanRewriteFR (Derived, NomEq) (Derived, _)  = True-then we lose property R2 of Definition [Can-rewrite relation]-in GHC.Tc.Solver.Monad-  R2.  If f1 >= f, and f2 >= f,-       then either f1 >= f2 or f2 >= f1-Consider f1 = (Given, ReprEq)-         f2 = (Derived, NomEq)-          f = (Derived, ReprEq)--I thought maybe we could never get Derived ReprEq constraints, but-we can; straight from the Wanteds during improvement. And from a Derived-ReprEq we could conceivably get a Derived NomEq improvement (by decomposing-a type constructor with Nomninal role), and hence unify.--This restriction that (Derived, NomEq) cannot rewrite (Derived, ReprEq) bites,-in an obscure scenario:--  data T a-  type role T nominal--  type family F a--  g :: forall b a. (F a ~ T a, Coercible (F a) (T b)) => ()-  g = ()--  f :: forall a. (F a ~ T a) => ()-  f = g @a--The problem is in the body of f. We have--  [G]  F a ~N T a-  [WD] F alpha ~N T alpha-  [WD] F alpha ~R T a--The Wanteds aren't of use, so let's just look at Deriveds:--  [G] F a ~N T a-  [D] F alpha ~N T alpha-  [D] F alpha ~R T a--As written, this makes no progress, and GHC errors. But, if we-allowed D/N to rewrite D/R, the first D could rewrite the second:--  [G] F a ~N T a-  [D] F alpha ~N T alpha-  [D] T alpha ~R T a--Now we decompose the second D to get--  [D] alpha ~N a--noting the role annotation on T. This causes (alpha := a), and then-everything else unlocks.--What to do? We could "decompose" nominal equalities into nominal-only-("NO") equalities and representational ones, where a NO equality rewrites-only nominals. That is, when considering whether [D] F alpha ~N T alpha-should rewrite [D] F alpha ~R T a, we could require splitting the first D-into [D] F alpha ~NO T alpha, [D] F alpha ~R T alpha. Then, we use the R-half of the split to rewrite the second D, and off we go. This splitting-would allow the split-off R equality to be rewritten by other equalities,-thus avoiding the problem in Note [Why R2?] in GHC.Tc.Solver.Monad.--This infelicity is #19665 and tested in typecheck/should_compile/T19665-(marked as expect_broken).---}--eqCanRewrite :: EqRel -> EqRel -> Bool-eqCanRewrite NomEq  _      = True-eqCanRewrite ReprEq ReprEq = True-eqCanRewrite ReprEq NomEq  = False--eqCanRewriteFR :: CtFlavourRole -> CtFlavourRole -> Bool--- Can fr1 actually rewrite fr2?--- Very important function!--- See Note [eqCanRewrite]--- See Note [Wanteds do not rewrite Wanteds]--- See Note [Deriveds do rewrite Deriveds]-eqCanRewriteFR (Given,         r1)    (_,       r2)    = eqCanRewrite r1 r2-eqCanRewriteFR (Wanted WDeriv, NomEq) (Derived, NomEq) = True-eqCanRewriteFR (Derived,       NomEq) (Derived, NomEq) = True-eqCanRewriteFR _                      _                = False--eqMayRewriteFR :: CtFlavourRole -> CtFlavourRole -> Bool--- Is it /possible/ that fr1 can rewrite fr2?--- This is used when deciding which inerts to kick out,--- at which time a [WD] inert may be split into [W] and [D]-eqMayRewriteFR (Wanted WDeriv, NomEq) (Wanted WDeriv, NomEq) = True-eqMayRewriteFR (Derived,       NomEq) (Wanted WDeriv, NomEq) = True-eqMayRewriteFR fr1 fr2 = eqCanRewriteFR fr1 fr2--{- Note [eqCanDischarge]-~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we have two identical CEqCan equality constraints-(i.e. both LHS and RHS are the same)-      (x1:lhs~t) `eqCanDischarge` (xs:lhs~t)-Can we just drop x2 in favour of x1?--Answer: yes if eqCanDischarge is true.--Note that we do /not/ allow Wanted to discharge Derived.-We must keep both.  Why?  Because the Derived may rewrite-other Deriveds in the model whereas the Wanted cannot.--However a Wanted can certainly discharge an identical Wanted.  So-eqCanDischarge does /not/ define a can-rewrite relation in the-sense of Definition [Can-rewrite relation] in GHC.Tc.Solver.Monad.--We /do/ say that a [W] can discharge a [WD].  In evidence terms it-certainly can, and the /caller/ arranges that the otherwise-lost [D]-is spat out as a new Derived.  -}--eqCanDischargeFR :: CtFlavourRole -> CtFlavourRole -> Bool--- See Note [eqCanDischarge]-eqCanDischargeFR (f1,r1) (f2, r2) =  eqCanRewrite r1 r2-                                  && eqCanDischargeF f1 f2--eqCanDischargeF :: CtFlavour -> CtFlavour -> Bool-eqCanDischargeF Given   _                  = True-eqCanDischargeF (Wanted _)      (Wanted _) = True-eqCanDischargeF (Wanted WDeriv) Derived    = True-eqCanDischargeF Derived         Derived    = True-eqCanDischargeF _               _          = False---{--************************************************************************-*                                                                      *-            SubGoalDepth-*                                                                      *-************************************************************************--Note [SubGoalDepth]-~~~~~~~~~~~~~~~~~~~-The 'SubGoalDepth' takes care of stopping the constraint solver from looping.--The counter starts at zero and increases. It includes dictionary constraints,-equality simplification, and type family reduction. (Why combine these? Because-it's actually quite easy to mistake one for another, in sufficiently involved-scenarios, like ConstraintKinds.)--The flag -freduction-depth=n fixes the maximium level.--* The counter includes the depth of type class instance declarations.  Example:-     [W] d{7} : Eq [Int]-  That is d's dictionary-constraint depth is 7.  If we use the instance-     $dfEqList :: Eq a => Eq [a]-  to simplify it, we get-     d{7} = $dfEqList d'{8}-  where d'{8} : Eq Int, and d' has depth 8.--  For civilised (decidable) instance declarations, each increase of-  depth removes a type constructor from the type, so the depth never-  gets big; i.e. is bounded by the structural depth of the type.--* The counter also increments when resolving-equalities involving type functions. Example:-  Assume we have a wanted at depth 7:-    [W] d{7} : F () ~ a-  If there is a type function equation "F () = Int", this would be rewritten to-    [W] d{8} : Int ~ a-  and remembered as having depth 8.--  Again, without UndecidableInstances, this counter is bounded, but without it-  can resolve things ad infinitum. Hence there is a maximum level.--* Lastly, every time an equality is rewritten, the counter increases. Again,-  rewriting an equality constraint normally makes progress, but it's possible-  the "progress" is just the reduction of an infinitely-reducing type family.-  Hence we need to track the rewrites.--When compiling a program requires a greater depth, then GHC recommends turning-off this check entirely by setting -freduction-depth=0. This is because the-exact number that works is highly variable, and is likely to change even between-minor releases. Because this check is solely to prevent infinite compilation-times, it seems safe to disable it when a user has ascertained that their program-doesn't loop at the type level.---}---- | See Note [SubGoalDepth]-newtype SubGoalDepth = SubGoalDepth Int-  deriving (Eq, Ord, Outputable)--initialSubGoalDepth :: SubGoalDepth-initialSubGoalDepth = SubGoalDepth 0--bumpSubGoalDepth :: SubGoalDepth -> SubGoalDepth-bumpSubGoalDepth (SubGoalDepth n) = SubGoalDepth (n + 1)--maxSubGoalDepth :: SubGoalDepth -> SubGoalDepth -> SubGoalDepth-maxSubGoalDepth (SubGoalDepth n) (SubGoalDepth m) = SubGoalDepth (n `max` m)--subGoalDepthExceeded :: DynFlags -> SubGoalDepth -> Bool-subGoalDepthExceeded dflags (SubGoalDepth d)-  = mkIntWithInf d > reductionDepth dflags--{--************************************************************************-*                                                                      *-            CtLoc-*                                                                      *-************************************************************************--The 'CtLoc' gives information about where a constraint came from.-This is important for decent error message reporting because-dictionaries don't appear in the original source code.-type will evolve...---}--data CtLoc = CtLoc { ctl_origin :: CtOrigin-                   , ctl_env    :: TcLclEnv-                   , ctl_t_or_k :: Maybe TypeOrKind  -- OK if we're not sure-                   , ctl_depth  :: !SubGoalDepth }--  -- The TcLclEnv includes particularly-  --    source location:  tcl_loc   :: RealSrcSpan-  --    context:          tcl_ctxt  :: [ErrCtxt]-  --    binder stack:     tcl_bndrs :: TcBinderStack-  --    level:            tcl_tclvl :: TcLevel--mkKindLoc :: TcType -> TcType   -- original *types* being compared-          -> CtLoc -> CtLoc-mkKindLoc s1 s2 loc = setCtLocOrigin (toKindLoc loc)-                        (KindEqOrigin s1 s2 (ctLocOrigin loc)-                                      (ctLocTypeOrKind_maybe loc))---- | Take a CtLoc and moves it to the kind level-toKindLoc :: CtLoc -> CtLoc-toKindLoc loc = loc { ctl_t_or_k = Just KindLevel }--mkGivenLoc :: TcLevel -> SkolemInfo -> TcLclEnv -> CtLoc-mkGivenLoc tclvl skol_info env-  = CtLoc { ctl_origin = GivenOrigin skol_info-          , ctl_env    = setLclEnvTcLevel env tclvl-          , ctl_t_or_k = Nothing    -- this only matters for error msgs-          , ctl_depth  = initialSubGoalDepth }++{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeApplications #-}++{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}++-- | This module defines types and simple operations over constraints, as used+-- in the type-checker and constraint solver.+module GHC.Tc.Types.Constraint (+        -- QCInst+        QCInst(..), isPendingScInst,++        -- Canonical constraints+        Xi, Ct(..), Cts,+        emptyCts, andCts, andManyCts, pprCts,+        singleCt, listToCts, ctsElts, consCts, snocCts, extendCtsList,+        isEmptyCts,+        isPendingScDict, superClassesMightHelp, getPendingWantedScs,+        isWantedCt, isGivenCt,+        isUserTypeError, getUserTypeErrorMsg,+        ctEvidence, ctLoc, ctPred, ctFlavour, ctEqRel, ctOrigin,+        ctRewriters,+        ctEvId, wantedEvId_maybe, mkTcEqPredLikeEv,+        mkNonCanonical, mkNonCanonicalCt, mkGivens,+        mkIrredCt,+        ctEvPred, ctEvLoc, ctEvOrigin, ctEvEqRel,+        ctEvExpr, ctEvTerm, ctEvCoercion, ctEvEvId,+        ctEvRewriters,+        tyCoVarsOfCt, tyCoVarsOfCts,+        tyCoVarsOfCtList, tyCoVarsOfCtsList,++        CtIrredReason(..), isInsolubleReason,++        CheckTyEqResult, CheckTyEqProblem, cteProblem, cterClearOccursCheck,+        cteOK, cteImpredicative, cteTypeFamily,+        cteInsolubleOccurs, cteSolubleOccurs, cterSetOccursCheckSoluble,++        cterHasNoProblem, cterHasProblem, cterHasOnlyProblem,+        cterRemoveProblem, cterHasOccursCheck, cterFromKind,++        CanEqLHS(..), canEqLHS_maybe, canEqLHSKind, canEqLHSType,+        eqCanEqLHS,++        Hole(..), HoleSort(..), isOutOfScopeHole,+        DelayedError(..), NotConcreteError(..),+        NotConcreteReason(..),++        WantedConstraints(..), insolubleWC, emptyWC, isEmptyWC,+        isSolvedWC, andWC, unionsWC, mkSimpleWC, mkImplicWC,+        addInsols, dropMisleading, addSimples, addImplics, addHoles,+        addNotConcreteError, addDelayedErrors,+        tyCoVarsOfWC,+        tyCoVarsOfWCList, insolubleWantedCt, insolubleEqCt, insolubleCt,+        insolubleImplic, nonDefaultableTyVarsOfWC,++        Implication(..), implicationPrototype, checkTelescopeSkol,+        ImplicStatus(..), isInsolubleStatus, isSolvedStatus,+        UserGiven, getUserGivensFromImplics,+        HasGivenEqs(..), checkImplicationInvariants,+        SubGoalDepth, initialSubGoalDepth, maxSubGoalDepth,+        bumpSubGoalDepth, subGoalDepthExceeded,+        CtLoc(..), ctLocSpan, ctLocEnv, ctLocLevel, ctLocOrigin,+        ctLocTypeOrKind_maybe,+        ctLocDepth, bumpCtLocDepth, isGivenLoc,+        setCtLocOrigin, updateCtLocOrigin, setCtLocEnv, setCtLocSpan,+        pprCtLoc,++        -- CtEvidence+        CtEvidence(..), TcEvDest(..),+        mkKindLoc, toKindLoc, mkGivenLoc,+        isWanted, isGiven,+        ctEvRole, setCtEvPredType, setCtEvLoc, arisesFromGivens,+        tyCoVarsOfCtEvList, tyCoVarsOfCtEv, tyCoVarsOfCtEvsList,+        ctEvUnique, tcEvDestUnique,++        RewriterSet(..), emptyRewriterSet, isEmptyRewriterSet,+           -- exported concretely only for anyUnfilledCoercionHoles+        rewriterSetFromType, rewriterSetFromTypes, rewriterSetFromCo,+        addRewriterSet,++        wrapType,++        CtFlavour(..), ctEvFlavour,+        CtFlavourRole, ctEvFlavourRole, ctFlavourRole,+        eqCanRewrite, eqCanRewriteFR,++        -- Pretty printing+        pprEvVarTheta,+        pprEvVars, pprEvVarWithType,++  )+  where++import GHC.Prelude++import {-# SOURCE #-} GHC.Tc.Types ( TcLclEnv, setLclEnvTcLevel, getLclEnvTcLevel+                                   , setLclEnvLoc, getLclEnvLoc )++import GHC.Core.Predicate+import GHC.Core.Type+import GHC.Core.Coercion+import GHC.Core.Class+import GHC.Core.TyCon+import GHC.Types.Name+import GHC.Types.Var++import GHC.Tc.Utils.TcType+import GHC.Tc.Types.Evidence+import GHC.Tc.Types.Origin++import GHC.Core++import GHC.Core.TyCo.Ppr+import GHC.Utils.FV+import GHC.Types.Var.Set+import GHC.Driver.Session+import GHC.Types.Basic+import GHC.Types.Unique+import GHC.Types.Unique.Set++import GHC.Utils.Outputable+import GHC.Types.SrcLoc+import GHC.Data.Bag+import GHC.Utils.Misc+import GHC.Utils.Panic+import GHC.Utils.Constants (debugIsOn)++import Data.Coerce+import Data.Monoid ( Endo(..) )+import qualified Data.Semigroup as S+import Control.Monad ( msum, when )+import Data.Maybe ( mapMaybe )+import Data.List.NonEmpty ( NonEmpty )++-- these are for CheckTyEqResult+import Data.Word  ( Word8 )+import Data.List  ( intersperse )+++++{-+************************************************************************+*                                                                      *+*                       Canonical constraints                          *+*                                                                      *+*   These are the constraints the low-level simplifier works with      *+*                                                                      *+************************************************************************++Note [CEqCan occurs check]+~~~~~~~~~~~~~~~~~~~~~~~~~~+A CEqCan relates a CanEqLHS (a type variable or type family applications) on+its left to an arbitrary type on its right. It is used for rewriting.+Because it is used for rewriting, it would be disastrous if the RHS+were to mention the LHS: this would cause a loop in rewriting.++We thus perform an occurs-check. There is, of course, some subtlety:++* For type variables, the occurs-check looks deeply. This is because+  a CEqCan over a meta-variable is also used to inform unification,+  in GHC.Tc.Solver.Interact.solveByUnification. If the LHS appears+  anywhere, at all, in the RHS, unification will create an infinite+  structure, which is bad.++* For type family applications, the occurs-check is shallow; it looks+  only in places where we might rewrite. (Specifically, it does not+  look in kinds or coercions.) An occurrence of the LHS in, say, an+  RHS coercion is OK, as we do not rewrite in coercions. No loop to+  be found.++  You might also worry about the possibility that a type family+  application LHS doesn't exactly appear in the RHS, but something+  that reduces to the LHS does. Yet that can't happen: the RHS is+  already inert, with all type family redexes reduced. So a simple+  syntactic check is just fine.++The occurs check is performed in GHC.Tc.Utils.Unify.checkTypeEq+and forms condition T3 in Note [Extending the inert equalities]+in GHC.Tc.Solver.InertSet.++-}++-- | A 'Xi'-type is one that has been fully rewritten with respect+-- to the inert set; that is, it has been rewritten by the algorithm+-- in GHC.Tc.Solver.Rewrite. (Historical note: 'Xi', for years and years,+-- meant that a type was type-family-free. It does *not* mean this+-- any more.)+type Xi = TcType++type Cts = Bag Ct++data Ct+  -- Atomic canonical constraints+  = CDictCan {  -- e.g.  Num ty+      cc_ev     :: CtEvidence, -- See Note [Ct/evidence invariant]++      cc_class  :: Class,+      cc_tyargs :: [Xi],   -- cc_tyargs are rewritten w.r.t. inerts, so Xi++      cc_pend_sc :: Bool,+          -- See Note [The superclass story] in GHC.Tc.Solver.Canonical+          -- True <=> (a) cc_class has superclasses+          --          (b) we have not (yet) added those+          --              superclasses as Givens++      cc_fundeps :: Bool+          -- See Note [Fundeps with instances] in GHC.Tc.Solver.Interact+          -- True <=> the class has fundeps, and we have not yet+          --          compared this constraint with the global+          --          instances for fundep improvement+    }++  | CIrredCan {  -- These stand for yet-unusable predicates+      cc_ev     :: CtEvidence,   -- See Note [Ct/evidence invariant]+      cc_reason :: CtIrredReason++        -- For the might-be-soluble case, the ctev_pred of the evidence is+        -- of form   (tv xi1 xi2 ... xin)   with a tyvar at the head+        --      or   (lhs1 ~ ty2)  where the CEqCan    kind invariant (TyEq:K) fails+        -- See Note [CIrredCan constraints]++        -- The definitely-insoluble case is for things like+        --    Int ~ Bool      tycons don't match+        --    a ~ [a]         occurs check+    }++  | CEqCan {  -- CanEqLHS ~ rhs+       -- Invariants:+       --   * See Note [inert_eqs: the inert equalities] in GHC.Tc.Solver.InertSet+       --   * Many are checked in checkTypeEq in GHC.Tc.Utils.Unify+       --   * (TyEq:OC) lhs does not occur in rhs (occurs check)+       --               Note [CEqCan occurs check]+       --   * (TyEq:F) rhs has no foralls+       --       (this avoids substituting a forall for the tyvar in other types)+       --   * (TyEq:K) tcTypeKind lhs `tcEqKind` tcTypeKind rhs; Note [Ct kind invariant]+       --   * (TyEq:N) If the equality is representational, rhs has no top-level newtype+       --     See Note [No top-level newtypes on RHS of representational equalities]+       --     in GHC.Tc.Solver.Canonical. (Applies only when constructor of newtype is+       --     in scope.)+       --   * (TyEq:TV) If rhs (perhaps under a cast) is also CanEqLHS, then it is oriented+       --     to give best chance of+       --     unification happening; eg if rhs is touchable then lhs is too+       --     Note [TyVar/TyVar orientation] in GHC.Tc.Utils.Unify+      cc_ev     :: CtEvidence, -- See Note [Ct/evidence invariant]+      cc_lhs    :: CanEqLHS,+      cc_rhs    :: Xi,         -- See invariants above++      cc_eq_rel :: EqRel       -- INVARIANT: cc_eq_rel = ctEvEqRel cc_ev+    }++  | CNonCanonical {        -- See Note [NonCanonical Semantics] in GHC.Tc.Solver.Monad+      cc_ev  :: CtEvidence+    }++  | CQuantCan QCInst       -- A quantified constraint+      -- NB: I expect to make more of the cases in Ct+      --     look like this, with the payload in an+      --     auxiliary type++------------+-- | 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 TcTyVar+  | TyFamLHS TyCon  -- ^ of the family+             [Xi]   -- ^ 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)++------------+data QCInst  -- A much simplified version of ClsInst+             -- See Note [Quantified constraints] in GHC.Tc.Solver.Canonical+  = QCI { qci_ev   :: CtEvidence -- Always of type forall tvs. context => ty+                                 -- Always Given+        , qci_tvs  :: [TcTyVar]  -- The tvs+        , qci_pred :: TcPredType -- The ty+        , qci_pend_sc :: Bool    -- Same as cc_pend_sc flag in CDictCan+                                 -- Invariant: True => qci_pred is a ClassPred+    }++instance Outputable QCInst where+  ppr (QCI { qci_ev = ev }) = ppr ev++------------------------------------------------------------------------------+--+-- Holes and other delayed errors+--+------------------------------------------------------------------------------++-- | A delayed error, to be reported after constraint solving, in order to benefit+-- from deferred unifications.+data DelayedError+  = DE_Hole Hole+    -- ^ A hole (in a type or in a term).+    --+    -- See Note [Holes].+  | DE_NotConcrete NotConcreteError+    -- ^ A type could not be ensured to be concrete.+    --+    -- See Note [The Concrete mechanism] in GHC.Tc.Utils.Concrete.++instance Outputable DelayedError where+  ppr (DE_Hole hole) = ppr hole+  ppr (DE_NotConcrete err) = ppr err++-- | A hole stores the information needed to report diagnostics+-- about holes in terms (unbound identifiers or underscores) or+-- in types (also called wildcards, as used in partial type+-- signatures). See Note [Holes].+data Hole+  = Hole { hole_sort :: HoleSort -- ^ What flavour of hole is this?+         , hole_occ  :: OccName  -- ^ The name of this hole+         , hole_ty   :: TcType   -- ^ Type to be printed to the user+                                 -- For expression holes: type of expr+                                 -- For type holes: the missing type+         , hole_loc  :: CtLoc    -- ^ Where hole was written+         }+           -- For the hole_loc, we usually only want the TcLclEnv stored within.+           -- Except when we rewrite, where we need a whole location. And this+           -- might get reported to the user if reducing type families in a+           -- hole type loops.+++-- | Used to indicate which sort of hole we have.+data HoleSort = ExprHole HoleExprRef+                 -- ^ Either an out-of-scope variable or a "true" hole in an+                 -- expression (TypedHoles).+                 -- The HoleExprRef says where to write the+                 -- the erroring expression for -fdefer-type-errors.+              | TypeHole+                 -- ^ A hole in a type (PartialTypeSignatures)+              | ConstraintHole+                 -- ^ A hole in a constraint, like @f :: (_, Eq a) => ...+                 -- Differentiated from TypeHole because a ConstraintHole+                 -- is simplified differently. See+                 -- Note [Do not simplify ConstraintHoles] in GHC.Tc.Solver.++instance Outputable Hole where+  ppr (Hole { hole_sort = ExprHole ref+            , hole_occ  = occ+            , hole_ty   = ty })+    = parens $ (braces $ ppr occ <> colon <> ppr ref) <+> dcolon <+> ppr ty+  ppr (Hole { hole_sort = _other+            , hole_occ  = occ+            , hole_ty   = ty })+    = braces $ ppr occ <> colon <> ppr ty++instance Outputable HoleSort where+  ppr (ExprHole ref) = text "ExprHole:" <+> ppr ref+  ppr TypeHole       = text "TypeHole"+  ppr ConstraintHole = text "ConstraintHole"++-- | Why did we require that a certain type be concrete?+data NotConcreteError+  -- | Concreteness was required by a representation-polymorphism+  -- check.+  --+  -- See Note [The Concrete mechanism] in GHC.Tc.Utils.Concrete.+  = NCE_FRR+    { nce_loc        :: CtLoc+      -- ^ Where did this check take place?+    , nce_frr_origin :: FixedRuntimeRepOrigin+      -- ^ Which representation-polymorphism check did we perform?+    , nce_reasons    :: NonEmpty NotConcreteReason+      -- ^ Why did the check fail?+    }++-- | Why did we decide that a type was not concrete?+data NotConcreteReason+  -- | The type contains a 'TyConApp' of a non-concrete 'TyCon'.+  --+  -- See Note [Concrete types] in GHC.Tc.Utils.Concrete.+  = NonConcreteTyCon TyCon [TcType]++  -- | The type contains a type variable that could not be made+  -- concrete (e.g. a skolem type variable).+  | NonConcretisableTyVar TyVar++  -- | The type contains a cast.+  | ContainsCast TcType TcCoercionN++  -- | The type contains a forall.+  | ContainsForall TyCoVarBinder TcType++  -- | The type contains a 'CoercionTy'.+  | ContainsCoercionTy TcCoercion++instance Outputable NotConcreteError where+  ppr (NCE_FRR { nce_frr_origin = frr_orig })+    = text "NCE_FRR" <+> parens (ppr (frr_type frr_orig))++------------+-- | Used to indicate extra information about why a CIrredCan is irreducible+data CtIrredReason+  = IrredShapeReason+      -- ^ this constraint has a non-canonical shape (e.g. @c Int@, for a variable @c@)++  | NonCanonicalReason CheckTyEqResult+   -- ^ an equality where some invariant other than (TyEq:H) of 'CEqCan' is not satisfied;+   -- the 'CheckTyEqResult' states exactly why++  | ReprEqReason+    -- ^ an equality that cannot be decomposed because it is representational.+    -- Example: @a b ~R# Int@.+    -- These might still be solved later.+    -- INVARIANT: The constraint is a representational equality constraint++  | ShapeMismatchReason+    -- ^ a nominal equality that relates two wholly different types,+    -- like @Int ~# Bool@ or @a b ~# 3@.+    -- INVARIANT: The constraint is a nominal equality constraint++  | AbstractTyConReason+    -- ^ an equality like @T a b c ~ Q d e@ where either @T@ or @Q@+    -- is an abstract type constructor. See Note [Skolem abstract data]+    -- in GHC.Core.TyCon.+    -- INVARIANT: The constraint is an equality constraint between two TyConApps++instance Outputable CtIrredReason where+  ppr IrredShapeReason          = text "(irred)"+  ppr (NonCanonicalReason cter) = ppr cter+  ppr ReprEqReason              = text "(repr)"+  ppr ShapeMismatchReason       = text "(shape)"+  ppr AbstractTyConReason       = text "(abstc)"++-- | Are we sure that more solving will never solve this constraint?+isInsolubleReason :: CtIrredReason -> Bool+isInsolubleReason IrredShapeReason          = False+isInsolubleReason (NonCanonicalReason cter) = cterIsInsoluble cter+isInsolubleReason ReprEqReason              = False+isInsolubleReason ShapeMismatchReason       = True+isInsolubleReason AbstractTyConReason       = True++------------------------------------------------------------------------------+--+-- CheckTyEqResult, defined here because it is stored in a CtIrredReason+--+------------------------------------------------------------------------------++-- | A set of problems in checking the validity of a type equality.+-- See 'checkTypeEq'.+newtype CheckTyEqResult = CTER Word8++-- | No problems in checking the validity of a type equality.+cteOK :: CheckTyEqResult+cteOK = CTER zeroBits++-- | Check whether a 'CheckTyEqResult' is marked successful.+cterHasNoProblem :: CheckTyEqResult -> Bool+cterHasNoProblem (CTER 0) = True+cterHasNoProblem _        = False++-- | An individual problem that might be logged in a 'CheckTyEqResult'+newtype CheckTyEqProblem = CTEP Word8++cteImpredicative, cteTypeFamily, cteInsolubleOccurs, cteSolubleOccurs :: CheckTyEqProblem+cteImpredicative   = CTEP (bit 0)   -- forall or (=>) encountered+cteTypeFamily      = CTEP (bit 1)   -- type family encountered+cteInsolubleOccurs = CTEP (bit 2)   -- occurs-check+cteSolubleOccurs   = CTEP (bit 3)   -- occurs-check under a type function or in a coercion+                                    -- must be one bit to the left of cteInsolubleOccurs+-- See also Note [Insoluble occurs check] in GHC.Tc.Errors++cteProblem :: CheckTyEqProblem -> CheckTyEqResult+cteProblem (CTEP mask) = CTER mask++occurs_mask :: Word8+occurs_mask = insoluble_mask .|. soluble_mask+  where+    CTEP insoluble_mask = cteInsolubleOccurs+    CTEP soluble_mask   = cteSolubleOccurs++-- | Check whether a 'CheckTyEqResult' has a 'CheckTyEqProblem'+cterHasProblem :: CheckTyEqResult -> CheckTyEqProblem -> Bool+CTER bits `cterHasProblem` CTEP mask = (bits .&. mask) /= 0++-- | Check whether a 'CheckTyEqResult' has one 'CheckTyEqProblem' and no other+cterHasOnlyProblem :: CheckTyEqResult -> CheckTyEqProblem -> Bool+CTER bits `cterHasOnlyProblem` CTEP mask = bits == mask++cterRemoveProblem :: CheckTyEqResult -> CheckTyEqProblem -> CheckTyEqResult+cterRemoveProblem (CTER bits) (CTEP mask) = CTER (bits .&. complement mask)++cterHasOccursCheck :: CheckTyEqResult -> Bool+cterHasOccursCheck (CTER bits) = (bits .&. occurs_mask) /= 0++cterClearOccursCheck :: CheckTyEqResult -> CheckTyEqResult+cterClearOccursCheck (CTER bits) = CTER (bits .&. complement occurs_mask)++-- | Mark a 'CheckTyEqResult' as not having an insoluble occurs-check: any occurs+-- check under a type family or in a representation equality is soluble.+cterSetOccursCheckSoluble :: CheckTyEqResult -> CheckTyEqResult+cterSetOccursCheckSoluble (CTER bits)+  = CTER $ ((bits .&. insoluble_mask) `shift` 1) .|. (bits .&. complement insoluble_mask)+  where+    CTEP insoluble_mask = cteInsolubleOccurs++-- | Retain only information about occurs-check failures, because only that+-- matters after recurring into a kind.+cterFromKind :: CheckTyEqResult -> CheckTyEqResult+cterFromKind (CTER bits)+  = CTER (bits .&. occurs_mask)++cterIsInsoluble :: CheckTyEqResult -> Bool+cterIsInsoluble (CTER bits) = (bits .&. mask) /= 0+  where+    mask = impredicative_mask .|. insoluble_occurs_mask++    CTEP impredicative_mask    = cteImpredicative+    CTEP insoluble_occurs_mask = cteInsolubleOccurs++instance Semigroup CheckTyEqResult where+  CTER bits1 <> CTER bits2 = CTER (bits1 .|. bits2)+instance Monoid CheckTyEqResult where+  mempty = cteOK++instance Outputable CheckTyEqResult where+  ppr cter | cterHasNoProblem cter = text "cteOK"+           | otherwise+           = parens $ fcat $ intersperse vbar $ set_bits+    where+      all_bits = [ (cteImpredicative,   "cteImpredicative")+                 , (cteTypeFamily,      "cteTypeFamily")+                 , (cteInsolubleOccurs, "cteInsolubleOccurs")+                 , (cteSolubleOccurs,   "cteSolubleOccurs") ]+      set_bits = [ text str+                 | (bitmask, str) <- all_bits+                 , cter `cterHasProblem` bitmask ]++{- Note [CIrredCan constraints]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+CIrredCan constraints are used for constraints that are "stuck"+   - we can't solve them (yet)+   - we can't use them to solve other constraints+   - but they may become soluble if we substitute for some+     of the type variables in the constraint++Example 1:  (c Int), where c :: * -> Constraint.  We can't do anything+            with this yet, but if later c := Num, *then* we can solve it++Example 2:  a ~ b, where a :: *, b :: k, where k is a kind variable+            We don't want to use this to substitute 'b' for 'a', in case+            'k' is subsequently unified with (say) *->*, because then+            we'd have ill-kinded types floating about.  Rather we want+            to defer using the equality altogether until 'k' get resolved.++Note [Ct/evidence invariant]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If  ct :: Ct, then extra fields of 'ct' cache precisely the ctev_pred field+of (cc_ev ct), and is fully rewritten wrt the substitution.   Eg for CDictCan,+   ctev_pred (cc_ev ct) = (cc_class ct) (cc_tyargs ct)+This holds by construction; look at the unique place where CDictCan is+built (in GHC.Tc.Solver.Canonical).++Note [Ct kind invariant]+~~~~~~~~~~~~~~~~~~~~~~~~+CEqCan requires that the kind of the lhs matches the kind+of the rhs. This is necessary because these constraints are used for substitutions+during solving. If the kinds differed, then the substitution would take a well-kinded+type to an ill-kinded one.++Note [Holes]+~~~~~~~~~~~~+This Note explains how GHC tracks *holes*.++A hole represents one of two conditions:+ - A missing bit of an expression. Example: foo x = x + _+ - A missing bit of a type. Example: bar :: Int -> _++What these have in common is that both cause GHC to emit a diagnostic to the+user describing the bit that is left out.++When a hole is encountered, a new entry of type Hole is added to the ambient+WantedConstraints. The type (hole_ty) of the hole is then simplified during+solving (with respect to any Givens in surrounding implications). It is+reported with all the other errors in GHC.Tc.Errors.++For expression holes, the user has the option of deferring errors until runtime+with -fdefer-type-errors. In this case, the hole actually has evidence: this+evidence is an erroring expression that prints an error and crashes at runtime.+The ExprHole variant of holes stores an IORef EvTerm that will contain this evidence;+during constraint generation, this IORef was stored in the HsUnboundVar extension+field by the type checker. The desugarer simply dereferences to get the CoreExpr.++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.++Type-level holes have no evidence at all.+-}++mkNonCanonical :: CtEvidence -> Ct+mkNonCanonical ev = CNonCanonical { cc_ev = ev }++mkNonCanonicalCt :: Ct -> Ct+mkNonCanonicalCt ct = CNonCanonical { cc_ev = cc_ev ct }++mkIrredCt :: CtIrredReason -> CtEvidence -> Ct+mkIrredCt reason ev = CIrredCan { cc_ev = ev, cc_reason = reason }++mkGivens :: CtLoc -> [EvId] -> [Ct]+mkGivens loc ev_ids+  = map mk ev_ids+  where+    mk ev_id = mkNonCanonical (CtGiven { ctev_evar = ev_id+                                       , ctev_pred = evVarPred ev_id+                                       , ctev_loc = loc })++ctEvidence :: Ct -> CtEvidence+ctEvidence (CQuantCan (QCI { qci_ev = ev })) = ev+ctEvidence ct = cc_ev ct++ctLoc :: Ct -> CtLoc+ctLoc = ctEvLoc . ctEvidence++ctOrigin :: Ct -> CtOrigin+ctOrigin = ctLocOrigin . ctLoc++ctPred :: Ct -> PredType+-- See Note [Ct/evidence invariant]+ctPred ct = ctEvPred (ctEvidence ct)++ctRewriters :: Ct -> RewriterSet+ctRewriters = ctEvRewriters . ctEvidence++ctEvId :: HasDebugCallStack => Ct -> EvVar+-- The evidence Id for this Ct+ctEvId ct = ctEvEvId (ctEvidence ct)++-- | Returns the evidence 'Id' for the argument 'Ct'+-- when this 'Ct' is a 'Wanted'.+--+-- Returns 'Nothing' otherwise.+wantedEvId_maybe :: Ct -> Maybe EvVar+wantedEvId_maybe ct+  = case ctEvidence ct of+    ctev@(CtWanted {})+      | otherwise+      -> Just $ ctEvEvId ctev+    CtGiven {}+      -> Nothing++-- | Makes a new equality predicate with the same role as the given+-- evidence.+mkTcEqPredLikeEv :: CtEvidence -> TcType -> TcType -> TcType+mkTcEqPredLikeEv ev+  = case predTypeEqRel pred of+      NomEq  -> mkPrimEqPred+      ReprEq -> mkReprPrimEqPred+  where+    pred = ctEvPred ev++-- | Get the flavour of the given 'Ct'+ctFlavour :: Ct -> CtFlavour+ctFlavour = ctEvFlavour . ctEvidence++-- | Get the equality relation for the given 'Ct'+ctEqRel :: Ct -> EqRel+ctEqRel = ctEvEqRel . ctEvidence++instance Outputable Ct where+  ppr ct = ppr (ctEvidence ct) <+> parens pp_sort+    where+      pp_sort = case ct of+         CEqCan {}        -> text "CEqCan"+         CNonCanonical {} -> text "CNonCanonical"+         CDictCan { cc_pend_sc = psc, cc_fundeps = fds }+            | psc, fds     -> text "CDictCan(psc,fds)"+            | psc, not fds -> text "CDictCan(psc)"+            | not psc, fds -> text "CDictCan(fds)"+            | otherwise    -> text "CDictCan"+         CIrredCan { cc_reason = reason } -> text "CIrredCan" <> ppr reason+         CQuantCan (QCI { qci_pend_sc = pend_sc })+            | pend_sc   -> text "CQuantCan(psc)"+            | otherwise -> text "CQuantCan"++-----------------------------------+-- | 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 :: Xi -> Maybe CanEqLHS+canEqLHS_maybe xi+  | Just tv <- tcGetTyVar_maybe xi+  = Just $ TyVarLHS tv++  | 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 -> TcType+canEqLHSType (TyVarLHS tv) = mkTyVarTy tv+canEqLHSType (TyFamLHS fam_tc fam_args) = mkTyConApp fam_tc fam_args++-- | Retrieve the kind of a 'CanEqLHS'+canEqLHSKind :: CanEqLHS -> TcKind+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++{-+************************************************************************+*                                                                      *+        Simple functions over evidence variables+*                                                                      *+************************************************************************+-}++---------------- Getting free tyvars -------------------------++-- | Returns free variables of constraints as a non-deterministic set+tyCoVarsOfCt :: Ct -> TcTyCoVarSet+tyCoVarsOfCt = fvVarSet . tyCoFVsOfCt++-- | Returns free variables of constraints as a non-deterministic set+tyCoVarsOfCtEv :: CtEvidence -> TcTyCoVarSet+tyCoVarsOfCtEv = fvVarSet . tyCoFVsOfCtEv++-- | Returns free variables of constraints as a deterministically ordered+-- list. See Note [Deterministic FV] in GHC.Utils.FV.+tyCoVarsOfCtList :: Ct -> [TcTyCoVar]+tyCoVarsOfCtList = fvVarList . tyCoFVsOfCt++-- | Returns free variables of constraints as a deterministically ordered+-- list. See Note [Deterministic FV] in GHC.Utils.FV.+tyCoVarsOfCtEvList :: CtEvidence -> [TcTyCoVar]+tyCoVarsOfCtEvList = fvVarList . tyCoFVsOfType . ctEvPred++-- | Returns free variables of constraints as a composable FV computation.+-- See Note [Deterministic FV] in "GHC.Utils.FV".+tyCoFVsOfCt :: Ct -> FV+tyCoFVsOfCt ct = tyCoFVsOfType (ctPred ct)+  -- This must consult only the ctPred, so that it gets *tidied* fvs if the+  -- constraint has been tidied. Tidying a constraint does not tidy the+  -- fields of the Ct, only the predicate in the CtEvidence.++-- | Returns free variables of constraints as a composable FV computation.+-- See Note [Deterministic FV] in GHC.Utils.FV.+tyCoFVsOfCtEv :: CtEvidence -> FV+tyCoFVsOfCtEv ct = tyCoFVsOfType (ctEvPred ct)++-- | Returns free variables of a bag of constraints as a non-deterministic+-- set. See Note [Deterministic FV] in "GHC.Utils.FV".+tyCoVarsOfCts :: Cts -> TcTyCoVarSet+tyCoVarsOfCts = fvVarSet . tyCoFVsOfCts++-- | Returns free variables of a bag of constraints as a deterministically+-- ordered list. See Note [Deterministic FV] in "GHC.Utils.FV".+tyCoVarsOfCtsList :: Cts -> [TcTyCoVar]+tyCoVarsOfCtsList = fvVarList . tyCoFVsOfCts++-- | Returns free variables of a bag of constraints as a deterministically+-- ordered list. See Note [Deterministic FV] in GHC.Utils.FV.+tyCoVarsOfCtEvsList :: [CtEvidence] -> [TcTyCoVar]+tyCoVarsOfCtEvsList = fvVarList . tyCoFVsOfCtEvs++-- | Returns free variables of a bag of constraints as a composable FV+-- computation. See Note [Deterministic FV] in "GHC.Utils.FV".+tyCoFVsOfCts :: Cts -> FV+tyCoFVsOfCts = foldr (unionFV . tyCoFVsOfCt) emptyFV++-- | Returns free variables of a bag of constraints as a composable FV+-- computation. See Note [Deterministic FV] in GHC.Utils.FV.+tyCoFVsOfCtEvs :: [CtEvidence] -> FV+tyCoFVsOfCtEvs = foldr (unionFV . tyCoFVsOfCtEv) emptyFV++-- | Returns free variables of WantedConstraints as a non-deterministic+-- set. See Note [Deterministic FV] in "GHC.Utils.FV".+tyCoVarsOfWC :: WantedConstraints -> TyCoVarSet+-- Only called on *zonked* things+tyCoVarsOfWC = fvVarSet . tyCoFVsOfWC++-- | Returns free variables of WantedConstraints as a deterministically+-- ordered list. See Note [Deterministic FV] in "GHC.Utils.FV".+tyCoVarsOfWCList :: WantedConstraints -> [TyCoVar]+-- Only called on *zonked* things+tyCoVarsOfWCList = fvVarList . tyCoFVsOfWC++-- | Returns free variables of WantedConstraints as a composable FV+-- computation. See Note [Deterministic FV] in "GHC.Utils.FV".+tyCoFVsOfWC :: WantedConstraints -> FV+-- Only called on *zonked* things+tyCoFVsOfWC (WC { wc_simple = simple, wc_impl = implic, wc_errors = errors })+  = tyCoFVsOfCts simple `unionFV`+    tyCoFVsOfBag tyCoFVsOfImplic implic `unionFV`+    tyCoFVsOfBag tyCoFVsOfDelayedError errors++-- | Returns free variables of Implication as a composable FV computation.+-- See Note [Deterministic FV] in "GHC.Utils.FV".+tyCoFVsOfImplic :: Implication -> FV+-- Only called on *zonked* things+tyCoFVsOfImplic (Implic { ic_skols = skols+                        , ic_given = givens+                        , ic_wanted = wanted })+  | isEmptyWC wanted+  = emptyFV+  | otherwise+  = tyCoFVsVarBndrs skols  $+    tyCoFVsVarBndrs givens $+    tyCoFVsOfWC wanted++tyCoFVsOfDelayedError :: DelayedError -> FV+tyCoFVsOfDelayedError (DE_Hole hole) = tyCoFVsOfHole hole+tyCoFVsOfDelayedError (DE_NotConcrete {}) = emptyFV++tyCoFVsOfHole :: Hole -> FV+tyCoFVsOfHole (Hole { hole_ty = ty }) = tyCoFVsOfType ty++tyCoFVsOfBag :: (a -> FV) -> Bag a -> FV+tyCoFVsOfBag tvs_of = foldr (unionFV . tvs_of) emptyFV++isGivenLoc :: CtLoc -> Bool+isGivenLoc loc = isGivenOrigin (ctLocOrigin loc)++{-+************************************************************************+*                                                                      *+                    CtEvidence+         The "flavor" of a canonical constraint+*                                                                      *+************************************************************************+-}++isWantedCt :: Ct -> Bool+isWantedCt = isWanted . ctEvidence++isGivenCt :: Ct -> Bool+isGivenCt = isGiven . ctEvidence++{- Note [Custom type errors in constraints]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++When GHC reports a type-error about an unsolved-constraint, we check+to see if the constraint contains any custom-type errors, and if so+we report them.  Here are some examples of constraints containing type+errors:++TypeError msg           -- The actual constraint is a type error++TypError msg ~ Int      -- Some type was supposed to be Int, but ended up+                        -- being a type error instead++Eq (TypeError msg)      -- A class constraint is stuck due to a type error++F (TypeError msg) ~ a   -- A type function failed to evaluate due to a type err++It is also possible to have constraints where the type error is nested deeper,+for example see #11990, and also:++Eq (F (TypeError msg))  -- Here the type error is nested under a type-function+                        -- call, which failed to evaluate because of it,+                        -- and so the `Eq` constraint was unsolved.+                        -- This may happen when one function calls another+                        -- and the called function produced a custom type error.+-}++-- | A constraint is considered to be a custom type error, if it contains+-- custom type errors anywhere in it.+-- See Note [Custom type errors in constraints]+getUserTypeErrorMsg :: PredType -> Maybe Type+getUserTypeErrorMsg pred = msum $ userTypeError_maybe pred+                                  : map getUserTypeErrorMsg (subTys pred)+  where+   -- Richard thinks this function is very broken. What is subTys+   -- supposed to be doing? Why are exactly-saturated tyconapps special?+   -- What stops this from accidentally ripping apart a call to TypeError?+    subTys t = case splitAppTys t of+                 (t,[]) ->+                   case splitTyConApp_maybe t of+                              Nothing     -> []+                              Just (_,ts) -> ts+                 (t,ts) -> t : ts++isUserTypeError :: PredType -> Bool+isUserTypeError pred = case getUserTypeErrorMsg pred of+                             Just _ -> True+                             _      -> False++isPendingScDict :: Ct -> Maybe Ct+-- Says whether this is a CDictCan with cc_pend_sc is True,+-- AND if so flips the flag+isPendingScDict ct@(CDictCan { cc_pend_sc = True })+                  = Just (ct { cc_pend_sc = False })+isPendingScDict _ = Nothing++isPendingScInst :: QCInst -> Maybe QCInst+-- Same as isPendingScDict, but for QCInsts+isPendingScInst qci@(QCI { qci_pend_sc = True })+                  = Just (qci { qci_pend_sc = False })+isPendingScInst _ = Nothing++superClassesMightHelp :: WantedConstraints -> Bool+-- ^ True if taking superclasses of givens, or of wanteds (to perhaps+-- expose more equalities or functional dependencies) might help to+-- solve this constraint.  See Note [When superclasses help]+superClassesMightHelp (WC { wc_simple = simples, wc_impl = implics })+  = anyBag might_help_ct simples || anyBag might_help_implic implics+  where+    might_help_implic ic+       | IC_Unsolved <- ic_status ic = superClassesMightHelp (ic_wanted ic)+       | otherwise                   = False++    might_help_ct ct = not (is_ip ct)++    is_ip (CDictCan { cc_class = cls }) = isIPClass cls+    is_ip _                             = False++getPendingWantedScs :: Cts -> ([Ct], Cts)+getPendingWantedScs simples+  = mapAccumBagL get [] simples+  where+    get acc ct | Just ct' <- isPendingScDict ct+               = (ct':acc, ct')+               | otherwise+               = (acc,     ct)++{- Note [When superclasses help]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+First read Note [The superclass story] in GHC.Tc.Solver.Canonical.++We expand superclasses and iterate only if there is at unsolved wanted+for which expansion of superclasses (e.g. from given constraints)+might actually help. The function superClassesMightHelp tells if+doing this superclass expansion might help solve this constraint.+Note that++  * We look inside implications; maybe it'll help to expand the Givens+    at level 2 to help solve an unsolved Wanted buried inside an+    implication.  E.g.+        forall a. Ord a => forall b. [W] Eq a++  * We say "no" for implicit parameters.+    we have [W] ?x::ty, expanding superclasses won't help:+      - Superclasses can't be implicit parameters+      - If we have a [G] ?x:ty2, then we'll have another unsolved+        [W] ty ~ ty2 (from the functional dependency)+        which will trigger superclass expansion.++    It's a bit of a special case, but it's easy to do.  The runtime cost+    is low because the unsolved set is usually empty anyway (errors+    aside), and the first non-implicit-parameter will terminate the search.++    The special case is worth it (#11480, comment:2) because it+    applies to CallStack constraints, which aren't type errors. If we have+       f :: (C a) => blah+       f x = ...undefined...+    we'll get a CallStack constraint.  If that's the only unsolved+    constraint it'll eventually be solved by defaulting.  So we don't+    want to emit warnings about hitting the simplifier's iteration+    limit.  A CallStack constraint really isn't an unsolved+    constraint; it can always be solved by defaulting.+-}++singleCt :: Ct -> Cts+singleCt = unitBag++andCts :: Cts -> Cts -> Cts+andCts = unionBags++listToCts :: [Ct] -> Cts+listToCts = listToBag++ctsElts :: Cts -> [Ct]+ctsElts = bagToList++consCts :: Ct -> Cts -> Cts+consCts = consBag++snocCts :: Cts -> Ct -> Cts+snocCts = snocBag++extendCtsList :: Cts -> [Ct] -> Cts+extendCtsList cts xs | null xs   = cts+                     | otherwise = cts `unionBags` listToBag xs++andManyCts :: [Cts] -> Cts+andManyCts = unionManyBags++emptyCts :: Cts+emptyCts = emptyBag++isEmptyCts :: Cts -> Bool+isEmptyCts = isEmptyBag++pprCts :: Cts -> SDoc+pprCts cts = vcat (map ppr (bagToList cts))++{-+************************************************************************+*                                                                      *+                Wanted constraints+*                                                                      *+************************************************************************+-}++data WantedConstraints+  = WC { wc_simple :: Cts              -- Unsolved constraints, all wanted+       , wc_impl   :: Bag Implication+       , wc_errors :: Bag DelayedError+    }++emptyWC :: WantedConstraints+emptyWC = WC { wc_simple = emptyBag+             , wc_impl   = emptyBag+             , wc_errors = emptyBag }++mkSimpleWC :: [CtEvidence] -> WantedConstraints+mkSimpleWC cts+  = emptyWC { wc_simple = listToBag (map mkNonCanonical cts) }++mkImplicWC :: Bag Implication -> WantedConstraints+mkImplicWC implic+  = emptyWC { wc_impl = implic }++isEmptyWC :: WantedConstraints -> Bool+isEmptyWC (WC { wc_simple = f, wc_impl = i, wc_errors = errors })+  = isEmptyBag f && isEmptyBag i && isEmptyBag errors++-- | Checks whether a the given wanted constraints are solved, i.e.+-- that there are no simple constraints left and all the implications+-- are solved.+isSolvedWC :: WantedConstraints -> Bool+isSolvedWC WC {wc_simple = wc_simple, wc_impl = wc_impl, wc_errors = errors} =+  isEmptyBag wc_simple && allBag (isSolvedStatus . ic_status) wc_impl && isEmptyBag errors++andWC :: WantedConstraints -> WantedConstraints -> WantedConstraints+andWC (WC { wc_simple = f1, wc_impl = i1, wc_errors = e1 })+      (WC { wc_simple = f2, wc_impl = i2, wc_errors = e2 })+  = WC { wc_simple = f1 `unionBags` f2+       , wc_impl   = i1 `unionBags` i2+       , wc_errors = e1 `unionBags` e2 }++unionsWC :: [WantedConstraints] -> WantedConstraints+unionsWC = foldr andWC emptyWC++addSimples :: WantedConstraints -> Bag Ct -> WantedConstraints+addSimples wc cts+  = wc { wc_simple = wc_simple wc `unionBags` cts }+    -- Consider: Put the new constraints at the front, so they get solved first++addImplics :: WantedConstraints -> Bag Implication -> WantedConstraints+addImplics wc implic = wc { wc_impl = wc_impl wc `unionBags` implic }++addInsols :: WantedConstraints -> Bag Ct -> WantedConstraints+addInsols wc cts+  = wc { wc_simple = wc_simple wc `unionBags` cts }++addHoles :: WantedConstraints -> Bag Hole -> WantedConstraints+addHoles wc holes+  = wc { wc_errors = mapBag DE_Hole holes `unionBags` wc_errors wc }++addNotConcreteError :: WantedConstraints -> NotConcreteError -> WantedConstraints+addNotConcreteError wc err+  = wc { wc_errors = unitBag (DE_NotConcrete err) `unionBags` wc_errors wc }++addDelayedErrors :: WantedConstraints -> Bag DelayedError -> WantedConstraints+addDelayedErrors wc errs+  = wc { wc_errors = errs `unionBags` wc_errors wc }++dropMisleading :: WantedConstraints -> WantedConstraints+-- Drop misleading constraints; really just class constraints+-- See Note [Constraints and errors] in GHC.Tc.Utils.Monad+--   for why this function is so strange, treating the 'simples'+--   and the implications differently.  Sigh.+dropMisleading (WC { wc_simple = simples, wc_impl = implics, wc_errors = errors })+  = WC { wc_simple = filterBag insolubleWantedCt simples+       , wc_impl   = mapBag drop_implic implics+       , wc_errors = filterBag keep_delayed_error errors }+  where+    drop_implic implic+      = implic { ic_wanted = drop_wanted (ic_wanted implic) }+    drop_wanted (WC { wc_simple = simples, wc_impl = implics, wc_errors = errors })+      = WC { wc_simple = filterBag keep_ct simples+           , wc_impl   = mapBag drop_implic implics+           , wc_errors  = filterBag keep_delayed_error errors }++    keep_ct ct = case classifyPredType (ctPred ct) of+                    ClassPred {} -> False+                    _ -> True++    keep_delayed_error (DE_Hole hole) = isOutOfScopeHole hole+    keep_delayed_error (DE_NotConcrete {}) = True++isSolvedStatus :: ImplicStatus -> Bool+isSolvedStatus (IC_Solved {}) = True+isSolvedStatus _              = False++isInsolubleStatus :: ImplicStatus -> Bool+isInsolubleStatus IC_Insoluble    = True+isInsolubleStatus IC_BadTelescope = True+isInsolubleStatus _               = False++insolubleImplic :: Implication -> Bool+insolubleImplic ic = isInsolubleStatus (ic_status ic)++-- | Gather all the type variables from 'WantedConstraints'+-- that it would be unhelpful to default. For the moment,+-- these are only 'ConcreteTv' metavariables participating+-- in a nominal equality whose other side is not concrete;+-- it's usually better to report those as errors instead of+-- defaulting.+nonDefaultableTyVarsOfWC :: WantedConstraints -> TyCoVarSet+-- Currently used in simplifyTop and in tcRule.+-- TODO: should we also use this in decideQuantifiedTyVars, kindGeneralize{All,Some}?+nonDefaultableTyVarsOfWC (WC { wc_simple = simples, wc_impl = implics, wc_errors = errs })+  =             concatMapBag non_defaultable_tvs_of_ct simples+  `unionVarSet` concatMapBag (nonDefaultableTyVarsOfWC . ic_wanted) implics+  `unionVarSet` concatMapBag non_defaultable_tvs_of_err errs+    where++      concatMapBag :: (a -> TyVarSet) -> Bag a -> TyCoVarSet+      concatMapBag f = foldr (\ r acc -> f r `unionVarSet` acc) emptyVarSet++      -- Don't default ConcreteTv metavariables involved+      -- in an equality with something non-concrete: it's usually+      -- better to report the unsolved Wanted.+      --+      -- Example: alpha[conc] ~# rr[sk].+      non_defaultable_tvs_of_ct :: Ct -> TyCoVarSet+      non_defaultable_tvs_of_ct ct =+        -- NB: using classifyPredType instead of inspecting the Ct+        -- so that we deal uniformly with CNonCanonical (which come up in tcRule),+        -- CEqCan (unsolved but potentially soluble, e.g. @alpha[conc] ~# RR@)+        -- and CIrredCan.+        case classifyPredType $ ctPred ct of+          EqPred NomEq lhs rhs+            | Just tv <- getTyVar_maybe lhs+            , isConcreteTyVar tv+            , not (isConcrete rhs)+            -> unitVarSet tv+            | Just tv <- getTyVar_maybe rhs+            , isConcreteTyVar tv+            , not (isConcrete lhs)+            -> unitVarSet tv+          _ -> emptyVarSet++      -- Make sure to apply the same logic as above to delayed errors.+      non_defaultable_tvs_of_err (DE_NotConcrete err)+        = case err of+            NCE_FRR { nce_frr_origin = frr } -> tyCoVarsOfType (frr_type frr)+      non_defaultable_tvs_of_err (DE_Hole {}) = emptyVarSet++insolubleWC :: WantedConstraints -> Bool+insolubleWC (WC { wc_impl = implics, wc_simple = simples, wc_errors = errors })+  =  anyBag insolubleWantedCt simples+  || anyBag insolubleImplic implics+  || anyBag is_insoluble errors++    where+      is_insoluble (DE_Hole hole) = isOutOfScopeHole hole -- See Note [Insoluble holes]+      is_insoluble (DE_NotConcrete {}) = True++insolubleWantedCt :: Ct -> Bool+-- Definitely insoluble, in particular /excluding/ type-hole constraints+-- Namely:+--   a) an insoluble constraint as per 'insolubleCt', i.e. either+--        - an insoluble equality constraint (e.g. Int ~ Bool), or+--        - a custom type error constraint, TypeError msg :: Constraint+--   b) that does not arise from a Given or a Wanted/Wanted fundep interaction+--+-- See Note [Given insolubles].+insolubleWantedCt ct = insolubleCt ct &&+                       not (arisesFromGivens ct) &&+                       not (isWantedWantedFunDepOrigin (ctOrigin ct))++insolubleEqCt :: Ct -> Bool+-- Returns True of /equality/ constraints+-- that are /definitely/ insoluble+-- It won't detect some definite errors like+--       F a ~ T (F a)+-- where F is a type family, which actually has an occurs check+--+-- The function is tuned for application /after/ constraint solving+--       i.e. assuming canonicalisation has been done+-- E.g.  It'll reply True  for     a ~ [a]+--               but False for   [a] ~ a+-- and+--                   True for  Int ~ F a Int+--               but False for  Maybe Int ~ F a Int Int+--               (where F is an arity-1 type function)+insolubleEqCt (CIrredCan { cc_reason = reason }) = isInsolubleReason reason+insolubleEqCt _                                  = False++-- | Returns True of equality constraints that are definitely insoluble,+-- as well as TypeError constraints.+-- Can return 'True' for Given constraints, unlike 'insolubleWantedCt'.+--+-- This function is critical for accurate pattern-match overlap warnings.+-- See Note [Pattern match warnings with insoluble Givens] in GHC.Tc.Solver+--+-- Note that this does not traverse through the constraint to find+-- nested custom type errors: it only detects @TypeError msg :: Constraint@,+-- and not e.g. @Eq (TypeError msg)@.+insolubleCt :: Ct -> Bool+insolubleCt ct+  | Just _ <- userTypeError_maybe (ctPred ct)+  -- Don't use 'isUserTypeErrorCt' here, as that function is too eager:+  -- the TypeError might appear inside a type family application+  -- which might later reduce, but we only want to return 'True'+  -- for constraints that are definitely insoluble.+  --+  -- Test case: T11503, with the 'Assert' type family:+  --+  -- > type Assert :: Bool -> Constraint -> Constraint+  -- > type family Assert check errMsg where+  -- >   Assert 'True  _errMsg = ()+  -- >   Assert _check errMsg  = errMsg+  = True+  | otherwise+  = insolubleEqCt ct++-- | Does this hole represent an "out of scope" error?+-- See Note [Insoluble holes]+isOutOfScopeHole :: Hole -> Bool+isOutOfScopeHole (Hole { hole_occ = occ }) = not (startsWithUnderscore occ)++instance Outputable WantedConstraints where+  ppr (WC {wc_simple = s, wc_impl = i, wc_errors = e})+   = text "WC" <+> braces (vcat+        [ ppr_bag (text "wc_simple") s+        , ppr_bag (text "wc_impl") i+        , ppr_bag (text "wc_errors") e ])++ppr_bag :: Outputable a => SDoc -> Bag a -> SDoc+ppr_bag doc bag+ | isEmptyBag bag = empty+ | otherwise      = hang (doc <+> equals)+                       2 (foldr (($$) . ppr) empty bag)++{- Note [Given insolubles]+~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider (#14325, comment:)+    class (a~b) => C a b++    foo :: C a c => a -> c+    foo x = x++    hm3 :: C (f b) b => b -> f b+    hm3 x = foo x++In the RHS of hm3, from the [G] C (f b) b we get the insoluble+[G] f b ~# b.  Then we also get an unsolved [W] C b (f b).+Residual implication looks like+    forall b. C (f b) b => [G] f b ~# b+                           [W] C f (f b)++We do /not/ want to set the implication status to IC_Insoluble,+because that'll suppress reports of [W] C b (f b).  But we+may not report the insoluble [G] f b ~# b either (see Note [Given errors]+in GHC.Tc.Errors), so we may fail to report anything at all!  Yikes.++Bottom line: insolubleWC (called in GHC.Tc.Solver.setImplicationStatus)+             should ignore givens even if they are insoluble.++Note [Insoluble holes]+~~~~~~~~~~~~~~~~~~~~~~+Hole constraints that ARE NOT treated as truly insoluble:+  a) type holes, arising from PartialTypeSignatures,+  b) "true" expression holes arising from TypedHoles++An "expression hole" or "type hole" isn't really an error+at all; it's a report saying "_ :: Int" here.  But an out-of-scope+variable masquerading as expression holes IS treated as truly+insoluble, so that it trumps other errors during error reporting.+Yuk!++************************************************************************+*                                                                      *+                Implication constraints+*                                                                      *+************************************************************************+-}++data Implication+  = Implic {   -- Invariants for a tree of implications:+               -- see TcType Note [TcLevel invariants]++      ic_tclvl :: TcLevel,       -- TcLevel of unification variables+                                 -- allocated /inside/ this implication++      ic_info  :: SkolemInfoAnon,    -- See Note [Skolems in an implication]+                                     -- See Note [Shadowing in a constraint]++      ic_skols :: [TcTyVar],     -- Introduced skolems; always skolem TcTyVars+                                 -- Their level numbers should be precisely ic_tclvl+                                 -- Their SkolemInfo should be precisely ic_info (almost)+                                 --       See Note [Implication invariants]++      ic_given  :: [EvVar],      -- Given evidence variables+                                 --   (order does not matter)+                                 -- See Invariant (GivenInv) in GHC.Tc.Utils.TcType++      ic_given_eqs :: HasGivenEqs,  -- Are there Given equalities here?++      ic_warn_inaccessible :: Bool,+                                 -- True  <=> -Winaccessible-code is enabled+                                 -- at construction. See+                                 -- Note [Avoid -Winaccessible-code when deriving]+                                 -- in GHC.Tc.TyCl.Instance++      ic_env   :: TcLclEnv,+                                 -- Records the TcLClEnv at the time of creation.+                                 --+                                 -- The TcLclEnv gives the source location+                                 -- and error context for the implication, and+                                 -- hence for all the given evidence variables.++      ic_wanted :: WantedConstraints,  -- The wanteds+                                       -- See Invariant (WantedInf) in GHC.Tc.Utils.TcType++      ic_binds  :: EvBindsVar,    -- Points to the place to fill in the+                                  -- abstraction and bindings.++      -- The ic_need fields keep track of which Given evidence+      -- is used by this implication or its children+      -- NB: including stuff used by nested implications that have since+      --     been discarded+      -- See Note [Needed evidence variables]+      ic_need_inner :: VarSet,    -- Includes all used Given evidence+      ic_need_outer :: VarSet,    -- Includes only the free Given evidence+                                  --  i.e. ic_need_inner after deleting+                                  --       (a) givens (b) binders of ic_binds++      ic_status   :: ImplicStatus+    }++implicationPrototype :: Implication+implicationPrototype+   = Implic { -- These fields must be initialised+              ic_tclvl      = panic "newImplic:tclvl"+            , ic_binds      = panic "newImplic:binds"+            , ic_info       = panic "newImplic:info"+            , ic_env        = panic "newImplic:env"+            , ic_warn_inaccessible = panic "newImplic:warn_inaccessible"++              -- The rest have sensible default values+            , ic_skols      = []+            , ic_given      = []+            , ic_wanted     = emptyWC+            , ic_given_eqs  = MaybeGivenEqs+            , ic_status     = IC_Unsolved+            , ic_need_inner = emptyVarSet+            , ic_need_outer = emptyVarSet }++data ImplicStatus+  = IC_Solved     -- All wanteds in the tree are solved, all the way down+       { ics_dead :: [EvVar] }  -- Subset of ic_given that are not needed+         -- See Note [Tracking redundant constraints] in GHC.Tc.Solver++  | IC_Insoluble  -- At least one insoluble constraint in the tree++  | IC_BadTelescope  -- Solved, but the skolems in the telescope are out of+                     -- dependency order. See Note [Checking telescopes]++  | IC_Unsolved   -- Neither of the above; might go either way++data HasGivenEqs -- See Note [HasGivenEqs]+  = NoGivenEqs      -- Definitely no given equalities,+                    --   except by Note [Let-bound skolems] in GHC.Tc.Solver.InertSet+  | LocalGivenEqs   -- Might have Given equalities, but only ones that affect only+                    --   local skolems e.g. forall a b. (a ~ F b) => ...+  | MaybeGivenEqs   -- Might have any kind of Given equalities; no floating out+                    --   is possible.+  deriving Eq++type UserGiven = Implication++getUserGivensFromImplics :: [Implication] -> [UserGiven]+getUserGivensFromImplics implics+  = reverse (filterOut (null . ic_given) implics)++{- Note [HasGivenEqs]+~~~~~~~~~~~~~~~~~~~~~+The GivenEqs data type describes the Given constraints of an implication constraint:++* NoGivenEqs: definitely no Given equalities, except perhaps let-bound skolems+  which don't count: see Note [Let-bound skolems] in GHC.Tc.Solver.InertSet+  Examples: forall a. Eq a => ...+            forall a. (Show a, Num a) => ...+            forall a. a ~ Either Int Bool => ...  -- Let-bound skolem++* LocalGivenEqs: definitely no Given equalities that would affect principal+  types.  But may have equalities that affect only skolems of this implication+  (and hence do not affect princial types)+  Examples: forall a. F a ~ Int => ...+            forall a b. F a ~ G b => ...++* MaybeGivenEqs: may have Given equalities that would affect principal+  types+  Examples: forall. (a ~ b) => ...+            forall a. F a ~ b => ...+            forall a. c a => ...       -- The 'c' might be instantiated to (b ~)+            forall a. C a b => ....+               where class x~y => C a b+               so there is an equality in the superclass of a Given++The HasGivenEqs classifications affect two things:++* Suppressing redundant givens during error reporting; see GHC.Tc.Errors+  Note [Suppress redundant givens during error reporting]++* Floating in approximateWC.++Specifically, here's how it goes:++                 Stops floating    |   Suppresses Givens in errors+                 in approximateWC  |+                 -----------------------------------------------+ NoGivenEqs         NO             |         YES+ LocalGivenEqs      NO             |         NO+ MaybeGivenEqs      YES            |         NO+-}++instance Outputable Implication where+  ppr (Implic { ic_tclvl = tclvl, ic_skols = skols+              , ic_given = given, ic_given_eqs = given_eqs+              , ic_wanted = wanted, ic_status = status+              , ic_binds = binds+              , ic_need_inner = need_in, ic_need_outer = need_out+              , ic_info = info })+   = hang (text "Implic" <+> lbrace)+        2 (sep [ text "TcLevel =" <+> ppr tclvl+               , text "Skolems =" <+> pprTyVars skols+               , text "Given-eqs =" <+> ppr given_eqs+               , text "Status =" <+> ppr status+               , hang (text "Given =")  2 (pprEvVars given)+               , hang (text "Wanted =") 2 (ppr wanted)+               , text "Binds =" <+> ppr binds+               , whenPprDebug (text "Needed inner =" <+> ppr need_in)+               , whenPprDebug (text "Needed outer =" <+> ppr need_out)+               , pprSkolInfo info ] <+> rbrace)++instance Outputable ImplicStatus where+  ppr IC_Insoluble    = text "Insoluble"+  ppr IC_BadTelescope = text "Bad telescope"+  ppr IC_Unsolved     = text "Unsolved"+  ppr (IC_Solved { ics_dead = dead })+    = text "Solved" <+> (braces (text "Dead givens =" <+> ppr dead))++checkTelescopeSkol :: SkolemInfoAnon -> Bool+-- See Note [Checking telescopes]+checkTelescopeSkol (ForAllSkol {}) = True+checkTelescopeSkol _               = False++instance Outputable HasGivenEqs where+  ppr NoGivenEqs    = text "NoGivenEqs"+  ppr LocalGivenEqs = text "LocalGivenEqs"+  ppr MaybeGivenEqs = text "MaybeGivenEqs"++-- Used in GHC.Tc.Solver.Monad.getHasGivenEqs+instance Semigroup HasGivenEqs where+  NoGivenEqs <> other = other+  other <> NoGivenEqs = other++  MaybeGivenEqs <> _other = MaybeGivenEqs+  _other <> MaybeGivenEqs = MaybeGivenEqs++  LocalGivenEqs <> LocalGivenEqs = LocalGivenEqs++-- Used in GHC.Tc.Solver.Monad.getHasGivenEqs+instance Monoid HasGivenEqs where+  mempty = NoGivenEqs++{- Note [Checking telescopes]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When kind-checking a /user-written/ type, we might have a "bad telescope"+like this one:+  data SameKind :: forall k. k -> k -> Type+  type Foo :: forall a k (b :: k). SameKind a b -> Type++The kind of 'a' mentions 'k' which is bound after 'a'.  Oops.++One approach to doing this would be to bring each of a, k, and b into+scope, one at a time, creating a separate implication constraint for+each one, and bumping the TcLevel. This would work, because the kind+of, say, a would be untouchable when k is in scope (and the constraint+couldn't float out because k blocks it). However, it leads to terrible+error messages, complaining about skolem escape. While it is indeed a+problem of skolem escape, we can do better.++Instead, our approach is to bring the block of variables into scope+all at once, creating one implication constraint for the lot:++* We make a single implication constraint when kind-checking+  the 'forall' in Foo's kind, something like+      forall a k (b::k). { wanted constraints }++* Having solved {wanted}, before discarding the now-solved implication,+  the constraint solver checks the dependency order of the skolem+  variables (ic_skols).  This is done in setImplicationStatus.++* This check is only necessary if the implication was born from a+  'forall' in a user-written signature (the HsForAllTy case in+  GHC.Tc.Gen.HsType.  If, say, it comes from checking a pattern match+  that binds existentials, where the type of the data constructor is+  known to be valid (it in tcConPat), no need for the check.++  So the check is done /if and only if/ ic_info is ForAllSkol.++* If ic_info is (ForAllSkol dt dvs), the dvs::SDoc displays the+  original, user-written type variables.++* Be careful /NOT/ to discard an implication with a ForAllSkol+  ic_info, even if ic_wanted is empty.  We must give the+  constraint solver a chance to make that bad-telescope test!  Hence+  the extra guard in emitResidualTvConstraint; see #16247++* Don't mix up inferred and explicit variables in the same implication+  constraint.  E.g.+      foo :: forall a kx (b :: kx). SameKind a b+  We want an implication+      Implic { ic_skol = [(a::kx), kx, (b::kx)], ... }+  but GHC will attempt to quantify over kx, since it is free in (a::kx),+  and it's hopelessly confusing to report an error about quantified+  variables   kx (a::kx) kx (b::kx).+  Instead, the outer quantification over kx should be in a separate+  implication. TL;DR: an explicit forall should generate an implication+  quantified only over those explicitly quantified variables.++Note [Needed evidence variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Th ic_need_evs field holds the free vars of ic_binds, and all the+ic_binds in nested implications.++  * Main purpose: if one of the ic_givens is not mentioned in here, it+    is redundant.++  * solveImplication may drop an implication altogether if it has no+    remaining 'wanteds'. But we still track the free vars of its+    evidence binds, even though it has now disappeared.++Note [Shadowing in a constraint]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We assume NO SHADOWING in a constraint.  Specifically+ * The unification variables are all implicitly quantified at top+   level, and are all unique+ * The skolem variables bound in ic_skols are all freah when the+   implication is created.+So we can safely substitute. For example, if we have+   forall a.  a~Int => ...(forall b. ...a...)...+we can push the (a~Int) constraint inwards in the "givens" without+worrying that 'b' might clash.++Note [Skolems in an implication]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The skolems in an implication are used:++* When considering floating a constraint outside the implication in+  GHC.Tc.Solver.floatEqualities or GHC.Tc.Solver.approximateImplications+  For this, we can treat ic_skols as a set.++* When checking that a /user-specified/ forall (ic_info = ForAllSkol tvs)+  has its variables in the correct order; see Note [Checking telescopes].+  Only for these implications does ic_skols need to be a list.++Nota bene: Although ic_skols is a list, it is not necessarily+in dependency order:+- In the ic_info=ForAllSkol case, the user might have written them+  in the wrong order+- In the case of a type signature like+      f :: [a] -> [b]+  the renamer gathers the implicit "outer" forall'd variables {a,b}, but+  does not know what order to put them in.  The type checker can sort them+  into dependency order, but only after solving all the kind constraints;+  and to do that it's convenient to create the Implication!++So we accept that ic_skols may be out of order.  Think of it as a set or+(in the case of ic_info=ForAllSkol, a list in user-specified, and possibly+wrong, order.++Note [Insoluble constraints]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Some of the errors that we get during canonicalization are best+reported when all constraints have been simplified as much as+possible. For instance, assume that during simplification the+following constraints arise:++ [Wanted]   F alpha ~  uf1+ [Wanted]   beta ~ uf1 beta++When canonicalizing the wanted (beta ~ uf1 beta), if we eagerly fail+we will simply see a message:+    'Can't construct the infinite type  beta ~ uf1 beta'+and the user has no idea what the uf1 variable is.++Instead our plan is that we will NOT fail immediately, but:+    (1) Record the "frozen" error in the ic_insols field+    (2) Isolate the offending constraint from the rest of the inerts+    (3) Keep on simplifying/canonicalizing++At the end, we will hopefully have substituted uf1 := F alpha, and we+will be able to report a more informative error:+    'Can't construct the infinite type beta ~ F alpha beta'++************************************************************************+*                                                                      *+            Invariant checking (debug only)+*                                                                      *+************************************************************************++Note [Implication invariants]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The skolems of an implication have the following invariants, which are checked+by checkImplicationInvariants:++a) They are all SkolemTv TcTyVars; no TyVars, no unification variables+b) Their TcLevel matches the ic_lvl for the implication+c) Their SkolemInfo matches the implication.++Actually (c) is not quite true.  Consider+   data T a = forall b. MkT a b++In tcConDecl for MkT we'll create an implication with ic_info of+DataConSkol; but the type variable 'a' will have a SkolemInfo of+TyConSkol.  So we allow the tyvar to have a SkolemInfo of TyConFlav if+the implication SkolemInfo is DataConSkol.+-}++checkImplicationInvariants, check_implic :: (HasCallStack, Applicative m) => Implication -> m ()+{-# INLINE checkImplicationInvariants #-}+-- Nothing => OK, Just doc => doc gives info+checkImplicationInvariants implic = when debugIsOn (check_implic implic)++check_implic implic@(Implic { ic_tclvl = lvl+                            , ic_info = skol_info+                            , ic_skols = skols })+  | null bads = pure ()+  | otherwise = massertPpr False (vcat [ text "checkImplicationInvariants failure"+                                       , nest 2 (vcat bads)+                                       , ppr implic ])+  where+    bads = mapMaybe check skols++    check :: TcTyVar -> Maybe SDoc+    check tv | not (isTcTyVar tv)+             = Just (ppr tv <+> text "is not a TcTyVar")+             | otherwise+             = check_details tv (tcTyVarDetails tv)++    check_details :: TcTyVar -> TcTyVarDetails -> Maybe SDoc+    check_details tv (SkolemTv tv_skol_info tv_lvl _)+      | not (tv_lvl == lvl)+      = Just (vcat [ ppr tv <+> text "has level" <+> ppr tv_lvl+                   , text "ic_lvl" <+> ppr lvl ])+      | not (skol_info `checkSkolInfoAnon` skol_info_anon)+      = Just (vcat [ ppr tv <+> text "has skol info" <+> ppr skol_info_anon+                   , text "ic_info" <+> ppr skol_info ])+      | otherwise+      = Nothing+      where+        skol_info_anon = getSkolemInfo tv_skol_info+    check_details tv details+      = Just (ppr tv <+> text "is not a SkolemTv" <+> ppr details)++checkSkolInfoAnon :: SkolemInfoAnon   -- From the implication+                  -> SkolemInfoAnon   -- From the type variable+                  -> Bool             -- True <=> ok+-- Used only for debug-checking; checkImplicationInvariants+-- So it doesn't matter much if its's incomplete+checkSkolInfoAnon sk1 sk2 = go sk1 sk2+  where+    go (SigSkol c1 t1 s1)   (SigSkol c2 t2 s2)   = c1==c2 && t1 `tcEqType` t2 && s1==s2+    go (SigTypeSkol cx1)    (SigTypeSkol cx2)    = cx1==cx2++    go (ForAllSkol _)       (ForAllSkol _)       = True++    go (IPSkol ips1)        (IPSkol ips2)        = ips1 == ips2+    go (DerivSkol pred1)    (DerivSkol pred2)    = pred1 `tcEqType` pred2+    go (TyConSkol f1 n1)    (TyConSkol f2 n2)    = f1==f2 && n1==n2+    go (DataConSkol n1)     (DataConSkol n2)     = n1==n2+    go InstSkol             InstSkol             = True+    go FamInstSkol          FamInstSkol          = True+    go BracketSkol          BracketSkol          = True+    go (RuleSkol n1)        (RuleSkol n2)        = n1==n2+    go (PatSkol c1 _)       (PatSkol c2 _)       = getName c1 == getName c2+       -- Too tedious to compare the HsMatchContexts+    go (InferSkol ids1)     (InferSkol ids2)     = equalLength ids1 ids2 &&+                                                   and (zipWith eq_pr ids1 ids2)+    go (UnifyForAllSkol t1) (UnifyForAllSkol t2) = t1 `tcEqType` t2+    go ReifySkol            ReifySkol            = True+    go QuantCtxtSkol        QuantCtxtSkol        = True+    go RuntimeUnkSkol       RuntimeUnkSkol       = True+    go ArrowReboundIfSkol   ArrowReboundIfSkol   = True+    go (UnkSkol _)          (UnkSkol _)          = True++    -------- Three slightly strange special cases --------+    go (DataConSkol _)      (TyConSkol f _)      = h98_data_decl f+    -- In the H98 declaration  data T a = forall b. MkT a b+    -- in tcConDecl for MkT we'll have a SkolemInfo in the implication of+    -- DataConSkol, but the type variable 'a' will have a SkolemInfo of TyConSkol++    go (DataConSkol _)      FamInstSkol          = True+    -- In  data/newtype instance T a = MkT (a -> a),+    -- in tcConDecl for MkT we'll have a SkolemInfo in the implication of+    -- DataConSkol, but 'a' will have SkolemInfo of FamInstSkol++    go FamInstSkol          InstSkol             = True+    -- In instance C (T a) where { type F (T a) b = ... }+    -- we have 'a' with SkolemInfo InstSkol, but we make an implication wi+    -- SkolemInfo of FamInstSkol.  Very like the ConDecl/TyConSkol case++    go (ForAllSkol _)       _                    = True+    -- Telescope tests: we need a ForAllSkol to force the telescope+    -- test, but the skolems might come from (say) a family instance decl+    --    type instance forall a. F [a] = a->a++    go (SigTypeSkol DerivClauseCtxt) (TyConSkol f _) = h98_data_decl f+    -- e.g.   newtype T a = MkT ... deriving blah+    -- We use the skolems from T (TyConSkol) when typechecking+    -- the deriving clauses (SigTypeSkol DerivClauseCtxt)++    go _ _ = False++    eq_pr :: (Name,TcType) -> (Name,TcType) -> Bool+    eq_pr (i1,_) (i2,_) = i1==i2 -- Types may be differently zonked++    h98_data_decl DataTypeFlavour = True+    h98_data_decl NewtypeFlavour  = True+    h98_data_decl _               = False+++{- *********************************************************************+*                                                                      *+            Pretty printing+*                                                                      *+********************************************************************* -}++pprEvVars :: [EvVar] -> SDoc    -- Print with their types+pprEvVars ev_vars = vcat (map pprEvVarWithType ev_vars)++pprEvVarTheta :: [EvVar] -> SDoc+pprEvVarTheta ev_vars = pprTheta (map evVarPred ev_vars)++pprEvVarWithType :: EvVar -> SDoc+pprEvVarWithType v = ppr v <+> dcolon <+> pprType (evVarPred v)++++wrapType :: Type -> [TyVar] -> [PredType] -> Type+wrapType ty skols givens = mkSpecForAllTys skols $ mkPhiTy givens ty+++{-+************************************************************************+*                                                                      *+            CtEvidence+*                                                                      *+************************************************************************++Note [CtEvidence invariants]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The `ctev_pred` field of a `CtEvidence` is a just a cache for the type+of the evidence. More precisely:++* For Givens, `ctev_pred` = `varType ctev_evar`+* For Wanteds, `ctev_pred` = `evDestType ctev_dest`++where++  evDestType :: TcEvDest -> TcType+  evDestType (EvVarDest evVar)       = varType evVar+  evDestType (HoleDest coercionHole) = varType (coHoleCoVar coercionHole)++The invariant is maintained by `setCtEvPredType`, the only function that+updates the `ctev_pred` field of a `CtEvidence`.++Why is the invariant important? Because when the evidence is a coercion, it may+be used in (CastTy ty co); and then we may call `typeKind` on that type (e.g.+in the kind-check of `eqType`); and expect to see a fully zonked kind.+(This came up in test T13333, in the MR that fixed #20641, namely !6942.)++Historical Note [Evidence field of CtEvidence]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In the past we tried leaving the `ctev_evar`/`ctev_dest` field of a+constraint untouched (and hence un-zonked) on the grounds that it is+never looked at.  But in fact it is: the evidence can become part of a+type (via `CastTy ty kco`) and we may later ask the kind of that type+and expect a zonked result.  (For example, in the kind-check+of `eqType`.)++The safest thing is simply to keep `ctev_evar`/`ctev_dest` in sync+with `ctev_pref`, as stated in `Note [CtEvidence invariants]`.++Note [Bind new Givens immediately]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For Givens we make new EvVars and bind them immediately. Two main reasons:+  * Gain sharing.  E.g. suppose we start with g :: C a b, where+       class D a => C a b+       class (E a, F a) => D a+    If we generate all g's superclasses as separate EvTerms we might+    get    selD1 (selC1 g) :: E a+           selD2 (selC1 g) :: F a+           selC1 g :: D a+    which we could do more economically as:+           g1 :: D a = selC1 g+           g2 :: E a = selD1 g1+           g3 :: F a = selD2 g1++  * For *coercion* evidence we *must* bind each given:+      class (a~b) => C a b where ....+      f :: C a b => ....+    Then in f's Givens we have g:(C a b) and the superclass sc(g,0):a~b.+    But that superclass selector can't (yet) appear in a coercion+    (see evTermCoercion), so the easy thing is to bind it to an Id.++So a Given has EvVar inside it rather than (as previously) an EvTerm.++-}++-- | A place for type-checking evidence to go after it is generated.+--+--  - Wanted equalities use HoleDest,+--  - other Wanteds use EvVarDest.+data TcEvDest+  = EvVarDest EvVar         -- ^ bind this var to the evidence+              -- EvVarDest is always used for non-type-equalities+              -- e.g. class constraints++  | HoleDest  CoercionHole  -- ^ fill in this hole with the evidence+              -- HoleDest is always used for type-equalities+              -- See Note [Coercion holes] in GHC.Core.TyCo.Rep++data CtEvidence+  = CtGiven    -- Truly given, not depending on subgoals+      { ctev_pred :: TcPredType      -- See Note [Ct/evidence invariant]+      , ctev_evar :: EvVar           -- See Note [CtEvidence invariants]+      , ctev_loc  :: CtLoc }+++  | CtWanted   -- Wanted goal+      { ctev_pred      :: TcPredType     -- See Note [Ct/evidence invariant]+      , ctev_dest      :: TcEvDest       -- See Note [CtEvidence invariants]+      , ctev_loc       :: CtLoc+      , ctev_rewriters :: RewriterSet }  -- See Note [Wanteds rewrite Wanteds]++ctEvPred :: CtEvidence -> TcPredType+-- The predicate of a flavor+ctEvPred = ctev_pred++ctEvLoc :: CtEvidence -> CtLoc+ctEvLoc = ctev_loc++ctEvOrigin :: CtEvidence -> CtOrigin+ctEvOrigin = ctLocOrigin . ctEvLoc++-- | Get the equality relation relevant for a 'CtEvidence'+ctEvEqRel :: CtEvidence -> EqRel+ctEvEqRel = predTypeEqRel . ctEvPred++-- | Get the role relevant for a 'CtEvidence'+ctEvRole :: CtEvidence -> Role+ctEvRole = eqRelRole . ctEvEqRel++ctEvTerm :: CtEvidence -> EvTerm+ctEvTerm ev = EvExpr (ctEvExpr ev)++-- | Extract the set of rewriters from a 'CtEvidence'+-- See Note [Wanteds rewrite Wanteds]+-- If the provided CtEvidence is not for a Wanted, just+-- return an empty set.+ctEvRewriters :: CtEvidence -> RewriterSet+ctEvRewriters (CtWanted { ctev_rewriters = rewriters }) = rewriters+ctEvRewriters _other                                    = emptyRewriterSet++ctEvExpr :: HasDebugCallStack => CtEvidence -> EvExpr+ctEvExpr ev@(CtWanted { ctev_dest = HoleDest _ })+            = Coercion $ ctEvCoercion ev+ctEvExpr ev = evId (ctEvEvId ev)++ctEvCoercion :: HasDebugCallStack => CtEvidence -> TcCoercion+ctEvCoercion (CtGiven { ctev_evar = ev_id })+  = mkTcCoVarCo ev_id+ctEvCoercion (CtWanted { ctev_dest = dest })+  | HoleDest hole <- dest+  = -- ctEvCoercion is only called on type equalities+    -- and they always have HoleDests+    mkHoleCo hole+ctEvCoercion ev+  = pprPanic "ctEvCoercion" (ppr ev)++ctEvEvId :: CtEvidence -> EvVar+ctEvEvId (CtWanted { ctev_dest = EvVarDest ev }) = ev+ctEvEvId (CtWanted { ctev_dest = HoleDest h })   = coHoleCoVar h+ctEvEvId (CtGiven  { ctev_evar = ev })           = ev++ctEvUnique :: CtEvidence -> Unique+ctEvUnique (CtGiven { ctev_evar = ev })    = varUnique ev+ctEvUnique (CtWanted { ctev_dest = dest }) = tcEvDestUnique dest++tcEvDestUnique :: TcEvDest -> Unique+tcEvDestUnique (EvVarDest ev_var) = varUnique ev_var+tcEvDestUnique (HoleDest co_hole) = varUnique (coHoleCoVar co_hole)++setCtEvLoc :: CtEvidence -> CtLoc -> CtEvidence+setCtEvLoc ctev loc = ctev { ctev_loc = loc }++arisesFromGivens :: Ct -> Bool+arisesFromGivens ct = isGivenCt ct || isGivenLoc (ctLoc ct)++-- | Set the type of CtEvidence.+--+-- This function ensures that the invariants on 'CtEvidence' hold, by updating+-- the evidence and the ctev_pred in sync with each other.+-- See Note [CtEvidence invariants].+setCtEvPredType :: HasDebugCallStack => CtEvidence -> Type -> CtEvidence+setCtEvPredType old_ctev new_pred+  = case old_ctev of+    CtGiven { ctev_evar = ev, ctev_loc = loc } ->+      CtGiven { ctev_pred = new_pred+              , ctev_evar = setVarType ev new_pred+              , ctev_loc  = loc+              }+    CtWanted { ctev_dest = dest, ctev_loc = loc, ctev_rewriters = rewriters } ->+      CtWanted { ctev_pred      = new_pred+               , ctev_dest      = new_dest+               , ctev_loc       = loc+               , ctev_rewriters = rewriters+               }+        where+          new_dest = case dest of+            EvVarDest ev -> EvVarDest (setVarType ev new_pred)+            HoleDest h   -> HoleDest  (setCoHoleType h new_pred)++instance Outputable TcEvDest where+  ppr (HoleDest h)   = text "hole" <> ppr h+  ppr (EvVarDest ev) = ppr ev++instance Outputable CtEvidence where+  ppr ev = ppr (ctEvFlavour ev)+           <+> pp_ev <+> braces (ppr (ctl_depth (ctEvLoc ev)) <> pp_rewriters)+                         -- Show the sub-goal depth too+               <> dcolon <+> ppr (ctEvPred ev)+    where+      pp_ev = case ev of+             CtGiven { ctev_evar = v } -> ppr v+             CtWanted {ctev_dest = d } -> ppr d++      rewriters = ctEvRewriters ev+      pp_rewriters | isEmptyRewriterSet rewriters = empty+                   | otherwise                    = semi <> ppr rewriters++isWanted :: CtEvidence -> Bool+isWanted (CtWanted {}) = True+isWanted _ = False++isGiven :: CtEvidence -> Bool+isGiven (CtGiven {})  = True+isGiven _ = False++{-+************************************************************************+*                                                                      *+           RewriterSet+*                                                                      *+************************************************************************+-}++-- | Stores a set of CoercionHoles that have been used to rewrite a constraint.+-- See Note [Wanteds rewrite Wanteds].+newtype RewriterSet = RewriterSet (UniqSet CoercionHole)+  deriving newtype (Outputable, Semigroup, Monoid)++emptyRewriterSet :: RewriterSet+emptyRewriterSet = RewriterSet emptyUniqSet++isEmptyRewriterSet :: RewriterSet -> Bool+isEmptyRewriterSet (RewriterSet set) = isEmptyUniqSet set++addRewriterSet :: RewriterSet -> CoercionHole -> RewriterSet+addRewriterSet = coerce (addOneToUniqSet @CoercionHole)++-- | Makes a 'RewriterSet' from all the coercion holes that occur in the+-- given coercion.+rewriterSetFromCo :: Coercion -> RewriterSet+rewriterSetFromCo co = appEndo (rewriter_set_from_co co) emptyRewriterSet++-- | Makes a 'RewriterSet' from all the coercion holes that occur in the+-- given type.+rewriterSetFromType :: Type -> RewriterSet+rewriterSetFromType ty = appEndo (rewriter_set_from_ty ty) emptyRewriterSet++-- | Makes a 'RewriterSet' from all the coercion holes that occur in the+-- given types.+rewriterSetFromTypes :: [Type] -> RewriterSet+rewriterSetFromTypes tys = appEndo (rewriter_set_from_tys tys) emptyRewriterSet++rewriter_set_from_ty :: Type -> Endo RewriterSet+rewriter_set_from_tys :: [Type] -> Endo RewriterSet+rewriter_set_from_co :: Coercion -> Endo RewriterSet+(rewriter_set_from_ty, rewriter_set_from_tys, rewriter_set_from_co, _)+  = foldTyCo folder ()+  where+    folder :: TyCoFolder () (Endo RewriterSet)+    folder = TyCoFolder+               { tcf_view  = noView+               , tcf_tyvar = \ _ tv -> rewriter_set_from_ty (tyVarKind tv)+               , tcf_covar = \ _ cv -> rewriter_set_from_ty (varType cv)+               , tcf_hole  = \ _ hole -> coerce (`addOneToUniqSet` hole) S.<>+                                         rewriter_set_from_ty (varType (coHoleCoVar hole))+               , tcf_tycobinder = \ _ _ _ -> () }++{-+************************************************************************+*                                                                      *+           CtFlavour+*                                                                      *+************************************************************************+-}++data CtFlavour+  = Given     -- we have evidence+  | Wanted    -- we want evidence+  deriving Eq++instance Outputable CtFlavour where+  ppr Given  = text "[G]"+  ppr Wanted = text "[W]"++ctEvFlavour :: CtEvidence -> CtFlavour+ctEvFlavour (CtWanted {}) = Wanted+ctEvFlavour (CtGiven {})  = Given++-- | Whether or not one 'Ct' can rewrite another is determined by its+-- flavour and its equality relation. See also+-- Note [Flavours with roles] in GHC.Tc.Solver.InertSet+type CtFlavourRole = (CtFlavour, EqRel)++-- | Extract the flavour, role, and boxity from a 'CtEvidence'+ctEvFlavourRole :: CtEvidence -> CtFlavourRole+ctEvFlavourRole ev = (ctEvFlavour ev, ctEvEqRel ev)++-- | Extract the flavour and role from a 'Ct'+ctFlavourRole :: Ct -> CtFlavourRole+-- Uses short-cuts to role for special cases+ctFlavourRole (CDictCan { cc_ev = ev })+  = (ctEvFlavour ev, NomEq)+ctFlavourRole (CEqCan { cc_ev = ev, cc_eq_rel = eq_rel })+  = (ctEvFlavour ev, eq_rel)+ctFlavourRole ct+  = ctEvFlavourRole (ctEvidence ct)++{- Note [eqCanRewrite]+~~~~~~~~~~~~~~~~~~~~~~+(eqCanRewrite ct1 ct2) holds if the constraint ct1 (a CEqCan of form+lhs ~ ty) can be used to rewrite ct2.  It must satisfy the properties of+a can-rewrite relation, see Definition [Can-rewrite relation] in+GHC.Tc.Solver.Monad.++With the solver handling Coercible constraints like equality constraints,+the rewrite conditions must take role into account, never allowing+a representational equality to rewrite a nominal one.++Note [Wanteds rewrite Wanteds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Should one Wanted constraint be allowed to rewrite another?++This example (along with #8450) suggests not:+   f :: a -> Bool+   f x = ( [x,'c'], [x,True] ) `seq` True+Here we get+  [W] a ~ Char+  [W] a ~ Bool+but we do not want to complain about Bool ~ Char!++This example suggests yes (indexed-types/should_fail/T4093a):+  type family Foo a+  f :: (Foo e ~ Maybe e) => Foo e+In the ambiguity check, we get+  [G] g1 :: Foo e ~ Maybe e+  [W] w1 :: Foo alpha ~ Foo e+  [W] w2 :: Foo alpha ~ Maybe alpha+w1 gets rewritten by the Given to become+  [W] w3 :: Foo alpha ~ Maybe e+Now, the only way to make progress is to allow Wanteds to rewrite Wanteds.+Rewriting w3 with w2 gives us+  [W] w4 :: Maybe alpha ~ Maybe e+which will soon get us to alpha := e and thence to victory.++TL;DR we want equality saturation.++We thus want Wanteds to rewrite Wanteds in order to accept more programs,+but we don't want Wanteds to rewrite Wanteds because doing so can create+inscrutable error messages. We choose to allow the rewriting, but+every Wanted tracks the set of Wanteds it has been rewritten by. This is+called a RewriterSet, stored in the ctev_rewriters field of the CtWanted+constructor of CtEvidence.  (Only Wanteds have RewriterSets.)++Let's continue our first example above:++  inert: [W] w1 :: a ~ Char+  work:  [W] w2 :: a ~ Bool++Because Wanteds can rewrite Wanteds, w1 will rewrite w2, yielding++  inert: [W] w1 :: a ~ Char+         [W] w2 {w1}:: Char ~ Bool++The {w1} in the second line of output is the RewriterSet of w1.++A RewriterSet is just a set of unfilled CoercionHoles. This is+sufficient because only equalities (evidenced by coercion holes) are+used for rewriting; other (dictionary) constraints cannot ever+rewrite. The rewriter (in e.g. GHC.Tc.Solver.Rewrite.rewrite) tracks+and returns a RewriterSet, consisting of the evidence (a CoercionHole)+for any Wanted equalities used in rewriting.  Then rewriteEvidence and+rewriteEqEvidence (in GHC.Tc.Solver.Canonical) add this RewriterSet to+the rewritten constraint's rewriter set.++In error reporting, we simply suppress any errors that have been rewritten by+/unsolved/ wanteds. This suppression happens in GHC.Tc.Errors.mkErrorItem, which+uses GHC.Tc.Utils.anyUnfilledCoercionHoles to look through any filled coercion+holes. The idea is that we wish to report the "root cause" -- the error that+rewrote all the others.++Worry: It seems possible that *all* unsolved wanteds are rewritten by other+unsolved wanteds, so that e.g. w1 has w2 in its rewriter set, and w2 has+w1 in its rewiter set. We are unable to come up with an example of this in+practice, however, and so we believe this case cannot happen.++Note [Avoiding rewriting cycles]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Note [inert_eqs: the inert equalities] in GHC.Tc.Solver.InertSet describes+the can-rewrite relation among CtFlavour/Role pairs, saying which constraints+can rewrite which other constraints. It puts forth (R2):+  (R2) If f1 >= f, and f2 >= f,+       then either f1 >= f2 or f2 >= f1+The naive can-rewrite relation says that (Given, Representational) can rewrite+(Wanted, Representational) and that (Wanted, Nominal) can rewrite+(Wanted, Representational), but neither of (Given, Representational) and+(Wanted, Nominal) can rewrite the other. This would violate (R2). See also+Note [Why R2?] in GHC.Tc.Solver.InertSet.++To keep R2, we do not allow (Wanted, Nominal) to rewrite (Wanted, Representational).+This can, in theory, bite, in this scenario:++  type family F a+  data T a+  type role T nominal++  [G] F a ~N T a+  [W] F alpha ~N T alpha+  [W] F alpha ~R T a++As written, this makes no progress, and GHC errors. But, if we+allowed W/N to rewrite W/R, the first W could rewrite the second:++  [G] F a ~N T a+  [W] F alpha ~N T alpha+  [W] T alpha ~R T a++Now we decompose the second W to get++  [W] alpha ~N a++noting the role annotation on T. This causes (alpha := a), and then+everything else unlocks.++What to do? We could "decompose" nominal equalities into nominal-only+("NO") equalities and representational ones, where a NO equality rewrites+only nominals. That is, when considering whether [W] F alpha ~N T alpha+should rewrite [W] F alpha ~R T a, we could require splitting the first W+into [W] F alpha ~NO T alpha, [W] F alpha ~R T alpha. Then, we use the R+half of the split to rewrite the second W, and off we go. This splitting+would allow the split-off R equality to be rewritten by other equalities,+thus avoiding the problem in Note [Why R2?] in GHC.Tc.Solver.InertSet.++However, note that I said that this bites in theory. That's because no+known program actually gives rise to this scenario. A direct encoding+ends up starting with++  [G] F a ~ T a+  [W] F alpha ~ T alpha+  [W] Coercible (F alpha) (T a)++where ~ and Coercible denote lifted class constraints. The ~s quickly+reduce to ~N: good. But the Coercible constraint gets rewritten to++  [W] Coercible (T alpha) (T a)++by the first Wanted. This is because Coercible is a class, and arguments+in class constraints use *nominal* rewriting, not the representational+rewriting that is restricted due to (R2). Note that reordering the code+doesn't help, because equalities (including lifted ones) are prioritized+over Coercible. Thus, I (Richard E.) see no way to write a program that+is rejected because of this infelicity. I have not proved it impossible,+exactly, but my usual tricks have not yielded results.++In the olden days, when we had Derived constraints, this Note was all+about G/R and D/N both rewriting D/R. Back then, the code in+typecheck/should_compile/T19665 really did get rejected. But now,+according to the rewriting of the Coercible constraint, the program+is accepted.++-}++eqCanRewrite :: EqRel -> EqRel -> Bool+eqCanRewrite NomEq  _      = True+eqCanRewrite ReprEq ReprEq = True+eqCanRewrite ReprEq NomEq  = False++eqCanRewriteFR :: CtFlavourRole -> CtFlavourRole -> Bool+-- Can fr1 actually rewrite fr2?+-- Very important function!+-- See Note [eqCanRewrite]+-- See Note [Wanteds rewrite Wanteds]+-- See Note [Avoiding rewriting cycles]+eqCanRewriteFR (Given,  r1)    (_,      r2)     = eqCanRewrite r1 r2+eqCanRewriteFR (Wanted, NomEq) (Wanted, ReprEq) = False+eqCanRewriteFR (Wanted, r1)    (Wanted, r2)     = eqCanRewrite r1 r2+eqCanRewriteFR (Wanted, _)     (Given, _)       = False++{-+************************************************************************+*                                                                      *+            SubGoalDepth+*                                                                      *+************************************************************************++Note [SubGoalDepth]+~~~~~~~~~~~~~~~~~~~+The 'SubGoalDepth' takes care of stopping the constraint solver from looping.++The counter starts at zero and increases. It includes dictionary constraints,+equality simplification, and type family reduction. (Why combine these? Because+it's actually quite easy to mistake one for another, in sufficiently involved+scenarios, like ConstraintKinds.)++The flag -freduction-depth=n fixes the maximium level.++* The counter includes the depth of type class instance declarations.  Example:+     [W] d{7} : Eq [Int]+  That is d's dictionary-constraint depth is 7.  If we use the instance+     $dfEqList :: Eq a => Eq [a]+  to simplify it, we get+     d{7} = $dfEqList d'{8}+  where d'{8} : Eq Int, and d' has depth 8.++  For civilised (decidable) instance declarations, each increase of+  depth removes a type constructor from the type, so the depth never+  gets big; i.e. is bounded by the structural depth of the type.++* The counter also increments when resolving+equalities involving type functions. Example:+  Assume we have a wanted at depth 7:+    [W] d{7} : F () ~ a+  If there is a type function equation "F () = Int", this would be rewritten to+    [W] d{8} : Int ~ a+  and remembered as having depth 8.++  Again, without UndecidableInstances, this counter is bounded, but without it+  can resolve things ad infinitum. Hence there is a maximum level.++* Lastly, every time an equality is rewritten, the counter increases. Again,+  rewriting an equality constraint normally makes progress, but it's possible+  the "progress" is just the reduction of an infinitely-reducing type family.+  Hence we need to track the rewrites.++When compiling a program requires a greater depth, then GHC recommends turning+off this check entirely by setting -freduction-depth=0. This is because the+exact number that works is highly variable, and is likely to change even between+minor releases. Because this check is solely to prevent infinite compilation+times, it seems safe to disable it when a user has ascertained that their program+doesn't loop at the type level.++-}++-- | See Note [SubGoalDepth]+newtype SubGoalDepth = SubGoalDepth Int+  deriving (Eq, Ord, Outputable)++initialSubGoalDepth :: SubGoalDepth+initialSubGoalDepth = SubGoalDepth 0++bumpSubGoalDepth :: SubGoalDepth -> SubGoalDepth+bumpSubGoalDepth (SubGoalDepth n) = SubGoalDepth (n + 1)++maxSubGoalDepth :: SubGoalDepth -> SubGoalDepth -> SubGoalDepth+maxSubGoalDepth (SubGoalDepth n) (SubGoalDepth m) = SubGoalDepth (n `max` m)++subGoalDepthExceeded :: DynFlags -> SubGoalDepth -> Bool+subGoalDepthExceeded dflags (SubGoalDepth d)+  = mkIntWithInf d > reductionDepth dflags++{-+************************************************************************+*                                                                      *+            CtLoc+*                                                                      *+************************************************************************++The 'CtLoc' gives information about where a constraint came from.+This is important for decent error message reporting because+dictionaries don't appear in the original source code.++-}++data CtLoc = CtLoc { ctl_origin   :: CtOrigin+                   , ctl_env      :: TcLclEnv+                   , ctl_t_or_k   :: Maybe TypeOrKind  -- OK if we're not sure+                   , ctl_depth    :: !SubGoalDepth }++  -- The TcLclEnv includes particularly+  --    source location:  tcl_loc   :: RealSrcSpan+  --    context:          tcl_ctxt  :: [ErrCtxt]+  --    binder stack:     tcl_bndrs :: TcBinderStack+  --    level:            tcl_tclvl :: TcLevel++mkKindLoc :: TcType -> TcType   -- original *types* being compared+          -> CtLoc -> CtLoc+mkKindLoc s1 s2 loc = setCtLocOrigin (toKindLoc loc)+                        (KindEqOrigin s1 s2 (ctLocOrigin loc)+                                      (ctLocTypeOrKind_maybe loc))++-- | Take a CtLoc and moves it to the kind level+toKindLoc :: CtLoc -> CtLoc+toKindLoc loc = loc { ctl_t_or_k = Just KindLevel }++mkGivenLoc :: TcLevel -> SkolemInfoAnon -> TcLclEnv -> CtLoc+mkGivenLoc tclvl skol_info env+  = CtLoc { ctl_origin   = GivenOrigin skol_info+          , ctl_env      = setLclEnvTcLevel env tclvl+          , ctl_t_or_k   = Nothing    -- this only matters for error msgs+          , ctl_depth    = initialSubGoalDepth }  ctLocEnv :: CtLoc -> TcLclEnv ctLocEnv = ctl_env
GHC/Tc/Types/EvTerm.hs view
@@ -13,34 +13,26 @@ import GHC.Unit  import GHC.Builtin.Names-import GHC.Builtin.Types ( liftedRepTy, unitTy )+import GHC.Builtin.Types ( unitTy )  import GHC.Core.Type import GHC.Core import GHC.Core.Make import GHC.Core.Utils -import GHC.Types.Literal ( Literal(..) ) import GHC.Types.SrcLoc-import GHC.Types.Name import GHC.Types.TyThing -import GHC.Data.FastString- -- Used with Opt_DeferTypeErrors -- See Note [Deferring coercion errors to runtime] -- in GHC.Tc.Solver-evDelayedError :: Type -> FastString -> EvTerm+evDelayedError :: Type -> String -> EvTerm evDelayedError ty msg   = EvExpr $-    let fail_expr = Var errorId `mkTyApps` [liftedRepTy, unitTy] `mkApps` [litMsg]+    let fail_expr = mkRuntimeErrorApp tYPE_ERROR_ID unitTy msg     in mkWildCase fail_expr (unrestricted unitTy) ty []        -- See Note [Incompleteness and linearity] in GHC.HsToCore.Utils-       -- c.f. mkFailExpr in GHC.HsToCore.Utils--  where-    errorId = tYPE_ERROR_ID-    litMsg  = Lit (LitString (bytesFS msg))+       -- c.f. mkErrorAppDs in GHC.HsToCore.Utils  -- Dictionary for CallStack implicit parameters evCallStack :: (MonadThings m, HasModule m, HasDynFlags m) =>@@ -78,5 +70,5 @@         return (pushCS nameExpr locExpr (Cast tm ip_co))    case cs of-    EvCsPushCall name loc tm -> mkPush (occNameFS $ getOccName name) loc tm-    EvCsEmpty -> return emptyCS+    EvCsPushCall fs loc tm -> mkPush fs loc tm+    EvCsEmpty              -> return emptyCS
GHC/Tc/Types/Evidence.hs view
@@ -1,6 +1,6 @@ -- (c) The University of Glasgow 2006 -{-# LANGUAGE CPP, DeriveDataTypeable #-}+{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE LambdaCase #-}  module GHC.Tc.Types.Evidence (@@ -8,8 +8,9 @@   -- * HsWrapper   HsWrapper(..),   (<.>), mkWpTyApps, mkWpEvApps, mkWpEvVarApps, mkWpTyLams,-  mkWpLams, mkWpLet, mkWpCastN, mkWpCastR, collectHsWrapBinders,-  mkWpFun, idHsWrapper, isIdHsWrapper,+  mkWpLams, mkWpLet, mkWpFun, mkWpCastN, mkWpCastR,+  collectHsWrapBinders,+  idHsWrapper, isIdHsWrapper,   pprHsWrapper, hsWrapDictBinders,    -- * Evidence bindings@@ -43,7 +44,9 @@   mkTcReflCo, mkTcNomReflCo, mkTcRepReflCo,   mkTcTyConAppCo, mkTcAppCo, mkTcFunCo,   mkTcAxInstCo, mkTcUnbranchedAxInstCo, mkTcForAllCo, mkTcForAllCos,-  mkTcSymCo, mkTcSymMCo, mkTcTransCo, mkTcNthCo, mkTcLRCo, mkTcSubCo, maybeTcSymCo,+  mkTcSymCo, mkTcSymMCo,+  mkTcTransCo,+  mkTcNthCo, mkTcLRCo, mkTcSubCo, maybeTcSymCo,   maybeTcSubCo, tcDowngradeRole,   mkTcAxiomRuleCo, mkTcGReflRightCo, mkTcGReflRightMCo, mkTcGReflLeftCo, mkTcGReflLeftMCo,   mkTcPhantomCo,@@ -60,7 +63,6 @@   -- * QuoteWrapper   QuoteWrapper(..), applyQuoteWrapper, quoteWrapperTyVarTy   ) where-#include "HsVersions.h"  import GHC.Prelude @@ -78,7 +80,6 @@ import GHC.Types.Var.Env import GHC.Types.Var.Set import GHC.Core.Predicate-import GHC.Types.Name import GHC.Data.Pair import GHC.Types.Basic @@ -91,12 +92,16 @@ import GHC.Utils.Outputable  import GHC.Data.Bag+import GHC.Data.FastString+ import qualified Data.Data as Data import GHC.Types.SrcLoc import Data.IORef( IORef ) import GHC.Types.Unique.Set import GHC.Core.Multiplicity +import qualified Data.Semigroup as S+ {- Note [TcCoercions] ~~~~~~~~~~~~~~~~~~@@ -223,7 +228,7 @@        -- Hence  (\a. []) `WpCompose` (\b. []) = (\a b. [])        -- But    ([] a)   `WpCompose` ([] b)   = ([] b a) -  | WpFun HsWrapper HsWrapper (Scaled TcType) SDoc+  | WpFun HsWrapper HsWrapper (Scaled TcTypeFRR)        -- (WpFun wrap1 wrap2 (w, t1))[e] = \(x:_w t1). wrap2[ e wrap1[x] ]        -- So note that if  wrap1 :: exp_arg <= act_arg        --                  wrap2 :: act_res <= exp_res@@ -231,9 +236,8 @@        -- This isn't the same as for mkFunCo, but it has to be this way        -- because we can't use 'sym' to flip around these HsWrappers        -- The TcType is the "from" type of the first wrapper-       -- The SDoc explains the circumstances under which we have created this-       -- WpFun, in case we run afoul of levity polymorphism restrictions in-       -- the desugarer. See Note [Levity polymorphism checking] in GHC.HsToCore.Monad+       --+       -- Use 'mkWpFun' to construct such a wrapper.    | WpCast TcCoercionR        -- A cast:  [] `cast` co                               -- Guaranteed not the identity coercion@@ -254,100 +258,61 @@   | WpMultCoercion Coercion     -- Require that a Coercion be reflexive; otherwise,                                 -- error in the desugarer. See GHC.Tc.Utils.Unify                                 -- Note [Wrapper returned from tcSubMult]---- Cannot derive Data instance because SDoc is not Data (it stores a function).--- So we do it manually:-instance Data.Data HsWrapper where-  gfoldl _ z WpHole             = z WpHole-  gfoldl k z (WpCompose a1 a2)  = z WpCompose `k` a1 `k` a2-  gfoldl k z (WpFun a1 a2 a3 _) = z wpFunEmpty `k` a1 `k` a2 `k` a3-  gfoldl k z (WpCast a1)        = z WpCast `k` a1-  gfoldl k z (WpEvLam a1)       = z WpEvLam `k` a1-  gfoldl k z (WpEvApp a1)       = z WpEvApp `k` a1-  gfoldl k z (WpTyLam a1)       = z WpTyLam `k` a1-  gfoldl k z (WpTyApp a1)       = z WpTyApp `k` a1-  gfoldl k z (WpLet a1)         = z WpLet `k` a1-  gfoldl k z (WpMultCoercion a1) = z WpMultCoercion `k` a1--  gunfold k z c = case Data.constrIndex c of-                    1 -> z WpHole-                    2 -> k (k (z WpCompose))-                    3 -> k (k (k (z wpFunEmpty)))-                    4 -> k (z WpCast)-                    5 -> k (z WpEvLam)-                    6 -> k (z WpEvApp)-                    7 -> k (z WpTyLam)-                    8 -> k (z WpTyApp)-                    9 -> k (z WpLet)-                    _ -> k (z WpMultCoercion)--  toConstr WpHole          = wpHole_constr-  toConstr (WpCompose _ _) = wpCompose_constr-  toConstr (WpFun _ _ _ _) = wpFun_constr-  toConstr (WpCast _)      = wpCast_constr-  toConstr (WpEvLam _)     = wpEvLam_constr-  toConstr (WpEvApp _)     = wpEvApp_constr-  toConstr (WpTyLam _)     = wpTyLam_constr-  toConstr (WpTyApp _)     = wpTyApp_constr-  toConstr (WpLet _)       = wpLet_constr-  toConstr (WpMultCoercion _) = wpMultCoercion_constr--  dataTypeOf _ = hsWrapper_dataType--hsWrapper_dataType :: Data.DataType-hsWrapper_dataType-  = Data.mkDataType "HsWrapper"-      [ wpHole_constr, wpCompose_constr, wpFun_constr, wpCast_constr-      , wpEvLam_constr, wpEvApp_constr, wpTyLam_constr, wpTyApp_constr-      , wpLet_constr, wpMultCoercion_constr ]--wpHole_constr, wpCompose_constr, wpFun_constr, wpCast_constr, wpEvLam_constr,-  wpEvApp_constr, wpTyLam_constr, wpTyApp_constr, wpLet_constr,-  wpMultCoercion_constr :: Data.Constr-wpHole_constr    = mkHsWrapperConstr "WpHole"-wpCompose_constr = mkHsWrapperConstr "WpCompose"-wpFun_constr     = mkHsWrapperConstr "WpFun"-wpCast_constr    = mkHsWrapperConstr "WpCast"-wpEvLam_constr   = mkHsWrapperConstr "WpEvLam"-wpEvApp_constr   = mkHsWrapperConstr "WpEvApp"-wpTyLam_constr   = mkHsWrapperConstr "WpTyLam"-wpTyApp_constr   = mkHsWrapperConstr "WpTyApp"-wpLet_constr     = mkHsWrapperConstr "WpLet"-wpMultCoercion_constr     = mkHsWrapperConstr "WpMultCoercion"+  deriving Data.Data -mkHsWrapperConstr :: String -> Data.Constr-mkHsWrapperConstr name = Data.mkConstr hsWrapper_dataType name [] Data.Prefix+-- | The Semigroup instance is a bit fishy, since @WpCompose@, as a data+-- constructor, is "syntactic" and not associative. Concretely, if @a@, @b@,+-- and @c@ aren't @WpHole@:+--+-- > (a <> b) <> c ?= a <> (b <> c)+--+-- ==>+--+-- > (a `WpCompose` b) `WpCompose` c /= @ a `WpCompose` (b `WpCompose` c)+--+-- However these two associations are are "semantically equal" in the sense+-- that they produce equal functions when passed to+-- @GHC.HsToCore.Binds.dsHsWrapper@.+instance S.Semigroup HsWrapper where+  (<>) = (<.>) -wpFunEmpty :: HsWrapper -> HsWrapper -> Scaled TcType -> HsWrapper-wpFunEmpty c1 c2 t1 = WpFun c1 c2 t1 empty+instance Monoid HsWrapper where+  mempty = WpHole  (<.>) :: HsWrapper -> HsWrapper -> HsWrapper WpHole <.> c = c c <.> WpHole = c c1 <.> c2    = c1 `WpCompose` c2 +-- | Smart constructor to create a 'WpFun' 'HsWrapper'.+--+-- PRECONDITION: the "from" type of the first wrapper must have a syntactically+-- fixed RuntimeRep (see Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete). mkWpFun :: HsWrapper -> HsWrapper-        -> (Scaled TcType)    -- the "from" type of the first wrapper-        -> TcType    -- either type of the second wrapper (used only when the-                     -- second wrapper is the identity)-        -> SDoc      -- what caused you to want a WpFun? Something like "When converting ..."+        -> Scaled TcTypeFRR -- ^ the "from" type of the first wrapper+                            -- MUST have a fixed RuntimeRep+        -> TcType           -- ^ either type of the second wrapper (used only when the+                            -- second wrapper is the identity)         -> HsWrapper-mkWpFun WpHole       WpHole       _  _  _ = WpHole-mkWpFun WpHole       (WpCast co2) (Scaled w t1) _  _ = WpCast (mkTcFunCo Representational (multToCo w) (mkTcRepReflCo t1) co2)-mkWpFun (WpCast co1) WpHole       (Scaled w _)  t2 _ = WpCast (mkTcFunCo Representational (multToCo w) (mkTcSymCo co1) (mkTcRepReflCo t2))-mkWpFun (WpCast co1) (WpCast co2) (Scaled w _)  _  _ = WpCast (mkTcFunCo Representational (multToCo w) (mkTcSymCo co1) co2)-mkWpFun co1          co2          t1 _  d = WpFun co1 co2 t1 d+  -- NB: we can't check that the argument type has a fixed RuntimeRep with an assertion,+  -- because of [Wrinkle: Typed Template Haskell] in Note [hasFixedRuntimeRep]+  -- in GHC.Tc.Utils.Concrete.+mkWpFun WpHole       WpHole       _             _  = WpHole+mkWpFun WpHole       (WpCast co2) (Scaled w t1) _  = WpCast (mkTcFunCo Representational (multToCo w) (mkTcRepReflCo t1) co2)+mkWpFun (WpCast co1) WpHole       (Scaled w _)  t2 = WpCast (mkTcFunCo Representational (multToCo w) (mkTcSymCo co1) (mkTcRepReflCo t2))+mkWpFun (WpCast co1) (WpCast co2) (Scaled w _)  _  = WpCast (mkTcFunCo Representational (multToCo w) (mkTcSymCo co1) co2)+mkWpFun co1          co2          t1            _  = WpFun co1 co2 t1  mkWpCastR :: TcCoercionR -> HsWrapper mkWpCastR co   | isTcReflCo co = WpHole-  | otherwise     = ASSERT2(tcCoercionRole co == Representational, ppr co)+  | otherwise     = assertPpr (tcCoercionRole co == Representational) (ppr co) $                     WpCast co  mkWpCastN :: TcCoercionN -> HsWrapper mkWpCastN co   | isTcReflCo co = WpHole-  | otherwise     = ASSERT2(tcCoercionRole co == Nominal, ppr co)+  | otherwise     = assertPpr (tcCoercionRole co == Nominal) (ppr co) $                     WpCast (mkTcSubCo co)     -- The mkTcSubCo converts Nominal to Representational @@ -399,7 +364,7 @@  where    go (WpEvLam dict_id)   = unitBag dict_id    go (w1 `WpCompose` w2) = go w1 `unionBags` go w2-   go (WpFun _ w _ _)     = go w+   go (WpFun _ w _)       = go w    go WpHole              = emptyBag    go (WpCast  {})        = emptyBag    go (WpEvApp {})        = emptyBag@@ -641,7 +606,7 @@     -- given a dictionaries for @s@ and @t@.    | EvTypeableTrFun EvTerm EvTerm EvTerm-    -- ^ Dictionary for @Typeable (s # w -> t)@,+    -- ^ Dictionary for @Typeable (s % w -> t)@,     -- given a dictionaries for @w@, @s@, and @t@.    | EvTypeableTyLit EvTerm@@ -655,9 +620,14 @@ data EvCallStack   -- See Note [Overview of implicit CallStacks]   = EvCsEmpty-  | EvCsPushCall Name RealSrcSpan EvExpr-    -- ^ @EvCsPushCall name loc stk@ represents a call to @name@, occurring at-    -- @loc@, in a calling context @stk@.+  | EvCsPushCall+        FastString   -- Usually the name of the function being called+                     --   but can also be "the literal 42"+                     --   or "an if-then-else expression", etc+        RealSrcSpan  -- Location of the call+        EvExpr       -- Rest of the stack+    -- ^ @EvCsPushCall origin loc stk@ represents a call from @origin@,+    --  occurring at @loc@, in a calling context @stk@.   deriving Data.Data  {-@@ -741,7 +711,7 @@   Note [Overview of implicit CallStacks]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ (See https://gitlab.haskell.org/ghc/ghc/wikis/explicit-call-stack/implicit-locations)  The goal of CallStack evidence terms is to reify locations@@ -754,9 +724,12 @@ Implicit parameters of type GHC.Stack.Types.CallStack (the name is not important) are solved in three steps: -1. Occurrences of CallStack IPs are solved directly from the given IP,-   just like a regular IP. For example, the occurrence of `?stk` in+1. Explicit, user-written occurrences of `?stk :: CallStack`+   which have IPOccOrigin, are solved directly from the given IP,+   just like a regular IP; see GHC.Tc.Solver.Interact.interactDict. +   For example, the occurrence of `?stk` in+      error :: (?stk :: CallStack) => String -> a      error s = raise (ErrorCall (s ++ prettyCallStack ?stk)) @@ -766,30 +739,42 @@    append the current call-site to it. For example, consider a    call to the callstack-aware `error` above. -     undefined :: (?stk :: CallStack) => a-     undefined = error "undefined!"+     foo :: (?stk :: CallStack) => a+     foo = error "undefined!"     Here we want to take the given `?stk` and append the current    call-site, before passing it to `error`. In essence, we want to-   rewrite `error "undefined!"` to+   rewrite `foo "undefined!"` to -     let ?stk = pushCallStack <error's location> ?stk-     in error "undefined!"+     let ?stk = pushCallStack <foo's location> ?stk+     in foo "undefined!" -   We achieve this effect by emitting a NEW wanted+   We achieve this as follows: -     [W] d :: IP "stk" CallStack+   * At a call of foo :: (?stk :: CallStack) => blah+     we emit a Wanted+        [W] d1 : IP "stk" CallStack+     with CtOrigin = OccurrenceOf "foo" -   from which we build the evidence term+   * We /solve/ this constraint, in GHC.Tc.Solver.Canonical.canClassNC+     by emitting a NEW Wanted+        [W] d2 :: IP "stk" CallStack+     with CtOrigin = IPOccOrigin -     EvCsPushCall "error" <error's location> (EvId d)+     and solve d1 = EvCsPushCall "foo" <foo's location> (EvId d1) -   that we use to solve the call to `error`. The new wanted `d` will-   then be solved per rule (1), ie as a regular IP.+   * The new Wanted, for `d2` will be solved per rule (1), ie as a regular IP. -   (see GHC.Tc.Solver.Interact.interactDict)+3. We use the predicate isPushCallStackOrigin to identify whether we+   want to do (1) solve directly, or (2) push and then solve directly.+   Key point (see #19918): the CtOrigin where we want to push an item on the+   call stack can include IfThenElseOrigin etc, when RebindableSyntax is+   involved.  See the defn of fun_orig in GHC.Tc.Gen.App.tcInstFun; it is+   this CtOrigin that is pinned on the constraints generated by functions+   in the "expansion" for rebindable syntax. c.f. GHC.Rename.Expr+   Note [Handling overloaded and rebindable constructs] -3. We default any insoluble CallStacks to the empty CallStack. Suppose+4. We default any insoluble CallStacks to the empty CallStack. Suppose    `undefined` did not request a CallStack, ie       undefinedNoStk :: a@@ -827,7 +812,7 @@ - GHC should NEVER report an insoluble CallStack constraint.  - GHC should NEVER infer a CallStack constraint unless one was requested-  with a partial type signature (See TcType.pickQuantifiablePreds).+  with a partial type signature (See GHC.Tc.Solver..pickQuantifiablePreds).  - A CallStack (defined in GHC.Stack.Types) is a [(String, SrcLoc)],   where the String is the name of the binder that is used at the@@ -866,8 +851,8 @@  mkEvCast :: EvExpr -> TcCoercion -> EvTerm mkEvCast ev lco-  | ASSERT2( tcCoercionRole lco == Representational-           , (vcat [text "Coercion of wrong role passed to mkEvCast:", ppr ev, ppr lco]))+  | assertPpr (tcCoercionRole lco == Representational)+              (vcat [text "Coercion of wrong role passed to mkEvCast:", ppr ev, ppr lco]) $     isTcReflCo lco = EvExpr ev   | otherwise      = evCast ev lco @@ -992,8 +977,8 @@     -- False <=> appears as body of let or lambda     help it WpHole             = it     help it (WpCompose f1 f2)  = help (help it f2) f1-    help it (WpFun f1 f2 (Scaled w t1) _) = add_parens $ text "\\(x" <> dcolon <> brackets (ppr w) <> ppr t1 <> text ")." <+>-                                              help (\_ -> it True <+> help (\_ -> text "x") f1 True) f2 False+    help it (WpFun f1 f2 (Scaled w t1)) = add_parens $ text "\\(x" <> dcolon <> brackets (ppr w) <> ppr t1 <> text ")." <+>+                                            help (\_ -> it True <+> help (\_ -> text "x") f1 True) f2 False     help it (WpCast co)   = add_parens $ sep [it False, nest 2 (text "|>"                                               <+> pprParendCo co)]     help it (WpEvApp id)  = no_parens  $ sep [it True, nest 2 (ppr id)]@@ -1043,8 +1028,8 @@ instance Outputable EvCallStack where   ppr EvCsEmpty     = text "[]"-  ppr (EvCsPushCall name loc tm)-    = ppr (name,loc) <+> text ":" <+> ppr tm+  ppr (EvCsPushCall orig loc tm)+    = ppr (orig,loc) <+> text ":" <+> ppr tm  instance Outputable EvTypeable where   ppr (EvTypeableTyCon ts _)  = text "TyCon" <+> ppr ts@@ -1057,12 +1042,10 @@ -- Helper functions for dealing with IP newtype-dictionaries ---------------------------------------------------------------------- --- | Create a 'Coercion' that unwraps an implicit-parameter or--- overloaded-label dictionary to expose the underlying value. We--- expect the 'Type' to have the form `IP sym ty` or `IsLabel sym ty`,--- and return a 'Coercion' `co :: IP sym ty ~ ty` or--- `co :: IsLabel sym ty ~ ty`.  See also--- Note [Type-checking overloaded labels] in "GHC.Tc.Gen.Expr".+-- | Create a 'Coercion' that unwraps an implicit-parameter+-- dictionary to expose the underlying value.+-- We expect the 'Type' to have the form `IP sym ty`,+-- and return a 'Coercion' `co :: IP sym ty ~ ty` unwrapIP :: Type -> CoercionR unwrapIP ty =   case unwrapNewTyCon_maybe tc of
GHC/Tc/Types/Origin.hs view
@@ -1,5 +1,7 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE PolyKinds #-}  {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}@@ -7,21 +9,36 @@ -- | Describes the provenance of types as they flow through the type-checker. -- The datatypes here are mainly used for error message generation. module GHC.Tc.Types.Origin (-  -- UserTypeCtxt+  -- * UserTypeCtxt   UserTypeCtxt(..), pprUserTypeCtxt, isSigMaybe,+  ReportRedundantConstraints(..), reportRedundantConstraints,+  redundantConstraintsSpan, -  -- SkolemInfo-  SkolemInfo(..), pprSigSkolInfo, pprSkolInfo,+  -- * SkolemInfo+  SkolemInfo(..), SkolemInfoAnon(..), mkSkolemInfo, getSkolemInfo, pprSigSkolInfo, pprSkolInfo,+  unkSkol, unkSkolAnon, -  -- CtOrigin+  -- * CtOrigin   CtOrigin(..), exprCtOrigin, lexprCtOrigin, matchesCtOrigin, grhssCtOrigin,   isVisibleOrigin, toInvisibleOrigin,-  pprCtOrigin, isGivenOrigin+  pprCtOrigin, isGivenOrigin, isWantedWantedFunDepOrigin,+  isWantedSuperclassOrigin, -  ) where+  TypedThing(..), TyVarBndrs(..), -#include "HsVersions.h"+  -- * CtOrigin and CallStack+  isPushCallStackOrigin, callStackOriginFS,+  -- * FixedRuntimeRep origin+  FixedRuntimeRepOrigin(..), FixedRuntimeRepContext(..),+  pprFixedRuntimeRepContext,+  StmtOrigin(..), +  -- * Arrow command origin+  FRRArrowContext(..), pprFRRArrowContext,+  ExpectedFunTyOrigin(..), pprExpectedFunTyOrigin, pprExpectedFunTyHerald,++  ) where+ import GHC.Prelude  import GHC.Tc.Utils.TcType@@ -46,7 +63,10 @@  import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Driver.Ppr+import GHC.Stack+import GHC.Utils.Monad+import GHC.Types.Unique+import GHC.Types.Unique.Supply  {- ********************************************************************* *                                                                      *@@ -61,17 +81,16 @@   = FunSigCtxt      -- Function type signature, when checking the type                     -- Also used for types in SPECIALISE pragmas        Name              -- Name of the function-       Bool              -- True <=> report redundant constraints-                            -- This is usually True, but False for-                            --   * Record selectors (not important here)-                            --   * Class and instance methods.  Here-                            --     the code may legitimately be more-                            --     polymorphic than the signature-                            --     generated from the class-                            --     declaration+       ReportRedundantConstraints+         -- This is usually 'WantRCC', but 'NoRCC' for+         --   * Record selectors (not important here)+         --   * Class and instance methods.  Here the code may legitimately+         --     be more polymorphic than the signature generated from the+         --     class declaration    | InfSigCtxt Name     -- Inferred type for function   | ExprSigCtxt         -- Expression type signature+      ReportRedundantConstraints   | KindSigCtxt         -- Kind signature   | StandaloneKindSigCtxt  -- Standalone kind signature        Name                -- Name of the type/class@@ -82,7 +101,7 @@   | PatSigCtxt          -- Type sig in pattern                         --   eg  f (x::t) = ...                         --   or  (x::t, y) = e-  | RuleSigCtxt Name    -- LHS of a RULE forall+  | RuleSigCtxt FastString Name    -- LHS of a RULE forall                         --    RULE "foo" forall (x :: a -> a). f (Just x) = ...   | ForSigCtxt Name     -- Foreign import or export signature   | DefaultDeclCtxt     -- Types in a default declaration@@ -109,7 +128,26 @@   | DataKindCtxt Name   -- The kind of a data/newtype (instance)   | TySynKindCtxt Name  -- The kind of the RHS of a type synonym   | TyFamResKindCtxt Name   -- The result kind of a type family+  deriving( Eq ) -- Just for checkSkolInfoAnon +-- | Report Redundant Constraints.+data ReportRedundantConstraints+  = NoRRC            -- ^ Don't report redundant constraints+  | WantRRC SrcSpan  -- ^ Report redundant constraints, and here+                     -- is the SrcSpan for the constraints+                     -- E.g. f :: (Eq a, Ord b) => blah+                     -- The span is for the (Eq a, Ord b)+  deriving( Eq )  -- Just for checkSkolInfoAnon++reportRedundantConstraints :: ReportRedundantConstraints -> Bool+reportRedundantConstraints NoRRC        = False+reportRedundantConstraints (WantRRC {}) = True++redundantConstraintsSpan :: UserTypeCtxt -> SrcSpan+redundantConstraintsSpan (FunSigCtxt _ (WantRRC span)) = span+redundantConstraintsSpan (ExprSigCtxt (WantRRC span))  = span+redundantConstraintsSpan _ = noSrcSpan+ {- -- Notes re TySynCtxt -- We allow type synonyms that aren't types; e.g.  type List = []@@ -126,8 +164,8 @@ pprUserTypeCtxt :: UserTypeCtxt -> SDoc pprUserTypeCtxt (FunSigCtxt n _)  = text "the type signature for" <+> quotes (ppr n) pprUserTypeCtxt (InfSigCtxt n)    = text "the inferred type for" <+> quotes (ppr n)-pprUserTypeCtxt (RuleSigCtxt n)   = text "the type signature for" <+> quotes (ppr n)-pprUserTypeCtxt ExprSigCtxt       = text "an expression type signature"+pprUserTypeCtxt (RuleSigCtxt _ n) = text "the type signature for" <+> quotes (ppr n)+pprUserTypeCtxt (ExprSigCtxt _)   = text "an expression type signature" pprUserTypeCtxt KindSigCtxt       = text "a kind signature" pprUserTypeCtxt (StandaloneKindSigCtxt n) = text "a standalone kind signature for" <+> quotes (ppr n) pprUserTypeCtxt TypeAppCtxt       = text "a type argument"@@ -166,10 +204,31 @@ ************************************************************************ -} --- SkolemInfo gives the origin of *given* constraints---   a) type variables are skolemised---   b) an implication constraint is generated+-- | 'SkolemInfo' stores the origin of a skolem type variable,+-- so that we can display this information to the user in case of a type error.+--+-- The 'Unique' field allows us to report all skolem type variables bound in the+-- same place in a single report. data SkolemInfo+  = SkolemInfo+      Unique -- ^ used to common up skolem variables bound at the same location (only used in pprSkols)+      SkolemInfoAnon -- ^ the information about the origin of the skolem type variable++instance Uniquable SkolemInfo where+  getUnique (SkolemInfo u _) = u++-- | 'SkolemInfoAnon' stores the origin of a skolem type variable (e.g. bound by+-- a user-written forall, the header of a data declaration, a deriving clause, ...).+--+-- This information is displayed when reporting an error message, such as+--+--  @"Couldn't match 'k' with 'l'"@+--+-- This allows us to explain where the type variable came from.+--+-- When several skolem type variables are bound at once, prefer using 'SkolemInfo',+-- which stores a 'Unique' which allows these type variables to be reported+data SkolemInfoAnon   = SigSkol -- A skolem that is created by instantiating             -- a programmer-supplied type signature             -- Location of the binding site is on the TyVar@@ -184,8 +243,8 @@                  -- hence, we have less info    | ForAllSkol  -- Bound by a user-written "forall".-       SDoc        -- Shows just the binders, used when reporting a bad telescope-                   -- See Note [Checking telescopes] in GHC.Tc.Types.Constraint+      TyVarBndrs   -- Shows just the binders, used when reporting a bad telescope+                    -- See Note [Checking telescopes] in GHC.Tc.Types.Constraint    | DerivSkol Type      -- Bound by a 'deriving' clause;                         -- the type is the instance we are trying to derive@@ -195,14 +254,12 @@   | FamInstSkol         -- Bound at a family instance decl   | PatSkol             -- An existential type variable bound by a pattern for       ConLike           -- a data constructor with an existential type.-      (HsMatchContext GhcRn)+      (HsMatchContext GhcTc)              -- e.g.   data T = forall a. Eq a => MkT a              --        f (MkT x) = ...              -- The pattern MkT x will allocate an existential type              -- variable for 'a'. -  | ArrowSkol           -- An arrow form (see GHC.Tc.Gen.Arrow)-   | IPSkol [HsIPName]   -- Binding site of an implicit parameter    | RuleSkol RuleName   -- The LHS of a RULE@@ -229,16 +286,45 @@    | RuntimeUnkSkol      -- Runtime skolem from the GHCi debugger      #14628 -  | UnkSkol             -- Unhelpful info (until I improve it)+  | ArrowReboundIfSkol  -- Bound by the expected type of the rebound arrow ifThenElse command. +  | UnkSkol CallStack+++-- | Use this when you can't specify a helpful origin for+-- some skolem type variable.+--+-- We're hoping to be able to get rid of this entirely, but for the moment+-- it's still needed.+unkSkol :: HasCallStack => SkolemInfo+unkSkol = SkolemInfo (mkUniqueGrimily 0) unkSkolAnon++unkSkolAnon :: HasCallStack => SkolemInfoAnon+unkSkolAnon = UnkSkol callStack++-- | Wrap up the origin of a skolem type variable with a new 'Unique',+-- so that we can common up skolem type variables whose 'SkolemInfo'+-- shares a certain 'Unique'.+mkSkolemInfo :: MonadIO m => SkolemInfoAnon -> m SkolemInfo+mkSkolemInfo sk_anon = do+  u <- liftIO $! uniqFromMask 's'+  return (SkolemInfo u sk_anon)++getSkolemInfo :: SkolemInfo -> SkolemInfoAnon+getSkolemInfo (SkolemInfo _ skol_anon) = skol_anon++ instance Outputable SkolemInfo where+  ppr (SkolemInfo _ sk_info ) = ppr sk_info++instance Outputable SkolemInfoAnon where   ppr = pprSkolInfo -pprSkolInfo :: SkolemInfo -> SDoc+pprSkolInfo :: SkolemInfoAnon -> SDoc -- Complete the sentence "is a rigid type variable bound by..." pprSkolInfo (SigSkol cx ty _) = pprSigSkolInfo cx ty pprSkolInfo (SigTypeSkol cx)  = pprUserTypeCtxt cx-pprSkolInfo (ForAllSkol tvs)  = text "an explicit forall" <+> tvs+pprSkolInfo (ForAllSkol tvs)  = text "an explicit forall" <+> ppr tvs pprSkolInfo (IPSkol ips)      = text "the implicit-parameter binding" <> plural ips <+> text "for"                                  <+> pprWithCommas ppr ips pprSkolInfo (DerivSkol pred)  = text "the deriving clause for" <+> quotes (ppr pred)@@ -246,25 +332,26 @@ pprSkolInfo FamInstSkol       = text "a family instance declaration" pprSkolInfo BracketSkol       = text "a Template Haskell bracket" pprSkolInfo (RuleSkol name)   = text "the RULE" <+> pprRuleName name-pprSkolInfo ArrowSkol         = text "an arrow form" pprSkolInfo (PatSkol cl mc)   = sep [ pprPatSkolInfo cl                                     , text "in" <+> pprMatchContext mc ] pprSkolInfo (InferSkol ids)   = hang (text "the inferred type" <> plural ids <+> text "of")                                    2 (vcat [ ppr name <+> dcolon <+> ppr ty                                            | (name,ty) <- ids ])-pprSkolInfo (UnifyForAllSkol ty) = text "the type" <+> ppr ty+pprSkolInfo (UnifyForAllSkol ty)  = text "the type" <+> ppr ty pprSkolInfo (TyConSkol flav name) = text "the" <+> ppr flav <+> text "declaration for" <+> quotes (ppr name)-pprSkolInfo (DataConSkol name)= text "the data constructor" <+> quotes (ppr name)-pprSkolInfo ReifySkol         = text "the type being reified"+pprSkolInfo (DataConSkol name)    = text "the type signature for" <+> quotes (ppr name)+pprSkolInfo ReifySkol             = text "the type being reified"  pprSkolInfo (QuantCtxtSkol {}) = text "a quantified context" pprSkolInfo RuntimeUnkSkol     = text "Unknown type from GHCi runtime"+pprSkolInfo ArrowReboundIfSkol = text "the expected type of a rebound if-then-else command" --- UnkSkol+-- unkSkol -- For type variables the others are dealt with by pprSkolTvBinding. -- For Insts, these cases should not happen-pprSkolInfo UnkSkol = WARN( True, text "pprSkolInfo: UnkSkol" ) text "UnkSkol"+pprSkolInfo (UnkSkol cs) = text "UnkSkol (please report this as a bug)" $$ prettyCallStackDoc cs + pprSigSkolInfo :: UserTypeCtxt -> TcType -> SDoc -- The type is already tidied pprSigSkolInfo ctxt ty@@ -333,10 +420,36 @@ ************************************************************************ -} +-- | Some thing which has a type.+--+-- This datatype is used when we want to report to the user+-- that something has an unexpected type.+data TypedThing+  = HsTypeRnThing (HsType GhcRn)+  | TypeThing Type+  | HsExprRnThing (HsExpr GhcRn)+  | NameThing Name++-- | Some kind of type variable binder.+--+-- Used for reporting errors, in 'SkolemInfo' and 'TcSolverReportMsg'.+data TyVarBndrs+  = forall flag. OutputableBndrFlag flag 'Renamed =>+      HsTyVarBndrsRn [HsTyVarBndr flag GhcRn]++instance Outputable TypedThing where+  ppr (HsTypeRnThing ty) = ppr ty+  ppr (TypeThing ty) = ppr ty+  ppr (HsExprRnThing expr) = ppr expr+  ppr (NameThing name) = ppr name++instance Outputable TyVarBndrs where+  ppr (HsTyVarBndrsRn bndrs) = fsep (map ppr bndrs)+ data CtOrigin   = -- | A given constraint from a user-written type signature. The     -- 'SkolemInfo' inside gives more information.-    GivenOrigin SkolemInfo+    GivenOrigin SkolemInfoAnon    -- The following are other origins for given constraints that cannot produce   -- new skolems -- hence no SkolemInfo.@@ -367,7 +480,7 @@   -- Note [Use only the best local instance], both in GHC.Tc.Solver.Interact.   | OtherSCOrigin ScDepth -- ^ The number of superclass selections necessary to                           -- get this constraint-                  SkolemInfo   -- ^ Where the sub-class constraint arose from+                  SkolemInfoAnon   -- ^ Where the sub-class constraint arose from                                -- (used only for printing)    -- All the others are for *wanted* constraints@@ -379,9 +492,10 @@   | SpecPragOrigin UserTypeCtxt    -- Specialisation pragma for                                    -- function or instance +   | TypeEqOrigin { uo_actual   :: TcType                  , uo_expected :: TcType-                 , uo_thing    :: Maybe SDoc+                 , uo_thing    :: Maybe TypedThing                        -- ^ The thing that has type "actual"                  , uo_visible  :: Bool                        -- ^ Is at least one of the three elements above visible?@@ -403,6 +517,8 @@   | ArithSeqOrigin (ArithSeqInfo GhcRn) -- [x..], [x..y] etc   | AssocFamPatOrigin   -- When matching the patterns of an associated                         -- family instance with that of its parent class+                        -- IMPORTANT: These constraints will never cause errors;+                        -- See Note [Constraints to ignore] in GHC.Tc.Errors   | SectionOrigin   | HasFieldOrigin FastString   | TupleOrigin         -- (..,..)@@ -447,8 +563,8 @@   | MCompOrigin         -- Arising from a monad comprehension   | MCompPatOrigin (LPat GhcRn) -- Arising from a failable pattern in a                                 -- monad comprehension-  | IfOrigin            -- Arising from an if statement   | ProcOrigin          -- Arising from a proc expression+  | ArrowCmdOrigin      -- Arising from an arrow command   | AnnOrigin           -- An annotation    | FunDepOrigin1       -- A functional dependency from combining@@ -461,32 +577,48 @@         -- We only need a CtOrigin on the first, because the location         -- is pinned on the entire error message +  | InjTFOrigin1    -- injective type family equation combining+      PredType CtOrigin RealSrcSpan    -- This constraint arising from ...+      PredType CtOrigin RealSrcSpan    -- and this constraint arising from ...+   | ExprHoleOrigin (Maybe OccName)   -- from an expression hole   | TypeHoleOrigin OccName   -- from a type hole (partial type signature)   | PatCheckOrigin      -- normalisation of a type during pattern-match checking   | ListOrigin          -- An overloaded list+  | IfThenElseOrigin    -- An if-then-else expression   | BracketOrigin       -- An overloaded quotation bracket   | StaticOrigin        -- A static form   | Shouldn'tHappenOrigin String-                            -- the user should never see this one,-                            -- unless ImpredicativeTypes is on, where all-                            -- bets are off-  | InstProvidedOrigin Module ClsInst-        -- Skolem variable arose when we were testing if an instance-        -- is solvable or not.+                            -- the user should never see this one+  | GhcBug20076             -- see #20076++  -- | Testing whether the constraint associated with an instance declaration+  -- in a signature file is satisfied upon instantiation.+  --+  -- Test cases: backpack/should_fail/bkpfail{11,43}.bkp+  | InstProvidedOrigin+      Module  -- ^ Module in which the instance was declared+      ClsInst -- ^ The declared typeclass instance+   | NonLinearPatternOrigin   | UsageEnvironmentOf Name    | CycleBreakerOrigin       CtOrigin   -- origin of the original constraint       -- See Detail (7) of Note [Type equality cycles] in GHC.Tc.Solver.Canonical+  | FRROrigin+      FixedRuntimeRepOrigin +  | WantedSuperclassOrigin PredType CtOrigin+        -- From expanding out the superclasses of a Wanted; the PredType+        -- is the subclass predicate, and the origin+        -- of the original Wanted is the CtOrigin+   | InstanceSigOrigin   -- from the sub-type check of an InstanceSig       Name   -- the method name       Type   -- the instance-sig type       Type   -- the instantiated type of the method   | AmbiguityCheckOrigin UserTypeCtxt-  | GhcBug20076  -- | The number of superclass selections needed to get this Given. -- If @d :: C ty@   has @ScDepth=2@, then the evidence @d@ will look@@ -512,11 +644,23 @@ isGivenOrigin (GivenOrigin {})              = True isGivenOrigin (InstSCOrigin {})             = True isGivenOrigin (OtherSCOrigin {})            = True-isGivenOrigin (FunDepOrigin1 _ o1 _ _ o2 _) = isGivenOrigin o1 && isGivenOrigin o2-isGivenOrigin (FunDepOrigin2 _ o1 _ _)      = isGivenOrigin o1 isGivenOrigin (CycleBreakerOrigin o)        = isGivenOrigin o isGivenOrigin _                             = False +-- See Note [Suppressing confusing errors] in GHC.Tc.Errors+isWantedWantedFunDepOrigin :: CtOrigin -> Bool+isWantedWantedFunDepOrigin (FunDepOrigin1 _ orig1 _ _ orig2 _)+  = not (isGivenOrigin orig1) && not (isGivenOrigin orig2)+isWantedWantedFunDepOrigin (InjTFOrigin1 _ orig1 _ _ orig2 _)+  = not (isGivenOrigin orig1) && not (isGivenOrigin orig2)+isWantedWantedFunDepOrigin _ = False++-- | Did a constraint arise from expanding a Wanted constraint+-- to look at superclasses?+isWantedSuperclassOrigin :: CtOrigin -> Bool+isWantedSuperclassOrigin (WantedSuperclassOrigin {}) = True+isWantedSuperclassOrigin _                           = False+ instance Outputable CtOrigin where   ppr = pprCtOrigin @@ -529,45 +673,41 @@  exprCtOrigin :: HsExpr GhcRn -> CtOrigin exprCtOrigin (HsVar _ (L _ name)) = OccurrenceOf name-exprCtOrigin (HsGetField _ _ (L _ f)) = HasFieldOrigin (unLoc $ hflLabel f)+exprCtOrigin (HsGetField _ _ (L _ f)) = HasFieldOrigin (unLoc $ dfoLabel f) exprCtOrigin (HsUnboundVar {})    = Shouldn'tHappenOrigin "unbound variable"-exprCtOrigin (HsConLikeOut {})    = panic "exprCtOrigin HsConLikeOut"-exprCtOrigin (HsRecFld _ f)       = OccurrenceOfRecSel (rdrNameAmbiguousFieldOcc f)+exprCtOrigin (HsRecSel _ f)       = OccurrenceOfRecSel (unLoc $ foLabel f) exprCtOrigin (HsOverLabel _ l)    = OverLabelOrigin l exprCtOrigin (ExplicitList {})    = ListOrigin exprCtOrigin (HsIPVar _ ip)       = IPOccOrigin ip exprCtOrigin (HsOverLit _ lit)    = LiteralOrigin lit exprCtOrigin (HsLit {})           = Shouldn'tHappenOrigin "concrete literal" exprCtOrigin (HsLam _ matches)    = matchesCtOrigin matches-exprCtOrigin (HsLamCase _ ms)     = matchesCtOrigin ms+exprCtOrigin (HsLamCase _ _ ms)   = matchesCtOrigin ms exprCtOrigin (HsApp _ e1 _)       = lexprCtOrigin e1 exprCtOrigin (HsAppType _ e1 _)   = lexprCtOrigin e1 exprCtOrigin (OpApp _ _ op _)     = lexprCtOrigin op exprCtOrigin (NegApp _ e _)       = lexprCtOrigin e-exprCtOrigin (HsPar _ e)          = lexprCtOrigin e+exprCtOrigin (HsPar _ _ e _)      = lexprCtOrigin e exprCtOrigin (HsProjection _ _)   = SectionOrigin exprCtOrigin (SectionL _ _ _)     = SectionOrigin exprCtOrigin (SectionR _ _ _)     = SectionOrigin exprCtOrigin (ExplicitTuple {})   = Shouldn'tHappenOrigin "explicit tuple" exprCtOrigin ExplicitSum{}        = Shouldn'tHappenOrigin "explicit sum" exprCtOrigin (HsCase _ _ matches) = matchesCtOrigin matches-exprCtOrigin (HsIf {})           = Shouldn'tHappenOrigin "if expression"+exprCtOrigin (HsIf {})           = IfThenElseOrigin exprCtOrigin (HsMultiIf _ rhs)   = lGRHSCtOrigin rhs-exprCtOrigin (HsLet _ _ e)       = lexprCtOrigin e+exprCtOrigin (HsLet _ _ _ _ e)   = lexprCtOrigin e exprCtOrigin (HsDo {})           = DoOrigin exprCtOrigin (RecordCon {})      = Shouldn'tHappenOrigin "record construction" exprCtOrigin (RecordUpd {})      = RecordUpdOrigin exprCtOrigin (ExprWithTySig {})  = ExprSigOrigin exprCtOrigin (ArithSeq {})       = Shouldn'tHappenOrigin "arithmetic sequence" exprCtOrigin (HsPragE _ _ e)     = lexprCtOrigin e-exprCtOrigin (HsBracket {})      = Shouldn'tHappenOrigin "TH bracket"-exprCtOrigin (HsRnBracketOut {})= Shouldn'tHappenOrigin "HsRnBracketOut"-exprCtOrigin (HsTcBracketOut {})= panic "exprCtOrigin HsTcBracketOut"+exprCtOrigin (HsTypedBracket {}) = Shouldn'tHappenOrigin "TH typed bracket"+exprCtOrigin (HsUntypedBracket {}) = Shouldn'tHappenOrigin "TH untyped bracket" exprCtOrigin (HsSpliceE {})      = Shouldn'tHappenOrigin "TH splice" exprCtOrigin (HsProc {})         = Shouldn'tHappenOrigin "proc" exprCtOrigin (HsStatic {})       = Shouldn'tHappenOrigin "static expression"-exprCtOrigin (HsTick _ _ e)           = lexprCtOrigin e-exprCtOrigin (HsBinTick _ _ _ e)      = lexprCtOrigin e exprCtOrigin (XExpr (HsExpanded a _)) = exprCtOrigin a  -- | Extract a suitable CtOrigin from a MatchGroup@@ -591,7 +731,6 @@  pprCtOrigin :: CtOrigin -> SDoc -- "arising from ..."--- Not an instance of Outputable because of the "arising from" prefix pprCtOrigin (GivenOrigin sk)     = ctoHerald <+> ppr sk pprCtOrigin (InstSCOrigin {})    = ctoHerald <+> pprSkolInfo InstSkol   -- keep output in sync pprCtOrigin (OtherSCOrigin _ si) = ctoHerald <+> pprSkolInfo si@@ -614,11 +753,17 @@                , hang (text "instance" <+> quotes (ppr pred2))                     2 (text "at" <+> ppr loc2) ]) +pprCtOrigin (InjTFOrigin1 pred1 orig1 loc1 pred2 orig2 loc2)+  = hang (ctoHerald <+> text "reasoning about an injective type family using constraints:")+       2 (vcat [ hang (quotes (ppr pred1)) 2 (pprCtOrigin orig1 <+> text "at" <+> ppr loc1)+               , hang (quotes (ppr pred2)) 2 (pprCtOrigin orig2 <+> text "at" <+> ppr loc2) ])+ pprCtOrigin AssocFamPatOrigin   = text "when matching a family LHS with its class instance head"  pprCtOrigin (TypeEqOrigin { uo_actual = t1, uo_expected =  t2, uo_visible = vis })-  = text "a type equality" <> brackets (ppr vis) <+> sep [ppr t1, char '~', ppr t2]+  = hang (ctoHerald <+> text "a type equality" <> whenPprDebug (brackets (ppr vis)))+       2 (sep [ppr t1, char '~', ppr t2])  pprCtOrigin (KindEqOrigin t1 t2 _ _)   = hang (ctoHerald <+> text "a kind equality arising from")@@ -647,14 +792,19 @@            , text "in a statement in a monad comprehension" ]  pprCtOrigin (Shouldn'tHappenOrigin note)-  = sdocOption sdocImpredicativeTypes $ \case-      True  -> text "a situation created by impredicative types"-      False -> vcat [ text "<< This should not appear in error messages. If you see this"-                    , text "in an error message, please report a bug mentioning"-                        <+> quotes (text note) <+> text "at"-                    , text "https://gitlab.haskell.org/ghc/ghc/wikis/report-a-bug >>"-                    ]+  = vcat [ text "<< This should not appear in error messages. If you see this"+         , text "in an error message, please report a bug mentioning"+             <+> quotes (text note) <+> text "at"+         , text "https://gitlab.haskell.org/ghc/ghc/wikis/report-a-bug >>"+         ] +pprCtOrigin GhcBug20076+  = vcat [ text "GHC Bug #20076 <https://gitlab.haskell.org/ghc/ghc/-/issues/20076>"+         , text "Assuming you have a partial type signature, you can avoid this error"+         , text "by either adding an extra-constraints wildcard (like `(..., _) => ...`,"+         , text "with the underscore at the end of the constraint), or by avoiding the"+         , text "use of a simplifiable constraint in your partial type signature." ]+ pprCtOrigin (ProvCtxtOrigin PSB{ psb_id = (L _ name) })   = hang (ctoHerald <+> text "the \"provided\" constraints claimed by")        2 (text "the signature of" <+> quotes (ppr name))@@ -667,6 +817,13 @@ pprCtOrigin (CycleBreakerOrigin orig)   = pprCtOrigin orig +pprCtOrigin (FRROrigin {})+  = ctoHerald <+> text "a representation-polymorphism check"++pprCtOrigin (WantedSuperclassOrigin subclass_pred subclass_orig)+  = sep [ ctoHerald <+> text "a superclass required to satisfy" <+> quotes (ppr subclass_pred) <> comma+        , pprCtOrigin subclass_orig ]+ pprCtOrigin (InstanceSigOrigin method_name sig_type orig_method_type)   = vcat [ ctoHerald <+> text "the check that an instance signature is more general"          , text "than the type of the method (instantiated for this instance)"@@ -683,7 +840,7 @@   = ctoHerald <+> pprCtO simple_origin  -- | Short one-liners-pprCtO :: CtOrigin -> SDoc+pprCtO :: HasCallStack => CtOrigin -> SDoc pprCtO (OccurrenceOf name)   = hsep [text "a use of", quotes (ppr name)] pprCtO (OccurrenceOfRecSel name) = hsep [text "a use of", quotes (ppr name)] pprCtO AppOrigin             = text "an application"@@ -695,7 +852,6 @@ pprCtO PatSigOrigin          = text "a pattern type signature" pprCtO PatOrigin             = text "a pattern" pprCtO ViewPatOrigin         = text "a view pattern"-pprCtO IfOrigin              = text "an if expression" pprCtO (LiteralOrigin lit)   = hsep [text "the literal", quotes (ppr lit)] pprCtO (ArithSeqOrigin seq)  = hsep [text "the arithmetic sequence", quotes (ppr seq)] pprCtO SectionOrigin         = text "an operator section"@@ -711,17 +867,485 @@ pprCtO DoOrigin              = text "a do statement" pprCtO MCompOrigin           = text "a statement in a monad comprehension" pprCtO ProcOrigin            = text "a proc expression"+pprCtO ArrowCmdOrigin        = text "an arrow command" pprCtO AnnOrigin             = text "an annotation"-pprCtO (ExprHoleOrigin Nothing)  = text "an expression hole"-pprCtO (ExprHoleOrigin (Just occ))  = text "a use of" <+> quotes (ppr occ)+pprCtO (ExprHoleOrigin Nothing)    = text "an expression hole"+pprCtO (ExprHoleOrigin (Just occ)) = text "a use of" <+> quotes (ppr occ) pprCtO (TypeHoleOrigin occ)  = text "a use of wildcard" <+> quotes (ppr occ) pprCtO PatCheckOrigin        = text "a pattern-match completeness check" pprCtO ListOrigin            = text "an overloaded list"+pprCtO IfThenElseOrigin      = text "an if-then-else expression" pprCtO StaticOrigin          = text "a static form" pprCtO NonLinearPatternOrigin = text "a non-linear pattern" pprCtO (UsageEnvironmentOf x) = hsep [text "multiplicity of", quotes (ppr x)] pprCtO BracketOrigin         = text "a quotation bracket"-pprCtO (InstanceSigOrigin {})  = text "a type signature in an instance"-pprCtO (AmbiguityCheckOrigin {}) = text "a type ambiguity check"-pprCtO GhcBug20076           = text "GHC Bug #20076"-pprCtO _                     = panic "pprCtOrigin"++-- These ones are handled by pprCtOrigin, but we nevertheless sometimes+-- get here via callStackOriginFS, when doing ambiguity checks+-- A bit silly, but no great harm+pprCtO (GivenOrigin {})             = text "a given constraint"+pprCtO (InstSCOrigin {})            = text "the superclass of an instance constraint"+pprCtO (OtherSCOrigin {})           = text "the superclass of a given constraint"+pprCtO (SpecPragOrigin {})          = text "a SPECIALISE pragma"+pprCtO (FunDepOrigin1 {})           = text "a functional dependency"+pprCtO (FunDepOrigin2 {})           = text "a functional dependency"+pprCtO (InjTFOrigin1 {})            = text "an injective type family"+pprCtO (TypeEqOrigin {})            = text "a type equality"+pprCtO (KindEqOrigin {})            = text "a kind equality"+pprCtO (DerivOriginDC {})           = text "a deriving clause"+pprCtO (DerivOriginCoerce {})       = text "a derived method"+pprCtO (DoPatOrigin {})             = text "a do statement"+pprCtO (MCompPatOrigin {})          = text "a monad comprehension pattern"+pprCtO (Shouldn'tHappenOrigin note) = text note+pprCtO (ProvCtxtOrigin {})          = text "a provided constraint"+pprCtO (InstProvidedOrigin {})      = text "a provided constraint"+pprCtO (CycleBreakerOrigin orig)    = pprCtO orig+pprCtO (FRROrigin {})               = text "a representation-polymorphism check"+pprCtO GhcBug20076                  = text "GHC Bug #20076"+pprCtO (WantedSuperclassOrigin {})  = text "a superclass constraint"+pprCtO (InstanceSigOrigin {})       = text "a type signature in an instance"+pprCtO (AmbiguityCheckOrigin {})    = text "a type ambiguity check"++{- *********************************************************************+*                                                                      *+             CallStacks and CtOrigin++    See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence+*                                                                      *+********************************************************************* -}++isPushCallStackOrigin :: CtOrigin -> Bool+-- Do we want to solve this IP constraint directly (return False)+-- or push the call site (return True)+-- See Note [Overview of implicit CallStacks] in GHc.Tc.Types.Evidence+isPushCallStackOrigin (IPOccOrigin {}) = False+isPushCallStackOrigin _                = True+++callStackOriginFS :: CtOrigin -> FastString+-- This is the string that appears in the CallStack+callStackOriginFS (OccurrenceOf fun) = occNameFS (getOccName fun)+callStackOriginFS orig               = mkFastString (showSDocUnsafe (pprCtO orig))++{-+************************************************************************+*                                                                      *+            Checking for representation polymorphism+*                                                                      *+************************************************************************++Note [Reporting representation-polymorphism errors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+As explained in Note [The Concrete mechanism] in GHC.Tc.Utils.Concrete,+to check that (ty :: ki) has a fixed runtime representation, we emit+an equality constraint of the form++  ki ~# concrete_tv++where concrete_tv is a concrete metavariable. In this situation, we attach+a 'FixedRuntimeRepOrigin' to both the equality and the concrete type variable.+The 'FixedRuntimeRepOrigin' consists of two pieces of information:++  - the type 'ty' on which we performed the representation-polymorphism check,+  - a 'FixedRuntimeRepContext' which explains why we needed to perform a check+    (e.g. because 'ty' was the kind of a function argument, or of a bound variable+    in a lambda abstraction, ...).++This information gets passed along as we make progress on solving the constraint,+and if we end up with an unsolved constraint we can report an informative error+message to the user using the 'FixedRuntimeRepOrigin'.++The error reporting goes through two different paths:++  - constraints whose 'CtOrigin' contains a 'FixedRuntimeRepOrigin' are reported+    using 'mkFRRErr' in 'reportWanteds',+  - equality constraints in which one side is a concrete metavariable and the+    other side is not concrete are reported using 'mkTyVarEqErr'. In this case,+    we pass on the type variable and the non-concrete type for error reporting,+    using the 'frr_info_not_concrete' field.++This is why we have the 'FixedRuntimeRepErrorInfo' datatype: so that we can optionally+include this extra message about an unsolved equality between a concrete type variable+and a non-concrete type.+-}++-- | The context for a representation-polymorphism check.+--+-- For example, when typechecking @ \ (a :: k) -> ...@,+-- we are checking the type @a@ because it's the type of+-- a term variable bound in a lambda, so we use 'FRRBinder'.+data FixedRuntimeRepOrigin+  = FixedRuntimeRepOrigin+    { frr_type    :: Type+       -- ^ What type are we checking?+       -- For example, `a[tau]` in `a[tau] :: TYPE rr[tau]`.++    , frr_context :: FixedRuntimeRepContext+      -- ^ What context requires a fixed runtime representation?+    }++-- | The context in which a representation-polymorphism check was performed.+--+-- Does not include the type on which the check was performed; see+-- 'FixedRuntimeRepOrigin' for that.+data FixedRuntimeRepContext++  -- | Record fields in record updates must have a fixed runtime representation.+  --+  -- Test case: RepPolyRecordUpdate.+  = FRRRecordUpdate !RdrName !(HsExpr GhcTc)++  -- | Variable binders must have a fixed runtime representation.+  --+  -- Test cases: LevPolyLet, RepPolyPatBind.+  | FRRBinder !Name++  -- | Pattern binds must have a fixed runtime representation.+  --+  -- Test case: RepPolyInferPatBind.+  | FRRPatBind++  -- | Pattern synonym arguments must have a fixed runtime representation.+  --+  -- Test case: RepPolyInferPatSyn.+  | FRRPatSynArg++  -- | The type of the scrutinee in a case statement must have a+  -- fixed runtime representation.+  --+  -- Test cases: RepPolyCase{1,2}.+  | FRRCase++  -- | An instantiation of a newtype/data constructor in which+  -- an argument type does not have a fixed runtime representation.+  --+  -- The argument can either be an expression or a pattern.+  --+  -- Test cases:+  --  Expression: UnliftedNewtypesLevityBinder.+  --     Pattern: T20363.+  | FRRDataConArg !ExprOrPat !DataCon !Int++  -- | An instantiation of an 'Id' with no binding (e.g. `coerce`, `unsafeCoerce#`)+  -- in which one of the remaining arguments types does not have a fixed runtime representation.+  --+  -- Test cases: RepPolyWrappedVar, T14561, UnliftedNewtypesCoerceFail.+  | FRRNoBindingResArg !Id !Int++  -- | Arguments to unboxed tuples must have fixed runtime representations.+  --+  -- Test case: RepPolyTuple.+  | FRRTupleArg !Int++  -- | Tuple sections must have a fixed runtime representation.+  --+  -- Test case: RepPolyTupleSection.+  | FRRTupleSection !Int++  -- | Unboxed sums must have a fixed runtime representation.+  --+  -- Test cases: RepPolySum.+  | FRRUnboxedSum++  -- | The body of a @do@ expression or a monad comprehension must+  -- have a fixed runtime representation.+  --+  -- Test cases: RepPolyDoBody{1,2}, RepPolyMcBody.+  | FRRBodyStmt !StmtOrigin !Int++  -- | Arguments to a guard in a monad comprehesion must have+  -- a fixed runtime representation.+  --+  -- Test case: RepPolyMcGuard.+  | FRRBodyStmtGuard++  -- | Arguments to `(>>=)` arising from a @do@ expression+  -- or a monad comprehension must have a fixed runtime representation.+  --+  -- Test cases: RepPolyDoBind, RepPolyMcBind.+  | FRRBindStmt !StmtOrigin++  -- | A value bound by a pattern guard must have a fixed runtime representation.+  --+  -- Test cases: none.+  | FRRBindStmtGuard++  -- | A representation-polymorphism check arising from arrow notation.+  --+  -- See 'FRRArrowContext' for more details.+  | FRRArrow !FRRArrowContext++  -- | A representation-polymorphic check arising from a call+  -- to 'matchExpectedFunTys' or 'matchActualFunTySigma'.+  --+  -- See 'ExpectedFunTyOrigin' for more details.+  | FRRExpectedFunTy+      !ExpectedFunTyOrigin+      !Int+        -- ^ argument position (1-indexed)++-- | Print the context for a @FixedRuntimeRep@ representation-polymorphism check.+--+-- Note that this function does not include the specific 'RuntimeRep'+-- which is not fixed. That information is stored in 'FixedRuntimeRepOrigin'+-- and is reported separately.+pprFixedRuntimeRepContext :: FixedRuntimeRepContext -> SDoc+pprFixedRuntimeRepContext (FRRRecordUpdate lbl _arg)+  = sep [ text "The record update at field"+        , quotes (ppr lbl) ]+pprFixedRuntimeRepContext (FRRBinder binder)+  = sep [ text "The binder"+        , quotes (ppr binder) ]+pprFixedRuntimeRepContext FRRPatBind+  = text "The pattern binding"+pprFixedRuntimeRepContext FRRPatSynArg+  = text "The pattern synonym argument pattern"+pprFixedRuntimeRepContext FRRCase+  = text "The scrutinee of the case statement"+pprFixedRuntimeRepContext (FRRDataConArg expr_or_pat con i)+  = text "The" <+> what+  where+    arg, what :: SDoc+    arg = case expr_or_pat of+      Expression -> text "argument"+      Pattern    -> text "pattern"+    what+      | isNewDataCon con+      = text "newtype constructor" <+> arg+      | otherwise+      = text "data constructor" <+> arg <+> text "in" <+> speakNth i <+> text "position"+pprFixedRuntimeRepContext (FRRNoBindingResArg fn i)+  = vcat [ text "Unsaturated use of a representation-polymorphic primitive function."+         , text "The" <+> speakNth i <+> text "argument of" <+> quotes (ppr $ getName fn) ]+pprFixedRuntimeRepContext (FRRTupleArg i)+  = text "The tuple argument in" <+> speakNth i <+> text "position"+pprFixedRuntimeRepContext (FRRTupleSection i)+  = text "The" <+> speakNth i <+> text "component of the tuple section"+pprFixedRuntimeRepContext FRRUnboxedSum+  = text "The unboxed sum"+pprFixedRuntimeRepContext (FRRBodyStmt stmtOrig i)+  = vcat [ text "The" <+> speakNth i <+> text "argument to (>>)" <> comma+         , text "arising from the" <+> ppr stmtOrig <> comma ]+pprFixedRuntimeRepContext FRRBodyStmtGuard+  = vcat [ text "The argument to" <+> quotes (text "guard") <> comma+         , text "arising from the" <+> ppr MonadComprehension <> comma ]+pprFixedRuntimeRepContext (FRRBindStmt stmtOrig)+  = vcat [ text "The first argument to (>>=)" <> comma+         , text "arising from the" <+> ppr stmtOrig <> comma ]+pprFixedRuntimeRepContext FRRBindStmtGuard+  = sep [ text "The body of the bind statement" ]+pprFixedRuntimeRepContext (FRRArrow arrowContext)+  = pprFRRArrowContext arrowContext+pprFixedRuntimeRepContext (FRRExpectedFunTy funTyOrig arg_pos)+  = pprExpectedFunTyOrigin funTyOrig arg_pos++instance Outputable FixedRuntimeRepContext where+  ppr = pprFixedRuntimeRepContext++-- | Are we in a @do@ expression or a monad comprehension?+--+-- This datatype is only used to report this context to the user in error messages.+data StmtOrigin+  = MonadComprehension+  | DoNotation++instance Outputable StmtOrigin where+  ppr MonadComprehension = text "monad comprehension"+  ppr DoNotation         = quotes ( text "do" ) <+> text "statement"++{- *********************************************************************+*                                                                      *+                       FixedRuntimeRep: arrows+*                                                                      *+********************************************************************* -}++-- | While typechecking arrow notation, in which context+-- did a representation polymorphism check arise?+--+-- See 'FixedRuntimeRepContext' for more general origins of+-- representation polymorphism checks.+data FRRArrowContext++  -- | The result of an arrow command does not have a fixed runtime representation.+  --+  -- Test case: RepPolyArrowCmd.+  = ArrowCmdResTy !(HsCmd GhcRn)++  -- | The argument to an arrow in an arrow command application does not have+  -- a fixed runtime representation.+  --+  -- Test cases: none.+  | ArrowCmdApp !(HsCmd GhcRn) !(HsExpr GhcRn)++  -- | A function in an arrow application does not have+  -- a fixed runtime representation.+  --+  -- Test cases: none.+  | ArrowCmdArrApp !(HsExpr GhcRn) !(HsExpr GhcRn) !HsArrAppType++  -- | The scrutinee type in an arrow command case statement does not have a+  -- fixed runtime representation.+  --+  -- Test cases: none.+  | ArrowCmdCase++  -- | The overall type of an arrow proc expression does not have+  -- a fixed runtime representation.+  --+  -- Test case: RepPolyArrowFun.+  | ArrowFun !(HsExpr GhcRn)++pprFRRArrowContext :: FRRArrowContext -> SDoc+pprFRRArrowContext (ArrowCmdResTy cmd)+  = vcat [ hang (text "The arrow command") 2 (quotes (ppr cmd)) ]+pprFRRArrowContext (ArrowCmdApp fun arg)+  = vcat [ text "The argument in the arrow command application of"+         , nest 2 (quotes (ppr fun))+         , text "to"+         , nest 2 (quotes (ppr arg)) ]+pprFRRArrowContext (ArrowCmdArrApp fun arg ho_app)+  = vcat [ text "The function in the" <+> pprHsArrType ho_app <+> text "of"+         , nest 2 (quotes (ppr fun))+         , text "to"+         , nest 2 (quotes (ppr arg)) ]+pprFRRArrowContext ArrowCmdCase+  = text "The scrutinee of the arrow case command"+pprFRRArrowContext (ArrowFun fun)+  = vcat [ text "The return type of the arrow function"+         , nest 2 (quotes (ppr fun)) ]++instance Outputable FRRArrowContext where+  ppr = pprFRRArrowContext++{- *********************************************************************+*                                                                      *+              FixedRuntimeRep: ExpectedFunTy origin+*                                                                      *+********************************************************************* -}++-- | In what context are we calling 'matchExpectedFunTys'+-- or 'matchActualFunTySigma'?+--+-- Used for two things:+--+--  1. Reporting error messages which explain that a function has been+--     given an unexpected number of arguments.+--     Uses 'pprExpectedFunTyHerald'.+--     See Note [Herald for matchExpectedFunTys] in GHC.Tc.Utils.Unify.+--+--  2. Reporting representation-polymorphism errors when a function argument+--     doesn't have a fixed RuntimeRep as per Note [Fixed RuntimeRep]+--     in GHC.Tc.Utils.Concrete.+--     Uses 'pprExpectedFunTyOrigin'.+--     See 'FixedRuntimeRepContext' for the situations in which+--     representation-polymorphism checks are performed.+data ExpectedFunTyOrigin++  -- | A rebindable syntax operator is expected to have a function type.+  --+  -- Test cases for representation-polymorphism checks:+  --   RepPolyDoBind, RepPolyDoBody{1,2}, RepPolyMc{Bind,Body,Guard}, RepPolyNPlusK+  = ExpectedFunTySyntaxOp+    !CtOrigin+    !(HsExpr GhcRn)+      -- ^ rebindable syntax operator++  -- | A view pattern must have a function type.+  --+  -- Test cases for representation-polymorphism checks:+  --   RepPolyBinder+  | ExpectedFunTyViewPat+    !(HsExpr GhcRn)+      -- ^ function used in the view pattern++  -- | Need to be able to extract an argument type from a function type.+  --+  -- Test cases for representation-polymorphism checks:+  --   RepPolyApp+  | forall (p :: Pass)+      . (OutputableBndrId p)+      => ExpectedFunTyArg+          !TypedThing+            -- ^ function+          !(HsExpr (GhcPass p))+            -- ^ argument++  -- | Ensure that a function defined by equations indeed has a function type+  -- with the appropriate number of arguments.+  --+  -- Test cases for representation-polymorphism checks:+  --   RepPolyBinder, RepPolyRecordPattern, RepPolyWildcardPattern+  | ExpectedFunTyMatches+      !TypedThing+        -- ^ name of the function+      !(MatchGroup GhcRn (LHsExpr GhcRn))+       -- ^ equations++  -- | Ensure that a lambda abstraction has a function type.+  --+  -- Test cases for representation-polymorphism checks:+  --   RepPolyLambda+  | ExpectedFunTyLam+      !(MatchGroup GhcRn (LHsExpr GhcRn))++  -- | Ensure that a lambda case expression has a function type.+  --+  -- Test cases for representation-polymorphism checks:+  --   RepPolyMatch+  | ExpectedFunTyLamCase+      LamCaseVariant+      !(HsExpr GhcRn)+       -- ^ the entire lambda-case expression++pprExpectedFunTyOrigin :: ExpectedFunTyOrigin+                       -> Int -- ^ argument position (starting at 1)+                       -> SDoc+pprExpectedFunTyOrigin funTy_origin i =+  case funTy_origin of+    ExpectedFunTySyntaxOp orig op ->+      vcat [ sep [ the_arg_of+                 , text "the rebindable syntax operator"+                 , quotes (ppr op) ]+           , nest 2 (ppr orig) ]+    ExpectedFunTyViewPat expr ->+      vcat [ the_arg_of <+> text "the view pattern"+           , nest 2 (ppr expr) ]+    ExpectedFunTyArg fun arg ->+      sep [ text "The argument"+          , quotes (ppr arg)+          , text "of"+          , quotes (ppr fun) ]+    ExpectedFunTyMatches fun (MG { mg_alts = L _ alts })+      | null alts+      -> the_arg_of <+> quotes (ppr fun)+      | otherwise+      -> text "The" <+> speakNth i <+> text "pattern in the equation" <> plural alts+     <+> text "for" <+> quotes (ppr fun)+    ExpectedFunTyLam {} -> binder_of $ text "lambda"+    ExpectedFunTyLamCase lc_variant _ -> binder_of $ lamCaseKeyword lc_variant+  where+    the_arg_of :: SDoc+    the_arg_of = text "The" <+> speakNth i <+> text "argument of"++    binder_of :: SDoc -> SDoc+    binder_of what = text "The binder of the" <+> what <+> text "expression"++pprExpectedFunTyHerald :: ExpectedFunTyOrigin -> SDoc+pprExpectedFunTyHerald (ExpectedFunTySyntaxOp {})+  = text "This rebindable syntax expects a function with"+pprExpectedFunTyHerald (ExpectedFunTyViewPat {})+  = text "A view pattern expression expects"+pprExpectedFunTyHerald (ExpectedFunTyArg fun _)+  = sep [ text "The function" <+> quotes (ppr fun)+        , text "is applied to" ]+pprExpectedFunTyHerald (ExpectedFunTyMatches fun (MG { mg_alts = L _ alts }))+  = text "The equation" <> plural alts <+> text "for" <+> quotes (ppr fun) <+> hasOrHave alts+pprExpectedFunTyHerald (ExpectedFunTyLam match)+  = sep [ text "The lambda expression" <+>+                   quotes (pprSetDepth (PartWay 1) $+                           pprMatches match)+        -- The pprSetDepth makes the lambda abstraction print briefly+        , text "has" ]+pprExpectedFunTyHerald (ExpectedFunTyLamCase _ expr)+  = sep [ text "The function" <+> quotes (ppr expr)+        , text "requires" ]
+ GHC/Tc/Types/Origin.hs-boot view
@@ -0,0 +1,10 @@+module GHC.Tc.Types.Origin where++import GHC.Stack ( HasCallStack )++data SkolemInfoAnon+data SkolemInfo+data FixedRuntimeRepContext+data FixedRuntimeRepOrigin++unkSkol :: HasCallStack => SkolemInfo
+ GHC/Tc/Types/Rank.hs view
@@ -0,0 +1,40 @@+module GHC.Tc.Types.Rank (Rank(..))  where++import GHC.Base (Bool)+import GHC.Utils.Outputable (Outputable, (<+>), parens, ppr, text)++{-+Note [Higher rank types]+~~~~~~~~~~~~~~~~~~~~~~~~+Technically+            Int -> forall a. a->a+is still a rank-1 type, but it's not Haskell 98 (#5957).  So the+validity checker allow a forall after an arrow only if we allow it+before -- that is, with Rank2Types or RankNTypes+-}++data Rank = ArbitraryRank -- Any rank ok++          | LimitedRank   -- Note [Higher rank types]+                 Bool     -- Forall ok at top+                 Rank     -- Use for function arguments++          -- Monotypes that could be a polytype through an extension+          | MonoTypeRankZero   -- RankNTypes+          | MonoTypeTyConArg   -- ImpredicativeTypes+          | MonoTypeSynArg     -- LiberalTypeSynonyms+          | MonoTypeConstraint -- QuantifiedConstraints+          --++          | MustBeMonoType  -- Monotype regardless of flags++instance Outputable Rank where+  ppr ArbitraryRank      = text "ArbitraryRank"+  ppr (LimitedRank top_forall_ok r)+                         = text "LimitedRank" <+> ppr top_forall_ok+                                              <+> parens (ppr r)+  ppr MonoTypeRankZero   = text "MonoTypeRankZero"+  ppr MonoTypeTyConArg   = text "MonoTypeTyConArg"+  ppr MonoTypeSynArg     = text "MonoTypeSynArg"+  ppr MonoTypeConstraint = text "MonoTypeConstraint"+  ppr MustBeMonoType     = text "MustBeMonoType"
GHC/Tc/Utils/Backpack.hs view
@@ -1,12 +1,10 @@-{-# LANGUAGE CPP                      #-}+ {-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE ScopedTypeVariables      #-} {-# LANGUAGE TypeFamilies             #-}  module GHC.Tc.Utils.Backpack (-    findExtraSigImports',     findExtraSigImports,-    implicitRequirements',     implicitRequirements,     implicitRequirementsShallow,     checkUnit,@@ -19,8 +17,10 @@  import GHC.Prelude + import GHC.Driver.Env import GHC.Driver.Ppr+import GHC.Driver.Session  import GHC.Types.Basic (TypeOrKind(..)) import GHC.Types.Fixity (defaultFixity)@@ -37,9 +37,9 @@ import GHC.Types.Var import GHC.Types.Unique.DSet import GHC.Types.Name.Shape+import GHC.Types.PkgQual  import GHC.Unit-import GHC.Unit.State import GHC.Unit.Finder import GHC.Unit.Module.Warnings import GHC.Unit.Module.ModIface@@ -47,6 +47,7 @@ import GHC.Unit.Module.Imported import GHC.Unit.Module.Deps +import GHC.Tc.Errors.Types import GHC.Tc.Gen.Export import GHC.Tc.Solver import GHC.Tc.TyCl.Utils@@ -76,10 +77,10 @@ import GHC.Tc.Errors import GHC.Tc.Utils.Unify -import GHC.Utils.Misc import GHC.Utils.Error import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain  import GHC.Data.FastString import GHC.Data.Maybe@@ -89,10 +90,9 @@  import {-# SOURCE #-} GHC.Tc.Module -#include "HsVersions.h"--fixityMisMatch :: TyThing -> Fixity -> Fixity -> SDoc+fixityMisMatch :: TyThing -> Fixity -> Fixity -> TcRnMessage fixityMisMatch real_thing real_fixity sig_fixity =+  TcRnUnknownMessage $ mkPlainError noHints $     vcat [ppr real_thing <+> text "has conflicting fixities in the module",           text "and its hsig file",           text "Main module:" <+> ppr_fix real_fixity,@@ -134,6 +134,7 @@     traceTc "checkHsigIface" $ vcat         [ ppr sig_type_env, ppr sig_insts, ppr sig_exports ]     mapM_ check_export (map availName sig_exports)+    failIfErrsM -- See Note [Fail before checking instances in checkHsigIface]     unless (null sig_fam_insts) $         panic ("GHC.Tc.Module.checkHsigIface: Cannot handle family " ++                "instances in hsig files yet...")@@ -145,7 +146,7 @@                         tcg_fam_inst_env = emptyFamInstEnv,                         tcg_insts = [],                         tcg_fam_insts = [] } $ do-    mapM_ check_inst sig_insts+    mapM_ check_inst (instEnvElts sig_insts)     failIfErrsM   where     -- NB: the Names in sig_type_env are bogus.  Let's say we have H.hsig@@ -154,8 +155,8 @@     -- have to look up the right name.     sig_type_occ_env = mkOccEnv                      . map (\t -> (nameOccName (getName t), t))-                     $ nameEnvElts sig_type_env-    dfun_names = map getName sig_insts+                     $ nonDetNameEnvElts sig_type_env+    dfun_names = map getName (instEnvElts sig_insts)     check_export name       -- Skip instances, we'll check them later       -- TODO: Actually this should never happen, because DFuns are@@ -168,7 +169,7 @@         -- tcg_env (TODO: but maybe this isn't relevant anymore).         r <- tcLookupImported_maybe name         case r of-          Failed err -> addErr err+          Failed err -> addErr (TcRnUnknownMessage $ mkPlainError noHints err)           Succeeded real_thing -> checkHsigDeclM sig_iface sig_thing real_thing        -- The hsig did NOT define this function; that means it must@@ -194,6 +195,14 @@         addErrAt (nameSrcSpan name)             (missingBootThing False name "exported by") +-- Note [Fail before checking instances in checkHsigIface]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- We need to be careful about failing before checking instances if there happens+-- to be an error in the exports.+-- Otherwise, we might proceed with typechecking (and subsequently panic-ing) on+-- ill-kinded types that are constructed while checking instances.+-- This lead to #19244+ -- Note [Error reporting bad reexport] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- NB: You want to be a bit careful about what location you report on reexports.@@ -220,14 +229,14 @@     mapM_ tcLookupImported_maybe (nameSetElemsStable (orphNamesOfClsInst sig_inst))     -- Based off of 'simplifyDeriv'     let ty = idType (instanceDFunId sig_inst)-        skol_info = InstSkol         -- Based off of tcSplitDFunTy         (tvs, theta, pred) =            case tcSplitForAllInvisTyVars ty of { (tvs, rho)    ->            case splitFunTys rho             of { (theta, pred) ->            (tvs, theta, pred) }}         origin = InstProvidedOrigin (tcg_semantic_mod tcg_env) sig_inst-    (skol_subst, tvs_skols) <- tcInstSkolTyVars tvs -- Skolemize+    skol_info <- mkSkolemInfo InstSkol+    (skol_subst, tvs_skols) <- tcInstSkolTyVars skol_info tvs -- Skolemize     (tclvl,cts) <- pushTcLevelM $ do        wanted <- newWanted origin                            (Just TypeLevel)@@ -244,7 +253,7 @@        return $ wanted : givens     unsolved <- simplifyWantedsTcM cts -    (implic, _) <- buildImplicationFor tclvl skol_info tvs_skols [] unsolved+    (implic, _) <- buildImplicationFor tclvl (getSkolemInfo skol_info) tvs_skols [] unsolved     reportAllUnsolved (mkImplicWC implic)  -- | For a module @modname@ of type 'HscSource', determine the list@@ -267,56 +276,42 @@ -- process A first, because the merging process will cause B to indirectly -- import A.  This function finds the TRANSITIVE closure of all such imports -- we need to make.-findExtraSigImports' :: HscEnv-                     -> HscSource-                     -> ModuleName-                     -> IO (UniqDSet ModuleName)-findExtraSigImports' hsc_env HsigFile modname =-    fmap unionManyUniqDSets (forM reqs $ \(Module iuid mod_name) ->-        (initIfaceLoad hsc_env-            . withException+findExtraSigImports :: HscEnv+                    -> HscSource+                    -> ModuleName+                    -> IO [ModuleName]+findExtraSigImports hsc_env HsigFile modname = do+    let+      dflags     = hsc_dflags hsc_env+      ctx        = initSDocContext dflags defaultUserStyle+      unit_state = hsc_units hsc_env+      reqs       = requirementMerges unit_state modname+    holes <- forM reqs $ \(Module iuid mod_name) -> do+        initIfaceLoad hsc_env+            . withException ctx             $ moduleFreeHolesPrecise (text "findExtraSigImports")-                (mkModule (VirtUnit iuid) mod_name)))-  where-    unit_state = hsc_units hsc_env-    reqs = requirementMerges unit_state modname--findExtraSigImports' _ _ _ = return emptyUniqDSet---- | 'findExtraSigImports', but in a convenient form for "GHC.Driver.Make" and--- "GHC.Tc.Module".-findExtraSigImports :: HscEnv -> HscSource -> ModuleName-                    -> IO [(Maybe FastString, Located ModuleName)]-findExtraSigImports hsc_env hsc_src modname = do-    extra_requirements <- findExtraSigImports' hsc_env hsc_src modname-    return [ (Nothing, noLoc mod_name)-           | mod_name <- uniqDSetToList extra_requirements ]+                (mkModule (VirtUnit iuid) mod_name)+    return (uniqDSetToList (unionManyUniqDSets holes)) --- A version of 'implicitRequirements'' which is more friendly--- for "GHC.Tc.Module".-implicitRequirements :: HscEnv-                     -> [(Maybe FastString, Located ModuleName)]-                     -> IO [(Maybe FastString, Located ModuleName)]-implicitRequirements hsc_env normal_imports-  = do mns <- implicitRequirements' hsc_env normal_imports-       return [ (Nothing, noLoc mn) | mn <- mns ]+findExtraSigImports _ _ _ = return []  -- Given a list of 'import M' statements in a module, figure out -- any extra implicit requirement imports they may have.  For -- example, if they 'import M' and M resolves to p[A=<B>,C=D], then -- they actually also import the local requirement B.-implicitRequirements' :: HscEnv-                     -> [(Maybe FastString, Located ModuleName)]+implicitRequirements :: HscEnv+                     -> [(PkgQual, Located ModuleName)]                      -> IO [ModuleName]-implicitRequirements' hsc_env normal_imports+implicitRequirements hsc_env normal_imports   = fmap concat $     forM normal_imports $ \(mb_pkg, L _ imp) -> do         found <- findImportedModule hsc_env imp mb_pkg         case found of-            Found _ mod | not (isHomeModule home_unit mod) ->+            Found _ mod | notHomeModuleMaybe mhome_unit mod ->                 return (uniqDSetToList (moduleFreeHoles mod))             _ -> return []-  where home_unit = hsc_home_unit hsc_env+  where+    mhome_unit = hsc_home_unit_maybe hsc_env  -- | Like @implicitRequirements'@, but returns either the module name, if it is -- a free hole, or the instantiated unit the imported module is from, so that@@ -324,15 +319,17 @@ -- than a transitive closure done here) all the free holes are still reachable. implicitRequirementsShallow   :: HscEnv-  -> [(Maybe FastString, Located ModuleName)]+  -> [(PkgQual, Located ModuleName)]   -> IO ([ModuleName], [InstantiatedUnit]) implicitRequirementsShallow hsc_env normal_imports = go ([], []) normal_imports  where+  mhome_unit = hsc_home_unit_maybe hsc_env+   go acc [] = pure acc   go (accL, accR) ((mb_pkg, L _ imp):imports) = do     found <- findImportedModule hsc_env imp mb_pkg     let acc' = case found of-          Found _ mod | not (isHomeModule (hsc_home_unit hsc_env) mod) ->+          Found _ mod | notHomeModuleMaybe mhome_unit mod ->               case moduleUnit mod of                   HoleUnit -> (moduleName mod : accL, accR)                   RealUnit _ -> (accL, accR)@@ -361,15 +358,15 @@ -- an @hsig@ file.) tcRnCheckUnit ::     HscEnv -> Unit ->-    IO (Messages DecoratedSDoc, Maybe ())+    IO (Messages TcRnMessage, Maybe ()) tcRnCheckUnit hsc_env uid =-   withTiming logger dflags+   withTiming logger               (text "Check unit id" <+> ppr uid)               (const ()) $    initTc hsc_env           HsigFile -- bogus           False-          (mainModIs hsc_env)+          (mainModIs (hsc_HUE hsc_env))           (realSrcLocSpan (mkRealSrcLoc (fsLit loc_str) 0 0)) -- bogus     $ checkUnit uid   where@@ -382,15 +379,14 @@ -- | Top-level driver for signature merging (run after typechecking -- an @hsig@ file). tcRnMergeSignatures :: HscEnv -> HsParsedModule -> TcGblEnv {- from local sig -} -> ModIface-                    -> IO (Messages DecoratedSDoc, Maybe TcGblEnv)+                    -> IO (Messages TcRnMessage, Maybe TcGblEnv) tcRnMergeSignatures hsc_env hpm orig_tcg_env iface =-  withTiming logger dflags+  withTiming logger              (text "Signature merging" <+> brackets (ppr this_mod))              (const ()) $   initTc hsc_env HsigFile False this_mod real_loc $     mergeSignatures hpm orig_tcg_env iface  where-  dflags   = hsc_dflags hsc_env   logger   = hsc_logger hsc_env   this_mod = mi_module iface   real_loc = tcg_top_loc orig_tcg_env@@ -560,10 +556,10 @@     tcg_env <- getGblEnv      let outer_mod  = tcg_mod tcg_env-        inner_mod  = tcg_semantic_mod tcg_env-        mod_name   = moduleName (tcg_mod tcg_env)-        unit_state = hsc_units hsc_env-        home_unit  = hsc_home_unit hsc_env+    let inner_mod  = tcg_semantic_mod tcg_env+    let mod_name   = moduleName (tcg_mod tcg_env)+    let unit_state = hsc_units hsc_env+    let dflags     = hsc_dflags hsc_env      -- STEP 1: Figure out all of the external signature interfaces     -- we are going to merge in.@@ -572,12 +568,14 @@     addErrCtxt (pprWithUnitState unit_state $ merge_msg mod_name reqs) $ do      -- STEP 2: Read in the RAW forms of all of these interfaces-    ireq_ifaces0 <- forM reqs $ \(Module iuid mod_name) ->+    ireq_ifaces0 <- liftIO $ forM reqs $ \(Module iuid mod_name) -> do         let m = mkModule (VirtUnit iuid) mod_name             im = fst (getModuleInstantiation m)-        in fmap fst-         . withException-         $ findAndReadIface (text "mergeSignatures") im m NotBoot+            ctx = initSDocContext dflags defaultUserStyle+        fmap fst+         . withException ctx+         $ findAndReadIface hsc_env+                            (text "mergeSignatures") im m NotBoot      -- STEP 3: Get the unrenamed exports of all these interfaces,     -- thin it according to the export list, and do shaping on them.@@ -596,7 +594,7 @@             let insts = instUnitInsts iuid                 isFromSignaturePackage =                     let inst_uid = instUnitInstanceOf iuid-                        pkg = unsafeLookupUnitId unit_state (indefUnit inst_uid)+                        pkg = unsafeLookupUnitId unit_state inst_uid                     in null (unitExposedModules pkg)             -- 3(a). Rename the exports according to how the dependency             -- was instantiated.  The resulting export list will be accurate@@ -689,7 +687,7 @@             -- 3(d). Extend the name substitution (performing shaping)             mb_r <- extend_ns nsubst as2             case mb_r of-                Left err -> failWithTc err+                Left err -> failWithTc (TcRnUnknownMessage $ mkPlainError noHints err)                 Right nsubst' -> return (nsubst',oks',(imod, thinned_iface):ifaces)         nsubst0 = mkNameShape (moduleName inner_mod) (mi_exports lcl_iface0)         ok_to_use0 = mkOccSet (exportOccs (mi_exports lcl_iface0))@@ -756,6 +754,8 @@     setGblEnv tcg_env { tcg_rn_exports = mb_lies } $ do     tcg_env <- getGblEnv +    let home_unit = hsc_home_unit hsc_env+     -- STEP 4: Rename the interfaces     ext_ifaces <- forM thinned_ifaces $ \((Module iuid _), ireq_iface) ->         tcRnModIface (instUnitInsts iuid) (Just nsubst) ireq_iface@@ -865,14 +865,15 @@                 = (inst:insts, extendInstEnv inst_env inst)             (insts, inst_env) = foldl' merge_inst                                     (tcg_insts tcg_env, tcg_inst_env tcg_env)-                                    (md_insts details)+                                    (instEnvElts $ md_insts details)             -- This is a HACK to prevent calculateAvails from including imp_mod             -- in the listing.  We don't want it because a module is NOT             -- supposed to include itself in its dep_orphs/dep_finsts.  See #13214             iface' = iface { mi_final_exts = (mi_final_exts iface){ mi_orphan = False, mi_finsts = False } }             home_unit = hsc_home_unit hsc_env+            other_home_units = hsc_all_home_unit_ids hsc_env             avails = plusImportAvails (tcg_imports tcg_env) $-                        calculateAvails home_unit iface' False NotBoot ImportedBySystem+                        calculateAvails home_unit other_home_units iface' False NotBoot ImportedBySystem         return tcg_env {             tcg_inst_env = inst_env,             tcg_insts    = insts,@@ -914,14 +915,13 @@ -- an @hsig@ file.) tcRnInstantiateSignature ::     HscEnv -> Module -> RealSrcSpan ->-    IO (Messages DecoratedSDoc, Maybe TcGblEnv)+    IO (Messages TcRnMessage, Maybe TcGblEnv) tcRnInstantiateSignature hsc_env this_mod real_loc =-   withTiming logger dflags+   withTiming logger               (text "Signature instantiation"<+>brackets (ppr this_mod))               (const ()) $    initTc hsc_env HsigFile False this_mod real_loc $ instantiateSignature   where-   dflags = hsc_dflags hsc_env    logger = hsc_logger hsc_env  exportOccs :: [AvailInfo] -> [OccName]@@ -942,6 +942,7 @@   hsc_env <- getTopEnv   let unit_state = hsc_units hsc_env       home_unit  = hsc_home_unit hsc_env+      other_home_units = hsc_all_home_unit_ids hsc_env   addErrCtxt (impl_msg unit_state impl_mod req_mod) $ do     let insts = instUnitInsts uid @@ -962,7 +963,7 @@     loadModuleInterfaces (text "Loading orphan modules (from implementor of hsig)")                          (dep_orphs (mi_deps impl_iface)) -    let avails = calculateAvails home_unit+    let avails = calculateAvails home_unit other_home_units                     impl_iface False{- safe -} NotBoot ImportedBySystem         fix_env = mkNameEnv [ (greMangledName rdr_elt, FixItem occ f)                             | (occ, f) <- mi_fixities impl_iface@@ -987,10 +988,13 @@     -- instantiation is correct.     let sig_mod = mkModule (VirtUnit uid) mod_name         isig_mod = fst (getModuleInstantiation sig_mod)-    mb_isig_iface <- findAndReadIface (text "checkImplements 2") isig_mod sig_mod NotBoot+    hsc_env <- getTopEnv+    mb_isig_iface <- liftIO $ findAndReadIface hsc_env+                                               (text "checkImplements 2")+                                               isig_mod sig_mod NotBoot     isig_iface <- case mb_isig_iface of         Succeeded (iface, _) -> return iface-        Failed err -> failWithTc $+        Failed err -> failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $             hang (text "Could not find hi interface for signature" <+>                   quotes (ppr isig_mod) <> colon) 4 err @@ -998,7 +1002,8 @@     -- we need.  (Notice we IGNORE the Modules in the AvailInfos.)     forM_ (exportOccs (mi_exports isig_iface)) $ \occ ->         case lookupGlobalRdrEnv impl_gr occ of-            [] -> addErr $ quotes (ppr occ)+            [] -> addErr $ TcRnUnknownMessage $ mkPlainError noHints $+                        quotes (ppr occ)                     <+> text "is exported by the hsig file, but not exported by the implementing module"                     <+> quotes (pprWithUnitState unit_state $ ppr impl_mod)             _ -> return ()@@ -1034,9 +1039,9 @@     -- TODO: setup the local RdrEnv so the error messages look a little better.     -- But this information isn't stored anywhere. Should we RETYPECHECK     -- the local one just to get the information?  Hmm...-    MASSERT( isHomeModule home_unit outer_mod )-    MASSERT( isHomeUnitInstantiating home_unit)-    let uid = Indefinite (homeUnitInstanceOf home_unit)+    massert (isHomeModule home_unit outer_mod )+    massert (isHomeUnitInstantiating home_unit)+    let uid = homeUnitInstanceOf home_unit     inner_mod `checkImplements`         Module             (mkInstantiatedUnit uid (homeUnitInstantiations home_unit))
+ GHC/Tc/Utils/Concrete.hs view
@@ -0,0 +1,684 @@+{-# LANGUAGE MultiWayIf #-}++-- | Checking for representation-polymorphism using the Concrete mechanism.+--+-- This module contains the logic for enforcing the representation-polymorphism+-- invariants by way of emitting constraints.+module GHC.Tc.Utils.Concrete+  ( -- * Ensuring that a type has a fixed runtime representation+    hasFixedRuntimeRep+  , hasFixedRuntimeRep_syntactic++    -- * Making a type concrete+  , makeTypeConcrete+  )+ where++import GHC.Prelude++import GHC.Builtin.Types       ( liftedTypeKindTyCon, unliftedTypeKindTyCon )++import GHC.Core.Coercion       ( coToMCo, mkCastTyMCo )+import GHC.Core.TyCo.Rep       ( Type(..), MCoercion(..) )+import GHC.Core.TyCon          ( isConcreteTyCon )+import GHC.Core.Type           ( isConcrete, typeKind, tyVarKind, tcView+                               , mkTyVarTy, mkTyConApp, mkFunTy, mkAppTy )++import GHC.Tc.Types            ( TcM, ThStage(..), PendingStuff(..) )+import GHC.Tc.Types.Constraint ( NotConcreteError(..), NotConcreteReason(..) )+import GHC.Tc.Types.Evidence   ( Role(..), TcCoercionN, TcMCoercionN+                               , mkTcGReflRightMCo, mkTcNomReflCo )+import GHC.Tc.Types.Origin     ( CtOrigin(..), FixedRuntimeRepContext, FixedRuntimeRepOrigin(..) )+import GHC.Tc.Utils.Monad      ( emitNotConcreteError, setTcLevel, getCtLocM, getStage, traceTc )+import GHC.Tc.Utils.TcType     ( TcType, TcKind, TcTypeFRR+                               , MetaInfo(..), ConcreteTvOrigin(..)+                               , isMetaTyVar, metaTyVarInfo, tcTyVarLevel )+import GHC.Tc.Utils.TcMType    ( newConcreteTyVar, isFilledMetaTyVar_maybe, writeMetaTyVar+                               , emitWantedEq )++import GHC.Types.Basic         ( TypeOrKind(..) )+import GHC.Utils.Misc          ( HasDebugCallStack )+import GHC.Utils.Outputable++import Control.Monad      ( void )+import Data.Functor       ( ($>) )+import Data.List.NonEmpty ( NonEmpty((:|)) )++import Control.Monad.Trans.Class      ( lift )+import Control.Monad.Trans.Writer.CPS ( WriterT, runWriterT, tell )++{- Note [Concrete overview]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+GHC ensures that certain types have a fixed runtime representation in the+typechecker, by emitting certain constraints.+Emitting constraints to be solved later allows us to accept more programs:+if we directly inspected the type (using e.g. `typePrimRep`), we might not+have enough information available (e.g. if the type has kind `TYPE r` for+a metavariable `r` which has not yet been filled in.)++We give here an overview of the various moving parts, to serve+as a central point of reference for this topic.++  * Representation polymorphism+    Note [Representation polymorphism invariants] in GHC.Core+    Note [Representation polymorphism checking]++    The first note explains why we require that certain types have+    a fixed runtime representation.++    The second note details why we sometimes need a constraint to+    perform such checks in the typechecker: we might not know immediately+    whether a type has a fixed runtime representation. For example, we might+    need further unification to take place before being able to decide.+    So, instead of checking immediately, we emit a constraint.++  * What does it mean for a type to be concrete?+    Note [Concrete types] explains what it means for a type to be concrete.++    To compute which representation to use for a type, `typePrimRep` expects+    its kind to be concrete: something specific like `BoxedRep Lifted` or+    `IntRep`; certainly not a type involving type variables or type families.++  * What constraints do we emit?+    Note [The Concrete mechanism]++    Instead of simply checking that a type `ty` is concrete (i.e. computing+    'isConcrete`), we emit an equality constraint:++       co :: ty ~# concrete_ty++    where 'concrete_ty' is a concrete metavariable: a metavariable whose 'MetaInfo'+    is 'ConcreteTv', signifying that it can only be unified with a concrete type.++    The Note explains that this allows us to accept more programs. The Note+    also explains that the implementation is happening in two phases+    (PHASE 1 and PHASE 2).+    In PHASE 1 (the current implementation) we only allow trivial evidence+    of the form `co = Refl`.++  * Fixed runtime representation vs fixed RuntimeRep+    Note [Fixed RuntimeRep]++    We currently enforce the representation-polymorphism invariants by checking+    that binders and function arguments have a "fixed RuntimeRep".++    This is slightly less general than we might like, as this rules out+    types with kind `TYPE (BoxedRep l)`: we know that this will be represented+    by a pointer, which should be enough to go on in many situations.++  * When do we emit these constraints?+    Note [hasFixedRuntimeRep]++    We introduce constraints to satisfy the representation-polymorphism+    invariants outlined in Note [Representation polymorphism invariants] in GHC.Core,+    which mostly amounts to the following two cases:++      - checking that a binder has a fixed runtime representation,+      - checking that a function argument has a fixed runtime representation.++    The Note explains precisely how and where these constraints are emitted.++  * Reporting unsolved constraints+    Note [Reporting representation-polymorphism errors] in GHC.Tc.Types.Origin++    When we emit a constraint to enforce a fixed representation, we also provide+    a 'FixedRuntimeRepOrigin' which gives context about the check being done.+    This origin gets reported to the user if we end up with such an an unsolved Wanted constraint.++Note [Representation polymorphism checking]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+According to the "Levity Polymorphism" paper (PLDI '17),+there are two places in which we must know that a type has a+fixed runtime representation, as explained in+  Note [Representation polymorphism invariants] in GHC.Core:++  I1. the type of a bound term-level variable,+  I2. the type of an argument to a function.++The paper explains the restrictions more fully, but briefly:+expressions in these contexts need to be stored in registers, and it's+hard (read: impossible) to store something that does not have a+fixed runtime representation.++In practice, we enforce these types to have a /fixed RuntimeRep/, which is slightly+stronger, as explained in Note [Fixed RuntimeRep].++There are two different ways we check whether a given type+has a fixed runtime representation, both in the typechecker:++  1. When typechecking type declarations (e.g. datatypes, typeclass, pattern synonyms),+     under the GHC.Tc.TyCl module hierarchy.+     In these situations, we can immediately reject bad representation polymorphism.++     For instance, the following datatype declaration++       data Foo (r :: RuntimeRep) (a :: TYPE r) = Foo a++     is rejected in GHC.Tc.TyCl.checkValidDataCon upon seeing that the type 'a'+     is representation-polymorphic.++     Such checks are done using `GHC.Tc.Utils.TcMType.checkTypeHasFixedRuntimeRep`,+     with `GHC.Tc.Errors.Types.FixedRuntimeRepProvenance` describing the different+     contexts in which bad representation polymorphism can occur while validity checking.++  2. When typechecking value-level declarations (functions, expressions, patterns, ...),+     under the GHC.Tc.Gen module hierarchy.+     In these situations, the typechecker might need to do some work to figure out+     whether a type has a fixed runtime representation or not. For instance,+     GHC might introduce a metavariable (rr :: RuntimeRep), which is only later+     (through constraint solving) discovered to be equal to FloatRep.++     This is handled by the Concrete mechanism outlined in+     Note [The Concrete mechanism] in GHC.Tc.Utils.Concrete.+     See Note [Concrete overview] in GHC.Tc.Utils.Concrete for an overview+     of the various moving parts.++Note [Concrete types]+~~~~~~~~~~~~~~~~~~~~~+Definition: a type is /concrete/ iff it is:+            - a concrete type constructor (as defined below), or+            - a concrete type variable (see Note [ConcreteTv] below), or+            - an application of a concrete type to another concrete type+GHC.Core.Type.isConcrete checks whether a type meets this definition.++Definition: a /concrete type constructor/ is defined by+            - a promoted data constructor+            - a class, data type or newtype+            - a primitive type like Array# or Int#+            - an abstract type as defined in a Backpack signature file+              (see Note [Synonyms implement abstract data] in GHC.Tc.Module)+            In particular, type and data families are not concrete.+GHC.Core.TyCon.isConcreteTyCon checks whether a TyCon meets this definition.++Examples of concrete types:+   Lifted, BoxedRep Lifted, TYPE (BoxedRep Lifted) are all concrete+Examples of non-concrete types+   F Int, TYPE (F Int), TYPE r, a[sk]+   NB: (F Int) is not concrete because F is a type function++The recursive definition of concreteness entails the following property:++Concrete Congruence Property (CCP)+  All sub-trees of a concrete type tree are concrete.++The following property also holds due to the invariant that the kind of a+concrete metavariable is itself concrete (see Note [ConcreteTv]):++Concrete Kinds Property (CKP)+  The kind of a concrete type is concrete.++Note [ConcreteTv]+~~~~~~~~~~~~~~~~~+A concrete metavariable is a metavariable whose 'MetaInfo' is 'ConcreteTv'.+Similar to 'TyVarTv's which are type variables which can only be unified with+other type variables, a 'ConcreteTv' type variable is a type variable which can+only be unified with a concrete type (in the sense of Note [Concrete types]).++INVARIANT: the kind of a concrete metavariable is concrete.++This invariant is upheld at the time of creation of a new concrete metavariable.++Concrete metavariables are useful for representation-polymorphism checks:+they allow us to refer to a type whose representation is not yet known but will+be figured out by the typechecker (see Note [The Concrete mechanism]).++Note [The Concrete mechanism]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+To check (ty :: ki) has a fixed runtime representation, we proceed as follows:++  - Create a new concrete metavariable `concrete_tv`, i.e. a metavariable+    with 'ConcreteTv' 'MetaInfo' (see Note [ConcreteTv]).++  - Emit an equality constraint:++      ki ~# concrete_tv++    The origin for such an equality constraint uses+    `GHC.Tc.Types.Origin.FixedRuntimeRepOrigin`, so that we can report the+    appropriate representation-polymorphism error if any such constraint+    goes unsolved.++To solve `ki ~# concrete_ki`, we must unify `concrete_tv := concrete_ki`,+where `concrete_ki` is some concrete type. We can then compute `kindPrimRep`+on `concrete_ki` to compute the representation: this means `ty` indeed+has a fixed runtime representation.++-------------------------+-- PHASE 1 and PHASE 2 --+-------------------------++The Concrete mechanism is being implemented in two separate phases.++In PHASE 1, we enforce that we only solve the emitted constraints+`co :: ki ~# concrete_tv` with `Refl`. This forbids any program+which requires type family evaluation in order to determine that a 'RuntimeRep'+is fixed.+To achieve this, instead of creating a new concrete metavariable, we directly+ensure that 'ki' is concrete, using 'makeTypeConcrete'. If it fails, then+we report an error (even though rewriting might have allowed us to proceed).++In PHASE 2, we lift this restriction. This means we replace a call to+`hasFixedRuntimeRep_syntactic` with a call to `hasFixedRuntimeRep`, and insert the+obtained coercion in the typechecked result. To illustrate what this entails,+recall that the code generator needs to be able to compute 'PrimRep's, so that it+can put function arguments in the correct registers, etc.+As a result, we must insert additional casts in Core to ensure that no type family+reduction is needed to be able to compute 'PrimRep's. For example, the Core++  f = /\ ( a :: F Int ). \ ( x :: a ). some_expression++is problematic when 'F' is a type family: we don't know what runtime representation to use+for 'x', so we can't compile this function (we can't evaluate type family applications+after we are done with typechecking). Instead, we ensure the 'RuntimeRep' is always+explicitly visible:++  f = /\ ( a :: F Int ). \ ( x :: ( a |> kco ) ). some_expression++where 'kco' is the appropriate coercion; for example if `F Int = TYPE Int#`+this would be:++  kco :: F Int ~# TYPE Int#++As `( a |> kco ) :: TYPE Int#`, the code generator knows to use a machine-sized+integer register for `x`, and all is good again.++Because we can convert calls from hasFixedRuntimeRep_syntactic to+hasFixedRuntimeRep one at a time, we can migrate from PHASE 1 to PHASE 2+incrementally.++Example test cases that require PHASE 2: T13105, T17021, T20363b.++Note [Fixed RuntimeRep]+~~~~~~~~~~~~~~~~~~~~~~~+Definitions:++  FRR.++    The type `ty :: ki` has a /syntactically fixed RuntimeRep/+    (we also say that `ty` is an `FRRType`)+      <=>+    the kind `ki` is concrete (in the sense of Note [Concrete types])+      <=>+    `typePrimRep ty` (= `kindPrimRep ki`) does not crash+    (assuming that typechecking succeeded, so that all metavariables+    in `ty` have been filled)++  Fixed RuntimeRep.++    The type `ty :: ki` has a /fixed RuntimeRep/+      <=>+    there exists an FRR type `ty'` with `ty ~# ty'`+      <=>+    there exists a concrete type `concrete_ki` such that+    `ki ~ concrete_ki`++These definitions are crafted to be useful to satisfy the invariants of+Core; see Note [Representation polymorphism invariants] in GHC.Core.++Notice that "fixed RuntimeRep" means (for now anyway) that+  * we know the runtime representation, and+  * we know the levity.++For example (ty :: TYPE (BoxedRep l)), where `l` is a levity variable+is /not/ "fixed RuntimeRep", even though it is always represented by+a heap pointer, because we don't know the levity.  In due course we+will want to make finer distinctions, as explained in the paper+Kinds are Calling Conventions [ICFP'20], but this suffices for now.++Note [hasFixedRuntimeRep]+~~~~~~~~~~~~~~~~~~~~~~~~~+The 'hasFixedRuntimeRep' function is responsible for taking a type 'ty'+and emitting a constraint to ensure that 'ty' has a fixed `RuntimeRep`,+as outlined in Note [The Concrete mechanism].++To do so, we compute the kind 'ki' of 'ty', create a new concrete metavariable+`concrete_tv` of kind `ki`, and emit a constraint `ki ~# concrete_tv`,+which will only be solved if we can prove that 'ty' indeed has a fixed RuntimeRep.++If we can solve the equality constraint, i.e. produce a coercion+`kco :: ki ~# concrete_tv`, then 'hasFixedRuntimeRep' returns the coercion++  co = GRefl ty kco :: ty ~# ty |> kco++The RHS of the coercion `co` is `ty |> kco`. The kind of this type is+concrete (by construction), which means that `ty |> kco` is an FRRType+in the sense of Note [Fixed RuntimeRep], so that we can directely compute+its runtime representation using `typePrimRep`.++  [Wrinkle: Typed Template Haskell]+    We don't perform any checks when type-checking a typed Template Haskell quote:+    we want to allow representation polymorphic quotes, as long as they are+    monomorphised at splice site.++    Example:++      Module1++        repPolyId :: forall r (a :: TYPE r). CodeQ (a -> a)+        repPolyId = [|| \ x -> x ||]++      Module2++        import Module1++        id1 :: Int -> Int+        id1 = $$repPolyId++        id2 :: Int# -> Int#+        id2 = $$repPolyId++    We implement this skip by inspecting the TH stage in `hasFixedRuntimeRep`.++    A better solution would be to use 'CodeC' constraints, as in the paper+      "Staging With Class", POPL 2022+        by Ningning Xie, Matthew Pickering, Andres Löh, Nicolas Wu, Jeremy Yallop, Meng Wang+    but for the moment, as we will typecheck again when splicing,+    this shouldn't cause any problems in practice.  See ticket #18170.++    Test case: rep-poly/T18170a.+-}++-- | Given a type @ty :: ki@, this function ensures that @ty@+-- has a __fixed__ 'RuntimeRep', by emitting a new equality constraint+-- @ki ~ concrete_tv@ for a concrete metavariable @concrete_tv@.+--+-- Returns a coercion @co :: ty ~# concrete_ty@ as evidence.+-- If @ty@ obviously has a fixed 'RuntimeRep', e.g @ki = IntRep@,+-- then this function immediately returns 'MRefl',+-- without emitting any constraints.+hasFixedRuntimeRep :: HasDebugCallStack+                   => FixedRuntimeRepContext+                        -- ^ Context to be reported to the user+                        -- if the type ends up not having a fixed+                        -- 'RuntimeRep'.+                   -> TcType+                        -- ^ The type to check (we only look at its kind).+                   -> TcM (TcCoercionN, TcTypeFRR)+                        -- ^ @(co, ty')@ where @ty' :: ki'@,+                        -- @ki@ is concrete, and @co :: ty ~# ty'@.+                        -- That is, @ty'@ has a syntactically fixed RuntimeRep+                        -- in the sense of Note [Fixed RuntimeRep].+hasFixedRuntimeRep frr_ctxt ty = checkFRR_with unifyConcrete frr_ctxt ty++-- | Like 'hasFixedRuntimeRep', but we perform an eager syntactic check.+--+-- Throws an error in the 'TcM' monad if the check fails.+--+-- This is useful if we are not actually going to use the coercion returned+-- from 'hasFixedRuntimeRep'; it would generally be unsound to allow a non-reflexive+-- coercion but not actually make use of it in a cast.+--+-- The goal is to eliminate all uses of this function and replace them with+-- 'hasFixedRuntimeRep', making use of the returned coercion. This is what+-- is meant by going from PHASE 1 to PHASE 2, in Note [The Concrete mechanism].+hasFixedRuntimeRep_syntactic :: HasDebugCallStack+                             => FixedRuntimeRepContext+                                  -- ^ Context to be reported to the user+                                  -- if the type does not have a syntactically+                                  -- fixed 'RuntimeRep'.+                             -> TcType+                                  -- ^ The type to check (we only look at its kind).+                             -> TcM ()+hasFixedRuntimeRep_syntactic frr_ctxt ty+  = void $ checkFRR_with ensure_conc frr_ctxt ty+    where+      ensure_conc :: FixedRuntimeRepOrigin -> TcKind -> TcM TcMCoercionN+      ensure_conc frr_orig ki = ensureConcrete frr_orig ki $> MRefl++-- | Internal function to check whether the given type has a fixed 'RuntimeRep'.+--+-- Use 'hasFixedRuntimeRep' to allow rewriting, or 'hasFixedRuntimeRep_syntactic'+-- to perform a syntactic check.+checkFRR_with :: HasDebugCallStack+              => (FixedRuntimeRepOrigin -> TcKind -> TcM TcMCoercionN)+                   -- ^ The check to perform on the kind.+              -> FixedRuntimeRepContext+                   -- ^ The context which required a fixed 'RuntimeRep',+                   -- e.g. an application, a lambda abstraction, ...+              -> TcType+                   -- ^ The type @ty@ to check (the check itself only looks at its kind).+              -> TcM (TcCoercionN, TcTypeFRR)+                  -- ^ Returns @(co, frr_ty)@ with @co :: ty ~# frr_ty@+                  -- and @frr_@ty has a fixed 'RuntimeRep'.+checkFRR_with check_kind frr_ctxt ty+  = do { th_stage <- getStage+       ; if+          -- Shortcut: check for 'Type' and 'UnliftedType' type synonyms.+          | TyConApp tc [] <- ki+          , tc == liftedTypeKindTyCon || tc == unliftedTypeKindTyCon+          -> return refl++          -- See [Wrinkle: Typed Template Haskell] in Note [hasFixedRuntimeRep].+          | Brack _ (TcPending {}) <- th_stage+          -> return refl++          -- Otherwise: ensure that the kind 'ki' of 'ty' is concrete.+          | otherwise+          -> do { kco <- check_kind frr_orig ki+                ; return ( mkTcGReflRightMCo Nominal ty kco+                         , mkCastTyMCo ty kco ) } }++  where+    refl :: (TcCoercionN, TcType)+    refl = (mkTcNomReflCo ty, ty)+    ki :: TcKind+    ki = typeKind ty+    frr_orig :: FixedRuntimeRepOrigin+    frr_orig = FixedRuntimeRepOrigin { frr_type = ty, frr_context = frr_ctxt }++-- | Ensure that the given type @ty@ can unify with a concrete type,+-- in the sense of Note [Concrete types].+--+-- Returns a coercion @co :: ty ~# conc_ty@, where @conc_ty@ is+-- concrete.+--+-- If the type is already syntactically concrete, this+-- immediately returns a reflexive coercion. Otherwise,+-- it creates a new concrete metavariable @concrete_tv@+-- and emits an equality constraint @ty ~# concrete_tv@,+-- to be handled by the constraint solver.+--+-- Invariant: the kind of the supplied type must be concrete.+--+-- We assume the provided type is already at the kind-level+-- (this only matters for error messages).+unifyConcrete :: HasDebugCallStack+              => FixedRuntimeRepOrigin -> TcType -> TcM TcMCoercionN+unifyConcrete frr_orig ty+  = do { (ty, errs) <- makeTypeConcrete (ConcreteFRR frr_orig) ty+       ; case errs of+           -- We were able to make the type fully concrete.+         { [] -> return MRefl+           -- The type could not be made concrete; perhaps it contains+           -- a skolem type variable, a type family application, ...+           --+           -- Create a new ConcreteTv metavariable @concrete_tv@+           -- and unify @ty ~# concrete_tv@.+         ; _  ->+    do { conc_tv <- newConcreteTyVar (ConcreteFRR frr_orig) ki+           -- NB: newConcreteTyVar asserts that 'ki' is concrete.+       ; coToMCo <$> emitWantedEq orig KindLevel Nominal ty (mkTyVarTy conc_tv) } } }+  where+    ki :: TcKind+    ki = typeKind ty+    orig :: CtOrigin+    orig = FRROrigin frr_orig++-- | Ensure that the given type is concrete.+--+-- This is an eager syntactic check, and never defers+-- any work to the constraint solver.+--+-- Invariant: the kind of the supplied type must be concrete.+-- Invariant: the output type is equal to the input type,+--            up to zonking.+--+-- We assume the provided type is already at the kind-level+-- (this only matters for error messages).+ensureConcrete :: HasDebugCallStack+               => FixedRuntimeRepOrigin+               -> TcType+               -> TcM TcType+ensureConcrete frr_orig ty+  = do { (ty', errs) <- makeTypeConcrete conc_orig ty+       ; case errs of+          { err:errs ->+              do { traceTc "ensureConcrete } failure" $+                     vcat [ text "ty:" <+> ppr ty+                          , text "ty':" <+> ppr ty' ]+                 ; loc <- getCtLocM (FRROrigin frr_orig) (Just KindLevel)+                 ; emitNotConcreteError $+                     NCE_FRR+                       { nce_loc = loc+                       , nce_frr_origin = frr_orig+                       , nce_reasons = err :| errs }+                 }+          ; [] ->+              traceTc "ensureConcrete } success" $+                vcat [ text "ty: " <+> ppr ty+                     , text "ty':" <+> ppr ty' ] }+        ; return ty' }+  where+    conc_orig :: ConcreteTvOrigin+    conc_orig = ConcreteFRR frr_orig++{-***********************************************************************+%*                                                                      *+                    Making a type concrete+%*                                                                      *+%************************************************************************++Note [Unifying concrete metavariables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Unifying concrete metavariables (as defined in Note [ConcreteTv]) is not+an all-or-nothing affair as it is for other sorts of metavariables.++Consider the following unification problem in which all metavariables+are unfilled (and ignoring any TcLevel considerations):++  alpha[conc] ~# TYPE (TupleRep '[ beta[conc], IntRep, gamma[tau] ])++We can't immediately unify `alpha` with the RHS, because the RHS is not+a concrete type (in the sense of Note [Concrete types]). Instead, we+proceed as follows:++  - create a fresh concrete metavariable variable `gamma'[conc]`,+  - write gamma[tau] := gamma'[conc],+  - write alpha[conc] := TYPE (TupleRep '[ beta[conc], IntRep, gamma'[conc] ]).++Thus, in general, to unify `alpha[conc] ~# rhs`, we first try to turn+`rhs` into a concrete type (see the 'makeTypeConcrete' function).+If this succeeds, resulting in a concrete type `rhs'`, we simply fill+`alpha[conc] := rhs'`. If it fails, then syntactic unification fails.++Example 1:++    alpha[conc] ~# TYPE (TupleRep '[ beta[conc], IntRep, gamma[tau] ])++  We proceed by filling metavariables:++    gamma[tau] := gamma[conc]+    alpha[conc] := TYPE (TupleRep '[ beta[conc], IntRep, gamma[conc] ])++  This successfully unifies alpha.++Example 2:++  For a type family `F :: Type -> Type`:++    delta[conc] ~# TYPE (SumRep '[ zeta[tau], a[sk], F omega[tau] ])++  We write zeta[tau] := zeta[conc], and then fail, providing the following+  two reasons:++    - `a[sk]` is not a concrete type variable, so the overall type+      cannot be concrete+    - `F` is not a concrete type constructor, in the sense of+       Note [Concrete types]. So we keep it as is; in particular,+       we /should not/ try to make its argument `omega[tau]` into+       a ConcreteTv.++  Note that making zeta concrete allows us to propagate information.+  For example, after more typechecking, we might try to unify+  `zeta ~# rr[sk]`. If we made zeta a ConcreteTv, we will report+  this unsolved equality using the 'ConcreteTvOrigin' stored in zeta[conc].+  This allows us to report ALL the problems in a representation-polymorphism+  check (instead of only a non-empty subset).+-}++-- | Try to turn the provided type into a concrete type, by ensuring+-- unfilled metavariables are appropriately marked as concrete.+--+-- Returns a zonked type which is "as concrete as possible", and+-- a list of problems encountered when trying to make it concrete.+--+-- INVARIANT: the returned type is equal to the input type, up to zonking.+-- INVARIANT: if this function returns an empty list of 'NotConcreteReasons',+-- then the returned type is concrete, in the sense of Note [Concrete types].+makeTypeConcrete :: ConcreteTvOrigin -> TcType -> TcM (TcType, [NotConcreteReason])+-- TODO: it could be worthwhile to return enough information to continue solving.+-- Consider unifying `alpha[conc] ~# TupleRep '[ beta[tau], F Int ]` for+-- a type family 'F'.+-- This function will concretise `beta[tau] := beta[conc]` and return+-- that `TupleRep '[ beta[conc], F Int ]` is not concrete because of the+-- type family application `F Int`. But we could decompose by setting+-- alpha := TupleRep '[ beta, gamma[conc] ] and emitting `[W] gamma[conc] ~ F Int`.+--+-- This would be useful in startSolvingByUnification.+makeTypeConcrete conc_orig ty =+  do { res@(ty', _) <- runWriterT $ go ty+     ; traceTc "makeTypeConcrete" $+        vcat [ text "ty:" <+> ppr ty+             , text "ty':" <+> ppr ty' ]+     ; return res }+  where+    go :: TcType -> WriterT [NotConcreteReason] TcM TcType+    go ty+      | Just ty <- tcView ty+      = go ty+      | isConcrete ty+      = pure ty+    go ty@(TyVarTy tv) -- not a ConcreteTv (already handled above)+      = do { mb_filled <- lift $ isFilledMetaTyVar_maybe tv+           ; case mb_filled of+           { Just ty -> go ty+           ; Nothing+               | isMetaTyVar tv+               , TauTv <- metaTyVarInfo tv+               -> -- Change the MetaInfo to ConcreteTv, but retain the TcLevel+               do { kind <- go (tyVarKind tv)+                  ; lift $+                    do { conc_tv <- setTcLevel (tcTyVarLevel tv) $+                                    newConcreteTyVar conc_orig kind+                       ; let conc_ty = mkTyVarTy conc_tv+                       ; writeMetaTyVar tv conc_ty+                       ; return conc_ty } }+               | otherwise+               -- Don't attempt to make other type variables concrete+               -- (e.g. SkolemTv, TyVarTv, CycleBreakerTv, RuntimeUnkTv).+               -> bale_out ty (NonConcretisableTyVar tv) } }+    go ty@(TyConApp tc tys)+      | isConcreteTyCon tc+      = mkTyConApp tc <$> mapM go tys+      | otherwise+      = bale_out ty (NonConcreteTyCon tc tys)+    go (FunTy af w ty1 ty2)+      = do { w <- go w+           ; ty1 <- go ty1+           ; ty2 <- go ty2+           ; return $ mkFunTy af w ty1 ty2 }+    go (AppTy ty1 ty2)+      = do { ty1 <- go ty1+           ; ty2 <- go ty2+           ; return $ mkAppTy ty1 ty2 }+    go ty@(LitTy {})+      = return ty+    go ty@(CastTy cast_ty kco)+      = bale_out ty (ContainsCast cast_ty kco)+    go ty@(ForAllTy tcv body)+      = bale_out ty (ContainsForall tcv body)+    go ty@(CoercionTy co)+      = bale_out ty (ContainsCoercionTy co)++    bale_out :: TcType -> NotConcreteReason -> WriterT [NotConcreteReason] TcM TcType+    bale_out ty reason = do { tell [reason]; return ty }
GHC/Tc/Utils/Env.hs view
@@ -1,5 +1,5 @@ -- (c) The University of Glasgow 2006-{-# LANGUAGE CPP, FlexibleInstances #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# OPTIONS_GHC -fno-warn-orphans #-}  -- instance MonadThings is necessarily an                                        -- orphan@@ -18,13 +18,13 @@         -- Global environment         tcExtendGlobalEnv, tcExtendTyConEnv,         tcExtendGlobalEnvImplicit, setGlobalTypeEnv,-        tcExtendGlobalValEnv,+        tcExtendGlobalValEnv, tcTyThBinders,         tcLookupLocatedGlobal, tcLookupGlobal, tcLookupGlobalOnly,         tcLookupTyCon, tcLookupClass,         tcLookupDataCon, tcLookupPatSyn, tcLookupConLike,         tcLookupLocatedGlobalId, tcLookupLocatedTyCon,         tcLookupLocatedClass, tcLookupAxiom,-        lookupGlobal, ioLookupDataCon,+        lookupGlobal, lookupGlobal_maybe, ioLookupDataCon,         addTypecheckedBinds,          -- Local environment@@ -70,8 +70,6 @@         mkWrapperName   ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Driver.Env@@ -87,6 +85,7 @@ import GHC.Iface.Env import GHC.Iface.Load +import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Tc.Utils.TcMType import GHC.Tc.Utils.TcType@@ -96,7 +95,7 @@  import GHC.Core.UsageEnv import GHC.Core.InstEnv-import GHC.Core.DataCon ( DataCon )+import GHC.Core.DataCon ( DataCon, flSelector ) import GHC.Core.PatSyn  ( PatSyn ) import GHC.Core.ConLike import GHC.Core.TyCon@@ -130,11 +129,13 @@ import GHC.Types.Var.Env import GHC.Types.Name.Reader import GHC.Types.TyThing+import GHC.Types.Error import qualified GHC.LanguageExtensions as LangExt  import Data.IORef import Data.List (intercalate) import Control.Monad+import GHC.Driver.Env.KnotVars  {- ********************************************************************* *                                                                      *@@ -160,8 +161,8 @@ lookupGlobal_maybe hsc_env name   = do  {    -- Try local envt           let mod = icInteractiveModule (hsc_IC hsc_env)-              home_unit = hsc_home_unit hsc_env-              tcg_semantic_mod = homeModuleInstantiation home_unit mod+              mhome_unit = hsc_home_unit_maybe hsc_env+              tcg_semantic_mod = homeModuleInstantiation mhome_unit mod          ; if nameIsLocalOrFrom tcg_semantic_mod name               then (return@@ -256,7 +257,7 @@     do  { mb_thing <- tcLookupImported_maybe name         ; case mb_thing of             Succeeded thing -> return thing-            Failed msg      -> failWithTc msg+            Failed msg      -> failWithTc (TcRnUnknownMessage $ mkPlainError noHints msg)         }}}  -- Look up only in this module's global env't. Don't look in imports, etc.@@ -326,10 +327,12 @@ tcLookupInstance cls tys   = do { instEnv <- tcGetInstEnvs        ; case lookupUniqueInstEnv instEnv cls tys of-           Left err             -> failWithTc $ text "Couldn't match instance:" <+> err+           Left err             ->+             failWithTc $ TcRnUnknownMessage+                        $ mkPlainError noHints (text "Couldn't match instance:" <+> err)            Right (inst, tys)              | uniqueTyVars tys -> return inst-             | otherwise        -> failWithTc errNotExact+             | otherwise        -> failWithTc (TcRnUnknownMessage $ mkPlainError noHints errNotExact)        }   where     errNotExact = text "Not an exact match (i.e., some variables get instantiated)"@@ -363,7 +366,9 @@ --                  * the tcg_type_env_var field seen by interface files setGlobalTypeEnv tcg_env new_type_env   = do  {     -- Sync the type-envt variable seen by interface files-           writeMutVar (tcg_type_env_var tcg_env) new_type_env+         ; case lookupKnotVars (tcg_type_env_var tcg_env) (tcg_mod tcg_env) of+              Just tcg_env_var -> writeMutVar tcg_env_var new_type_env+              Nothing -> return ()          ; return (tcg_env { tcg_type_env = new_type_env }) }  @@ -397,6 +402,24 @@          tcExtendGlobalEnvImplicit (map ATyCon tycons) thing_inside        } +-- Given a [TyThing] of "non-value" bindings coming from type decls+-- (constructors, field selectors, class methods) return their+-- TH binding levels (to be added to a LclEnv).+-- See GHC ticket #17820 .+tcTyThBinders :: [TyThing] -> TcM ThBindEnv+tcTyThBinders implicit_things = do+  stage <- getStage+  let th_lvl  = thLevel stage+      th_bndrs = mkNameEnv+                  [ ( n , (TopLevel, th_lvl) ) | n <- names ]+  return th_bndrs+  where+    names = concatMap get_names implicit_things+    get_names (AConLike acl) =+      conLikeName acl : map flSelector (conLikeFieldLabels acl)+    get_names (AnId i) = [idName i]+    get_names _ = []+ tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a   -- Same deal as tcExtendGlobalEnv, but for Ids tcExtendGlobalValEnv ids thing_inside@@ -513,6 +536,7 @@ -- Scoped type and kind variables tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r tcExtendTyVarEnv tvs thing_inside+  -- MP: This silently coerces TyVar to TcTyVar.   = tcExtendNameTyVarEnv (mkTyVarNamePairs tvs) thing_inside  tcExtendNameTyVarEnv :: [(Name,TcTyVar)] -> TcM r -> TcM r@@ -615,29 +639,28 @@ -- that are bound together with extra_env and should not be regarded -- as free in the types of extra_env.   = do  { traceTc "tc_extend_local_env" (ppr extra_env)-        ; stage <- getStage-        ; env0@(TcLclEnv { tcl_rdr      = rdr_env-                         , tcl_th_bndrs = th_bndrs-                         , tcl_env      = lcl_type_env }) <- getLclEnv--        ; let thlvl = (top_lvl, thLevel stage)--              env1 = env0 { tcl_rdr = extendLocalRdrEnvList rdr_env-                                      [ n | (n, _) <- extra_env, isInternalName n ]-                                      -- The LocalRdrEnv contains only non-top-level names-                                      -- (GlobalRdrEnv handles the top level)--                         , tcl_th_bndrs = extendNameEnvList th_bndrs-                                          [(n, thlvl) | (n, ATcId {}) <- extra_env]-                                          -- We only track Ids in tcl_th_bndrs+        ; updLclEnv upd_lcl_env thing_inside }+  where+    upd_lcl_env env0@(TcLclEnv { tcl_th_ctxt  = stage+                               , tcl_rdr      = rdr_env+                               , tcl_th_bndrs = th_bndrs+                               , tcl_env      = lcl_type_env })+       = env0 { tcl_rdr = extendLocalRdrEnvList rdr_env+                          [ n | (n, _) <- extra_env, isInternalName n ]+                          -- The LocalRdrEnv contains only non-top-level names+                          -- (GlobalRdrEnv handles the top level) -                         , tcl_env = extendNameEnvList lcl_type_env extra_env }+              , tcl_th_bndrs = extendNameEnvList th_bndrs+                               [(n, thlvl) | (n, ATcId {}) <- extra_env]+                               -- We only track Ids in tcl_th_bndrs +              , tcl_env = extendNameEnvList lcl_type_env extra_env }               -- tcl_rdr and tcl_th_bndrs: extend the local LocalRdrEnv and               -- Template Haskell staging env simultaneously. Reason for extending               -- LocalRdrEnv: after running a TH splice we need to do renaming.+      where+        thlvl = (top_lvl, thLevel stage) -        ; setLclEnv env1 thing_inside }  tcExtendLocalTypeEnv :: TcLclEnv -> [(Name, TcTyThing)] -> TcLclEnv tcExtendLocalTypeEnv lcl_env@(TcLclEnv { tcl_env = lcl_type_env }) tc_ty_things@@ -723,7 +746,7 @@        = do { let (env', occ') = tidyOccName env (nameOccName name)                   name'  = tidyNameOcc name occ'                   tyvar1 = setTyVarName tyvar name'-            ; tyvar2 <- zonkTcTyVarToTyVar tyvar1+            ; tyvar2 <- zonkTcTyVarToTcTyVar tyvar1               -- Be sure to zonk here!  Tidying applies to zonked               -- types, so if we don't zonk we may create an               -- ill-kinded type (#14175)@@ -876,6 +899,7 @@    | otherwise                   -- Badly staged   = failWithTc $                -- E.g.  \x -> $(f x)+    TcRnUnknownMessage $ mkPlainError noHints $     text "Stage error:" <+> pp_thing <+>         hsep   [text "is bound at stage" <+> ppr bind_lvl,                 text "but used at stage" <+> ppr use_lvl]@@ -883,6 +907,7 @@ stageRestrictionError :: SDoc -> TcM a stageRestrictionError pp_thing   = failWithTc $+    TcRnUnknownMessage $ mkPlainError noHints $     sep [ text "GHC stage restriction:"         , nest 2 (vcat [ pp_thing <+> text "is used in a top-level splice, quasi-quote, or annotation,"                        , text "and must be imported, not defined locally"])]@@ -1086,7 +1111,8 @@ mkStableIdFromString str sig_ty loc occ_wrapper = do     uniq <- newUnique     mod <- getModule-    name <- mkWrapperName "stable" str+    nextWrapperNum <- tcg_next_wrapper_num <$> getGblEnv+    name <- mkWrapperName nextWrapperNum "stable" str     let occ = mkVarOccFS name :: OccName         gnm = mkExternalName uniq mod (occ_wrapper occ) loc :: Name         id  = mkExportedVanillaId gnm sig_ty :: Id@@ -1095,14 +1121,14 @@ mkStableIdFromName :: Name -> Type -> SrcSpan -> (OccName -> OccName) -> TcM TcId mkStableIdFromName nm = mkStableIdFromString (getOccString nm) -mkWrapperName :: (MonadIO m, HasDynFlags m, HasModule m)-              => String -> String -> m FastString-mkWrapperName what nameBase-    = do dflags <- getDynFlags-         thisMod <- getModule-         let -- Note [Generating fresh names for ccall wrapper]-             wrapperRef = nextWrapperNum dflags-             pkg = unitString  (moduleUnit thisMod)+mkWrapperName :: (MonadIO m, HasModule m)+              => IORef (ModuleEnv Int) -> String -> String -> m FastString+-- ^ @mkWrapperName ref what nameBase@+--+-- See Note [Generating fresh names for ccall wrapper] for @ref@'s purpose.+mkWrapperName wrapperRef what nameBase+    = do thisMod <- getModule+         let pkg = unitString  (moduleUnit thisMod)              mod = moduleNameString (moduleName      thisMod)          wrapperNum <- liftIO $ atomicModifyIORef' wrapperRef $ \mod_env ->              let num = lookupWithDefaultModuleEnv mod_env 0 thisMod@@ -1149,6 +1175,7 @@                                             -- don't report it again (#11941)              | otherwise -> stageRestrictionError (quotes (ppr name))            _ -> failWithTc $+                TcRnUnknownMessage $ mkPlainError noHints $                 vcat[text "GHC internal error:" <+> quotes (ppr name) <+>                      text "is not in scope during type checking, but it passed the renamer",                      text "tcl_env of environment:" <+> ppr (tcl_env lcl_env)]@@ -1164,8 +1191,10 @@ -- turn does not look at the details of the TcTyThing. -- See Note [Placeholder PatSyn kinds] in GHC.Tc.Gen.Bind wrongThingErr expected thing name-  = failWithTc (pprTcTyThingCategory thing <+> quotes (ppr name) <+>-                text "used as a" <+> text expected)+  = let msg = TcRnUnknownMessage $ mkPlainError noHints $+          (pprTcTyThingCategory thing <+> quotes (ppr name) <+>+                     text "used as a" <+> text expected)+  in failWithTc msg  {- Note [Out of scope might be a staging error] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
GHC/Tc/Utils/Instantiate.hs view
@@ -1,5 +1,6 @@-{-# LANGUAGE CPP              #-}+ {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DisambiguateRecordFields #-}  {-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}@@ -18,7 +19,8 @@      newWanted, newWanteds,       tcInstType, tcInstTypeBndrs,-     tcInstSkolTyVars, tcInstSkolTyVarsX, tcInstSkolTyVarsAt,+     tcSkolemiseInvisibleBndrs,+     tcInstSkolTyVars, tcInstSkolTyVarsX,      tcSkolDFunType, tcSuperSkolTyVars, tcInstSuperSkolTyVarsX,       freshenTyVarBndrs, freshenCoVarBndrsX,@@ -38,8 +40,6 @@      tyCoVarsOfCt, tyCoVarsOfCts,   ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Driver.Session@@ -49,6 +49,7 @@ import GHC.Builtin.Names  import GHC.Hs+import GHC.Hs.Syn.Type   ( hsLitType )  import GHC.Core.InstEnv import GHC.Core.Predicate@@ -69,11 +70,14 @@ import GHC.Tc.Utils.Env import GHC.Tc.Types.Evidence import GHC.Tc.Instance.FunDeps+import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic ) import GHC.Tc.Utils.TcMType import GHC.Tc.Utils.TcType+import GHC.Tc.Errors.Types  import GHC.Types.Id.Make( mkDictFunId )-import GHC.Types.Basic ( TypeOrKind(..) )+import GHC.Types.Basic ( TypeOrKind(..), Arity )+import GHC.Types.Error import GHC.Types.SourceText import GHC.Types.SrcLoc as SrcLoc import GHC.Types.Var.Env@@ -85,13 +89,15 @@  import GHC.Utils.Misc import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Utils.Outputable  import GHC.Unit.State import GHC.Unit.External -import Data.List ( sortBy, mapAccumL )-import Control.Monad( unless )+import Data.List ( mapAccumL )+import qualified Data.List.NonEmpty as NE+import Control.Monad( when, unless ) import Data.Function ( on )  {-@@ -124,7 +130,7 @@         ; let ty = piResultTys (idType id) ty_args              (theta, _caller_knows_this) = tcSplitPhiTy ty-       ; wrap <- ASSERT( not (isForAllTy ty) && isSingleton theta )+       ; wrap <- assert (not (isForAllTy ty) && isSingleton theta) $                  instCall origin ty_args theta         ; return (mkHsWrap wrap (HsVar noExtField (noLocA id))) }@@ -163,13 +169,14 @@  -} -topSkolemise :: TcSigmaType+topSkolemise :: SkolemInfo+             -> TcSigmaType              -> TcM ( HsWrapper                     , [(Name,TyVar)]     -- All skolemised variables                     , [EvVar]            -- All "given"s                     , TcRhoType ) -- See Note [Skolemisation]-topSkolemise ty+topSkolemise skolem_info ty   = go init_subst idHsWrapper [] [] ty   where     init_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType ty))@@ -178,7 +185,7 @@     go subst wrap tv_prs ev_vars ty       | (tvs, theta, inner_ty) <- tcSplitSigmaTy ty       , not (null tvs && null theta)-      = do { (subst', tvs1) <- tcInstSkolTyVarsX subst tvs+      = do { (subst', tvs1) <- tcInstSkolTyVarsX skolem_info subst tvs            ; ev_vars1       <- newEvVars (substTheta subst' theta)            ; go subst'                 (wrap <.> mkWpTyLams tvs1 <.> mkWpLams ev_vars1)@@ -397,7 +404,7 @@   | Just (mk, k1, k2) <- get_eq_tys_maybe (substTy subst (scaledThing ty))     -- Equality is the *only* constraint currently handled in types.     -- See Note [Constraints in kinds] in GHC.Core.TyCo.Rep-  = ASSERT( af == InvisArg )+  = assert (af == InvisArg) $     do { co <- unifyKind Nothing k1 k2        ; arg' <- mk co        ; return (subst, arg') }@@ -491,70 +498,99 @@       = do { (subst', tv') <- newMetaTyVarTyVarX subst tv            ; return (subst', Bndr tv' spec) } -tcSkolDFunType :: DFunId -> TcM ([TcTyVar], TcThetaType, TcType)+--------------------------+tcSkolDFunType :: SkolemInfo -> DFunId -> TcM ([TcTyVar], TcThetaType, TcType) -- Instantiate a type signature with skolem constants. -- This freshens the names, but no need to do so-tcSkolDFunType dfun-  = do { (tv_prs, theta, tau) <- tcInstType tcInstSuperSkolTyVars dfun+tcSkolDFunType skol_info dfun+  = do { (tv_prs, theta, tau) <- tcInstType (tcInstSuperSkolTyVars skol_info) dfun        ; return (map snd tv_prs, theta, tau) } -tcSuperSkolTyVars :: [TyVar] -> (TCvSubst, [TcTyVar])+tcSuperSkolTyVars :: TcLevel -> SkolemInfo -> [TyVar] -> (TCvSubst, [TcTyVar]) -- Make skolem constants, but do *not* give them new names, as above--- Moreover, make them "super skolems"; see comments with superSkolemTv--- see Note [Kind substitution when instantiating]+-- As always, allocate them one level in+-- Moreover, make them "super skolems"; see GHC.Core.InstEnv+--    Note [Binding when looking up instances]+-- See Note [Kind substitution when instantiating] -- Precondition: tyvars should be ordered by scoping-tcSuperSkolTyVars = mapAccumL tcSuperSkolTyVar emptyTCvSubst--tcSuperSkolTyVar :: TCvSubst -> TyVar -> (TCvSubst, TcTyVar)-tcSuperSkolTyVar subst tv-  = (extendTvSubstWithClone subst tv new_tv, new_tv)+tcSuperSkolTyVars tc_lvl skol_info = mapAccumL do_one emptyTCvSubst   where-    kind   = substTyUnchecked subst (tyVarKind tv)-    new_tv = mkTcTyVar (tyVarName tv) kind superSkolemTv+    details = SkolemTv skol_info (pushTcLevel tc_lvl)+                       True   -- The "super" bit+    do_one subst tv = (extendTvSubstWithClone subst tv new_tv, new_tv)+      where+        kind   = substTyUnchecked subst (tyVarKind tv)+        new_tv = mkTcTyVar (tyVarName tv) kind details  -- | Given a list of @['TyVar']@, skolemize the type variables, -- returning a substitution mapping the original tyvars to the -- skolems, and the list of newly bound skolems.-tcInstSkolTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar])+tcInstSkolTyVars :: SkolemInfo -> [TyVar] -> TcM (TCvSubst, [TcTyVar]) -- See Note [Skolemising type variables]-tcInstSkolTyVars = tcInstSkolTyVarsX emptyTCvSubst+tcInstSkolTyVars skol_info = tcInstSkolTyVarsX skol_info emptyTCvSubst -tcInstSkolTyVarsX :: TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar])+tcInstSkolTyVarsX :: SkolemInfo -> TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar]) -- See Note [Skolemising type variables]-tcInstSkolTyVarsX = tcInstSkolTyVarsPushLevel False+tcInstSkolTyVarsX skol_info = tcInstSkolTyVarsPushLevel skol_info False -tcInstSuperSkolTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar])+tcInstSuperSkolTyVars :: SkolemInfo -> [TyVar] -> TcM (TCvSubst, [TcTyVar]) -- See Note [Skolemising type variables] -- This version freshens the names and creates "super skolems"; -- see comments around superSkolemTv.-tcInstSuperSkolTyVars = tcInstSuperSkolTyVarsX emptyTCvSubst+tcInstSuperSkolTyVars skol_info = tcInstSuperSkolTyVarsX skol_info emptyTCvSubst -tcInstSuperSkolTyVarsX :: TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar])+tcInstSuperSkolTyVarsX :: SkolemInfo -> TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar]) -- See Note [Skolemising type variables] -- This version freshens the names and creates "super skolems"; -- see comments around superSkolemTv.-tcInstSuperSkolTyVarsX subst = tcInstSkolTyVarsPushLevel True subst+tcInstSuperSkolTyVarsX skol_info subst = tcInstSkolTyVarsPushLevel skol_info True subst -tcInstSkolTyVarsPushLevel :: Bool  -- True <=> make "super skolem"+tcInstSkolTyVarsPushLevel :: SkolemInfo -> Bool  -- True <=> make "super skolem"                           -> TCvSubst -> [TyVar]                           -> TcM (TCvSubst, [TcTyVar]) -- Skolemise one level deeper, hence pushTcLevel -- See Note [Skolemising type variables]-tcInstSkolTyVarsPushLevel overlappable subst tvs+tcInstSkolTyVarsPushLevel skol_info overlappable subst tvs   = do { tc_lvl <- getTcLevel        -- Do not retain the whole TcLclEnv        ; let !pushed_lvl = pushTcLevel tc_lvl-       ; tcInstSkolTyVarsAt pushed_lvl overlappable subst tvs }+       ; tcInstSkolTyVarsAt skol_info pushed_lvl overlappable subst tvs } -tcInstSkolTyVarsAt :: TcLevel -> Bool+tcInstSkolTyVarsAt :: SkolemInfo -> TcLevel -> Bool                    -> TCvSubst -> [TyVar]                    -> TcM (TCvSubst, [TcTyVar])-tcInstSkolTyVarsAt lvl overlappable subst tvs+tcInstSkolTyVarsAt skol_info lvl overlappable subst tvs   = freshenTyCoVarsX new_skol_tv subst tvs   where-    details = SkolemTv lvl overlappable-    new_skol_tv name kind = mkTcTyVar name kind details+    sk_details = SkolemTv skol_info lvl overlappable+    new_skol_tv name kind = mkTcTyVar name kind sk_details +tcSkolemiseInvisibleBndrs :: SkolemInfoAnon -> Type -> TcM ([TcTyVar], TcType)+-- Skolemise the outer invisible binders of a type+-- Do /not/ freshen them, because their scope is broader than+-- just this type.  It's a bit dubious, but used in very limited ways.+tcSkolemiseInvisibleBndrs skol_info ty+  = do { let (tvs, body_ty) = tcSplitForAllInvisTyVars ty+       ; lvl           <- getTcLevel+       ; skol_info     <- mkSkolemInfo skol_info+       ; let details = SkolemTv skol_info lvl False+             mk_skol_tv name kind = return (mkTcTyVar name kind details)  -- No freshening+       ; (subst, tvs') <- instantiateTyVarsX mk_skol_tv emptyTCvSubst tvs+       ; return (tvs', substTy subst body_ty) }++instantiateTyVarsX :: (Name -> Kind -> TcM TcTyVar)+                   -> TCvSubst -> [TyVar]+                   -> TcM (TCvSubst, [TcTyVar])+-- Instantiate each type variable in turn with the specified function+instantiateTyVarsX mk_tv subst tvs+  = case tvs of+      []       -> return (subst, [])+      (tv:tvs) -> do { let kind1 = substTyUnchecked subst (tyVarKind tv)+                     ; tv' <- mk_tv (tyVarName tv) kind1+                     ; let subst1 = extendTCvSubstWithClone subst tv tv'+                     ; (subst', tvs') <- instantiateTyVarsX mk_tv subst1 tvs+                     ; return (subst', tv':tvs') }+ ------------------ freshenTyVarBndrs :: [TyVar] -> TcM (TCvSubst, [TyVar]) -- ^ Give fresh uniques to a bunch of TyVars, but they stay@@ -575,22 +611,21 @@ freshenTyCoVarsX :: (Name -> Kind -> TyCoVar)                  -> TCvSubst -> [TyCoVar]                  -> TcM (TCvSubst, [TyCoVar])-freshenTyCoVarsX mk_tcv = mapAccumLM (freshenTyCoVarX mk_tcv)--freshenTyCoVarX :: (Name -> Kind -> TyCoVar)-                -> TCvSubst -> TyCoVar -> TcM (TCvSubst, TyCoVar) -- This a complete freshening operation: -- the skolems have a fresh unique, and a location from the monad -- See Note [Skolemising type variables]-freshenTyCoVarX mk_tcv subst tycovar-  = do { loc  <- getSrcSpanM-       ; uniq <- newUnique-       ; let old_name = tyVarName tycovar-             new_name = mkInternalName uniq (getOccName old_name) loc-             new_kind = substTyUnchecked subst (tyVarKind tycovar)-             new_tcv  = mk_tcv new_name new_kind-             subst1   = extendTCvSubstWithClone subst tycovar new_tcv-       ; return (subst1, new_tcv) }+freshenTyCoVarsX mk_tcv+  = instantiateTyVarsX freshen_tcv+  where+    freshen_tcv :: Name -> Kind -> TcM TcTyVar+    freshen_tcv name kind+      = do { loc  <- getSrcSpanM+           ; uniq <- newUnique+           ; let !occ_name = getOccName name+                    -- Force so we don't retain reference to the old+                    -- name and id.   See (#19619) for more discussion+                 new_name = mkInternalName uniq occ_name loc+           ; return (mk_tcv new_name kind) }  {- Note [Skolemising type variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -672,8 +707,8 @@                            -> ExpRhoType                            -> TcM (HsOverLit GhcTc) newNonTrivialOverloadedLit-  lit@(OverLit { ol_val = val, ol_witness = HsVar _ (L _ meth_name)-               , ol_ext = rebindable }) res_ty+  lit@(OverLit { ol_val = val, ol_ext = OverLitRn rebindable (L _ meth_name) })+  res_ty   = do  { hs_lit <- mkOverLit val         ; let lit_ty = hsLitType hs_lit         ; (_, fi') <- tcSyntaxOp orig (mkRnSyntaxExpr meth_name)@@ -681,14 +716,12 @@                       \_ _ -> return ()         ; let L _ witness = nlHsSyntaxApps fi' [nlHsLit hs_lit]         ; res_ty <- readExpType res_ty-        ; return (lit { ol_witness = witness-                      , ol_ext = OverLitTc rebindable res_ty }) }+        ; return (lit { ol_ext = OverLitTc { ol_rebindable = rebindable+                                           , ol_witness = witness+                                           , ol_type = res_ty } }) }   where     orig = LiteralOrigin lit -newNonTrivialOverloadedLit lit _-  = pprPanic "newNonTrivialOverloadedLit" (ppr lit)- ------------ mkOverLit ::OverLitVal -> TcM (HsLit GhcTc) mkOverLit (HsIntegral i)@@ -735,10 +768,10 @@ -}  tcSyntaxName :: CtOrigin-             -> TcType                 -- ^ Type to instantiate it at-             -> (Name, HsExpr GhcRn)   -- ^ (Standard name, user name)+             -> TcType                  -- ^ Type to instantiate it at+             -> (Name, HsExpr GhcRn)    -- ^ (Standard name, user name)              -> TcM (Name, HsExpr GhcTc)-                                       -- ^ (Standard name, suitable expression)+                                        -- ^ (Standard name, suitable expression) -- USED ONLY FOR CmdTop (sigh) *** -- See Note [CmdSyntaxTable] in "GHC.Hs.Expr" @@ -750,35 +783,69 @@ tcSyntaxName orig ty (std_nm, user_nm_expr) = do     std_id <- tcLookupId std_nm     let-        -- C.f. newMethodAtLoc         ([tv], _, tau) = tcSplitSigmaTy (idType std_id)         sigma1         = substTyWith [tv] [ty] tau         -- Actually, the "tau-type" might be a sigma-type in the         -- case of locally-polymorphic methods. -    addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1) $ do+    span <- getSrcSpanM+    addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1 span) $ do          -- Check that the user-supplied thing has the         -- same type as the standard one.         -- Tiresome jiggling because tcCheckSigma takes a located expression-     span <- getSrcSpanM      expr <- tcCheckPolyExpr (L (noAnnSrcSpan span) user_nm_expr) sigma1+     hasFixedRuntimeRepRes std_nm user_nm_expr sigma1      return (std_nm, unLoc expr) -syntaxNameCtxt :: HsExpr GhcRn -> CtOrigin -> Type -> TidyEnv+syntaxNameCtxt :: HsExpr GhcRn -> CtOrigin -> Type -> SrcSpan -> TidyEnv                -> TcRn (TidyEnv, SDoc)-syntaxNameCtxt name orig ty tidy_env-  = do { inst_loc <- getCtLocM orig (Just TypeLevel)-       ; let msg = vcat [ text "When checking that" <+> quotes (ppr name)+syntaxNameCtxt name orig ty loc tidy_env = return (tidy_env, msg)+  where+    msg = vcat [ text "When checking that" <+> quotes (ppr name)                           <+> text "(needed by a syntactic construct)"-                        , nest 2 (text "has the required type:"-                                  <+> ppr (tidyType tidy_env ty))-                        , nest 2 (pprCtLoc inst_loc) ]-       ; return (tidy_env, msg) }+               , nest 2 (text "has the required type:"+                         <+> ppr (tidyType tidy_env ty))+               , nest 2 (sep [ppr orig, text "at" <+> ppr loc])]  {- ************************************************************************ *                                                                      *+                FixedRuntimeRep+*                                                                      *+************************************************************************+-}++-- | Check that the result type of an expression has a fixed runtime representation.+--+-- Used only for arrow operations such as 'arr', 'first', etc.+hasFixedRuntimeRepRes :: Name -> HsExpr GhcRn -> TcSigmaType -> TcM ()+hasFixedRuntimeRepRes std_nm user_expr ty = mapM_ do_check mb_arity+  where+   do_check :: Arity -> TcM ()+   do_check arity =+     let res_ty = nTimes arity (snd . splitPiTy) ty+     in hasFixedRuntimeRep_syntactic (FRRArrow $ ArrowFun user_expr) res_ty+   mb_arity :: Maybe Arity+   mb_arity -- arity of the arrow operation, counting type-level arguments+     | std_nm == arrAName     -- result used as an argument in, e.g., do_premap+     = Just 3+     | std_nm == composeAName -- result used as an argument in, e.g., dsCmdStmt/BodyStmt+     = Just 5+     | std_nm == firstAName   -- result used as an argument in, e.g., dsCmdStmt/BodyStmt+     = Just 4+     | std_nm == appAName     -- result used as an argument in, e.g., dsCmd/HsCmdArrApp/HsHigherOrderApp+     = Just 2+     | std_nm == choiceAName  -- result used as an argument in, e.g., HsCmdIf+     = Just 5+     | std_nm == loopAName    -- result used as an argument in, e.g., HsCmdIf+     = Just 4+     | otherwise+     = Nothing++{-+************************************************************************+*                                                                      *                 Instances *                                                                      * ************************************************************************@@ -822,29 +889,24 @@         ; oflag <- getOverlapFlag overlap_mode        ; let inst = mkLocalInstance dfun oflag tvs' clas tys'-       ; warnIfFlag Opt_WarnOrphans-                    (isOrphan (is_orphan inst))-                    (instOrphWarn inst)+       ; when (isOrphan (is_orphan inst)) $+          addDiagnostic (TcRnOrphanInstance inst)        ; return inst } -instOrphWarn :: ClsInst -> SDoc-instOrphWarn inst-  = hang (text "Orphan instance:") 2 (pprInstanceHdr inst)-    $$ text "To avoid this"-    $$ nest 4 (vcat possibilities)-  where-    possibilities =-      text "move the instance declaration to the module of the class or of the type, or" :-      text "wrap the type with a newtype and declare the instance on the new type." :-      []- tcExtendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a   -- Add new locally-defined instances tcExtendLocalInstEnv dfuns thing_inside  = do { traceDFuns dfuns       ; env <- getGblEnv+      -- Force the access to the TcgEnv so it isn't retained.+      -- During auditing it is much easier to observe in -hi profiles if+      -- there are a very small number of TcGblEnv. Keeping a TcGblEnv+      -- alive is quite dangerous because it contains reference to many+      -- large data structures.+      ; let !init_inst_env = tcg_inst_env env+            !init_insts = tcg_insts env       ; (inst_env', cls_insts') <- foldlM addLocalInst-                                          (tcg_inst_env env, tcg_insts env)+                                          (init_inst_env, init_insts)                                           dfuns       ; let env' = env { tcg_insts    = cls_insts'                        , tcg_inst_env = inst_env' }@@ -955,21 +1017,21 @@  funDepErr :: ClsInst -> [ClsInst] -> TcRn () funDepErr ispec ispecs-  = addClsInstsErr (text "Functional dependencies conflict between instance declarations:")-                    (ispec : ispecs)+  = addClsInstsErr TcRnFunDepConflict (ispec NE.:| ispecs)  dupInstErr :: ClsInst -> ClsInst -> TcRn () dupInstErr ispec dup_ispec-  = addClsInstsErr (text "Duplicate instance declarations:")-                    [ispec, dup_ispec]+  = addClsInstsErr TcRnDupInstanceDecls (ispec NE.:| [dup_ispec]) -addClsInstsErr :: SDoc -> [ClsInst] -> TcRn ()-addClsInstsErr herald ispecs = do+addClsInstsErr :: (UnitState -> NE.NonEmpty ClsInst -> TcRnMessage)+               -> NE.NonEmpty ClsInst+               -> TcRn ()+addClsInstsErr mkErr ispecs = do    unit_state <- hsc_units <$> getTopEnv-   setSrcSpan (getSrcSpan (head sorted)) $-      addErr $ pprWithUnitState unit_state $ (hang herald 2 (pprInstances sorted))+   setSrcSpan (getSrcSpan (NE.head sorted)) $+      addErr $ mkErr unit_state sorted  where-   sorted = sortBy (SrcLoc.leftmost_smallest `on` getSrcSpan) ispecs+   sorted = NE.sortBy (SrcLoc.leftmost_smallest `on` getSrcSpan) ispecs    -- The sortBy just arranges that instances are displayed in order    -- of source location, which reduced wobbling in error messages,    -- and is better for users
GHC/Tc/Utils/Monad.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE BangPatterns      #-}-{-# LANGUAGE CPP               #-} {-# LANGUAGE ExplicitForAll    #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RecordWildCards   #-}@@ -21,18 +20,19 @@   -- * Simple accessors   discardResult,   getTopEnv, updTopEnv, getGblEnv, updGblEnv,-  setGblEnv, getLclEnv, updLclEnv, setLclEnv,-  getEnvs, setEnvs,+  setGblEnv, getLclEnv, updLclEnv, setLclEnv, restoreLclEnv,+  updTopFlags,+  getEnvs, setEnvs, updEnvs, restoreEnvs,   xoptM, doptM, goptM, woptM,   setXOptM, unsetXOptM, unsetGOptM, unsetWOptM,   whenDOptM, whenGOptM, whenWOptM,   whenXOptM, unlessXOptM,   getGhcMode,-  withDynamicNow, withoutDynamicNow,+  withoutDynamicNow,   getEpsVar,   getEps,   updateEps, updateEps_,-  getHpt, getEpsAndHpt,+  getHpt, getEpsAndHug,    -- * Arrow scopes   newArrowScope, escapeArrowScope,@@ -49,7 +49,7 @@   dumpTcRn,   getPrintUnqualified,   printForUserTcRn,-  traceIf, traceHiDiffs, traceOptIf,+  traceIf, traceOptIf,   debugTc,    -- * Typechecker global environment@@ -76,8 +76,7 @@   tcCollectingUsage, tcScalingUsage, tcEmitBindingUsage,    -- * Shared error message stuff: renamer and typechecker-  mkLongErrAt, mkDecoratedSDocAt, addLongErrAt, reportErrors, reportError,-  reportWarning, recoverM, mapAndRecoverM, mapAndReportM, foldAndRecoverM,+  recoverM, mapAndRecoverM, mapAndReportM, foldAndRecoverM,   attemptM, tryTc,   askNoErrs, discardErrs, tryTcDiscardingErrs,   checkNoErrs, whenNoErrs,@@ -87,15 +86,17 @@   getErrCtxt, setErrCtxt, addErrCtxt, addErrCtxtM, addLandmarkErrCtxt,   addLandmarkErrCtxtM, popErrCtxt, getCtLocM, setCtLocM, -  -- * Error message generation (type checker)+  -- * Diagnostic message generation (type checker)   addErrTc,   addErrTcM,   failWithTc, failWithTcM,   checkTc, checkTcM,   failIfTc, failIfTcM,-  warnIfFlag, warnIf, warnTc, warnTcM,-  addWarnTc, addWarnTcM, addWarn, addWarnAt, add_warn,   mkErrInfo,+  addTcRnDiagnostic, addDetailedDiagnostic,+  mkTcRnMessage, reportDiagnostic, reportDiagnostics,+  warnIf, diagnosticTc, diagnosticTcM,+  addDiagnosticTc, addDiagnosticTcM, addDiagnostic, addDiagnosticAt,    -- * Type constraints   newTcEvBinds, newNoTcEvBinds, cloneEvBindsVar,@@ -105,17 +106,17 @@   getConstraintVar, setConstraintVar,   emitConstraints, emitStaticConstraints, emitSimple, emitSimples,   emitImplication, emitImplications, emitInsoluble,-  emitHole, emitHoles,+  emitDelayedErrors, emitHole, emitHoles, emitNotConcreteError,   discardConstraints, captureConstraints, tryCaptureConstraints,   pushLevelAndCaptureConstraints,-  pushTcLevelM_, pushTcLevelM, pushTcLevelsM,+  pushTcLevelM_, pushTcLevelM,   getTcLevel, setTcLevel, isTouchableTcM,   getLclTypeEnv, setLclTypeEnv,   traceTcConstraints,   emitNamedTypeHole, IsExtraConstraint(..), emitAnonTypeHole,    -- * Template Haskell context-  recordThUse, recordThSpliceUse,+  recordThUse, recordThSpliceUse, recordThNeededRuntimeDeps,   keepAlive, getStage, getStageAndBindLevel, setStage,   addModFinalizersWithLclEnv, @@ -132,9 +133,9 @@   initIfaceLcl,   initIfaceLclWithSubst,   initIfaceLoad,+  initIfaceLoadModule,   getIfModule,   failIfM,-  forkM_maybe,   forkM,   setImplicitEnvM, @@ -148,8 +149,6 @@   module GHC.Data.IOEnv   ) where -#include "HsVersions.h"- import GHC.Prelude  @@ -164,6 +163,7 @@ import GHC.Hs hiding (LIE)  import GHC.Unit+import GHC.Unit.Env import GHC.Unit.External import GHC.Unit.Module.Warnings import GHC.Unit.Home.ModInfo@@ -174,8 +174,8 @@ import GHC.Core.FamInstEnv  import GHC.Driver.Env-import GHC.Driver.Ppr import GHC.Driver.Session+import GHC.Driver.Config.Diagnostic  import GHC.Runtime.Context @@ -187,8 +187,9 @@ import GHC.Utils.Outputable as Outputable import GHC.Utils.Error import GHC.Utils.Panic-import GHC.Utils.Misc+import GHC.Utils.Constants (debugIsOn) import GHC.Utils.Logger+import qualified GHC.Data.Strict as Strict  import GHC.Types.Error import GHC.Types.Fixity.Env@@ -203,6 +204,7 @@ import GHC.Types.Name.Env import GHC.Types.Name.Set import GHC.Types.Name.Ppr+import GHC.Types.Unique.FM ( emptyUFM ) import GHC.Types.Unique.Supply import GHC.Types.Annotations import GHC.Types.Basic( TopLevelFlag, TypeOrKind(..) )@@ -214,9 +216,13 @@ import Data.IORef import Control.Monad +import GHC.Tc.Errors.Types import {-# SOURCE #-} GHC.Tc.Utils.Env    ( tcInitTidyEnv )  import qualified Data.Map as Map+import GHC.Driver.Env.KnotVars+import GHC.Linker.Types+import GHC.Types.Unique.DFM  {- ************************************************************************@@ -233,7 +239,7 @@        -> Module        -> RealSrcSpan        -> TcM r-       -> IO (Messages DecoratedSDoc, Maybe r)+       -> IO (Messages TcRnMessage, Maybe r)                 -- Nothing => error thrown by the thing inside                 -- (error messages should have been printed already) @@ -242,11 +248,10 @@         used_gre_var <- newIORef [] ;         th_var       <- newIORef False ;         th_splice_var<- newIORef False ;-        infer_var    <- newIORef (True, emptyBag) ;+        infer_var    <- newIORef True ;+        infer_reasons_var <- newIORef emptyMessages ;         dfun_n_var   <- newIORef emptyOccSet ;-        type_env_var <- case hsc_type_env_var hsc_env of {-                           Just (_mod, te_var) -> return te_var ;-                           Nothing             -> newIORef emptyNameEnv } ;+        let { type_env_var = hsc_type_env_vars hsc_env };          dependent_files_var <- newIORef [] ;         static_wc_var       <- newIORef emptyWC ;@@ -259,14 +264,17 @@         th_state_var         <- newIORef Map.empty ;         th_remote_state_var  <- newIORef Nothing ;         th_docs_var          <- newIORef Map.empty ;+        th_needed_deps_var   <- newIORef ([], emptyUDFM) ;+        next_wrapper_num     <- newIORef emptyModuleEnv ;         let {              -- bangs to avoid leaking the env (#19356)              !dflags = hsc_dflags hsc_env ;-             !home_unit = hsc_home_unit hsc_env ;+             !mhome_unit = hsc_home_unit_maybe hsc_env;+             !logger = hsc_logger hsc_env ;               maybe_rn_syntax :: forall a. a -> Maybe a ;              maybe_rn_syntax empty_val-                | dopt Opt_D_dump_rn_ast dflags = Just empty_val+                | logHasDumpFlag logger Opt_D_dump_rn_ast = Just empty_val                  | gopt Opt_WriteHie dflags       = Just empty_val @@ -289,7 +297,7 @@                 tcg_th_docs          = th_docs_var,                  tcg_mod            = mod,-                tcg_semantic_mod   = homeModuleInstantiation home_unit mod,+                tcg_semantic_mod   = homeModuleInstantiation mhome_unit mod,                 tcg_src            = hsc_src,                 tcg_rdr_env        = emptyGlobalRdrEnv,                 tcg_fix_env        = emptyNameEnv,@@ -305,6 +313,7 @@                 tcg_ann_env        = emptyAnnEnv,                 tcg_th_used        = th_var,                 tcg_th_splice_used = th_splice_var,+                tcg_th_needed_deps = th_needed_deps_var,                 tcg_exports        = [],                 tcg_imports        = emptyImportAvails,                 tcg_used_gres     = used_gre_var,@@ -339,14 +348,18 @@                 tcg_hpc            = False,                 tcg_main           = Nothing,                 tcg_self_boot      = NoSelfBoot,-                tcg_safeInfer      = infer_var,+                tcg_safe_infer     = infer_var,+                tcg_safe_infer_reasons = infer_reasons_var,                 tcg_dependent_files = dependent_files_var,-                tcg_tc_plugins     = [],+                tcg_tc_plugin_solvers   = [],+                tcg_tc_plugin_rewriters = emptyUFM,+                tcg_defaulting_plugins  = [],                 tcg_hf_plugins     = [],                 tcg_top_loc        = loc,                 tcg_static_wc      = static_wc_var,                 tcg_complete_matches = [],-                tcg_cc_st          = cc_st_var+                tcg_cc_st          = cc_st_var,+                tcg_next_wrapper_num = next_wrapper_num              } ;         } ; @@ -359,7 +372,7 @@               -> TcGblEnv               -> RealSrcSpan               -> TcM r-              -> IO (Messages DecoratedSDoc, Maybe r)+              -> IO (Messages TcRnMessage, Maybe r) initTcWithGbl hsc_env gbl_env loc do_this  = do { lie_var      <- newIORef emptyWC       ; errs_var     <- newIORef emptyMessages@@ -405,7 +418,7 @@       ; return (msgs, final_res)       } -initTcInteractive :: HscEnv -> TcM a -> IO (Messages DecoratedSDoc, Maybe a)+initTcInteractive :: HscEnv -> TcM a -> IO (Messages TcRnMessage, Maybe a) -- Initialise the type checker monad for use in GHCi initTcInteractive hsc_env thing_inside   = initTc hsc_env HsSrcFile False@@ -472,7 +485,7 @@ updGblEnv upd = updEnv (\ env@(Env { env_gbl = gbl }) ->                           env { env_gbl = upd gbl }) -setGblEnv :: gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a+setGblEnv :: gbl' -> TcRnIf gbl' lcl a -> TcRnIf gbl lcl a setGblEnv gbl_env = updEnv (\ env -> env { env_gbl = gbl_env })  getLclEnv :: TcRnIf gbl lcl lcl@@ -482,44 +495,93 @@ updLclEnv upd = updEnv (\ env@(Env { env_lcl = lcl }) ->                           env { env_lcl = upd lcl }) + setLclEnv :: lcl' -> TcRnIf gbl lcl' a -> TcRnIf gbl lcl a setLclEnv lcl_env = updEnv (\ env -> env { env_lcl = lcl_env }) +restoreLclEnv :: TcLclEnv -> TcRnIf gbl TcLclEnv a -> TcRnIf gbl TcLclEnv a+-- See Note [restoreLclEnv vs setLclEnv]+restoreLclEnv new_lcl_env = updLclEnv upd+  where+    upd old_lcl_env =  new_lcl_env { tcl_errs  = tcl_errs  old_lcl_env+                                   , tcl_lie   = tcl_lie   old_lcl_env+                                   , tcl_usage = tcl_usage old_lcl_env }+ getEnvs :: TcRnIf gbl lcl (gbl, lcl) getEnvs = do { env <- getEnv; return (env_gbl env, env_lcl env) }  setEnvs :: (gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a-setEnvs (gbl_env, lcl_env) = updEnv (\ env -> env { env_gbl = gbl_env, env_lcl = lcl_env })+setEnvs (gbl_env, lcl_env) = setGblEnv gbl_env . setLclEnv lcl_env +updEnvs :: ((gbl,lcl) -> (gbl, lcl)) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a+updEnvs upd_envs = updEnv upd+  where+    upd env@(Env { env_gbl = gbl, env_lcl = lcl })+      = env { env_gbl = gbl', env_lcl = lcl' }+      where+        !(gbl', lcl') = upd_envs (gbl, lcl)++restoreEnvs :: (TcGblEnv, TcLclEnv) -> TcRn a -> TcRn a+-- See Note [restoreLclEnv vs setLclEnv]+restoreEnvs (gbl, lcl) = setGblEnv gbl . restoreLclEnv lcl++{- Note [restoreLclEnv vs setLclEnv]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In the typechecker we use this idiom quite a lot+   do { (gbl_env, lcl_env) <- tcRnSrcDecls ...+      ; setGblEnv gbl_env $ setLclEnv lcl_env $+        more_stuff }++The `tcRnSrcDecls` extends the environments in `gbl_env` and `lcl_env`+which we then want to be in scope in `more stuff`.++The problem is that `lcl_env :: TcLclEnv` has an IORef for error+messages `tcl_errs`, and another for constraints (`tcl_lie`), and+another for Linear Haskell usage information (`tcl_usage`).  Now+suppose we change it a tiny bit+   do { (gbl_env, lcl_env) <- checkNoErrs $+                              tcRnSrcDecls ...+      ; setGblEnv gbl_env $ setLclEnv lcl_env $+        more_stuff }++That should be innocuous.  But *alas*, `checkNoErrs` gathers errors in+a fresh IORef *which is then captured in the returned `lcl_env`.  When+we do the `setLclEnv` we'll make that captured IORef into the place+where we gather error messages -- but no one is going to look at that!!!+This led to #19470 and #20981.++Solution: instead of setLclEnv use restoreLclEnv, which preserves from+the /parent/ context these mutable collection IORefs:+      tcl_errs, tcl_lie, tcl_usage+-}+ -- Command-line flags  xoptM :: LangExt.Extension -> TcRnIf gbl lcl Bool-xoptM flag = do { dflags <- getDynFlags; return (xopt flag dflags) }+xoptM flag = xopt flag <$> getDynFlags  doptM :: DumpFlag -> TcRnIf gbl lcl Bool-doptM flag = do { dflags <- getDynFlags; return (dopt flag dflags) }+doptM flag = do+  logger <- getLogger+  return (logHasDumpFlag logger flag)  goptM :: GeneralFlag -> TcRnIf gbl lcl Bool-goptM flag = do { dflags <- getDynFlags; return (gopt flag dflags) }+goptM flag = gopt flag <$> getDynFlags  woptM :: WarningFlag -> TcRnIf gbl lcl Bool-woptM flag = do { dflags <- getDynFlags; return (wopt flag dflags) }+woptM flag = wopt flag <$> getDynFlags  setXOptM :: LangExt.Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a-setXOptM flag =-  updTopEnv (\top -> top { hsc_dflags = xopt_set (hsc_dflags top) flag})+setXOptM flag = updTopFlags (\dflags -> xopt_set dflags flag)  unsetXOptM :: LangExt.Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a-unsetXOptM flag =-  updTopEnv (\top -> top { hsc_dflags = xopt_unset (hsc_dflags top) flag})+unsetXOptM flag = updTopFlags (\dflags -> xopt_unset dflags flag)  unsetGOptM :: GeneralFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a-unsetGOptM flag =-  updTopEnv (\top -> top { hsc_dflags = gopt_unset (hsc_dflags top) flag})+unsetGOptM flag = updTopFlags (\dflags -> gopt_unset dflags flag)  unsetWOptM :: WarningFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a-unsetWOptM flag =-  updTopEnv (\top -> top { hsc_dflags = wopt_unset (hsc_dflags top) flag})+unsetWOptM flag = updTopFlags (\dflags -> wopt_unset dflags flag)  -- | Do it flag is true whenDOptM :: DumpFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()@@ -549,23 +611,21 @@ {-# INLINE unlessXOptM #-} -- see Note [INLINE conditional tracing utilities]  getGhcMode :: TcRnIf gbl lcl GhcMode-getGhcMode = do { env <- getTopEnv; return (ghcMode (hsc_dflags env)) }--withDynamicNow :: TcRnIf gbl lcl a -> TcRnIf gbl lcl a-withDynamicNow =-  updTopEnv (\top@(HscEnv { hsc_dflags = dflags }) ->-              top { hsc_dflags = setDynamicNow dflags })+getGhcMode = ghcMode <$> getDynFlags  withoutDynamicNow :: TcRnIf gbl lcl a -> TcRnIf gbl lcl a-withoutDynamicNow =-  updTopEnv (\top@(HscEnv { hsc_dflags = dflags }) ->-              top { hsc_dflags = dflags { dynamicNow = False} })+withoutDynamicNow = updTopFlags (\dflags -> dflags { dynamicNow = False}) +updTopFlags :: (DynFlags -> DynFlags) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a+updTopFlags f = updTopEnv (hscUpdateFlags f)+ getEpsVar :: TcRnIf gbl lcl (TcRef ExternalPackageState)-getEpsVar = do { env <- getTopEnv; return (hsc_EPS env) }+getEpsVar = do+  env <- getTopEnv+  return (euc_eps (ue_eps (hsc_unit_env env)))  getEps :: TcRnIf gbl lcl ExternalPackageState-getEps = do { env <- getTopEnv; readMutVar (hsc_EPS env) }+getEps = do { env <- getTopEnv; liftIO $ hscEPS env }  -- | Update the external package state.  Returns the second result of the -- modifier function.@@ -590,18 +650,17 @@ getHpt :: TcRnIf gbl lcl HomePackageTable getHpt = do { env <- getTopEnv; return (hsc_HPT env) } -getEpsAndHpt :: TcRnIf gbl lcl (ExternalPackageState, HomePackageTable)-getEpsAndHpt = do { env <- getTopEnv; eps <- readMutVar (hsc_EPS env)-                  ; return (eps, hsc_HPT env) }+getEpsAndHug :: TcRnIf gbl lcl (ExternalPackageState, HomeUnitGraph)+getEpsAndHug = do { env <- getTopEnv; eps <- liftIO $ hscEPS env+                  ; return (eps, hsc_HUG env) }  -- | A convenient wrapper for taking a @MaybeErr SDoc a@ and throwing -- an exception if it is an error.-withException :: TcRnIf gbl lcl (MaybeErr SDoc a) -> TcRnIf gbl lcl a-withException do_this = do+withException :: MonadIO m => SDocContext -> m (MaybeErr SDoc a) -> m a+withException ctx do_this = do     r <- do_this-    dflags <- getDynFlags     case r of-        Failed err -> liftIO $ throwGhcExceptionIO (ProgramError (showSDoc dflags err))+        Failed err -> liftIO $ throwGhcExceptionIO (ProgramError (renderWithContext ctx err))         Succeeded result -> return result  {-@@ -708,30 +767,42 @@ ************************************************************************ -} --- Note [INLINE conditional tracing utilities]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~--- In general we want to optimise for the case where tracing is not enabled.--- To ensure this happens, we ensure that traceTc and friends are inlined; this--- ensures that the allocation of the document can be pushed into the tracing--- path, keeping the non-traced path free of this extraneous work. For--- instance, instead of------     let thunk = ...---     in if doTracing---          then emitTraceMsg thunk---          else return ()------ where the conditional is buried in a non-inlined utility function (e.g.--- traceTc), we would rather have:------     if doTracing---       then let thunk = ...---            in emitTraceMsg thunk---       else return ()------ See #18168.---+{- Note [INLINE conditional tracing utilities]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In general we want to optimise for the case where tracing is not enabled.+To ensure this happens, we ensure that traceTc and friends are inlined; this+ensures that the allocation of the document can be pushed into the tracing+path, keeping the non-traced path free of this extraneous work. For+instance, if we don't inline traceTc, we'll get +    let stuff_to_print = ...+    in traceTc "wombat" stuff_to_print++and the stuff_to_print thunk will be allocated in the "hot path", regardless+of tracing.  But if we INLINE traceTc we get++    let stuff_to_print = ...+    in if doTracing+         then emitTraceMsg "wombat" stuff_to_print+         else return ()++and then we float in:++    if doTracing+      then let stuff_to_print = ...+           in emitTraceMsg "wombat" stuff_to_print+      else return ()++Now stuff_to_print is allocated only in the "cold path".++Moreover, on the "cold" path, after the conditional, we want to inline+as /little/ as possible.  Performance doesn't matter here, and we'd like+to bloat the caller's code as little as possible.  So we put a NOINLINE+on 'emitTraceMsg'++See #18168.+-}+ -- Typechecker trace traceTc :: String -> SDoc -> TcRn () traceTc herald doc =@@ -776,24 +847,23 @@ -- dumpTcRn :: Bool -> DumpFlag -> String -> DumpFormat -> SDoc -> TcRn () dumpTcRn useUserStyle flag title fmt doc = do-  dflags <- getDynFlags   logger <- getLogger   printer <- getPrintUnqualified   real_doc <- wrapDocLoc doc   let sty = if useUserStyle               then mkUserStyle printer AllTheWay               else mkDumpStyle printer-  liftIO $ putDumpMsg logger dflags sty flag title fmt real_doc+  liftIO $ logDumpFile logger sty flag title fmt real_doc  -- | Add current location if -dppr-debug -- (otherwise the full location is usually way too much) wrapDocLoc :: SDoc -> TcRn SDoc wrapDocLoc doc = do-  dflags <- getDynFlags-  if hasPprDebug dflags+  logger <- getLogger+  if logHasDumpFlag logger Opt_D_ppr_debug     then do       loc <- getSrcSpanM-      return (mkLocMessage SevOutput loc doc)+      return (mkLocMessage MCOutput loc doc)     else       return doc @@ -806,30 +876,26 @@ -- | Like logInfoTcRn, but for user consumption printForUserTcRn :: SDoc -> TcRn () printForUserTcRn doc = do-    dflags <- getDynFlags     logger <- getLogger     printer <- getPrintUnqualified-    liftIO (printOutputForUser logger dflags printer doc)+    liftIO (printOutputForUser logger printer doc)  {--traceIf and traceHiDiffs work in the TcRnIf monad, where no RdrEnv is+traceIf works in the TcRnIf monad, where no RdrEnv is available.  Alas, they behave inconsistently with the other stuff; e.g. are unaffected by -dump-to-file. -} -traceIf, traceHiDiffs :: SDoc -> TcRnIf m n ()-traceIf      = traceOptIf Opt_D_dump_if_trace-traceHiDiffs = traceOptIf Opt_D_dump_hi_diffs+traceIf :: SDoc -> TcRnIf m n ()+traceIf = traceOptIf Opt_D_dump_if_trace {-# INLINE traceIf #-}-{-# INLINE traceHiDiffs #-}   -- see Note [INLINE conditional tracing utilities]  traceOptIf :: DumpFlag -> SDoc -> TcRnIf m n () traceOptIf flag doc   = whenDOptM flag $ do   -- No RdrEnv available, so qualify everything-        dflags <- getDynFlags         logger <- getLogger-        liftIO (putMsg logger dflags doc)+        liftIO (putMsg logger doc) {-# INLINE traceOptIf #-}  -- see Note [INLINE conditional tracing utilities]  {-@@ -898,7 +964,7 @@  getSrcSpanM :: TcRn SrcSpan         -- Avoid clash with Name.getSrcLoc-getSrcSpanM = do { env <- getLclEnv; return (RealSrcSpan (tcl_loc env) Nothing) }+getSrcSpanM = do { env <- getLclEnv; return (RealSrcSpan (tcl_loc env) Strict.Nothing) }  -- See Note [Error contexts in generated code] inGeneratedCode :: TcRn Bool@@ -932,8 +998,7 @@                                             ; return (L loc b) }  wrapLocAM :: (a -> TcM b) -> LocatedAn an a -> TcM (Located b)-wrapLocAM fn (L loc a) = setSrcSpanA loc $ do { b <- fn a-                                              ; return (L (locA loc) b) }+wrapLocAM fn a = wrapLocM fn (reLoc a)  wrapLocMA :: (a -> TcM b) -> GenLocated (SrcSpanAnn' ann) a -> TcRn (GenLocated (SrcSpanAnn' ann) b) wrapLocMA fn (L loc a) = setSrcSpanA loc $ do { b <- fn a@@ -945,7 +1010,12 @@     (b,c) <- fn a     return (L loc b, c) -wrapLocFstMA :: (a -> TcM (b,c)) -> LocatedA a -> TcM (LocatedA b, c)+-- Possible instantiations:+--    wrapLocFstMA :: (a -> TcM (b,c)) -> LocatedA    a -> TcM (LocatedA    b, c)+--    wrapLocFstMA :: (a -> TcM (b,c)) -> LocatedN    a -> TcM (LocatedN    b, c)+--    wrapLocFstMA :: (a -> TcM (b,c)) -> LocatedAn t a -> TcM (LocatedAn t b, c)+-- and so on.+wrapLocFstMA :: (a -> TcM (b,c)) -> GenLocated (SrcSpanAnn' ann) a -> TcM (GenLocated (SrcSpanAnn' ann) b, c) wrapLocFstMA fn (L loc a) =   setSrcSpanA loc $ do     (b,c) <- fn a@@ -957,7 +1027,12 @@     (b,c) <- fn a     return (b, L loc c) -wrapLocSndMA :: (a -> TcM (b, c)) -> LocatedA a -> TcM (b, LocatedA c)+-- Possible instantiations:+--    wrapLocSndMA :: (a -> TcM (b, c)) -> LocatedA    a -> TcM (b, LocatedA    c)+--    wrapLocSndMA :: (a -> TcM (b, c)) -> LocatedN    a -> TcM (b, LocatedN    c)+--    wrapLocSndMA :: (a -> TcM (b, c)) -> LocatedAn t a -> TcM (b, LocatedAn t c)+-- and so on.+wrapLocSndMA :: (a -> TcM (b, c)) -> GenLocated (SrcSpanAnn' ann) a -> TcM (b, GenLocated (SrcSpanAnn' ann) c) wrapLocSndMA fn (L loc a) =   setSrcSpanA loc $ do     (b,c) <- fn a@@ -971,44 +1046,44 @@  -- Reporting errors -getErrsVar :: TcRn (TcRef (Messages DecoratedSDoc))+getErrsVar :: TcRn (TcRef (Messages TcRnMessage)) getErrsVar = do { env <- getLclEnv; return (tcl_errs env) } -setErrsVar :: TcRef (Messages DecoratedSDoc) -> TcRn a -> TcRn a+setErrsVar :: TcRef (Messages TcRnMessage) -> TcRn a -> TcRn a setErrsVar v = updLclEnv (\ env -> env { tcl_errs =  v }) -addErr :: SDoc -> TcRn ()+addErr :: TcRnMessage -> TcRn () addErr msg = do { loc <- getSrcSpanM; addErrAt loc msg } -failWith :: SDoc -> TcRn a+failWith :: TcRnMessage -> TcRn a failWith msg = addErr msg >> failM -failAt :: SrcSpan -> SDoc -> TcRn a+failAt :: SrcSpan -> TcRnMessage -> TcRn a failAt loc msg = addErrAt loc msg >> failM -addErrAt :: SrcSpan -> SDoc -> TcRn ()+addErrAt :: SrcSpan -> TcRnMessage -> TcRn () -- addErrAt is mainly (exclusively?) used by the renamer, where -- tidying is not an issue, but it's all lazy so the extra -- work doesn't matter addErrAt loc msg = do { ctxt <- getErrCtxt                       ; tidy_env <- tcInitTidyEnv                       ; err_info <- mkErrInfo tidy_env ctxt-                      ; addLongErrAt loc msg err_info }+                      ; add_long_err_at loc (TcRnMessageDetailed (ErrInfo err_info Outputable.empty) msg) } -addErrs :: [(SrcSpan,SDoc)] -> TcRn ()+addErrs :: [(SrcSpan,TcRnMessage)] -> TcRn () addErrs msgs = mapM_ add msgs              where                add (loc,msg) = addErrAt loc msg -checkErr :: Bool -> SDoc -> TcRn ()+checkErr :: Bool -> TcRnMessage -> TcRn () -- Add the error if the bool is False checkErr ok msg = unless ok (addErr msg) -addMessages :: Messages DecoratedSDoc -> TcRn ()+addMessages :: Messages TcRnMessage -> TcRn () addMessages msgs1-  = do { errs_var <- getErrsVar ;-         msgs0 <- readTcRef errs_var ;-         writeTcRef errs_var (unionMessages msgs0 msgs1) }+  = do { errs_var <- getErrsVar+       ; msgs0    <- readTcRef errs_var+       ; writeTcRef errs_var (msgs0 `unionMessages` msgs1) }  discardWarnings :: TcRn a -> TcRn a -- Ignore warnings inside the thing inside;@@ -1033,60 +1108,39 @@ ************************************************************************ -} -mkLongErrAt :: SrcSpan -> SDoc -> SDoc -> TcRn (MsgEnvelope DecoratedSDoc)-mkLongErrAt loc msg extra-  = do { printer <- getPrintUnqualified ;-         unit_state <- hsc_units <$> getTopEnv ;-         let msg' = pprWithUnitState unit_state msg in-         return $ mkLongMsgEnvelope loc printer msg' extra }+add_long_err_at :: SrcSpan -> TcRnMessageDetailed -> TcRn ()+add_long_err_at loc msg = mk_long_err_at loc msg >>= reportDiagnostic+  where+    mk_long_err_at :: SrcSpan -> TcRnMessageDetailed -> TcRn (MsgEnvelope TcRnMessage)+    mk_long_err_at loc msg+      = do { printer <- getPrintUnqualified ;+             unit_state <- hsc_units <$> getTopEnv ;+             return $ mkErrorMsgEnvelope loc printer+                    $ TcRnMessageWithInfo unit_state msg+                    } -mkDecoratedSDocAt :: SrcSpan-                  -> SDoc-                  -- ^ The important part of the message-                  -> SDoc-                  -- ^ The context of the message-                  -> SDoc-                  -- ^ Any supplementary information.-                  -> TcRn (MsgEnvelope DecoratedSDoc)-mkDecoratedSDocAt loc important context extra+mkTcRnMessage :: SrcSpan+              -> TcRnMessage+              -> TcRn (MsgEnvelope TcRnMessage)+mkTcRnMessage loc msg   = do { printer <- getPrintUnqualified ;-         unit_state <- hsc_units <$> getTopEnv ;-         let f = pprWithUnitState unit_state-             errDoc  = [important, context, extra]-             errDoc' = mkDecorated $ map f errDoc-         in-         return $ mkErr loc printer errDoc' }--addLongErrAt :: SrcSpan -> SDoc -> SDoc -> TcRn ()-addLongErrAt loc msg extra = mkLongErrAt loc msg extra >>= reportError+         diag_opts <- initDiagOpts <$> getDynFlags ;+         return $ mkMsgEnvelope diag_opts loc printer msg } -reportErrors :: [MsgEnvelope DecoratedSDoc] -> TcM ()-reportErrors = mapM_ reportError+reportDiagnostics :: [MsgEnvelope TcRnMessage] -> TcM ()+reportDiagnostics = mapM_ reportDiagnostic -reportError :: MsgEnvelope DecoratedSDoc -> TcRn ()-reportError err-  = do { traceTc "Adding error:" (pprLocMsgEnvelope err) ;+reportDiagnostic :: MsgEnvelope TcRnMessage -> TcRn ()+reportDiagnostic msg+  = do { traceTc "Adding diagnostic:" (pprLocMsgEnvelope msg) ;          errs_var <- getErrsVar ;          msgs     <- readTcRef errs_var ;-         writeTcRef errs_var (err `addMessage` msgs) }--reportWarning :: WarnReason -> MsgEnvelope DecoratedSDoc -> TcRn ()-reportWarning reason err-  = do { let warn = makeIntoWarning reason err-                    -- 'err' was built by mkLongMsgEnvelope or something like that,-                    -- so it's of error severity.  For a warning we downgrade-                    -- its severity to SevWarning--       ; traceTc "Adding warning:" (pprLocMsgEnvelope warn)-       ; errs_var <- getErrsVar-       ; (warns, errs) <- partitionMessages <$> readTcRef errs_var-       ; writeTcRef errs_var (mkMessages $ (warns `snocBag` warn) `unionBags` errs) }-+         writeTcRef errs_var (msg `addMessage` msgs) }  ----------------------- checkNoErrs :: TcM r -> TcM r -- (checkNoErrs m) succeeds iff m succeeds and generates no errors--- If m fails then (checkNoErrsTc m) fails.+-- If m fails then (checkNoErrs m) fails. -- If m succeeds, it checks whether m generated any errors messages --      (it might have recovered internally) --      If so, it fails too.@@ -1206,10 +1260,10 @@ getCtLocM :: CtOrigin -> Maybe TypeOrKind -> TcM CtLoc getCtLocM origin t_or_k   = do { env <- getLclEnv-       ; return (CtLoc { ctl_origin = origin-                       , ctl_env    = env-                       , ctl_t_or_k = t_or_k-                       , ctl_depth  = initialSubGoalDepth }) }+       ; return (CtLoc { ctl_origin   = origin+                       , ctl_env      = env+                       , ctl_t_or_k   = t_or_k+                       , ctl_depth    = initialSubGoalDepth }) }  setCtLocM :: CtLoc -> TcM a -> TcM a -- Set the SrcSpan and error context from the CtLoc@@ -1254,7 +1308,7 @@        ; lie <- readTcRef lie_var        ; return (res, lie) } -capture_messages :: TcM r -> TcM (r, Messages DecoratedSDoc)+capture_messages :: TcM r -> TcM (r, Messages TcRnMessage) -- capture_messages simply captures and returns the --                  errors arnd warnings generated by thing_inside -- Precondition: thing_inside must not throw an exception!@@ -1337,10 +1391,8 @@ -- returned usage information into the larger context appropriately. tcCollectingUsage :: TcM a -> TcM (UsageEnv,a) tcCollectingUsage thing_inside-  = do { env0 <- getLclEnv-       ; local_usage_ref <- newTcRef zeroUE-       ; let env1 = env0 { tcl_usage = local_usage_ref }-       ; result <- setLclEnv env1 thing_inside+  = do { local_usage_ref <- newTcRef zeroUE+       ; result <- updLclEnv (\env -> env { tcl_usage = local_usage_ref }) thing_inside        ; local_usage <- readTcRef local_usage_ref        ; return (local_usage,result) } @@ -1424,7 +1476,7 @@                                 Just acc' -> foldAndRecoverM f acc' xs  }  ------------------------tryTc :: TcRn a -> TcRn (Maybe a, Messages DecoratedSDoc)+tryTc :: TcRn a -> TcRn (Maybe a, Messages TcRnMessage) -- (tryTc m) executes m, and returns --      Just r,  if m succeeds (returning r) --      Nothing, if m fails@@ -1477,11 +1529,11 @@     tidy up the message; we then use it to tidy the context messages -} -addErrTc :: SDoc -> TcM ()+addErrTc :: TcRnMessage -> TcM () addErrTc err_msg = do { env0 <- tcInitTidyEnv                       ; addErrTcM (env0, err_msg) } -addErrTcM :: (TidyEnv, SDoc) -> TcM ()+addErrTcM :: (TidyEnv, TcRnMessage) -> TcM () addErrTcM (tidy_env, err_msg)   = do { ctxt <- getErrCtxt ;          loc  <- getSrcSpanM ;@@ -1489,27 +1541,27 @@  -- The failWith functions add an error message and cause failure -failWithTc :: SDoc -> TcM a               -- Add an error message and fail+failWithTc :: TcRnMessage -> TcM a               -- Add an error message and fail failWithTc err_msg   = addErrTc err_msg >> failM -failWithTcM :: (TidyEnv, SDoc) -> TcM a   -- Add an error message and fail+failWithTcM :: (TidyEnv, TcRnMessage) -> TcM a   -- Add an error message and fail failWithTcM local_and_msg   = addErrTcM local_and_msg >> failM -checkTc :: Bool -> SDoc -> TcM ()         -- Check that the boolean is true+checkTc :: Bool -> TcRnMessage -> TcM ()         -- Check that the boolean is true checkTc True  _   = return () checkTc False err = failWithTc err -checkTcM :: Bool -> (TidyEnv, SDoc) -> TcM ()+checkTcM :: Bool -> (TidyEnv, TcRnMessage) -> TcM () checkTcM True  _   = return () checkTcM False err = failWithTcM err -failIfTc :: Bool -> SDoc -> TcM ()         -- Check that the boolean is false+failIfTc :: Bool -> TcRnMessage -> TcM ()         -- Check that the boolean is false failIfTc False _   = return () failIfTc True  err = failWithTc err -failIfTcM :: Bool -> (TidyEnv, SDoc) -> TcM ()+failIfTcM :: Bool -> (TidyEnv, TcRnMessage) -> TcM ()    -- Check that the boolean is false failIfTcM False _   = return () failIfTcM True  err = failWithTcM err@@ -1517,66 +1569,77 @@  --         Warnings have no 'M' variant, nor failure --- | Display a warning if a condition is met,---   and the warning is enabled-warnIfFlag :: WarningFlag -> Bool -> SDoc -> TcRn ()-warnIfFlag warn_flag is_bad msg-  = do { warn_on <- woptM warn_flag-       ; when (warn_on && is_bad) $-         addWarn (Reason warn_flag) msg }- -- | Display a warning if a condition is met.-warnIf :: Bool -> SDoc -> TcRn ()-warnIf is_bad msg-  = when is_bad (addWarn NoReason msg)+warnIf :: Bool -> TcRnMessage -> TcRn ()+warnIf is_bad msg -- No need to check any flag here, it will be done in 'diagReasonSeverity'.+  = when is_bad (addDiagnostic msg) --- | Display a warning if a condition is met.-warnTc :: WarnReason -> Bool -> SDoc -> TcM ()-warnTc reason warn_if_true warn_msg-  | warn_if_true = addWarnTc reason warn_msg-  | otherwise    = return ()+no_err_info :: ErrInfo+no_err_info = ErrInfo Outputable.empty Outputable.empty  -- | Display a warning if a condition is met.-warnTcM :: WarnReason -> Bool -> (TidyEnv, SDoc) -> TcM ()-warnTcM reason warn_if_true warn_msg-  | warn_if_true = addWarnTcM reason warn_msg-  | otherwise    = return ()+diagnosticTc :: Bool -> TcRnMessage -> TcM ()+diagnosticTc should_report warn_msg+  | should_report = addDiagnosticTc warn_msg+  | otherwise     = return () --- | Display a warning in the current context.-addWarnTc :: WarnReason -> SDoc -> TcM ()-addWarnTc reason msg+-- | Display a diagnostic if a condition is met.+diagnosticTcM :: Bool -> (TidyEnv, TcRnMessage) -> TcM ()+diagnosticTcM should_report warn_msg+  | should_report = addDiagnosticTcM warn_msg+  | otherwise     = return ()++-- | Display a diagnostic in the current context.+addDiagnosticTc :: TcRnMessage -> TcM ()+addDiagnosticTc msg  = do { env0 <- tcInitTidyEnv ;-      addWarnTcM reason (env0, msg) }+      addDiagnosticTcM (env0, msg) } --- | Display a warning in a given context.-addWarnTcM :: WarnReason -> (TidyEnv, SDoc) -> TcM ()-addWarnTcM reason (env0, msg)- = do { ctxt <- getErrCtxt ;-        err_info <- mkErrInfo env0 ctxt ;-        add_warn reason msg err_info }+-- | Display a diagnostic in a given context.+addDiagnosticTcM :: (TidyEnv, TcRnMessage) -> TcM ()+addDiagnosticTcM (env0, msg)+ = do { ctxt <- getErrCtxt+      ; extra <- mkErrInfo env0 ctxt+      ; let err_info = ErrInfo extra Outputable.empty+      ; add_diagnostic (TcRnMessageDetailed err_info msg) } --- | Display a warning for the current source location.-addWarn :: WarnReason -> SDoc -> TcRn ()-addWarn reason msg = add_warn reason msg Outputable.empty+-- | A variation of 'addDiagnostic' that takes a function to produce a 'TcRnDsMessage'+-- given some additional context about the diagnostic.+addDetailedDiagnostic :: (ErrInfo -> TcRnMessage) -> TcM ()+addDetailedDiagnostic mkMsg = do+  loc <- getSrcSpanM+  printer <- getPrintUnqualified+  !diag_opts  <- initDiagOpts <$> getDynFlags+  env0 <- tcInitTidyEnv+  ctxt <- getErrCtxt+  err_info <- mkErrInfo env0 ctxt+  reportDiagnostic (mkMsgEnvelope diag_opts loc printer (mkMsg (ErrInfo err_info empty))) --- | Display a warning for a given source location.-addWarnAt :: WarnReason -> SrcSpan -> SDoc -> TcRn ()-addWarnAt reason loc msg = add_warn_at reason loc msg Outputable.empty+addTcRnDiagnostic :: TcRnMessage -> TcM ()+addTcRnDiagnostic msg = do+  loc <- getSrcSpanM+  mkTcRnMessage loc msg >>= reportDiagnostic --- | Display a warning, with an optional flag, for the current source+-- | Display a diagnostic for the current source location, taken from+-- the 'TcRn' monad.+addDiagnostic :: TcRnMessage -> TcRn ()+addDiagnostic msg = add_diagnostic (TcRnMessageDetailed no_err_info msg)++-- | Display a diagnostic for a given source location.+addDiagnosticAt :: SrcSpan -> TcRnMessage -> TcRn ()+addDiagnosticAt loc msg = do+  unit_state <- hsc_units <$> getTopEnv+  let dia = TcRnMessageDetailed no_err_info msg+  mkTcRnMessage loc (TcRnMessageWithInfo unit_state dia) >>= reportDiagnostic++-- | Display a diagnostic, with an optional flag, for the current source -- location.-add_warn :: WarnReason -> SDoc -> SDoc -> TcRn ()-add_warn reason msg extra_info+add_diagnostic :: TcRnMessageDetailed -> TcRn ()+add_diagnostic msg   = do { loc <- getSrcSpanM-       ; add_warn_at reason loc msg extra_info }---- | Display a warning, with an optional flag, for a given location.-add_warn_at :: WarnReason -> SrcSpan -> SDoc -> SDoc -> TcRn ()-add_warn_at reason loc msg extra_info-  = do { printer <- getPrintUnqualified ;-         let { warn = mkLongWarnMsg loc printer-                                    msg extra_info } ;-         reportWarning reason warn }+       ; unit_state <- hsc_units <$> getTopEnv+       ; mkTcRnMessage loc (TcRnMessageWithInfo unit_state msg) >>= reportDiagnostic+       }   {-@@ -1584,12 +1647,12 @@         Other helper functions -} -add_err_tcm :: TidyEnv -> SDoc -> SrcSpan+add_err_tcm :: TidyEnv -> TcRnMessage -> SrcSpan             -> [ErrCtxt]             -> TcM ()-add_err_tcm tidy_env err_msg loc ctxt+add_err_tcm tidy_env msg loc ctxt  = do { err_info <- mkErrInfo tidy_env ctxt ;-        addLongErrAt loc err_msg err_info }+        add_long_err_at loc (TcRnMessageDetailed (ErrInfo err_info Outputable.empty) msg) }  mkErrInfo :: TidyEnv -> [ErrCtxt] -> TcM SDoc -- Tidy the error info, trimming excessive contexts@@ -1753,6 +1816,12 @@        ; lie_var <- getConstraintVar        ; updTcRef lie_var (`addInsols` unitBag ct) } +emitDelayedErrors :: Bag DelayedError -> TcM ()+emitDelayedErrors errs+  = do { traceTc "emitDelayedErrors" (ppr errs)+       ; lie_var <- getConstraintVar+       ; updTcRef lie_var (`addDelayedErrors` errs)}+ emitHole :: Hole -> TcM () emitHole hole   = do { traceTc "emitHole" (ppr hole)@@ -1765,6 +1834,12 @@        ; lie_var <- getConstraintVar        ; updTcRef lie_var (`addHoles` holes) } +emitNotConcreteError :: NotConcreteError -> TcM ()+emitNotConcreteError err+  = do { traceTc "emitNotConcreteError" (ppr err)+       ; lie_var <- getConstraintVar+       ; updTcRef lie_var (`addNotConcreteError` err) }+ -- | Throw out any constraints emitted by the thing_inside discardConstraints :: TcM a -> TcM a discardConstraints thing_inside = fst <$> captureConstraints thing_inside@@ -1772,10 +1847,10 @@ -- | The name says it all. The returned TcLevel is the *inner* TcLevel. pushLevelAndCaptureConstraints :: TcM a -> TcM (TcLevel, WantedConstraints, a) pushLevelAndCaptureConstraints thing_inside-  = do { env <- getLclEnv-       ; let tclvl' = pushTcLevel (tcl_tclvl env)+  = do { tclvl <- getTcLevel+       ; let tclvl' = pushTcLevel tclvl        ; traceTc "pushLevelAndCaptureConstraints {" (ppr tclvl')-       ; (res, lie) <- setLclEnv (env { tcl_tclvl = tclvl' }) $+       ; (res, lie) <- updLclEnv (\env -> env { tcl_tclvl = tclvl' }) $                        captureConstraints thing_inside        ; traceTc "pushLevelAndCaptureConstraints }" (ppr tclvl')        ; return (tclvl', lie, res) }@@ -1786,21 +1861,11 @@ pushTcLevelM :: TcM a -> TcM (TcLevel, a) -- See Note [TcLevel assignment] in GHC.Tc.Utils.TcType pushTcLevelM thing_inside-  = do { env <- getLclEnv-       ; let tclvl' = pushTcLevel (tcl_tclvl env)-       ; res <- setLclEnv (env { tcl_tclvl = tclvl' })-                          thing_inside+  = do { tclvl <- getTcLevel+       ; let tclvl' = pushTcLevel tclvl+       ; res <- updLclEnv (\env -> env { tcl_tclvl = tclvl' }) thing_inside        ; return (tclvl', res) } --- Returns pushed TcLevel-pushTcLevelsM :: Int -> TcM a -> TcM (a, TcLevel)-pushTcLevelsM num_levels thing_inside-  = do { env <- getLclEnv-       ; let tclvl' = nTimes num_levels pushTcLevel (tcl_tclvl env)-       ; res <- setLclEnv (env { tcl_tclvl = tclvl' }) $-                thing_inside-       ; return (res, tclvl') }- getTcLevel :: TcM TcLevel getTcLevel = do { env <- getLclEnv                 ; return (tcl_tclvl env) }@@ -1955,6 +2020,15 @@ recordThSpliceUse :: TcM () recordThSpliceUse = do { env <- getGblEnv; writeTcRef (tcg_th_splice_used env) True } +recordThNeededRuntimeDeps :: [Linkable] -> PkgsLoaded -> TcM ()+recordThNeededRuntimeDeps new_links new_pkgs+  = do { env <- getGblEnv+       ; updTcRef (tcg_th_needed_deps env) $ \(needed_links, needed_pkgs) ->+           let links = new_links ++ needed_links+               !pkgs = plusUDFM needed_pkgs new_pkgs+               in (links, pkgs)+       }+ keepAlive :: Name -> TcRn ()     -- Record the name in the keep-alive set keepAlive name   = do { env <- getGblEnv@@ -1994,14 +2068,15 @@ -- | Mark that safe inference has failed -- See Note [Safe Haskell Overlapping Instances Implementation] -- although this is used for more than just that failure case.-recordUnsafeInfer :: WarningMessages -> TcM ()-recordUnsafeInfer warns =-    getGblEnv >>= \env -> writeTcRef (tcg_safeInfer env) (False, warns)+recordUnsafeInfer :: Messages TcRnMessage -> TcM ()+recordUnsafeInfer msgs =+    getGblEnv >>= \env -> do writeTcRef (tcg_safe_infer env) False+                             writeTcRef (tcg_safe_infer_reasons env) msgs  -- | Figure out the final correct safe haskell mode finalSafeMode :: DynFlags -> TcGblEnv -> IO SafeHaskellMode finalSafeMode dflags tcg_env = do-    safeInf <- fst <$> readIORef (tcg_safeInfer tcg_env)+    safeInf <- readIORef (tcg_safe_infer tcg_env)     return $ case safeHaskell dflags of         Sf_None | safeInferOn dflags && safeInf -> Sf_SafeInferred                 | otherwise                     -> Sf_None@@ -2055,43 +2130,49 @@   = do  { tcg_env <- getGblEnv         ; hsc_env <- getTopEnv           -- bangs to avoid leaking the envs (#19356)-        ; let !mod = tcg_semantic_mod tcg_env-              !home_unit = hsc_home_unit hsc_env+        ; let !mhome_unit = hsc_home_unit_maybe hsc_env+              !knot_vars = tcg_type_env_var tcg_env               -- When we are instantiating a signature, we DEFINITELY               -- do not want to knot tie.-              is_instantiate = isHomeUnitInstantiating home_unit+              is_instantiate = fromMaybe False (isHomeUnitInstantiating <$> mhome_unit)         ; let { if_env = IfGblEnv {                             if_doc = text "initIfaceTcRn",                             if_rec_types =                                 if is_instantiate-                                    then Nothing-                                    else Just (mod, get_type_env)+                                    then emptyKnotVars+                                    else readTcRef <$> knot_vars+                            }                          }-              ; get_type_env = readTcRef (tcg_type_env_var tcg_env) }         ; setEnvs (if_env, ()) thing_inside } --- Used when sucking in a ModIface into a ModDetails to put in--- the HPT.  Notably, unlike initIfaceCheck, this does NOT use--- hsc_type_env_var (since we're not actually going to typecheck,--- so this variable will never get updated!)+-- | 'initIfaceLoad' can be used when there's no chance that the action will+-- call 'typecheckIface' when inside a module loop and hence 'tcIfaceGlobal'. initIfaceLoad :: HscEnv -> IfG a -> IO a initIfaceLoad hsc_env do_this  = do let gbl_env = IfGblEnv {                         if_doc = text "initIfaceLoad",-                        if_rec_types = Nothing+                        if_rec_types = emptyKnotVars                     }+      initTcRnIf 'i' (hsc_env { hsc_type_env_vars = emptyKnotVars }) gbl_env () do_this++-- | This is used when we are doing to call 'typecheckModule' on an 'ModIface',+-- if it's part of a loop with some other modules then we need to use their+-- IORef TypeEnv vars when typechecking but crucially not our own.+initIfaceLoadModule :: HscEnv -> Module -> IfG a -> IO a+initIfaceLoadModule hsc_env this_mod do_this+ = do let gbl_env = IfGblEnv {+                        if_doc = text "initIfaceLoadModule",+                        if_rec_types = readTcRef <$> knotVarsWithout this_mod (hsc_type_env_vars hsc_env)+                    }       initTcRnIf 'i' hsc_env gbl_env () do_this  initIfaceCheck :: SDoc -> HscEnv -> IfG a -> IO a -- Used when checking the up-to-date-ness of the old Iface -- Initialise the environment with no useful info at all initIfaceCheck doc hsc_env do_this- = do let rec_types = case hsc_type_env_var hsc_env of-                         Just (mod,var) -> Just (mod, readTcRef var)-                         Nothing        -> Nothing-          gbl_env = IfGblEnv {+ = do let gbl_env = IfGblEnv {                         if_doc = text "initIfaceCheck" <+> doc,-                        if_rec_types = rec_types+                        if_rec_types = readTcRef <$> hsc_type_env_vars hsc_env                     }       initTcRnIf 'i' hsc_env gbl_env () do_this @@ -2117,9 +2198,8 @@ failIfM msg = do     env <- getLclEnv     let full_msg = (if_loc env <> colon) $$ nest 2 msg-    dflags <- getDynFlags     logger <- getLogger-    liftIO (putLogMsg logger dflags NoReason SevFatal+    liftIO (logMsg logger MCFatal              noSrcSpan $ withPprStyle defaultErrStyle full_msg)     failM @@ -2128,14 +2208,14 @@ -- | Run thing_inside in an interleaved thread. -- It shares everything with the parent thread, so this is DANGEROUS. ----- It returns Nothing if the computation fails+-- It throws an error if the computation fails -- -- It's used for lazily type-checking interface -- signatures, which is pretty benign. ----- See Note [Masking exceptions in forkM_maybe]-forkM_maybe :: SDoc -> IfL a -> IfL (Maybe a)-forkM_maybe doc thing_inside+-- See Note [Masking exceptions in forkM]+forkM :: SDoc -> IfL a -> IfL a+forkM doc thing_inside  = unsafeInterleaveM $ uninterruptibleMaskM_ $     do { traceIf (text "Starting fork {" <+> doc)        ; mb_res <- tryM $@@ -2143,48 +2223,37 @@                    thing_inside        ; case mb_res of             Right r  -> do  { traceIf (text "} ending fork" <+> doc)-                            ; return (Just r) }+                            ; return r }             Left exn -> do {                 -- Bleat about errors in the forked thread, if -ddump-if-trace is on                 -- Otherwise we silently discard errors. Errors can legitimately-                -- happen when compiling interface signatures (see tcInterfaceSigs)+                -- happen when compiling interface signatures.                   whenDOptM Opt_D_dump_if_trace $ do-                      dflags <- getDynFlags                       logger <- getLogger                       let msg = hang (text "forkM failed:" <+> doc)                                    2 (text (show exn))-                      liftIO $ putLogMsg logger dflags-                                         NoReason-                                         SevFatal+                      liftIO $ logMsg logger+                                         MCFatal                                          noSrcSpan                                          $ withPprStyle defaultErrStyle msg-                 ; traceIf (text "} ending fork (badly)" <+> doc)-                ; return Nothing }+                ; pgmError "Cannot continue after interface file error" }     } -forkM :: SDoc -> IfL a -> IfL a-forkM doc thing_inside- = do   { mb_res <- forkM_maybe doc thing_inside-        ; return (case mb_res of-                        Nothing -> pgmError "Cannot continue after interface file error"-                                   -- pprPanic "forkM" doc-                        Just r  -> r) }- setImplicitEnvM :: TypeEnv -> IfL a -> IfL a setImplicitEnvM tenv m = updLclEnv (\lcl -> lcl                                      { if_implicits_env = Just tenv }) m  {--Note [Masking exceptions in forkM_maybe]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Note [Masking exceptions in forkM]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~  When using GHC-as-API it must be possible to interrupt snippets of code executed using runStmt (#1381). Since commit 02c4ab04 this is almost possible by throwing an asynchronous interrupt to the GHC thread. However, there is a subtle problem: runStmt first typechecks the code before running it, and the exception might interrupt the type checker rather than the code. Moreover, the-typechecker might be inside an unsafeInterleaveIO (through forkM_maybe), and+typechecker might be inside an unsafeInterleaveIO (through forkM), and more importantly might be inside an exception handler inside that unsafeInterleaveIO. If that is the case, the exception handler will rethrow the asynchronous exception as a synchronous exception, and the exception will end
GHC/Tc/Utils/TcMType.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP             #-}+ {-# LANGUAGE MultiWayIf      #-} {-# LANGUAGE TupleSections   #-} @@ -25,7 +25,7 @@   newOpenFlexiTyVar, newOpenFlexiTyVarTy, newOpenTypeKind,   newOpenBoxedTypeKind,   newMetaKindVar, newMetaKindVars, newMetaTyVarTyAtLevel,-  newAnonMetaTyVar, cloneMetaTyVar,+  newAnonMetaTyVar, newConcreteTyVar, cloneMetaTyVar,   newCycleBreakerTyVar,    newMultiplicityVar,@@ -36,9 +36,9 @@   --------------------------------   -- Creating new evidence variables   newEvVar, newEvVars, newDict,-  newWanted, newWanteds, cloneWanted, cloneWC,+  newWantedWithLoc, newWanted, newWanteds, cloneWanted, cloneWC, cloneWantedCtEv,   emitWanted, emitWantedEq, emitWantedEvVar, emitWantedEvVars,-  emitDerivedEqs,+  emitWantedEqs,   newTcEvBinds, newNoTcEvBinds, addTcEvBind,   emitNewExprHole, @@ -46,6 +46,8 @@   unpackCoercionHole, unpackCoercionHole_maybe,   checkCoercionHole, +  ConcreteHole, newConcreteHole,+   newImplication,    --------------------------------@@ -58,84 +60,98 @@   --------------------------------   -- Expected types   ExpType(..), ExpSigmaType, ExpRhoType,-  mkCheckExpType, newInferExpType, tcInfer,+  mkCheckExpType, newInferExpType, newInferExpTypeFRR,+  tcInfer, tcInferFRR,   readExpType, readExpType_maybe, readScaledExpType,   expTypeToType, scaledExpTypeToType,   checkingExpType_maybe, checkingExpType,-  inferResultToType, fillInferResult, promoteTcType,+  inferResultToType, ensureMonoType, promoteTcType,    --------------------------------   -- Zonking and tidying-  zonkTidyTcType, zonkTidyTcTypes, zonkTidyOrigin,-  tidyEvVar, tidyCt, tidyHole, tidySkolemInfo,+  zonkTidyTcType, zonkTidyTcTypes, zonkTidyOrigin, zonkTidyOrigins,+  zonkTidyFRRInfos,+  tidyEvVar, tidyCt, tidyHole, tidyDelayedError,     zonkTcTyVar, zonkTcTyVars,-  zonkTcTyVarToTyVar, zonkInvisTVBinder,+  zonkTcTyVarToTcTyVar, zonkTcTyVarsToTcTyVars,+  zonkInvisTVBinder,   zonkTyCoVarsAndFV, zonkTcTypeAndFV, zonkDTyCoVarSetAndFV,   zonkTyCoVarsAndFVList,    zonkTcType, zonkTcTypes, zonkCo,-  zonkTyCoVarKind, zonkTyCoVarKindBinder,+  zonkTyCoVarKind,   zonkEvVar, zonkWC, zonkImplication, zonkSimples,   zonkId, zonkCoVar,-  zonkCt, zonkSkolemInfo,+  zonkCt, zonkSkolemInfo, zonkSkolemInfoAnon,    ---------------------------------   -- Promotion, defaulting, skolemisation   defaultTyVar, promoteMetaTyVarTo, promoteTyVarSet,   quantifyTyVars, isQuantifiableTv,-  skolemiseUnboundMetaTyVar, zonkAndSkolemise, skolemiseQuantifiedTyVar,+  zonkAndSkolemise, skolemiseQuantifiedTyVar,   doNotQuantifyTyVars,    candidateQTyVarsOfType,  candidateQTyVarsOfKind,   candidateQTyVarsOfTypes, candidateQTyVarsOfKinds,+  candidateQTyVarsWithBinders,   CandidatesQTvs(..), delCandidates,   candidateKindVars, partitionCandidates,    -------------------------------  -- Levity polymorphism-  ensureNotLevPoly, checkForLevPoly, checkForLevPolyX, formatLevPolyErr-  ) where+  -- Representation polymorphism+  checkTypeHasFixedRuntimeRep, -#include "HsVersions.h"+  ------------------------------+  -- Other+  anyUnfilledCoercionHoles+  ) where --- friends: import GHC.Prelude -import {-# SOURCE #-}   GHC.Tc.Utils.Unify( unifyType {- , unifyKind -} )+import GHC.Driver.Session+import qualified GHC.LanguageExtensions as LangExt +import GHC.Tc.Types.Origin+import GHC.Tc.Utils.Monad        -- TcType, amongst others+import GHC.Tc.Types.Constraint+import GHC.Tc.Types.Evidence+import GHC.Tc.Utils.TcType+import GHC.Tc.Errors.Types+import GHC.Tc.Errors.Ppr+ import GHC.Core.TyCo.Rep import GHC.Core.TyCo.Ppr-import GHC.Tc.Utils.TcType import GHC.Core.Type import GHC.Core.TyCon import GHC.Core.Coercion import GHC.Core.Class-import GHC.Types.Var import GHC.Core.Predicate-import GHC.Tc.Types.Origin+import GHC.Core.InstEnv (ClsInst(is_tys)) --- others:-import GHC.Tc.Utils.Monad        -- TcType, amongst others-import GHC.Tc.Types.Constraint-import GHC.Tc.Types.Evidence+import GHC.Types.Var import GHC.Types.Id as Id import GHC.Types.Name import GHC.Types.Var.Set+ import GHC.Builtin.Types+import GHC.Types.Error import GHC.Types.Var.Env-import GHC.Types.Name.Env-import GHC.Utils.Misc-import GHC.Utils.Outputable-import GHC.Utils.Panic+import GHC.Types.Unique.Set+import GHC.Types.Basic ( TypeOrKind(..)+                       , NonStandardDefaultingStrategy(..)+                       , DefaultingStrategy(..), defaultNonStandardTyVars )+ import GHC.Data.FastString import GHC.Data.Bag import GHC.Data.Pair-import GHC.Types.Unique.Set-import GHC.Driver.Session-import GHC.Driver.Ppr-import qualified GHC.LanguageExtensions as LangExt-import GHC.Types.Basic ( TypeOrKind(..) ) +import GHC.Utils.Misc+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Utils.Panic.Plain+import GHC.Utils.Constants (debugIsOn)+import GHC.Utils.Trace+ import Control.Monad import GHC.Data.Maybe import qualified Data.Semigroup as Semi@@ -179,17 +195,27 @@ newEvVar ty = do { name <- newSysName (predTypeOccName ty)                  ; return (mkLocalIdOrCoVar name Many ty) } +-- | Create a new Wanted constraint with the given 'CtLoc'.+newWantedWithLoc :: CtLoc -> PredType -> TcM CtEvidence+newWantedWithLoc loc pty+  = do dst <- case classifyPredType pty of+                EqPred {} -> HoleDest  <$> newCoercionHole pty+                _         -> EvVarDest <$> newEvVar pty+       return $ CtWanted { ctev_dest      = dst+                         , ctev_pred      = pty+                         , ctev_loc       = loc+                         , ctev_rewriters = emptyRewriterSet }++-- | Create a new Wanted constraint with the given 'CtOrigin', and+-- location information taken from the 'TcM' environment. newWanted :: CtOrigin -> Maybe TypeOrKind -> PredType -> TcM CtEvidence -- Deals with both equality and non-equality predicates newWanted orig t_or_k pty   = do loc <- getCtLocM orig t_or_k-       d <- if isEqPrimPred pty then HoleDest  <$> newCoercionHole pty-                                else EvVarDest <$> newEvVar pty-       return $ CtWanted { ctev_dest = d-                         , ctev_pred = pty-                         , ctev_nosh = WDeriv-                         , ctev_loc = loc }+       newWantedWithLoc loc pty +-- | Create new Wanted constraints with the given 'CtOrigin',+-- and location information taken from the 'TcM' environment. newWanteds :: CtOrigin -> ThetaType -> TcM [CtEvidence] newWanteds orig = mapM (newWanted orig Nothing) @@ -197,14 +223,18 @@ -- Cloning constraints ---------------------------------------------- -cloneWanted :: Ct -> TcM Ct-cloneWanted ct-  | ev@(CtWanted { ctev_pred = pty, ctev_dest = HoleDest _ }) <- ctEvidence ct+cloneWantedCtEv :: CtEvidence -> TcM CtEvidence+cloneWantedCtEv ctev@(CtWanted { ctev_pred = pty, ctev_dest = HoleDest _ })+  | isEqPrimPred pty   = do { co_hole <- newCoercionHole pty-       ; return (mkNonCanonical (ev { ctev_dest = HoleDest co_hole })) }+       ; return (ctev { ctev_dest = HoleDest co_hole }) }   | otherwise-  = return ct+  = pprPanic "cloneWantedCtEv" (ppr pty)+cloneWantedCtEv ctev = return ctev +cloneWanted :: Ct -> TcM Ct+cloneWanted ct = mkNonCanonical <$> cloneWantedCtEv (ctEvidence ct)+ cloneWC :: WantedConstraints -> TcM WantedConstraints -- Clone all the evidence bindings in --   a) the ic_bind field of any implications@@ -233,19 +263,13 @@        ; emitSimple $ mkNonCanonical ev        ; return $ ctEvTerm ev } -emitDerivedEqs :: CtOrigin -> [(TcType,TcType)] -> TcM ()--- Emit some new derived nominal equalities-emitDerivedEqs origin pairs+emitWantedEqs :: CtOrigin -> [(TcType,TcType)] -> TcM ()+-- Emit some new wanted nominal equalities+emitWantedEqs origin pairs   | null pairs   = return ()   | otherwise-  = do { loc <- getCtLocM origin Nothing-       ; emitSimples (listToBag (map (mk_one loc) pairs)) }-  where-    mk_one loc (ty1, ty2)-       = mkNonCanonical $-         CtDerived { ctev_pred = mkPrimEqPred ty1 ty2-                   , ctev_loc = loc }+  = mapM_ (uncurry (emitWantedEq origin TypeLevel Nominal)) pairs  -- | Emits a new equality constraint emitWantedEq :: CtOrigin -> TypeOrKind -> Role -> TcType -> TcType -> TcM Coercion@@ -253,8 +277,10 @@   = do { hole <- newCoercionHole pty        ; loc <- getCtLocM origin (Just t_or_k)        ; emitSimple $ mkNonCanonical $-         CtWanted { ctev_pred = pty, ctev_dest = HoleDest hole-                  , ctev_nosh = WDeriv, ctev_loc = loc }+         CtWanted { ctev_pred = pty+                  , ctev_dest = HoleDest hole+                  , ctev_loc = loc+                  , ctev_rewriters = rewriterSetFromTypes [ty1, ty2] }        ; return (HoleCo hole) }   where     pty = mkPrimEqPredRole role ty1 ty2@@ -265,10 +291,10 @@ emitWantedEvVar origin ty   = do { new_cv <- newEvVar ty        ; loc <- getCtLocM origin Nothing-       ; let ctev = CtWanted { ctev_dest = EvVarDest new_cv-                             , ctev_pred = ty-                             , ctev_nosh = WDeriv-                             , ctev_loc  = loc }+       ; let ctev = CtWanted { ctev_dest      = EvVarDest new_cv+                             , ctev_pred      = ty+                             , ctev_loc       = loc+                             , ctev_rewriters = emptyRewriterSet }        ; emitSimple $ mkNonCanonical ctev        ; return new_cv } @@ -331,21 +357,19 @@ newCoercionHole :: TcPredType -> TcM CoercionHole newCoercionHole pred_ty   = do { co_var <- newEvVar pred_ty-       ; traceTc "New coercion hole:" (ppr co_var)+       ; traceTc "New coercion hole:" (ppr co_var <+> dcolon <+> ppr pred_ty)        ; ref <- newMutVar Nothing        ; return $ CoercionHole { ch_co_var = co_var, ch_ref = ref } }  -- | Put a value in a coercion hole fillCoercionHole :: CoercionHole -> Coercion -> TcM ()-fillCoercionHole (CoercionHole { ch_ref = ref, ch_co_var = cv }) co-  = do {-#if defined(DEBUG)-       ; cts <- readTcRef ref-       ; whenIsJust cts $ \old_co ->-         pprPanic "Filling a filled coercion hole" (ppr cv $$ ppr co $$ ppr old_co)-#endif-       ; traceTc "Filling coercion hole" (ppr cv <+> text ":=" <+> ppr co)-       ; writeTcRef ref (Just co) }+fillCoercionHole (CoercionHole { ch_ref = ref, ch_co_var = cv }) co = do+  when debugIsOn $ do+    cts <- readTcRef ref+    whenIsJust cts $ \old_co ->+      pprPanic "Filling a filled coercion hole" (ppr cv $$ ppr co $$ ppr old_co)+  traceTc "Filling coercion hole" (ppr cv <+> text ":=" <+> ppr co)+  writeTcRef ref (Just co)  -- | Is a coercion hole filled in? isFilledCoercionHole :: CoercionHole -> TcM Bool@@ -374,10 +398,10 @@   = do { cv_ty <- zonkTcType (varType cv)                   -- co is already zonked, but cv might not be        ; return $-         ASSERT2( ok cv_ty-                , (text "Bad coercion hole" <+>-                   ppr cv <> colon <+> vcat [ ppr t1, ppr t2, ppr role-                                            , ppr cv_ty ]) )+         assertPpr (ok cv_ty)+                   (text "Bad coercion hole" <+>+                    ppr cv <> colon <+> vcat [ ppr t1, ppr t2, ppr role+                                             , ppr cv_ty ])          co }   | otherwise   = return co@@ -391,6 +415,24 @@              | otherwise              = False +-- | A coercion hole used to store evidence for `Concrete#` constraints.+--+-- See Note [The Concrete mechanism].+type ConcreteHole = CoercionHole++-- | Create a new (initially unfilled) coercion hole,+-- to hold evidence for a @'Concrete#' (ty :: ki)@ constraint.+newConcreteHole :: Kind -- ^ Kind of the thing we want to ensure is concrete (e.g. 'runtimeRepTy')+                -> Type -- ^ Thing we want to ensure is concrete (e.g. some 'RuntimeRep')+                -> TcM (ConcreteHole, TcType)+                  -- ^ where to put the evidence, and a metavariable to store+                  -- the concrete type+newConcreteHole ki ty+  = do { concrete_ty <- newFlexiTyVarTy ki+       ; let co_ty = mkHeteroPrimEqPred ki ki ty concrete_ty+       ; hole <- newCoercionHole co_ty+       ; return (hole, concrete_ty) }+ {- ********************************************************************** *                       ExpType functions@@ -434,18 +476,42 @@ out later by some means -- see fillInferResult, and Note [fillInferResult]  This behaviour triggered in test gadt/gadt-escape1.++Note [FixedRuntimeRep context in ExpType]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Sometimes, we want to be sure that we fill an ExpType with a type+that has a syntactically fixed RuntimeRep (in the sense of+Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete).++Example:++  pattern S a = (a :: (T :: TYPE R))++We have to infer a type for `a` which has a syntactically fixed RuntimeRep.+When it comes time to filling in the inferred type, we do the appropriate+representation-polymorphism check, much like we do a level check+as explained in Note [TcLevel of ExpType].++See test case T21325. -}  -- actual data definition is in GHC.Tc.Utils.TcType  newInferExpType :: TcM ExpType-newInferExpType+newInferExpType = new_inferExpType Nothing++newInferExpTypeFRR :: FixedRuntimeRepContext -> TcM ExpTypeFRR+newInferExpTypeFRR frr_orig = new_inferExpType (Just frr_orig)++new_inferExpType :: Maybe FixedRuntimeRepContext -> TcM ExpType+new_inferExpType mb_frr_orig   = do { u <- newUnique        ; tclvl <- getTcLevel        ; traceTc "newInferExpType" (ppr u <+> ppr tclvl)        ; ref <- newMutVar Nothing        ; return (Infer (IR { ir_uniq = u, ir_lvl = tclvl-                           , ir_ref = ref })) }+                           , ir_ref = ref+                           , ir_frr = mb_frr_orig })) }  -- | Extract a type out of an ExpType, if one exists. But one should always -- exist. Unless you're quite sure you know what you're doing.@@ -498,7 +564,7 @@                             -- See Note [inferResultToType]                           ; return ty }             Nothing -> do { rr  <- newMetaTyVarTyAtLevel tc_lvl runtimeRepTy-                          ; tau <- newMetaTyVarTyAtLevel tc_lvl (tYPE rr)+                          ; tau <- newMetaTyVarTyAtLevel tc_lvl (mkTYPEapp rr)                             -- See Note [TcLevel of ExpType]                           ; writeMutVar ref (Just tau)                           ; return tau }@@ -515,119 +581,30 @@ already.  See also Note [TcLevel of ExpType] above, and-Note [fillInferResult].+Note [fillInferResult] in GHC.Tc.Utils.Unify. -}  -- | Infer a type using a fresh ExpType -- See also Note [ExpType] in "GHC.Tc.Utils.TcMType"+--+-- Use 'tcInferFRR' if you require the type to have a fixed+-- runtime representation. tcInfer :: (ExpSigmaType -> TcM a) -> TcM (a, TcSigmaType)-tcInfer tc_check-  = do { res_ty <- newInferExpType+tcInfer = tc_infer Nothing++-- | Like 'tcInfer', except it ensures that the resulting type+-- has a syntactically fixed RuntimeRep as per Note [Fixed RuntimeRep] in+-- GHC.Tc.Utils.Concrete.+tcInferFRR :: FixedRuntimeRepContext -> (ExpSigmaTypeFRR -> TcM a) -> TcM (a, TcSigmaTypeFRR)+tcInferFRR frr_orig = tc_infer (Just frr_orig)++tc_infer :: Maybe FixedRuntimeRepContext -> (ExpSigmaType -> TcM a) -> TcM (a, TcSigmaType)+tc_infer mb_frr tc_check+  = do { res_ty <- new_inferExpType mb_frr        ; result <- tc_check res_ty        ; res_ty <- readExpType res_ty        ; return (result, res_ty) } -fillInferResult :: TcType -> InferResult -> TcM TcCoercionN--- If co = fillInferResult t1 t2---    => co :: t1 ~ t2--- See Note [fillInferResult]-fillInferResult act_res_ty (IR { ir_uniq = u, ir_lvl = res_lvl-                               , ir_ref = ref })-  = do { mb_exp_res_ty <- readTcRef ref-       ; case mb_exp_res_ty of-            Just exp_res_ty-               -> do { traceTc "Joining inferred ExpType" $-                       ppr u <> colon <+> ppr act_res_ty <+> char '~' <+> ppr exp_res_ty-                     ; cur_lvl <- getTcLevel-                     ; unless (cur_lvl `sameDepthAs` res_lvl) $-                       ensureMonoType act_res_ty-                     ; unifyType Nothing act_res_ty exp_res_ty }-            Nothing-               -> do { traceTc "Filling inferred ExpType" $-                       ppr u <+> text ":=" <+> ppr act_res_ty-                     ; (prom_co, act_res_ty) <- promoteTcType res_lvl act_res_ty-                     ; writeTcRef ref (Just act_res_ty)-                     ; return prom_co }-     }---{- Note [fillInferResult]-~~~~~~~~~~~~~~~~~~~~~~~~~-When inferring, we use fillInferResult to "fill in" the hole in InferResult-   data InferResult = IR { ir_uniq :: Unique-                         , ir_lvl  :: TcLevel-                         , ir_ref  :: IORef (Maybe TcType) }--There are two things to worry about:--1. What if it is under a GADT or existential pattern match?-   - GADTs: a unification variable (and Infer's hole is similar) is untouchable-   - Existentials: be careful about skolem-escape--2. What if it is filled in more than once?  E.g. multiple branches of a case-     case e of-        T1 -> e1-        T2 -> e2--Our typing rules are:--* The RHS of a existential or GADT alternative must always be a-  monotype, regardless of the number of alternatives.--* Multiple non-existential/GADT branches can have (the same)-  higher rank type (#18412).  E.g. this is OK:-      case e of-        True  -> hr-        False -> hr-  where hr:: (forall a. a->a) -> Int-  c.f. Section 7.1 of "Practical type inference for arbitrary-rank types"-       We use choice (2) in that Section.-       (GHC 8.10 and earlier used choice (1).)--  But note that-      case e of-        True  -> hr-        False -> \x -> hr x-  will fail, because we still /infer/ both branches, so the \x will get-  a (monotype) unification variable, which will fail to unify with-  (forall a. a->a)--For (1) we can detect the GADT/existential situation by seeing that-the current TcLevel is greater than that stored in ir_lvl of the Infer-ExpType.  We bump the level whenever we go past a GADT/existential match.--Then, before filling the hole use promoteTcType to promote the type-to the outer ir_lvl.  promoteTcType does this-  - create a fresh unification variable alpha at level ir_lvl-  - emits an equality alpha[ir_lvl] ~ ty-  - fills the hole with alpha-That forces the type to be a monotype (since unification variables can-only unify with monotypes); and catches skolem-escapes because the-alpha is untouchable until the equality floats out.--For (2), we simply look to see if the hole is filled already.-  - if not, we promote (as above) and fill the hole-  - if it is filled, we simply unify with the type that is-    already there--There is one wrinkle.  Suppose we have-   case e of-      T1 -> e1 :: (forall a. a->a) -> Int-      G2 -> e2-where T1 is not GADT or existential, but G2 is a GADT.  Then supppose the-T1 alternative fills the hole with (forall a. a->a) -> Int, which is fine.-But now the G2 alternative must not *just* unify with that else we'd risk-allowing through (e2 :: (forall a. a->a) -> Int).  If we'd checked G2 first-we'd have filled the hole with a unification variable, which enforces a-monotype.--So if we check G2 second, we still want to emit a constraint that restricts-the RHS to be a monotype. This is done by ensureMonoType, and it works-by simply generating a constraint (alpha ~ ty), where alpha is a fresh-unification variable.  We discard the evidence.---}- {- ********************************************************************* *                                                                      *               Promoting types@@ -675,7 +652,7 @@     promote_it  -- Emit a constraint  (alpha :: TYPE rr) ~ ty                 -- where alpha and rr are fresh and from level dest_lvl       = do { rr      <- newMetaTyVarTyAtLevel dest_lvl runtimeRepTy-           ; prom_ty <- newMetaTyVarTyAtLevel dest_lvl (tYPE rr)+           ; prom_ty <- newMetaTyVarTyAtLevel dest_lvl (mkTYPEapp rr)            ; let eq_orig = TypeEqOrigin { uo_actual   = ty                                         , uo_expected = prom_ty                                         , uo_thing    = Nothing@@ -816,6 +793,7 @@        TyVarTv        -> fsLit "a"        RuntimeUnkTv   -> fsLit "r"        CycleBreakerTv -> fsLit "b"+       ConcreteTv {}  -> fsLit "c"  newAnonMetaTyVar :: MetaInfo -> Kind -> TcM TcTyVar newAnonMetaTyVar mi = newNamedAnonMetaTyVar (metaInfoToTyVarName mi) mi@@ -831,10 +809,10 @@         ; return tyvar }  -- makes a new skolem tv-newSkolemTyVar :: Name -> Kind -> TcM TcTyVar-newSkolemTyVar name kind+newSkolemTyVar :: SkolemInfo -> Name -> Kind -> TcM TcTyVar+newSkolemTyVar skol_info name kind   = do { lvl <- getTcLevel-       ; return (mkTcTyVar name kind (SkolemTv lvl False)) }+       ; return (mkTcTyVar name kind (SkolemTv skol_info lvl False)) }  newTyVarTyVar :: Name -> Kind -> TcM TcTyVar -- See Note [TyVarTv]@@ -860,6 +838,17 @@        ; traceTc "cloneTyVarTyVar" (ppr tyvar)        ; return tyvar } +-- | Create a new metavariable, of the given kind, which can only be unified+-- with a concrete type.+--+-- Invariant: the kind must be concrete, as per Note [ConcreteTv].+-- This is checked with an assertion.+newConcreteTyVar :: HasDebugCallStack => ConcreteTvOrigin -> TcKind -> TcM TcTyVar+newConcreteTyVar reason kind =+  assertPpr (isConcrete kind)+    (text "newConcreteTyVar: non-concrete kind" <+> ppr kind)+  $ newAnonMetaTyVar (ConcreteTv reason) kind+ newPatSigTyVar :: Name -> Kind -> TcM TcTyVar newPatSigTyVar name kind   = do { details <- newMetaDetails TauTv@@ -906,7 +895,7 @@  cloneMetaTyVar :: TcTyVar -> TcM TcTyVar cloneMetaTyVar tv-  = ASSERT( isTcTyVar tv )+  = assert (isTcTyVar tv) $     do  { ref  <- newMutVar Flexi         ; name' <- cloneMetaTyVarName (tyVarName tv)         ; let details' = case tcTyVarDetails tv of@@ -918,12 +907,15 @@  -- Works for both type and kind variables readMetaTyVar :: TyVar -> TcM MetaDetails-readMetaTyVar tyvar = ASSERT2( isMetaTyVar tyvar, ppr tyvar )+readMetaTyVar tyvar = assertPpr (isMetaTyVar tyvar) (ppr tyvar) $                       readMutVar (metaTyVarRef tyvar)  isFilledMetaTyVar_maybe :: TcTyVar -> TcM (Maybe Type) isFilledMetaTyVar_maybe tv- | MetaTv { mtv_ref = ref } <- tcTyVarDetails tv+-- TODO: This should be an assertion that tv is definitely a TcTyVar but it fails+-- at the moment (Jan 22)+ | isTcTyVar tv+ , MetaTv { mtv_ref = ref } <- tcTyVarDetails tv  = do { cts <- readTcRef ref       ; case cts of           Indirect ty -> return (Just ty)@@ -955,15 +947,13 @@  -- Everything from here on only happens if DEBUG is on   | not (isTcTyVar tyvar)-  = ASSERT2( False, text "Writing to non-tc tyvar" <+> ppr tyvar )-    return ()+  = massertPpr False (text "Writing to non-tc tyvar" <+> ppr tyvar)    | MetaTv { mtv_ref = ref } <- tcTyVarDetails tyvar   = writeMetaTyVarRef tyvar ref ty    | otherwise-  = ASSERT2( False, text "Writing to non-meta tyvar" <+> ppr tyvar )-    return ()+  = massertPpr False (text "Writing to non-meta tyvar" <+> ppr tyvar)  -------------------- writeMetaTyVarRef :: TcTyVar -> TcRef MetaDetails -> TcType -> TcM ()@@ -987,10 +977,10 @@              zonked_ty_lvl  = tcTypeLevel zonked_ty              level_check_ok  = not (zonked_ty_lvl `strictlyDeeperThan` tv_lvl)              level_check_msg = ppr zonked_ty_lvl $$ ppr tv_lvl $$ ppr tyvar $$ ppr ty-             kind_check_ok = tcIsConstraintKind zonked_tv_kind-                          || tcEqKind zonked_ty_kind zonked_tv_kind-             -- Hack alert! tcIsConstraintKind: see GHC.Tc.Gen.HsType-             -- Note [Extra-constraint holes in partial type signatures]+             kind_check_ok = zonked_ty_kind `eqType` zonked_tv_kind+             -- Hack alert! eqType, not tcEqType. see:+             -- Note [coreView vs tcView] in GHC.Core.Type+             -- Note [Extra-constraint holes in partial type signatures] in GHC.Tc.Gen.HsType               kind_msg = hang (text "Ill-kinded update to meta tyvar")                            2 (    ppr tyvar <+> text "::" <+> (ppr tv_kind $$ ppr zonked_tv_kind)@@ -1000,13 +990,13 @@        ; traceTc "writeMetaTyVar" (ppr tyvar <+> text ":=" <+> ppr ty)         -- Check for double updates-       ; MASSERT2( isFlexi meta_details, double_upd_msg meta_details )+       ; massertPpr (isFlexi meta_details) (double_upd_msg meta_details)         -- Check for level OK-       ; MASSERT2( level_check_ok, level_check_msg )+       ; massertPpr level_check_ok level_check_msg         -- Check Kinds ok-       ; MASSERT2( kind_check_ok, kind_msg )+       ; massertPpr kind_check_ok kind_msg         -- Do the write        ; writeMutVar ref (Indirect ty) }@@ -1062,7 +1052,7 @@ newOpenTypeKind :: TcM TcKind newOpenTypeKind   = do { rr <- newFlexiTyVarTy runtimeRepTy-       ; return (tYPE rr) }+       ; return (mkTYPEapp rr) }  -- | Create a tyvar that can be a lifted or unlifted type. -- Returns alpha :: TYPE kappa, where both alpha and kappa are fresh@@ -1080,7 +1070,7 @@ newOpenBoxedTypeKind   = do { lev <- newFlexiTyVarTy (mkTyConTy levityTyCon)        ; let rr = mkTyConApp boxedRepDataConTyCon [lev]-       ; return (tYPE rr) }+       ; return (mkTYPEapp rr) }  newMetaTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar]) -- Instantiate with META type variables@@ -1252,6 +1242,9 @@ This change is inspired by and described in Section 7.2 of "Kind Inference for Datatypes", POPL'20. +NB: this is all rather similar to, but sadly not the same as+    Note [Error on unconstrained meta-variables]+ Wrinkle:  We must make absolutely sure that alpha indeed is not@@ -1339,6 +1332,12 @@ candidateKindVars :: CandidatesQTvs -> TyVarSet candidateKindVars dvs = dVarSetToVarSet (dv_kvs dvs) +delCandidates :: CandidatesQTvs -> [Var] -> CandidatesQTvs+delCandidates (DV { dv_kvs = kvs, dv_tvs = tvs, dv_cvs = cvs }) vars+  = DV { dv_kvs = kvs `delDVarSetList` vars+       , dv_tvs = tvs `delDVarSetList` vars+       , dv_cvs = cvs `delVarSetList`  vars }+ partitionCandidates :: CandidatesQTvs -> (TyVar -> Bool) -> (TyVarSet, CandidatesQTvs) -- The selected TyVars are returned as a non-deterministic TyVarSet partitionCandidates dvs@(DV { dv_kvs = kvs, dv_tvs = tvs }) pred@@ -1348,6 +1347,17 @@     (extracted_tvs, rest_tvs) = partitionDVarSet pred tvs     extracted = dVarSetToVarSet extracted_kvs `unionVarSet` dVarSetToVarSet extracted_tvs +candidateQTyVarsWithBinders :: [TyVar] -> Type -> TcM CandidatesQTvs+-- (candidateQTyVarsWithBinders tvs ty) returns the candidateQTyVars+-- of (forall tvs. ty), but do not treat 'tvs' as bound for the purpose+-- of Note [Naughty quantification candidates].  Why?+-- Because we are going to scoped-sort the quantified variables+-- in among the tvs+candidateQTyVarsWithBinders bound_tvs ty+  = do { kvs <- candidateQTyVarsOfKinds (map tyVarKind bound_tvs)+       ; all_tvs <- collect_cand_qtvs ty False emptyVarSet kvs ty+       ; return (all_tvs `delCandidates` bound_tvs) }+ -- | Gathers free variables to use as quantification candidates (in -- 'quantifyTyVars'). This might output the same var -- in both sets, if it's used in both a type and a kind.@@ -1379,12 +1389,6 @@ candidateQTyVarsOfKinds tys = foldM (\acc ty -> collect_cand_qtvs ty True emptyVarSet acc ty)                                     mempty tys -delCandidates :: CandidatesQTvs -> [Var] -> CandidatesQTvs-delCandidates (DV { dv_kvs = kvs, dv_tvs = tvs, dv_cvs = cvs }) vars-  = DV { dv_kvs = kvs `delDVarSetList` vars-       , dv_tvs = tvs `delDVarSetList` vars-       , dv_cvs = cvs `delVarSetList`  vars }- collect_cand_qtvs   :: TcType          -- original type that we started recurring into; for errors   -> Bool            -- True <=> consider every fv in Type to be dependent@@ -1467,6 +1471,11 @@                 -> return dv   -- this variable is from an outer context; skip                                -- See Note [Use level numbers for quantification] +                | case tcTyVarDetails tv of+                     SkolemTv _ lvl _ -> lvl > pushTcLevel cur_lvl+                     _                -> False+                -> return dv  -- Skip inner skolems; ToDo: explain+                 |  intersectsVarSet bound tv_kind_vars                    -- the tyvar must not be from an outer context, but we have                    -- already checked for this.@@ -1683,7 +1692,9 @@ Note [Deterministic UniqFM] in GHC.Types.Unique.DFM. -} -quantifyTyVars :: CandidatesQTvs   -- See Note [Dependent type variables]+quantifyTyVars :: SkolemInfo+               -> NonStandardDefaultingStrategy+               -> CandidatesQTvs   -- See Note [Dependent type variables]                                    -- Already zonked                -> TcM [TcTyVar] -- See Note [quantifyTyVars]@@ -1693,16 +1704,18 @@ -- invariants on CandidateQTvs, we do not have to filter out variables -- free in the environment here. Just quantify unconditionally, subject -- to the restrictions in Note [quantifyTyVars].-quantifyTyVars dvs+quantifyTyVars skol_info ns_strat dvs        -- short-circuit common case   | isEmptyCandidates dvs   = do { traceTc "quantifyTyVars has nothing to quantify" empty        ; return [] }    | otherwise-  = do { traceTc "quantifyTyVars {" (ppr dvs)+  = do { traceTc "quantifyTyVars {"+           ( vcat [ text "ns_strat =" <+> ppr ns_strat+                  , text "dvs =" <+> ppr dvs ]) -       ; undefaulted <- defaultTyVars dvs+       ; undefaulted <- defaultTyVars ns_strat dvs        ; final_qtvs  <- mapMaybeM zonk_quant undefaulted         ; traceTc "quantifyTyVars }"@@ -1711,7 +1724,7 @@         -- We should never quantify over coercion variables; check this        ; let co_vars = filter isCoVar final_qtvs-       ; MASSERT2( null co_vars, ppr co_vars )+       ; massertPpr (null co_vars) (ppr co_vars)         ; return final_qtvs }   where@@ -1723,12 +1736,14 @@       = return Nothing   -- this can happen for a covar that's associated with                          -- a coercion hole. Test case: typecheck/should_compile/T2494 -      | not (isTcTyVar tkv)-      = return (Just tkv)  -- For associated types in a class with a standalone-                           -- kind signature, we have the class variables in-                           -- scope, and they are TyVars not TcTyVars+-- Omit: no TyVars now+--      | not (isTcTyVar tkv)+--      = return (Just tkv)  -- For associated types in a class with a standalone+--                           -- kind signature, we have the class variables in+--                           -- scope, and they are TyVars not TcTyVars+       | otherwise-      = Just <$> skolemiseQuantifiedTyVar tkv+      = Just <$> skolemiseQuantifiedTyVar skol_info tkv  isQuantifiableTv :: TcLevel   -- Level of the context, outside the quantification                  -> TcTyVar@@ -1739,25 +1754,25 @@   | otherwise   = False -zonkAndSkolemise :: TcTyCoVar -> TcM TcTyCoVar+zonkAndSkolemise :: SkolemInfo -> TcTyCoVar -> TcM TcTyCoVar -- A tyvar binder is never a unification variable (TauTv), -- rather it is always a skolem. It *might* be a TyVarTv. -- (Because non-CUSK type declarations use TyVarTvs.) -- Regardless, it may have a kind that has not yet been zonked, -- and may include kind unification variables.-zonkAndSkolemise tyvar+zonkAndSkolemise skol_info tyvar   | isTyVarTyVar tyvar      -- We want to preserve the binding location of the original TyVarTv.      -- This is important for error messages. If we don't do this, then      -- we get bad locations in, e.g., typecheck/should_fail/T2688-  = do { zonked_tyvar <- zonkTcTyVarToTyVar tyvar-       ; skolemiseQuantifiedTyVar zonked_tyvar }+  = do { zonked_tyvar <- zonkTcTyVarToTcTyVar tyvar+       ; skolemiseQuantifiedTyVar skol_info zonked_tyvar }    | otherwise-  = ASSERT2( isImmutableTyVar tyvar || isCoVar tyvar, pprTyVar tyvar )+  = assertPpr (isImmutableTyVar tyvar || isCoVar tyvar) (pprTyVar tyvar) $     zonkTyCoVarKind tyvar -skolemiseQuantifiedTyVar :: TcTyVar -> TcM TcTyVar+skolemiseQuantifiedTyVar :: SkolemInfo -> TcTyVar -> TcM TcTyVar -- The quantified type variables often include meta type variables -- we want to freeze them into ordinary type variables -- The meta tyvar is updated to point to the new skolem TyVar.  Now any@@ -1769,54 +1784,57 @@ -- This function is called on both kind and type variables, -- but kind variables *only* if PolyKinds is on. -skolemiseQuantifiedTyVar tv+skolemiseQuantifiedTyVar skol_info tv   = case tcTyVarDetails tv of       SkolemTv {} -> do { kind <- zonkTcType (tyVarKind tv)                         ; return (setTyVarKind tv kind) }         -- It might be a skolem type variable,         -- for example from a user type signature -      MetaTv {} -> skolemiseUnboundMetaTyVar tv+      MetaTv {} -> skolemiseUnboundMetaTyVar skol_info tv        _other -> pprPanic "skolemiseQuantifiedTyVar" (ppr tv) -- RuntimeUnk -defaultTyVar :: Bool      -- True <=> please default this kind variable to *-             -> TcTyVar   -- If it's a MetaTyVar then it is unbound-             -> TcM Bool  -- True <=> defaulted away altogether--defaultTyVar default_kind tv+-- | Default a type variable using the given defaulting strategy.+--+-- See Note [Type variable defaulting options] in GHC.Types.Basic.+defaultTyVar :: DefaultingStrategy+             -> TcTyVar    -- If it's a MetaTyVar then it is unbound+             -> TcM Bool   -- True <=> defaulted away altogether+defaultTyVar def_strat tv   | not (isMetaTyVar tv)-  = return False--  | isTyVarTyVar tv+  || isTyVarTyVar tv     -- Do not default TyVarTvs. Doing so would violate the invariants     -- on TyVarTvs; see Note [TyVarTv] in GHC.Tc.Utils.TcMType.     -- #13343 is an example; #14555 is another     -- See Note [Inferring kinds for type declarations] in GHC.Tc.TyCl   = return False --  | isRuntimeRepVar tv  -- Do not quantify over a RuntimeRep var-                        -- unless it is a TyVarTv, handled earlier+  | isRuntimeRepVar tv+  , default_ns_vars   = do { traceTc "Defaulting a RuntimeRep var to LiftedRep" (ppr tv)        ; writeMetaTyVar tv liftedRepTy        ; return True }   | isLevityVar tv+  , default_ns_vars   = do { traceTc "Defaulting a Levity var to Lifted" (ppr tv)        ; writeMetaTyVar tv liftedDataConTy        ; return True }   | isMultiplicityVar tv-  = do { traceTc "Defaulting a Multiplicty var to Many" (ppr tv)+  , default_ns_vars+  = do { traceTc "Defaulting a Multiplicity var to Many" (ppr tv)        ; writeMetaTyVar tv manyDataConTy        ; return True } -  | default_kind            -- -XNoPolyKinds and this is a kind var-  = default_kind_var tv     -- so default it to * if possible+  | DefaultKindVars <- def_strat -- -XNoPolyKinds and this is a kind var: we must default it+  = default_kind_var tv    | otherwise   = return False    where+    default_ns_vars :: Bool+    default_ns_vars = defaultNonStandardTyVars def_strat     default_kind_var :: TyVar -> TcM Bool        -- defaultKindVar is used exclusively with -XNoPolyKinds        -- See Note [Defaulting with -XNoPolyKinds]@@ -1828,9 +1846,10 @@            ; writeMetaTyVar kv liftedTypeKind            ; return True }       | otherwise-      = do { addErr (vcat [ text "Cannot default kind variable" <+> quotes (ppr kv')-                          , text "of kind:" <+> ppr (tyVarKind kv')-                          , text "Perhaps enable PolyKinds or add a kind signature" ])+      = do { addErr $ TcRnUnknownMessage $ mkPlainError noHints $+               (vcat [ text "Cannot default kind variable" <+> quotes (ppr kv')+                     , text "of kind:" <+> ppr (tyVarKind kv')+                     , text "Perhaps enable PolyKinds or add a kind signature" ])            -- We failed to default it, so return False to say so.            -- Hence, it'll get skolemised.  That might seem odd, but we must either            -- promote, skolemise, or zap-to-Any, to satisfy GHC.Tc.Gen.HsType@@ -1842,17 +1861,37 @@       where         (_, kv') = tidyOpenTyCoVar emptyTidyEnv kv --- | Default some unconstrained type variables:---     RuntimeRep tyvars default to LiftedRep---     Multiplicity tyvars default to Many---     Type tyvars from dv_kvs default to Type, when -XNoPolyKinds---     (under -XNoPolyKinds, non-defaulting vars in dv_kvs is an error)-defaultTyVars :: CandidatesQTvs  -- ^ all candidates for quantification-              -> TcM [TcTyVar]   -- ^ those variables not defaulted-defaultTyVars dvs+-- | Default some unconstrained type variables, as specified+-- by the defaulting options:+--+--  - 'RuntimeRep' tyvars default to 'LiftedRep'+--  - 'Levity' tyvars default to 'Lifted'+--  - 'Multiplicity' tyvars default to 'Many'+--  - 'Type' tyvars from dv_kvs default to 'Type', when -XNoPolyKinds+--    (under -XNoPolyKinds, non-defaulting vars in dv_kvs is an error)+defaultTyVars :: NonStandardDefaultingStrategy+              -> CandidatesQTvs    -- ^ all candidates for quantification+              -> TcM [TcTyVar]     -- ^ those variables not defaulted+defaultTyVars ns_strat dvs   = do { poly_kinds <- xoptM LangExt.PolyKinds-       ; defaulted_kvs <- mapM (defaultTyVar (not poly_kinds)) dep_kvs-       ; defaulted_tvs <- mapM (defaultTyVar False)            nondep_tvs+       ; let+           def_tvs, def_kvs :: DefaultingStrategy+           def_tvs = NonStandardDefaulting ns_strat+           def_kvs+             | poly_kinds = def_tvs+             | otherwise  = DefaultKindVars+             -- As -XNoPolyKinds precludes polymorphic kind variables, we default them.+             -- For example:+             --+             --   type F :: Type -> Type+             --   type family F a where+             --      F (a -> b) = b+             --+             -- Here we get `a :: TYPE r`, so to accept this program when -XNoPolyKinds is enabled+             -- we must default the kind variable `r :: RuntimeRep`.+             -- Test case: T20584.+       ; defaulted_kvs <- mapM (defaultTyVar def_kvs) dep_kvs+       ; defaulted_tvs <- mapM (defaultTyVar def_tvs) nondep_tvs        ; let undefaulted_kvs = [ kv | (kv, False) <- dep_kvs    `zip` defaulted_kvs ]              undefaulted_tvs = [ tv | (tv, False) <- nondep_tvs `zip` defaulted_tvs ]        ; return (undefaulted_kvs ++ undefaulted_tvs) }@@ -1860,38 +1899,48 @@   where     (dep_kvs, nondep_tvs) = candidateVars dvs -skolemiseUnboundMetaTyVar :: TcTyVar -> TcM TyVar+skolemiseUnboundMetaTyVar :: SkolemInfo -> TcTyVar -> TcM TyVar -- We have a Meta tyvar with a ref-cell inside it -- Skolemise it, so that we are totally out of Meta-tyvar-land -- We create a skolem TcTyVar, not a regular TyVar --   See Note [Zonking to Skolem]-skolemiseUnboundMetaTyVar tv-  = ASSERT2( isMetaTyVar tv, ppr tv )-    do  { when debugIsOn (check_empty tv)-        ; here <- getSrcSpanM    -- Get the location from "here"-                                 -- ie where we are generalising-        ; kind <- zonkTcType (tyVarKind tv)-        ; let tv_name     = tyVarName tv+--+-- Its level should be one greater than the ambient level, which will typically+-- be the same as the level on the meta-tyvar. But not invariably; for example+--    f :: (forall a b. SameKind a b) -> Int+-- The skolems 'a' and 'b' are bound by tcTKTelescope, at level 2; and they each+-- have a level-2 kind unification variable, since it might get unified with another+-- of the level-2 skolems e.g. 'k' in this version+--    f :: (forall k (a :: k) b. SameKind a b) -> Int+-- So when we quantify the kind vars at the top level of the signature, the ambient+-- level is 1, but we will quantify over kappa[2].++skolemiseUnboundMetaTyVar skol_info tv+  = assertPpr (isMetaTyVar tv) (ppr tv) $+    do  { check_empty tv+        ; tc_lvl <- getTcLevel   -- Get the location and level from "here"+        ; here   <- getSrcSpanM  -- i.e. where we are generalising+        ; kind   <- zonkTcType (tyVarKind tv)+        ; let tv_name = tyVarName tv               -- See Note [Skolemising and identity]               final_name | isSystemName tv_name                          = mkInternalName (nameUnique tv_name)                                           (nameOccName tv_name) here                          | otherwise                          = tv_name-              final_tv = mkTcTyVar final_name kind details+              details    = SkolemTv skol_info (pushTcLevel tc_lvl) False+              final_tv   = mkTcTyVar final_name kind details          ; traceTc "Skolemising" (ppr tv <+> text ":=" <+> ppr final_tv)         ; writeMetaTyVar tv (mkTyVarTy final_tv)         ; return final_tv }-   where-    details = SkolemTv (metaTyVarTcLevel tv) False     check_empty tv       -- [Sept 04] Check for non-empty.-      = when debugIsOn $  -- See note [Silly Type Synonym]+      = when debugIsOn $  -- See Note [Silly Type Synonyms]         do { cts <- readMetaTyVar tv            ; case cts of                Flexi       -> return ()-               Indirect ty -> WARN( True, ppr tv $$ ppr ty )+               Indirect ty -> warnPprTrace True "skolemiseUnboundMetaTyVar" (ppr tv $$ ppr ty) $                               return () }  {- Note [Error on unconstrained meta-variables]@@ -1926,10 +1975,6 @@ NB: this is all rather similar to, but sadly not the same as     Note [Naughty quantification candidates] -(One last example: type instance F Int = Proxy Any, where the unconstrained-kind variable is the inferred kind of Any. The four examples here illustrate-all cases in which this Note applies.)- To do this, we must take an extra step before doing the final zonk to create e.g. a TyCon. (There is no problem in the final term-level zonk. See the section on alternative (B) below.) This extra step is needed only for@@ -2005,13 +2050,14 @@                     -> (TidyEnv -> TcM (TidyEnv, SDoc))                             -- ^ like "the class context (D a b, E foogle)"                     -> TcM ()+-- See Note [Error on unconstrained meta-variables] doNotQuantifyTyVars dvs where_found   | isEmptyCandidates dvs   = traceTc "doNotQuantifyTyVars has nothing to error on" empty    | otherwise   = do { traceTc "doNotQuantifyTyVars" (ppr dvs)-       ; undefaulted <- defaultTyVars dvs+       ; undefaulted <- defaultTyVars DefaultNonStandardTyVars dvs           -- could have regular TyVars here, in an associated type RHS, or           -- bound by a type declaration head. So filter looking only for           -- metavars. e.g. b and c in `class (forall a. a b ~ a c) => C b c`@@ -2020,12 +2066,15 @@        ; unless (null leftover_metas) $          do { let (tidy_env1, tidied_tvs) = tidyOpenTyCoVars emptyTidyEnv leftover_metas             ; (tidy_env2, where_doc) <- where_found tidy_env1-            ; let doc = vcat [ text "Uninferrable type variable"-                               <> plural tidied_tvs-                               <+> pprWithCommas pprTyVar tidied_tvs-                               <+> text "in"-                             , where_doc ]-            ; failWithTcM (tidy_env2, pprWithExplicitKindsWhen True doc) }+            ; let msg = TcRnUnknownMessage            $+                        mkPlainError noHints          $+                        pprWithExplicitKindsWhen True $+                    vcat [ text "Uninferrable type variable"+                           <> plural tidied_tvs+                           <+> pprWithCommas pprTyVar tidied_tvs+                           <+> text "in"+                         , where_doc ]+            ; failWithTcM (tidy_env2, msg) }        ; traceTc "doNotQuantifyTyVars success" empty }  {- Note [Defaulting with -XNoPolyKinds]@@ -2174,7 +2223,7 @@  * So we get a dict binding for Num (C d a), which is zonked to give         a = ()-  [Note Sept 04: now that we are zonking quantified type variables+  Note (Sept 04): now that we are zonking quantified type variables   on construction, the 'a' will be frozen as a regular tyvar on   quantification, so the floated dict will still have type (C d a).   Which renders this whole note moot; happily!]@@ -2198,7 +2247,7 @@ -- Also returns either the original tyvar (no promotion) or the new one -- See Note [Promoting unification variables] promoteMetaTyVarTo tclvl tv-  | ASSERT2( isMetaTyVar tv, ppr tv )+  | assertPpr (isMetaTyVar tv) (ppr tv) $     tcTyVarLevel tv `strictlyDeeperThan` tclvl   = do { cloned_tv <- cloneMetaTyVar tv        ; let rhs_tv = setMetaTyVarTcLevel cloned_tv tclvl@@ -2239,7 +2288,7 @@ -- Works on TyVars and TcTyVars zonkTyCoVar tv | isTcTyVar tv = zonkTcTyVar tv                | isTyVar   tv = mkTyVarTy <$> zonkTyCoVarKind tv-               | otherwise    = ASSERT2( isCoVar tv, ppr tv )+               | otherwise    = assertPpr (isCoVar tv) (ppr tv) $                                 mkCoercionTy . mkCoVarCo <$> zonkTyCoVarKind tv    -- Hackily, when typechecking type and class decls    -- we have TyVars in scope added (only) in@@ -2271,10 +2320,6 @@ zonkTyCoVarKind tv = do { kind' <- zonkTcType (tyVarKind tv)                         ; return (setTyVarKind tv kind') } -zonkTyCoVarKindBinder :: (VarBndr TyCoVar fl) -> TcM (VarBndr TyCoVar fl)-zonkTyCoVarKindBinder (Bndr tv fl) = do { kind' <- zonkTcType (tyVarKind tv)-                                        ; return $ Bndr (setTyVarKind tv kind') fl }- {- ************************************************************************ *                                                                      *@@ -2291,7 +2336,7 @@   = do { skols'  <- mapM zonkTyCoVarKind skols  -- Need to zonk their kinds!                                                 -- as #7230 showed        ; given'  <- mapM zonkEvVar given-       ; info'   <- zonkSkolemInfo info+       ; info'   <- zonkSkolemInfoAnon info        ; wanted' <- zonkWCRec wanted        ; return (implic { ic_skols  = skols'                         , ic_given  = given'@@ -2306,22 +2351,38 @@ zonkWC wc = zonkWCRec wc  zonkWCRec :: WantedConstraints -> TcM WantedConstraints-zonkWCRec (WC { wc_simple = simple, wc_impl = implic, wc_holes = holes })+zonkWCRec (WC { wc_simple = simple, wc_impl = implic, wc_errors = errs })   = do { simple' <- zonkSimples simple        ; implic' <- mapBagM zonkImplication implic-       ; holes'  <- mapBagM zonkHole holes-       ; return (WC { wc_simple = simple', wc_impl = implic', wc_holes = holes' }) }+       ; errs'   <- mapBagM zonkDelayedError errs+       ; return (WC { wc_simple = simple', wc_impl = implic', wc_errors = errs' }) }  zonkSimples :: Cts -> TcM Cts zonkSimples cts = do { cts' <- mapBagM zonkCt cts                      ; traceTc "zonkSimples done:" (ppr cts')                      ; return cts' } +zonkDelayedError :: DelayedError -> TcM DelayedError+zonkDelayedError (DE_Hole hole)+  = DE_Hole <$> zonkHole hole+zonkDelayedError (DE_NotConcrete err)+  = DE_NotConcrete <$> zonkNotConcreteError err+ zonkHole :: Hole -> TcM Hole zonkHole hole@(Hole { hole_ty = ty })   = do { ty' <- zonkTcType ty        ; return (hole { hole_ty = ty' }) } +zonkNotConcreteError :: NotConcreteError -> TcM NotConcreteError+zonkNotConcreteError err@(NCE_FRR { nce_frr_origin = frr_orig })+  = do { frr_orig  <- zonkFRROrigin frr_orig+       ; return $ err { nce_frr_origin = frr_orig  } }++zonkFRROrigin :: FixedRuntimeRepOrigin -> TcM FixedRuntimeRepOrigin+zonkFRROrigin (FixedRuntimeRepOrigin ty orig)+  = do { ty' <- zonkTcType ty+       ; return $ FixedRuntimeRepOrigin ty' orig }+ {- Note [zonkCt behaviour] ~~~~~~~~~~~~~~~~~~~~~~~~~~ zonkCt tries to maintain the canonical form of a Ct.  For example,@@ -2368,38 +2429,29 @@        ; return (mkNonCanonical fl') }  zonkCtEvidence :: CtEvidence -> TcM CtEvidence-zonkCtEvidence ctev@(CtGiven { ctev_pred = pred })-  = do { pred' <- zonkTcType pred-       ; return (ctev { ctev_pred = pred'}) }-zonkCtEvidence ctev@(CtWanted { ctev_pred = pred, ctev_dest = dest })-  = do { pred' <- zonkTcType pred-       ; let dest' = case dest of-                       EvVarDest ev -> EvVarDest $ setVarType ev pred'-                         -- necessary in simplifyInfer-                       HoleDest h   -> HoleDest h-       ; return (ctev { ctev_pred = pred', ctev_dest = dest' }) }-zonkCtEvidence ctev@(CtDerived { ctev_pred = pred })-  = do { pred' <- zonkTcType pred-       ; return (ctev { ctev_pred = pred' }) }+zonkCtEvidence ctev+  = do { pred' <- zonkTcType (ctev_pred ctev)+       ; return (setCtEvPredType ctev pred')+       }  zonkSkolemInfo :: SkolemInfo -> TcM SkolemInfo-zonkSkolemInfo (SigSkol cx ty tv_prs)  = do { ty' <- zonkTcType ty+zonkSkolemInfo (SkolemInfo u sk) = SkolemInfo u <$> zonkSkolemInfoAnon sk++zonkSkolemInfoAnon :: SkolemInfoAnon -> TcM SkolemInfoAnon+zonkSkolemInfoAnon (SigSkol cx ty tv_prs)  = do { ty' <- zonkTcType ty                                             ; return (SigSkol cx ty' tv_prs) }-zonkSkolemInfo (InferSkol ntys) = do { ntys' <- mapM do_one ntys+zonkSkolemInfoAnon (InferSkol ntys) = do { ntys' <- mapM do_one ntys                                      ; return (InferSkol ntys') }   where     do_one (n, ty) = do { ty' <- zonkTcType ty; return (n, ty') }-zonkSkolemInfo skol_info = return skol_info+zonkSkolemInfoAnon skol_info = return skol_info  {--%************************************************************************-%*                                                                      *-\subsection{Zonking -- the main work-horses: zonkTcType, zonkTcTyVar}+************************************************************************ *                                                                      *-*              For internal use only!                                  *+     Zonking -- the main work-horses: zonkTcType, zonkTcTyVar *                                                                      * ************************************************************************- -}  -- For unbound, mutable tyvars, zonkType uses the function given to it@@ -2464,17 +2516,20 @@  -- Variant that assumes that any result of zonking is still a TyVar. -- Should be used only on skolems and TyVarTvs-zonkTcTyVarToTyVar :: HasDebugCallStack => TcTyVar -> TcM TcTyVar-zonkTcTyVarToTyVar tv+zonkTcTyVarsToTcTyVars :: HasDebugCallStack => [TcTyVar] -> TcM [TcTyVar]+zonkTcTyVarsToTcTyVars = mapM zonkTcTyVarToTcTyVar++zonkTcTyVarToTcTyVar :: HasDebugCallStack => TcTyVar -> TcM TcTyVar+zonkTcTyVarToTcTyVar tv   = do { ty <- zonkTcTyVar tv        ; let tv' = case tcGetTyVar_maybe ty of                      Just tv' -> tv'-                     Nothing  -> pprPanic "zonkTcTyVarToTyVar"+                     Nothing  -> pprPanic "zonkTcTyVarToTcTyVar"                                           (ppr tv $$ ppr ty)        ; return tv' } -zonkInvisTVBinder :: VarBndr TcTyVar spec -> TcM (VarBndr TyVar spec)-zonkInvisTVBinder (Bndr tv spec) = do { tv' <- zonkTcTyVarToTyVar tv+zonkInvisTVBinder :: VarBndr TcTyVar spec -> TcM (VarBndr TcTyVar spec)+zonkInvisTVBinder (Bndr tv spec) = do { tv' <- zonkTcTyVarToTcTyVar tv                                       ; return (Bndr tv' spec) }  -- zonkId is used *during* typechecking just to zonk the Id's type@@ -2524,12 +2579,12 @@  zonkTidyOrigin :: TidyEnv -> CtOrigin -> TcM (TidyEnv, CtOrigin) zonkTidyOrigin env (GivenOrigin skol_info)-  = do { skol_info1 <- zonkSkolemInfo skol_info-       ; let skol_info2 = tidySkolemInfo env skol_info1+  = do { skol_info1 <- zonkSkolemInfoAnon skol_info+       ; let skol_info2 = tidySkolemInfoAnon env skol_info1        ; return (env, GivenOrigin skol_info2) } zonkTidyOrigin env (OtherSCOrigin sc_depth skol_info)-  = do { skol_info1 <- zonkSkolemInfo skol_info-       ; let skol_info2 = tidySkolemInfo env skol_info1+  = do { skol_info1 <- zonkSkolemInfoAnon skol_info+       ; let skol_info2 = tidySkolemInfoAnon env skol_info1        ; return (env, OtherSCOrigin sc_depth skol_info2) } zonkTidyOrigin env orig@(TypeEqOrigin { uo_actual   = act                                       , uo_expected = exp })@@ -2544,122 +2599,113 @@        ; return (env3, KindEqOrigin ty1' ty2' orig' t_or_k) } zonkTidyOrigin env (FunDepOrigin1 p1 o1 l1 p2 o2 l2)   = do { (env1, p1') <- zonkTidyTcType env  p1-       ; (env2, p2') <- zonkTidyTcType env1 p2-       ; return (env2, FunDepOrigin1 p1' o1 l1 p2' o2 l2) }+       ; (env2, o1') <- zonkTidyOrigin env1 o1+       ; (env3, p2') <- zonkTidyTcType env2 p2+       ; (env4, o2') <- zonkTidyOrigin env3 o2+       ; return (env4, FunDepOrigin1 p1' o1' l1 p2' o2' l2) } zonkTidyOrigin env (FunDepOrigin2 p1 o1 p2 l2)   = do { (env1, p1') <- zonkTidyTcType env  p1        ; (env2, p2') <- zonkTidyTcType env1 p2        ; (env3, o1') <- zonkTidyOrigin env2 o1        ; return (env3, FunDepOrigin2 p1' o1' p2' l2) }+zonkTidyOrigin env (InjTFOrigin1 pred1 orig1 loc1 pred2 orig2 loc2)+  = do { (env1, pred1') <- zonkTidyTcType env  pred1+       ; (env2, orig1') <- zonkTidyOrigin env1 orig1+       ; (env3, pred2') <- zonkTidyTcType env2 pred2+       ; (env4, orig2') <- zonkTidyOrigin env3 orig2+       ; return (env4, InjTFOrigin1 pred1' orig1' loc1 pred2' orig2' loc2) }+zonkTidyOrigin env (CycleBreakerOrigin orig)+  = do { (env1, orig') <- zonkTidyOrigin env orig+       ; return (env1, CycleBreakerOrigin orig') }+zonkTidyOrigin env (InstProvidedOrigin mod cls_inst)+  = do { (env1, is_tys') <- mapAccumLM zonkTidyTcType env (is_tys cls_inst)+       ; return (env1, InstProvidedOrigin mod (cls_inst {is_tys = is_tys'})) }+zonkTidyOrigin env (WantedSuperclassOrigin pty orig)+  = do { (env1, pty')  <- zonkTidyTcType env pty+       ; (env2, orig') <- zonkTidyOrigin env1 orig+       ; return (env2, WantedSuperclassOrigin pty' orig') } zonkTidyOrigin env orig = return (env, orig) +zonkTidyOrigins :: TidyEnv -> [CtOrigin] -> TcM (TidyEnv, [CtOrigin])+zonkTidyOrigins = mapAccumLM zonkTidyOrigin++zonkTidyFRRInfos :: TidyEnv+                 -> [FixedRuntimeRepErrorInfo]+                 -> TcM (TidyEnv, [FixedRuntimeRepErrorInfo])+zonkTidyFRRInfos = go []+  where+    go zs env [] = return (env, reverse zs)+    go zs env (FRR_Info { frr_info_origin = FixedRuntimeRepOrigin ty orig+                        , frr_info_not_concrete = mb_not_conc } : tys)+      = do { (env, ty) <- zonkTidyTcType env ty+           ; (env, mb_not_conc) <- go_mb_not_conc env mb_not_conc+           ; let info = FRR_Info { frr_info_origin = FixedRuntimeRepOrigin ty orig+                                 , frr_info_not_concrete = mb_not_conc }+           ; go (info:zs) env tys }++    go_mb_not_conc env Nothing = return (env, Nothing)+    go_mb_not_conc env (Just (tv, ty))+      = do { (env, tv) <- return $ tidyOpenTyCoVar env tv+           ; (env, ty) <- zonkTidyTcType env ty+           ; return (env, Just (tv, ty)) }+ ---------------- tidyCt :: TidyEnv -> Ct -> Ct -- Used only in error reporting-tidyCt env ct-  = ct { cc_ev = tidy_ev (ctEvidence ct) }-  where-    tidy_ev :: CtEvidence -> CtEvidence+tidyCt env ct = ct { cc_ev = tidyCtEvidence env (ctEvidence ct) }++tidyCtEvidence :: TidyEnv -> CtEvidence -> CtEvidence      -- NB: we do not tidy the ctev_evar field because we don't      --     show it in error messages-    tidy_ev ctev = ctev { ctev_pred = tidyType env (ctev_pred ctev) }+tidyCtEvidence env ctev = ctev { ctev_pred = tidyType env ty }+  where+    ty  = ctev_pred ctev  tidyHole :: TidyEnv -> Hole -> Hole tidyHole env h@(Hole { hole_ty = ty }) = h { hole_ty = tidyType env ty } +tidyDelayedError :: TidyEnv -> DelayedError -> DelayedError+tidyDelayedError env (DE_Hole hole)+  = DE_Hole $ tidyHole env hole+tidyDelayedError env (DE_NotConcrete err)+  = DE_NotConcrete $ tidyConcreteError env err++tidyConcreteError :: TidyEnv -> NotConcreteError -> NotConcreteError+tidyConcreteError env err@(NCE_FRR { nce_frr_origin = frr_orig })+  = err { nce_frr_origin = tidyFRROrigin env frr_orig }++tidyFRROrigin :: TidyEnv -> FixedRuntimeRepOrigin -> FixedRuntimeRepOrigin+tidyFRROrigin env (FixedRuntimeRepOrigin ty orig)+  = FixedRuntimeRepOrigin (tidyType env ty) orig+ ---------------- tidyEvVar :: TidyEnv -> EvVar -> EvVar tidyEvVar env var = updateIdTypeAndMult (tidyType env) var ------------------tidySkolemInfo :: TidyEnv -> SkolemInfo -> SkolemInfo-tidySkolemInfo env (DerivSkol ty)         = DerivSkol (tidyType env ty)-tidySkolemInfo env (SigSkol cx ty tv_prs) = tidySigSkol env cx ty tv_prs-tidySkolemInfo env (InferSkol ids)        = InferSkol (mapSnd (tidyType env) ids)-tidySkolemInfo env (UnifyForAllSkol ty)   = UnifyForAllSkol (tidyType env ty)-tidySkolemInfo _   info                   = info -tidySigSkol :: TidyEnv -> UserTypeCtxt-            -> TcType -> [(Name,TcTyVar)] -> SkolemInfo--- We need to take special care when tidying SigSkol--- See Note [SigSkol SkolemInfo] in "GHC.Tc.Types.Origin"-tidySigSkol env cx ty tv_prs-  = SigSkol cx (tidy_ty env ty) tv_prs'-  where-    tv_prs' = mapSnd (tidyTyCoVarOcc env) tv_prs-    inst_env = mkNameEnv tv_prs'--    tidy_ty env (ForAllTy (Bndr tv vis) ty)-      = ForAllTy (Bndr tv' vis) (tidy_ty env' ty)-      where-        (env', tv') = tidy_tv_bndr env tv--    tidy_ty env ty@(FunTy InvisArg w arg res) -- Look under  c => t-      = ty { ft_mult = tidy_ty env w,-             ft_arg = tidyType env arg,-             ft_res = tidy_ty env res }--    tidy_ty env ty = tidyType env ty--    tidy_tv_bndr :: TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar)-    tidy_tv_bndr env@(occ_env, subst) tv-      | Just tv' <- lookupNameEnv inst_env (tyVarName tv)-      = ((occ_env, extendVarEnv subst tv tv'), tv')--      | otherwise-      = tidyVarBndr env tv- ------------------------------------------------------------------------- {- %************************************************************************ %*                                                                      *-             Levity polymorphism checks+             Representation polymorphism checks *                                                                       *-*************************************************************************--See Note [Levity polymorphism checking] in GHC.HsToCore.Monad---}---- | According to the rules around representation polymorphism--- (see https://gitlab.haskell.org/ghc/ghc/wikis/no-sub-kinds), no binder--- can have a representation-polymorphic type. This check ensures--- that we respect this rule. It is a bit regrettable that this error--- occurs in zonking, after which we should have reported all errors.--- But it's hard to see where else to do it, because this can be discovered--- only after all solving is done. And, perhaps most importantly, this--- isn't really a compositional property of a type system, so it's--- not a terrible surprise that the check has to go in an awkward spot.-ensureNotLevPoly :: Type  -- its zonked type-                 -> SDoc  -- where this happened-                 -> TcM ()-ensureNotLevPoly ty doc-  = whenNoErrs $   -- sometimes we end up zonking bogus definitions of type-                   -- forall a. a. See, for example, test ghci/scripts/T9140-    checkForLevPoly doc ty--  -- See Note [Levity polymorphism checking] in GHC.HsToCore.Monad-checkForLevPoly :: SDoc -> Type -> TcM ()-checkForLevPoly = checkForLevPolyX addErr--checkForLevPolyX :: Monad m-                 => (SDoc -> m ())  -- how to report an error-                 -> SDoc -> Type -> m ()-checkForLevPolyX add_err extra ty-  | isTypeLevPoly ty-  = add_err (formatLevPolyErr ty $$ extra)-  | otherwise-  = return ()+***********************************************************************-} -formatLevPolyErr :: Type  -- levity-polymorphic type-                 -> SDoc-formatLevPolyErr ty-  = hang (text "A levity-polymorphic type is not allowed here:")-       2 (vcat [ text "Type:" <+> pprWithTYPE tidy_ty-               , text "Kind:" <+> pprWithTYPE tidy_ki ])-  where-    (tidy_env, tidy_ty) = tidyOpenType emptyTidyEnv ty-    tidy_ki             = tidyType tidy_env (tcTypeKind ty)+-- | Check that the specified type has a fixed runtime representation.+--+-- If it isn't, throw a representation-polymorphism error appropriate+-- for the context (as specified by the 'FixedRuntimeRepProvenance').+--+-- Unlike the other representation polymorphism checks, which can emit+-- new Wanted constraints to be solved by the constraint solver, this function+-- does not emit any constraints: it has enough information to immediately+-- make a decision.+--+-- See (1) in Note [Representation polymorphism checking] in GHC.Tc.Utils.Concrete+checkTypeHasFixedRuntimeRep :: FixedRuntimeRepProvenance -> Type -> TcM ()+checkTypeHasFixedRuntimeRep prov ty =+  unless (typeHasFixedRuntimeRep ty)+    (addDetailedDiagnostic $ TcRnTypeDoesNotHaveFixedRuntimeRep ty prov)  {- %************************************************************************@@ -2678,7 +2724,7 @@ naughtyQuantification orig_ty tv escapees   = do { orig_ty1 <- zonkTcType orig_ty  -- in case it's not zonked -       ; escapees' <- mapM zonkTcTyVarToTyVar $+       ; escapees' <- zonkTcTyVarsToTcTyVars $                       nonDetEltsUniqSet escapees                      -- we'll just be printing, so no harmful non-determinism @@ -2690,7 +2736,8 @@               orig_ty'   = tidyType env orig_ty1              ppr_tidied = pprTyVars . map (tidyTyCoVarOcc env)-             doc = pprWithExplicitKindsWhen True $+             msg = TcRnUnknownMessage $ mkPlainError noHints $+                   pprWithExplicitKindsWhen True $                    vcat [ sep [ text "Cannot generalise type; skolem" <> plural escapees'                               , quotes $ ppr_tidied escapees'                               , text "would escape" <+> itsOrTheir escapees' <+> text "scope"@@ -2704,4 +2751,50 @@                         , text " due to its ill-scoped nature.)"                         ] -       ; failWithTcM (env, doc) }+       ; failWithTcM (env, msg) }++{-+************************************************************************+*                                                                      *+             Checking for coercion holes+*                                                                      *+************************************************************************+-}++-- | Check whether any coercion hole in a RewriterSet is still unsolved.+-- Does this by recursively looking through filled coercion holes until+-- one is found that is not yet filled in, at which point this aborts.+anyUnfilledCoercionHoles :: RewriterSet -> TcM Bool+anyUnfilledCoercionHoles (RewriterSet set)+  = nonDetStrictFoldUniqSet go (return False) set+     -- this does not introduce non-determinism, because the only+     -- monadic action is to read, and the combining function is+     -- commutative+  where+    go :: CoercionHole -> TcM Bool -> TcM Bool+    go hole m_acc = m_acc <||> check_hole hole++    check_hole :: CoercionHole -> TcM Bool+    check_hole hole = do { m_co <- unpackCoercionHole_maybe hole+                         ; case m_co of+                             Nothing -> return True  -- unfilled hole+                             Just co -> unUCHM (check_co co) }++    check_ty :: Type -> UnfilledCoercionHoleMonoid+    check_co :: Coercion -> UnfilledCoercionHoleMonoid+    (check_ty, _, check_co, _) = foldTyCo folder ()++    folder :: TyCoFolder () UnfilledCoercionHoleMonoid+    folder = TyCoFolder { tcf_view  = noView+                        , tcf_tyvar = \ _ tv -> check_ty (tyVarKind tv)+                        , tcf_covar = \ _ cv -> check_ty (varType cv)+                        , tcf_hole  = \ _ -> UCHM . check_hole+                        , tcf_tycobinder = \ _ _ _ -> () }++newtype UnfilledCoercionHoleMonoid = UCHM { unUCHM :: TcM Bool }++instance Semigroup UnfilledCoercionHoleMonoid where+  UCHM l <> UCHM r = UCHM (l <||> r)++instance Monoid UnfilledCoercionHoleMonoid where+  mempty = UCHM (return False)
GHC/Tc/Utils/TcType.hs view
@@ -1,6 +1,7 @@-{-# LANGUAGE CPP                 #-}+ {-# LANGUAGE FlexibleContexts    #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections       #-}  {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -22,12 +23,16 @@ module GHC.Tc.Utils.TcType (   --------------------------------   -- Types-  TcType, TcSigmaType, TcRhoType, TcTauType, TcPredType, TcThetaType,+  TcType, TcSigmaType, TcTypeFRR, TcSigmaTypeFRR,+  TcRhoType, TcTauType, TcPredType, TcThetaType,   TcTyVar, TcTyVarSet, TcDTyVarSet, TcTyCoVarSet, TcDTyCoVarSet,   TcKind, TcCoVar, TcTyCoVar, TcTyVarBinder, TcInvisTVBinder, TcReqTVBinder,-  TcTyCon, KnotTied,+  TcTyCon, MonoTcTyCon, PolyTcTyCon, TcTyConBinder, KnotTied, -  ExpType(..), InferResult(..), ExpSigmaType, ExpRhoType, mkCheckExpType,+  ExpType(..), InferResult(..),+  ExpTypeFRR, ExpSigmaType, ExpSigmaTypeFRR,+  ExpRhoType,+  mkCheckExpType,    SyntaxOpType(..), synKnownType, mkSynFunTys, @@ -35,13 +40,14 @@   TcLevel(..), topTcLevel, pushTcLevel, isTopTcLevel,   strictlyDeeperThan, deeperThanOrSame, sameDepthAs,   tcTypeLevel, tcTyVarLevel, maxTcLevel,-  promoteSkolem, promoteSkolemX, promoteSkolemsX,   --------------------------------   -- MetaDetails-  TcTyVarDetails(..), pprTcTyVarDetails, vanillaSkolemTv, superSkolemTv,-  MetaDetails(Flexi, Indirect), MetaInfo(..),+  TcTyVarDetails(..), pprTcTyVarDetails, vanillaSkolemTvUnk,+  MetaDetails(Flexi, Indirect), MetaInfo(..), skolemSkolInfo,   isImmutableTyVar, isSkolemTyVar, isMetaTyVar,  isMetaTyVarTy, isTyVarTy,   tcIsTcTyVar, isTyVarTyVar, isOverlappableTyVar,  isTyConableTyVar,+  ConcreteTvOrigin(..), isConcreteTyVar_maybe, isConcreteTyVar,+  isConcreteTyVarTy, isConcreteTyVarTy_maybe,   isAmbiguousTyVar, isCycleBreakerTyVar, metaTyVarRef, metaTyVarInfo,   isFlexi, isIndirect, isRuntimeUnkSkol,   metaTyVarTcLevel, setMetaTyVarTcLevel, metaTyVarTcLevel_maybe,@@ -78,9 +84,9 @@   pickyEqType, tcEqType, tcEqKind, tcEqTypeNoKindCheck, tcEqTypeVis,   tcEqTyConApps,   isSigmaTy, isRhoTy, isRhoExpTy, isOverloadedTy,-  isFloatingTy, isDoubleTy, isFloatTy, isIntTy, isWordTy, isStringTy,+  isFloatingPrimTy, isDoubleTy, isFloatTy, isIntTy, isWordTy, isStringTy,   isIntegerTy, isNaturalTy,-  isBoolTy, isUnitTy, isCharTy, isCallStackTy, isCallStackPred,+  isBoolTy, isUnitTy, isCharTy,   isTauTy, isTauTyCon, tcIsTyVarTy, tcIsForAllTy,   isPredTy, isTyVarClassPred,   checkValidClsArgs, hasTyVarHead,@@ -93,11 +99,12 @@   orphNamesOfType, orphNamesOfCo,   orphNamesOfTypes, orphNamesOfCoCon,   getDFunTyKey, evVarPred,+  ambigTkvsOfTy,    ---------------------------------   -- Predicate types   mkMinimalBySCs, transSuperClasses,-  pickQuantifiablePreds, pickCapturedPreds,+  pickCapturedPreds,   immSuperClasses, boxEqPred,   isImprovementPred, @@ -106,10 +113,12 @@    -- * Finding "exact" (non-dead) type variables   exactTyCoVarsOfType, exactTyCoVarsOfTypes,-  anyRewritableTyVar, anyRewritableTyFamApp, anyRewritableCanEqLHS,+  anyRewritableTyVar, anyRewritableTyFamApp,    ---------------------------------   -- Foreign import and export+  IllegalForeignTypeReason(..),+  TypeCannotBeMarshaledReason(..),   isFFIArgumentTy,     -- :: DynFlags -> Safety -> Type -> Bool   isFFIImportResultTy, -- :: DynFlags -> Type -> Bool   isFFIExportResultTy, -- :: Type -> Bool@@ -118,7 +127,6 @@   isFFIPrimArgumentTy, -- :: DynFlags -> Type -> Bool   isFFIPrimResultTy,   -- :: DynFlags -> Type -> Bool   isFFILabelTy,        -- :: Type -> Bool-  isFFITy,             -- :: Type -> Bool   isFunPtrTy,          -- :: Type -> Bool   tcSplitIOType_maybe, -- :: Type -> Maybe Type @@ -146,7 +154,7 @@   isClassPred, isEqPrimPred, isIPLikePred, isEqPred, isEqPredClass,   mkClassPred,   tcSplitDFunTy, tcSplitDFunHead, tcSplitMethodTy,-  isRuntimeRepVar, isKindLevPoly,+  isRuntimeRepVar, isFixedRuntimeRepKind,   isVisibleBinder, isInvisibleBinder,    -- Type substitutions@@ -193,8 +201,6 @@    ) where -#include "HsVersions.h"- -- friends: import GHC.Prelude @@ -212,6 +218,10 @@ import GHC.Types.RepType import GHC.Core.TyCon +import {-# SOURCE #-} GHC.Tc.Types.Origin+  ( SkolemInfo, unkSkol+  , FixedRuntimeRepOrigin, FixedRuntimeRepContext )+ -- others: import GHC.Driver.Session import GHC.Core.FVs@@ -229,15 +239,15 @@ import GHC.Data.List.SetOps ( getNth, findDupsEq ) import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Data.FastString-import GHC.Utils.Error( Validity(..), isValid )+import GHC.Utils.Panic.Plain+import GHC.Utils.Error( Validity'(..) ) import qualified GHC.LanguageExtensions as LangExt -import Data.List  ( mapAccumL )--- import Data.Functor.Identity( Identity(..) ) import Data.IORef import Data.List.NonEmpty( NonEmpty(..) )+import Data.List ( partition ) + {- ************************************************************************ *                                                                      *@@ -341,15 +351,41 @@ type TcType = Type      -- A TcType can have mutable type variables type TcTyCoVar = Var    -- Either a TcTyVar or a CoVar +-- | A type which has a syntactically fixed RuntimeRep as per+-- Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete.+type TcTypeFRR = TcType+  -- TODO: consider making this a newtype.+ type TcTyVarBinder     = TyVarBinder type TcInvisTVBinder   = InvisTVBinder type TcReqTVBinder     = ReqTVBinder-type TcTyCon           = TyCon   -- these can be the TcTyCon constructor +-- See Note [TcTyCon, MonoTcTyCon, and PolyTcTyCon]+type TcTyCon       = TyCon+type MonoTcTyCon   = TcTyCon+type PolyTcTyCon   = TcTyCon+type TcTyConBinder = TyConBinder -- With skolem TcTyVars+ -- These types do not have boxy type variables in them type TcPredType     = PredType type TcThetaType    = ThetaType type TcSigmaType    = TcType++-- | A 'TcSigmaTypeFRR' is a 'TcSigmaType' which has a syntactically+--  fixed 'RuntimeRep' in the sense of Note [Fixed RuntimeRep]+-- in GHC.Tc.Utils.Concrete.+--+-- In particular, this means that:+--+-- - 'GHC.Types.RepType.typePrimRep' does not panic,+-- - 'GHC.Core.typeLevity_maybe' does not return 'Nothing'.+--+-- This property is important in functions such as 'matchExpectedFunTys', where+-- we want to provide argument types which have a known runtime representation.+-- See Note [Return arguments with a fixed RuntimeRep.+type TcSigmaTypeFRR = TcSigmaType+    -- TODO: consider making this a newtype.+ type TcRhoType      = TcType  -- Note [TcRhoType] type TcTauType      = TcType type TcKind         = Kind@@ -358,6 +394,51 @@ type TcDTyVarSet    = DTyVarSet type TcDTyCoVarSet  = DTyCoVarSet +{- Note [TcTyCon, MonoTcTyCon, and PolyTcTyCon]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+See Note [How TcTyCons work] in GHC.Tc.TyCl++Invariants:++* TcTyCon: a TyCon built with the TcTyCon constructor++* TcTyConBinder: a TyConBinder with a TcTyVar inside (not a TyVar)++* TcTyCons contain TcTyVars++* MonoTcTyCon:+  - Flag tcTyConIsPoly = False++  - tyConScopedTyVars is important; maps a Name to a TyVarTv unification variable+    The order is important: Specified then Required variables.   E.g. in+        data T a (b :: k) = ...+    the order will be [k, a, b].++    NB: There are no Inferred binders in tyConScopedTyVars; 'a' may+    also be poly-kinded, but that kind variable will be added by+    generaliseTcTyCon, in the passage to a PolyTcTyCon.++  - tyConBinders are irrelevant; we just use tcTyConScopedTyVars+    Well not /quite/ irrelevant: its length gives the number of Required binders,+    and so allows up to distinguish between the Specified and Required elements of+    tyConScopedTyVars.++* PolyTcTyCon:+  - Flag tcTyConIsPoly = True; this is used only to short-cut zonking++  - tyConBinders are still TcTyConBinders, but they are /skolem/ TcTyVars,+    with fixed kinds: no unification variables here++    tyConBinders includes the Inferred binders if any++    tyConBinders uses the Names from the original, renamed program.++  - tcTyConScopedTyVars is irrelevant: just use (binderVars tyConBinders)+    All the types have been swizzled back to use the original Names+    See Note [tyConBinders and lexical scoping] in GHC.Core.TyCon++-}+ {- ********************************************************************* *                                                                      *           ExpType: an "expected type" in the type checker@@ -370,24 +451,51 @@              | Infer !InferResult  data InferResult-  = IR { ir_uniq :: Unique  -- For debugging only+  = IR { ir_uniq :: Unique+          -- ^ This 'Unique' is for debugging only -       , ir_lvl  :: TcLevel -- See Note [TcLevel of ExpType] in GHC.Tc.Utils.TcMType+       , ir_lvl  :: TcLevel+         -- ^ See Note [TcLevel of ExpType] in GHC.Tc.Utils.TcMType +       , ir_frr  :: Maybe FixedRuntimeRepContext+         -- ^ See Note [FixedRuntimeRep context in ExpType] in GHC.Tc.Utils.TcMType+        , ir_ref  :: IORef (Maybe TcType) }-         -- The type that fills in this hole should be a Type,-         -- that is, its kind should be (TYPE rr) for some rr+         -- ^ The type that fills in this hole should be a @Type@,+         -- that is, its kind should be @TYPE rr@ for some @rr :: RuntimeRep@.+         --+         -- Additionally, if the 'ir_frr' field is @Just frr_orig@ then+         -- @rr@ must be concrete, in the sense of Note [Concrete types]+         -- in GHC.Tc.Utils.Concrete. -type ExpSigmaType = ExpType-type ExpRhoType   = ExpType+type ExpSigmaType    = ExpType +-- | An 'ExpType' which has a fixed RuntimeRep.+--+-- For a 'Check' 'ExpType', the stored 'TcType' must have+-- a fixed RuntimeRep. For an 'Infer' 'ExpType', the 'ir_frr'+-- field must be of the form @Just frr_orig@.+type ExpTypeFRR      = ExpType++-- | Like 'TcSigmaTypeFRR', but for an expected type.+--+-- See 'ExpTypeFRR'.+type ExpSigmaTypeFRR = ExpTypeFRR+  -- TODO: consider making this a newtype.++type ExpRhoType      = ExpType+ instance Outputable ExpType where   ppr (Check ty) = text "Check" <> braces (ppr ty)   ppr (Infer ir) = ppr ir  instance Outputable InferResult where-  ppr (IR { ir_uniq = u, ir_lvl = lvl })-    = text "Infer" <> braces (ppr u <> comma <> ppr lvl)+  ppr (IR { ir_uniq = u, ir_lvl = lvl, ir_frr = mb_frr })+    = text "Infer" <> mb_frr_text <> braces (ppr u <> comma <> ppr lvl)+    where+      mb_frr_text = case mb_frr of+        Just _  -> text "FRR"+        Nothing -> empty  -- | Make an 'ExpType' suitable for checking. mkCheckExpType :: TcType -> ExpType@@ -483,6 +591,7 @@ -- See Note [TyVars and TcTyVars] data TcTyVarDetails   = SkolemTv      -- A skolem+       SkolemInfo        TcLevel    -- Level of the implication that binds it                   -- See GHC.Tc.Utils.Unify Note [Deeper level on the left] for                   --     how this level number is used@@ -497,12 +606,8 @@            , mtv_ref   :: IORef MetaDetails            , mtv_tclvl :: TcLevel }  -- See Note [TcLevel invariants] -vanillaSkolemTv, superSkolemTv :: TcTyVarDetails--- See Note [Binding when looking up instances] in GHC.Core.InstEnv-vanillaSkolemTv = SkolemTv topTcLevel False  -- Might be instantiated-superSkolemTv   = SkolemTv topTcLevel True   -- Treat this as a completely distinct type-                  -- The choice of level number here is a bit dodgy, but-                  -- topTcLevel works in the places that vanillaSkolemTv is used+vanillaSkolemTvUnk :: HasCallStack => TcTyVarDetails+vanillaSkolemTvUnk = SkolemTv unkSkol topTcLevel False  instance Outputable TcTyVarDetails where   ppr = pprTcTyVarDetails@@ -510,8 +615,8 @@ pprTcTyVarDetails :: TcTyVarDetails -> SDoc -- For debugging pprTcTyVarDetails (RuntimeUnk {})      = text "rt"-pprTcTyVarDetails (SkolemTv lvl True)  = text "ssk" <> colon <> ppr lvl-pprTcTyVarDetails (SkolemTv lvl False) = text "sk"  <> colon <> ppr lvl+pprTcTyVarDetails (SkolemTv _sk lvl True)  = text "ssk" <> colon <> ppr lvl+pprTcTyVarDetails (SkolemTv _sk lvl False) = text "sk"  <> colon <> ppr lvl pprTcTyVarDetails (MetaTv { mtv_info = info, mtv_tclvl = tclvl })   = ppr info <> colon <> ppr tclvl @@ -520,32 +625,51 @@   = Flexi  -- Flexi type variables unify to become Indirects   | Indirect TcType +-- | What restrictions are on this metavariable around unification?+-- These are checked in GHC.Tc.Utils.Unify.startSolvingByUnification. data MetaInfo-   = TauTv         -- This MetaTv is an ordinary unification variable+   = TauTv         -- ^ This MetaTv is an ordinary unification variable                    -- A TauTv is always filled in with a tau-type, which                    -- never contains any ForAlls. -   | TyVarTv       -- A variant of TauTv, except that it should not be+   | TyVarTv       -- ^ A variant of TauTv, except that it should not be                    --   unified with a type, only with a type variable                    -- See Note [TyVarTv] in GHC.Tc.Utils.TcMType -   | RuntimeUnkTv  -- A unification variable used in the GHCi debugger.+   | RuntimeUnkTv  -- ^ A unification variable used in the GHCi debugger.                    -- It /is/ allowed to unify with a polytype, unlike TauTv     | CycleBreakerTv  -- Used to fix occurs-check problems in Givens                      -- See Note [Type equality cycles] in                      -- GHC.Tc.Solver.Canonical +   | ConcreteTv ConcreteTvOrigin+        -- ^ A unification variable that can only be unified+        -- with a concrete type, in the sense of+        -- Note [Concrete types] in GHC.Tc.Utils.Concrete.+        -- See Note [ConcreteTv] in GHC.Tc.Utils.Concrete.+        -- See also Note [The Concrete mechanism] in GHC.Tc.Utils.Concrete+        -- for an overview of how this works in context.+ instance Outputable MetaDetails where   ppr Flexi         = text "Flexi"   ppr (Indirect ty) = text "Indirect" <+> ppr ty  instance Outputable MetaInfo where-  ppr TauTv          = text "tau"-  ppr TyVarTv        = text "tyv"-  ppr RuntimeUnkTv   = text "rutv"-  ppr CycleBreakerTv = text "cbv"+  ppr TauTv           = text "tau"+  ppr TyVarTv         = text "tyv"+  ppr RuntimeUnkTv    = text "rutv"+  ppr CycleBreakerTv  = text "cbv"+  ppr (ConcreteTv {}) = text "conc" +-- | What caused us to create a 'ConcreteTv' metavariable?+-- See Note [ConcreteTv] in GHC.Tc.Utils.Concrete.+data ConcreteTvOrigin+   -- | A 'ConcreteTv' used to enforce the representation-polymorphism invariants.+   --+   -- See 'FixedRuntimeRepOrigin' for more information.+  = ConcreteFRR FixedRuntimeRepOrigin+ {- ********************************************************************* *                                                                      *                 Untouchable type variables@@ -681,7 +805,7 @@ tcTyVarLevel tv   = case tcTyVarDetails tv of           MetaTv { mtv_tclvl = tv_lvl } -> tv_lvl-          SkolemTv tv_lvl _             -> tv_lvl+          SkolemTv _ tv_lvl _           -> tv_lvl           RuntimeUnk                    -> topTcLevel  @@ -699,32 +823,6 @@ instance Outputable TcLevel where   ppr (TcLevel us) = ppr us -promoteSkolem :: TcLevel -> TcTyVar -> TcTyVar-promoteSkolem tclvl skol-  | tclvl < tcTyVarLevel skol-  = ASSERT( isTcTyVar skol && isSkolemTyVar skol )-    setTcTyVarDetails skol (SkolemTv tclvl (isOverlappableTyVar skol))--  | otherwise-  = skol---- | Change the TcLevel in a skolem, extending a substitution-promoteSkolemX :: TcLevel -> TCvSubst -> TcTyVar -> (TCvSubst, TcTyVar)-promoteSkolemX tclvl subst skol-  = ASSERT( isTcTyVar skol && isSkolemTyVar skol )-    (new_subst, new_skol)-  where-    new_skol-      | tclvl < tcTyVarLevel skol-      = setTcTyVarDetails (updateTyVarKind (substTy subst) skol)-                          (SkolemTv tclvl (isOverlappableTyVar skol))-      | otherwise-      = updateTyVarKind (substTy subst) skol-    new_subst = extendTvSubstWithClone subst skol new_skol--promoteSkolemsX :: TcLevel -> TCvSubst -> [TcTyVar] -> (TCvSubst, [TcTyVar])-promoteSkolemsX tclvl = mapAccumL (promoteSkolemX tclvl)- {- ********************************************************************* *                                                                      *     Finding type family instances@@ -830,24 +928,23 @@ -- ^ Check that a type does not contain any type family applications. isTyFamFree = null . tcTyFamInsts -any_rewritable :: Bool    -- Ignore casts and coercions-               -> EqRel   -- Ambient role+any_rewritable :: EqRel   -- Ambient role                -> (EqRel -> TcTyVar -> Bool)           -- check tyvar                -> (EqRel -> TyCon -> [TcType] -> Bool) -- check type family                -> (TyCon -> Bool)                      -- expand type synonym?                -> TcType -> Bool -- Checks every tyvar and tyconapp (not including FunTys) within a type, -- ORing the results of the predicates above together--- Do not look inside casts and coercions if 'ignore_cos' is True+-- Do not look inside casts and coercions -- See Note [anyRewritableTyVar must be role-aware] -- -- This looks like it should use foldTyCo, but that function is -- role-agnostic, and this one must be role-aware. We could make -- foldTyCon role-aware, but that may slow down more common usages. ----- See Note [Rewritable] in GHC.Tc.Solver.Monad for a specification for this function.+-- See Note [Rewritable] in GHC.Tc.Solver.InertSet for a specification for this function. {-# INLINE any_rewritable #-} -- this allows specialization of predicates-any_rewritable ignore_cos role tv_pred tc_pred should_expand+any_rewritable role tv_pred tc_pred should_expand   = go role emptyVarSet   where     go_tv rl bvs tv | tv `elemVarSet` bvs = False@@ -873,8 +970,8 @@       where arg_rep = getRuntimeRep arg -- forgetting these causes #17024             res_rep = getRuntimeRep res     go rl bvs (ForAllTy tv ty)   = go rl (bvs `extendVarSet` binderVar tv) ty-    go rl bvs (CastTy ty co)     = go rl bvs ty || go_co rl bvs co-    go rl bvs (CoercionTy co)    = go_co rl bvs co  -- ToDo: check+    go rl bvs (CastTy ty _)      = go rl bvs ty+    go _  _   (CoercionTy _)     = False      go_tc NomEq  bvs _  tys = any (go NomEq bvs) tys     go_tc ReprEq bvs tc tys = any (go_arg bvs)@@ -884,19 +981,12 @@     go_arg bvs (Representational, ty) = go ReprEq bvs ty     go_arg _   (Phantom,          _)  = False  -- We never rewrite with phantoms -    go_co rl bvs co-      | ignore_cos = False-      | otherwise  = anyVarSet (go_tv rl bvs) (tyCoVarsOfCo co)-      -- We don't have an equivalent of anyRewritableTyVar for coercions-      -- (at least not yet) so take the free vars and test them--anyRewritableTyVar :: Bool     -- Ignore casts and coercions-                   -> EqRel    -- Ambient role+anyRewritableTyVar :: EqRel    -- Ambient role                    -> (EqRel -> TcTyVar -> Bool)  -- check tyvar                    -> TcType -> Bool--- See Note [Rewritable] in GHC.Tc.Solver.Monad for a specification for this function.-anyRewritableTyVar ignore_cos role pred-  = any_rewritable ignore_cos role pred+-- See Note [Rewritable] in GHC.Tc.Solver.InertSet for a specification for this function.+anyRewritableTyVar role pred+  = any_rewritable role pred       (\ _ _ _ -> False) -- no special check for tyconapps                          -- (this False is ORed with other results, so it                          --  really means "do nothing special"; the arguments@@ -911,20 +1001,9 @@                           -- should return True only for type family applications                       -> TcType -> Bool   -- always ignores casts & coercions--- See Note [Rewritable] in GHC.Tc.Solver.Monad for a specification for this function.+-- See Note [Rewritable] in GHC.Tc.Solver.InertSet for a specification for this function. anyRewritableTyFamApp role check_tyconapp-  = any_rewritable True role (\ _ _ -> False) check_tyconapp (not . isFamFreeTyCon)---- This version is used by shouldSplitWD. It *does* look in casts--- and coercions, and it always expands type synonyms whose RHSs mention--- type families.--- See Note [Rewritable] in GHC.Tc.Solver.Monad for a specification for this function.-anyRewritableCanEqLHS :: EqRel   -- Ambient role-                      -> (EqRel -> TcTyVar -> Bool)            -- check tyvar-                      -> (EqRel -> TyCon -> [TcType] -> Bool)  -- check type family-                      -> TcType -> Bool-anyRewritableCanEqLHS role check_tyvar check_tyconapp-  = any_rewritable False role check_tyvar check_tyconapp (not . isFamFreeTyCon)+  = any_rewritable role (\ _ _ -> False) check_tyconapp (not . isFamFreeTyCon)  {- Note [anyRewritableTyVar must be role-aware] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1009,8 +1088,8 @@   | isTyVar tv -- See Note [Coercion variables in free variable lists]   , MetaTv { mtv_tclvl = tv_tclvl, mtv_info = info } <- tcTyVarDetails tv   , isTouchableInfo info-  = ASSERT2( checkTcLevelInvariant ctxt_tclvl tv_tclvl,-             ppr tv $$ ppr tv_tclvl $$ ppr ctxt_tclvl )+  = assertPpr (checkTcLevelInvariant ctxt_tclvl tv_tclvl)+              (ppr tv $$ ppr tv_tclvl $$ ppr ctxt_tclvl) $     tv_tclvl `sameDepthAs` ctxt_tclvl    | otherwise = False@@ -1032,15 +1111,24 @@   | otherwise = True  isSkolemTyVar tv-  = ASSERT2( tcIsTcTyVar tv, ppr tv )+  = assertPpr (tcIsTcTyVar tv) (ppr tv) $     case tcTyVarDetails tv of         MetaTv {} -> False         _other    -> True +skolemSkolInfo :: TcTyVar -> SkolemInfo+skolemSkolInfo tv+  = assert (isSkolemTyVar tv) $+    case tcTyVarDetails tv of+      SkolemTv skol_info _ _ -> skol_info+      RuntimeUnk -> panic "RuntimeUnk"+      MetaTv {} -> panic "skolemSkolInfo"++ isOverlappableTyVar tv   | isTyVar tv -- See Note [Coercion variables in free variable lists]   = case tcTyVarDetails tv of-        SkolemTv _ overlappable -> overlappable+        SkolemTv _ _ overlappable -> overlappable         _                       -> False   | otherwise = False @@ -1053,7 +1141,7 @@  -- isAmbiguousTyVar is used only when reporting type errors -- It picks out variables that are unbound, namely meta--- type variables and the RuntimUnk variables created by+-- type variables and the RuntimeUnk variables created by -- GHC.Runtime.Heap.Inspect.zonkRTTIType.  These are "ambiguous" in -- the sense that they stand for an as-yet-unknown type isAmbiguousTyVar tv@@ -1072,6 +1160,35 @@   | otherwise   = False +-- | Is this type variable a concrete type variable, i.e.+-- it is a metavariable with 'ConcreteTv' 'MetaInfo'?+--+-- Returns the 'ConcreteTvOrigin' stored in the type variable+-- if so, or 'Nothing' otherwise.+isConcreteTyVar_maybe :: TcTyVar -> Maybe ConcreteTvOrigin+isConcreteTyVar_maybe tv+  | isTcTyVar tv+  , MetaTv { mtv_info = ConcreteTv conc_orig } <- tcTyVarDetails tv+  = Just conc_orig+  | otherwise+  = Nothing++-- | Is this type variable a concrete type variable, i.e.+-- it is a metavariable with 'ConcreteTv' 'MetaInfo'?+isConcreteTyVar :: TcTyVar -> Bool+isConcreteTyVar = isJust . isConcreteTyVar_maybe++-- | Is this type concrete type variable, i.e.+-- a metavariable with 'ConcreteTv' 'MetaInfo'?+isConcreteTyVarTy :: TcType -> Bool+isConcreteTyVarTy = isJust . isConcreteTyVarTy_maybe++-- | Is this type a concrete type variable? If so, return+-- the associated 'TcTyVar' and 'ConcreteTvOrigin'.+isConcreteTyVarTy_maybe :: TcType -> Maybe (TcTyVar, ConcreteTvOrigin)+isConcreteTyVarTy_maybe (TyVarTy tv) = (tv, ) <$> isConcreteTyVar_maybe tv+isConcreteTyVarTy_maybe _            = Nothing+ isMetaTyVarTy :: TcType -> Bool isMetaTyVarTy (TyVarTy tv) = isMetaTyVar tv isMetaTyVarTy _            = False@@ -1144,6 +1261,16 @@     eq_snd (_,tv1) (_,tv2) = tv1 == tv2     mk_result_prs ((n1,_) :| xs) = map (\(n2,_) -> (n1,n2)) xs +-- | Returns the (kind, type) variables in a type that are+-- as-yet-unknown: metavariables and RuntimeUnks+ambigTkvsOfTy :: TcType -> ([Var],[Var])+ambigTkvsOfTy ty+  = partition (`elemVarSet` dep_tkv_set) ambig_tkvs+  where+    tkvs        = tyCoVarsOfTypeList ty+    ambig_tkvs  = filter isAmbiguousTyVar tkvs+    dep_tkv_set = tyCoVarsOfTypes (map tyVarKind tkvs)+ {- ************************************************************************ *                                                                      *@@ -1224,13 +1351,13 @@ -- Always succeeds, even if it returns an empty list. tcSplitPiTys :: Type -> ([TyBinder], Type) tcSplitPiTys ty-  = ASSERT( all isTyBinder (fst sty) ) sty+  = assert (all isTyBinder (fst sty) ) sty   where sty = splitPiTys ty  -- | Splits a type into a TyBinder and a body, if possible. Panics otherwise tcSplitPiTy_maybe :: Type -> Maybe (TyBinder, Type) tcSplitPiTy_maybe ty-  = ASSERT( isMaybeTyBinder sty ) sty+  = assert (isMaybeTyBinder sty ) sty   where     sty = splitPiTy_maybe ty     isMaybeTyBinder (Just (t,_)) = isTyBinder t@@ -1238,14 +1365,14 @@  tcSplitForAllTyVarBinder_maybe :: Type -> Maybe (TyVarBinder, Type) tcSplitForAllTyVarBinder_maybe ty | Just ty' <- tcView ty = tcSplitForAllTyVarBinder_maybe ty'-tcSplitForAllTyVarBinder_maybe (ForAllTy tv ty) = ASSERT( isTyVarBinder tv ) Just (tv, ty)+tcSplitForAllTyVarBinder_maybe (ForAllTy tv ty) = assert (isTyVarBinder tv ) Just (tv, ty) tcSplitForAllTyVarBinder_maybe _                = Nothing  -- | Like 'tcSplitPiTys', but splits off only named binders, -- returning just the tyvars. tcSplitForAllTyVars :: Type -> ([TyVar], Type) tcSplitForAllTyVars ty-  = ASSERT( all isTyVar (fst sty) ) sty+  = assert (all isTyVar (fst sty) ) sty   where sty = splitForAllTyCoVars ty  -- | Like 'tcSplitForAllTyVars', but only splits 'ForAllTy's with 'Invisible'@@ -1269,18 +1396,18 @@ -- | Like 'tcSplitForAllTyVars', but only splits 'ForAllTy's with 'Required' type -- variable binders. All split tyvars are annotated with '()'. tcSplitForAllReqTVBinders :: Type -> ([TcReqTVBinder], Type)-tcSplitForAllReqTVBinders ty = ASSERT( all (isTyVar . binderVar) (fst sty) ) sty+tcSplitForAllReqTVBinders ty = assert (all (isTyVar . binderVar) (fst sty) ) sty   where sty = splitForAllReqTVBinders ty  -- | Like 'tcSplitForAllTyVars', but only splits 'ForAllTy's with 'Invisible' type -- variable binders. All split tyvars are annotated with their 'Specificity'. tcSplitForAllInvisTVBinders :: Type -> ([TcInvisTVBinder], Type)-tcSplitForAllInvisTVBinders ty = ASSERT( all (isTyVar . binderVar) (fst sty) ) sty+tcSplitForAllInvisTVBinders ty = assert (all (isTyVar . binderVar) (fst sty) ) sty   where sty = splitForAllInvisTVBinders ty  -- | Like 'tcSplitForAllTyVars', but splits off only named binders. tcSplitForAllTyVarBinders :: Type -> ([TyVarBinder], Type)-tcSplitForAllTyVarBinders ty = ASSERT( all isTyVarBinder (fst sty)) sty+tcSplitForAllTyVarBinders ty = assert (all isTyVarBinder (fst sty)) sty   where sty = splitForAllTyCoVarBinders ty  -- | Is this a ForAllTy with a named binder?@@ -1764,71 +1891,7 @@   -- partial signatures, (isEvVarType kappa) will return False. But   -- nothing is wrong.  So I just removed the ASSERT. ---------------------- | When inferring types, should we quantify over a given predicate?--- Generally true of classes; generally false of equality constraints.--- Equality constraints that mention quantified type variables and--- implicit variables complicate the story. See Notes--- [Inheriting implicit parameters] and [Quantifying over equality constraints]-pickQuantifiablePreds-  :: TyVarSet           -- Quantifying over these-  -> TcThetaType        -- Proposed constraints to quantify-  -> TcThetaType        -- A subset that we can actually quantify--- This function decides whether a particular constraint should be--- quantified over, given the type variables that are being quantified-pickQuantifiablePreds qtvs theta-  = let flex_ctxt = True in  -- Quantify over non-tyvar constraints, even without-                             -- -XFlexibleContexts: see #10608, #10351-         -- flex_ctxt <- xoptM Opt_FlexibleContexts-    mapMaybe (pick_me flex_ctxt) theta-  where-    pick_me flex_ctxt pred-      = case classifyPredType pred of--          ClassPred cls tys-            | Just {} <- isCallStackPred cls tys-              -- NEVER infer a CallStack constraint.  Otherwise we let-              -- the constraints bubble up to be solved from the outer-              -- context, or be defaulted when we reach the top-level.-              -- See Note [Overview of implicit CallStacks]-            -> Nothing--            | isIPClass cls-            -> Just pred -- See note [Inheriting implicit parameters]--            | pick_cls_pred flex_ctxt cls tys-            -> Just pred--          EqPred eq_rel ty1 ty2-            | quantify_equality eq_rel ty1 ty2-            , Just (cls, tys) <- boxEqPred eq_rel ty1 ty2-              -- boxEqPred: See Note [Lift equality constraints when quantifying]-            , pick_cls_pred flex_ctxt cls tys-            -> Just (mkClassPred cls tys)--          IrredPred ty-            | tyCoVarsOfType ty `intersectsVarSet` qtvs-            -> Just pred--          _ -> Nothing---    pick_cls_pred flex_ctxt cls tys-      = tyCoVarsOfTypes tys `intersectsVarSet` qtvs-        && (checkValidClsArgs flex_ctxt cls tys)-           -- Only quantify over predicates that checkValidType-           -- will pass!  See #10351.--    -- See Note [Quantifying over equality constraints]-    quantify_equality NomEq  ty1 ty2 = quant_fun ty1 || quant_fun ty2-    quantify_equality ReprEq _   _   = True--    quant_fun ty-      = case tcSplitTyConApp_maybe ty of-          Just (tc, tys) | isTypeFamilyTyCon tc-                         -> tyCoVarsOfTypes tys `intersectsVarSet` qtvs-          _ -> False-+--------------------------- boxEqPred :: EqRel -> Type -> Type -> Maybe (Class, [Type]) -- Given (t1 ~# t2) or (t1 ~R# t2) return the boxed version --       (t1 ~ t2)  or (t1 `Coercible` t2)@@ -2002,71 +2065,6 @@  See also GHC.Tc.TyCl.Utils.checkClassCycles. -Note [Lift equality constraints when quantifying]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We can't quantify over a constraint (t1 ~# t2) because that isn't a-predicate type; see Note [Types for coercions, predicates, and evidence]-in GHC.Core.TyCo.Rep.--So we have to 'lift' it to (t1 ~ t2).  Similarly (~R#) must be lifted-to Coercible.--This tiresome lifting is the reason that pick_me (in-pickQuantifiablePreds) returns a Maybe rather than a Bool.--Note [Quantifying over equality constraints]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Should we quantify over an equality constraint (s ~ t)?  In general, we don't.-Doing so may simply postpone a type error from the function definition site to-its call site.  (At worst, imagine (Int ~ Bool)).--However, consider this-         forall a. (F [a] ~ Int) => blah-Should we quantify over the (F [a] ~ Int)?  Perhaps yes, because at the call-site we will know 'a', and perhaps we have instance  F [Bool] = Int.-So we *do* quantify over a type-family equality where the arguments mention-the quantified variables.--Note [Inheriting implicit parameters]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this:--        f x = (x::Int) + ?y--where f is *not* a top-level binding.-From the RHS of f we'll get the constraint (?y::Int).-There are two types we might infer for f:--        f :: Int -> Int--(so we get ?y from the context of f's definition), or--        f :: (?y::Int) => Int -> Int--At first you might think the first was better, because then-?y behaves like a free variable of the definition, rather than-having to be passed at each call site.  But of course, the WHOLE-IDEA is that ?y should be passed at each call site (that's what-dynamic binding means) so we'd better infer the second.--BOTTOM LINE: when *inferring types* you must quantify over implicit-parameters, *even if* they don't mention the bound type variables.-Reason: because implicit parameters, uniquely, have local instance-declarations. See pickQuantifiablePreds.--Note [Quantifying over equality constraints]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Should we quantify over an equality constraint (s ~ t)?  In general, we don't.-Doing so may simply postpone a type error from the function definition site to-its call site.  (At worst, imagine (Int ~ Bool)).--However, consider this-         forall a. (F [a] ~ Int) => blah-Should we quantify over the (F [a] ~ Int).  Perhaps yes, because at the call-site we will know 'a', and perhaps we have instance  F [Bool] = Int.-So we *do* quantify over a type-family equality where the arguments mention-the quantified variables.- ************************************************************************ *                                                                      *       Classifying types@@ -2102,11 +2100,15 @@ isOverloadedTy (FunTy { ft_af = InvisArg }) = True isOverloadedTy _                            = False -isFloatTy, isDoubleTy, isIntegerTy, isNaturalTy,+isFloatTy, isDoubleTy,+    isFloatPrimTy, isDoublePrimTy,+    isIntegerTy, isNaturalTy,     isIntTy, isWordTy, isBoolTy,     isUnitTy, isCharTy, isAnyTy :: Type -> Bool isFloatTy      = is_tc floatTyConKey isDoubleTy     = is_tc doubleTyConKey+isFloatPrimTy  = is_tc floatPrimTyConKey+isDoublePrimTy = is_tc doublePrimTyConKey isIntegerTy    = is_tc integerTyConKey isNaturalTy    = is_tc naturalTyConKey isIntTy        = is_tc intTyConKey@@ -2116,9 +2118,15 @@ isCharTy       = is_tc charTyConKey isAnyTy        = is_tc anyTyConKey --- | Does a type represent a floating-point number?-isFloatingTy :: Type -> Bool-isFloatingTy ty = isFloatTy ty || isDoubleTy ty+-- | Is the type inhabited by machine floating-point numbers?+--+-- Used to check that we don't use floating-point literal patterns+-- in Core.+--+-- See #9238 and Note [Rules for floating-point comparisons]+-- in GHC.Core.Opt.ConstantFold.+isFloatingPrimTy :: Type -> Bool+isFloatingPrimTy ty = isFloatPrimTy ty || isDoublePrimTy ty  -- | Is a type 'String'? isStringTy :: Type -> Bool@@ -2127,26 +2135,6 @@       Just (tc, [arg_ty]) -> tc == listTyCon && isCharTy arg_ty       _                   -> False --- | Is a type a 'CallStack'?-isCallStackTy :: Type -> Bool-isCallStackTy ty-  | Just tc <- tyConAppTyCon_maybe ty-  = tc `hasKey` callStackTyConKey-  | 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_tc :: Unique -> Type -> Bool -- Newtypes are opaque to this is_tc uniq ty = case tcSplitTyConApp_maybe ty of@@ -2160,7 +2148,6 @@   | isForAllTy ty                           = True   | otherwise                               = False - {- ************************************************************************ *                                                                      *@@ -2237,27 +2224,45 @@         _ ->             Nothing -isFFITy :: Type -> Bool--- True for any TyCon that can possibly be an arg or result of an FFI call-isFFITy ty = isValid (checkRepTyCon legalFFITyCon ty)+-- | Reason why a type in an FFI signature is invalid+data IllegalForeignTypeReason+  = TypeCannotBeMarshaled !Type TypeCannotBeMarshaledReason+  | ForeignDynNotPtr+      !Type -- ^ Expected type+      !Type -- ^ Actual type+  | SafeHaskellMustBeInIO+  | IOResultExpected+  | UnexpectedNestedForall+  | LinearTypesNotAllowed+  | OneArgExpected+  | AtLeastOneArgExpected -isFFIArgumentTy :: DynFlags -> Safety -> Type -> Validity+-- | Reason why a type cannot be marshalled through the FFI.+data TypeCannotBeMarshaledReason+  = NotADataType+  | NewtypeDataConNotInScope !(Maybe TyCon)+  | UnliftedFFITypesNeeded+  | NotABoxedMarshalableTyCon+  | ForeignLabelNotAPtr+  | NotSimpleUnliftedType++isFFIArgumentTy :: DynFlags -> Safety -> Type -> Validity' IllegalForeignTypeReason -- Checks for valid argument type for a 'foreign import' isFFIArgumentTy dflags safety ty    = checkRepTyCon (legalOutgoingTyCon dflags safety) ty -isFFIExternalTy :: Type -> Validity+isFFIExternalTy :: Type -> Validity' IllegalForeignTypeReason -- Types that are allowed as arguments of a 'foreign export' isFFIExternalTy ty = checkRepTyCon legalFEArgTyCon ty -isFFIImportResultTy :: DynFlags -> Type -> Validity+isFFIImportResultTy :: DynFlags -> Type -> Validity' IllegalForeignTypeReason isFFIImportResultTy dflags ty   = checkRepTyCon (legalFIResultTyCon dflags) ty -isFFIExportResultTy :: Type -> Validity+isFFIExportResultTy :: Type -> Validity' IllegalForeignTypeReason isFFIExportResultTy ty = checkRepTyCon legalFEResultTyCon ty -isFFIDynTy :: Type -> Type -> Validity+isFFIDynTy :: Type -> Type -> Validity' IllegalForeignTypeReason -- The type in a foreign import dynamic must be Ptr, FunPtr, or a newtype of -- either, and the wrapped function type must be equal to the given type. -- We assume that all types have been run through normaliseFfiType, so we don't@@ -2271,19 +2276,18 @@     , eqType ty' expected     = IsValid     | otherwise-    = NotValid (vcat [ text "Expected: Ptr/FunPtr" <+> pprParendType expected <> comma-                     , text "  Actual:" <+> ppr ty ])+    = NotValid (ForeignDynNotPtr expected ty) -isFFILabelTy :: Type -> Validity+isFFILabelTy :: Type -> Validity' IllegalForeignTypeReason -- The type of a foreign label must be Ptr, FunPtr, or a newtype of either. isFFILabelTy ty = checkRepTyCon ok ty   where     ok tc | tc `hasKey` funPtrTyConKey || tc `hasKey` ptrTyConKey           = IsValid           | otherwise-          = NotValid (text "A foreign-imported address (via &foo) must have type (Ptr a) or (FunPtr a)")+          = NotValid ForeignLabelNotAPtr -isFFIPrimArgumentTy :: DynFlags -> Type -> Validity+isFFIPrimArgumentTy :: DynFlags -> Type -> Validity' IllegalForeignTypeReason -- Checks for valid argument type for a 'foreign import prim' -- Currently they must all be simple unlifted types, or the well-known type -- Any, which can be used to pass the address to a Haskell object on the heap to@@ -2292,7 +2296,7 @@   | isAnyTy ty = IsValid   | otherwise  = checkRepTyCon (legalFIPrimArgTyCon dflags) ty -isFFIPrimResultTy :: DynFlags -> Type -> Validity+isFFIPrimResultTy :: DynFlags -> Type -> Validity' IllegalForeignTypeReason -- Checks for valid result type for a 'foreign import prim' Currently -- it must be an unlifted type, including unboxed tuples, unboxed -- sums, or the well-known type Any.@@ -2310,22 +2314,20 @@ -- normaliseFfiType gets run before checkRepTyCon, so we don't -- need to worry about looking through newtypes or type functions -- here; that's already been taken care of.-checkRepTyCon :: (TyCon -> Validity) -> Type -> Validity+checkRepTyCon+  :: (TyCon -> Validity' TypeCannotBeMarshaledReason)+  -> Type+  -> Validity' IllegalForeignTypeReason checkRepTyCon check_tc ty-  = case splitTyConApp_maybe ty of+  = fmap (TypeCannotBeMarshaled ty) $ case splitTyConApp_maybe ty of       Just (tc, tys)-        | isNewTyCon tc -> NotValid (hang msg 2 (mk_nt_reason tc tys $$ nt_fix))-        | otherwise     -> case check_tc tc of-                             IsValid        -> IsValid-                             NotValid extra -> NotValid (msg $$ extra)-      Nothing -> NotValid (quotes (ppr ty) <+> text "is not a data type")+        | isNewTyCon tc -> NotValid (mk_nt_reason tc tys)+        | otherwise     -> check_tc tc+      Nothing -> NotValid NotADataType   where-    msg = quotes (ppr ty) <+> text "cannot be marshalled in a foreign call"     mk_nt_reason tc tys-      | null tys  = text "because its data constructor is not in scope"-      | otherwise = text "because the data constructor for"-                    <+> quotes (ppr tc) <+> text "is not in scope"-    nt_fix = text "Possible fix: import the data constructor to bring it into scope"+      | null tys  = NewtypeDataConNotInScope Nothing+      | otherwise = NewtypeDataConNotInScope (Just tc)  {- Note [Foreign import dynamic]@@ -2348,44 +2350,46 @@ ---------------------------------------------- -} -legalFEArgTyCon :: TyCon -> Validity+legalFEArgTyCon :: TyCon -> Validity' TypeCannotBeMarshaledReason legalFEArgTyCon tc   -- It's illegal to make foreign exports that take unboxed   -- arguments.  The RTS API currently can't invoke such things.  --SDM 7/2000   = boxedMarshalableTyCon tc -legalFIResultTyCon :: DynFlags -> TyCon -> Validity+legalFIResultTyCon :: DynFlags -> TyCon -> Validity' TypeCannotBeMarshaledReason legalFIResultTyCon dflags tc   | tc == unitTyCon         = IsValid   | otherwise               = marshalableTyCon dflags tc -legalFEResultTyCon :: TyCon -> Validity+legalFEResultTyCon :: TyCon -> Validity' TypeCannotBeMarshaledReason legalFEResultTyCon tc   | tc == unitTyCon         = IsValid   | otherwise               = boxedMarshalableTyCon tc -legalOutgoingTyCon :: DynFlags -> Safety -> TyCon -> Validity+legalOutgoingTyCon :: DynFlags -> Safety -> TyCon -> Validity' TypeCannotBeMarshaledReason -- Checks validity of types going from Haskell -> external world legalOutgoingTyCon dflags _ tc   = marshalableTyCon dflags tc -legalFFITyCon :: TyCon -> Validity--- True for any TyCon that can possibly be an arg or result of an FFI call-legalFFITyCon tc-  | isUnliftedTyCon tc = IsValid-  | tc == unitTyCon    = IsValid-  | otherwise          = boxedMarshalableTyCon tc+-- Check for marshalability of a primitive type.+-- We exclude lifted types such as RealWorld and TYPE.+-- They can technically appear in types, e.g.+-- f :: RealWorld -> TYPE LiftedRep -> RealWorld+-- f x _ = x+-- but there are no values of type RealWorld or TYPE LiftedRep,+-- so it doesn't make sense to use them in FFI.+marshalablePrimTyCon :: TyCon -> Bool+marshalablePrimTyCon tc = isPrimTyCon tc && not (isLiftedTypeKind (tyConResKind tc)) -marshalableTyCon :: DynFlags -> TyCon -> Validity+marshalableTyCon :: DynFlags -> TyCon -> Validity' TypeCannotBeMarshaledReason marshalableTyCon dflags tc-  | isUnliftedTyCon tc-  , not (isUnboxedTupleTyCon tc || isUnboxedSumTyCon tc)+  | marshalablePrimTyCon tc   , not (null (tyConPrimRep tc)) -- Note [Marshalling void]   = validIfUnliftedFFITypes dflags   | otherwise   = boxedMarshalableTyCon tc -boxedMarshalableTyCon :: TyCon -> Validity+boxedMarshalableTyCon :: TyCon -> Validity' TypeCannotBeMarshaledReason boxedMarshalableTyCon tc    | getUnique tc `elem` [ intTyConKey, int8TyConKey, int16TyConKey                          , int32TyConKey, int64TyConKey@@ -2399,38 +2403,34 @@                          ]   = IsValid -  | otherwise = NotValid empty+  | otherwise = NotValid NotABoxedMarshalableTyCon -legalFIPrimArgTyCon :: DynFlags -> TyCon -> Validity+legalFIPrimArgTyCon :: DynFlags -> TyCon -> Validity' TypeCannotBeMarshaledReason -- Check args of 'foreign import prim', only allow simple unlifted types.--- Strictly speaking it is unnecessary to ban unboxed tuples and sums here since--- currently they're of the wrong kind to use in function args anyway. legalFIPrimArgTyCon dflags tc-  | isUnliftedTyCon tc-  , not (isUnboxedTupleTyCon tc || isUnboxedSumTyCon tc)+  | marshalablePrimTyCon tc   = validIfUnliftedFFITypes dflags   | otherwise-  = NotValid unlifted_only+  = NotValid NotSimpleUnliftedType -legalFIPrimResultTyCon :: DynFlags -> TyCon -> Validity+legalFIPrimResultTyCon :: DynFlags -> TyCon -> Validity' TypeCannotBeMarshaledReason -- Check result type of 'foreign import prim'. Allow simple unlifted -- types and also unboxed tuple and sum result types. legalFIPrimResultTyCon dflags tc-  | isUnliftedTyCon tc-  , isUnboxedTupleTyCon tc || isUnboxedSumTyCon tc-     || not (null (tyConPrimRep tc))   -- Note [Marshalling void]+  | marshalablePrimTyCon tc+  , not (null (tyConPrimRep tc))   -- Note [Marshalling void]   = validIfUnliftedFFITypes dflags -  | otherwise-  = NotValid unlifted_only+  | isUnboxedTupleTyCon tc || isUnboxedSumTyCon tc+  = validIfUnliftedFFITypes dflags -unlifted_only :: SDoc-unlifted_only = text "foreign import prim only accepts simple unlifted types"+  | otherwise+  = NotValid $ NotSimpleUnliftedType -validIfUnliftedFFITypes :: DynFlags -> Validity+validIfUnliftedFFITypes :: DynFlags -> Validity' TypeCannotBeMarshaledReason validIfUnliftedFFITypes dflags   | xopt LangExt.UnliftedFFITypes dflags =  IsValid-  | otherwise = NotValid (text "To marshal unlifted types, use UnliftedFFITypes")+  | otherwise = NotValid UnliftedFFITypesNeeded  {- Note [Marshalling void]
GHC/Tc/Utils/TcType.hs-boot view
@@ -2,11 +2,18 @@ import GHC.Utils.Outputable( SDoc ) import GHC.Prelude ( Bool ) import {-# SOURCE #-} GHC.Types.Var ( TcTyVar )+import {-# SOURCE #-} GHC.Core.TyCo.Rep+import GHC.Utils.Misc ( HasDebugCallStack )+import GHC.Stack  data MetaDetails  data TcTyVarDetails pprTcTyVarDetails :: TcTyVarDetails -> SDoc-vanillaSkolemTv :: TcTyVarDetails+vanillaSkolemTvUnk :: HasCallStack => TcTyVarDetails isMetaTyVar :: TcTyVar -> Bool isTyConableTyVar :: TcTyVar -> Bool+isConcreteTyVar :: TcTyVar -> Bool++tcEqType :: HasDebugCallStack => Type -> Type -> Bool+
GHC/Tc/Utils/Unify.hs view
@@ -1,7 +1,5 @@-{-# LANGUAGE CPP                 #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections       #-}-{-# LANGUAGE BlockArguments      #-} {-# LANGUAGE RecursiveDo         #-}  {-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}@@ -17,7 +15,7 @@   -- Full-blown subsumption   tcWrapResult, tcWrapResultO, tcWrapResultMono,   tcTopSkolemise, tcSkolemiseScoped, tcSkolemiseExpType,-  tcSubType, tcSubTypeSigma, tcSubTypePat, tcSubTypeDS,+  tcSubType, tcSubTypeNC, tcSubTypeSigma, tcSubTypePat,   tcSubTypeAmbiguity, tcSubMult,   checkConstraints, checkTvConstraints,   buildImplicationFor, buildTvImplication, emitResidualTvConstraint,@@ -25,7 +23,7 @@   -- Various unifications   unifyType, unifyKind, unifyExpectedType,   uType, promoteTcType,-  swapOverTyVars, canSolveByUnification,+  swapOverTyVars, startSolvingByUnification,    --------------------------------   -- Holes@@ -41,27 +39,28 @@    ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Hs import GHC.Core.TyCo.Rep import GHC.Core.TyCo.Ppr( debugPprType )-import GHC.Tc.Utils.TcMType+import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep, makeTypeConcrete, hasFixedRuntimeRep_syntactic )+import GHC.Tc.Utils.Env+import GHC.Tc.Utils.Instantiate import GHC.Tc.Utils.Monad+import GHC.Tc.Utils.TcMType import GHC.Tc.Utils.TcType-import GHC.Tc.Utils.Env+ import GHC.Core.Type import GHC.Core.Coercion import GHC.Core.Multiplicity+ import qualified GHC.LanguageExtensions as LangExt  import GHC.Tc.Types.Evidence import GHC.Tc.Types.Constraint import GHC.Tc.Types.Origin -import GHC.Tc.Utils.Instantiate import GHC.Core.TyCon import GHC.Builtin.Types import GHC.Types.Name( Name, isSystemName )@@ -76,6 +75,7 @@ import GHC.Utils.Misc import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain  import GHC.Exts      ( inline ) import Control.Monad@@ -87,19 +87,31 @@ *                                                                      * ********************************************************************* -} --- | matchActualFunTySigma does looks for just one function arrow---   returning an uninstantiated sigma-type+-- | 'matchActualFunTySigma' looks for just one function arrow,+-- returning an uninstantiated sigma-type.+--+-- Invariant: the returned argument type has a syntactically fixed+-- RuntimeRep in the sense of Note [Fixed RuntimeRep]+-- in GHC.Tc.Utils.Concrete.+--+-- See Note [Return arguments with a fixed RuntimeRep]. matchActualFunTySigma-  :: SDoc -- See Note [Herald for matchExpectedFunTys]-  -> Maybe SDoc                    -- The thing with type TcSigmaType-  -> (Arity, [Scaled TcSigmaType]) -- Total number of value args in the call, and-                                   -- types of values args to which function has-                                   --   been applied already (reversed)-                                   -- Both are used only for error messages)-  -> TcRhoType                     -- Type to analyse: a TcRhoType-  -> TcM (HsWrapper, Scaled TcSigmaType, TcSigmaType)--- The /argument/ is a RhoType--- The /result/   is an (uninstantiated) SigmaType+  :: ExpectedFunTyOrigin+      -- ^ See Note [Herald for matchExpectedFunTys]+  -> Maybe TypedThing+      -- ^ The thing with type TcSigmaType+  -> (Arity, [Scaled TcSigmaType])+      -- ^ Total number of value args in the call, and+      -- types of values args to which function has+      --   been applied already (reversed)+      -- (Both are used only for error messages)+  -> TcRhoType+      -- ^ Type to analyse: a TcRhoType+  -> TcM (HsWrapper, Scaled TcSigmaTypeFRR, TcSigmaType)+-- This function takes in a type to analyse (a RhoType) and returns+-- an argument type and a result type (splitting apart a function arrow).+-- The returned argument type is a SigmaType with a fixed RuntimeRep;+-- as explained in Note [Return arguments with a fixed RuntimeRep]. -- -- See Note [matchActualFunTy error handling] for the first three arguments @@ -108,7 +120,7 @@ -- and NB: res_ty is an (uninstantiated) SigmaType  matchActualFunTySigma herald mb_thing err_info fun_ty-  = ASSERT2( isRhoTy fun_ty, ppr fun_ty )+  = assertPpr (isRhoTy fun_ty) (ppr fun_ty) $     go fun_ty   where     -- Does not allocate unnecessary meta variables: if the input already is@@ -118,13 +130,14 @@     -- If allocated (fresh-meta-var1 -> fresh-meta-var2) and unified, we'd     -- hide the forall inside a meta-variable     go :: TcRhoType   -- The type we're processing, perhaps after-                      -- expanding any type synonym-       -> TcM (HsWrapper, Scaled TcSigmaType, TcSigmaType)+                      -- expanding type synonyms+       -> TcM (HsWrapper, Scaled TcSigmaTypeFRR, TcSigmaType)     go ty | Just ty' <- tcView ty = go ty'      go (FunTy { ft_af = af, ft_mult = w, ft_arg = arg_ty, ft_res = res_ty })-      = ASSERT( af == VisArg )-        return (idHsWrapper, Scaled w arg_ty, res_ty)+      = assert (af == VisArg) $+      do { hasFixedRuntimeRep_syntactic (FRRExpectedFunTy herald 1) arg_ty+         ; return (idHsWrapper, Scaled w arg_ty, res_ty) }      go ty@(TyVarTy tv)       | isMetaTyVar tv@@ -157,6 +170,7 @@            ; mult <- newFlexiTyVarTy multiplicityTy            ; let unif_fun_ty = mkVisFunTy mult arg_ty res_ty            ; co <- unifyType mb_thing fun_ty unif_fun_ty+           ; hasFixedRuntimeRep_syntactic (FRRExpectedFunTy herald 1) arg_ty            ; return (mkWpCastN co, Scaled mult arg_ty, res_ty) }      ------------@@ -188,14 +202,18 @@ Ugh! -} --- Like 'matchExpectedFunTys', but used when you have an "actual" type,--- for example in function application-matchActualFunTysRho :: SDoc   -- See Note [Herald for matchExpectedFunTys]+-- | Like 'matchExpectedFunTys', but used when you have an "actual" type,+-- for example in function application.+--+-- INVARIANT: the returned arguemnt types all have a syntactically fixed RuntimeRep+-- in the sense of Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete.+-- See Note [Return arguments with a fixed RuntimeRep].+matchActualFunTysRho :: ExpectedFunTyOrigin -- ^ See Note [Herald for matchExpectedFunTys]                      -> CtOrigin-                     -> Maybe SDoc  -- the thing with type TcSigmaType+                     -> Maybe TypedThing -- ^ the thing with type TcSigmaType                      -> Arity                      -> TcSigmaType-                     -> TcM (HsWrapper, [Scaled TcSigmaType], TcRhoType)+                     -> TcM (HsWrapper, [Scaled TcSigmaTypeFRR], TcRhoType) -- If    matchActualFunTysRho n ty = (wrap, [t1,..,tn], res_ty) -- then  wrap : ty ~> (t1 -> ... -> tn -> res_ty) --       and res_ty is a RhoType@@ -217,13 +235,11 @@                                                  (n_val_args_wanted, so_far)                                                  fun_ty            ; (wrap_res, arg_tys, res_ty)   <- go (n-1) (arg_ty1:so_far) res_ty1-           ; let wrap_fun2 = mkWpFun idHsWrapper wrap_res arg_ty1 res_ty doc+           ; let wrap_fun2 = mkWpFun idHsWrapper wrap_res arg_ty1 res_ty+           -- NB: arg_ty1 comes from matchActualFunTySigma, so it has+           -- a syntactically fixed RuntimeRep as needed to call mkWpFun.            ; return (wrap_fun2 <.> wrap_fun1, arg_ty1:arg_tys, res_ty) }-      where-        doc = text "When inferring the argument type of a function with type" <+>-              quotes (ppr fun_ty) - {- ************************************************************************ *                                                                      *@@ -286,18 +302,75 @@ ExpTypes produced for arguments before it can fill in the ExpType passed in. +Note [Return arguments with a fixed RuntimeRep]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The functions++  - matchExpectedFunTys,+  - matchActualFunTySigma,+  - matchActualFunTysRho,++peel off argument types, as explained in Note [matchExpectedFunTys].+It's important that these functions return argument types that have+a fixed runtime representation, otherwise we would be in violation+of the representation-polymorphism invariants of+Note [Representation polymorphism invariants] in GHC.Core.++This is why all these functions have an additional invariant,+that the argument types they return all have a syntactically fixed RuntimeRep,+in the sense of Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete.++Example:++  Suppose we have++    type F :: Type -> RuntimeRep+    type family F a where { F Int = LiftedRep }++    type Dual :: Type -> Type+    type family Dual a where+      Dual a = a -> ()++    f :: forall (a :: TYPE (F Int)). Dual a+    f = \ x -> ()++  The body of `f` is a lambda abstraction, so we must be able to split off+  one argument type from its type. This is handled by `matchExpectedFunTys`+  (see 'GHC.Tc.Gen.Match.tcMatchLambda'). We end up with desugared Core that+  looks like this:++    f :: forall (a :: TYPE (F Int)). Dual (a |> (TYPE F[0]))+    f = \ @(a :: TYPE (F Int)) ->+          (\ (x :: (a |> (TYPE F[0]))) -> ())+          `cast`+          (Sub (Sym (Dual[0] <(a |> (TYPE F[0]))>)))++  Two important transformations took place:++    1. We inserted casts around the argument type to ensure that it has+       a fixed runtime representation, as required by invariant (I1) from+       Note [Representation polymorphism invariants] in GHC.Core.+    2. We inserted a cast around the whole lambda to make everything line up+       with the type signature. -} --- Use this one when you have an "expected" type.+-- | Use this function to split off arguments types when you have an+-- \"expected\" type.+-- -- This function skolemises at each polytype.+--+-- Invariant: this function only applies the provided function+-- to a list of argument types which all have a syntactically fixed RuntimeRep+-- in the sense of Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete.+-- See Note [Return arguments with a fixed RuntimeRep]. matchExpectedFunTys :: forall a.-                       SDoc   -- See Note [Herald for matchExpectedFunTys]+                       ExpectedFunTyOrigin -- See Note [Herald for matchExpectedFunTys]                     -> UserTypeCtxt                     -> Arity                     -> ExpRhoType      -- Skolemised-                    -> ([Scaled ExpSigmaType] -> ExpRhoType -> TcM a)+                    -> ([Scaled ExpSigmaTypeFRR] -> ExpRhoType -> TcM a)                     -> TcM (HsWrapper, a)--- If    matchExpectedFunTys n ty = (_, wrap)+-- If    matchExpectedFunTys n ty = (wrap, _) -- then  wrap : (t1 -> ... -> tn -> ty_r) ~> ty, --   where [t1, ..., tn], ty_r are passed to the thing_inside matchExpectedFunTys herald ctx arity orig_ty thing_inside@@ -324,14 +397,14 @@       | Just ty' <- tcView ty = go acc_arg_tys n ty'      go acc_arg_tys n (FunTy { ft_mult = mult, ft_af = af, ft_arg = arg_ty, ft_res = res_ty })-      = ASSERT( af == VisArg )-        do { (wrap_res, result) <- go ((Scaled mult $ mkCheckExpType arg_ty) : acc_arg_tys)+      = assert (af == VisArg) $+        do { let arg_pos = 1 + length acc_arg_tys -- for error messages only+           ; (arg_co, arg_ty) <- hasFixedRuntimeRep (FRRExpectedFunTy herald arg_pos) arg_ty+           ; (wrap_res, result) <- go ((Scaled mult $ mkCheckExpType arg_ty) : acc_arg_tys)                                       (n-1) res_ty-           ; let fun_wrap = mkWpFun idHsWrapper wrap_res (Scaled mult arg_ty) res_ty doc-           ; return ( fun_wrap, result ) }-      where-        doc = text "When inferring the argument type of a function with type" <+>-              quotes (ppr orig_ty)+           ; let wrap_arg = mkWpCastN arg_co+                 fun_wrap = mkWpFun wrap_arg wrap_res (Scaled mult arg_ty) res_ty+           ; return (fun_wrap, result) }      go acc_arg_tys n ty@(TyVarTy tv)       | isMetaTyVar tv@@ -359,9 +432,10 @@                           defer acc_arg_tys n (mkCheckExpType ty)      -------------    defer :: [Scaled ExpSigmaType] -> Arity -> ExpRhoType -> TcM (HsWrapper, a)+    defer :: [Scaled ExpSigmaTypeFRR] -> Arity -> ExpRhoType -> TcM (HsWrapper, a)     defer acc_arg_tys n fun_ty-      = do { more_arg_tys <- replicateM n (mkScaled <$> newFlexiTyVarTy multiplicityTy <*> newInferExpType)+      = do { let last_acc_arg_pos = length acc_arg_tys+           ; more_arg_tys <- mapM new_exp_arg_ty [last_acc_arg_pos + 1 .. last_acc_arg_pos + n]            ; res_ty       <- newInferExpType            ; result       <- thing_inside (reverse acc_arg_tys ++ more_arg_tys) res_ty            ; more_arg_tys <- mapM (\(Scaled m t) -> Scaled m <$> readExpType t) more_arg_tys@@ -371,8 +445,13 @@                          -- Not a good origin at all :-(            ; return (wrap, result) } +    new_exp_arg_ty :: Int -> TcM (Scaled ExpSigmaTypeFRR)+    new_exp_arg_ty arg_pos -- position for error messages only+      = mkScaled <$> newFlexiTyVarTy multiplicityTy+                 <*> newInferExpTypeFRR (FRRExpectedFunTy herald arg_pos)+     -------------    mk_ctxt :: [Scaled ExpSigmaType] -> TcType -> TidyEnv -> TcM (TidyEnv, SDoc)+    mk_ctxt :: [Scaled ExpSigmaTypeFRR] -> TcType -> TidyEnv -> TcM (TidyEnv, SDoc)     mk_ctxt arg_tys res_ty env       = mkFunTysMsg env herald arg_tys' res_ty arity       where@@ -380,7 +459,9 @@                    reverse arg_tys             -- this is safe b/c we're called from "go" -mkFunTysMsg :: TidyEnv -> SDoc -> [Scaled TcType] -> TcType -> Arity+mkFunTysMsg :: TidyEnv+            -> ExpectedFunTyOrigin+            -> [Scaled TcType] -> TcType -> Arity             -> TcM (TidyEnv, SDoc) mkFunTysMsg env herald arg_tys res_ty n_val_args_in_call   = do { (env', fun_rho) <- zonkTidyTcType env $@@ -399,7 +480,8 @@         ; return (env', msg) }  where-  full_herald = herald <+> speakNOf n_val_args_in_call (text "value argument")+  full_herald = pprExpectedFunTyHerald herald+            <+> speakNOf n_val_args_in_call (text "value argument")  ---------------------- matchExpectedListTy :: TcRhoType -> TcM (TcCoercionN, TcRhoType)@@ -420,7 +502,7 @@ -- Postcondition: (T k1 k2 k3 a b c) is well-kinded  matchExpectedTyConApp tc orig_ty-  = ASSERT(not $ isFunTyCon tc) go orig_ty+  = assert (not $ isFunTyCon tc) $ go orig_ty   where     go ty        | Just ty' <- tcView ty@@ -494,6 +576,167 @@     kind2 = liftedTypeKind    -- m :: * -> k                               -- arg type :: * +{- **********************************************************************+*+                      fillInferResult+*+********************************************************************** -}++{- Note [inferResultToType]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+expTypeToType and inferResultType convert an InferResult to a monotype.+It must be a monotype because if the InferResult isn't already filled in,+we fill it in with a unification variable (hence monotype).  So to preserve+order-independence we check for mono-type-ness even if it *is* filled in+already.++See also Note [TcLevel of ExpType] in GHC.Tc.Utils.TcType, and+Note [fillInferResult].+-}++-- | Fill an 'InferResult' with the given type.+--+-- If @co = fillInferResult t1 infer_res@, then @co :: t1 ~# t2@,+-- where @t2@ is the type stored in the 'ir_ref' field of @infer_res@.+--+-- This function enforces the following invariants:+--+--  - Level invariant.+--    The stored type @t2@ is at the same level as given by the+--    'ir_lvl' field.+--  - FRR invariant.+--    Whenever the 'ir_frr' field is not @Nothing@, @t2@ is guaranteed+--    to have a syntactically fixed RuntimeRep, in the sense of+--    Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete.+fillInferResult :: TcType -> InferResult -> TcM TcCoercionN+fillInferResult act_res_ty (IR { ir_uniq = u+                               , ir_lvl  = res_lvl+                               , ir_frr  = mb_frr+                               , ir_ref  = ref })+  = do { mb_exp_res_ty <- readTcRef ref+       ; case mb_exp_res_ty of+            Just exp_res_ty+               -- We progressively refine the type stored in 'ref',+               -- for example when inferring types across multiple equations.+               --+               -- Example:+               --+               --  \ x -> case y of { True -> x ; False -> 3 :: Int }+               --+               -- When inferring the return type of this function, we will create+               -- an 'Infer' 'ExpType', which will first be filled by the type of 'x'+               -- after typechecking the first equation, and then filled again with+               -- the type 'Int', at which point we want to ensure that we unify+               -- the type of 'x' with 'Int'. This is what is happening below when+               -- we are "joining" several inferred 'ExpType's.+               -> do { traceTc "Joining inferred ExpType" $+                       ppr u <> colon <+> ppr act_res_ty <+> char '~' <+> ppr exp_res_ty+                     ; cur_lvl <- getTcLevel+                     ; unless (cur_lvl `sameDepthAs` res_lvl) $+                       ensureMonoType act_res_ty+                     ; unifyType Nothing act_res_ty exp_res_ty }+            Nothing+               -> do { traceTc "Filling inferred ExpType" $+                       ppr u <+> text ":=" <+> ppr act_res_ty++                     -- Enforce the level invariant: ensure the TcLevel of+                     -- the type we are writing to 'ref' matches 'ir_lvl'.+                     ; (prom_co, act_res_ty) <- promoteTcType res_lvl act_res_ty++                     -- Enforce the FRR invariant: ensure the type has a syntactically+                     -- fixed RuntimeRep (if necessary, i.e. 'mb_frr' is not 'Nothing').+                     ; (frr_co, act_res_ty) <-+                         case mb_frr of+                           Nothing       -> return (mkNomReflCo act_res_ty, act_res_ty)+                           Just frr_orig -> hasFixedRuntimeRep frr_orig act_res_ty++                     -- Compose the two coercions.+                     ; let final_co = prom_co `mkTcTransCo` frr_co++                     ; writeTcRef ref (Just act_res_ty)++                     ; return final_co }+     }++{- Note [fillInferResult]+~~~~~~~~~~~~~~~~~~~~~~~~~+When inferring, we use fillInferResult to "fill in" the hole in InferResult+   data InferResult = IR { ir_uniq :: Unique+                         , ir_lvl  :: TcLevel+                         , ir_ref  :: IORef (Maybe TcType) }++There are two things to worry about:++1. What if it is under a GADT or existential pattern match?+   - GADTs: a unification variable (and Infer's hole is similar) is untouchable+   - Existentials: be careful about skolem-escape++2. What if it is filled in more than once?  E.g. multiple branches of a case+     case e of+        T1 -> e1+        T2 -> e2++Our typing rules are:++* The RHS of a existential or GADT alternative must always be a+  monotype, regardless of the number of alternatives.++* Multiple non-existential/GADT branches can have (the same)+  higher rank type (#18412).  E.g. this is OK:+      case e of+        True  -> hr+        False -> hr+  where hr:: (forall a. a->a) -> Int+  c.f. Section 7.1 of "Practical type inference for arbitrary-rank types"+       We use choice (2) in that Section.+       (GHC 8.10 and earlier used choice (1).)++  But note that+      case e of+        True  -> hr+        False -> \x -> hr x+  will fail, because we still /infer/ both branches, so the \x will get+  a (monotype) unification variable, which will fail to unify with+  (forall a. a->a)++For (1) we can detect the GADT/existential situation by seeing that+the current TcLevel is greater than that stored in ir_lvl of the Infer+ExpType.  We bump the level whenever we go past a GADT/existential match.++Then, before filling the hole use promoteTcType to promote the type+to the outer ir_lvl.  promoteTcType does this+  - create a fresh unification variable alpha at level ir_lvl+  - emits an equality alpha[ir_lvl] ~ ty+  - fills the hole with alpha+That forces the type to be a monotype (since unification variables can+only unify with monotypes); and catches skolem-escapes because the+alpha is untouchable until the equality floats out.++For (2), we simply look to see if the hole is filled already.+  - if not, we promote (as above) and fill the hole+  - if it is filled, we simply unify with the type that is+    already there++There is one wrinkle.  Suppose we have+   case e of+      T1 -> e1 :: (forall a. a->a) -> Int+      G2 -> e2+where T1 is not GADT or existential, but G2 is a GADT.  Then supppose the+T1 alternative fills the hole with (forall a. a->a) -> Int, which is fine.+But now the G2 alternative must not *just* unify with that else we'd risk+allowing through (e2 :: (forall a. a->a) -> Int).  If we'd checked G2 first+we'd have filled the hole with a unification variable, which enforces a+monotype.++So if we check G2 second, we still want to emit a constraint that restricts+the RHS to be a monotype. This is done by ensureMonoType, and it works+by simply generating a constraint (alpha ~ ty), where alpha is a fresh+unification variable.  We discard the evidence.++-}+++ {- ************************************************************************ *                                                                      *@@ -559,7 +802,7 @@ tcWrapResultO orig rn_expr expr actual_ty res_ty   = do { traceTc "tcWrapResult" (vcat [ text "Actual:  " <+> ppr actual_ty                                       , text "Expected:" <+> ppr res_ty ])-       ; wrap <- tcSubTypeNC orig GenSigCtxt (Just (ppr rn_expr)) actual_ty res_ty+       ; wrap <- tcSubTypeNC orig GenSigCtxt (Just $ HsExprRnThing rn_expr) actual_ty res_ty        ; return (mkHsWrap wrap expr) }  tcWrapResultMono :: HsExpr GhcRn -> HsExpr GhcTc@@ -570,7 +813,7 @@ -- rho-type, so nothing to instantiate; just go straight to unify. -- It means we don't need to pass in a CtOrigin tcWrapResultMono rn_expr expr act_ty res_ty-  = ASSERT2( isRhoTy act_ty, ppr act_ty $$ ppr rn_expr )+  = assertPpr (isRhoTy act_ty) (ppr act_ty $$ ppr rn_expr) $     do { co <- unifyExpectedType rn_expr act_ty res_ty        ; return (mkHsWrapCo co expr) } @@ -581,7 +824,7 @@ unifyExpectedType rn_expr act_ty exp_ty   = case exp_ty of       Infer inf_res -> fillInferResult act_ty inf_res-      Check exp_ty  -> unifyType (Just (ppr rn_expr)) act_ty exp_ty+      Check exp_ty  -> unifyType (Just $ HsExprRnThing rn_expr) act_ty exp_ty  ------------------------ tcSubTypePat :: CtOrigin -> UserTypeCtxt@@ -591,8 +834,7 @@ -- If wrap = tc_sub_type_et t1 t2 --    => wrap :: t1 ~> t2 tcSubTypePat inst_orig ctxt (Check ty_actual) ty_expected-  = do { dflags <- getDynFlags-       ; tc_sub_type dflags unifyTypeET inst_orig ctxt ty_actual ty_expected }+  = tc_sub_type unifyTypeET inst_orig ctxt ty_actual ty_expected  tcSubTypePat _ _ (Infer inf_res) ty_expected   = do { co <- fillInferResult ty_expected inf_res@@ -602,8 +844,8 @@  --------------- tcSubType :: CtOrigin -> UserTypeCtxt-          -> TcSigmaType  -- Actual-          -> ExpRhoType   -- Expected+          -> TcSigmaType  -- ^ Actual+          -> ExpRhoType   -- ^ Expected           -> TcM HsWrapper -- Checks that 'actual' is more polymorphic than 'expected' tcSubType orig ctxt ty_actual ty_expected@@ -612,37 +854,16 @@        ; tcSubTypeNC orig ctxt Nothing ty_actual ty_expected }  ----------------tcSubTypeDS :: HsExpr GhcRn-            -> TcRhoType   -- Actual -- a rho-type not a sigma-type-            -> ExpRhoType  -- Expected-            -> TcM HsWrapper--- Similar signature to unifyExpectedType; does deep subsumption--- Only one call site, in GHC.Tc.Gen.App.tcApp-tcSubTypeDS rn_expr act_rho res_ty-  = case res_ty of-      Check exp_rho -> do { dflags <- getDynFlags-                          ; tc_sub_type_deep dflags (unifyType m_thing) orig-                                        GenSigCtxt act_rho exp_rho-                          }--      Infer inf_res -> do { co <- fillInferResult act_rho inf_res-                          ; return (mkWpCastN co) }-  where-    orig    = exprCtOrigin rn_expr-    m_thing = Just (ppr rn_expr)----------------- tcSubTypeNC :: CtOrigin          -- ^ Used when instantiating             -> UserTypeCtxt      -- ^ Used when skolemising-            -> Maybe SDoc        -- ^ The expression that has type 'actual' (if known)+            -> Maybe TypedThing -- ^ The expression that has type 'actual' (if known)             -> TcSigmaType       -- ^ Actual type             -> ExpRhoType        -- ^ Expected type             -> TcM HsWrapper tcSubTypeNC inst_orig ctxt m_thing ty_actual res_ty   = case res_ty of-      Check ty_expected -> do { dflags <- getDynFlags-                              ; tc_sub_type dflags (unifyType m_thing) inst_orig ctxt-                                            ty_actual ty_expected }+      Check ty_expected -> tc_sub_type (unifyType m_thing) inst_orig ctxt+                                       ty_actual ty_expected        Infer inf_res -> do { (wrap, rho) <- topInstantiate inst_orig ty_actual                                    -- See Note [Instantiation of InferResult]@@ -658,20 +879,16 @@ -- Checks that actual <= expected -- Returns HsWrapper :: actual ~ expected tcSubTypeSigma orig ctxt ty_actual ty_expected-  = do { dflags <- getDynFlags-       ; tc_sub_type dflags (unifyType Nothing) orig ctxt ty_actual ty_expected-       }+  = tc_sub_type (unifyType Nothing) orig ctxt ty_actual ty_expected  --------------- tcSubTypeAmbiguity :: UserTypeCtxt   -- Where did this type arise                    -> TcSigmaType -> TcSigmaType -> TcM HsWrapper -- See Note [Ambiguity check and deep subsumption] tcSubTypeAmbiguity ctxt ty_actual ty_expected-  = do { dflags <- getDynFlags-       ; tc_sub_type_shallow dflags (unifyType Nothing)+  = tc_sub_type_shallow (unifyType Nothing)                         (AmbiguityCheckOrigin ctxt)                         ctxt ty_actual ty_expected-       }  --------------- addSubTypeCtxt :: TcType -> ExpType -> TcM a -> TcM a@@ -733,8 +950,7 @@  --------------- tc_sub_type, tc_sub_type_deep, tc_sub_type_shallow-    :: DynFlags-    -> (TcType -> TcType -> TcM TcCoercionN)  -- How to unify+    :: (TcType -> TcType -> TcM TcCoercionN)  -- How to unify     -> CtOrigin       -- Used when instantiating     -> UserTypeCtxt   -- Used when skolemising     -> TcSigmaType    -- Actual; a sigma-type@@ -749,16 +965,16 @@ -- the argument types and context.  -----------------------tc_sub_type dflags unify inst_orig ctxt ty_actual ty_expected+tc_sub_type unify inst_orig ctxt ty_actual ty_expected   = do { deep_subsumption <- xoptM LangExt.DeepSubsumption        ; if deep_subsumption-         then tc_sub_type_deep    dflags unify inst_orig ctxt ty_actual ty_expected-         else tc_sub_type_shallow dflags unify inst_orig ctxt ty_actual ty_expected+         then tc_sub_type_deep    unify inst_orig ctxt ty_actual ty_expected+         else tc_sub_type_shallow unify inst_orig ctxt ty_actual ty_expected   }  -----------------------tc_sub_type_shallow dflags unify inst_orig ctxt ty_actual ty_expected-  | definitely_poly dflags ty_expected   -- See Note [Don't skolemise unnecessarily]+tc_sub_type_shallow unify inst_orig ctxt ty_actual ty_expected+  | definitely_poly ty_expected   -- See Note [Don't skolemise unnecessarily]   , definitely_mono_shallow ty_actual   = do { traceTc "tc_sub_type (drop to equality)" $          vcat [ text "ty_actual   =" <+> ppr ty_actual@@ -780,8 +996,8 @@        ; return (sk_wrap <.> inner_wrap) }  -----------------------tc_sub_type_deep dflags unify inst_orig ctxt ty_actual ty_expected-  | definitely_poly dflags ty_expected      -- See Note [Don't skolemise unnecessarily]+tc_sub_type_deep unify inst_orig ctxt ty_actual ty_expected+  | definitely_poly ty_expected      -- See Note [Don't skolemise unnecessarily]   , definitely_mono_deep ty_actual   = do { traceTc "tc_sub_type_deep (drop to equality)" $          vcat [ text "ty_actual   =" <+> ppr ty_actual@@ -813,14 +1029,14 @@     -- Top level (->)   | otherwise                              = True -definitely_poly :: DynFlags -> TcType -> Bool+definitely_poly :: TcType -> Bool -- A very conservative test: -- see Note [Don't skolemise unnecessarily]-definitely_poly dflags ty+definitely_poly ty   | (tvs, theta, tau) <- tcSplitSigmaTy ty   , (tv:_) <- tvs   -- At least one tyvar   , null theta      -- No constraints; see (DP1)-  , checkTyVarEq dflags tv tau `cterHasProblem` cteInsolubleOccurs+  , checkTyVarEq tv tau `cterHasProblem` cteInsolubleOccurs        -- The tyvar actually occurs (DP2),        --     and occurs in an injective position (DP3).        -- Fortunately checkTyVarEq, used for the occur check,@@ -866,7 +1082,7 @@ returned by tcSubMult (and derived functions such as tcCheckUsage and checkManyPattern) is quite unlike any other wrapper: it checks whether the coercion produced by the constraint solver is trivial, producing a type error-is it is not. This is implemented via the WpMultCoercion wrapper, as desugared+if it is not. This is implemented via the WpMultCoercion wrapper, as desugared by GHC.HsToCore.Binds.dsHsWrapper, which does the reflexivity check.  This wrapper needs to be placed in the term; otherwise, checking of the@@ -875,11 +1091,14 @@  Why do we check this in the desugarer? It's a convenient place, since it's right after all the constraints are solved. We need the constraints to be-solved to check whether they are trivial or not. Plus there is precedent for-type errors during desuraging (such as the levity polymorphism-restriction). An alternative would be to have a kind of constraint which can-only produce trivial evidence, then this check would happen in the constraint-solver.+solved to check whether they are trivial or not.++An alternative would be to have a kind of constraint which can+only produce trivial evidence. This would allow such checks to happen+in the constraint solver (#18756).+This would be similar to the existing setup for Concrete, see+  Note [The Concrete mechanism] in GHC.Tc.Utils.Concrete+    (PHASE 1 in particular). -}  tcSubMult :: CtOrigin -> Mult -> Mult -> TcM HsWrapper@@ -935,7 +1154,7 @@    signatures (e.g. f :: ty; f = e), we must deeply skolemise the type;    see the call to tcDeeplySkolemise in tcSkolemiseScoped. -4. In GHC.Tc.Gen.App.tcApp we call tcSubTypeDS to match the result+4. In GHC.Tc.Gen.App.tcApp we call tcSubTypeNC to match the result    type. Without deep subsumption, unifyExpectedType would be sufficent.  In all these cases note that the deep skolemisation must be done /first/.@@ -1062,16 +1281,13 @@       | otherwise       = -- This is where we do the co/contra thing, and generate a WpFun, which in turn         -- causes eta-expansion, which we don't like; hence encouraging NoDeepSubsumption-        do { dflags <- getDynFlags-           ; arg_wrap  <- tc_sub_type_deep dflags unify given_orig GenSigCtxt exp_arg act_arg+        do { arg_wrap  <- tc_sub_type_deep unify given_orig GenSigCtxt exp_arg act_arg                           -- GenSigCtxt: See Note [Setting the argument context]            ; res_wrap  <- tc_sub_type_ds   unify inst_orig  ctxt       act_res exp_res            ; mult_wrap <- tcEqMult inst_orig act_mult exp_mult                           -- See Note [Multiplicity in deep subsumption]-           ; let doc = text "When checking that" <+> quotes (ppr ty_actual)-                   <+> text "is more polymorphic than" <+> quotes (ppr ty_expected)            ; return (mult_wrap <.>-                     mkWpFun arg_wrap res_wrap (Scaled exp_mult exp_arg) exp_res doc)}+                     mkWpFun arg_wrap res_wrap (Scaled exp_mult exp_arg) exp_res) }                      -- arg_wrap :: exp_arg ~> act_arg                      -- res_wrap :: act-res ~> exp_res       where@@ -1111,26 +1327,29 @@   = do { res <- thing_inside expected_ty        ; return (idHsWrapper, res) }   | otherwise-  = do  { (wrap, tv_prs, given, rho_ty) <- deeplySkolemise expected_ty-        ; let skol_info = SigSkol ctxt expected_ty tv_prs+  = do  { -- This (unpleasant) rec block allows us to pass skol_info to deeplySkolemise;+          -- but skol_info can't be built until we have tv_prs+          rec { (wrap, tv_prs, given, rho_ty) <- deeplySkolemise skol_info expected_ty+              ; skol_info <- mkSkolemInfo (SigSkol ctxt expected_ty tv_prs) }+         ; traceTc "tcDeeplySkolemise" (ppr expected_ty $$ ppr rho_ty $$ ppr tv_prs)          ; let skol_tvs  = map snd tv_prs         ; (ev_binds, result)-              <- checkConstraints skol_info skol_tvs given $+              <- checkConstraints (getSkolemInfo skol_info) skol_tvs given $                  thing_inside rho_ty          ; return (wrap <.> mkWpLet ev_binds, result) }           -- The ev_binds returned by checkConstraints is very           -- often empty, in which case mkWpLet is a no-op -deeplySkolemise :: TcSigmaType+deeplySkolemise :: SkolemInfo -> TcSigmaType                 -> TcM ( HsWrapper                        , [(Name,TyVar)]     -- All skolemised variables                        , [EvVar]            -- All "given"s                        , TcRhoType ) -- See Note [Deep skolemisation]-deeplySkolemise ty+deeplySkolemise skol_info ty   = go init_subst ty   where     init_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType ty))@@ -1139,7 +1358,7 @@       | Just (arg_tys, tvs, theta, ty') <- tcDeepSplitSigmaTy_maybe ty       = do { let arg_tys' = substScaledTys subst arg_tys            ; ids1           <- newSysLocalIds (fsLit "dk") arg_tys'-           ; (subst', tvs1) <- tcInstSkolTyVarsX subst tvs+           ; (subst', tvs1) <- tcInstSkolTyVarsX skol_info subst tvs            ; ev_vars1       <- newEvVars (substTheta subst' theta)            ; (wrap, tvs_prs2, ev_vars2, rho) <- go subst' ty'            ; let tv_prs1 = map tyVarName tvs `zip` tvs1@@ -1246,12 +1465,14 @@   = do { deep_subsumption <- xoptM LangExt.DeepSubsumption        ; let skolemise | deep_subsumption = deeplySkolemise                        | otherwise        = topSkolemise-       ; (wrap, tv_prs, given, rho_ty) <- skolemise expected_ty+       ; -- This (unpleasant) rec block allows us to pass skol_info to deeplySkolemise;+         -- but skol_info can't be built until we have tv_prs+         rec { (wrap, tv_prs, given, rho_ty) <- skolemise skol_info expected_ty+             ; skol_info <- mkSkolemInfo (SigSkol ctxt expected_ty tv_prs) }         ; let skol_tvs = map snd tv_prs-             skol_info = SigSkol ctxt expected_ty tv_prs        ; (ev_binds, res)-             <- checkConstraints skol_info skol_tvs given $+             <- checkConstraints (getSkolemInfo skol_info) skol_tvs given $                 tcExtendNameTyVarEnv tv_prs               $                 thing_inside rho_ty @@ -1262,13 +1483,12 @@   = do { res <- thing_inside expected_ty        ; return (idHsWrapper, res) }   | otherwise-  = do { rec { let skol_info = SigSkol ctxt expected_ty tv_prs-             ; (wrap, tv_prs, given, rho_ty) <- topSkolemise expected_ty-             }+  = do { rec { (wrap, tv_prs, given, rho_ty) <- topSkolemise skol_info expected_ty+             ; skol_info <- mkSkolemInfo (SigSkol ctxt expected_ty tv_prs) }         ; let skol_tvs = map snd tv_prs        ; (ev_binds, result)-             <- checkConstraints skol_info skol_tvs given $+             <- checkConstraints (getSkolemInfo skol_info) skol_tvs given $                 thing_inside rho_ty         ; return (wrap <.> mkWpLet ev_binds, result) }@@ -1288,7 +1508,7 @@        ; skolemise ctxt ty $ \rho_ty ->          thing_inside (mkCheckExpType rho_ty) } -checkConstraints :: SkolemInfo+checkConstraints :: SkolemInfoAnon                  -> [TcTyVar]           -- Skolems                  -> [EvVar]             -- Given                  -> TcM result@@ -1324,33 +1544,39 @@                          -> TcLevel -> WantedConstraints -> TcM () emitResidualTvConstraint skol_info skol_tvs tclvl wanted   | not (isEmptyWC wanted) ||-    checkTelescopeSkol skol_info+    checkTelescopeSkol skol_info_anon   = -- checkTelescopeSkol: in this case, /always/ emit this implication     -- even if 'wanted' is empty. We need the implication so that we check     -- for a bad telescope. See Note [Skolem escape and forall-types] in     -- GHC.Tc.Gen.HsType-    do { implic <- buildTvImplication skol_info skol_tvs tclvl wanted+    do { implic <- buildTvImplication skol_info_anon skol_tvs tclvl wanted        ; emitImplication implic }    | otherwise  -- Empty 'wanted', emit nothing   = return ()+  where+     skol_info_anon = getSkolemInfo skol_info -buildTvImplication :: SkolemInfo -> [TcTyVar]+buildTvImplication :: SkolemInfoAnon -> [TcTyVar]                    -> TcLevel -> WantedConstraints -> TcM Implication buildTvImplication skol_info skol_tvs tclvl wanted-  = do { ev_binds <- newNoTcEvBinds  -- Used for equalities only, so all the constraints+  = assertPpr (all (isSkolemTyVar <||> isTyVarTyVar) skol_tvs) (ppr skol_tvs) $+    do { ev_binds <- newNoTcEvBinds  -- Used for equalities only, so all the constraints                                      -- are solved by filling in coercion holes, not                                      -- by creating a value-level evidence binding        ; implic   <- newImplication -       ; return (implic { ic_tclvl     = tclvl-                        , ic_skols     = skol_tvs-                        , ic_given_eqs = NoGivenEqs-                        , ic_wanted    = wanted-                        , ic_binds     = ev_binds-                        , ic_info      = skol_info }) }+       ; let implic' = implic { ic_tclvl     = tclvl+                              , ic_skols     = skol_tvs+                              , ic_given_eqs = NoGivenEqs+                              , ic_wanted    = wanted+                              , ic_binds     = ev_binds+                              , ic_info      = skol_info } -implicationNeeded :: SkolemInfo -> [TcTyVar] -> [EvVar] -> TcM Bool+       ; checkImplicationInvariants implic'+       ; return implic' }++implicationNeeded :: SkolemInfoAnon -> [TcTyVar] -> [EvVar] -> TcM Bool -- See Note [When to build an implication] implicationNeeded skol_info skol_tvs given   | null skol_tvs@@ -1370,7 +1596,7 @@   | otherwise     -- Non-empty skolems or givens   = return True   -- Definitely need an implication -alwaysBuildImplication :: SkolemInfo -> Bool+alwaysBuildImplication :: SkolemInfoAnon -> Bool -- See Note [When to build an implication] alwaysBuildImplication _ = False @@ -1387,7 +1613,7 @@ alwaysBuildImplication _                  = False -} -buildImplicationFor :: TcLevel -> SkolemInfo -> [TcTyVar]+buildImplicationFor :: TcLevel -> SkolemInfoAnon -> [TcTyVar]                    -> [EvVar] -> WantedConstraints                    -> TcM (Bag Implication, TcEvBinds) buildImplicationFor tclvl skol_info skol_tvs given wanted@@ -1399,7 +1625,7 @@   = return (emptyBag, emptyTcEvBinds)    | otherwise-  = ASSERT2( all (isSkolemTyVar <||> isTyVarTyVar) skol_tvs, ppr skol_tvs )+  = assertPpr (all (isSkolemTyVar <||> isTyVarTyVar) skol_tvs) (ppr skol_tvs) $       -- Why allow TyVarTvs? Because implicitly declared kind variables in       -- non-CUSK type declarations are TyVarTvs, and we need to bring them       -- into scope as a skolem in an implication. This is OK, though,@@ -1412,6 +1638,7 @@                               , ic_wanted = wanted                               , ic_binds  = ev_binds_var                               , ic_info   = skol_info }+       ; checkImplicationInvariants implic'         ; return (unitBag implic', TcEvBinds ev_binds_var) } @@ -1441,7 +1668,7 @@   can yield /very/ confusing error messages, because we can get       [W] C Int b1    -- from f_blah       [W] C Int b2    -- from g_blan-  and fundpes can yield [D] b1 ~ b2, even though the two functions have+  and fundpes can yield [W] b1 ~ b2, even though the two functions have   literally nothing to do with each other.  #14185 is an example.   Building an implication keeps them separate. -}@@ -1457,7 +1684,7 @@ non-exported generic functions. -} -unifyType :: Maybe SDoc  -- ^ If present, the thing that has type ty1+unifyType :: Maybe TypedThing  -- ^ If present, the thing that has type ty1           -> TcTauType -> TcTauType    -- ty1, ty2           -> TcM TcCoercionN           -- :: ty1 ~# ty2 -- Actual and expected types@@ -1467,7 +1694,7 @@   where     origin = TypeEqOrigin { uo_actual   = ty1                           , uo_expected = ty2-                          , uo_thing    = ppr <$> thing+                          , uo_thing    = thing                           , uo_visible  = True }  unifyTypeET :: TcTauType -> TcTauType -> TcM CoercionN@@ -1482,7 +1709,7 @@                           , uo_visible  = True }  -unifyKind :: Maybe SDoc -> TcKind -> TcKind -> TcM CoercionN+unifyKind :: Maybe TypedThing -> TcKind -> TcKind -> TcM CoercionN unifyKind mb_thing ty1 ty2   = uType KindLevel origin ty1 ty2   where@@ -1610,7 +1837,7 @@     go (TyConApp tc1 tys1) (TyConApp tc2 tys2)       -- See Note [Mismatched type lists and application decomposition]       | tc1 == tc2, equalLength tys1 tys2-      = ASSERT2( isGenerativeTyCon tc1 Nominal, ppr tc1 )+      = assertPpr (isGenerativeTyCon tc1 Nominal) (ppr tc1) $         do { cos <- zipWith3M (uType t_or_k) origins' tys1 tys2            ; return $ mkTyConAppCo Nominal tc1 cos }       where@@ -1629,12 +1856,12 @@      go (AppTy s1 t1) (TyConApp tc2 ts2)       | Just (ts2', t2') <- snocView ts2-      = ASSERT( not (mustBeSaturated tc2) )+      = assert (not (mustBeSaturated tc2)) $         go_app (isNextTyConArgVisible tc2 ts2') s1 t1 (TyConApp tc2 ts2') t2'      go (TyConApp tc1 ts1) (AppTy s2 t2)       | Just (ts1', t1') <- snocView ts1-      = ASSERT( not (mustBeSaturated tc1) )+      = assert (not (mustBeSaturated tc1)) $         go_app (isNextTyConArgVisible tc1 ts1') (TyConApp tc1 ts1') t1' s2 t2      go (CoercionTy co1) (CoercionTy co2)@@ -1745,7 +1972,6 @@ synonyms have already been expanded via tcCoreView).  This is, as usual, to improve error messages. - ************************************************************************ *                                                                      *                  uUnfilledVar and friends@@ -1821,17 +2047,19 @@               -> TcTauType      -- Type 2, zonked               -> TcM Coercion uUnfilledVar2 origin t_or_k swapped tv1 ty2-  = do { dflags  <- getDynFlags-       ; cur_lvl <- getTcLevel-       ; go dflags cur_lvl }+  = do { cur_lvl <- getTcLevel+       ; go cur_lvl }   where-    go dflags cur_lvl+    go cur_lvl       | isTouchableMetaTyVar cur_lvl tv1            -- See Note [Unification preconditions], (UNTOUCHABLE) wrinkles-      , canSolveByUnification (metaTyVarInfo tv1) ty2-      , cterHasNoProblem (checkTyVarEq dflags tv1 ty2)+      , cterHasNoProblem (checkTyVarEq tv1 ty2)            -- See Note [Prevent unification with type families]-      = do { co_k <- uType KindLevel kind_origin (tcTypeKind ty2) (tyVarKind tv1)+      = do { can_continue_solving <- startSolvingByUnification (metaTyVarInfo tv1) ty2+           ; if not can_continue_solving+             then not_ok_so_defer+             else+        do { co_k <- uType KindLevel kind_origin (tcTypeKind ty2) (tyVarKind tv1)            ; traceTc "uUnfilledVar2 ok" $              vcat [ ppr tv1 <+> dcolon <+> ppr (tyVarKind tv1)                   , ppr ty2 <+> dcolon <+> ppr (tcTypeKind  ty2)@@ -1844,36 +2072,61 @@              then do { writeMetaTyVar tv1 ty2                      ; return (mkTcNomReflCo ty2) } -             else defer } -- This cannot be solved now.  See GHC.Tc.Solver.Canonical-                          -- Note [Equalities with incompatible kinds]+             else defer }} -- This cannot be solved now.  See GHC.Tc.Solver.Canonical+                           -- Note [Equalities with incompatible kinds] for how+                           -- this will be dealt with in the solver        | otherwise-      = do { traceTc "uUnfilledVar2 not ok" (ppr tv1 $$ ppr ty2)-               -- Occurs check or an untouchable: just defer-               -- NB: occurs check isn't necessarily fatal:-               --     eg tv1 occurred in type family parameter-            ; defer }+      = not_ok_so_defer      ty1 = mkTyVarTy tv1     kind_origin = KindEqOrigin ty1 ty2 origin (Just t_or_k)      defer = unSwap swapped (uType_defer t_or_k origin) ty1 ty2 -canSolveByUnification :: MetaInfo -> TcType -> Bool--- See Note [Unification preconditions, (TYVAR-TV)]-canSolveByUnification info xi+    not_ok_so_defer =+      do { traceTc "uUnfilledVar2 not ok" (ppr tv1 $$ ppr ty2)+               -- Occurs check or an untouchable: just defer+               -- NB: occurs check isn't necessarily fatal:+               --     eg tv1 occurred in type family parameter+          ; defer }++-- | Checks (TYVAR-TV), (COERCION-HOLE) and (CONCRETE) of+-- Note [Unification preconditions]; returns True if these conditions+-- are satisfied. But see the Note for other preconditions, too.+startSolvingByUnification :: MetaInfo -> TcType  -- zonked+                          -> TcM Bool+startSolvingByUnification _ xi+  | hasCoercionHoleTy xi  -- (COERCION-HOLE) check+  = return False+startSolvingByUnification info xi   = case info of-      CycleBreakerTv -> False-      TyVarTv -> case tcGetTyVar_maybe xi of-                   Nothing -> False-                   Just tv -> case tcTyVarDetails tv of-                                 MetaTv { mtv_info = info }-                                            -> case info of-                                                 TyVarTv -> True-                                                 _       -> False-                                 SkolemTv {} -> True-                                 RuntimeUnk  -> True-      _ -> True+      CycleBreakerTv -> return False+      ConcreteTv conc_orig ->+        do { (_, not_conc_reasons) <- makeTypeConcrete conc_orig xi+                 -- NB: makeTypeConcrete has the side-effect of turning+                 -- some TauTvs into ConcreteTvs, e.g.+                 -- alpha[conc] ~# TYPE (TupleRep '[ beta[tau], IntRep ])+                 -- will write `beta[tau] := beta[conc]`.+                 --+                 -- We don't need to track these unifications for the purposes+                 -- of constraint solving (e.g. updating tcs_unified or tcs_unif_lvl),+                 -- as they don't unlock any further progress.+           ; case not_conc_reasons of+               [] -> return True+               _  -> return False }+      TyVarTv ->+        case tcGetTyVar_maybe xi of+           Nothing -> return False+           Just tv ->+             case tcTyVarDetails tv of -- (TYVAR-TV) wrinkle+                SkolemTv {} -> return True+                RuntimeUnk  -> return True+                MetaTv { mtv_info = info } ->+                  case info of+                    TyVarTv -> return True+                    _       -> return False+      _ -> return True  swapOverTyVars :: Bool -> TcTyVar -> TcTyVar -> Bool swapOverTyVars is_given tv1 tv2@@ -1908,15 +2161,16 @@ --        => more likely to be eliminated -- See Note [TyVar/TyVar orientation] lhsPriority tv-  = ASSERT2( isTyVar tv, ppr tv)+  = assertPpr (isTyVar tv) (ppr tv) $     case tcTyVarDetails tv of       RuntimeUnk  -> 0       SkolemTv {} -> 0       MetaTv { mtv_info = info } -> case info of                                      CycleBreakerTv -> 0                                      TyVarTv        -> 1-                                     TauTv          -> 2-                                     RuntimeUnkTv   -> 3+                                     ConcreteTv {}  -> 2+                                     TauTv          -> 3+                                     RuntimeUnkTv   -> 4  {- Note [Unification preconditions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1926,7 +2180,7 @@ This note only applied to /homogeneous/ equalities, in which both sides have the same kind. -There are three reasons not to unify:+There are five reasons not to unify:  1. (SKOL-ESC) Skolem-escape    Consider the constraint@@ -1952,7 +2206,7 @@    between levels 'n' and 'l'.     Exactly what is a "given equality" for the purpose of (UNTOUCHABLE)?-   Answer: see Note [Tracking Given equalities] in GHC.Tc.Solver.Monad+   Answer: see Note [Tracking Given equalities] in GHC.Tc.Solver.InertSet  3. (TYVAR-TV) Unifying TyVarTvs and CycleBreakerTvs    This precondition looks at the MetaInfo of the unification variable:@@ -1964,9 +2218,41 @@     * CycleBreakerTv: never unified, except by restoreTyVarCycles. +4. (CONCRETE) A ConcreteTv can only unify with a concrete type,+    by definition. -Needless to say, all three have wrinkles:+    That is, if we have `rr[conc] ~ F Int`, we can't unify+    `rr` with `F Int`, so we hold off on unifying.+    Note however that the equality might get rewritten; for instance+    if we can rewrite `F Int` to a concrete type, say `FloatRep`,+    then we will have `rr[conc] ~ FloatRep` and we can unify `rr ~ FloatRep`. +    Note that we can still make progress on unification even if+    we can't fully solve an equality, e.g.++      alpha[conc] ~# TupleRep '[ beta[tau], F gamma[tau] ]++    we can fill beta[tau] := beta[conc]. This is why we call+    'makeTypeConcrete' in startSolvingByUnification.++5. (COERCION-HOLE) Confusing coercion holes+   Suppose our equality is+     (alpha :: k) ~ (Int |> {co})+   where co :: Type ~ k is an unsolved wanted. Note that this+   equality is homogeneous; both sides have kind k. Unifying here+   is sensible, but it can lead to very confusing error messages.+   It's very much like a Wanted rewriting a Wanted. Even worse,+   unifying a variable essentially turns an equality into a Given,+   and so we could not use the tracking mechansim in+   Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint.+   We thus simply do not unify in this case.++   This is expanded as Wrinkle (2) in Note [Equalities with incompatible kinds]+   in GHC.Tc.Solver.Canonical.+++Needless to say, all there are wrinkles:+ * (SKOL-ESC) Promotion.  Given alpha[n] ~ ty, what if beta[k] is free   in 'ty', where beta is a unification variable, and k>n?  'beta'   stands for a monotype, and since it is part of a level-n type@@ -1993,7 +2279,7 @@     isTouchableMetaTyVar.    * In the constraint solver, we track where Given equalities occur-    and use that to guard unification in GHC.Tc.Solver.Canonical.unifyTest+    and use that to guard unification in GHC.Tc.Solver.Canonical.touchabilityTest     More details in Note [Tracking Given equalities] in GHC.Tc.Solver.InertSet      Historical note: in the olden days (pre 2021) the constraint solver@@ -2027,7 +2313,7 @@   Generally speaking we always try to put a MetaTv on the left   in preference to SkolemTv or RuntimeUnkTv:      a) Because the MetaTv may be touchable and can be unified-     b) Even if it's not touchable, GHC.Tc.Solver.floatEqualities+     b) Even if it's not touchable, GHC.Tc.Solver.floatConstraints         looks for meta tyvars on the left    Tie-breaking rules for MetaTvs:@@ -2038,12 +2324,16 @@        a TyVarTv with a TauTv, because then the TyVarTv could (transitively)        get a non-tyvar type. So give these a low priority: 1. +  - ConcreteTv: These are like TauTv, except they can only unify with+    a concrete type. So we want to be able to write to them, but not quite+    as much as TauTvs: 2.+   - TauTv: This is the common case; we want these on the left so that they-       can be written to: 2.+       can be written to: 3.    - RuntimeUnkTv: These aren't really meta-variables used in type inference,        but just a convenience in the implementation of the GHCi debugger.-       Eagerly write to these: 3. See Note [RuntimeUnkTv] in+       Eagerly write to these: 4. See Note [RuntimeUnkTv] in        GHC.Runtime.Heap.Inspect.  * Names. If the level and priority comparisons are all@@ -2090,7 +2380,7 @@   Otherwise it can't.  By putting the deepest variable on the left   we maximise our changes of eliminating skolem capture. -  See also GHC.Tc.Solver.Monad Note [Let-bound skolems] for another reason+  See also GHC.Tc.Solver.InertSet Note [Let-bound skolems] for another reason   to orient with the deepest skolem on the left.    IMPORTANT NOTE: this test does a level-number comparison on@@ -2151,38 +2441,6 @@ Revisited in Nov '20, along with removing flattening variables. Problem is still present, and the solution is still the same. -Note [Refactoring hazard: metaTyVarUpdateOK]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-I (Richard E.) have a sad story about refactoring this code, retained here-to prevent others (or a future me!) from falling into the same traps.--It all started with #11407, which was caused by the fact that the TyVarTy-case of defer_me didn't look in the kind. But it seemed reasonable to-simply remove the defer_me check instead.--It referred to two Notes (since removed) that were out of date, and the-fast_check code in occurCheckExpand seemed to do just about the same thing as-defer_me. The one piece that defer_me did that wasn't repeated by-occurCheckExpand was the type-family check. (See Note [Prevent unification-with type families].) So I checked the result of occurCheckExpand for any-type family occurrences and deferred if there were any. This was done-in commit e9bf7bb5cc9fb3f87dd05111aa23da76b86a8967 .--This approach turned out not to be performant, because the expanded-type was bigger than the original type, and tyConsOfType (needed to-see if there are any type family occurrences) looks through type-synonyms. So it then struck me that we could dispense with the-defer_me check entirely. This simplified the code nicely, and it cut-the allocations in T5030 by half. But, as documented in Note [Prevent-unification with type families], this destroyed performance in-T3064. Regardless, I missed this regression and the change was-committed as 3f5d1a13f112f34d992f6b74656d64d95a3f506d .--Bottom lines:- * defer_me is back, but now fixed w.r.t. #11407.- * Tread carefully before you start to refactor here. There can be-   lots of hard-to-predict consequences.- Note [Type synonyms and the occur check] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Generally speaking we try to update a variable with type synonyms not@@ -2238,8 +2496,7 @@  -- | Breaks apart a function kind into its pieces. matchExpectedFunKind-  :: Outputable fun-  => fun             -- ^ type, only for errors+  :: TypedThing     -- ^ type, only for errors   -> Arity           -- ^ n: number of desired arrows   -> TcKind          -- ^ fun_ kind   -> TcM Coercion    -- ^ co :: fun_kind ~ (arg1 -> ... -> argn -> res)@@ -2270,7 +2527,7 @@            ; let new_fun = mkVisFunTysMany arg_kinds res_kind                  origin  = TypeEqOrigin { uo_actual   = k                                         , uo_expected = new_fun-                                        , uo_thing    = Just (ppr hs_ty)+                                        , uo_thing    = Just hs_ty                                         , uo_visible  = True                                         }            ; uType KindLevel origin k new_fun }@@ -2316,23 +2573,22 @@  ---------------- {-# NOINLINE checkTyVarEq #-}  -- checkTyVarEq becomes big after the `inline` fires-checkTyVarEq :: DynFlags -> TcTyVar -> TcType -> CheckTyEqResult-checkTyVarEq dflags tv ty-  = inline checkTypeEq dflags (TyVarLHS tv) ty+checkTyVarEq :: TcTyVar -> TcType -> CheckTyEqResult+checkTyVarEq tv ty+  = inline checkTypeEq (TyVarLHS tv) ty     -- inline checkTypeEq so that the `case`s over the CanEqLHS get blasted away  {-# NOINLINE checkTyFamEq #-}  -- checkTyFamEq becomes big after the `inline` fires-checkTyFamEq :: DynFlags-             -> TyCon     -- type function+checkTyFamEq :: TyCon     -- type function              -> [TcType]  -- args, exactly saturated              -> TcType    -- RHS              -> CheckTyEqResult   -- always drops cteTypeFamily-checkTyFamEq dflags fun_tc fun_args ty-  = inline checkTypeEq dflags (TyFamLHS fun_tc fun_args) ty+checkTyFamEq fun_tc fun_args ty+  = inline checkTypeEq (TyFamLHS fun_tc fun_args) ty     `cterRemoveProblem` cteTypeFamily     -- inline checkTypeEq so that the `case`s over the CanEqLHS get blasted away -checkTypeEq :: DynFlags -> CanEqLHS -> TcType -> CheckTyEqResult+checkTypeEq :: CanEqLHS -> TcType -> CheckTyEqResult -- If cteHasNoProblem (checkTypeEq dflags lhs rhs), then lhs ~ rhs -- is a canonical CEqCan. --@@ -2340,8 +2596,7 @@ --   (a) a forall type (forall a. blah) --   (b) a predicate type (c => ty) --   (c) a type family; see Note [Prevent unification with type families]---   (d) a blocking coercion hole---   (e) an occurrence of the LHS (occurs check)+--   (d) an occurrence of the LHS (occurs check) -- -- Note that an occurs-check does not mean "definite error".  For example --   type family F a@@ -2352,22 +2607,20 @@ -- certainly can't unify b0 := F b0 -- -- For (a), (b), and (c) we check only the top level of the type, NOT--- inside the kinds of variables it mentions.  For (d) we look deeply--- in coercions when the LHS is a tyvar (but skip coercions for type family--- LHSs), and for (e) see Note [CEqCan occurs check] in GHC.Tc.Types.Constraint.+-- inside the kinds of variables it mentions, and for (d) see+-- Note [CEqCan occurs check] in GHC.Tc.Types.Constraint. -- -- checkTypeEq is called from --    * checkTyFamEq, checkTyVarEq (which inline it to specialise away the --      case-analysis on 'lhs') --    * checkEqCanLHSFinish, which does not know the form of 'lhs'-checkTypeEq dflags lhs ty+checkTypeEq lhs ty   = go ty   where-    impredicative    = cteProblem cteImpredicative-    type_family      = cteProblem cteTypeFamily-    hole_blocker     = cteProblem cteHoleBlocker-    insoluble_occurs = cteProblem cteInsolubleOccurs-    soluble_occurs   = cteProblem cteSolubleOccurs+    impredicative      = cteProblem cteImpredicative+    type_family        = cteProblem cteTypeFamily+    insoluble_occurs   = cteProblem cteInsolubleOccurs+    soluble_occurs     = cteProblem cteSolubleOccurs      -- The GHCi runtime debugger does its type-matching with     -- unification variables that can unify with a polytype@@ -2436,21 +2689,11 @@      -- inferred     go_co co | TyVarLHS tv <- lhs              , tv `elemVarSet` tyCoVarsOfCo co-             = soluble_occurs S.<> maybe_hole_blocker+             = soluble_occurs          -- Don't check coercions for type families; see commentary at top of function              | otherwise-             = maybe_hole_blocker-      where-        -- See GHC.Tc.Solver.Canonical Note [Equalities with incompatible kinds]-        -- Wrinkle (2) about this case in general, Wrinkle (4b) about the check for-        -- deferred type errors-        maybe_hole_blocker | not (gopt Opt_DeferTypeErrors dflags)-                           , hasCoercionHoleCo co-                           = hole_blocker--                           | otherwise-                           = cteOK+             = cteOK      check_tc :: TyCon -> CheckTyEqResult     check_tc
GHC/Tc/Utils/Unify.hs-boot view
@@ -1,18 +1,17 @@ module GHC.Tc.Utils.Unify where  import GHC.Prelude+import GHC.Core.Type         ( Mult ) import GHC.Tc.Utils.TcType   ( TcTauType ) import GHC.Tc.Types          ( TcM ) import GHC.Tc.Types.Evidence ( TcCoercion, HsWrapper )-import GHC.Tc.Types.Origin ( CtOrigin )-import GHC.Utils.Outputable( SDoc )-import GHC.Hs.Type     ( Mult )+import GHC.Tc.Types.Origin   ( CtOrigin, TypedThing )   -- This boot file exists only to tie the knot between---              GHC.Tc.Utils.Unify and Inst+--   GHC.Tc.Utils.Unify and GHC.Tc.Utils.Instantiate -unifyType :: Maybe SDoc -> TcTauType -> TcTauType -> TcM TcCoercion-unifyKind :: Maybe SDoc -> TcTauType -> TcTauType -> TcM TcCoercion+unifyType :: Maybe TypedThing -> TcTauType -> TcTauType -> TcM TcCoercion+unifyKind :: Maybe TypedThing -> TcTauType -> TcTauType -> TcM TcCoercion  tcSubMult :: CtOrigin -> Mult -> Mult -> TcM HsWrapper
GHC/Tc/Utils/Zonk.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP              #-}+ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies     #-} @@ -14,9 +14,6 @@ -- -- This module is an extension of @HsSyn@ syntax, for use in the type checker. module GHC.Tc.Utils.Zonk (-        -- * Extracting types from HsSyn-        hsLitType, hsPatType, hsLPatType,-         -- * Other HsSyn functions         mkHsDictLet, mkHsApp,         mkHsAppTy, mkHsCaseAlt,@@ -40,17 +37,14 @@         zonkCoToCo,         zonkEvBinds, zonkTcEvBinds,         zonkTcMethInfoToMethInfoX,-        lookupTyVarOcc+        lookupTyVarX   ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Platform  import GHC.Builtin.Types-import GHC.Builtin.Types.Prim import GHC.Builtin.Names  import GHC.Hs@@ -73,6 +67,7 @@ import GHC.Utils.Outputable import GHC.Utils.Misc import GHC.Utils.Panic+import GHC.Utils.Panic.Plain  import GHC.Core.Multiplicity import GHC.Core@@ -99,59 +94,6 @@ import Data.List  ( partition ) import Control.Arrow ( second ) -{--************************************************************************-*                                                                      *-       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 (ListPatTc ty Nothing) _)      = mkListTy ty-hsPatType (ListPat (ListPatTc _ (Just (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 (XPat (CoPat _ _ ty))         = ty-hsPatType SplicePat{}                   = panic "hsPatType: SplicePat"--hsLitType :: HsLit (GhcPass p) -> TcType-hsLitType (HsChar _ _)       = charTy-hsLitType (HsCharPrim _ _)   = charPrimTy-hsLitType (HsString _ _)     = stringTy-hsLitType (HsStringPrim _ _) = addrPrimTy-hsLitType (HsInt _ _)        = intTy-hsLitType (HsIntPrim _ _)    = intPrimTy-hsLitType (HsWordPrim _ _)   = wordPrimTy-hsLitType (HsInt64Prim _ _)  = int64PrimTy-hsLitType (HsWord64Prim _ _) = word64PrimTy-hsLitType (HsInteger _ _ ty) = ty-hsLitType (HsRat _ _ ty)     = ty-hsLitType (HsFloatPrim _ _)  = floatPrimTy-hsLitType (HsDoublePrim _ _) = doublePrimTy- {- ********************************************************************* *                                                                      *          Short-cuts for overloaded numeric literals@@ -178,15 +120,14 @@ -}  tcShortCutLit :: HsOverLit GhcRn -> ExpRhoType -> TcM (Maybe (HsOverLit GhcTc))-tcShortCutLit lit@(OverLit { ol_val = val, ol_ext = rebindable }) exp_res_ty+tcShortCutLit lit@(OverLit { ol_val = val, ol_ext = OverLitRn rebindable _}) exp_res_ty   | not rebindable   , Just res_ty <- checkingExpType_maybe exp_res_ty   = do { dflags <- getDynFlags        ; let platform = targetPlatform dflags        ; case shortCutLit platform val res_ty of             Just expr -> return $ Just $-                         lit { ol_witness = expr-                             , ol_ext = OverLitTc False res_ty }+                         lit { ol_ext = OverLitTc False expr res_ty }             Nothing   -> return Nothing }   | otherwise   = return Nothing@@ -444,9 +385,6 @@ zonkIdBndr :: ZonkEnv -> TcId -> TcM Id zonkIdBndr env v   = do Scaled w' ty' <- zonkScaledTcTypeToTypeX env (idScaledType v)-       ensureNotLevPoly ty'-         (text "In the type of binder" <+> quotes (ppr v))-        return (modifyIdInfo (`setLevityInfoWithType` ty') (setIdMult (setIdType v ty') w'))  zonkIdBndrs :: ZonkEnv -> [TcId] -> TcM [Id]@@ -506,7 +444,7 @@ -- as the old one.  This important when zonking the -- TyVarBndrs of a TyCon, whose Names may scope. zonkTyBndrX env tv-  = ASSERT2( isImmutableTyVar tv, ppr tv <+> dcolon <+> ppr (tyVarKind tv) )+  = assertPpr (isImmutableTyVar tv) (ppr tv <+> dcolon <+> ppr (tyVarKind tv)) $     do { ki <- zonkTcTypeToTypeX env (tyVarKind tv)                -- Internal names tidy up better, for iface files.        ; let tv' = mkTyVar (tyVarName tv) ki@@ -572,14 +510,14 @@     new_binds <- mapM (wrapLocMA zonk_ip_bind) binds     let         env1 = extendIdZonkEnvRec env-                 [ n | (L _ (IPBind _ (Right n) _)) <- new_binds]+                 [ n | (L _ (IPBind n _ _)) <- new_binds]     (env2, new_dict_binds) <- zonkTcEvBinds env1 dict_binds     return (env2, HsIPBinds x (IPBinds new_dict_binds new_binds))   where-    zonk_ip_bind (IPBind x n e)-        = do n' <- mapIPNameTc (zonkIdBndr env) n+    zonk_ip_bind (IPBind dict_id n e)+        = do dict_id' <- zonkIdBndr env dict_id              e' <- zonkLExpr env e-             return (IPBind x n' e')+             return (IPBind dict_id' n e')  --------------------------------------------- zonkRecMonoBinds :: ZonkEnv -> LHsBinds GhcTc -> TcM (ZonkEnv, LHsBinds GhcTc)@@ -623,12 +561,12 @@                       , fun_matches = new_ms                       , fun_ext = new_co_fn }) } -zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs-                        , abs_ev_binds = ev_binds-                        , abs_exports = exports-                        , abs_binds = val_binds-                        , abs_sig = has_sig })-  = ASSERT( all isImmutableTyVar tyvars )+zonk_bind env (XHsBindsLR (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs+                                    , abs_ev_binds = ev_binds+                                    , abs_exports = exports+                                    , abs_binds = val_binds+                                    , abs_sig = has_sig }))+  = assert ( all isImmutableTyVar tyvars ) $     do { (env0, new_tyvars) <- zonkTyBndrsX env tyvars        ; (env1, new_evs) <- zonkEvBndrsX env0 evs        ; (env2, new_ev_binds) <- zonkTcEvBinds_s env1 ev_binds@@ -638,11 +576,11 @@             ; new_val_binds <- mapBagM (zonk_val_bind env3) val_binds             ; new_exports   <- mapM (zonk_export env3) exports             ; return (new_val_binds, new_exports) }-       ; return (AbsBinds { abs_ext = noExtField-                          , abs_tvs = new_tyvars, abs_ev_vars = new_evs+       ; return $ XHsBindsLR $+                 AbsBinds { abs_tvs = new_tyvars, abs_ev_vars = new_evs                           , abs_ev_binds = new_ev_binds                           , abs_exports = new_exports, abs_binds = new_val_bind-                          , abs_sig = has_sig }) }+                          , abs_sig = has_sig } }   where     zonk_val_bind env lbind       | has_sig@@ -650,8 +588,8 @@                              , fun_matches = ms                              , fun_ext     = co_fn })) <- lbind       = do { new_mono_id <- updateIdTypeAndMultM (zonkTcTypeToTypeX env) mono_id-                            -- Specifically /not/ zonkIdBndr; we do not-                            -- want to complain about a levity-polymorphic binder+                            -- Specifically /not/ zonkIdBndr; we do not want to+                            -- complain about a representation-polymorphic binder            ; (env', new_co_fn) <- zonkCoFn env co_fn            ; new_ms            <- zonkMatchGroup env' zonkLExpr ms            ; return $ L loc $@@ -661,17 +599,15 @@       | otherwise       = zonk_lbind env lbind   -- The normal case -    zonk_export :: ZonkEnv -> ABExport GhcTc -> TcM (ABExport GhcTc)-    zonk_export env (ABE{ abe_ext = x-                        , abe_wrap = wrap+    zonk_export :: ZonkEnv -> ABExport -> TcM ABExport+    zonk_export env (ABE{ abe_wrap = wrap                         , abe_poly = poly_id                         , abe_mono = mono_id                         , abe_prags = prags })         = do new_poly_id <- zonkIdBndr env poly_id              (_, new_wrap) <- zonkCoFn env wrap              new_prags <- zonkSpecPrags env prags-             return (ABE{ abe_ext = x-                        , abe_wrap = new_wrap+             return (ABE{ abe_wrap = new_wrap                         , abe_poly = new_poly_id                         , abe_mono = zonkIdOcc env mono_id                         , abe_prags = new_prags })@@ -733,7 +669,7 @@ ************************************************************************ -} -zonkMatchGroup :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcSpan+zonkMatchGroup :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcAnn NoEpAnns             => ZonkEnv             -> (ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc)))             -> MatchGroup GhcTc (LocatedA (body GhcTc))@@ -748,7 +684,7 @@                      , mg_ext = MatchGroupTc arg_tys' res_ty'                      , mg_origin = origin }) } -zonkMatch :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcSpan+zonkMatch :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcAnn NoEpAnns           => ZonkEnv           -> (ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc)))           -> LMatch GhcTc (LocatedA (body GhcTc))@@ -760,7 +696,7 @@         ; return (L loc (match { m_pats = new_pats, m_grhss = new_grhss })) }  --------------------------------------------------------------------------zonkGRHSs :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcSpan+zonkGRHSs :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcAnn NoEpAnns           => ZonkEnv           -> (ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc)))           -> GRHSs GhcTc (LocatedA (body GhcTc))@@ -773,7 +709,7 @@           = do (env2, new_guarded) <- zonkStmts new_env zonkLExpr guarded                new_rhs <- zBody env2 rhs                return (GRHS xx new_guarded new_rhs)-    new_grhss <- mapM (wrapLocM zonk_grhs) grhss+    new_grhss <- mapM (wrapLocMA zonk_grhs) grhss     return (GRHSs x new_grhss new_binds)  {-@@ -792,7 +728,7 @@ zonkLExpr  env expr  = wrapLocMA (zonkExpr env) expr  zonkExpr env (HsVar x (L l id))-  = ASSERT2( isNothing (isDataConId_maybe id), ppr id )+  = assertPpr (isNothing (isDataConId_maybe id)) (ppr id) $     return (HsVar x (L l (zonkIdOcc env id)))  zonkExpr env (HsUnboundVar her occ)@@ -805,17 +741,12 @@            ty'  <- zonkTcTypeToTypeX env ty            return (HER ref ty' u) -zonkExpr env (HsRecFld _ (Ambiguous v occ))-  = return (HsRecFld noExtField (Ambiguous (zonkIdOcc env v) occ))-zonkExpr env (HsRecFld _ (Unambiguous v occ))-  = return (HsRecFld noExtField (Unambiguous (zonkIdOcc env v) occ))--zonkExpr _ e@(HsConLikeOut {}) = return e+zonkExpr env (HsRecSel _ (FieldOcc v occ))+  = return (HsRecSel noExtField (FieldOcc (zonkIdOcc env v) occ)) -zonkExpr _ (HsIPVar x id)-  = return (HsIPVar x id)+zonkExpr _ (HsIPVar x _) = dataConCantHappen x -zonkExpr _ e@HsOverLabel{} = return e+zonkExpr _ (HsOverLabel x _) = dataConCantHappen x  zonkExpr env (HsLit x (HsRat e f ty))   = do new_ty <- zonkTcTypeToTypeX env ty@@ -832,9 +763,9 @@   = do new_matches <- zonkMatchGroup env zonkLExpr matches        return (HsLam x new_matches) -zonkExpr env (HsLamCase x matches)+zonkExpr env (HsLamCase x lc_variant matches)   = do new_matches <- zonkMatchGroup env zonkLExpr matches-       return (HsLamCase x new_matches)+       return (HsLamCase x lc_variant new_matches)  zonkExpr env (HsApp x e1 e2)   = do new_e1 <- zonkLExpr env e1@@ -847,52 +778,30 @@        return (HsAppType new_ty new_e t)        -- NB: the type is an HsType; can't zonk that! -zonkExpr _ e@(HsRnBracketOut _ _ _)-  = pprPanic "zonkExpr: HsRnBracketOut" (ppr e)--zonkExpr env (HsTcBracketOut x wrap body bs)-  = do wrap' <- traverse zonkQuoteWrap wrap-       bs' <- mapM (zonk_b env) bs-       return (HsTcBracketOut x wrap' body bs')-  where-    zonkQuoteWrap (QuoteWrapper ev ty) = do-        let ev' = zonkIdOcc env ev-        ty' <- zonkTcTypeToTypeX env ty-        return (QuoteWrapper ev' ty')+zonkExpr env (HsTypedBracket hsb_tc body)+  = (\x -> HsTypedBracket x body) <$> zonkBracket env hsb_tc -    zonk_b env' (PendingTcSplice n e) = do e' <- zonkLExpr env' e-                                           return (PendingTcSplice n e')+zonkExpr env (HsUntypedBracket hsb_tc body)+  = (\x -> HsUntypedBracket x body) <$> zonkBracket env hsb_tc  zonkExpr env (HsSpliceE _ (XSplice (HsSplicedT s))) =   runTopSplice s >>= zonkExpr env  zonkExpr _ e@(HsSpliceE _ _) = pprPanic "zonkExpr: HsSpliceE" (ppr e) -zonkExpr env (OpApp fixity e1 op e2)-  = do new_e1 <- zonkLExpr env e1-       new_op <- zonkLExpr env op-       new_e2 <- zonkLExpr env e2-       return (OpApp fixity new_e1 new_op new_e2)+zonkExpr _ (OpApp x _ _ _) = dataConCantHappen x  zonkExpr env (NegApp x expr op)   = do (env', new_op) <- zonkSyntaxExpr env op        new_expr <- zonkLExpr env' expr        return (NegApp x new_expr new_op) -zonkExpr env (HsPar x e)+zonkExpr env (HsPar x lpar e rpar)   = do new_e <- zonkLExpr env e-       return (HsPar x new_e)--zonkExpr env (SectionL x expr op)-  = do new_expr <- zonkLExpr env expr-       new_op   <- zonkLExpr env op-       return (SectionL x new_expr new_op)--zonkExpr env (SectionR x op expr)-  = do new_op   <- zonkLExpr env op-       new_expr <- zonkLExpr env expr-       return (SectionR x new_op new_expr)+       return (HsPar x lpar new_e rpar) +zonkExpr _ (SectionL x _ _) = dataConCantHappen x+zonkExpr _ (SectionR x _ _) = dataConCantHappen x zonkExpr env (ExplicitTuple x tup_args boxed)   = do { new_tup_args <- mapM zonk_tup_arg tup_args        ; return (ExplicitTuple x new_tup_args boxed) }@@ -920,7 +829,7 @@        return (HsIf x new_e1 new_e2 new_e3)  zonkExpr env (HsMultiIf ty alts)-  = do { alts' <- mapM (wrapLocM zonk_alt) alts+  = do { alts' <- mapM (wrapLocMA zonk_alt) alts        ; ty'   <- zonkTcTypeToTypeX env ty        ; return $ HsMultiIf ty' alts' }   where zonk_alt (GRHS x guard expr)@@ -928,10 +837,10 @@                ; expr'          <- zonkLExpr env' expr                ; return $ GRHS x guard' expr' } -zonkExpr env (HsLet x binds expr)+zonkExpr env (HsLet x tkLet binds tkIn expr)   = do (new_env, new_binds) <- zonkLocalBinds env binds        new_expr <- zonkLExpr new_env expr-       return (HsLet x new_binds new_expr)+       return (HsLet x tkLet new_binds tkIn new_expr)  zonkExpr env (HsDo ty do_or_lc (L l stmts))   = do (_, new_stmts) <- zonkStmts env zonkLExpr stmts@@ -950,7 +859,7 @@                        , rcon_flds = new_rbinds }) }  -- Record updates via dot syntax are replaced by desugared expressions--- in the renamer. See Note [Rebindable Syntax and HsExpansion]. This+-- in the renamer. See Note [Rebindable syntax and HsExpansion]. This -- is why we match on 'rupd_flds = Left rbinds' here and panic otherwise. zonkExpr env (RecordUpd { rupd_flds = Left rbinds                         , rupd_expr = expr@@ -998,8 +907,9 @@         ; return (HsProc x new_pat new_body) }  -- StaticPointers extension-zonkExpr env (HsStatic fvs expr)-  = HsStatic fvs <$> zonkLExpr env expr+zonkExpr env (HsStatic (fvs, ty) expr)+  = do new_ty <- zonkTcTypeToTypeX env ty+       HsStatic (fvs, new_ty) <$> zonkLExpr env expr  zonkExpr env (XExpr (WrapExpr (HsWrap co_fn expr)))   = do (env1, new_co_fn) <- zonkCoFn env co_fn@@ -1009,6 +919,14 @@ zonkExpr env (XExpr (ExpansionExpr (HsExpanded a b)))   = XExpr . ExpansionExpr . HsExpanded a <$> zonkExpr env b +zonkExpr env (XExpr (ConLikeTc con tvs tys))+  = XExpr . ConLikeTc con tvs <$> mapM zonk_scale tys+  where+    zonk_scale (Scaled m ty) = Scaled <$> zonkTcTypeToTypeX env m <*> pure ty+    -- Only the multiplicity can contain unification variables+    -- The tvs come straight from the data-con, and so are strictly redundant+    -- See Wrinkles of Note [Typechecking data constructors] in GHC.Tc.Gen.Head+ zonkExpr _ expr = pprPanic "zonkExpr" (ppr expr)  -------------------------------------------------------------------------@@ -1077,18 +995,18 @@   = do new_matches <- zonkMatchGroup env zonkLCmd matches        return (HsCmdLam x new_matches) -zonkCmd env (HsCmdPar x c)+zonkCmd env (HsCmdPar x lpar c rpar)   = do new_c <- zonkLCmd env c-       return (HsCmdPar x new_c)+       return (HsCmdPar x lpar new_c rpar)  zonkCmd env (HsCmdCase x expr ms)   = do new_expr <- zonkLExpr env expr        new_ms <- zonkMatchGroup env zonkLCmd ms        return (HsCmdCase x new_expr new_ms) -zonkCmd env (HsCmdLamCase x ms)+zonkCmd env (HsCmdLamCase x lc_variant ms)   = do new_ms <- zonkMatchGroup env zonkLCmd ms-       return (HsCmdLamCase x new_ms)+       return (HsCmdLamCase x lc_variant new_ms)  zonkCmd env (HsCmdIf x eCond ePred cThen cElse)   = do { (env1, new_eCond) <- zonkSyntaxExpr env eCond@@ -1097,10 +1015,10 @@        ; new_cElse <- zonkLCmd env1 cElse        ; return (HsCmdIf x new_eCond new_ePred new_cThen new_cElse) } -zonkCmd env (HsCmdLet x binds cmd)+zonkCmd env (HsCmdLet x tkLet binds tkIn cmd)   = do (new_env, new_binds) <- zonkLocalBinds env binds        new_cmd <- zonkLCmd new_env cmd-       return (HsCmdLet x new_binds new_cmd)+       return (HsCmdLet x tkLet new_binds tkIn new_cmd)  zonkCmd env (HsCmdDo ty (L l stmts))   = do (_, new_stmts) <- zonkStmts env zonkLCmd stmts@@ -1110,7 +1028,7 @@   zonkCmdTop :: ZonkEnv -> LHsCmdTop GhcTc -> TcM (LHsCmdTop GhcTc)-zonkCmdTop env cmd = wrapLocM (zonk_cmd_top env) cmd+zonkCmdTop env cmd = wrapLocMA (zonk_cmd_top env) cmd  zonk_cmd_top :: ZonkEnv -> HsCmdTop GhcTc -> TcM (HsCmdTop GhcTc) zonk_cmd_top env (HsCmdTop (CmdTopTc stack_tys ty ids) cmd)@@ -1119,8 +1037,8 @@        new_ty <- zonkTcTypeToTypeX env ty        new_ids <- mapSndM (zonkExpr env) ids -       MASSERT( isLiftedTypeKind (tcTypeKind new_stack_tys) )-         -- desugarer assumes that this is not levity polymorphic...+       massert (isLiftedTypeKind (tcTypeKind new_stack_tys))+         -- desugarer assumes that this is not representation-polymorphic...          -- but indeed it should always be lifted due to the typing          -- rules for arrows @@ -1132,17 +1050,17 @@ zonkCoFn env (WpCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1                                     ; (env2, c2') <- zonkCoFn env1 c2                                     ; return (env2, WpCompose c1' c2') }-zonkCoFn env (WpFun c1 c2 t1 d) = do { (env1, c1') <- zonkCoFn env c1-                                     ; (env2, c2') <- zonkCoFn env1 c2-                                     ; t1'         <- zonkScaledTcTypeToTypeX env2 t1-                                     ; return (env2, WpFun c1' c2' t1' d) }+zonkCoFn env (WpFun c1 c2 t1)  = do { (env1, c1') <- zonkCoFn env c1+                                    ; (env2, c2') <- zonkCoFn env1 c2+                                    ; t1'         <- zonkScaledTcTypeToTypeX env2 t1+                                    ; return (env2, WpFun c1' c2' t1') } zonkCoFn env (WpCast co) = do { co' <- zonkCoToCo env co                               ; return (env, WpCast co') } zonkCoFn env (WpEvLam ev)   = do { (env', ev') <- zonkEvBndrX env ev                                  ; return (env', WpEvLam ev') } zonkCoFn env (WpEvApp arg)  = do { arg' <- zonkEvTerm env arg                                  ; return (env, WpEvApp arg') }-zonkCoFn env (WpTyLam tv)   = ASSERT( isImmutableTyVar tv )+zonkCoFn env (WpTyLam tv)   = assert (isImmutableTyVar tv) $                               do { (env', tv') <- zonkTyBndrX env tv                                  ; return (env', WpTyLam tv') } zonkCoFn env (WpTyApp ty)   = do { ty' <- zonkTcTypeToTypeX env ty@@ -1154,12 +1072,29 @@  ------------------------------------------------------------------------- zonkOverLit :: ZonkEnv -> HsOverLit GhcTc -> TcM (HsOverLit GhcTc)-zonkOverLit env lit@(OverLit {ol_ext = OverLitTc r ty, ol_witness = e })+zonkOverLit env lit@(OverLit {ol_ext = x@OverLitTc { ol_witness = e, ol_type = ty } })   = do  { ty' <- zonkTcTypeToTypeX env ty         ; e' <- zonkExpr env e-        ; return (lit { ol_witness = e', ol_ext = OverLitTc r ty' }) }+        ; return (lit { ol_ext = x { ol_witness = e'+                                   , ol_type = ty' } }) }  -------------------------------------------------------------------------+zonkBracket :: ZonkEnv -> HsBracketTc -> TcM HsBracketTc+zonkBracket env (HsBracketTc hsb_thing ty wrap bs)+  = do wrap' <- traverse zonkQuoteWrap wrap+       bs' <- mapM (zonk_b env) bs+       new_ty <- zonkTcTypeToTypeX env ty+       return (HsBracketTc hsb_thing new_ty wrap' bs')+  where+    zonkQuoteWrap (QuoteWrapper ev ty) = do+        let ev' = zonkIdOcc env ev+        ty' <- zonkTcTypeToTypeX env ty+        return (QuoteWrapper ev' ty')++    zonk_b env' (PendingTcSplice n e) = do e' <- zonkLExpr env' e+                                           return (PendingTcSplice n e')++------------------------------------------------------------------------- zonkArithSeq :: ZonkEnv -> ArithSeqInfo GhcTc -> TcM (ArithSeqInfo GhcTc)  zonkArithSeq env (From e)@@ -1182,7 +1117,6 @@        new_e3 <- zonkLExpr env e3        return (FromThenTo new_e1 new_e2 new_e3) - ------------------------------------------------------------------------- zonkStmts :: Anno (StmtLR GhcTc GhcTc (LocatedA (body GhcTc))) ~ SrcSpanAnnA           => ZonkEnv@@ -1371,27 +1305,20 @@         ; return (HsRecFields flds' dd) }   where     zonk_rbind (L l fld)-      = do { new_id   <- wrapLocM (zonkFieldOcc env) (hsRecFieldLbl fld)-           ; new_expr <- zonkLExpr env (hsRecFieldArg fld)-           ; return (L l (fld { hsRecFieldLbl = new_id-                              , hsRecFieldArg = new_expr })) }+      = do { new_id   <- wrapLocMA (zonkFieldOcc env) (hfbLHS fld)+           ; new_expr <- zonkLExpr env (hfbRHS fld)+           ; return (L l (fld { hfbLHS = new_id+                              , hfbRHS = new_expr })) }  zonkRecUpdFields :: ZonkEnv -> [LHsRecUpdField GhcTc]                  -> TcM [LHsRecUpdField GhcTc] zonkRecUpdFields env = mapM zonk_rbind   where     zonk_rbind (L l fld)-      = do { new_id   <- wrapLocM (zonkFieldOcc env) (hsRecUpdFieldOcc fld)-           ; new_expr <- zonkLExpr env (hsRecFieldArg fld)-           ; return (L l (fld { hsRecFieldLbl = fmap ambiguousFieldOcc new_id-                              , hsRecFieldArg = new_expr })) }----------------------------------------------------------------------------mapIPNameTc :: (a -> TcM b) -> Either (Located HsIPName) a-            -> TcM (Either (Located HsIPName) b)-mapIPNameTc _ (Left x)  = return (Left x)-mapIPNameTc f (Right x) = do r <- f x-                             return (Right r)+      = do { new_id   <- wrapLocMA (zonkFieldOcc env) (hsRecUpdFieldOcc fld)+           ; new_expr <- zonkLExpr env (hfbRHS fld)+           ; return (L l (fld { hfbLHS = fmap ambiguousFieldOcc new_id+                              , hfbRHS = new_expr })) }  {- ************************************************************************@@ -1408,14 +1335,12 @@ zonkPat env pat = wrapLocSndMA (zonk_pat env) pat  zonk_pat :: ZonkEnv -> Pat GhcTc -> TcM (ZonkEnv, Pat GhcTc)-zonk_pat env (ParPat x p)+zonk_pat env (ParPat x lpar p rpar)   = do  { (env', p') <- zonkPat env p-        ; return (env', ParPat x p') }+        ; return (env', ParPat x lpar p' rpar) }  zonk_pat env (WildPat ty)   = do  { ty' <- zonkTcTypeToTypeX env ty-        ; ensureNotLevPoly ty'-            (text "In a wildcard pattern")         ; return (env, WildPat ty') }  zonk_pat env (VarPat x (L l v))@@ -1441,17 +1366,10 @@         ; ty' <- zonkTcTypeToTypeX env ty         ; return (env', ViewPat ty' expr' pat') } -zonk_pat env (ListPat (ListPatTc ty Nothing) pats)+zonk_pat env (ListPat ty pats)   = do  { ty' <- zonkTcTypeToTypeX env ty         ; (env', pats') <- zonkPats env pats-        ; return (env', ListPat (ListPatTc ty' Nothing) pats') }--zonk_pat env (ListPat (ListPatTc ty (Just (ty2,wit))) pats)-  = do  { (env', wit') <- zonkSyntaxExpr env wit-        ; ty2' <- zonkTcTypeToTypeX env' ty2-        ; ty' <- zonkTcTypeToTypeX env' ty-        ; (env'', pats') <- zonkPats env' pats-        ; return (env'', ListPat (ListPatTc ty' (Just (ty2',wit'))) pats') }+        ; return (env', ListPat ty' pats') }  zonk_pat env (TuplePat tys pats boxed)   = do  { tys' <- mapM (zonkTcTypeToTypeX env) tys@@ -1463,8 +1381,7 @@         ; (env', pat') <- zonkPat env pat         ; return (env', SumPat tys' pat' alt arity) } -zonk_pat env p@(ConPat { pat_con = L _ con-                       , pat_args = args+zonk_pat env p@(ConPat { pat_args = args                        , pat_con_ext = p'@(ConPatTc                          { cpt_tvs = tyvars                          , cpt_dicts = evs@@ -1473,17 +1390,8 @@                          , cpt_arg_tys = tys                          })                        })-  = ASSERT( all isImmutableTyVar tyvars )+  = assert (all isImmutableTyVar tyvars) $     do  { new_tys <- mapM (zonkTcTypeToTypeX env) tys--          -- an unboxed tuple pattern (but only an unboxed tuple pattern)-          -- might have levity-polymorphic arguments. Check for this badness.-        ; case con of-            RealDataCon dc-              | isUnboxedTupleTyCon (dataConTyCon dc)-              -> mapM_ (checkForLevPoly doc) (dropRuntimeRepArgs new_tys)-            _ -> return ()-         ; (env0, new_tyvars) <- zonkTyBndrsX env tyvars           -- Must zonk the existential variables, because their           -- /kind/ need potential zonking.@@ -1505,8 +1413,6 @@                  }                )         }-  where-    doc = text "In the type of an element of an unboxed tuple pattern:" $$ ppr p  zonk_pat env (LitPat x lit) = return (env, LitPat x lit) @@ -1534,13 +1440,16 @@         ; ty' <- zonkTcTypeToTypeX env2 ty         ; return (extendIdZonkEnv env2 n',                   NPlusKPat ty' (L loc n') (L l lit1') lit2' e1' e2') }--zonk_pat env (XPat (CoPat co_fn pat ty))-  = do { (env', co_fn') <- zonkCoFn env co_fn+zonk_pat env (XPat ext) = case ext of+  { ExpansionPat orig pat->+    do { (env, pat') <- zonk_pat env pat+       ; return $ (env, XPat $ ExpansionPat orig pat') }+  ; CoPat co_fn pat ty ->+    do { (env', co_fn') <- zonkCoFn env co_fn        ; (env'', pat') <- zonkPat env' (noLocA pat)        ; ty' <- zonkTcTypeToTypeX env'' ty        ; return (env'', XPat $ CoPat co_fn' (unLoc pat') ty')-       }+       }}  zonk_pat _ pat = pprPanic "zonk_pat" (ppr pat) @@ -1557,9 +1466,9 @@         ; return (env', InfixCon p1' p2') }  zonkConStuff env (RecCon (HsRecFields rpats dd))-  = do  { (env', pats') <- zonkPats env (map (hsRecFieldArg . unLoc) rpats)+  = do  { (env', pats') <- zonkPats env (map (hfbRHS . unLoc) rpats)         ; let rpats' = zipWith (\(L l rp) p' ->-                                  L l (rp { hsRecFieldArg = p' }))+                                  L l (rp { hfbRHS = p' }))                                rpats pats'         ; return (env', RecCon (HsRecFields rpats' dd)) }         -- Field selectors have declared types; hence no zonking@@ -1620,7 +1529,7 @@    zonk_it env v      | isId v     = do { v' <- zonkIdBndr env v                        ; return (extendIdZonkEnvRec env [v'], v') }-     | otherwise  = ASSERT( isImmutableTyVar v)+     | otherwise  = assert (isImmutableTyVar v)                     zonkTyBndrX env v                     -- DV: used to be return (env,v) but that is plain                     -- wrong because we may need to go inside the kind@@ -1862,7 +1771,7 @@ T9198 and #19668.  So yes, it seems worth it. -} -zonkTyVarOcc :: ZonkEnv -> TyVar -> TcM TcType+zonkTyVarOcc :: ZonkEnv -> TcTyVar -> TcM Type zonkTyVarOcc env@(ZonkEnv { ze_flexi = flexi                           , ze_tv_env = tv_env                           , ze_meta_tv_env = mtv_env_ref }) tv@@ -1877,13 +1786,19 @@                   Just ty -> return ty                   Nothing -> do { mtv_details <- readTcRef ref                                 ; zonk_meta ref mtv_details } }-  | otherwise+  | otherwise  -- This should never really happen;+               -- TyVars should not occur in the typechecker   = lookup_in_tv_env    where     lookup_in_tv_env    -- Look up in the env just as we do for Ids       = case lookupVarEnv tv_env tv of-          Nothing  -> mkTyVarTy <$> updateTyVarKindM (zonkTcTypeToTypeX env) tv+          Nothing  -> -- TyVar/SkolemTv/RuntimeUnk that isn't in the ZonkEnv+                      -- This can happen for RuntimeUnk variables (which+                      -- should stay as RuntimeUnk), but I think it should+                      -- not happen for SkolemTv.+                      mkTyVarTy <$> updateTyVarKindM (zonkTcTypeToTypeX env) tv+           Just tv' -> return (mkTyVarTy tv')      zonk_meta ref Flexi@@ -1900,9 +1815,11 @@       = do { updTcRef mtv_env_ref (\env -> extendVarEnv env tv ty)            ; return ty } -lookupTyVarOcc :: ZonkEnv -> TcTyVar -> Maybe TyVar-lookupTyVarOcc (ZonkEnv { ze_tv_env = tv_env }) tv-  = lookupVarEnv tv_env tv+lookupTyVarX :: ZonkEnv -> TcTyVar -> TyVar+lookupTyVarX (ZonkEnv { ze_tv_env = tv_env }) tv+  = case lookupVarEnv tv_env tv of+       Just tv -> tv+       Nothing -> pprPanic "lookupTyVarOcc" (ppr tv $$ ppr tv_env)  commitFlexi :: ZonkFlexi -> TcTyVar -> Kind -> TcM Type -- Only monadic so we can do tc-tracing@@ -1911,9 +1828,19 @@       SkolemiseFlexi  -> return (mkTyVarTy (mkTyVar name zonked_kind))        DefaultFlexi+          -- Normally, RuntimeRep variables are defaulted in TcMType.defaultTyVar+          -- But that sees only type variables that appear in, say, an inferred type+          -- Defaulting here in the zonker is needed to catch e.g.+          --    y :: Bool+          --    y = (\x -> True) undefined+          -- We need *some* known RuntimeRep for the x and undefined, but no one+          -- will choose it until we get here, in the zonker.         | isRuntimeRepTy zonked_kind         -> do { traceTc "Defaulting flexi tyvar to LiftedRep:" (pprTyVar tv)               ; return liftedRepTy }+        | isLevityTy zonked_kind+        -> do { traceTc "Defaulting flexi tyvar to Lifted:" (pprTyVar tv)+              ; return liftedDataConTy }         | isMultiplicityTy zonked_kind         -> do { traceTc "Defaulting flexi tyvar to Many:" (pprTyVar tv)               ; return manyDataConTy }@@ -1952,11 +1879,6 @@               -- (undeferred) type errors. Originally, I put in a panic               -- here, but that caused too many uses of `failIfErrsM`.            Nothing -> do { traceTc "Zonking unfilled coercion hole" (ppr hole)-                         ; when debugIsOn $-                           whenNoErrs $-                           MASSERT2( False-                                   , text "Type-correct unfilled coercion hole"-                                     <+> ppr hole )                          ; cv' <- zonkCoVar cv                          ; return $ mkCoVarCo cv' } }                              -- This will be an out-of-scope variable, but keeping
GHC/Tc/Validity.hs view
@@ -1,5 +1,6 @@-{-# LANGUAGE CPP           #-} +{-# LANGUAGE DerivingStrategies #-}+ {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-} @@ -9,19 +10,17 @@ -}  module GHC.Tc.Validity (-  Rank, UserTypeCtxt(..), checkValidType, checkValidMonoType,+  Rank(..), UserTypeCtxt(..), checkValidType, checkValidMonoType,   checkValidTheta,   checkValidInstance, checkValidInstHead, validDerivPred,   checkTySynRhs,   checkValidCoAxiom, checkValidCoAxBranch,   checkValidTyFamEqn, checkValidAssocTyFamDeflt, checkConsistentFamInst,-  badATErr, arityErr,+  arityErr,   checkTyConTelescope,   allDistinctTyVars   ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Data.Maybe@@ -34,7 +33,7 @@ import GHC.Core.TyCo.Rep import GHC.Core.TyCo.Ppr import GHC.Tc.Utils.TcType hiding ( sizeType, sizeTypes )-import GHC.Builtin.Types ( heqTyConName, eqTyConName, coercibleTyConName, manyDataConTy )+import GHC.Builtin.Types import GHC.Builtin.Names import GHC.Core.Type import GHC.Core.Unify ( tcMatchTyX_BM, BindFlag(..) )@@ -44,6 +43,9 @@ import GHC.Core.TyCon import GHC.Core.Predicate import GHC.Tc.Types.Origin+import GHC.Tc.Types.Rank+import GHC.Tc.Errors.Types+import GHC.Types.Error  -- others: import GHC.Iface.Type    ( pprIfaceType, pprIfaceTypeApp )@@ -55,6 +57,7 @@ import GHC.Core.FamInstEnv    ( isDominatedBy, injectiveBranches, InjectivityCheckResult(..) ) import GHC.Tc.Instance.Family+import GHC.Types.Basic   ( UnboxedTupleOrSum(..), unboxedTupleOrSumExtension ) import GHC.Types.Name import GHC.Types.Var.Env import GHC.Types.Var.Set@@ -68,7 +71,6 @@ import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic import GHC.Builtin.Uniques  ( mkAlphaTyVarUnique )-import GHC.Data.Bag      ( emptyBag ) import qualified GHC.LanguageExtensions as LangExt  import Control.Monad@@ -257,27 +259,41 @@       StandaloneKindSigCtxt{} -> False       _            -> True -checkUserTypeError :: Type -> TcM ()--- Check to see if the type signature mentions "TypeError blah"--- anywhere in it, and fail if so.+-- | Check whether the type signature contains custom type errors,+-- and fail if so. --+-- Note that some custom type errors are acceptable:+--+--   - in the RHS of a type synonym, e.g. to allow users to define+--     type synonyms for custom type errors with large messages (#20181),+--   - inside a type family application, as a custom type error+--     might evaporate after performing type family reduction (#20241).+checkUserTypeError :: UserTypeCtxt -> Type -> TcM () -- Very unsatisfactorily (#11144) we need to tidy the type -- because it may have come from an /inferred/ signature, not a -- user-supplied one.  This is really only a half-baked fix; -- the other errors in checkValidType don't do tidying, and so -- may give bad error messages when given an inferred type.-checkUserTypeError = check+checkUserTypeError ctxt ty+  | TySynCtxt {} <- ctxt  -- Do not complain about TypeError on the+  = return ()             -- RHS of type synonyms. See #20181++  | otherwise+  = check ty   where   check ty-    | Just msg     <- userTypeError_maybe ty      = fail_with msg-    | Just (_,ts)  <- splitTyConApp_maybe ty      = mapM_ check ts-    | Just (t1,t2) <- splitAppTy_maybe ty         = check t1 >> check t2-    | Just (_,t1)  <- splitForAllTyCoVar_maybe ty = check t1-    | otherwise                                   = return ()+    | Just msg    <- userTypeError_maybe ty      = fail_with msg+    | Just (_,t1) <- splitForAllTyCoVar_maybe ty = check t1+    | let (_,tys) =  splitAppTys ty              = mapM_ check tys+    -- splitAppTys keeps type family applications saturated.+    -- This means we don't go looking for user type errors+    -- inside type family arguments (see #20241). +  fail_with :: Type -> TcM ()   fail_with msg = do { env0 <- tcInitTidyEnv                      ; let (env1, tidy_msg) = tidyOpenType env0 msg-                     ; failWithTcM (env1, pprUserTypeErrorTy tidy_msg) }+                     ; failWithTcM (env1, TcRnUserTypeError tidy_msg)+                     }   {- Note [When we don't check for ambiguity]@@ -345,6 +361,8 @@ checkValidType :: UserTypeCtxt -> Type -> TcM () -- Checks that a user-written type is valid for the given context -- Assumes argument is fully zonked+-- Assumes arugment is well-kinded;+--    that is, checkValidType doesn't need to do kind checking -- Not used for instance decls; checkValidInstance instead checkValidType ctxt ty   = do { traceTc "checkValidType" (ppr ty <+> text "::" <+> ppr (tcTypeKind ty))@@ -355,23 +373,22 @@                         | otherwise  = r               rank1 = gen_rank r1-             rank0 = gen_rank r0+             rank0 = gen_rank MonoTypeRankZero -             r0 = rankZeroMonoType-             r1 = LimitedRank True r0+             r1 = LimitedRank True MonoTypeRankZero               rank                = case ctxt of                  DefaultDeclCtxt-> MustBeMonoType                  PatSigCtxt     -> rank0-                 RuleSigCtxt _  -> rank1+                 RuleSigCtxt {} -> rank1                  TySynCtxt _    -> rank0 -                 ExprSigCtxt    -> rank1+                 ExprSigCtxt {} -> rank1                  KindSigCtxt    -> rank1                  StandaloneKindSigCtxt{} -> rank1                  TypeAppCtxt | impred_flag -> ArbitraryRank-                             | otherwise   -> tyConArgMonoType+                             | otherwise   -> MonoTypeTyConArg                     -- Normally, ImpredicativeTypes is handled in check_arg_type,                     -- but visible type applications don't go through there.                     -- So we do this check here.@@ -406,7 +423,7 @@        -- (and more complicated) errors in checkAmbiguity        ; checkNoErrs $          do { check_type ve ty-            ; checkUserTypeError ty+            ; checkUserTypeError ctxt ty             ; traceTc "done ct" (ppr ty) }         -- Check for ambiguous types.  See Note [When to call checkAmbiguity]@@ -434,48 +451,15 @@                     (do { dflags <- getDynFlags                         ; expand <- initialExpandMode                         ; check_pred_ty emptyTidyEnv dflags ctxt expand ty })-         else addErrTcM (constraintSynErr emptyTidyEnv actual_kind) }+         else addErrTcM ( emptyTidyEnv+                        , TcRnIllegalConstraintSynonymOfKind (tidyType emptyTidyEnv actual_kind)+                        ) }    | otherwise   = return ()   where     actual_kind = tcTypeKind ty -{--Note [Higher rank types]-~~~~~~~~~~~~~~~~~~~~~~~~-Technically-            Int -> forall a. a->a-is still a rank-1 type, but it's not Haskell 98 (#5957).  So the-validity checker allow a forall after an arrow only if we allow it-before -- that is, with Rank2Types or RankNTypes--}--data Rank = ArbitraryRank         -- Any rank ok--          | LimitedRank   -- Note [Higher rank types]-                 Bool     -- Forall ok at top-                 Rank     -- Use for function arguments--          | MonoType SDoc   -- Monotype, with a suggestion of how it could be a polytype--          | MustBeMonoType  -- Monotype regardless of flags--instance Outputable Rank where-  ppr ArbitraryRank  = text "ArbitraryRank"-  ppr (LimitedRank top_forall_ok r)-                     = text "LimitedRank" <+> ppr top_forall_ok-                                          <+> parens (ppr r)-  ppr (MonoType msg) = text "MonoType" <+> parens msg-  ppr MustBeMonoType = text "MustBeMonoType"--rankZeroMonoType, tyConArgMonoType, synArgMonoType, constraintMonoType :: Rank-rankZeroMonoType   = MonoType (text "Perhaps you intended to use RankNTypes")-tyConArgMonoType   = MonoType (text "Perhaps you intended to use ImpredicativeTypes")-synArgMonoType     = MonoType (text "Perhaps you intended to use LiberalTypeSynonyms")-constraintMonoType = MonoType (vcat [ text "A constraint must be a monotype"-                                    , text "Perhaps you intended to use QuantifiedConstraints" ])- funArgResRank :: Rank -> (Rank, Rank)             -- Function argument and result funArgResRank (LimitedRank _ arg_rank) = (arg_rank, LimitedRank (forAllAllowed arg_rank) arg_rank) funArgResRank other_rank               = (other_rank, other_rank)@@ -719,7 +703,8 @@ -- Rank is allowed rank for function args -- Rank 0 means no for-alls anywhere -check_type _ (TyVarTy _) = return ()+check_type _ (TyVarTy _)+  = return ()  check_type ve (AppTy ty1 ty2)   = do  { check_type ve ty1@@ -728,9 +713,17 @@ check_type ve ty@(TyConApp tc tys)   | isTypeSynonymTyCon tc || isTypeFamilyTyCon tc   = check_syn_tc_app ve ty tc tys-  | isUnboxedTupleTyCon tc = check_ubx_tuple ve ty tys-  | otherwise              = mapM_ (check_arg_type False ve) tys +  -- Check for unboxed tuples and unboxed sums: these+  -- require the corresponding extension to be enabled.+  | isUnboxedTupleTyCon tc+  = check_ubx_tuple_or_sum UnboxedTupleType ve ty tys+  | isUnboxedSumTyCon tc+  = check_ubx_tuple_or_sum UnboxedSumType   ve ty tys++  | otherwise+  = mapM_ (check_arg_type False ve) tys+ check_type _ (LitTy {}) = return ()  check_type ve (CastTy ty _) = check_type ve ty@@ -743,7 +736,7 @@                           , ve_rank = rank, ve_expand = expand }) ty   | not (null tvbs && null theta)   = do  { traceTc "check_type" (ppr ty $$ ppr rank)-        ; checkTcM (forAllAllowed rank) (forAllTyErr env rank ty)+        ; checkTcM (forAllAllowed rank) (env, TcRnForAllRankErr rank (tidyType env ty))                 -- Reject e.g. (Maybe (?x::Int => Int)),                 -- with a decent error message @@ -753,7 +746,7 @@          ; checkTcM (all (isInvisibleArgFlag . binderArgFlag) tvbs                          || vdqAllowed ctxt)-                   (illegalVDQTyErr env ty)+                   (env, TcRnVDQInTermType (tidyType env ty))                 -- Reject visible, dependent quantification in the type of a                 -- term (e.g., `f :: forall a -> a -> Maybe a`) @@ -764,17 +757,17 @@         ; check_type (ve{ve_tidy_env = env'}) tau                 -- Allow foralls to right of arrow -        ; checkEscapingKind env' tvbs' theta tau }+        }   where     (tvbs, phi)   = tcSplitForAllTyVarBinders ty     (theta, tau)  = tcSplitPhiTy phi-    (env', tvbs') = tidyTyCoVarBinders env tvbs+    (env', _)     = tidyTyCoVarBinders env tvbs  check_type (ve@ValidityEnv{ ve_tidy_env = env, ve_ctxt = ctxt                           , ve_rank = rank })            ty@(FunTy _ mult arg_ty res_ty)   = do  { failIfTcM (not (linearityAllowed ctxt) && not (isManyDataConTy mult))-                     (linearFunKindErr env ty)+                     (env, TcRnLinearFuncInKind (tidyType env ty))         ; check_type (ve{ve_rank = arg_rank}) arg_ty         ; check_type (ve{ve_rank = res_rank}) res_ty }   where@@ -824,7 +817,7 @@     check_args_only expand = mapM_ (check_arg expand) tys      check_expansion_only expand-      = ASSERT2( isTypeSynonymTyCon tc, ppr tc )+      = assertPpr (isTypeSynonymTyCon tc) (ppr tc) $         case tcView ty of          Just ty' -> let err_ctxt = text "In the expansion of type synonym"                                     <+> quotes (ppr tc)@@ -871,16 +864,17 @@ -}  -----------------------------------------check_ubx_tuple :: ValidityEnv -> KindOrType -> [KindOrType] -> TcM ()-check_ubx_tuple (ve@ValidityEnv{ve_tidy_env = env}) ty tys-  = do  { ub_tuples_allowed <- xoptM LangExt.UnboxedTuples-        ; checkTcM ub_tuples_allowed (ubxArgTyErr env ty)+check_ubx_tuple_or_sum :: UnboxedTupleOrSum -> ValidityEnv -> KindOrType -> [KindOrType] -> TcM ()+check_ubx_tuple_or_sum tup_or_sum (ve@ValidityEnv{ve_tidy_env = env}) ty tys+  = do  { ub_thing_allowed <- xoptM $ unboxedTupleOrSumExtension tup_or_sum+        ; checkTcM ub_thing_allowed+            (env, TcRnUnboxedTupleOrSumTypeFuncArg tup_or_sum (tidyType env ty))          ; impred <- xoptM LangExt.ImpredicativeTypes-        ; let rank' = if impred then ArbitraryRank else tyConArgMonoType+        ; let rank' = if impred then ArbitraryRank else MonoTypeTyConArg                 -- c.f. check_arg_type                 -- However, args are allowed to be unlifted, or-                -- more unboxed tuples, so can't use check_arg_ty+                -- more unboxed tuples or sums, so can't use check_arg_ty         ; mapM_ (check_type (ve{ve_rank = rank'})) tys }  ----------------------------------------@@ -912,10 +906,10 @@         ; let rank' = case rank of          -- Predictive => must be monotype                         -- Rank-n arguments to type synonyms are OK, provided                         -- that LiberalTypeSynonyms is enabled.-                        _ | type_syn       -> synArgMonoType+                        _ | type_syn       -> MonoTypeSynArg                         MustBeMonoType     -> MustBeMonoType  -- Monotype, regardless                         _other | impred    -> ArbitraryRank-                               | otherwise -> tyConArgMonoType+                               | otherwise -> MonoTypeTyConArg                         -- Make sure that MustBeMonoType is propagated,                         -- so that we don't suggest -XImpredicativeTypes in                         --    (Ord (forall a.a)) => a -> a@@ -933,73 +927,6 @@         ; check_type (ve{ve_ctxt = ctxt', ve_rank = rank'}) ty }  -----------------------------------------forAllTyErr :: TidyEnv -> Rank -> Type -> (TidyEnv, SDoc)-forAllTyErr env rank ty-   = ( env-     , vcat [ hang herald 2 (ppr_tidy env ty)-            , suggestion ] )-  where-    (tvs, _rho) = tcSplitForAllTyVars ty-    herald | null tvs  = text "Illegal qualified type:"-           | otherwise = text "Illegal polymorphic type:"-    suggestion = case rank of-                   LimitedRank {} -> text "Perhaps you intended to use RankNTypes"-                   MonoType d     -> d-                   _              -> Outputable.empty -- Polytype is always illegal---- | Reject type variables that would escape their escape through a kind.--- See @Note [Type variables escaping through kinds]@.-checkEscapingKind :: TidyEnv -> [TyVarBinder] -> ThetaType -> Type -> TcM ()-checkEscapingKind env tvbs theta tau =-  case occCheckExpand (binderVars tvbs) phi_kind of-    -- Ensure that none of the tvs occur in the kind of the forall-    -- /after/ expanding type synonyms.-    -- See Note [Phantom type variables in kinds] in GHC.Core.Type-    Nothing -> failWithTcM $ forAllEscapeErr env tvbs theta tau tau_kind-    Just _  -> pure ()-  where-    tau_kind              = tcTypeKind tau-    phi_kind | null theta = tau_kind-             | otherwise  = liftedTypeKind-        -- If there are any constraints, the kind is *. (#11405)--forAllEscapeErr :: TidyEnv -> [TyVarBinder] -> ThetaType -> Type -> Kind-                -> (TidyEnv, SDoc)-forAllEscapeErr env tvbs theta tau tau_kind-  = ( env-    , vcat [ hang (text "Quantified type's kind mentions quantified type variable")-                2 (text "type:" <+> quotes (ppr (mkSigmaTy tvbs theta tau)))-                -- NB: Don't tidy this type since the tvbs were already tidied-                -- previously, and re-tidying them will make the names of type-                -- variables different from tau_kind.-           , hang (text "where the body of the forall has this kind:")-                2 (quotes (ppr_tidy env tau_kind)) ] )--{--Note [Type variables escaping through kinds]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider:--  type family T (r :: RuntimeRep) :: TYPE r-  foo :: forall r. T r--Something smells funny about the type of `foo`. If you spell out the kind-explicitly, it becomes clearer from where the smell originates:--  foo :: ((forall r. T r) :: TYPE r)--The type variable `r` appears in the result kind, which escapes the scope of-its binding site! This is not desirable, so we establish a validity check-(`checkEscapingKind`) to catch any type variables that might escape through-kinds in this way.--}--ubxArgTyErr :: TidyEnv -> Type -> (TidyEnv, SDoc)-ubxArgTyErr env ty-  = ( env, vcat [ sep [ text "Illegal unboxed tuple type as function argument:"-                      , ppr_tidy env ty ]-                , text "Perhaps you intended to use UnboxedTuples" ] )- checkConstraintsOK :: ValidityEnv -> ThetaType -> Type -> TcM () checkConstraintsOK ve theta ty   | null theta                         = return ()@@ -1007,26 +934,8 @@   | otherwise   = -- We are in a kind, where we allow only equality predicates     -- See Note [Constraints in kinds] in GHC.Core.TyCo.Rep, and #16263-    checkTcM (all isEqPred theta) $-    constraintTyErr (ve_tidy_env ve) ty--constraintTyErr :: TidyEnv -> Type -> (TidyEnv, SDoc)-constraintTyErr env ty-  = (env, text "Illegal constraint in a kind:" <+> ppr_tidy env ty)---- | Reject a use of visible, dependent quantification in the type of a term.-illegalVDQTyErr :: TidyEnv -> Type -> (TidyEnv, SDoc)-illegalVDQTyErr env ty =-  (env, vcat-  [ hang (text "Illegal visible, dependent quantification" <+>-          text "in the type of a term:")-       2 (ppr_tidy env ty)-  , text "(GHC does not yet support this)" ] )---- | Reject uses of linear function arrows in kinds.-linearFunKindErr :: TidyEnv -> Type -> (TidyEnv, SDoc)-linearFunKindErr env ty =-  (env, text "Illegal linear function in a kind:" <+> ppr_tidy env ty)+    checkTcM (all isEqPred theta) (env, TcRnConstraintInKind (tidyType env ty))+  where env = ve_tidy_env ve  {- Note [Liberal type synonyms]@@ -1117,15 +1026,8 @@   = return () check_valid_theta env ctxt expand theta   = do { dflags <- getDynFlags-       ; warnTcM (Reason Opt_WarnDuplicateConstraints)-                 (wopt Opt_WarnDuplicateConstraints dflags && notNull dups)-                 (dupPredWarn env dups)        ; traceTc "check_valid_theta" (ppr theta)        ; mapM_ (check_pred_ty env dflags ctxt expand) theta }-  where-    (_,dups) = removeDups nonDetCmpType theta-    -- It's OK to use nonDetCmpType because dups only appears in the-    -- warning  ------------------------- {- Note [Validity checking for constraints]@@ -1163,7 +1065,7 @@     rank | xopt LangExt.QuantifiedConstraints dflags          = ArbitraryRank          | otherwise-         = constraintMonoType+         = MonoTypeConstraint      ve :: ValidityEnv     ve = ValidityEnv{ ve_tidy_env = env@@ -1194,18 +1096,10 @@               -- is wrong.  For user written signatures, it'll be rejected by kind-checking               -- well before we get to validity checking.  For inferred types we are careful               -- to box such constraints in GHC.Tc.Utils.TcType.pickQuantifiablePreds, as described-              -- in Note [Lift equality constraints when quantifying] in GHC.Tc.Utils.TcType+              -- in Note [Lift equality constraints when quantifying] in GHC.Tc.Solver        ForAllPred _ theta head -> check_quant_pred env dflags ctxt pred theta head-      IrredPred {}            -> check_irred_pred under_syn env dflags pred--check_eq_pred :: TidyEnv -> DynFlags -> PredType -> TcM ()-check_eq_pred env dflags pred-  =         -- Equational constraints are valid in all contexts if type-            -- families are permitted-    checkTcM (xopt LangExt.TypeFamilies dflags-              || xopt LangExt.GADTs dflags)-             (eqPredTyErr env pred)+      _                       -> return ()  check_quant_pred :: TidyEnv -> DynFlags -> UserTypeCtxt                  -> PredType -> ThetaType -> PredType -> TcM ()@@ -1223,7 +1117,7 @@                                -- in check_pred_ty             IrredPred {}      | hasTyVarHead head_pred                               -> return ()-            _                 -> failWithTcM (badQuantHeadErr env pred)+            _                 -> failWithTcM (env, TcRnBadQuantPredHead (tidyType env pred))           -- Check for termination        ; unless (xopt LangExt.UndecidableInstances dflags) $@@ -1234,23 +1128,11 @@ check_tuple_pred under_syn env dflags ctxt pred ts   = do { -- See Note [ConstraintKinds in predicates]          checkTcM (under_syn || xopt LangExt.ConstraintKinds dflags)-                  (predTupleErr env pred)+                  (env, TcRnIllegalTupleConstraint (tidyType env pred))        ; mapM_ (check_pred_help under_syn env dflags ctxt) ts }     -- This case will not normally be executed because without     -- -XConstraintKinds tuple types are only kind-checked as * -check_irred_pred :: Bool -> TidyEnv -> DynFlags -> PredType -> TcM ()-check_irred_pred under_syn env dflags pred-    -- The predicate looks like (X t1 t2) or (x t1 t2) :: Constraint-    -- where X is a type function-  =      -- If it looks like (x t1 t2), require ConstraintKinds-         --   see Note [ConstraintKinds in predicates]-         -- But (X t1 t2) is always ok because we just require ConstraintKinds-         -- at the definition site (#9838)-    failIfTcM (not under_syn && not (xopt LangExt.ConstraintKinds dflags)-                            && hasTyVarHead pred)-              (predIrredErr env pred)- {- Note [ConstraintKinds in predicates] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Don't check for -XConstraintKinds under a type synonym, because that@@ -1268,16 +1150,20 @@ check_class_pred env dflags ctxt pred cls tys   | isEqPredClass cls    -- (~) and (~~) are classified as classes,                          -- but here we want to treat them as equalities-  = check_eq_pred env dflags pred+  = -- Equational constraints are valid in all contexts, and+    -- we do not need to check e.g. for FlexibleContexts here, so just do nothing+    -- We used to require TypeFamilies/GADTs for equality constraints,+    -- but not anymore (GHC Proposal #371)+   return ()    | isIPClass cls   = do { check_arity-       ; checkTcM (okIPCtxt ctxt) (badIPPred env pred) }+       ; checkTcM (okIPCtxt ctxt) (env, TcRnIllegalImplicitParam (tidyType env pred)) }    | otherwise     -- Includes Coercible   = do { check_arity        ; checkSimplifiableClassConstraint env dflags ctxt cls tys-       ; checkTcM arg_tys_ok (predTyVarErr env pred) }+       ; checkTcM arg_tys_ok (env, TcRnNonTypeVarArgInConstraint (tidyType env pred)) }   where     check_arity = checkTc (tys `lengthIs` classArity cls)                           (tyConArityErr (classTyCon cls) tys)@@ -1312,8 +1198,11 @@   = do { result <- matchGlobalInst dflags False cls tys        ; case result of            OneInst { cir_what = what }-              -> addWarnTc (Reason Opt_WarnSimplifiableClassConstraints)-                                   (simplifiable_constraint_warn what)+              -> let dia = TcRnUnknownMessage $+                       mkPlainDiagnostic (WarningWithFlag Opt_WarnSimplifiableClassConstraints)+                                         noHints+                                         (simplifiable_constraint_warn what)+                 in addDiagnosticTc dia            _          -> return () }   where     pred = mkClassPred cls tys@@ -1366,7 +1255,7 @@   -- See Note [Implicit parameters in instance decls] okIPCtxt (FunSigCtxt {})        = True okIPCtxt (InfSigCtxt {})        = True-okIPCtxt ExprSigCtxt            = True+okIPCtxt (ExprSigCtxt {})       = True okIPCtxt TypeAppCtxt            = True okIPCtxt PatSigCtxt             = True okIPCtxt GenSigCtxt             = True@@ -1419,52 +1308,7 @@            , vcat [ text "In the context:" <+> pprTheta (tidyTypes env theta)                   , text "While checking" <+> pprUserTypeCtxt ctxt ] ) -eqPredTyErr, predTupleErr, predIrredErr,-   badQuantHeadErr :: TidyEnv -> PredType -> (TidyEnv, SDoc)-badQuantHeadErr env pred-  = ( env-    , hang (text "Quantified predicate must have a class or type variable head:")-         2 (ppr_tidy env pred) )-eqPredTyErr  env pred-  = ( env-    , text "Illegal equational constraint" <+> ppr_tidy env pred $$-      parens (text "Use GADTs or TypeFamilies to permit this") )-predTupleErr env pred-  = ( env-    , hang (text "Illegal tuple constraint:" <+> ppr_tidy env pred)-         2 (parens constraintKindsMsg) )-predIrredErr env pred-  = ( env-    , hang (text "Illegal constraint:" <+> ppr_tidy env pred)-         2 (parens constraintKindsMsg) )--predTyVarErr :: TidyEnv -> PredType -> (TidyEnv, SDoc)-predTyVarErr env pred-  = (env-    , vcat [ hang (text "Non type-variable argument")-                2 (text "in the constraint:" <+> ppr_tidy env pred)-           , parens (text "Use FlexibleContexts to permit this") ])--badIPPred :: TidyEnv -> PredType -> (TidyEnv, SDoc)-badIPPred env pred-  = ( env-    , text "Illegal implicit parameter" <+> quotes (ppr_tidy env pred) )--constraintSynErr :: TidyEnv -> Type -> (TidyEnv, SDoc)-constraintSynErr env kind-  = ( env-    , hang (text "Illegal constraint synonym of kind:" <+> quotes (ppr_tidy env kind))-         2 (parens constraintKindsMsg) )--dupPredWarn :: TidyEnv -> [NE.NonEmpty PredType] -> (TidyEnv, SDoc)-dupPredWarn env dups-  = ( env-    , text "Duplicate constraint" <> plural primaryDups <> text ":"-      <+> pprWithCommas (ppr_tidy env) primaryDups )-  where-    primaryDups = map NE.head dups--tyConArityErr :: TyCon -> [TcType] -> SDoc+tyConArityErr :: TyCon -> [TcType] -> TcRnMessage -- For type-constructor arity errors, be careful to report -- the number of /visible/ arguments required and supplied, -- ignoring the /invisible/ arguments, which the user does not see.@@ -1480,9 +1324,10 @@     tc_type_arity = count isVisibleTyConBinder (tyConBinders tc)     tc_type_args  = length vis_tks -arityErr :: Outputable a => SDoc -> a -> Int -> Int -> SDoc+arityErr :: Outputable a => SDoc -> a -> Int -> Int -> TcRnMessage arityErr what name n m-  = hsep [ text "The" <+> what, quotes (ppr name), text "should have",+  = TcRnUnknownMessage $ mkPlainError noHints $+    hsep [ text "The" <+> what, quotes (ppr name), text "should have",            n_arguments <> comma, text "but has been given",            if m==0 then text "none" else int m]     where@@ -1521,11 +1366,12 @@ Note [Instances of built-in classes in signature files] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -User defined instances for KnownNat, KnownSymbol and Typeable are-disallowed -- they are generated when needed by GHC itself on-the-fly.+User defined instances for KnownNat, KnownSymbol, KnownChar,+and Typeable are disallowed+  -- they are generated when needed by GHC itself, on-the-fly.  However, if they occur in a Backpack signature file, they have an-entirely different meaning. Suppose in M.hsig we see+entirely different meaning. To illustrate, suppose in M.hsig we see    signature M where     data T :: Nat@@ -1544,49 +1390,57 @@ check_special_inst_head :: DynFlags -> Bool -> Bool                         -> UserTypeCtxt -> Class -> [Type] -> TcM () -- Wow!  There are a surprising number of ad-hoc special cases here.+-- TODO: common up the logic for special typeclasses (see GHC ticket #20441). check_special_inst_head dflags is_boot is_sig ctxt clas cls_args    -- If not in an hs-boot file, abstract classes cannot have instances   | isAbstractClass clas   , not is_boot-  = failWithTc abstract_class_msg+  = failWithTc (TcRnAbstractClassInst clas) -  -- For Typeable, don't complain about instances for-  -- standalone deriving; they are no-ops, and we warn about-  -- it in GHC.Tc.Deriv.deriveStandalone.+  -- Complain about hand-written instances of built-in classes+  -- Typeable, KnownNat, KnownSymbol, Coercible, HasField.++  -- Disallow hand-written Typeable instances, except that we+  -- allow a standalone deriving declaration: they are no-ops,+  -- and we warn about them in GHC.Tc.Deriv.deriveStandalone.   | clas_nm == typeableClassName   , not is_sig     -- Note [Instances of built-in classes in signature files]   , hand_written_bindings-  = failWithTc rejected_class_msg+  = failWithTc $ TcRnSpecialClassInst clas False -  -- Handwritten instances of KnownNat/KnownSymbol class-  -- are always forbidden (#12837)-  | clas_nm `elem` [ knownNatClassName, knownSymbolClassName ]-  , not is_sig+  -- Handwritten instances of KnownNat/KnownChar/KnownSymbol+  -- are forbidden outside of signature files (#12837).+  -- Derived instances are forbidden completely (#21087).+  | clas_nm `elem` [ knownNatClassName, knownSymbolClassName, knownCharClassName ]+  , (not is_sig && hand_written_bindings) || derived_instance     -- Note [Instances of built-in classes in signature files]-  , hand_written_bindings-  = failWithTc rejected_class_msg+  = failWithTc $ TcRnSpecialClassInst clas False    -- For the most part we don't allow   -- instances for (~), (~~), or Coercible;   -- but we DO want to allow them in quantified constraints:   --   f :: (forall a b. Coercible a b => Coercible (m a) (m b)) => ...m...-  | clas_nm `elem` [ heqTyConName, eqTyConName, coercibleTyConName ]+  | clas_nm `elem` [ heqTyConName, eqTyConName, coercibleTyConName, withDictClassName ]   , not quantified_constraint-  = failWithTc rejected_class_msg+  = failWithTc $ TcRnSpecialClassInst clas False    -- Check for hand-written Generic instances (disallowed in Safe Haskell)   | clas_nm `elem` genericClassNames   , hand_written_bindings-  =  do { failIfTc (safeLanguageOn dflags) gen_inst_err-        ; when (safeInferOn dflags) (recordUnsafeInfer emptyBag) }+  =  do { failIfTc (safeLanguageOn dflags) (TcRnSpecialClassInst clas True)+        ; when (safeInferOn dflags) (recordUnsafeInfer emptyMessages) }    | clas_nm == hasFieldClassName+  , not quantified_constraint+  -- Don't do any validity checking for HasField contexts+  -- inside quantified constraints (#20989): the validity checks+  -- only apply to user-written instances.   = checkHasFieldInst clas cls_args    | isCTupleClass clas-  = failWithTc tuple_class_msg+  = failWithTc (TcRnTupleConstraintInst clas)    -- Check language restrictions on the args to the class   | check_h98_arg_shape@@ -1600,12 +1454,19 @@     ty_args = filterOutInvisibleTypes (classTyCon clas) cls_args      hand_written_bindings-        = case ctxt of-            InstDeclCtxt stand_alone -> not stand_alone-            SpecInstCtxt             -> False-            DerivClauseCtxt          -> False-            _                        -> True+      = case ctxt of+          InstDeclCtxt standalone -> not standalone+          SpecInstCtxt            -> False+          DerivClauseCtxt         -> False+          SigmaCtxt               -> False+          _                       -> True +    derived_instance+      = case ctxt of+            InstDeclCtxt standalone -> standalone+            DerivClauseCtxt         -> True+            _                       -> False+     check_h98_arg_shape = case ctxt of                             SpecInstCtxt    -> False                             DerivClauseCtxt -> False@@ -1637,15 +1498,6 @@                         text "Only one type can be given in an instance head." $$                         text "Use MultiParamTypeClasses if you want to allow more, or zero." -    rejected_class_msg = text "Class" <+> quotes (ppr clas_nm)-                         <+> text "does not support user-specified instances"-    tuple_class_msg    = text "You can't specify an instance for a tuple constraint"--    gen_inst_err = rejected_class_msg $$ nest 2 (text "(in Safe Haskell)")--    abstract_class_msg = text "Cannot define instance for abstract class"-                         <+> quotes (ppr clas_nm)-     mb_ty_args_msg       | not (xopt LangExt.TypeSynonymInstances dflags)       , not (all tcInstHeadTyNotSynonym ty_args)@@ -1713,9 +1565,10 @@ dropCastsB :: TyVarBinder -> TyVarBinder dropCastsB b = b   -- Don't bother in the kind of a forall -instTypeErr :: Class -> [Type] -> SDoc -> SDoc+instTypeErr :: Class -> [Type] -> SDoc -> TcRnMessage instTypeErr cls tys msg-  = hang (hang (text "Illegal instance declaration for")+  = TcRnUnknownMessage $ mkPlainError noHints $+    hang (hang (text "Illegal instance declaration for")              2 (quotes (pprClassPred cls tys)))        2 msg @@ -1745,7 +1598,7 @@ Consider the (bogus)      instance Eq Char# We elaborate to  'Eq (Char# |> UnivCo(hole))'  where the hole is an-insoluble equality constraint for * ~ #.  We'll report the insoluble+insoluble equality constraint for Type ~ TYPE WordRep.  We'll report the insoluble constraint separately, but we don't want to *also* complain that Eq is not applied to a type constructor.  So we look gaily look through CastTys here.@@ -1783,30 +1636,30 @@  It checks for three things -  * No repeated variables (hasNoDups fvs)+(VD1) No repeated variables (hasNoDups fvs) -  * No type constructors.  This is done by comparing+(VD2) No type constructors.  This is done by comparing         sizeTypes tys == length (fvTypes tys)-    sizeTypes counts variables and constructors; fvTypes returns variables.-    So if they are the same, there must be no constructors.  But there-    might be applications thus (f (g x)).+      sizeTypes counts variables and constructors; fvTypes returns variables.+      So if they are the same, there must be no constructors.  But there+      might be applications thus (f (g x)). -    Note that tys only includes the visible arguments of the class type-    constructor. Including the non-visible arguments can cause the following,-    perfectly valid instance to be rejected:-       class Category (cat :: k -> k -> *) where ...-       newtype T (c :: * -> * -> *) a b = MkT (c a b)-       instance Category c => Category (T c) where ...-    since the first argument to Category is a non-visible *, which sizeTypes-    would count as a constructor! See #11833.+      Note that tys only includes the visible arguments of the class type+      constructor. Including the non-visible arguments can cause the following,+      perfectly valid instance to be rejected:+         class Category (cat :: k -> k -> *) where ...+         newtype T (c :: * -> * -> *) a b = MkT (c a b)+         instance Category c => Category (T c) where ...+      since the first argument to Category is a non-visible *, which sizeTypes+      would count as a constructor! See #11833. -  * Also check for a bizarre corner case, when the derived instance decl-    would look like-       instance C a b => D (T a) where ...-    Note that 'b' isn't a parameter of T.  This gives rise to all sorts of-    problems; in particular, it's hard to compare solutions for equality-    when finding the fixpoint, and that means the inferContext loop does-    not converge.  See #5287.+(VD3) Also check for a bizarre corner case, when the derived instance decl+      would look like+         instance C a b => D (T a) where ...+      Note that 'b' isn't a parameter of T.  This gives rise to all sorts of+      problems; in particular, it's hard to compare solutions for equality+      when finding the fixpoint, and that means the inferContext loop does+      not converge.  See #5287, #21302  Note [Equality class instances] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1819,22 +1672,27 @@ validDerivPred :: TyVarSet -> PredType -> Bool -- See Note [Valid 'deriving' predicate] validDerivPred tv_set pred+  | not (tyCoVarsOfType pred `subVarSet` tv_set)+  = False  -- Check (VD3)++  | otherwise   = case classifyPredType pred of-       ClassPred cls tys -> cls `hasKey` typeableClassKey-                -- Typeable constraints are bigger than they appear due-                -- to kind polymorphism, but that's OK-                       || check_tys cls tys-       EqPred {}       -> False  -- reject equality constraints-       _               -> True   -- Non-class predicates are ok-  where-    check_tys cls tys-              = hasNoDups fvs-                   -- use sizePred to ignore implicit args-                && lengthIs fvs (sizePred pred)-                && all (`elemVarSet` tv_set) fvs-      where tys' = filterOutInvisibleTypes (classTyCon cls) tys-            fvs  = fvTypes tys' +       ClassPred cls tys+          | isTerminatingClass cls -> True+            -- Typeable constraints are bigger than they appear due+            -- to kind polymorphism, but that's OK++          | otherwise -> hasNoDups visible_fvs                        -- Check (VD1)+                      && lengthIs visible_fvs (sizeTypes visible_tys) -- Check (VD2)+          where+            visible_tys = filterOutInvisibleTypes (classTyCon cls) tys+            visible_fvs = fvTypes visible_tys++       IrredPred {}   -> True   -- Accept (f a)+       EqPred {}      -> False  -- Reject equality constraints+       ForAllPred {}  -> False  -- Rejects quantified predicates+ {- ************************************************************************ *                                                                      *@@ -1868,15 +1726,10 @@ checkValidInstance :: UserTypeCtxt -> LHsSigType GhcRn -> Type -> TcM () checkValidInstance ctxt hs_type ty   | not is_tc_app-  = failWithTc (hang (text "Instance head is not headed by a class:")-                   2 ( ppr tau))+  = failWithTc (TcRnNoClassInstHead tau)    | isNothing mb_cls-  = failWithTc (vcat [ text "Illegal instance for a" <+> ppr (tyConFlavour tc)-                     , text "A class instance must be for a class" ])--  | not arity_ok-  = failWithTc (text "Arity mis-match in instance head")+  = failWithTc (TcRnIllegalClassInst (tyConFlavour tc))    | otherwise   = do  { setSrcSpanA head_loc $@@ -1918,7 +1771,6 @@     TyConApp tc inst_tys = tau   -- See Note [Instances and constraint synonyms]     mb_cls               = tyConClass_maybe tc     Just clas            = mb_cls-    arity_ok             = inst_tys `lengthIs` classArity clas          -- The location of the "head" of the instance     head_loc = getLoc (getLHsInstDeclHead hs_type)@@ -1957,8 +1809,8 @@    check :: VarSet -> PredType -> TcM ()    check foralld_tvs pred      = case classifyPredType pred of-         EqPred {}    -> return ()  -- See #4200.-         IrredPred {} -> check2 foralld_tvs pred (sizeType pred)+         EqPred {}      -> return ()  -- See #4200.+         IrredPred {}   -> check2 foralld_tvs pred (sizeType pred)          ClassPred cls tys            | isTerminatingClass cls            -> return ()@@ -1978,9 +1830,12 @@               -- when the predicates are individually checked for validity     check2 foralld_tvs pred pred_size-     | not (null bad_tvs)     = failWithTc (noMoreMsg bad_tvs what (ppr head_pred))-     | not (isTyFamFree pred) = failWithTc (nestedMsg what)-     | pred_size >= head_size = failWithTc (smallerMsg what (ppr head_pred))+     | not (null bad_tvs)     = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $+       (noMoreMsg bad_tvs what (ppr head_pred))+     | not (isTyFamFree pred) = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $+       (nestedMsg what)+     | pred_size >= head_size = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $+       (smallerMsg what (ppr head_pred))      | otherwise              = return ()      -- isTyFamFree: see Note [Type families in instance contexts]      where@@ -2007,9 +1862,8 @@    occurs = if isSingleton tvs1 then text "occurs"                                else text "occur" -undecidableMsg, constraintKindsMsg :: SDoc-undecidableMsg     = text "Use UndecidableInstances to permit this"-constraintKindsMsg = text "Use ConstraintKinds to permit this"+undecidableMsg :: SDoc+undecidableMsg = text "Use UndecidableInstances to permit this"  {- Note [Type families in instance contexts] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -2063,8 +1917,9 @@     --   (b) failure of injectivity     check_branch_compat prev_branches cur_branch       | cur_branch `isDominatedBy` prev_branches-      = do { addWarnAt NoReason (coAxBranchSpan cur_branch) $-             inaccessibleCoAxBranch fam_tc cur_branch+      = do { let dia = TcRnUnknownMessage $+                   mkPlainDiagnostic WarningWithoutFlag noHints (inaccessibleCoAxBranch fam_tc cur_branch)+           ; addDiagnosticAt (coAxBranchSpan cur_branch) dia            ; return prev_branches }       | otherwise       = do { check_injectivity prev_branches cur_branch@@ -2133,8 +1988,7 @@            case drop (tyConArity fam_tc) typats of              [] -> pure ()              spec_arg:_ ->-               addErr $ text "Illegal oversaturated visible kind argument:"-                    <+> quotes (char '@' <> pprParendType spec_arg)+               addErr (TcRnOversaturatedVisibleKindArg spec_arg)           -- The argument patterns, and RHS, are all boxed tau types          -- E.g  Reject type family F (a :: k1) :: k2@@ -2180,7 +2034,7 @@     extract_tv pat pat_vis =       case getTyVar_maybe pat of         Just tv -> pure tv-        Nothing -> failWithTc $+        Nothing -> failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $           pprWithExplicitKindsWhen (isInvisibleArgFlag pat_vis) $           hang (text "Illegal argument" <+> quotes (ppr pat) <+> text "in:")              2 (vcat [ppr_eqn, suggestion])@@ -2198,6 +2052,7 @@       let dups = findDupsEq ((==) `on` fst) cpt_tvs_vis in       traverse_         (\d -> let (pat_tv, pat_vis) = NE.head d in failWithTc $+               TcRnUnknownMessage $ mkPlainError noHints $                pprWithExplicitKindsWhen (isInvisibleArgFlag pat_vis) $                hang (text "Illegal duplicate variable"                        <+> quotes (ppr pat_tv) <+> text "in:")@@ -2220,9 +2075,9 @@ -- checkFamInstRhs :: TyCon -> [Type]         -- LHS                 -> [(TyCon, [Type])]       -- type family calls in RHS-                -> [SDoc]+                -> [TcRnMessage] checkFamInstRhs lhs_tc lhs_tys famInsts-  = mapMaybe check famInsts+  = map (TcRnUnknownMessage . mkPlainError noHints) $ mapMaybe check famInsts   where    lhs_size  = sizeTyConAppArgs lhs_tc lhs_tys    inst_head = pprType (TyConApp lhs_tc lhs_tys)@@ -2293,7 +2148,7 @@     dodgy_tvs   = cpt_tvs `minusVarSet` inj_cpt_tvs      check_tvs tvs what what2-      = unless (null tvs) $ addErrAt (getSrcSpan (head tvs)) $+      = unless (null tvs) $ addErrAt (getSrcSpan (head tvs)) $ TcRnUnknownMessage $ mkPlainError noHints $         hang (text "Type variable" <> plural tvs <+> pprQuotedList tvs               <+> isOrAre tvs <+> what <> comma)            2 (vcat [ text "but not" <+> what2 <+> text "the family instance"@@ -2324,7 +2179,7 @@        -- Ensure that no type family applications occur a type pattern        ; case tcTyConAppTyFamInstsAndVis tc pat_ty_args of             [] -> pure ()-            ((tf_is_invis_arg, tf_tc, tf_args):_) -> failWithTc $+            ((tf_is_invis_arg, tf_tc, tf_args):_) -> failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $                ty_fam_inst_illegal_err tf_is_invis_arg                                        (mkTyConApp tf_tc tf_args) }   where@@ -2349,12 +2204,6 @@   = sep [ text "Illegal nested" <+> what         , parens undecidableMsg ] -badATErr :: Name -> Name -> SDoc-badATErr clas op-  = hsep [text "Class", quotes (ppr clas),-          text "does not have an associated type", quotes (ppr op)]-- ------------------------- checkConsistentFamInst :: AssocInstInfo                        -> TyCon     -- ^ Family tycon@@ -2379,7 +2228,7 @@        -- See [Mismatched class methods and associated type families]        -- in TcInstDecls.        ; checkTc (Just (classTyCon clas) == tyConAssoc_maybe fam_tc)-                 (badATErr (className clas) (tyConName fam_tc))+                 (TcRnBadAssociatedType (className clas) (tyConName fam_tc))         ; check_match arg_triples        }@@ -2431,7 +2280,7 @@       , Just rl_subst1 <- tcMatchTyX_BM bind_me rl_subst ty2 ty1       = go lr_subst1 rl_subst1 triples       | otherwise-      = addErrTc (pp_wrong_at_arg vis)+      = addErrTc (TcRnUnknownMessage $ mkPlainError noHints $ pp_wrong_at_arg vis)      -- The /scoped/ type variables from the class-instance header     -- should not be alpha-renamed.  Inferred ones can be.@@ -2859,7 +2708,7 @@ checkTyConTelescope tc   | bad_scope   = -- See "Ill-scoped binders" in Note [Bad TyCon telescopes]-    addErr $+    addErr $ TcRnUnknownMessage $ mkPlainError noHints $     vcat [ hang (text "The kind of" <+> quotes (ppr tc) <+> text "is ill-scoped")               2 pp_tc_kind          , extra@@ -2958,26 +2807,6 @@ sizeTyConAppArgs _tc tys = sizeTypes tys -- (filterOutInvisibleTypes tc tys)                            -- See Note [Invisible arguments and termination] --- Size of a predicate------ We are considering whether class constraints terminate.--- Equality constraints and constraints for the implicit--- parameter class always terminate so it is safe to say "size 0".--- See #4200.-sizePred :: PredType -> Int-sizePred ty = goClass ty-  where-    goClass p = go (classifyPredType p)--    go (ClassPred cls tys')-      | isTerminatingClass cls = 0-      | otherwise = sizeTypes (filterOutInvisibleTypes (classTyCon cls) tys')-                    -- The filtering looks bogus-                    -- See Note [Invisible arguments and termination]-    go (EqPred {})           = 0-    go (IrredPred ty)        = sizeType ty-    go (ForAllPred _ _ pred) = goClass pred- -- | When this says "True", ignore this class constraint during -- a termination check isTerminatingClass :: Class -> Bool@@ -2988,10 +2817,6 @@     || isEqPredClass cls     || cls `hasKey` typeableClassKey     || cls `hasKey` coercibleTyConKey---- | Tidy before printing a type-ppr_tidy :: TidyEnv -> Type -> SDoc-ppr_tidy env ty = pprType (tidyType env ty)  allDistinctTyVars :: TyVarSet -> [KindOrType] -> Bool -- (allDistinctTyVars tvs tys) returns True if tys are
GHC/ThToHs.hs view
@@ -4,6 +4,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-}@@ -56,7 +57,6 @@  import qualified Data.ByteString as BS import Control.Monad( unless, ap )- import Data.Maybe( catMaybes, isNothing ) import Language.Haskell.TH as TH hiding (sigP) import Language.Haskell.TH.Syntax as TH@@ -96,9 +96,8 @@ -- Reason: so a (head []) in TH code doesn't subsequently --         make GHC crash when it tries to walk the generated tree --- Use the loc everywhere, for lack of anything better--- In particular, we want it on binding locations, so that variables bound in--- the spliced-in declarations get a location that at least relates to the splice point+-- Use the SrcSpan everywhere, for lack of anything better.+-- See Note [Source locations within TH splices].  instance Applicative CvtM where     pure x = CvtM $ \_ loc -> Right (loc,x)@@ -124,23 +123,18 @@ getL :: CvtM SrcSpan getL = CvtM (\_ loc -> Right (loc,loc)) +-- NB: This is only used in conjunction with LineP pragmas.+-- See Note [Source locations within TH splices]. setL :: SrcSpan -> CvtM () setL loc = CvtM (\_ _ -> Right (loc, ())) -returnL :: a -> CvtM (Located a)-returnL x = CvtM (\_ loc -> Right (loc, L loc x))---- returnLA :: a -> CvtM (LocatedA a)-returnLA :: e -> CvtM (GenLocated (SrcSpanAnn' (EpAnn ann)) e)+returnLA :: e -> CvtM (LocatedAn ann e) returnLA x = CvtM (\_ loc -> Right (loc, L (noAnnSrcSpan loc) x))  returnJustLA :: a -> CvtM (Maybe (LocatedA a)) returnJustLA = fmap Just . returnLA --- wrapParL :: (Located a -> a) -> a -> CvtM a--- wrapParL add_par x = CvtM (\_ loc -> Right (loc, add_par (L loc x)))--wrapParLA :: (LocatedA a -> a) -> a -> CvtM a+wrapParLA :: (LocatedAn ann a -> b) -> a -> CvtM b wrapParLA add_par x = CvtM (\_ loc -> Right (loc, add_par (L (noAnnSrcSpan loc) x)))  wrapMsg :: (Show a, TH.Ppr a) => String -> a -> CvtM b -> CvtM b@@ -172,6 +166,41 @@   Left err -> Left err   Right (loc', v) -> Right (loc', L (noAnnSrcSpan loc) v) +{-+Note [Source locations within TH splices]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider a TH splice such as $(x), where `x` evaluates to `id True`. What+source locations should we use for subexpressions within the splice, such as+`id` and `True`? We basically have two options:++1. Don't give anything within the splice a SrcSpan. That is, use the `noLoc`+   everywhere.+2. Give everything within the splice the same `SrcSpan` as where the splice+   occurs (i.e., where $(x) occurs).++We implement option (2) for the following reasons:++* We want SrcSpans on binding locations so that variables bound in the+  spliced-in declarations get a location that at least relates to the splice+  point.++* Generally speaking, having *some* SrcSpan for each sub-expression in the AST+  in better than having no SrcSpan at all. This extra information can be useful+  for programs that walk over the AST directly.++Because of our choice of option (2), we are very careful not to use the noLoc+function anywhere in GHC.ThToHs. Instead, we thread around a SrcSpan in CvtM+and allow retrieving the SrcSpan through combinators such as getL, returnLA,+wrapParLA, etc.++Note that CvtM is actually a *state* monad vis-à-vis SrcSpan, not just a+reader monad. This is because LineP pragmas can change the source location+within a splice—see testsuite/tests/th/TH_linePragma.hs for an example. This+is a bit unusual, since it changes the source location from that of the splice+point to that of the code being spliced in. Nevertheless, LineP is *the* reason+why CvtM is a state monad.+-}+ ------------------------------------------------------------------- cvtDecs :: [TH.Dec] -> CvtM [LHsDecl GhcPs] cvtDecs = fmap catMaybes . mapM cvtDec@@ -226,6 +255,10 @@        ; returnJustLA (Hs.SigD noExtField (FixSig noAnn                                       (FixitySig noExtField [nm'] (cvtFixity fx)))) } +cvtDec (TH.DefaultD tys)+  = do  { tys' <- traverse cvtType tys+        ; returnJustLA (Hs.DefD noExtField $ DefaultDecl noAnn tys') }+ cvtDec (PragmaD prag)   = cvtPragmaD prag @@ -255,7 +288,7 @@         ; derivs' <- cvtDerivs derivs         ; let defn = HsDataDefn { dd_ext = noExtField                                 , dd_ND = DataType, dd_cType = Nothing-                                , dd_ctxt = Just ctxt'+                                , dd_ctxt = mkHsContextMaybe ctxt'                                 , dd_kindSig = ksig'                                 , dd_cons = cons', dd_derivs = derivs' }         ; returnJustLA $ TyClD noExtField $@@ -271,7 +304,7 @@         ; derivs' <- cvtDerivs derivs         ; let defn = HsDataDefn { dd_ext = noExtField                                 , dd_ND = NewType, dd_cType = Nothing-                                , dd_ctxt = Just ctxt'+                                , dd_ctxt = mkHsContextMaybe ctxt'                                 , dd_kindSig = ksig'                                 , dd_cons = [con']                                 , dd_derivs = derivs' }@@ -291,7 +324,7 @@                    $$ (Outputable.ppr adts'))         ; returnJustLA $ TyClD noExtField $           ClassDecl { tcdCExt = (noAnn, NoAnnSortKey, NoLayoutInfo)-                    , tcdCtxt = Just cxt', tcdLName = tc', tcdTyVars = tvs'+                    , tcdCtxt = mkHsContextMaybe cxt', tcdLName = tc', tcdTyVars = tvs'                     , tcdFixity = Prefix                     , tcdFDs = fds', tcdSigs = Hs.mkClassOpSigs sigs'                     , tcdMeths = binds'@@ -342,12 +375,12 @@        ; derivs' <- cvtDerivs derivs        ; let defn = HsDataDefn { dd_ext = noExtField                                , dd_ND = DataType, dd_cType = Nothing-                               , dd_ctxt = Just ctxt'+                               , dd_ctxt = mkHsContextMaybe ctxt'                                , dd_kindSig = ksig'                                , dd_cons = cons', dd_derivs = derivs' }         ; returnJustLA $ InstD noExtField $ DataFamInstD-           { dfid_ext = noAnn+           { dfid_ext = noExtField            , dfid_inst = DataFamInstDecl { dfid_eqn =                            FamEqn { feqn_ext = noAnn                                   , feqn_tycon = tc'@@ -363,11 +396,11 @@        ; derivs' <- cvtDerivs derivs        ; let defn = HsDataDefn { dd_ext = noExtField                                , dd_ND = NewType, dd_cType = Nothing-                               , dd_ctxt = Just ctxt'+                               , dd_ctxt = mkHsContextMaybe ctxt'                                , dd_kindSig = ksig'                                , dd_cons = [con'], dd_derivs = derivs' }        ; returnJustLA $ InstD noExtField $ DataFamInstD-           { dfid_ext = noAnn+           { dfid_ext = noExtField            , dfid_inst = DataFamInstDecl { dfid_eqn =                            FamEqn { feqn_ext = noAnn                                   , feqn_tycon = tc'@@ -397,7 +430,7 @@  cvtDec (TH.RoleAnnotD tc roles)   = do { tc' <- tconNameN tc-       ; let roles' = map (noLoc . cvtRole) roles+       ; roles' <- traverse (returnLA . cvtRole) roles        ; returnJustLA                    $ Hs.RoleAnnotD noExtField (RoleAnnotDecl noAnn tc' roles') } @@ -440,7 +473,7 @@     cvtDir n (ExplBidir cls) =       do { ms <- mapM (cvtClause (mkPrefixFunRhs n)) cls          ; th_origin <- getOrigin-         ; return $ ExplicitBidirectional $ mkMatchGroup th_origin (noLocA ms) }+         ; wrapParLA (ExplicitBidirectional . mkMatchGroup th_origin) ms }  cvtDec (TH.PatSynSigD nm ty)   = do { nm' <- cNameN nm@@ -602,8 +635,8 @@ cvtConstr (RecC c varstrtys)   = do  { c'    <- cNameN c         ; args' <- mapM cvt_id_arg varstrtys-        ; returnLA $ mkConDeclH98 noAnn c' Nothing Nothing-                                   (RecCon (noLocA args')) }+        ; con_decl <- wrapParLA (mkConDeclH98 noAnn c' Nothing Nothing . RecCon) args'+        ; returnLA con_decl }  cvtConstr (InfixC st1 c st2)   = do  { c'   <- cNameN c@@ -618,7 +651,7 @@         ; L _ con'  <- cvtConstr con         ; returnLA $ add_forall tvs' ctxt' con' }   where-    add_cxt lcxt         Nothing           = Just lcxt+    add_cxt lcxt         Nothing           = mkHsContextMaybe lcxt     add_cxt (L loc cxt1) (Just (L _ cxt2))       = Just (L loc (cxt1 ++ cxt2)) @@ -650,7 +683,7 @@   = do  { c'      <- mapM cNameN c         ; args    <- mapM cvt_arg strtys         ; ty'     <- cvtType ty-        ; returnLA $ mk_gadt_decl c' (PrefixConGADT $ map hsLinear args) ty'}+        ; mk_gadt_decl c' (PrefixConGADT $ map hsLinear args) ty'}  cvtConstr (RecGadtC [] _varstrtys _ty)   = failWith (text "RecGadtC must have at least one constructor name")@@ -659,18 +692,21 @@   = do  { c'       <- mapM cNameN c         ; ty'      <- cvtType ty         ; rec_flds <- mapM cvt_id_arg varstrtys-        ; returnLA $ mk_gadt_decl c' (RecConGADT $ noLocA rec_flds) ty' }+        ; lrec_flds <- returnLA rec_flds+        ; mk_gadt_decl c' (RecConGADT lrec_flds noHsUniTok) ty' }  mk_gadt_decl :: [LocatedN RdrName] -> HsConDeclGADTDetails GhcPs -> LHsType GhcPs-             -> ConDecl GhcPs+             -> CvtM (LConDecl GhcPs) mk_gadt_decl names args res_ty-  = ConDeclGADT { con_g_ext  = noAnn-                , con_names  = names-                , con_bndrs  = noLocA mkHsOuterImplicit-                , con_mb_cxt = Nothing-                , con_g_args = args-                , con_res_ty = res_ty-                , con_doc    = Nothing }+  = do bndrs <- returnLA mkHsOuterImplicit+       returnLA $ ConDeclGADT+                   { con_g_ext  = noAnn+                   , con_names  = names+                   , con_bndrs  = bndrs+                   , con_mb_cxt = Nothing+                   , con_g_args = args+                   , con_res_ty = res_ty+                   , con_doc    = Nothing }  cvtSrcUnpackedness :: TH.SourceUnpackedness -> SrcUnpackedness cvtSrcUnpackedness NoSourceUnpackedness = NoSrcUnpack@@ -694,12 +730,12 @@ cvt_id_arg (i, str, ty)   = do  { L li i' <- vNameN i         ; ty' <- cvt_arg (str,ty)-        ; return $ noLocA (ConDeclField+        ; returnLA $ ConDeclField                           { cd_fld_ext = noAnn                           , cd_fld_names-                              = [L (locA li) $ FieldOcc noExtField (L li i')]+                              = [L (l2l li) $ FieldOcc noExtField (L li i')]                           , cd_fld_type =  ty'-                          , cd_fld_doc = Nothing}) }+                          , cd_fld_doc = Nothing} }  cvtDerivs :: [TH.DerivClause] -> CvtM (HsDeriving GhcPs) cvtDerivs cs = do { mapM cvtDerivClause cs }@@ -715,21 +751,22 @@ ------------------------------------------  cvtForD :: Foreign -> CvtM (ForeignDecl GhcPs)-cvtForD (ImportF callconv safety from nm ty)-  -- the prim and javascript calling conventions do not support headers-  -- and are inserted verbatim, analogous to mkImport in GHC.Parser.PostProcess-  | callconv == TH.Prim || callconv == TH.JavaScript-  = mk_imp (CImport (noLoc (cvt_conv callconv)) (noLoc safety') Nothing-                    (CFunction (StaticTarget (SourceText from)-                                             (mkFastString from) Nothing-                                             True))-                    (noLoc $ quotedSourceText from))-  | Just impspec <- parseCImport (noLoc (cvt_conv callconv)) (noLoc safety')-                                 (mkFastString (TH.nameBase nm))-                                 from (noLoc $ quotedSourceText from)-  = mk_imp impspec-  | otherwise-  = failWith $ text (show from) <+> text "is not a valid ccall impent"+cvtForD (ImportF callconv safety from nm ty) =+  do { l <- getL+     ; if -- the prim and javascript calling conventions do not support headers+          -- and are inserted verbatim, analogous to mkImport in GHC.Parser.PostProcess+          |  callconv == TH.Prim || callconv == TH.JavaScript+          -> mk_imp (CImport (L l (cvt_conv callconv)) (L l safety') Nothing+                             (CFunction (StaticTarget (SourceText from)+                                                      (mkFastString from) Nothing+                                                      True))+                             (L l $ quotedSourceText from))+          |  Just impspec <- parseCImport (L l (cvt_conv callconv)) (L l safety')+                                          (mkFastString (TH.nameBase nm))+                                          from (L l $ quotedSourceText from)+          -> mk_imp impspec+          |  otherwise+          -> failWith $ text (show from) <+> text "is not a valid ccall impent" }   where     mk_imp impspec       = do { nm' <- vNameN nm@@ -747,10 +784,11 @@ cvtForD (ExportF callconv as nm ty)   = do  { nm' <- vNameN nm         ; ty' <- cvtSigType ty-        ; let e = CExport (noLoc (CExportStatic (SourceText as)-                                                (mkFastString as)-                                                (cvt_conv callconv)))-                                                (noLoc (SourceText as))+        ; l <- getL+        ; let e = CExport (L l (CExportStatic (SourceText as)+                                              (mkFastString as)+                                              (cvt_conv callconv)))+                                              (L l (SourceText as))         ; return $ ForeignExport { fd_e_ext = noAnn                                  , fd_name = nm'                                  , fd_sig_ty = ty'@@ -774,25 +812,40 @@        ; let src TH.NoInline  = "{-# NOINLINE"              src TH.Inline    = "{-# INLINE"              src TH.Inlinable = "{-# INLINABLE"-       ; let ip   = InlinePragma { inl_src    = SourceText $ src inline-                                 , inl_inline = cvtInline inline+       ; let ip   = InlinePragma { inl_src    = toSrcTxt inline+                                 , inl_inline = cvtInline inline (toSrcTxt inline)                                  , inl_rule   = cvtRuleMatch rm                                  , inl_act    = cvtPhases phases dflt                                  , inl_sat    = Nothing }+                    where+                     toSrcTxt a = SourceText $ src a        ; returnJustLA $ Hs.SigD noExtField $ InlineSig noAnn nm' ip } +cvtPragmaD (OpaqueP nm)+  = do { nm' <- vNameN nm+       ; let ip = InlinePragma { inl_src    = srcTxt+                               , inl_inline = Opaque srcTxt+                               , inl_rule   = Hs.FunLike+                               , inl_act    = NeverActive+                               , inl_sat    = Nothing }+                  where+                    srcTxt = SourceText "{-# OPAQUE"+       ; returnJustLA $ Hs.SigD noExtField $ InlineSig noAnn nm' ip }+ cvtPragmaD (SpecialiseP nm ty inline phases)   = do { nm' <- vNameN nm        ; ty' <- cvtSigType ty        ; let src TH.NoInline  = "{-# SPECIALISE NOINLINE"              src TH.Inline    = "{-# SPECIALISE INLINE"              src TH.Inlinable = "{-# SPECIALISE INLINE"-       ; let (inline', dflt,srcText) = case inline of-               Just inline1 -> (cvtInline inline1, dfltActivation inline1,-                                src inline1)+       ; let (inline', dflt, srcText) = case inline of+               Just inline1 -> (cvtInline inline1 (toSrcTxt inline1), dfltActivation inline1,+                                toSrcTxt inline1)                Nothing      -> (NoUserInlinePrag,   AlwaysActive,-                                "{-# SPECIALISE")-       ; let ip = InlinePragma { inl_src    = SourceText srcText+                                SourceText "{-# SPECIALISE")+               where+                toSrcTxt a = SourceText $ src a+       ; let ip = InlinePragma { inl_src    = srcText                                , inl_inline = inline'                                , inl_rule   = Hs.FunLike                                , inl_act    = cvtPhases phases dflt@@ -806,22 +859,24 @@  cvtPragmaD (RuleP nm ty_bndrs tm_bndrs lhs rhs phases)   = do { let nm' = mkFastString nm+       ; rd_name' <- returnLA (quotedSourceText nm,nm')        ; let act = cvtPhases phases AlwaysActive        ; ty_bndrs' <- traverse cvtTvs ty_bndrs        ; tm_bndrs' <- mapM cvtRuleBndr tm_bndrs        ; lhs'   <- cvtl lhs        ; rhs'   <- cvtl rhs+       ; rule <- returnLA $+                   HsRule { rd_ext  = noAnn+                          , rd_name = rd_name'+                          , rd_act  = act+                          , rd_tyvs = ty_bndrs'+                          , rd_tmvs = tm_bndrs'+                          , rd_lhs  = lhs'+                          , rd_rhs  = rhs' }        ; returnJustLA $ Hs.RuleD noExtField             $ HsRules { rds_ext = noAnn                       , rds_src = SourceText "{-# RULES"-                      , rds_rules = [noLocA $-                          HsRule { rd_ext  = noAnn-                                 , rd_name = (noLoc (quotedSourceText nm,nm'))-                                 , rd_act  = act-                                 , rd_tyvs = ty_bndrs'-                                 , rd_tmvs = tm_bndrs'-                                 , rd_lhs  = lhs'-                                 , rd_rhs  = rhs' }] }+                      , rds_rules = [rule] }            } @@ -831,20 +886,22 @@          ModuleAnnotation  -> return ModuleAnnProvenance          TypeAnnotation n  -> do            n' <- tconName n-           return (TypeAnnProvenance  (noLocA n'))+           wrapParLA TypeAnnProvenance n'          ValueAnnotation n -> do            n' <- vcName n-           return (ValueAnnProvenance (noLocA n'))+           wrapParLA ValueAnnProvenance n'        ; returnJustLA $ Hs.AnnD noExtField                      $ HsAnnotation noAnn (SourceText "{-# ANN") target' exp'        } +-- NB: This is the only place in GHC.ThToHs that makes use of the `setL`+-- function. See Note [Source locations within TH splices]. cvtPragmaD (LineP line file)   = do { setL (srcLocSpan (mkSrcLoc (fsLit file) line 1))        ; return Nothing        } cvtPragmaD (CompleteP cls mty)-  = do { cls' <- noLoc <$> mapM cNameN cls+  = do { cls'  <- wrapL $ mapM cNameN cls        ; mty'  <- traverse tconNameN mty        ; returnJustLA $ Hs.SigD noExtField                    $ CompleteMatchSig noAnn NoSourceText cls' mty' }@@ -853,10 +910,10 @@ dfltActivation TH.NoInline = NeverActive dfltActivation _           = AlwaysActive -cvtInline :: TH.Inline -> Hs.InlineSpec-cvtInline TH.NoInline  = Hs.NoInline-cvtInline TH.Inline    = Hs.Inline-cvtInline TH.Inlinable = Hs.Inlinable+cvtInline :: TH.Inline  -> SourceText -> Hs.InlineSpec+cvtInline TH.NoInline   srcText  = Hs.NoInline  srcText+cvtInline TH.Inline     srcText  = Hs.Inline    srcText+cvtInline TH.Inlinable  srcText  = Hs.Inlinable srcText  cvtRuleMatch :: TH.RuleMatch -> RuleMatchInfo cvtRuleMatch TH.ConLike = Hs.ConLike@@ -870,11 +927,11 @@ cvtRuleBndr :: TH.RuleBndr -> CvtM (Hs.LRuleBndr GhcPs) cvtRuleBndr (RuleVar n)   = do { n' <- vNameN n-       ; return $ noLoc $ Hs.RuleBndr noAnn n' }+       ; returnLA $ Hs.RuleBndr noAnn n' } cvtRuleBndr (TypedRuleVar n ty)   = do { n'  <- vNameN n        ; ty' <- cvtType ty-       ; return $ noLoc $ Hs.RuleBndrSig noAnn n' $ mkHsPatSigType noAnn ty' }+       ; returnLA $ Hs.RuleBndrSig noAnn n' $ mkHsPatSigType noAnn ty' }  --------------------------------------------------- --              Declarations@@ -909,7 +966,7 @@ cvtImplicitParamBind n e = do     n' <- wrapL (ipName n)     e' <- cvtl e-    returnLA (IPBind noAnn (Left n') e')+    returnLA (IPBind noAnn (reLocA n') e')  ------------------------------------------------------------------- --              Expressions@@ -918,8 +975,8 @@ cvtl :: TH.Exp -> CvtM (LHsExpr GhcPs) cvtl e = wrapLA (cvt e)   where-    cvt (VarE s)   = do { s' <- vName s; return $ HsVar noExtField (noLocA s') }-    cvt (ConE s)   = do { s' <- cName s; return $ HsVar noExtField (noLocA s') }+    cvt (VarE s)   = do { s' <- vName s; wrapParLA (HsVar noExtField) s' }+    cvt (ConE s)   = do { s' <- cName s; wrapParLA (HsVar noExtField) s' }     cvt (LitE l)       | overloadedLit l = go cvtOverLit (HsOverLit noComments)                              (hsOverLitNeedsParens appPrec)@@ -933,7 +990,7 @@         go cvt_lit mk_expr is_compound_lit = do           l' <- cvt_lit l           let e' = mk_expr l'-          return $ if is_compound_lit l' then HsPar noAnn (noLocA e') else e'+          if is_compound_lit l' then wrapParLA gHsPar e' else pure e'     cvt (AppE x@(LamE _ _) y) = do { x' <- cvtl x; y' <- cvtl y                                    ; return $ HsApp noComments (mkLHsPar x')                                                           (mkLHsPar y')}@@ -952,20 +1009,23 @@     cvt (LamE ps e)    = do { ps' <- cvtPats ps; e' <- cvtl e                             ; let pats = map (parenthesizePat appPrec) ps'                             ; th_origin <- getOrigin-                            ; return $ HsLam noExtField (mkMatchGroup th_origin-                                             (noLocA [mkSimpleMatch LambdaExpr-                                             pats e']))}-    cvt (LamCaseE ms)  = do { ms' <- mapM (cvtMatch CaseAlt) ms+                            ; wrapParLA (HsLam noExtField . mkMatchGroup th_origin)+                                        [mkSimpleMatch LambdaExpr pats e']}+    cvt (LamCaseE ms)  = do { ms' <- mapM (cvtMatch $ LamCaseAlt LamCase) ms                             ; th_origin <- getOrigin-                            ; return $ HsLamCase noAnn-                                                   (mkMatchGroup th_origin (noLocA ms'))+                            ; wrapParLA (HsLamCase noAnn LamCase . mkMatchGroup th_origin) ms'                             }+    cvt (LamCasesE ms)+      | null ms   = failWith (text "\\cases expression with no alternatives")+      | otherwise = do { ms' <- mapM (cvtClause $ LamCaseAlt LamCases) ms+                       ; th_origin <- getOrigin+                       ; wrapParLA (HsLamCase noAnn LamCases . mkMatchGroup th_origin) ms'+                       }     cvt (TupE es)        = cvt_tup es Boxed     cvt (UnboxedTupE es) = cvt_tup es Unboxed     cvt (UnboxedSumE e alt arity) = do { e' <- cvtl e                                        ; unboxedSumChecks alt arity-                                       ; return $ ExplicitSum noAnn-                                                                   alt arity e'}+                                       ; return $ ExplicitSum noAnn alt arity e'}     cvt (CondE x y z)  = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z;                             ; return $ mkHsIf x' y' z' noAnn }     cvt (MultiIfE alts)@@ -973,11 +1033,10 @@       | otherwise      = do { alts' <- mapM cvtpair alts                             ; return $ HsMultiIf noAnn alts' }     cvt (LetE ds e)    = do { ds' <- cvtLocalDecs (text "a let expression") ds-                            ; e' <- cvtl e; return $ HsLet noAnn ds' e'}+                            ; e' <- cvtl e; return $ HsLet noAnn noHsTok ds' noHsTok e'}     cvt (CaseE e ms)   = do { e' <- cvtl e; ms' <- mapM (cvtMatch CaseAlt) ms                             ; th_origin <- getOrigin-                            ; return $ HsCase noAnn e'-                                                 (mkMatchGroup th_origin (noLocA ms')) }+                            ; wrapParLA (HsCase noAnn e' . mkMatchGroup th_origin) ms' }     cvt (DoE m ss)     = cvtHsDo (DoExpr (mk_mod <$> m)) ss     cvt (MDoE m ss)    = cvtHsDo (MDoExpr (mk_mod <$> m)) ss     cvt (CompE ss)     = cvtHsDo ListComp ss@@ -998,7 +1057,7 @@          ; y' <- cvtl y          ; let px = parenthesizeHsExpr opPrec x'                py = parenthesizeHsExpr opPrec y'-         ; wrapParLA (HsPar noAnn)+         ; wrapParLA gHsPar            $ OpApp noAnn px s' py }            -- Parenthesise both arguments and result,            -- to ensure this operator application does@@ -1006,17 +1065,17 @@            -- See Note [Operator association]     cvt (InfixE Nothing  s (Just y)) = ensureValidOpExp s $                                        do { s' <- cvtl s; y' <- cvtl y-                                          ; wrapParLA (HsPar noAnn) $+                                          ; wrapParLA gHsPar $                                                           SectionR noComments s' y' }                                             -- See Note [Sections in HsSyn] in GHC.Hs.Expr     cvt (InfixE (Just x) s Nothing ) = ensureValidOpExp s $                                        do { x' <- cvtl x; s' <- cvtl s-                                          ; wrapParLA (HsPar noAnn) $+                                          ; wrapParLA gHsPar $                                                           SectionL noComments x' s' }      cvt (InfixE Nothing  s Nothing ) = ensureValidOpExp s $                                        do { s' <- cvtl s-                                          ; return $ HsPar noAnn s' }+                                          ; return $ gHsPar s' }                                        -- Can I indicate this is an infix thing?                                        -- Note [Dropping constructors] @@ -1027,16 +1086,16 @@                                             _ -> mkLHsPar x'                               ; cvtOpApp x'' s y } --  Note [Converting UInfix] -    cvt (ParensE e)      = do { e' <- cvtl e; return $ HsPar noAnn e' }+    cvt (ParensE e)      = do { e' <- cvtl e; return $ gHsPar e' }     cvt (SigE e t)       = do { e' <- cvtl e; t' <- cvtSigType t                               ; let pe = parenthesizeHsExpr sigPrec e'                               ; return $ ExprWithTySig noAnn pe (mkHsWildCardBndrs t') }     cvt (RecConE c flds) = do { c' <- cNameN c-                              ; flds' <- mapM (cvtFld (mkFieldOcc . noLocA)) flds+                              ; flds' <- mapM (cvtFld (wrapParLA mkFieldOcc)) flds                               ; return $ mkRdrRecordCon c' (HsRecFields flds' Nothing) noAnn }     cvt (RecUpdE e flds) = do { e' <- cvtl e                               ; flds'-                                  <- mapM (cvtFld (mkAmbiguousFieldOcc . noLocA))+                                  <- mapM (cvtFld (wrapParLA mkAmbiguousFieldOcc))                                            flds                               ; return $ RecordUpd noAnn e' (Left flds') }     cvt (StaticE e)      = fmap (HsStatic noAnn) $ cvtl e@@ -1044,12 +1103,12 @@                               -- important, because UnboundVarE may contain                               -- constructor names - see #14627.                               { s' <- vcName s-                              ; return $ HsVar noExtField (noLocA s') }+                              ; wrapParLA (HsVar noExtField) s' }     cvt (LabelE s)       = return $ HsOverLabel noComments (fsLit s)     cvt (ImplicitParamVarE n) = do { n' <- ipName n; return $ HsIPVar noComments n' }     cvt (GetFieldE exp f) = do { e' <- cvtl exp-                               ; return $ HsGetField noComments e' (L noSrcSpan (HsFieldLabel noAnn (L noSrcSpan (fsLit f)))) }-    cvt (ProjectionE xs) = return $ HsProjection noAnn $ fmap (L noSrcSpan . HsFieldLabel noAnn . L noSrcSpan . fsLit) xs+                               ; return $ HsGetField noComments e' (L noSrcSpanA (DotFieldOcc noAnn (L noSrcSpanA (fsLit f)))) }+    cvt (ProjectionE xs) = return $ HsProjection noAnn $ fmap (L noSrcSpanA . DotFieldOcc noAnn . L noSrcSpanA . fsLit) xs  {- | #16895 Ensure an infix expression's operator is a variable/constructor. Consider this example:@@ -1084,14 +1143,16 @@ which we don't want. -} -cvtFld :: (RdrName -> t) -> (TH.Name, TH.Exp)-       -> CvtM (LHsRecField' GhcPs t (LHsExpr GhcPs))+cvtFld :: (RdrName -> CvtM t) -> (TH.Name, TH.Exp)+       -> CvtM (LHsFieldBind GhcPs (LocatedAn NoEpAnns t) (LHsExpr GhcPs)) cvtFld f (v,e)-  = do  { v' <- vNameL v; e' <- cvtl e-        ; return (noLocA $ HsRecField { hsRecFieldAnn = noAnn-                                      , hsRecFieldLbl = reLoc $ fmap f v'-                                      , hsRecFieldArg = e'-                                      , hsRecPun      = False}) }+  = do  { v' <- vNameL v+        ; lhs' <- traverse f v'+        ; e' <- cvtl e+        ; returnLA $ HsFieldBind { hfbAnn = noAnn+                                 , hfbLHS = la2la lhs'+                                 , hfbRHS = e'+                                 , hfbPun = False} }  cvtDD :: Range -> CvtM (ArithSeqInfo GhcPs) cvtDD (FromR x)           = do { x' <- cvtl x; return $ From x' }@@ -1109,6 +1170,7 @@                                     boxity }  {- Note [Operator association]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~ We must be quite careful about adding parens:   * Infix (UInfix ...) op arg      Needs parens round the first arg   * Infix (Infix ...) op arg       Needs parens round the first arg@@ -1118,15 +1180,17 @@  Note [Converting UInfix] ~~~~~~~~~~~~~~~~~~~~~~~~-When converting @UInfixE@, @UInfixP@, and @UInfixT@ values, we want to readjust-the trees to reflect the fixities of the underlying operators:+When converting @UInfixE@, @UInfixP@, @UInfixT@, and @PromotedUInfixT@ values,+we want to readjust the trees to reflect the fixities of the underlying+operators:    UInfixE x * (UInfixE y + z) ---> (x * y) + z  This is done by the renamer (see @mkOppAppRn@, @mkConOppPatRn@, and-@mkHsOpTyRn@ in GHC.Rename.HsType), which expects that the input will be completely-right-biased for types and left-biased for everything else. So we left-bias the-trees of @UInfixP@ and @UInfixE@ and right-bias the trees of @UInfixT@.+@mkHsOpTyRn@ in GHC.Rename.HsType), which expects that the input will be+completely right-biased for types and left-biased for everything else. So we+left-bias the trees of @UInfixP@ and @UInfixE@ and right-bias the trees of+@UInfixT@ and @PromotedUnfixT@.  Sample input: @@ -1173,7 +1237,7 @@ --      Do notation and statements ------------------------------------- -cvtHsDo :: HsStmtContext GhcRn -> [TH.Stmt] -> CvtM (HsExpr GhcPs)+cvtHsDo :: HsDoFlavour -> [TH.Stmt] -> CvtM (HsExpr GhcPs) cvtHsDo do_or_lc stmts   | null stmts = failWith (text "Empty stmt list in do-block")   | otherwise@@ -1185,9 +1249,9 @@                       -> return (L loc (mkLastStmt body))                     _ -> failWith (bad_last last') -        ; return $ HsDo noAnn do_or_lc (noLocA (stmts'' ++ [last''])) }+        ; wrapParLA (HsDo noAnn do_or_lc) (stmts'' ++ [last'']) }   where-    bad_last stmt = vcat [ text "Illegal last statement of" <+> pprAStmtContext do_or_lc <> colon+    bad_last stmt = vcat [ text "Illegal last statement of" <+> pprAHsDoFlavour do_or_lc <> colon                          , nest 2 $ Outputable.ppr stmt                          , text "(It should be an expression.)" ] @@ -1204,14 +1268,16 @@   where     cvt_one ds = do { ds' <- cvtStmts ds                     ; return (ParStmtBlock noExtField ds' undefined noSyntaxExpr) }-cvtStmt (TH.RecS ss) = do { ss' <- mapM cvtStmt ss; returnLA (mkRecStmt noAnn (noLocA ss')) }+cvtStmt (TH.RecS ss) = do { ss' <- mapM cvtStmt ss+                          ; rec_stmt <- wrapParLA (mkRecStmt noAnn) ss'+                          ; returnLA rec_stmt }  cvtMatch :: HsMatchContext GhcPs          -> TH.Match -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs)) cvtMatch ctxt (TH.Match p body decs)   = do  { p' <- cvtPat p         ; let lp = case p' of-                     (L loc SigPat{}) -> L loc (ParPat noAnn p') -- #14875+                     (L loc SigPat{}) -> L loc (gParPat p') -- #14875                      _                -> p'         ; g' <- cvtGuard body         ; decs' <- cvtLocalDecs (text "a where clause") decs@@ -1220,14 +1286,14 @@ cvtGuard :: TH.Body -> CvtM [LGRHS GhcPs (LHsExpr GhcPs)] cvtGuard (GuardedB pairs) = mapM cvtpair pairs cvtGuard (NormalB e)      = do { e' <- cvtl e-                               ; g' <- returnL $ GRHS noAnn [] e'; return [g'] }+                               ; g' <- returnLA $ GRHS noAnn [] e'; return [g'] }  cvtpair :: (TH.Guard, TH.Exp) -> CvtM (LGRHS GhcPs (LHsExpr GhcPs)) cvtpair (NormalG ge,rhs) = do { ge' <- cvtl ge; rhs' <- cvtl rhs                               ; g' <- returnLA $ mkBodyStmt ge'-                              ; returnL $ GRHS noAnn [g'] rhs' }+                              ; returnLA $ GRHS noAnn [g'] rhs' } cvtpair (PatG gs,rhs)    = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs-                              ; returnL $ GRHS noAnn gs' rhs' }+                              ; returnLA $ GRHS noAnn gs' rhs' }  cvtOverLit :: Lit -> CvtM (HsOverLit GhcPs) cvtOverLit (IntegerL i)@@ -1300,12 +1366,13 @@ cvtp :: TH.Pat -> CvtM (Hs.Pat GhcPs) cvtp (TH.LitP l)   | overloadedLit l    = do { l' <- cvtOverLit l-                            ; return (mkNPat (noLoc l') Nothing noAnn) }+                            ; l'' <- returnLA l'+                            ; return (mkNPat l'' Nothing noAnn) }                                   -- Not right for negative patterns;                                   -- need to think about that!   | otherwise          = do { l' <- cvtLit l; return $ Hs.LitPat noExtField l' } cvtp (TH.VarP s)       = do { s' <- vName s-                            ; return $ Hs.VarPat noExtField (noLocA s') }+                            ; wrapParLA (Hs.VarPat noExtField) s' } cvtp (TupP ps)         = do { ps' <- cvtPats ps                             ; return $ TuplePat noAnn ps' Boxed } cvtp (UnboxedTupP ps)  = do { ps' <- cvtPats ps@@ -1325,7 +1392,7 @@                                 }                             } cvtp (InfixP p1 s p2)  = do { s' <- cNameN s; p1' <- cvtPat p1; p2' <- cvtPat p2-                            ; wrapParLA (ParPat noAnn) $+                            ; wrapParLA gParPat $                               ConPat                                 { pat_con_ext = noAnn                                 , pat_con = s'@@ -1339,7 +1406,7 @@ cvtp (ParensP p)       = do { p' <- cvtPat p;                             ; case unLoc p' of  -- may be wrapped ConPatIn                                 ParPat {} -> return $ unLoc p'-                                _         -> return $ ParPat noAnn p' }+                                _         -> return $ gParPat p' } cvtp (TildeP p)        = do { p' <- cvtPat p; return $ LazyPat noAnn p' } cvtp (BangP p)         = do { p' <- cvtPat p; return $ BangPat noAnn p' } cvtp (TH.AsP s p)      = do { s' <- vNameN s; p' <- cvtPat p@@ -1364,11 +1431,11 @@ cvtPatFld (s,p)   = do  { L ls s' <- vNameN s         ; p' <- cvtPat p-        ; return (noLocA $ HsRecField { hsRecFieldAnn = noAnn-                                      , hsRecFieldLbl-                                         = L (locA ls) $ mkFieldOcc (L ls s')-                                      , hsRecFieldArg = p'-                                      , hsRecPun      = False}) }+        ; returnLA $ HsFieldBind { hfbAnn = noAnn+                                 , hfbLHS+                                    = L (l2l ls) $ mkFieldOcc (L (l2l ls) s')+                                 , hfbRHS = p'+                                 , hfbPun = False} }  {- | @cvtOpAppP x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@. The produced tree of infix patterns will be left-biased, provided @x@ is.@@ -1448,15 +1515,15 @@ cvtDerivClause (TH.DerivClause ds tys)   = do { tys' <- cvtDerivClauseTys tys        ; ds'  <- traverse cvtDerivStrategy ds-       ; returnL $ HsDerivingClause noAnn ds' tys' }+       ; returnLA $ HsDerivingClause noAnn ds' tys' }  cvtDerivStrategy :: TH.DerivStrategy -> CvtM (Hs.LDerivStrategy GhcPs)-cvtDerivStrategy TH.StockStrategy    = returnL (Hs.StockStrategy noAnn)-cvtDerivStrategy TH.AnyclassStrategy = returnL (Hs.AnyclassStrategy noAnn)-cvtDerivStrategy TH.NewtypeStrategy  = returnL (Hs.NewtypeStrategy noAnn)+cvtDerivStrategy TH.StockStrategy    = returnLA (Hs.StockStrategy noAnn)+cvtDerivStrategy TH.AnyclassStrategy = returnLA (Hs.AnyclassStrategy noAnn)+cvtDerivStrategy TH.NewtypeStrategy  = returnLA (Hs.NewtypeStrategy noAnn) cvtDerivStrategy (TH.ViaStrategy ty) = do   ty' <- cvtSigType ty-  returnL $ Hs.ViaStrategy (XViaStrategyPs noAnn ty')+  returnLA $ Hs.ViaStrategy (XViaStrategyPs noAnn ty')  cvtType :: TH.Type -> CvtM (LHsType GhcPs) cvtType = cvtTypeKind "type"@@ -1485,19 +1552,15 @@             , normals `lengthIs` n         -- Saturated             -> returnLA (HsTupleTy noAnn HsBoxedOrConstraintTuple normals)             | otherwise-            -> mk_apps-               (HsTyVar noAnn NotPromoted-                                     (noLocA (getRdrName (tupleTyCon Boxed n))))-               tys'+            -> do { tuple_tc <- returnLA $ getRdrName $ tupleTyCon Boxed n+                  ; mk_apps (HsTyVar noAnn NotPromoted tuple_tc) tys' }            UnboxedTupleT n              | Just normals <- m_normals              , normals `lengthIs` n               -- Saturated              -> returnLA (HsTupleTy noAnn HsUnboxedTuple normals)              | otherwise-             -> mk_apps-                (HsTyVar noAnn NotPromoted-                                   (noLocA (getRdrName (tupleTyCon Unboxed n))))-                tys'+             -> do { tuple_tc <- returnLA $ getRdrName $ tupleTyCon Unboxed n+                   ; mk_apps (HsTyVar noAnn NotPromoted tuple_tc) tys' }            UnboxedSumT n              | n < 2             -> failWith $@@ -1508,9 +1571,8 @@              , normals `lengthIs` n -- Saturated              -> returnLA (HsSumTy noAnn normals)              | otherwise-             -> mk_apps-                (HsTyVar noAnn NotPromoted (noLocA (getRdrName (sumTyCon n))))-                tys'+             -> do { sum_tc <- returnLA $ getRdrName $ sumTyCon n+                   ; mk_apps (HsTyVar noAnn NotPromoted sum_tc) tys' }            ArrowT              | Just normals <- m_normals              , [x',y'] <- normals -> do@@ -1521,11 +1583,10 @@                           _            -> return $                                           parenthesizeHsType sigPrec x'                  let y'' = parenthesizeHsType sigPrec y'-                 returnLA (HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) x'' y'')+                 returnLA (HsFunTy noAnn (HsUnrestrictedArrow noHsUniTok) x'' y'')              | otherwise-             -> mk_apps-                (HsTyVar noAnn NotPromoted (noLocA (getRdrName unrestrictedFunTyCon)))-                tys'+             -> do { fun_tc <- returnLA $ getRdrName unrestrictedFunTyCon+                   ; mk_apps (HsTyVar noAnn NotPromoted fun_tc) tys' }            MulArrowT              | Just normals <- m_normals              , [w',x',y'] <- normals -> do@@ -1539,23 +1600,22 @@                      w'' = hsTypeToArrow w'                  returnLA (HsFunTy noAnn w'' x'' y'')              | otherwise-             -> mk_apps-                (HsTyVar noAnn NotPromoted (noLocA (getRdrName funTyCon)))-                tys'+             -> do { fun_tc <- returnLA $ getRdrName funTyCon+                   ; mk_apps (HsTyVar noAnn NotPromoted fun_tc) tys' }            ListT              | Just normals <- m_normals              , [x'] <- normals ->                 returnLA (HsListTy noAnn x')              | otherwise-             -> mk_apps-                (HsTyVar noAnn NotPromoted (noLocA (getRdrName listTyCon)))-                tys'+             -> do { list_tc <- returnLA $ getRdrName listTyCon+                   ; mk_apps (HsTyVar noAnn NotPromoted list_tc) tys' }             VarT nm -> do { nm' <- tNameN nm                          ; mk_apps (HsTyVar noAnn NotPromoted nm') tys' }            ConT nm -> do { nm' <- tconName nm                          ; let prom = name_promotedness nm'-                         ; mk_apps (HsTyVar noAnn prom (noLocA nm')) tys'}+                         ; lnm' <- returnLA nm'+                         ; mk_apps (HsTyVar noAnn prom lnm') tys'}             ForallT tvs cxt ty              | null tys'@@ -1596,25 +1656,42 @@                    ; t1' <- cvtType t1                    ; t2' <- cvtType t2                    ; let prom = name_promotedness s'+                   ; ls' <- returnLA s'                    ; mk_apps-                      (HsTyVar noAnn prom (noLocA s'))+                      (HsTyVar noAnn prom ls')                       ([HsValArg t1', HsValArg t2'] ++ tys')                    }             UInfixT t1 s t2-             -> do { t2' <- cvtType t2-                   ; t <- cvtOpAppT t1 s t2'+             -> do { s' <- tconNameN s+                   ; t2' <- cvtType t2+                   ; t <- cvtOpAppT NotPromoted t1 s' t2'                    ; mk_apps (unLoc t) tys'                    } -- Note [Converting UInfix] +           PromotedInfixT t1 s t2+             -> do { s'  <- cNameN s+                   ; t1' <- cvtType t1+                   ; t2' <- cvtType t2+                   ; mk_apps+                      (HsTyVar noAnn IsPromoted s')+                      ([HsValArg t1', HsValArg t2'] ++ tys')+                   }++           PromotedUInfixT t1 s t2+             -> do { s' <- cNameN s+                   ; t2' <- cvtType t2+                   ; t <- cvtOpAppT IsPromoted t1 s' t2'+                   ; mk_apps (unLoc t) tys'+                   } -- Note [Converting UInfix]+            ParensT t              -> do { t' <- cvtType t                    ; mk_apps (HsParTy noAnn t') tys'                    } -           PromotedT nm -> do { nm' <- cName nm-                              ; mk_apps (HsTyVar noAnn IsPromoted-                                         (noLocA nm'))+           PromotedT nm -> do { nm' <- cNameN nm+                              ; mk_apps (HsTyVar noAnn IsPromoted nm')                                         tys' }                  -- Promoted data constructor; hence cName @@ -1623,10 +1700,8 @@               , normals `lengthIs` n   -- Saturated               -> returnLA (HsExplicitTupleTy noAnn normals)               | otherwise-              -> mk_apps-                 (HsTyVar noAnn IsPromoted-                                   (noLocA (getRdrName (tupleDataCon Boxed n))))-                 tys'+              -> do { tuple_tc <- returnLA $ getRdrName $ tupleDataCon Boxed n+                    ; mk_apps (HsTyVar noAnn IsPromoted tuple_tc) tys' }             PromotedNilT              -> mk_apps (HsExplicitListTy noAnn IsPromoted []) tys'@@ -1637,50 +1712,46 @@               , [ty1, L _ (HsExplicitListTy _ ip tys2)] <- normals               -> returnLA (HsExplicitListTy noAnn ip (ty1:tys2))               | otherwise-              -> mk_apps-                 (HsTyVar noAnn IsPromoted (noLocA (getRdrName consDataCon)))-                 tys'+              -> do { cons_tc <- returnLA $ getRdrName consDataCon+                    ; mk_apps (HsTyVar noAnn IsPromoted cons_tc) tys' }             StarT-             -> mk_apps-                (HsTyVar noAnn NotPromoted-                                      (noLocA (getRdrName liftedTypeKindTyCon)))-                tys'+             -> do { type_tc <- returnLA $ getRdrName liftedTypeKindTyCon+                   ; mk_apps (HsTyVar noAnn NotPromoted type_tc) tys' }             ConstraintT-             -> mk_apps-                (HsTyVar noAnn NotPromoted-                                      (noLocA (getRdrName constraintKindTyCon)))-                tys'+             -> do { constraint_tc <- returnLA $ getRdrName constraintKindTyCon+                   ; mk_apps (HsTyVar noAnn NotPromoted constraint_tc) tys' }             EqualityT              | Just normals <- m_normals              , [x',y'] <- normals ->                    let px = parenthesizeHsType opPrec x'                        py = parenthesizeHsType opPrec y'-                   in returnLA (HsOpTy noExtField px (noLocA eqTyCon_RDR) py)+                   in do { eq_tc <- returnLA eqTyCon_RDR+                         ; returnLA (HsOpTy noAnn NotPromoted px eq_tc py) }                -- The long-term goal is to remove the above case entirely and                -- subsume it under the case for InfixT. See #15815, comment:6,                -- for more details.               | otherwise ->-                   mk_apps (HsTyVar noAnn NotPromoted-                            (noLocA eqTyCon_RDR)) tys'+                   do { eq_tc <- returnLA eqTyCon_RDR+                      ; mk_apps (HsTyVar noAnn NotPromoted eq_tc) tys' }            ImplicitParamT n t              -> do { n' <- wrapL $ ipName n                    ; t' <- cvtType t-                   ; returnLA (HsIParamTy noAnn n' t')+                   ; returnLA (HsIParamTy noAnn (reLocA n') t')                    } -           _ -> failWith (ptext (sLit ("Malformed " ++ ty_str)) <+> text (show ty))+           _ -> failWith (text "Malformed " <> text ty_str <+> text (show ty))     }  hsTypeToArrow :: LHsType GhcPs -> HsArrow GhcPs hsTypeToArrow w = case unLoc w of                      HsTyVar _ _ (L _ (isExact_maybe -> Just n))-                        | n == oneDataConName -> HsLinearArrow NormalSyntax Nothing-                        | n == manyDataConName -> HsUnrestrictedArrow NormalSyntax-                     _ -> HsExplicitMult NormalSyntax Nothing w+                        | n == oneDataConName -> HsLinearArrow (HsPct1 noHsTok noHsUniTok)+                        | n == manyDataConName -> HsUnrestrictedArrow noHsUniTok+                     _ -> HsExplicitMult noHsTok w noHsUniTok  -- ConT/InfixT can contain both data constructor (i.e., promoted) names and -- other (i.e, unpromoted) names, as opposed to PromotedT, which can only@@ -1768,14 +1839,18 @@  See the @cvtOpApp@ documentation for how this function works. -}-cvtOpAppT :: TH.Type -> TH.Name -> LHsType GhcPs -> CvtM (LHsType GhcPs)-cvtOpAppT (UInfixT x op2 y) op1 z-  = do { l <- cvtOpAppT y op1 z-       ; cvtOpAppT x op2 l }-cvtOpAppT x op y-  = do { op' <- tconNameN op-       ; x' <- cvtType x-       ; returnLA (mkHsOpTy x' op' y) }+cvtOpAppT :: PromotionFlag -> TH.Type -> LocatedN RdrName -> LHsType GhcPs -> CvtM (LHsType GhcPs)+cvtOpAppT prom (UInfixT x op2 y) op1 z+  = do { op2' <- tconNameN op2+       ; l <- cvtOpAppT prom y op1 z+       ; cvtOpAppT NotPromoted x op2' l }+cvtOpAppT prom (PromotedUInfixT x op2 y) op1 z+  = do { op2' <- cNameN op2+       ; l <- cvtOpAppT prom y op1 z+       ; cvtOpAppT IsPromoted x op2' l }+cvtOpAppT prom x op y+  = do { x' <- cvtType x+       ; returnLA (mkHsOpTy prom x' op y) }  cvtKind :: TH.Kind -> CvtM (LHsKind GhcPs) cvtKind = cvtTypeKind "kind"@@ -1788,18 +1863,18 @@ -- signature is possible). cvtMaybeKindToFamilyResultSig :: Maybe TH.Kind                               -> CvtM (LFamilyResultSig GhcPs)-cvtMaybeKindToFamilyResultSig Nothing   = returnL (Hs.NoSig noExtField)+cvtMaybeKindToFamilyResultSig Nothing   = returnLA (Hs.NoSig noExtField) cvtMaybeKindToFamilyResultSig (Just ki) = do { ki' <- cvtKind ki-                                             ; returnL (Hs.KindSig noExtField ki') }+                                             ; returnLA (Hs.KindSig noExtField ki') }  -- | Convert type family result signature. Used with both open and closed type -- families. cvtFamilyResultSig :: TH.FamilyResultSig -> CvtM (Hs.LFamilyResultSig GhcPs)-cvtFamilyResultSig TH.NoSig           = returnL (Hs.NoSig noExtField)+cvtFamilyResultSig TH.NoSig           = returnLA (Hs.NoSig noExtField) cvtFamilyResultSig (TH.KindSig ki)    = do { ki' <- cvtKind ki-                                           ; returnL (Hs.KindSig noExtField  ki') }+                                           ; returnLA (Hs.KindSig noExtField  ki') } cvtFamilyResultSig (TH.TyVarSig bndr) = do { tv <- cvt_tv bndr-                                           ; returnL (Hs.TyVarSig noExtField tv) }+                                           ; returnLA (Hs.TyVarSig noExtField tv) }  -- | Convert injectivity annotation of a type family. cvtInjectivityAnnotation :: TH.InjectivityAnn@@ -1807,7 +1882,7 @@ cvtInjectivityAnnotation (TH.InjectivityAnn annLHS annRHS)   = do { annLHS' <- tNameN annLHS        ; annRHS' <- mapM tNameN annRHS-       ; returnL (Hs.InjectivityAnn noAnn annLHS' annRHS') }+       ; returnLA (Hs.InjectivityAnn noAnn annLHS' annRHS') }  cvtPatSynSigTy :: TH.Type -> CvtM (LHsSigType GhcPs) -- pattern synonym types are of peculiar shapes, which is why we treat@@ -1815,22 +1890,21 @@ -- see Note [Pattern synonym type signatures and Template Haskell] cvtPatSynSigTy (ForallT univs reqs (ForallT exis provs ty))   | null exis, null provs = cvtSigType (ForallT univs reqs ty)-  | null univs, null reqs = do { l'  <- getL-                               ; let l = noAnnSrcSpan l'-                               ; ty' <- cvtType (ForallT exis provs ty)-                               ; return $ L l $ mkHsImplicitSigType-                                        $ L l (HsQualTy { hst_ctxt = Nothing-                                                        , hst_xqual = noExtField-                                                        , hst_body = ty' }) }-  | null reqs             = do { l'      <- getL-                               ; let l'' = noAnnSrcSpan l'-                               ; univs' <- cvtTvs univs+  | null univs, null reqs = do { ty' <- cvtType (ForallT exis provs ty)+                               ; ctxt' <- returnLA []+                               ; cxtTy <- wrapParLA mkHsImplicitSigType $+                                          HsQualTy { hst_ctxt = ctxt'+                                                   , hst_xqual = noExtField+                                                   , hst_body = ty' }+                               ; returnLA cxtTy }+  | null reqs             = do { univs' <- cvtTvs univs                                ; ty'    <- cvtType (ForallT exis provs ty)-                               ; let forTy = mkHsExplicitSigType noAnn univs' $ L l'' cxtTy-                                     cxtTy = HsQualTy { hst_ctxt = Nothing+                               ; ctxt'  <- returnLA []+                               ; let cxtTy = HsQualTy { hst_ctxt = ctxt'                                                       , hst_xqual = noExtField                                                       , hst_body = ty' }-                               ; return $ L (noAnnSrcSpan l') forTy }+                               ; forTy <- wrapParLA (mkHsExplicitSigType noAnn univs') cxtTy+                               ; returnLA forTy }   | otherwise             = cvtSigType (ForallT univs reqs (ForallT exis provs ty)) cvtPatSynSigTy ty         = cvtSigType ty @@ -1913,8 +1987,22 @@ mkHsQualTy ctxt loc ctxt' ty   | null ctxt = ty   | otherwise = L loc $ HsQualTy { hst_xqual = noExtField-                                 , hst_ctxt  = Just ctxt'+                                 , hst_ctxt  = ctxt'                                  , hst_body  = ty }++-- | @'mkHsContextMaybe' lc@ returns 'Nothing' if @lc@ is empty and @'Just' lc@+-- otherwise.+--+-- This is much like 'mkHsQualTy', except that it returns a+-- @'Maybe' ('LHsContext' 'GhcPs')@. This is used specifically for constructing+-- superclasses, datatype contexts (#20011), and contexts in GADT constructor+-- types (#20590). We wish to avoid using @'Just' []@ in the case of an empty+-- contexts, as the pretty-printer always prints 'Just' contexts, even if+-- they're empty.+mkHsContextMaybe :: LHsContext GhcPs -> Maybe (LHsContext GhcPs)+mkHsContextMaybe lctxt@(L _ ctxt)+  | null ctxt = Nothing+  | otherwise = Just lctxt  mkHsOuterFamEqnTyVarBndrs :: Maybe [LHsTyVarBndr () GhcPs] -> HsOuterFamEqnTyVarBndrs GhcPs mkHsOuterFamEqnTyVarBndrs = maybe mkHsOuterImplicit (mkHsOuterExplicit noAnn)
GHC/Types/Avail.hs view
@@ -1,11 +1,9 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE DeriveDataTypeable #-} -- -- (c) The University of Glasgow -- -#include "HsVersions.h"- module GHC.Types.Avail (     Avails,     AvailInfo(..),@@ -51,6 +49,7 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Misc+import GHC.Utils.Constants (debugIsOn)  import Data.Data ( Data ) import Data.Either ( partitionEithers )@@ -350,9 +349,9 @@ -- will give Ix(Ix,index,range) and Ix(index) -- We want to combine these; addAvail does that nubAvails :: [AvailInfo] -> [AvailInfo]-nubAvails avails = nameEnvElts (foldl' add emptyNameEnv avails)+nubAvails avails = eltsDNameEnv (foldl' add emptyDNameEnv avails)   where-    add env avail = extendNameEnv_C plusAvail env (availName avail) avail+    add env avail = extendDNameEnv_C plusAvail env (availName avail) avail  -- ----------------------------------------------------------------------------- -- Printing
GHC/Types/Basic.hs view
@@ -16,6 +16,7 @@  {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}  {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}@@ -45,12 +46,15 @@          Boxity(..), isBoxed, +        CbvMark(..), isMarkedCbv,+         PprPrec(..), topPrec, sigPrec, opPrec, funPrec, starPrec, appPrec,         maybeParen,          TupleSort(..), tupleSortBoxity, boxityTupleSort,         tupleParens, +        UnboxedTupleOrSum(..), unboxedTupleOrSumExtension,         sumParens, pprAlternative,          -- ** The OneShotInfo type@@ -73,18 +77,21 @@         DefMethSpec(..),         SwapFlag(..), flipSwap, unSwap, isSwapped, -        CompilerPhase(..), PhaseNum,+        CompilerPhase(..), PhaseNum, beginPhase, nextPhase, laterPhase,          Activation(..), isActive, competesWith,         isNeverActive, isAlwaysActive, activeInFinalPhase,-        activateAfterInitial, activateDuringFinal,+        activateAfterInitial, activateDuringFinal, activeAfter,          RuleMatchInfo(..), isConLike, isFunLike,         InlineSpec(..), noUserInlineSpec,         InlinePragma(..), defaultInlinePragma, alwaysInlinePragma,         neverInlinePragma, dfunInlinePragma,         isDefaultInlinePragma,-        isInlinePragma, isInlinablePragma, isAnyInlinePragma,+        isInlinePragma, isInlinablePragma, isNoInlinePragma, isOpaquePragma,+        isAnyInlinePragma, alwaysInlineConLikePragma,+        inlinePragmaSource,+        inlinePragmaName, inlineSpecSource,         inlinePragmaSpec, inlinePragmaSat,         inlinePragmaActivation, inlinePragmaRuleMatchInfo,         setInlinePragmaActivation, setInlinePragmaRuleMatchInfo,@@ -92,12 +99,19 @@          SuccessFlag(..), succeeded, failed, successIf, -        IntWithInf, infinity, treatZeroAsInf, mkIntWithInf, intGtLimit,+        IntWithInf, infinity, treatZeroAsInf, subWithInf, mkIntWithInf, intGtLimit,          SpliceExplicitFlag(..),          TypeOrKind(..), isTypeLevel, isKindLevel, +        Levity(..), mightBeLifted, mightBeUnlifted,++        ExprOrPat(..),++        NonStandardDefaultingStrategy(..),+        DefaultingStrategy(..), defaultNonStandardTyVars,+         ForeignSrcLang (..)    ) where @@ -109,6 +123,7 @@ import GHC.Utils.Panic import GHC.Utils.Binary import GHC.Types.SourceText+import qualified GHC.LanguageExtensions as LangExt import Data.Data import qualified Data.Semigroup as Semi @@ -500,9 +515,46 @@   ppr Boxed   = text "Boxed"   ppr Unboxed = text "Unboxed" +instance Binary Boxity where -- implemented via isBoxed-isomorphism to Bool+  put_ bh = put_ bh . isBoxed+  get bh  = do+    b <- get bh+    pure $ if b then Boxed else Unboxed+ {- ************************************************************************ *                                                                      *+                Call by value flag+*                                                                      *+************************************************************************+-}++-- | Should an argument be passed evaluated *and* tagged.+data CbvMark = MarkedCbv | NotMarkedCbv+    deriving Eq++instance Outputable CbvMark where+  ppr MarkedCbv    = text "!"+  ppr NotMarkedCbv = text "~"++instance Binary CbvMark where+    put_ bh NotMarkedCbv = putByte bh 0+    put_ bh MarkedCbv    = putByte bh 1+    get bh =+      do h <- getByte bh+         case h of+           0 -> return NotMarkedCbv+           1 -> return MarkedCbv+           _ -> panic "Invalid binary format"++isMarkedCbv :: CbvMark -> Bool+isMarkedCbv MarkedCbv = True+isMarkedCbv NotMarkedCbv = False+++{-+************************************************************************+*                                                                      *                 Recursive/Non-Recursive flag *                                                                      * ************************************************************************@@ -579,7 +631,7 @@ --                              @'\{-\# INCOHERENT'@, --      'GHC.Parser.Annotation.AnnClose' @`\#-\}`@, --- For details on above see note [exact print annotations] in "GHC.Parser.Annotation"+-- For details on above see Note [exact print annotations] in "GHC.Parser.Annotation" data OverlapFlag = OverlapFlag   { overlapMode   :: OverlapMode   , isSafeOverlap :: Bool@@ -663,7 +715,7 @@     -- instance                   Foo [a]     -- Without the Incoherent flag, we'd complain that     -- instantiating 'b' would change which instance-    -- was chosen. See also note [Incoherent instances] in "GHC.Core.InstEnv"+    -- was chosen. See also Note [Incoherent instances] in "GHC.Core.InstEnv"    deriving (Eq, Data) @@ -840,9 +892,9 @@  tupleParens :: TupleSort -> SDoc -> SDoc tupleParens BoxedTuple      p = parens p-tupleParens UnboxedTuple    p = text "(#" <+> p <+> ptext (sLit "#)")+tupleParens UnboxedTuple    p = text "(#" <+> p <+> text "#)" tupleParens ConstraintTuple p   -- In debug-style write (% Eq a, Ord b %)-  = ifPprDebug (text "(%" <+> p <+> ptext (sLit "%)"))+  = ifPprDebug (text "(%" <+> p <+> text "%)")                (parens p)  {-@@ -854,7 +906,7 @@ -}  sumParens :: SDoc -> SDoc-sumParens p = ptext (sLit "(#") <+> p <+> ptext (sLit "#)")+sumParens p = text "(#" <+> p <+> text "#)"  -- | Pretty print an alternative in an unboxed sum e.g. "| a | |". pprAlternative :: (a -> SDoc) -- ^ The pretty printing function to use@@ -866,6 +918,22 @@ pprAlternative pp x alt arity =     fsep (replicate (alt - 1) vbar ++ [pp x] ++ replicate (arity - alt) vbar) +-- | Are we dealing with an unboxed tuple or an unboxed sum?+--+-- Used when validity checking, see 'check_ubx_tuple_or_sum'.+data UnboxedTupleOrSum+  = UnboxedTupleType+  | UnboxedSumType+  deriving Eq++instance Outputable UnboxedTupleOrSum where+  ppr UnboxedTupleType = text "UnboxedTupleType"+  ppr UnboxedSumType   = text "UnboxedSumType"++unboxedTupleOrSumExtension :: UnboxedTupleOrSum -> LangExt.Extension+unboxedTupleOrSumExtension UnboxedTupleType = LangExt.UnboxedTuples+unboxedTupleOrSumExtension UnboxedSumType   = LangExt.UnboxedSums+ {- ************************************************************************ *                                                                      *@@ -1148,6 +1216,12 @@  data SuccessFlag = Succeeded | Failed +instance Semigroup SuccessFlag where+  Failed <> _ = Failed+  _ <> Failed = Failed+  _ <> _      = Succeeded++ instance Outputable SuccessFlag where     ppr Succeeded = text "Succeeded"     ppr Failed    = text "Failed"@@ -1210,7 +1284,7 @@    ppr InitialPhase = text "InitialPhase"    ppr FinalPhase   = text "FinalPhase" --- See note [Pragma source text]+-- See Note [Pragma source text] data Activation   = AlwaysActive   | ActiveBefore SourceText PhaseNum  -- Active only *strictly before* this phase@@ -1220,13 +1294,44 @@   deriving( Eq, Data )     -- Eq used in comparing rules in GHC.Hs.Decls -activateAfterInitial :: Activation--- Active in the first phase after the initial phase+beginPhase :: Activation -> CompilerPhase+-- First phase in which the Activation is active+-- or FinalPhase if it is never active+beginPhase AlwaysActive      = InitialPhase+beginPhase (ActiveBefore {}) = InitialPhase+beginPhase (ActiveAfter _ n) = Phase n+beginPhase FinalActive       = FinalPhase+beginPhase NeverActive       = FinalPhase++activeAfter :: CompilerPhase -> Activation+-- (activeAfter p) makes an Activation that is active in phase p and after+-- Invariant: beginPhase (activeAfter p) = p+activeAfter InitialPhase = AlwaysActive+activeAfter (Phase n)    = ActiveAfter NoSourceText n+activeAfter FinalPhase   = FinalActive++nextPhase :: CompilerPhase -> CompilerPhase+-- Tells you the next phase after this one -- Currently we have just phases [2,1,0,FinalPhase,FinalPhase,...] -- Where FinalPhase means GHC's internal simplification steps -- after all rules have run-activateAfterInitial = ActiveAfter NoSourceText 2+nextPhase InitialPhase = Phase 2+nextPhase (Phase 0)    = FinalPhase+nextPhase (Phase n)    = Phase (n-1)+nextPhase FinalPhase   = FinalPhase +laterPhase :: CompilerPhase -> CompilerPhase -> CompilerPhase+-- Returns the later of two phases+laterPhase (Phase n1)   (Phase n2)   = Phase (n1 `min` n2)+laterPhase InitialPhase p2           = p2+laterPhase FinalPhase   _            = FinalPhase+laterPhase p1           InitialPhase = p1+laterPhase _            FinalPhase   = FinalPhase++activateAfterInitial :: Activation+-- Active in the first phase after the initial phase+activateAfterInitial = activeAfter (nextPhase InitialPhase)+ activateDuringFinal :: Activation -- Active in the final simplification phase (which is repeated) activateDuringFinal = FinalActive@@ -1330,9 +1435,12 @@  -- | Inline Specification data InlineSpec   -- What the user's INLINE pragma looked like-  = Inline           -- User wrote INLINE-  | Inlinable        -- User wrote INLINABLE-  | NoInline         -- User wrote NOINLINE+  = Inline    SourceText       -- User wrote INLINE+  | Inlinable SourceText       -- User wrote INLINABLE+  | NoInline  SourceText       -- User wrote NOINLINE+  | Opaque    SourceText       -- User wrote OPAQUE+                               -- Each of the above keywords is accompanied with+                               -- a string of type SourceText written by the user   | NoUserInlinePrag -- User did not write any of INLINE/INLINABLE/NOINLINE                      -- e.g. in `defaultInlinePragma` or when created by CSE   deriving( Eq, Data, Show )@@ -1358,7 +1466,7 @@ Note [inl_inline and inl_act] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ * inl_inline says what the user wrote: did they say INLINE, NOINLINE,-  INLINABLE, or nothing at all+  INLINABLE, OPAQUE, or nothing at all  * inl_act says in what phases the unfolding is active or inactive   E.g  If you write INLINE[1]    then inl_act will be set to ActiveAfter 1@@ -1407,6 +1515,52 @@      - The rule matcher consults this field.  See       Note [Expanding variables] in GHC.Core.Rules.++Note [OPAQUE pragma]+~~~~~~~~~~~~~~~~~~~~+Suppose a function `f` is marked {-# OPAQUE f #-}.  Then every call of `f`+should remain a call of `f` throughout optimisation; it should not be turned+into a call of a name-mangled variant of `f` (e.g by worker/wrapper).++The motivation for the OPAQUE pragma is discussed in GHC proposal 0415:+https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0415-opaque-pragma.rst+Basically it boils down to the desire of GHC API users and GHC RULE writers for+calls to certain binders to be left completely untouched by GHCs optimisations.++What this entails at the time of writing, is that for every binder annotated+with the OPAQUE pragma we:++* Do not do worker/wrapper via cast W/W:+  See the guard in GHC.Core.Opt.Simplify.tryCastWorkerWrapper++* Do not any worker/wrapper after demand/CPR analysis. To that end add a guard+  in GHC.Core.Opt.WorkWrap.tryWW to disable worker/wrapper++* It is important that the demand signature and CPR signature do not lie, else+  clients of the function will believe that it has the CPR property etc. But it+  won't, because we've disabled worker/wrapper. To avoid the signatures lying:+  * Strip boxity information from the demand signature+    in GHC.Core.Opt.DmdAnal.finaliseArgBoxities+    See Note [The OPAQUE pragma and avoiding the reboxing of arguments]+  * Strip CPR information from the CPR signature+    in GHC.Core.Opt.CprAnal.cprAnalBind+    See Note [The OPAQUE pragma and avoiding the reboxing of results]++* Do create specialised versions of the function in+  * Specialise: see GHC.Core.Opt.Specialise.specCalls+  * SpecConstr: see GHC.Core.Opt.SpecConstr.specialise+  Both are accomplished easily: these passes already skip NOINLINE+  functions with NeverActive activation, and an OPAQUE function is+  also NeverActive.++At the moment of writing, the major difference between the NOINLINE pragma and+the OPAQUE pragma is that binders annoted with the NOINLINE pragma _are_ W/W+transformed (see also Note [Worker/wrapper for NOINLINE functions]) where+binders annoted with the OPAQUE pragma are _not_ W/W transformed.++Future "name-mangling" optimisations should respect the OPAQUE pragma and+update the list of moving parts referenced in this note.+ -}  isConLike :: RuleMatchInfo -> Bool@@ -1429,12 +1583,31 @@                                    , inl_inline = NoUserInlinePrag                                    , inl_sat = Nothing } -alwaysInlinePragma = defaultInlinePragma { inl_inline = Inline }+alwaysInlinePragma = defaultInlinePragma { inl_inline = Inline (inlinePragmaSource defaultInlinePragma) } neverInlinePragma  = defaultInlinePragma { inl_act    = NeverActive } +alwaysInlineConLikePragma :: InlinePragma+alwaysInlineConLikePragma = alwaysInlinePragma { inl_rule = ConLike }+ inlinePragmaSpec :: InlinePragma -> InlineSpec inlinePragmaSpec = inl_inline +inlinePragmaSource :: InlinePragma -> SourceText+inlinePragmaSource prag = case inl_inline prag of+                            Inline    x      -> x+                            Inlinable y      -> y+                            NoInline  z      -> z+                            Opaque    q      -> q+                            NoUserInlinePrag -> NoSourceText++inlineSpecSource :: InlineSpec -> SourceText+inlineSpecSource spec = case spec of+                            Inline    x      -> x+                            Inlinable y      -> y+                            NoInline  z      -> z+                            Opaque    q      -> q+                            NoUserInlinePrag -> NoSourceText+ -- A DFun has an always-active inline activation so that -- exprIsConApp_maybe can "see" its unfolding -- (However, its actual Unfolding is a DFunUnfolding, which is@@ -1450,21 +1623,31 @@  isInlinePragma :: InlinePragma -> Bool isInlinePragma prag = case inl_inline prag of-                        Inline -> True-                        _      -> False+                        Inline _  -> True+                        _         -> False  isInlinablePragma :: InlinePragma -> Bool isInlinablePragma prag = case inl_inline prag of-                           Inlinable -> True-                           _         -> False+                           Inlinable _  -> True+                           _            -> False +isNoInlinePragma :: InlinePragma -> Bool+isNoInlinePragma prag = case inl_inline prag of+                          NoInline _   -> True+                          _            -> False+ isAnyInlinePragma :: InlinePragma -> Bool -- INLINE or INLINABLE isAnyInlinePragma prag = case inl_inline prag of-                        Inline    -> True-                        Inlinable -> True-                        _         -> False+                        Inline    _   -> True+                        Inlinable _   -> True+                        _             -> False +isOpaquePragma :: InlinePragma -> Bool+isOpaquePragma prag = case inl_inline prag of+                        Opaque _ -> True+                        _        -> False+ inlinePragmaSat :: InlinePragma -> Maybe Arity inlinePragmaSat = inl_sat @@ -1515,7 +1698,6 @@                       ab <- get bh                       return (ActiveAfter src ab) - instance Outputable RuleMatchInfo where    ppr ConLike = text "CONLIKE"    ppr FunLike = text "FUNLIKE"@@ -1529,24 +1711,38 @@                       else return FunLike  instance Outputable InlineSpec where-   ppr Inline           = text "INLINE"-   ppr NoInline         = text "NOINLINE"-   ppr Inlinable        = text "INLINABLE"-   ppr NoUserInlinePrag = empty+    ppr (Inline          src)  = text "INLINE" <+> pprWithSourceText src empty+    ppr (NoInline        src)  = text "NOINLINE" <+> pprWithSourceText src empty+    ppr (Inlinable       src)  = text "INLINABLE" <+> pprWithSourceText src empty+    ppr (Opaque          src)  = text "OPAQUE" <+> pprWithSourceText src empty+    ppr NoUserInlinePrag       = empty  instance Binary InlineSpec where     put_ bh NoUserInlinePrag = putByte bh 0-    put_ bh Inline           = putByte bh 1-    put_ bh Inlinable        = putByte bh 2-    put_ bh NoInline         = putByte bh 3+    put_ bh (Inline s)       = do putByte bh 1+                                  put_ bh s+    put_ bh (Inlinable s)    = do putByte bh 2+                                  put_ bh s+    put_ bh (NoInline s)     = do putByte bh 3+                                  put_ bh s+    put_ bh (Opaque s)       = do putByte bh 4+                                  put_ bh s      get bh = do h <- getByte bh                 case h of                   0 -> return NoUserInlinePrag-                  1 -> return Inline-                  2 -> return Inlinable-                  _ -> return NoInline-+                  1 -> do+                        s <- get bh+                        return (Inline s)+                  2 -> do+                        s <- get bh+                        return (Inlinable s)+                  3 -> do+                        s <- get bh+                        return (NoInline s)+                  _ -> do+                        s <- get bh+                        return (Opaque s)  instance Outputable InlinePragma where   ppr = pprInline@@ -1567,6 +1763,15 @@            d <- get bh            return (InlinePragma s a b c d) +-- | Outputs string for pragma name for any of INLINE/INLINABLE/NOINLINE. This+-- differs from the Outputable instance for the InlineSpec type where the pragma+-- name string as well as the accompanying SourceText (if any) is printed.+inlinePragmaName :: InlineSpec -> SDoc+inlinePragmaName (Inline            _)  = text "INLINE"+inlinePragmaName (Inlinable         _)  = text "INLINABLE"+inlinePragmaName (NoInline          _)  = text "NOINLINE"+inlinePragmaName (Opaque            _)  = text "OPAQUE"+inlinePragmaName NoUserInlinePrag       = empty  pprInline :: InlinePragma -> SDoc pprInline = pprInline' True@@ -1577,15 +1782,19 @@ pprInline' :: Bool           -- True <=> do not display the inl_inline field            -> InlinePragma            -> SDoc-pprInline' emptyInline (InlinePragma { inl_inline = inline, inl_act = activation-                                    , inl_rule = info, inl_sat = mb_arity })+pprInline' emptyInline (InlinePragma+                        { inl_inline = inline,+                          inl_act = activation,+                          inl_rule = info,+                          inl_sat = mb_arity })     = pp_inl inline <> pp_act inline activation <+> pp_sat <+> pp_info     where-      pp_inl x = if emptyInline then empty else ppr x+      pp_inl x = if emptyInline then empty else inlinePragmaName x -      pp_act Inline   AlwaysActive = empty-      pp_act NoInline NeverActive  = empty-      pp_act _        act          = ppr act+      pp_act Inline   {}  AlwaysActive = empty+      pp_act NoInline {}  NeverActive  = empty+      pp_act Opaque   {}  NeverActive  = empty+      pp_act _            act          = ppr act        pp_sat | Just ar <- mb_arity = parens (text "sat-args=" <> int ar)              | otherwise           = empty@@ -1654,6 +1863,11 @@ mulWithInf _        Infinity = Infinity mulWithInf (Int a)  (Int b)  = Int (a * b) +-- | Subtract an 'Int' from an 'IntWithInf'+subWithInf :: IntWithInf -> Int -> IntWithInf+subWithInf Infinity _ = Infinity+subWithInf (Int a)  b = Int (a - b)+ -- | Turn a positive number into an 'IntWithInf', where 0 represents infinity treatZeroAsInf :: Int -> IntWithInf treatZeroAsInf 0 = Infinity@@ -1689,3 +1903,174 @@ isKindLevel :: TypeOrKind -> Bool isKindLevel TypeLevel = False isKindLevel KindLevel = True++{- *********************************************************************+*                                                                      *+                     Levity information+*                                                                      *+********************************************************************* -}++data Levity+  = Lifted+  | Unlifted+  deriving Eq++instance Outputable Levity where+  ppr Lifted   = text "Lifted"+  ppr Unlifted = text "Unlifted"++mightBeLifted :: Maybe Levity -> Bool+mightBeLifted (Just Unlifted) = False+mightBeLifted _               = True++mightBeUnlifted :: Maybe Levity -> Bool+mightBeUnlifted (Just Lifted) = False+mightBeUnlifted _             = True++{- *********************************************************************+*                                                                      *+                     Expressions vs Patterns+*                                                                      *+********************************************************************* -}++-- | Are we dealing with an expression or a pattern?+--+-- Used only for the textual output of certain error messages;+-- see the 'FRRDataConArg' constructor of 'FixedRuntimeRepContext'.+data ExprOrPat+  = Expression+  | Pattern+  deriving Eq++instance Outputable ExprOrPat where+  ppr Expression = text "expression"+  ppr Pattern    = text "pattern"++{- *********************************************************************+*                                                                      *+                        Defaulting options+*                                                                      *+********************************************************************* -}++{- Note [Type variable defaulting options]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Here is an overview of the current type variable defaulting mechanisms,+in the order in which they happen.++GHC.Tc.Utils.TcMType.defaultTyVar++  This is a built-in defaulting mechanism for the following type variables:++    (1) kind variables with -XNoPolyKinds,+    (2) type variables of kind 'RuntimeRep' default to 'LiftedRep',+        of kind 'Levity' to 'Lifted', and of kind 'Multiplicity' to 'Many'.++  It is used in many situations:++    - inferring a type (e.g. a declaration with no type signature or a+      partial type signature), in 'GHC.Tc.Solver.simplifyInfer',+    - simplifying top-level constraints in 'GHC.Tc.Solver.simplifyTop',+    - kind checking a CUSK in 'GHC.Tc.Gen.kcCheckDeclHeader_cusk',+    - 'GHC.Tc.TyCl.generaliseTcTyCon',+    - type checking type family and data family instances,+      in 'GHC.Tc.TyCl.tcTyFamInstEqnGuts' and 'GHC.Tc.TyCl.Instance.tcDataFamInstHeader'+      respectively,+    - type-checking rules in 'GHC.Tc.Gen.tcRule',+    - kind generalisation in 'GHC.Tc.Gen.HsType.kindGeneralizeSome'+      and 'GHC.Tc.Gen.HsType.kindGeneralizeAll'.++  Different situations call for a different defaulting strategy,+  so 'defaultTyVar' takes a strategy parameter which determines which+  type variables to default.+  Currently, this strategy is set as follows:++    - Kind variables:+      - with -XNoPolyKinds, these must be defaulted. This includes kind variables+        of kind 'RuntimeRep', 'Levity' and 'Multiplicity'.+        Test case: T20584.+      - with -XPolyKinds, behave as if they were type variables (see below).+    - Type variables of kind 'RuntimeRep', 'Levity' or 'Multiplicity'+      - in type and data families instances, these are not defaulted.+        Test case: T17536.+      - otherwise: default variables of these three kinds. This ensures+        that in a program such as++          foo :: forall a. a -> a+          foo x = x++        we continue to infer `a :: Type`.++  Note that the strategy is set in two steps: callers of 'defaultTyVars' only+  specify whether to default type variables of "non-standard" kinds+  (that is, of kinds 'RuntimeRep'/'Levity'/'Multiplicity'). Then 'defaultTyVars'+  determines which variables are type variables and which are kind variables,+  and if the user has asked for -XNoPolyKinds we default the kind variables.++GHC.Tc.Solver.defaultTyVarTcS++  This is a built-in defaulting mechanism that happens after+  the constraint solver has run, in 'GHC.Tc.Solver.simplifyTopWanteds'.++  It only defaults type (and kind) variables of kind 'RuntimeRep',+  'Levity', 'Multiplicity'.++  It is not configurable, neither by options nor by the user.++GHC.Tc.Solver.applyDefaultingRules++  This is typeclass defaulting, and includes defaulting plugins.+  It happens right after 'defaultTyVarTcS' in 'GHC.Tc.Solver.simplifyTopWanteds'.+  It is user configurable, using default declarations (/plugins).++GHC.Iface.Type.defaultIfaceTyVarsOfKind++  This is a built-in defaulting mechanism that only applies when pretty-printing.+  It defaults 'RuntimeRep'/'Levity' variables unless -fprint-explicit-kinds is enabled,+  and 'Multiplicity' variables unless -XLinearTypes is enabled.++-}++-- | Specify whether to default type variables of kind 'RuntimeRep'/'Levity'/'Multiplicity'.+data NonStandardDefaultingStrategy+  -- | Default type variables of the given kinds:+  --+  --   - default 'RuntimeRep' variables to 'LiftedRep'+  --   - default 'Levity' variables to 'Lifted'+  --   - default 'Multiplicity' variables to 'Many'+  = DefaultNonStandardTyVars+  -- | Try not to default type variables of the kinds 'RuntimeRep'/'Levity'/'Multiplicity'.+  --+  -- Note that these might get defaulted anyway, if they are kind variables+  -- and `-XNoPolyKinds` is enabled.+  | TryNotToDefaultNonStandardTyVars++-- | Specify whether to default kind variables, and type variables+-- of kind 'RuntimeRep'/'Levity'/'Multiplicity'.+data DefaultingStrategy+  -- | Default kind variables:+  --+  --   - default kind variables of kind 'Type' to 'Type',+  --   - default 'RuntimeRep'/'Levity'/'Multiplicity' kind variables+  --     to 'LiftedRep'/'Lifted'/'Many', respectively.+  --+  -- When this strategy is used, it means that we have determined that+  -- the variables we are considering defaulting are all kind variables.+  --+  -- Usually, we pass this option when -XNoPolyKinds is enabled.+  = DefaultKindVars+  -- | Default (or don't default) non-standard variables, of kinds+  -- 'RuntimeRep', 'Levity' and 'Multiplicity'.+  | NonStandardDefaulting NonStandardDefaultingStrategy++defaultNonStandardTyVars :: DefaultingStrategy -> Bool+defaultNonStandardTyVars DefaultKindVars                                          = True+defaultNonStandardTyVars (NonStandardDefaulting DefaultNonStandardTyVars)         = True+defaultNonStandardTyVars (NonStandardDefaulting TryNotToDefaultNonStandardTyVars) = False++instance Outputable NonStandardDefaultingStrategy where+  ppr DefaultNonStandardTyVars         = text "DefaultOnlyNonStandardTyVars"+  ppr TryNotToDefaultNonStandardTyVars = text "TryNotToDefaultNonStandardTyVars"++instance Outputable DefaultingStrategy where+  ppr DefaultKindVars            = text "DefaultKindVars"+  ppr (NonStandardDefaulting ns) = text "NonStandardDefaulting" <+> ppr ns
+ GHC/Types/BreakInfo.hs view
@@ -0,0 +1,12 @@+-- | A module for the BreakInfo type. Used by both the GHC.Runtime.Eval and+-- GHC.Runtime.Interpreter hierarchy, so put here to have a less deep module+-- dependency tree+module GHC.Types.BreakInfo (BreakInfo(..)) where++import GHC.Prelude+import GHC.Unit.Module++data BreakInfo = BreakInfo+  { breakInfo_module :: Module+  , breakInfo_number :: Int+  }
GHC/Types/CostCentre.hs view
@@ -31,6 +31,7 @@ import GHC.Types.SrcLoc import GHC.Data.FastString import GHC.Types.CostCentre.State+import GHC.Utils.Panic.Plain  import Data.Data @@ -71,6 +72,7 @@                | ExprCC !CostCentreIndex -- ^ Explicitly annotated expression                | DeclCC !CostCentreIndex -- ^ Explicitly annotated declaration                | HpcCC !CostCentreIndex -- ^ Generated by HPC for coverage+               | LateCC !CostCentreIndex -- ^ Annotated by the one of the prof-last* passes.                deriving (Eq, Ord, Data)  -- | Extract the index from a flavour@@ -79,6 +81,7 @@ flavourIndex (ExprCC x) = unCostCentreIndex x flavourIndex (DeclCC x) = unCostCentreIndex x flavourIndex (HpcCC x) = unCostCentreIndex x+flavourIndex (LateCC x) = unCostCentreIndex x  instance Eq CostCentre where         c1 == c2 = case c1 `cmpCostCentre` c2 of { EQ -> True; _ -> False }@@ -292,7 +295,8 @@ ppFlavourLblComponent CafCC = text "CAF" ppFlavourLblComponent (ExprCC i) = text "EXPR" <> ppIdxLblComponent i ppFlavourLblComponent (DeclCC i) = text "DECL" <> ppIdxLblComponent i-ppFlavourLblComponent (HpcCC i) = text "HPC" <> ppIdxLblComponent i+ppFlavourLblComponent (HpcCC i)  = text "HPC"  <> ppIdxLblComponent i+ppFlavourLblComponent (LateCC i) = text "LATECC" <> ppIdxLblComponent i  -- ^ Print the flavour index component of a C label ppIdxLblComponent :: CostCentreIndex -> SDoc@@ -328,13 +332,18 @@     put_ bh (HpcCC i) = do             putByte bh 3             put_ bh i+    put_ bh (LateCC i) = do+            putByte bh 4+            put_ bh i     get bh = do             h <- getByte bh             case h of               0 -> return CafCC               1 -> ExprCC <$> get bh               2 -> DeclCC <$> get bh-              _ -> HpcCC  <$> get bh+              3 -> HpcCC  <$> get bh+              4 -> LateCC <$> get bh+              _ -> panic "Invalid CCFlavour"  instance Binary CostCentre where     put_ bh (NormalCC aa ab ac _ad) = do
GHC/Types/Cpr.hs view
@@ -4,7 +4,7 @@  -- | Types for the Constructed Product Result lattice. -- "GHC.Core.Opt.CprAnal" and "GHC.Core.Opt.WorkWrap.Utils"--- are its primary customers via 'GHC.Types.Id.idCprInfo'.+-- are its primary customers via 'GHC.Types.Id.idCprSig'. module GHC.Types.Cpr (     Cpr (ConCpr), topCpr, botCpr, flatConCpr, asConCpr,     CprType (..), topCprType, botCprType, flatConCprType,@@ -33,6 +33,8 @@   -- If all of them are top, better use 'FlatConCpr', as ensured by the pattern   -- synonym 'ConCpr'.   | FlatConCpr !ConTag+  -- ^ @FlatConCpr tag@ is an efficient encoding for @'ConCpr_' tag [TopCpr..]@.+  -- Purely for compiler perf. Can be constructed with 'ConCpr'.   | TopCpr   deriving Eq @@ -161,20 +163,17 @@ seqCprTy (CprType _ cpr) = seqCpr cpr  -- | The arity of the wrapped 'CprType' is the arity at which it is safe--- to unleash. See Note [Understanding DmdType and StrictSig] in "GHC.Types.Demand"+-- to unleash. See Note [Understanding DmdType and DmdSig] in "GHC.Types.Demand" newtype CprSig = CprSig { getCprSig :: CprType }   deriving (Eq, Binary)  -- | Turns a 'CprType' computed for the particular 'Arity' into a 'CprSig'--- unleashable at that arity. See Note [Understanding DmdType and StrictSig] in+-- unleashable at that arity. See Note [Understanding DmdType and DmdSig] in -- "GHC.Types.Demand" mkCprSigForArity :: Arity -> CprType -> CprSig-mkCprSigForArity arty ty@(CprType n cpr)-  | arty /= n         = topCprSig-      -- Trim on arity mismatch-  | ConCpr t _ <- cpr = CprSig (CprType n (flatConCpr t))-      -- Flatten nested CPR info, we don't exploit it (yet)-  | otherwise         = CprSig ty+mkCprSigForArity arty ty@(CprType n _)+  | arty /= n = topCprSig -- Trim on arity mismatch+  | otherwise = CprSig ty  topCprSig :: CprSig topCprSig = CprSig topCprType@@ -189,14 +188,14 @@ seqCprSig (CprSig ty) = seqCprTy ty  -- | BNF:--- ```---   cpr ::= ''                               -- TopCpr---        |  n                                -- FlatConCpr n---        |  n '(' cpr1 ',' cpr2 ',' ... ')'  -- ConCpr n [cpr1,cpr2,...]---        |  'b'                              -- BotCpr--- ```+--+-- > cpr ::= ''                               -- TopCpr+-- >      |  n                                -- FlatConCpr n+-- >      |  n '(' cpr1 ',' cpr2 ',' ... ')'  -- ConCpr n [cpr1,cpr2,...]+-- >      |  'b'                              -- BotCpr+-- -- Examples:---   * `f x = f x` has denotation `b`+--   * `f x = f x` has result CPR `b` --   * `1(1,)` is a valid (nested) 'Cpr' denotation for `(I# 42#, f 42)`. instance Outputable Cpr where   ppr TopCpr         = empty@@ -204,8 +203,18 @@   ppr (ConCpr n cs)  = int n <> parens (pprWithCommas ppr cs)   ppr BotCpr         = char 'b' +-- | BNF:+--+-- > cpr_ty ::= cpr               -- short form if arty == 0+-- >         |  '\' arty '.' cpr  -- if arty > 0+--+-- Examples:+--   * `f x y z = f x y z` has denotation `\3.b`+--   * `g !x = (x+1, x+2)` has denotation `\1.1(1,1)`. instance Outputable CprType where-  ppr (CprType arty res) = ppr arty <> ppr res+  ppr (CprType arty res)+    | 0 <- arty = ppr res+    | otherwise = char '\\' <> ppr arty <> char '.' <> ppr res  -- | Only print the CPR result instance Outputable CprSig where
GHC/Types/Demand.hs view
@@ -1,1893 +1,2475 @@-{-# LANGUAGE CPP          #-}-{-# LANGUAGE ViewPatterns #-}--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}--{--(c) The University of Glasgow 2006-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998--}---- | A language to express the evaluation context of an expression as a--- 'Demand' and track how an expression evaluates free variables and arguments--- in turn as a 'DmdType'.------ Lays out the abstract domain for "GHC.Core.Opt.DmdAnal".-module GHC.Types.Demand (-    -- * Demands-    Card(..), Demand(..), SubDemand(Prod), mkProd, viewProd,-    -- ** Algebra-    absDmd, topDmd, botDmd, seqDmd, topSubDmd,-    -- *** Least upper bound-    lubCard, lubDmd, lubSubDmd,-    -- *** Plus-    plusCard, plusDmd, plusSubDmd,-    -- *** Multiply-    multCard, multDmd, multSubDmd,-    -- ** Predicates on @Card@inalities and @Demand@s-    isAbs, isUsedOnce, isStrict,-    isAbsDmd, isUsedOnceDmd, isStrUsedDmd, isStrictDmd,-    isTopDmd, isSeqDmd, isWeakDmd,-    -- ** Special demands-    evalDmd,-    -- *** Demands used in PrimOp signatures-    lazyApply1Dmd, lazyApply2Dmd, strictOnceApply1Dmd, strictManyApply1Dmd,-    -- ** Other @Demand@ operations-    oneifyCard, oneifyDmd, strictifyDmd, strictifyDictDmd, mkWorkerDemand,-    peelCallDmd, peelManyCalls, mkCalledOnceDmd, mkCalledOnceDmds,-    addCaseBndrDmd,-    -- ** Extracting one-shot information-    argOneShots, argsOneShots, saturatedByOneShots,--    -- * Demand environments-    DmdEnv, emptyDmdEnv,-    keepAliveDmdEnv, reuseEnv,--    -- * Divergence-    Divergence(..), topDiv, botDiv, exnDiv, lubDivergence, isDeadEndDiv,--    -- * Demand types-    DmdType(..), dmdTypeDepth,-    -- ** Algebra-    nopDmdType, botDmdType,-    lubDmdType, plusDmdType, multDmdType,-    -- *** PlusDmdArg-    PlusDmdArg, mkPlusDmdArg, toPlusDmdArg,-    -- ** Other operations-    peelFV, findIdDemand, addDemand, splitDmdTy, deferAfterPreciseException,-    keepAliveDmdType,--    -- * Demand signatures-    StrictSig(..), mkStrictSigForArity, mkClosedStrictSig,-    splitStrictSig, strictSigDmdEnv, hasDemandEnvSig,-    nopSig, botSig, isTopSig, isDeadEndSig, isDeadEndAppSig,-    -- ** Handling arity adjustments-    prependArgsStrictSig, etaConvertStrictSig,--    -- * Demand transformers from demand signatures-    DmdTransformer, dmdTransformSig, dmdTransformDataConSig, dmdTransformDictSelSig,--    -- * Trim to a type shape-    TypeShape(..), trimToType,--    -- * @seq@ing stuff-    seqDemand, seqDemandList, seqDmdType, seqStrictSig,--    -- * Zapping usage information-    zapUsageDemand, zapDmdEnvSig, zapUsedOnceDemand, zapUsedOnceSig-  ) where--#include "HsVersions.h"--import GHC.Prelude--import GHC.Types.Var ( Var, Id )-import GHC.Types.Var.Env-import GHC.Types.Var.Set-import GHC.Types.Unique.FM-import GHC.Types.Basic-import GHC.Data.Maybe   ( orElse )--import GHC.Core.Type    ( Type )-import GHC.Core.TyCon   ( isNewTyCon, isClassTyCon )-import GHC.Core.DataCon ( splitDataProductType_maybe )-import GHC.Core.Multiplicity    ( scaledThing )--import GHC.Utils.Binary-import GHC.Utils.Misc-import GHC.Utils.Outputable-import GHC.Utils.Panic--{--************************************************************************-*                                                                      *-           Card: Combining Strictness and Usage-*                                                                      *-************************************************************************--}--{- Note [Evaluation cardinalities]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The demand analyser uses an /evaluation cardinality/ of type Card,-to specify how many times a term is evaluated.  A cardinality C_lu-represents an /interval/ [l..u], meaning-    C_lu means evaluated /at least/ 'l' times and-                         /at most/  'u' times--* The lower bound corresponds to /strictness/-  Hence 'l' is either 0 (lazy)-                   or 1 (strict)--* The upper bound corresponds to /usage/-  Hence 'u' is either 0 (not used at all),-                   or 1 (used at most once)-                   or n (no information)--Intervals describe sets, so the underlying lattice is the powerset lattice.--Usually l<=u, but we also have C_10, the interval [1,0], the empty interval,-denoting the empty set.   This is the bottom element of the lattice.--See Note [Demand notation] for the notation we use for each of the constructors.--}----- | Describes an interval of /evaluation cardinalities/.--- See Note [Evaluation cardinalities]-data Card-  = C_00 -- ^ {0}     Absent.-  | C_01 -- ^ {0,1}   Used at most once.-  | C_0N -- ^ {0,1,n} Every possible cardinality; the top element.-  | C_11 -- ^ {1}     Strict and used once.-  | C_1N -- ^ {1,n}   Strict and used (possibly) many times.-  | C_10 -- ^ {}      The empty interval; the bottom element of the lattice.-  deriving Eq--_botCard, topCard :: Card-_botCard = C_10-topCard = C_0N---- | True <=> lower bound is 1.-isStrict :: Card -> Bool-isStrict C_10 = True-isStrict C_11 = True-isStrict C_1N = True-isStrict _    = False---- | True <=> upper bound is 0.-isAbs :: Card -> Bool-isAbs C_00 = True-isAbs C_10 = True -- Bottom cardinality is also absent-isAbs _    = False---- | True <=> upper bound is 1.-isUsedOnce :: Card -> Bool-isUsedOnce C_0N = False-isUsedOnce C_1N = False-isUsedOnce _    = True---- | Intersect with [0,1].-oneifyCard :: Card -> Card-oneifyCard C_0N = C_01-oneifyCard C_1N = C_11-oneifyCard c    = c---- | Denotes '∪' on 'Card'.-lubCard :: Card -> Card -> Card--- Handle C_10 (bot)-lubCard C_10 n    = n    -- bot-lubCard n    C_10 = n    -- bot--- Handle C_0N (top)-lubCard C_0N _    = C_0N -- top-lubCard _    C_0N = C_0N -- top--- Handle C_11-lubCard C_00 C_11 = C_01 -- {0} ∪ {1} = {0,1}-lubCard C_11 C_00 = C_01 -- {0} ∪ {1} = {0,1}-lubCard C_11 n    = n    -- {1} is a subset of all other intervals-lubCard n    C_11 = n    -- {1} is a subset of all other intervals--- Handle C_1N-lubCard C_1N C_1N = C_1N -- reflexivity-lubCard _    C_1N = C_0N -- {0} ∪ {1,n} = top-lubCard C_1N _    = C_0N -- {0} ∪ {1,n} = top--- Handle C_01-lubCard C_01 _    = C_01 -- {0} ∪ {0,1} = {0,1}-lubCard _    C_01 = C_01 -- {0} ∪ {0,1} = {0,1}--- Handle C_00-lubCard C_00 C_00 = C_00 -- reflexivity---- | Denotes '+' on 'Card'.-plusCard :: Card -> Card -> Card--- Handle C_00-plusCard C_00 n    = n    -- {0}+n = n-plusCard n    C_00 = n    -- {0}+n = n--- Handle C_10-plusCard C_10 C_01 = C_11 -- These follow by applying + to lower and upper-plusCard C_10 C_0N = C_1N -- bounds individually-plusCard C_10 n    = n-plusCard C_01 C_10 = C_11-plusCard C_0N C_10 = C_1N-plusCard n    C_10 = n--- Handle the rest (C_01, C_0N, C_11, C_1N)-plusCard C_01 C_01 = C_0N -- The upper bound is at least 1, so upper bound of-plusCard C_01 C_0N = C_0N -- the result must be 1+1 ~= N.-plusCard C_0N C_01 = C_0N -- But for the lower bound we have 4 cases where-plusCard C_0N C_0N = C_0N -- 0+0 ~= 0 (as opposed to 1), so we match on these.-plusCard _    _    = C_1N -- Otherwise we return {1,n}---- | Denotes '*' on 'Card'.-multCard :: Card -> Card -> Card--- Handle C_11 (neutral element)-multCard C_11 c    = c-multCard c    C_11 = c--- Handle C_00 (annihilating element)-multCard C_00 _    = C_00-multCard _    C_00 = C_00--- Handle C_10-multCard C_10 c    = if isStrict c then C_10 else C_00-multCard c    C_10 = if isStrict c then C_10 else C_00--- Handle reflexive C_1N, C_01-multCard C_1N C_1N = C_1N-multCard C_01 C_01 = C_01--- Handle C_0N and the rest (C_01, C_1N):-multCard _    _    = C_0N--{--************************************************************************-*                                                                      *-           Demand: Evaluation contexts-*                                                                      *-************************************************************************--}---- | A demand describes a /scaled evaluation context/, e.g. how many times--- and how deep the denoted thing is evaluated.------ The "how many" component is represented by a 'Card'inality.--- The "how deep" component is represented by a 'SubDemand'.--- Examples (using Note [Demand notation]):------   * 'seq' puts demand @1A@ on its first argument: It evaluates the argument---     strictly (@1@), but not any deeper (@A@).---   * 'fst' puts demand @1P(1L,A)@ on its argument: It evaluates the argument---     pair strictly and the first component strictly, but no nested info---     beyond that (@L@). Its second argument is not used at all.---   * '$' puts demand @1C1(L)@ on its first argument: It calls (@C@) the---     argument function with one argument, exactly once (@1@). No info---     on how the result of that call is evaluated (@L@).---   * 'maybe' puts demand @MCM(L)@ on its second argument: It evaluates---     the argument function at most once ((M)aybe) and calls it once when---     it is evaluated.---   * @fst p + fst p@ puts demand @SP(SL,A)@ on @p@: It's @1P(1L,A)@---     multiplied by two, so we get @S@ (used at least once, possibly multiple---     times).------ This data type is quite similar to @'Scaled' 'SubDemand'@, but it's scaled--- by 'Card', which is an /interval/ on 'Multiplicity', the upper bound of--- which could be used to infer uniqueness types.-data Demand-  = !Card :* !SubDemand-  deriving Eq---- | A sub-demand describes an /evaluation context/, e.g. how deep the--- denoted thing is evaluated. See 'Demand' for examples.------ The nested 'SubDemand' @d@ of a 'Call' @Cn(d)@ is /relative/ to a single such call.--- E.g. The expression @f 1 2 + f 3 4@ puts call demand @SCS(C1(L))@ on @f@:--- @f@ is called exactly twice (@S@), each time exactly once (@1@) with an--- additional argument.------ The nested 'Demand's @dn@ of a 'Prod' @P(d1,d2,...)@ apply /absolutely/:--- If @dn@ is a used once demand (cf. 'isUsedOnce'), then that means that--- the denoted sub-expression is used once in the entire evaluation context--- described by the surrounding 'Demand'. E.g., @LP(ML)@ means that the--- field of the denoted expression is used at most once, although the--- entire expression might be used many times.------ See Note [Call demands are relative]--- and Note [Demand notation].-data SubDemand-  = Poly !Card-  -- ^ Polymorphic demand, the denoted thing is evaluated arbitrarily deep,-  -- with the specified cardinality at every level.-  -- Expands to 'Call' via 'viewCall' and to 'Prod' via 'viewProd'.-  ---  -- @Poly n@ is semantically equivalent to @Prod [n :* Poly n, ...]@ or-  -- @Call n (Poly n)@. 'mkCall' and 'mkProd' do these rewrites.-  ---  -- In Note [Demand notation]: @L === P(L,L,...)@ and @L === CL(L)@,-  --                            @1 === P(1,1,...)@ and @1 === C1(1)@, and so on.-  ---  -- We only really use 'Poly' with 'C_10' (B), 'C_00' (A), 'C_0N' (L) and-  -- sometimes 'C_1N' (S), but it's simpler to treat it uniformly than to-  -- have a special constructor for each of the three cases.-  | Call !Card !SubDemand-  -- ^ @Call n sd@ describes the evaluation context of @n@ function-  -- applications, where every individual result is evaluated according to @sd@.-  -- @sd@ is /relative/ to a single call, cf. Note [Call demands are relative].-  -- Used only for values of function type. Use the smart constructor 'mkCall'-  -- whenever possible!-  | Prod ![Demand]-  -- ^ @Prod ds@ describes the evaluation context of a case scrutinisation-  -- on an expression of product type, where the product components are-  -- evaluated according to @ds@.-  deriving Eq--poly00, poly01, poly0N, poly11, poly1N, poly10 :: SubDemand-topSubDmd, botSubDmd, seqSubDmd :: SubDemand-poly00 = Poly C_00-poly01 = Poly C_01-poly0N = Poly C_0N-poly11 = Poly C_11-poly1N = Poly C_1N-poly10 = Poly C_10-topSubDmd = poly0N-botSubDmd = poly10-seqSubDmd = poly00--polyDmd :: Card -> Demand-polyDmd C_00 = C_00 :* poly00-polyDmd C_01 = C_01 :* poly01-polyDmd C_0N = C_0N :* poly0N-polyDmd C_11 = C_11 :* poly11-polyDmd C_1N = C_1N :* poly1N-polyDmd C_10 = C_10 :* poly10---- | A smart constructor for 'Prod', applying rewrite rules along the semantic--- equality @Prod [polyDmd n, ...] === polyDmd n@, simplifying to 'Poly'--- 'SubDemand's when possible. Note that this degrades boxity information! E.g. a--- polymorphic demand will never unbox.-mkProd :: [Demand] -> SubDemand-mkProd [] = seqSubDmd-mkProd ds@(n:*sd : _)-  | want_to_simplify n, all (== polyDmd n) ds = sd-  | otherwise                                 = Prod ds-  where-    -- We only want to simplify absent and bottom demands and unbox the others.-    -- See also Note [L should win] and Note [Don't optimise LP(L,L,...) to L].-    want_to_simplify C_00 = True-    want_to_simplify C_10 = True-    want_to_simplify _    = False---- | @viewProd n sd@ interprets @sd@ as a 'Prod' of arity @n@, expanding 'Poly'--- demands as necessary.-viewProd :: Arity -> SubDemand -> Maybe [Demand]--- It's quite important that this function is optimised well;--- it is used by lubSubDmd and plusSubDmd. Note the strict--- application to 'polyDmd':-viewProd n (Prod ds)   | ds `lengthIs` n = Just ds--- Note the strict application to replicate: This makes sure we don't allocate--- a thunk for it, inlines it and lets case-of-case fire at call sites.-viewProd n (Poly card)                   = Just $! (replicate n $! polyDmd card)-viewProd _ _                             = Nothing-{-# INLINE viewProd #-} -- we want to fuse away the replicate and the allocation-                        -- for Arity. Otherwise, #18304 bites us.---- | A smart constructor for 'Call', applying rewrite rules along the semantic--- equality @Call n (Poly n) === Poly n@, simplifying to 'Poly' 'SubDemand's--- when possible.-mkCall :: Card -> SubDemand -> SubDemand-mkCall n cd@(Poly m) | n == m = cd-mkCall n cd                   = Call n cd---- | @viewCall sd@ interprets @sd@ as a 'Call', expanding 'Poly' demands as--- necessary.-viewCall :: SubDemand -> Maybe (Card, SubDemand)-viewCall (Call n sd)    = Just (n, sd)-viewCall sd@(Poly card) = Just (card, sd)-viewCall _              = Nothing--topDmd, absDmd, botDmd, seqDmd :: Demand-topDmd = polyDmd C_0N-absDmd = polyDmd C_00-botDmd = polyDmd C_10-seqDmd = C_11 :* seqSubDmd---- | Denotes '∪' on 'SubDemand'.-lubSubDmd :: SubDemand -> SubDemand -> SubDemand--- Handle Prod-lubSubDmd (Prod ds1) (viewProd (length ds1) -> Just ds2) =-  Prod $ strictZipWith lubDmd ds2 ds1 -- try to fuse with ds2--- Handle Call-lubSubDmd (Call n1 d1) (viewCall -> Just (n2, d2))-  -- See Note [Call demands are relative]-  | isAbs n1  = mkCall (lubCard n1 n2) (lubSubDmd botSubDmd d2)-  | isAbs n2  = mkCall (lubCard n1 n2) (lubSubDmd d1 botSubDmd)-  | otherwise = mkCall (lubCard n1 n2) (lubSubDmd d1        d2)--- Handle Poly-lubSubDmd (Poly n1)  (Poly n2) = Poly (lubCard n1 n2)--- Make use of reflexivity (so we'll match the Prod or Call cases again).-lubSubDmd sd1@Poly{} sd2       = lubSubDmd sd2 sd1--- Otherwise (Call `lub` Prod) return Top-lubSubDmd _          _         = topSubDmd---- | Denotes '∪' on 'Demand'.-lubDmd :: Demand -> Demand -> Demand-lubDmd (n1 :* sd1) (n2 :* sd2) = lubCard n1 n2 :* lubSubDmd sd1 sd2---- | Denotes '+' on 'SubDemand'.-plusSubDmd :: SubDemand -> SubDemand -> SubDemand--- Handle Prod-plusSubDmd (Prod ds1) (viewProd (length ds1) -> Just ds2) =-  Prod $ zipWith plusDmd ds2 ds1 -- try to fuse with ds2--- Handle Call-plusSubDmd (Call n1 d1) (viewCall -> Just (n2, d2))-  -- See Note [Call demands are relative]-  | isAbs n1  = mkCall (plusCard n1 n2) (lubSubDmd botSubDmd d2)-  | isAbs n2  = mkCall (plusCard n1 n2) (lubSubDmd d1 botSubDmd)-  | otherwise = mkCall (plusCard n1 n2) (lubSubDmd d1        d2)--- Handle Poly-plusSubDmd (Poly n1)  (Poly n2) = Poly (plusCard n1 n2)--- Make use of reflexivity (so we'll match the Prod or Call cases again).-plusSubDmd sd1@Poly{} sd2       = plusSubDmd sd2 sd1--- Otherwise (Call `lub` Prod) return Top-plusSubDmd _          _         = topSubDmd---- | Denotes '+' on 'Demand'.-plusDmd :: Demand -> Demand -> Demand-plusDmd (n1 :* sd1) (n2 :* sd2) = plusCard n1 n2 :* plusSubDmd sd1 sd2---- | The trivial cases of the @mult*@ functions.--- If @multTrivial n abs a = ma@, we have the following outcomes--- depending on @n@:------   * 'C_11' => multiply by one, @ma = Just a@---   * 'C_00', 'C_10' (e.g. @'isAbs' n@) => return the absent thing,---      @ma = Just abs@---   * Otherwise ('C_01', 'C_*N') it's not a trivial case, @ma = Nothing@.-multTrivial :: Card -> a -> a -> Maybe a-multTrivial C_11 _   a           = Just a-multTrivial n    abs _ | isAbs n = Just abs-multTrivial _    _   _           = Nothing--multSubDmd :: Card -> SubDemand -> SubDemand-multSubDmd n sd-  | Just sd' <- multTrivial n seqSubDmd sd = sd'-multSubDmd n (Poly n')    = Poly (multCard n n')-multSubDmd n (Call n' sd) = mkCall (multCard n n') sd -- See Note [Call demands are relative]-multSubDmd n (Prod ds)    = Prod (map (multDmd n) ds)--multDmd :: Card -> Demand -> Demand-multDmd n    dmd-  | Just dmd' <- multTrivial n absDmd dmd = dmd'-multDmd n (m :* dmd) = multCard n m :* multSubDmd n dmd---- | Used to suppress pretty-printing of an uninformative demand-isTopDmd :: Demand -> Bool-isTopDmd dmd = dmd == topDmd--isAbsDmd :: Demand -> Bool-isAbsDmd (n :* _) = isAbs n---- | Contrast with isStrictUsedDmd. See Note [Strict demands]-isStrictDmd :: Demand -> Bool-isStrictDmd (n :* _) = isStrict n---- | Not absent and used strictly. See Note [Strict demands]-isStrUsedDmd :: Demand -> Bool-isStrUsedDmd (n :* _) = isStrict n && not (isAbs n)--isSeqDmd :: Demand -> Bool-isSeqDmd (C_11 :* sd) = sd == seqSubDmd-isSeqDmd (C_1N :* sd) = sd == seqSubDmd -- I wonder if we need this case.-isSeqDmd _            = False---- | Is the value used at most once?-isUsedOnceDmd :: Demand -> Bool-isUsedOnceDmd (n :* _) = isUsedOnce n---- | We try to avoid tracking weak free variable demands in strictness--- signatures for analysis performance reasons.--- See Note [Lazy and unleashable free variables] in "GHC.Core.Opt.DmdAnal".-isWeakDmd :: Demand -> Bool-isWeakDmd dmd@(n :* _) = not (isStrict n) && is_plus_idem_dmd dmd-  where-    -- @is_plus_idem_* thing@ checks whether @thing `plus` thing = thing@,-    -- e.g. if @thing@ is idempotent wrt. to @plus@.-    is_plus_idem_card c = plusCard c c == c-    -- is_plus_idem_dmd dmd = plusDmd dmd dmd == dmd-    is_plus_idem_dmd (n :* sd) = is_plus_idem_card n && is_plus_idem_sub_dmd sd-    -- is_plus_idem_sub_dmd sd = plusSubDmd sd sd == sd-    is_plus_idem_sub_dmd (Poly n)   = is_plus_idem_card n-    is_plus_idem_sub_dmd (Prod ds)  = all is_plus_idem_dmd ds-    is_plus_idem_sub_dmd (Call n _) = is_plus_idem_card n -- See Note [Call demands are relative]--evalDmd :: Demand-evalDmd = C_1N :* topSubDmd---- | First argument of 'GHC.Exts.maskAsyncExceptions#': @1C1(L)@.--- Called exactly once.-strictOnceApply1Dmd :: Demand-strictOnceApply1Dmd = C_11 :* mkCall C_11 topSubDmd---- | First argument of 'GHC.Exts.atomically#': @SCS(L)@.--- Called at least once, possibly many times.-strictManyApply1Dmd :: Demand-strictManyApply1Dmd = C_1N :* mkCall C_1N topSubDmd---- | First argument of catch#: @MCM(L)@.--- Evaluates its arg lazily, but then applies it exactly once to one argument.-lazyApply1Dmd :: Demand-lazyApply1Dmd = C_01 :* mkCall C_01 topSubDmd---- | Second argument of catch#: @MCM(C1(L))@.--- Calls its arg lazily, but then applies it exactly once to an additional argument.-lazyApply2Dmd :: Demand-lazyApply2Dmd = C_01 :* mkCall C_01 (mkCall C_11 topSubDmd)---- | Make a 'Demand' evaluated at-most-once.-oneifyDmd :: Demand -> Demand-oneifyDmd (n :* sd) = oneifyCard n :* sd---- | Make a 'Demand' evaluated at-least-once (e.g. strict).-strictifyDmd :: Demand -> Demand-strictifyDmd (n :* sd) = plusCard C_10 n :* sd---- | If the argument is a used non-newtype dictionary, give it strict demand.--- Also split the product type & demand and recur in order to similarly--- strictify the argument's contained used non-newtype superclass dictionaries.--- We use the demand as our recursive measure to guarantee termination.-strictifyDictDmd :: Type -> Demand -> Demand-strictifyDictDmd ty (n :* Prod ds)-  | not (isAbs n)-  , Just field_tys <- as_non_newtype_dict ty-  = C_1N :* -- main idea: ensure it's strict-      if all (not . isAbsDmd) ds-        then topSubDmd -- abstract to strict w/ arbitrary component use,-                         -- since this smells like reboxing; results in CBV-                         -- boxed-                         ---                         -- TODO revisit this if we ever do boxity analysis-        else Prod (zipWith strictifyDictDmd field_tys ds)-  where-    -- | Return a TyCon and a list of field types if the given-    -- type is a non-newtype dictionary type-    as_non_newtype_dict ty-      | Just (tycon, _arg_tys, _data_con, map scaledThing -> inst_con_arg_tys)-          <- splitDataProductType_maybe ty-      , not (isNewTyCon tycon)-      , isClassTyCon tycon-      = Just inst_con_arg_tys-      | otherwise-      = Nothing-strictifyDictDmd _  dmd = dmd---- | Wraps the 'SubDemand' with a one-shot call demand: @d@ -> @C1(d)@.-mkCalledOnceDmd :: SubDemand -> SubDemand-mkCalledOnceDmd sd = mkCall C_11 sd---- | @mkCalledOnceDmds n d@ returns @C1(C1...(C1 d))@ where there are @n@ @C1@'s.-mkCalledOnceDmds :: Arity -> SubDemand -> SubDemand-mkCalledOnceDmds arity sd = iterate mkCalledOnceDmd sd !! arity---- | Peels one call level from the sub-demand, and also returns how many--- times we entered the lambda body.-peelCallDmd :: SubDemand -> (Card, SubDemand)-peelCallDmd sd = viewCall sd `orElse` (topCard, topSubDmd)---- Peels multiple nestings of 'Call' sub-demands and also returns--- whether it was unsaturated in the form of a 'Card'inality, denoting--- how many times the lambda body was entered.--- See Note [Demands from unsaturated function calls].-peelManyCalls :: Int -> SubDemand -> Card-peelManyCalls 0 _                          = C_11--- See Note [Call demands are relative]-peelManyCalls n (viewCall -> Just (m, sd)) = m `multCard` peelManyCalls (n-1) sd-peelManyCalls _ _                          = C_0N---- See Note [Demand on the worker] in GHC.Core.Opt.WorkWrap-mkWorkerDemand :: Int -> Demand-mkWorkerDemand n = C_01 :* go n-  where go 0 = topSubDmd-        go n = Call C_01 $ go (n-1)--addCaseBndrDmd :: SubDemand -- On the case binder-               -> [Demand]  -- On the components of the constructor-               -> [Demand]  -- Final demands for the components of the constructor-addCaseBndrDmd (Poly n) alt_dmds-  | isAbs n   = alt_dmds--- See Note [Demand on case-alternative binders]-addCaseBndrDmd sd       alt_dmds = zipWith plusDmd ds alt_dmds -- fuse ds!-  where-    Just ds = viewProd (length alt_dmds) sd -- Guaranteed not to be a call--argsOneShots :: StrictSig -> Arity -> [[OneShotInfo]]--- ^ See Note [Computing one-shot info]-argsOneShots (StrictSig (DmdType _ arg_ds _)) n_val_args-  | unsaturated_call = []-  | otherwise = go arg_ds-  where-    unsaturated_call = arg_ds `lengthExceeds` n_val_args--    go []               = []-    go (arg_d : arg_ds) = argOneShots arg_d `cons` go arg_ds--    -- Avoid list tail like [ [], [], [] ]-    cons [] [] = []-    cons a  as = a:as--argOneShots :: Demand          -- ^ depending on saturation-            -> [OneShotInfo]--- ^ See Note [Computing one-shot info]-argOneShots (_ :* sd) = go sd -- See Note [Call demands are relative]-  where-    go (Call n sd)-      | isUsedOnce n = OneShotLam    : go sd-      | otherwise    = NoOneShotInfo : go sd-    go _    = []---- |--- @saturatedByOneShots n CM(CM(...)) = True@---   <=>--- There are at least n nested CM(..) calls.--- See Note [Demand on the worker] in GHC.Core.Opt.WorkWrap-saturatedByOneShots :: Int -> Demand -> Bool-saturatedByOneShots n (_ :* sd) = isUsedOnce (peelManyCalls n sd)--{- Note [Strict demands]-~~~~~~~~~~~~~~~~~~~~~~~~-'isStrUsedDmd' returns true only of demands that are-   both strict-   and  used--In particular, it is False for <B> (i.e. strict and not used,-cardinality C_10), which can and does arise in, say (#7319)-   f x = raise# <some exception>-Then 'x' is not used, so f gets strictness <B> -> .-Now the w/w generates-   fx = let x <B> = absentError "unused"-        in raise <some exception>-At this point we really don't want to convert to-   fx = case absentError "unused" of x -> raise <some exception>-Since the program is going to diverge, this swaps one error for another,-but it's really a bad idea to *ever* evaluate an absent argument.-In #7319 we get-   T7319.exe: Oops!  Entered absent arg w_s1Hd{v} [lid] [base:GHC.Base.String{tc 36u}]--Note [Call demands are relative]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The expression @if b then 0 else f 1 2 + f 3 4@ uses @f@ according to the demand-@LCL(C1(P(L)))@, meaning--  "f is called multiple times or not at all (CL), but each time it-   is called, it's called with *exactly one* (C1) more argument.-   Whenever it is called with two arguments, we have no info on how often-   the field of the product result is used (L)."--So the 'SubDemand' nested in a 'Call' demand is relative to exactly one call.-And that extends to the information we have how its results are used in each-call site. Consider (#18903)--  h :: Int -> Int-  h m =-    let g :: Int -> (Int,Int)-        g 1 = (m, 0)-        g n = (2 * n, 2 `div` n)-        {-# NOINLINE g #-}-    in case m of-      1 -> 0-      2 -> snd (g m)-      _ -> uncurry (+) (g m)--We want to give @g@ the demand @MCM(P(MP(L),1P(L)))@, so we see that in each call-site of @g@, we are strict in the second component of the returned pair.--This relative cardinality leads to an otherwise unexpected call to 'lubSubDmd'-in 'plusSubDmd', but if you do the math it's just the right thing.--There's one more subtlety: Since the nested demand is relative to exactly one-call, in the case where we have *at most zero calls* (e.g. CA(...)), the premise-is hurt and we can assume that the nested demand is 'botSubDmd'. That ensures-that @g@ above actually gets the @1P(L)@ demand on its second pair component,-rather than the lazy @MP(L)@ if we 'lub'bed with an absent demand.--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:-  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 }--It's true that ds_dnz is *itself* absent, but the use of wild_X7 means-that it is very much alive and demanded.  See #10148 for how the-consequences play out.--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 [Don't optimise LP(L,L,...) to L]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-These two SubDemands:-   LP(L,L) (@Prod [topDmd, topDmd]@)   and   L (@topSubDmd@)-are semantically equivalent, but we do not turn the former into-the latter, for a regrettable-subtle reason.  Consider-  f p1@(x,y) = (y,x)-  g h p2@(_,_) = h p-We want to unbox @p1@ of @f@, but not @p2@ of @g@, because @g@ only uses-@p2@ boxed and we'd have to rebox. So we give @p1@ demand LP(L,L) and @p2@-demand @L@ to inform 'GHC.Core.Opt.WorkWrap.Utils.wantToUnbox', which will-say "unbox" for @p1@ and "don't unbox" for @p2@.--So the solution is: don't aggressively collapse @Prod [topDmd, topDmd]@ to-@topSubDmd@; instead leave it as-is. In effect we are using the UseDmd to do a-little bit of boxity analysis.  Not very nice.--Note [L should win]-~~~~~~~~~~~~~~~~~~~-Both in 'lubSubDmd' and 'plusSubDmd' we want @L `plusSubDmd` LP(..))@ to be @L@.-Why?  Because U carries the implication the whole thing is used, box and all,-so we don't want to w/w it, cf. Note [Don't optimise LP(L,L,...) to L].-If we use it both boxed and unboxed, then we are definitely using the box,-and so we are quite likely to pay a reboxing cost. So we make U win here.-TODO: Investigate why since 2013, we don't.--Example is in the Buffer argument of GHC.IO.Handle.Internals.writeCharBuffer--Baseline: (A) Not making Used win (LP(..) wins)-Compare with: (B) making Used win for lub and both--            Min          -0.3%     -5.6%    -10.7%    -11.0%    -33.3%-            Max          +0.3%    +45.6%    +11.5%    +11.5%     +6.9%- Geometric Mean          -0.0%     +0.5%     +0.3%     +0.2%     -0.8%--Baseline: (B) Making L win for both lub and both-Compare with: (C) making L win for plus, but LP(..) win for lub--            Min          -0.1%     -0.3%     -7.9%     -8.0%     -6.5%-            Max          +0.1%     +1.0%    +21.0%    +21.0%     +0.5%- Geometric Mean          +0.0%     +0.0%     -0.0%     -0.1%     -0.1%--Note [Computing one-shot info]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider a call-    f (\pqr. e1) (\xyz. e2) e3-where f has usage signature-    <CM(CL(CM(L)))><CM(L)><L>-Then argsOneShots returns a [[OneShotInfo]] of-    [[OneShot,NoOneShotInfo,OneShot],  [OneShot]]-The occurrence analyser propagates this one-shot infor to the-binders \pqr and \xyz;-see Note [Use one-shot information] in "GHC.Core.Opt.OccurAnal".--}--{- *********************************************************************-*                                                                      *-                 Divergence: Whether evaluation surely diverges-*                                                                      *-********************************************************************* -}---- | 'Divergence' characterises whether something surely diverges.--- Models a subset lattice of the following exhaustive set of divergence--- results:------ [n] nontermination (e.g. loops)--- [i] throws imprecise exception--- [p] throws precise exceTtion--- [c] converges (reduces to WHNF).------ The different lattice elements correspond to different subsets, indicated by--- juxtaposition of indicators (e.g. __nc__ definitely doesn't throw an--- exception, and may or may not reduce to WHNF).------ @---             Dunno (nipc)---                  |---            ExnOrDiv (nip)---                  |---            Diverges (ni)--- @------ As you can see, we don't distinguish __n__ and __i__.--- See Note [Precise exceptions and strictness analysis] for why __p__ is so--- special compared to __i__.-data Divergence-  = Diverges -- ^ Definitely throws an imprecise exception or diverges.-  | ExnOrDiv -- ^ Definitely throws a *precise* exception, an imprecise-             --   exception or diverges. Never converges, hence 'isDeadEndDiv'!-             --   See scenario 1 in Note [Precise exceptions and strictness analysis].-  | Dunno    -- ^ Might diverge, throw any kind of exception or converge.-  deriving Eq--lubDivergence :: Divergence -> Divergence -> Divergence-lubDivergence Diverges div      = div-lubDivergence div      Diverges = div-lubDivergence ExnOrDiv ExnOrDiv = ExnOrDiv-lubDivergence _        _        = Dunno--- This needs to commute with defaultFvDmd, i.e.--- defaultFvDmd (r1 `lubDivergence` r2) = defaultFvDmd r1 `lubDmd` defaultFvDmd r2--- (See Note [Default demand on free variables and arguments] for why)---- | See Note [Asymmetry of 'plus*'], which concludes that 'plusDivergence'--- needs to be symmetric.--- Strictly speaking, we should have @plusDivergence Dunno Diverges = ExnOrDiv@.--- But that regresses in too many places (every infinite loop, basically) to be--- worth it and is only relevant in higher-order scenarios--- (e.g. Divergence of @f (throwIO blah)@).--- So 'plusDivergence' currently is 'glbDivergence', really.-plusDivergence :: Divergence -> Divergence -> Divergence-plusDivergence Dunno    Dunno    = Dunno-plusDivergence Diverges _        = Diverges-plusDivergence _        Diverges = Diverges-plusDivergence _        _        = ExnOrDiv---- | In a non-strict scenario, we might not force the Divergence, in which case--- we might converge, hence Dunno.-multDivergence :: Card -> Divergence -> Divergence-multDivergence n _ | not (isStrict n) = Dunno-multDivergence _ d                    = d--topDiv, exnDiv, botDiv :: Divergence-topDiv = Dunno-exnDiv = ExnOrDiv-botDiv = Diverges---- | True if the 'Divergence' indicates that evaluation will not return.--- See Note [Dead ends].-isDeadEndDiv :: Divergence -> Bool-isDeadEndDiv Diverges = True-isDeadEndDiv ExnOrDiv = True-isDeadEndDiv Dunno    = False---- See Notes [Default demand on free variables and arguments]--- and Scenario 1 in [Precise exceptions and strictness analysis]-defaultFvDmd :: Divergence -> Demand-defaultFvDmd Dunno    = absDmd-defaultFvDmd ExnOrDiv = absDmd -- This is the whole point of ExnOrDiv!-defaultFvDmd Diverges = botDmd -- Diverges--defaultArgDmd :: Divergence -> Demand--- TopRes and BotRes are polymorphic, so that---      BotRes === (Bot -> BotRes) === ...---      TopRes === (Top -> TopRes) === ...--- This function makes that concrete--- Also see Note [Default demand on free variables and arguments]-defaultArgDmd Dunno    = topDmd--- NB: not botDmd! We don't want to mask the precise exception by forcing the--- argument. But it is still absent.-defaultArgDmd ExnOrDiv = absDmd-defaultArgDmd Diverges = botDmd--{- Note [Precise vs imprecise exceptions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-An exception is considered to be /precise/ when it is thrown by the 'raiseIO#'-primop. It follows that all other primops (such as 'raise#' or-division-by-zero) throw /imprecise/ exceptions. Note that the actual type of-the exception thrown doesn't have any impact!--GHC undertakes some effort not to apply an optimisation that would mask a-/precise/ exception with some other source of nontermination, such as genuine-divergence or an imprecise exception, so that the user can reliably-intercept the precise exception with a catch handler before and after-optimisations.--See also the wiki page on precise exceptions:-https://gitlab.haskell.org/ghc/ghc/wikis/exceptions/precise-exceptions-Section 5 of "Tackling the awkward squad" talks about semantic concerns.-Imprecise exceptions are actually more interesting than precise ones (which are-fairly standard) from the perspective of semantics. See the paper "A Semantics-for Imprecise Exceptions" for more details.--Note [Dead ends]-~~~~~~~~~~~~~~~~-We call an expression that either diverges or throws a precise or imprecise-exception a "dead end". We used to call such an expression just "bottoming",-but with the measures we take to preserve precise exception semantics-(see Note [Precise exceptions and strictness analysis]), that is no longer-accurate: 'exnDiv' is no longer the bottom of the Divergence lattice.--Yet externally to demand analysis, we mostly care about being able to drop dead-code etc., which is all due to the property that such an expression never-returns, hence we consider throwing a precise exception to be a dead end.-See also 'isDeadEndDiv'.--Note [Precise exceptions and strictness analysis]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We have to take care to preserve precise exception semantics in strictness-analysis (#17676). There are two scenarios that need careful treatment.--The fixes were discussed at-https://gitlab.haskell.org/ghc/ghc/wikis/fixing-precise-exceptions--Recall that raiseIO# raises a *precise* exception, in contrast to raise# which-raises an *imprecise* exception. See Note [Precise vs imprecise exceptions].--Scenario 1: Precise exceptions in case alternatives-----------------------------------------------------Unlike raise# (which returns botDiv), we want raiseIO# to return exnDiv.-Here's why. Consider this example from #13380 (similarly #17676):-  f x y | x>0       = raiseIO# Exc-        | y>0       = return 1-        | otherwise = return 2-Is 'f' strict in 'y'? One might be tempted to say yes! But that plays fast and-loose with the precise exception; after optimisation, (f 42 (error "boom"))-turns from throwing the precise Exc to throwing the imprecise user error-"boom". So, the defaultFvDmd of raiseIO# should be lazy (topDmd), which can be-achieved by giving it divergence exnDiv.-See Note [Default demand on free variables and arguments].--Why don't we just give it topDiv instead of introducing exnDiv?-Because then the simplifier will fail to discard raiseIO#'s continuation in-  case raiseIO# x s of { (# s', r #) -> <BIG> }-which we'd like to optimise to-  case raiseIO# x s of {}-Hence we came up with exnDiv. The default FV demand of exnDiv is lazy (and-its default arg dmd is absent), but otherwise (in terms of 'isDeadEndDiv') it-behaves exactly as botDiv, so that dead code elimination works as expected.-This is tracked by T13380b.--Scenario 2: Precise exceptions in case scrutinees---------------------------------------------------Consider (more complete examples in #148, #1592, testcase strun003)--  case foo x s of { (# s', r #) -> y }--Is this strict in 'y'? Often not! If @foo x s@ might throw a precise exception-(ultimately via raiseIO#), then we must not force 'y', which may fail to-terminate or throw an imprecise exception, until we have performed @foo x s@.--So we have to 'deferAfterPreciseException' (which 'lub's with 'exnDmdType' to-model the exceptional control flow) when @foo x s@ may throw a precise-exception. Motivated by T13380{d,e,f}.-See Note [Which scrutinees may throw precise exceptions] in "GHC.Core.Opt.DmdAnal".--We have to be careful not to discard dead-end Divergence from case-alternatives, though (#18086):--  m = putStrLn "foo" >> error "bar"--'m' should still have 'exnDiv', which is why it is not sufficient to lub with-'nopDmdType' (which has 'topDiv') in 'deferAfterPreciseException'.--Historical Note: This used to be called the "IO hack". But that term is rather-a bad fit because-1. It's easily confused with the "State hack", which also affects IO.-2. Neither "IO" nor "hack" is a good description of what goes on here, which-   is deferring strictness results after possibly throwing a precise exception.-   The "hack" is probably not having to defer when we can prove that the-   expression may not throw a precise exception (increasing precision of the-   analysis), but that's just a favourable guess.--Note [Exceptions and strictness]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We used to smart about catching exceptions, but we aren't anymore.-See #14998 for the way it's resolved at the moment.--Here's a historic breakdown:--Apparently, exception handling prim-ops didn't use to have any special-strictness signatures, thus defaulting to nopSig, which assumes they use their-arguments lazily. Joachim was the first to realise that we could provide richer-information. Thus, in 0558911f91c (Dec 13), he added signatures to-primops.txt.pp indicating that functions like `catch#` and `catchRetry#` call-their argument, which is useful information for usage analysis. Still with a-'Lazy' strictness demand (i.e. 'lazyApply1Dmd'), though, and the world was fine.--In 7c0fff4 (July 15), Simon argued that giving `catch#` et al. a-'strictApply1Dmd' leads to substantial performance gains. That was at the cost-of correctness, as #10712 proved. So, back to 'lazyApply1Dmd' in-28638dfe79e (Dec 15).--Motivated to reproduce the gains of 7c0fff4 without the breakage of #10712,-Ben opened #11222. Simon made the demand analyser "understand catch" in-9915b656 (Jan 16) by adding a new 'catchArgDmd', which basically said to call-its argument strictly, but also swallow any thrown exceptions in-'multDivergence'. This was realized by extending the 'Str' constructor of-'ArgStr' with a 'ExnStr' field, indicating that it catches the exception, and-adding a 'ThrowsExn' constructor to the 'Divergence' lattice as an element-between 'Dunno' and 'Diverges'. Then along came #11555 and finally #13330,-so we had to revert to 'lazyApply1Dmd' again in 701256df88c (Mar 17).--This left the other variants like 'catchRetry#' having 'catchArgDmd', which is-where #14998 picked up. Item 1 was concerned with measuring the impact of also-making `catchRetry#` and `catchSTM#` have 'lazyApply1Dmd'. The result was that-there was none. We removed the last usages of 'catchArgDmd' in 00b8ecb7-(Apr 18). There was a lot of dead code resulting from that change, that we-removed in ef6b283 (Jan 19): We got rid of 'ThrowsExn' and 'ExnStr' again and-removed any code that was dealing with the peculiarities.--Where did the speed-ups vanish to? In #14998, item 3 established that-turning 'catch#' strict in its first argument didn't bring back any of the-alleged performance benefits. Item 2 of that ticket finally found out that it-was entirely due to 'catchException's new (since #11555) definition, which-was simply--    catchException !io handler = catch io handler--While 'catchException' is arguably the saner semantics for 'catch', it is an-internal helper function in "GHC.IO". Its use in-"GHC.IO.Handle.Internals.do_operation" made for the huge allocation differences:-Remove the bang and you find the regressions we originally wanted to avoid with-'catchArgDmd'. See also #exceptions_and_strictness# in "GHC.IO".--So history keeps telling us that the only possibly correct strictness annotation-for the first argument of 'catch#' is 'lazyApply1Dmd', because 'catch#' really-is not strict in its argument: Just try this in GHCi--  :set -XScopedTypeVariables-  import Control.Exception-  catch undefined (\(_ :: SomeException) -> putStrLn "you'll see this")--Any analysis that assumes otherwise will be broken in some way or another-(beyond `-fno-pendantic-bottoms`).--But then #13380 and #17676 suggest (in Mar 20) that we need to re-introduce a-subtly different variant of `ThrowsExn` (which we call `ExnOrDiv` now) that is-only used by `raiseIO#` in order to preserve precise exceptions by strictness-analysis, while not impacting the ability to eliminate dead code.-See Note [Precise exceptions and strictness analysis].--Note [Default demand on free variables and arguments]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Free variables not mentioned in the environment of a 'DmdType'-are demanded according to the demand type's Divergence:-  * In a Diverges (botDiv) context, that demand is botDmd-    (strict and absent).-  * In all other contexts, the demand is absDmd (lazy and absent).-This is recorded in 'defaultFvDmd'.--Similarly, we can eta-expand demand types to get demands on excess arguments-not accounted for in the type, by consulting 'defaultArgDmd':-  * In a Diverges (botDiv) context, that demand is again botDmd.-  * In a ExnOrDiv (exnDiv) context, that demand is absDmd: We surely diverge-    before evaluating the excess argument, but don't want to eagerly evaluate-    it (cf. Note [Precise exceptions and strictness analysis]).-  * In a Dunno context (topDiv), the demand is topDmd, because-    it's perfectly possible to enter the additional lambda and evaluate it-    in unforeseen ways (so, not absent).--Note [Bottom CPR iff Dead-Ending Divergence]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Both CPR analysis and Demand analysis handle recursive functions by doing-fixed-point iteration. To find the *least* (e.g., most informative) fixed-point,-iteration starts with the bottom element of the semantic domain. Diverging-functions generally have the bottom element as their least fixed-point.--One might think that CPR analysis and Demand analysis then agree in when a-function gets a bottom denotation. E.g., whenever it has 'botCpr', it should-also have 'botDiv'. But that is not the case, because strictness analysis has to-be careful around precise exceptions, see Note [Precise vs imprecise exceptions].--So Demand analysis gives some diverging functions 'exnDiv' (which is *not* the-bottom element) when the CPR signature says 'botCpr', and that's OK. Here's an-example (from #18086) where that is the case:--ioTest :: IO ()-ioTest = do-  putStrLn "hi"-  undefined--However, one can loosely say that we give a function 'botCpr' whenever its-'Divergence' is 'exnDiv' or 'botDiv', i.e., dead-ending. But that's just-a consequence of fixed-point iteration, it's not important that they agree.--************************************************************************-*                                                                      *-           Demand environments and types-*                                                                      *-************************************************************************--}---- Subject to Note [Default demand on free variables and arguments]-type DmdEnv = VarEnv Demand--emptyDmdEnv :: DmdEnv-emptyDmdEnv = emptyVarEnv--multDmdEnv :: Card -> DmdEnv -> DmdEnv-multDmdEnv n env-  | Just env' <- multTrivial n emptyDmdEnv env = env'-  | otherwise                                  = mapVarEnv (multDmd n) env--reuseEnv :: DmdEnv -> DmdEnv-reuseEnv = multDmdEnv C_1N---- | @keepAliveDmdType dt vs@ makes sure that the Ids in @vs@ have--- /some/ usage in the returned demand types -- they are not Absent.--- See Note [Absence analysis for stable unfoldings and RULES]---     in "GHC.Core.Opt.DmdAnal".-keepAliveDmdEnv :: DmdEnv -> IdSet -> DmdEnv-keepAliveDmdEnv env vs-  = nonDetStrictFoldVarSet add env vs-  where-    add :: Id -> DmdEnv -> DmdEnv-    add v env = extendVarEnv_C add_dmd env v topDmd--    add_dmd :: Demand -> Demand -> Demand-    -- If the existing usage is Absent, make it used-    -- Otherwise leave it alone-    add_dmd dmd _ | isAbsDmd dmd = topDmd-                  | otherwise    = dmd---- | Characterises how an expression---    * Evaluates its free variables ('dt_env')---    * Evaluates its arguments ('dt_args')---    * Diverges on every code path or not ('dt_div')-data DmdType-  = DmdType-  { dt_env  :: !DmdEnv     -- ^ Demand on explicitly-mentioned free variables-  , dt_args :: ![Demand]   -- ^ Demand on arguments-  , dt_div  :: !Divergence -- ^ Whether evaluation diverges.-                          -- See Note [Demand type Divergence]-  }--instance Eq DmdType where-  (==) (DmdType fv1 ds1 div1)-       (DmdType fv2 ds2 div2) = nonDetUFMToList fv1 == nonDetUFMToList fv2-         -- It's OK to use nonDetUFMToList here because we're testing for-         -- equality and even though the lists will be in some arbitrary-         -- Unique order, it is the same order for both-                              && ds1 == ds2 && div1 == div2---- | Compute the least upper bound of two 'DmdType's elicited /by the same--- incoming demand/!-lubDmdType :: DmdType -> DmdType -> DmdType-lubDmdType d1 d2-  = DmdType lub_fv lub_ds lub_div-  where-    n = max (dmdTypeDepth d1) (dmdTypeDepth d2)-    (DmdType fv1 ds1 r1) = etaExpandDmdType n d1-    (DmdType fv2 ds2 r2) = etaExpandDmdType n d2--    lub_fv  = plusVarEnv_CD lubDmd fv1 (defaultFvDmd r1) fv2 (defaultFvDmd r2)-    lub_ds  = zipWithEqual "lubDmdType" lubDmd ds1 ds2-    lub_div = lubDivergence r1 r2--type PlusDmdArg = (DmdEnv, Divergence)--mkPlusDmdArg :: DmdEnv -> PlusDmdArg-mkPlusDmdArg env = (env, topDiv)--toPlusDmdArg :: DmdType -> PlusDmdArg-toPlusDmdArg (DmdType fv _ r) = (fv, r)--plusDmdType :: DmdType -> PlusDmdArg -> DmdType-plusDmdType (DmdType fv1 ds1 r1) (fv2, t2)-    -- See Note [Asymmetry of 'plus*']-    -- 'plus' takes the argument/result info from its *first* arg,-    -- using its second arg just for its free-var info.-  = DmdType (plusVarEnv_CD plusDmd fv1 (defaultFvDmd r1) fv2 (defaultFvDmd t2))-            ds1-            (r1 `plusDivergence` t2)--botDmdType :: DmdType-botDmdType = DmdType emptyDmdEnv [] botDiv---- | The demand type of doing nothing (lazy, absent, no Divergence--- information). Note that it is ''not'' the top of the lattice (which would be--- "may use everything"), so it is (no longer) called topDmdType.-nopDmdType :: DmdType-nopDmdType = DmdType emptyDmdEnv [] topDiv--isTopDmdType :: DmdType -> Bool-isTopDmdType (DmdType env args div)-  = div == topDiv && null args && isEmptyVarEnv env---- | The demand type of an unspecified expression that is guaranteed to--- throw a (precise or imprecise) exception or diverge.-exnDmdType :: DmdType-exnDmdType = DmdType emptyDmdEnv [] exnDiv--dmdTypeDepth :: DmdType -> Arity-dmdTypeDepth = length . dt_args---- | This makes sure we can use the demand type with n arguments after eta--- expansion, where n must not be lower than the demand types depth.--- It appends the argument list with the correct 'defaultArgDmd'.-etaExpandDmdType :: Arity -> DmdType -> DmdType-etaExpandDmdType n d@DmdType{dt_args = ds, dt_div = div}-  | n == depth = d-  | n >  depth = d{dt_args = inc_ds}-  | otherwise  = pprPanic "etaExpandDmdType: arity decrease" (ppr n $$ ppr d)-  where depth = length ds-        -- Arity increase:-        --  * Demands on FVs are still valid-        --  * Demands on args also valid, plus we can extend with defaultArgDmd-        --    as appropriate for the given Divergence-        --  * Divergence is still valid:-        --    - A dead end after 2 arguments stays a dead end after 3 arguments-        --    - The remaining case is Dunno, which is already topDiv-        inc_ds = take n (ds ++ repeat (defaultArgDmd div))---- | A conservative approximation for a given 'DmdType' in case of an arity--- decrease. Currently, it's just nopDmdType.-decreaseArityDmdType :: DmdType -> DmdType-decreaseArityDmdType _ = nopDmdType--splitDmdTy :: DmdType -> (Demand, DmdType)--- Split off one function argument--- We already have a suitable demand on all--- free vars, so no need to add more!-splitDmdTy ty@DmdType{dt_args=dmd:args} = (dmd, ty{dt_args=args})-splitDmdTy ty@DmdType{dt_div=div}       = (defaultArgDmd div, ty)--multDmdType :: Card -> DmdType -> DmdType-multDmdType n (DmdType fv args res_ty)-  = -- pprTrace "multDmdType" (ppr n $$ ppr fv $$ ppr (multDmdEnv n fv)) $-    DmdType (multDmdEnv n fv)-            (map (multDmd n) args)-            (multDivergence n res_ty)--peelFV :: DmdType -> Var -> (DmdType, Demand)-peelFV (DmdType fv ds res) id = -- pprTrace "rfv" (ppr id <+> ppr dmd $$ ppr fv)-                               (DmdType fv' ds res, dmd)-  where-  -- Force these arguments so that old `Env` is not retained.-  !fv' = fv `delVarEnv` id-  -- See Note [Default demand on free variables and arguments]-  !dmd  = lookupVarEnv fv id `orElse` defaultFvDmd res--addDemand :: Demand -> DmdType -> DmdType-addDemand dmd (DmdType fv ds res) = DmdType fv (dmd:ds) res--findIdDemand :: DmdType -> Var -> Demand-findIdDemand (DmdType fv _ res) id-  = lookupVarEnv fv id `orElse` defaultFvDmd res---- | When e is evaluated after executing an IO action that may throw a precise--- exception, we act as if there is an additional control flow path that is--- taken if e throws a precise exception. The demand type of this control flow--- path---   * is lazy and absent ('topDmd') in all free variables and arguments---   * has 'exnDiv' 'Divergence' result--- So we can simply take a variant of 'nopDmdType', 'exnDmdType'.--- Why not 'nopDmdType'? Because then the result of 'e' can never be 'exnDiv'!--- That means failure to drop dead-ends, see #18086.--- See Note [Precise exceptions and strictness analysis]-deferAfterPreciseException :: DmdType -> DmdType-deferAfterPreciseException = lubDmdType exnDmdType---- | See 'keepAliveDmdEnv'.-keepAliveDmdType :: DmdType -> VarSet -> DmdType-keepAliveDmdType (DmdType fvs ds res) vars =-  DmdType (fvs `keepAliveDmdEnv` vars) ds res--{--Note [Demand type Divergence]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In contrast to StrictSigs, DmdTypes are elicited under a specific incoming demand.-This is described in detail in Note [Understanding DmdType and StrictSig].-Here, we'll focus on what that means for a DmdType's Divergence in a higher-order-scenario.--Consider-  err x y = x `seq` y `seq` error (show x)-this has a strictness signature of-  <1L><1L>b-meaning that we don't know what happens when we call err in weaker contexts than-C1(C1(L)), like @err `seq` ()@ (1A) and @err 1 `seq` ()@ (CS(A)). We-may not unleash the botDiv, hence assume topDiv. Of course, in-@err 1 2 `seq` ()@ the incoming demand CS(CS(A)) is strong enough and we see-that the expression diverges.--Now consider a function-  f g = g 1 2-with signature <C1(C1(L))>, and the expression-  f err `seq` ()-now f puts a strictness demand of C1(C1(L)) onto its argument, which is unleashed-on err via the App rule. In contrast to weaker head strictness, this demand is-strong enough to unleash err's signature and hence we see that the whole-expression diverges!--Note [Asymmetry of 'plus*']-~~~~~~~~~~~~~~~~~~~~~~~~~~~-'plus' for DmdTypes is *asymmetrical*, because there can only one-be one type contributing argument demands!  For example, given (e1 e2), we get-a DmdType dt1 for e1, use its arg demand to analyse e2 giving dt2, and then do-(dt1 `plusType` dt2). Similarly with-  case e of { p -> rhs }-we get dt_scrut from the scrutinee and dt_rhs from the RHS, and then-compute (dt_rhs `plusType` dt_scrut).--We- 1. combine the information on the free variables,- 2. take the demand on arguments from the first argument- 3. combine the termination results, as in plusDivergence.--Since we don't use argument demands of the second argument anyway, 'plus's-second argument is just a 'PlusDmdType'.--But note that the argument demand types are not guaranteed to be observed in-left to right order. For example, analysis of a case expression will pass the-demand type for the alts as the left argument and the type for the scrutinee as-the right argument. Also, it is not at all clear if there is such an order;-consider the LetUp case, where the RHS might be forced at any point while-evaluating the let body.-Therefore, it is crucial that 'plusDivergence' is symmetric!--Note [Demands from unsaturated function calls]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider a demand transformer d1 -> d2 -> r for f.-If a sufficiently detailed demand is fed into this transformer,-e.g <C1(C1(L))> arising from "f x1 x2" in a strict, use-once context,-then d1 and d2 is precisely the demand unleashed onto x1 and x2 (similar for-the free variable environment) and furthermore the result information r is the-one we want to use.--An anonymous lambda is also an unsaturated function all (needs one argument,-none given), so this applies to that case as well.--But the demand fed into f might be less than C1(C1(L)). Then we have to-'multDmdType' the announced demand type. Examples:- * Not strict enough, e.g. C1(C1(L)):-   - We have to multiply all argument and free variable demands with C_01,-     zapping strictness.-   - We have to multiply divergence with C_01. If r says that f Diverges for sure,-     then this holds when the demand guarantees that two arguments are going to-     be passed. If the demand is lower, we may just as well converge.-     If we were tracking definite convergence, than that would still hold under-     a weaker demand than expected by the demand transformer.- * Used more than once, e.g. CS(C1(L)):-   - Multiply with C_1N. Even if f puts a used-once demand on any of its argument-     or free variables, if we call f multiple times, we may evaluate this-     argument or free variable multiple times.--In dmdTransformSig, we call peelManyCalls to find out the 'Card'inality with-which we have to multiply and then call multDmdType with that.--Similarly, dmdTransformDictSelSig and dmdAnal, when analyzing a Lambda, use-peelCallDmd, which peels only one level, but also returns the demand put on the-body of the function.--}---{--************************************************************************-*                                                                      *-                     Demand signatures-*                                                                      *-************************************************************************--In a let-bound Id we record its demand signature.-In principle, this demand signature is a demand transformer, mapping-a demand on the Id into a DmdType, which gives-        a) the free vars of the Id's value-        b) the Id's arguments-        c) an indication of the result of applying-           the Id to its arguments--However, in fact we store in the Id an extremely emascuated demand-transfomer, namely--                a single DmdType-(Nevertheless we dignify StrictSig as a distinct type.)--This DmdType gives the demands unleashed by the Id when it is applied-to as many arguments as are given in by the arg demands in the DmdType.-Also see Note [Demand type Divergence] for the meaning of a Divergence in a-strictness signature.--If an Id is applied to less arguments than its arity, it means that-the demand on the function at a call site is weaker than the vanilla-call demand, used for signature inference. Therefore we place a top-demand on all arguments. Otherwise, the demand is specified by Id's-signature.--For example, the demand transformer described by the demand signature-        StrictSig (DmdType {x -> <1L>} <A><1P(L,L)>)-says that when the function is applied to two arguments, it-unleashes demand 1L on the free var x, A on the first arg,-and 1P(L,L) on the second.--If this same function is applied to one arg, all we can say is that it-uses x with 1L, and its arg with demand 1P(L,L).--Note [Understanding DmdType and StrictSig]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Demand types are sound approximations of an expression's semantics relative to-the incoming demand we put the expression under. Consider the following-expression:--    \x y -> x `seq` (y, 2*x)--Here is a table with demand types resulting from different incoming demands we-put that expression under. Note the monotonicity; a stronger incoming demand-yields a more precise demand type:--    incoming demand   |  demand type-    ---------------------------------    1A                  |  <L><L>{}-    C1(C1(L))           |  <1P(L)><L>{}-    C1(C1(1P(1P(L),A))) |  <1P(A)><A>{}--Note that in the first example, the depth of the demand type was *higher* than-the arity of the incoming call demand due to the anonymous lambda.-The converse is also possible and happens when we unleash demand signatures.-In @f x y@, the incoming call demand on f has arity 2. But if all we have is a-demand signature with depth 1 for @f@ (which we can safely unleash, see below),-the demand type of @f@ under a call demand of arity 2 has a *lower* depth of 1.--So: Demand types are elicited by putting an expression under an incoming (call)-demand, the arity of which can be lower or higher than the depth of the-resulting demand type.-In contrast, a demand signature summarises a function's semantics *without*-immediately specifying the incoming demand it was produced under. Despite StrSig-being a newtype wrapper around DmdType, it actually encodes two things:--  * The threshold (i.e., minimum arity) to unleash the signature-  * A demand type that is sound to unleash when the minimum arity requirement is-    met.--Here comes the subtle part: The threshold is encoded in the wrapped demand-type's depth! So in mkStrictSigForArity we make sure to trim the list of-argument demands to the given threshold arity. Call sites will make sure that-this corresponds to the arity of the call demand that elicited the wrapped-demand type. See also Note [What are demand signatures?].--}---- | The depth of the wrapped 'DmdType' encodes the arity at which it is safe--- to unleash. Better construct this through 'mkStrictSigForArity'.--- See Note [Understanding DmdType and StrictSig]-newtype StrictSig-  = StrictSig DmdType-  deriving Eq---- | Turns a 'DmdType' computed for the particular 'Arity' into a 'StrictSig'--- unleashable at that arity. See Note [Understanding DmdType and StrictSig]-mkStrictSigForArity :: Arity -> DmdType -> StrictSig-mkStrictSigForArity arity dmd_ty@(DmdType fvs args div)-  | arity < dmdTypeDepth dmd_ty = StrictSig (DmdType fvs (take arity args) div)-  | otherwise                   = StrictSig (etaExpandDmdType arity dmd_ty)--mkClosedStrictSig :: [Demand] -> Divergence -> StrictSig-mkClosedStrictSig ds res = mkStrictSigForArity (length ds) (DmdType emptyDmdEnv ds res)--splitStrictSig :: StrictSig -> ([Demand], Divergence)-splitStrictSig (StrictSig (DmdType _ dmds res)) = (dmds, res)--strictSigDmdEnv :: StrictSig -> DmdEnv-strictSigDmdEnv (StrictSig (DmdType env _ _)) = env--hasDemandEnvSig :: StrictSig -> Bool-hasDemandEnvSig = not . isEmptyVarEnv . strictSigDmdEnv--botSig :: StrictSig-botSig = StrictSig botDmdType--nopSig :: StrictSig-nopSig = StrictSig nopDmdType--isTopSig :: StrictSig -> Bool-isTopSig (StrictSig ty) = isTopDmdType ty---- | True if the signature diverges or throws an exception in a saturated call.--- See Note [Dead ends].-isDeadEndSig :: StrictSig -> Bool-isDeadEndSig (StrictSig (DmdType _ _ res)) = isDeadEndDiv res---- | Returns true if an application to n value args would diverge or throw an--- exception.------ If a function having 'botDiv' is applied to a less number of arguments than--- its syntactic arity, we cannot say for sure that it is going to diverge.--- Hence this function conservatively returns False in that case.--- See Note [Dead ends].-isDeadEndAppSig :: StrictSig -> Int -> Bool-isDeadEndAppSig (StrictSig (DmdType _ ds res)) n-  = isDeadEndDiv res && not (lengthExceeds ds n)--prependArgsStrictSig :: Int -> StrictSig -> StrictSig--- ^ Add extra ('topDmd') arguments to a strictness signature.--- In contrast to 'etaConvertStrictSig', this /prepends/ additional argument--- demands. This is used by FloatOut.-prependArgsStrictSig new_args sig@(StrictSig dmd_ty@(DmdType env dmds res))-  | new_args == 0       = sig-  | isTopDmdType dmd_ty = sig-  | new_args < 0        = pprPanic "prependArgsStrictSig: negative new_args"-                                   (ppr new_args $$ ppr sig)-  | otherwise           = StrictSig (DmdType env dmds' res)-  where-    dmds' = replicate new_args topDmd ++ dmds--etaConvertStrictSig :: Arity -> StrictSig -> StrictSig--- ^ We are expanding (\x y. e) to (\x y z. e z) or reducing from the latter to--- the former (when the Simplifier identifies a new join points, for example).--- In contrast to 'prependArgsStrictSig', this /appends/ extra arg demands if--- necessary.--- This works by looking at the 'DmdType' (which was produced under a call--- demand for the old arity) and trying to transfer as many facts as we can to--- the call demand of new arity.--- An arity increase (resulting in a stronger incoming demand) can retain much--- of the info, while an arity decrease (a weakening of the incoming demand)--- must fall back to a conservative default.-etaConvertStrictSig arity (StrictSig dmd_ty)-  | arity < dmdTypeDepth dmd_ty = StrictSig $ decreaseArityDmdType dmd_ty-  | otherwise                   = StrictSig $ etaExpandDmdType arity dmd_ty--{--************************************************************************-*                                                                      *-                     Demand transformers-*                                                                      *-************************************************************************--}---- | A /demand transformer/ is a monotone function from an incoming evaluation--- context ('SubDemand') to a 'DmdType', describing how the denoted thing--- (i.e. expression, function) uses its arguments and free variables, and--- whether it diverges.------ See Note [Understanding DmdType and StrictSig]--- and Note [What are demand signatures?].-type DmdTransformer = SubDemand -> DmdType---- | Extrapolate a demand signature ('StrictSig') into a 'DmdTransformer'.------ Given a function's 'StrictSig' and a 'SubDemand' for the evaluation context,--- return how the function evaluates its free variables and arguments.-dmdTransformSig :: StrictSig -> DmdTransformer-dmdTransformSig (StrictSig dmd_ty@(DmdType _ arg_ds _)) sd-  = multDmdType (peelManyCalls (length arg_ds) sd) dmd_ty-    -- see Note [Demands from unsaturated function calls]-    -- and Note [What are demand signatures?]---- | A special 'DmdTransformer' for data constructors that feeds product--- demands into the constructor arguments.-dmdTransformDataConSig :: Arity -> DmdTransformer-dmdTransformDataConSig arity sd = case go arity sd of-  Just dmds -> DmdType emptyDmdEnv dmds topDiv-  Nothing   -> nopDmdType -- Not saturated-  where-    go 0 sd                            = viewProd arity sd-    go n (viewCall -> Just (C_11, sd)) = go (n-1) sd  -- strict calls only!-    go _ _                             = Nothing---- | A special 'DmdTransformer' for dictionary selectors that feeds the demand--- on the result into the indicated dictionary component (if saturated).-dmdTransformDictSelSig :: StrictSig -> DmdTransformer--- NB: This currently doesn't handle newtype dictionaries and it's unclear how--- it could without additional parameters.-dmdTransformDictSelSig (StrictSig (DmdType _ [(_ :* sig_sd)] _)) call_sd-   | (n, sd') <- peelCallDmd call_sd-   , Prod sig_ds  <- sig_sd-   = multDmdType n $-     DmdType emptyDmdEnv [C_11 :* Prod (map (enhance sd') sig_ds)] topDiv-   | otherwise-   = nopDmdType -- See Note [Demand transformer for a dictionary selector]-  where-    enhance sd old | isAbsDmd old = old-                   | otherwise    = C_11 :* sd  -- This is the one!--dmdTransformDictSelSig sig sd = pprPanic "dmdTransformDictSelSig: no args" (ppr sig $$ ppr sd)--{--Note [What are demand signatures?]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Demand analysis interprets expressions in the abstract domain of demand-transformers. Given a (sub-)demand that denotes the evaluation context, the-abstract transformer of an expression gives us back a demand type denoting-how other things (like arguments and free vars) were used when the expression-was evaluated. Here's an example:--  f x y =-    if x + expensive-      then \z -> z + y * ...-      else \z -> z * ...--The abstract transformer (let's call it F_e) of the if expression (let's-call it e) would transform an incoming (undersaturated!) head demand 1A into-a demand type like {x-><1L>,y-><L>}<L>. In pictures:--     Demand ---F_e---> DmdType-     <1A>              {x-><1L>,y-><L>}<L>--Let's assume that the demand transformers we compute for an expression are-correct wrt. to some concrete semantics for Core. How do demand signatures fit-in? They are strange beasts, given that they come with strict rules when to-it's sound to unleash them.--Fortunately, we can formalise the rules with Galois connections. Consider-f's strictness signature, {}<1L><L>. It's a single-point approximation of-the actual abstract transformer of f's RHS for arity 2. So, what happens is that-we abstract *once more* from the abstract domain we already are in, replacing-the incoming Demand by a simple lattice with two elements denoting incoming-arity: A_2 = {<2, >=2} (where '<2' is the top element and >=2 the bottom-element). Here's the diagram:--     A_2 -----f_f----> DmdType-      ^                   |-      | α               γ |-      |                   v-  SubDemand --F_f----> DmdType--With-  α(C1(C1(_))) = >=2-  α(_)         =  <2-  γ(ty)        =  ty-and F_f being the abstract transformer of f's RHS and f_f being the abstracted-abstract transformer computable from our demand signature simply by--  f_f(>=2) = {}<1L><L>-  f_f(<2)  = multDmdType C_0N {}<1L><L>--where multDmdType makes a proper top element out of the given demand type.--In practice, the A_n domain is not just a simple Bool, but a Card, which is-exactly the Card with which we have to multDmdType. The Card for arity n-is computed by calling @peelManyCalls n@, which corresponds to α above.--Note [Demand transformer for a dictionary selector]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If we evaluate (op dict-expr) under demand 'd', then we can push the demand 'd'-into the appropriate field of the dictionary. What *is* the appropriate field?-We just look at the strictness signature of the class op, which will be-something like: P(AAA1AAAAA).  Then replace the '1' by the demand 'd'.--For single-method classes, which are represented by newtypes the signature-of 'op' won't look like P(...), so matching on Prod will fail.-That's fine: if we are doing strictness analysis we are also doing inlining,-so we'll have inlined 'op' into a cast.  So we can bale out in a conservative-way, returning nopDmdType.--It is (just.. #8329) possible to be running strictness analysis *without*-having inlined class ops from single-method classes.  Suppose you are using-ghc --make; and the first module has a local -O0 flag.  So you may load a class-without interface pragmas, ie (currently) without an unfolding for the class-ops.   Now if a subsequent module in the --make sweep has a local -O flag-you might do strictness analysis, but there is no inlining for the class op.-This is weird, so I'm not worried about whether this optimises brilliantly; but-it should not fall over.--}---- | Remove the demand environment from the signature.-zapDmdEnvSig :: StrictSig -> StrictSig-zapDmdEnvSig (StrictSig (DmdType _ ds r)) = mkClosedStrictSig ds r--zapUsageDemand :: Demand -> Demand--- Remove the usage info, but not the strictness info, from the demand-zapUsageDemand = kill_usage $ KillFlags-    { kf_abs         = True-    , kf_used_once   = True-    , kf_called_once = True-    }---- | Remove all `C_01 :*` info (but not `CM` sub-demands) from the demand-zapUsedOnceDemand :: Demand -> Demand-zapUsedOnceDemand = kill_usage $ KillFlags-    { kf_abs         = False-    , kf_used_once   = True-    , kf_called_once = False-    }---- | Remove all `C_01 :*` info (but not `CM` sub-demands) from the strictness---   signature-zapUsedOnceSig :: StrictSig -> StrictSig-zapUsedOnceSig (StrictSig (DmdType env ds r))-    = StrictSig (DmdType env (map zapUsedOnceDemand ds) r)--data KillFlags = KillFlags-    { kf_abs         :: Bool-    , kf_used_once   :: Bool-    , kf_called_once :: Bool-    }--kill_usage_card :: KillFlags -> Card -> Card-kill_usage_card kfs C_00 | kf_abs kfs       = C_0N-kill_usage_card kfs C_10 | kf_abs kfs       = C_1N-kill_usage_card kfs C_01 | kf_used_once kfs = C_0N-kill_usage_card kfs C_11 | kf_used_once kfs = C_1N-kill_usage_card _   n                       = n--kill_usage :: KillFlags -> Demand -> Demand-kill_usage kfs (n :* sd) = kill_usage_card kfs n :* kill_usage_sd kfs sd--kill_usage_sd :: KillFlags -> SubDemand -> SubDemand-kill_usage_sd kfs (Call n sd)-  | kf_called_once kfs      = mkCall (lubCard C_1N n) (kill_usage_sd kfs sd)-  | otherwise               = mkCall n                (kill_usage_sd kfs sd)-kill_usage_sd kfs (Prod ds) = Prod (map (kill_usage kfs) ds)-kill_usage_sd _   sd        = sd--{- *********************************************************************-*                                                                      *-               TypeShape and demand trimming-*                                                                      *-********************************************************************* -}---data TypeShape -- See Note [Trimming a demand to a type]-               --     in GHC.Core.Opt.DmdAnal-  = TsFun TypeShape-  | TsProd [TypeShape]-  | TsUnk--trimToType :: Demand -> TypeShape -> Demand--- See Note [Trimming a demand to a type] in GHC.Core.Opt.DmdAnal-trimToType (n :* sd) ts-  = n :* go sd ts-  where-    go (Prod ds)   (TsProd tss)-      | equalLength ds tss    = Prod (zipWith trimToType ds tss)-    go (Call n sd) (TsFun ts) = mkCall n (go sd ts)-    go sd@Poly{}   _          = sd-    go _           _          = topSubDmd--{--************************************************************************-*                                                                      *-                     'seq'ing demands-*                                                                      *-************************************************************************--}--seqDemand :: Demand -> ()-seqDemand (_ :* sd) = seqSubDemand sd--seqSubDemand :: SubDemand -> ()-seqSubDemand (Prod ds)   = seqDemandList ds-seqSubDemand (Call _ sd) = seqSubDemand sd-seqSubDemand (Poly _)    = ()--seqDemandList :: [Demand] -> ()-seqDemandList = foldr (seq . seqDemand) ()--seqDmdType :: DmdType -> ()-seqDmdType (DmdType env ds res) =-  seqDmdEnv env `seq` seqDemandList ds `seq` res `seq` ()--seqDmdEnv :: DmdEnv -> ()-seqDmdEnv env = seqEltsUFM seqDemandList env--seqStrictSig :: StrictSig -> ()-seqStrictSig (StrictSig ty) = seqDmdType ty--{--************************************************************************-*                                                                      *-                     Outputable and Binary instances-*                                                                      *-************************************************************************--}--{- Note [Demand notation]-~~~~~~~~~~~~~~~~~~~~~~~~~-This Note should be kept up to date with the documentation of `-fstrictness`-in the user's guide.--For pretty-printing demands, we use quite a compact notation with some-abbreviations. Here's the BNF:--  card ::= B    {}-        |  A    {0}-        |  M    {0,1}-        |  L    {0,1,n}-        |  1    {1}-        |  S    {1,n}--  d    ::= card sd                  The :* constructor, just juxtaposition-        |  card                     abbreviation: Same as "card card",-                                                  in code @polyDmd card@--  sd   ::= card                     @Poly card@-        |  P(d,d,..)                @Prod [d1,d2,..]@-        |  Ccard(sd)                @Call card sd@--So, L can denote a 'Card', polymorphic 'SubDemand' or polymorphic 'Demand',-but it's always clear from context which "overload" is meant. It's like-return-type inference of e.g. 'read'.--Examples are in the haddock for 'Demand'.--This is the syntax for demand signatures:--  div ::= <empty>      topDiv-       |  x            exnDiv-       |  b            botDiv--  sig ::= {x->dx,y->dy,z->dz...}<d1><d2><d3>...<dn>div-                  ^              ^   ^   ^      ^   ^-                  |              |   |   |      |   |-                  |              \---+---+------/   |-                  |                  |              |-             demand on free        demand on      divergence-               variables           arguments      information-           (omitted if empty)                     (omitted if-                                                no information)----}---- | See Note [Demand notation]--- Current syntax was discussed in #19016.-instance Outputable Card where-  ppr C_00 = char 'A' -- "Absent"-  ppr C_01 = char 'M' -- "Maybe"-  ppr C_0N = char 'L' -- "Lazy"-  ppr C_11 = char '1' -- "exactly 1"-  ppr C_1N = char 'S' -- "Strict"-  ppr C_10 = char 'B' -- "Bottom"---- | See Note [Demand notation]-instance Outputable Demand where-  ppr dmd@(n :* sd)-    | isAbs n          = ppr n   -- If absent, sd is arbitrary-    | dmd == polyDmd n = ppr n   -- Print UU as just U-    | otherwise        = ppr n <> ppr sd---- | See Note [Demand notation]-instance Outputable SubDemand where-  ppr (Poly sd)   = ppr sd-  ppr (Call n sd) = char 'C' <> ppr n <> parens (ppr sd)-  ppr (Prod ds)   = char 'P' <> parens (fields ds)-    where-      fields []     = empty-      fields [x]    = ppr x-      fields (x:xs) = ppr x <> char ',' <> fields xs--instance Outputable Divergence where-  ppr Diverges = char 'b' -- for (b)ottom-  ppr ExnOrDiv = char 'x' -- for e(x)ception-  ppr Dunno    = empty--instance Outputable DmdType where-  ppr (DmdType fv ds res)-    = hsep [hcat (map (angleBrackets . ppr) ds) <> ppr res,-            if null fv_elts then empty-            else braces (fsep (map pp_elt fv_elts))]-    where-      pp_elt (uniq, dmd) = ppr uniq <> text "->" <> ppr dmd-      fv_elts = nonDetUFMToList fv-        -- It's OK to use nonDetUFMToList here because we only do it for-        -- pretty printing--instance Outputable StrictSig where-   ppr (StrictSig ty) = ppr ty--instance Outputable TypeShape where-  ppr TsUnk        = text "TsUnk"-  ppr (TsFun ts)   = text "TsFun" <> parens (ppr ts)-  ppr (TsProd tss) = parens (hsep $ punctuate comma $ map ppr tss)--instance Binary Card where-  put_ bh C_00 = putByte bh 0-  put_ bh C_01 = putByte bh 1-  put_ bh C_0N = putByte bh 2-  put_ bh C_11 = putByte bh 3-  put_ bh C_1N = putByte bh 4-  put_ bh C_10 = putByte bh 5-  get bh = do-    h <- getByte bh-    case h of-      0 -> return C_00-      1 -> return C_01-      2 -> return C_0N-      3 -> return C_11-      4 -> return C_1N-      5 -> return C_10-      _ -> pprPanic "Binary:Card" (ppr (fromIntegral h :: Int))--instance Binary Demand where-  put_ bh (n :* sd) = put_ bh n *> put_ bh sd-  get bh = (:*) <$> get bh <*> get bh--instance Binary SubDemand where-  put_ bh (Poly sd)   = putByte bh 0 *> put_ bh sd-  put_ bh (Call n sd) = putByte bh 1 *> put_ bh n *> put_ bh sd-  put_ bh (Prod ds)   = putByte bh 2 *> put_ bh ds-  get bh = do-    h <- getByte bh-    case h of-      0 -> Poly <$> get bh-      1 -> mkCall <$> get bh <*> get bh-      2 -> Prod <$> get bh-      _ -> pprPanic "Binary:SubDemand" (ppr (fromIntegral h :: Int))--instance Binary StrictSig where-  put_ bh (StrictSig aa) = put_ bh aa-  get bh = StrictSig <$> get bh+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE BinaryLiterals #-}+{-# LANGUAGE PatternSynonyms #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+-}++-- | A language to express the evaluation context of an expression as a+-- 'Demand' and track how an expression evaluates free variables and arguments+-- in turn as a 'DmdType'.+--+-- Lays out the abstract domain for "GHC.Core.Opt.DmdAnal".+module GHC.Types.Demand (+    -- * Demands+    Boxity(..),+    Card(C_00, C_01, C_0N, C_10, C_11, C_1N), CardNonAbs, CardNonOnce,+    Demand(AbsDmd, BotDmd, (:*)),+    SubDemand(Prod, Poly), mkProd, viewProd,+    -- ** Algebra+    absDmd, topDmd, botDmd, seqDmd, topSubDmd,+    -- *** Least upper bound+    lubCard, lubDmd, lubSubDmd,+    -- *** Plus+    plusCard, plusDmd, plusSubDmd,+    -- *** Multiply+    multCard, multDmd, multSubDmd,+    -- ** Predicates on @Card@inalities and @Demand@s+    isAbs, isUsedOnce, isStrict,+    isAbsDmd, isUsedOnceDmd, isStrUsedDmd, isStrictDmd,+    isTopDmd, isWeakDmd, onlyBoxedArguments,+    -- ** Special demands+    evalDmd,+    -- *** Demands used in PrimOp signatures+    lazyApply1Dmd, lazyApply2Dmd, strictOnceApply1Dmd, strictManyApply1Dmd,+    -- ** Other @Demand@ operations+    oneifyCard, oneifyDmd, strictifyDmd, strictifyDictDmd, lazifyDmd,+    peelCallDmd, peelManyCalls, mkCalledOnceDmd, mkCalledOnceDmds,+    mkWorkerDemand,+    -- ** Extracting one-shot information+    argOneShots, argsOneShots, saturatedByOneShots,+    -- ** Manipulating Boxity of a Demand+    unboxDeeplyDmd,++    -- * Demand environments+    DmdEnv, emptyDmdEnv,+    keepAliveDmdEnv, reuseEnv,++    -- * Divergence+    Divergence(..), topDiv, botDiv, exnDiv, lubDivergence, isDeadEndDiv,++    -- * Demand types+    DmdType(..), dmdTypeDepth,+    -- ** Algebra+    nopDmdType, botDmdType,+    lubDmdType, plusDmdType, multDmdType,+    -- *** PlusDmdArg+    PlusDmdArg, mkPlusDmdArg, toPlusDmdArg,+    -- ** Other operations+    peelFV, findIdDemand, addDemand, splitDmdTy, deferAfterPreciseException,+    keepAliveDmdType,++    -- * Demand signatures+    DmdSig(..), mkDmdSigForArity, mkClosedDmdSig,+    splitDmdSig, dmdSigDmdEnv, hasDemandEnvSig,+    nopSig, botSig, isTopSig, isDeadEndSig, isDeadEndAppSig, trimBoxityDmdSig,+    -- ** Handling arity adjustments+    prependArgsDmdSig, etaConvertDmdSig,++    -- * Demand transformers from demand signatures+    DmdTransformer, dmdTransformSig, dmdTransformDataConSig, dmdTransformDictSelSig,++    -- * Trim to a type shape+    TypeShape(..), trimToType, trimBoxity,++    -- * @seq@ing stuff+    seqDemand, seqDemandList, seqDmdType, seqDmdSig,++    -- * Zapping usage information+    zapUsageDemand, zapDmdEnvSig, zapUsedOnceDemand, zapUsedOnceSig+  ) where++import GHC.Prelude++import GHC.Types.Var ( Var, Id )+import GHC.Types.Var.Env+import GHC.Types.Var.Set+import GHC.Types.Unique.FM+import GHC.Types.Basic+import GHC.Data.Maybe   ( orElse )++import GHC.Core.Type    ( Type )+import GHC.Core.TyCon   ( isNewTyCon, isClassTyCon )+import GHC.Core.DataCon ( splitDataProductType_maybe )+import GHC.Core.Multiplicity    ( scaledThing )++import GHC.Utils.Binary+import GHC.Utils.Misc+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Utils.Panic.Plain++import Data.Coerce (coerce)+import Data.Function++import GHC.Utils.Trace+_ = pprTrace -- Tired of commenting out the import all the time++{-+************************************************************************+*                                                                      *+           Boxity: Whether the box of something is used+*                                                                      *+************************************************************************+-}++{- Note [Strictness and Unboxing]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If an argument is used strictly by the function body, we may use use+call-by-value instead of call-by-need for that argument. What's more, we may+unbox an argument that is used strictly, discarding the box at the call site.+This can reduce allocations of the program drastically if the box really isn't+needed in the function body. Here's an example:+```+even :: Int -> Bool+even (I# 0) = True+even (I# 1) = False+even (I# n) = even (I# (n -# 2))+```+All three code paths of 'even' are (a) strict in the argument, and (b)+immediately discard the boxed 'Int'. Now if we have a call site like+`even (I# 42)`, then it would be terrible to allocate the 'I#' box for the+argument only to tear it apart immediately in the body of 'even'! Hence,+worker/wrapper will allocate a wrapper for 'even' that not only uses+call-by-value for the argument (e.g., `case I# 42 of b { $weven b }`), but also+*unboxes* the argument, resulting in+```+even :: Int -> Bool+even (I# n) = $weven n+$weven :: Int# -> Bool+$weven 0 = True+$weven 1 = False+$weven n = $weven (n -# 2)+```+And now the box in `even (I# 42)` will cancel away after inlining the wrapper.++As far as the permission to unbox is concerned, *evaluatedness* of the argument+is the important trait. Unboxing implies eager evaluation of an argument and+we don't want to change the termination properties of the function. One way+to ensure that is to unbox strict arguments only, but strictness is only a+sufficient condition for evaluatedness.+See Note [Unboxing evaluated arguments] in "GHC.Core.Opt.DmdAnal", where+we manage to unbox *strict fields* of unboxed arguments that the function is not+actually strict in, simply by realising that those fields have to be evaluated.++Note [Boxity analysis]+~~~~~~~~~~~~~~~~~~~~~~+Alas, we don't want to unbox *every* strict argument+(as Note [Strictness and Unboxing] might suggest).+Here's an example (from T19871):+```+data Huge = H Bool Bool ... Bool+ann :: Huge -> (Bool, Huge)+ann h@(Huge True _ ... _) = (False, h)+ann h                     = (True,  h)+```+Unboxing 'h' yields+```+$wann :: Bool -> Bool -> ... -> Bool -> (Bool, Huge)+$wann True b2 ... bn = (False, Huge True b2 ... bn)+$wann b1   b2 ... bn = (True,  Huge b1   b2 ... bn)+```+The pair constructor really needs its fields boxed. But '$wann' doesn't get+passed 'h' anymore, only its components! Ergo it has to reallocate the 'Huge'+box, in a process called "reboxing". After w/w, call sites like+`case ... of Just h -> ann h` pay for the allocation of the additional box.+In earlier versions of GHC we simply accepted that reboxing would sometimes+happen, but we found some cases where it made a big difference: #19407, for+example.++We therefore perform a simple syntactic boxity analysis that piggy-backs on+demand analysis in order to determine whether the box of a strict argument is+always discarded in the function body, in which case we can pass it unboxed+without risking regressions such as in 'ann' above. But as soon as one use needs+the box, we want Boxed to win over any Unboxed uses.++The demand signature (cf. Note [Demand notation]) will say whether it uses+its arguments boxed or unboxed. Indeed it does so for every sub-component of+the argument demand. Here's an example:+```+f :: (Int, Int) -> Bool+f (a, b) = even (a + b) -- demand signature: <1!P(1!L,1!L)>+```+The '!' indicates places where we want to unbox, the lack thereof indicates the+box is used by the function. Boxity flags are part of the 'Poly' and 'Prod'+'SubDemand's, see Note [Why Boxity in SubDemand and not in Demand?].+The given demand signature says "Unbox the pair and then nestedly unbox its+two fields". By contrast, the demand signature of 'ann' above would look like+<1P(1L,L,...,L)>, lacking any '!'.++A demand signature like <1P(1!L)> -- Boxed outside but Unboxed in the field --+doesn't make a lot of sense, as we can never unbox the field without unboxing+the containing record. See Note [Finalising boxity for demand signatures] in+"GHC.Core.Opt.DmdAnal" for how we avoid to spread this and other kinds of+misinformed boxities.++Due to various practical reasons, Boxity Analysis is not conservative at times.+Here are reasons for too much optimism:++ * Note [Function body boxity and call sites] is an observation about when it is+   beneficial to unbox a parameter that is returned from a function.+   Note [Unboxed demand on function bodies returning small products] derives+   a heuristic from the former Note, pretending that all call sites of a+   function need returned small products Unboxed.+ * Note [Boxity for bottoming functions] in DmdAnal makes all bottoming+   functions unbox their arguments, incurring reboxing in code paths that will+   diverge anyway. In turn we get more unboxing in hot code paths.++Boxity analysis fixes a number of issues: #19871, #19407, #4267, #16859, #18907, #13331++Note [Function body boxity and call sites]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider (from T5949)+```+f n p = case n of+  0 -> p :: (a, b)+  _ -> f (n-1) p+-- Worker/wrapper split if we decide to unbox:+$wf n x y = case n of+  0 -> (# x, y #)+  _ -> $wf (n-1) x y+f n (x,y) = case $wf n x y of (# r, s #) -> (r,s)+```+When is it better to /not/ to unbox 'p'? That depends on the callers of 'f'!+If all call sites++ 1. Wouldn't need to allocate fresh boxes for 'p', and+ 2. Needed the result pair of 'f' boxed++Only then we'd see an increase in allocation resulting from unboxing. But as+soon as only one of (1) or (2) holds, it really doesn't matter if 'f' unboxes+'p' (and its result, it's important that CPR follows suit). For example+```+res = ... case f m (field t) of (r1,r2) -> ...  -- (1) holds+arg = ... [ f m (x,y) ] ...                     -- (2) holds+```+Because one of the boxes in the call site can cancel away:+```+res = ... case field1 t of (x1,x2) ->+          case field2 t of (y1,y2) ->+          case $wf x1 x2 y1 y2 of (#r1,r2#) -> ...+arg = ... [ case $wf x1 x2 y1 y2 of (#r1,r2#) -> (r1,r2) ] ...+```+And when call sites neither have arg boxes (1) nor need the result boxed (2),+then hesitating to unbox means /more/ allocation in the call site because of the+need for fresh argument boxes.++Summary: If call sites that satisfy both (1) and (2) occur more often than call+sites that satisfy neither condition, then it's best /not/ to unbox 'p'.++Note [Unboxed demand on function bodies returning small products]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Note [Boxity analysis] achieves its biggest wins when we avoid reboxing huge+records. But when we return small products from a function, we often get faster+programs by pretending that the caller unboxes the result. Long version:++Observation: Big record arguments (e.g., DynFlags) tend to be modified much less+             frequently than small records (e.g., Int).+Result:      Big records tend to be passed around boxed (unmodified) much more+             frequently than small records.+Consequnce:  The larger the record, the more likely conditions (1) and (2) from+             Note [Function body boxity and call sites] are met, in which case+             unboxing returned parameters leads to reboxing.++So we put an Unboxed demand on function bodies returning small products and a+Boxed demand on the others. What is regarded a small product is controlled by+the -fdmd-unbox-width flag.++This also manages to unbox functions like+```+sum z      []          = z+sum (I# n) ((I# x):xs) = sum (I# (n +# x)) xs+```+where we can unbox 'z' on the grounds that it's but a small box anyway. That in+turn means that the I# allocation in the recursive call site can cancel away and+we get a non-allocating loop, nice and tight.+Note that this is the typical case in "Observation" above: A small box is+unboxed, modified, the result reboxed for the recursive call.++Originally, this came up in binary-trees' check' function and #4267 which+(similarly) features a strict fold over a tree. We'd also regress in join004 and+join007 if we didn't assume an optimistic Unboxed demand on the function body.+T17932 features a (non-recursive) function that returns a large record, e.g.,+```+flags (Options f x) = <huge> `seq` f+```+and here we won't unbox 'f' because it has 5 fields (which is larger than the+default -fdmd-unbox-width threshold).++Why not focus on putting Unboxed demands on *all recursive* function?+Then we'd unbox+```+flags 0 (Options f x) = <huge> `seq` f+flags n o             = flags (n-1) o+```+and that seems hardly useful.+(NB: Similar to 'f' from Note [Preserving Boxity of results is rarely a win],+but there we only had 2 fields.)++What about the Boxity of *fields* of a small, returned box? Consider+```+sumIO :: Int -> Int -> IO Int+sumIO 0 !z = return z     -- What DmdAnal sees: sumIO 0 z s = z `seq` (# s, z #)+sumIO n !z = sumIO (n-1) (z+n)+```+We really want 'z' to unbox here. Yet its use in the returned unboxed pair+is fundamentally a Boxed one! CPR would manage to unbox it, but DmdAnal runs+before that. There is an Unboxed use in the recursive call to 'go' though.+But 'IO Int' returns a small product, and 'Int' is a small product itself.+So we'll put the RHS of 'sumIO' under sub-demand '!P(L,L!P(L))', indicating that+*if* we evaluate 'z', we don't need the box later on. And indeed the bang will+evaluate `z`, so we conclude with a total demand of `1!P(L)` on `z` and unbox+it.++Unlike for recursive functions, where we can often speed up the loop by+unboxing at the cost of a bit of reboxing in the base case, the wins for+non-recursive functions quickly turn into losses when unboxing too deeply.+That happens in T11545, T18109 and T18174. Therefore, we deeply unbox recursive+function bodies but only shallowly unbox non-recursive function bodies (governed+by the max_depth variable).++The implementation is in 'GHC.Core.Opt.DmdAnal.unboxWhenSmall'. It is quite+vital, guarding for regressions in test cases like #2387, #3586, #16040, #5075+and #19871.++Note that this is fundamentally working around a phase problem, namely that the+results of boxity analysis depend on CPR analysis (and vice versa, of course).++Note [unboxedWins]+~~~~~~~~~~~~~~~~~~+We used to use '_unboxedWins' below in 'lubBoxity', which was too optimistic.++While it worked around some shortcomings of the phase separation between Boxity+analysis and CPR analysis, it was a gross hack which caused regressions itself+that needed all kinds of fixes and workarounds. Examples (from #21119):++  * As #20767 says, L and B were no longer top and bottom of our lattice+  * In #20746 we unboxed huge Handle types that were never needed boxed in the+    first place. See Note [deferAfterPreciseException].+  * It also caused unboxing of huge records where we better shouldn't, for+    example in T19871.absent.+  * It became impossible to work with when implementing !7599, mostly due to the+    chaos that results from #20767.++Conclusion: We should use 'boxedWins' in 'lubBoxity', #21119.+Fortunately, we could come up with a number of better mechanisms to make up for+the sometimes huge regressions that would have otherwise incured:++1. A beefed up Note [Unboxed demand on function bodies returning small products]+   that works recursively fixes most regressions. It's a bit unsound, but+   pretty well-behaved.+2. We saw bottoming functions spoil boxity in some less severe cases and+   countered that with Note [Boxity for bottoming functions].++-}++boxedWins :: Boxity -> Boxity -> Boxity+boxedWins Unboxed Unboxed = Unboxed+boxedWins _       !_      = Boxed++_unboxedWins :: Boxity -> Boxity -> Boxity+-- See Note [unboxedWins]+_unboxedWins Boxed Boxed = Boxed+_unboxedWins _     !_    = Unboxed++lubBoxity :: Boxity -> Boxity -> Boxity+-- See Note [Boxity analysis] for the lattice.+lubBoxity = boxedWins++plusBoxity :: Boxity -> Boxity -> Boxity+plusBoxity = boxedWins++{-+************************************************************************+*                                                                      *+           Card: Combining Strictness and Usage+*                                                                      *+************************************************************************+-}++{- Note [Evaluation cardinalities]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The demand analyser uses an (abstraction of) /evaluation cardinality/ of type+Card, to specify how many times a term is evaluated. A Card C_lu+represents an /interval/ of possible cardinalities [l..u], meaning++* Evaluated /at least/ 'l' times (strictness).+  Hence 'l' is either 0 (lazy)+                   or 1 (strict)++* Evaluated /at most/ 'u' times (usage).+  Hence 'u' is either 0 (not used at all),+                   or 1 (used at most once)+                   or n (no information)++Intervals describe sets, so the underlying lattice is the powerset lattice.++Usually l<=u, but we also have C_10, the interval [1,0], the empty interval,+denoting the empty set.   This is the bottom element of the lattice.++See Note [Demand notation] for the notation we use for each of the constructors.++Note [Bit vector representation for Card]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+While the 6 inhabitants of Card admit an efficient representation as an+enumeration, implementing operations such as lubCard, plusCard and multCard+leads to unreasonably bloated code. This was the old defn for lubCard, for+example:++  -- Handle C_10 (bot)+  lubCard C_10 n    = n    -- bot+  lubCard n    C_10 = n    -- bot+  -- Handle C_0N (top)+  lubCard C_0N _    = C_0N -- top+  lubCard _    C_0N = C_0N -- top+  -- Handle C_11+  lubCard C_00 C_11 = C_01 -- {0} ∪ {1} = {0,1}+  lubCard C_11 C_00 = C_01 -- {0} ∪ {1} = {0,1}+  lubCard C_11 n    = n    -- {1} is a subset of all other intervals+  lubCard n    C_11 = n    -- {1} is a subset of all other intervals+  -- Handle C_1N+  lubCard C_1N C_1N = C_1N -- reflexivity+  lubCard _    C_1N = C_0N -- {0} ∪ {1,n} = top+  lubCard C_1N _    = C_0N -- {0} ∪ {1,n} = top+  -- Handle C_01+  lubCard C_01 _    = C_01 -- {0} ∪ {0,1} = {0,1}+  lubCard _    C_01 = C_01 -- {0} ∪ {0,1} = {0,1}+  -- Handle C_00+  lubCard C_00 C_00 = C_00 -- reflexivity++There's a much more compact way to encode these operations if Card is+represented not as distinctly denoted intervals, but as the subset of the set+of all cardinalities {0,1,n} instead. We represent such a subset as a bit vector+of length 3 (which fits in an Int). That's actually pretty common for such+powerset lattices.+There's one bit per denoted cardinality that is set iff that cardinality is part+of the denoted set, with n being the most significand bit (index 2) and 0 being+represented by the least significand bit (index 0).++How does that help? Well, for one, lubCard just becomes++  lubCard (Card a) (Card b) = Card (a .|. b)++The other operations, 'plusCard' and 'multCard', become significantly more+tricky, but immensely more compact. It's all straight-line code with a few bit+twiddling instructions now!++Note [Algebraic specification for plusCard and multCard]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The representation change in Note [Bit vector representation for Card] admits+very dense definitions of 'plusCard' and 'multCard' in terms of bit twiddling,+but the connection to the algebraic operations they implement is lost.+It's helpful to have a written specification of what 'plusCard' and 'multCard'+here that says what they should compute.++  * plusCard: a@[l1,u1] + b@[l2,u2] = r@[l1+l2,u1+u2].+      - In terms of sets, 0 ∈ r iff 0 ∈ a and 0 ∈ b.+        Examples: set in C_00 + C_00, C_01 + C_0N, but not in C_10 + C_00+      - In terms of sets, 1 ∈ r iff 1 ∈ a or 1 ∈ b.+        Examples: set in C_01 + C_00, C_0N + C_0N, but not in C_10 + C_00+      - In terms of sets, n ∈ r iff n ∈ a or n ∈ b, or (1 ∈ a and 1 ∈ b),+        so not unlike add with carry.+        Examples: set in C_01 + C_01, C_01 + C_0N, but not in C_10 + C_01+      - Handy special cases:+          o 'plusCard C_10' bumps up the strictness of its argument, just like+            'lubCard C_00' lazifies it, without touching upper bounds.+          o Similarly, 'plusCard C_0N' discards usage information+            (incl. absence) but leaves strictness alone.++  * multCard: a@[l1,u1] * b@[l2,u2] = r@[l1*l2,u1*u2].+      - In terms of sets, 0 ∈ r iff 0 ∈ a or 0 ∈ b.+        Examples: set in C_00 * C_10, C_01 * C_1N, but not in C_10 * C_1N+      - In terms of sets, 1 ∈ r iff 1 ∈ a and 1 ∈ b.+        Examples: set in C_01 * C_01, C_01 * C_1N, but not in C_11 * C_10+      - In terms of sets, n ∈ r iff 1 ∈ r and (n ∈ a or n ∈ b).+        Examples: set in C_1N * C_01, C_1N * C_0N, but not in C_10 * C_1N+      - Handy special cases:+          o 'multCard C_1N c' is the same as 'plusCard c c' and+            drops used-once info. But unlike 'plusCard C_0N', it leaves absence+            and strictness.+          o 'multCard C_01' drops strictness info, like 'lubCard C_00'.+          o 'multCard C_0N' does both; it discards all strictness and used-once+            info and retains only absence info.+-}+++-- | Describes an interval of /evaluation cardinalities/.+-- See Note [Evaluation cardinalities]+-- See Note [Bit vector representation for Card]+newtype Card = Card Int+  deriving Eq++-- | A subtype of 'Card' for which the upper bound is never 0 (no 'C_00' or+-- 'C_10'). The only four inhabitants are 'C_01', 'C_0N', 'C_11', 'C_1N'.+-- Membership can be tested with 'isCardNonAbs'.+-- See 'D' and 'Call' for use sites and explanation.+type CardNonAbs = Card++-- | A subtype of 'Card' for which the upper bound is never 1 (no 'C_01' or+-- 'C_11'). The only four inhabitants are 'C_00', 'C_0N', 'C_10', 'C_1N'.+-- Membership can be tested with 'isCardNonOnce'.+-- See 'Poly' for use sites and explanation.+type CardNonOnce = Card++-- | Absent, {0}. Pretty-printed as A.+pattern C_00 :: Card+pattern C_00 = Card 0b001+-- | Bottom, {}. Pretty-printed as A.+pattern C_10 :: Card+pattern C_10 = Card 0b000+-- | Strict and used once, {1}. Pretty-printed as 1.+pattern C_11 :: Card+pattern C_11 = Card 0b010+-- | Used at most once, {0,1}. Pretty-printed as M.+pattern C_01 :: Card+pattern C_01 = Card 0b011+-- | Strict and used (possibly) many times, {1,n}. Pretty-printed as S.+pattern C_1N :: Card+pattern C_1N = Card 0b110+-- | Every possible cardinality; the top element, {0,1,n}. Pretty-printed as L.+pattern C_0N :: Card+pattern C_0N = Card 0b111++{-# COMPLETE C_00, C_01, C_0N, C_10, C_11, C_1N :: Card #-}++_botCard, topCard :: Card+_botCard = C_10+topCard = C_0N++-- | True <=> lower bound is 1.+isStrict :: Card -> Bool+-- See Note [Bit vector representation for Card]+isStrict (Card c) = c .&. 0b001 == 0 -- simply check 0 bit is not set++-- | True <=> upper bound is 0.+isAbs :: Card -> Bool+-- See Note [Bit vector representation for Card]+isAbs (Card c) = c .&. 0b110 == 0 -- simply check 1 and n bit are not set++-- | True <=> upper bound is 1.+isUsedOnce :: Card -> Bool+-- See Note [Bit vector representation for Card]+isUsedOnce (Card c) = c .&. 0b100 == 0 -- simply check n bit is not set++-- | Is this a 'CardNonAbs'?+isCardNonAbs :: Card -> Bool+isCardNonAbs = not . isAbs++-- | Is this a 'CardNonOnce'?+isCardNonOnce :: Card -> Bool+isCardNonOnce n = isAbs n || not (isUsedOnce n)++-- | Intersect with [0,1].+oneifyCard :: Card -> Card+oneifyCard C_0N = C_01+oneifyCard C_1N = C_11+oneifyCard c    = c++-- | Denotes '∪' on 'Card'.+lubCard :: Card -> Card -> Card+-- See Note [Bit vector representation for Card]+lubCard (Card a) (Card b) = Card (a .|. b) -- main point of the bit-vector encoding!++-- | Denotes '+' on lower and upper bounds of 'Card'.+plusCard :: Card -> Card -> Card+-- See Note [Algebraic specification for plusCard and multCard]+plusCard (Card a) (Card b)+  = Card (bit0 .|. bit1 .|. bitN)+  where+    bit0 =  (a .&. b)                         .&. 0b001+    bit1 =  (a .|. b)                         .&. 0b010+    bitN = ((a .|. b) .|. shiftL (a .&. b) 1) .&. 0b100++-- | Denotes '*' on lower and upper bounds of 'Card'.+multCard :: Card -> Card -> Card+-- See Note [Algebraic specification for plusCard and multCard]+multCard (Card a) (Card b)+  = Card (bit0 .|. bit1 .|. bitN)+  where+    bit0 = (a .|. b)                   .&. 0b001+    bit1 = (a .&. b)                   .&. 0b010+    bitN = (a .|. b) .&. shiftL bit1 1 .&. 0b100++{-+************************************************************************+*                                                                      *+           Demand: Evaluation contexts+*                                                                      *+************************************************************************+-}++-- | A demand describes a /scaled evaluation context/, e.g. how many times+-- and how deep the denoted thing is evaluated.+--+-- The "how many" component is represented by a 'Card'inality.+-- The "how deep" component is represented by a 'SubDemand'.+-- Examples (using Note [Demand notation]):+--+--   * 'seq' puts demand @1A@ on its first argument: It evaluates the argument+--     strictly (@1@), but not any deeper (@A@).+--   * 'fst' puts demand @1P(1L,A)@ on its argument: It evaluates the argument+--     pair strictly and the first component strictly, but no nested info+--     beyond that (@L@). Its second argument is not used at all.+--   * '$' puts demand @1C1(L)@ on its first argument: It calls (@C@) the+--     argument function with one argument, exactly once (@1@). No info+--     on how the result of that call is evaluated (@L@).+--   * 'maybe' puts demand @MCM(L)@ on its second argument: It evaluates+--     the argument function at most once ((M)aybe) and calls it once when+--     it is evaluated.+--   * @fst p + fst p@ puts demand @SP(SL,A)@ on @p@: It's @1P(1L,A)@+--     multiplied by two, so we get @S@ (used at least once, possibly multiple+--     times).+--+-- This data type is quite similar to @'Scaled' 'SubDemand'@, but it's scaled+-- by 'Card', which is an /interval/ on 'Multiplicity', the upper bound of+-- which could be used to infer uniqueness types. Also we treat 'AbsDmd' and+-- 'BotDmd' specially, as the concept of a 'SubDemand' doesn't apply when there+-- isn't any evaluation at all. If you don't care, simply use '(:*)'.+data Demand+  = BotDmd+  -- ^ A bottoming demand, produced by a diverging function ('C_10'), hence there is no+  -- 'SubDemand' that describes how it was evaluated.++  | AbsDmd+  -- ^ An absent demand: Evaluated exactly 0 times ('C_00'), hence there is no+  -- 'SubDemand' that describes how it was evaluated.++  | D !CardNonAbs !SubDemand+  -- ^ Don't use this internal data constructor; use '(:*)' instead.+  -- Since BotDmd deals with 'C_10' and AbsDmd deals with 'C_00', the+  -- cardinality component is CardNonAbs+  deriving Eq++-- | Only meant to be used in the pattern synonym below!+viewDmdPair :: Demand -> (Card, SubDemand)+viewDmdPair BotDmd   = (C_10, botSubDmd)+viewDmdPair AbsDmd   = (C_00, seqSubDmd)+viewDmdPair (D n sd) = (n, sd)++-- | @c :* sd@ is a demand that says \"evaluated @c@ times, and each time it+-- was evaluated, it was at least as deep as @sd@\".+--+-- Matching on this pattern synonym is a complete match.+-- If the matched demand was 'AbsDmd', it will match as @C_00 :* seqSubDmd@.+-- If the matched demand was 'BotDmd', it will match as @C_10 :* botSubDmd@.+-- The builder of this pattern synonym simply /discards/ the 'SubDemand' if the+-- 'Card' was absent and returns 'AbsDmd' or 'BotDmd' instead. It will assert+-- that the discarded sub-demand was 'seqSubDmd' and 'botSubDmd', respectively.+--+-- Call sites should consider whether they really want to look at the+-- 'SubDemand' of an absent demand and match on 'AbsDmd' and/or 'BotDmd'+-- otherwise. Really, any other 'SubDemand' would be allowed and+-- might work better, depending on context.+pattern (:*) :: HasDebugCallStack => Card -> SubDemand -> Demand+pattern n :* sd <- (viewDmdPair -> (n, sd)) where+  C_10 :* sd = BotDmd & assertPpr (sd == botSubDmd) (text "B /=" <+> ppr sd)+  C_00 :* sd = AbsDmd & assertPpr (sd == seqSubDmd) (text "A /=" <+> ppr sd)+  n    :* sd = D n sd & assertPpr (isCardNonAbs n)  (ppr n $$ ppr sd)+{-# COMPLETE (:*) #-}++-- | A sub-demand describes an /evaluation context/, e.g. how deep the+-- denoted thing is evaluated. See 'Demand' for examples.+--+-- The nested 'SubDemand' @d@ of a 'Call' @Cn(d)@ is /relative/ to a single such call.+-- E.g. The expression @f 1 2 + f 3 4@ puts call demand @SCS(C1(L))@ on @f@:+-- @f@ is called exactly twice (@S@), each time exactly once (@1@) with an+-- additional argument.+--+-- The nested 'Demand's @dn@ of a 'Prod' @P(d1,d2,...)@ apply /absolutely/:+-- If @dn@ is a used once demand (cf. 'isUsedOnce'), then that means that+-- the denoted sub-expression is used once in the entire evaluation context+-- described by the surrounding 'Demand'. E.g., @LP(ML)@ means that the+-- field of the denoted expression is used at most once, although the+-- entire expression might be used many times.+--+-- See Note [Call demands are relative]+-- and Note [Demand notation].+-- See also Note [Why Boxity in SubDemand and not in Demand?].+data SubDemand+  = Poly !Boxity !CardNonOnce+  -- ^ Polymorphic demand, the denoted thing is evaluated arbitrarily deep,+  -- with the specified cardinality at every level. The 'Boxity' applies only+  -- to the outer evaluation context as well as all inner evaluation context.+  -- See Note [Boxity in Poly] for why we want it to carry 'Boxity'.+  -- Expands to 'Call' via 'viewCall' and to 'Prod' via 'viewProd'.+  --+  -- @Poly b n@ is semantically equivalent to @Prod b [n :* Poly b n, ...]+  -- or @Call n (Poly Boxed n)@. 'viewCall' and 'viewProd' do these rewrites.+  --+  -- In Note [Demand notation]: @L  === P(L,L,...)@  and @L  === CL(L)@,+  --                            @B  === P(B,B,...)@  and @B  === CB(B)@,+  --                            @!A === !P(A,A,...)@ and @!A === !CA(A)@,+  --                            and so on.+  --+  -- We'll only see 'Poly' with 'C_10' (B), 'C_00' (A), 'C_0N' (L) and sometimes+  -- 'C_1N' (S) through 'plusSubDmd', never 'C_01' (M) or 'C_11' (1) (grep the+  -- source code). Hence 'CardNonOnce', which is closed under 'lub' and 'plus'.+  | Call !CardNonAbs !SubDemand+  -- ^ @Call n sd@ describes the evaluation context of @n@ function+  -- applications, where every individual result is evaluated according to @sd@.+  -- @sd@ is /relative/ to a single call, see Note [Call demands are relative].+  -- That Note also explains why it doesn't make sense for @n@ to be absent,+  -- hence we forbid it with 'CardNonAbs'. Absent call demands can still be+  -- expressed with 'Poly'.+  -- Used only for values of function type. Use the smart constructor 'mkCall'+  -- whenever possible!+  | Prod !Boxity ![Demand]+  -- ^ @Prod b ds@ describes the evaluation context of a case scrutinisation+  -- on an expression of product type, where the product components are+  -- evaluated according to @ds@. The 'Boxity' @b@ says whether or not the box+  -- of the product was used.++-- | We have to respect Poly rewrites through 'viewCall' and 'viewProd'.+instance Eq SubDemand where+  d1 == d2 = case d1 of+    Prod b1 ds1+      | Just (b2, ds2) <- viewProd (length ds1) d2 -> b1 == b2 && ds1 == ds2+    Call n1 sd1+      | Just (n2, sd2) <- viewCall d2              -> n1 == n2 && sd1 == sd2+    Poly b1 n1+      | Poly b2 n2 <- d2                           -> b1 == b2 && n1 == n2+    _                                              -> False++topSubDmd, botSubDmd, seqSubDmd :: SubDemand+topSubDmd = Poly   Boxed C_0N+botSubDmd = Poly Unboxed C_10+seqSubDmd = Poly Unboxed C_00++-- | The uniform field demand when viewing a 'Poly' as a 'Prod', as in+-- 'viewProd'.+polyFieldDmd :: Boxity -> CardNonOnce -> Demand+polyFieldDmd _     C_00 = AbsDmd+polyFieldDmd _     C_10 = BotDmd+polyFieldDmd Boxed C_0N = topDmd+polyFieldDmd b     n    = n :* Poly b n & assertPpr (isCardNonOnce n) (ppr n)++-- | A smart constructor for 'Prod', applying rewrite rules along the semantic+-- equality @Prod b [n :* Poly Boxed n, ...] === Poly b n@, simplifying to+-- 'Poly' 'SubDemand's when possible. Examples:+--+--   * Rewrites @P(L,L)@ (e.g., arguments @Boxed@, @[L,L]@) to @L@+--   * Rewrites @!P(L!L,L!L)@ (e.g., arguments @Unboxed@, @[L!L,L!L]@) to @!L@+--   * Does not rewrite @P(1L)@, @P(L!L)@, @!P(L)@ or @P(L,A)@+--+mkProd :: Boxity -> [Demand] -> SubDemand+mkProd b ds+  | all (== AbsDmd) ds = Poly b C_00+  | all (== BotDmd) ds = Poly b C_10+  | dmd@(n :* Poly b2 m):_ <- ds+  , n == m           -- don't rewrite P(SL)  to S+  , b == b2          -- don't rewrite P(S!S) to !S+  , all (== dmd) ds  -- don't rewrite P(L,A) to L+  = Poly b n+  | otherwise          = Prod b ds++-- | @viewProd n sd@ interprets @sd@ as a 'Prod' of arity @n@, expanding 'Poly'+-- demands as necessary.+viewProd :: Arity -> SubDemand -> Maybe (Boxity, [Demand])+-- It's quite important that this function is optimised well;+-- it is used by lubSubDmd and plusSubDmd.+viewProd n (Prod b ds)+  | ds `lengthIs` n = Just (b, ds)+-- Note the strict application to replicate: This makes sure we don't allocate+-- a thunk for it, inlines it and lets case-of-case fire at call sites.+viewProd n (Poly b card)+  | let !ds = replicate n $! polyFieldDmd b card+  = Just (b, ds)+viewProd _ _+  = Nothing+{-# INLINE viewProd #-} -- we want to fuse away the replicate and the allocation+                        -- for Arity. Otherwise, #18304 bites us.++-- | A smart constructor for 'Call', applying rewrite rules along the semantic+-- equality @Call n (Poly n) === Poly n@, simplifying to 'Poly' 'SubDemand's+-- when possible.+mkCall :: CardNonAbs -> SubDemand -> SubDemand+mkCall C_1N sd@(Poly Boxed C_1N) = sd+mkCall C_0N sd@(Poly Boxed C_0N) = sd+mkCall n    cd               = assertPpr (isCardNonAbs n) (ppr n $$ ppr cd) $+                               Call n cd++-- | @viewCall sd@ interprets @sd@ as a 'Call', expanding 'Poly' subdemands as+-- necessary.+viewCall :: SubDemand -> Maybe (Card, SubDemand)+viewCall (Call n sd) = Just (n :: Card, sd)+viewCall (Poly _ n)  = Just (n :: Card, Poly Boxed n)+viewCall _           = Nothing++topDmd, absDmd, botDmd, seqDmd :: Demand+topDmd = C_0N :* topSubDmd+absDmd = AbsDmd+botDmd = BotDmd+seqDmd = C_11 :* seqSubDmd++-- | Sets 'Boxity' to 'Unboxed' for non-'Call' sub-demands and recurses into 'Prod'.+unboxDeeplySubDmd :: SubDemand -> SubDemand+unboxDeeplySubDmd (Poly _ n)  = Poly Unboxed n+unboxDeeplySubDmd (Prod _ ds) = mkProd Unboxed (strictMap unboxDeeplyDmd ds)+unboxDeeplySubDmd call@Call{} = call++-- | Sets 'Boxity' to 'Unboxed' for the 'Demand', recursing into 'Prod's.+unboxDeeplyDmd :: Demand -> Demand+unboxDeeplyDmd AbsDmd   = AbsDmd+unboxDeeplyDmd BotDmd   = BotDmd+unboxDeeplyDmd (D n sd) = D n (unboxDeeplySubDmd sd)++-- | Denotes '∪' on 'SubDemand'.+lubSubDmd :: SubDemand -> SubDemand -> SubDemand+-- Handle botSubDmd (just an optimisation, the general case would do the same)+lubSubDmd (Poly Unboxed C_10) d2                  = d2+lubSubDmd d1                  (Poly Unboxed C_10) = d1+-- Handle Prod+lubSubDmd (Prod b1 ds1) (Poly b2 n2)+  | let !d = polyFieldDmd b2 n2+  = mkProd (lubBoxity b1 b2) (strictMap (lubDmd d) ds1)+lubSubDmd (Prod b1 ds1) (Prod b2 ds2)+  | equalLength ds1 ds2+  = mkProd (lubBoxity b1 b2) (strictZipWith lubDmd ds1 ds2)+-- Handle Call+lubSubDmd (Call n1 sd1) sd2@(Poly _ n2)+  -- See Note [Call demands are relative]+  | isAbs n2  = mkCall (lubCard n2 n1) sd1+  | otherwise = mkCall (lubCard n2 n1) (lubSubDmd sd1 sd2)+lubSubDmd (Call n1 d1)  (Call n2 d2)+  | otherwise = mkCall (lubCard n1 n2) (lubSubDmd d1 d2)+-- Handle Poly. Exploit reflexivity (so we'll match the Prod or Call cases again).+lubSubDmd (Poly b1 n1)  (Poly b2 n2) = Poly (lubBoxity b1 b2) (lubCard n1 n2)+lubSubDmd sd1@Poly{}    sd2          = lubSubDmd sd2 sd1+-- Otherwise (Call `lub` Prod) return Top+lubSubDmd _             _            = topSubDmd++-- | Denotes '∪' on 'Demand'.+lubDmd :: Demand -> Demand -> Demand+lubDmd (n1 :* sd1) (n2 :* sd2) = lubCard n1 n2 :* lubSubDmd sd1 sd2++multSubDmd :: Card -> SubDemand -> SubDemand+multSubDmd C_11 sd           = sd+-- The following three equations don't have an impact on Demands, only on+-- Boxity. They are needed so that we don't trigger the assertions in `:*`+-- when called from `multDmd`.+multSubDmd C_00 _            = seqSubDmd -- Otherwise `multSubDmd A L == A /= !A`+multSubDmd C_10 (Poly _ n)   = if isStrict n then botSubDmd else seqSubDmd -- Otherwise `multSubDmd B L == B /= !B`+multSubDmd C_10 (Call n _)   = if isStrict n then botSubDmd else seqSubDmd -- Otherwise we'd call `mkCall` with absent cardinality+multSubDmd n    (Poly b m)   = Poly b (multCard n m)+multSubDmd n    (Call n' sd) = mkCall (multCard n n') sd -- See Note [Call demands are relative]+multSubDmd n    (Prod b ds)  = mkProd b (strictMap (multDmd n) ds)++multDmd :: Card -> Demand -> Demand+-- The first two lines compute the same result as the last line, but won't+-- trigger the assertion in `:*` for input like `multDmd B 1L`, which would call+-- `B :* A`. We want to return `B` in these cases.+multDmd C_10 (n :* _)    = if isStrict n then BotDmd else AbsDmd+multDmd n    (C_10 :* _) = if isStrict n then BotDmd else AbsDmd+multDmd n    (m :* sd)   = multCard n m :* multSubDmd n sd++-- | Denotes '+' on 'SubDemand'.+plusSubDmd :: SubDemand -> SubDemand -> SubDemand+-- Handle seqSubDmd (just an optimisation, the general case would do the same)+plusSubDmd (Poly Unboxed C_00) d2                  = d2+plusSubDmd d1                  (Poly Unboxed C_00) = d1+-- Handle Prod+plusSubDmd (Prod b1 ds1) (Poly b2 n2)+  | let !d = polyFieldDmd b2 n2+  = mkProd (plusBoxity b1 b2) (strictMap (plusDmd d) ds1)+plusSubDmd (Prod b1 ds1) (Prod b2 ds2)+  | equalLength ds1 ds2+  = mkProd (plusBoxity b1 b2) (strictZipWith plusDmd ds1 ds2)+-- Handle Call+plusSubDmd (Call n1 sd1) sd2@(Poly _ n2)+  -- See Note [Call demands are relative]+  | isAbs n2  = mkCall (plusCard n2 n1) sd1+  | otherwise = mkCall (plusCard n2 n1) (lubSubDmd sd1 sd2)+plusSubDmd (Call n1 sd1) (Call n2 sd2)+  | otherwise = mkCall (plusCard n1 n2) (lubSubDmd sd1 sd2)+-- Handle Poly. Exploit reflexivity (so we'll match the Prod or Call cases again).+plusSubDmd (Poly b1 n1) (Poly b2 n2) = Poly (plusBoxity b1 b2) (plusCard n1 n2)+plusSubDmd sd1@Poly{}   sd2          = plusSubDmd sd2 sd1+-- Otherwise (Call `lub` Prod) return Top+plusSubDmd _            _            = topSubDmd++-- | Denotes '+' on 'Demand'.+plusDmd :: Demand -> Demand -> Demand+plusDmd (n1 :* sd1) (n2 :* sd2) = plusCard n1 n2 :* plusSubDmd sd1 sd2++-- | Used to suppress pretty-printing of an uninformative demand+isTopDmd :: Demand -> Bool+isTopDmd dmd = dmd == topDmd++isAbsDmd :: Demand -> Bool+isAbsDmd (n :* _) = isAbs n++-- | Contrast with isStrictUsedDmd. See Note [Strict demands]+isStrictDmd :: Demand -> Bool+isStrictDmd (n :* _) = isStrict n++-- | Not absent and used strictly. See Note [Strict demands]+isStrUsedDmd :: Demand -> Bool+isStrUsedDmd (n :* _) = isStrict n && not (isAbs n)++-- | Is the value used at most once?+isUsedOnceDmd :: Demand -> Bool+isUsedOnceDmd (n :* _) = isUsedOnce n++-- | We try to avoid tracking weak free variable demands in strictness+-- signatures for analysis performance reasons.+-- See Note [Lazy and unleashable free variables] in "GHC.Core.Opt.DmdAnal".+isWeakDmd :: Demand -> Bool+isWeakDmd dmd@(n :* _) = not (isStrict n) && is_plus_idem_dmd dmd+  where+    -- @is_plus_idem_* thing@ checks whether @thing `plus` thing = thing@,+    -- e.g. if @thing@ is idempotent wrt. to @plus@.+    -- is_plus_idem_card n = plusCard n n == n+    is_plus_idem_card = isCardNonOnce+    -- is_plus_idem_dmd dmd = plusDmd dmd dmd == dmd+    is_plus_idem_dmd AbsDmd    = True+    is_plus_idem_dmd BotDmd    = True+    is_plus_idem_dmd (n :* sd) = is_plus_idem_card n && is_plus_idem_sub_dmd sd+    -- is_plus_idem_sub_dmd sd = plusSubDmd sd sd == sd+    is_plus_idem_sub_dmd (Poly _ n)  = assert (isCardNonOnce n) True+    is_plus_idem_sub_dmd (Prod _ ds) = all is_plus_idem_dmd ds+    is_plus_idem_sub_dmd (Call n _)  = is_plus_idem_card n -- See Note [Call demands are relative]++evalDmd :: Demand+evalDmd = C_1N :* topSubDmd++-- | First argument of 'GHC.Exts.maskAsyncExceptions#': @1C1(L)@.+-- Called exactly once.+strictOnceApply1Dmd :: Demand+strictOnceApply1Dmd = C_11 :* mkCall C_11 topSubDmd++-- | First argument of 'GHC.Exts.atomically#': @SCS(L)@.+-- Called at least once, possibly many times.+strictManyApply1Dmd :: Demand+strictManyApply1Dmd = C_1N :* mkCall C_1N topSubDmd++-- | First argument of catch#: @MCM(L)@.+-- Evaluates its arg lazily, but then applies it exactly once to one argument.+lazyApply1Dmd :: Demand+lazyApply1Dmd = C_01 :* mkCall C_01 topSubDmd++-- | Second argument of catch#: @MCM(C1(L))@.+-- Calls its arg lazily, but then applies it exactly once to an additional argument.+lazyApply2Dmd :: Demand+lazyApply2Dmd = C_01 :* mkCall C_01 (mkCall C_11 topSubDmd)++-- | Make a 'Demand' evaluated at-most-once.+oneifyDmd :: Demand -> Demand+oneifyDmd AbsDmd    = AbsDmd+oneifyDmd BotDmd    = BotDmd+oneifyDmd (n :* sd) = oneifyCard n :* sd++-- | Make a 'Demand' evaluated at-least-once (e.g. strict).+strictifyDmd :: Demand -> Demand+strictifyDmd AbsDmd    = seqDmd+strictifyDmd BotDmd    = BotDmd+strictifyDmd (n :* sd) = plusCard C_10 n :* sd++-- | If the argument is a used non-newtype dictionary, give it strict demand.+-- Also split the product type & demand and recur in order to similarly+-- strictify the argument's contained used non-newtype superclass dictionaries.+-- We use the demand as our recursive measure to guarantee termination.+strictifyDictDmd :: Type -> Demand -> Demand+strictifyDictDmd ty (n :* Prod b ds)+  | not (isAbs n)+  , Just field_tys <- as_non_newtype_dict ty+  = C_1N :* mkProd b (zipWith strictifyDictDmd field_tys ds)+      -- main idea: ensure it's strict+  where+    -- Return a TyCon and a list of field types if the given+    -- type is a non-newtype dictionary type+    as_non_newtype_dict ty+      | Just (tycon, _arg_tys, _data_con, map scaledThing -> inst_con_arg_tys)+          <- splitDataProductType_maybe ty+      , not (isNewTyCon tycon)+      , isClassTyCon tycon+      = Just inst_con_arg_tys+      | otherwise+      = Nothing+strictifyDictDmd _  dmd = dmd++-- | Make a 'Demand' lazy, setting all lower bounds (outside 'Call's) to 0.+lazifyDmd :: Demand -> Demand+lazifyDmd AbsDmd    = AbsDmd+lazifyDmd BotDmd    = AbsDmd+lazifyDmd (n :* sd) = multCard C_01 n :* lazifySubDmd sd++-- | Make a 'SubDemand' lazy, setting all lower bounds (outside 'Call's) to 0.+lazifySubDmd :: SubDemand -> SubDemand+lazifySubDmd (Poly b n)  = Poly b (multCard C_01 n)+lazifySubDmd (Prod b sd) = mkProd b (strictMap lazifyDmd sd)+lazifySubDmd (Call n sd) = mkCall (lubCard C_01 n) sd++-- | Wraps the 'SubDemand' with a one-shot call demand: @d@ -> @C1(d)@.+mkCalledOnceDmd :: SubDemand -> SubDemand+mkCalledOnceDmd sd = mkCall C_11 sd++-- | @mkCalledOnceDmds n d@ returns @C1(C1...(C1 d))@ where there are @n@ @C1@'s.+mkCalledOnceDmds :: Arity -> SubDemand -> SubDemand+mkCalledOnceDmds arity sd = iterate mkCalledOnceDmd sd !! arity++-- | Peels one call level from the sub-demand, and also returns how many+-- times we entered the lambda body.+peelCallDmd :: SubDemand -> (Card, SubDemand)+peelCallDmd sd = viewCall sd `orElse` (topCard, topSubDmd)++-- Peels multiple nestings of 'Call' sub-demands and also returns+-- whether it was unsaturated in the form of a 'Card'inality, denoting+-- how many times the lambda body was entered.+-- See Note [Demands from unsaturated function calls].+peelManyCalls :: Int -> SubDemand -> Card+peelManyCalls 0 _                          = C_11+-- See Note [Call demands are relative]+peelManyCalls n (viewCall -> Just (m, sd)) = m `multCard` peelManyCalls (n-1) sd+peelManyCalls _ _                          = C_0N++-- See Note [Demand on the worker] in GHC.Core.Opt.WorkWrap+mkWorkerDemand :: Int -> Demand+mkWorkerDemand n = C_01 :* go n+  where go 0 = topSubDmd+        go n = Call C_01 $ go (n-1)++argsOneShots :: DmdSig -> Arity -> [[OneShotInfo]]+-- ^ See Note [Computing one-shot info]+argsOneShots (DmdSig (DmdType _ arg_ds _)) n_val_args+  | unsaturated_call = []+  | otherwise = go arg_ds+  where+    unsaturated_call = arg_ds `lengthExceeds` n_val_args++    go []               = []+    go (arg_d : arg_ds) = argOneShots arg_d `cons` go arg_ds++    -- Avoid list tail like [ [], [], [] ]+    cons [] [] = []+    cons a  as = a:as++argOneShots :: Demand          -- ^ depending on saturation+            -> [OneShotInfo]+-- ^ See Note [Computing one-shot info]+argOneShots AbsDmd    = [] -- This defn conflicts with 'saturatedByOneShots',+argOneShots BotDmd    = [] -- according to which we should return+                           -- @repeat OneShotLam@ here...+argOneShots (_ :* sd) = go sd -- See Note [Call demands are relative]+  where+    go (Call n sd)+      | isUsedOnce n = OneShotLam    : go sd+      | otherwise    = NoOneShotInfo : go sd+    go _    = []++-- |+-- @saturatedByOneShots n CM(CM(...)) = True@+--   <=>+-- There are at least n nested CM(..) calls.+-- See Note [Demand on the worker] in GHC.Core.Opt.WorkWrap+saturatedByOneShots :: Int -> Demand -> Bool+saturatedByOneShots _ AbsDmd    = True+saturatedByOneShots _ BotDmd    = True+saturatedByOneShots n (_ :* sd) = isUsedOnce (peelManyCalls n sd)++{- Note [Strict demands]+~~~~~~~~~~~~~~~~~~~~~~~~+'isStrUsedDmd' returns true only of demands that are+   both strict+   and  used++In particular, it is False for <B> (i.e. strict and not used,+cardinality C_10), which can and does arise in, say (#7319)+   f x = raise# <some exception>+Then 'x' is not used, so f gets strictness <B> -> .+Now the w/w generates+   fx = let x <B> = absentError "unused"+        in raise <some exception>+At this point we really don't want to convert to+   fx = case absentError "unused" of x -> raise <some exception>+Since the program is going to diverge, this swaps one error for another,+but it's really a bad idea to *ever* evaluate an absent argument.+In #7319 we get+   T7319.exe: Oops!  Entered absent arg w_s1Hd{v} [lid] [base:GHC.Base.String{tc 36u}]++Note [Call demands are relative]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The expression @if b then 0 else f 1 2 + f 3 4@ uses @f@ according to the demand+@LCL(C1(P(L)))@, meaning++  "f is called multiple times or not at all (CL), but each time it+   is called, it's called with *exactly one* (C1) more argument.+   Whenever it is called with two arguments, we have no info on how often+   the field of the product result is used (L)."++So the 'SubDemand' nested in a 'Call' demand is relative to exactly one call.+And that extends to the information we have how its results are used in each+call site. Consider (#18903)++  h :: Int -> Int+  h m =+    let g :: Int -> (Int,Int)+        g 1 = (m, 0)+        g n = (2 * n, 2 `div` n)+        {-# NOINLINE g #-}+    in case m of+      1 -> 0+      2 -> snd (g m)+      _ -> uncurry (+) (g m)++We want to give @g@ the demand @MCM(P(MP(L),1P(L)))@, so we see that in each call+site of @g@, we are strict in the second component of the returned pair.++This relative cardinality leads to an otherwise unexpected call to 'lubSubDmd'+in 'plusSubDmd', but if you do the math it's just the right thing.++There's one more subtlety: Since the nested demand is relative to exactly one+call, in the case where we have *at most zero calls* (e.g. CA(...)), the premise+is hurt and we can assume that the nested demand is 'botSubDmd'. That ensures+that @g@ above actually gets the @1P(L)@ demand on its second pair component,+rather than the lazy @MP(L)@ if we 'lub'bed with an absent demand.++Note [Computing one-shot info]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider a call+    f (\pqr. e1) (\xyz. e2) e3+where f has usage signature+    <CM(CL(CM(L)))><CM(L)><L>+Then argsOneShots returns a [[OneShotInfo]] of+    [[OneShot,NoOneShotInfo,OneShot],  [OneShot]]+The occurrence analyser propagates this one-shot infor to the+binders \pqr and \xyz;+see Note [Use one-shot information] in "GHC.Core.Opt.OccurAnal".++Note [Boxity in Poly]+~~~~~~~~~~~~~~~~~~~~~+To support Note [Boxity analysis], it makes sense that 'Prod' carries a+'Boxity'. But why does 'Poly' have to carry a 'Boxity', too? Shouldn't all+'Poly's be 'Boxed'? Couldn't we simply use 'Prod Unboxed' when we need to+express an unboxing demand?++'botSubDmd' (B) needs to be the bottom of the lattice, so it needs to be an+Unboxed demand (and deeply, at that). Similarly, 'seqSubDmd' (A) is an Unboxed+demand. So why not say that Polys with absent cardinalities have Unboxed boxity?+That doesn't work, because we also need the boxed equivalents. Here's an example+for A (function 'absent' in T19871):+```+f _ True  = 1+f a False = a `seq` 2+  -- demand on a: MA, the A is short for `Poly Boxed C_00`++g a = a `seq` f a True+  -- demand on a: SA, which is `Poly Boxed C_00`++h True  p       = g p -- SA on p (inherited from g)+h False p@(x,y) = x+y -- S!P(1!L,1!L) on p+```+If A is treated as Unboxed, we get reboxing in the call site to 'g'.+So we obviously would need a Boxed variant of A. Rather than introducing a lot+of special cases, we just carry the Boxity in 'Poly'. Plus, we could most likely+find examples like the above for any other cardinality.++Note [Why Boxity in SubDemand and not in Demand?]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In #19871, we started out by storing 'Boxity' in 'SubDemand', in the 'Prod'+constructor only. But then we found that we weren't able to express the unboxing+'seqSubDmd', because that one really is a `Poly C_00` sub-demand.+We then tried to store the Boxity in 'Demand' instead, for these reasons:++  1. The whole boxity-of-seq business comes to a satisfying conclusion+  2. Putting Boxity in the SubDemand is weird to begin with, because it+     describes the box and not its fields, just as the evaluation cardinality+     of a Demand describes how often the box is used. It makes more sense that+     Card and Boxity travel together. Also the alternative would have been to+     store Boxity with Poly, which is even weirder and more redundant.++But then we regressed in T7837 (grep #19871 for boring specifics), which needed+to transfer an ambient unboxed *demand* on a dictionary selector to its argument+dictionary, via a 'Call' sub-demand `C1(sd)`, as+Note [Demand transformer for a dictionary selector] explains. Annoyingly,+the boxity info has to be stored in the *sub-demand* `sd`! There's no demand+to store the boxity in. So we bit the bullet and now we store Boxity in+'SubDemand', both in 'Prod' *and* 'Poly'. See also Note [Boxity in Poly].+-}++{- *********************************************************************+*                                                                      *+                 Divergence: Whether evaluation surely diverges+*                                                                      *+********************************************************************* -}++-- | 'Divergence' characterises whether something surely diverges.+-- Models a subset lattice of the following exhaustive set of divergence+-- results:+--+-- [n] nontermination (e.g. loops)+-- [i] throws imprecise exception+-- [p] throws precise exceTtion+-- [c] converges (reduces to WHNF).+--+-- The different lattice elements correspond to different subsets, indicated by+-- juxtaposition of indicators (e.g. __nc__ definitely doesn't throw an+-- exception, and may or may not reduce to WHNF).+--+-- @+--             Dunno (nipc)+--                  |+--            ExnOrDiv (nip)+--                  |+--            Diverges (ni)+-- @+--+-- As you can see, we don't distinguish __n__ and __i__.+-- See Note [Precise exceptions and strictness analysis] for why __p__ is so+-- special compared to __i__.+data Divergence+  = Diverges -- ^ Definitely throws an imprecise exception or diverges.+  | ExnOrDiv -- ^ Definitely throws a *precise* exception, an imprecise+             --   exception or diverges. Never converges, hence 'isDeadEndDiv'!+             --   See scenario 1 in Note [Precise exceptions and strictness analysis].+  | Dunno    -- ^ Might diverge, throw any kind of exception or converge.+  deriving Eq++lubDivergence :: Divergence -> Divergence -> Divergence+lubDivergence Diverges div      = div+lubDivergence div      Diverges = div+lubDivergence ExnOrDiv ExnOrDiv = ExnOrDiv+lubDivergence _        _        = Dunno+-- This needs to commute with defaultFvDmd, i.e.+-- defaultFvDmd (r1 `lubDivergence` r2) = defaultFvDmd r1 `lubDmd` defaultFvDmd r2+-- (See Note [Default demand on free variables and arguments] for why)++-- | See Note [Asymmetry of 'plus*'], which concludes that 'plusDivergence'+-- needs to be symmetric.+-- Strictly speaking, we should have @plusDivergence Dunno Diverges = ExnOrDiv@.+-- But that regresses in too many places (every infinite loop, basically) to be+-- worth it and is only relevant in higher-order scenarios+-- (e.g. Divergence of @f (throwIO blah)@).+-- So 'plusDivergence' currently is 'glbDivergence', really.+plusDivergence :: Divergence -> Divergence -> Divergence+plusDivergence Dunno    Dunno    = Dunno+plusDivergence Diverges _        = Diverges+plusDivergence _        Diverges = Diverges+plusDivergence _        _        = ExnOrDiv++-- | In a non-strict scenario, we might not force the Divergence, in which case+-- we might converge, hence Dunno.+multDivergence :: Card -> Divergence -> Divergence+multDivergence n _ | not (isStrict n) = Dunno+multDivergence _ d                    = d++topDiv, exnDiv, botDiv :: Divergence+topDiv = Dunno+exnDiv = ExnOrDiv+botDiv = Diverges++-- | True if the 'Divergence' indicates that evaluation will not return.+-- See Note [Dead ends].+isDeadEndDiv :: Divergence -> Bool+isDeadEndDiv Diverges = True+isDeadEndDiv ExnOrDiv = True+isDeadEndDiv Dunno    = False++-- See Notes [Default demand on free variables and arguments]+-- and Scenario 1 in [Precise exceptions and strictness analysis]+defaultFvDmd :: Divergence -> Demand+defaultFvDmd Dunno    = absDmd+defaultFvDmd ExnOrDiv = absDmd -- This is the whole point of ExnOrDiv!+defaultFvDmd Diverges = botDmd -- Diverges++defaultArgDmd :: Divergence -> Demand+-- TopRes and BotRes are polymorphic, so that+--      BotRes === (Bot -> BotRes) === ...+--      TopRes === (Top -> TopRes) === ...+-- This function makes that concrete+-- Also see Note [Default demand on free variables and arguments]+defaultArgDmd Dunno    = topDmd+-- NB: not botDmd! We don't want to mask the precise exception by forcing the+-- argument. But it is still absent.+defaultArgDmd ExnOrDiv = absDmd+defaultArgDmd Diverges = botDmd++{- Note [Precise vs imprecise exceptions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+An exception is considered to be /precise/ when it is thrown by the 'raiseIO#'+primop. It follows that all other primops (such as 'raise#' or+division-by-zero) throw /imprecise/ exceptions. Note that the actual type of+the exception thrown doesn't have any impact!++GHC undertakes some effort not to apply an optimisation that would mask a+/precise/ exception with some other source of nontermination, such as genuine+divergence or an imprecise exception, so that the user can reliably+intercept the precise exception with a catch handler before and after+optimisations.++See also the wiki page on precise exceptions:+https://gitlab.haskell.org/ghc/ghc/wikis/exceptions/precise-exceptions+Section 5 of "Tackling the awkward squad" talks about semantic concerns.+Imprecise exceptions are actually more interesting than precise ones (which are+fairly standard) from the perspective of semantics. See the paper "A Semantics+for Imprecise Exceptions" for more details.++Note [Dead ends]+~~~~~~~~~~~~~~~~+We call an expression that either diverges or throws a precise or imprecise+exception a "dead end". We used to call such an expression just "bottoming",+but with the measures we take to preserve precise exception semantics+(see Note [Precise exceptions and strictness analysis]), that is no longer+accurate: 'exnDiv' is no longer the bottom of the Divergence lattice.++Yet externally to demand analysis, we mostly care about being able to drop dead+code etc., which is all due to the property that such an expression never+returns, hence we consider throwing a precise exception to be a dead end.+See also 'isDeadEndDiv'.++Note [Precise exceptions and strictness analysis]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We have to take care to preserve precise exception semantics in strictness+analysis (#17676). There are two scenarios that need careful treatment.++The fixes were discussed at+https://gitlab.haskell.org/ghc/ghc/wikis/fixing-precise-exceptions++Recall that raiseIO# raises a *precise* exception, in contrast to raise# which+raises an *imprecise* exception. See Note [Precise vs imprecise exceptions].++Scenario 1: Precise exceptions in case alternatives+---------------------------------------------------+Unlike raise# (which returns botDiv), we want raiseIO# to return exnDiv.+Here's why. Consider this example from #13380 (similarly #17676):+  f x y | x>0       = raiseIO# Exc+        | y>0       = return 1+        | otherwise = return 2+Is 'f' strict in 'y'? One might be tempted to say yes! But that plays fast and+loose with the precise exception; after optimisation, (f 42 (error "boom"))+turns from throwing the precise Exc to throwing the imprecise user error+"boom". So, the defaultFvDmd of raiseIO# should be lazy (topDmd), which can be+achieved by giving it divergence exnDiv.+See Note [Default demand on free variables and arguments].++Why don't we just give it topDiv instead of introducing exnDiv?+Because then the simplifier will fail to discard raiseIO#'s continuation in+  case raiseIO# x s of { (# s', r #) -> <BIG> }+which we'd like to optimise to+  case raiseIO# x s of {}+Hence we came up with exnDiv. The default FV demand of exnDiv is lazy (and+its default arg dmd is absent), but otherwise (in terms of 'isDeadEndDiv') it+behaves exactly as botDiv, so that dead code elimination works as expected.+This is tracked by T13380b.++Scenario 2: Precise exceptions in case scrutinees+-------------------------------------------------+Consider (more complete examples in #148, #1592, testcase strun003)++  case foo x s of { (# s', r #) -> y }++Is this strict in 'y'? Often not! If @foo x s@ might throw a precise exception+(ultimately via raiseIO#), then we must not force 'y', which may fail to+terminate or throw an imprecise exception, until we have performed @foo x s@.++So we have to 'deferAfterPreciseException' (which 'lub's with 'exnDmdType' to+model the exceptional control flow) when @foo x s@ may throw a precise+exception. Motivated by T13380{d,e,f}.+See Note [Which scrutinees may throw precise exceptions] in "GHC.Core.Opt.DmdAnal".++We have to be careful not to discard dead-end Divergence from case+alternatives, though (#18086):++  m = putStrLn "foo" >> error "bar"++'m' should still have 'exnDiv', which is why it is not sufficient to lub with+'nopDmdType' (which has 'topDiv') in 'deferAfterPreciseException'.++Historical Note: This used to be called the "IO hack". But that term is rather+a bad fit because+1. It's easily confused with the "State hack", which also affects IO.+2. Neither "IO" nor "hack" is a good description of what goes on here, which+   is deferring strictness results after possibly throwing a precise exception.+   The "hack" is probably not having to defer when we can prove that the+   expression may not throw a precise exception (increasing precision of the+   analysis), but that's just a favourable guess.++Note [Exceptions and strictness]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We used to smart about catching exceptions, but we aren't anymore.+See #14998 for the way it's resolved at the moment.++Here's a historic breakdown:++Apparently, exception handling prim-ops didn't use to have any special+strictness signatures, thus defaulting to nopSig, which assumes they use their+arguments lazily. Joachim was the first to realise that we could provide richer+information. Thus, in 0558911f91c (Dec 13), he added signatures to+primops.txt.pp indicating that functions like `catch#` and `catchRetry#` call+their argument, which is useful information for usage analysis. Still with a+'Lazy' strictness demand (i.e. 'lazyApply1Dmd'), though, and the world was fine.++In 7c0fff4 (July 15), Simon argued that giving `catch#` et al. a+'strictApply1Dmd' leads to substantial performance gains. That was at the cost+of correctness, as #10712 proved. So, back to 'lazyApply1Dmd' in+28638dfe79e (Dec 15).++Motivated to reproduce the gains of 7c0fff4 without the breakage of #10712,+Ben opened #11222. Simon made the demand analyser "understand catch" in+9915b656 (Jan 16) by adding a new 'catchArgDmd', which basically said to call+its argument strictly, but also swallow any thrown exceptions in+'multDivergence'. This was realized by extending the 'Str' constructor of+'ArgStr' with a 'ExnStr' field, indicating that it catches the exception, and+adding a 'ThrowsExn' constructor to the 'Divergence' lattice as an element+between 'Dunno' and 'Diverges'. Then along came #11555 and finally #13330,+so we had to revert to 'lazyApply1Dmd' again in 701256df88c (Mar 17).++This left the other variants like 'catchRetry#' having 'catchArgDmd', which is+where #14998 picked up. Item 1 was concerned with measuring the impact of also+making `catchRetry#` and `catchSTM#` have 'lazyApply1Dmd'. The result was that+there was none. We removed the last usages of 'catchArgDmd' in 00b8ecb7+(Apr 18). There was a lot of dead code resulting from that change, that we+removed in ef6b283 (Jan 19): We got rid of 'ThrowsExn' and 'ExnStr' again and+removed any code that was dealing with the peculiarities.++Where did the speed-ups vanish to? In #14998, item 3 established that+turning 'catch#' strict in its first argument didn't bring back any of the+alleged performance benefits. Item 2 of that ticket finally found out that it+was entirely due to 'catchException's new (since #11555) definition, which+was simply++    catchException !io handler = catch io handler++While 'catchException' is arguably the saner semantics for 'catch', it is an+internal helper function in "GHC.IO". Its use in+"GHC.IO.Handle.Internals.do_operation" made for the huge allocation differences:+Remove the bang and you find the regressions we originally wanted to avoid with+'catchArgDmd'. See also #exceptions_and_strictness# in "GHC.IO".++So history keeps telling us that the only possibly correct strictness annotation+for the first argument of 'catch#' is 'lazyApply1Dmd', because 'catch#' really+is not strict in its argument: Just try this in GHCi++  :set -XScopedTypeVariables+  import Control.Exception+  catch undefined (\(_ :: SomeException) -> putStrLn "you'll see this")++Any analysis that assumes otherwise will be broken in some way or another+(beyond `-fno-pendantic-bottoms`).++But then #13380 and #17676 suggest (in Mar 20) that we need to re-introduce a+subtly different variant of `ThrowsExn` (which we call `ExnOrDiv` now) that is+only used by `raiseIO#` in order to preserve precise exceptions by strictness+analysis, while not impacting the ability to eliminate dead code.+See Note [Precise exceptions and strictness analysis].++Note [Default demand on free variables and arguments]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Free variables not mentioned in the environment of a 'DmdType'+are demanded according to the demand type's Divergence:+  * In a Diverges (botDiv) context, that demand is botDmd+    (strict and absent).+  * In all other contexts, the demand is absDmd (lazy and absent).+This is recorded in 'defaultFvDmd'.++Similarly, we can eta-expand demand types to get demands on excess arguments+not accounted for in the type, by consulting 'defaultArgDmd':+  * In a Diverges (botDiv) context, that demand is again botDmd.+  * In a ExnOrDiv (exnDiv) context, that demand is absDmd: We surely diverge+    before evaluating the excess argument, but don't want to eagerly evaluate+    it (cf. Note [Precise exceptions and strictness analysis]).+  * In a Dunno context (topDiv), the demand is topDmd, because+    it's perfectly possible to enter the additional lambda and evaluate it+    in unforeseen ways (so, not absent).++Note [Bottom CPR iff Dead-Ending Divergence]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Both CPR analysis and Demand analysis handle recursive functions by doing+fixed-point iteration. To find the *least* (e.g., most informative) fixed-point,+iteration starts with the bottom element of the semantic domain. Diverging+functions generally have the bottom element as their least fixed-point.++One might think that CPR analysis and Demand analysis then agree in when a+function gets a bottom denotation. E.g., whenever it has 'botCpr', it should+also have 'botDiv'. But that is not the case, because strictness analysis has to+be careful around precise exceptions, see Note [Precise vs imprecise exceptions].++So Demand analysis gives some diverging functions 'exnDiv' (which is *not* the+bottom element) when the CPR signature says 'botCpr', and that's OK. Here's an+example (from #18086) where that is the case:++ioTest :: IO ()+ioTest = do+  putStrLn "hi"+  undefined++However, one can loosely say that we give a function 'botCpr' whenever its+'Divergence' is 'exnDiv' or 'botDiv', i.e., dead-ending. But that's just+a consequence of fixed-point iteration, it's not important that they agree.++************************************************************************+*                                                                      *+           Demand environments and types+*                                                                      *+************************************************************************+-}++-- Subject to Note [Default demand on free variables and arguments]+type DmdEnv = VarEnv Demand++emptyDmdEnv :: DmdEnv+emptyDmdEnv = emptyVarEnv++multDmdEnv :: Card -> DmdEnv -> DmdEnv+multDmdEnv C_11 env = env+multDmdEnv C_00 _   = emptyDmdEnv+multDmdEnv n    env = mapVarEnv (multDmd n) env++reuseEnv :: DmdEnv -> DmdEnv+reuseEnv = multDmdEnv C_1N++-- | @keepAliveDmdType dt vs@ makes sure that the Ids in @vs@ have+-- /some/ usage in the returned demand types -- they are not Absent.+-- See Note [Absence analysis for stable unfoldings and RULES]+--     in "GHC.Core.Opt.DmdAnal".+keepAliveDmdEnv :: DmdEnv -> IdSet -> DmdEnv+keepAliveDmdEnv env vs+  = nonDetStrictFoldVarSet add env vs+  where+    add :: Id -> DmdEnv -> DmdEnv+    add v env = extendVarEnv_C add_dmd env v topDmd++    add_dmd :: Demand -> Demand -> Demand+    -- If the existing usage is Absent, make it used+    -- Otherwise leave it alone+    add_dmd dmd _ | isAbsDmd dmd = topDmd+                  | otherwise    = dmd++-- | Characterises how an expression+--+--    * Evaluates its free variables ('dt_env')+--    * Evaluates its arguments ('dt_args')+--    * Diverges on every code path or not ('dt_div')+--+-- Equality is defined modulo 'defaultFvDmd's in 'dt_env'.+-- See Note [Demand type Equality].+data DmdType+  = DmdType+  { dt_env  :: !DmdEnv     -- ^ Demand on explicitly-mentioned free variables+  , dt_args :: ![Demand]   -- ^ Demand on arguments+  , dt_div  :: !Divergence -- ^ Whether evaluation diverges.+                          -- See Note [Demand type Divergence]+  }++-- | See Note [Demand type Equality].+instance Eq DmdType where+  (==) (DmdType fv1 ds1 div1)+       (DmdType fv2 ds2 div2) =  div1 == div2 && ds1 == ds2 -- cheap checks first+                              && canonicalise div1 fv1 == canonicalise div2 fv2+       where+         canonicalise div fv = filterUFM (/= defaultFvDmd div) fv++-- | Compute the least upper bound of two 'DmdType's elicited /by the same+-- incoming demand/!+lubDmdType :: DmdType -> DmdType -> DmdType+lubDmdType d1 d2+  = DmdType lub_fv lub_ds lub_div+  where+    n = max (dmdTypeDepth d1) (dmdTypeDepth d2)+    (DmdType fv1 ds1 r1) = etaExpandDmdType n d1+    (DmdType fv2 ds2 r2) = etaExpandDmdType n d2++    -- See Note [Demand type Equality]+    lub_fv  = plusVarEnv_CD lubDmd fv1 (defaultFvDmd r1) fv2 (defaultFvDmd r2)+    lub_ds  = zipWithEqual "lubDmdType" lubDmd ds1 ds2+    lub_div = lubDivergence r1 r2++type PlusDmdArg = (DmdEnv, Divergence)++mkPlusDmdArg :: DmdEnv -> PlusDmdArg+mkPlusDmdArg env = (env, topDiv)++toPlusDmdArg :: DmdType -> PlusDmdArg+toPlusDmdArg (DmdType fv _ r) = (fv, r)++plusDmdType :: DmdType -> PlusDmdArg -> DmdType+plusDmdType (DmdType fv1 ds1 r1) (fv2, t2)+    -- See Note [Asymmetry of 'plus*']+    -- 'plus' takes the argument/result info from its *first* arg,+    -- using its second arg just for its free-var info.+  | isEmptyVarEnv fv2, defaultFvDmd t2 == absDmd+  = DmdType fv1 ds1 (r1 `plusDivergence` t2) -- a very common case that is much more efficient+  | otherwise+  = DmdType (plusVarEnv_CD plusDmd fv1 (defaultFvDmd r1) fv2 (defaultFvDmd t2))+            ds1+            (r1 `plusDivergence` t2)++botDmdType :: DmdType+botDmdType = DmdType emptyDmdEnv [] botDiv++-- | The demand type of doing nothing (lazy, absent, no Divergence+-- information). Note that it is ''not'' the top of the lattice (which would be+-- "may use everything"), so it is (no longer) called topDmdType.+nopDmdType :: DmdType+nopDmdType = DmdType emptyDmdEnv [] topDiv++isTopDmdType :: DmdType -> Bool+isTopDmdType (DmdType env args div)+  = div == topDiv && null args && isEmptyVarEnv env++-- | The demand type of an unspecified expression that is guaranteed to+-- throw a (precise or imprecise) exception or diverge.+exnDmdType :: DmdType+exnDmdType = DmdType emptyDmdEnv [] exnDiv++dmdTypeDepth :: DmdType -> Arity+dmdTypeDepth = length . dt_args++-- | This makes sure we can use the demand type with n arguments after eta+-- expansion, where n must not be lower than the demand types depth.+-- It appends the argument list with the correct 'defaultArgDmd'.+etaExpandDmdType :: Arity -> DmdType -> DmdType+etaExpandDmdType n d@DmdType{dt_args = ds, dt_div = div}+  | n == depth = d+  | n >  depth = d{dt_args = inc_ds}+  | otherwise  = pprPanic "etaExpandDmdType: arity decrease" (ppr n $$ ppr d)+  where depth = length ds+        -- Arity increase:+        --  * Demands on FVs are still valid+        --  * Demands on args also valid, plus we can extend with defaultArgDmd+        --    as appropriate for the given Divergence+        --  * Divergence is still valid:+        --    - A dead end after 2 arguments stays a dead end after 3 arguments+        --    - The remaining case is Dunno, which is already topDiv+        inc_ds = take n (ds ++ repeat (defaultArgDmd div))++-- | A conservative approximation for a given 'DmdType' in case of an arity+-- decrease. Currently, it's just nopDmdType.+decreaseArityDmdType :: DmdType -> DmdType+decreaseArityDmdType _ = nopDmdType++splitDmdTy :: DmdType -> (Demand, DmdType)+-- Split off one function argument+-- We already have a suitable demand on all+-- free vars, so no need to add more!+splitDmdTy ty@DmdType{dt_args=dmd:args} = (dmd, ty{dt_args=args})+splitDmdTy ty@DmdType{dt_div=div}       = (defaultArgDmd div, ty)++multDmdType :: Card -> DmdType -> DmdType+multDmdType n (DmdType fv args res_ty)+  = -- pprTrace "multDmdType" (ppr n $$ ppr fv $$ ppr (multDmdEnv n fv)) $+    DmdType (multDmdEnv n fv)+            (map (multDmd n) args)+            (multDivergence n res_ty)++peelFV :: DmdType -> Var -> (DmdType, Demand)+peelFV (DmdType fv ds res) id = -- pprTrace "rfv" (ppr id <+> ppr dmd $$ ppr fv)+                               (DmdType fv' ds res, dmd)+  where+  -- Force these arguments so that old `Env` is not retained.+  !fv' = fv `delVarEnv` id+  -- See Note [Default demand on free variables and arguments]+  !dmd  = lookupVarEnv fv id `orElse` defaultFvDmd res++addDemand :: Demand -> DmdType -> DmdType+addDemand dmd (DmdType fv ds res) = DmdType fv (dmd:ds) res++findIdDemand :: DmdType -> Var -> Demand+findIdDemand (DmdType fv _ res) id+  = lookupVarEnv fv id `orElse` defaultFvDmd res++-- | When e is evaluated after executing an IO action that may throw a precise+-- exception, we act as if there is an additional control flow path that is+-- taken if e throws a precise exception. The demand type of this control flow+-- path+--   * is lazy and absent ('topDmd') and boxed in all free variables and arguments+--   * has 'exnDiv' 'Divergence' result+-- See Note [Precise exceptions and strictness analysis]+--+-- So we can simply take a variant of 'nopDmdType', 'exnDmdType'.+-- Why not 'nopDmdType'? Because then the result of 'e' can never be 'exnDiv'!+-- That means failure to drop dead-ends, see #18086.+deferAfterPreciseException :: DmdType -> DmdType+deferAfterPreciseException = lubDmdType exnDmdType++-- | See 'keepAliveDmdEnv'.+keepAliveDmdType :: DmdType -> VarSet -> DmdType+keepAliveDmdType (DmdType fvs ds res) vars =+  DmdType (fvs `keepAliveDmdEnv` vars) ds res++{- Note [deferAfterPreciseException]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The big picture is in Note [Precise exceptions and strictness analysis]+The idea is that we want to treat+   case <I/O operation> of (# s', r #) -> rhs++as if it was+   case <I/O operation> of+      Just (# s', r #) -> rhs+      Nothing          -> error++That is, the I/O operation might throw an exception, so that 'rhs' never+gets reached.  For example, we don't want to be strict in the strict free+variables of 'rhs'.++So we have the simple definition+  deferAfterPreciseException = lubDmdType (DmdType emptyDmdEnv [] exnDiv)++Historically, when we had `lubBoxity = _unboxedWins` (see Note [unboxedWins]),+we had a more complicated definition for deferAfterPreciseException to make sure+it preserved boxity in its argument. That was needed for code like+   case <I/O operation> of+      (# s', r) -> f x++which uses `x` *boxed*. If we `lub`bed it with `(DmdType emptyDmdEnv [] exnDiv)`+we'd get an *unboxed* demand on `x` (because we let Unboxed win), which led to+ticket #20746.+Nowadays with `lubBoxity = boxedWins` we don't need the complicated definition.++Note [Demand type Divergence]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In contrast to DmdSigs, DmdTypes are elicited under a specific incoming demand.+This is described in detail in Note [Understanding DmdType and DmdSig].+Here, we'll focus on what that means for a DmdType's Divergence in a higher-order+scenario.++Consider+  err x y = x `seq` y `seq` error (show x)+this has a strictness signature of+  <1L><1L>b+meaning that we don't know what happens when we call err in weaker contexts than+C1(C1(L)), like @err `seq` ()@ (1A) and @err 1 `seq` ()@ (CS(A)). We+may not unleash the botDiv, hence assume topDiv. Of course, in+@err 1 2 `seq` ()@ the incoming demand CS(CS(A)) is strong enough and we see+that the expression diverges.++Now consider a function+  f g = g 1 2+with signature <C1(C1(L))>, and the expression+  f err `seq` ()+now f puts a strictness demand of C1(C1(L)) onto its argument, which is unleashed+on err via the App rule. In contrast to weaker head strictness, this demand is+strong enough to unleash err's signature and hence we see that the whole+expression diverges!++Note [Demand type Equality]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+What is the difference between the DmdType <L>{x->A} and <L>?+Answer: There is none! They have the exact same semantics, because any var that+is not mentioned in 'dt_env' implicitly has demand 'defaultFvDmd', based on+the divergence of the demand type 'dt_div'.+Similarly, <B>b{x->B, y->A} is the same as <B>b{y->A}, because the default FV+demand of BotDiv is B. But neither is equal to <B>b, because y has demand B in+the latter, not A as before.++NB: 'dt_env' technically can't stand for its own, because it doesn't tell us the+demand on FVs that don't appear in the DmdEnv. Hence 'PlusDmdArg' carries along+a 'Divergence', for example.++The Eq instance of DmdType must reflect that, otherwise we can get into monotonicity+issues during fixed-point iteration (<L>{x->A} /= <L> /= <L>{x->A} /= ...).+It does so by filtering out any default FV demands prior to comparing 'dt_env'.+An alternative would be to maintain an invariant that there are no default FV demands+in 'dt_env' to begin with, but that seems more involved to maintain in the current+implementation.++Note that 'lubDmdType' maintains this kind of equality by using 'plusVarEnv_CD',+involving 'defaultFvDmd' for any entries present in one 'dt_env' but not the+other.++Note [Asymmetry of 'plus*']+~~~~~~~~~~~~~~~~~~~~~~~~~~~+'plus' for DmdTypes is *asymmetrical*, because there can only one+be one type contributing argument demands!  For example, given (e1 e2), we get+a DmdType dt1 for e1, use its arg demand to analyse e2 giving dt2, and then do+(dt1 `plusType` dt2). Similarly with+  case e of { p -> rhs }+we get dt_scrut from the scrutinee and dt_rhs from the RHS, and then+compute (dt_rhs `plusType` dt_scrut).++We+ 1. combine the information on the free variables,+ 2. take the demand on arguments from the first argument+ 3. combine the termination results, as in plusDivergence.++Since we don't use argument demands of the second argument anyway, 'plus's+second argument is just a 'PlusDmdType'.++But note that the argument demand types are not guaranteed to be observed in+left to right order. For example, analysis of a case expression will pass the+demand type for the alts as the left argument and the type for the scrutinee as+the right argument. Also, it is not at all clear if there is such an order;+consider the LetUp case, where the RHS might be forced at any point while+evaluating the let body.+Therefore, it is crucial that 'plusDivergence' is symmetric!++Note [Demands from unsaturated function calls]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider a demand transformer d1 -> d2 -> r for f.+If a sufficiently detailed demand is fed into this transformer,+e.g <C1(C1(L))> arising from "f x1 x2" in a strict, use-once context,+then d1 and d2 is precisely the demand unleashed onto x1 and x2 (similar for+the free variable environment) and furthermore the result information r is the+one we want to use.++An anonymous lambda is also an unsaturated function all (needs one argument,+none given), so this applies to that case as well.++But the demand fed into f might be less than C1(C1(L)). Then we have to+'multDmdType' the announced demand type. Examples:+ * Not strict enough, e.g. C1(C1(L)):+   - We have to multiply all argument and free variable demands with C_01,+     zapping strictness.+   - We have to multiply divergence with C_01. If r says that f Diverges for sure,+     then this holds when the demand guarantees that two arguments are going to+     be passed. If the demand is lower, we may just as well converge.+     If we were tracking definite convergence, than that would still hold under+     a weaker demand than expected by the demand transformer.+ * Used more than once, e.g. CS(C1(L)):+   - Multiply with C_1N. Even if f puts a used-once demand on any of its argument+     or free variables, if we call f multiple times, we may evaluate this+     argument or free variable multiple times.++In dmdTransformSig, we call peelManyCalls to find out the 'Card'inality with+which we have to multiply and then call multDmdType with that.++Similarly, dmdTransformDictSelSig and dmdAnal, when analyzing a Lambda, use+peelCallDmd, which peels only one level, but also returns the demand put on the+body of the function.+-}+++{-+************************************************************************+*                                                                      *+                     Demand signatures+*                                                                      *+************************************************************************++In a let-bound Id we record its demand signature.+In principle, this demand signature is a demand transformer, mapping+a demand on the Id into a DmdType, which gives+        a) the free vars of the Id's value+        b) the Id's arguments+        c) an indication of the result of applying+           the Id to its arguments++However, in fact we store in the Id an extremely emascuated demand+transfomer, namely++                a single DmdType+(Nevertheless we dignify DmdSig as a distinct type.)++This DmdType gives the demands unleashed by the Id when it is applied+to as many arguments as are given in by the arg demands in the DmdType.+Also see Note [Demand type Divergence] for the meaning of a Divergence in a+strictness signature.++If an Id is applied to less arguments than its arity, it means that+the demand on the function at a call site is weaker than the vanilla+call demand, used for signature inference. Therefore we place a top+demand on all arguments. Otherwise, the demand is specified by Id's+signature.++For example, the demand transformer described by the demand signature+        DmdSig (DmdType {x -> <1L>} <A><1P(L,L)>)+says that when the function is applied to two arguments, it+unleashes demand 1L on the free var x, A on the first arg,+and 1P(L,L) on the second.++If this same function is applied to one arg, all we can say is that it+uses x with 1L, and its arg with demand 1P(L,L).++Note [Understanding DmdType and DmdSig]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Demand types are sound approximations of an expression's semantics relative to+the incoming demand we put the expression under. Consider the following+expression:++    \x y -> x `seq` (y, 2*x)++Here is a table with demand types resulting from different incoming demands we+put that expression under. Note the monotonicity; a stronger incoming demand+yields a more precise demand type:++    incoming demand   |  demand type+    --------------------------------+    1A                  |  <L><L>{}+    C1(C1(L))           |  <1P(L)><L>{}+    C1(C1(1P(1P(L),A))) |  <1P(A)><A>{}++Note that in the first example, the depth of the demand type was *higher* than+the arity of the incoming call demand due to the anonymous lambda.+The converse is also possible and happens when we unleash demand signatures.+In @f x y@, the incoming call demand on f has arity 2. But if all we have is a+demand signature with depth 1 for @f@ (which we can safely unleash, see below),+the demand type of @f@ under a call demand of arity 2 has a *lower* depth of 1.++So: Demand types are elicited by putting an expression under an incoming (call)+demand, the arity of which can be lower or higher than the depth of the+resulting demand type.+In contrast, a demand signature summarises a function's semantics *without*+immediately specifying the incoming demand it was produced under. Despite StrSig+being a newtype wrapper around DmdType, it actually encodes two things:++  * The threshold (i.e., minimum arity) to unleash the signature+  * A demand type that is sound to unleash when the minimum arity requirement is+    met.++Here comes the subtle part: The threshold is encoded in the wrapped demand+type's depth! So in mkDmdSigForArity we make sure to trim the list of+argument demands to the given threshold arity. Call sites will make sure that+this corresponds to the arity of the call demand that elicited the wrapped+demand type. See also Note [What are demand signatures?].+-}++-- | The depth of the wrapped 'DmdType' encodes the arity at which it is safe+-- to unleash. Better construct this through 'mkDmdSigForArity'.+-- See Note [Understanding DmdType and DmdSig]+newtype DmdSig+  = DmdSig DmdType+  deriving Eq++-- | Turns a 'DmdType' computed for the particular 'Arity' into a 'DmdSig'+-- unleashable at that arity. See Note [Understanding DmdType and DmdSig].+mkDmdSigForArity :: Arity -> DmdType -> DmdSig+mkDmdSigForArity arity dmd_ty@(DmdType fvs args div)+  | arity < dmdTypeDepth dmd_ty = DmdSig $ DmdType fvs (take arity args) div+  | otherwise                   = DmdSig (etaExpandDmdType arity dmd_ty)++mkClosedDmdSig :: [Demand] -> Divergence -> DmdSig+mkClosedDmdSig ds res = mkDmdSigForArity (length ds) (DmdType emptyDmdEnv ds res)++splitDmdSig :: DmdSig -> ([Demand], Divergence)+splitDmdSig (DmdSig (DmdType _ dmds res)) = (dmds, res)++dmdSigDmdEnv :: DmdSig -> DmdEnv+dmdSigDmdEnv (DmdSig (DmdType env _ _)) = env++hasDemandEnvSig :: DmdSig -> Bool+hasDemandEnvSig = not . isEmptyVarEnv . dmdSigDmdEnv++botSig :: DmdSig+botSig = DmdSig botDmdType++nopSig :: DmdSig+nopSig = DmdSig nopDmdType++isTopSig :: DmdSig -> Bool+isTopSig (DmdSig ty) = isTopDmdType ty++-- | True if the signature diverges or throws an exception in a saturated call.+-- See Note [Dead ends].+isDeadEndSig :: DmdSig -> Bool+isDeadEndSig (DmdSig (DmdType _ _ res)) = isDeadEndDiv res++-- | True when the signature indicates all arguments are boxed+onlyBoxedArguments :: DmdSig -> Bool+onlyBoxedArguments (DmdSig (DmdType _ dmds _)) = all demandIsBoxed dmds+ where+   demandIsBoxed BotDmd    = True+   demandIsBoxed AbsDmd    = True+   demandIsBoxed (_ :* sd) = subDemandIsboxed sd++   subDemandIsboxed (Poly Unboxed _) = False+   subDemandIsboxed (Poly _ _)       = True+   subDemandIsboxed (Call _ sd)      = subDemandIsboxed sd+   subDemandIsboxed (Prod Unboxed _) = False+   subDemandIsboxed (Prod _ ds)      = all demandIsBoxed ds++-- | Returns true if an application to n value args would diverge or throw an+-- exception.+--+-- If a function having 'botDiv' is applied to a less number of arguments than+-- its syntactic arity, we cannot say for sure that it is going to diverge.+-- Hence this function conservatively returns False in that case.+-- See Note [Dead ends].+isDeadEndAppSig :: DmdSig -> Int -> Bool+isDeadEndAppSig (DmdSig (DmdType _ ds res)) n+  = isDeadEndDiv res && not (lengthExceeds ds n)++trimBoxityDmdType :: DmdType -> DmdType+trimBoxityDmdType (DmdType fvs ds res) =+  DmdType (mapVarEnv trimBoxity fvs) (map trimBoxity ds) res++trimBoxityDmdSig :: DmdSig -> DmdSig+trimBoxityDmdSig = coerce trimBoxityDmdType++prependArgsDmdSig :: Int -> DmdSig -> DmdSig+-- ^ Add extra ('topDmd') arguments to a strictness signature.+-- In contrast to 'etaConvertDmdSig', this /prepends/ additional argument+-- demands. This is used by FloatOut.+prependArgsDmdSig new_args sig@(DmdSig dmd_ty@(DmdType env dmds res))+  | new_args == 0       = sig+  | isTopDmdType dmd_ty = sig+  | new_args < 0        = pprPanic "prependArgsDmdSig: negative new_args"+                                   (ppr new_args $$ ppr sig)+  | otherwise           = DmdSig (DmdType env dmds' res)+  where+    dmds' = replicate new_args topDmd ++ dmds++etaConvertDmdSig :: Arity -> DmdSig -> DmdSig+-- ^ We are expanding (\x y. e) to (\x y z. e z) or reducing from the latter to+-- the former (when the Simplifier identifies a new join points, for example).+-- In contrast to 'prependArgsDmdSig', this /appends/ extra arg demands if+-- necessary.+-- This works by looking at the 'DmdType' (which was produced under a call+-- demand for the old arity) and trying to transfer as many facts as we can to+-- the call demand of new arity.+-- An arity increase (resulting in a stronger incoming demand) can retain much+-- of the info, while an arity decrease (a weakening of the incoming demand)+-- must fall back to a conservative default.+etaConvertDmdSig arity (DmdSig dmd_ty)+  | arity < dmdTypeDepth dmd_ty = DmdSig $ decreaseArityDmdType dmd_ty+  | otherwise                   = DmdSig $ etaExpandDmdType arity dmd_ty++{-+************************************************************************+*                                                                      *+                     Demand transformers+*                                                                      *+************************************************************************+-}++-- | A /demand transformer/ is a monotone function from an incoming evaluation+-- context ('SubDemand') to a 'DmdType', describing how the denoted thing+-- (i.e. expression, function) uses its arguments and free variables, and+-- whether it diverges.+--+-- See Note [Understanding DmdType and DmdSig]+-- and Note [What are demand signatures?].+type DmdTransformer = SubDemand -> DmdType++-- | Extrapolate a demand signature ('DmdSig') into a 'DmdTransformer'.+--+-- Given a function's 'DmdSig' and a 'SubDemand' for the evaluation context,+-- return how the function evaluates its free variables and arguments.+dmdTransformSig :: DmdSig -> DmdTransformer+dmdTransformSig (DmdSig dmd_ty@(DmdType _ arg_ds _)) sd+  = multDmdType (peelManyCalls (length arg_ds) sd) dmd_ty+    -- see Note [Demands from unsaturated function calls]+    -- and Note [What are demand signatures?]++-- | A special 'DmdTransformer' for data constructors that feeds product+-- demands into the constructor arguments.+dmdTransformDataConSig :: Arity -> DmdTransformer+dmdTransformDataConSig arity sd = case go arity sd of+  Just dmds -> DmdType emptyDmdEnv dmds topDiv+  Nothing   -> nopDmdType -- Not saturated+  where+    go 0 sd             = snd <$> viewProd arity sd+    go n (Call C_11 sd) = go (n-1) sd  -- strict calls only!+    go _ _              = Nothing++-- | A special 'DmdTransformer' for dictionary selectors that feeds the demand+-- on the result into the indicated dictionary component (if saturated).+-- See Note [Demand transformer for a dictionary selector].+dmdTransformDictSelSig :: DmdSig -> DmdTransformer+-- NB: This currently doesn't handle newtype dictionaries.+-- It should simply apply call_sd directly to the dictionary, I suppose.+dmdTransformDictSelSig (DmdSig (DmdType _ [_ :* prod] _)) call_sd+   | (n, sd') <- peelCallDmd call_sd+   , Prod _ sig_ds <- prod+   = multDmdType n $+     DmdType emptyDmdEnv [C_11 :* mkProd Unboxed (map (enhance sd') sig_ds)] topDiv+   | otherwise+   = nopDmdType -- See Note [Demand transformer for a dictionary selector]+  where+    enhance _  AbsDmd   = AbsDmd+    enhance _  BotDmd   = BotDmd+    enhance sd _dmd_var = C_11 :* sd  -- This is the one!+                                      -- C_11, because we multiply with n above+dmdTransformDictSelSig sig sd = pprPanic "dmdTransformDictSelSig: no args" (ppr sig $$ ppr sd)++{-+Note [What are demand signatures?]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Demand analysis interprets expressions in the abstract domain of demand+transformers. Given a (sub-)demand that denotes the evaluation context, the+abstract transformer of an expression gives us back a demand type denoting+how other things (like arguments and free vars) were used when the expression+was evaluated. Here's an example:++  f x y =+    if x + expensive+      then \z -> z + y * ...+      else \z -> z * ...++The abstract transformer (let's call it F_e) of the if expression (let's+call it e) would transform an incoming (undersaturated!) head demand 1A into+a demand type like {x-><1L>,y-><L>}<L>. In pictures:++     Demand ---F_e---> DmdType+     <1A>              {x-><1L>,y-><L>}<L>++Let's assume that the demand transformers we compute for an expression are+correct wrt. to some concrete semantics for Core. How do demand signatures fit+in? They are strange beasts, given that they come with strict rules when to+it's sound to unleash them.++Fortunately, we can formalise the rules with Galois connections. Consider+f's strictness signature, {}<1L><L>. It's a single-point approximation of+the actual abstract transformer of f's RHS for arity 2. So, what happens is that+we abstract *once more* from the abstract domain we already are in, replacing+the incoming Demand by a simple lattice with two elements denoting incoming+arity: A_2 = {<2, >=2} (where '<2' is the top element and >=2 the bottom+element). Here's the diagram:++     A_2 -----f_f----> DmdType+      ^                   |+      | α               γ |+      |                   v+  SubDemand --F_f----> DmdType++With+  α(C1(C1(_))) = >=2+  α(_)         =  <2+  γ(ty)        =  ty+and F_f being the abstract transformer of f's RHS and f_f being the abstracted+abstract transformer computable from our demand signature simply by++  f_f(>=2) = {}<1L><L>+  f_f(<2)  = multDmdType C_0N {}<1L><L>++where multDmdType makes a proper top element out of the given demand type.++In practice, the A_n domain is not just a simple Bool, but a Card, which is+exactly the Card with which we have to multDmdType. The Card for arity n+is computed by calling @peelManyCalls n@, which corresponds to α above.++Note [Demand transformer for a dictionary selector]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have a superclass selector 'sc_sel' and a class method+selector 'op_sel', and a function that uses both, like this++-- Strictness sig: 1P(1,A)+sc_sel (x,y) = x++-- Strictness sig: 1P(A,1)+op_sel (p,q)= q++f d v = op_sel (sc_sel d) v++What do we learn about the demand on 'd'?  Alas, we see only the+demand from 'sc_sel', namely '1P(1,A)'.  We /don't/ see that 'd' really has a nested+demand '1P(1P(A,1C1(1)),A)'.  On the other hand, if we inlined the two selectors+we'd have++f d x = case d of (x,_) ->+        case x of (_,q) ->+        q v++If we analyse that, we'll get a richer, nested demand on 'd'.++We want to behave /as if/ we'd inlined 'op_sel' and 'sc_sel'. We can do this+easily by building a richer demand transformer for dictionary selectors than+is expressible by a regular demand signature.+And that is what 'dmdTransformDictSelSig' does: it transforms the demand on the+result to a demand on the (single) argument.++How does it do that?+If we evaluate (op dict-expr) under demand 'd', then we can push the demand 'd'+into the appropriate field of the dictionary. What *is* the appropriate field?+We just look at the strictness signature of the class op, which will be+something like: P(AAA1AAAAA). Then replace the '1' (or any other non-absent+demand, really) by the demand 'd'. The '1' acts as if it was a demand variable,+the whole signature really means `\d. P(AAAdAAAAA)` for any incoming+demand 'd'.++For single-method classes, which are represented by newtypes the signature+of 'op' won't look like P(...), so matching on Prod will fail.+That's fine: if we are doing strictness analysis we are also doing inlining,+so we'll have inlined 'op' into a cast.  So we can bale out in a conservative+way, returning nopDmdType. SG: Although we then probably want to apply the eval+demand 'd' directly to 'op' rather than turning it into 'topSubDmd'...++It is (just.. #8329) possible to be running strictness analysis *without*+having inlined class ops from single-method classes.  Suppose you are using+ghc --make; and the first module has a local -O0 flag.  So you may load a class+without interface pragmas, ie (currently) without an unfolding for the class+ops.   Now if a subsequent module in the --make sweep has a local -O flag+you might do strictness analysis, but there is no inlining for the class op.+This is weird, so I'm not worried about whether this optimises brilliantly; but+it should not fall over.+-}++-- | Remove the demand environment from the signature.+zapDmdEnvSig :: DmdSig -> DmdSig+zapDmdEnvSig (DmdSig (DmdType _ ds r)) = mkClosedDmdSig ds r++zapUsageDemand :: Demand -> Demand+-- Remove the usage info, but not the strictness info, from the demand+zapUsageDemand = kill_usage $ KillFlags+    { kf_abs         = True+    , kf_used_once   = True+    , kf_called_once = True+    }++-- | Remove all `C_01 :*` info (but not `CM` sub-demands) from the demand+zapUsedOnceDemand :: Demand -> Demand+zapUsedOnceDemand = kill_usage $ KillFlags+    { kf_abs         = False+    , kf_used_once   = True+    , kf_called_once = False+    }++-- | Remove all `C_01 :*` info (but not `CM` sub-demands) from the strictness+--   signature+zapUsedOnceSig :: DmdSig -> DmdSig+zapUsedOnceSig (DmdSig (DmdType env ds r))+    = DmdSig (DmdType env (map zapUsedOnceDemand ds) r)++data KillFlags = KillFlags+    { kf_abs         :: Bool+    , kf_used_once   :: Bool+    , kf_called_once :: Bool+    }++kill_usage_card :: KillFlags -> Card -> Card+kill_usage_card kfs C_00 | kf_abs kfs       = C_0N+kill_usage_card kfs C_10 | kf_abs kfs       = C_1N+kill_usage_card kfs C_01 | kf_used_once kfs = C_0N+kill_usage_card kfs C_11 | kf_used_once kfs = C_1N+kill_usage_card _   n                       = n++kill_usage :: KillFlags -> Demand -> Demand+kill_usage _   AbsDmd    = AbsDmd+kill_usage _   BotDmd    = BotDmd+kill_usage kfs (n :* sd) = kill_usage_card kfs n :* kill_usage_sd kfs sd++kill_usage_sd :: KillFlags -> SubDemand -> SubDemand+kill_usage_sd kfs (Call n sd)+  | kf_called_once kfs        = mkCall (lubCard C_1N n) (kill_usage_sd kfs sd)+  | otherwise                 = mkCall n                (kill_usage_sd kfs sd)+kill_usage_sd kfs (Prod b ds) = mkProd b (map (kill_usage kfs) ds)+kill_usage_sd _   sd          = sd++{- *********************************************************************+*                                                                      *+               TypeShape and demand trimming+*                                                                      *+********************************************************************* -}+++data TypeShape -- See Note [Trimming a demand to a type]+               --     in GHC.Core.Opt.DmdAnal+  = TsFun TypeShape+  | TsProd [TypeShape]+  | TsUnk++trimToType :: Demand -> TypeShape -> Demand+-- See Note [Trimming a demand to a type] in GHC.Core.Opt.DmdAnal+trimToType AbsDmd    _  = AbsDmd+trimToType BotDmd    _  = BotDmd+trimToType (n :* sd) ts+  = n :* go sd ts+  where+    go (Prod b ds) (TsProd tss)+      | equalLength ds tss    = mkProd b (zipWith trimToType ds tss)+    go (Call n sd) (TsFun ts) = mkCall n (go sd ts)+    go sd@Poly{}   _          = sd+    go _           _          = topSubDmd++-- | Drop all boxity+trimBoxity :: Demand -> Demand+trimBoxity AbsDmd    = AbsDmd+trimBoxity BotDmd    = BotDmd+trimBoxity (n :* sd) = n :* go sd+  where+    go (Poly _ n)  = Poly Boxed n+    go (Prod _ ds) = mkProd Boxed (map trimBoxity ds)+    go (Call n sd) = mkCall n $ go sd++{-+************************************************************************+*                                                                      *+                     'seq'ing demands+*                                                                      *+************************************************************************+-}++seqDemand :: Demand -> ()+seqDemand AbsDmd    = ()+seqDemand BotDmd    = ()+seqDemand (_ :* sd) = seqSubDemand sd++seqSubDemand :: SubDemand -> ()+seqSubDemand (Prod _ ds) = seqDemandList ds+seqSubDemand (Call _ sd) = seqSubDemand sd+seqSubDemand (Poly _ _)  = ()++seqDemandList :: [Demand] -> ()+seqDemandList = foldr (seq . seqDemand) ()++seqDmdType :: DmdType -> ()+seqDmdType (DmdType env ds res) =+  seqDmdEnv env `seq` seqDemandList ds `seq` res `seq` ()++seqDmdEnv :: DmdEnv -> ()+seqDmdEnv env = seqEltsUFM seqDemand env++seqDmdSig :: DmdSig -> ()+seqDmdSig (DmdSig ty) = seqDmdType ty++{-+************************************************************************+*                                                                      *+                     Outputable and Binary instances+*                                                                      *+************************************************************************+-}++-- Just for debugging purposes.+instance Show Card where+  show C_00 = "C_00"+  show C_01 = "C_01"+  show C_0N = "C_0N"+  show C_10 = "C_10"+  show C_11 = "C_11"+  show C_1N = "C_1N"++{- Note [Demand notation]+~~~~~~~~~~~~~~~~~~~~~~~~~+This Note should be kept up to date with the documentation of `-fstrictness`+in the user's guide.++For pretty-printing demands, we use quite a compact notation with some+abbreviations. Here's the BNF:++  card ::= B                        {}+        |  A                        {0}+        |  M                        {0,1}+        |  L                        {0,1,n}+        |  1                        {1}+        |  S                        {1,n}++  box  ::= !                        Unboxed+        |  <empty>                  Boxed++  d    ::= card sd                  The :* constructor, just juxtaposition+        |  card                     abbreviation: Same as "card card"++  sd   ::= box card                 @Poly box card@+        |  box P(d,d,..)            @Prod box [d1,d2,..]@+        |  Ccard(sd)                @Call card sd@++So, L can denote a 'Card', polymorphic 'SubDemand' or polymorphic 'Demand',+but it's always clear from context which "overload" is meant. It's like+return-type inference of e.g. 'read'.++Examples are in the haddock for 'Demand'.++This is the syntax for demand signatures:++  div ::= <empty>      topDiv+       |  x            exnDiv+       |  b            botDiv++  sig ::= {x->dx,y->dy,z->dz...}<d1><d2><d3>...<dn>div+                  ^              ^   ^   ^      ^   ^+                  |              |   |   |      |   |+                  |              \---+---+------/   |+                  |                  |              |+             demand on free        demand on      divergence+               variables           arguments      information+           (omitted if empty)                     (omitted if+                                                no information)+++-}++-- | See Note [Demand notation]+-- Current syntax was discussed in #19016.+instance Outputable Card where+  ppr C_00 = char 'A' -- "Absent"+  ppr C_01 = char 'M' -- "Maybe"+  ppr C_0N = char 'L' -- "Lazy"+  ppr C_11 = char '1' -- "exactly 1"+  ppr C_1N = char 'S' -- "Strict"+  ppr C_10 = char 'B' -- "Bottom"++-- | See Note [Demand notation]+instance Outputable Demand where+  ppr AbsDmd                    = char 'A'+  ppr BotDmd                    = char 'B'+  ppr (C_0N :* Poly Boxed C_0N) = char 'L' -- Print LL as just L+  ppr (C_1N :* Poly Boxed C_1N) = char 'S' -- Dito SS+  ppr (n :* sd)                 = ppr n <> ppr sd++-- | See Note [Demand notation]+instance Outputable SubDemand where+  ppr (Poly b sd) = pp_boxity b <> ppr sd+  ppr (Call n sd) = char 'C' <> ppr n <> parens (ppr sd)+  ppr (Prod b ds) = pp_boxity b <> char 'P' <> parens (fields ds)+    where+      fields []     = empty+      fields [x]    = ppr x+      fields (x:xs) = ppr x <> char ',' <> fields xs++pp_boxity :: Boxity -> SDoc+pp_boxity Unboxed = char '!'+pp_boxity _       = empty++instance Outputable Divergence where+  ppr Diverges = char 'b' -- for (b)ottom+  ppr ExnOrDiv = char 'x' -- for e(x)ception+  ppr Dunno    = empty++instance Outputable DmdType where+  ppr (DmdType fv ds res)+    = hsep [hcat (map (angleBrackets . ppr) ds) <> ppr res,+            if null fv_elts then empty+            else braces (fsep (map pp_elt fv_elts))]+    where+      pp_elt (uniq, dmd) = ppr uniq <> text "->" <> ppr dmd+      fv_elts = nonDetUFMToList fv+        -- It's OK to use nonDetUFMToList here because we only do it for+        -- pretty printing++instance Outputable DmdSig where+   ppr (DmdSig ty) = ppr ty++instance Outputable TypeShape where+  ppr TsUnk        = text "TsUnk"+  ppr (TsFun ts)   = text "TsFun" <> parens (ppr ts)+  ppr (TsProd tss) = parens (hsep $ punctuate comma $ map ppr tss)++instance Binary Card where+  put_ bh C_00 = putByte bh 0+  put_ bh C_01 = putByte bh 1+  put_ bh C_0N = putByte bh 2+  put_ bh C_11 = putByte bh 3+  put_ bh C_1N = putByte bh 4+  put_ bh C_10 = putByte bh 5+  get bh = do+    h <- getByte bh+    case h of+      0 -> return C_00+      1 -> return C_01+      2 -> return C_0N+      3 -> return C_11+      4 -> return C_1N+      5 -> return C_10+      _ -> pprPanic "Binary:Card" (ppr (fromIntegral h :: Int))++instance Binary Demand where+  put_ bh (n :* sd) = put_ bh n *> case n of+    C_00 -> return ()+    C_10 -> return ()+    _    -> put_ bh sd+  get bh = get bh >>= \n -> case n of+    C_00 -> return AbsDmd+    C_10 -> return BotDmd+    _    -> (n :*) <$> get bh++instance Binary SubDemand where+  put_ bh (Poly b sd) = putByte bh 0 *> put_ bh b *> put_ bh sd+  put_ bh (Call n sd) = putByte bh 1 *> put_ bh n *> put_ bh sd+  put_ bh (Prod b ds) = putByte bh 2 *> put_ bh b *> put_ bh ds+  get bh = do+    h <- getByte bh+    case h of+      0 -> Poly <$> get bh <*> get bh+      1 -> mkCall <$> get bh <*> get bh+      2 -> Prod <$> get bh <*> get bh+      _ -> pprPanic "Binary:SubDemand" (ppr (fromIntegral h :: Int))++instance Binary DmdSig where+  put_ bh (DmdSig aa) = put_ bh aa+  get bh = DmdSig <$> get bh  instance Binary DmdType where   -- Ignore DmdEnv when spitting out the DmdType
GHC/Types/Error.hs view
@@ -1,45 +1,70 @@-{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-}  module GHC.Types.Error    ( -- * Messages      Messages-   , WarningMessages-   , ErrorMessages    , mkMessages+   , getMessages    , emptyMessages    , isEmptyMessages+   , singleMessage    , addMessage    , unionMessages+   , unionManyMessages    , MsgEnvelope (..)-   , WarnMsg++   -- * Classifying Messages++   , MessageClass (..)+   , Severity (..)+   , Diagnostic (..)+   , DiagnosticMessage (..)+   , DiagnosticReason (..)+   , DiagnosticHint (..)+   , mkPlainDiagnostic+   , mkPlainError+   , mkDecoratedDiagnostic+   , mkDecoratedError++   -- * Hints and refactoring actions+   , GhcHint (..)+   , AvailableBindings(..)+   , LanguageExtensionHint(..)+   , suggestExtension+   , suggestExtensionWithInfo+   , suggestExtensions+   , suggestExtensionsWithInfo+   , suggestAnyExtension+   , suggestAnyExtensionWithInfo+   , useExtensionInOrderTo+   , noHints++    -- * Rendering Messages+    , SDoc    , DecoratedSDoc (unDecorated)-   , Severity (..)-   , RenderableDiagnostic (..)+   , mkDecorated, mkSimpleDecorated+   , unionDecoratedSDoc+   , mapDecoratedSDoc+    , pprMessageBag-   , mkDecorated    , mkLocMessage    , mkLocMessageAnn-   , getSeverityColour    , getCaretDiagnostic-   , makeIntoWarning-   -- * Constructing individual errors-   , mkMsgEnvelope-   , mkPlainMsgEnvelope-   , mkErr-   , mkLongMsgEnvelope-   , mkWarnMsg-   , mkPlainWarnMsg-   , mkLongWarnMsg    -- * Queries-   , isErrorMessage+   , isIntrinsicErrorMessage+   , isExtrinsicErrorMessage    , isWarningMessage    , getErrorMessages    , getWarningMessages    , partitionMessages    , errorsFound+   , errorsOrFatalWarningsFound    ) where @@ -48,6 +73,7 @@ import GHC.Driver.Flags  import GHC.Data.Bag+import GHC.IO (catchException) import GHC.Utils.Outputable as Outputable import qualified GHC.Utils.Ppr.Colour as Col import GHC.Types.SrcLoc as SrcLoc@@ -55,7 +81,9 @@ import GHC.Data.StringBuffer (atLine, hGetStringBuffer, len, lexemeToString) import GHC.Utils.Json -import System.IO.Error  ( catchIOError )+import Data.Bifunctor+import Data.Foldable    ( fold )+import GHC.Types.Hint  {- Note [Messages]@@ -63,202 +91,397 @@  We represent the 'Messages' as a single bag of warnings and errors. -The reason behind that is that there is a fluid relationship between errors and warnings and we want to-be able to promote or demote errors and warnings based on certain flags (e.g. -Werror, -fdefer-type-errors-or -XPartialTypeSignatures). For now we rely on the 'Severity' to distinguish between a warning and an-error, although the 'Severity' can be /more/ than just 'SevWarn' and 'SevError', and as such it probably-shouldn't belong to an 'MsgEnvelope' to begin with, as it might potentially lead to the construction of-"impossible states" (e.g. a waning with 'SevInfo', for example).+The reason behind that is that there is a fluid relationship between errors+and warnings and we want to be able to promote or demote errors and warnings+based on certain flags (e.g. -Werror, -fdefer-type-errors or+-XPartialTypeSignatures). More specifically, every diagnostic has a+'DiagnosticReason', but a warning 'DiagnosticReason' might be associated with+'SevError', in the case of -Werror. -'WarningMessages' and 'ErrorMessages' are for now simple type aliases to retain backward compatibility, but-in future iterations these can be either parameterised over an 'e' message type (to make type signatures-a bit more declarative) or removed altogether.--}+We rely on the 'Severity' to distinguish between a warning and an error. --- | A collection of messages emitted by GHC during error reporting. A diagnostic message is typically--- a warning or an error. See Note [Messages].-newtype Messages e = Messages (Bag (MsgEnvelope e))+'WarningMessages' and 'ErrorMessages' are for now simple type aliases to+retain backward compatibility, but in future iterations these can be either+parameterised over an 'e' message type (to make type signatures a bit more+declarative) or removed altogether.+-} -instance Functor Messages where-  fmap f (Messages xs) = Messages (mapBag (fmap f) xs)+-- | A collection of messages emitted by GHC during error reporting. A+-- diagnostic message is typically a warning or an error. See Note [Messages].+--+-- /INVARIANT/: All the messages in this collection must be relevant, i.e.+-- their 'Severity' should /not/ be 'SevIgnore'. The smart constructor+-- 'mkMessages' will filter out any message which 'Severity' is 'SevIgnore'.+newtype Messages e = Messages { getMessages :: Bag (MsgEnvelope e) }+  deriving newtype (Semigroup, Monoid)+  deriving stock (Functor, Foldable, Traversable)  emptyMessages :: Messages e emptyMessages = Messages emptyBag  mkMessages :: Bag (MsgEnvelope e) -> Messages e-mkMessages = Messages+mkMessages = Messages . filterBag interesting+  where+    interesting :: MsgEnvelope e -> Bool+    interesting = (/=) SevIgnore . errMsgSeverity  isEmptyMessages :: Messages e -> Bool isEmptyMessages (Messages msgs) = isEmptyBag msgs +singleMessage :: MsgEnvelope e -> Messages e+singleMessage e = addMessage e emptyMessages++instance Diagnostic e => Outputable (Messages e) where+  ppr msgs = braces (vcat (map ppr_one (bagToList (getMessages msgs))))+     where+       ppr_one :: MsgEnvelope e -> SDoc+       ppr_one envelope = pprDiagnostic (errMsgDiagnostic envelope)++{- Note [Discarding Messages]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Discarding a 'SevIgnore' message from 'addMessage' and 'unionMessages' is just+an optimisation, as GHC would /also/ suppress any diagnostic which severity is+'SevIgnore' before printing the message: See for example 'putLogMsg' and+'defaultLogAction'.++-}++-- | Adds a 'Message' to the input collection of messages.+-- See Note [Discarding Messages]. addMessage :: MsgEnvelope e -> Messages e -> Messages e-addMessage x (Messages xs) = Messages (x `consBag` xs)+addMessage x (Messages xs)+  | SevIgnore <- errMsgSeverity x = Messages xs+  | otherwise                     = Messages (x `consBag` xs)  -- | Joins two collections of messages together.+-- See Note [Discarding Messages]. unionMessages :: Messages e -> Messages e -> Messages e-unionMessages (Messages msgs1) (Messages msgs2) = Messages (msgs1 `unionBags` msgs2)--type WarningMessages = Bag (MsgEnvelope DecoratedSDoc)-type ErrorMessages   = Bag (MsgEnvelope DecoratedSDoc)+unionMessages (Messages msgs1) (Messages msgs2) =+  Messages (msgs1 `unionBags` msgs2) -type WarnMsg         = MsgEnvelope DecoratedSDoc+-- | Joins many 'Messages's together+unionManyMessages :: Foldable f => f (Messages e) -> Messages e+unionManyMessages = fold --- | A 'DecoratedSDoc' is isomorphic to a '[SDoc]' but it carries the invariant that the input '[SDoc]'--- needs to be rendered /decorated/ into its final form, where the typical case would be adding bullets--- between each elements of the list.--- The type of decoration depends on the formatting function used, but in practice GHC uses the--- 'formatBulleted'.+-- | A 'DecoratedSDoc' is isomorphic to a '[SDoc]' but it carries the+-- invariant that the input '[SDoc]' needs to be rendered /decorated/ into its+-- final form, where the typical case would be adding bullets between each+-- elements of the list. The type of decoration depends on the formatting+-- function used, but in practice GHC uses the 'formatBulleted'. newtype DecoratedSDoc = Decorated { unDecorated :: [SDoc] }  -- | Creates a new 'DecoratedSDoc' out of a list of 'SDoc'. mkDecorated :: [SDoc] -> DecoratedSDoc mkDecorated = Decorated +-- | Creates a new 'DecoratedSDoc' out of a single 'SDoc'+mkSimpleDecorated :: SDoc -> DecoratedSDoc+mkSimpleDecorated doc = Decorated [doc]++-- | Joins two 'DecoratedSDoc' together. The resulting 'DecoratedSDoc'+-- will have a number of entries which is the sum of the lengths of+-- the input.+unionDecoratedSDoc :: DecoratedSDoc -> DecoratedSDoc -> DecoratedSDoc+unionDecoratedSDoc (Decorated s1) (Decorated s2) =+  Decorated (s1 `mappend` s2)++-- | Apply a transformation function to all elements of a 'DecoratedSDoc'.+mapDecoratedSDoc :: (SDoc -> SDoc) -> DecoratedSDoc -> DecoratedSDoc+mapDecoratedSDoc f (Decorated s1) =+  Decorated (map f s1)+ {- Note [Rendering Messages] ~~~~~~~~~~~~~~~~~~~~~~~~~ -Turning 'Messages' into something that renders nicely for the user is one of the last steps, and it-happens typically at the application boundaries (i.e. from the 'Driver' upwards).+Turning 'Messages' into something that renders nicely for the user is one of+the last steps, and it happens typically at the application's boundaries (i.e.+from the 'Driver' upwards). -For now (see #18516) this class is very boring as it has only one instance, but the idea is that as-the more domain-specific types are defined, the more instances we would get. For example, given something like:+For now (see #18516) this class has few instance, but the idea is that as the+more domain-specific types are defined, the more instances we would get. For+example, given something like: -data TcRnMessage-  = TcRnOutOfScope ..-  | ..+  data TcRnDiagnostic+    = TcRnOutOfScope ..+    | .. -We could then define how a 'TcRnMessage' is displayed to the user. Rather than scattering pieces of-'SDoc' around the codebase, we would write once for all:+  newtype TcRnMessage = TcRnMessage (DiagnosticMessage TcRnDiagnostic) -instance RenderableDiagnostic TcRnMessage where-  renderDiagnostic = \case-    TcRnOutOfScope .. -> Decorated [text "Out of scope error ..."]-    ...+We could then define how a 'TcRnDiagnostic' is displayed to the user. Rather+than scattering pieces of 'SDoc' around the codebase, we would write once for+all: -This way, we can easily write generic rendering functions for errors that all they care about is the-knowledge that a given type 'e' has a 'RenderableDiagnostic' constraint.+  instance Diagnostic TcRnDiagnostic where+    diagnosticMessage (TcRnMessage msg) = case diagMessage msg of+      TcRnOutOfScope .. -> Decorated [text "Out of scope error ..."]+      ... +This way, we can easily write generic rendering functions for errors that all+they care about is the knowledge that a given type 'e' has a 'Diagnostic'+constraint.+ -} --- | A class for types (typically errors and warnings) which can be \"rendered\" into an opaque 'DecoratedSDoc'.--- For more information, see Note [Rendering Messages].-class RenderableDiagnostic a where-  renderDiagnostic :: a -> DecoratedSDoc+-- | A class identifying a diagnostic.+-- Dictionary.com defines a diagnostic as:+--+-- \"a message output by a computer diagnosing an error in a computer program,+-- computer system, or component device\".+--+-- A 'Diagnostic' carries the /actual/ description of the message (which, in+-- GHC's case, it can be an error or a warning) and the /reason/ why such+-- message was generated in the first place. See also Note [Rendering+-- Messages].+class Diagnostic a where+  diagnosticMessage :: a -> DecoratedSDoc+  diagnosticReason  :: a -> DiagnosticReason+  diagnosticHints   :: a -> [GhcHint] +pprDiagnostic :: Diagnostic e => e -> SDoc+pprDiagnostic e = vcat [ ppr (diagnosticReason e)+                       , nest 2 (vcat (unDecorated (diagnosticMessage e))) ]++-- | A generic 'Hint' message, to be used with 'DiagnosticMessage'.+data DiagnosticHint = DiagnosticHint !SDoc++instance Outputable DiagnosticHint where+  ppr (DiagnosticHint msg) = msg++-- | A generic 'Diagnostic' message, without any further classification or+-- provenance: By looking at a 'DiagnosticMessage' we don't know neither+-- /where/ it was generated nor how to intepret its payload (as it's just a+-- structured document). All we can do is to print it out and look at its+-- 'DiagnosticReason'.+data DiagnosticMessage = DiagnosticMessage+  { diagMessage :: !DecoratedSDoc+  , diagReason  :: !DiagnosticReason+  , diagHints   :: [GhcHint]+  }++instance Diagnostic DiagnosticMessage where+  diagnosticMessage = diagMessage+  diagnosticReason  = diagReason+  diagnosticHints   = diagHints++-- | Helper function to use when no hints can be provided. Currently this function+-- can be used to construct plain 'DiagnosticMessage' and add hints to them, but+-- once #18516 will be fully executed, the main usage of this function would be in+-- the implementation of the 'diagnosticHints' typeclass method, to report the fact+-- that a particular 'Diagnostic' has no hints.+noHints :: [GhcHint]+noHints = mempty++mkPlainDiagnostic :: DiagnosticReason -> [GhcHint] -> SDoc -> DiagnosticMessage+mkPlainDiagnostic rea hints doc = DiagnosticMessage (mkSimpleDecorated doc) rea hints++-- | Create an error 'DiagnosticMessage' holding just a single 'SDoc'+mkPlainError :: [GhcHint] -> SDoc -> DiagnosticMessage+mkPlainError hints doc = DiagnosticMessage (mkSimpleDecorated doc) ErrorWithoutFlag hints++-- | Create a 'DiagnosticMessage' from a list of bulleted SDocs and a 'DiagnosticReason'+mkDecoratedDiagnostic :: DiagnosticReason -> [GhcHint] -> [SDoc] -> DiagnosticMessage+mkDecoratedDiagnostic rea hints docs = DiagnosticMessage (mkDecorated docs) rea hints++-- | Create an error 'DiagnosticMessage' from a list of bulleted SDocs+mkDecoratedError :: [GhcHint] -> [SDoc] -> DiagnosticMessage+mkDecoratedError hints docs = DiagnosticMessage (mkDecorated docs) ErrorWithoutFlag hints++-- | The reason /why/ a 'Diagnostic' was emitted in the first place.+-- Diagnostic messages are born within GHC with a very precise reason, which+-- can be completely statically-computed (i.e. this is an error or a warning+-- no matter what), or influenced by the specific state of the 'DynFlags' at+-- the moment of the creation of a new 'Diagnostic'. For example, a parsing+-- error is /always/ going to be an error, whereas a 'WarningWithoutFlag+-- Opt_WarnUnusedImports' might turn into an error due to '-Werror' or+-- '-Werror=warn-unused-imports'. Interpreting a 'DiagnosticReason' together+-- with its associated 'Severity' gives us the full picture.+data DiagnosticReason+  = WarningWithoutFlag+  -- ^ Born as a warning.+  | WarningWithFlag !WarningFlag+  -- ^ Warning was enabled with the flag.+  | ErrorWithoutFlag+  -- ^ Born as an error.+  deriving (Eq, Show)++instance Outputable DiagnosticReason where+  ppr = \case+    WarningWithoutFlag  -> text "WarningWithoutFlag"+    WarningWithFlag wf  -> text ("WarningWithFlag " ++ show wf)+    ErrorWithoutFlag    -> text "ErrorWithoutFlag"+ -- | An envelope for GHC's facts about a running program, parameterised over the -- /domain-specific/ (i.e. parsing, typecheck-renaming, etc) diagnostics. ----- To say things differently, GHC emits /diagnostics/ about the running program, each of which is wrapped--- into a 'MsgEnvelope' that carries specific information like where the error happened, its severity, etc.--- Finally, multiple 'MsgEnvelope's are aggregated into 'Messages' that are returned to the user.+-- To say things differently, GHC emits /diagnostics/ about the running+-- program, each of which is wrapped into a 'MsgEnvelope' that carries+-- specific information like where the error happened, etc. Finally, multiple+-- 'MsgEnvelope's are aggregated into 'Messages' that are returned to the+-- user. data MsgEnvelope e = MsgEnvelope    { errMsgSpan        :: SrcSpan       -- ^ The SrcSpan is used for sorting errors into line-number order    , errMsgContext     :: PrintUnqualified    , errMsgDiagnostic  :: e    , errMsgSeverity    :: Severity-   , errMsgReason      :: WarnReason-   } deriving Functor--instance RenderableDiagnostic DecoratedSDoc where-  renderDiagnostic = id+   } deriving (Functor, Foldable, Traversable) -data Severity-  = SevOutput-  | SevFatal-  | SevInteractive+-- | The class for a diagnostic message. The main purpose is to classify a+-- message within GHC, to distinguish it from a debug/dump message vs a proper+-- diagnostic, for which we include a 'DiagnosticReason'.+data MessageClass+  = MCOutput+  | MCFatal+  | MCInteractive -  | SevDump+  | MCDump     -- ^ Log message intended for compiler developers     -- No file\/line\/column stuff -  | SevInfo+  | MCInfo     -- ^ Log messages intended for end users.     -- No file\/line\/column stuff. +  | MCDiagnostic Severity DiagnosticReason+    -- ^ Diagnostics from the compiler. This constructor is very powerful as+    -- it allows the construction of a 'MessageClass' with a completely+    -- arbitrary permutation of 'Severity' and 'DiagnosticReason'. As such,+    -- users are encouraged to use the 'mkMCDiagnostic' smart constructor+    -- instead. Use this constructor directly only if you need to construct+    -- and manipulate diagnostic messages directly, for example inside+    -- 'GHC.Utils.Error'. In all the other circumstances, /especially/ when+    -- emitting compiler diagnostics, use the smart constructor.+  deriving (Eq, Show)++{- Note [Suppressing Messages]++The 'SevIgnore' constructor is used to generate messages for diagnostics which+are meant to be suppressed and not reported to the user: the classic example+are warnings for which the user didn't enable the corresponding 'WarningFlag',+so GHC shouldn't print them.++A different approach would be to extend the zoo of 'mkMsgEnvelope' functions+to return a 'Maybe (MsgEnvelope e)', so that we won't need to even create the+message to begin with. Both approaches have been evaluated, but we settled on+the "SevIgnore one" for a number of reasons:++* It's less invasive to deal with;+* It plays slightly better with deferred diagnostics (see 'GHC.Tc.Errors') as+  for those we need to be able to /always/ produce a message (so that is+  reported at runtime);+* It gives us more freedom: we can still decide to drop a 'SevIgnore' message+  at leisure, or we can decide to keep it around until the last moment. Maybe+  in the future we would need to turn a 'SevIgnore' into something else, for+  example to "unsuppress" diagnostics if a flag is set: with this approach, we+  have more leeway to accommodate new features.++-}+++-- | Used to describe warnings and errors+--   o The message has a file\/line\/column heading,+--     plus "warning:" or "error:",+--     added by mkLocMessage+--   o With 'SevIgnore' the message is suppressed+--   o Output is intended for end users+data Severity+  = SevIgnore+  -- ^ Ignore this message, for example in+  -- case of suppression of warnings users+  -- don't want to see. See Note [Suppressing Messages]   | SevWarning   | SevError-    -- ^ SevWarning and SevError are used for warnings and errors-    --   o The message has a file\/line\/column heading,-    --     plus "warning:" or "error:",-    --     added by mkLocMessags-    --   o Output is intended for end users   deriving (Eq, Show) +instance Outputable Severity where+  ppr = \case+    SevIgnore  -> text "SevIgnore"+    SevWarning -> text "SevWarning"+    SevError   -> text "SevError"  instance ToJson Severity where   json s = JSString (show s) -instance Show (MsgEnvelope DecoratedSDoc) where+instance ToJson MessageClass where+  json MCOutput = JSString "MCOutput"+  json MCFatal  = JSString "MCFatal"+  json MCInteractive = JSString "MCInteractive"+  json MCDump = JSString "MCDump"+  json MCInfo = JSString "MCInfo"+  json (MCDiagnostic sev reason) =+    JSString $ renderWithContext defaultSDocContext (ppr $ text "MCDiagnostic" <+> ppr sev <+> ppr reason)++instance Show (MsgEnvelope DiagnosticMessage) where     show = showMsgEnvelope  -- | Shows an 'MsgEnvelope'.-showMsgEnvelope :: RenderableDiagnostic a => MsgEnvelope a -> String+showMsgEnvelope :: Diagnostic a => MsgEnvelope a -> String showMsgEnvelope err =-  renderWithContext defaultSDocContext (vcat (unDecorated . renderDiagnostic $ errMsgDiagnostic err))+  renderWithContext defaultSDocContext (vcat (unDecorated . diagnosticMessage $ errMsgDiagnostic err))  pprMessageBag :: Bag SDoc -> SDoc pprMessageBag msgs = vcat (punctuate blankLine (bagToList msgs))  -- | Make an unannotated error message with location info.-mkLocMessage :: Severity -> SrcSpan -> SDoc -> SDoc+mkLocMessage :: MessageClass -> SrcSpan -> SDoc -> SDoc mkLocMessage = mkLocMessageAnn Nothing  -- | Make a possibly annotated error message with location info. mkLocMessageAnn   :: Maybe String                       -- ^ optional annotation-  -> Severity                           -- ^ severity+  -> MessageClass                       -- ^ What kind of message?   -> SrcSpan                            -- ^ location-  -> SDoc                             -- ^ message+  -> SDoc                               -- ^ message   -> SDoc   -- Always print the location, even if it is unhelpful.  Error messages   -- are supposed to be in a standard format, and one without a location   -- would look strange.  Better to say explicitly "<no location info>".-mkLocMessageAnn ann severity locn msg+mkLocMessageAnn ann msg_class locn msg     = sdocOption sdocColScheme $ \col_scheme ->       let locn' = sdocOption sdocErrorSpans $ \case                      True  -> ppr locn                      False -> ppr (srcSpanStart locn) -          sevColour = getSeverityColour severity col_scheme+          msgColour = getMessageClassColour msg_class col_scheme            -- Add optional information           optAnn = case ann of             Nothing -> text ""-            Just i  -> text " [" <> coloured sevColour (text i) <> text "]"+            Just i  -> text " [" <> coloured msgColour (text i) <> text "]"            -- Add prefixes, like    Foo.hs:34: warning:           --                           <the warning message>           header = locn' <> colon <+>-                   coloured sevColour sevText <> optAnn+                   coloured msgColour msgText <> optAnn        in coloured (Col.sMessage col_scheme)                   (hang (coloured (Col.sHeader col_scheme) header) 4                         msg)    where-    sevText =-      case severity of-        SevWarning -> text "warning:"-        SevError   -> text "error:"-        SevFatal   -> text "fatal:"-        _          -> empty+    msgText =+      case msg_class of+        MCDiagnostic SevError _reason   -> text "error:"+        MCDiagnostic SevWarning _reason -> text "warning:"+        MCFatal                         -> text "fatal:"+        _                               -> empty -getSeverityColour :: Severity -> Col.Scheme -> Col.PprColour-getSeverityColour SevWarning = Col.sWarning-getSeverityColour SevError   = Col.sError-getSeverityColour SevFatal   = Col.sFatal-getSeverityColour _          = const mempty+getMessageClassColour :: MessageClass -> Col.Scheme -> Col.PprColour+getMessageClassColour (MCDiagnostic SevError _reason)   = Col.sError+getMessageClassColour (MCDiagnostic SevWarning _reason) = Col.sWarning+getMessageClassColour MCFatal                           = Col.sFatal+getMessageClassColour _                                 = const mempty -getCaretDiagnostic :: Severity -> SrcSpan -> IO SDoc+getCaretDiagnostic :: MessageClass -> SrcSpan -> IO SDoc getCaretDiagnostic _ (UnhelpfulSpan _) = pure empty-getCaretDiagnostic severity (RealSrcSpan span _) =+getCaretDiagnostic msg_class (RealSrcSpan span _) =   caretDiagnostic <$> getSrcLine (srcSpanFile span) row   where     getSrcLine fn i =       getLine i (unpackFS fn)-        `catchIOError` \_ ->+        `catchException` \(_ :: IOError) ->           pure Nothing      getLine i fn = do@@ -286,7 +509,7 @@     caretDiagnostic Nothing = empty     caretDiagnostic (Just srcLineWithNewline) =       sdocOption sdocColScheme$ \col_scheme ->-      let sevColour = getSeverityColour severity col_scheme+      let sevColour = getMessageClassColour msg_class col_scheme           marginColour = Col.sMargin col_scheme       in       coloured marginColour (text marginSpace) <>@@ -327,61 +550,55 @@                       | otherwise = ""         caretLine = replicate start ' ' ++ replicate width '^' ++ caretEllipsis -makeIntoWarning :: WarnReason -> MsgEnvelope e -> MsgEnvelope e-makeIntoWarning reason err = err-    { errMsgSeverity = SevWarning-    , errMsgReason = reason }- ----- Creating MsgEnvelope(s)+-- Queries -- -mk_err_msg-  :: Severity -> SrcSpan -> PrintUnqualified -> e -> MsgEnvelope e-mk_err_msg sev locn print_unqual err- = MsgEnvelope { errMsgSpan = locn-               , errMsgContext = print_unqual-               , errMsgDiagnostic = err-               , errMsgSeverity = sev-               , errMsgReason = NoReason }--mkErr :: SrcSpan -> PrintUnqualified -> e -> MsgEnvelope e-mkErr = mk_err_msg SevError--mkLongMsgEnvelope, mkLongWarnMsg   :: SrcSpan -> PrintUnqualified -> SDoc -> SDoc -> MsgEnvelope DecoratedSDoc--- ^ A long (multi-line) error message-mkMsgEnvelope, mkWarnMsg           :: SrcSpan -> PrintUnqualified -> SDoc         -> MsgEnvelope DecoratedSDoc--- ^ A short (one-line) error message-mkPlainMsgEnvelope, mkPlainWarnMsg :: SrcSpan ->                     SDoc         -> MsgEnvelope DecoratedSDoc--- ^ Variant that doesn't care about qualified/unqualified names+{- Note [Intrinsic And Extrinsic Failures]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We distinguish between /intrinsic/ and /extrinsic/ failures. We classify in+the former category those diagnostics which are /essentially/ failures, and+their nature can't be changed. This is the case for 'ErrorWithoutFlag'. We+classify as /extrinsic/ all those diagnostics (like fatal warnings) which are+born as warnings but which are still failures under particular 'DynFlags'+settings. It's important to be aware of such logic distinction, because when+we are inside the typechecker or the desugarer, we are interested about+intrinsic errors, and to bail out as soon as we find one of them. Conversely,+if we find an /extrinsic/ one, for example because a particular 'WarningFlag'+makes a warning into an error, we /don't/ want to bail out, that's still not the+right time to do so: Rather, we want to first collect all the diagnostics, and+later classify and report them appropriately (in the driver).+-} -mkLongMsgEnvelope   locn unqual msg extra = mk_err_msg SevError   locn unqual        (mkDecorated [msg,extra])-mkMsgEnvelope       locn unqual msg       = mk_err_msg SevError   locn unqual        (mkDecorated [msg])-mkPlainMsgEnvelope  locn        msg       = mk_err_msg SevError   locn alwaysQualify (mkDecorated [msg])-mkLongWarnMsg       locn unqual msg extra = mk_err_msg SevWarning locn unqual        (mkDecorated [msg,extra])-mkWarnMsg           locn unqual msg       = mk_err_msg SevWarning locn unqual        (mkDecorated [msg])-mkPlainWarnMsg      locn        msg       = mk_err_msg SevWarning locn alwaysQualify (mkDecorated [msg])+-- | Returns 'True' if this is, intrinsically, a failure. See+-- Note [Intrinsic And Extrinsic Failures].+isIntrinsicErrorMessage :: Diagnostic e => MsgEnvelope e -> Bool+isIntrinsicErrorMessage = (==) ErrorWithoutFlag . diagnosticReason . errMsgDiagnostic ------ Queries---+isWarningMessage :: Diagnostic e => MsgEnvelope e -> Bool+isWarningMessage = not . isIntrinsicErrorMessage -isErrorMessage :: MsgEnvelope e -> Bool-isErrorMessage = (== SevError) . errMsgSeverity+-- | Are there any hard errors here? -Werror warnings are /not/ detected. If+-- you want to check for -Werror warnings, use 'errorsOrFatalWarningsFound'.+errorsFound :: Diagnostic e => Messages e -> Bool+errorsFound (Messages msgs) = any isIntrinsicErrorMessage msgs -isWarningMessage :: MsgEnvelope e -> Bool-isWarningMessage = not . isErrorMessage+-- | Returns 'True' if the envelope contains a message that will stop+-- compilation: either an intrinsic error or a fatal (-Werror) warning+isExtrinsicErrorMessage :: MsgEnvelope e -> Bool+isExtrinsicErrorMessage = (==) SevError . errMsgSeverity -errorsFound :: Messages e -> Bool-errorsFound (Messages msgs) = any isErrorMessage msgs+-- | Are there any errors or -Werror warnings here?+errorsOrFatalWarningsFound :: Messages e -> Bool+errorsOrFatalWarningsFound (Messages msgs) = any isExtrinsicErrorMessage msgs -getWarningMessages :: Messages e -> Bag (MsgEnvelope e)+getWarningMessages :: Diagnostic e => Messages e -> Bag (MsgEnvelope e) getWarningMessages (Messages xs) = fst $ partitionBag isWarningMessage xs -getErrorMessages :: Messages e -> Bag (MsgEnvelope e)-getErrorMessages (Messages xs) = fst $ partitionBag isErrorMessage xs+getErrorMessages :: Diagnostic e => Messages e -> Bag (MsgEnvelope e)+getErrorMessages (Messages xs) = fst $ partitionBag isIntrinsicErrorMessage xs --- | Partitions the 'Messages' and returns a tuple which first element are the warnings, and the--- second the errors.-partitionMessages :: Messages e -> (Bag (MsgEnvelope e), Bag (MsgEnvelope e))-partitionMessages (Messages xs) = partitionBag isWarningMessage xs+-- | Partitions the 'Messages' and returns a tuple which first element are the+-- warnings, and the second the errors.+partitionMessages :: Diagnostic e => Messages e -> (Messages e, Messages e)+partitionMessages (Messages xs) = bimap Messages Messages (partitionBag isWarningMessage xs)
GHC/Types/ForeignCall.hs view
@@ -71,7 +71,7 @@                       --     * No blocking                       --     * No precise exceptions                       ---  deriving ( Eq, Show, Data )+  deriving ( Eq, Show, Data, Enum )         -- Show used just for Show Lex.Token, I think  instance Outputable Safety where@@ -99,7 +99,7 @@ data CExportSpec   = CExportStatic               -- foreign export ccall foo :: ty         SourceText              -- of the CLabelString.-                                -- See note [Pragma source text] in GHC.Types.SourceText+                                -- See Note [Pragma source text] in GHC.Types.SourceText         CLabelString            -- C Name of exported function         CCallConv   deriving Data@@ -117,7 +117,7 @@   -- An "unboxed" ccall# to named function in a particular package.   = StaticTarget         SourceText                -- of the CLabelString.-                                  -- See note [Pragma source text] in GHC.Types.SourceText+                                  -- See Note [Pragma source text] in GHC.Types.SourceText         CLabelString                    -- C-land name of label.          (Maybe Unit)                    -- What package the function is in.@@ -153,9 +153,14 @@ See: http://www.programmersheaven.com/2/Calling-conventions -} --- any changes here should be replicated in  the CallConv type in template haskell-data CCallConv = CCallConv | CApiConv | StdCallConv | PrimCallConv | JavaScriptCallConv-  deriving (Eq, Data)+-- any changes here should be replicated in the CallConv type in template haskell+data CCallConv+  = CCallConv+  | CApiConv+  | StdCallConv+  | PrimCallConv+  | JavaScriptCallConv+  deriving (Eq, Data, Enum)  instance Outputable CCallConv where   ppr StdCallConv = text "stdcall"@@ -241,7 +246,7 @@ --        'GHC.Parser.Annotation.AnnHeader','GHC.Parser.Annotation.AnnVal', --        'GHC.Parser.Annotation.AnnClose' @'\#-}'@, --- For details on above see note [exact print annotations] in "GHC.Parser.Annotation"+-- For details on above see Note [exact print annotations] in "GHC.Parser.Annotation" data CType = CType SourceText -- Note [Pragma source text] in GHC.Types.SourceText                    (Maybe Header) -- header to include for this type                    (SourceText,FastString) -- the type itself
GHC/Types/ForeignStubs.hs view
@@ -4,29 +4,74 @@    ( ForeignStubs (..)    , CHeader(..)    , CStub(..)+   , initializerCStub+   , finalizerCStub    , appendStubC    ) where +import {-# SOURCE #-} GHC.Cmm.CLabel++import GHC.Platform import GHC.Utils.Outputable+import Data.List ((++)) import Data.Monoid import Data.Semigroup import Data.Coerce -newtype CStub = CStub { getCStub :: SDoc }+data CStub = CStub { getCStub :: SDoc+                   , getInitializers :: [CLabel]+                     -- ^ Initializers to be run at startup+                     -- See Note [Initializers and finalizers in Cmm] in+                     -- "GHC.Cmm.InitFini".+                   , getFinalizers :: [CLabel]+                     -- ^ Finalizers to be run at shutdown+                   }  emptyCStub :: CStub-emptyCStub = CStub empty+emptyCStub = CStub empty [] []  instance Monoid CStub where   mempty = emptyCStub-  mconcat = coerce vcat  instance Semigroup CStub where-  (<>) = coerce ($$)+  CStub a0 b0 c0 <> CStub a1 b1 c1 =+      CStub (a0 $$ a1) (b0 ++ b1) (c0 ++ c1) +functionCStub :: Platform -> CLabel -> SDoc -> SDoc -> CStub+functionCStub platform clbl declarations body =+    CStub body' [] []+  where+    body' = vcat+        [ declarations+        , hsep [text "void", pprCLabel platform CStyle clbl, text "(void)"]+        , braces body+        ]++-- | @initializerCStub fn_nm decls body@ is a 'CStub' containing C initializer+-- function (e.g. an entry of the @.init_array@ section) named+-- @fn_nm@ with the given body and the given set of declarations.+initializerCStub :: Platform -> CLabel -> SDoc -> SDoc -> CStub+initializerCStub platform clbl declarations body =+    functionCStub platform clbl declarations body+    `mappend` CStub empty [clbl] []++-- | @finalizerCStub fn_nm decls body@ is a 'CStub' containing C finalizer+-- function (e.g. an entry of the @.fini_array@ section) named+-- @fn_nm@ with the given body and the given set of declarations.+finalizerCStub :: Platform -> CLabel -> SDoc -> SDoc -> CStub+finalizerCStub platform clbl declarations body =+    functionCStub platform clbl declarations body+    `mappend` CStub empty [] [clbl]+ newtype CHeader = CHeader { getCHeader :: SDoc }-  deriving (Monoid, Semigroup) via CStub++instance Monoid CHeader where+  mempty = CHeader empty+  mconcat = coerce vcat++instance Semigroup CHeader where+    (<>) = coerce ($$)  -- | Foreign export stubs data ForeignStubs
+ GHC/Types/Hint.hs view
@@ -0,0 +1,538 @@+{-# LANGUAGE ExistentialQuantification #-}++module GHC.Types.Hint (+    GhcHint(..)+  , AvailableBindings(..)+  , InstantiationSuggestion(..)+  , LanguageExtensionHint(..)+  , ImportSuggestion(..)+  , HowInScope(..)+  , SimilarName(..)+  , StarIsType(..)+  , UntickedPromotedThing(..)+  , pprUntickedConstructor, isBareSymbol+  , suggestExtension+  , suggestExtensionWithInfo+  , suggestExtensions+  , suggestExtensionsWithInfo+  , suggestAnyExtension+  , suggestAnyExtensionWithInfo+  , useExtensionInOrderTo+  , noStarIsTypeHints+  ) where++import GHC.Prelude++import qualified Data.List.NonEmpty as NE++import GHC.Utils.Outputable+import qualified GHC.LanguageExtensions as LangExt+import Data.Typeable+import GHC.Unit.Module (ModuleName, Module)+import GHC.Hs.Extension (GhcTc)+import GHC.Core.Coercion+import GHC.Types.Fixity (LexicalFixity(..))+import GHC.Types.Name (Name, NameSpace, OccName (occNameFS), isSymOcc, nameOccName)+import GHC.Types.Name.Reader (RdrName (Unqual), ImpDeclSpec)+import GHC.Types.SrcLoc (SrcSpan)+import GHC.Types.Basic (Activation, RuleName)+import GHC.Parser.Errors.Basic+import {-# SOURCE #-} Language.Haskell.Syntax.Expr+import GHC.Unit.Module.Imported (ImportedModsVal)+import GHC.Data.FastString (fsLit)+  -- This {-# SOURCE #-} import should be removable once+  -- 'Language.Haskell.Syntax.Bind' no longer depends on 'GHC.Tc.Types.Evidence'.++-- | The bindings we have available in scope when+-- suggesting an explicit type signature.+data AvailableBindings+  = NamedBindings  (NE.NonEmpty Name)+  | UnnamedBinding+  -- ^ An unknown binding (i.e. too complicated to turn into a 'Name')++data LanguageExtensionHint+  = -- | Suggest to enable the input extension. This is the hint that+    -- GHC emits if this is not a \"known\" fix, i.e. this is GHC giving+    -- its best guess on what extension might be necessary to make a+    -- certain program compile. For example, GHC might suggests to+    -- enable 'BlockArguments' when the user simply formatted incorrectly+    -- the input program, so GHC here is trying to be as helpful as+    -- possible.+    -- If the input 'SDoc' is not empty, it will contain some extra+    -- information about the why the extension is required, but+    -- it's totally irrelevant/redundant for IDEs and other tools.+     SuggestSingleExtension !SDoc !LangExt.Extension+    -- | Suggest to enable the input extensions. The list+    -- is to be intended as /disjuctive/ i.e. the user is+    -- suggested to enable /any/ of the extensions listed. If+    -- the input 'SDoc' is not empty, it will contain some extra+    -- information about the why the extensions are required, but+    -- it's totally irrelevant/redundant for IDEs and other tools.+  | SuggestAnyExtension !SDoc [LangExt.Extension]+    -- | Suggest to enable the input extensions. The list+    -- is to be intended as /conjunctive/ i.e. the user is+    -- suggested to enable /all/ the extensions listed. If+    -- the input 'SDoc' is not empty, it will contain some extra+    -- information about the why the extensions are required, but+    -- it's totally irrelevant/redundant for IDEs and other tools.+  | SuggestExtensions !SDoc [LangExt.Extension]+    -- | Suggest to enable the input extension in order to fix+    -- a certain problem. This is the suggestion that GHC emits when+    -- is more-or-less clear \"what's going on\". For example, if+    -- both 'DeriveAnyClass' and 'GeneralizedNewtypeDeriving' are+    -- turned on, the right thing to do is to enabled 'DerivingStrategies',+    -- so in contrast to 'SuggestSingleExtension' GHC will be a bit more+    -- \"imperative\" (i.e. \"Use X Y Z in order to ... \").+    -- If the input 'SDoc' is not empty, it will contain some extra+    -- information about the why the extensions are required, but+    -- it's totally irrelevant/redundant for IDEs and other tools.+  | SuggestExtensionInOrderTo !SDoc !LangExt.Extension++-- | Suggests a single extension without extra user info.+suggestExtension :: LangExt.Extension -> GhcHint+suggestExtension ext = SuggestExtension (SuggestSingleExtension empty ext)++-- | Like 'suggestExtension' but allows supplying extra info for the user.+suggestExtensionWithInfo :: SDoc -> LangExt.Extension -> GhcHint+suggestExtensionWithInfo extraInfo ext = SuggestExtension (SuggestSingleExtension extraInfo ext)++-- | Suggests to enable /every/ extension in the list.+suggestExtensions :: [LangExt.Extension] -> GhcHint+suggestExtensions exts = SuggestExtension (SuggestExtensions empty exts)++-- | Like 'suggestExtensions' but allows supplying extra info for the user.+suggestExtensionsWithInfo :: SDoc -> [LangExt.Extension] -> GhcHint+suggestExtensionsWithInfo extraInfo exts = SuggestExtension (SuggestExtensions extraInfo exts)++-- | Suggests to enable /any/ extension in the list.+suggestAnyExtension :: [LangExt.Extension] -> GhcHint+suggestAnyExtension exts = SuggestExtension (SuggestAnyExtension empty exts)++-- | Like 'suggestAnyExtension' but allows supplying extra info for the user.+suggestAnyExtensionWithInfo :: SDoc -> [LangExt.Extension] -> GhcHint+suggestAnyExtensionWithInfo extraInfo exts = SuggestExtension (SuggestAnyExtension extraInfo exts)++useExtensionInOrderTo :: SDoc -> LangExt.Extension -> GhcHint+useExtensionInOrderTo extraInfo ext = SuggestExtension (SuggestExtensionInOrderTo extraInfo ext)++-- | A type for hints emitted by GHC.+-- A /hint/ suggests a possible way to deal with a particular warning or error.+data GhcHint+  =+    {-| An \"unknown\" hint. This type constructor allows arbitrary+    -- hints to be embedded. The typical use case would be GHC plugins+    -- willing to emit hints alongside their custom diagnostics.+    -}+    forall a. (Outputable a, Typeable a) => UnknownHint a+    {-| Suggests adding a particular language extension. GHC will do its best trying+        to guess when the user is using the syntax of a particular language extension+        without having the relevant extension enabled.++        Example: If the user uses the keyword \"mdo\" (and we are in a monadic block), but+        the relevant extension is not enabled, GHC will emit a 'SuggestExtension RecursiveDo'.++        Test case(s): parser/should_fail/T12429, parser/should_fail/T8501c,+                      parser/should_fail/T18251e, ... (and many more)++    -}+  | SuggestExtension !LanguageExtensionHint+    {-| Suggests that a monadic code block is probably missing a \"do\" keyword.++        Example:+            main =+              putStrLn "hello"+              putStrLn "world"++        Test case(s): parser/should_fail/T8501a, parser/should_fail/readFail007,+                      parser/should_fail/InfixAppPatErr, parser/should_fail/T984+    -}+  | SuggestMissingDo+    {-| Suggests that a \"let\" expression is needed in a \"do\" block.++       Test cases: None (that explicitly test this particular hint is emitted).+    -}+  | SuggestLetInDo+    {-| Suggests to add an \".hsig\" signature file to the Cabal manifest.++      Triggered by: 'GHC.Driver.Errors.Types.DriverUnexpectedSignature', if Cabal+                    is being used.++      Example: See comment of 'DriverUnexpectedSignature'.++      Test case(s): driver/T12955++    -}+  | SuggestAddSignatureCabalFile !ModuleName+    {-| Suggests to explicitly list the instantiations for the signatures in+        the GHC invocation command.++      Triggered by: 'GHC.Driver.Errors.Types.DriverUnexpectedSignature', if Cabal+                    is /not/ being used.++      Example: See comment of 'DriverUnexpectedSignature'.++      Test case(s): driver/T12955+    -}+  | SuggestSignatureInstantiations !ModuleName [InstantiationSuggestion]+    {-| Suggests to use spaces instead of tabs.++        Triggered by: 'GHC.Parser.Errors.Types.PsWarnTab'.++        Examples: None+        Test Case(s): None+    -}+  | SuggestUseSpaces+    {-| Suggests adding a whitespace after the given symbol.++        Examples: None+        Test Case(s): parser/should_compile/T18834a.hs+    -}+  | SuggestUseWhitespaceAfter !OperatorWhitespaceSymbol+    {-| Suggests adding a whitespace around the given operator symbol,+        as it might be repurposed as special syntax by a future language extension.+        The second parameter is how such operator occurred, if in a prefix, suffix+        or tight infix position.++        Triggered by: 'GHC.Parser.Errors.Types.PsWarnOperatorWhitespace'.++        Example:+          h a b = a+b -- not OK, no spaces around '+'.++        Test Case(s): parser/should_compile/T18834b.hs+    -}+  | SuggestUseWhitespaceAround !String !OperatorWhitespaceOccurrence+    {-| Suggests wrapping an expression in parentheses++        Examples: None+        Test Case(s): None+    -}+  | SuggestParentheses+    {-| Suggests to increase the -fmax-pmcheck-models limit for the pattern match checker.++      Triggered by: 'GHC.HsToCore.Errors.Types.DsMaxPmCheckModelsReached'++      Test case(s): pmcheck/should_compile/TooManyDeltas+                    pmcheck/should_compile/TooManyDeltas+                    pmcheck/should_compile/T11822+    -}+  | SuggestIncreaseMaxPmCheckModels+    {-| Suggests adding a type signature, typically to resolve ambiguity or help GHC inferring types.++    -}+  | SuggestAddTypeSignatures AvailableBindings+    {-| Suggests to explicitly discard the result of a monadic action by binding the result to+        the '_' wilcard.++        Example:+           main = do+             _ <- getCurrentTime++    -}+  | SuggestBindToWildcard !(LHsExpr GhcTc)++  | SuggestAddInlineOrNoInlinePragma !Var !Activation++  | SuggestAddPhaseToCompetingRule !RuleName+    {-| Suggests adding an identifier to the export list of a signature.+    -}+  | SuggestAddToHSigExportList !Name !(Maybe Module)+    {-| Suggests increasing the limit for the number of iterations in the simplifier.++    -}+  | SuggestIncreaseSimplifierIterations+    {-| Suggests to explicitly import 'Type' from the 'Data.Kind' module, because+        using "*" to mean 'Data.Kind.Type' relies on the StarIsType extension, which+        will become deprecated in the future.++        Triggered by: 'GHC.Parser.Errors.Types.PsWarnStarIsType'+        Example: None+        Test case(s): wcompat-warnings/WCompatWarningsOn.hs++    -}+  | SuggestUseTypeFromDataKind (Maybe RdrName)++    {-| Suggests placing the 'qualified' keyword /after/ the module name.++        Triggered by: 'GHC.Parser.Errors.Types.PsWarnImportPreQualified'+        Example: None+        Test case(s): module/mod184.hs++    -}+  | SuggestQualifiedAfterModuleName++    {-| Suggests using TemplateHaskell quotation syntax.++        Triggered by: 'GHC.Parser.Errors.Types.PsErrEmptyDoubleQuotes' only if TemplateHaskell+                      is enabled.+        Example: None+        Test case(s): parser/should_fail/T13450TH.hs++    -}+  | SuggestThQuotationSyntax++    {-| Suggests alternative roles in case we found an illegal one.++        Triggered by: 'GHC.Parser.Errors.Types.PsErrIllegalRoleName'+        Example: None+        Test case(s): roles/should_fail/Roles7.hs++    -}+  | SuggestRoles [Role]++    {-| Suggests qualifying the '*' operator in modules where StarIsType is enabled.++        Triggered by: 'GHC.Parser.Errors.Types.PsWarnStarBinder'+        Test case(s): warnings/should_compile/StarBinder.hs+    -}+  | SuggestQualifyStarOperator++    {-| Suggests that a type signature should have form <variable> :: <type>+        in order to be accepted by GHC.++        Triggered by: 'GHC.Parser.Errors.Types.PsErrInvalidTypeSignature'+        Test case(s): parser/should_fail/T3811+    -}+  | SuggestTypeSignatureForm++    {-| Suggests to move an orphan instance or to newtype-wrap it.++        Triggered by: 'GHC.Tc.Errors.Types.TcRnOrphanInstance'+        Test cases(s): warnings/should_compile/T9178+                       typecheck/should_compile/T4912+    -}+  | SuggestFixOrphanInstance++    {-| Suggests to use a standalone deriving declaration when GHC+        can't derive a typeclass instance in a trivial way.++        Triggered by: 'GHC.Tc.Errors.Types.DerivBadErrConstructor'+        Test cases(s): typecheck/should_fail/tcfail086+    -}+  | SuggestAddStandaloneDerivation++    {-| Suggests the user to fill in the wildcard constraint to+        disambiguate which constraint that is.++        Example:+          deriving instance _ => Eq (Foo f a)++        Triggered by: 'GHC.Tc.Errors.Types.DerivBadErrConstructor'+        Test cases(s): partial-sigs/should_fail/T13324_fail2+    -}+  | SuggestFillInWildcardConstraint++  {-| Suggests to use an identifier other than 'forall'+      Triggered by: 'GHC.Tc.Errors.Types.TcRnForallIdentifier'+  -}+  | SuggestRenameForall++    {-| Suggests to use the appropriate Template Haskell tick:+        a single tick for a term-level 'NameSpace', or a double tick+        for a type-level 'NameSpace'.++        Triggered by: 'GHC.Tc.Errors.Types.TcRnIncorrectNameSpace'.+    -}+  | SuggestAppropriateTHTick NameSpace++  {-| Suggests enabling -ddump-splices to help debug an issue+      when a 'Name' is not in scope or is used in multiple+      different namespaces (e.g. both as a data constructor+      and a type constructor).++      Concomitant with 'NoExactName' or 'SameName' errors,+      see e.g. "GHC.Rename.Env.lookupExactOcc_either".+      Test cases: T5971, T7241, T13937.+   -}+  | SuggestDumpSlices++  {-| Suggests adding a tick to refer to something which has been+      promoted to the type level, e.g. a data constructor.++      Test cases: T9778, T19984.+  -}+  | SuggestAddTick UntickedPromotedThing++  {-| Something is split off from its corresponding declaration.+      For example, a datatype is given a role declaration+      in a different module.++      Test cases: T495, T8485, T2713, T5533.+   -}+  | SuggestMoveToDeclarationSite+      -- TODO: remove the SDoc argument.+      SDoc -- ^ fixity declaration, role annotation, type signature, ...+      RdrName -- ^ the 'RdrName' for the declaration site++  {-| Suggest a similar name that the user might have meant,+      e.g. suggest 'traverse' when the user has written @travrese@.++      Test case: mod73.+  -}+  | SuggestSimilarNames RdrName (NE.NonEmpty SimilarName)++  {-| Remind the user that the field selector has been suppressed+      because of -XNoFieldSelectors.++      Test cases: NFSSuppressed, records-nofieldselectors.+  -}+  | RemindFieldSelectorSuppressed+      { suppressed_selector :: RdrName+      , suppressed_parents  :: [Name] }++  {-| Suggest importing from a module, removing a @hiding@ clause,+      or explain to the user that we couldn't find a module+      with the given 'ModuleName'.++      Test cases: mod28, mod36, mod87, mod114, ...+  -}+  | ImportSuggestion ImportSuggestion++    {-| Suggest importing a data constructor to bring it into scope+        Triggered by: 'GHC.Tc.Errors.Types.TcRnTypeCannotBeMarshaled'++        Test cases: ccfail004+    -}+  | SuggestImportingDataCon++  {- Found a pragma in the body of a module, suggest+     placing it in the header+  -}+  | SuggestPlacePragmaInHeader++-- | An 'InstantiationSuggestion' for a '.hsig' file. This is generated+-- by GHC in case of a 'DriverUnexpectedSignature' and suggests a way+-- to instantiate a particular signature, where the first argument is+-- the signature name and the second is the module where the signature+-- was defined.+-- Example:+--+-- src/MyStr.hsig:2:11: error:+--     Unexpected signature: ‘MyStr’+--     (Try passing -instantiated-with="MyStr=<MyStr>"+--      replacing <MyStr> as necessary.)+data InstantiationSuggestion = InstantiationSuggestion !ModuleName !Module++-- | Suggest how to fix an import.+data ImportSuggestion+  -- | Some module exports what we want, but we aren't explicitly importing it.+  = CouldImportFrom (NE.NonEmpty (Module, ImportedModsVal)) OccName+  -- | Some module exports what we want, but we are explicitly hiding it.+  | CouldUnhideFrom (NE.NonEmpty (Module, ImportedModsVal)) OccName++-- | Explain how something is in scope.+data HowInScope+  -- | It was locally bound at this particular source location.+  = LocallyBoundAt SrcSpan+  -- | It was imported by this particular import declaration.+  | ImportedBy ImpDeclSpec++data SimilarName+  = SimilarName Name+  | SimilarRdrName RdrName HowInScope++-- | Something is promoted to the type-level without a promotion tick.+data UntickedPromotedThing+  = UntickedConstructor LexicalFixity Name+  | UntickedExplicitList++pprUntickedConstructor :: LexicalFixity -> Name -> SDoc+pprUntickedConstructor fixity nm =+  case fixity of+    Prefix -> pprPrefixVar is_op ppr_nm -- e.g. (:) and '(:)+    Infix  -> pprInfixVar  is_op ppr_nm -- e.g. `Con` and '`Con`+  where+    ppr_nm = ppr nm+    is_op = isSymOcc (nameOccName nm)++-- | Whether a constructor name is printed out as a bare symbol, e.g. @:@.+--+-- True for symbolic names in infix position.+--+-- Used for pretty-printing.+isBareSymbol :: LexicalFixity -> Name -> Bool+isBareSymbol fixity nm+  | isSymOcc (nameOccName nm)+  , Infix <- fixity+  = True+  | otherwise+  = False++--------------------------------------------------------------------------------++-- | Whether '*' is a synonym for 'Data.Kind.Type'.+data StarIsType+  = StarIsNotType+  | StarIsType++-- | Display info about the treatment of '*' under NoStarIsType.+--+-- With StarIsType, three properties of '*' hold:+--+--   (a) it is not an infix operator+--   (b) it is always in scope+--   (c) it is a synonym for Data.Kind.Type+--+-- However, the user might not know that they are working on a module with+-- NoStarIsType and write code that still assumes (a), (b), and (c), which+-- actually do not hold in that module.+--+-- Violation of (a) shows up in the parser. For instance, in the following+-- examples, we have '*' not applied to enough arguments:+--+--   data A :: *+--   data F :: * -> *+--+-- Violation of (b) or (c) show up in the renamer and the typechecker+-- respectively. For instance:+--+--   type K = Either * Bool+--+-- This will parse differently depending on whether StarIsType is enabled,+-- but it will parse nonetheless. With NoStarIsType it is parsed as a type+-- operator, thus we have ((*) Either Bool). Now there are two cases to+-- consider:+--+--   1. There is no definition of (*) in scope. In this case the renamer will+--      fail to look it up. This is a violation of assumption (b).+--+--   2. There is a definition of the (*) type operator in scope (for example+--      coming from GHC.TypeNats). In this case the user will get a kind+--      mismatch error. This is a violation of assumption (c).+--+-- The user might unknowingly be working on a module with NoStarIsType+-- or use '*' as 'Data.Kind.Type' out of habit. So it is important to give a+-- hint whenever an assumption about '*' is violated. Unfortunately, it is+-- somewhat difficult to deal with (c), so we limit ourselves to (a) and (b).+--+-- 'noStarIsTypeHints' returns appropriate hints to the user depending on the+-- extensions enabled in the module and the name that triggered the error.+-- That is, if we have NoStarIsType and the error is related to '*' or its+-- Unicode variant, we will suggest using 'Data.Kind.Type'; otherwise we won't+-- suggest anything.+noStarIsTypeHints :: StarIsType -> RdrName -> [GhcHint]+noStarIsTypeHints is_star_type rdr_name+  -- One might ask: if can use `sdocOption sdocStarIsType` here, why bother to+  -- take star_is_type as input? Why not refactor?+  --+  -- The reason is that `sdocOption sdocStarIsType` would indicate that+  -- StarIsType is enabled in the module that tries to load the problematic+  -- definition, not in the module that is being loaded.+  --+  -- So if we have 'data T :: *' in a module with NoStarIsType, then the hint+  -- must be displayed even if we load this definition from a module (or GHCi)+  -- with StarIsType enabled!+  --+  | isUnqualStar+  , StarIsNotType <- is_star_type+  = [SuggestUseTypeFromDataKind (Just rdr_name)]+  | otherwise+  = []+  where+    -- Does rdr_name look like the user might have meant the '*' kind by it?+    -- We focus on unqualified stars specifically, because qualified stars are+    -- treated as type operators even under StarIsType.+    isUnqualStar+      | Unqual occName <- rdr_name+      = let fs = occNameFS occName+        in fs == fsLit "*" || fs == fsLit "★"+      | otherwise = False
+ GHC/Types/Hint/Ppr.hs view
@@ -0,0 +1,270 @@+{-# LANGUAGE LambdaCase #-}++{-# OPTIONS_GHC -Wno-orphans #-}   -- instance Outputable GhcHint++module GHC.Types.Hint.Ppr (+  perhapsAsPat+  -- also, and more interesting: instance Outputable GhcHint+  ) where++import GHC.Prelude++import GHC.Parser.Errors.Basic+import GHC.Types.Hint++import GHC.Hs.Expr ()   -- instance Outputable+import GHC.Types.Id+import GHC.Types.Name (NameSpace, pprDefinedAt, occNameSpace, pprNameSpace, isValNameSpace)+import GHC.Types.Name.Reader (RdrName,ImpDeclSpec (..), rdrNameOcc, rdrNameSpace)+import GHC.Types.SrcLoc (SrcSpan(..), srcSpanStartLine)+import GHC.Unit.Module.Imported (ImportedModsVal(..))+import GHC.Unit.Types+import GHC.Utils.Outputable++import Data.List (intersperse)+import qualified Data.List.NonEmpty as NE++instance Outputable GhcHint where+  ppr = \case+    UnknownHint m+      -> ppr m+    SuggestExtension extHint+      -> case extHint of+          SuggestSingleExtension extraUserInfo ext ->+            (text "Perhaps you intended to use" <+> ppr ext) $$ extraUserInfo+          SuggestAnyExtension extraUserInfo exts ->+            let header = text "Enable any of the following extensions:"+            in  header <+> hcat (intersperse (text ", ") (map ppr exts)) $$ extraUserInfo+          SuggestExtensions extraUserInfo exts ->+            let header = text "Enable all of the following extensions:"+            in  header <+> hcat (intersperse (text ", ") (map ppr exts)) $$ extraUserInfo+          SuggestExtensionInOrderTo extraUserInfo ext ->+            (text "Use" <+> ppr ext) $$ extraUserInfo+    SuggestMissingDo+      -> text "Possibly caused by a missing 'do'?"+    SuggestLetInDo+      -> text "Perhaps you need a 'let' in a 'do' block?"+           $$ text "e.g. 'let x = 5' instead of 'x = 5'"+    SuggestAddSignatureCabalFile pi_mod_name+      -> text "Try adding" <+> quotes (ppr pi_mod_name)+           <+> text "to the"+           <+> quotes (text "signatures")+           <+> text "field in your Cabal file."+    SuggestSignatureInstantiations pi_mod_name suggestions+      -> let suggested_instantiated_with =+               hcat (punctuate comma $+                   [ ppr k <> text "=" <> ppr v+                   | InstantiationSuggestion k v <- suggestions+                   ])+         in text "Try passing -instantiated-with=\"" <>+              suggested_instantiated_with <> text "\"" $$+                text "replacing <" <> ppr pi_mod_name <> text "> as necessary."+    SuggestUseSpaces+      -> text "Please use spaces instead."+    SuggestUseWhitespaceAfter sym+      -> text "Add whitespace after the"+           <+> quotes (pprOperatorWhitespaceSymbol sym) <> char '.'+    SuggestUseWhitespaceAround sym _occurrence+      -> text "Add whitespace around" <+> quotes (text sym) <> char '.'+    SuggestParentheses+      -> text "Use parentheses."+    SuggestIncreaseMaxPmCheckModels+      -> text "Increase the limit or resolve the warnings to suppress this message."+    SuggestAddTypeSignatures bindings+      -> case bindings of+          -- This might happen when we have bindings which are /too complicated/,+          -- see for example 'DsCannotMixPolyAndUnliftedBindings' in 'GHC.HsToCore.Errors.Types'.+          -- In this case, we emit a generic message.+          UnnamedBinding   -> text "Add a type signature."+          NamedBindings (x NE.:| xs) ->+            let nameList = case xs of+                  [] -> quotes . ppr $ x+                  _  -> pprWithCommas (quotes . ppr) xs <+> text "and" <+> quotes (ppr x)+            in hsep [ text "Consider giving"+                    , nameList+                    , text "a type signature"]+    SuggestBindToWildcard rhs+      -> hang (text "Suppress this warning by saying") 2 (quotes $ text "_ <-" <+> ppr rhs)+    SuggestAddInlineOrNoInlinePragma lhs_id rule_act+      -> vcat [ text "Add an INLINE[n] or NOINLINE[n] pragma for" <+> quotes (ppr lhs_id)+              , whenPprDebug (ppr (idInlineActivation lhs_id) $$ ppr rule_act)+              ]+    SuggestAddPhaseToCompetingRule bad_rule+      -> vcat [ text "Add phase [n] or [~n] to the competing rule"+              , whenPprDebug (ppr bad_rule) ]+    SuggestIncreaseSimplifierIterations+      -> text "Set limit with -fconstraint-solver-iterations=n; n=0 for no limit"+    SuggestUseTypeFromDataKind mb_rdr_name+      -> text "Use" <+> quotes (text "Type")+         <+> text "from" <+> quotes (text "Data.Kind") <+> text "instead."+         $$+           maybe empty+           (\rdr_name ->+             text "NB: with NoStarIsType, " <> quotes (ppr rdr_name)+             <+> text "is treated as a regular type operator.")+           mb_rdr_name++    SuggestQualifiedAfterModuleName+      -> text "Place" <+> quotes (text "qualified")+          <+> text "after the module name."+    SuggestThQuotationSyntax+      -> vcat [ text "Perhaps you intended to use quotation syntax of TemplateHaskell,"+              , text "but the type variable or constructor is missing"+              ]+    SuggestRoles nearby+      -> case nearby of+               []  -> empty+               [r] -> text "Perhaps you meant" <+> quotes (ppr r)+               -- will this last case ever happen??+               _   -> hang (text "Perhaps you meant one of these:")+                           2 (pprWithCommas (quotes . ppr) nearby)+    SuggestQualifyStarOperator+      -> text "To use (or export) this operator in"+            <+> text "modules with StarIsType,"+         $$ text "    including the definition module, you must qualify it."+    SuggestTypeSignatureForm+      -> text "A type signature should be of form <variables> :: <type>"+    SuggestAddToHSigExportList _name mb_mod+      -> let header = text "Try adding it to the export list of"+         in case mb_mod of+              Nothing -> header <+> text "the hsig file."+              Just mod -> header <+> ppr (moduleName mod) <> text "'s hsig file."+    SuggestFixOrphanInstance+      -> vcat [ text "Move the instance declaration to the module of the class or of the type, or"+              , text "wrap the type with a newtype and declare the instance on the new type."+              ]+    SuggestAddStandaloneDerivation+      -> text "Use a standalone deriving declaration instead"+    SuggestFillInWildcardConstraint+      -> text "Fill in the wildcard constraint yourself"+    SuggestRenameForall+      -> vcat [ text "Consider using another name, such as"+              , quotes (text "forAll") <> comma <+>+                quotes (text "for_all") <> comma <+> text "or" <+>+                quotes (text "forall_") <> dot ]+    SuggestAppropriateTHTick ns+      -> text "Perhaps use a" <+> how_many <+> text "tick"+        where+          how_many+            | isValNameSpace ns = text "single"+            | otherwise         = text "double"+    SuggestDumpSlices+      -> vcat [ text "If you bound a unique Template Haskell name (NameU)"+              , text "perhaps via newName,"+              , text "then -ddump-splices might be useful." ]+    SuggestAddTick (UntickedConstructor fixity name)+      -> hsep [ text "Use"+              , char '\'' <> con+              , text "instead of"+              , con <> mb_dot ]+        where+          con = pprUntickedConstructor fixity name+          mb_dot+            | isBareSymbol fixity name+            -- A final dot can be confusing for a symbol without parens, e.g.+            --+            --  * Use ': instead of :.+            = empty+            | otherwise+            = dot++    SuggestAddTick UntickedExplicitList+      -> text "Add a promotion tick, e.g." <+> text "'[x,y,z]" <> dot+    SuggestMoveToDeclarationSite what rdr_name+      -> text "Move the" <+> what <+> text "to the declaration site of"+         <+> quotes (ppr rdr_name) <> dot+    SuggestSimilarNames tried_rdr_name similar_names+      -> case similar_names of+            n NE.:| [] -> text "Perhaps use" <+> pp_item n+            _          -> sep [ text "Perhaps use one of these:"+                              , nest 2 (pprWithCommas pp_item $ NE.toList similar_names) ]+        where+          tried_ns = occNameSpace $ rdrNameOcc tried_rdr_name+          pp_item = pprSimilarName tried_ns+    RemindFieldSelectorSuppressed rdr_name parents+      -> text "Notice that" <+> quotes (ppr rdr_name)+         <+> text "is a field selector" <+> whose+         $$ text "that has been suppressed by NoFieldSelectors."+      where+        -- parents may be empty if this is a pattern synonym field without a selector+        whose | null parents = empty+              | otherwise    = text "belonging to the type" <> plural parents+                                 <+> pprQuotedList parents+    ImportSuggestion import_suggestion+      -> pprImportSuggestion import_suggestion+    SuggestImportingDataCon+      -> text "Import the data constructor to bring it into scope"+    SuggestPlacePragmaInHeader+      -> text "Perhaps you meant to place it in the module header?"+      $$ text "The module header is the section at the top of the file, before the" <+> quotes (text "module") <+> text "keyword"++perhapsAsPat :: SDoc+perhapsAsPat = text "Perhaps you meant an as-pattern, which must not be surrounded by whitespace"++-- | Pretty-print an 'ImportSuggestion'.+pprImportSuggestion :: ImportSuggestion -> SDoc+pprImportSuggestion (CouldImportFrom mods occ_name)+  | (mod, imv) NE.:| [] <- mods+  = fsep+      [ text "Perhaps you want to add"+      , quotes (ppr occ_name)+      , text "to the import list"+      , text "in the import of"+      , quotes (ppr mod)+      , parens (ppr (imv_span imv)) <> dot+      ]+  | otherwise+  = fsep+      [ text "Perhaps you want to add"+      , quotes (ppr occ_name)+      , text "to one of these import lists:"+      ]+    $$+    nest 2 (vcat+        [ quotes (ppr mod) <+> parens (ppr (imv_span imv))+        | (mod,imv) <- NE.toList mods+        ])+pprImportSuggestion (CouldUnhideFrom mods occ_name)+  | (mod, imv) NE.:| [] <- mods+  = fsep+      [ text "Perhaps you want to remove"+      , quotes (ppr occ_name)+      , text "from the explicit hiding list"+      , text "in the import of"+      , quotes (ppr mod)+      , parens (ppr (imv_span imv)) <> dot+      ]+  | otherwise+  = fsep+      [ text "Perhaps you want to remove"+      , quotes (ppr occ_name)+      , text "from the hiding clauses"+      , text "in one of these imports:"+      ]+    $$+    nest 2 (vcat+        [ quotes (ppr mod) <+> parens (ppr (imv_span imv))+        | (mod,imv) <- NE.toList mods+        ])++-- | Pretty-print a 'SimilarName'.+pprSimilarName :: NameSpace -> SimilarName -> SDoc+pprSimilarName _ (SimilarName name)+  = quotes (ppr name) <+> parens (pprDefinedAt name)+pprSimilarName tried_ns (SimilarRdrName rdr_name how_in_scope)+  = case how_in_scope of+      LocallyBoundAt loc ->+        pp_ns rdr_name <+> quotes (ppr rdr_name) <+> loc'+          where+            loc' = case loc of+              UnhelpfulSpan l -> parens (ppr l)+              RealSrcSpan l _ -> parens (text "line" <+> int (srcSpanStartLine l))+      ImportedBy is ->+        pp_ns rdr_name <+> quotes (ppr rdr_name) <+>+        parens (text "imported from" <+> ppr (is_mod is))++  where+    pp_ns :: RdrName -> SDoc+    pp_ns rdr | ns /= tried_ns = pprNameSpace ns+              | otherwise      = empty+      where ns = rdrNameSpace rdr
GHC/Types/IPE.hs view
@@ -1,5 +1,10 @@-module GHC.Types.IPE(DCMap, ClosureMap, InfoTableProvMap(..)-                    , emptyInfoTableProvMap) where+module GHC.Types.IPE (+    DCMap,+    ClosureMap,+    InfoTableProvMap(..),+    emptyInfoTableProvMap,+    IpeSourceLocation+) where  import GHC.Prelude @@ -10,11 +15,17 @@ import GHC.Types.Unique.Map import GHC.Core.Type import Data.List.NonEmpty+import GHC.Cmm.CLabel (CLabel)+import qualified Data.Map.Strict as Map +-- | Position and information about an info table.+-- For return frames these are the contents of a 'CoreSyn.SourceNote'.+type IpeSourceLocation = (RealSrcSpan, String)+ -- | A map from a 'Name' to the best approximate source position that -- name arose from. type ClosureMap = UniqMap Name  -- The binding-                          (Type, Maybe (RealSrcSpan, String))+                          (Type, Maybe IpeSourceLocation)                           -- The best approximate source position.                           -- (rendered type, source position, source note                           -- label)@@ -26,11 +37,15 @@ -- the constructor was used at, if possible and a string which names -- the source location. This is the same information as is the payload -- for the 'GHC.Core.SourceNote' constructor.-type DCMap = UniqMap DataCon (NonEmpty (Int, Maybe (RealSrcSpan, String)))+type DCMap = UniqMap DataCon (NonEmpty (Int, Maybe IpeSourceLocation)) +type InfoTableToSourceLocationMap = Map.Map CLabel (Maybe IpeSourceLocation)+ data InfoTableProvMap = InfoTableProvMap                           { provDC :: DCMap-                          , provClosure :: ClosureMap }+                          , provClosure :: ClosureMap+                          , provInfoTables :: InfoTableToSourceLocationMap+                          }  emptyInfoTableProvMap :: InfoTableProvMap-emptyInfoTableProvMap = InfoTableProvMap emptyUniqMap emptyUniqMap+emptyInfoTableProvMap = InfoTableProvMap emptyUniqMap emptyUniqMap Map.empty
GHC/Types/Id.hs view
@@ -5,8 +5,8 @@ \section[Id]{@Ids@: Value and constructor identifiers} -} -{-# LANGUAGE CPP #-} + -- | -- #name_types# -- GHC uses several kinds of name internally:@@ -56,7 +56,7 @@         setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo,         zapLamIdInfo, zapIdDemandInfo, zapIdUsageInfo, zapIdUsageEnvInfo,         zapIdUsedOnceInfo, zapIdTailCallInfo,-        zapFragileIdInfo, zapIdStrictness, zapStableUnfolding,+        zapFragileIdInfo, zapIdDmdSig, zapStableUnfolding,         transferPolyIdInfo, scaleIdBy, scaleVarBy,          -- ** Predicates on Ids@@ -74,7 +74,7 @@         isDataConWrapId, isDataConWrapId_maybe,         isDataConId_maybe,         idDataCon,-        isConLikeId, isDeadEndId, idIsFrom,+        isConLikeId, isWorkerLikeId, isDeadEndId, idIsFrom,         hasNoBinding,          -- ** Join variables@@ -99,10 +99,10 @@         idCafInfo, idLFInfo_maybe,         idOneShotInfo, idStateHackOneShotInfo,         idOccInfo,-        isNeverLevPolyId,+        isNeverRepPolyId,          -- ** Writing 'IdInfo' fields-        setIdUnfolding, setCaseBndrEvald,+        setIdUnfolding, zapIdUnfolding, setCaseBndrEvald,         setIdArity,         setIdCallArity, @@ -112,21 +112,25 @@         setIdLFInfo,          setIdDemandInfo,-        setIdStrictness,-        setIdCprInfo,+        setIdDmdSig,+        setIdCprSig,+        setIdCbvMarks,+        idCbvMarks_maybe,+        idCbvMarkArity,+        asWorkerLikeId, asNonWorkerLikeId,          idDemandInfo,-        idStrictness,-        idCprInfo,+        idDmdSig,+        idCprSig, +        idTagSig_maybe,+        setIdTagSig     ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Core ( CoreRule, isStableUnfolding, evaldUnfolding,-                 isCompulsoryUnfolding, Unfolding( NoUnfolding ) )+                 isCompulsoryUnfolding, Unfolding( NoUnfolding ), isEvaldUnfolding, hasSomeUnfolding, noUnfolding )  import GHC.Types.Id.Info import GHC.Types.Basic@@ -162,9 +166,10 @@ import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Utils.GlobalVars--import GHC.Driver.Ppr+import GHC.Utils.Trace+import GHC.Stg.InferTags.TagSig  -- infixl so you can say (id `set` a `set` b) infixl  1 `setIdUnfolding`,@@ -179,11 +184,12 @@           `idCafInfo`,            `setIdDemandInfo`,-          `setIdStrictness`,-          `setIdCprInfo`,+          `setIdDmdSig`,+          `setIdCprSig`,            `asJoinId`,-          `asJoinId_maybe`+          `asJoinId_maybe`,+          `setIdCbvMarks`  {- ************************************************************************@@ -239,7 +245,7 @@ -- Make an Id with the same unique and type as the -- incoming Id, but with an *Internal* Name and *LocalId* flavour localiseId id-  | ASSERT( isId id ) isLocalId id && isInternalName name+  | assert (isId id) $ isLocalId id && isInternalName name   = id   | otherwise   = Var.mkLocalVar (idDetails id) (localiseName name) (Var.varMult id) (idType id) (idInfo id)@@ -261,6 +267,11 @@ maybeModifyIdInfo (Just new_info) id = lazySetIdInfo id new_info maybeModifyIdInfo Nothing         id = id +-- maybeModifyIdInfo tries to avoid unnecessary thrashing+maybeModifyIdDetails :: Maybe IdDetails  -> Id -> Id+maybeModifyIdDetails (Just new_details) id = setIdDetails id new_details+maybeModifyIdDetails Nothing         id = id+ {- ************************************************************************ *                                                                      *@@ -298,19 +309,18 @@  -- | For an explanation of global vs. local 'Id's, see "GHC.Types.Var#globalvslocal" mkLocalId :: HasDebugCallStack => Name -> Mult -> Type -> Id-mkLocalId name w ty = ASSERT( not (isCoVarType ty) )-                      mkLocalIdWithInfo name w ty vanillaIdInfo+mkLocalId name w ty = mkLocalIdWithInfo name w (assert (not (isCoVarType ty)) ty) vanillaIdInfo  -- | Make a local CoVar mkLocalCoVar :: Name -> Type -> CoVar mkLocalCoVar name ty-  = ASSERT( isCoVarType ty )+  = assert (isCoVarType ty) $     Var.mkLocalVar CoVarId name Many ty vanillaIdInfo  -- | Like 'mkLocalId', but checks the type to see if it should make a covar mkLocalIdOrCoVar :: Name -> Mult -> Type -> Id mkLocalIdOrCoVar name w ty-  -- We should ASSERT(eqType w Many) in the isCoVarType case.+  -- We should assert (eqType w Many) in the isCoVarType case.   -- However, currently this assertion does not hold.   -- In tests with -fdefer-type-errors, such as T14584a,   -- we create a linear 'case' where the scrutinee is a coercion@@ -320,8 +330,8 @@      -- proper ids only; no covars! mkLocalIdWithInfo :: HasDebugCallStack => Name -> Mult -> Type -> IdInfo -> Id-mkLocalIdWithInfo name w ty info = ASSERT( not (isCoVarType ty) )-                                   Var.mkLocalVar VanillaId name w ty info+mkLocalIdWithInfo name w ty info =+  Var.mkLocalVar VanillaId name w (assert (not (isCoVarType ty)) ty) info         -- Note [Free type variables]  -- | Create a local 'Id' that is marked as exported.@@ -339,7 +349,7 @@ -- | Create a system local 'Id'. These are local 'Id's (see "Var#globalvslocal") -- that are created by the compiler out of thin air mkSysLocal :: FastString -> Unique -> Mult -> Type -> Id-mkSysLocal fs uniq w ty = ASSERT( not (isCoVarType ty) )+mkSysLocal fs uniq w ty = assert (not (isCoVarType ty)) $                         mkLocalId (mkSystemVarName uniq fs) w ty  -- | Like 'mkSysLocal', but checks to see if we have a covar type@@ -356,7 +366,7 @@  -- | Create a user local 'Id'. These are local 'Id's (see "GHC.Types.Var#globalvslocal") with a name and location that the user might recognize mkUserLocal :: OccName -> Unique -> Mult -> Type -> SrcSpan -> Id-mkUserLocal occ uniq w ty loc = ASSERT( not (isCoVarType ty) )+mkUserLocal occ uniq w ty loc = assert (not (isCoVarType ty)) $                                 mkLocalId (mkInternalName uniq occ loc) w ty  -- | Like 'mkUserLocal', but checks if we have a coercion type@@ -533,6 +543,15 @@                          DataConWrapId con -> Just con                          _                 -> Nothing +-- | An Id for which we might require all callers to pass strict arguments properly tagged + evaluated.+--+-- See Note [CBV Function Ids]+isWorkerLikeId :: Id -> Bool+isWorkerLikeId id = case Var.idDetails id of+  WorkerLikeId _  -> True+  JoinId _ Just{}   -> True+  _                 -> False+ isJoinId :: Var -> Bool -- It is convenient in GHC.Core.Opt.SetLevels.lvlMFE to apply isJoinId -- to the free vars of an expression, so it's convenient@@ -543,11 +562,12 @@                 _         -> False   | otherwise = False +-- | Doesn't return strictness marks isJoinId_maybe :: Var -> Maybe JoinArity isJoinId_maybe id- | isId id  = ASSERT2( isId id, ppr id )+ | isId id  = assertPpr (isId id) (ppr id) $               case Var.idDetails id of-                JoinId arity -> Just arity+                JoinId arity _marks -> Just arity                 _            -> Nothing  | otherwise = Nothing @@ -569,8 +589,20 @@                         PrimOpId _       -> True    -- See Note [Eta expanding primops] in GHC.Builtin.PrimOps                         FCallId _        -> True                         DataConWorkId dc -> isUnboxedTupleDataCon dc || isUnboxedSumDataCon dc-                        _                -> isCompulsoryUnfolding (idUnfolding id)-                                            -- See Note [Levity-polymorphic Ids]+                        _                -> isCompulsoryUnfolding (realIdUnfolding id)+  -- Note: this function must be very careful not to force+  -- any of the fields that aren't the 'uf_src' field of+  -- the 'Unfolding' of the 'Id'. This is because these fields are computed+  -- in terms of the 'uf_tmpl' field, which is not available+  -- until we have finished Core Lint for the unfolding, which calls 'hasNoBinding'+  -- in 'checkCanEtaExpand'.+  --+  -- In particular, calling 'idUnfolding' rather than 'realIdUnfolding' here can+  -- force the 'uf_tmpl' field, because 'trimUnfolding' forces the 'uf_is_value' field,+  -- and this field is usually computed in terms of the 'uf_tmpl' field,+  -- so we will force that as well.+  --+  -- See Note [Lazily checking Unfoldings] in GHC.IfaceToCore.  isImplicitId :: Id -> Bool -- ^ 'isImplicitId' tells whether an 'Id's info is implied by other@@ -592,26 +624,6 @@ idIsFrom :: Module -> Id -> Bool idIsFrom mod id = nameIsLocalOrFrom mod (idName id) -{- Note [Levity-polymorphic Ids]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Some levity-polymorphic Ids must be applied and inlined, not left-un-saturated.  Example:-  unsafeCoerceId :: forall r1 r2 (a::TYPE r1) (b::TYPE r2). a -> b--This has a compulsory unfolding because we can't lambda-bind those-arguments.  But the compulsory unfolding may leave levity-polymorphic-lambdas if it is not applied to enough arguments; e.g. (#14561)-  bad :: forall (a :: TYPE r). a -> a-  bad = unsafeCoerce#--The desugar has special magic to detect such cases: GHC.HsToCore.Expr.badUseOfLevPolyPrimop.-And we want that magic to apply to levity-polymorphic compulsory-inline things.-The easiest way to do this is for hasNoBinding to return True of all things-that have compulsory unfolding.  Some Ids with a compulsory unfolding also-have a binding, but it does not harm to say they don't here, and its a very-simple way to fix #14561.--}- isDeadBinder :: Id -> Bool isDeadBinder bndr | isId bndr = isDeadOcc (idOccInfo bndr)                   | otherwise = False   -- TyVars count as not dead@@ -628,24 +640,35 @@ idJoinArity id = isJoinId_maybe id `orElse` pprPanic "idJoinArity" (ppr id)  asJoinId :: Id -> JoinArity -> JoinId-asJoinId id arity = WARN(not (isLocalId id),-                         text "global id being marked as join var:" <+> ppr id)-                    WARN(not (is_vanilla_or_join id),-                         ppr id <+> pprIdDetails (idDetails id))-                    id `setIdDetails` JoinId arity+asJoinId id arity = warnPprTrace (not (isLocalId id))+                         "global id being marked as join var"  (ppr id) $+                    warnPprTrace (not (is_vanilla_or_join id))+                         "asJoinId"+                         (ppr id <+> pprIdDetails (idDetails id)) $+                    id `setIdDetails` JoinId arity (idCbvMarks_maybe id)   where     is_vanilla_or_join id = case Var.idDetails id of                               VanillaId -> True+                              -- Can workers become join ids? Yes!+                              WorkerLikeId {} -> pprTraceDebug "asJoinId (call by value function)" (ppr id) True                               JoinId {} -> True                               _         -> False  zapJoinId :: Id -> Id -- May be a regular id already-zapJoinId jid | isJoinId jid = zapIdTailCallInfo (jid `setIdDetails` VanillaId)+zapJoinId jid | isJoinId jid = zapIdTailCallInfo (newIdDetails `seq` jid `setIdDetails` newIdDetails)                                  -- Core Lint may complain if still marked                                  -- as AlwaysTailCalled               | otherwise    = jid+              where+                newIdDetails = case idDetails jid of+                  -- We treat join points as CBV functions. Even after they are floated out.+                  -- See Note [Use CBV semantics only for join points and workers]+                  JoinId _ (Just marks) -> WorkerLikeId marks+                  JoinId _ Nothing      -> WorkerLikeId []+                  _                     -> panic "zapJoinId: newIdDetails can only be used if Id was a join Id." + asJoinId_maybe :: Id -> Maybe JoinArity -> Id asJoinId_maybe id (Just arity) = asJoinId id arity asJoinId_maybe id Nothing      = zapJoinId id@@ -679,24 +702,24 @@ -- See Note [Dead ends] in "GHC.Types.Demand". isDeadEndId :: Var -> Bool isDeadEndId v-  | isId v    = isDeadEndSig (idStrictness v)+  | isId v    = isDeadEndSig (idDmdSig v)   | otherwise = False --- | Accesses the 'Id''s 'strictnessInfo'.-idStrictness :: Id -> StrictSig-idStrictness id = strictnessInfo (idInfo id)+-- | Accesses the 'Id''s 'dmdSigInfo'.+idDmdSig :: Id -> DmdSig+idDmdSig id = dmdSigInfo (idInfo id) -setIdStrictness :: Id -> StrictSig -> Id-setIdStrictness id sig = modifyIdInfo (`setStrictnessInfo` sig) id+setIdDmdSig :: Id -> DmdSig -> Id+setIdDmdSig id sig = modifyIdInfo (`setDmdSigInfo` sig) id -idCprInfo :: Id -> CprSig-idCprInfo id = cprInfo (idInfo id)+idCprSig :: Id -> CprSig+idCprSig id = cprSigInfo (idInfo id) -setIdCprInfo :: Id -> CprSig -> Id-setIdCprInfo id sig = modifyIdInfo (\info -> setCprInfo info sig) id+setIdCprSig :: Id -> CprSig -> Id+setIdCprSig id sig = modifyIdInfo (\info -> setCprSigInfo info sig) id -zapIdStrictness :: Id -> Id-zapIdStrictness id = modifyIdInfo (`setStrictnessInfo` nopSig) id+zapIdDmdSig :: Id -> Id+zapIdDmdSig id = modifyIdInfo (`setDmdSigInfo` nopSig) id  -- | This predicate says whether the 'Id' has a strict demand placed on it or -- has a type such that it can always be evaluated strictly (i.e an@@ -706,25 +729,28 @@ -- type, we still want @isStrictId id@ to be @True@. isStrictId :: Id -> Bool isStrictId id-  | ASSERT2( isId id, text "isStrictId: not an id: " <+> ppr id )+  | assertPpr (isId id) (text "isStrictId: not an id: " <+> ppr id) $     isJoinId id = False   | otherwise   = isStrictType (idType id) ||                   isStrUsedDmd (idDemandInfo id)                   -- Take the best of both strictnesses - old and new -        ----------------------------------        -- UNFOLDING+idTagSig_maybe :: Id -> Maybe TagSig+idTagSig_maybe = tagSig . idInfo++---------------------------------+-- UNFOLDING++-- | Returns the 'Id's unfolding, but does not expose the unfolding of a strong+-- loop breaker. See 'unfoldingInfo'.+--+-- If you really want the unfolding of a strong loopbreaker, call 'realIdUnfolding'. idUnfolding :: Id -> Unfolding--- Do not expose the unfolding of a loop breaker!-idUnfolding id-  | isStrongLoopBreaker (occInfo info) = NoUnfolding-  | otherwise                          = unfoldingInfo info-  where-    info = idInfo id+idUnfolding id = unfoldingInfo (idInfo id)  realIdUnfolding :: Id -> Unfolding--- Expose the unfolding if there is one, including for loop breakers-realIdUnfolding id = unfoldingInfo (idInfo id)+-- ^ Expose the unfolding if there is one, including for loop breakers+realIdUnfolding id = realUnfoldingInfo (idInfo id)  setIdUnfolding :: Id -> Unfolding -> Id setIdUnfolding id unfolding = modifyIdInfo (`setUnfoldingInfo` unfolding) id@@ -735,6 +761,69 @@ setIdDemandInfo :: Id -> Demand -> Id setIdDemandInfo id dmd = modifyIdInfo (`setDemandInfo` dmd) id +setIdTagSig :: Id -> TagSig -> Id+setIdTagSig id sig = modifyIdInfo (`setTagSig` sig) id++-- | If all marks are NotMarkedStrict we just set nothing.+setIdCbvMarks :: Id -> [CbvMark] -> Id+setIdCbvMarks id marks+  | not (any isMarkedCbv marks) = id+  | otherwise =+      -- pprTrace "setMarks:" (ppr id <> text ":" <> ppr marks) $+      case idDetails id of+        -- good ol (likely worker) function+        VanillaId ->      id `setIdDetails` (WorkerLikeId trimmedMarks)+        JoinId arity _ -> id `setIdDetails` (JoinId arity (Just trimmedMarks))+        -- Updating an existing call by value function.+        WorkerLikeId _ -> id `setIdDetails` (WorkerLikeId trimmedMarks)+        -- Do nothing for these+        RecSelId{} -> id+        DFunId{} -> id+        _ -> pprTrace "setIdCbvMarks: Unable to set cbv marks for" (ppr id $$+              text "marks:" <> ppr marks $$+              text "idDetails:" <> ppr (idDetails id)) id++    where+      -- (Currently) no point in passing args beyond the arity unlifted.+      -- We would have to eta expand all call sites to (length marks).+      -- Perhaps that's sensible but for now be conservative.+      -- Similarly we don't need any lazy marks at the end of the list.+      -- This way the length of the list is always exactly number of arguments+      -- that must be visible to CodeGen. See See Note [CBV Function Ids]+      -- for more details.+      trimmedMarks = dropWhileEndLE (not . isMarkedCbv) $ take (idArity id) marks++idCbvMarks_maybe :: Id -> Maybe [CbvMark]+idCbvMarks_maybe id = case idDetails id of+  WorkerLikeId marks -> Just marks+  JoinId _arity marks  -> marks+  _                    -> Nothing++-- Id must be called with at least this arity in order to allow arguments to+-- be passed unlifted.+idCbvMarkArity :: Id -> Arity+idCbvMarkArity fn = maybe 0 length (idCbvMarks_maybe fn)++-- | Remove any cbv marks on arguments from a given Id.+asNonWorkerLikeId :: Id -> Id+asNonWorkerLikeId id =+  let details = case idDetails id of+        WorkerLikeId{}      -> Just $ VanillaId+        JoinId arity Just{}   -> Just $ JoinId arity Nothing+        _                     -> Nothing+  in maybeModifyIdDetails details id++-- | Turn this id into a WorkerLikeId if possible.+asWorkerLikeId :: Id -> Id+asWorkerLikeId id =+  let details = case idDetails id of+        WorkerLikeId{}      -> Nothing+        JoinId _arity Just{}  -> Nothing+        JoinId arity Nothing  -> Just (JoinId arity (Just []))+        VanillaId             -> Just $ WorkerLikeId []+        _                     -> Nothing+  in maybeModifyIdDetails details id+ setCaseBndrEvald :: StrictnessMark -> Id -> Id -- Used for variables bound by a case expressions, both the case-binder -- itself, and any pattern-bound variables that are argument of a@@ -744,6 +833,12 @@   | isMarkedStrict str = id `setIdUnfolding` evaldUnfolding   | otherwise          = id +-- | Similar to trimUnfolding, but also removes evaldness info.+zapIdUnfolding :: Id -> Id+zapIdUnfolding v+  | isId v, hasSomeUnfolding (idUnfolding v) = setIdUnfolding v noUnfolding+  | otherwise = v+         ---------------------------------         -- SPECIALISATION @@ -907,6 +1002,7 @@ --      f = \x -> e -- If we change the one-shot-ness of x, f's type changes +-- Replaces the id info if the zapper returns @Just idinfo@ zapInfo :: (IdInfo -> Maybe IdInfo) -> Id -> Id zapInfo zapper id = maybeModifyIdInfo (zapper (idInfo id)) id @@ -992,7 +1088,7 @@                    -> Id        -- New Id                    -> Id transferPolyIdInfo old_id abstract_wrt new_id-  = modifyIdInfo transfer new_id+  = modifyIdInfo transfer new_id `setIdCbvMarks` new_cbv_marks   where     arity_increase = count isId abstract_wrt    -- Arity increases by the                                                 -- number of value binders@@ -1004,15 +1100,27 @@     new_arity       = old_arity + arity_increase     new_occ_info    = zapOccTailCallInfo old_occ_info -    old_strictness  = strictnessInfo old_info-    new_strictness  = prependArgsStrictSig arity_increase old_strictness-    old_cpr         = cprInfo old_info+    old_strictness  = dmdSigInfo old_info+    new_strictness  = prependArgsDmdSig arity_increase old_strictness+    old_cpr         = cprSigInfo old_info +    old_cbv_marks   = fromMaybe (replicate old_arity NotMarkedCbv) (idCbvMarks_maybe old_id)+    abstr_cbv_marks = mapMaybe getMark abstract_wrt+    new_cbv_marks   = abstr_cbv_marks ++ old_cbv_marks++    getMark v+      | not (isId v)+      = Nothing+      | isId v+      , isEvaldUnfolding (idUnfolding v)+      , mightBeLiftedType (idType v)+      = Just MarkedCbv+      | otherwise = Just NotMarkedCbv     transfer new_info = new_info `setArityInfo` new_arity                                  `setInlinePragInfo` old_inline_prag                                  `setOccInfo` new_occ_info-                                 `setStrictnessInfo` new_strictness-                                 `setCprInfo` old_cpr+                                 `setDmdSigInfo` new_strictness+                                 `setCprSigInfo` old_cpr -isNeverLevPolyId :: Id -> Bool-isNeverLevPolyId = isNeverLevPolyIdInfo . idInfo+isNeverRepPolyId :: Id -> Bool+isNeverRepPolyId = isNeverRepPolyIdInfo . idInfo
GHC/Types/Id/Info.hs view
@@ -8,7 +8,7 @@ Haskell. [WDP 94/11]) -} -{-# LANGUAGE CPP #-}+ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE BinaryLiterals #-} @@ -32,7 +32,7 @@         -- ** Zapping various forms of Info         zapLamInfo, zapFragileInfo,         zapDemandInfo, zapUsageInfo, zapUsageEnvInfo, zapUsedOnceInfo,-        zapTailCallInfo, zapCallArityInfo, zapUnfolding,+        zapTailCallInfo, zapCallArityInfo, trimUnfolding,          -- ** The ArityInfo type         ArityInfo,@@ -42,12 +42,12 @@         callArityInfo, setCallArityInfo,          -- ** Demand and strictness Info-        strictnessInfo, setStrictnessInfo,-        cprInfo, setCprInfo,+        dmdSigInfo, setDmdSigInfo,+        cprSigInfo, setCprSigInfo,         demandInfo, setDemandInfo, pprStrictness,          -- ** Unfolding Info-        unfoldingInfo, setUnfoldingInfo,+        realUnfoldingInfo, unfoldingInfo, setUnfoldingInfo, hasInlineUnfolding,          -- ** The InlinePragInfo type         InlinePragInfo,@@ -68,7 +68,7 @@         emptyRuleInfo,         isEmptyRuleInfo, ruleInfoFreeVars,         ruleInfoRules, setRuleInfoHead,-        ruleInfo, setRuleInfo,+        ruleInfo, setRuleInfo, tagSigInfo,          -- ** The CAFInfo type         CafInfo(..),@@ -76,24 +76,22 @@         cafInfo, setCafInfo,          -- ** The LambdaFormInfo type-        LambdaFormInfo(..),-        lfInfo, setLFInfo,+        LambdaFormInfo,+        lfInfo, setLFInfo, setTagSig, +        tagSig,+         -- ** Tick-box Info         TickBoxOp(..), TickBoxId,          -- ** Levity info-        LevityInfo, levityInfo, setNeverLevPoly, setLevityInfoWithType,-        isNeverLevPolyIdInfo+        LevityInfo, levityInfo, setNeverRepPoly, setLevityInfoWithType,+        isNeverRepPolyIdInfo     ) where -#include "HsVersions.h"- import GHC.Prelude -import GHC.Core hiding( hasCoreUnfolding )-import GHC.Core( hasCoreUnfolding )-+import GHC.Core import GHC.Core.Class import {-# SOURCE #-} GHC.Builtin.PrimOps (PrimOp) import GHC.Types.Name@@ -111,10 +109,12 @@ import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain+import GHC.Stg.InferTags.TagSig  import Data.Word -import GHC.StgToCmm.Types (LambdaFormInfo (..))+import GHC.StgToCmm.Types (LambdaFormInfo)  -- infixl so you can say (id `set` a `set` b) infixl  1 `setRuleInfo`,@@ -124,12 +124,11 @@           `setOneShotInfo`,           `setOccInfo`,           `setCafInfo`,-          `setStrictnessInfo`,-          `setCprInfo`,+          `setDmdSigInfo`,+          `setCprSigInfo`,           `setDemandInfo`,-          `setNeverLevPoly`,+          `setNeverRepPoly`,           `setLevityInfoWithType`- {- ************************************************************************ *                                                                      *@@ -176,9 +175,103 @@   | CoVarId    -- ^ A coercion variable                -- This only covers /un-lifted/ coercions, of type                -- (t1 ~# t2) or (t1 ~R# t2), not their lifted variants-  | JoinId JoinArity           -- ^ An 'Id' for a join point taking n arguments-       -- Note [Join points] in "GHC.Core"+  | JoinId JoinArity (Maybe [CbvMark])+        -- ^ An 'Id' for a join point taking n arguments+        -- Note [Join points] in "GHC.Core"+        -- Can also work as a WorkerLikeId if given `CbvMark`s.+        -- See Note [CBV Function Ids]+        -- The [CbvMark] is always empty (and ignored) until after Tidy.+  | WorkerLikeId [CbvMark]+        -- ^ An 'Id' for a worker like function, which might expect some arguments to be+        -- passed both evaluated and tagged.+        -- Worker like functions are create by W/W and SpecConstr and we can expect that they+        -- aren't used unapplied.+        -- See Note [CBV Function Ids]+        -- See Note [Tag Inference]+        -- The [CbvMark] is always empty (and ignored) until after Tidy for ids from the current+        -- module. +{- Note [CBV Function Ids]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+A WorkerLikeId essentially allows us to constrain the calling convention+for the given Id. Each such Id carries with it a list of CbvMarks+with each element representing a value argument. Arguments who have+a matching `MarkedCbv` entry in the list need to be passed evaluated+*properly tagged*.++CallByValueFunIds give us additional expressiveness which we use to improve+runtime. This is all part of the TagInference work. See also Note [Tag Inference].++They allows us to express the fact that an argument is not only evaluated to WHNF once we+entered it's RHS but also that an lifted argument is already *properly tagged* once we jump+into the RHS.+This means when e.g. branching on such an argument the RHS doesn't needed to perform+an eval check to ensure the argument isn't an indirection. All seqs on such an argument in+the functions body become no-ops as well.++The invariants around the arguments of call by value function like Ids are then:++* In any call `(f e1 .. en)`, if `f`'s i'th argument is marked `MarkedCbv`,+  then the caller must ensure that the i'th argument+  * points directly to the value (and hence is certainly evaluated before the call)+  * is a properly tagged pointer to that value++* The following functions (and only these functions) have `CbvMarks`:+  * Any `WorkerLikeId`+  * Some `JoinId` bindings.++This works analogous to the Strict Field Invariant. See also Note [Strict Field Invariant].++To make this work what we do is:+* During W/W and SpecConstr any worker/specialized binding we introduce+  is marked as a worker binding by `asWorkerLikeId`.+* W/W and SpecConstr further set OtherCon[] unfoldings on arguments which+  represent contents of a strict fields.+* During Tidy we look at all bindings.+  For any callByValueLike Id and join point we mark arguments as cbv if they+  Are strict. We don't do so for regular bindings.+  See Note [Use CBV semantics only for join points and workers] for why.+  We might have made some ids rhs *more* strict in order to make their arguments+  be passed CBV. See Note [Call-by-value for worker args] for why.+* During CorePrep calls to CallByValueFunIds are eta expanded.+* During Stg CodeGen:+  * When we see a call to a callByValueLike Id:+    * We check if all arguments marked to be passed unlifted are already tagged.+    * If they aren't we will wrap the call in case expressions which will evaluate+tag+      these arguments before jumping to the function.+* During Cmm codeGen:+  * When generating code for the RHS of a StrictWorker binding+    we omit tag checks when using arguments marked as tagged.++We only use this for workers and specialized versions of SpecConstr+But we also check other functions during tidy and potentially turn some of them into+call by value functions and mark some of their arguments as call-by-value by looking at+argument unfoldings.++NB: I choose to put the information into a new Id constructor since these are loaded+at all optimization levels. This makes it trivial to ensure the additional+calling convention demands are available at all call sites. Putting it into+IdInfo would require us at the very least to always decode the IdInfo+just to decide if we need to throw it away or not after.++Note [Use CBV semantics only for join points and workers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A function with cbv-semantics requires arguments to be visible+and if no arguments are visible requires us to eta-expand it's+call site. That is for a binding with three cbv arguments like+`w[WorkerLikeId[!,!,!]]` we would need to eta expand undersaturated+occurences like `map w xs` into `map (\x1 x2 x3 -> w x1 x2 x3) xs.++In experiments it turned out that the code size increase of doing so+can outweigh the performance benefits of doing so.+So we only do this for join points, workers and+specialized functions (from SpecConstr).+Join points are naturally always called saturated so+this problem can't occur for them.+For workers and specialized functions there are also always at least+some applied arguments as we won't inline the wrapper/apply their rule+if there are unapplied occurances like `map f xs`.+-}+ -- | Recursive Selector Parent data RecSelParent = RecSelData TyCon | RecSelPatSyn PatSyn deriving Eq   -- Either `TyCon` or `PatSyn` depending@@ -201,8 +294,8 @@ isCoVarDetails CoVarId = True isCoVarDetails _       = False -isJoinIdDetails_maybe :: IdDetails -> Maybe JoinArity-isJoinIdDetails_maybe (JoinId join_arity) = Just join_arity+isJoinIdDetails_maybe :: IdDetails -> Maybe (JoinArity, (Maybe [CbvMark]))+isJoinIdDetails_maybe (JoinId join_arity marks) = Just (join_arity, marks) isJoinIdDetails_maybe _                   = Nothing  instance Outputable IdDetails where@@ -213,6 +306,7 @@ pprIdDetails other     = brackets (pp other)  where    pp VanillaId               = panic "pprIdDetails"+   pp (WorkerLikeId dmds)   = text "StrictWorker" <> parens (ppr dmds)    pp (DataConWorkId _)       = text "DataCon"    pp (DataConWrapId _)       = text "DataConWrapper"    pp (ClassOpId {})          = text "ClassOp"@@ -224,7 +318,7 @@                               = brackets $ text "RecSel" <>                                            ppWhen is_naughty (text "(naughty)")    pp CoVarId                 = text "CoVarId"-   pp (JoinId arity)          = text "JoinId" <> parens (int arity)+   pp (JoinId arity marks)    = text "JoinId" <> parens (int arity) <> parens (ppr marks)  {- ************************************************************************@@ -256,16 +350,16 @@         ruleInfo        :: RuleInfo,         -- ^ Specialisations of the 'Id's function which exist.         -- See Note [Specialisations and RULES in IdInfo]-        unfoldingInfo   :: Unfolding,+        realUnfoldingInfo   :: Unfolding,         -- ^ The 'Id's unfolding         inlinePragInfo  :: InlinePragma,         -- ^ Any inline pragma attached to the 'Id'         occInfo         :: OccInfo,         -- ^ How the 'Id' occurs in the program-        strictnessInfo  :: StrictSig,+        dmdSigInfo      :: DmdSig,         -- ^ A strictness signature. Digests how a function uses its arguments         -- if applied to at least 'arityInfo' arguments.-        cprInfo         :: CprSig,+        cprSigInfo      :: CprSig,         -- ^ Information on whether the function will ultimately return a         -- freshly allocated constructor.         demandInfo      :: Demand,@@ -277,7 +371,10 @@         -- 4% in some programs. See #17497 and associated MR.         --         -- See documentation of the getters for what these packed fields mean.-        lfInfo          :: !(Maybe LambdaFormInfo)+        lfInfo          :: !(Maybe LambdaFormInfo),++        -- See documentation of the getters for what these packed fields mean.+        tagSig          :: !(Maybe TagSig)     }  -- | Encodes arities, OneShotInfo, CafInfo and LevityInfo.@@ -334,18 +431,18 @@  bitfieldSetCallArityInfo :: ArityInfo -> BitField -> BitField bitfieldSetCallArityInfo info bf@(BitField bits) =-    ASSERT(info < 2^(30 :: Int) - 1)+    assert (info < 2^(30 :: Int) - 1) $     bitfieldSetArityInfo (bitfieldGetArityInfo bf) $     BitField ((fromIntegral info `shiftL` 3) .|. (bits .&. 0b111))  bitfieldSetArityInfo :: ArityInfo -> BitField -> BitField bitfieldSetArityInfo info (BitField bits) =-    ASSERT(info < 2^(30 :: Int) - 1)+    assert (info < 2^(30 :: Int) - 1) $     BitField ((fromIntegral info `shiftL` 33) .|. (bits .&. ((1 `shiftL` 33) - 1)))  -- Getters --- | When applied, will this Id ever have a levity-polymorphic type?+-- | When applied, will this Id ever have a representation-polymorphic type? levityInfo :: IdInfo -> LevityInfo levityInfo = bitfieldGetLevityInfo . bitfield @@ -368,6 +465,9 @@ callArityInfo :: IdInfo -> ArityInfo callArityInfo = bitfieldGetCallArityInfo . bitfield +tagSigInfo :: IdInfo -> Maybe TagSig+tagSigInfo = tagSig+ -- Setters  setRuleInfo :: IdInfo -> RuleInfo -> IdInfo@@ -378,14 +478,30 @@ setOccInfo        info oc = oc `seq` info { occInfo = oc }         -- Try to avoid space leaks by seq'ing +-- | Essentially returns the 'realUnfoldingInfo' field, but does not expose the+-- unfolding of a strong loop breaker.+--+-- This is the right thing to call if you plan to decide whether an unfolding+-- will inline.+unfoldingInfo :: IdInfo -> Unfolding+unfoldingInfo info+  | isStrongLoopBreaker (occInfo info) = trimUnfolding $ realUnfoldingInfo info+  | otherwise                          =                realUnfoldingInfo info+ setUnfoldingInfo :: IdInfo -> Unfolding -> IdInfo setUnfoldingInfo info uf   = -- We don't seq the unfolding, as we generate intermediate     -- unfoldings which are just thrown away, so evaluating them is a     -- waste of time.     -- seqUnfolding uf `seq`-    info { unfoldingInfo = uf }+    info { realUnfoldingInfo = uf } +hasInlineUnfolding :: IdInfo -> Bool+-- ^ True of a /non-loop-breaker/ Id that has a /stable/ unfolding that is+--   (a) always inlined; that is, with an `UnfWhen` guidance, or+--   (b) a DFunUnfolding which never needs to be inlined+hasInlineUnfolding info = isInlineUnfolding (unfoldingInfo info)+ setArityInfo :: IdInfo -> ArityInfo -> IdInfo setArityInfo info ar =     info { bitfield = bitfieldSetArityInfo ar (bitfield info) }@@ -401,6 +517,9 @@ setLFInfo :: IdInfo -> LambdaFormInfo -> IdInfo setLFInfo info lf = info { lfInfo = Just lf } +setTagSig :: IdInfo -> TagSig -> IdInfo+setTagSig info sig = info { tagSig = Just sig }+ setOneShotInfo :: IdInfo -> OneShotInfo -> IdInfo setOneShotInfo info lb =     info { bitfield = bitfieldSetOneShotInfo lb (bitfield info) }@@ -408,30 +527,31 @@ setDemandInfo :: IdInfo -> Demand -> IdInfo setDemandInfo info dd = dd `seq` info { demandInfo = dd } -setStrictnessInfo :: IdInfo -> StrictSig -> IdInfo-setStrictnessInfo info dd = dd `seq` info { strictnessInfo = dd }+setDmdSigInfo :: IdInfo -> DmdSig -> IdInfo+setDmdSigInfo info dd = dd `seq` info { dmdSigInfo = dd } -setCprInfo :: IdInfo -> CprSig -> IdInfo-setCprInfo info cpr = cpr `seq` info { cprInfo = cpr }+setCprSigInfo :: IdInfo -> CprSig -> IdInfo+setCprSigInfo info cpr = cpr `seq` info { cprSigInfo = cpr }  -- | Basic 'IdInfo' that carries no useful information whatsoever vanillaIdInfo :: IdInfo vanillaIdInfo   = IdInfo {-            ruleInfo            = emptyRuleInfo,-            unfoldingInfo       = noUnfolding,-            inlinePragInfo      = defaultInlinePragma,-            occInfo             = noOccInfo,-            demandInfo          = topDmd,-            strictnessInfo      = nopSig,-            cprInfo             = topCprSig,-            bitfield            = bitfieldSetCafInfo vanillaCafInfo $-                                  bitfieldSetArityInfo unknownArity $-                                  bitfieldSetCallArityInfo unknownArity $-                                  bitfieldSetOneShotInfo NoOneShotInfo $-                                  bitfieldSetLevityInfo NoLevityInfo $-                                  emptyBitField,-            lfInfo              = Nothing+            ruleInfo       = emptyRuleInfo,+            realUnfoldingInfo  = noUnfolding,+            inlinePragInfo = defaultInlinePragma,+            occInfo        = noOccInfo,+            demandInfo     = topDmd,+            dmdSigInfo     = nopSig,+            cprSigInfo     = topCprSig,+            bitfield       = bitfieldSetCafInfo vanillaCafInfo $+                             bitfieldSetArityInfo unknownArity $+                             bitfieldSetCallArityInfo unknownArity $+                             bitfieldSetOneShotInfo NoOneShotInfo $+                             bitfieldSetLevityInfo NoLevityInfo $+                             emptyBitField,+            lfInfo         = Nothing,+            tagSig         = Nothing            }  -- | More informative 'IdInfo' we can use when we know the 'Id' has no CAF references@@ -449,8 +569,36 @@ For locally-defined Ids, the code generator maintains its own notion of their arities; so it should not be asking...  (but other things besides the code-generator need arity info!)++Note [Arity and function types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The arity of an 'Id' must never exceed the number of arguments that+can be read off from the 'Id's type, possibly after expanding newtypes.++Examples:++  f1 :: forall a. a -> a++    idArity f1 <= 1: only one value argument, of type 'a'++  f2 :: forall a. Show a => Int -> a++    idArity f2 <= 2: two value arguments, of types 'Show a' and 'Int'.+++  newtype Id a = MkId a+  f3 :: forall b. Id (Int -> b)++    idArity f3 <= 1: there is one value argument, of type 'Int', hidden under the newtype.++  newtype RecFun = MkRecFun (Int -> RecFun)+  f4 :: RecFun++    no constraint on the arity of f4: we can unwrap as many layers of the newtype as we want,+    to get arbitrarily many arguments of type 'Int'. -} + -- | Arity Information -- -- An 'ArityInfo' of @n@ tells us that partial application of this@@ -461,6 +609,10 @@ -- -- The arity might increase later in the compilation process, if -- an extra lambda floats up to the binding site.+--+-- /Invariant:/ the 'Arity' of an 'Id' must never exceed the number of+-- value arguments that appear in the type of the 'Id'.+-- See Note [Arity and function types]. type ArityInfo = Arity  -- | It is always safe to assume that an 'Id' has an arity of 0@@ -500,7 +652,7 @@ ************************************************************************ -} -pprStrictness :: StrictSig -> SDoc+pprStrictness :: DmdSig -> SDoc pprStrictness sig = ppr sig  {-@@ -648,19 +800,19 @@ -- | Remove usage environment info from the strictness signature on the 'IdInfo' zapUsageEnvInfo :: IdInfo -> Maybe IdInfo zapUsageEnvInfo info-    | hasDemandEnvSig (strictnessInfo info)-    = Just (info {strictnessInfo = zapDmdEnvSig (strictnessInfo info)})+    | hasDemandEnvSig (dmdSigInfo info)+    = Just (info {dmdSigInfo = zapDmdEnvSig (dmdSigInfo info)})     | otherwise     = Nothing  zapUsedOnceInfo :: IdInfo -> Maybe IdInfo zapUsedOnceInfo info-    = Just $ info { strictnessInfo = zapUsedOnceSig    (strictnessInfo info)+    = Just $ info { dmdSigInfo = zapUsedOnceSig    (dmdSigInfo info)                   , demandInfo     = zapUsedOnceDemand (demandInfo     info) }  zapFragileInfo :: IdInfo -> Maybe IdInfo -- ^ Zap info that depends on free variables-zapFragileInfo info@(IdInfo { occInfo = occ, unfoldingInfo = unf })+zapFragileInfo info@(IdInfo { occInfo = occ, realUnfoldingInfo = unf })   = new_unf `seq`  -- The unfolding field is not (currently) strict, so we                    -- force it here to avoid a (zapFragileUnfolding unf) thunk                    -- which might leak space@@ -671,13 +823,17 @@     new_unf = zapFragileUnfolding unf  zapFragileUnfolding :: Unfolding -> Unfolding+-- ^ Zaps any core unfolding, but /preserves/ evaluated-ness,+-- i.e. an unfolding of OtherCon zapFragileUnfolding unf- | hasCoreUnfolding unf = noUnfolding- | otherwise            = unf+ -- N.B. isEvaldUnfolding catches *both* OtherCon [] *and* core unfoldings+ -- representing values.+ | isEvaldUnfolding unf = evaldUnfolding+ | otherwise            = noUnfolding -zapUnfolding :: Unfolding -> Unfolding+trimUnfolding :: Unfolding -> Unfolding -- Squash all unfolding info, preserving only evaluated-ness-zapUnfolding unf | isEvaldUnfolding unf = evaldUnfolding+trimUnfolding unf | isEvaldUnfolding unf = evaldUnfolding                  | otherwise            = noUnfolding  zapTailCallInfo :: IdInfo -> Maybe IdInfo@@ -718,13 +874,17 @@ Note [Levity info] ~~~~~~~~~~~~~~~~~~ -Ids store whether or not they can be levity-polymorphic at any amount-of saturation. This is helpful in optimizing the levity-polymorphism check-done in the desugarer, where we can usually learn that something is not-levity-polymorphic without actually figuring out its type. See-isExprLevPoly in GHC.Core.Utils for where this info is used. Storing-this is required to prevent perf/compiler/T5631 from blowing up.+Ids store whether or not they can be representation-polymorphic at any amount+of saturation. This is helpful in optimizing representation polymorphism checks,+allowing us to learn that something is not representation-polymorphic without+actually figuring out its type.+See exprHasFixedRuntimeRep in GHC.Core.Utils for where this info is used. +Historical note: this was very important when representation polymorphism+was checked in the desugarer (it was needed to prevent T5631 from blowing up).+It's less important now that the checks happen in the typechecker, but remains useful.+Refer to Note [The Concrete mechanism] in GHC.Tc.Utils.Concrete for details+about the new approach being used. -}  -- See Note [Levity info]@@ -736,22 +896,22 @@   ppr NoLevityInfo           = text "NoLevityInfo"   ppr NeverLevityPolymorphic = text "NeverLevityPolymorphic" --- | Marks an IdInfo describing an Id that is never levity polymorphic (even when--- applied). The Type is only there for checking that it's really never levity--- polymorphic-setNeverLevPoly :: HasDebugCallStack => IdInfo -> Type -> IdInfo-setNeverLevPoly info ty-  = ASSERT2( not (resultIsLevPoly ty), ppr ty )+-- | Marks an IdInfo describing an Id that is never representation-polymorphic+-- (even when applied). The Type is only there for checking that it's really+-- never representation-polymorphic.+setNeverRepPoly :: HasDebugCallStack => IdInfo -> Type -> IdInfo+setNeverRepPoly info ty+  = assertPpr (resultHasFixedRuntimeRep ty) (ppr ty) $     info { bitfield = bitfieldSetLevityInfo NeverLevityPolymorphic (bitfield info) }  setLevityInfoWithType :: IdInfo -> Type -> IdInfo setLevityInfoWithType info ty-  | not (resultIsLevPoly ty)+  | resultHasFixedRuntimeRep ty   = info { bitfield = bitfieldSetLevityInfo NeverLevityPolymorphic (bitfield info) }   | otherwise   = info -isNeverLevPolyIdInfo :: IdInfo -> Bool-isNeverLevPolyIdInfo info+isNeverRepPolyIdInfo :: IdInfo -> Bool+isNeverRepPolyIdInfo info   | NeverLevityPolymorphic <- levityInfo info = True   | otherwise                                 = False
GHC/Types/Id/Make.hs view
@@ -12,81 +12,75 @@ - primitive operations -} -{-# LANGUAGE CPP #-} + {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}  module GHC.Types.Id.Make (         mkDictFunId, mkDictFunTy, mkDictSelId, mkDictSelRhs, -        mkPrimOpId, mkFCallId,+        mkFCallId,          unwrapNewTypeBody, wrapFamInstBody,         DataConBoxer(..), vanillaDataConBoxer,         mkDataConRep, mkDataConWorkId,+        DataConBangOpts (..), BangOpts (..),          -- And some particular Ids; see below for why they are wired in         wiredInIds, ghcPrimIds,         realWorldPrimId,         voidPrimId, voidArgId,         nullAddrId, seqId, lazyId, lazyIdKey,-        coercionTokenId, magicDictId, coerceId,+        coercionTokenId, coerceId,         proxyHashId, noinlineId, noinlineIdName,         coerceName, leftSectionName, rightSectionName,--        -- Re-export error Ids-        module GHC.Core.Opt.ConstantFold     ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Builtin.Types.Prim import GHC.Builtin.Types-import GHC.Core.Opt.ConstantFold+import GHC.Builtin.Names++import GHC.Core import GHC.Core.Type import GHC.Core.Multiplicity import GHC.Core.TyCo.Rep import GHC.Core.FamInstEnv import GHC.Core.Coercion-import GHC.Tc.Utils.TcType as TcType+import GHC.Core.Reduction import GHC.Core.Make import GHC.Core.FVs     ( mkRuleInfo ) import GHC.Core.Utils   ( exprType, mkCast, mkDefaultCase ) import GHC.Core.Unfold.Make import GHC.Core.SimpleOpt-import GHC.Types.Literal-import GHC.Types.SourceText import GHC.Core.TyCon import GHC.Core.Class+import GHC.Core.DataCon++import GHC.Types.Literal+import GHC.Types.SourceText import GHC.Types.Name.Set import GHC.Types.Name-import GHC.Builtin.PrimOps import GHC.Types.ForeignCall-import GHC.Core.DataCon import GHC.Types.Id import GHC.Types.Id.Info import GHC.Types.Demand import GHC.Types.Cpr-import GHC.Types.TyThing-import GHC.Core-import GHC.Types.Unique-import GHC.Builtin.Uniques import GHC.Types.Unique.Supply-import GHC.Builtin.Names import GHC.Types.Basic       hiding ( SuccessFlag(..) )+import GHC.Types.Var (VarBndr(Bndr))++import GHC.Tc.Utils.TcType as TcType+ import GHC.Utils.Misc-import GHC.Driver.Session-import GHC.Driver.Ppr import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain+ import GHC.Data.FastString import GHC.Data.List.SetOps-import GHC.Types.Var (VarBndr(Bndr))-import qualified GHC.LanguageExtensions as LangExt -import Data.Maybe       ( maybeToList )  {- ************************************************************************@@ -173,7 +167,6 @@     , voidPrimId     , nullAddrId     , seqId-    , magicDictId     , coerceId     , proxyHashId     , leftSectionId@@ -363,24 +356,24 @@     We'd like 'map Age' to match the LHS. For this to happen, Age     must be unfolded, otherwise we'll be stuck. This is tested in T16208. -It also allows for the posssibility of levity polymorphic newtypes+It also allows for the posssibility of representation-polymorphic newtypes with wrappers (with -XUnliftedNewtypes):    newtype N (a :: TYPE r) = MkN a -With -XUnliftedNewtypes, this is allowed -- even though MkN is levity-+With -XUnliftedNewtypes, this is allowed -- even though MkN is representation- polymorphic. It's OK because MkN evaporates in the compiled code, becoming just a cast. That is, it has a compulsory unfolding. As long as its-argument is not levity-polymorphic (which it can't be, according to-Note [Levity polymorphism invariants] in GHC.Core), and it's saturated,-no levity-polymorphic code ends up in the code generator. The saturation-condition is effectively checked by Note [Detecting forced eta expansion]-in GHC.HsToCore.Expr.+argument is not representation-polymorphic (which it can't be, according to+Note [Representation polymorphism invariants] in GHC.Core), and it's saturated,+no representation-polymorphic code ends up in the code generator.+The saturation condition is effectively checked in+GHC.Tc.Gen.App.hasFixedRuntimeRep_remainingValArgs.  However, if we make a *wrapper* for a newtype, we get into trouble.-The saturation condition is no longer checked (because hasNoBinding-returns False) and indeed we generate a forbidden levity-polymorphic-binding.+In that case, we generate a forbidden representation-polymorphic+binding, and we must then ensure that it is always instantiated+at a representation-monomorphic type.  The solution is simple, though: just make the newtype wrappers as ephemeral as the newtype workers. In other words, give the wrappers@@ -413,12 +406,12 @@ unrestricted, then is perfectly possible to have a linear projection. Such a linear projection has as simple definition. -  data Bar = MkBar { c :: C, d # Many :: D }+  data Bar = MkBar { c :: C, d % Many :: D }    c :: Bar %1 -> C   c MkBar{ c=x, d=_} = x -The `# Many` syntax, for records, does not exist yet. But there is one important+The `% Many` syntax, for records, does not exist yet. But there is one important special case which already happens: when there is a single field (usually a newtype). @@ -456,7 +449,7 @@ https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0111-linear-types.rst .  When translating to core `C => ...` is always translated to an unrestricted-arrow `C # Many -> ...`.+arrow `C % Many -> ...`.  Therefore there is no loss of generality if we make all selectors unrestricted. @@ -484,8 +477,8 @@      base_info = noCafIdInfo                 `setArityInfo`          1-                `setStrictnessInfo`     strict_sig-                `setCprInfo`            topCprSig+                `setDmdSigInfo`     strict_sig+                `setCprSigInfo`            topCprSig                 `setLevityInfoWithType` sel_ty      info | new_tycon@@ -498,6 +491,10 @@           | otherwise          = base_info `setRuleInfo` mkRuleInfo [rule]+                     `setInlinePragInfo` neverInlinePragma+                     `setUnfoldingInfo`  mkInlineUnfoldingWithArity 1+                                           defaultSimpleOpts+                                           (mkDictSelRhs clas val_index)                    -- Add a magic BuiltinRule, but no unfolding                    -- so that the rule is always available to fire.                    -- See Note [ClassOp/DFun selection] in GHC.Tc.TyCl.Instance@@ -515,11 +512,14 @@         -- It's worth giving one, so that absence info etc is generated         -- even if the selector isn't inlined -    strict_sig = mkClosedStrictSig [arg_dmd] topDiv+    strict_sig = mkClosedDmdSig [arg_dmd] topDiv     arg_dmd | new_tycon = evalDmd-            | otherwise = C_1N :*-                          Prod [ if name == sel_name then evalDmd else absDmd-                               | sel_name <- sel_names ]+            | otherwise = C_1N :* mkProd Unboxed dict_field_dmds+            where+              -- The evalDmd below is just a placeholder and will be replaced in+              -- GHC.Types.Demand.dmdTransformDictSel+              dict_field_dmds = [ if name == sel_name then evalDmd else absDmd+                                | sel_name <- sel_names ]  mkDictSelRhs :: Class              -> Int         -- 0-indexed selector among (superclasses ++ methods)@@ -582,13 +582,12 @@     ----------- Workers for data types --------------     alg_wkr_info = noCafIdInfo                    `setArityInfo`          wkr_arity-                   `setCprInfo`            mkCprSig wkr_arity (dataConCPR data_con)                    `setInlinePragInfo`     wkr_inline_prag                    `setUnfoldingInfo`      evaldUnfolding  -- Record that it's evaluated,                                                            -- even if arity = 0                    `setLevityInfoWithType` wkr_ty                      -- NB: unboxed tuples have workers, so we can't use-                     -- setNeverLevPoly+                     -- setNeverRepPoly      wkr_inline_prag = defaultInlinePragma { inl_rule = ConLike }     wkr_arity = dataConRepArity data_con@@ -602,39 +601,13 @@                   `setLevityInfoWithType` wkr_ty     id_arg1      = mkScaledTemplateLocal 1 (head arg_tys)     res_ty_args  = mkTyCoVarTys univ_tvs-    newtype_unf  = ASSERT2( isVanillaDataCon data_con &&-                            isSingleton arg_tys-                          , ppr data_con  )+    newtype_unf  = assertPpr (isVanillaDataCon data_con && isSingleton arg_tys)+                             (ppr data_con) $                               -- Note [Newtype datacons]                    mkCompulsoryUnfolding defaultSimpleOpts $                    mkLams univ_tvs $ Lam id_arg1 $                    wrapNewTypeBody tycon res_ty_args (Var id_arg1) -dataConCPR :: DataCon -> Cpr-dataConCPR con-  | isDataTyCon tycon     -- Real data types only; that is,-                          -- not unboxed tuples or newtypes-  , null (dataConExTyCoVars con)  -- No existentials-  , wkr_arity > 0-  , wkr_arity <= mAX_CPR_SIZE-  = flatConCpr (dataConTag con)-  | otherwise-  = topCpr-  where-    tycon     = dataConTyCon con-    wkr_arity = dataConRepArity con--    mAX_CPR_SIZE :: Arity-    mAX_CPR_SIZE = 10-    -- 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.- {- ------------------------------------------------- --         Data constructor representation@@ -687,19 +660,30 @@  -} -mkDataConRep :: DynFlags+data DataConBangOpts+  = FixedBangOpts [HsImplBang]+    -- ^ Used for imported data constructors+    -- See Note [Bangs on imported data constructors]+  | SrcBangOpts !BangOpts++data BangOpts = BangOpts+  { bang_opt_strict_data   :: !Bool -- ^ Strict fields by default+  , bang_opt_unbox_disable :: !Bool -- ^ Disable automatic field unboxing (e.g. if we aren't optimising)+  , bang_opt_unbox_strict  :: !Bool -- ^ Unbox strict fields+  , bang_opt_unbox_small   :: !Bool -- ^ Unbox small strict fields+  }++mkDataConRep :: DataConBangOpts              -> FamInstEnvs              -> Name-             -> Maybe [HsImplBang]-                -- See Note [Bangs on imported data constructors]              -> DataCon              -> UniqSM DataConRep-mkDataConRep dflags fam_envs wrap_name mb_bangs data_con+mkDataConRep dc_bang_opts fam_envs wrap_name data_con   | not wrapper_reqd   = return NoDataConRep    | otherwise-  = do { wrap_args <- mapM newLocal wrap_arg_tys+  = do { wrap_args <- mapM (newLocal (fsLit "conrep")) wrap_arg_tys        ; wrap_body <- mk_rep_app (wrap_args `zip` dropList eq_spec unboxers)                                  initial_wrap_app @@ -710,14 +694,13 @@                              -- applications are treated as values                          `setInlinePragInfo`    wrap_prag                          `setUnfoldingInfo`     wrap_unf-                         `setStrictnessInfo`    wrap_sig-                         `setCprInfo`           mkCprSig wrap_arity (dataConCPR data_con)+                         `setDmdSigInfo`    wrap_sig                              -- We need to get the CAF info right here because GHC.Iface.Tidy                              -- does not tidy the IdInfo of implicit bindings (like the wrapper)                              -- so it not make sure that the CAF info is sane                          `setLevityInfoWithType` wrap_ty -             wrap_sig = mkClosedStrictSig wrap_arg_dmds topDiv+             wrap_sig = mkClosedDmdSig wrap_arg_dmds topDiv               wrap_arg_dmds =                replicate (length theta) topDmd ++ map mk_dmd arg_ibangs@@ -782,10 +765,10 @@                                         -- if a user declared a wrong newtype we                                         -- detect this later (see test T2334A)       | otherwise-      = case mb_bangs of-          Nothing    -> zipWith (dataConSrcToImplBang dflags fam_envs)-                                orig_arg_tys orig_bangs-          Just bangs -> bangs+      = case dc_bang_opts of+          SrcBangOpts bang_opts -> zipWith (dataConSrcToImplBang bang_opts fam_envs)+                                    orig_arg_tys orig_bangs+          FixedBangOpts bangs   -> bangs      (rep_tys_w_strs, wrappers)       = unzip (zipWith dataConArgRep all_arg_tys (ev_ibangs ++ arg_ibangs))@@ -822,7 +805,7 @@                          ; (rep_ids, binds) <- go subst2 boxers term_vars                          ; return (ex_vars ++ rep_ids, binds) } ) -    go _ [] src_vars = ASSERT2( null src_vars, ppr data_con ) return ([], [])+    go _ [] src_vars = assertPpr (null src_vars) (ppr data_con) $ return ([], [])     go subst (UnitBox : boxers) (src_var : src_vars)       = do { (rep_ids2, binds) <- go subst boxers src_vars            ; return (src_var : rep_ids2, binds) }@@ -843,13 +826,12 @@  dataConWrapperInlinePragma :: InlinePragma -- See Note [DataCon wrappers are conlike]-dataConWrapperInlinePragma = alwaysInlinePragma { inl_rule = ConLike-                                                , inl_inline = Inline }+dataConWrapperInlinePragma =  alwaysInlineConLikePragma  {- Note [Activation for data constructor wrappers] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The Activation on a data constructor wrapper allows it to inline only in Phase-0. This way rules have a chance to fire if they mention a data constructor on+The Activation on a data constructor wrapper allows it to inline only in FinalPhase.+This way rules have a chance to fire if they mention a data constructor on the left    RULE "foo"  f (K a b) = ... Since the LHS of rules are simplified with InitialPhase, we won't@@ -901,7 +883,6 @@  Note [Bangs on imported data constructors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~- We pass Maybe [HsImplBang] to mkDataConRep to make use of HsImplBangs from imported modules. @@ -989,28 +970,33 @@ -}  --------------------------newLocal :: Scaled Type -> UniqSM Var-newLocal (Scaled w ty) = do { uniq <- getUniqueM-                            ; return (mkSysLocalOrCoVar (fsLit "dt") uniq w ty) }-                 -- We should not have "OrCoVar" here, this is a bug (#17545) +-- | Conjure a fresh local binder.+newLocal :: FastString   -- ^ a string which will form part of the 'Var'\'s name+         -> Scaled Type  -- ^ the type of the 'Var'+         -> UniqSM Var+newLocal name_stem (Scaled w ty) =+    do { uniq <- getUniqueM+       ; return (mkSysLocalOrCoVar name_stem uniq w ty) }+         -- We should not have "OrCoVar" here, this is a bug (#17545) + -- | Unpack/Strictness decisions from source module. -- -- This function should only ever be invoked for data constructor fields, and -- never on the field of a newtype constructor. -- See @Note [HsImplBangs for newtypes]@. dataConSrcToImplBang-   :: DynFlags+   :: BangOpts    -> FamInstEnvs    -> Scaled Type    -> HsSrcBang    -> HsImplBang -dataConSrcToImplBang dflags fam_envs arg_ty+dataConSrcToImplBang bang_opts fam_envs arg_ty                      (HsSrcBang ann unpk NoSrcStrict)-  | xopt LangExt.StrictData dflags -- StrictData => strict field-  = dataConSrcToImplBang dflags fam_envs arg_ty+  | bang_opt_strict_data bang_opts -- StrictData => strict field+  = dataConSrcToImplBang bang_opts fam_envs arg_ty                   (HsSrcBang ann unpk SrcStrict)   | otherwise -- no StrictData => lazy field   = HsLazy@@ -1018,29 +1004,31 @@ dataConSrcToImplBang _ _ _ (HsSrcBang _ _ SrcLazy)   = HsLazy -dataConSrcToImplBang dflags fam_envs arg_ty+dataConSrcToImplBang bang_opts fam_envs arg_ty                      (HsSrcBang _ unpk_prag SrcStrict)   | isUnliftedType (scaledThing arg_ty)+    -- NB: non-newtype data constructors can't have representation-polymorphic fields+    -- so this is OK.   = HsLazy  -- For !Int#, say, use HsLazy             -- See Note [Data con wrappers and unlifted types] -  | not (gopt Opt_OmitInterfacePragmas dflags) -- Don't unpack if -fomit-iface-pragmas-          -- Don't unpack if we aren't optimising; rather arbitrarily,-          -- we use -fomit-iface-pragmas as the indication+  | not (bang_opt_unbox_disable bang_opts) -- Don't unpack if disabled   , let mb_co   = topNormaliseType_maybe fam_envs (scaledThing arg_ty)                      -- Unwrap type families and newtypes-        arg_ty' = case mb_co of { Just (_,ty) -> scaledSet arg_ty ty; Nothing -> arg_ty }-  , isUnpackableType dflags fam_envs (scaledThing arg_ty')+        arg_ty' = case mb_co of+                    { Just redn -> scaledSet arg_ty (reductionReducedType redn)+                    ; Nothing   -> arg_ty }+  , isUnpackableType bang_opts fam_envs (scaledThing arg_ty')   , (rep_tys, _) <- dataConArgUnpack arg_ty'   , case unpk_prag of       NoSrcUnpack ->-        gopt Opt_UnboxStrictFields dflags-            || (gopt Opt_UnboxSmallStrictFields dflags+        bang_opt_unbox_strict bang_opts+            || (bang_opt_unbox_small bang_opts                 && rep_tys `lengthAtMost` 1) -- See Note [Unpack one-wide fields]       srcUnpack -> isSrcUnpacked srcUnpack   = case mb_co of-      Nothing     -> HsUnpack Nothing-      Just (co,_) -> HsUnpack (Just co)+      Nothing   -> HsUnpack Nothing+      Just redn -> HsUnpack (Just $ reductionCoercion redn)    | otherwise -- Record the strict-but-no-unpack decision   = HsStrict@@ -1075,14 +1063,14 @@ wrapCo co rep_ty (unbox_rep, box_rep)  -- co :: arg_ty ~ rep_ty   = (unboxer, boxer)   where-    unboxer arg_id = do { rep_id <- newLocal (Scaled (idMult arg_id) rep_ty)+    unboxer arg_id = do { rep_id <- newLocal (fsLit "cowrap_unbx") (Scaled (idMult arg_id) rep_ty)                         ; (rep_ids, rep_fn) <- unbox_rep rep_id                         ; let co_bind = NonRec rep_id (Var arg_id `Cast` co)                         ; return (rep_ids, Let co_bind . rep_fn) }     boxer = Boxer $ \ subst ->             do { (rep_ids, rep_expr)                     <- case box_rep of-                         UnitBox -> do { rep_id <- newLocal (linear $ TcType.substTy subst rep_ty)+                         UnitBox -> do { rep_id <- newLocal (fsLit "cowrap_bx") (linear $ TcType.substTy subst rep_ty)                                        ; return ([rep_id], Var rep_id) }                          Boxer boxer -> boxer subst                ; let sco = substCoUnchecked subst co@@ -1111,11 +1099,11 @@       -- A recursive newtype might mean that       -- 'arg_ty' is a newtype   , let rep_tys = map (scaleScaled arg_mult) $ dataConInstArgTys con tc_args-  = ASSERT( null (dataConExTyCoVars con) )+  = assert (null (dataConExTyCoVars con))       -- Note [Unpacking GADTs and existentials]     ( rep_tys `zip` dataConRepStrictness con     ,( \ arg_id ->-       do { rep_ids <- mapM newLocal rep_tys+       do { rep_ids <- mapM (newLocal (fsLit "unbx")) rep_tys           ; let r_mult = idMult arg_id           ; let rep_ids' = map (scaleIdBy r_mult) rep_ids           ; let unbox_fn body@@ -1123,7 +1111,7 @@                              (DataAlt con) rep_ids' body           ; return (rep_ids, unbox_fn) }      , Boxer $ \ subst ->-       do { rep_ids <- mapM (newLocal . TcType.substScaledTyUnchecked subst) rep_tys+       do { rep_ids <- mapM (newLocal (fsLit "bx") . TcType.substScaledTyUnchecked subst) rep_tys           ; return (rep_ids, Var (dataConWorkId con)                              `mkTyApps` (substTysUnchecked subst tc_args)                              `mkVarApps` rep_ids ) } ) )@@ -1131,13 +1119,13 @@   = pprPanic "dataConArgUnpack" (ppr arg_ty)     -- An interface file specified Unpacked, but we couldn't unpack it -isUnpackableType :: DynFlags -> FamInstEnvs -> Type -> Bool+isUnpackableType :: BangOpts -> FamInstEnvs -> Type -> Bool -- True if we can unpack the UNPACK the argument type -- See Note [Recursive unboxing] -- We look "deeply" inside rather than relying on the DataCons -- we encounter on the way, because otherwise we might well -- end up relying on ourselves!-isUnpackableType dflags fam_envs ty+isUnpackableType bang_opts fam_envs ty   | Just data_con <- unpackable_type ty   = ok_con_args emptyNameSet data_con   | otherwise@@ -1167,13 +1155,13 @@       = True        -- NB True here, in contrast to False at top level      attempt_unpack (HsSrcBang _ SrcUnpack NoSrcStrict)-      = xopt LangExt.StrictData dflags+      = bang_opt_strict_data bang_opts     attempt_unpack (HsSrcBang _ SrcUnpack SrcStrict)       = True     attempt_unpack (HsSrcBang _  NoSrcUnpack SrcStrict)       = True  -- Be conservative     attempt_unpack (HsSrcBang _  NoSrcUnpack NoSrcStrict)-      = xopt LangExt.StrictData dflags -- Be conservative+      = bang_opt_strict_data bang_opts -- Be conservative     attempt_unpack _ = False      unpackable_type :: Type -> Maybe DataCon@@ -1274,7 +1262,7 @@ -- it, otherwise the wrap/unwrap are both no-ops  wrapNewTypeBody tycon args result_expr-  = ASSERT( isNewTyCon tycon )+  = assert (isNewTyCon tycon) $     mkCast result_expr (mkSymCo co)   where     co = mkUnbranchedAxInstCo Representational (newTyConCo tycon) args []@@ -1286,7 +1274,7 @@  unwrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr unwrapNewTypeBody tycon args result_expr-  = ASSERT( isNewTyCon tycon )+  = assert (isNewTyCon tycon) $     mkCast result_expr (mkUnbranchedAxInstCo Representational (newTyConCo tycon) args [])  -- If the type constructor is a representation type of a data instance, wrap@@ -1304,39 +1292,11 @@ {- ************************************************************************ *                                                                      *-\subsection{Primitive operations}+* Foreign calls *                                                                      * ************************************************************************ -} -mkPrimOpId :: PrimOp -> Id-mkPrimOpId prim_op-  = id-  where-    (tyvars,arg_tys,res_ty, arity, strict_sig) = primOpSig prim_op-    ty   = mkSpecForAllTys 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) name ty info--    -- PrimOps don't ever construct a product, but we want to preserve bottoms-    cpr-      | isDeadEndDiv (snd (splitStrictSig strict_sig)) = botCpr-      | otherwise                                      = topCpr--    info = noCafIdInfo-           `setRuleInfo`           mkRuleInfo (maybeToList $ primOpRules name prim_op)-           `setArityInfo`          arity-           `setStrictnessInfo`     strict_sig-           `setCprInfo`            mkCprSig arity cpr-           `setInlinePragInfo`     neverInlinePragma-           `setLevityInfoWithType` res_ty-               -- 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- -- For each ccall we manufacture a separate CCallOpId, giving it -- a fresh unique, a type that is correct for this particular ccall, -- and a CCall structure that gives the correct details about calling@@ -1346,14 +1306,14 @@ -- details of the ccall, type and all.  This means that the interface -- file reader can reconstruct a suitable Id -mkFCallId :: DynFlags -> Unique -> ForeignCall -> Type -> Id-mkFCallId dflags uniq fcall ty-  = ASSERT( noFreeVarsOfType ty )+mkFCallId :: Unique -> ForeignCall -> Type -> Id+mkFCallId uniq fcall ty+  = assert (noFreeVarsOfType ty) $     -- A CCallOpId should have no free type variables;     -- when doing substitutions won't substitute over it     mkGlobalId (FCallId fcall) name ty info   where-    occ_str = showSDoc dflags (braces (ppr fcall <+> ppr ty))+    occ_str = renderWithContext defaultSDocContext (braces (ppr fcall <+> ppr ty))     -- The "occurrence name" of a ccall is the full info about the     -- ccall; it is encoded, but may have embedded spaces etc! @@ -1361,13 +1321,13 @@      info = noCafIdInfo            `setArityInfo`          arity-           `setStrictnessInfo`     strict_sig-           `setCprInfo`            topCprSig+           `setDmdSigInfo`     strict_sig+           `setCprSigInfo`            topCprSig            `setLevityInfoWithType` ty      (bndrs, _) = tcSplitPiTys ty     arity      = count isAnonTyCoBinder bndrs-    strict_sig = mkClosedStrictSig (replicate arity topDmd) topDiv+    strict_sig = mkClosedDmdSig (replicate arity topDmd) topDiv     -- the call does not claim to be strict in its arguments, since they     -- may be lifted (foreign import prim) and the called code doesn't     -- necessarily force them. See #11076.@@ -1429,14 +1389,13 @@  nullAddrName, seqName,    realWorldName, voidPrimIdName, coercionTokenName,-   magicDictName, coerceName, proxyName,+   coerceName, proxyName,    leftSectionName, rightSectionName :: Name nullAddrName      = mkWiredInIdName gHC_PRIM  (fsLit "nullAddr#")      nullAddrIdKey      nullAddrId seqName           = mkWiredInIdName gHC_PRIM  (fsLit "seq")            seqIdKey           seqId realWorldName     = mkWiredInIdName gHC_PRIM  (fsLit "realWorld#")     realWorldPrimIdKey realWorldPrimId voidPrimIdName    = mkWiredInIdName gHC_PRIM  (fsLit "void#")          voidPrimIdKey      voidPrimId coercionTokenName = mkWiredInIdName gHC_PRIM  (fsLit "coercionToken#") coercionTokenIdKey coercionTokenId-magicDictName     = mkWiredInIdName gHC_PRIM  (fsLit "magicDict")      magicDictKey       magicDictId coerceName        = mkWiredInIdName gHC_PRIM  (fsLit "coerce")         coerceKey          coerceId proxyName         = mkWiredInIdName gHC_PRIM  (fsLit "proxy#")         proxyHashKey       proxyHashId leftSectionName   = mkWiredInIdName gHC_PRIM  (fsLit "leftSection")    leftSectionKey     leftSectionId@@ -1453,7 +1412,7 @@ proxyHashId   = pcMiscPrelId proxyName ty        (noCafIdInfo `setUnfoldingInfo` evaldUnfolding -- Note [evaldUnfoldings]-                    `setNeverLevPoly`  ty)+                    `setNeverRepPoly`  ty)   where     -- proxy# :: forall {k} (a:k). Proxy# k a     --@@ -1473,7 +1432,7 @@   where     info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma                        `setUnfoldingInfo`  mkCompulsoryUnfolding defaultSimpleOpts (Lit nullAddrLit)-                       `setNeverLevPoly`   addrPrimTy+                       `setNeverRepPoly`   addrPrimTy  ------------------------------------------------ seqId :: Id     -- See Note [seqId magic]@@ -1481,6 +1440,7 @@   where     info = noCafIdInfo `setInlinePragInfo` inline_prag                        `setUnfoldingInfo`  mkCompulsoryUnfolding defaultSimpleOpts rhs+                       `setArityInfo`      arity      inline_prag          = alwaysInlinePragma `setInlinePragmaActivation` ActiveAfter@@ -1500,17 +1460,19 @@     rhs = mkLams ([runtimeRep2TyVar, alphaTyVar, openBetaTyVar, x, y]) $           Case (Var x) x openBetaTy [Alt DEFAULT [] (Var y)] +    arity = 2+ ------------------------------------------------ lazyId :: Id    -- See Note [lazyId magic] lazyId = pcMiscPrelId lazyIdName ty info   where-    info = noCafIdInfo `setNeverLevPoly` ty+    info = noCafIdInfo `setNeverRepPoly` ty     ty  = mkSpecForAllTys [alphaTyVar] (mkVisFunTyMany alphaTy alphaTy)  noinlineId :: Id -- See Note [noinlineId magic] noinlineId = pcMiscPrelId noinlineIdName ty info   where-    info = noCafIdInfo `setNeverLevPoly` ty+    info = noCafIdInfo `setNeverRepPoly` ty     ty  = mkSpecForAllTys [alphaTyVar] (mkVisFunTyMany alphaTy alphaTy)  oneShotId :: Id -- See Note [The oneShot function]@@ -1518,6 +1480,7 @@   where     info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma                        `setUnfoldingInfo`  mkCompulsoryUnfolding defaultSimpleOpts rhs+                       `setArityInfo`      arity     ty  = mkInfForAllTys  [ runtimeRep1TyVar, runtimeRep2TyVar ] $           mkSpecForAllTys [ openAlphaTyVar, openBetaTyVar ]      $           mkVisFunTyMany fun_ty fun_ty@@ -1528,25 +1491,26 @@                  , openAlphaTyVar, openBetaTyVar                  , body, x'] $           Var body `App` Var x'+    arity = 2  ---------------------------------------------------------------------- {- Note [Wired-in Ids for rebindable syntax] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The functions leftSectionId, rightSectionId are-wired in here ONLY because they are use in a levity-polymorphic way+wired in here ONLY because they are use in a representation-polymorphic way by the rebindable syntax mechanism. See GHC.Rename.Expr Note [Handling overloaded and rebindable constructs].  Alas, we can't currenly give Haskell definitions for-levity-polymorphic functions.+representation-polymorphic functions. -They have Compulsory unfoldings to so that the levity polymorphism+They have Compulsory unfoldings, so that the representation polymorphism does not linger for long. -}  -- See Note [Left and right sections] in GHC.Rename.Expr -- See Note [Wired-in Ids for rebindable syntax]---   leftSection :: forall r1 r2 n (a:Type r1) (b:TYPE r2).+--   leftSection :: forall r1 r2 n (a::TYPE r1) (b::TYPE r2). --                  (a %n-> b) -> a %n-> b --   leftSection f x = f x -- Important that it is eta-expanded, so that (leftSection undefined `seq` ())@@ -1557,6 +1521,7 @@   where     info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma                        `setUnfoldingInfo`  mkCompulsoryUnfolding defaultSimpleOpts rhs+                       `setArityInfo`      arity     ty  = mkInfForAllTys  [runtimeRep1TyVar,runtimeRep2TyVar, multiplicityTyVar1] $           mkSpecForAllTys [openAlphaTyVar,  openBetaTyVar]    $           exprType body@@ -1568,10 +1533,11 @@     rhs  = mkLams [ runtimeRep1TyVar, runtimeRep2TyVar, multiplicityTyVar1                   , openAlphaTyVar,   openBetaTyVar   ] body     body = mkLams [f,xmult] $ App (Var f) (Var xmult)+    arity = 2  -- See Note [Left and right sections] in GHC.Rename.Expr -- See Note [Wired-in Ids for rebindable syntax]---   rightSection :: forall r1 r2 r3 (a:TYPE r1) (b:TYPE r2) (c:TYPE r3).+--   rightSection :: forall r1 r2 r3 n1 n2 (a::TYPE r1) (b::TYPE r2) (c::TYPE r3). --                   (a %n1 -> b %n2-> c) -> b %n2-> a %n1-> c --   rightSection f y x = f x y -- Again, multiplicity polymorphism is important@@ -1580,6 +1546,7 @@   where     info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma                        `setUnfoldingInfo`  mkCompulsoryUnfolding defaultSimpleOpts rhs+                       `setArityInfo`      arity     ty  = mkInfForAllTys  [runtimeRep1TyVar,runtimeRep2TyVar,runtimeRep3TyVar                           , multiplicityTyVar1, multiplicityTyVar2 ] $           mkSpecForAllTys [openAlphaTyVar,  openBetaTyVar,   openGammaTyVar ]  $@@ -1596,14 +1563,7 @@                   , multiplicityTyVar1, multiplicityTyVar2                   , openAlphaTyVar,   openBetaTyVar,    openGammaTyVar ] body     body = mkLams [f,ymult,xmult] $ mkVarApps (Var f) [xmult,ymult]-----------------------------------------------------------------------------------magicDictId :: Id  -- See Note [magicDictId magic]-magicDictId = pcMiscPrelId magicDictName ty info-  where-  info = noCafIdInfo `setInlinePragInfo` neverInlinePragma-                     `setNeverLevPoly`   ty-  ty   = mkSpecForAllTys [alphaTyVar] alphaTy+    arity = 3  -------------------------------------------------------------------------------- @@ -1612,19 +1572,20 @@   where     info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma                        `setUnfoldingInfo`  mkCompulsoryUnfolding defaultSimpleOpts rhs-    eqRTy     = mkTyConApp coercibleTyCon [ tYPE r , a, b ]-    eqRPrimTy = mkTyConApp eqReprPrimTyCon [ tYPE r, tYPE r, a, b ]+                       `setArityInfo`      2+    eqRTy     = mkTyConApp coercibleTyCon  [ tYPE_r,         a, b ]+    eqRPrimTy = mkTyConApp eqReprPrimTyCon [ tYPE_r, tYPE_r, a, b ]     ty        = mkInvisForAllTys [ Bndr rv InferredSpec                                  , Bndr av SpecifiedSpec-                                 , Bndr bv SpecifiedSpec-                                 ] $+                                 , Bndr bv SpecifiedSpec ] $                 mkInvisFunTyMany eqRTy $                 mkVisFunTyMany a b      bndrs@[rv,av,bv] = mkTemplateKiTyVar runtimeRepTy-                        (\r -> [tYPE r, tYPE r])+                        (\r -> [mkTYPEapp r, mkTYPEapp r])      [r, a, b] = mkTyVarTys bndrs+    tYPE_r    = mkTYPEapp r      [eqR,x,eq] = mkTemplateLocals [eqRTy, a, eqRPrimTy]     rhs = mkLams (bndrs ++ [eqR, x]) $@@ -1647,9 +1608,9 @@     In GHC.Tc.Gen.Expr we used to need a special typing rule for 'seq', to handle calls     whose second argument had an unboxed type, e.g.  x `seq` 3# -    However, with levity polymorphism we can now give seq the type seq ::-    forall (r :: RuntimeRep) a (b :: TYPE r). a -> b -> b which handles this-    case without special treatment in the typechecker.+    However, with representation polymorphism we can now give seq the type+    seq :: forall (r :: RuntimeRep) a (b :: TYPE r). a -> b -> b+    which handles this case without special treatment in the typechecker.  Note [User-defined RULES for seq] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1776,8 +1737,8 @@ if library authors could explicitly tell the compiler that a certain lambda is called at most once. The oneShot function allows that. -'oneShot' is levity-polymorphic, i.e. the type variables can refer to unlifted-types as well (#10744); e.g.+'oneShot' is representation-polymorphic, i.e. the type variables can refer+to unlifted types as well (#10744); e.g.    oneShot (\x:Int# -> x +# 1#)  Like most magic functions it has a compulsory unfolding, so there is no need@@ -1801,54 +1762,6 @@ Also see https://gitlab.haskell.org/ghc/ghc/wikis/one-shot.  -Note [magicDictId magic]-~~~~~~~~~~~~~~~~~~~~~~~~~-The identifier `magicDict` is just a place-holder, which is used to-implement a primitive that we cannot define in Haskell but we can write-in Core.  It is declared with a place-holder type:--    magicDict :: forall a. a--The intention is that the identifier will be used in a very specific way,-to create dictionaries for classes with a single method.  Consider a class-like this:--   class C a where-     f :: T a--We are going to use `magicDict`, in conjunction with a built-in Prelude-rule, to cast values of type `T a` into dictionaries for `C a`.  To do-this, we define a function like this in the library:--  data WrapC a b = WrapC (C a => Proxy a -> b)--  withT :: (C a => Proxy a -> b)-        ->  T a -> Proxy a -> b-  withT f x y = magicDict (WrapC f) x y--The purpose of `WrapC` is to avoid having `f` instantiated.-Also, it avoids impredicativity, because `magicDict`'s type-cannot be instantiated with a forall.  The field of `WrapC` contains-a `Proxy` parameter which is used to link the type of the constraint,-`C a`, with the type of the `Wrap` value being made.--Next, we add a built-in Prelude rule (see GHC.Core.Opt.ConstantFold),-which will replace the RHS of this definition with the appropriate-definition in Core.  The rewrite rule works as follows:--  magicDict @t (wrap @a @b f) x y----->-  f (x `cast` co a) y--The `co` coercion is the newtype-coercion extracted from the type-class.-The type class is obtained by looking at the type of wrap.--In the constant folding rule it's very import to make sure to strip all ticks-from the expression as if there's an occurence of-magicDict we *must* convert it for correctness. See #19667 for where this went-wrong in GHCi.-- ------------------------------------------------------------- @realWorld#@ used to be a magic literal, \tr{void#}.  If things get nasty as-is, change it back to a literal (@Literal@).@@ -1872,7 +1785,7 @@ realWorldPrimId = pcMiscPrelId realWorldName realWorldStatePrimTy                      (noCafIdInfo `setUnfoldingInfo` evaldUnfolding    -- Note [evaldUnfoldings]                                   `setOneShotInfo`   stateHackOneShot-                                  `setNeverLevPoly`  realWorldStatePrimTy)+                                  `setNeverRepPoly`  realWorldStatePrimTy)  voidPrimId :: Id     -- Global constant :: Void#                      -- The type Void# is now the same as (# #) (ticket #18441),@@ -1882,7 +1795,7 @@                      -- a top-level unlifted value. voidPrimId  = pcMiscPrelId voidPrimIdName unboxedUnitTy                 (noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding defaultSimpleOpts rhs-                             `setNeverLevPoly`  unboxedUnitTy)+                             `setNeverRepPoly`  unboxedUnitTy)     where rhs = Var (dataConWorkId unboxedUnitDataCon)
GHC/Types/Id/Make.hs-boot view
@@ -3,14 +3,8 @@ import GHC.Types.Var( Id ) import GHC.Core.Class( Class ) import {-# SOURCE #-} GHC.Core.DataCon( DataCon )-import {-# SOURCE #-} GHC.Builtin.PrimOps( PrimOp )  data DataConBoxer  mkDataConWorkId :: Name -> DataCon -> Id mkDictSelId     :: Name -> Class   -> Id--mkPrimOpId      :: PrimOp -> Id-voidPrimId      :: Id--magicDictId :: Id
GHC/Types/Literal.hs view
@@ -4,7 +4,7 @@  -} -{-# LANGUAGE CPP, DeriveDataTypeable, ScopedTypeVariables #-}+{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE AllowAmbiguousTypes #-}@@ -31,13 +31,14 @@         , mkLitWord64, mkLitWord64Wrap, mkLitWord64Unchecked         , mkLitFloat, mkLitDouble         , mkLitChar, mkLitString-        , mkLitInteger, mkLitNatural+        , mkLitBigNat         , mkLitNumber, mkLitNumberWrap          -- ** Operations on Literals         , literalType         , pprLiteral         , litNumIsSigned+        , litNumRange         , litNumCheckRange         , litNumWrap         , litNumCoerce@@ -63,12 +64,9 @@         , nullAddrLit, floatToDoubleLit, doubleToFloatLit         ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Builtin.Types.Prim-import {-# SOURCE #-} GHC.Builtin.Types import GHC.Core.Type import GHC.Utils.Outputable import GHC.Data.FastString@@ -76,8 +74,8 @@ import GHC.Utils.Binary import GHC.Settings.Constants import GHC.Platform-import GHC.Utils.Misc import GHC.Utils.Panic+import GHC.Utils.Encoding  import Data.ByteString (ByteString) import Data.Int@@ -164,8 +162,7 @@  -- | Numeric literal type data LitNumType-  = LitNumInteger -- ^ @Integer@ (see Note [BigNum literals])-  | LitNumNatural -- ^ @Natural@ (see Note [BigNum literals])+  = LitNumBigNat  -- ^ @Bignat@ (see Note [BigNum literals])   | LitNumInt     -- ^ @Int#@ - according to target machine   | LitNumInt8    -- ^ @Int8#@ - exactly 8 bits   | LitNumInt16   -- ^ @Int16#@ - exactly 16 bits@@ -181,8 +178,7 @@ -- | Indicate if a numeric literal type supports negative numbers litNumIsSigned :: LitNumType -> Bool litNumIsSigned nt = case nt of-  LitNumInteger -> True-  LitNumNatural -> False+  LitNumBigNat  -> False   LitNumInt     -> True   LitNumInt8    -> True   LitNumInt16   -> True@@ -197,8 +193,7 @@ -- | Number of bits litNumBitSize :: Platform -> LitNumType -> Maybe Word litNumBitSize platform nt = case nt of-  LitNumInteger -> Nothing-  LitNumNatural -> Nothing+  LitNumBigNat  -> Nothing   LitNumInt     -> Just (fromIntegral (platformWordSizeInBits platform))   LitNumInt8    -> Just 8   LitNumInt16   -> Just 16@@ -219,17 +214,29 @@ {- Note [BigNum literals] ~~~~~~~~~~~~~~~~~~~~~~-GHC supports 2 kinds of arbitrary precision integers (a.k.a BigNum):+GHC supports 2 kinds of arbitrary precision numbers (a.k.a BigNum): -   * Natural: natural represented as a Word# or as a BigNat+   * data Natural = NS Word# | NB BigNat# -   * Integer: integer represented a an Int# or as a BigNat (Integer's-   constructors indicate the sign)+   * data Integer = IS Int# | IN BigNat# | IP BigNat# -BigNum literal instances are removed from Core during the CorePrep phase. They-are replaced with expression to build them at runtime from machine literals-(Word#, Int#, etc.) or from a list of Word#s.+In the past, we had Core constructors to represent Integer and Natural literals.+These literals were then lowered into their real Core representation only in+Core prep. The issue with this approach is that literals have two+representations and we have to ensure that we handle them the same everywhere+(in every optimisation, etc.). +For example (0 :: Integer) was representable in Core with both:++    Lit (LitNumber LitNumInteger 0)                          -- literal+    App (Var integerISDataCon) (Lit (LitNumber LitNumInt 0)) -- real representation++Nowadays we always use the real representation for Integer and Natural literals.+However we still have two representations for BigNat# literals. BigNat# literals+are still lowered in Core prep into a call to a constructor function (BigNat# is+ByteArray# and we don't have ByteArray# literals yet so we have to build them at+runtime).+ Note [String literals] ~~~~~~~~~~~~~~~~~~~~~~ String literals are UTF-8 encoded and stored into ByteStrings in the following@@ -342,9 +349,8 @@   LitNumWord16  -> wrap @Word16   LitNumWord32  -> wrap @Word32   LitNumWord64  -> wrap @Word64-  LitNumInteger -> LitNumber nt i-  LitNumNatural-    | i < 0     -> panic "mkLitNumberWrap: trying to create a negative Natural"+  LitNumBigNat+    | i < 0     -> panic "mkLitNumberWrap: trying to create a negative BigNat"     | otherwise -> LitNumber nt i   where     wrap :: forall a. (Integral a, Num a) => Literal@@ -372,29 +378,40 @@  -- | Check that a given number is in the range of a numeric literal litNumCheckRange :: Platform -> LitNumType -> Integer -> Bool-litNumCheckRange platform nt i = case nt of-     LitNumInt     -> platformInIntRange platform i-     LitNumWord    -> platformInWordRange platform i-     LitNumInt8    -> inBoundedRange @Int8 i-     LitNumInt16   -> inBoundedRange @Int16 i-     LitNumInt32   -> inBoundedRange @Int32 i-     LitNumInt64   -> inBoundedRange @Int64 i-     LitNumWord8   -> inBoundedRange @Word8 i-     LitNumWord16  -> inBoundedRange @Word16 i-     LitNumWord32  -> inBoundedRange @Word32 i-     LitNumWord64  -> inBoundedRange @Word64 i-     LitNumNatural -> i >= 0-     LitNumInteger -> True+litNumCheckRange platform nt i =+    maybe True (i >=) m_lower &&+    maybe True (i <=) m_upper+  where+    (m_lower, m_upper) = litNumRange platform nt +-- | Get the literal range+litNumRange :: Platform -> LitNumType -> (Maybe Integer, Maybe Integer)+litNumRange platform nt = case nt of+     LitNumInt     -> (Just (platformMinInt platform), Just (platformMaxInt platform))+     LitNumWord    -> (Just 0, Just (platformMaxWord platform))+     LitNumInt8    -> bounded_range @Int8+     LitNumInt16   -> bounded_range @Int16+     LitNumInt32   -> bounded_range @Int32+     LitNumInt64   -> bounded_range @Int64+     LitNumWord8   -> bounded_range @Word8+     LitNumWord16  -> bounded_range @Word16+     LitNumWord32  -> bounded_range @Word32+     LitNumWord64  -> bounded_range @Word64+     LitNumBigNat  -> (Just 0, Nothing)+  where+    bounded_range :: forall a . (Integral a, Bounded a) => (Maybe Integer,Maybe Integer)+    bounded_range = case boundedRange @a of+      (mi,ma) -> (Just mi, Just ma)+ -- | Create a numeric 'Literal' of the given type mkLitNumber :: Platform -> LitNumType -> Integer -> Literal mkLitNumber platform nt i =-  ASSERT2(litNumCheckRange platform nt i, integer i)+  assertPpr (litNumCheckRange platform nt i) (integer i)   (LitNumber nt i)  -- | Creates a 'Literal' of type @Int#@ mkLitInt :: Platform -> Integer -> Literal-mkLitInt platform x = ASSERT2( platformInIntRange platform x,  integer x )+mkLitInt platform x = assertPpr (platformInIntRange platform x) (integer x)                        (mkLitIntUnchecked x)  -- | Creates a 'Literal' of type @Int#@.@@ -418,7 +435,7 @@  -- | Creates a 'Literal' of type @Word#@ mkLitWord :: Platform -> Integer -> Literal-mkLitWord platform x = ASSERT2( platformInWordRange platform x, integer x )+mkLitWord platform x = assertPpr (platformInWordRange platform x) (integer x)                         (mkLitWordUnchecked x)  -- | Creates a 'Literal' of type @Word#@.@@ -442,7 +459,7 @@  -- | Creates a 'Literal' of type @Int8#@ mkLitInt8 :: Integer -> Literal-mkLitInt8  x = ASSERT2( inBoundedRange @Int8 x, integer x ) (mkLitInt8Unchecked x)+mkLitInt8  x = assertPpr (inBoundedRange @Int8 x) (integer x) (mkLitInt8Unchecked x)  -- | Creates a 'Literal' of type @Int8#@. --   If the argument is out of the range, it is wrapped.@@ -455,7 +472,7 @@  -- | Creates a 'Literal' of type @Word8#@ mkLitWord8 :: Integer -> Literal-mkLitWord8 x = ASSERT2( inBoundedRange @Word8 x, integer x ) (mkLitWord8Unchecked x)+mkLitWord8 x = assertPpr (inBoundedRange @Word8 x) (integer x) (mkLitWord8Unchecked x)  -- | Creates a 'Literal' of type @Word8#@. --   If the argument is out of the range, it is wrapped.@@ -468,7 +485,7 @@  -- | Creates a 'Literal' of type @Int16#@ mkLitInt16 :: Integer -> Literal-mkLitInt16  x = ASSERT2( inBoundedRange @Int16 x, integer x ) (mkLitInt16Unchecked x)+mkLitInt16  x = assertPpr (inBoundedRange @Int16 x) (integer x) (mkLitInt16Unchecked x)  -- | Creates a 'Literal' of type @Int16#@. --   If the argument is out of the range, it is wrapped.@@ -481,7 +498,7 @@  -- | Creates a 'Literal' of type @Word16#@ mkLitWord16 :: Integer -> Literal-mkLitWord16 x = ASSERT2( inBoundedRange @Word16 x, integer x ) (mkLitWord16Unchecked x)+mkLitWord16 x = assertPpr (inBoundedRange @Word16 x) (integer x) (mkLitWord16Unchecked x)  -- | Creates a 'Literal' of type @Word16#@. --   If the argument is out of the range, it is wrapped.@@ -494,7 +511,7 @@  -- | Creates a 'Literal' of type @Int32#@ mkLitInt32 :: Integer -> Literal-mkLitInt32  x = ASSERT2( inBoundedRange @Int32 x, integer x ) (mkLitInt32Unchecked x)+mkLitInt32  x = assertPpr (inBoundedRange @Int32 x) (integer x) (mkLitInt32Unchecked x)  -- | Creates a 'Literal' of type @Int32#@. --   If the argument is out of the range, it is wrapped.@@ -507,7 +524,7 @@  -- | Creates a 'Literal' of type @Word32#@ mkLitWord32 :: Integer -> Literal-mkLitWord32 x = ASSERT2( inBoundedRange @Word32 x, integer x ) (mkLitWord32Unchecked x)+mkLitWord32 x = assertPpr (inBoundedRange @Word32 x) (integer x) (mkLitWord32Unchecked x)  -- | Creates a 'Literal' of type @Word32#@. --   If the argument is out of the range, it is wrapped.@@ -520,7 +537,7 @@  -- | Creates a 'Literal' of type @Int64#@ mkLitInt64 :: Integer -> Literal-mkLitInt64  x = ASSERT2( inBoundedRange @Int64 x, integer x ) (mkLitInt64Unchecked x)+mkLitInt64  x = assertPpr (inBoundedRange @Int64 x) (integer x) (mkLitInt64Unchecked x)  -- | Creates a 'Literal' of type @Int64#@. --   If the argument is out of the range, it is wrapped.@@ -533,7 +550,7 @@  -- | Creates a 'Literal' of type @Word64#@ mkLitWord64 :: Integer -> Literal-mkLitWord64 x = ASSERT2( inBoundedRange @Word64 x, integer x ) (mkLitWord64Unchecked x)+mkLitWord64 x = assertPpr (inBoundedRange @Word64 x) (integer x) (mkLitWord64Unchecked x)  -- | Creates a 'Literal' of type @Word64#@. --   If the argument is out of the range, it is wrapped.@@ -560,26 +577,24 @@ -- e.g. some of the \"error\" functions in GHC.Err such as @GHC.Err.runtimeError@ mkLitString :: String -> Literal -- stored UTF-8 encoded-mkLitString s = LitString (bytesFS $ mkFastString s)--mkLitInteger :: Integer -> Literal-mkLitInteger x = LitNumber LitNumInteger x+mkLitString [] = LitString mempty+mkLitString s  = LitString (utf8EncodeString s) -mkLitNatural :: Integer -> Literal-mkLitNatural x = ASSERT2( inNaturalRange x,  integer x )-                    (LitNumber LitNumNatural x)+mkLitBigNat :: Integer -> Literal+mkLitBigNat x = assertPpr (x >= 0) (integer x)+                    (LitNumber LitNumBigNat x)  isLitRubbish :: Literal -> Bool isLitRubbish (LitRubbish {}) = True isLitRubbish _               = False -inNaturalRange :: Integer -> Bool-inNaturalRange x = x >= 0- inBoundedRange :: forall a. (Bounded a, Integral a) => Integer -> Bool inBoundedRange x  = x >= toInteger (minBound :: a) &&                     x <= toInteger (maxBound :: a) +boundedRange :: forall a. (Bounded a, Integral a) => (Integer,Integer)+boundedRange = (toInteger (minBound :: a), toInteger (maxBound :: a))+ isMinBound :: Platform -> Literal -> Bool isMinBound _        (LitChar c)        = c == minBound isMinBound platform (LitNumber nt i)   = case nt of@@ -593,8 +608,7 @@    LitNumWord16  -> i == 0    LitNumWord32  -> i == 0    LitNumWord64  -> i == 0-   LitNumNatural -> i == 0-   LitNumInteger -> False+   LitNumBigNat  -> i == 0 isMinBound _        _                  = False  isMaxBound :: Platform -> Literal -> Bool@@ -610,8 +624,7 @@    LitNumWord16  -> i == toInteger (maxBound :: Word16)    LitNumWord32  -> i == toInteger (maxBound :: Word32)    LitNumWord64  -> i == toInteger (maxBound :: Word64)-   LitNumNatural -> False-   LitNumInteger -> False+   LitNumBigNat  -> False isMaxBound _        _                  = False  inCharRange :: Char -> Bool@@ -632,7 +645,7 @@ isOneLit _               = False  -- | Returns the 'Integer' contained in the 'Literal', for when that makes--- sense, i.e. for 'Char', 'Int', 'Word', 'LitInteger' and 'LitNatural'.+-- sense, i.e. for 'Char' and numbers. litValue  :: Literal -> Integer litValue l = case isLitValue_maybe l of    Just x  -> x@@ -757,8 +770,7 @@ --      c.f. GHC.Core.Utils.exprIsTrivial litIsTrivial (LitString _)    = False litIsTrivial (LitNumber nt _) = case nt of-  LitNumInteger -> False-  LitNumNatural -> False+  LitNumBigNat  -> False   LitNumInt     -> True   LitNumInt8    -> True   LitNumInt16   -> True@@ -775,9 +787,8 @@ litIsDupable :: Platform -> Literal -> Bool --      c.f. GHC.Core.Utils.exprIsDupable litIsDupable platform x = case x of-   (LitNumber nt i) -> case nt of-      LitNumInteger -> platformInIntRange platform i-      LitNumNatural -> platformInWordRange platform i+   LitNumber nt i -> case nt of+      LitNumBigNat  -> i <= platformMaxWord platform * 8 -- arbitrary, reasonable       LitNumInt     -> True       LitNumInt8    -> True       LitNumInt16   -> True@@ -788,8 +799,8 @@       LitNumWord16  -> True       LitNumWord32  -> True       LitNumWord64  -> True-   (LitString _) -> False-   _             -> True+   LitString _ -> False+   _           -> True  litFitsInChar :: Literal -> Bool litFitsInChar (LitNumber _ i) = i >= toInteger (ord minBound)@@ -798,8 +809,7 @@  litIsLifted :: Literal -> Bool litIsLifted (LitNumber nt _) = case nt of-  LitNumInteger -> True-  LitNumNatural -> True+  LitNumBigNat  -> True   LitNumInt     -> False   LitNumInt8    -> False   LitNumInt16   -> False@@ -827,8 +837,7 @@ literalType (LitDouble _)     = doublePrimTy literalType (LitLabel _ _ _)  = addrPrimTy literalType (LitNumber lt _)  = case lt of-   LitNumInteger -> integerTy-   LitNumNatural -> naturalTy+   LitNumBigNat  -> byteArrayPrimTy    LitNumInt     -> intPrimTy    LitNumInt8    -> int8PrimTy    LitNumInt16   -> int16PrimTy@@ -844,7 +853,7 @@ literalType (LitRubbish rep)   = mkForAllTy a Inferred (mkTyVarTy a)   where-    a = mkTemplateKindVar (tYPE rep)+    a = mkTemplateKindVar (mkTYPEapp rep)  {-         Comparison@@ -877,10 +886,9 @@ pprLiteral _       (LitNullAddr)   = text "__NULL" pprLiteral _       (LitFloat f)    = float (fromRat f) <> primFloatSuffix pprLiteral _       (LitDouble d)   = double (fromRat d) <> primDoubleSuffix-pprLiteral add_par (LitNumber nt i)+pprLiteral _       (LitNumber nt i)    = case nt of-       LitNumInteger -> pprIntegerVal add_par i-       LitNumNatural -> pprIntegerVal add_par i+       LitNumBigNat  -> integer i        LitNumInt     -> pprPrimInt i        LitNumInt8    -> pprPrimInt8 i        LitNumInt16   -> pprPrimInt16 i@@ -899,17 +907,12 @@ pprLiteral _       (LitRubbish rep)   = text "RUBBISH" <> parens (ppr rep) -pprIntegerVal :: (SDoc -> SDoc) -> Integer -> SDoc--- See Note [Printing of literals in Core].-pprIntegerVal add_par i | i < 0     = add_par (integer i)-                        | otherwise = integer i- {- Note [Printing of literals in Core] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The function `add_par` is used to wrap parenthesis around negative integers-(`LitInteger`) and labels (`LitLabel`), if they occur in a context requiring-an atomic thing (for example function application).+The function `add_par` is used to wrap parenthesis around labels (`LitLabel`),+if they occur in a context requiring an atomic thing (for example function+application).  Although not all Core literals would be valid Haskell, we are trying to stay as close as possible to Haskell syntax in the printing of Core, to make it@@ -937,7 +940,7 @@ LitWordN         1##N LitFloat        -1.0# LitDouble       -1.0##-LitInteger      -1                 (-1)+LitBigNat       1 LitLabel        "__label" ...      ("__label" ...) LitRubbish      "RUBBISH[...]" @@ -1030,7 +1033,7 @@    Moreover, rubbish literals should not appear in patterns anyway.  d) Why not lower LitRubbish in CoreToStg? Because it enables us to use-   RubbishLit when unarising unboxed sums in the future, and it allows+   LitRubbish when unarising unboxed sums in the future, and it allows    rubbish values of e.g.  VecRep, for which we can't cough up dummy    values in STG.
GHC/Types/Name.hs view
@@ -56,6 +56,7 @@         localiseName,          nameSrcLoc, nameSrcSpan, pprNameDefnLoc, pprDefinedAt,+        pprFullName, pprTickyName,          -- ** Predicates on 'Name's         isSystemName, isInternalName, isExternalName,@@ -64,7 +65,7 @@         isWiredInName, isWiredIn, isBuiltInSyntax,         isHoleName,         wiredInNameTyThing_maybe,-        nameIsLocalOrFrom, nameIsHomePackage,+        nameIsLocalOrFrom, nameIsExternalOrFrom, nameIsHomePackage,         nameIsHomePackageImport, nameIsFromExternalPackage,         stableNameCmp, @@ -198,6 +199,7 @@  {- Note [About the NameSorts]+~~~~~~~~~~~~~~~~~~~~~~~~~~  1.  Initially, top-level Ids (including locally-defined ones) get External names,     and all other local Ids get Internal names@@ -327,6 +329,9 @@ nameModule_maybe (Name { n_sort = WiredIn mod _ _}) = Just mod nameModule_maybe _                                  = Nothing +is_interactive_or_from :: Module -> Module -> Bool+is_interactive_or_from from mod = from == mod || isInteractiveModule mod+ nameIsLocalOrFrom :: Module -> Name -> Bool -- ^ Returns True if the name is --   (a) Internal@@ -351,9 +356,16 @@ -- See Note [The interactive package] in "GHC.Runtime.Context"  nameIsLocalOrFrom from name-  | Just mod <- nameModule_maybe name = from == mod || isInteractiveModule mod+  | Just mod <- nameModule_maybe name = is_interactive_or_from from mod   | otherwise                         = True +nameIsExternalOrFrom :: Module -> Name -> Bool+-- ^ Returns True if the name is external or from the 'interactive' package+-- See documentation of `nameIsLocalOrFrom` function+nameIsExternalOrFrom from name+  | Just mod <- nameModule_maybe name = is_interactive_or_from from mod+  | otherwise                         = False+ nameIsHomePackage :: Module -> Name -> Bool -- True if the Name is defined in module of this package nameIsHomePackage this_mod@@ -552,11 +564,7 @@  -- For a deterministic lexicographic ordering, use `stableNameCmp`. instance Ord Name where-    a <= b = case (a `compare` b) of { LT -> True;  EQ -> True;  GT -> False }-    a <  b = case (a `compare` b) of { LT -> True;  EQ -> False; GT -> False }-    a >= b = case (a `compare` b) of { LT -> False; EQ -> True;  GT -> True  }-    a >  b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True  }-    compare a b = cmpName a b+    compare = cmpName  instance Uniquable Name where     getUnique = nameUnique@@ -616,6 +624,31 @@       External mod            -> pprExternal debug sty uniq mod occ False UserSyntax       System                  -> pprSystem   debug sty uniq occ       Internal                -> pprInternal debug sty uniq occ++-- | Print fully qualified name (with unit-id, module and unique)+pprFullName :: Module -> Name -> SDoc+pprFullName this_mod Name{n_sort = sort, n_uniq = uniq, n_occ = occ} =+  let mod = case sort of+        WiredIn  m _ _ -> m+        External m     -> m+        System         -> this_mod+        Internal       -> this_mod+      in ftext (unitIdFS (moduleUnitId mod))+         <> colon    <> ftext (moduleNameFS $ moduleName mod)+         <> dot      <> ftext (occNameFS occ)+         <> char '_' <> pprUniqueAlways uniq+++-- | Print a ticky ticky styled name+--+-- Module argument is the module to use for internal and system names. When+-- printing the name in a ticky profile, the module name is included even for+-- local things. However, ticky uses the format "x (M)" rather than "M.x".+-- Hence, this function provides a separation from normal styling.+pprTickyName :: Module -> Name -> SDoc+pprTickyName this_mod name+  | isInternalName name = pprName name <+> parens (ppr this_mod)+  | otherwise           = pprName name  -- | Print the string of Name unqualifiedly directly. pprNameUnqualified :: Name -> SDoc
GHC/Types/Name/Cache.hs view
@@ -1,15 +1,22 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE RankNTypes #-}  -- | The Name Cache module GHC.Types.Name.Cache-    ( lookupOrigNameCache-    , extendOrigNameCache-    , extendNameCache-    , initNameCache-    , NameCache(..), OrigNameCache-    ) where+  ( NameCache (..)+  , initNameCache+  , takeUniqFromNameCache+  , updateNameCache'+  , updateNameCache +  -- * OrigNameCache+  , OrigNameCache+  , lookupOrigNameCache+  , extendOrigNameCache'+  , extendOrigNameCache+  )+where+ import GHC.Prelude  import GHC.Unit.Module@@ -18,11 +25,11 @@ import GHC.Builtin.Types import GHC.Builtin.Names -import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic -#include "HsVersions.h"+import Control.Concurrent.MVar+import Control.Monad  {- @@ -41,7 +48,13 @@ When you make an External name, you should probably be calling one of them. +Names in a NameCache are always stored as a Global, and have the SrcLoc of their+binding locations.  Actually that's not quite right.  When we first encounter+the original name, we might not be at its binding site (e.g. we are reading an+interface file); so we give it 'noSrcLoc' then.  Later, when we find its binding+site, we fix it up. + Note [Built-in syntax and the OrigNameCache] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -73,10 +86,20 @@     go this route (#8954).  -}+-- | The NameCache makes sure that there is just one Unique assigned for+-- each original name; i.e. (module-name, occ-name) pair and provides+-- something of a lookup mechanism for those names.+data NameCache = NameCache+  { nsUniqChar :: {-# UNPACK #-} !Char+  , nsNames    :: {-# UNPACK #-} !(MVar OrigNameCache)+  }  -- | Per-module cache of original 'OccName's given 'Name's type OrigNameCache   = ModuleEnv (OccEnv Name) +takeUniqFromNameCache :: NameCache -> IO Unique+takeUniqFromNameCache (NameCache c _) = uniqFromMask c+ lookupOrigNameCache :: OrigNameCache -> Module -> OccName -> Maybe Name lookupOrigNameCache nc mod occ   | mod == gHC_TYPES || mod == gHC_PRIM || mod == gHC_TUPLE@@ -91,32 +114,47 @@         Nothing      -> Nothing         Just occ_env -> lookupOccEnv occ_env occ -extendOrigNameCache :: OrigNameCache -> Name -> OrigNameCache-extendOrigNameCache nc name-  = ASSERT2( isExternalName name, ppr name )-    extendNameCache nc (nameModule name) (nameOccName name) name+extendOrigNameCache' :: OrigNameCache -> Name -> OrigNameCache+extendOrigNameCache' nc name+  = assertPpr (isExternalName name) (ppr name) $+    extendOrigNameCache nc (nameModule name) (nameOccName name) name -extendNameCache :: OrigNameCache -> Module -> OccName -> Name -> OrigNameCache-extendNameCache nc mod occ name+extendOrigNameCache :: OrigNameCache -> Module -> OccName -> Name -> OrigNameCache+extendOrigNameCache nc mod occ name   = extendModuleEnvWith combine nc mod (unitOccEnv occ name)   where     combine _ occ_env = extendOccEnv occ_env occ name --- | The NameCache makes sure that there is just one Unique assigned for--- each original name; i.e. (module-name, occ-name) pair and provides--- something of a lookup mechanism for those names.-data NameCache- = NameCache {  nsUniqs :: !UniqSupply,-                -- ^ Supply of uniques-                nsNames :: !OrigNameCache-                -- ^ Ensures that one original name gets one unique-   }---- | Return a function to atomically update the name cache.-initNameCache :: UniqSupply -> [Name] -> NameCache-initNameCache us names-  = NameCache { nsUniqs = us,-                nsNames = initOrigNames names }+initNameCache :: Char -> [Name] -> IO NameCache+initNameCache c names = NameCache c <$> newMVar (initOrigNames names)  initOrigNames :: [Name] -> OrigNameCache-initOrigNames names = foldl' extendOrigNameCache emptyModuleEnv names+initOrigNames names = foldl' extendOrigNameCache' emptyModuleEnv names++-- | Update the name cache with the given function+updateNameCache'+  :: NameCache+  -> (OrigNameCache -> IO (OrigNameCache, c))  -- The updating function+  -> IO c+updateNameCache' (NameCache _c nc) upd_fn = modifyMVar' nc upd_fn++-- this should be in `base`+modifyMVar' :: MVar a -> (a -> IO (a,b)) -> IO b+modifyMVar' m f = modifyMVar m $ f >=> \c -> fst c `seq` pure c++-- | Update the name cache with the given function+--+-- Additionally, it ensures that the given Module and OccName are evaluated.+-- If not, chaos can ensue:+--      we read the name-cache+--      then pull on mod (say)+--      which does some stuff that modifies the name cache+-- This did happen, with tycon_mod in GHC.IfaceToCore.tcIfaceAlt (DataAlt..)+updateNameCache+  :: NameCache+  -> Module+  -> OccName+  -> (OrigNameCache -> IO (OrigNameCache, c))+  -> IO c+updateNameCache name_cache !_mod !_occ upd_fn+  = updateNameCache' name_cache upd_fn
GHC/Types/Name/Env.hs view
@@ -5,7 +5,7 @@ \section[NameEnv]{@NameEnv@: name environments} -} -{-# LANGUAGE CPP #-}+ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -16,27 +16,31 @@         -- ** Manipulating these environments         mkNameEnv, mkNameEnvWith,         emptyNameEnv, isEmptyNameEnv,-        unitNameEnv, nameEnvElts,+        unitNameEnv, nonDetNameEnvElts,         extendNameEnv_C, extendNameEnv_Acc, extendNameEnv,         extendNameEnvList, extendNameEnvList_C,         filterNameEnv, anyNameEnv,         plusNameEnv, plusNameEnv_C, plusNameEnv_CD, plusNameEnv_CD2, alterNameEnv,         lookupNameEnv, lookupNameEnv_NF, delFromNameEnv, delListFromNameEnv,         elemNameEnv, mapNameEnv, disjointNameEnv,+        seqEltsNameEnv,          DNameEnv,          emptyDNameEnv,+        isEmptyDNameEnv,         lookupDNameEnv,         delFromDNameEnv, filterDNameEnv,         mapDNameEnv,         adjustDNameEnv, alterDNameEnv, extendDNameEnv,+        eltsDNameEnv, extendDNameEnv_C,+        plusDNameEnv_C,+        foldDNameEnv,+        nonDetStrictFoldDNameEnv,         -- ** Dependency analysis         depAnal     ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Data.Graph.Directed@@ -99,7 +103,7 @@ isEmptyNameEnv     :: NameEnv a -> Bool mkNameEnv          :: [(Name,a)] -> NameEnv a mkNameEnvWith      :: (a -> Name) -> [a] -> NameEnv a-nameEnvElts        :: NameEnv a -> [a]+nonDetNameEnvElts  :: NameEnv a -> [a] alterNameEnv       :: (Maybe a-> Maybe a) -> NameEnv a -> Name -> NameEnv a extendNameEnv_C    :: (a->a->a) -> NameEnv a -> Name -> a -> NameEnv a extendNameEnv_Acc  :: (a->b->b) -> (a->b) -> NameEnv b -> Name -> a -> NameEnv b@@ -120,8 +124,9 @@ anyNameEnv         :: (elt -> Bool) -> NameEnv elt -> Bool mapNameEnv         :: (elt1 -> elt2) -> NameEnv elt1 -> NameEnv elt2 disjointNameEnv    :: NameEnv a -> NameEnv a -> Bool+seqEltsNameEnv     :: (elt -> ()) -> NameEnv elt -> () -nameEnvElts x         = eltsUFM x+nonDetNameEnvElts x         = nonDetEltsUFM x emptyNameEnv          = emptyUFM isEmptyNameEnv        = isNullUFM unitNameEnv x y       = unitUFM x y@@ -146,6 +151,7 @@ filterNameEnv x y       = filterUFM x y anyNameEnv f x          = foldUFM ((||) . f) False x disjointNameEnv x y     = disjointUFM x y+seqEltsNameEnv seqElt x = seqEltsUFM seqElt x  lookupNameEnv_NF env n = expectJust "lookupNameEnv_NF" (lookupNameEnv env n) @@ -158,6 +164,9 @@ emptyDNameEnv :: DNameEnv a emptyDNameEnv = emptyUDFM +isEmptyDNameEnv :: DNameEnv a -> Bool+isEmptyDNameEnv = isNullUDFM+ lookupDNameEnv :: DNameEnv a -> Name -> Maybe a lookupDNameEnv = lookupUDFM @@ -178,3 +187,19 @@  extendDNameEnv :: DNameEnv a -> Name -> a -> DNameEnv a extendDNameEnv = addToUDFM++extendDNameEnv_C :: (a -> a -> a) -> DNameEnv a -> Name -> a -> DNameEnv a+extendDNameEnv_C = addToUDFM_C++eltsDNameEnv :: DNameEnv a -> [a]+eltsDNameEnv = eltsUDFM++foldDNameEnv :: (a -> b -> b) -> b -> DNameEnv a -> b+foldDNameEnv = foldUDFM++plusDNameEnv_C :: (elt -> elt -> elt) -> DNameEnv elt -> DNameEnv elt -> DNameEnv elt+plusDNameEnv_C = plusUDFM_C++nonDetStrictFoldDNameEnv :: (a -> b -> b) -> b -> DNameEnv a -> b+nonDetStrictFoldDNameEnv = nonDetStrictFoldUDFM+
GHC/Types/Name/Occurrence.hs view
@@ -28,8 +28,6 @@         -- * The 'NameSpace' type         NameSpace, -- Abstract -        nameSpacesRelated,-         -- ** Construction         -- $real_vs_source_data_constructors         tcName, clsName, tcClsName, dataName, varName,@@ -83,16 +81,16 @@         -- * The 'OccEnv' type         OccEnv, emptyOccEnv, unitOccEnv, extendOccEnv, mapOccEnv,         lookupOccEnv, mkOccEnv, mkOccEnv_C, extendOccEnvList, elemOccEnv,-        occEnvElts, foldOccEnv, plusOccEnv, plusOccEnv_C, extendOccEnv_C,+        nonDetOccEnvElts, foldOccEnv, plusOccEnv, plusOccEnv_C, extendOccEnv_C,         extendOccEnv_Acc, filterOccEnv, delListFromOccEnv, delFromOccEnv,-        alterOccEnv, pprOccEnv,+        alterOccEnv, minusOccEnv, minusOccEnv_C, pprOccEnv,          -- * The 'OccSet' type         OccSet, emptyOccSet, unitOccSet, mkOccSet, extendOccSet,         extendOccSetList,         unionOccSets, unionManyOccSets, minusOccSet, elemOccSet,         isEmptyOccSet, intersectOccSet,-        filterOccSet,+        filterOccSet, occSetToEnv,          -- * Tidying up         TidyOccEnv, emptyTidyOccEnv, initTidyOccEnv,@@ -134,6 +132,7 @@                deriving( Eq, Ord )  -- Note [Data Constructors]+-- ~~~~~~~~~~~~~~~~~~~~~~~~ -- see also: Note [Data Constructor Naming] in GHC.Core.DataCon -- -- $real_vs_source_data_constructors@@ -358,19 +357,6 @@   space' <- promoteNameSpace space   return $ OccName space' name --- Name spaces are related if there is a chance to mean the one when one writes--- the other, i.e. variables <-> data constructors and type variables <-> type constructors-nameSpacesRelated :: NameSpace -> NameSpace -> Bool-nameSpacesRelated ns1 ns2 = ns1 == ns2 || otherNameSpace ns1 == ns2--otherNameSpace :: NameSpace -> NameSpace-otherNameSpace VarName = DataName-otherNameSpace DataName = VarName-otherNameSpace TvName = TcClsName-otherNameSpace TcClsName = TvName--- {- | Other names in the compiler add additional information to an OccName. This class provides a consistent way to access the underlying OccName. -} class HasOccName name where@@ -416,7 +402,7 @@ mkOccEnv_C   :: (a -> a -> a) -> [(OccName,a)] -> OccEnv a elemOccEnv   :: OccName -> OccEnv a -> Bool foldOccEnv   :: (a -> b -> b) -> b -> OccEnv a -> b-occEnvElts   :: OccEnv a -> [a]+nonDetOccEnvElts   :: OccEnv a -> [a] extendOccEnv_C :: (a->a->a) -> OccEnv a -> OccName -> a -> OccEnv a extendOccEnv_Acc :: (a->b->b) -> (a->b) -> OccEnv b -> OccName -> a -> OccEnv b plusOccEnv     :: OccEnv a -> OccEnv a -> OccEnv a@@ -426,7 +412,11 @@ delListFromOccEnv :: OccEnv a -> [OccName] -> OccEnv a filterOccEnv       :: (elt -> Bool) -> OccEnv elt -> OccEnv elt alterOccEnv        :: (Maybe elt -> Maybe elt) -> OccEnv elt -> OccName -> OccEnv elt+minusOccEnv :: OccEnv a -> OccEnv b -> OccEnv a +-- | Alters (replaces or removes) those elements of the map that are mentioned in the second map+minusOccEnv_C :: (a -> b -> Maybe a) -> OccEnv a -> OccEnv b -> OccEnv a+ emptyOccEnv      = A emptyUFM unitOccEnv x y = A $ unitUFM x y extendOccEnv (A x) y z = A $ addToUFM x y z@@ -435,7 +425,7 @@ mkOccEnv     l    = A $ listToUFM l elemOccEnv x (A y)       = elemUFM x y foldOccEnv a b (A c)     = foldUFM a b c-occEnvElts (A x)         = eltsUFM x+nonDetOccEnvElts (A x)         = nonDetEltsUFM x plusOccEnv (A x) (A y)   = A $ plusUFM x y plusOccEnv_C f (A x) (A y)       = A $ plusUFM_C f x y extendOccEnv_C f (A x) y z   = A $ addToUFM_C f x y z@@ -446,6 +436,8 @@ delListFromOccEnv (A x) y  = A $ delListFromUFM x y filterOccEnv x (A y)       = A $ filterUFM x y alterOccEnv fn (A y) k     = A $ alterUFM fn y k+minusOccEnv (A x) (A y) = A $ minusUFM x y+minusOccEnv_C fn (A x) (A y) = A $ minusUFM_C fn x y  instance Outputable a => Outputable (OccEnv a) where     ppr x = pprOccEnv ppr x@@ -467,6 +459,8 @@ isEmptyOccSet     :: OccSet -> Bool intersectOccSet   :: OccSet -> OccSet -> OccSet filterOccSet      :: (OccName -> Bool) -> OccSet -> OccSet+-- | Converts an OccSet to an OccEnv (operationally the identity)+occSetToEnv       :: OccSet -> OccEnv OccName  emptyOccSet       = emptyUniqSet unitOccSet        = unitUniqSet@@ -480,6 +474,7 @@ isEmptyOccSet     = isEmptyUniqSet intersectOccSet   = intersectUniqSets filterOccSet      = filterUniqSet+occSetToEnv       = A . getUniqSet  {- ************************************************************************
GHC/Types/Name/Ppr.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE CPP #-} + module GHC.Types.Name.Ppr    ( mkPrintUnqualified    , mkQualModule@@ -8,16 +8,11 @@    ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Unit import GHC.Unit.Env-import GHC.Unit.State -import GHC.Core.TyCon- import GHC.Types.Name import GHC.Types.Name.Reader @@ -26,6 +21,7 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Misc+import GHC.Builtin.Types.Prim (tYPETyConName, funTyConName)   {-@@ -77,7 +73,7 @@       (mkQualPackage unit_state)   where   unit_state = ue_units unit_env-  home_unit  = ue_home_unit unit_env+  home_unit  = ue_homeUnit unit_env   qual_name mod occ         | [gre] <- unqual_gres         , right_name gre@@ -86,18 +82,9 @@                        -- the right one, then we can use the unqualified name          | [] <- unqual_gres-        , any is_name forceUnqualNames+        , pretendNameIsInScopeForPpr         , not (isDerivedOccName occ)-        = NameUnqual   -- Don't qualify names that come from modules-                       -- that come with GHC, often appear in error messages,-                       -- but aren't typically in scope. Doing this does not-                       -- cause ambiguity, and it reduces the amount of-                       -- qualification in error messages thus improving-                       -- readability.-                       ---                       -- A motivating example is 'Constraint'. It's often not-                       -- in scope, but printing GHC.Prim.Constraint seems-                       -- overkill.+        = NameUnqual   -- See Note [pretendNameIsInScopeForPpr]          | [gre] <- qual_gres         = NameQual (greQualModName gre)@@ -112,13 +99,22 @@                             -- Eg  f = True; g = 0; f = False       where         is_name :: Name -> Bool-        is_name name = ASSERT2( isExternalName name, ppr name )+        is_name name = assertPpr (isExternalName name) (ppr name) $                        nameModule name == mod && nameOccName name == occ -        forceUnqualNames :: [Name]-        forceUnqualNames =-          map tyConName [ constraintKindTyCon, heqTyCon, coercibleTyCon ]-          ++ [ eqTyConName ]+        -- See Note [pretendNameIsInScopeForPpr]+        pretendNameIsInScopeForPpr :: Bool+        pretendNameIsInScopeForPpr =+          any is_name+            [ liftedTypeKindTyConName+            , constraintKindTyConName+            , heqTyConName+            , coercibleTyConName+            , eqTyConName+            , tYPETyConName+            , funTyConName+            , oneDataConName+            , manyDataConName ]          right_name gre = greDefinitionModule gre == Just mod @@ -129,12 +125,50 @@     -- "import M" would resolve unambiguously to P:M.  (if P is the     -- current package we can just assume it is unqualified). +{- Note [pretendNameIsInScopeForPpr]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Normally, a name is printed unqualified if it's in scope and unambiguous:+  ghci> :t not+  not :: Bool -> Bool++Out of scope names are qualified:+  ghci> import Prelude hiding (Bool)+  ghci> :t not+  not :: GHC.Types.Bool -> GHC.Types.Bool++And so are ambiguous names:+  ghci> data Bool+  ghci> :t not+  not :: Prelude.Bool -> Prelude.Bool++However, these rules alone would lead to excessive qualification:+  ghci> :k Functor+  Functor :: (GHC.Types.Type -> GHC.Types.Type) -> GHC.Types.Constraint++Even if the user has not imported Data.Kind, we would rather print:+  Functor :: (Type -> Type) -> Constraint++So we maintain a list of names for which we only require that they are+unambiguous. It reduces the amount of qualification in GHCi output and error+messages thus improving readability.++One potential problem here is that external tooling that relies on parsing GHCi+output (e.g. Emacs mode for Haskell) requires names to be properly qualified to+make sense of the output (see #11208). So extend this list with care.++Side note (int-index):+  This function is distinct from GHC.Bulitin.Names.pretendNameIsInScope (used+  when filtering out instances), and perhaps we could unify them by taking a+  union, but I have not looked into what that would entail.+-}+ -- | Creates a function for formatting modules based on two heuristics: -- (1) if the module is the current module, don't qualify, and (2) if there -- is only one exposed package which exports this module, don't qualify.-mkQualModule :: UnitState -> HomeUnit -> QueryQualifyModule-mkQualModule unit_state home_unit mod-     | isHomeModule home_unit mod = False+mkQualModule :: UnitState -> Maybe HomeUnit -> QueryQualifyModule+mkQualModule unit_state mhome_unit mod+     | Just home_unit <- mhome_unit+     , isHomeModule home_unit mod = False       | [(_, pkgconfig)] <- lookup,        mkUnit pkgconfig == moduleUnit mod
GHC/Types/Name/Reader.hs view
@@ -3,7 +3,8 @@ (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -} -{-# LANGUAGE CPP, DeriveDataTypeable #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}  -- | -- #name_types#@@ -40,7 +41,7 @@         LocalRdrEnv, emptyLocalRdrEnv, extendLocalRdrEnv, extendLocalRdrEnvList,         lookupLocalRdrEnv, lookupLocalRdrOcc,         elemLocalRdrEnv, inLocalRdrEnvScope,-        localRdrEnvElts, delLocalRdrEnvList,+        localRdrEnvElts, minusLocalRdrEnv,          -- * Global mapping of 'RdrName' to 'GlobalRdrElt's         GlobalRdrEnv, emptyGlobalRdrEnv, mkGlobalRdrEnv, plusGlobalRdrEnv,@@ -70,15 +71,10 @@         ImportSpec(..), ImpDeclSpec(..), ImpItemSpec(..),         importSpecLoc, importSpecModule, isExplicitItem, bestImport, -        -- * Utils for StarIsType-        starInfo,-         -- * Utils-        opIsAt,+        opIsAt   ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Unit.Module@@ -99,6 +95,7 @@  import Data.Data import Data.List( sortBy )+import GHC.Data.Bag  {- ************************************************************************@@ -127,7 +124,7 @@ --           'GHC.Parser.Annotation.AnnVal' --           'GHC.Parser.Annotation.AnnTilde', --- For details on above see note [exact print annotations] in "GHC.Parser.Annotation"+-- For details on above see Note [exact print annotations] in "GHC.Parser.Annotation" data RdrName   = Unqual OccName         -- ^ Unqualified  name@@ -429,15 +426,15 @@       Orig {} -> False  localRdrEnvElts :: LocalRdrEnv -> [Name]-localRdrEnvElts (LRE { lre_env = env }) = occEnvElts env+localRdrEnvElts (LRE { lre_env = env }) = nonDetOccEnvElts env  inLocalRdrEnvScope :: Name -> LocalRdrEnv -> Bool -- This is the point of the NameSet inLocalRdrEnvScope name (LRE { lre_in_scope = ns }) = name `elemNameSet` ns -delLocalRdrEnvList :: LocalRdrEnv -> [OccName] -> LocalRdrEnv-delLocalRdrEnvList lre@(LRE { lre_env = env }) occs-  = lre { lre_env = delListFromOccEnv env occs }+minusLocalRdrEnv :: LocalRdrEnv -> OccEnv a -> LocalRdrEnv+minusLocalRdrEnv lre@(LRE { lre_env = env }) occs+  = lre { lre_env = minusOccEnv env occs }  {- Note [Local bindings with Exact Names]@@ -488,9 +485,9 @@ data GlobalRdrElt   = GRE { gre_name :: !GreName      -- ^ See Note [GreNames]         , gre_par  :: !Parent       -- ^ See Note [Parents]-        , gre_lcl :: !Bool          -- ^ True <=> the thing was defined locally-        , gre_imp :: ![ImportSpec]  -- ^ In scope through these imports-    } deriving (Data, Eq)+        , gre_lcl ::  !Bool          -- ^ True <=> the thing was defined locally+        , gre_imp ::  !(Bag ImportSpec)  -- ^ In scope through these imports+    } deriving (Data)          -- INVARIANT: either gre_lcl = True or gre_imp is non-empty          -- See Note [GlobalRdrElt provenance] @@ -672,17 +669,17 @@       = case prov_fn n of  -- Nothing => bound locally                            -- Just is => imported from 'is'           Nothing -> GRE { gre_name = NormalGreName n, gre_par = mkParent n avail-                         , gre_lcl = True, gre_imp = [] }+                         , gre_lcl = True, gre_imp = emptyBag }           Just is -> GRE { gre_name = NormalGreName n, gre_par = mkParent n avail-                         , gre_lcl = False, gre_imp = [is] }+                         , gre_lcl = False, gre_imp = unitBag is }      mk_fld_gre fl       = case prov_fn (flSelector fl) of  -- Nothing => bound locally                            -- Just is => imported from 'is'           Nothing -> GRE { gre_name = FieldGreName fl, gre_par = availParent avail-                         , gre_lcl = True, gre_imp = [] }+                         , gre_lcl = True, gre_imp = emptyBag }           Just is -> GRE { gre_name = FieldGreName fl, gre_par = availParent avail-                         , gre_lcl = False, gre_imp = [is] }+                         , gre_lcl = False, gre_imp = unitBag is }  instance HasOccName GlobalRdrElt where   occName = greOccName@@ -715,18 +712,18 @@ -- Prerecondition: the greMangledName is always External greQualModName gre@(GRE { gre_lcl = lcl, gre_imp = iss })  | lcl, Just mod <- greDefinitionModule gre = moduleName mod- | (is:_) <- iss                            = is_as (is_decl is)+ | Just is <- headMaybe iss                 = is_as (is_decl is)  | otherwise                                = pprPanic "greQualModName" (ppr gre)  greRdrNames :: GlobalRdrElt -> [RdrName] greRdrNames gre@GRE{ gre_lcl = lcl, gre_imp = iss }-  = (if lcl then [unqual] else []) ++ concatMap do_spec (map is_decl iss)+  = bagToList $ (if lcl then unitBag unqual else emptyBag) `unionBags` concatMapBag do_spec (mapBag is_decl iss)   where     occ    = greOccName gre     unqual = Unqual occ     do_spec decl_spec-        | is_qual decl_spec = [qual]-        | otherwise         = [unqual,qual]+        | is_qual decl_spec = unitBag qual+        | otherwise         = listToBag [unqual,qual]         where qual = Qual (is_as decl_spec) occ  -- the SrcSpan that pprNameProvenance prints out depends on whether@@ -737,7 +734,7 @@ greSrcSpan :: GlobalRdrElt -> SrcSpan greSrcSpan gre@(GRE { gre_lcl = lcl, gre_imp = iss } )   | lcl           = greDefinitionSrcSpan gre-  | (is:_) <- iss = is_dloc (is_decl is)+  | Just is <- headMaybe iss = is_dloc (is_decl is)   | otherwise     = pprPanic "greSrcSpan" (ppr gre)  mkParent :: Name -> AvailInfo -> Parent@@ -761,7 +758,7 @@ -- uniqueness assumption. gresToAvailInfo :: [GlobalRdrElt] -> [AvailInfo] gresToAvailInfo gres-  = nameEnvElts avail_env+  = nonDetNameEnvElts avail_env   where     avail_env :: NameEnv AvailInfo -- Keyed by the parent     (avail_env, _) = foldl' add (emptyNameEnv, emptyNameSet) gres@@ -817,9 +814,9 @@  pprGlobalRdrEnv :: Bool -> GlobalRdrEnv -> SDoc pprGlobalRdrEnv locals_only env-  = vcat [ text "GlobalRdrEnv" <+> ppWhen locals_only (ptext (sLit "(locals only)"))+  = vcat [ text "GlobalRdrEnv" <+> ppWhen locals_only (text "(locals only)")              <+> lbrace-         , nest 2 (vcat [ pp (remove_locals gre_list) | gre_list <- occEnvElts env ]+         , nest 2 (vcat [ pp (remove_locals gre_list) | gre_list <- nonDetOccEnvElts env ]              <+> rbrace) ]   where     remove_locals gres | locals_only = filter isLocalGRE gres@@ -897,7 +894,7 @@   where     qualifier_maybe (GRE { gre_lcl = lcl, gre_imp = iss })       | lcl       = Nothing-      | otherwise = Just $ map (is_as . is_decl) iss+      | otherwise = Just $ map (is_as . is_decl) (bagToList iss)  isLocalGRE :: GlobalRdrElt -> Bool isLocalGRE (GRE {gre_lcl = lcl }) = lcl@@ -984,14 +981,14 @@   | not lcl, null iss' = Nothing   | otherwise          = Just (gre { gre_imp = iss' })   where-    iss' = filter unQualSpecOK iss+    iss' = filterBag unQualSpecOK iss  pickQualGRE :: ModuleName -> GlobalRdrElt -> Maybe GlobalRdrElt pickQualGRE mod gre@(GRE { gre_lcl = lcl, gre_imp = iss })   | not lcl', null iss' = Nothing   | otherwise           = Just (gre { gre_lcl = lcl', gre_imp = iss' })   where-    iss' = filter (qualSpecOK mod) iss+    iss' = filterBag (qualSpecOK mod) iss     lcl' = lcl && name_is_from mod      name_is_from :: ModuleName -> Bool@@ -1048,7 +1045,7 @@ plusGRE g1 g2   = GRE { gre_name = gre_name g1         , gre_lcl  = gre_lcl g1 || gre_lcl g2-        , gre_imp  = gre_imp g1 ++ gre_imp g2+        , gre_imp  = gre_imp g1 `unionBags` gre_imp g2         , gre_par  = gre_par  g1 `plusParent` gre_par  g2 }  transformGREs :: (GlobalRdrElt -> GlobalRdrElt)@@ -1068,15 +1065,12 @@   = extendOccEnv_Acc insertGRE Utils.singleton env                      (greOccName gre) gre -shadowNames :: GlobalRdrEnv -> [GreName] -> GlobalRdrEnv-shadowNames = foldl' shadowName- {- Note [GlobalRdrEnv shadowing] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Before adding new names to the GlobalRdrEnv we nuke some existing entries;-this is "shadowing".  The actual work is done by RdrEnv.shadowName.+this is "shadowing".  The actual work is done by RdrEnv.shadowNames. Suppose-   env' = shadowName env M.f+   env' = shadowNames env f `extendGlobalRdrEnv` M.f  Then:    * Looking up (Unqual f) in env' should succeed, returning M.f,@@ -1087,8 +1081,9 @@     * Looking up (Qual X.f) in env', where X /= M, should be the same as      looking up (Qual X.f) in env.-     That is, shadowName does /not/ delete earlier qualified bindings +     That is, shadowNames does /not/ delete earlier qualified bindings+ There are two reasons for shadowing:  * The GHCi REPL@@ -1108,9 +1103,10 @@            ghci> True            ghci> M.x           -- M.x is still in scope!            ghci> "Hello"+     So when we add `x = True` we must not delete the `M.x` from the     `GlobalRdrEnv`; rather we just want to make it "qualified only";-    hence the `mk_fake-imp_spec` in `shadowName`.  See also Note+    hence the `set_qual` in `shadowNames`.  See also Note     [Interactively-bound Ids in GHCi] in GHC.Runtime.Context    - Data types also have External Names, like Ghci4.T; but we still want@@ -1144,24 +1140,17 @@       At that stage, the class op 'f' will have an Internal name. -} -shadowName :: GlobalRdrEnv -> GreName -> GlobalRdrEnv+shadowNames :: GlobalRdrEnv -> OccEnv a -> GlobalRdrEnv -- Remove certain old GREs that share the same OccName as this new Name. -- See Note [GlobalRdrEnv shadowing] for details-shadowName env new_name-  = alterOccEnv (fmap (mapMaybe shadow)) env (occName new_name)+shadowNames = minusOccEnv_C (\gres _ -> Just (mapMaybe shadow gres))   where-    maybe_new_mod = nameModule_maybe (greNameMangledName new_name)-     shadow :: GlobalRdrElt -> Maybe GlobalRdrElt     shadow        old_gre@(GRE { gre_lcl = lcl, gre_imp = iss })        = case greDefinitionModule old_gre of            Nothing -> Just old_gre   -- Old name is Internal; do not shadow            Just old_mod-              | Just new_mod <- maybe_new_mod-              , new_mod == old_mod   -- Old name same as new name; shadow completely-              -> Nothing-               | null iss'            -- Nothing remains               -> Nothing @@ -1169,9 +1158,9 @@               -> Just (old_gre { gre_lcl = False, gre_imp = iss' })                where-                iss' = lcl_imp ++ mapMaybe shadow_is iss-                lcl_imp | lcl       = [mk_fake_imp_spec old_gre old_mod]-                        | otherwise = []+                iss' = lcl_imp `unionBags` mapMaybeBag set_qual iss+                lcl_imp | lcl       = listToBag [mk_fake_imp_spec old_gre old_mod]+                        | otherwise = emptyBag      mk_fake_imp_spec old_gre old_mod    -- Urgh!       = ImpSpec id_spec ImpAll@@ -1182,13 +1171,8 @@                                    , is_qual = True                                    , is_dloc = greDefinitionSrcSpan old_gre } -    shadow_is :: ImportSpec -> Maybe ImportSpec-    shadow_is is@(ImpSpec { is_decl = id_spec })-       | Just new_mod <- maybe_new_mod-       , is_as id_spec == moduleName new_mod-       = Nothing   -- Shadow both qualified and unqualified-       | otherwise -- Shadow unqualified only-       = Just (is { is_decl = id_spec { is_qual = True } })+    set_qual :: ImportSpec -> Maybe ImportSpec+    set_qual is = Just (is { is_decl = (is_decl is) { is_qual = True } })   {-@@ -1352,7 +1336,7 @@                (head pp_provs)   where     name = greMangledName gre-    pp_provs = pp_lcl ++ map pp_is iss+    pp_provs = pp_lcl ++ map pp_is (bagToList iss)     pp_lcl = if lcl then [text "defined at" <+> ppr (nameSrcLoc name)]                     else []     pp_is is = sep [ppr is, ppr_defn_site is name]@@ -1368,7 +1352,7 @@                 2 (pprLoc loc)   where     loc = nameSrcSpan name-    defining_mod = ASSERT2( isExternalName name, ppr name ) nameModule name+    defining_mod = assertPpr (isExternalName name) (ppr name) $ nameModule name     same_module = importSpecModule imp_spec == moduleName defining_mod     pp_mod | same_module = empty            | otherwise   = text "in" <+> quotes (ppr defining_mod)@@ -1386,83 +1370,6 @@ pprLoc :: SrcSpan -> SDoc pprLoc (RealSrcSpan s _)  = text "at" <+> ppr s pprLoc (UnhelpfulSpan {}) = empty---- | Display info about the treatment of '*' under NoStarIsType.------ With StarIsType, three properties of '*' hold:------   (a) it is not an infix operator---   (b) it is always in scope---   (c) it is a synonym for Data.Kind.Type------ However, the user might not know that they are working on a module with--- NoStarIsType and write code that still assumes (a), (b), and (c), which--- actually do not hold in that module.------ Violation of (a) shows up in the parser. For instance, in the following--- examples, we have '*' not applied to enough arguments:------   data A :: *---   data F :: * -> *------ Violation of (b) or (c) show up in the renamer and the typechecker--- respectively. For instance:------   type K = Either * Bool------ This will parse differently depending on whether StarIsType is enabled,--- but it will parse nonetheless. With NoStarIsType it is parsed as a type--- operator, thus we have ((*) Either Bool). Now there are two cases to--- consider:------   1. There is no definition of (*) in scope. In this case the renamer will---      fail to look it up. This is a violation of assumption (b).------   2. There is a definition of the (*) type operator in scope (for example---      coming from GHC.TypeNats). In this case the user will get a kind---      mismatch error. This is a violation of assumption (c).------ The user might unknowingly be working on a module with NoStarIsType--- or use '*' as 'Data.Kind.Type' out of habit. So it is important to give a--- hint whenever an assumption about '*' is violated. Unfortunately, it is--- somewhat difficult to deal with (c), so we limit ourselves to (a) and (b).------ 'starInfo' generates an appropriate hint to the user depending on the--- extensions enabled in the module and the name that triggered the error.--- That is, if we have NoStarIsType and the error is related to '*' or its--- Unicode variant, the resulting SDoc will contain a helpful suggestion.--- Otherwise it is empty.----starInfo :: Bool -> RdrName -> SDoc-starInfo star_is_type rdr_name =-  -- One might ask: if can use `sdocOption sdocStarIsType` here, why bother to-  -- take star_is_type as input? Why not refactor?-  ---  -- The reason is that `sdocOption sdocStarIsType` would indicate that-  -- StarIsType is enabled in the module that tries to load the problematic-  -- definition, not in the module that is being loaded.-  ---  -- So if we have 'data T :: *' in a module with NoStarIsType, then the hint-  -- must be displayed even if we load this definition from a module (or GHCi)-  -- with StarIsType enabled!-  ---  if isUnqualStar && not star_is_type-     then text "With NoStarIsType, " <>-          quotes (ppr rdr_name) <>-          text " is treated as a regular type operator. "-        $$-          text "Did you mean to use " <> quotes (text "Type") <>-          text " from Data.Kind instead?"-      else empty-  where-    -- Does rdr_name look like the user might have meant the '*' kind by it?-    -- We focus on unqualified stars specifically, because qualified stars are-    -- treated as type operators even under StarIsType.-    isUnqualStar-      | Unqual occName <- rdr_name-      = let fs = occNameFS occName-        in fs == fsLit "*" || fs == fsLit "★"-      | otherwise = False  -- | Indicate if the given name is the "@" operator opIsAt :: RdrName -> Bool
GHC/Types/Name/Set.hs view
@@ -3,7 +3,7 @@ (c) The GRASP/AQUA Project, Glasgow University, 1998 -} -{-# LANGUAGE CPP #-}+ {-# LANGUAGE GeneralizedNewtypeDeriving #-} module GHC.Types.Name.Set (         -- * Names set type@@ -34,8 +34,6 @@         -- * Non-CAFfy names         NonCaffySet(..)     ) where--#include "HsVersions.h"  import GHC.Prelude
GHC/Types/Name/Shape.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE CPP #-} + module GHC.Types.Name.Shape    ( NameShape(..)    , emptyNameShape@@ -11,8 +11,6 @@    ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Driver.Env@@ -29,8 +27,7 @@ import GHC.Iface.Env  import GHC.Utils.Outputable-import GHC.Utils.Misc-import GHC.Utils.Panic+import GHC.Utils.Panic.Plain  import Control.Monad @@ -215,7 +212,7 @@ mergeAvails :: [AvailInfo] -> [AvailInfo] -> [AvailInfo] mergeAvails as1 as2 =     let mkNE as = mkNameEnv [(availName a, a) | a <- as]-    in nameEnvElts (plusNameEnv_C plusAvail (mkNE as1) (mkNE as2))+    in nonDetNameEnvElts (plusNameEnv_C plusAvail (mkNE as1) (mkNE as2))  {- ************************************************************************@@ -233,7 +230,7 @@                                  n <- availNames a                                  return (nameOccName n, a)     in foldM (\subst (a1, a2) -> uAvailInfo flexi subst a1 a2) emptyNameEnv-             (eltsUFM (intersectUFM_C (,) (mkOE as1) (mkOE as2)))+             (nonDetEltsUFM (intersectUFM_C (,) (mkOE as1) (mkOE as2)))              -- Edward: I have to say, this is pretty clever.  -- | Unify two 'AvailInfo's, given an existing substitution @subst@,@@ -268,11 +265,11 @@ uHoleName :: ModuleName -> ShNameSubst -> Name {- hole name -} -> Name           -> Either SDoc ShNameSubst uHoleName flexi subst h n =-    ASSERT( isHoleName h )+    assert (isHoleName h) $     case lookupNameEnv subst h of         Just n' -> uName flexi subst n' n                 -- Do a quick check if the other name is substituted.         Nothing | Just n' <- lookupNameEnv subst n ->-                    ASSERT( isHoleName n ) uName flexi subst h n'+                    assert (isHoleName n) $ uName flexi subst h n'                 | otherwise ->                     Right (extendNameEnv subst h n)
+ GHC/Types/PkgQual.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE LambdaCase #-}++module GHC.Types.PkgQual where++import GHC.Prelude+import GHC.Types.SourceText+import GHC.Unit.Types+import GHC.Utils.Outputable++import Data.Data++-- | Package-qualifier as it was parsed+data RawPkgQual+  = NoRawPkgQual             -- ^ No package qualifier+  | RawPkgQual StringLiteral -- ^ Raw package qualifier string.+  deriving (Data)++-- | Package-qualifier after renaming+--+-- Renaming detects if "this" or the unit-id of the home-unit was used as a+-- package qualifier.+data PkgQual+  = NoPkgQual       -- ^ No package qualifier+  | ThisPkg  UnitId -- ^ Import from home-unit+  | OtherPkg UnitId -- ^ Import from another unit+  deriving (Data, Ord, Eq)++instance Outputable RawPkgQual where+  ppr = \case+    NoRawPkgQual -> empty+    RawPkgQual (StringLiteral st p _)+      -> pprWithSourceText st (doubleQuotes (ftext p))++instance Outputable PkgQual where+  ppr = \case+    NoPkgQual  -> empty+    ThisPkg u  -> doubleQuotes (ppr u)+    OtherPkg u -> doubleQuotes (ppr u)++
GHC/Types/RepType.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE FlexibleContexts #-}  module GHC.Types.RepType@@ -8,21 +8,25 @@     unwrapType,      -- * Predicates on types-    isVoidTy,+    isZeroBitTy,      -- * Type representation for the code generator-    typePrimRep, typePrimRep1, typeMonoPrimRep_maybe,+    typePrimRep, typePrimRep1,     runtimeRepPrimRep, typePrimRepArgs,     PrimRep(..), primRepToType,-    countFunRepArgs, countConRepArgs, tyConPrimRep, tyConPrimRep1,+    countFunRepArgs, countConRepArgs, dataConRuntimeRepStrictness,+    tyConPrimRep, tyConPrimRep1,+    runtimeRepPrimRep_maybe, kindPrimRep_maybe, typePrimRep_maybe,      -- * Unboxed sum representation type     ubxSumRepType, layoutUbxSum, typeSlotTy, SlotTy (..),-    slotPrimRep, primRepSlot-  ) where+    slotPrimRep, primRepSlot, -#include "HsVersions.h"+    -- * Is this type known to be data?+    mightBeFunTy +    ) where+ import GHC.Prelude  import GHC.Types.Basic (Arity, RepArity)@@ -33,12 +37,26 @@ import GHC.Core.TyCon.RecWalk import GHC.Core.TyCo.Rep import GHC.Core.Type-import GHC.Builtin.Types.Prim-import {-# SOURCE #-} GHC.Builtin.Types ( anyTypeOfKind, runtimeRepTy )+import {-# SOURCE #-} GHC.Builtin.Types ( anyTypeOfKind+  , 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 )  import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain  import Data.List (sort) import qualified Data.IntSet as IS@@ -128,9 +146,42 @@       | otherwise       = pprPanic "countConRepArgs: arity greater than type can handle" (ppr (n, ty, typePrimRep ty)) +dataConRuntimeRepStrictness :: HasDebugCallStack => DataCon -> [StrictnessMark]+-- ^ Give the demands on the arguments of a+-- Core constructor application (Con dc args) at runtime.+-- Assumes the constructor is not levity polymorphic. For example+-- unboxed tuples won't work.+dataConRuntimeRepStrictness dc =++  -- pprTrace "dataConRuntimeRepStrictness" (ppr dc $$ ppr (dataConRepArgTys dc)) $++  let repMarks = dataConRepStrictness dc+      repTys = map irrelevantMult $ dataConRepArgTys dc+  in -- todo: assert dc != unboxedTuple/unboxedSum+     go repMarks repTys []+  where+    go (mark:marks) (ty:types) out_marks+      -- Zero-width argument, mark is irrelevant at runtime.+      |  -- pprTrace "VoidTy" (ppr ty) $+        (isZeroBitTy ty)+      = go marks types out_marks+      -- Single rep argument, e.g. Int+      -- Keep mark as-is+      | [_] <- reps+      = go marks types (mark:out_marks)+      -- Multi-rep argument, e.g. (# Int, Bool #) or (# Int | Bool #)+      -- Make up one non-strict mark per runtime argument.+      | otherwise -- TODO: Assert real_reps /= null+      = go marks types ((replicate (length real_reps) NotMarkedStrict)++out_marks)+      where+        reps = typePrimRep ty+        real_reps = filter (not . isVoidRep) $ reps+    go [] [] out_marks = reverse out_marks+    go _m _t _o = pprPanic "dataConRuntimeRepStrictness2" (ppr dc $$ ppr _m $$ ppr _t $$ ppr _o)+ -- | True if the type has zero width.-isVoidTy :: Type -> Bool-isVoidTy = null . typePrimRep+isZeroBitTy :: HasDebugCallStack => Type -> Bool+isZeroBitTy = null . typePrimRep   {- **********************************************************************@@ -235,7 +286,7 @@ -- -- TODO(michalt): We should probably introduce `SlotTy`s for 8-/16-/32-bit -- values, so that we can pack things more tightly.-data SlotTy = PtrLiftedSlot | PtrUnliftedSlot | WordSlot | Word64Slot | FloatSlot | DoubleSlot | VecSlot Int PrimElemRep+data SlotTy = PtrLiftedSlot | PtrUnliftedSlot | WordSlot | Word64Slot | FloatSlot | DoubleSlot   deriving (Eq, Ord)     -- Constructor order is important! If slot A could fit into slot B     -- then slot A must occur first.  E.g.  FloatSlot before DoubleSlot@@ -250,11 +301,10 @@   ppr WordSlot        = text "WordSlot"   ppr DoubleSlot      = text "DoubleSlot"   ppr FloatSlot       = text "FloatSlot"-  ppr (VecSlot n e)   = text "VecSlot" <+> ppr n <+> ppr e  typeSlotTy :: UnaryType -> Maybe SlotTy typeSlotTy ty-  | isVoidTy ty+  | isZeroBitTy ty   = Nothing   | otherwise   = Just (primRepSlot (typePrimRep1 ty))@@ -276,7 +326,7 @@ primRepSlot AddrRep     = WordSlot primRepSlot FloatRep    = FloatSlot primRepSlot DoubleRep   = DoubleSlot-primRepSlot (VecRep n e) = VecSlot n e+primRepSlot VecRep{}    = pprPanic "primRepSlot" (text "No slot for VecRep")  slotPrimRep :: SlotTy -> PrimRep slotPrimRep PtrLiftedSlot   = LiftedRep@@ -285,9 +335,12 @@ slotPrimRep WordSlot        = WordRep slotPrimRep DoubleSlot      = DoubleRep slotPrimRep FloatSlot       = FloatRep-slotPrimRep (VecSlot n e)   = VecRep n e  -- | Returns the bigger type if one fits into the other. (commutative)+--+-- Note that lifted and unlifted pointers are *not* in a fits-in relation for+-- the reasons described in Note [Don't merge lifted and unlifted slots] in+-- GHC.Stg.Unarise. fitsIn :: SlotTy -> SlotTy -> Maybe SlotTy fitsIn ty1 ty2   | ty1 == ty2@@ -317,8 +370,8 @@ Note [RuntimeRep and PrimRep] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ This Note describes the relationship between GHC.Types.RuntimeRep-(of levity-polymorphism fame) and GHC.Core.TyCon.PrimRep, as these types-are closely related.+(of levity/representation polymorphism fame) and GHC.Core.TyCon.PrimRep,+as these types are closely related.  A "primitive entity" is one that can be  * stored in one register@@ -438,7 +491,8 @@ should be passed the TyCon produced by promoting one of the constructors of RuntimeRep into type-level data. The RuntimeRep promoted datacons are associated with a RuntimeRepInfo (stored directly in the PromotedDataCon-constructor of TyCon). This pairing happens in GHC.Builtin.Types. A RuntimeRepInfo+constructor of TyCon, field promDcRepInfo).+This pairing happens in GHC.Builtin.Types. A RuntimeRepInfo usually(*) contains a function from [Type] to [PrimRep]: the [Type] are the arguments to the promoted datacon. These arguments are necessary for the TupleRep and SumRep constructors, so that this process can recur,@@ -484,6 +538,14 @@                               parens (ppr ty <+> dcolon <+> ppr (typeKind ty)))                              (typeKind ty) +-- | Discovers the primitive representation of a 'Type'. Returns+-- a list of 'PrimRep': it's a list because of the possibility of+-- no runtime representation (void) or multiple (unboxed tuple/sum)+-- See also Note [Getting from RuntimeRep to PrimRep]+-- Returns Nothing if rep can't be determined. Eg. levity polymorphic types.+typePrimRep_maybe :: Type -> Maybe [PrimRep]+typePrimRep_maybe ty = kindPrimRep_maybe (typeKind ty)+ -- | Like 'typePrimRep', but assumes that there is precisely one 'PrimRep' output; -- an empty list of PrimReps becomes a VoidRep. -- This assumption holds after unarise, see Note [Post-unarisation invariants].@@ -495,14 +557,6 @@   [rep] -> rep   _     -> pprPanic "typePrimRep1" (ppr ty $$ ppr (typePrimRep ty)) --- | Like 'typePrimRep', but returns 'Nothing' instead of panicking, when------    * The @ty@ was not of form @TYPE rep@---    * @rep@ was not monomorphic----typeMonoPrimRep_maybe :: Type -> Maybe [PrimRep]-typeMonoPrimRep_maybe ty = getRuntimeRep_maybe ty >>= runtimeRepMonoPrimRep_maybe- -- | Find the runtime representation of a 'TyCon'. Defined here to -- avoid module loops. Returns a list of the register shapes necessary. -- See also Note [Getting from RuntimeRep to PrimRep]@@ -530,22 +584,27 @@   | Just ki' <- coreView ki   = kindPrimRep doc ki' kindPrimRep doc (TyConApp typ [runtime_rep])-  = ASSERT( typ `hasKey` tYPETyConKey )+  = assert (typ `hasKey` tYPETyConKey) $     runtimeRepPrimRep doc runtime_rep kindPrimRep doc ki   = pprPanic "kindPrimRep" (ppr ki $$ doc) --- | Take a type of kind RuntimeRep and extract the list of 'PrimRep' that--- it encodes if it's a monomorphic rep. Otherwise returns 'Nothing'.+-- NB: We could implement the partial methods by calling into the maybe+-- variants here. But then both would need to pass around the doc argument.++-- | Take a kind (of shape @TYPE rr@) and produce the 'PrimRep's+-- of values of types of this kind. -- See also Note [Getting from RuntimeRep to PrimRep]-runtimeRepMonoPrimRep_maybe :: HasDebugCallStack => Type -> Maybe [PrimRep]-runtimeRepMonoPrimRep_maybe rr_ty-  | Just (rr_dc, args) <- splitTyConApp_maybe rr_ty-  , ASSERT2( runtimeRepTy `eqType` typeKind rr_ty, ppr rr_ty ) True-  , RuntimeRep fun <- tyConRuntimeRepInfo rr_dc-  = Just (fun args)-  | otherwise-  = Nothing -- not mono rep+-- Returns Nothing if rep can't be determined. Eg. levity polymorphic types.+kindPrimRep_maybe :: HasDebugCallStack => Kind -> Maybe [PrimRep]+kindPrimRep_maybe ki+  | Just ki' <- coreView ki+  = kindPrimRep_maybe ki'+kindPrimRep_maybe (TyConApp typ [runtime_rep])+  = assert (typ `hasKey` tYPETyConKey) $+    runtimeRepPrimRep_maybe runtime_rep+kindPrimRep_maybe _ki+  = Nothing  -- | Take a type of kind RuntimeRep and extract the list of 'PrimRep' that -- it encodes. See also Note [Getting from RuntimeRep to PrimRep]@@ -560,8 +619,80 @@   | otherwise   = pprPanic "runtimeRepPrimRep" (doc $$ ppr rr_ty) +-- | Take a type of kind RuntimeRep and extract the list of 'PrimRep' that+-- it encodes. See also Note [Getting from RuntimeRep to PrimRep]+-- The [PrimRep] is the final runtime representation /after/ unarisation+-- Returns Nothing if rep can't be determined. Eg. levity polymorphic types.+runtimeRepPrimRep_maybe :: Type -> Maybe [PrimRep]+runtimeRepPrimRep_maybe rr_ty+  | Just rr_ty' <- coreView rr_ty+  = runtimeRepPrimRep_maybe rr_ty'+  | TyConApp rr_dc args <- rr_ty+  , RuntimeRep fun <- tyConRuntimeRepInfo rr_dc+  = Just $! fun args+  | otherwise+  = Nothing++-- | Convert a 'PrimRep' to a 'Type' of kind RuntimeRep+primRepToRuntimeRep :: PrimRep -> Type+primRepToRuntimeRep rep = case rep of+  VoidRep       -> zeroBitRepTy+  LiftedRep     -> liftedRepTy+  UnliftedRep   -> unliftedRepTy+  IntRep        -> intRepDataConTy+  Int8Rep       -> int8RepDataConTy+  Int16Rep      -> int16RepDataConTy+  Int32Rep      -> int32RepDataConTy+  Int64Rep      -> int64RepDataConTy+  WordRep       -> wordRepDataConTy+  Word8Rep      -> word8RepDataConTy+  Word16Rep     -> word16RepDataConTy+  Word32Rep     -> word32RepDataConTy+  Word64Rep     -> word64RepDataConTy+  AddrRep       -> addrRepDataConTy+  FloatRep      -> floatRepDataConTy+  DoubleRep     -> doubleRepDataConTy+  VecRep n elem -> TyConApp vecRepDataConTyCon [n', elem']+    where+      n' = case n of+        2  -> vec2DataConTy+        4  -> vec4DataConTy+        8  -> vec8DataConTy+        16 -> vec16DataConTy+        32 -> vec32DataConTy+        64 -> vec64DataConTy+        _  -> pprPanic "Disallowed VecCount" (ppr n)++      elem' = case elem of+        Int8ElemRep   -> int8ElemRepDataConTy+        Int16ElemRep  -> int16ElemRepDataConTy+        Int32ElemRep  -> int32ElemRepDataConTy+        Int64ElemRep  -> int64ElemRepDataConTy+        Word8ElemRep  -> word8ElemRepDataConTy+        Word16ElemRep -> word16ElemRepDataConTy+        Word32ElemRep -> word32ElemRepDataConTy+        Word64ElemRep -> word64ElemRepDataConTy+        FloatElemRep  -> floatElemRepDataConTy+        DoubleElemRep -> doubleElemRepDataConTy+ -- | Convert a PrimRep back to a Type. Used only in the unariser to give types -- to fresh Ids. Really, only the type's representation matters. -- See also Note [RuntimeRep and PrimRep] primRepToType :: PrimRep -> Type-primRepToType = anyTypeOfKind . tYPE . primRepToRuntimeRep+primRepToType = anyTypeOfKind . mkTYPEapp . primRepToRuntimeRep++--------------+mightBeFunTy :: Type -> Bool+-- Return False only if we are *sure* it's a data type+-- Look through newtypes etc as much as possible. Used to+-- decide if we need to enter a closure via a slow call.+--+-- AK: It would be nice to figure out and document the difference+-- between this and isFunTy at some point.+mightBeFunTy ty+  | [LiftedRep] <- typePrimRep ty+  , Just tc <- tyConAppTyCon_maybe (unwrapType ty)+  , isDataTyCon tc+  = False+  | otherwise+  = True
GHC/Types/SourceError.hs view
@@ -10,25 +10,29 @@ where  import GHC.Prelude-import GHC.Data.Bag import GHC.Types.Error import GHC.Utils.Monad import GHC.Utils.Panic import GHC.Utils.Exception+import GHC.Utils.Error (pprMsgEnvelopeBagWithLoc)+import GHC.Utils.Outputable +import GHC.Driver.Errors.Ppr () -- instance Diagnostic GhcMessage+import GHC.Driver.Errors.Types+ import Control.Monad.Catch as MC (MonadCatch, catch) -mkSrcErr :: ErrorMessages -> SourceError+mkSrcErr :: Messages GhcMessage -> SourceError mkSrcErr = SourceError -srcErrorMessages :: SourceError -> ErrorMessages+srcErrorMessages :: SourceError -> Messages GhcMessage srcErrorMessages (SourceError msgs) = msgs -throwErrors :: MonadIO io => ErrorMessages -> io a+throwErrors :: MonadIO io => Messages GhcMessage -> io a throwErrors = liftIO . throwIO . mkSrcErr -throwOneError :: MonadIO io => MsgEnvelope DecoratedSDoc -> io a-throwOneError = throwErrors . unitBag+throwOneError :: MonadIO io => MsgEnvelope GhcMessage -> io a+throwOneError = throwErrors . singleMessage  -- | A source error is an error that is caused by one or more errors in the -- source code.  A 'SourceError' is thrown by many functions in the@@ -46,10 +50,18 @@ -- -- See 'printExceptionAndWarnings' for more information on what to take care -- of when writing a custom error handler.-newtype SourceError = SourceError ErrorMessages+newtype SourceError = SourceError (Messages GhcMessage)  instance Show SourceError where-  show (SourceError msgs) = unlines . map show . bagToList $ msgs+  -- We implement 'Show' because it's required by the 'Exception' instance, but diagnostics+  -- shouldn't be shown via the 'Show' typeclass, but rather rendered using the ppr functions.+  -- This also explains why there is no 'Show' instance for a 'MsgEnvelope'.+  show (SourceError msgs) =+      renderWithContext defaultSDocContext+    . vcat+    . pprMsgEnvelopeBagWithLoc+    . getMessages+    $ msgs  instance Exception SourceError
GHC/Types/SourceFile.hs view
@@ -1,6 +1,6 @@ module GHC.Types.SourceFile    ( HscSource(..)-   , SourceModified (..)+   , hscSourceToIsBoot    , isHsBootOrSig    , isHsigFile    , hscSourceString@@ -9,6 +9,7 @@  import GHC.Prelude import GHC.Utils.Binary+import GHC.Unit.Types  -- Note [HscSource types] -- ~~~~~~~~~~~~~~~~~~~~~~@@ -49,6 +50,14 @@    | HsigFile   -- ^ .hsig file    deriving (Eq, Ord, Show) +-- | Tests if an 'HscSource' is a boot file, primarily for constructing elements+-- of 'BuildModule'. We conflate signatures and modules because they are bound+-- in the same namespace; only boot interfaces can be disambiguated with+-- `import {-# SOURCE #-}`.+hscSourceToIsBoot :: HscSource -> IsBootInterface+hscSourceToIsBoot HsBootFile = IsBoot+hscSourceToIsBoot _ = NotBoot+ instance Binary HscSource where     put_ bh HsSrcFile = putByte bh 0     put_ bh HsBootFile = putByte bh 1@@ -74,21 +83,3 @@ isHsigFile :: HscSource -> Bool isHsigFile HsigFile = True isHsigFile _        = False---- | Indicates whether a given module's source has been modified since it--- was last compiled.-data SourceModified-  = SourceModified-       -- ^ the source has been modified-  | SourceUnmodified-       -- ^ the source has not been modified.  Compilation may or may-       -- not be necessary, depending on whether any dependencies have-       -- changed since we last compiled.-  | SourceUnmodifiedAndStable-       -- ^ the source has not been modified, and furthermore all of-       -- its (transitive) dependencies are up to date; it definitely-       -- does not need to be recompiled.  This is important for two-       -- reasons: (a) we can omit the version check in checkOldIface,-       -- and (b) if the module used TH splices we don't need to force-       -- recompilation.-
GHC/Types/SourceText.hs view
@@ -175,7 +175,7 @@     , fl_neg :: Bool                        -- See Note [Negative zero]     , fl_signi :: Rational                  -- The significand component of the literal     , fl_exp :: Integer                     -- The exponent component of the literal-    , fl_exp_base :: FractionalExponentBase -- See Note [Fractional exponent bases]+    , fl_exp_base :: FractionalExponentBase -- See Note [fractional exponent bases]     }     deriving (Data, Show)   -- The Show instance is required for the derived GHC.Parser.Lexer.Token instance when DEBUG is on
GHC/Types/SrcLoc.hs view
@@ -68,7 +68,6 @@         getBufPos,         BufSpan(..),         getBufSpan,-        removeBufSpan,          -- * Located         Located,@@ -83,6 +82,7 @@         getLoc, unLoc,         unRealSrcSpan, getRealSrcSpan,         pprLocated,+        pprLocatedAlways,          -- ** Modifying Located         mapLoc,@@ -107,6 +107,7 @@         psSpanEnd,         mkSrcSpanPs,         combineRealSrcSpans,+        psLocatedToLocated,          -- * Layout information         LayoutInfo(..),@@ -121,6 +122,7 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Data.FastString+import qualified GHC.Data.Strict as Strict  import Control.DeepSeq import Control.Applicative (liftA2)@@ -222,12 +224,12 @@ -- We use 'BufPos' in in GHC.Parser.PostProcess.Haddock to associate Haddock -- comments with parts of the AST using location information (#17544). newtype BufPos = BufPos { bufPos :: Int }-  deriving (Eq, Ord, Show)+  deriving (Eq, Ord, Show, Data)  -- | Source Location data SrcLoc-  = RealSrcLoc !RealSrcLoc !(Maybe BufPos)  -- See Note [Why Maybe BufPos]-  | UnhelpfulLoc FastString     -- Just a general indication+  = RealSrcLoc !RealSrcLoc !(Strict.Maybe BufPos)  -- See Note [Why Maybe BufPos]+  | UnhelpfulLoc !FastString     -- Just a general indication   deriving (Eq, Show)  {-@@ -239,14 +241,14 @@ -}  mkSrcLoc :: FastString -> Int -> Int -> SrcLoc-mkSrcLoc x line col = RealSrcLoc (mkRealSrcLoc x line col) Nothing+mkSrcLoc x line col = RealSrcLoc (mkRealSrcLoc x line col) Strict.Nothing  mkRealSrcLoc :: FastString -> Int -> Int -> RealSrcLoc mkRealSrcLoc x line col = SrcLoc (LexicalFastString x) line col -getBufPos :: SrcLoc -> Maybe BufPos+getBufPos :: SrcLoc -> Strict.Maybe BufPos getBufPos (RealSrcLoc _ mbpos) = mbpos-getBufPos (UnhelpfulLoc _) = Nothing+getBufPos (UnhelpfulLoc _) = Strict.Nothing  -- | Built-in "bad" 'SrcLoc' values for particular locations noSrcLoc, generatedSrcLoc, interactiveSrcLoc :: SrcLoc@@ -371,7 +373,7 @@ -- | StringBuffer Source Span data BufSpan =   BufSpan { bufSpanStart, bufSpanEnd :: {-# UNPACK #-} !BufPos }-  deriving (Eq, Ord, Show)+  deriving (Eq, Ord, Show, Data)  instance Semigroup BufSpan where   BufSpan start1 end1 <> BufSpan start2 end2 =@@ -382,7 +384,7 @@ -- A 'SrcSpan' identifies either a specific portion of a text file -- or a human-readable description of a location. data SrcSpan =-    RealSrcSpan !RealSrcSpan !(Maybe BufSpan)  -- See Note [Why Maybe BufPos]+    RealSrcSpan !RealSrcSpan !(Strict.Maybe BufSpan)  -- See Note [Why Maybe BufPos]   | UnhelpfulSpan !UnhelpfulSpanReason    deriving (Eq, Show) -- Show is used by GHC.Parser.Lexer, because we@@ -396,10 +398,6 @@   | UnhelpfulOther !FastString   deriving (Eq, Show) -removeBufSpan :: SrcSpan -> SrcSpan-removeBufSpan (RealSrcSpan s _) = RealSrcSpan s Nothing-removeBufSpan s = s- {- Note [Why Maybe BufPos] ~~~~~~~~~~~~~~~~~~~~~~~~~~ In SrcLoc we store (Maybe BufPos); in SrcSpan we store (Maybe BufSpan).@@ -435,9 +433,9 @@ instance NFData SrcSpan where   rnf x = x `seq` () -getBufSpan :: SrcSpan -> Maybe BufSpan+getBufSpan :: SrcSpan -> Strict.Maybe BufSpan getBufSpan (RealSrcSpan _ mbspan) = mbspan-getBufSpan (UnhelpfulSpan _) = Nothing+getBufSpan (UnhelpfulSpan _) = Strict.Nothing  -- | Built-in "bad" 'SrcSpan's for common sources of location uncertainty noSrcSpan, generatedSrcSpan, wiredInSrcSpan, interactiveSrcSpan :: SrcSpan@@ -734,7 +732,7 @@  -- | We attach SrcSpans to lots of things, so let's have a datatype for it. data GenLocated l e = L l e-  deriving (Eq, Ord, Data, Functor, Foldable, Traversable)+  deriving (Eq, Ord, Show, Data, Functor, Foldable, Traversable)  type Located = GenLocated SrcSpan type RealLocated = GenLocated RealSrcSpan@@ -778,8 +776,8 @@ -- Precondition: both operands have an associated 'BufSpan'. cmpBufSpan :: HasDebugCallStack => Located a -> Located a -> Ordering cmpBufSpan (L l1 _) (L l2  _)-  | Just a <- getBufSpan l1-  , Just b <- getBufSpan l2+  | Strict.Just a <- getBufSpan l1+  , Strict.Just b <- getBufSpan l2   = compare a b    | otherwise = panic "cmpBufSpan: no BufSpan"@@ -792,7 +790,7 @@ instance (Outputable e) => Outputable (GenLocated RealSrcSpan e) where   ppr (L l e) = -- GenLocated:                 -- Print spans without the file name etc-                whenPprDebug (braces (pprUserSpan False (RealSrcSpan l Nothing)))+                whenPprDebug (braces (pprUserSpan False (RealSrcSpan l Strict.Nothing)))              $$ ppr e  @@ -802,6 +800,12 @@                 whenPprDebug (braces (ppr l))              $$ ppr e +-- | Always prints the location, even without -dppr-debug+pprLocatedAlways :: (Outputable l, Outputable e) => GenLocated l e -> SDoc+pprLocatedAlways (L l e) =+     braces (ppr l)+  $$ ppr e+ {- ************************************************************************ *                                                                      *@@ -869,10 +873,13 @@  data PsSpan   = PsSpan { psRealSpan :: !RealSrcSpan, psBufSpan :: !BufSpan }-  deriving (Eq, Ord, Show)+  deriving (Eq, Ord, Show, Data)  type PsLocated = GenLocated PsSpan +psLocatedToLocated :: PsLocated a -> Located a+psLocatedToLocated (L sp a) = L (mkSrcSpanPs sp) a+ advancePsLoc :: PsLoc -> Char -> PsLoc advancePsLoc (PsLoc real_loc buf_loc) c =   PsLoc (advanceSrcLoc real_loc c) (advanceBufPos buf_loc)@@ -887,7 +894,7 @@ psSpanEnd (PsSpan r b) = PsLoc (realSrcSpanEnd r) (bufSpanEnd b)  mkSrcSpanPs :: PsSpan -> SrcSpan-mkSrcSpanPs (PsSpan r b) = RealSrcSpan r (Just b)+mkSrcSpanPs (PsSpan r b) = RealSrcSpan r (Strict.Just b)  -- | Layout information for declarations. data LayoutInfo =
GHC/Types/Target.hs view
@@ -21,10 +21,13 @@ -- module.  If so, use this instead of the file contents (this -- is for use in an IDE where the file hasn't been saved by -- the user yet).+--+-- These fields are strict because Targets are long lived. data Target   = Target {       targetId           :: !TargetId, -- ^ module or filename       targetAllowObjCode :: !Bool,     -- ^ object code allowed?+      targetUnitId       :: !UnitId,   -- ^ id of the unit this target is part of       targetContents     :: !(Maybe (InputFileBuffer, UTCTime))       -- ^ Optional in-memory buffer containing the source code GHC should       -- use for this target instead of reading it from disk.@@ -52,8 +55,8 @@   pprTarget :: Target -> SDoc-pprTarget (Target id obj _) =-    (if obj then empty else char '*') <> pprTargetId id+pprTarget Target { targetUnitId = uid, targetId = id, targetAllowObjCode = obj } =+    (if obj then empty else char '*') <> ppr uid <> colon <> pprTargetId id  instance Outputable Target where     ppr = pprTarget
GHC/Types/Tickish.hs view
@@ -18,6 +18,7 @@   mkNoCount,   mkNoScope,   tickishIsCode,+  isProfTick,   TickishPlacement(..),   tickishPlace,   tickishContains@@ -38,6 +39,7 @@ import Language.Haskell.Syntax.Extension ( NoExtField )  import Data.Data+import GHC.Utils.Outputable (Outputable (ppr), text)  {- ********************************************************************* *                                                                      *@@ -58,7 +60,7 @@  {-    Note [Tickish passes]-+   ~~~~~~~~~~~~~~~~~~~~~    Tickish annotations store different information depending on    where they are used. Here's a summary of the differences    between the passes.@@ -317,6 +319,9 @@ tickishIsCode SourceNote{} = False tickishIsCode _tickish     = True  -- all the rest for now +isProfTick :: GenTickish pass -> Bool+isProfTick ProfNote{} = True+isProfTick _          = False  -- | Governs the kind of expression that the tick gets placed on when -- annotating for example using @mkTick@. If we find that we want to@@ -330,6 +335,9 @@     -- restrictive placement rule for ticks, as all tickishs have in     -- common that they want to track runtime processes. The only     -- legal placement rule for counting ticks.+    -- NB: We generally try to move these as close to the relevant+    -- runtime expression as possible. This means they get pushed through+    -- tyoe arguments. E.g. we create `(tick f) @Bool` instead of `tick (f @Bool)`.     PlaceRuntime      -- | As @PlaceRuntime@, but we float the tick through all@@ -350,7 +358,10 @@     -- above example is safe.   | PlaceCostCentre -  deriving (Eq)+  deriving (Eq,Show)++instance Outputable TickishPlacement where+  ppr = text . show  -- | Placement behaviour we want for the ticks tickishPlace :: GenTickish pass -> TickishPlacement
GHC/Types/TyThing.hs view
@@ -139,7 +139,7 @@ -- names returned by 'GHC.Iface.Load.ifaceDeclImplicitBndrs', in the sense that -- TyThing.getOccName should define a bijection between the two lists. -- This invariant is used in 'GHC.IfaceToCore.tc_iface_decl_fingerprint' (see--- note [Tricky iface loop])+-- Note [Tricky iface loop]) -- The order of the list does not matter. implicitTyThings :: TyThing -> [TyThing] implicitTyThings (AnId _)       = []@@ -229,6 +229,8 @@ tyThingParent_maybe (AnId id)     = case idDetails id of                                       RecSelId { sel_tycon = RecSelData tc } ->                                           Just (ATyCon tc)+                                      RecSelId { sel_tycon = RecSelPatSyn ps } ->+                                          Just (AConLike (PatSynCon ps))                                       ClassOpId cls               ->                                           Just (ATyCon (classTyCon cls))                                       _other                      -> Nothing@@ -311,5 +313,3 @@ -- Instance used in GHC.HsToCore.Quote instance MonadThings m => MonadThings (ReaderT s m) where   lookupThing = lift . lookupThing--
GHC/Types/TyThing/Ppr.hs view
@@ -6,37 +6,32 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE CPP #-}+ module GHC.Types.TyThing.Ppr (         pprTyThing,         pprTyThingInContext,         pprTyThingLoc,         pprTyThingInContextLoc,         pprTyThingHdr,-        pprTypeForUser,         pprFamInst   ) where -#include "HsVersions.h"- import GHC.Prelude -import GHC.Driver.Ppr (warnPprTrace)- import GHC.Types.TyThing ( TyThing(..), tyThingParent_maybe ) import GHC.Types.Name-import GHC.Types.Var.Env( emptyTidyEnv ) -import GHC.Core.Type    ( Type, ArgFlag(..), mkTyVarBinders, tidyOpenType )+import GHC.Core.Type    ( ArgFlag(..), mkTyVarBinders ) import GHC.Core.Coercion.Axiom ( coAxiomTyCon ) import GHC.Core.FamInstEnv( FamInst(..), FamFlavor(..) )-import GHC.Core.TyCo.Ppr ( pprUserForAll, pprTypeApp, pprSigmaType )+import GHC.Core.TyCo.Ppr ( pprUserForAll, pprTypeApp )  import GHC.Iface.Syntax ( ShowSub(..), ShowHowMuch(..), AltPpr(..)   , showToHeader, pprIfaceDecl ) import GHC.Iface.Make ( tyThingToIfaceDecl )  import GHC.Utils.Outputable+import GHC.Utils.Trace  -- ----------------------------------------------------------------------------- -- Pretty-printing entities that we get from the GHC API@@ -169,7 +164,7 @@ -- | Pretty-prints a 'TyThing'. pprTyThing :: ShowSub -> TyThing -> SDoc -- We pretty-print 'TyThing' via 'IfaceDecl'--- See Note [Pretty-printing TyThings]+-- See Note [Pretty printing via Iface syntax] pprTyThing ss ty_thing   = sdocOption sdocLinearTypes $ \show_linear_types ->       pprIfaceDecl ss' (tyThingToIfaceDecl show_linear_types ty_thing)@@ -189,19 +184,8 @@          = case nameModule_maybe name of              Just mod -> Just $ \occ -> getPprStyle $ \sty ->                pprModulePrefix sty mod occ <> ppr occ-             Nothing  -> WARN( True, ppr name ) Nothing+             Nothing  -> warnPprTrace True "pprTyThing" (ppr name) Nothing              -- Nothing is unexpected here; TyThings have External names--pprTypeForUser :: Type -> SDoc--- The type is tidied-pprTypeForUser ty-  = pprSigmaType tidy_ty-  where-    (_, tidy_ty)     = tidyOpenType emptyTidyEnv ty-     -- Often the types/kinds we print in ghci are fully generalised-     -- and have no free variables, but it turns out that we sometimes-     -- print un-generalised kinds (eg when doing :k T), so it's-     -- better to use tidyOpenType here  showWithLoc :: SDoc -> SDoc -> SDoc showWithLoc loc doc
GHC/Types/TypeEnv.hs view
@@ -49,7 +49,7 @@ lookupTypeEnv   :: TypeEnv -> Name -> Maybe TyThing  emptyTypeEnv        = emptyNameEnv-typeEnvElts     env = nameEnvElts env+typeEnvElts     env = nonDetNameEnvElts env typeEnvTyCons   env = [tc | ATyCon tc   <- typeEnvElts env] typeEnvCoAxioms env = [ax | ACoAxiom ax <- typeEnvElts env] typeEnvIds      env = [id | AnId id     <- typeEnvElts env]
GHC/Types/Unique.hs view
@@ -17,7 +17,8 @@ Haskell). -} -{-# LANGUAGE CPP, BangPatterns, MagicHash #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns, MagicHash #-}  module GHC.Types.Unique (         -- * Main data types@@ -45,15 +46,13 @@         mkLocalUnique, minLocalUnique, maxLocalUnique,     ) where -#include "HsVersions.h" #include "Unique.h"  import GHC.Prelude  import GHC.Data.FastString import GHC.Utils.Outputable-import GHC.Utils.Misc-import GHC.Utils.Panic+import GHC.Utils.Panic.Plain  -- just for implementing a fast [0,61) -> Char function import GHC.Exts (indexCharOffAddr#, Char(..), Int(..))@@ -274,14 +273,7 @@ showUnique :: Unique -> String showUnique uniq   = case unpkUnique uniq of-      (tag, u) -> finish_show tag u (iToBase62 u)--finish_show :: Char -> Int -> String -> String-finish_show 't' u _pp_u | u < 26-  = -- Special case to make v common tyvars, t1, t2, ...-    -- come out as a, b, ... (shorter, easier to read)-    [chr (ord 'a' + u)]-finish_show tag _ pp_u = tag : pp_u+      (tag, u) -> tag : iToBase62 u  pprUniqueAlways :: Unique -> SDoc -- The "always" means regardless of -dsuppress-uniques@@ -311,7 +303,7 @@  iToBase62 :: Int -> String iToBase62 n_-  = ASSERT(n_ >= 0) go n_ ""+  = assert (n_ >= 0) $ go n_ ""   where     go n cs | n < 62             = let !c = chooseChar62 n in c : cs
GHC/Types/Unique/DFM.hs view
@@ -57,6 +57,7 @@         listToUDFM, listToUDFM_Directly,         udfmMinusUFM, ufmMinusUDFM,         partitionUDFM,+        udfmRestrictKeys,         anyUDFM, allUDFM,         pprUniqDFM, pprUDFM, @@ -78,7 +79,6 @@ import Data.Functor.Classes (Eq1 (..)) import Data.List (sortBy) import Data.Function (on)-import qualified Data.Semigroup as Semi import GHC.Types.Unique.FM (UniqFM, nonDetUFMToList, ufmToIntMap, unsafeIntMapToUFM) import Unsafe.Coerce @@ -311,6 +311,9 @@   where   p' k (TaggedVal v _) = p (getUnique k) v +udfmRestrictKeys :: UniqDFM key elt -> UniqDFM key elt2 -> UniqDFM key elt+udfmRestrictKeys (UDFM a i) (UDFM b _) = UDFM (M.restrictKeys a (M.keysSet b)) i+ -- | Converts `UniqDFM` to a list, with elements in deterministic order. -- It's O(n log n) while the corresponding function on `UniqFM` is O(n). udfmToList :: UniqDFM key elt -> [(Unique, elt)]@@ -419,13 +422,6 @@  allUDFM :: (elt -> Bool) -> UniqDFM key elt -> Bool allUDFM p (UDFM m _i) = M.foldr ((&&) . p . taggedFst) True m--instance Semi.Semigroup (UniqDFM key a) where-  (<>) = plusUDFM--instance Monoid (UniqDFM key a) where-  mempty = emptyUDFM-  mappend = (Semi.<>)  -- This should not be used in committed code, provided for convenience to -- make ad-hoc conversions when developing
GHC/Types/Unique/DSet.hs view
@@ -8,7 +8,6 @@ -- -- Basically, the things need to be in class 'Uniquable'. -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE DeriveDataTypeable #-}  module GHC.Types.Unique.DSet (@@ -46,14 +45,13 @@  import Data.Coerce import Data.Data-import qualified Data.Semigroup as Semi  -- See Note [UniqSet invariant] in GHC.Types.Unique.Set for why we want a newtype here. -- Beyond preserving invariants, we may also want to 'override' typeclass -- instances.  newtype UniqDSet a = UniqDSet {getUniqDSet' :: UniqDFM a a}-                   deriving (Data, Semi.Semigroup, Monoid)+                   deriving (Data)  emptyUniqDSet :: UniqDSet a emptyUniqDSet = UniqDSet emptyUDFM
GHC/Types/Unique/FM.hs view
@@ -23,7 +23,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE CPP #-}+ {-# OPTIONS_GHC -Wall #-}  module GHC.Types.Unique.FM (@@ -54,15 +54,18 @@         plusUFM_C,         plusUFM_CD,         plusUFM_CD2,-        plusMaybeUFM_C,         mergeUFM,+        plusMaybeUFM_C,         plusUFMList,+        sequenceUFMList,         minusUFM,+        minusUFM_C,         intersectUFM,         intersectUFM_C,         disjointUFM,         equalKeysUFM,-        nonDetStrictFoldUFM, foldUFM, nonDetStrictFoldUFM_Directly,+        nonDetStrictFoldUFM, foldUFM, nonDetStrictFoldUFM_DirectlyM,+        nonDetStrictFoldUFM_Directly,         anyUFM, allUFM, seqEltsUFM,         mapUFM, mapUFM_Directly,         mapMaybeUFM,@@ -72,21 +75,18 @@         isNullUFM,         lookupUFM, lookupUFM_Directly,         lookupWithDefaultUFM, lookupWithDefaultUFM_Directly,-        nonDetEltsUFM, eltsUFM, nonDetKeysUFM,+        nonDetEltsUFM, nonDetKeysUFM,         ufmToSet_Directly,         nonDetUFMToList, ufmToIntMap, unsafeIntMapToUFM,         unsafeCastUFMKey,         pprUniqFM, pprUFM, pprUFMWithKeys, pluralUFM     ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Types.Unique ( Uniquable(..), Unique, getKey ) import GHC.Utils.Outputable-import GHC.Utils.Panic (assertPanic)-import GHC.Utils.Misc (debugIsOn)+import GHC.Utils.Panic.Plain import qualified Data.IntMap as M import qualified Data.IntMap.Strict as MS import qualified Data.IntSet as S@@ -130,7 +130,7 @@ -- Note that listToUFM (zip ks vs) performs similarly, but -- the explicit recursion avoids relying too much on fusion. zipToUFM :: Uniquable key => [key] -> [elt] -> UniqFM key elt-zipToUFM ks vs = ASSERT( length ks == length vs ) innerZip emptyUFM ks vs+zipToUFM ks vs = assert (length ks == length vs ) innerZip emptyUFM ks vs   where     innerZip ufm (k:kList) (v:vList) = innerZip (addToUFM ufm k v) kList vList     innerZip ufm _ _ = ufm@@ -305,9 +305,26 @@ plusUFMList :: [UniqFM key elt] -> UniqFM key elt plusUFMList = foldl' plusUFM emptyUFM +sequenceUFMList :: forall key elt. [UniqFM key elt] -> UniqFM key [elt]+sequenceUFMList = foldr (plusUFM_CD2 cons) emptyUFM+  where+    cons :: Maybe elt -> Maybe [elt] -> [elt]+    cons (Just x) (Just ys) = x : ys+    cons Nothing  (Just ys) = ys+    cons (Just x) Nothing   = [x]+    cons Nothing  Nothing   = []+ minusUFM :: UniqFM key elt1 -> UniqFM key elt2 -> UniqFM key elt1 minusUFM (UFM x) (UFM y) = UFM (M.difference x y) +-- | @minusUFC_C f map1 map2@ returns @map1@, except that every mapping @key+-- |-> value1@ in @map1@ that shares a key with a mapping @key |-> value2@ in+-- @map2@ is altered by @f@: @value1@ is replaced by @f value1 value2@, where+-- 'Just' means that the new value is used and 'Nothing' means that the mapping+-- is deleted.+minusUFM_C :: (elt1 -> elt2 -> Maybe elt1) -> UniqFM key elt1 -> UniqFM key elt2 -> UniqFM key elt1+minusUFM_C f (UFM x) (UFM y) = UFM (M.differenceWith f x y)+ intersectUFM :: UniqFM key elt1 -> UniqFM key elt2 -> UniqFM key elt1 intersectUFM (UFM x) (UFM y) = UFM (M.intersection x y) @@ -366,9 +383,6 @@ lookupWithDefaultUFM_Directly :: UniqFM key elt -> elt -> Unique -> elt lookupWithDefaultUFM_Directly (UFM m) v u = M.findWithDefault v (getKey u) m -eltsUFM :: UniqFM key elt -> [elt]-eltsUFM (UFM m) = M.elems m- ufmToSet_Directly :: UniqFM key elt -> S.IntSet ufmToSet_Directly (UFM m) = M.keysSet m @@ -378,11 +392,8 @@ allUFM :: (elt -> Bool) -> UniqFM key elt -> Bool allUFM p (UFM m) = M.foldr ((&&) . p) True m -seqEltsUFM :: ([elt] -> ()) -> UniqFM key elt -> ()-seqEltsUFM seqList = seqList . nonDetEltsUFM-  -- It's OK to use nonDetEltsUFM here because the type guarantees that-  -- the only interesting thing this function can do is to force the-  -- elements.+seqEltsUFM :: (elt -> ()) -> UniqFM key elt -> ()+seqEltsUFM seqElt = foldUFM (\v rest -> seqElt v `seq` rest) ()  -- See Note [Deterministic UniqFM] to learn about nondeterminism. -- If you use this please provide a justification why it doesn't introduce@@ -401,12 +412,22 @@ -- nondeterminism. nonDetStrictFoldUFM :: (elt -> a -> a) -> a -> UniqFM key elt -> a nonDetStrictFoldUFM k z (UFM m) = M.foldl' (flip k) z m+{-# INLINE nonDetStrictFoldUFM #-} +-- | In essence foldM -- See Note [Deterministic UniqFM] to learn about nondeterminism. -- If you use this please provide a justification why it doesn't introduce -- nondeterminism.+{-# INLINE nonDetStrictFoldUFM_DirectlyM #-} -- Allow specialization+nonDetStrictFoldUFM_DirectlyM :: (Monad m) => (Unique -> b -> elt -> m b) -> b -> UniqFM key elt -> m b+nonDetStrictFoldUFM_DirectlyM f z0 (UFM xs) = M.foldrWithKey c return xs z0+  -- See Note [List fusion and continuations in 'c']+  where c u x k z = f (getUnique u) z x >>= k+        {-# INLINE c #-}+ nonDetStrictFoldUFM_Directly:: (Unique -> elt -> a -> a) -> a -> UniqFM key elt -> a nonDetStrictFoldUFM_Directly k z (UFM m) = M.foldlWithKey' (\z' i x -> k (getUnique i) x z') z m+{-# INLINE nonDetStrictFoldUFM_Directly #-}  -- See Note [Deterministic UniqFM] to learn about nondeterminism. -- If you use this please provide a justification why it doesn't introduce
GHC/Types/Unique/Map.hs view
@@ -41,6 +41,8 @@     lookupWithDefaultUniqMap,     anyUniqMap,     allUniqMap,+    nonDetEltsUniqMap,+    nonDetFoldUniqMap     -- Non-deterministic functions omitted ) where @@ -72,7 +74,7 @@     ppr (UniqMap m) =         brackets $ fsep $ punctuate comma $         [ ppr k <+> text "->" <+> ppr v-        | (k, v) <- eltsUFM m ]+        | (k, v) <- nonDetEltsUFM m ]  liftC :: (a -> a -> a) -> (k, a) -> (k, a) -> (k, a) liftC f (_, v) (k', v') = (k', f v v')@@ -204,3 +206,9 @@  allUniqMap :: (a -> Bool) -> UniqMap k a -> Bool allUniqMap f (UniqMap m) = allUFM (f . snd) m++nonDetEltsUniqMap :: UniqMap k a -> [(k, a)]+nonDetEltsUniqMap (UniqMap m) = nonDetEltsUFM m++nonDetFoldUniqMap :: ((k, a) -> b -> b) -> b -> UniqMap k a -> b+nonDetFoldUniqMap go z (UniqMap m) = foldUFM go z m
+ GHC/Types/Unique/MemoFun.hs view
@@ -0,0 +1,21 @@+module GHC.Types.Unique.MemoFun (memoiseUniqueFun) where++import GHC.Prelude+import GHC.Types.Unique+import GHC.Types.Unique.FM++import Data.IORef+import System.IO.Unsafe++memoiseUniqueFun :: Uniquable k => (k -> a) -> k -> a+memoiseUniqueFun fun = unsafePerformIO $ do+  ref <- newIORef emptyUFM+  return $ \k -> unsafePerformIO $ do+    m <- readIORef ref+    case lookupUFM m k of+      Just a  -> return a+      Nothing -> do+        let !a  = fun k+            !m' = addToUFM m k a+        writeIORef ref m'+        return a
GHC/Types/Unique/Supply.hs view
@@ -43,14 +43,10 @@ import GHC.Exts( Ptr(..), noDuplicate#, oneShot ) #if MIN_VERSION_GLASGOW_HASKELL(9,1,0,0) import GHC.Exts( Int(..), word2Int#, fetchAddWordAddr#, plusWord#, readWordOffAddr# )-#if defined(DEBUG)-import GHC.Utils.Misc #endif-#endif import Foreign.Storable  #include "Unique.h"-#include "HsVersions.h"  {- ************************************************************************@@ -241,7 +237,7 @@ #if defined(DEBUG)     -- Uh oh! We will overflow next time a unique is requested.     -- (Note that if the increment isn't 1 we may miss this check)-    MASSERT(u /= mask)+    massert (u /= mask) #endif     return u #endif@@ -258,7 +254,7 @@ uniqFromMask !mask   = do { uqNum <- genSym        ; return $! mkUnique mask uqNum }-+{-# NOINLINE uniqFromMask #-} -- We'll unbox everything, but we don't want to inline it  splitUniqSupply :: UniqSupply -> (UniqSupply, UniqSupply) -- ^ Build two 'UniqSupply' from a single one, each of which
GHC/Types/Var.hs view
@@ -5,7 +5,7 @@ \section{@Vars@: Variables} -} -{-# LANGUAGE CPP, FlexibleContexts, MultiWayIf, FlexibleInstances, DeriveDataTypeable,+{-# LANGUAGE FlexibleContexts, MultiWayIf, FlexibleInstances, DeriveDataTypeable,              PatternSynonyms, BangPatterns #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}@@ -92,26 +92,24 @@         updateTyVarKindM,          nonDetCmpVar--    ) where--#include "HsVersions.h"+        ) where  import GHC.Prelude  import {-# SOURCE #-}   GHC.Core.TyCo.Rep( Type, Kind, Mult ) import {-# SOURCE #-}   GHC.Core.TyCo.Ppr( pprKind )-import {-# SOURCE #-}   GHC.Tc.Utils.TcType( TcTyVarDetails, pprTcTyVarDetails, vanillaSkolemTv )+import {-# SOURCE #-}   GHC.Tc.Utils.TcType( TcTyVarDetails, pprTcTyVarDetails, vanillaSkolemTvUnk ) import {-# SOURCE #-}   GHC.Types.Id.Info( IdDetails, IdInfo, coVarDetails, isCoVarDetails,                                            vanillaIdInfo, pprIdDetails ) import {-# SOURCE #-}   GHC.Builtin.Types ( manyDataConTy )-import {-# SOURCE #-}   GHC.Types.Name+import GHC.Types.Name hiding (varName) import GHC.Types.Unique ( Uniquable, Unique, getKey, getUnique                         , mkUniqueGrimily, nonDetCmpUnique ) import GHC.Utils.Misc import GHC.Utils.Binary import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain  import Data.Data @@ -409,13 +407,10 @@ -- abuse, ASSERTs that there is no multiplicity to update. updateVarType :: (Type -> Type) -> Var -> Var updateVarType upd var-  | debugIsOn   = case var of-      Id { id_details = details } -> ASSERT( isCoVarDetails details )+      Id { id_details = details } -> assert (isCoVarDetails details) $                                      result       _ -> result-  | otherwise-  = result   where     result = var { varType = upd (varType var) } @@ -424,13 +419,10 @@ -- abuse, ASSERTs that there is no multiplicity to update. updateVarTypeM :: Monad m => (Type -> m Type) -> Var -> m Var updateVarTypeM upd var-  | debugIsOn   = case var of-      Id { id_details = details } -> ASSERT( isCoVarDetails details )+      Id { id_details = details } -> assert (isCoVarDetails details) $                                      result       _ -> result-  | otherwise-  = result   where     result = do { ty' <- upd (varType var)                 ; return (var { varType = ty' }) }@@ -628,7 +620,7 @@  * TyCon.TyConTyCoBinder = VarBndr TyCoVar TyConBndrVis   Binders of a PromotedDataCon-  See Note [Promoted GADT data construtors] in GHC.Core.TyCon+  See Note [Promoted GADT data constructors] in GHC.Core.TyCon  * IfaceType.IfaceForAllBndr     = VarBndr IfaceBndr ArgFlag * IfaceType.IfaceForAllSpecBndr = VarBndr IfaceBndr Specificity@@ -683,7 +675,7 @@ -- 'var' should be a type variable mkTyVarBinder :: vis -> TyVar -> VarBndr TyVar vis mkTyVarBinder vis var-  = ASSERT( isTyVar var )+  = assert (isTyVar var) $     Bndr var vis  -- | Make many named binders@@ -772,9 +764,10 @@         }  tcTyVarDetails :: TyVar -> TcTyVarDetails--- See Note [TcTyVars in the typechecker] in GHC.Tc.Utils.TcType+-- See Note [TcTyVars and TyVars in the typechecker] in GHC.Tc.Utils.TcType tcTyVarDetails (TcTyVar { tc_tv_details = details }) = details-tcTyVarDetails (TyVar {})                            = vanillaSkolemTv+-- MP: This should never happen, but it does. Future work is to turn this into a panic.+tcTyVarDetails (TyVar {})                            = vanillaSkolemTvUnk tcTyVarDetails var = pprPanic "tcTyVarDetails" (ppr var <+> dcolon <+> pprKind (tyVarKind var))  setTcTyVarDetails :: TyVar -> TcTyVarDetails -> TyVar@@ -848,7 +841,7 @@  setIdNotExported :: Id -> Id -- ^ We can only do this to LocalIds-setIdNotExported id = ASSERT( isLocalId id )+setIdNotExported id = assert (isLocalId id) $                       id { idScope = LocalId NotExported }  -----------------------
GHC/Types/Var.hs-boot view
@@ -1,3 +1,4 @@+{-# LANGUAGE NoPolyKinds #-} module GHC.Types.Var where  import GHC.Prelude ()
GHC/Types/Var/Env.hs view
@@ -17,6 +17,7 @@         delVarEnvList, delVarEnv,         minusVarEnv,         lookupVarEnv, lookupVarEnv_NF, lookupWithDefaultVarEnv,+        lookupVarEnv_Directly,         mapVarEnv, zipVarEnv,         modifyVarEnv, modifyVarEnv_Directly,         isEmptyVarEnv,@@ -98,7 +99,11 @@ ************************************************************************ -} --- | A set of variables that are in scope at some point+-- | A set of variables that are in scope at some point.+--+-- Note that this is a /superset/ of the variables that are currently in scope.+-- See Note [The InScopeSet invariant].+-- -- "Secrets of the Glasgow Haskell Compiler inliner" Section 3.2 provides -- the motivation for this abstraction. newtype InScopeSet = InScope VarSet@@ -110,6 +115,21 @@         -- lookup is useful (see, for instance, Note [In-scope set as a         -- substitution]). +        -- Note [The InScopeSet invariant]+        -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+        -- The InScopeSet must include every in-scope variable, but it may also+        -- include other variables.++        -- Its principal purpose is to provide a set of variables to be avoided+        -- when creating a fresh identifier (fresh in the sense that it does not+        -- "shadow" any in-scope binding). To do this we simply have to find one that+        -- does not appear in the InScopeSet. This is done by the key function+        -- GHC.Types.Var.Env.uniqAway.++        -- See "Secrets of the Glasgow Haskell Compiler inliner" Section 3.2+        -- for more detailed motivation. #20419 has further discussion.++ instance Outputable InScopeSet where   ppr (InScope s) =     text "InScope" <+>@@ -182,7 +202,8 @@  -}  -- | @uniqAway in_scope v@ finds a unique that is not used in the--- in-scope set, and gives that to v. See Note [Local uniques].+-- in-scope set, and gives that to v. See Note [Local uniques] and+-- Note [The InScopeSet invariant]. uniqAway :: InScopeSet -> Var -> Var -- It starts with v's current unique, of course, in the hope that it won't -- have to change, and thereafter uses the successor to the last derived unique@@ -304,6 +325,7 @@           | otherwise                          = uniqAway' in_scope bL          -- Note [Rebinding]+        -- ~~~~~~~~~~~~~~~~         -- If the new var is the same as the old one, note that         -- the extendVarEnv *deletes* any current renaming         -- E.g.   (\x. \x. ...)  ~  (\y. \z. ...)@@ -435,7 +457,7 @@ {- ************************************************************************ *                                                                      *-\subsection{@VarEnv@s}+   VarEnv *                                                                      * ************************************************************************ -}@@ -485,6 +507,7 @@  isEmptyVarEnv     :: VarEnv a -> Bool lookupVarEnv      :: VarEnv a -> Var -> Maybe a+lookupVarEnv_Directly :: VarEnv a -> Unique -> Maybe a filterVarEnv      :: (a -> Bool) -> VarEnv a -> VarEnv a lookupVarEnv_NF   :: VarEnv a -> Var -> a lookupWithDefaultVarEnv :: VarEnv a -> a -> Var -> a@@ -508,7 +531,13 @@ minusVarEnv      = minusUFM plusVarEnv       = plusUFM plusVarEnvList   = plusUFMList+-- lookupVarEnv is very hot (in part due to being called by substTyVar),+-- if it's not inlined than the mere allocation of the Just constructor causes+-- perf benchmarks to regress by 2% in some cases. See #21159, !7638 and containers#821+-- for some more explanation about what exactly went wrong.+{-# INLINE lookupVarEnv #-} lookupVarEnv     = lookupUFM+lookupVarEnv_Directly = lookupUFM_Directly filterVarEnv     = filterUFM lookupWithDefaultVarEnv = lookupWithDefaultUFM mapVarEnv        = mapUFM@@ -544,7 +573,13 @@       Nothing -> env       Just xx -> addToUFM_Directly env key (mangle_fn xx) --- Deterministic VarEnv+{-+************************************************************************+*                                                                      *+   Deterministic VarEnv (DVarEnv)+*                                                                      *+************************************************************************+-} -- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM for explanation why we need -- DVarEnv.
GHC/Types/Var/Set.hs view
@@ -3,8 +3,8 @@ (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -} -{-# LANGUAGE CPP #-} + module GHC.Types.Var.Set (         -- * Var, Id and TyVar set types         VarSet, IdSet, TyVarSet, CoVarSet, TyCoVarSet,@@ -46,8 +46,6 @@         dVarSetToVarSet,     ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Types.Var      ( Var, TyVar, CoVar, TyCoVar, Id )@@ -197,7 +195,7 @@          new_vs = fn candidates `minusVarSet` acc  seqVarSet :: VarSet -> ()-seqVarSet s = sizeVarSet s `seq` ()+seqVarSet s = s `seq` ()  -- | Determines the pluralisation suffix appropriate for the length of a set -- in the same way that plural from Outputable does for lists.@@ -325,7 +323,7 @@ delDVarSetList = delListFromUniqDSet  seqDVarSet :: DVarSet -> ()-seqDVarSet s = sizeDVarSet s `seq` ()+seqDVarSet s = s `seq` ()  -- | Add a list of variables to DVarSet extendDVarSetList :: DVarSet -> [Var] -> DVarSet
GHC/Unit.hs view
@@ -17,15 +17,12 @@ import GHC.Unit.Parser import GHC.Unit.Module import GHC.Unit.Home--- source import to avoid DynFlags import loops-import {-# SOURCE #-} GHC.Unit.State+import GHC.Unit.State  {---Note [About Units]+Note [About units] ~~~~~~~~~~~~~~~~~~--Haskell users are used to manipulate Cabal packages. These packages are+Haskell users are used to manipulating Cabal packages. These packages are identified by:    - a package name :: String    - a package version :: Version@@ -154,10 +151,6 @@ enough to compile them. As such, indefinite units found in databases only provide module interfaces (the .hi ones this time), not object code. -To distinguish between indefinite and definite unit ids at the type level, we-respectively use 'IndefUnitId' and 'DefUnitId' datatypes that are basically-wrappers over 'UnitId'.- Unit instantiation / on-the-fly instantiation --------------------------------------------- @@ -225,7 +218,7 @@  'InstantiatedUnit' has two interesting fields: -   * instUnitInstanceOf :: IndefUnitId+   * instUnitInstanceOf :: UnitId       -- ^ the indefinite unit that is instantiated     * instUnitInsts :: [(ModuleName,(Unit,ModuleName)]@@ -268,7 +261,7 @@                                  , ...                                  } -TODO: We should probably have `instanceOf :: Maybe IndefUnitId` instead.+TODO: We should probably have `instanceOf :: Maybe UnitId` instead.   Note [Pretty-printing UnitId]
GHC/Unit/Env.hs view
@@ -1,27 +1,137 @@+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE FlexibleInstances #-} module GHC.Unit.Env     ( UnitEnv (..)+    , initUnitEnv+    , unsafeGetHomeUnit+    , updateHug+    , updateHpt+    -- * Unit Env helper functions+    , ue_units+    , ue_currentHomeUnitEnv+    , ue_setUnits+    , ue_setUnitFlags+    , ue_unit_dbs+    , ue_setUnitDbs+    , ue_hpt+    , ue_homeUnit+    , ue_unsafeHomeUnit+    , ue_setFlags+    , ue_setActiveUnit+    , ue_currentUnit+    , ue_findHomeUnitEnv+    , ue_updateHomeUnitEnv+    , ue_unitHomeUnit+    , ue_unitFlags+    , ue_renameUnitId+    , ue_transitiveHomeDeps+    -- * HomeUnitEnv+    , HomeUnitGraph+    , HomeUnitEnv (..)+    , mkHomeUnitEnv+    , lookupHugByModule+    , hugElts+    , lookupHug+    , addHomeModInfoToHug+    -- * UnitEnvGraph+    , UnitEnvGraph (..)+    , unitEnv_insert+    , unitEnv_delete+    , unitEnv_adjust+    , unitEnv_new+    , unitEnv_singleton+    , unitEnv_map+    , unitEnv_member+    , unitEnv_lookup_maybe+    , unitEnv_lookup+    , unitEnv_keys+    , unitEnv_elts+    , unitEnv_hpts+    , unitEnv_foldWithKey+    , unitEnv_mapWithKey+    -- * Invariants+    , assertUnitEnvInvariant+    -- * Preload units info     , preloadUnitsInfo     , preloadUnitsInfo'-    )+    -- * Home Module functions+    , isUnitEnvInstalledModule ) where  import GHC.Prelude +import GHC.Unit.External import GHC.Unit.State import GHC.Unit.Home import GHC.Unit.Types+import GHC.Unit.Home.ModInfo  import GHC.Platform import GHC.Settings import GHC.Data.Maybe+import GHC.Utils.Panic.Plain+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import GHC.Utils.Misc (HasDebugCallStack)+import GHC.Driver.Session+import GHC.Utils.Outputable+import GHC.Utils.Panic (pprPanic)+import GHC.Unit.Module.ModIface+import GHC.Unit.Module+import qualified Data.Set as Set  data UnitEnv = UnitEnv-    { ue_units     :: !UnitState      -- ^ Units-    , ue_home_unit :: !HomeUnit       -- ^ Home unit-    , ue_platform  :: !Platform       -- ^ Platform-    , ue_namever   :: !GhcNameVersion -- ^ GHC name/version (used for dynamic library suffix)+    { ue_eps :: {-# UNPACK #-} !ExternalUnitCache+        -- ^ Information about the currently loaded external packages.+        -- This is mutable because packages will be demand-loaded during+        -- a compilation run as required.++    , ue_current_unit    :: UnitId++    , ue_home_unit_graph :: !HomeUnitGraph+        -- See Note [Multiple Home Units]++    , ue_platform  :: !Platform+        -- ^ Platform++    , ue_namever   :: !GhcNameVersion+        -- ^ GHC name/version (used for dynamic library suffix)     } +initUnitEnv :: UnitId -> HomeUnitGraph -> GhcNameVersion -> Platform -> IO UnitEnv+initUnitEnv cur_unit hug namever platform = do+  eps <- initExternalUnitCache+  return $ UnitEnv+    { ue_eps             = eps+    , ue_home_unit_graph = hug+    , ue_current_unit    = cur_unit+    , ue_platform        = platform+    , ue_namever         = namever+    }++-- | Get home-unit+--+-- Unsafe because the home-unit may not be set+unsafeGetHomeUnit :: UnitEnv -> HomeUnit+unsafeGetHomeUnit ue = ue_unsafeHomeUnit ue++updateHpt :: (HomePackageTable -> HomePackageTable) -> UnitEnv -> UnitEnv+updateHpt = ue_updateHPT++updateHug :: (HomeUnitGraph -> HomeUnitGraph) -> UnitEnv -> UnitEnv+updateHug = ue_updateHUG++ue_transitiveHomeDeps :: UnitId -> UnitEnv -> [UnitId]+ue_transitiveHomeDeps uid unit_env = Set.toList (loop Set.empty [uid])+  where+    loop acc [] = acc+    loop acc (uid:uids)+      | uid `Set.member` acc = loop acc uids+      | otherwise =+        let hue = homeUnitDepends (homeUnitEnv_units (ue_findHomeUnitEnv uid unit_env))+        in loop (Set.insert uid acc) (hue ++ uids)++ -- ----------------------------------------------------------------------------- -- Extracting information from the packages in scope @@ -39,15 +149,16 @@ preloadUnitsInfo' :: UnitEnv -> [UnitId] -> MaybeErr UnitErr [UnitInfo] preloadUnitsInfo' unit_env ids0 = all_infos   where-    home_unit  = ue_home_unit unit_env-    unit_state = ue_units     unit_env+    unit_state = ue_units unit_env     ids      = ids0 ++ inst_ids-    inst_ids+    inst_ids = case ue_homeUnit unit_env of+      Nothing -> []+      Just home_unit        -- An indefinite package will have insts to HOLE,        -- which is not a real package. Don't look it up.        -- Fixes #14525-       | isHomeUnitIndefinite home_unit = []-       | otherwise = map (toUnitId . moduleUnit . snd) (homeUnitInstantiations home_unit)+       | isHomeUnitIndefinite home_unit -> []+       | otherwise -> map (toUnitId . moduleUnit . snd) (homeUnitInstantiations home_unit)     pkg_map = unitInfoMap unit_state     preload = preloadUnits unit_state @@ -59,3 +170,401 @@ -- unit used to instantiate the home unit. preloadUnitsInfo :: UnitEnv -> MaybeErr UnitErr [UnitInfo] preloadUnitsInfo unit_env = preloadUnitsInfo' unit_env []++-- -----------------------------------------------------------------------------++data HomeUnitEnv = HomeUnitEnv+  { homeUnitEnv_units     :: !UnitState+      -- ^ External units++  , homeUnitEnv_unit_dbs :: !(Maybe [UnitDatabase UnitId])+      -- ^ Stack of unit databases for the target platform.+      --+      -- This field is populated with the result of `initUnits`.+      --+      -- 'Nothing' means the databases have never been read from disk.+      --+      -- Usually we don't reload the databases from disk if they are+      -- cached, even if the database flags changed!++  , homeUnitEnv_dflags :: DynFlags+    -- ^ The dynamic flag settings+  , homeUnitEnv_hpt :: HomePackageTable+    -- ^ The home package table describes already-compiled+    -- home-package modules, /excluding/ the module we+    -- are compiling right now.+    -- (In one-shot mode the current module is the only+    -- home-package module, so homeUnitEnv_hpt is empty.  All other+    -- modules count as \"external-package\" modules.+    -- However, even in GHCi mode, hi-boot interfaces are+    -- demand-loaded into the external-package table.)+    --+    -- 'homeUnitEnv_hpt' is not mutable because we only demand-load+    -- external packages; the home package is eagerly+    -- loaded, module by module, by the compilation manager.+    --+    -- The HPT may contain modules compiled earlier by @--make@+    -- but not actually below the current module in the dependency+    -- graph.+    --+    -- (This changes a previous invariant: changed Jan 05.)++  , homeUnitEnv_home_unit :: !(Maybe HomeUnit)+    -- ^ Home-unit+  }++instance Outputable HomeUnitEnv where+  ppr hug = pprHPT (homeUnitEnv_hpt hug)++homeUnitEnv_unsafeHomeUnit :: HomeUnitEnv -> HomeUnit+homeUnitEnv_unsafeHomeUnit hue = case homeUnitEnv_home_unit hue of+  Nothing -> panic "homeUnitEnv_unsafeHomeUnit: No home unit"+  Just h  -> h++mkHomeUnitEnv :: DynFlags -> HomePackageTable -> Maybe HomeUnit -> HomeUnitEnv+mkHomeUnitEnv dflags hpt home_unit = HomeUnitEnv+  { homeUnitEnv_units = emptyUnitState+  , homeUnitEnv_unit_dbs = Nothing+  , homeUnitEnv_dflags = dflags+  , homeUnitEnv_hpt = hpt+  , homeUnitEnv_home_unit = home_unit+  }++-- | Test if the module comes from the home unit+isUnitEnvInstalledModule :: UnitEnv -> InstalledModule -> Bool+isUnitEnvInstalledModule ue m = maybe False (`isHomeInstalledModule` m) hu+  where+    hu = ue_unitHomeUnit_maybe (moduleUnit m) ue+++type HomeUnitGraph = UnitEnvGraph HomeUnitEnv++lookupHugByModule :: Module -> HomeUnitGraph -> Maybe HomeModInfo+lookupHugByModule mod hug+  | otherwise = do+      env <- (unitEnv_lookup_maybe (toUnitId $ moduleUnit mod) hug)+      lookupHptByModule (homeUnitEnv_hpt env) mod++hugElts :: HomeUnitGraph -> [(UnitId, HomeUnitEnv)]+hugElts hug = unitEnv_elts hug++addHomeModInfoToHug :: HomeModInfo -> HomeUnitGraph -> HomeUnitGraph+addHomeModInfoToHug hmi hug = unitEnv_alter go hmi_unit hug+  where+    hmi_mod :: Module+    hmi_mod = mi_module (hm_iface hmi)++    hmi_unit = toUnitId (moduleUnit hmi_mod)+    _hmi_mn   = moduleName hmi_mod++    go :: Maybe HomeUnitEnv -> Maybe HomeUnitEnv+    go Nothing = pprPanic "addHomeInfoToHug" (ppr hmi_mod)+    go (Just hue) = Just (updateHueHpt (addHomeModInfoToHpt hmi) hue)++updateHueHpt :: (HomePackageTable -> HomePackageTable) -> HomeUnitEnv -> HomeUnitEnv+updateHueHpt f hue = hue { homeUnitEnv_hpt = f (homeUnitEnv_hpt hue)}+++lookupHug :: HomeUnitGraph -> UnitId -> ModuleName -> Maybe HomeModInfo+lookupHug hug uid mod = unitEnv_lookup_maybe uid hug >>= flip lookupHpt mod . homeUnitEnv_hpt+++instance Outputable (UnitEnvGraph HomeUnitEnv) where+  ppr g = ppr [(k, length (homeUnitEnv_hpt  hue)) | (k, hue) <- (unitEnv_elts g)]+++type UnitEnvGraphKey = UnitId++newtype UnitEnvGraph v = UnitEnvGraph+  { unitEnv_graph :: Map UnitEnvGraphKey v+  } deriving (Functor, Foldable, Traversable)++unitEnv_insert :: UnitEnvGraphKey -> v -> UnitEnvGraph v -> UnitEnvGraph v+unitEnv_insert unitId env unitEnv = unitEnv+  { unitEnv_graph = Map.insert unitId env (unitEnv_graph unitEnv)+  }++unitEnv_delete :: UnitEnvGraphKey -> UnitEnvGraph v -> UnitEnvGraph v+unitEnv_delete uid unitEnv =+    unitEnv+      { unitEnv_graph = Map.delete uid (unitEnv_graph unitEnv)+      }++unitEnv_adjust :: (v -> v) -> UnitEnvGraphKey -> UnitEnvGraph v -> UnitEnvGraph v+unitEnv_adjust f uid unitEnv = unitEnv+  { unitEnv_graph = Map.adjust f uid (unitEnv_graph unitEnv)+  }++unitEnv_alter :: (Maybe v -> Maybe v) -> UnitEnvGraphKey -> UnitEnvGraph v -> UnitEnvGraph v+unitEnv_alter f uid unitEnv = unitEnv+  { unitEnv_graph = Map.alter f uid (unitEnv_graph unitEnv)+  }++unitEnv_mapWithKey :: (UnitEnvGraphKey -> v -> b) -> UnitEnvGraph v -> UnitEnvGraph b+unitEnv_mapWithKey f (UnitEnvGraph u) = UnitEnvGraph $ Map.mapWithKey f u++unitEnv_new :: Map UnitEnvGraphKey v -> UnitEnvGraph v+unitEnv_new m =+  UnitEnvGraph+    { unitEnv_graph = m+    }++unitEnv_singleton :: UnitEnvGraphKey -> v -> UnitEnvGraph v+unitEnv_singleton active m = UnitEnvGraph+  { unitEnv_graph = Map.singleton active m+  }++unitEnv_map :: (v -> v) -> UnitEnvGraph v -> UnitEnvGraph v+unitEnv_map f m = m { unitEnv_graph = Map.map f (unitEnv_graph m)}++unitEnv_member :: UnitEnvGraphKey -> UnitEnvGraph v -> Bool+unitEnv_member u env = Map.member u (unitEnv_graph env)++unitEnv_lookup_maybe :: UnitEnvGraphKey -> UnitEnvGraph v -> Maybe v+unitEnv_lookup_maybe u env = Map.lookup u (unitEnv_graph env)++unitEnv_lookup :: UnitEnvGraphKey -> UnitEnvGraph v -> v+unitEnv_lookup u env = fromJust $ unitEnv_lookup_maybe u env++unitEnv_keys :: UnitEnvGraph v -> Set.Set UnitEnvGraphKey+unitEnv_keys env = Map.keysSet (unitEnv_graph env)++unitEnv_elts :: UnitEnvGraph v -> [(UnitEnvGraphKey, v)]+unitEnv_elts env = Map.toList (unitEnv_graph env)++unitEnv_hpts :: UnitEnvGraph HomeUnitEnv -> [HomePackageTable]+unitEnv_hpts env = map homeUnitEnv_hpt (Map.elems (unitEnv_graph env))++unitEnv_foldWithKey :: (b -> UnitEnvGraphKey -> a -> b) -> b -> UnitEnvGraph a -> b+unitEnv_foldWithKey f z (UnitEnvGraph g)= Map.foldlWithKey' f z g++-- -------------------------------------------------------+-- Query and modify UnitState in HomeUnitEnv+-- -------------------------------------------------------++ue_units :: HasDebugCallStack => UnitEnv -> UnitState+ue_units = homeUnitEnv_units . ue_currentHomeUnitEnv++ue_setUnits :: UnitState -> UnitEnv -> UnitEnv+ue_setUnits units ue = ue_updateHomeUnitEnv f (ue_currentUnit ue) ue+  where+    f hue = hue { homeUnitEnv_units = units  }++ue_unit_dbs :: UnitEnv ->  Maybe [UnitDatabase UnitId]+ue_unit_dbs = homeUnitEnv_unit_dbs . ue_currentHomeUnitEnv++ue_setUnitDbs :: Maybe [UnitDatabase UnitId] -> UnitEnv -> UnitEnv+ue_setUnitDbs unit_dbs ue = ue_updateHomeUnitEnv f (ue_currentUnit ue) ue+  where+    f hue = hue { homeUnitEnv_unit_dbs = unit_dbs  }++-- -------------------------------------------------------+-- Query and modify Home Package Table in HomeUnitEnv+-- -------------------------------------------------------++ue_hpt :: HasDebugCallStack => UnitEnv -> HomePackageTable+ue_hpt = homeUnitEnv_hpt . ue_currentHomeUnitEnv++ue_updateHPT :: HasDebugCallStack => (HomePackageTable -> HomePackageTable) -> UnitEnv -> UnitEnv+ue_updateHPT f e = ue_updateUnitHPT f (ue_currentUnit e) e++ue_updateHUG :: HasDebugCallStack => (HomeUnitGraph -> HomeUnitGraph) -> UnitEnv -> UnitEnv+ue_updateHUG f e = ue_updateUnitHUG f e++ue_updateUnitHPT :: HasDebugCallStack => (HomePackageTable -> HomePackageTable) -> UnitId -> UnitEnv -> UnitEnv+ue_updateUnitHPT f uid ue_env = ue_updateHomeUnitEnv update uid ue_env+  where+    update unitEnv = unitEnv { homeUnitEnv_hpt = f $ homeUnitEnv_hpt unitEnv }++ue_updateUnitHUG :: HasDebugCallStack => (HomeUnitGraph -> HomeUnitGraph) -> UnitEnv -> UnitEnv+ue_updateUnitHUG f ue_env = ue_env { ue_home_unit_graph = f (ue_home_unit_graph ue_env)}++-- -------------------------------------------------------+-- Query and modify DynFlags in HomeUnitEnv+-- -------------------------------------------------------++ue_setFlags :: HasDebugCallStack => DynFlags -> UnitEnv -> UnitEnv+ue_setFlags dflags ue_env = ue_setUnitFlags (ue_currentUnit ue_env) dflags ue_env++ue_setUnitFlags :: HasDebugCallStack => UnitId -> DynFlags -> UnitEnv -> UnitEnv+ue_setUnitFlags uid dflags e =+  ue_updateUnitFlags (const dflags) uid e++ue_unitFlags :: HasDebugCallStack => UnitId -> UnitEnv -> DynFlags+ue_unitFlags uid ue_env = homeUnitEnv_dflags $ ue_findHomeUnitEnv uid ue_env++ue_updateUnitFlags :: HasDebugCallStack => (DynFlags -> DynFlags) -> UnitId -> UnitEnv -> UnitEnv+ue_updateUnitFlags f uid e = ue_updateHomeUnitEnv update uid e+  where+    update hue = hue { homeUnitEnv_dflags = f $ homeUnitEnv_dflags hue }++-- -------------------------------------------------------+-- Query and modify home units in HomeUnitEnv+-- -------------------------------------------------------++ue_homeUnit :: UnitEnv -> Maybe HomeUnit+ue_homeUnit = homeUnitEnv_home_unit . ue_currentHomeUnitEnv++ue_unsafeHomeUnit :: UnitEnv -> HomeUnit+ue_unsafeHomeUnit ue = case ue_homeUnit ue of+  Nothing -> panic "unsafeGetHomeUnit: No home unit"+  Just h  -> h++ue_unitHomeUnit_maybe :: UnitId -> UnitEnv -> Maybe HomeUnit+ue_unitHomeUnit_maybe uid ue_env =+  homeUnitEnv_unsafeHomeUnit <$> (ue_findHomeUnitEnv_maybe uid ue_env)++ue_unitHomeUnit :: UnitId -> UnitEnv -> HomeUnit+ue_unitHomeUnit uid ue_env = homeUnitEnv_unsafeHomeUnit $ ue_findHomeUnitEnv uid ue_env+++-- -------------------------------------------------------+-- Query and modify the currently active unit+-- -------------------------------------------------------++ue_currentHomeUnitEnv :: HasDebugCallStack => UnitEnv -> HomeUnitEnv+ue_currentHomeUnitEnv e =+  case ue_findHomeUnitEnv_maybe (ue_currentUnit e) e of+    Just unitEnv -> unitEnv+    Nothing -> pprPanic "packageNotFound" $+      (ppr $ ue_currentUnit e) $$ ppr (ue_home_unit_graph e)++ue_setActiveUnit :: UnitId -> UnitEnv -> UnitEnv+ue_setActiveUnit u ue_env = assertUnitEnvInvariant $ ue_env+  { ue_current_unit = u+  }++ue_currentUnit :: UnitEnv -> UnitId+ue_currentUnit = ue_current_unit++-- -------------------------------------------------------+-- Operations on arbitrary elements of the home unit graph+-- -------------------------------------------------------++ue_findHomeUnitEnv_maybe :: UnitId -> UnitEnv -> Maybe HomeUnitEnv+ue_findHomeUnitEnv_maybe uid e =+  unitEnv_lookup_maybe uid (ue_home_unit_graph e)++ue_findHomeUnitEnv :: HasDebugCallStack => UnitId -> UnitEnv -> HomeUnitEnv+ue_findHomeUnitEnv uid e = case unitEnv_lookup_maybe uid (ue_home_unit_graph e) of+  Nothing -> pprPanic "Unit unknown to the internal unit environment"+              $  text "unit (" <> ppr uid <> text ")"+              $$ pprUnitEnvGraph e+  Just hue -> hue++ue_updateHomeUnitEnv :: (HomeUnitEnv -> HomeUnitEnv) -> UnitId -> UnitEnv -> UnitEnv+ue_updateHomeUnitEnv f uid e = e+  { ue_home_unit_graph = unitEnv_adjust f uid $ ue_home_unit_graph e+  }+++-- | Rename a unit id in the internal unit env.+--+-- @'ue_renameUnitId' oldUnit newUnit UnitEnv@, it is assumed that the 'oldUnit' exists in the map,+-- otherwise we panic.+-- The 'DynFlags' associated with the home unit will have its field 'homeUnitId' set to 'newUnit'.+ue_renameUnitId :: HasDebugCallStack => UnitId -> UnitId -> UnitEnv -> UnitEnv+ue_renameUnitId oldUnit newUnit unitEnv = case ue_findHomeUnitEnv_maybe oldUnit unitEnv of+  Nothing ->+    pprPanic "Tried to rename unit, but it didn't exist"+              $ text "Rename old unit \"" <> ppr oldUnit <> text "\" to \""<> ppr newUnit <> text "\""+              $$ nest 2 (pprUnitEnvGraph unitEnv)+  Just oldEnv ->+    let+      activeUnit :: UnitId+      !activeUnit = if ue_currentUnit unitEnv == oldUnit+                then newUnit+                else ue_currentUnit unitEnv++      newInternalUnitEnv = oldEnv+        { homeUnitEnv_dflags = (homeUnitEnv_dflags oldEnv)+            { homeUnitId_ = newUnit+            }+        }+    in+    unitEnv+      { ue_current_unit = activeUnit+      , ue_home_unit_graph =+          unitEnv_insert newUnit newInternalUnitEnv+          $ unitEnv_delete oldUnit+          $ ue_home_unit_graph unitEnv+          }++-- ---------------------------------------------+-- Asserts to enforce invariants for the UnitEnv+-- ---------------------------------------------++assertUnitEnvInvariant :: HasDebugCallStack => UnitEnv -> UnitEnv+assertUnitEnvInvariant u =+  if ue_current_unit u `unitEnv_member` ue_home_unit_graph u+    then u+    else pprPanic "invariant" (ppr (ue_current_unit u) $$ ppr (ue_home_unit_graph u))++-- -----------------------------------------------------------------------------+-- Pretty output functions+-- -----------------------------------------------------------------------------++pprUnitEnvGraph :: UnitEnv -> SDoc+pprUnitEnvGraph env = text "pprInternalUnitMap"+  $$ nest 2 (pprHomeUnitGraph $ ue_home_unit_graph env)++pprHomeUnitGraph :: HomeUnitGraph -> SDoc+pprHomeUnitGraph unitEnv = vcat (map (\(k, v) -> pprHomeUnitEnv k v) $ Map.assocs $ unitEnv_graph unitEnv)++pprHomeUnitEnv :: UnitId -> HomeUnitEnv -> SDoc+pprHomeUnitEnv uid env =+  ppr uid <+> text "(flags:" <+> ppr (homeUnitId_ $ homeUnitEnv_dflags env) <> text "," <+> ppr (fmap homeUnitId $ homeUnitEnv_home_unit env) <> text ")" <+> text "->"+  $$ nest 4 (pprHPT $ homeUnitEnv_hpt env)++{-+Note [Multiple Home Units]+~~~~~~~~~~~~~~~~~~~~~~~~~~+The basic idea of multiple home units is quite simple. Instead of allowing one+home unit, you can multiple home units++The flow:++1. Dependencies between units are specified between each other in the normal manner,+   a unit is identified by the -this-unit-id flag and dependencies specified by+   the normal -package-id flag.+2. Downsweep is augmented to know to know how to look for dependencies in any home unit.+3. The rest of the compiler is modified appropiately to offset paths to the right places.+4. --make mode can parallelise between home units and multiple units are allowed to produce linkables.++Closure Property+----------------++You must perform a clean cut of the dependency graph.++> Any dependency which is not a home unit must not (transitively) depend on a home unit.++For example, if you have three packages p, q and r, then if p depends on q which+depends on r then it is illegal to load both p and r as home units but not q,+because q is a dependency of the home unit p which depends on another home unit r.++Offsetting Paths+----------------++The main complication to the implementation is to do with offsetting paths appropiately.+For a long time it has been assumed that GHC will execute in the top-directory for a unit,+normally where the .cabal file is and all paths are interpreted relative to there.+When you have multiple home units then it doesn't make sense to pick one of these+units to choose as the base-unit, and you can't robustly change directories when+using parralelism.++Therefore there is an option `-working-directory`, which tells GHC where the relative+paths for each unit should be interpreted relative to. For example, if you specify+`-working-dir a -ib`, then GHC will offset the relative path `b`, by `a`, and look for+source files in `a/b`. The same thing happens for any path passed on the command line.++A non-exhaustive list is++* -i+* -I+* -odir/-hidir/-outputdir/-stubdir/-hiedir+* Target files passed on the command line++There is also a template-haskell function, makeRelativeToProject, which uses the `-working-directory` option+in order to allow users to offset their own relative paths.++-}
GHC/Unit/External.hs view
@@ -1,5 +1,8 @@ module GHC.Unit.External-   ( ExternalPackageState (..)+   ( ExternalUnitCache (..)+   , initExternalUnitCache+   , ExternalPackageState (..)+   , initExternalPackageState    , EpsStats(..)    , addEpsInStats    , PackageTypeEnv@@ -19,14 +22,18 @@  import GHC.Core         ( RuleBase ) import GHC.Core.FamInstEnv-import GHC.Core.InstEnv ( InstEnv )+import GHC.Core.InstEnv ( InstEnv, emptyInstEnv )+import GHC.Core.Opt.ConstantFold+import GHC.Core.Rules (mkRuleBase) -import GHC.Types.Annotations ( AnnEnv )+import GHC.Types.Annotations ( AnnEnv, emptyAnnEnv ) import GHC.Types.CompleteMatch import GHC.Types.TypeEnv import GHC.Types.Unique.DSet +import Data.IORef + type PackageTypeEnv          = TypeEnv type PackageRuleBase         = RuleBase type PackageInstEnv          = InstEnv@@ -42,12 +49,46 @@ emptyPackageIfaceTable :: PackageIfaceTable emptyPackageIfaceTable = emptyModuleEnv +-- | Information about the currently loaded external packages.+-- This is mutable because packages will be demand-loaded during+-- a compilation run as required.+newtype ExternalUnitCache = ExternalUnitCache+  { euc_eps :: IORef ExternalPackageState+  } +initExternalUnitCache :: IO ExternalUnitCache+initExternalUnitCache = ExternalUnitCache <$> newIORef initExternalPackageState++initExternalPackageState :: ExternalPackageState+initExternalPackageState = EPS+  { eps_is_boot          = emptyInstalledModuleEnv+  , eps_PIT              = emptyPackageIfaceTable+  , eps_free_holes       = emptyInstalledModuleEnv+  , eps_PTE              = emptyTypeEnv+  , eps_inst_env         = emptyInstEnv+  , eps_fam_inst_env     = emptyFamInstEnv+  , eps_rule_base        = mkRuleBase builtinRules+  , -- Initialise the EPS rule pool with the built-in rules+    eps_mod_fam_inst_env = emptyModuleEnv+  , eps_complete_matches = []+  , eps_ann_env          = emptyAnnEnv+  , eps_stats            = EpsStats+                            { n_ifaces_in = 0+                            , n_decls_in = 0+                            , n_decls_out = 0+                            , n_insts_in = 0+                            , n_insts_out = 0+                            , n_rules_in = length builtinRules+                            , n_rules_out = 0+                            }+  }++ -- | Information about other packages that we have slurped in by reading -- their interface files data ExternalPackageState   = EPS {-        eps_is_boot :: !(ModuleNameEnv ModuleNameWithIsBoot),+        eps_is_boot :: !(InstalledModuleEnv ModuleNameWithIsBoot),                 -- ^ In OneShot mode (only), home-package modules                 -- accumulate in the external package state, and are                 -- sucked in lazily.  For these home-pkg modules
GHC/Unit/Finder.hs view
@@ -3,14 +3,16 @@  -} -{-# LANGUAGE CPP #-}+ {-# LANGUAGE FlexibleContexts #-}  -- | Module finder module GHC.Unit.Finder (     FindResult(..),     InstalledFindResult(..),+    FinderOpts(..),     FinderCache,+    initFinderCache,     flushFinderCaches,     findImportedModule,     findPluginModule,@@ -22,6 +24,7 @@     mkHiOnlyModLocation,     mkHiPath,     mkObjPath,+    addModuleToFinder,     addHomeModuleToFinder,     uncacheModule,     mkStubPaths,@@ -29,26 +32,23 @@     findObjectLinkableMaybe,     findObjectLinkable, +    -- Hash cache+    lookupFileCache   ) where -#include "HsVersions.h"- import GHC.Prelude -import GHC.Driver.Env-import GHC.Driver.Session- import GHC.Platform.Ways  import GHC.Builtin.Names ( gHC_PRIM ) +import GHC.Unit.Env import GHC.Unit.Types import GHC.Unit.Module import GHC.Unit.Home import GHC.Unit.State import GHC.Unit.Finder.Types -import GHC.Data.FastString import GHC.Data.Maybe    ( expectJust ) import qualified GHC.Data.ShortText as ST @@ -57,13 +57,19 @@ import GHC.Utils.Panic  import GHC.Linker.Types+import GHC.Types.PkgQual -import Data.IORef       ( IORef, readIORef, atomicModifyIORef' )+import GHC.Fingerprint+import Data.IORef import System.Directory import System.FilePath import Control.Monad import Data.Time-+import qualified Data.Map as M+import GHC.Driver.Env+    ( hsc_home_unit_maybe, HscEnv(hsc_FC, hsc_dflags, hsc_unit_env) )+import GHC.Driver.Config.Finder+import qualified Data.Set as Set  type FileExt = String   -- Filename extension type BaseName = String  -- Basename of file@@ -81,62 +87,125 @@ -- ----------------------------------------------------------------------------- -- The finder's cache ++initFinderCache :: IO FinderCache+initFinderCache = FinderCache <$> newIORef emptyInstalledModuleEnv+                              <*> newIORef M.empty+ -- remove all the home modules from the cache; package modules are--- assumed to not move around during a session.-flushFinderCaches :: HscEnv -> IO ()-flushFinderCaches hsc_env =-  atomicModifyIORef' fc_ref $ \fm -> (filterInstalledModuleEnv is_ext fm, ())+-- assumed to not move around during a session; also flush the file hash+-- cache+flushFinderCaches :: FinderCache -> UnitEnv -> IO ()+flushFinderCaches (FinderCache ref file_ref) ue = do+  atomicModifyIORef' ref $ \fm -> (filterInstalledModuleEnv is_ext fm, ())+  atomicModifyIORef' file_ref $ \_ -> (M.empty, ())  where-        fc_ref       = hsc_FC hsc_env-        home_unit    = hsc_home_unit hsc_env-        is_ext mod _ = not (isHomeInstalledModule home_unit mod)+  is_ext mod _ = not (isUnitEnvInstalledModule ue mod) -addToFinderCache :: IORef FinderCache -> InstalledModule -> InstalledFindResult -> IO ()-addToFinderCache ref key val =+addToFinderCache :: FinderCache -> InstalledModule -> InstalledFindResult -> IO ()+addToFinderCache (FinderCache ref _) key val =   atomicModifyIORef' ref $ \c -> (extendInstalledModuleEnv c key val, ()) -removeFromFinderCache :: IORef FinderCache -> InstalledModule -> IO ()-removeFromFinderCache ref key =+removeFromFinderCache :: FinderCache -> InstalledModule -> IO ()+removeFromFinderCache (FinderCache ref _) key =   atomicModifyIORef' ref $ \c -> (delInstalledModuleEnv c key, ()) -lookupFinderCache :: IORef FinderCache -> InstalledModule -> IO (Maybe InstalledFindResult)-lookupFinderCache ref key = do+lookupFinderCache :: FinderCache -> InstalledModule -> IO (Maybe InstalledFindResult)+lookupFinderCache (FinderCache ref _) key = do    c <- readIORef ref    return $! lookupInstalledModuleEnv c key +lookupFileCache :: FinderCache -> FilePath -> IO Fingerprint+lookupFileCache (FinderCache _ ref) key = do+   c <- readIORef ref+   case M.lookup key c of+     Nothing -> do+       hash <- getFileHash key+       atomicModifyIORef' ref $ \c -> (M.insert key hash c, ())+       return hash+     Just fp -> return fp+ -- ----------------------------------------------------------------------------- -- The three external entry points + -- | Locate a module that was imported by the user.  We have the -- module's name, and possibly a package name.  Without a package -- name, this function will use the search path and the known exposed -- packages to find the module, if a package is specified then only -- that package is searched for the module. -findImportedModule :: HscEnv -> ModuleName -> Maybe FastString -> IO FindResult-findImportedModule hsc_env mod_name mb_pkg =+findImportedModule :: HscEnv -> ModuleName -> PkgQual -> IO FindResult+findImportedModule hsc_env mod fs =+  let fc        = hsc_FC hsc_env+      mhome_unit = hsc_home_unit_maybe hsc_env+      dflags    = hsc_dflags hsc_env+      fopts     = initFinderOpts dflags+  in do+    findImportedModuleNoHsc fc fopts (hsc_unit_env hsc_env) mhome_unit mod fs++findImportedModuleNoHsc+  :: FinderCache+  -> FinderOpts+  -> UnitEnv+  -> Maybe HomeUnit+  -> ModuleName+  -> PkgQual+  -> IO FindResult+findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg =   case mb_pkg of-        Nothing                        -> unqual_import-        Just pkg | pkg == fsLit "this" -> home_import -- "this" is special-                 | otherwise           -> pkg_import+    NoPkgQual  -> unqual_import+    ThisPkg uid | (homeUnitId <$> mhome_unit) == Just uid -> home_import+                | Just os <- lookup uid other_fopts -> home_pkg_import (uid, os)+                | otherwise -> pprPanic "findImportModule" (ppr mod_name $$ ppr mb_pkg $$ ppr (homeUnitId <$> mhome_unit) $$ ppr uid $$ ppr (map fst all_opts))+    OtherPkg _ -> pkg_import   where-    home_import   = findHomeModule hsc_env mod_name+    all_opts = case mhome_unit of+                Nothing -> other_fopts+                Just home_unit -> (homeUnitId home_unit, fopts) : other_fopts -    pkg_import    = findExposedPackageModule hsc_env mod_name mb_pkg -    unqual_import = home_import+    home_import = case mhome_unit of+                   Just home_unit -> findHomeModule fc fopts home_unit mod_name+                   Nothing -> pure $ NoPackage (panic "findImportedModule: no home-unit")+++    home_pkg_import (uid, opts)+      -- If the module is reexported, then look for it as if it was from the perspective+      -- of that package which reexports it.+      | mod_name `Set.member` finder_reexportedModules opts =+        findImportedModuleNoHsc fc opts ue (Just $ DefiniteHomeUnit uid Nothing) mod_name NoPkgQual+      | mod_name `Set.member` finder_hiddenModules opts =+        return (mkHomeHidden uid)+      | otherwise =+        findHomePackageModule fc opts uid mod_name++    any_home_import = foldr orIfNotFound home_import (map home_pkg_import other_fopts)++    pkg_import    = findExposedPackageModule fc fopts units  mod_name mb_pkg++    unqual_import = any_home_import                     `orIfNotFound`-                    findExposedPackageModule hsc_env mod_name Nothing+                    findExposedPackageModule fc fopts units mod_name NoPkgQual +    units     = case mhome_unit of+                  Nothing -> ue_units ue+                  Just home_unit -> homeUnitEnv_units $ ue_findHomeUnitEnv (homeUnitId home_unit) ue+    hpt_deps :: [UnitId]+    hpt_deps  = homeUnitDepends units+    other_fopts  = map (\uid -> (uid, initFinderOpts (homeUnitEnv_dflags (ue_findHomeUnitEnv uid ue)))) hpt_deps+ -- | Locate a plugin module requested by the user, for a compiler -- plugin.  This consults the same set of exposed packages as -- 'findImportedModule', unless @-hide-all-plugin-packages@ or -- @-plugin-package@ are specified.-findPluginModule :: HscEnv -> ModuleName -> IO FindResult-findPluginModule hsc_env mod_name =-  findHomeModule hsc_env mod_name+findPluginModule :: FinderCache -> FinderOpts -> UnitState -> Maybe HomeUnit -> ModuleName -> IO FindResult+findPluginModule fc fopts units (Just home_unit) mod_name =+  findHomeModule fc fopts home_unit mod_name   `orIfNotFound`-  findExposedPluginPackageModule hsc_env mod_name+  findExposedPluginPackageModule fc fopts units mod_name+findPluginModule fc fopts units Nothing mod_name =+  findExposedPluginPackageModule fc fopts units mod_name  -- | Locate a specific 'Module'.  The purpose of this function is to -- create a 'ModLocation' for a given 'Module', that is to find out@@ -144,12 +213,15 @@ -- reading the interface for a module mentioned by another interface, -- for example (a "system import"). -findExactModule :: HscEnv -> InstalledModule -> IO InstalledFindResult-findExactModule hsc_env mod =-    let home_unit = hsc_home_unit hsc_env-    in if isHomeInstalledModule home_unit mod-       then findInstalledHomeModule hsc_env (moduleName mod)-       else findPackageModule hsc_env mod+findExactModule :: FinderCache -> FinderOpts ->  UnitEnvGraph FinderOpts -> UnitState -> Maybe HomeUnit -> InstalledModule -> IO InstalledFindResult+findExactModule fc fopts other_fopts unit_state mhome_unit mod = do+  case mhome_unit of+    Just home_unit+     | isHomeInstalledModule home_unit mod+        -> findInstalledHomeModule fc fopts (homeUnitId home_unit) (moduleName mod)+     | Just home_fopts <- unitEnv_lookup_maybe (moduleUnit mod) other_fopts+        -> findInstalledHomeModule fc home_fopts (moduleUnit mod) (moduleName mod)+    _ -> findPackageModule fc unit_state fopts mod  -- ----------------------------------------------------------------------------- -- Helpers@@ -184,31 +256,26 @@ -- been done.  Otherwise, do the lookup (with the IO action) and save -- the result in the finder cache and the module location cache (if it -- was successful.)-homeSearchCache :: HscEnv -> ModuleName -> IO InstalledFindResult -> IO InstalledFindResult-homeSearchCache hsc_env mod_name do_this = do-  let home_unit = hsc_home_unit hsc_env-      mod = mkHomeInstalledModule home_unit mod_name-  modLocationCache hsc_env mod do_this+homeSearchCache :: FinderCache -> UnitId -> ModuleName -> IO InstalledFindResult -> IO InstalledFindResult+homeSearchCache fc home_unit mod_name do_this = do+  let mod = mkModule home_unit mod_name+  modLocationCache fc mod do_this -findExposedPackageModule :: HscEnv -> ModuleName -> Maybe FastString-                         -> IO FindResult-findExposedPackageModule hsc_env mod_name mb_pkg-  = findLookupResult hsc_env-  $ lookupModuleWithSuggestions-        (hsc_units hsc_env) mod_name mb_pkg+findExposedPackageModule :: FinderCache -> FinderOpts -> UnitState -> ModuleName -> PkgQual -> IO FindResult+findExposedPackageModule fc fopts units mod_name mb_pkg =+  findLookupResult fc fopts+    $ lookupModuleWithSuggestions units mod_name mb_pkg -findExposedPluginPackageModule :: HscEnv -> ModuleName-                               -> IO FindResult-findExposedPluginPackageModule hsc_env mod_name-  = findLookupResult hsc_env-  $ lookupPluginModuleWithSuggestions-        (hsc_units hsc_env) mod_name Nothing+findExposedPluginPackageModule :: FinderCache -> FinderOpts -> UnitState -> ModuleName -> IO FindResult+findExposedPluginPackageModule fc fopts units mod_name =+  findLookupResult fc fopts+    $ lookupPluginModuleWithSuggestions units mod_name NoPkgQual -findLookupResult :: HscEnv -> LookupResult -> IO FindResult-findLookupResult hsc_env r = case r of+findLookupResult :: FinderCache -> FinderOpts -> LookupResult -> IO FindResult+findLookupResult fc fopts r = case r of      LookupFound m pkg_conf -> do        let im = fst (getModuleInstantiation m)-       r' <- findPackageModule_ hsc_env im (fst pkg_conf)+       r' <- findPackageModule_ fc fopts im (fst pkg_conf)        case r' of         -- TODO: ghc -M is unlikely to do the right thing         -- with just the location of the thing that was@@ -241,7 +308,7 @@                           , fr_suggestions = [] })      LookupNotFound suggest -> do        let suggest'-             | gopt Opt_HelpfulErrors (hsc_dflags hsc_env) = suggest+             | finder_enableSuggestions fopts = suggest              | otherwise = []        return (NotFound{ fr_paths = [], fr_pkg = Nothing                        , fr_pkgs_hidden = []@@ -249,36 +316,40 @@                        , fr_unusables = []                        , fr_suggestions = suggest' }) -modLocationCache :: HscEnv -> InstalledModule -> IO InstalledFindResult -> IO InstalledFindResult-modLocationCache hsc_env mod do_this = do-  m <- lookupFinderCache (hsc_FC hsc_env) mod+modLocationCache :: FinderCache -> InstalledModule -> IO InstalledFindResult -> IO InstalledFindResult+modLocationCache fc mod do_this = do+  m <- lookupFinderCache fc mod   case m of     Just result -> return result     Nothing     -> do         result <- do_this-        addToFinderCache (hsc_FC hsc_env) mod result+        addToFinderCache fc mod result         return result +addModuleToFinder :: FinderCache -> Module -> ModLocation -> IO ()+addModuleToFinder fc mod loc = do+  let imod = toUnitId <$> mod+  addToFinderCache fc imod (InstalledFound loc imod)+ -- This returns a module because it's more convenient for users-addHomeModuleToFinder :: HscEnv -> ModuleName -> ModLocation -> IO Module-addHomeModuleToFinder hsc_env mod_name loc = do-  let home_unit = hsc_home_unit hsc_env-      mod = mkHomeInstalledModule home_unit mod_name-  addToFinderCache (hsc_FC hsc_env) mod (InstalledFound loc mod)+addHomeModuleToFinder :: FinderCache -> HomeUnit -> ModuleName -> ModLocation -> IO Module+addHomeModuleToFinder fc home_unit mod_name loc = do+  let mod = mkHomeInstalledModule home_unit mod_name+  addToFinderCache fc mod (InstalledFound loc mod)   return (mkHomeModule home_unit mod_name) -uncacheModule :: HscEnv -> ModuleName -> IO ()-uncacheModule hsc_env mod_name = do-  let home_unit = hsc_home_unit hsc_env-      mod = mkHomeInstalledModule home_unit mod_name-  removeFromFinderCache (hsc_FC hsc_env) mod+uncacheModule :: FinderCache -> HomeUnit -> ModuleName -> IO ()+uncacheModule fc home_unit mod_name = do+  let mod = mkHomeInstalledModule home_unit mod_name+  removeFromFinderCache fc mod  -- ----------------------------------------------------------------------------- --      The internal workers -findHomeModule :: HscEnv -> ModuleName -> IO FindResult-findHomeModule hsc_env mod_name = do-  r <- findInstalledHomeModule hsc_env mod_name+findHomeModule :: FinderCache -> FinderOpts -> HomeUnit -> ModuleName -> IO FindResult+findHomeModule fc fopts  home_unit mod_name = do+  let uid       = homeUnitAsUnit home_unit+  r <- findInstalledHomeModule fc fopts (homeUnitId home_unit) mod_name   return $ case r of     InstalledFound loc _ -> Found loc (mkHomeModule home_unit mod_name)     InstalledNoPackage _ -> NoPackage uid -- impossible@@ -290,10 +361,33 @@         fr_unusables = [],         fr_suggestions = []       }- where-  home_unit = hsc_home_unit hsc_env-  uid       = homeUnitAsUnit home_unit +mkHomeHidden :: UnitId -> FindResult+mkHomeHidden uid =+  NotFound { fr_paths = []+           , fr_pkg = Just (RealUnit (Definite uid))+           , fr_mods_hidden = [RealUnit (Definite uid)]+           , fr_pkgs_hidden = []+           , fr_unusables = []+           , fr_suggestions = []}++findHomePackageModule :: FinderCache -> FinderOpts -> UnitId -> ModuleName -> IO FindResult+findHomePackageModule fc fopts  home_unit mod_name = do+  let uid       = RealUnit (Definite home_unit)+  r <- findInstalledHomeModule fc fopts home_unit mod_name+  return $ case r of+    InstalledFound loc _ -> Found loc (mkModule uid mod_name)+    InstalledNoPackage _ -> NoPackage uid -- impossible+    InstalledNotFound fps _ -> NotFound {+        fr_paths = fps,+        fr_pkg = Just uid,+        fr_mods_hidden = [],+        fr_pkgs_hidden = [],+        fr_unusables = [],+        fr_suggestions = []+      }++ -- | Implements the search for a module name in the home package only.  Calling -- this function directly is usually *not* what you want; currently, it's used -- as a building block for the following operations:@@ -310,51 +404,64 @@ -- --  4. Some special-case code in GHCi (ToDo: Figure out why that needs to --  call this.)-findInstalledHomeModule :: HscEnv -> ModuleName -> IO InstalledFindResult-findInstalledHomeModule hsc_env mod_name =-   homeSearchCache hsc_env mod_name $+findInstalledHomeModule :: FinderCache -> FinderOpts -> UnitId -> ModuleName -> IO InstalledFindResult+findInstalledHomeModule fc fopts home_unit mod_name = do+  homeSearchCache fc home_unit mod_name $    let-     dflags = hsc_dflags hsc_env-     home_unit = hsc_home_unit hsc_env-     home_path = importPaths dflags-     hisuf = hiSuf dflags-     mod = mkHomeInstalledModule home_unit mod_name+     maybe_working_dir = finder_workingDirectory fopts+     home_path = case maybe_working_dir of+                  Nothing -> finder_importPaths fopts+                  Just fp -> augmentImports fp (finder_importPaths fopts)+     hi_dir_path =+      case finder_hiDir fopts of+        Just hiDir -> case maybe_working_dir of+                        Nothing -> [hiDir]+                        Just fp -> [fp </> hiDir]+        Nothing -> home_path+     hisuf = finder_hiSuf fopts+     mod = mkModule home_unit mod_name       source_exts =-      [ ("hs",   mkHomeModLocationSearched dflags mod_name "hs")-      , ("lhs",  mkHomeModLocationSearched dflags mod_name "lhs")-      , ("hsig",  mkHomeModLocationSearched dflags mod_name "hsig")-      , ("lhsig",  mkHomeModLocationSearched dflags mod_name "lhsig")+      [ ("hs",    mkHomeModLocationSearched fopts mod_name "hs")+      , ("lhs",   mkHomeModLocationSearched fopts mod_name "lhs")+      , ("hsig",  mkHomeModLocationSearched fopts mod_name "hsig")+      , ("lhsig", mkHomeModLocationSearched fopts mod_name "lhsig")       ]       -- we use mkHomeModHiOnlyLocation instead of mkHiOnlyModLocation so that      -- when hiDir field is set in dflags, we know to look there (see #16500)-     hi_exts = [ (hisuf,                mkHomeModHiOnlyLocation dflags mod_name)-               , (addBootSuffix hisuf,  mkHomeModHiOnlyLocation dflags mod_name)+     hi_exts = [ (hisuf,                mkHomeModHiOnlyLocation fopts mod_name)+               , (addBootSuffix hisuf,  mkHomeModHiOnlyLocation fopts mod_name)                ]          -- In compilation manager modes, we look for source files in the home         -- package because we can compile these automatically.  In one-shot         -- compilation mode we look for .hi and .hi-boot files only.-     exts | isOneShot (ghcMode dflags) = hi_exts-          | otherwise                  = source_exts+     (search_dirs, exts)+          | finder_lookupHomeInterfaces fopts = (hi_dir_path, hi_exts)+          | otherwise                         = (home_path, source_exts)    in -  -- special case for GHC.Prim; we won't find it in the filesystem.-  -- This is important only when compiling the base package (where GHC.Prim-  -- is a home module).-  if mod `installedModuleEq` gHC_PRIM-        then return (InstalledFound (error "GHC.Prim ModLocation") mod)-        else searchPathExts home_path mod exts+   -- special case for GHC.Prim; we won't find it in the filesystem.+   -- This is important only when compiling the base package (where GHC.Prim+   -- is a home module).+   if mod `installedModuleEq` gHC_PRIM+         then return (InstalledFound (error "GHC.Prim ModLocation") mod)+         else searchPathExts search_dirs mod exts +-- | Prepend the working directory to the search path.+augmentImports :: FilePath -> [FilePath] -> [FilePath]+augmentImports _work_dir [] = []+augmentImports work_dir (fp:fps) | isAbsolute fp = fp : augmentImports work_dir fps+                                 | otherwise     = (work_dir </> fp) : augmentImports work_dir fps  -- | Search for a module in external packages only.-findPackageModule :: HscEnv -> InstalledModule -> IO InstalledFindResult-findPackageModule hsc_env mod = do+findPackageModule :: FinderCache -> UnitState -> FinderOpts -> InstalledModule -> IO InstalledFindResult+findPackageModule fc unit_state fopts mod = do   let pkg_id = moduleUnit mod-  case lookupUnitId (hsc_units hsc_env) pkg_id of+  case lookupUnitId unit_state pkg_id of      Nothing -> return (InstalledNoPackage pkg_id)-     Just u  -> findPackageModule_ hsc_env mod u+     Just u  -> findPackageModule_ fc fopts mod u  -- | Look up the interface file associated with module @mod@.  This function -- requires a few invariants to be upheld: (1) the 'Module' in question must@@ -363,48 +470,50 @@ -- the 'UnitInfo' must be consistent with the unit id in the 'Module'. -- The redundancy is to avoid an extra lookup in the package state -- for the appropriate config.-findPackageModule_ :: HscEnv -> InstalledModule -> UnitInfo -> IO InstalledFindResult-findPackageModule_ hsc_env mod pkg_conf =-  ASSERT2( moduleUnit mod == unitId pkg_conf, ppr (moduleUnit mod) <+> ppr (unitId pkg_conf) )-  modLocationCache hsc_env mod $+findPackageModule_ :: FinderCache -> FinderOpts -> InstalledModule -> UnitInfo -> IO InstalledFindResult+findPackageModule_ fc fopts mod pkg_conf = do+  massertPpr (moduleUnit mod == unitId pkg_conf)+             (ppr (moduleUnit mod) <+> ppr (unitId pkg_conf))+  modLocationCache fc mod $ -  -- special case for GHC.Prim; we won't find it in the filesystem.-  if mod `installedModuleEq` gHC_PRIM-        then return (InstalledFound (error "GHC.Prim ModLocation") mod)-        else+    -- special case for GHC.Prim; we won't find it in the filesystem.+    if mod `installedModuleEq` gHC_PRIM+          then return (InstalledFound (error "GHC.Prim ModLocation") mod)+          else -  let-     dflags = hsc_dflags hsc_env-     tag = waysBuildTag (ways dflags)+    let+       tag = waysBuildTag (finder_ways fopts) -           -- hi-suffix for packages depends on the build tag.-     package_hisuf | null tag  = "hi"-                   | otherwise = tag ++ "_hi"+             -- hi-suffix for packages depends on the build tag.+       package_hisuf | null tag  = "hi"+                     | otherwise = tag ++ "_hi" -     mk_hi_loc = mkHiOnlyModLocation dflags package_hisuf+       package_dynhisuf = waysBuildTag (addWay WayDyn (finder_ways fopts)) ++ "_hi" -     import_dirs = map ST.unpack $ unitImportDirs pkg_conf-      -- we never look for a .hi-boot file in an external package;-      -- .hi-boot files only make sense for the home package.-  in-  case import_dirs of-    [one] | MkDepend <- ghcMode dflags -> do-          -- there's only one place that this .hi file can be, so-          -- don't bother looking for it.-          let basename = moduleNameSlashes (moduleName mod)-          loc <- mk_hi_loc one basename-          return (InstalledFound loc mod)-    _otherwise ->-          searchPathExts import_dirs mod [(package_hisuf, mk_hi_loc)]+       mk_hi_loc = mkHiOnlyModLocation fopts package_hisuf package_dynhisuf +       import_dirs = map ST.unpack $ unitImportDirs pkg_conf+        -- we never look for a .hi-boot file in an external package;+        -- .hi-boot files only make sense for the home package.+    in+    case import_dirs of+      [one] | finder_bypassHiFileCheck fopts ->+            -- there's only one place that this .hi file can be, so+            -- don't bother looking for it.+            let basename = moduleNameSlashes (moduleName mod)+                loc = mk_hi_loc one basename+            in return $ InstalledFound loc mod+      _otherwise ->+            searchPathExts import_dirs mod [(package_hisuf, mk_hi_loc)]+ -- ----------------------------------------------------------------------------- -- General path searching  searchPathExts :: [FilePath]      -- paths to search                -> InstalledModule -- module name                -> [ (-                     FileExt,                                -- suffix-                     FilePath -> BaseName -> IO ModLocation  -- action+                     FileExt,                             -- suffix+                     FilePath -> BaseName -> ModLocation  -- action                     )                   ]                -> IO InstalledFindResult@@ -413,7 +522,7 @@   where     basename = moduleNameSlashes (moduleName mod) -    to_search :: [(FilePath, IO ModLocation)]+    to_search :: [(FilePath, ModLocation)]     to_search = [ (file, fn path basename)                 | path <- paths,                   (ext,fn) <- exts,@@ -424,17 +533,18 @@      search [] = return (InstalledNotFound (map fst to_search) (Just (moduleUnit mod))) -    search ((file, mk_result) : rest) = do+    search ((file, loc) : rest) = do       b <- doesFileExist file       if b-        then do { loc <- mk_result; return (InstalledFound loc mod) }+        then return $ InstalledFound loc mod         else search rest -mkHomeModLocationSearched :: DynFlags -> ModuleName -> FileExt-                          -> FilePath -> BaseName -> IO ModLocation-mkHomeModLocationSearched dflags mod suff path basename =-  mkHomeModLocation2 dflags mod (path </> basename) suff+mkHomeModLocationSearched :: FinderOpts -> ModuleName -> FileExt+                          -> FilePath -> BaseName -> ModLocation+mkHomeModLocationSearched fopts mod suff path basename =+  mkHomeModLocation2 fopts mod (path </> basename) suff + -- ----------------------------------------------------------------------------- -- Constructing a home module location @@ -468,49 +578,59 @@ -- ext --      The filename extension of the source file (usually "hs" or "lhs"). -mkHomeModLocation :: DynFlags -> ModuleName -> FilePath -> IO ModLocation-mkHomeModLocation dflags mod src_filename = do+mkHomeModLocation :: FinderOpts -> ModuleName -> FilePath -> ModLocation+mkHomeModLocation dflags mod src_filename =    let (basename,extension) = splitExtension src_filename-   mkHomeModLocation2 dflags mod basename extension+   in mkHomeModLocation2 dflags mod basename extension -mkHomeModLocation2 :: DynFlags+mkHomeModLocation2 :: FinderOpts                    -> ModuleName                    -> FilePath  -- Of source module, without suffix                    -> String    -- Suffix-                   -> IO ModLocation-mkHomeModLocation2 dflags mod src_basename ext = do+                   -> ModLocation+mkHomeModLocation2 fopts mod src_basename ext =    let mod_basename = moduleNameSlashes mod -       obj_fn = mkObjPath  dflags src_basename mod_basename-       hi_fn  = mkHiPath   dflags src_basename mod_basename-       hie_fn = mkHiePath  dflags src_basename mod_basename+       obj_fn = mkObjPath  fopts src_basename mod_basename+       dyn_obj_fn = mkDynObjPath  fopts src_basename mod_basename+       hi_fn  = mkHiPath   fopts src_basename mod_basename+       dyn_hi_fn  = mkDynHiPath   fopts src_basename mod_basename+       hie_fn = mkHiePath  fopts src_basename mod_basename -   return (ModLocation{ ml_hs_file   = Just (src_basename <.> ext),+   in (ModLocation{ ml_hs_file   = Just (src_basename <.> ext),                         ml_hi_file   = hi_fn,+                        ml_dyn_hi_file = dyn_hi_fn,                         ml_obj_file  = obj_fn,+                        ml_dyn_obj_file = dyn_obj_fn,                         ml_hie_file  = hie_fn }) -mkHomeModHiOnlyLocation :: DynFlags+mkHomeModHiOnlyLocation :: FinderOpts                         -> ModuleName                         -> FilePath                         -> BaseName-                        -> IO ModLocation-mkHomeModHiOnlyLocation dflags mod path basename = do-   loc <- mkHomeModLocation2 dflags mod (path </> basename) ""-   return loc { ml_hs_file = Nothing }+                        -> ModLocation+mkHomeModHiOnlyLocation fopts mod path basename =+   let loc = mkHomeModLocation2 fopts mod (path </> basename) ""+   in loc { ml_hs_file = Nothing } -mkHiOnlyModLocation :: DynFlags -> Suffix -> FilePath -> String-                    -> IO ModLocation-mkHiOnlyModLocation dflags hisuf path basename- = do let full_basename = path </> basename-          obj_fn = mkObjPath  dflags full_basename basename-          hie_fn = mkHiePath  dflags full_basename basename-      return ModLocation{    ml_hs_file   = Nothing,+-- This function is used to make a ModLocation for a package module. Hence why+-- we explicitly pass in the interface file suffixes.+mkHiOnlyModLocation :: FinderOpts -> Suffix -> Suffix -> FilePath -> String+                    -> ModLocation+mkHiOnlyModLocation fopts hisuf dynhisuf path basename+ = let full_basename = path </> basename+       obj_fn = mkObjPath fopts full_basename basename+       dyn_obj_fn = mkDynObjPath fopts full_basename basename+       hie_fn = mkHiePath fopts full_basename basename+   in ModLocation{    ml_hs_file   = Nothing,                              ml_hi_file   = full_basename <.> hisuf,                                 -- Remove the .hi-boot suffix from                                 -- hi_file, if it had one.  We always                                 -- want the name of the real .hi file                                 -- in the ml_hi_file field.+                             ml_dyn_obj_file = dyn_obj_fn,+                             -- MP: TODO+                             ml_dyn_hi_file  = full_basename <.> dynhisuf,                              ml_obj_file  = obj_fn,                              ml_hie_file  = hie_fn                   }@@ -518,45 +638,75 @@ -- | Constructs the filename of a .o file for a given source file. -- Does /not/ check whether the .o file exists mkObjPath-  :: DynFlags+  :: FinderOpts   -> FilePath           -- the filename of the source file, minus the extension   -> String             -- the module name with dots replaced by slashes   -> FilePath-mkObjPath dflags basename mod_basename = obj_basename <.> osuf+mkObjPath fopts basename mod_basename = obj_basename <.> osuf   where-                odir = objectDir dflags-                osuf = objectSuf dflags+                odir = finder_objectDir fopts+                osuf = finder_objectSuf fopts                  obj_basename | Just dir <- odir = dir </> mod_basename                              | otherwise        = basename +-- | Constructs the filename of a .dyn_o file for a given source file.+-- Does /not/ check whether the .dyn_o file exists+mkDynObjPath+  :: FinderOpts+  -> FilePath           -- the filename of the source file, minus the extension+  -> String             -- the module name with dots replaced by slashes+  -> FilePath+mkDynObjPath fopts basename mod_basename = obj_basename <.> dynosuf+  where+                odir = finder_objectDir fopts+                dynosuf = finder_dynObjectSuf fopts +                obj_basename | Just dir <- odir = dir </> mod_basename+                             | otherwise        = basename++ -- | Constructs the filename of a .hi file for a given source file. -- Does /not/ check whether the .hi file exists mkHiPath-  :: DynFlags+  :: FinderOpts   -> FilePath           -- the filename of the source file, minus the extension   -> String             -- the module name with dots replaced by slashes   -> FilePath-mkHiPath dflags basename mod_basename = hi_basename <.> hisuf+mkHiPath fopts basename mod_basename = hi_basename <.> hisuf  where-                hidir = hiDir dflags-                hisuf = hiSuf dflags+                hidir = finder_hiDir fopts+                hisuf = finder_hiSuf fopts                  hi_basename | Just dir <- hidir = dir </> mod_basename                             | otherwise         = basename +-- | Constructs the filename of a .dyn_hi file for a given source file.+-- Does /not/ check whether the .dyn_hi file exists+mkDynHiPath+  :: FinderOpts+  -> FilePath           -- the filename of the source file, minus the extension+  -> String             -- the module name with dots replaced by slashes+  -> FilePath+mkDynHiPath fopts basename mod_basename = hi_basename <.> dynhisuf+ where+                hidir = finder_hiDir fopts+                dynhisuf = finder_dynHiSuf fopts++                hi_basename | Just dir <- hidir = dir </> mod_basename+                            | otherwise         = basename+ -- | Constructs the filename of a .hie file for a given source file. -- Does /not/ check whether the .hie file exists mkHiePath-  :: DynFlags+  :: FinderOpts   -> FilePath           -- the filename of the source file, minus the extension   -> String             -- the module name with dots replaced by slashes   -> FilePath-mkHiePath dflags basename mod_basename = hie_basename <.> hiesuf+mkHiePath fopts basename mod_basename = hie_basename <.> hiesuf  where-                hiedir = hieDir dflags-                hiesuf = hieSuf dflags+                hiedir = finder_hieDir fopts+                hiesuf = finder_hieSuf fopts                  hie_basename | Just dir <- hiedir = dir </> mod_basename                              | otherwise          = basename@@ -570,14 +720,14 @@ -- from other available information, and they're only rarely needed.  mkStubPaths-  :: DynFlags+  :: FinderOpts   -> ModuleName   -> ModLocation   -> FilePath -mkStubPaths dflags mod location+mkStubPaths fopts mod location   = let-        stubdir = stubDir dflags+        stubdir = finder_stubDir fopts          mod_basename = moduleNameSlashes mod         src_basename = dropExtension $ expectJust "mkStubPaths"
GHC/Unit/Finder/Types.hs view
@@ -1,20 +1,32 @@ module GHC.Unit.Finder.Types-   ( FinderCache+   ( FinderCache (..)+   , FinderCacheState    , FindResult (..)    , InstalledFindResult (..)+   , FinderOpts(..)    ) where  import GHC.Prelude import GHC.Unit-import GHC.Unit.State+import qualified Data.Map as M+import GHC.Fingerprint+import GHC.Platform.Ways +import Data.IORef+import GHC.Data.FastString+import qualified Data.Set as Set+ -- | The 'FinderCache' maps modules to the result of -- searching for that module. It records the results of searching for -- modules along the search path. On @:load@, we flush the entire -- contents of this cache. ---type FinderCache = InstalledModuleEnv InstalledFindResult+type FinderCacheState = InstalledModuleEnv InstalledFindResult+type FileCacheState   = M.Map FilePath Fingerprint+data FinderCache = FinderCache { fcModuleCache :: (IORef FinderCacheState)+                               , fcFileCache   :: (IORef FileCacheState)+                               }  data InstalledFindResult   = InstalledFound ModLocation InstalledModule@@ -54,3 +66,39 @@       , fr_suggestions :: [ModuleSuggestion] -- ^ Possible mis-spelled modules       } +-- | Locations and information the finder cares about.+--+-- Should be taken from 'DynFlags' via 'initFinderOpts'.+data FinderOpts = FinderOpts+  { finder_importPaths :: [FilePath]+      -- ^ Where are we allowed to look for Modules and Source files+  , finder_lookupHomeInterfaces :: Bool+      -- ^ When looking up a home module:+      --+      --    * 'True':  search interface files (e.g. in '-c' mode)+      --    * 'False': search source files (e.g. in '--make' mode)++  , finder_bypassHiFileCheck :: Bool+      -- ^ Don't check that an imported interface file actually exists+      -- if it can only be at one location. The interface will be reported+      -- as `InstalledFound` even if the file doesn't exist, so this is+      -- only useful in specific cases (e.g. to generate dependencies+      -- with `ghc -M`)+  , finder_ways :: Ways+  , finder_enableSuggestions :: Bool+      -- ^ If we encounter unknown modules, should we suggest modules+      -- that have a similar name.+  , finder_workingDirectory :: Maybe FilePath+  , finder_thisPackageName  :: Maybe FastString+  , finder_hiddenModules    :: Set.Set ModuleName+  , finder_reexportedModules :: Set.Set ModuleName+  , finder_hieDir :: Maybe FilePath+  , finder_hieSuf :: String+  , finder_hiDir :: Maybe FilePath+  , finder_hiSuf :: String+  , finder_dynHiSuf :: String+  , finder_objectDir :: Maybe FilePath+  , finder_objectSuf :: String+  , finder_dynObjectSuf :: String+  , finder_stubDir :: Maybe FilePath+  } deriving Show
GHC/Unit/Home.hs view
@@ -18,6 +18,7 @@    , isHomeUnitInstanceOf    , isHomeModule    , isHomeInstalledModule+   , notHomeUnitId    , notHomeModule    , notHomeModuleMaybe    , notHomeInstalledModule@@ -103,7 +104,7 @@ --    produce any code object that rely on the unit id of this virtual unit. homeUnitAsUnit :: HomeUnit -> Unit homeUnitAsUnit (DefiniteHomeUnit u _)    = RealUnit (Definite u)-homeUnitAsUnit (IndefiniteHomeUnit u is) = mkVirtUnit (Indefinite u) is+homeUnitAsUnit (IndefiniteHomeUnit u is) = mkVirtUnit u is  -- | Map over the unit identifier for instantiating units homeUnitMap :: IsUnitId v => (u -> v) -> GenHomeUnit u -> GenHomeUnit v@@ -142,6 +143,11 @@ isHomeUnitId :: GenHomeUnit u -> UnitId -> Bool isHomeUnitId hu uid = uid == homeUnitId hu +-- | Test if the unit-id is not the home unit-id+notHomeUnitId :: Maybe (GenHomeUnit u) -> UnitId -> Bool+notHomeUnitId Nothing   _   = True+notHomeUnitId (Just hu) uid = not (isHomeUnitId hu uid)+ -- | Test if the home unit is an instance of the given unit-id isHomeUnitInstanceOf :: HomeUnit -> UnitId -> Bool isHomeUnitInstanceOf hu u = homeUnitInstanceOf hu == u@@ -204,8 +210,9 @@ --       the instantiating module of @r:A@ in @p[A=q[]:B]@ is @r:A@. --       the instantiating module of @p:A@ in @p@ is @p:A@. --       the instantiating module of @r:A@ in @p@ is @r:A@.-homeModuleInstantiation :: HomeUnit -> Module -> Module-homeModuleInstantiation hu mod-   | isHomeModule hu mod = homeModuleNameInstantiation hu (moduleName mod)+homeModuleInstantiation :: Maybe HomeUnit -> Module -> Module+homeModuleInstantiation mhu mod+   | Just hu <- mhu+   , isHomeModule hu mod = homeModuleNameInstantiation hu (moduleName mod)    | otherwise           = mod
GHC/Unit/Home/ModInfo.hs view
@@ -11,10 +11,12 @@    , mapHpt    , delFromHpt    , addToHpt+   , addHomeModInfoToHpt    , addListToHpt    , lookupHptDirectly    , lookupHptByModule    , listToHpt+   , listHMIToHpt    , pprHPT    ) where@@ -31,6 +33,8 @@ import GHC.Types.Unique.DFM  import GHC.Utils.Outputable+import Data.List (sortOn)+import Data.Ord  -- | Information about modules in the package being compiled data HomeModInfo = HomeModInfo@@ -99,6 +103,9 @@ addToHpt :: HomePackageTable -> ModuleName -> HomeModInfo -> HomePackageTable addToHpt = addToUDFM +addHomeModInfoToHpt :: HomeModInfo -> HomePackageTable -> HomePackageTable+addHomeModInfoToHpt hmi hpt = addToHpt hpt (moduleName (mi_module (hm_iface hmi))) hmi+ addListToHpt   :: HomePackageTable -> [(ModuleName, HomeModInfo)] -> HomePackageTable addListToHpt = addListToUDFM@@ -106,6 +113,14 @@ listToHpt :: [(ModuleName, HomeModInfo)] -> HomePackageTable listToHpt = listToUDFM +listHMIToHpt :: [HomeModInfo] -> HomePackageTable+listHMIToHpt hmis =+  listToHpt [(moduleName (mi_module (hm_iface hmi)), hmi) | hmi <- sorted_hmis]+  where+    -- Sort to put Non-boot things last, so they overwrite the boot interfaces+    -- in the HPT, other than that, the order doesn't matter+    sorted_hmis = sortOn (Down . mi_boot . hm_iface) hmis+ lookupHptByModule :: HomePackageTable -> Module -> Maybe HomeModInfo -- The HPT is indexed by ModuleName, not Module, -- we must check for a hit on the right Module@@ -117,7 +132,6 @@ pprHPT :: HomePackageTable -> SDoc -- A bit arbitrary for now pprHPT hpt = pprUDFM hpt $ \hms ->-    vcat [ hang (ppr (mi_module (hm_iface hm)))-              2 (ppr (md_types (hm_details hm)))+    vcat [ ppr (mi_module (hm_iface hm))          | hm <- hms ]
GHC/Unit/Info.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, RecordWildCards, FlexibleInstances, MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards, FlexibleInstances, MultiParamTypeClasses #-}  -- | Info about installed units (compiled libraries) module GHC.Unit.Info@@ -29,8 +29,6 @@    ) where -#include "HsVersions.h"- import GHC.Prelude import GHC.Platform.Ways @@ -52,7 +50,6 @@ import Data.Version import Data.Bifunctor import Data.List (isPrefixOf, stripPrefix)-import qualified Data.Set as Set   -- | Information about an installed unit@@ -62,8 +59,8 @@ --    * UnitId: identifier used to generate code (cf 'UnitInfo') -- -- These two identifiers are different for wired-in packages. See Note [About--- Units] in "GHC.Unit"-type GenUnitInfo unit = GenericUnitInfo (Indefinite unit) PackageId PackageName unit ModuleName (GenModule (GenUnit unit))+-- units] in "GHC.Unit"+type GenUnitInfo unit = GenericUnitInfo PackageId PackageName unit ModuleName (GenModule (GenUnit unit))  -- | Information about an installed unit (units are identified by their database -- UnitKey)@@ -77,7 +74,6 @@ mkUnitKeyInfo :: DbUnitInfo -> UnitKeyInfo mkUnitKeyInfo = mapGenericUnitInfo    mkUnitKey'-   mkIndefUnitKey'    mkPackageIdentifier'    mkPackageName'    mkModuleName'@@ -87,9 +83,8 @@      mkPackageName'       = PackageName    . mkFastStringByteString      mkUnitKey'           = UnitKey        . mkFastStringByteString      mkModuleName'        = mkModuleNameFS . mkFastStringByteString-     mkIndefUnitKey' cid  = Indefinite (mkUnitKey' cid)      mkVirtUnitKey' i = case i of-      DbInstUnitId cid insts -> mkVirtUnit (mkIndefUnitKey' cid) (fmap (bimap mkModuleName' mkModule') insts)+      DbInstUnitId cid insts -> mkVirtUnit (mkUnitKey' cid) (fmap (bimap mkModuleName' mkModule') insts)       DbUnitId uid           -> RealUnit (Definite (mkUnitKey' uid))      mkModule' m = case m of        DbModule uid n -> mkModule (mkVirtUnitKey' uid) (mkModuleName' n)@@ -99,7 +94,6 @@ mapUnitInfo :: IsUnitId v => (u -> v) -> GenUnitInfo u -> GenUnitInfo v mapUnitInfo f = mapGenericUnitInfo    f         -- unit identifier-   (fmap f)  -- indefinite unit identifier    id        -- package identifier    id        -- package name    id        -- module name@@ -207,24 +201,18 @@ -- | Either the 'unitLibraryDirs' or 'unitLibraryDynDirs' as appropriate for the way. libraryDirsForWay :: Ways -> UnitInfo -> [String] libraryDirsForWay ws-  | WayDyn `elem` ws = map ST.unpack . unitLibraryDynDirs+  | hasWay ws WayDyn = map ST.unpack . unitLibraryDynDirs   | otherwise        = map ST.unpack . unitLibraryDirs  unitHsLibs :: GhcNameVersion -> Ways -> UnitInfo -> [String] unitHsLibs namever ways0 p = map (mkDynName . addSuffix . ST.unpack) (unitLibraries p)   where-        ways1 = Set.filter (/= WayDyn) ways0+        ways1 = removeWay WayDyn ways0         -- the name of a shared library is libHSfoo-ghc<version>.so         -- we leave out the _dyn, because it is superfluous -        -- debug and profiled RTSs include support for -eventlog-        ways2 | WayDebug `Set.member` ways1 || WayProf `Set.member` ways1-              = Set.filter (/= WayTracing) ways1-              | otherwise-              = ways1--        tag     = waysTag (fullWays ways2)-        rts_tag = waysTag ways2+        tag     = waysTag (fullWays ways1)+        rts_tag = waysTag ways1          mkDynName x          | not (ways0 `hasWay` WayDyn) = x
GHC/Unit/Module.hs view
@@ -106,9 +106,9 @@  -- | Return the unit-id this unit is an instance of and the module instantiations (if any). getUnitInstantiations :: Unit -> (UnitId, Maybe InstantiatedUnit)-getUnitInstantiations (VirtUnit iuid)           = (indefUnit (instUnitInstanceOf iuid), Just iuid)+getUnitInstantiations (VirtUnit iuid)           = (instUnitInstanceOf iuid, Just iuid) getUnitInstantiations (RealUnit (Definite uid)) = (uid, Nothing)-getUnitInstantiations HoleUnit                  = error "Hole unit"+getUnitInstantiations (HoleUnit {})             = error "Hole unit"  -- | Remove instantiations of the given instantiated unit uninstantiateInstantiatedUnit :: InstantiatedUnit -> InstantiatedUnit
GHC/Unit/Module/Deps.hs view
@@ -1,8 +1,21 @@ -- | Dependencies and Usage of a module module GHC.Unit.Module.Deps-   ( Dependencies (..)-   , Usage (..)+   ( Dependencies+   , mkDependencies    , noDependencies+   , dep_direct_mods+   , dep_direct_pkgs+   , dep_sig_mods+   , dep_trusted_pkgs+   , dep_orphs+   , dep_plugin_pkgs+   , dep_finsts+   , dep_boot_mods+   , dep_orphs_update+   , dep_finsts_update+   , pprDeps+   , Usage (..)+   , ImportAvails (..)    ) where @@ -10,32 +23,64 @@  import GHC.Types.SafeHaskell import GHC.Types.Name+ import GHC.Unit.Module.Name+import GHC.Unit.Module.Imported import GHC.Unit.Module+import GHC.Unit.Home+import GHC.Unit.State  import GHC.Utils.Fingerprint import GHC.Utils.Binary+import GHC.Utils.Outputable +import Data.List (sortBy, sort, partition)+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Bifunctor+ -- | Dependency information about ALL modules and packages below this one--- in the import hierarchy.+-- in the import hierarchy. This is the serialisable version of `ImportAvails`. -- -- Invariant: the dependencies of a module @M@ never includes @M@. -- -- Invariant: none of the lists contain duplicates.+--+-- Invariant: lists are ordered canonically (e.g. using stableModuleCmp)+--+-- See Note [Transitive Information in Dependencies] data Dependencies = Deps-   { dep_mods   :: [ModuleNameWithIsBoot]-      -- ^ All home-package modules transitively below this one-      -- I.e. modules that this one imports, or that are in the-      --      dep_mods of those directly-imported modules+   { dep_direct_mods :: Set (UnitId, ModuleNameWithIsBoot)+      -- ^ All home-package modules which are directly imported by this one.+      -- This may include modules from other units when using multiple home units -   , dep_pkgs   :: [(UnitId, Bool)]-      -- ^ All packages transitively below this module-      -- I.e. packages to which this module's direct imports belong,-      --      or that are in the dep_pkgs of those modules-      -- The bool indicates if the package is required to be-      -- trusted when the module is imported as a safe import+   , dep_direct_pkgs :: Set UnitId+      -- ^ All packages directly imported by this module+      -- I.e. packages to which this module's direct imports belong.+      -- Does not include other home units when using multiple home units.+      -- Modules from these units will go in `dep_direct_mods`++   , dep_plugin_pkgs :: Set UnitId+      -- ^ All units needed for plugins++    ------------------------------------+    -- Transitive information below here++   , dep_sig_mods :: ![ModuleName]+    -- ^ Transitive closure of hsig files in the home package+++   , dep_trusted_pkgs :: Set UnitId+      -- Packages which we are required to trust+      -- when the module is imported as a safe import       -- (Safe Haskell). See Note [Tracking Trust Transitively] in GHC.Rename.Names +   , dep_boot_mods :: Set (UnitId, ModuleNameWithIsBoot)+      -- ^ All modules which have boot files below this one, and whether we+      -- should use the boot file or not.+      -- This information is only used to populate the eps_is_boot field.+      -- See Note [Structure of dep_boot_mods]+    , dep_orphs  :: [Module]       -- ^ Transitive closure of orphan modules (whether       -- home or external pkg).@@ -53,31 +98,144 @@       -- does NOT include us, unlike 'imp_finsts'. See Note       -- [The type family instance consistency story]. -   , dep_plgins :: [ModuleName]-      -- ^ All the plugins used while compiling this module.    }    deriving( Eq )         -- Equality used only for old/new comparison in GHC.Iface.Recomp.addFingerprints         -- See 'GHC.Tc.Utils.ImportAvails' for details on dependencies. ++-- | Extract information from the rename and typecheck phases to produce+-- a dependencies information for the module being compiled.+--+-- The fourth argument is a list of plugin modules.+mkDependencies :: HomeUnit -> Module -> ImportAvails -> [Module] -> Dependencies+mkDependencies home_unit mod imports plugin_mods =+  let (home_plugins, external_plugins) = partition (isHomeUnit home_unit . moduleUnit) plugin_mods+      plugin_units = Set.fromList (map (toUnitId . moduleUnit) external_plugins)+      all_direct_mods = foldr (\mn m -> extendInstalledModuleEnv m mn (GWIB (moduleName mn) NotBoot))+                              (imp_direct_dep_mods imports)+                              (map (fmap toUnitId) home_plugins)++      modDepsElts = Set.fromList . installedModuleEnvElts+        -- It's OK to use nonDetEltsUFM here because sorting by module names+        -- restores determinism++      direct_mods = first moduleUnit `Set.map` modDepsElts (delInstalledModuleEnv all_direct_mods (toUnitId <$> mod))+            -- M.hi-boot can be in the imp_dep_mods, but we must remove+            -- it before recording the modules on which this one depends!+            -- (We want to retain M.hi-boot in imp_dep_mods so that+            --  loadHiBootInterface can see if M's direct imports depend+            --  on M.hi-boot, and hence that we should do the hi-boot consistency+            --  check.)++      dep_orphs = filter (/= mod) (imp_orphs imports)+            -- We must also remove self-references from imp_orphs. See+            -- Note [Module self-dependency]++      direct_pkgs = imp_dep_direct_pkgs imports++      -- Set the packages required to be Safe according to Safe Haskell.+      -- See Note [Tracking Trust Transitively] in GHC.Rename.Names+      trust_pkgs  = imp_trust_pkgs imports++      -- If there's a non-boot import, then it shadows the boot import+      -- coming from the dependencies+      source_mods = first moduleUnit `Set.map` modDepsElts (imp_boot_mods imports)++      sig_mods = filter (/= (moduleName mod)) $ imp_sig_mods imports++  in Deps { dep_direct_mods  = direct_mods+          , dep_direct_pkgs  = direct_pkgs+          , dep_plugin_pkgs  = plugin_units+          , dep_sig_mods     = sort sig_mods+          , dep_trusted_pkgs = trust_pkgs+          , dep_boot_mods    = source_mods+          , dep_orphs        = sortBy stableModuleCmp dep_orphs+          , dep_finsts       = sortBy stableModuleCmp (imp_finsts imports)+            -- sort to get into canonical order+            -- NB. remember to use lexicographic ordering+          }++-- | Update module dependencies containing orphans (used by Backpack)+dep_orphs_update :: Monad m => Dependencies -> ([Module] -> m [Module]) -> m Dependencies+dep_orphs_update deps f = do+  r <- f (dep_orphs deps)+  pure (deps { dep_orphs = sortBy stableModuleCmp r })++-- | Update module dependencies containing family instances (used by Backpack)+dep_finsts_update :: Monad m => Dependencies -> ([Module] -> m [Module]) -> m Dependencies+dep_finsts_update deps f = do+  r <- f (dep_finsts deps)+  pure (deps { dep_finsts = sortBy stableModuleCmp r })++ instance Binary Dependencies where-    put_ bh deps = do put_ bh (dep_mods deps)-                      put_ bh (dep_pkgs deps)+    put_ bh deps = do put_ bh (dep_direct_mods deps)+                      put_ bh (dep_direct_pkgs deps)+                      put_ bh (dep_plugin_pkgs deps)+                      put_ bh (dep_trusted_pkgs deps)+                      put_ bh (dep_sig_mods deps)+                      put_ bh (dep_boot_mods deps)                       put_ bh (dep_orphs deps)                       put_ bh (dep_finsts deps)-                      put_ bh (dep_plgins deps) -    get bh = do ms <- get bh-                ps <- get bh+    get bh = do dms <- get bh+                dps <- get bh+                plugin_pkgs <- get bh+                tps <- get bh+                hsigms <- get bh+                sms <- get bh                 os <- get bh                 fis <- get bh-                pl <- get bh-                return (Deps { dep_mods = ms, dep_pkgs = ps, dep_orphs = os,-                               dep_finsts = fis, dep_plgins = pl })+                return (Deps { dep_direct_mods = dms+                             , dep_direct_pkgs = dps+                             , dep_plugin_pkgs = plugin_pkgs+                             , dep_sig_mods = hsigms+                             , dep_boot_mods = sms+                             , dep_trusted_pkgs = tps+                             , dep_orphs = os,+                               dep_finsts = fis })  noDependencies :: Dependencies-noDependencies = Deps [] [] [] [] []+noDependencies = Deps+  { dep_direct_mods  = Set.empty+  , dep_direct_pkgs  = Set.empty+  , dep_plugin_pkgs  = Set.empty+  , dep_sig_mods     = []+  , dep_boot_mods    = Set.empty+  , dep_trusted_pkgs = Set.empty+  , dep_orphs        = []+  , dep_finsts       = []+  } +-- | Pretty-print unit dependencies+pprDeps :: UnitState -> Dependencies -> SDoc+pprDeps unit_state (Deps { dep_direct_mods = dmods+                         , dep_boot_mods = bmods+                         , dep_plugin_pkgs = plgns+                         , dep_orphs = orphs+                         , dep_direct_pkgs = pkgs+                         , dep_trusted_pkgs = tps+                         , dep_finsts = finsts+                         })+  = pprWithUnitState unit_state $+    vcat [text "direct module dependencies:"  <+> ppr_set ppr_mod dmods,+          text "boot module dependencies:"    <+> ppr_set ppr bmods,+          text "direct package dependencies:" <+> ppr_set ppr pkgs,+          text "plugin package dependencies:" <+> ppr_set ppr plgns,+          if null tps+            then empty+            else text "trusted package dependencies:" <+> ppr_set ppr tps,+          text "orphans:" <+> fsep (map ppr orphs),+          text "family instance modules:" <+> fsep (map ppr finsts)+        ]+  where+    ppr_mod (uid, (GWIB mod IsBoot))  = ppr uid <> colon <> ppr mod <+> text "[boot]"+    ppr_mod (uid, (GWIB mod NotBoot)) = ppr uid <> colon <> ppr mod++    ppr_set :: Outputable a => (a -> SDoc) -> Set a -> SDoc+    ppr_set w = fsep . fmap w . Set.toAscList+ -- | Records modules for which changes may force recompilation of this module -- See wiki: https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance --@@ -90,7 +248,7 @@         usg_mod      :: Module,            -- ^ External package module depended on         usg_mod_hash :: Fingerprint,-            -- ^ Cached module fingerprint+            -- ^ Cached module ABI fingerprint (corresponds to mi_mod_hash)         usg_safe :: IsSafeImport             -- ^ Was this module imported as a safe import     }@@ -99,7 +257,10 @@         usg_mod_name :: ModuleName,             -- ^ Name of the module         usg_mod_hash :: Fingerprint,-            -- ^ Cached module fingerprint+            -- ^ Cached module ABI fingerprint (corresponds to mi_mod_hash).+            -- This may be out dated after recompilation was avoided, but is+            -- still used as a fast initial check for change during+            -- recompilation avoidance.         usg_entities :: [(OccName,Fingerprint)],             -- ^ Entities we depend on, sorted by occurrence name and fingerprinted.             -- NB: usages are for parent names only, e.g. type constructors@@ -109,21 +270,38 @@             -- if we directly imported it (and hence we depend on its export list)         usg_safe :: IsSafeImport             -- ^ Was this module imported as a safe import-    }                                           -- ^ Module from the current package+    }   -- | A file upon which the module depends, e.g. a CPP #include, or using TH's   -- 'addDependentFile'   | UsageFile {         usg_file_path  :: FilePath,         -- ^ External file dependency. From a CPP #include or TH         -- addDependentFile. Should be absolute.-        usg_file_hash  :: Fingerprint+        usg_file_hash  :: Fingerprint,         -- ^ 'Fingerprint' of the file contents. +        usg_file_label :: Maybe String+        -- ^ An optional string which is used in recompilation messages if+        -- file in question has changed.+         -- Note: We don't consider things like modification timestamps         -- here, because there's no reason to recompile if the actual         -- contents don't change.  This previously lead to odd         -- recompilation behaviors; see #8114   }+  | UsageHomeModuleInterface {+        usg_mod_name :: ModuleName+        -- ^ Name of the module+        , usg_iface_hash :: Fingerprint+        -- ^ The *interface* hash of the module, not the ABI hash.+        -- This changes when anything about the interface (and hence the+        -- module) has changed.++        -- UsageHomeModuleInterface is *only* used for recompilation+        -- checking when using TemplateHaskell in the interpreter (where+        -- some modules are loaded as BCOs).++  }   -- | A requirement which was merged into this one.   | UsageMergedRequirement {         usg_mod :: Module,@@ -162,12 +340,18 @@         putByte bh 2         put_ bh (usg_file_path usg)         put_ bh (usg_file_hash usg)+        put_ bh (usg_file_label usg)      put_ bh usg@UsageMergedRequirement{} = do         putByte bh 3         put_ bh (usg_mod      usg)         put_ bh (usg_mod_hash usg) +    put_ bh usg@UsageHomeModuleInterface{} = do+        putByte bh 4+        put_ bh (usg_mod_name usg)+        put_ bh (usg_iface_hash usg)+     get bh = do         h <- getByte bh         case h of@@ -187,9 +371,150 @@           2 -> do             fp   <- get bh             hash <- get bh-            return UsageFile { usg_file_path = fp, usg_file_hash = hash }+            label <- get bh+            return UsageFile { usg_file_path = fp, usg_file_hash = hash, usg_file_label = label }           3 -> do             mod <- get bh             hash <- get bh             return UsageMergedRequirement { usg_mod = mod, usg_mod_hash = hash }+          4 -> do+            mod <- get bh+            hash <- get bh+            return UsageHomeModuleInterface { usg_mod_name = mod, usg_iface_hash = hash }           i -> error ("Binary.get(Usage): " ++ show i)+++{-+Note [Transitive Information in Dependencies]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++It is important to be careful what information we put in 'Dependencies' because+ultimately it ends up serialised in an interface file. Interface files must always+be kept up-to-date with the state of the world, so if `Dependencies` needs to be updated+then the module had to be recompiled just to update `Dependencies`.++Before #16885, the dependencies used to contain the transitive closure of all+home modules. Therefore, if you added an import somewhere low down in the home package+it would recompile nearly every module in your project, just to update this information.++Now, we are a bit more careful about what we store and+explicitly store transitive information only if it is really needed.++~ Direct Information++* dep_direct_mods - Directly imported home package modules+* dep_direct_pkgs - Directly imported packages+* dep_plgins      - Directly used plugins++~ Transitive Information++Some features of the compiler require transitive information about what is currently+being compiled, so that is explicitly stored separately in the form they need.++* dep_trusted_pkgs - Only used for the -fpackage-trust feature+* dep_boot_mods  - Only used to populate eps_is_boot in -c mode+* dep_orphs        - Modules with orphan instances+* dep_finsts       - Modules with type family instances++Important note: If you add some transitive information to the interface file then+you need to make sure recompilation is triggered when it could be out of date.+The correct way to do this is to include the transitive information in the export+hash of the module. The export hash is computed in `GHC.Iface.Recomp.addFingerprints`.+-}++{-+Note [Structure of dep_boot_deps]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++In `-c` mode we always need to know whether to load the normal or boot version of+an interface file, and this can't be determined from just looking at the direct imports.++Consider modules with dependencies:++```+A -(S)-> B+A -> C -> B -(S)-> B+```++Say when compiling module `A` that we need to load the interface for `B`, do we load+`B.hi` or `B.hi-boot`? Well, `A` does directly {-# SOURCE #-} import B, so you might think+that we would load the `B.hi-boot` file, however this is wrong because `C` imports+`B` normally. Therefore in the interface file for `C` we still need to record that+there is a hs-boot file for `B` below it but that we now want `B.hi` rather than+`B.hi-boot`. When `C` is imported, the fact that it needs `B.hi` clobbers the `{- SOURCE -}`+import for `B`.++Therefore in mod_boot_deps we store the names of any modules which have hs-boot files,+and whether we want to import the .hi or .hi-boot version of the interface file.++If you get this wrong, then GHC fails to compile, so there is a test but you might+not make it that far if you get this wrong!++Question: does this happen even across packages?+No: if I need to load the interface for module X from package P I always look for p:X.hi.++-}++-- | 'ImportAvails' summarises what was imported from where, irrespective of+-- whether the imported things are actually used or not.  It is used:+--+--  * when processing the export list,+--+--  * when constructing usage info for the interface file,+--+--  * to identify the list of directly imported modules for initialisation+--    purposes and for optimised overlap checking of family instances,+--+--  * when figuring out what things are really unused+--+data ImportAvails+   = ImportAvails {+        imp_mods :: ImportedMods,+          --      = ModuleEnv [ImportedModsVal],+          -- ^ Domain is all directly-imported modules+          --+          -- See the documentation on ImportedModsVal in+          -- "GHC.Unit.Module.Imported" for the meaning of the fields.+          --+          -- We need a full ModuleEnv rather than a ModuleNameEnv here,+          -- because we might be importing modules of the same name from+          -- different packages. (currently not the case, but might be in the+          -- future).++        imp_direct_dep_mods :: InstalledModuleEnv ModuleNameWithIsBoot,+          -- ^ Home-package modules directly imported by the module being compiled.++        imp_dep_direct_pkgs :: Set UnitId,+          -- ^ Packages directly needed by the module being compiled++        imp_trust_own_pkg :: Bool,+          -- ^ Do we require that our own package is trusted?+          -- This is to handle efficiently the case where a Safe module imports+          -- a Trustworthy module that resides in the same package as it.+          -- See Note [Trust Own Package] in "GHC.Rename.Names"++        -- Transitive information below here++        imp_trust_pkgs :: Set UnitId,+          -- ^ This records the+          -- packages the current module needs to trust for Safe Haskell+          -- compilation to succeed. A package is required to be trusted if+          -- we are dependent on a trustworthy module in that package.+          -- See Note [Tracking Trust Transitively] in "GHC.Rename.Names"++        imp_boot_mods :: InstalledModuleEnv ModuleNameWithIsBoot,+          -- ^ Domain is all modules which have hs-boot files, and whether+          -- we should import the boot version of interface file. Only used+          -- in one-shot mode to populate eps_is_boot.++        imp_sig_mods :: [ModuleName],+          -- ^ Signature modules below this one++        imp_orphs :: [Module],+          -- ^ Orphan modules below us in the import tree (and maybe including+          -- us for imported modules)++        imp_finsts :: [Module]+          -- ^ Family instance modules below us in the import tree (and maybe+          -- including us for imported modules)+      }
GHC/Unit/Module/Env.hs view
@@ -6,6 +6,7 @@    , extendModuleEnvList_C, plusModuleEnv_C    , delModuleEnvList, delModuleEnv, plusModuleEnv, lookupModuleEnv    , lookupWithDefaultModuleEnv, mapModuleEnv, mkModuleEnv, emptyModuleEnv+   , partitionModuleEnv    , moduleEnvKeys, moduleEnvElts, moduleEnvToList    , unitModuleEnv, isEmptyModuleEnv    , extendModuleEnvWith, filterModuleEnv@@ -18,7 +19,8 @@    , emptyModuleSet, mkModuleSet, moduleSetElts    , extendModuleSet, extendModuleSetList, delModuleSet    , elemModuleSet, intersectModuleSet, minusModuleSet, unionModuleSet-   , unitModuleSet+   , unitModuleSet, isEmptyModuleSet+   , unionManyModuleSets       -- * InstalledModuleEnv    , InstalledModuleEnv@@ -27,6 +29,9 @@    , extendInstalledModuleEnv    , filterInstalledModuleEnv    , delInstalledModuleEnv+   , mergeInstalledModuleEnv+   , plusInstalledModuleEnv+   , installedModuleEnvElts    ) where @@ -47,10 +52,14 @@ import qualified Data.Map as Map import qualified Data.Set as Set import qualified GHC.Data.FiniteMap as Map+import GHC.Utils.Outputable  -- | A map keyed off of 'Module's newtype ModuleEnv elt = ModuleEnv (Map NDModule elt) +instance Outputable a => Outputable (ModuleEnv a) where+  ppr (ModuleEnv m) = ppr m+ {- Note [ModuleEnv performance and determinism] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -71,6 +80,9 @@   deriving Eq   -- A wrapper for Module with faster nondeterministic Ord.   -- Don't export, See [ModuleEnv performance and determinism]+  --+instance Outputable NDModule where+  ppr (NDModule a) = ppr a  instance Ord NDModule where   compare (NDModule (Module p1 n1)) (NDModule (Module p2 n2)) =@@ -125,6 +137,11 @@ mapModuleEnv :: (a -> b) -> ModuleEnv a -> ModuleEnv b mapModuleEnv f (ModuleEnv e) = ModuleEnv (Map.mapWithKey (\_ v -> f v) e) +partitionModuleEnv :: (a -> Bool) -> ModuleEnv a -> (ModuleEnv a, ModuleEnv a)+partitionModuleEnv f (ModuleEnv e) = (ModuleEnv a, ModuleEnv b)+  where+    (a,b) = Map.partition f e+ mkModuleEnv :: [(Module, a)] -> ModuleEnv a mkModuleEnv xs = ModuleEnv (Map.fromList [(NDModule k, v) | (k,v) <- xs]) @@ -165,6 +182,9 @@ emptyModuleSet :: ModuleSet emptyModuleSet = Set.empty +isEmptyModuleSet :: ModuleSet -> Bool+isEmptyModuleSet = Set.null+ moduleSetElts :: ModuleSet -> [Module] moduleSetElts = sort . coerce . Set.toList @@ -183,6 +203,9 @@ unionModuleSet :: ModuleSet -> ModuleSet -> ModuleSet unionModuleSet = coerce Set.union +unionManyModuleSets :: [ModuleSet] -> ModuleSet+unionManyModuleSets = coerce (Set.unions :: [Set NDModule] -> Set NDModule)+ unitModuleSet :: Module -> ModuleSet unitModuleSet = coerce Set.singleton @@ -207,6 +230,10 @@ -- | A map keyed off of 'InstalledModule' newtype InstalledModuleEnv elt = InstalledModuleEnv (Map InstalledModule elt) +instance Outputable elt => Outputable (InstalledModuleEnv elt) where+  ppr (InstalledModuleEnv env) = ppr env++ emptyInstalledModuleEnv :: InstalledModuleEnv a emptyInstalledModuleEnv = InstalledModuleEnv Map.empty @@ -222,4 +249,28 @@  delInstalledModuleEnv :: InstalledModuleEnv a -> InstalledModule -> InstalledModuleEnv a delInstalledModuleEnv (InstalledModuleEnv e) m = InstalledModuleEnv (Map.delete m e)++installedModuleEnvElts :: InstalledModuleEnv a -> [(InstalledModule, a)]+installedModuleEnvElts (InstalledModuleEnv e) = Map.assocs e++mergeInstalledModuleEnv+  :: (elta -> eltb -> Maybe eltc)+  -> (InstalledModuleEnv elta -> InstalledModuleEnv eltc)  -- map X+  -> (InstalledModuleEnv eltb -> InstalledModuleEnv eltc) -- map Y+  -> InstalledModuleEnv elta+  -> InstalledModuleEnv eltb+  -> InstalledModuleEnv eltc+mergeInstalledModuleEnv f g h (InstalledModuleEnv xm) (InstalledModuleEnv ym)+  = InstalledModuleEnv $ Map.mergeWithKey+      (\_ x y -> (x `f` y))+      (coerce g)+      (coerce h)+      xm ym++plusInstalledModuleEnv :: (elt -> elt -> elt)+  -> InstalledModuleEnv elt+  -> InstalledModuleEnv elt+  -> InstalledModuleEnv elt+plusInstalledModuleEnv f (InstalledModuleEnv xm) (InstalledModuleEnv ym) =+  InstalledModuleEnv $ Map.unionWith f xm ym
GHC/Unit/Module/Graph.hs view
@@ -1,26 +1,42 @@ {-# LANGUAGE LambdaCase      #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE DeriveTraversable #-}  module GHC.Unit.Module.Graph    ( ModuleGraph    , ModuleGraphNode(..)+   , nodeDependencies    , emptyMG    , mkModuleGraph-   , mkModuleGraph'    , extendMG    , extendMGInst    , extendMG'+   , unionMG+   , isTemplateHaskellOrQQNonBoot    , filterToposortToModules    , mapMG    , mgModSummaries    , mgModSummaries'-   , mgExtendedModSummaries-   , mgElemModule    , mgLookupModule-   , mgBootModules-   , needsTemplateHaskellOrQQ-   , isTemplateHaskellOrQQNonBoot+   , mgTransDeps    , showModMsg+   , moduleGraphNodeModule+   , moduleGraphNodeModSum++   , moduleGraphNodes+   , SummaryNode+   , summaryNodeSummary++   , NodeKey(..)+   , nodeKeyUnitId+   , ModNodeKey+   , mkNodeKey+   , msKey+++   , moduleGraphNodeUnitId++   , ModNodeKeyWithUid(..)    ) where @@ -29,7 +45,7 @@ import qualified GHC.LanguageExtensions as LangExt  import GHC.Data.Maybe-import GHC.Data.Graph.Directed ( SCC(..) )+import GHC.Data.Graph.Directed  import GHC.Driver.Backend import GHC.Driver.Ppr@@ -38,27 +54,84 @@ import GHC.Types.SourceFile ( hscSourceString )  import GHC.Unit.Module.ModSummary-import GHC.Unit.Module.Env import GHC.Unit.Types import GHC.Utils.Outputable  import System.FilePath+import qualified Data.Map as Map+import GHC.Types.Unique.DSet+import qualified Data.Set as Set+import GHC.Unit.Module+import GHC.Linker.Static.Utils +import Data.Bifunctor+import Data.Either+import Data.Function+import GHC.Data.List.SetOps+ -- | A '@ModuleGraphNode@' is a node in the '@ModuleGraph@'. -- Edges between nodes mark dependencies arising from module imports -- and dependencies arising from backpack instantiations. data ModuleGraphNode   -- | Instantiation nodes track the instantiation of other units   -- (backpack dependencies) with the holes (signatures) of the current package.-  = InstantiationNode InstantiatedUnit+  = InstantiationNode UnitId InstantiatedUnit   -- | There is a module summary node for each module, signature, and boot module being built.-  | ModuleNode ExtendedModSummary+  | ModuleNode [NodeKey] ModSummary+  -- | Link nodes are whether are are creating a linked product (ie executable/shared object etc) for a unit.+  | LinkNode [NodeKey] UnitId +moduleGraphNodeModule :: ModuleGraphNode -> Maybe ModuleName+moduleGraphNodeModule mgn = ms_mod_name <$> (moduleGraphNodeModSum mgn)++moduleGraphNodeModSum :: ModuleGraphNode -> Maybe ModSummary+moduleGraphNodeModSum (InstantiationNode {}) = Nothing+moduleGraphNodeModSum (LinkNode {})          = Nothing+moduleGraphNodeModSum (ModuleNode _ ms)      = Just ms++moduleGraphNodeUnitId :: ModuleGraphNode -> UnitId+moduleGraphNodeUnitId mgn =+  case mgn of+    InstantiationNode uid _iud -> uid+    ModuleNode _ ms           -> toUnitId (moduleUnit (ms_mod ms))+    LinkNode _ uid             -> uid+ instance Outputable ModuleGraphNode where   ppr = \case-    InstantiationNode iuid -> ppr iuid-    ModuleNode ems -> ppr ems+    InstantiationNode _ iuid -> ppr iuid+    ModuleNode nks ms -> ppr (ms_mnwib ms) <+> ppr nks+    LinkNode uid _     -> text "LN:" <+> ppr uid +instance Eq ModuleGraphNode where+  (==) = (==) `on` mkNodeKey++instance Ord ModuleGraphNode where+  compare = compare `on` mkNodeKey++data NodeKey = NodeKey_Unit {-# UNPACK #-} !InstantiatedUnit+             | NodeKey_Module {-# UNPACK #-} !ModNodeKeyWithUid+             | NodeKey_Link !UnitId+  deriving (Eq, Ord)++instance Outputable NodeKey where+  ppr nk = pprNodeKey nk++pprNodeKey :: NodeKey -> SDoc+pprNodeKey (NodeKey_Unit iu) = ppr iu+pprNodeKey (NodeKey_Module mk) = ppr mk+pprNodeKey (NodeKey_Link uid)  = ppr uid++nodeKeyUnitId :: NodeKey -> UnitId+nodeKeyUnitId (NodeKey_Unit iu)   = instUnitInstanceOf iu+nodeKeyUnitId (NodeKey_Module mk) = mnkUnitId mk+nodeKeyUnitId (NodeKey_Link uid)  = uid++data ModNodeKeyWithUid = ModNodeKeyWithUid { mnkModuleName :: ModuleNameWithIsBoot+                                           , mnkUnitId     :: UnitId } deriving (Eq, Ord)++instance Outputable ModNodeKeyWithUid where+  ppr (ModNodeKeyWithUid mnwib uid) = ppr uid <> colon <> ppr mnwib+ -- | A '@ModuleGraph@' contains all the nodes from the home package (only). See -- '@ModuleGraphNode@' for information about the nodes. --@@ -72,55 +145,53 @@ -- 'GHC.topSortModuleGraph' and 'GHC.Data.Graph.Directed.flattenSCC' to achieve this. data ModuleGraph = ModuleGraph   { mg_mss :: [ModuleGraphNode]-  , mg_non_boot :: !(ModuleEnv ModSummary)-    -- a map of all non-boot ModSummaries keyed by Modules-  , mg_boot :: !ModuleSet-    -- a set of boot Modules-  , mg_needs_th_or_qq :: !Bool-    -- does any of the modules in mg_mss require TemplateHaskell or-    -- QuasiQuotes?+  , mg_trans_deps :: Map.Map NodeKey (Set.Set NodeKey)+    -- A cached transitive dependency calculation so that a lot of work is not+    -- repeated whenever the transitive dependencies need to be calculated (for example, hptInstances)   } --- | Determines whether a set of modules requires Template Haskell or--- Quasi Quotes------ Note that if the session's 'DynFlags' enabled Template Haskell when--- 'depanal' was called, then each module in the returned module graph will--- have Template Haskell enabled whether it is actually needed or not.-needsTemplateHaskellOrQQ :: ModuleGraph -> Bool-needsTemplateHaskellOrQQ mg = mg_needs_th_or_qq mg- -- | Map a function 'f' over all the 'ModSummaries'. -- To preserve invariants 'f' can't change the isBoot status. mapMG :: (ModSummary -> ModSummary) -> ModuleGraph -> ModuleGraph mapMG f mg@ModuleGraph{..} = mg   { mg_mss = flip fmap mg_mss $ \case-      InstantiationNode iuid -> InstantiationNode iuid-      ModuleNode (ExtendedModSummary ms bds) -> ModuleNode (ExtendedModSummary (f ms) bds)-  , mg_non_boot = mapModuleEnv f mg_non_boot+      InstantiationNode uid iuid -> InstantiationNode uid iuid+      LinkNode uid nks -> LinkNode uid nks+      ModuleNode deps ms  -> ModuleNode deps (f ms)   } -mgBootModules :: ModuleGraph -> ModuleSet-mgBootModules ModuleGraph{..} = mg_boot+unionMG :: ModuleGraph -> ModuleGraph -> ModuleGraph+unionMG a b =+  let new_mss = nubOrdBy compare $ mg_mss a `mappend` mg_mss b+  in ModuleGraph {+        mg_mss = new_mss+      , mg_trans_deps = mkTransDeps new_mss+      } -mgModSummaries :: ModuleGraph -> [ModSummary]-mgModSummaries mg = [ m | ModuleNode (ExtendedModSummary m _) <- mgModSummaries' mg ] -mgExtendedModSummaries :: ModuleGraph -> [ExtendedModSummary]-mgExtendedModSummaries mg = [ ems | ModuleNode ems <- mgModSummaries' mg ]+mgTransDeps :: ModuleGraph -> Map.Map NodeKey (Set.Set NodeKey)+mgTransDeps = mg_trans_deps +mgModSummaries :: ModuleGraph -> [ModSummary]+mgModSummaries mg = [ m | ModuleNode _ m <- mgModSummaries' mg ]+ mgModSummaries' :: ModuleGraph -> [ModuleGraphNode] mgModSummaries' = mg_mss -mgElemModule :: ModuleGraph -> Module -> Bool-mgElemModule ModuleGraph{..} m = elemModuleEnv m mg_non_boot- -- | Look up a ModSummary in the ModuleGraph+-- Looks up the non-boot ModSummary+-- Linear in the size of the module graph mgLookupModule :: ModuleGraph -> Module -> Maybe ModSummary-mgLookupModule ModuleGraph{..} m = lookupModuleEnv mg_non_boot m+mgLookupModule ModuleGraph{..} m = listToMaybe $ mapMaybe go mg_mss+  where+    go (ModuleNode _ ms)+      | NotBoot <- isBootSummary ms+      , ms_mod ms == m+      = Just ms+    go _ = Nothing  emptyMG :: ModuleGraph-emptyMG = ModuleGraph [] emptyModuleEnv emptyModuleSet False+emptyMG = ModuleGraph [] Map.empty  isTemplateHaskellOrQQNonBoot :: ModSummary -> Bool isTemplateHaskellOrQQNonBoot ms =@@ -130,33 +201,33 @@  -- | Add an ExtendedModSummary to ModuleGraph. Assumes that the new ModSummary is -- not an element of the ModuleGraph.-extendMG :: ModuleGraph -> ExtendedModSummary -> ModuleGraph-extendMG ModuleGraph{..} ems@(ExtendedModSummary ms _) = ModuleGraph-  { mg_mss = ModuleNode ems : mg_mss-  , mg_non_boot = case isBootSummary ms of-      IsBoot -> mg_non_boot-      NotBoot -> extendModuleEnv mg_non_boot (ms_mod ms) ms-  , mg_boot = case isBootSummary ms of-      NotBoot -> mg_boot-      IsBoot -> extendModuleSet mg_boot (ms_mod ms)-  , mg_needs_th_or_qq = mg_needs_th_or_qq || isTemplateHaskellOrQQNonBoot ms+extendMG :: ModuleGraph -> [NodeKey] -> ModSummary -> ModuleGraph+extendMG ModuleGraph{..} deps ms = ModuleGraph+  { mg_mss = ModuleNode deps ms : mg_mss+  , mg_trans_deps = mkTransDeps (ModuleNode deps ms : mg_mss)   } -extendMGInst :: ModuleGraph -> InstantiatedUnit -> ModuleGraph-extendMGInst mg depUnitId = mg-  { mg_mss = InstantiationNode depUnitId : mg_mss mg+mkTransDeps :: [ModuleGraphNode] -> Map.Map NodeKey (Set.Set NodeKey)+mkTransDeps mss =+  let (gg, _lookup_node) = moduleGraphNodes False mss+  in allReachable gg (mkNodeKey . node_payload)++extendMGInst :: ModuleGraph -> UnitId -> InstantiatedUnit -> ModuleGraph+extendMGInst mg uid depUnitId = mg+  { mg_mss = InstantiationNode uid depUnitId : mg_mss mg   } +extendMGLink :: ModuleGraph -> UnitId -> [NodeKey] -> ModuleGraph+extendMGLink mg uid nks = mg { mg_mss = LinkNode nks uid : mg_mss mg }+ extendMG' :: ModuleGraph -> ModuleGraphNode -> ModuleGraph extendMG' mg = \case-  InstantiationNode depUnitId -> extendMGInst mg depUnitId-  ModuleNode ems -> extendMG mg ems--mkModuleGraph :: [ExtendedModSummary] -> ModuleGraph-mkModuleGraph = foldr (flip extendMG) emptyMG+  InstantiationNode uid depUnitId -> extendMGInst mg uid depUnitId+  ModuleNode deps ms -> extendMG mg deps ms+  LinkNode deps uid   -> extendMGLink mg uid deps -mkModuleGraph' :: [ModuleGraphNode] -> ModuleGraph-mkModuleGraph' = foldr (flip extendMG') emptyMG+mkModuleGraph :: [ModuleGraphNode] -> ModuleGraph+mkModuleGraph = foldr (flip extendMG') emptyMG  -- | This function filters out all the instantiation nodes from each SCC of a -- topological sort. Use this with care, as the resulting "strongly connected components"@@ -165,8 +236,9 @@ filterToposortToModules   :: [SCC ModuleGraphNode] -> [SCC ModSummary] filterToposortToModules = mapMaybe $ mapMaybeSCC $ \case-  InstantiationNode _ -> Nothing-  ModuleNode (ExtendedModSummary node _) -> Just node+  InstantiationNode _ _ -> Nothing+  LinkNode{} -> Nothing+  ModuleNode _deps node -> Just node   where     -- This higher order function is somewhat bogus,     -- as the definition of "strongly connected component"@@ -180,29 +252,131 @@         as -> Just $ CyclicSCC as  showModMsg :: DynFlags -> Bool -> ModuleGraphNode -> SDoc-showModMsg _ _ (InstantiationNode indef_unit) =+showModMsg dflags _ (LinkNode {}) =+      let staticLink = case ghcLink dflags of+                          LinkStaticLib -> True+                          _ -> False++          platform  = targetPlatform dflags+          exe_file  = exeFileName platform staticLink (outputFile_ dflags)+      in text exe_file+showModMsg _ _ (InstantiationNode _uid indef_unit) =   ppr $ instUnitInstanceOf indef_unit-showModMsg dflags recomp (ModuleNode (ExtendedModSummary mod_summary _)) =+showModMsg dflags recomp (ModuleNode _ mod_summary) =   if gopt Opt_HideSourcePaths dflags       then text mod_str       else hsep $          [ text (mod_str ++ replicate (max 0 (16 - length mod_str)) ' ')          , char '('          , text (op $ msHsFilePath mod_summary) <> char ','-         ] ++-         if gopt Opt_BuildDynamicToo dflags-            then [ text obj_file <> char ','-                 , text dyn_file-                 , char ')'-                 ]-            else [ text obj_file, char ')' ]+         , message, char ')' ]+   where     op       = normalise     mod      = moduleName (ms_mod mod_summary)     mod_str  = showPpr dflags mod ++ hscSourceString (ms_hsc_src mod_summary)-    dyn_file = op $ msDynObjFilePath mod_summary dflags-    obj_file = case backend dflags of-                Interpreter | recomp -> "interpreted"-                NoBackend            -> "nothing"-                _                    -> (op $ msObjFilePath mod_summary)+    dyn_file = op $ msDynObjFilePath mod_summary+    obj_file = op $ msObjFilePath mod_summary+    message = case backend dflags of+                Interpreter | recomp -> text "interpreted"+                NoBackend            -> text "nothing"+                _                    ->+                  if gopt Opt_BuildDynamicToo  dflags+                    then text obj_file <> comma <+> text dyn_file+                    else text obj_file++++type SummaryNode = Node Int ModuleGraphNode++summaryNodeKey :: SummaryNode -> Int+summaryNodeKey = node_key++summaryNodeSummary :: SummaryNode -> ModuleGraphNode+summaryNodeSummary = node_payload++-- | Collect the immediate dependencies of a ModuleGraphNode,+-- optionally avoiding hs-boot dependencies.+-- If the drop_hs_boot_nodes flag is False, and if this is a .hs and there is+-- an equivalent .hs-boot, add a link from the former to the latter.  This+-- has the effect of detecting bogus cases where the .hs-boot depends on the+-- .hs, by introducing a cycle.  Additionally, it ensures that we will always+-- process the .hs-boot before the .hs, and so the HomePackageTable will always+-- have the most up to date information.+nodeDependencies :: Bool -> ModuleGraphNode -> [NodeKey]+nodeDependencies drop_hs_boot_nodes = \case+    LinkNode deps _uid -> deps+    InstantiationNode uid iuid ->+      NodeKey_Module . (\mod -> ModNodeKeyWithUid (GWIB mod NotBoot) uid)  <$> uniqDSetToList (instUnitHoles iuid)+    ModuleNode deps _ms ->+      map drop_hs_boot deps+  where+    -- Drop hs-boot nodes by using HsSrcFile as the key+    hs_boot_key | drop_hs_boot_nodes = NotBoot -- is regular mod or signature+                | otherwise          = IsBoot++    drop_hs_boot (NodeKey_Module (ModNodeKeyWithUid (GWIB mn IsBoot) uid)) = (NodeKey_Module (ModNodeKeyWithUid (GWIB mn hs_boot_key) uid))+    drop_hs_boot x = x++-- | Turn a list of graph nodes into an efficient queriable graph.+-- The first boolean parameter indicates whether nodes corresponding to hs-boot files+-- should be collapsed into their relevant hs nodes.+moduleGraphNodes :: Bool+  -> [ModuleGraphNode]+  -> (Graph SummaryNode, NodeKey -> Maybe SummaryNode)+moduleGraphNodes drop_hs_boot_nodes summaries =+  (graphFromEdgedVerticesUniq nodes, lookup_node)+  where+    -- Map from module to extra boot summary dependencies which need to be merged in+    (boot_summaries, nodes) = bimap Map.fromList id $ partitionEithers (map go numbered_summaries)++      where+        go (s, key) =+          case s of+                ModuleNode __deps ms | isBootSummary ms == IsBoot, drop_hs_boot_nodes+                  -- Using nodeDependencies here converts dependencies on other+                  -- boot files to dependencies on dependencies on non-boot files.+                  -> Left (ms_mod ms, nodeDependencies drop_hs_boot_nodes s)+                _ -> normal_case+          where+           normal_case =+              let lkup_key = ms_mod <$> moduleGraphNodeModSum s+                  extra = (lkup_key >>= \key -> Map.lookup key boot_summaries)++              in Right $ DigraphNode s key $ out_edge_keys $+                      (fromMaybe [] extra+                        ++ nodeDependencies drop_hs_boot_nodes s)++    numbered_summaries = zip summaries [1..]++    lookup_node :: NodeKey -> Maybe SummaryNode+    lookup_node key = Map.lookup key (unNodeMap node_map)++    lookup_key :: NodeKey -> Maybe Int+    lookup_key = fmap summaryNodeKey . lookup_node++    node_map :: NodeMap SummaryNode+    node_map = NodeMap $+      Map.fromList [ (mkNodeKey s, node)+                   | node <- nodes+                   , let s = summaryNodeSummary node+                   ]++    out_edge_keys :: [NodeKey] -> [Int]+    out_edge_keys = mapMaybe lookup_key+        -- If we want keep_hi_boot_nodes, then we do lookup_key with+        -- IsBoot; else False+newtype NodeMap a = NodeMap { unNodeMap :: Map.Map NodeKey a }+  deriving (Functor, Traversable, Foldable)++mkNodeKey :: ModuleGraphNode -> NodeKey+mkNodeKey = \case+  InstantiationNode _ iu -> NodeKey_Unit iu+  ModuleNode _ x -> NodeKey_Module $ msKey x+  LinkNode _ uid   -> NodeKey_Link uid++msKey :: ModSummary -> ModNodeKeyWithUid+msKey ms = ModNodeKeyWithUid (ms_mnwib ms) (ms_unitid ms)++type ModNodeKey = ModuleNameWithIsBoot
GHC/Unit/Module/Location.hs view
@@ -3,6 +3,7 @@    ( ModLocation(..)    , addBootSuffix    , addBootSuffix_maybe+   , addBootSuffixLocn_maybe    , addBootSuffixLocn    , addBootSuffixLocnOut    , removeBootSuffix@@ -16,7 +17,7 @@ -- | Module Location -- -- Where a module lives on the file system: the actual locations--- of the .hs, .hi and .o files, if we have them.+-- of the .hs, .hi, .dyn_hi, .o, .dyn_o and .hie files, if we have them. -- -- For a module in another unit, the ml_hs_file and ml_obj_file components of -- ModLocation are undefined.@@ -25,6 +26,16 @@ -- correspond to actual files yet: for example, even if the object -- file doesn't exist, the ModLocation still contains the path to -- where the object file will reside if/when it is created.+--+-- The paths of anything which can affect recompilation should be placed inside+-- ModLocation.+--+-- When a ModLocation is created none of the filepaths will have -boot suffixes.+-- This is because in --make mode the ModLocation is put in the finder cache which+-- is indexed by ModuleName, when a ModLocation is retrieved from the FinderCache+-- the boot suffixes are appended.+-- The other case is in -c mode, there the ModLocation immediately gets given the+-- boot suffixes in mkOneShotModLocation.  data ModLocation    = ModLocation {@@ -37,12 +48,20 @@                 -- yet.  Always of form foo.hi, even if there is an                 -- hi-boot file (we add the -boot suffix later) +        ml_dyn_hi_file :: FilePath,+                -- ^ Where the .dyn_hi file is, whether or not it exists+                -- yet.+         ml_obj_file  :: FilePath,                 -- ^ Where the .o file is, whether or not it exists yet.                 -- (might not exist either because the module hasn't                 -- been compiled yet, or because it is part of a                 -- unit with a .a file) +        ml_dyn_obj_file :: FilePath,+                -- ^ Where the .dy file is, whether or not it exists+                -- yet.+         ml_hie_file  :: FilePath                 -- ^ Where the .hie file is, whether or not it exists                 -- yet.@@ -68,12 +87,19 @@   IsBoot -> addBootSuffix path   NotBoot -> path +addBootSuffixLocn_maybe :: IsBootInterface -> ModLocation -> ModLocation+addBootSuffixLocn_maybe is_boot locn = case is_boot of+  IsBoot -> addBootSuffixLocn locn+  _ -> locn+ -- | Add the @-boot@ suffix to all file paths associated with the module addBootSuffixLocn :: ModLocation -> ModLocation addBootSuffixLocn locn   = locn { ml_hs_file  = fmap addBootSuffix (ml_hs_file locn)          , ml_hi_file  = addBootSuffix (ml_hi_file locn)+         , ml_dyn_hi_file = addBootSuffix (ml_dyn_hi_file locn)          , ml_obj_file = addBootSuffix (ml_obj_file locn)+         , ml_dyn_obj_file = addBootSuffix (ml_dyn_obj_file locn)          , ml_hie_file = addBootSuffix (ml_hie_file locn) }  -- | Add the @-boot@ suffix to all output file paths associated with the@@ -81,7 +107,10 @@ addBootSuffixLocnOut :: ModLocation -> ModLocation addBootSuffixLocnOut locn   = locn { ml_hi_file  = addBootSuffix (ml_hi_file locn)+         , ml_dyn_hi_file = addBootSuffix (ml_dyn_hi_file locn)          , ml_obj_file = addBootSuffix (ml_obj_file locn)-         , ml_hie_file = addBootSuffix (ml_hie_file locn) }+         , ml_dyn_obj_file = addBootSuffix (ml_dyn_obj_file locn)+         , ml_hie_file = addBootSuffix (ml_hie_file locn)+         }
GHC/Unit/Module/ModDetails.hs view
@@ -6,7 +6,7 @@  import GHC.Core         ( CoreRule ) import GHC.Core.FamInstEnv-import GHC.Core.InstEnv ( ClsInst )+import GHC.Core.InstEnv ( InstEnv, emptyInstEnv )  import GHC.Types.Avail import GHC.Types.CompleteMatch@@ -23,7 +23,7 @@       -- ^ Local type environment for this particular module       -- Includes Ids, TyCons, PatSyns -   , md_insts     :: ![ClsInst]+   , md_insts     :: InstEnv       -- ^ 'DFunId's for the instances in this module     , md_fam_insts :: ![FamInst]@@ -43,7 +43,7 @@ emptyModDetails = ModDetails    { md_types            = emptyTypeEnv    , md_exports          = []-   , md_insts            = []+   , md_insts            = emptyInstEnv    , md_rules            = []    , md_fam_insts        = []    , md_anns             = []
GHC/Unit/Module/ModGuts.hs view
@@ -1,5 +1,6 @@ module GHC.Unit.Module.ModGuts    ( ModGuts (..)+   , mg_mnwib    , CgGuts (..)    ) where@@ -30,11 +31,15 @@ import GHC.Types.ForeignStubs import GHC.Types.HpcInfo import GHC.Types.Name.Reader+import GHC.Types.Name.Set (NameSet) import GHC.Types.SafeHaskell-import GHC.Types.SourceFile ( HscSource(..) )+import GHC.Types.SourceFile ( HscSource(..), hscSourceToIsBoot ) import GHC.Types.SrcLoc+import GHC.Types.CostCentre +import Data.Set (Set) + -- | A ModGuts is carried through the compiler, accumulating stuff as it goes -- There is only one ModGuts at any time, the one for the module -- being compiled right now.  Once it is compiled, a 'ModIface' and@@ -67,7 +72,7 @@         mg_foreign   :: !ForeignStubs,   -- ^ Foreign exports declared in this module         mg_foreign_files :: ![(ForeignSrcLang, FilePath)],         -- ^ Files to be compiled with the C compiler-        mg_warns     :: !Warnings,       -- ^ Warnings declared in the module+        mg_warns     :: !(Warnings GhcRn),  -- ^ Warnings declared in the module         mg_anns      :: [Annotation],    -- ^ Annotations declared in this module         mg_complete_matches :: [CompleteMatch], -- ^ Complete Matches         mg_hpc_info  :: !HpcInfo,        -- ^ Coverage tick boxes in the module@@ -84,6 +89,7 @@         mg_fam_inst_env :: FamInstEnv,          -- ^ Type-family instance environment for                                                 -- /home-package/ modules (including this                                                 -- one); c.f. 'tcg_fam_inst_env'+        mg_boot_exports :: !NameSet,             -- Things that are also export via hs-boot file          mg_safe_haskell :: SafeHaskellMode,     -- ^ Safe Haskell mode         mg_trust_pkg    :: Bool,                -- ^ Do we need to trust our@@ -91,11 +97,12 @@                                                 -- See Note [Trust Own Package]                                                 -- in "GHC.Rename.Names" -        mg_doc_hdr       :: !(Maybe HsDocString), -- ^ Module header.-        mg_decl_docs     :: !DeclDocMap,     -- ^ Docs on declarations.-        mg_arg_docs      :: !ArgDocMap       -- ^ Docs on arguments.+        mg_docs         :: !(Maybe Docs)       -- ^ Documentation.     } +mg_mnwib :: ModGuts -> ModuleNameWithIsBoot+mg_mnwib mg = GWIB (moduleName (mg_module mg)) (hscSourceToIsBoot (mg_hsc_src mg))+ -- The ModGuts takes on several slightly different forms: -- -- After simplification, the following fields change slightly:@@ -127,9 +134,10 @@                 -- data constructor workers; reason: we regard them                 -- as part of the code-gen of tycons +        cg_ccs       :: [CostCentre], -- List of cost centres used in bindings and rules         cg_foreign   :: !ForeignStubs,   -- ^ Foreign export stubs         cg_foreign_files :: ![(ForeignSrcLang, FilePath)],-        cg_dep_pkgs  :: ![UnitId], -- ^ Dependent packages, used to+        cg_dep_pkgs  :: !(Set UnitId),      -- ^ Dependent packages, used to                                             -- generate #includes for C code gen         cg_hpc_info  :: !HpcInfo,           -- ^ Program coverage tick box information         cg_modBreaks :: !(Maybe ModBreaks), -- ^ Module breakpoints
GHC/Unit/Module/ModIface.hs view
@@ -18,11 +18,13 @@    , mi_fix    , mi_semantic_module    , mi_free_holes+   , mi_mnwib    , renameFreeHoles    , emptyPartialModIface    , emptyFullModIface    , mkIfaceHashCache    , emptyIfaceHashCache+   , forceModIface    ) where @@ -54,6 +56,7 @@ import GHC.Utils.Binary  import Control.DeepSeq+import Control.Exception  {- Note [Interface file stages]    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -106,7 +109,7 @@     -- other fields and are not put into the interface file.     -- Not really produced by the backend but there is no need to create them     -- any earlier.-  , mi_warn_fn :: !(OccName -> Maybe WarningTxt)+  , mi_warn_fn :: !(OccName -> Maybe (WarningTxt GhcRn))     -- ^ Cached lookup for 'mi_warns'   , mi_fix_fn :: !(OccName -> Maybe Fixity)     -- ^ Cached lookup for 'mi_fixities'@@ -144,6 +147,9 @@ -- except that we explicitly make the 'mi_decls' and a few other fields empty; -- as when reading we consolidate the declarations etc. into a number of indexed -- maps and environments in the 'ExternalPackageState'.+--+-- See Note [Strictness in ModIface] to learn about why some fields are+-- strict and others are not. data ModIface_ (phase :: ModIfacePhase)   = ModIface {         mi_module     :: !Module,             -- ^ Name of the module we are for@@ -178,7 +184,7 @@                 -- ^ Fixities                 -- NOT STRICT!  we read this field lazily from the interface file -        mi_warns    :: Warnings,+        mi_warns    :: (Warnings GhcRn),                 -- ^ Warnings                 -- NOT STRICT!  we read this field lazily from the interface file @@ -227,30 +233,54 @@                 -- itself) but imports some trustworthy modules from its own                 -- package (which does require its own package be trusted).                 -- See Note [Trust Own Package] in GHC.Rename.Names-        mi_complete_matches :: [IfaceCompleteMatch],--        mi_doc_hdr :: Maybe HsDocString,-                -- ^ Module header.--        mi_decl_docs :: DeclDocMap,-                -- ^ Docs on declarations.+        mi_complete_matches :: ![IfaceCompleteMatch], -        mi_arg_docs :: ArgDocMap,-                -- ^ Docs on arguments.+        mi_docs :: Maybe Docs,+                -- ^ Docstrings and related data for use by haddock, the ghci+                -- @:doc@ command, and other tools.+                --+                -- @Just _@ @<=>@ the module was built with @-haddock@.          mi_final_exts :: !(IfaceBackendExts phase),                 -- ^ Either `()` or `ModIfaceBackend` for                 -- a fully instantiated interface. -        mi_ext_fields :: ExtensibleFields+        mi_ext_fields :: !ExtensibleFields,                 -- ^ Additional optional fields, where the Map key represents                 -- the field name, resulting in a (size, serialized data) pair.                 -- Because the data is intended to be serialized through the                 -- internal `Binary` class (increasing compatibility with types                 -- using `Name` and `FastString`, such as HIE), this format is                 -- chosen over `ByteString`s.+                --++        mi_src_hash :: !Fingerprint+                -- ^ Hash of the .hs source, used for recompilation checking.      } +{-+Note [Strictness in ModIface]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++The ModIface is the Haskell representation of an interface (.hi) file.++* During compilation we write out ModIface values to disk for files+  that we have just compiled+* For packages that we depend on we load the ModIface from disk.++Some fields in the ModIface are deliberately lazy because when we read+an interface file we don't always need all the parts. For example, an+interface file contains information about documentation which is often+not needed during compilation. This is achieved using the lazyPut/lazyGet pair.+If the field was strict then we would pointlessly load this information into memory.++On the other hand, if we create a ModIface but **don't** write it to+disk then to avoid space leaks we need to make sure to deepseq all these lazy fields+because the ModIface might live for a long time (for instance in a GHCi session).+That's why in GHC.Driver.Main.hscMaybeWriteIface there is the call to+forceModIface.+-}+ -- | Old-style accessor for whether or not the ModIface came from an hs-boot -- file. mi_boot :: ModIface -> IsBootInterface@@ -258,6 +288,9 @@     then IsBoot     else NotBoot +mi_mnwib :: ModIface -> ModuleNameWithIsBoot+mi_mnwib iface = GWIB (moduleName $ mi_module iface) (mi_boot iface)+ -- | Lookups up a (possibly cached) fixity from a 'ModIface'. If one cannot be -- found, 'defaultFixity' is returned instead. mi_fix :: ModIface -> OccName -> Fixity@@ -282,7 +315,7 @@         -> renameFreeHoles (mkUniqDSet cands) (instUnitInsts (moduleUnit indef))     _   -> emptyUniqDSet   where-    cands = map gwib_mod $ dep_mods $ mi_deps iface+    cands = dep_sig_mods $ mi_deps iface  -- | Given a set of free holes, and a unit identifier, rename -- the free holes according to the instantiation of the unit@@ -299,12 +332,15 @@         -- It wasn't actually a hole         | otherwise                           = emptyUniqDSet -+-- See Note [Strictness in ModIface] about where we use lazyPut vs put instance Binary ModIface where    put_ bh (ModIface {                  mi_module    = mod,                  mi_sig_of    = sig_of,                  mi_hsc_src   = hsc_src,+                 mi_src_hash = _src_hash, -- Don't `put_` this in the instance+                                          -- because we are going to write it+                                          -- out separately in the actual file                  mi_deps      = deps,                  mi_usages    = usages,                  mi_exports   = exports,@@ -320,9 +356,7 @@                  mi_trust     = trust,                  mi_trust_pkg = trust_pkg,                  mi_complete_matches = complete_matches,-                 mi_doc_hdr   = doc_hdr,-                 mi_decl_docs = decl_docs,-                 mi_arg_docs  = arg_docs,+                 mi_docs      = docs,                  mi_ext_fields = _ext_fields, -- Don't `put_` this in the instance so we                                               -- can deal with it's pointer in the header                                               -- when we write the actual file@@ -366,9 +400,7 @@         put_ bh trust         put_ bh trust_pkg         put_ bh complete_matches-        lazyPut bh doc_hdr-        lazyPut bh decl_docs-        lazyPut bh arg_docs+        lazyPutMaybe bh docs     get bh = do         mod         <- get bh@@ -399,13 +431,13 @@         trust       <- get bh         trust_pkg   <- get bh         complete_matches <- get bh-        doc_hdr     <- lazyGet bh-        decl_docs   <- lazyGet bh-        arg_docs    <- lazyGet bh+        docs        <- lazyGetMaybe bh         return (ModIface {                  mi_module      = mod,                  mi_sig_of      = sig_of,                  mi_hsc_src     = hsc_src,+                 mi_src_hash = fingerprint0, -- placeholder because this is dealt+                                             -- with specially when the file is read                  mi_deps        = deps,                  mi_usages      = usages,                  mi_exports     = exports,@@ -423,9 +455,7 @@                  mi_trust_pkg   = trust_pkg,                         -- And build the cached values                  mi_complete_matches = complete_matches,-                 mi_doc_hdr     = doc_hdr,-                 mi_decl_docs   = decl_docs,-                 mi_arg_docs    = arg_docs,+                 mi_docs        = docs,                  mi_ext_fields  = emptyExtensibleFields, -- placeholder because this is dealt                                                          -- with specially when the file is read                  mi_final_exts = ModIfaceBackend {@@ -452,6 +482,7 @@   = ModIface { mi_module      = mod,                mi_sig_of      = Nothing,                mi_hsc_src     = HsSrcFile,+               mi_src_hash    = fingerprint0,                mi_deps        = noDependencies,                mi_usages      = [],                mi_exports     = [],@@ -468,9 +499,7 @@                mi_trust       = noIfaceTrustInfo,                mi_trust_pkg   = False,                mi_complete_matches = [],-               mi_doc_hdr     = Nothing,-               mi_decl_docs   = emptyDeclDocMap,-               mi_arg_docs    = emptyArgDocMap,+               mi_docs        = Nothing,                mi_final_exts  = (),                mi_ext_fields  = emptyExtensibleFields              }@@ -512,11 +541,21 @@ -- avoid major space leaks. instance (NFData (IfaceBackendExts (phase :: ModIfacePhase)), NFData (IfaceDeclExts (phase :: ModIfacePhase))) => NFData (ModIface_ phase) where   rnf (ModIface f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12-                f13 f14 f15 f16 f17 f18 f19 f20 f21 f22 f23 f24) =+                f13 f14 f15 f16 f17 f18 f19 f20 f21 f22 f23) =     rnf f1 `seq` rnf f2 `seq` f3 `seq` f4 `seq` f5 `seq` f6 `seq` rnf f7 `seq` f8 `seq`     f9 `seq` rnf f10 `seq` rnf f11 `seq` f12 `seq` rnf f13 `seq` rnf f14 `seq` rnf f15 `seq`     rnf f16 `seq` f17 `seq` rnf f18 `seq` rnf f19 `seq` f20 `seq` f21 `seq` f22 `seq` rnf f23-    `seq` rnf f24+    `seq` ()++instance NFData (ModIfaceBackend) where+  rnf (ModIfaceBackend f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13)+    = rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq`+      rnf f5 `seq` rnf f6 `seq` rnf f7 `seq` rnf f8 `seq`+      rnf f9 `seq` rnf f10 `seq` rnf f11 `seq` rnf f12 `seq` rnf f13+++forceModIface :: ModIface -> IO ()+forceModIface iface = () <$ (evaluate $ force iface)  -- | Records whether a module has orphans. An \"orphan\" is one of: --
GHC/Unit/Module/ModSummary.hs view
@@ -1,21 +1,23 @@-{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TupleSections #-}  -- | A ModSummary is a node in the compilation manager's dependency graph -- (ModuleGraph) module GHC.Unit.Module.ModSummary-   ( ExtendedModSummary (..)-   , extendModSummaryNoDeps-   , ModSummary (..)+   ( ModSummary (..)+   , ms_unitid    , ms_installed_mod    , ms_mod_name    , ms_imps-   , ms_home_allimps+   , ms_plugin_imps+   , ms_mnwib    , ms_home_srcimps    , ms_home_imps    , msHiFilePath+   , msDynHiFilePath    , msHsFilePath    , msObjFilePath    , msDynObjFilePath+   , msDeps    , isBootSummary    , findTarget    )@@ -33,31 +35,17 @@ import GHC.Types.SourceFile ( HscSource(..), hscSourceString ) import GHC.Types.SrcLoc import GHC.Types.Target+import GHC.Types.PkgQual  import GHC.Data.Maybe-import GHC.Data.FastString import GHC.Data.StringBuffer ( StringBuffer ) +import GHC.Utils.Fingerprint import GHC.Utils.Outputable  import Data.Time --- | Enrichment of 'ModSummary' with backpack dependencies-data ExtendedModSummary = ExtendedModSummary-  { emsModSummary :: {-# UNPACK #-} !ModSummary-  , emsInstantiatedUnits :: [InstantiatedUnit]-  -- ^ Extra backpack deps-  -- NB: This is sometimes left empty in situations where the instantiated units-  -- would not be used. See call sites of 'extendModSummaryNoDeps'.-  } -instance Outputable ExtendedModSummary where-  ppr = \case-    ExtendedModSummary ms bds -> ppr ms <+> ppr bds--extendModSummaryNoDeps :: ModSummary -> ExtendedModSummary-extendModSummaryNoDeps ms = ExtendedModSummary ms []- -- | Data for a module node in a 'ModuleGraph'. Module nodes of the module graph -- are one of: --@@ -72,20 +60,23 @@           -- ^ The module source either plain Haskell, hs-boot, or hsig         ms_location     :: ModLocation,           -- ^ Location of the various files belonging to the module-        ms_hs_date      :: UTCTime,-          -- ^ Timestamp of source file+        ms_hs_hash      :: Fingerprint,+          -- ^ Content hash of source file         ms_obj_date     :: Maybe UTCTime,           -- ^ Timestamp of object, if we have one+        ms_dyn_obj_date     :: !(Maybe UTCTime),+          -- ^ Timestamp of dynamic object, if we have one         ms_iface_date   :: Maybe UTCTime,-          -- ^ Timestamp of hi file, if we *only* are typechecking (it is-          -- 'Nothing' otherwise.-          -- See Note [Recompilation checking in -fno-code mode] and #9243+          -- ^ Timestamp of hi file, if we have one+          -- See Note [When source is considered modified] and #9243         ms_hie_date   :: Maybe UTCTime,           -- ^ Timestamp of hie file, if we have one-        ms_srcimps      :: [(Maybe FastString, Located ModuleName)],+        ms_srcimps      :: [(PkgQual, Located ModuleName)], -- FIXME: source imports are never from an external package, why do we allow PkgQual?           -- ^ Source imports of the module-        ms_textual_imps :: [(Maybe FastString, Located ModuleName)],+        ms_textual_imps :: [(PkgQual, Located ModuleName)],           -- ^ Non-source imports of the module from the module *text*+        ms_ghc_prim_import :: !Bool,+          -- ^ Whether the special module GHC.Prim was imported explicitliy         ms_parsed_mod   :: Maybe HsParsedModule,           -- ^ The parsed, nonrenamed source, if we have it.  This is also           -- used to support "inline module syntax" in Backpack files.@@ -98,39 +89,44 @@           -- ^ The actual preprocessed source, if we have it      } +ms_unitid :: ModSummary -> UnitId+ms_unitid = toUnitId . moduleUnit . ms_mod+ ms_installed_mod :: ModSummary -> InstalledModule ms_installed_mod = fst . getModuleInstantiation . ms_mod  ms_mod_name :: ModSummary -> ModuleName ms_mod_name = moduleName . ms_mod -ms_imps :: ModSummary -> [(Maybe FastString, Located ModuleName)]-ms_imps ms =-  ms_textual_imps ms ++-  map mk_additional_import (dynFlagDependencies (ms_hspp_opts ms))-  where-    mk_additional_import mod_nm = (Nothing, noLoc mod_nm)+-- | Textual imports, plus plugin imports but not SOURCE imports.+ms_imps :: ModSummary -> [(PkgQual, Located ModuleName)]+ms_imps ms = ms_textual_imps ms ++ ms_plugin_imps ms -home_imps :: [(Maybe FastString, Located ModuleName)] -> [Located ModuleName]-home_imps imps = [ lmodname |  (mb_pkg, lmodname) <- imps,-                                  isLocal mb_pkg ]-  where isLocal Nothing = True-        isLocal (Just pkg) | pkg == fsLit "this" = True -- "this" is special-        isLocal _ = False+-- | Plugin imports+ms_plugin_imps :: ModSummary -> [(PkgQual, Located ModuleName)]+ms_plugin_imps ms = map ((NoPkgQual,) . noLoc) (pluginModNames (ms_hspp_opts ms)) -ms_home_allimps :: ModSummary -> [ModuleName]-ms_home_allimps ms = map unLoc (ms_home_srcimps ms ++ ms_home_imps ms)+-- | All of the (possibly) home module imports from the given list that is to+-- say, each of these module names could be a home import if an appropriately+-- named file existed.  (This is in contrast to package qualified imports, which+-- are guaranteed not to be home imports.)+home_imps :: [(PkgQual, Located ModuleName)] -> [(PkgQual, Located ModuleName)]+home_imps imps = filter (maybe_home . fst) imps+  where maybe_home NoPkgQual    = True+        maybe_home (ThisPkg _)  = True+        maybe_home (OtherPkg _) = False  -- | Like 'ms_home_imps', but for SOURCE imports.-ms_home_srcimps :: ModSummary -> [Located ModuleName]-ms_home_srcimps = home_imps . ms_srcimps+ms_home_srcimps :: ModSummary -> ([Located ModuleName])+-- [] here because source imports can only refer to the current package.+ms_home_srcimps = map snd . home_imps . ms_srcimps  -- | All of the (possibly) home module imports from a -- 'ModSummary'; that is to say, each of these module names -- could be a home import if an appropriately named file -- existed.  (This is in contrast to package qualified -- imports, which are guaranteed not to be home imports.)-ms_home_imps :: ModSummary -> [Located ModuleName]+ms_home_imps :: ModSummary -> ([(PkgQual, Located ModuleName)]) ms_home_imps = home_imps . ms_imps  -- The ModLocation contains both the original source filename and the@@ -141,42 +137,59 @@ -- and let @compile@ read from that file on the way back up.  -- The ModLocation is stable over successive up-sweeps in GHCi, wheres--- the ms_hs_date and imports can, of course, change+-- the ms_hs_hash and imports can, of course, change -msHsFilePath, msHiFilePath, msObjFilePath :: ModSummary -> FilePath+msHsFilePath, msDynHiFilePath, msHiFilePath, msObjFilePath, msDynObjFilePath :: ModSummary -> FilePath msHsFilePath  ms = expectJust "msHsFilePath" (ml_hs_file  (ms_location ms)) msHiFilePath  ms = ml_hi_file  (ms_location ms)+msDynHiFilePath ms = ml_dyn_hi_file (ms_location ms) msObjFilePath ms = ml_obj_file (ms_location ms)--msDynObjFilePath :: ModSummary -> DynFlags -> FilePath-msDynObjFilePath ms dflags = dynamicOutputFile dflags (msObjFilePath ms)+msDynObjFilePath ms = ml_dyn_obj_file (ms_location ms)  -- | Did this 'ModSummary' originate from a hs-boot file? isBootSummary :: ModSummary -> IsBootInterface isBootSummary ms = if ms_hsc_src ms == HsBootFile then IsBoot else NotBoot +ms_mnwib :: ModSummary -> ModuleNameWithIsBoot+ms_mnwib ms = GWIB (ms_mod_name ms) (isBootSummary ms)++-- | Returns the dependencies of the ModSummary s.+msDeps :: ModSummary -> ([(PkgQual, GenWithIsBoot (Located ModuleName))])+msDeps s =+           [ (NoPkgQual, d)+           | m <- ms_home_srcimps s+           , d <- [ GWIB { gwib_mod = m, gwib_isBoot = IsBoot }+                  ]+           ]+        ++ [ (pkg, (GWIB { gwib_mod = m, gwib_isBoot = NotBoot }))+           | (pkg, m) <- ms_imps s+           ]+ instance Outputable ModSummary where    ppr ms       = sep [text "ModSummary {",-             nest 3 (sep [text "ms_hs_date = " <> text (show (ms_hs_date ms)),+             nest 3 (sep [text "ms_hs_hash = " <> text (show (ms_hs_hash ms)),                           text "ms_mod =" <+> ppr (ms_mod ms)                                 <> text (hscSourceString (ms_hsc_src ms)) <> comma,+                          text "unit =" <+> ppr (ms_unitid ms),                           text "ms_textual_imps =" <+> ppr (ms_textual_imps ms),                           text "ms_srcimps =" <+> ppr (ms_srcimps ms)]),              char '}'             ] +-- | Find the first target in the provided list which matches the specified+-- 'ModSummary'. findTarget :: ModSummary -> [Target] -> Maybe Target findTarget ms ts =   case filter (matches ms) ts of         []    -> Nothing         (t:_) -> Just t   where-    summary `matches` Target (TargetModule m) _ _-        = ms_mod_name summary == m-    summary `matches` Target (TargetFile f _) _ _+    summary `matches` Target { targetId = TargetModule m, targetUnitId = unitId }+        = ms_mod_name summary == m && ms_unitid summary == unitId+    summary `matches` Target { targetId = TargetFile f _, targetUnitId = unitid }         | Just f' <- ml_hs_file (ms_location summary)-        = f == f'+        = f == f'  && ms_unitid summary == unitid     _ `matches` _         = False
GHC/Unit/Module/Status.hs view
@@ -1,5 +1,5 @@ module GHC.Unit.Module.Status-   ( HscStatus (..)+   ( HscBackendAction(..), HscRecompStatus (..)    ) where @@ -8,20 +8,24 @@ import GHC.Unit import GHC.Unit.Module.ModGuts import GHC.Unit.Module.ModIface-import GHC.Unit.Module.ModDetails  import GHC.Utils.Fingerprint+import GHC.Linker.Types+import GHC.Utils.Outputable --- | Status of a module compilation to machine code-data HscStatus-    -- | Nothing to do.-    = HscNotGeneratingCode ModIface ModDetails+-- | Status of a module in incremental compilation+data HscRecompStatus     -- | Nothing to do because code already exists.-    | HscUpToDate ModIface ModDetails-    -- | Update boot file result.-    | HscUpdateBoot ModIface ModDetails-    -- | Generate signature file (backpack)-    | HscUpdateSig ModIface ModDetails+    = HscUpToDate ModIface (Maybe Linkable)+    -- | Recompilation of module, or update of interface is required. Optionally+    -- pass the old interface hash to avoid updating the existing interface when+    -- it has not changed.+    | HscRecompNeeded (Maybe Fingerprint)++-- | Action to perform in backend compilation+data HscBackendAction+    -- | Update the boot and signature file results.+    = HscUpdate ModIface     -- | Recompile this module.     | HscRecomp         { hscs_guts           :: CgGuts@@ -36,3 +40,8 @@           -- avoid updating the existing interface when the interface isn't           -- changed.         }+++instance Outputable HscBackendAction where+  ppr (HscUpdate mi) = text "Update:" <+> (ppr (mi_module mi))+  ppr (HscRecomp _ ml _mi _mf) = text "Recomp:" <+> ppr ml
GHC/Unit/Module/Warnings.hs view
@@ -1,4 +1,8 @@ {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE StandaloneDeriving #-}  -- | Warnings for a module module GHC.Unit.Module.Warnings@@ -16,25 +20,31 @@ import GHC.Types.SourceText import GHC.Types.Name.Occurrence import GHC.Types.SrcLoc+import GHC.Hs.Doc+import GHC.Hs.Extension  import GHC.Utils.Outputable import GHC.Utils.Binary +import Language.Haskell.Syntax.Extension+ import Data.Data  -- | Warning Text -- -- reason/explanation from a WARNING or DEPRECATED pragma-data WarningTxt+data WarningTxt pass    = WarningTxt       (Located SourceText)-      [Located StringLiteral]+      [Located (WithHsDocIdentifiers StringLiteral pass)]    | DeprecatedTxt       (Located SourceText)-      [Located StringLiteral]-   deriving (Eq, Data)+      [Located (WithHsDocIdentifiers StringLiteral pass)] -instance Outputable WarningTxt where+deriving instance Eq (IdP pass) => Eq (WarningTxt pass)+deriving instance (Data pass, Data (IdP pass)) => Data (WarningTxt pass)++instance Outputable (WarningTxt pass) where     ppr (WarningTxt    lsrc ws)       = case unLoc lsrc of           NoSourceText   -> pp_ws ws@@ -45,7 +55,7 @@           NoSourceText   -> pp_ws ds           SourceText src -> text src <+> pp_ws ds <+> text "#-}" -instance Binary WarningTxt where+instance Binary (WarningTxt GhcRn) where     put_ bh (WarningTxt s w) = do             putByte bh 0             put_ bh s@@ -66,7 +76,7 @@                       return (DeprecatedTxt s d)  -pp_ws :: [Located StringLiteral] -> SDoc+pp_ws :: [Located (WithHsDocIdentifiers StringLiteral pass)] -> SDoc pp_ws [l] = ppr $ unLoc l pp_ws ws   = text "["@@ -74,19 +84,19 @@     <+> text "]"  -pprWarningTxtForMsg :: WarningTxt -> SDoc+pprWarningTxtForMsg :: WarningTxt p -> SDoc pprWarningTxtForMsg (WarningTxt    _ ws)-                     = doubleQuotes (vcat (map (ftext . sl_fs . unLoc) ws))+                     = doubleQuotes (vcat (map (ftext . sl_fs . hsDocString . unLoc) ws)) pprWarningTxtForMsg (DeprecatedTxt _ ds)                      = text "Deprecated:" <+>-                       doubleQuotes (vcat (map (ftext . sl_fs . unLoc) ds))+                       doubleQuotes (vcat (map (ftext . sl_fs . hsDocString . unLoc) ds))   -- | Warning information for a module-data Warnings+data Warnings pass   = NoWarnings                          -- ^ Nothing deprecated-  | WarnAll WarningTxt                  -- ^ Whole module deprecated-  | WarnSome [(OccName,WarningTxt)]     -- ^ Some specific things deprecated+  | WarnAll (WarningTxt pass)                  -- ^ Whole module deprecated+  | WarnSome [(OccName,WarningTxt pass)]     -- ^ Some specific things deprecated       -- Only an OccName is needed because      --    (1) a deprecation always applies to a binding@@ -108,9 +118,10 @@      --      --        this is in contrast with fixity declarations, where we need to map      --        a Name to its fixity declaration.-  deriving( Eq ) -instance Binary Warnings where+deriving instance Eq (IdP pass) => Eq (Warnings pass)++instance Binary (Warnings GhcRn) where     put_ bh NoWarnings     = putByte bh 0     put_ bh (WarnAll t) = do             putByte bh 1@@ -129,15 +140,15 @@                       return (WarnSome aa)  -- | Constructs the cache for the 'mi_warn_fn' field of a 'ModIface'-mkIfaceWarnCache :: Warnings -> OccName -> Maybe WarningTxt+mkIfaceWarnCache :: Warnings p -> OccName -> Maybe (WarningTxt p) mkIfaceWarnCache NoWarnings  = \_ -> Nothing mkIfaceWarnCache (WarnAll t) = \_ -> Just t mkIfaceWarnCache (WarnSome pairs) = lookupOccEnv (mkOccEnv pairs) -emptyIfaceWarnCache :: OccName -> Maybe WarningTxt+emptyIfaceWarnCache :: OccName -> Maybe (WarningTxt p) emptyIfaceWarnCache _ = Nothing -plusWarns :: Warnings -> Warnings -> Warnings+plusWarns :: Warnings p -> Warnings p -> Warnings p plusWarns d NoWarnings = d plusWarns NoWarnings d = d plusWarns _ (WarnAll t) = WarnAll t
GHC/Unit/Parser.hs view
@@ -1,7 +1,7 @@ -- | Parsers for unit/module identifiers module GHC.Unit.Parser    ( parseUnit-   , parseIndefUnitId+   , parseUnitId    , parseHoleyModule    , parseModSubst    )@@ -21,7 +21,7 @@ parseUnit = parseVirtUnitId <++ parseDefUnitId   where     parseVirtUnitId = do-        uid   <- parseIndefUnitId+        uid   <- parseUnitId         insts <- parseModSubst         return (mkVirtUnit uid insts)     parseDefUnitId = do@@ -32,11 +32,6 @@ parseUnitId = do    s <- Parse.munch1 (\c -> isAlphaNum c || c `elem` "-_.+")    return (UnitId (mkFastString s))--parseIndefUnitId :: ReadP IndefUnitId-parseIndefUnitId = do-   uid <- parseUnitId-   return (Indefinite uid)  parseHoleyModule :: ReadP Module parseHoleyModule = parseModuleVar <++ parseModule
GHC/Unit/State.hs view
@@ -1,8 +1,8 @@ -- (c) The University of Glasgow, 2006 -{-# LANGUAGE CPP, ScopedTypeVariables, BangPatterns, FlexibleContexts #-}-{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE ScopedTypeVariables, BangPatterns, FlexibleContexts #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}  -- | Unit manipulation module GHC.Unit.State (@@ -31,6 +31,7 @@         unsafeLookupUnitId,          lookupPackageName,+        resolvePackageImport,         improveUnit,         searchPackageId,         listVisibleModuleNames,@@ -68,12 +69,10 @@         pprWithUnitState,          -- * Utils-        unwireUnit-    )+        unwireUnit,+        implicitPackageDeps) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Driver.Session@@ -92,6 +91,7 @@ import GHC.Types.Unique.DFM import GHC.Types.Unique.Set import GHC.Types.Unique.DSet+import GHC.Types.PkgQual  import GHC.Utils.Misc import GHC.Utils.Panic@@ -118,6 +118,8 @@ import qualified Data.Map as Map import qualified Data.Map.Strict as MapStrict import qualified Data.Set as Set+import GHC.LanguageExtensions+import Control.Applicative  -- --------------------------------------------------------------------------- -- The Unit state@@ -275,7 +277,7 @@     , uv_requirements :: Map ModuleName (Set InstantiatedModule)       -- ^ The signatures which are contributed to the requirements context       -- from this unit ID.-    , uv_explicit :: Bool+    , uv_explicit :: Maybe PackageArg       -- ^ Whether or not this unit was explicitly brought into scope,       -- as opposed to implicitly via the 'exposed' fields in the       -- package database (when @-hide-all-packages@ is not passed.)@@ -297,7 +299,7 @@           , uv_renamings = uv_renamings uv1 ++ uv_renamings uv2           , uv_package_name = mappend (uv_package_name uv1) (uv_package_name uv2)           , uv_requirements = Map.unionWith Set.union (uv_requirements uv1) (uv_requirements uv2)-          , uv_explicit = uv_explicit uv1 || uv_explicit uv2+          , uv_explicit = uv_explicit uv1 <|> uv_explicit uv2           }  instance Monoid UnitVisibility where@@ -306,7 +308,7 @@              , uv_renamings = []              , uv_package_name = First Nothing              , uv_requirements = Map.empty-             , uv_explicit = False+             , uv_explicit = Nothing              }     mappend = (Semigroup.<>) @@ -317,8 +319,8 @@    , unitConfigWays           :: !Ways          -- ^ Ways to use     , unitConfigAllowVirtual   :: !Bool          -- ^ Allow virtual units-      -- ^ Do we allow the use of virtual units instantiated on-the-fly (see Note-      -- [About units] in GHC.Unit). This should only be true when we are+      -- ^ Do we allow the use of virtual units instantiated on-the-fly (see+      -- Note [About units] in GHC.Unit). This should only be true when we are       -- type-checking an indefinite unit (not producing any code).     , unitConfigProgramName    :: !String@@ -345,10 +347,11 @@    , unitConfigFlagsIgnored :: [IgnorePackageFlag] -- ^ Ignored units    , unitConfigFlagsTrusted :: [TrustFlag]         -- ^ Trusted units    , unitConfigFlagsPlugins :: [PackageFlag]       -- ^ Plugins exposed units+   , unitConfigHomeUnits    :: Set.Set UnitId    } -initUnitConfig :: DynFlags -> Maybe [UnitDatabase UnitId] -> UnitConfig-initUnitConfig dflags cached_dbs =+initUnitConfig :: DynFlags -> Maybe [UnitDatabase UnitId] -> Set.Set UnitId -> UnitConfig+initUnitConfig dflags cached_dbs home_units =    let !hu_id             = homeUnitId_ dflags        !hu_instanceof     = homeUnitInstanceOf_ dflags        !hu_instantiations = homeUnitInstantiations_ dflags@@ -382,19 +385,27 @@       , unitConfigHideAllPlugins = gopt Opt_HideAllPluginPackages dflags        , unitConfigDBCache      = cached_dbs-      , unitConfigFlagsDB      = packageDBFlags dflags+      , unitConfigFlagsDB      = map (offsetPackageDb (workingDirectory dflags)) $ packageDBFlags dflags       , unitConfigFlagsExposed = packageFlags dflags       , unitConfigFlagsIgnored = ignorePackageFlags dflags       , unitConfigFlagsTrusted = trustFlags dflags       , unitConfigFlagsPlugins = pluginPackageFlags dflags+      , unitConfigHomeUnits    = home_units        } +  where+    offsetPackageDb :: Maybe FilePath -> PackageDBFlag -> PackageDBFlag+    offsetPackageDb (Just offset) (PackageDB (PkgDbPath p)) | isRelative p = PackageDB (PkgDbPath (offset </> p))+    offsetPackageDb _ p = p++ -- | Map from 'ModuleName' to a set of module providers (i.e. a 'Module' and -- its 'ModuleOrigin'). -- -- NB: the set is in fact a 'Map Module ModuleOrigin', probably to keep only one -- origin for a given 'Module'+ type ModuleNameProvidersMap =     Map ModuleName (Map Module ModuleOrigin) @@ -413,9 +424,11 @@   -- See Note [VirtUnit to RealUnit improvement]   preloadClosure :: PreloadUnitClosure, -  -- | A mapping of 'PackageName' to 'IndefUnitId'.  This is used when-  -- users refer to packages in Backpack includes.-  packageNameMap            :: UniqFM PackageName IndefUnitId,+  -- | A mapping of 'PackageName' to 'UnitId'. If several units have the same+  -- package name (e.g. different instantiations), then we return one of them...+  -- This is used when users refer to packages in Backpack includes.+  -- And also to resolve package qualifiers with the PackageImports extension.+  packageNameMap            :: UniqFM PackageName UnitId,    -- | A mapping from database unit keys to wired in unit ids.   wireMap :: Map UnitId UnitId,@@ -429,9 +442,13 @@   preloadUnits      :: [UnitId],    -- | Units which we explicitly depend on (from a command line flag).-  -- We'll use this to generate version macros.-  explicitUnits      :: [Unit],+  -- We'll use this to generate version macros and the unused packages warning. The+  -- original flag which was used to bring the unit into scope is recorded for the+  -- -Wunused-packages warning.+  explicitUnits :: [(Unit, Maybe PackageArg)], +  homeUnitDepends    :: [UnitId],+   -- | This is a full map from 'ModuleName' to all modules which may possibly   -- be providing it.  These providers may be hidden (but we'll still want   -- to report them in error messages), or it may be an ambiguous import.@@ -465,6 +482,7 @@     unwireMap = Map.empty,     preloadUnits = [],     explicitUnits = [],+    homeUnitDepends = [],     moduleNameProvidersMap = Map.empty,     pluginModuleNameProvidersMap = Map.empty,     requirementContext = Map.empty,@@ -477,6 +495,9 @@    , unitDatabaseUnits :: [GenUnitInfo unit]    } +instance Outputable u => Outputable (UnitDatabase u) where+  ppr (UnitDatabase fp _u) = text "DB:" <+> text fp+ type UnitInfoMap = Map UnitId UnitInfo  -- | Find the unit we know about with the given unit, if any@@ -499,7 +520,7 @@       -> -- lookup UnitInfo of the indefinite unit to be instantiated and          -- instantiate it on-the-fly          fmap (renameUnitInfo pkg_map closure (instUnitInsts i))-           (Map.lookup (indefUnit (instUnitInstanceOf i)) pkg_map)+           (Map.lookup (instUnitInstanceOf i) pkg_map)        | otherwise       -> -- lookup UnitInfo by virtual UnitId. This is used to find indefinite@@ -532,7 +553,9 @@  -- | Find the unit we know about with the given package name (e.g. @foo@), if any -- (NB: there might be a locally defined unit name which overrides this)-lookupPackageName :: UnitState -> PackageName -> Maybe IndefUnitId+-- This function is unsafe to use in general because it doesn't respect package+-- visibility.+lookupPackageName :: UnitState -> PackageName -> Maybe UnitId lookupPackageName pkgstate n = lookupUFM (packageNameMap pkgstate) n  -- | Search for units with a given package ID (e.g. \"foo-0.1\")@@ -540,6 +563,21 @@ searchPackageId pkgstate pid = filter ((pid ==) . unitPackageId)                                (listUnitInfo pkgstate) +-- | Find the UnitId which an import qualified by a package import comes from.+-- Compared to 'lookupPackageName', this function correctly accounts for visibility,+-- renaming and thinning.+resolvePackageImport :: UnitState -> ModuleName -> PackageName -> Maybe UnitId+resolvePackageImport unit_st mn pn = do+  -- 1. Find all modules providing the ModuleName (this accounts for visibility/thinning etc)+  providers <- Map.filter originVisible <$> Map.lookup mn (moduleNameProvidersMap unit_st)+  -- 2. Get the UnitIds of the candidates+  let candidates_uid = map (toUnitId . moduleUnit) $ Map.keys providers+  -- 3. Get the package names of the candidates+  let candidates_units = map (\ui -> ((unitPackageName ui), unitId ui))+                              $ mapMaybe (\uid -> Map.lookup uid (unitInfoMap unit_st)) candidates_uid+  -- 4. Check to see if the PackageName helps us disambiguate any candidates.+  lookup pn candidates_units+ -- | Create a Map UnitId UnitInfo -- -- For each instantiated unit, we add two map keys:@@ -578,18 +616,16 @@ -- 'initUnits' can be called again subsequently after updating the -- 'packageFlags' field of the 'DynFlags', and it will update the -- 'unitState' in 'DynFlags'.-initUnits :: Logger -> DynFlags -> Maybe [UnitDatabase UnitId] -> IO ([UnitDatabase UnitId], UnitState, HomeUnit, Maybe PlatformConstants)-initUnits logger dflags cached_dbs = do+initUnits :: Logger -> DynFlags -> Maybe [UnitDatabase UnitId] -> Set.Set UnitId -> IO ([UnitDatabase UnitId], UnitState, HomeUnit, Maybe PlatformConstants)+initUnits logger dflags cached_dbs home_units = do    let forceUnitInfoMap (state, _) = unitInfoMap state `seq` ()-  let ctx     = initSDocContext dflags defaultUserStyle -- SDocContext used to render exception messages-  let printer = debugTraceMsg logger dflags             -- printer for trace messages -  (unit_state,dbs) <- withTiming logger dflags (text "initializing unit database")+  (unit_state,dbs) <- withTiming logger (text "initializing unit database")                    forceUnitInfoMap-                 $ mkUnitState ctx printer (initUnitConfig dflags cached_dbs)+                 $ mkUnitState logger (initUnitConfig dflags cached_dbs home_units) -  dumpIfSet_dyn logger dflags Opt_D_dump_mod_map "Module Map"+  putDumpFileMaybe logger Opt_D_dump_mod_map "Module Map"     FormatText (updSDocContext (\ctx -> ctx {sdocLineLength = 200})                 $ pprModuleMap (moduleNameProvidersMap unit_state)) @@ -648,11 +684,11 @@ -- ----------------------------------------------------------------------------- -- Reading the unit database(s) -readUnitDatabases :: (Int -> SDoc -> IO ()) -> UnitConfig -> IO [UnitDatabase UnitId]-readUnitDatabases printer cfg = do+readUnitDatabases :: Logger -> UnitConfig -> IO [UnitDatabase UnitId]+readUnitDatabases logger cfg = do   conf_refs <- getUnitDbRefs cfg   confs     <- liftM catMaybes $ mapM (resolveUnitDatabase cfg) conf_refs-  mapM (readUnitDatabase printer cfg) confs+  mapM (readUnitDatabase logger cfg) confs   getUnitDbRefs :: UnitConfig -> IO [PkgDbRef]@@ -704,8 +740,8 @@   if exist then return pkgconf else mzero resolveUnitDatabase _ (PkgDbPath name) = return $ Just name -readUnitDatabase :: (Int -> SDoc -> IO ()) -> UnitConfig -> FilePath -> IO (UnitDatabase UnitId)-readUnitDatabase printer cfg conf_file = do+readUnitDatabase :: Logger -> UnitConfig -> FilePath -> IO (UnitDatabase UnitId)+readUnitDatabase logger cfg conf_file = do   isdir <- doesDirectoryExist conf_file    proto_pkg_configs <-@@ -741,21 +777,21 @@       cache_exists <- doesFileExist filename       if cache_exists         then do-          printer 2 $ text "Using binary package database:" <+> text filename+          debugTraceMsg logger 2 $ text "Using binary package database:" <+> text filename           readPackageDbForGhc filename         else do           -- If there is no package.cache file, we check if the database is not           -- empty by inspecting if the directory contains any .conf file. If it           -- does, something is wrong and we fail. Otherwise we assume that the           -- database is empty.-          printer 2 $ text "There is no package.cache in"+          debugTraceMsg logger 2 $ text "There is no package.cache in"                       <+> text conf_dir                        <> text ", checking if the database is empty"           db_empty <- all (not . isSuffixOf ".conf")                    <$> getDirectoryContents conf_dir           if db_empty             then do-              printer 3 $ text "There are no .conf files in"+              debugTraceMsg logger 3 $ text "There are no .conf files in"                           <+> text conf_dir <> text ", treating"                           <+> text "package database as empty"               return []@@ -780,7 +816,7 @@           let conf_dir = conf_file <.> "d"           direxists <- doesDirectoryExist conf_dir           if direxists-             then do printer 2 (text "Ignoring old file-style db and trying:" <+> text conf_dir)+             then do debugTraceMsg logger 2 (text "Ignoring old file-style db and trying:" <+> text conf_dir)                      liftM Just (readDirStyleUnitInfo conf_dir)              else return (Just []) -- ghc-pkg will create it when it's updated         else return Nothing@@ -876,7 +912,7 @@                 , uv_renamings = rns                 , uv_package_name = First (Just n)                 , uv_requirements = reqs-                , uv_explicit = True+                , uv_explicit = Just arg                 }            vm' = Map.insertWith mappend (mkUnit p) uv vm_cleared            -- In the old days, if you said `ghc -package p-0.1 -package p-0.2`@@ -939,7 +975,7 @@             | iuid == unitId p             -> Just p           VirtUnit inst-            | indefUnit (instUnitInstanceOf inst) == unitId p+            | instUnitInstanceOf inst == unitId p             -> Just (renameUnitInfo pkg_map closure (instUnitInsts inst) p)           _ -> Nothing @@ -1035,7 +1071,7 @@ type WiringMap = Map UnitId UnitId  findWiredInUnits-   :: (SDoc -> IO ())      -- debug trace+   :: Logger    -> UnitPrecedenceMap    -> [UnitInfo]           -- database    -> VisibilityMap             -- info on what units are visible@@ -1043,7 +1079,7 @@    -> IO ([UnitInfo],  -- unit database updated for wired in           WiringMap)   -- map from unit id to wired identity -findWiredInUnits printer prec_map pkgs vis_map = do+findWiredInUnits logger prec_map pkgs vis_map = do   -- Now we must find our wired-in units, and rename them to   -- their canonical names (eg. base-1.0 ==> base), as described   -- in Note [Wired-in units] in GHC.Unit.Module@@ -1081,14 +1117,14 @@             many -> pick (head (sortByPreference prec_map many))           where                 notfound = do-                          printer $+                          debugTraceMsg logger 2 $                             text "wired-in package "                                  <> ftext (unitIdFS wired_pkg)                                  <> text " not found."                           return Nothing                 pick :: UnitInfo -> IO (Maybe (UnitId, UnitInfo))                 pick pkg = do-                        printer $+                        debugTraceMsg logger 2 $                             text "wired-in package "                                  <> ftext (unitIdFS wired_pkg)                                  <> text " mapped to "@@ -1111,11 +1147,11 @@           where upd_pkg pkg                   | Just wiredInUnitId <- Map.lookup (unitId pkg) wiredInMap                   = pkg { unitId         = wiredInUnitId-                        , unitInstanceOf = fmap (const wiredInUnitId) (unitInstanceOf pkg)+                        , unitInstanceOf = wiredInUnitId                            -- every non instantiated unit is an instance of                            -- itself (required by Backpack...)                            ---                           -- See Note [About Units] in GHC.Unit+                           -- See Note [About units] in GHC.Unit                         }                   | otherwise                   = pkg@@ -1141,7 +1177,7 @@  upd_wired_in_uid :: WiringMap -> Unit -> Unit upd_wired_in_uid wiredInMap u = case u of-   HoleUnit                -> HoleUnit+   HoleUnit -> HoleUnit    RealUnit (Definite uid) -> RealUnit (Definite (upd_wired_in wiredInMap uid))    VirtUnit indef_uid ->       VirtUnit $ mkInstantiatedUnit@@ -1208,20 +1244,20 @@       pref <+> text "unusable due to shadowed dependencies:" $$         nest 2 (hsep (map ppr deps)) -reportCycles :: (SDoc -> IO ()) -> [SCC UnitInfo] -> IO ()-reportCycles printer sccs = mapM_ report sccs+reportCycles :: Logger -> [SCC UnitInfo] -> IO ()+reportCycles logger sccs = mapM_ report sccs   where     report (AcyclicSCC _) = return ()     report (CyclicSCC vs) =-        printer $+        debugTraceMsg logger 2 $           text "these packages are involved in a cycle:" $$             nest 2 (hsep (map (ppr . unitId) vs)) -reportUnusable :: (SDoc -> IO ()) -> UnusableUnits -> IO ()-reportUnusable printer pkgs = mapM_ report (Map.toList pkgs)+reportUnusable :: Logger -> UnusableUnits -> IO ()+reportUnusable logger pkgs = mapM_ report (Map.toList pkgs)   where     report (ipid, (_, reason)) =-       printer $+       debugTraceMsg logger 2 $          pprReason            (text "package" <+> ppr ipid <+> text "is") reason @@ -1311,15 +1347,15 @@ -- units with the same unit id in later databases override -- earlier ones.  This does NOT check if the resulting database -- makes sense (that's done by 'validateDatabase').-mergeDatabases :: (SDoc -> IO ()) -> [UnitDatabase UnitId]+mergeDatabases :: Logger -> [UnitDatabase UnitId]                -> IO (UnitInfoMap, UnitPrecedenceMap)-mergeDatabases printer = foldM merge (Map.empty, Map.empty) . zip [1..]+mergeDatabases logger = foldM merge (Map.empty, Map.empty) . zip [1..]   where     merge (pkg_map, prec_map) (i, UnitDatabase db_path db) = do-      printer $+      debugTraceMsg logger 2 $           text "loading package database" <+> text db_path       forM_ (Set.toList override_set) $ \pkg ->-          printer $+          debugTraceMsg logger 2 $               text "package" <+> ppr pkg <+>               text "overrides a previously defined package"       return (pkg_map', prec_map')@@ -1402,11 +1438,10 @@ -- settings and populate the unit state.  mkUnitState-    :: SDocContext            -- ^ SDocContext used to render exception messages-    -> (Int -> SDoc -> IO ()) -- ^ Trace printer+    :: Logger     -> UnitConfig     -> IO (UnitState,[UnitDatabase UnitId])-mkUnitState ctx printer cfg = do+mkUnitState logger cfg = do {-    Plan. @@ -1462,7 +1497,7 @@    -- if databases have not been provided, read the database flags   raw_dbs <- case unitConfigDBCache cfg of-               Nothing  -> readUnitDatabases printer cfg+               Nothing  -> readUnitDatabases logger cfg                Just dbs -> return dbs    -- distrust all units if the flag is set@@ -1474,19 +1509,22 @@   -- This, and the other reverse's that you will see, are due to the fact that   -- packageFlags, pluginPackageFlags, etc. are all specified in *reverse* order   -- than they are on the command line.-  let other_flags = reverse (unitConfigFlagsExposed cfg)-  printer 2 $+  let raw_other_flags = reverse (unitConfigFlagsExposed cfg)+      (hpt_flags, other_flags) = partition (selectHptFlag (unitConfigHomeUnits cfg)) raw_other_flags+  debugTraceMsg logger 2 $       text "package flags" <+> ppr other_flags +  let home_unit_deps = selectHomeUnits (unitConfigHomeUnits cfg) hpt_flags+   -- Merge databases together, without checking validity-  (pkg_map1, prec_map) <- mergeDatabases (printer 2) dbs+  (pkg_map1, prec_map) <- mergeDatabases logger dbs    -- Now that we've merged everything together, prune out unusable   -- packages.   let (pkg_map2, unusable, sccs) = validateDatabase cfg pkg_map1 -  reportCycles   (printer 2) sccs-  reportUnusable (printer 2) unusable+  reportCycles   logger sccs+  reportUnusable logger unusable    -- Apply trust flags (these flags apply regardless of whether   -- or not packages are visible or not)@@ -1538,7 +1576,7 @@                                                  uv_renamings = [],                                                  uv_package_name = First (Just (fsPackageName p)),                                                  uv_requirements = Map.empty,-                                                 uv_explicit = False+                                                 uv_explicit = Nothing                                                }                                                vm                                else vm)@@ -1559,7 +1597,7 @@   -- it modifies the unit ids of wired in packages, but when we process   -- package arguments we need to key against the old versions.   ---  (pkgs2, wired_map) <- findWiredInUnits (printer 2) prec_map pkgs1 vis_map2+  (pkgs2, wired_map) <- findWiredInUnits logger prec_map pkgs1 vis_map2   let pkg_db = mkUnitInfoMap pkgs2    -- Update the visibility map, so we treat wired packages as visible.@@ -1601,7 +1639,7 @@   -- The requirement context is directly based off of this: we simply   -- look for nested unit IDs that are directly fed holes: the requirements   -- of those units are precisely the ones we need to track-  let explicit_pkgs = Map.keys vis_map+  let explicit_pkgs = [(k, uv_explicit v) | (k, v) <- Map.toList vis_map]       req_ctx = Map.map (Set.toList)               $ Map.unionsWith Set.union (map uv_requirements (Map.elems vis_map)) @@ -1616,7 +1654,7 @@   -- NB: preload IS important even for type-checking, because we   -- need the correct include path to be set.   ---  let preload1 = Map.keys (Map.filter uv_explicit vis_map)+  let preload1 = Map.keys (Map.filter (isJust . uv_explicit) vis_map)        -- add default preload units if they can be found in the db       basicLinkedUnits = fmap (RealUnit . Definite)@@ -1629,7 +1667,7 @@                     $ closeUnitDeps pkg_db                     $ zip (map toUnitId preload3) (repeat Nothing) -  let mod_map1 = mkModuleNameProvidersMap ctx cfg pkg_db emptyUniqSet vis_map+  let mod_map1 = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet vis_map       mod_map2 = mkUnusableModuleNameProvidersMap unusable       mod_map = Map.union mod_map1 mod_map2 @@ -1637,10 +1675,11 @@   let !state = UnitState          { preloadUnits                 = dep_preload          , explicitUnits                = explicit_pkgs+         , homeUnitDepends              = Set.toList home_unit_deps          , unitInfoMap                  = pkg_db          , preloadClosure               = emptyUniqSet          , moduleNameProvidersMap       = mod_map-         , pluginModuleNameProvidersMap = mkModuleNameProvidersMap ctx cfg pkg_db emptyUniqSet plugin_vis_map+         , pluginModuleNameProvidersMap = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet plugin_vis_map          , packageNameMap               = pkgname_map          , wireMap                      = wired_map          , unwireMap                    = Map.fromList [ (v,k) | (k,v) <- Map.toList wired_map ]@@ -1649,6 +1688,19 @@          }   return (state, raw_dbs) +selectHptFlag :: Set.Set UnitId -> PackageFlag -> Bool+selectHptFlag home_units (ExposePackage _ (UnitIdArg uid) _) | toUnitId uid `Set.member` home_units = True+selectHptFlag _ _ = False++selectHomeUnits :: Set.Set UnitId -> [PackageFlag] -> Set.Set UnitId+selectHomeUnits home_units flags = foldl' go Set.empty flags+  where+    go :: Set.Set UnitId -> PackageFlag -> Set.Set UnitId+    go cur (ExposePackage _ (UnitIdArg uid) _) | toUnitId uid `Set.member` home_units = Set.insert (toUnitId uid) cur+    -- MP: This does not yet support thinning/renaming+    go cur _ = cur++ -- | Given a wired-in 'Unit', "unwire" it into the 'Unit' -- that it was recorded as in the package database. unwireUnit :: UnitState -> Unit -> Unit@@ -1664,13 +1716,13 @@ -- packages a bit bothersome.  mkModuleNameProvidersMap-  :: SDocContext     -- ^ SDocContext used to render exception messages+  :: Logger   -> UnitConfig   -> UnitInfoMap   -> PreloadUnitClosure   -> VisibilityMap   -> ModuleNameProvidersMap-mkModuleNameProvidersMap ctx cfg pkg_map closure vis_map =+mkModuleNameProvidersMap logger cfg pkg_map closure vis_map =     -- What should we fold on?  Both situations are awkward:     --     --    * Folding on the visibility map means that we won't create@@ -1721,7 +1773,8 @@     rnBinding (orig, new) = (new, setOrigins origEntry fromFlag)      where origEntry = case lookupUFM esmap orig of             Just r -> r-            Nothing -> throwGhcException (CmdLineError (renderWithContext ctx+            Nothing -> throwGhcException (CmdLineError (renderWithContext+                        (log_default_user_context (logFlags logger))                         (text "package flag: could not find module name" <+>                             ppr orig <+> text "in package" <+> ppr pk))) @@ -1795,7 +1848,7 @@                           -> ModuleName                           -> [(Module, UnitInfo)] lookupModuleInAllUnits pkgs m-  = case lookupModuleWithSuggestions pkgs m Nothing of+  = case lookupModuleWithSuggestions pkgs m NoPkgQual of       LookupFound a b -> [(a,fst b)]       LookupMultiple rs -> map f rs         where f (m,_) = (m, expectJust "lookupModule" (lookupUnit pkgs@@ -1823,7 +1876,7 @@  lookupModuleWithSuggestions :: UnitState                             -> ModuleName-                            -> Maybe FastString+                            -> PkgQual                             -> LookupResult lookupModuleWithSuggestions pkgs   = lookupModuleWithSuggestions' pkgs (moduleNameProvidersMap pkgs)@@ -1831,7 +1884,7 @@ -- | The package which the module **appears** to come from, this could be -- the one which reexports the module from it's original package. This function -- is currently only used for -Wunused-packages-lookupModulePackage :: UnitState -> ModuleName -> Maybe FastString -> Maybe [UnitInfo]+lookupModulePackage :: UnitState -> ModuleName -> PkgQual -> Maybe [UnitInfo] lookupModulePackage pkgs mn mfs =     case lookupModuleWithSuggestions' pkgs (moduleNameProvidersMap pkgs) mn mfs of       LookupFound _ (orig_unit, origin) ->@@ -1850,7 +1903,7 @@  lookupPluginModuleWithSuggestions :: UnitState                                   -> ModuleName-                                  -> Maybe FastString+                                  -> PkgQual                                   -> LookupResult lookupPluginModuleWithSuggestions pkgs   = lookupModuleWithSuggestions' pkgs (pluginModuleNameProvidersMap pkgs)@@ -1858,7 +1911,7 @@ lookupModuleWithSuggestions' :: UnitState                             -> ModuleNameProvidersMap                             -> ModuleName-                            -> Maybe FastString+                            -> PkgQual                             -> LookupResult lookupModuleWithSuggestions' pkgs mod_map m mb_pn   = case Map.lookup m mod_map of@@ -1893,24 +1946,29 @@     -- Filters out origins which are not associated with the given package     -- qualifier.  No-op if there is no package qualifier.  Test if this     -- excluded all origins with 'originEmpty'.-    filterOrigin :: Maybe FastString+    filterOrigin :: PkgQual                  -> UnitInfo                  -> ModuleOrigin                  -> ModuleOrigin-    filterOrigin Nothing _ o = o-    filterOrigin (Just pn) pkg o =-      case o of-          ModHidden -> if go pkg then ModHidden else mempty-          (ModUnusable _) -> if go pkg then o else mempty+    filterOrigin NoPkgQual _ o = o+    filterOrigin (ThisPkg _) _ o = o+    filterOrigin (OtherPkg u) pkg o =+      let match_pkg p = u == unitId p+      in case o of+          ModHidden+            | match_pkg pkg -> ModHidden+            | otherwise     -> mempty+          ModUnusable _+            | match_pkg pkg -> o+            | otherwise     -> mempty           ModOrigin { fromOrigUnit = e, fromExposedReexport = res,                       fromHiddenReexport = rhs }-            -> ModOrigin {-                  fromOrigUnit = if go pkg then e else Nothing-                , fromExposedReexport = filter go res-                , fromHiddenReexport = filter go rhs-                , fromPackageFlag = False -- always excluded+            -> ModOrigin+                { fromOrigUnit        = if match_pkg pkg then e else Nothing+                , fromExposedReexport = filter match_pkg res+                , fromHiddenReexport  = filter match_pkg rhs+                , fromPackageFlag     = False -- always excluded                 }-      where go pkg = pn == fsPackageName pkg      suggestions = fuzzyLookup (moduleNameString m) all_mods @@ -2005,14 +2063,7 @@ -- to form @mod_name@, or @[]@ if this is not a requirement. requirementMerges :: UnitState -> ModuleName -> [InstantiatedModule] requirementMerges pkgstate mod_name =-    fmap fixupModule $ fromMaybe [] (Map.lookup mod_name (requirementContext pkgstate))-    where-      -- update IndefUnitId ppr info as they may have changed since the-      -- time the IndefUnitId was created-      fixupModule (Module iud name) = Module iud' name-         where-            iud' = iud { instUnitInstanceOf = cid' }-            cid' = instUnitInstanceOf iud+    fromMaybe [] (Map.lookup mod_name (requirementContext pkgstate))  -- ----------------------------------------------------------------------------- @@ -2020,7 +2071,7 @@ -- -- Cabal packages may contain several components (programs, libraries, etc.). -- As far as GHC is concerned, installed package components ("units") are--- identified by an opaque IndefUnitId string provided by Cabal. As the string+-- identified by an opaque UnitId string provided by Cabal. As the string -- contains a hash, we don't want to display it to users so GHC queries the -- database to retrieve some infos about the original source package (name, -- version, component name).@@ -2125,14 +2176,14 @@ type ShHoleSubst = ModuleNameEnv Module  -- | Substitutes holes in a 'Module'.  NOT suitable for being called--- directly on a 'nameModule', see Note [Representation of module/name variable].+-- directly on a 'nameModule', see Note [Representation of module/name variables]. -- @p[A=\<A>]:B@ maps to @p[A=q():A]:B@ with @A=q():A@; -- similarly, @\<A>@ maps to @q():A@. renameHoleModule :: UnitState -> ShHoleSubst -> Module -> Module renameHoleModule state = renameHoleModule' (unitInfoMap state) (preloadClosure state)  -- | Substitutes holes in a 'Unit', suitable for renaming when--- an include occurs; see Note [Representation of module/name variable].+-- an include occurs; see Note [Representation of module/name variables]. -- -- @p[A=\<A>]@ maps to @p[A=\<B>]@ with @A=\<B>@. renameHoleUnit :: UnitState -> ShHoleSubst -> Unit -> Unit@@ -2180,4 +2231,11 @@ pprWithUnitState state = updSDocContext (\ctx -> ctx    { sdocUnitIdForUser = \fs -> pprUnitIdForUser state (UnitId fs)    })++-- | Add package dependencies on the wired-in packages we use+implicitPackageDeps :: DynFlags -> [UnitId]+implicitPackageDeps dflags+   = [thUnitId | xopt TemplateHaskellQuotes dflags]+   -- TODO: Should also include `base` and `ghc-prim` if we use those implicitly, but+   -- it is possible to not depend on base (for example, see `ghc-prim`)
− GHC/Unit/State.hs-boot 
@@ -1,12 +0,0 @@-module GHC.Unit.State where--import {-# SOURCE #-} GHC.Utils.Outputable-import {-# SOURCE #-} GHC.Unit.Types (UnitId,Unit)--data UnitState-data UnitDatabase unit--emptyUnitState :: UnitState-pprUnitIdForUser :: UnitState -> UnitId -> SDoc-pprWithUnitState :: UnitState -> SDoc -> SDoc-unwireUnit :: UnitState -> Unit-> Unit
GHC/Unit/Types.hs view
@@ -14,8 +14,10 @@      GenModule (..)    , Module    , InstalledModule+   , HomeUnitModule    , InstantiatedModule    , mkModule+   , moduleUnitId    , pprModule    , pprInstantiatedModule    , moduleFreeHoles@@ -28,7 +30,6 @@    , UnitKey (..)    , GenInstantiatedUnit (..)    , InstantiatedUnit-   , IndefUnitId    , DefUnitId    , Instantiations    , GenInstantiations@@ -54,7 +55,6 @@       -- * Utils    , Definite (..)-   , Indefinite (..)       -- * Wired-in units    , primUnitId@@ -119,10 +119,17 @@ -- | A Module is a pair of a 'Unit' and a 'ModuleName'. type Module = GenModule Unit +moduleUnitId :: Module -> UnitId+moduleUnitId = toUnitId . moduleUnit+ -- | A 'InstalledModule' is a 'Module' whose unit is identified with an -- 'UnitId'. type InstalledModule = GenModule UnitId +-- | A 'HomeUnitModule' is like an 'InstalledModule' but we expect to find it in+-- one of the home units rather than the package database.+type HomeUnitModule  = GenModule UnitId+ -- | An `InstantiatedModule` is a 'Module' whose unit is identified with an `InstantiatedUnit`. type InstantiatedModule = GenModule InstantiatedUnit @@ -248,7 +255,7 @@ -- see Note [VirtUnit to RealUnit improvement]. -- -- An indefinite unit identifier pretty-prints to something like--- @p[H=<H>,A=aimpl:A>]@ (@p@ is the 'IndefUnitId', and the+-- @p[H=<H>,A=aimpl:A>]@ (@p@ is the 'UnitId', and the -- brackets enclose the module substitution). data GenInstantiatedUnit unit     = InstantiatedUnit {@@ -258,8 +265,8 @@         instUnitFS :: !FastString,         -- | Cached unique of 'unitFS'.         instUnitKey :: !Unique,-        -- | The indefinite unit being instantiated.-        instUnitInstanceOf :: !(Indefinite unit),+        -- | The (indefinite) unit being instantiated.+        instUnitInstanceOf :: !unit,         -- | The sorted (by 'ModuleName') instantiations of this unit.         instUnitInsts :: !(GenInstantiations unit),         -- | A cache of the free module holes of 'instUnitInsts'.@@ -290,7 +297,7 @@   u1 == u2 = instUnitKey u1 == instUnitKey u2  instance Ord (GenInstantiatedUnit unit) where-  u1 `compare` u2 = instUnitFS u1 `uniqCompareFS` instUnitFS u2+  u1 `compare` u2 = instUnitFS u1 `lexicalCompareFS` instUnitFS u2  instance Binary InstantiatedUnit where   put_ bh indef = do@@ -375,7 +382,7 @@   -- | Create a new 'GenInstantiatedUnit' given an explicit module substitution.-mkInstantiatedUnit :: IsUnitId u => Indefinite u -> GenInstantiations u -> GenInstantiatedUnit u+mkInstantiatedUnit :: IsUnitId u => u -> GenInstantiations u -> GenInstantiatedUnit u mkInstantiatedUnit cid insts =     InstantiatedUnit {         instUnitInstanceOf = cid,@@ -390,8 +397,8 @@   -- | Smart constructor for instantiated GenUnit-mkVirtUnit :: IsUnitId u => Indefinite u -> [(ModuleName, GenModule (GenUnit u))] -> GenUnit u-mkVirtUnit uid []    = RealUnit $ Definite (indefUnit uid) -- huh? indefinite unit without any instantiation/hole?+mkVirtUnit :: IsUnitId u => u -> [(ModuleName, GenModule (GenUnit u))] -> GenUnit u+mkVirtUnit uid []    = RealUnit $ Definite uid mkVirtUnit uid insts = VirtUnit $ mkInstantiatedUnit uid insts  -- | Generate a uniquely identifying hash (internal unit-id) for an instantiated@@ -402,7 +409,7 @@ -- This hash is completely internal to GHC and is not used for symbol names or -- file paths. It is different from the hash Cabal would produce for the same -- instantiated unit.-mkInstantiatedUnitHash :: IsUnitId u => Indefinite u -> [(ModuleName, GenModule (GenUnit u))] -> FastString+mkInstantiatedUnitHash :: IsUnitId u => u -> [(ModuleName, GenModule (GenUnit u))] -> FastString mkInstantiatedUnitHash cid sorted_holes =     mkFastStringByteString   . fingerprintUnitId (bytesFS (unitFS cid))@@ -451,7 +458,7 @@                RealUnit d -> RealUnit (fmap f d)                VirtUnit i ->                   VirtUnit $ mkInstantiatedUnit-                     (fmap f (instUnitInstanceOf i))+                     (f (instUnitInstanceOf i))                      (fmap (second (fmap go)) (instUnitInsts i))  -- | Map over the unit identifier of unit instantiations.@@ -462,7 +469,7 @@ -- the UnitId of the indefinite unit this unit is an instance of. toUnitId :: Unit -> UnitId toUnitId (RealUnit (Definite iuid)) = iuid-toUnitId (VirtUnit indef)           = indefUnit (instUnitInstanceOf indef)+toUnitId (VirtUnit indef)           = instUnitInstanceOf indef toUnitId HoleUnit                   = error "Hole unit"  -- | Return the virtual UnitId of an on-the-fly instantiated unit.@@ -489,12 +496,12 @@ -- libraries as we can cheaply instantiate them on-the-fly, cf VirtUnit).  Put -- another way, an installed unit id is either fully instantiated, or not -- instantiated at all.-newtype UnitId =-    UnitId {-      -- | The full hashed unit identifier, including the component id+newtype UnitId = UnitId+  { unitIdFS :: FastString+      -- ^ The full hashed unit identifier, including the component id       -- and the hash.-      unitIdFS :: FastString-    }+  }+  deriving (Data)  instance Binary UnitId where   put_ bh (UnitId fs) = put_ bh fs@@ -535,14 +542,6 @@    deriving (Functor)    deriving newtype (Eq, Ord, Outputable, Binary, Uniquable, IsUnitId) --- | An 'IndefUnitId' is an 'UnitId' with the invariant that it only--- refers to an indefinite library; i.e., one that can be instantiated.-type IndefUnitId = Indefinite UnitId--newtype Indefinite unit = Indefinite { indefUnit :: unit }-   deriving (Functor)-   deriving newtype (Eq, Ord, Outputable, Binary, Uniquable, IsUnitId)- --------------------------------------------------------------------- -- WIRED-IN UNITS ---------------------------------------------------------------------@@ -660,6 +659,9 @@   } deriving ( Eq, Ord, Show              , Functor, Foldable, Traversable              )+  -- the Ord instance must ensure that we first sort by Module and then by+  -- IsBootInterface: this is assumed to perform filtering of non-boot modules,+  -- e.g. in GHC.Driver.Env.hptModulesBelow  type ModuleNameWithIsBoot = GenWithIsBoot ModuleName
GHC/Unit/Types.hs-boot view
@@ -1,17 +1,17 @@+{-# LANGUAGE KindSignatures #-} module GHC.Unit.Types where  import GHC.Prelude () import {-# SOURCE #-} GHC.Utils.Outputable-import {-# SOURCE #-} GHC.Unit.Module.Name+import {-# SOURCE #-} GHC.Unit.Module.Name ( ModuleName )+import Data.Kind (Type)  data UnitId-data GenModule unit-data GenUnit uid-data Indefinite unit+data GenModule (unit :: Type)+data GenUnit (uid :: Type)  type Module      = GenModule  Unit type Unit        = GenUnit    UnitId-type IndefUnitId = Indefinite UnitId  moduleName :: GenModule a -> ModuleName moduleUnit :: GenModule a -> a
GHC/Utils/Binary.hs view
@@ -1,3 +1,4 @@+ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE PolyKinds #-}@@ -42,6 +43,8 @@    castBin,    withBinBuffer, +   foldGet,+    writeBinMem,    readBinMem, @@ -63,6 +66,8 @@    -- * Lazy Binary I/O    lazyGet,    lazyPut,+   lazyGetMaybe,+   lazyPutMaybe,     -- * User data    UserData(..), getUserData, setUserData,@@ -70,8 +75,6 @@    putDictionary, getDictionary, putFS,   ) where -#include "HsVersions.h"- import GHC.Prelude  import {-# SOURCE #-} GHC.Types.Name (Name)@@ -81,22 +84,31 @@ import GHC.Data.FastMutInt import GHC.Utils.Fingerprint import GHC.Types.SrcLoc+import qualified GHC.Data.Strict as Strict  import Control.DeepSeq import Foreign hiding (shiftL, shiftR) import Data.Array+import Data.Array.IO+import Data.Array.Unsafe import Data.ByteString (ByteString) import qualified Data.ByteString.Internal as BS import qualified Data.ByteString.Unsafe   as BS import Data.IORef import Data.Char                ( ord, chr )+import Data.List.NonEmpty       ( NonEmpty(..))+import qualified Data.List.NonEmpty as NonEmpty+import Data.Set                 ( Set )+import qualified Data.Set as Set import Data.Time import Data.List (unfoldr)-import Control.Monad            ( when, (<$!>), unless )+import Control.Monad            ( when, (<$!>), unless, forM_ ) import System.IO as IO import System.IO.Unsafe         ( unsafeInterleaveIO ) import System.IO.Error          ( mkIOError, eofErrorType ) import GHC.Real                 ( Ratio(..) )+import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap #if MIN_VERSION_base(4,15,0) import GHC.ForeignPtr           ( unsafeWithForeignPtr ) #endif@@ -163,15 +175,11 @@ setUserData bh us = bh { bh_usr = us }  -- | Get access to the underlying buffer.------ It is quite important that no references to the 'ByteString' leak out of the--- continuation lest terrible things happen. withBinBuffer :: BinHandle -> (ByteString -> IO a) -> IO a withBinBuffer (BinMem _ ix_r _ arr_r) action = do   arr <- readIORef arr_r   ix <- readFastMutInt ix_r-  withForeignPtr arr $ \ptr ->-    BS.unsafePackCStringLen (castPtr ptr, ix) >>= action+  action $ BS.fromForeignPtr arr 0 ix   ---------------------------------------------------------------@@ -271,6 +279,23 @@       | otherwise       = getSize (sz * 2) +foldGet+  :: Binary a+  => Word -- n elements+  -> BinHandle+  -> b -- initial accumulator+  -> (Word -> a -> b -> IO b)+  -> IO b+foldGet n bh init_b f = go 0 init_b+  where+    go i b+      | i == n    = return b+      | otherwise = do+          a <- get bh+          b' <- f i a b+          go (i+1) b'++ -- ----------------------------------------------------------------------------- -- Low-level reading/writing of bytes @@ -616,6 +641,16 @@             loop n = do a <- get bh; as <- loop (n-1); return (a:as)         loop len +-- | This instance doesn't rely on the determinism of the keys' 'Ord' instance,+-- so it works e.g. for 'Name's too.+instance (Binary a, Ord a) => Binary (Set a) where+  put_ bh s = put_ bh (Set.toList s)+  get bh = Set.fromList <$> get bh++instance Binary a => Binary (NonEmpty a) where+    put_ bh = put_ bh . NonEmpty.toList+    get bh = NonEmpty.fromList <$> get bh+ instance (Ix a, Binary a, Binary b) => Binary (Array a b) where     put_ bh arr = do         put_ bh $ bounds arr@@ -684,6 +719,15 @@                             0 -> return Nothing                             _ -> do x <- get bh; return (Just x) +instance Binary a => Binary (Strict.Maybe a) where+    put_ bh Strict.Nothing = putByte bh 0+    put_ bh (Strict.Just a) = do putByte bh 1; put_ bh a+    get bh =+      do h <- getWord8 bh+         case h of+           0 -> return Strict.Nothing+           _ -> do x <- get bh; return (Strict.Just x)+ instance (Binary a, Binary b) => Binary (Either a b) where     put_ bh (Left  a) = do putByte bh 0; put_ bh a     put_ bh (Right b) = do putByte bh 1; put_ bh b@@ -895,6 +939,25 @@     seekBin bh p -- skip over the object for now     return a +-- | Serialize the constructor strictly but lazily serialize a value inside a+-- 'Just'.+--+-- This way we can check for the presence of a value without deserializing the+-- value itself.+lazyPutMaybe :: Binary a => BinHandle -> Maybe a -> IO ()+lazyPutMaybe bh Nothing  = putWord8 bh 0+lazyPutMaybe bh (Just x) = do+  putWord8 bh 1+  lazyPut bh x++-- | Deserialize a value serialized by 'lazyPutMaybe'.+lazyGetMaybe :: Binary a => BinHandle -> IO (Maybe a)+lazyGetMaybe bh = do+  h <- getWord8 bh+  case h of+    0 -> pure Nothing+    _ -> Just <$> lazyGet bh+ -- ----------------------------------------------------------------------------- -- UserData -- -----------------------------------------------------------------------------@@ -980,9 +1043,12 @@  getDictionary :: BinHandle -> IO Dictionary getDictionary bh = do-  sz <- get bh-  elems <- sequence (take sz (repeat (getFS bh)))-  return (listArray (0,sz-1) elems)+  sz <- get bh :: IO Int+  mut_arr <- newArray_ (0, sz-1) :: IO (IOArray Int FastString)+  forM_ [0..(sz-1)] $ \i -> do+    fs <- getFS bh+    writeArray mut_arr i fs+  unsafeFreeze mut_arr  --------------------------------------------------------- -- The Symbol Table@@ -1240,6 +1306,19 @@             return (mkRealSrcSpan (mkRealSrcLoc f sl sc)                                   (mkRealSrcLoc f el ec)) +instance Binary BufPos where+  put_ bh (BufPos i) = put_ bh i+  get bh = BufPos <$> get bh++instance Binary BufSpan where+  put_ bh (BufSpan start end) = do+    put_ bh start+    put_ bh end+  get bh = do+    start <- get bh+    end <- get bh+    return (BufSpan start end)+ instance Binary UnhelpfulSpanReason where   put_ bh r = case r of     UnhelpfulNoLocationInfo -> putByte bh 0@@ -1258,11 +1337,10 @@       _ -> UnhelpfulOther <$> get bh  instance Binary SrcSpan where-  put_ bh (RealSrcSpan ss _sb) = do+  put_ bh (RealSrcSpan ss sb) = do           putByte bh 0-          -- BufSpan doesn't ever get serialised because the positions depend-          -- on build location.           put_ bh ss+          put_ bh sb    put_ bh (UnhelpfulSpan s) = do           putByte bh 1@@ -1272,6 +1350,15 @@           h <- getByte bh           case h of             0 -> do ss <- get bh-                    return (RealSrcSpan ss Nothing)+                    sb <- get bh+                    return (RealSrcSpan ss sb)             _ -> do s <- get bh                     return (UnhelpfulSpan s)++--------------------------------------------------------------------------------+-- Instances for the containers package+--------------------------------------------------------------------------------++instance (Binary v) => Binary (IntMap v) where+  put_ bh m = put_ bh (IntMap.toList m)+  get bh = IntMap.fromList <$> get bh
GHC/Utils/Binary/Typeable.hs view
@@ -1,10 +1,9 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE GADTs #-}  {-# OPTIONS_GHC -O2 -funbox-strict-fields #-}-{-# OPTIONS_GHC -Wno-orphans #-}+{-# OPTIONS_GHC -Wno-orphans -Wincomplete-patterns #-} #if MIN_VERSION_base(4,16,0) #define HAS_TYPELITCHAR #endif@@ -15,13 +14,11 @@    ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Utils.Binary -import GHC.Exts (TYPE, RuntimeRep(..), VecCount(..), VecElem(..))+import GHC.Exts (RuntimeRep(..), VecCount(..), VecElem(..)) #if __GLASGOW_HASKELL__ >= 901 import GHC.Exts (Levity(Lifted, Unlifted)) #endif@@ -51,7 +48,6 @@         1 -> do con <- get bh :: IO TyCon                 ks <- get bh :: IO [SomeTypeRep]                 return $ SomeTypeRep $ mkTrCon con ks-         2 -> do SomeTypeRep f <- getSomeTypeRep bh                 SomeTypeRep x <- getSomeTypeRep bh                 case typeRepKind f of@@ -70,20 +66,8 @@                        [ "    Applied type: " ++ show f                        , "    To argument:  " ++ show x                        ]-        3 -> do SomeTypeRep arg <- getSomeTypeRep bh-                SomeTypeRep res <- getSomeTypeRep bh-                if-                  | App argkcon _ <- typeRepKind arg-                  , App reskcon _ <- typeRepKind res-                  , Just HRefl <- argkcon `eqTypeRep` tYPErep-                  , Just HRefl <- reskcon `eqTypeRep` tYPErep-                  -> return $ SomeTypeRep $ Fun arg res-                  | otherwise -> failure "Kind mismatch" []         _ -> failure "Invalid SomeTypeRep" []   where-    tYPErep :: TypeRep TYPE-    tYPErep = typeRep-     failure description info =         fail $ unlines $ [ "Binary.getSomeTypeRep: "++description ]                       ++ map ("    "++) info@@ -203,10 +187,7 @@           _ -> fail "Binary.putTypeLitSort: invalid tag"  putTypeRep :: BinHandle -> TypeRep a -> IO ()--- Special handling for TYPE, (->), and RuntimeRep due to recursive kind--- relations.--- See Note [Mutually recursive representations of primitive types]-putTypeRep bh rep+putTypeRep bh rep -- Handle Type specially since it's so common   | Just HRefl <- rep `eqTypeRep` (typeRep :: TypeRep Type)   = put_ bh (0 :: Word8) putTypeRep bh (Con' con ks) = do@@ -217,10 +198,12 @@     put_ bh (2 :: Word8)     putTypeRep bh f     putTypeRep bh x+#if __GLASGOW_HASKELL__ < 903 putTypeRep bh (Fun arg res) = do     put_ bh (3 :: Word8)     putTypeRep bh arg     putTypeRep bh res+#endif  instance Binary Serialized where     put_ bh (Serialized the_type bytes) = do
+ GHC/Utils/Constants.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE CPP #-}++module GHC.Utils.Constants+  ( debugIsOn+  , ghciSupported+  , isWindowsHost+  , isDarwinHost+  )+where++import GHC.Prelude++{-++These booleans are global constants, set by CPP flags.  They allow us to+recompile a single module (this one) to change whether or not debug output+appears. They sometimes let us avoid even running CPP elsewhere.++It's important that the flags are literal constants (True/False). Then,+with -0, tests of the flags in other modules will simplify to the correct+branch of the conditional, thereby dropping debug code altogether when+the flags are off.+-}++ghciSupported :: Bool+#if defined(HAVE_INTERNAL_INTERPRETER)+ghciSupported = True+#else+ghciSupported = False+#endif++debugIsOn :: Bool+#if defined(DEBUG)+debugIsOn = True+#else+debugIsOn = False+#endif++isWindowsHost :: Bool+#if defined(mingw32_HOST_OS)+isWindowsHost = True+#else+isWindowsHost = False+#endif++isDarwinHost :: Bool+#if defined(darwin_HOST_OS)+isDarwinHost = True+#else+isDarwinHost = False+#endif
GHC/Utils/Error.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE BangPatterns    #-}-{-# LANGUAGE CPP             #-}+{-# LANGUAGE DeriveFunctor   #-} {-# LANGUAGE RankNTypes      #-} {-# LANGUAGE ViewPatterns    #-} @@ -11,38 +11,46 @@  module GHC.Utils.Error (         -- * Basic types-        Validity(..), andValid, allValid, isValid, getInvalids, orValid,+        Validity'(..), Validity, andValid, allValid, getInvalids,         Severity(..),          -- * Messages-        WarnMsg,+        Diagnostic(..),         MsgEnvelope(..),+        MessageClass(..),         SDoc,         DecoratedSDoc(unDecorated),-        Messages, ErrorMessages, WarningMessages,-        unionMessages,+        Messages,+        mkMessages, unionMessages,         errorsFound, isEmptyMessages,          -- ** Formatting         pprMessageBag, pprMsgEnvelopeBagWithLoc,+        pprMessages,         pprLocMsgEnvelope,         formatBulleted,          -- ** Construction-        emptyMessages, mkDecorated, mkLocMessage, mkLocMessageAnn, makeIntoWarning,-        mkMsgEnvelope, mkPlainMsgEnvelope, mkErr, mkLongMsgEnvelope, mkWarnMsg,-        mkPlainWarnMsg,-        mkLongWarnMsg,+        DiagOpts (..), diag_wopt, diag_fatal_wopt,+        emptyMessages, mkDecorated, mkLocMessage, mkLocMessageAnn,+        mkMsgEnvelope, mkPlainMsgEnvelope, mkPlainErrorMsgEnvelope,+        mkErrorMsgEnvelope,+        mkMCDiagnostic, errorDiagnostic, diagReasonSeverity, +        mkPlainError,+        mkPlainDiagnostic,+        mkDecoratedError,+        mkDecoratedDiagnostic,+        noHints,+         -- * Utilities-        doIfSet, doIfSet_dyn,         getCaretDiagnostic,          -- * Issuing messages during compilation         putMsg, printInfoForUser, printOutputForUser,         logInfo, logOutput,-        errorMsg, warningMsg,-        fatalErrorMsg, fatalErrorMsg'',+        errorMsg,+        fatalErrorMsg,         compilationProgressMsg,         showPass,         withTiming, withTimingSilent,@@ -54,24 +62,24 @@         sortMsgBag     ) where -#include "HsVersions.h"- import GHC.Prelude -import GHC.Driver.Session-import GHC.Driver.Ppr+import GHC.Driver.Flags  import GHC.Data.Bag+import qualified GHC.Data.EnumSet as EnumSet+import GHC.Data.EnumSet (EnumSet)+ import GHC.Utils.Exception import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Utils.Logger import GHC.Types.Error import GHC.Types.SrcLoc as SrcLoc  import System.Exit      ( ExitCode(..), exitWith ) import Data.List        ( sortBy )-import Data.Maybe       ( fromMaybe ) import Data.Function import Debug.Trace import Control.Monad@@ -80,31 +88,130 @@ import GHC.Conc         ( getAllocationCounter ) import System.CPUTime +data DiagOpts = DiagOpts+  { diag_warning_flags       :: !(EnumSet WarningFlag) -- ^ Enabled warnings+  , diag_fatal_warning_flags :: !(EnumSet WarningFlag) -- ^ Fatal warnings+  , diag_warn_is_error       :: !Bool                  -- ^ Treat warnings as errors+  , diag_reverse_errors      :: !Bool                  -- ^ Reverse error reporting order+  , diag_max_errors          :: !(Maybe Int)           -- ^ Max reported error count+  , diag_ppr_ctx             :: !SDocContext           -- ^ Error printing context+  }++diag_wopt :: WarningFlag -> DiagOpts -> Bool+diag_wopt wflag opts = wflag `EnumSet.member` diag_warning_flags opts++diag_fatal_wopt :: WarningFlag -> DiagOpts -> Bool+diag_fatal_wopt wflag opts = wflag `EnumSet.member` diag_fatal_warning_flags opts++-- | Computes the /right/ 'Severity' for the input 'DiagnosticReason' out of+-- the 'DiagOpts. This function /has/ to be called when a diagnostic is constructed,+-- i.e. with a 'DiagOpts \"snapshot\" taken as close as possible to where a+-- particular diagnostic message is built, otherwise the computed 'Severity' might+-- not be correct, due to the mutable nature of the 'DynFlags' in GHC.+diagReasonSeverity :: DiagOpts -> DiagnosticReason -> Severity+diagReasonSeverity opts reason = case reason of+  WarningWithFlag wflag+    | not (diag_wopt wflag opts) -> SevIgnore+    | diag_fatal_wopt wflag opts -> SevError+    | otherwise                  -> SevWarning+  WarningWithoutFlag+    | diag_warn_is_error opts -> SevError+    | otherwise             -> SevWarning+  ErrorWithoutFlag+    -> SevError+++-- | Make a 'MessageClass' for a given 'DiagnosticReason', consulting the+-- 'DiagOpts.+mkMCDiagnostic :: DiagOpts -> DiagnosticReason -> MessageClass+mkMCDiagnostic opts reason = MCDiagnostic (diagReasonSeverity opts reason) reason++-- | Varation of 'mkMCDiagnostic' which can be used when we are /sure/ the+-- input 'DiagnosticReason' /is/ 'ErrorWithoutFlag'.+errorDiagnostic :: MessageClass+errorDiagnostic = MCDiagnostic SevError ErrorWithoutFlag++--+-- Creating MsgEnvelope(s)+--++mk_msg_envelope+  :: Diagnostic e+  => Severity+  -> SrcSpan+  -> PrintUnqualified+  -> e+  -> MsgEnvelope e+mk_msg_envelope severity locn print_unqual err+ = MsgEnvelope { errMsgSpan = locn+               , errMsgContext = print_unqual+               , errMsgDiagnostic = err+               , errMsgSeverity = severity+               }++-- | Wrap a 'Diagnostic' in a 'MsgEnvelope', recording its location.+-- If you know your 'Diagnostic' is an error, consider using 'mkErrorMsgEnvelope',+-- which does not require looking at the 'DiagOpts'+mkMsgEnvelope+  :: Diagnostic e+  => DiagOpts+  -> SrcSpan+  -> PrintUnqualified+  -> e+  -> MsgEnvelope e+mkMsgEnvelope opts locn print_unqual err+ = mk_msg_envelope (diagReasonSeverity opts (diagnosticReason err)) locn print_unqual err++-- | Wrap a 'Diagnostic' in a 'MsgEnvelope', recording its location.+-- Precondition: the diagnostic is, in fact, an error. That is,+-- @diagnosticReason msg == ErrorWithoutFlag@.+mkErrorMsgEnvelope :: Diagnostic e+                   => SrcSpan+                   -> PrintUnqualified+                   -> e+                   -> MsgEnvelope e+mkErrorMsgEnvelope locn unqual msg =+ assert (diagnosticReason msg == ErrorWithoutFlag) $ mk_msg_envelope SevError locn unqual msg++-- | Variant that doesn't care about qualified/unqualified names.+mkPlainMsgEnvelope :: Diagnostic e+                   => DiagOpts+                   -> SrcSpan+                   -> e+                   -> MsgEnvelope e+mkPlainMsgEnvelope opts locn msg =+  mkMsgEnvelope opts locn alwaysQualify msg++-- | Variant of 'mkPlainMsgEnvelope' which can be used when we are /sure/ we+-- are constructing a diagnostic with a 'ErrorWithoutFlag' reason.+mkPlainErrorMsgEnvelope :: Diagnostic e+                        => SrcSpan+                        -> e+                        -> MsgEnvelope e+mkPlainErrorMsgEnvelope locn msg =+  mk_msg_envelope SevError locn alwaysQualify msg+ --------------------------data Validity-  = IsValid            -- ^ Everything is fine-  | NotValid SDoc    -- ^ A problem, and some indication of why+data Validity' a+  = IsValid      -- ^ Everything is fine+  | NotValid a   -- ^ A problem, and some indication of why+  deriving Functor -isValid :: Validity -> Bool-isValid IsValid       = True-isValid (NotValid {}) = False+-- | Monomorphic version of @Validity'@ specialised for 'SDoc's.+type Validity = Validity' SDoc -andValid :: Validity -> Validity -> Validity+andValid :: Validity' a -> Validity' a -> Validity' a andValid IsValid v = v andValid v _       = v  -- | If they aren't all valid, return the first-allValid :: [Validity] -> Validity+allValid :: [Validity' a] -> Validity' a allValid []       = IsValid allValid (v : vs) = v `andValid` allValid vs -getInvalids :: [Validity] -> [SDoc]+getInvalids :: [Validity' a] -> [a] getInvalids vs = [d | NotValid d <- vs] -orValid :: Validity -> Validity -> Validity-orValid IsValid _ = IsValid-orValid _       v = v- -- ----------------------------------------------------------------------------- -- Collecting up messages for later ordering and printing. @@ -120,80 +227,67 @@     msgs    = filter (not . Outputable.isEmpty ctx) docs     starred = (bullet<+>) -pprMsgEnvelopeBagWithLoc :: Bag (MsgEnvelope DecoratedSDoc) -> [SDoc]+pprMessages :: Diagnostic e => Messages e -> SDoc+pprMessages = vcat . pprMsgEnvelopeBagWithLoc . getMessages++pprMsgEnvelopeBagWithLoc :: Diagnostic e => Bag (MsgEnvelope e) -> [SDoc] pprMsgEnvelopeBagWithLoc bag = [ pprLocMsgEnvelope item | item <- sortMsgBag Nothing bag ] -pprLocMsgEnvelope :: RenderableDiagnostic e => MsgEnvelope e -> SDoc+pprLocMsgEnvelope :: Diagnostic e => MsgEnvelope e -> SDoc pprLocMsgEnvelope (MsgEnvelope { errMsgSpan      = s                                , errMsgDiagnostic = e                                , errMsgSeverity  = sev                                , errMsgContext   = unqual })   = sdocWithContext $ \ctx ->-    withErrStyle unqual $ mkLocMessage sev s (formatBulleted ctx $ renderDiagnostic e)+    withErrStyle unqual $+      mkLocMessage (MCDiagnostic sev (diagnosticReason e)) s (formatBulleted ctx $ diagnosticMessage e) -sortMsgBag :: Maybe DynFlags -> Bag (MsgEnvelope e) -> [MsgEnvelope e]-sortMsgBag dflags = maybeLimit . sortBy (cmp `on` errMsgSpan) . bagToList-  where cmp-          | fromMaybe False (fmap reverseErrors dflags) = SrcLoc.rightmost_smallest-          | otherwise                                   = SrcLoc.leftmost_smallest-        maybeLimit = case join (fmap maxErrors dflags) of-          Nothing        -> id-          Just err_limit -> take err_limit+sortMsgBag :: Maybe DiagOpts -> Bag (MsgEnvelope e) -> [MsgEnvelope e]+sortMsgBag mopts = maybeLimit . sortBy (cmp `on` errMsgSpan) . bagToList+  where+    cmp+      | Just opts <- mopts+      , diag_reverse_errors opts+      = SrcLoc.rightmost_smallest+      | otherwise+      = SrcLoc.leftmost_smallest+    maybeLimit+      | Just opts <- mopts+      , Just err_limit <- diag_max_errors opts+      = take err_limit+      | otherwise+      = id -ghcExit :: Logger -> DynFlags -> Int -> IO ()-ghcExit logger dflags val+ghcExit :: Logger -> Int -> IO ()+ghcExit logger val   | val == 0  = exitWith ExitSuccess-  | otherwise = do errorMsg logger dflags (text "\nCompilation had errors\n\n")+  | otherwise = do errorMsg logger (text "\nCompilation had errors\n\n")                    exitWith (ExitFailure val) -doIfSet :: Bool -> IO () -> IO ()-doIfSet flag action | flag      = action-                    | otherwise = return ()--doIfSet_dyn :: DynFlags -> GeneralFlag -> IO () -> IO()-doIfSet_dyn dflags flag action | gopt flag dflags = action-                               | otherwise        = return ()- -- ----------------------------------------------------------------------------- -- Outputting messages from the compiler --- We want all messages to go through one place, so that we can--- redirect them if necessary.  For example, when GHC is used as a--- library we might want to catch all messages that GHC tries to--- output and do something else with them.--ifVerbose :: DynFlags -> Int -> IO () -> IO ()-ifVerbose dflags val act-  | verbosity dflags >= val = act-  | otherwise               = return ()-{-# INLINE ifVerbose #-}  -- see Note [INLINE conditional tracing utilities]--errorMsg :: Logger -> DynFlags -> SDoc -> IO ()-errorMsg logger dflags msg-   = putLogMsg logger dflags NoReason SevError noSrcSpan $ withPprStyle defaultErrStyle msg--warningMsg :: Logger -> DynFlags -> SDoc -> IO ()-warningMsg logger dflags msg-   = putLogMsg logger dflags NoReason SevWarning noSrcSpan $ withPprStyle defaultErrStyle msg--fatalErrorMsg :: Logger -> DynFlags -> SDoc -> IO ()-fatalErrorMsg logger dflags msg =-    putLogMsg logger dflags NoReason SevFatal noSrcSpan $ withPprStyle defaultErrStyle msg+errorMsg :: Logger -> SDoc -> IO ()+errorMsg logger msg+   = logMsg logger errorDiagnostic noSrcSpan $+     withPprStyle defaultErrStyle msg -fatalErrorMsg'' :: FatalMessager -> String -> IO ()-fatalErrorMsg'' fm msg = fm msg+fatalErrorMsg :: Logger -> SDoc -> IO ()+fatalErrorMsg logger msg =+    logMsg logger MCFatal noSrcSpan $ withPprStyle defaultErrStyle msg -compilationProgressMsg :: Logger -> DynFlags -> SDoc -> IO ()-compilationProgressMsg logger dflags msg = do-    let str = showSDoc dflags msg-    traceEventIO $ "GHC progress: " ++ str-    ifVerbose dflags 1 $-        logOutput logger dflags $ withPprStyle defaultUserStyle msg+compilationProgressMsg :: Logger -> SDoc -> IO ()+compilationProgressMsg logger msg = do+  let logflags = logFlags logger+  let str = renderWithContext (log_default_user_context logflags) (text "GHC progress: " <> msg)+  traceEventIO str+  when (logVerbAtLeast logger 1) $+    logOutput logger $ withPprStyle defaultUserStyle msg -showPass :: Logger -> DynFlags -> String -> IO ()-showPass logger dflags what-  = ifVerbose dflags 2 $-    logInfo logger dflags $ withPprStyle defaultUserStyle (text "***" <+> text what <> colon)+showPass :: Logger -> String -> IO ()+showPass logger what =+  when (logVerbAtLeast logger 2) $+    logInfo logger $ withPprStyle defaultUserStyle (text "***" <+> text what <> colon)  data PrintTimings = PrintTimings | DontPrintTimings   deriving (Eq, Show)@@ -224,14 +318,13 @@ -- See Note [withTiming] for more. withTiming :: MonadIO m            => Logger-           -> DynFlags     -- ^ DynFlags            -> SDoc         -- ^ The name of the phase            -> (a -> ())    -- ^ A function to force the result                            -- (often either @const ()@ or 'rnf')            -> m a          -- ^ The body of the phase to be timed            -> m a-withTiming logger dflags what force action =-  withTiming' logger dflags what force PrintTimings action+withTiming logger what force action =+  withTiming' logger what force PrintTimings action  -- | Same as 'withTiming', but doesn't print timings in the --   console (when given @-vN@, @N >= 2@ or @-ddump-timings@).@@ -240,31 +333,29 @@ withTimingSilent   :: MonadIO m   => Logger-  -> DynFlags   -- ^ DynFlags   -> SDoc       -- ^ The name of the phase   -> (a -> ())  -- ^ A function to force the result                 -- (often either @const ()@ or 'rnf')   -> m a        -- ^ The body of the phase to be timed   -> m a-withTimingSilent logger dflags what force action =-  withTiming' logger dflags what force DontPrintTimings action+withTimingSilent logger what force action =+  withTiming' logger what force DontPrintTimings action  -- | Worker for 'withTiming' and 'withTimingSilent'. withTiming' :: MonadIO m             => Logger-            -> DynFlags   -- ^ 'DynFlags'             -> SDoc         -- ^ The name of the phase             -> (a -> ())    -- ^ A function to force the result                             -- (often either @const ()@ or 'rnf')             -> PrintTimings -- ^ Whether to print the timings             -> m a          -- ^ The body of the phase to be timed             -> m a-withTiming' logger dflags what force_result prtimings action-  = if verbosity dflags >= 2 || dopt Opt_D_dump_timings dflags+withTiming' logger what force_result prtimings action+  = if logVerbAtLeast logger 2 || logHasDumpFlag logger Opt_D_dump_timings     then do whenPrintTimings $-              logInfo logger dflags $ withPprStyle defaultUserStyle $+              logInfo logger $ withPprStyle defaultUserStyle $                 text "***" <+> what <> colon-            let ctx = initDefaultSDocContext dflags+            let ctx = log_default_user_context (logFlags logger)             alloc0 <- liftIO getAllocationCounter             start <- liftIO getCPUTime             eventBegins ctx what@@ -279,8 +370,8 @@             let alloc = alloc0 - alloc1                 time = realToFrac (end - start) * 1e-9 -            when (verbosity dflags >= 2 && prtimings == PrintTimings)-                $ liftIO $ logInfo logger dflags $ withPprStyle defaultUserStyle+            when (logVerbAtLeast logger 2 && prtimings == PrintTimings)+                $ liftIO $ logInfo logger $ withPprStyle defaultUserStyle                     (text "!!!" <+> what <> colon <+> text "finished in"                      <+> doublePrec 2 time                      <+> text "milliseconds"@@ -290,7 +381,7 @@                      <+> text "megabytes")              whenPrintTimings $-                dumpIfSet_dyn logger dflags Opt_D_dump_timings "" FormatText+                putDumpFileMaybe logger Opt_D_dump_timings "" FormatText                     $ text $ showSDocOneLine ctx                     $ hsep [ what <> colon                            , text "alloc=" <> ppr alloc@@ -317,65 +408,57 @@           eventBeginsDoc ctx w = showSDocOneLine ctx $ text "GHC:started:" <+> w           eventEndsDoc   ctx w = showSDocOneLine ctx $ text "GHC:finished:" <+> w -debugTraceMsg :: Logger -> DynFlags -> Int -> SDoc -> IO ()-debugTraceMsg logger dflags val msg =-   ifVerbose dflags val $-      logInfo logger dflags (withPprStyle defaultDumpStyle msg)+debugTraceMsg :: Logger -> Int -> SDoc -> IO ()+debugTraceMsg logger val msg =+   when (log_verbosity (logFlags logger) >= val) $+      logInfo logger (withPprStyle defaultDumpStyle msg) {-# INLINE debugTraceMsg #-}  -- see Note [INLINE conditional tracing utilities] -putMsg :: Logger -> DynFlags -> SDoc -> IO ()-putMsg logger dflags msg = logInfo logger dflags (withPprStyle defaultUserStyle msg)+putMsg :: Logger -> SDoc -> IO ()+putMsg logger msg = logInfo logger (withPprStyle defaultUserStyle msg) -printInfoForUser :: Logger -> DynFlags -> PrintUnqualified -> SDoc -> IO ()-printInfoForUser logger dflags print_unqual msg-  = logInfo logger dflags (withUserStyle print_unqual AllTheWay msg)+printInfoForUser :: Logger -> PrintUnqualified -> SDoc -> IO ()+printInfoForUser logger print_unqual msg+  = logInfo logger (withUserStyle print_unqual AllTheWay msg) -printOutputForUser :: Logger -> DynFlags -> PrintUnqualified -> SDoc -> IO ()-printOutputForUser logger dflags print_unqual msg-  = logOutput logger dflags (withUserStyle print_unqual AllTheWay msg)+printOutputForUser :: Logger -> PrintUnqualified -> SDoc -> IO ()+printOutputForUser logger print_unqual msg+  = logOutput logger (withUserStyle print_unqual AllTheWay msg) -logInfo :: Logger -> DynFlags -> SDoc -> IO ()-logInfo logger dflags msg-  = putLogMsg logger dflags NoReason SevInfo noSrcSpan msg+logInfo :: Logger -> SDoc -> IO ()+logInfo logger msg = logMsg logger MCInfo noSrcSpan msg  -- | Like 'logInfo' but with 'SevOutput' rather then 'SevInfo'-logOutput :: Logger -> DynFlags -> SDoc -> IO ()-logOutput logger dflags msg-  = putLogMsg logger dflags NoReason SevOutput noSrcSpan msg+logOutput :: Logger -> SDoc -> IO ()+logOutput logger msg = logMsg logger MCOutput noSrcSpan msg -prettyPrintGhcErrors :: ExceptionMonad m => DynFlags -> m a -> m a-prettyPrintGhcErrors dflags-    = MC.handle $ \e -> case e of-                      PprPanic str doc ->-                          pprDebugAndThen ctx panic (text str) doc-                      PprSorry str doc ->-                          pprDebugAndThen ctx sorry (text str) doc-                      PprProgramError str doc ->-                          pprDebugAndThen ctx pgmError (text str) doc-                      _ ->-                          liftIO $ throwIO e-      where-         ctx = initSDocContext dflags defaultUserStyle -traceCmd :: Logger -> DynFlags -> String -> String -> IO a -> IO a--- trace the command (at two levels of verbosity)-traceCmd logger dflags phase_name cmd_line action- = do   { let verb = verbosity dflags-        ; showPass logger dflags phase_name-        ; debugTraceMsg logger dflags 3 (text cmd_line)-        ; case flushErr dflags of-              FlushErr io -> io+prettyPrintGhcErrors :: ExceptionMonad m => Logger -> m a -> m a+prettyPrintGhcErrors logger = do+  let ctx = log_default_user_context (logFlags logger)+  MC.handle $ \e -> case e of+    PprPanic str doc ->+        pprDebugAndThen ctx panic (text str) doc+    PprSorry str doc ->+        pprDebugAndThen ctx sorry (text str) doc+    PprProgramError str doc ->+        pprDebugAndThen ctx pgmError (text str) doc+    _ -> liftIO $ throwIO e -           -- And run it!-        ; action `catchIO` handle_exn verb-        }-  where-    handle_exn _verb exn = do { debugTraceMsg logger dflags 2 (char '\n')-                              ; debugTraceMsg logger dflags 2-                                (text "Failed:"-                                 <+> text cmd_line-                                 <+> text (show exn))-                              ; throwGhcExceptionIO (ProgramError (show exn))}+-- | Trace a command (when verbosity level >= 3)+traceCmd :: Logger -> String -> String -> IO a -> IO a+traceCmd logger phase_name cmd_line action = do+  showPass logger phase_name+  let+    cmd_doc = text cmd_line+    handle_exn exn = do+      debugTraceMsg logger 2 (char '\n')+      debugTraceMsg logger 2 (text "Failed:" <+> cmd_doc <+> text (show exn))+      throwGhcExceptionIO (ProgramError (show exn))+  debugTraceMsg logger 3 cmd_doc+  loggerTraceFlush logger+   -- And run it!+  action `catchIO` handle_exn  {- Note [withTiming] ~~~~~~~~~~~~~~~~~~~~@@ -438,16 +521,8 @@ Producing an eventlog for GHC ----------------------------- -To actually produce the eventlog, you need an eventlog-capable GHC build:--  With Hadrian:-  $ hadrian/build -j "stage1.ghc-bin.ghc.link.opts += -eventlog"--  With Make:-  $ make -j GhcStage2HcOpts+=-eventlog--You can then produce an eventlog when compiling say hello.hs by simply-doing:+You can produce an eventlog when compiling, for instance, hello.hs by simply+running:    If GHC was built by Hadrian:   $ _build/stage1/bin/ghc -ddump-timings hello.hs -o hello +RTS -l@@ -472,5 +547,3 @@ spent in each label).  -}--
GHC/Utils/Exception.hs view
@@ -10,13 +10,14 @@  import GHC.Prelude -import Control.Exception as CE+import GHC.IO (catchException)+import Control.Exception as CE hiding (assert) import Control.Monad.IO.Class import Control.Monad.Catch  -- Monomorphised versions of exception-handling utilities catchIO :: IO a -> (IOException -> IO a) -> IO a-catchIO = CE.catch+catchIO = catchException  handleIO :: (IOException -> IO a) -> IO a -> IO a handleIO = flip catchIO
GHC/Utils/Fingerprint.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}  -- ----------------------------------------------------------------------------@@ -21,8 +21,6 @@         fingerprintString,         getFileHash    ) where--#include "HsVersions.h"  import GHC.Prelude
GHC/Utils/GlobalVars.hs view
@@ -3,6 +3,9 @@ {-# OPTIONS_GHC -fno-cse #-} -- -fno-cse is needed for GLOBAL_VAR's to behave properly +-- | Do not use global variables!+--+-- Global variables are a hack. Do not use them if you can help it. module GHC.Utils.GlobalVars    ( v_unsafeHasPprDebug    , v_unsafeHasNoDebugOutput@@ -19,8 +22,6 @@    ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Conc.Sync ( sharedCAF )@@ -29,13 +30,34 @@ import Data.IORef import Foreign (Ptr) +#define GLOBAL_VAR(name,value,ty)  \+{-# NOINLINE name #-};             \+name :: IORef (ty);                \+name = global (value); ------------------------------------------------------------------------------ Do not use global variables!------ Global variables are a hack. Do not use them if you can help it.+#define GLOBAL_VAR_M(name,value,ty) \+{-# NOINLINE name #-};              \+name :: IORef (ty);                 \+name = globalM (value); -#if GHC_STAGE < 2++#define SHARED_GLOBAL_VAR(name,accessor,saccessor,value,ty) \+{-# NOINLINE name #-};                                      \+name :: IORef (ty);                                         \+name = sharedGlobal (value) (accessor);                     \+foreign import ccall unsafe saccessor                       \+  accessor :: Ptr (IORef a) -> IO (Ptr (IORef a));++#define SHARED_GLOBAL_VAR_M(name,accessor,saccessor,value,ty)  \+{-# NOINLINE name #-};                                         \+name :: IORef (ty);                                            \+name = sharedGlobalM (value) (accessor);                       \+foreign import ccall unsafe saccessor                          \+  accessor :: Ptr (IORef a) -> IO (Ptr (IORef a));++++#if !MIN_VERSION_GLASGOW_HASKELL(9,3,0,0)  GLOBAL_VAR(v_unsafeHasPprDebug,      False, Bool) GLOBAL_VAR(v_unsafeHasNoDebugOutput, False, Bool)
GHC/Utils/IO/Unsafe.hs view
@@ -2,14 +2,12 @@ (c) The University of Glasgow, 2000-2006 -} -{-# LANGUAGE CPP, MagicHash, UnboxedTuples #-}+{-# LANGUAGE MagicHash, UnboxedTuples #-}  module GHC.Utils.IO.Unsafe    ( inlinePerformIO,    ) where--#include "HsVersions.h"  import GHC.Prelude ()
GHC/Utils/Json.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE GADTs #-}+{-# LANGUAGE FlexibleInstances #-} module GHC.Utils.Json where  import GHC.Prelude@@ -29,7 +30,7 @@     JSObject fs -> braces $ pprList renderField fs   where     renderField :: (String, JsonDoc) -> SDoc-    renderField (s, j) = doubleQuotes (text s) <>  colon <+> renderJSON j+    renderField (s, j) = doubleQuotes (text s) <>  colon <> renderJSON j      pprList pp xs = hcat (punctuate comma (map pp xs)) @@ -54,3 +55,9 @@  class ToJson a where   json :: a -> JsonDoc++instance ToJson String where+  json = JSString . escapeJsonString++instance ToJson Int where+  json = JSInt
GHC/Utils/Logger.hs view
@@ -1,20 +1,34 @@ {-# LANGUAGE RankNTypes #-}  -- | Logger+--+-- The Logger is an configurable entity that is used by the compiler to output+-- messages on the console (stdout, stderr) and in dump files.+--+-- The behaviour of default Logger returned by `initLogger` can be modified with+-- hooks. The compiler itself uses hooks in multithreaded code (--make) and it+-- is also probably used by ghc-api users (IDEs, etc.).+--+-- In addition to hooks, the Logger suppors LogFlags: basically a subset of the+-- command-line flags that control the logger behaviour at a higher level than+-- hooks.+--+--  1. Hooks are used to define how to generate a info/warning/error/dump messages+--  2. LogFlags are used to decide when and how to generate messages+-- module GHC.Utils.Logger     ( Logger-    , initLogger     , HasLogger (..)     , ContainsLogger (..)++    -- * Logger setup+    , initLogger     , LogAction     , DumpAction     , TraceAction     , DumpFormat (..)-    , putLogMsg-    , putDumpMsg-    , putTraceMsg -    -- * Hooks+    -- ** Hooks     , popLogHook     , pushLogHook     , popDumpHook@@ -23,28 +37,46 @@     , pushTraceHook     , makeThreadSafe +    -- ** Flags+    , LogFlags (..)+    , defaultLogFlags+    , log_dopt+    , log_set_dopt+    , setLogFlags+    , updateLogFlags+    , logFlags+    , logHasDumpFlag+    , logVerbAtLeast+     -- * Logging     , jsonLogAction+    , putLogMsg     , defaultLogAction     , defaultLogActionHPrintDoc     , defaultLogActionHPutStrDoc+    , logMsg+    , logDumpMsg      -- * Dumping     , defaultDumpAction+    , putDumpFile+    , putDumpFileMaybe+    , putDumpFileMaybe'     , withDumpFileHandle     , touchDumpFile-    , dumpIfSet-    , dumpIfSet_dyn-    , dumpIfSet_dyn_printer+    , logDumpFile      -- * Tracing     , defaultTraceAction+    , putTraceMsg+    , loggerTraceFlushUpdate+    , loggerTraceFlush+    , logTraceMsg     ) where  import GHC.Prelude-import GHC.Driver.Session-import GHC.Driver.Ppr+import GHC.Driver.Flags import GHC.Types.Error import GHC.Types.SrcLoc @@ -53,26 +85,96 @@ import GHC.Utils.Json import GHC.Utils.Panic +import GHC.Data.EnumSet (EnumSet)+import qualified GHC.Data.EnumSet as EnumSet+ import Data.IORef import System.Directory import System.FilePath  ( takeDirectory, (</>) ) import qualified Data.Set as Set import Data.Set (Set) import Data.List (intercalate, stripPrefix)+import qualified Data.List.NonEmpty as NE import Data.Time import System.IO import Control.Monad import Control.Concurrent.MVar import System.IO.Unsafe+import Debug.Trace (trace) -type LogAction = DynFlags-              -> WarnReason-              -> Severity+---------------------------------------------------------------+-- Log flags+---------------------------------------------------------------++-- | Logger flags+data LogFlags = LogFlags+  { log_default_user_context :: SDocContext+  , log_default_dump_context :: SDocContext+  , log_dump_flags           :: !(EnumSet DumpFlag) -- ^ Dump flags+  , log_show_caret           :: !Bool               -- ^ Show caret in diagnostics+  , log_show_warn_groups     :: !Bool               -- ^ Show warning flag groups+  , log_enable_timestamps    :: !Bool               -- ^ Enable timestamps+  , log_dump_to_file         :: !Bool               -- ^ Enable dump to file+  , log_dump_dir             :: !(Maybe FilePath)   -- ^ Dump directory+  , log_dump_prefix          :: !FilePath           -- ^ Normal dump path ("basename.")+  , log_dump_prefix_override :: !(Maybe FilePath)   -- ^ Overriden dump path+  , log_enable_debug         :: !Bool               -- ^ Enable debug output+  , log_verbosity            :: !Int                -- ^ Verbosity level+  }++-- | Default LogFlags+defaultLogFlags :: LogFlags+defaultLogFlags = LogFlags+  { log_default_user_context = defaultSDocContext+  , log_default_dump_context = defaultSDocContext+  , log_dump_flags           = EnumSet.empty+  , log_show_caret           = True+  , log_show_warn_groups     = True+  , log_enable_timestamps    = True+  , log_dump_to_file         = False+  , log_dump_dir             = Nothing+  , log_dump_prefix          = ""+  , log_dump_prefix_override = Nothing+  , log_enable_debug         = False+  , log_verbosity            = 0+  }++-- | Test if a DumpFlag is enabled+log_dopt :: DumpFlag -> LogFlags -> Bool+log_dopt f logflags = f `EnumSet.member` log_dump_flags logflags++-- | Enable a DumpFlag+log_set_dopt :: DumpFlag -> LogFlags -> LogFlags+log_set_dopt f logflags = logflags { log_dump_flags = EnumSet.insert f (log_dump_flags logflags) }++-- | Test if a DumpFlag is set+logHasDumpFlag :: Logger -> DumpFlag -> Bool+logHasDumpFlag logger f = log_dopt f (logFlags logger)++-- | Test if verbosity is >= to the given value+logVerbAtLeast :: Logger -> Int -> Bool+logVerbAtLeast logger v = log_verbosity (logFlags logger) >= v++-- | Update LogFlags+updateLogFlags :: Logger -> (LogFlags -> LogFlags) -> Logger+updateLogFlags logger f = setLogFlags logger (f (logFlags logger))++-- | Set LogFlags+setLogFlags :: Logger -> LogFlags -> Logger+setLogFlags logger flags = logger { logFlags = flags }+++---------------------------------------------------------------+-- Logger+---------------------------------------------------------------++type LogAction = LogFlags+              -> MessageClass               -> SrcSpan               -> SDoc               -> IO () -type DumpAction = DynFlags+type DumpAction = LogFlags                -> PprStyle                -> DumpFlag                -> String@@ -80,7 +182,7 @@                -> SDoc                -> IO () -type TraceAction a = DynFlags -> String -> SDoc -> a -> a+type TraceAction a = LogFlags -> String -> SDoc -> a -> a  -- | Format of a dump --@@ -113,8 +215,28 @@      , generated_dumps :: DumpCache         -- ^ Already dumped files (to append instead of overwriting them)++    , trace_flush :: IO ()+        -- ^ Flush the trace buffer++    , logFlags :: !LogFlags+        -- ^ Logger flags     } +-- | Set the trace flushing function+--+-- The currently set trace flushing function is passed to the updating function+loggerTraceFlushUpdate :: Logger -> (IO () -> IO ()) -> Logger+loggerTraceFlushUpdate logger upd = logger { trace_flush = upd (trace_flush logger) }++-- | Calls the trace flushing function+loggerTraceFlush :: Logger -> IO ()+loggerTraceFlush logger = trace_flush logger++-- | Default trace flushing function (flush stderr)+defaultTraceFlush :: IO ()+defaultTraceFlush = hFlush stderr+ initLogger :: IO Logger initLogger = do     dumps <- newIORef Set.empty@@ -123,6 +245,8 @@         , dump_hook       = []         , trace_hook      = []         , generated_dumps = dumps+        , trace_flush     = defaultTraceFlush+        , logFlags        = defaultLogFlags         }  -- | Log something@@ -130,8 +254,8 @@ putLogMsg logger = foldr ($) defaultLogAction (log_hook logger)  -- | Dump something-putDumpMsg :: Logger -> DumpAction-putDumpMsg logger =+putDumpFile :: Logger -> DumpAction+putDumpFile logger =     let         fallback = putLogMsg logger         dumps    = generated_dumps logger@@ -181,15 +305,15 @@         with_lock :: forall a. IO a -> IO a         with_lock act = withMVar lock (const act) -        log action dflags reason sev loc doc =-            with_lock (action dflags reason sev loc doc)+        log action logflags msg_class loc doc =+            with_lock (action logflags msg_class loc doc) -        dmp action dflags sty opts str fmt doc =-            with_lock (action dflags sty opts str fmt doc)+        dmp action logflags sty opts str fmt doc =+            with_lock (action logflags sty opts str fmt doc)          trc :: forall a. TraceAction a -> TraceAction a-        trc action dflags str doc v =-            unsafePerformIO (with_lock (return $! action dflags str doc v))+        trc action logflags str doc v =+            unsafePerformIO (with_lock (return $! action logflags str doc v))      return $ pushLogHook log            $ pushDumpHook dmp@@ -199,87 +323,86 @@ -- See Note [JSON Error Messages] -- jsonLogAction :: LogAction-jsonLogAction dflags reason severity srcSpan msg+jsonLogAction _ (MCDiagnostic SevIgnore _) _ _ = return () -- suppress the message+jsonLogAction logflags msg_class srcSpan msg   =-    defaultLogActionHPutStrDoc dflags True stdout+    defaultLogActionHPutStrDoc logflags True stdout       (withPprStyle (PprCode CStyle) (doc $$ text ""))     where-      str = renderWithContext (initSDocContext dflags defaultUserStyle) msg+      str = renderWithContext (log_default_user_context logflags) msg       doc = renderJSON $               JSObject [ ( "span", json srcSpan )                        , ( "doc" , JSString str )-                       , ( "severity", json severity )-                       , ( "reason" ,   json reason )+                       , ( "messageClass", json msg_class )                        ] - defaultLogAction :: LogAction-defaultLogAction dflags reason severity srcSpan msg-  | dopt Opt_D_dump_json dflags = jsonLogAction dflags reason severity srcSpan msg-  | otherwise = case severity of-      SevOutput      -> printOut msg-      SevDump        -> printOut (msg $$ blankLine)-      SevInteractive -> putStrSDoc msg-      SevInfo        -> printErrs msg-      SevFatal       -> printErrs msg-      SevWarning     -> printWarns-      SevError       -> printWarns+defaultLogAction logflags msg_class srcSpan msg+  | log_dopt Opt_D_dump_json logflags = jsonLogAction logflags msg_class srcSpan msg+  | otherwise = case msg_class of+      MCOutput                 -> printOut msg+      MCDump                   -> printOut (msg $$ blankLine)+      MCInteractive            -> putStrSDoc msg+      MCInfo                   -> printErrs msg+      MCFatal                  -> printErrs msg+      MCDiagnostic SevIgnore _ -> pure () -- suppress the message+      MCDiagnostic sev rea     -> printDiagnostics sev rea     where-      printOut   = defaultLogActionHPrintDoc  dflags False stdout-      printErrs  = defaultLogActionHPrintDoc  dflags False stderr-      putStrSDoc = defaultLogActionHPutStrDoc dflags False stdout+      printOut   = defaultLogActionHPrintDoc  logflags False stdout+      printErrs  = defaultLogActionHPrintDoc  logflags False stderr+      putStrSDoc = defaultLogActionHPutStrDoc logflags False stdout       -- Pretty print the warning flag, if any (#10752)-      message = mkLocMessageAnn flagMsg severity srcSpan msg+      message sev rea = mkLocMessageAnn (flagMsg sev rea) msg_class srcSpan msg -      printWarns = do+      printDiagnostics severity reason = do         hPutChar stderr '\n'         caretDiagnostic <--            if gopt Opt_DiagnosticsShowCaret dflags-            then getCaretDiagnostic severity srcSpan+            if log_show_caret logflags+            then getCaretDiagnostic msg_class srcSpan             else pure empty         printErrs $ getPprStyle $ \style ->           withPprStyle (setStyleColoured True style)-            (message $+$ caretDiagnostic)+            (message severity reason $+$ caretDiagnostic)         -- careful (#2302): printErrs prints in UTF-8,         -- whereas converting to string first and using         -- hPutStr would just emit the low 8 bits of         -- each unicode char. -      flagMsg =-        case reason of-          NoReason -> Nothing-          Reason wflag -> do-            spec <- flagSpecOf wflag-            return ("-W" ++ flagSpecName spec ++ warnFlagGrp wflag)-          ErrReason Nothing ->-            return "-Werror"-          ErrReason (Just wflag) -> do-            spec <- flagSpecOf wflag-            return $-              "-W" ++ flagSpecName spec ++ warnFlagGrp wflag ++-              ", -Werror=" ++ flagSpecName spec+      flagMsg :: Severity -> DiagnosticReason -> Maybe String+      flagMsg SevIgnore _                 =  panic "Called flagMsg with SevIgnore"+      flagMsg SevError WarningWithoutFlag =  Just "-Werror"+      flagMsg SevError (WarningWithFlag wflag) = do+        let name = NE.head (warnFlagNames wflag)+        return $+          "-W" ++ name ++ warnFlagGrp wflag +++          ", -Werror=" ++ name+      flagMsg SevError ErrorWithoutFlag = Nothing+      flagMsg SevWarning WarningWithoutFlag = Nothing+      flagMsg SevWarning (WarningWithFlag wflag) = do+        let name = NE.head (warnFlagNames wflag)+        return ("-W" ++ name ++ warnFlagGrp wflag)+      flagMsg SevWarning ErrorWithoutFlag =+        panic "SevWarning with ErrorWithoutFlag"        warnFlagGrp flag-          | gopt Opt_ShowWarnGroups dflags =-                case smallestGroups flag of+          | log_show_warn_groups logflags =+                case smallestWarningGroups flag of                     [] -> ""                     groups -> " (in " ++ intercalate ", " (map ("-W"++) groups) ++ ")"           | otherwise = ""  -- | Like 'defaultLogActionHPutStrDoc' but appends an extra newline.-defaultLogActionHPrintDoc :: DynFlags -> Bool -> Handle -> SDoc -> IO ()-defaultLogActionHPrintDoc dflags asciiSpace h d- = defaultLogActionHPutStrDoc dflags asciiSpace h (d $$ text "")+defaultLogActionHPrintDoc :: LogFlags -> Bool -> Handle -> SDoc -> IO ()+defaultLogActionHPrintDoc logflags asciiSpace h d+ = defaultLogActionHPutStrDoc logflags asciiSpace h (d $$ text "")  -- | The boolean arguments let's the pretty printer know if it can optimize indent -- by writing ascii ' ' characters without going through decoding.-defaultLogActionHPutStrDoc :: DynFlags -> Bool -> Handle -> SDoc -> IO ()-defaultLogActionHPutStrDoc dflags asciiSpace h d+defaultLogActionHPutStrDoc :: LogFlags -> Bool -> Handle -> SDoc -> IO ()+defaultLogActionHPutStrDoc logflags asciiSpace h d   -- Don't add a newline at the end, so that successive   -- calls to this log-action can output all on the same line-  = printSDoc ctx (Pretty.PageMode asciiSpace) h d-    where-      ctx = initSDocContext dflags defaultUserStyle+  = printSDoc (log_default_user_context logflags) (Pretty.PageMode asciiSpace) h d  -- -- Note [JSON Error Messages]@@ -299,8 +422,8 @@  -- | Default action for 'dumpAction' hook defaultDumpAction :: DumpCache -> LogAction -> DumpAction-defaultDumpAction dumps log_action dflags sty flag title _fmt doc =-  dumpSDocWithStyle dumps log_action sty dflags flag title doc+defaultDumpAction dumps log_action logflags sty flag title _fmt doc =+  dumpSDocWithStyle dumps log_action sty logflags flag title doc  -- | Write out a dump. --@@ -309,38 +432,37 @@ -- -- When @hdr@ is empty, we print in a more compact format (no separators and -- blank lines)-dumpSDocWithStyle :: DumpCache -> LogAction -> PprStyle -> DynFlags -> DumpFlag -> String -> SDoc -> IO ()-dumpSDocWithStyle dumps log_action sty dflags flag hdr doc =-    withDumpFileHandle dumps dflags flag writeDump+dumpSDocWithStyle :: DumpCache -> LogAction -> PprStyle -> LogFlags -> DumpFlag -> String -> SDoc -> IO ()+dumpSDocWithStyle dumps log_action sty logflags flag hdr doc =+    withDumpFileHandle dumps logflags flag writeDump   where     -- write dump to file     writeDump (Just handle) = do         doc' <- if null hdr                 then return doc-                else do t <- getCurrentTime-                        let timeStamp = if (gopt Opt_SuppressTimestamps dflags)-                                          then empty-                                          else text (show t)+                else do timeStamp <- if log_enable_timestamps logflags+                          then (text . show) <$> getCurrentTime+                          else pure empty                         let d = timeStamp                                 $$ blankLine                                 $$ doc                         return $ mkDumpDoc hdr d         -- When we dump to files we use UTF8. Which allows ascii spaces.-        defaultLogActionHPrintDoc dflags True handle (withPprStyle sty doc')+        defaultLogActionHPrintDoc logflags True handle (withPprStyle sty doc')      -- write the dump to stdout     writeDump Nothing = do-        let (doc', severity)-              | null hdr  = (doc, SevOutput)-              | otherwise = (mkDumpDoc hdr doc, SevDump)-        log_action dflags NoReason severity noSrcSpan (withPprStyle sty doc')+        let (doc', msg_class)+              | null hdr  = (doc, MCOutput)+              | otherwise = (mkDumpDoc hdr doc, MCDump)+        log_action logflags msg_class noSrcSpan (withPprStyle sty doc')   -- | Run an action with the handle of a 'DumpFlag' if we are outputting to a -- file, otherwise 'Nothing'.-withDumpFileHandle :: DumpCache -> DynFlags -> DumpFlag -> (Maybe Handle -> IO ()) -> IO ()-withDumpFileHandle dumps dflags flag action = do-    let mFile = chooseDumpFile dflags flag+withDumpFileHandle :: DumpCache -> LogFlags -> DumpFlag -> (Maybe Handle -> IO ()) -> IO ()+withDumpFileHandle dumps logflags flag action = do+    let mFile = chooseDumpFile logflags flag     case mFile of       Just fileName -> do         gd <- readIORef dumps@@ -359,12 +481,11 @@             action (Just handle)       Nothing -> action Nothing --- | Choose where to put a dump file based on DynFlags and DumpFlag-chooseDumpFile :: DynFlags -> DumpFlag -> Maybe FilePath-chooseDumpFile dflags flag-    | gopt Opt_DumpToFile dflags || forced_to_file-    , Just prefix <- getPrefix-    = Just $ setDir (prefix ++ dump_suffix)+-- | Choose where to put a dump file based on LogFlags and DumpFlag+chooseDumpFile :: LogFlags -> DumpFlag -> Maybe FilePath+chooseDumpFile logflags flag+    | log_dump_to_file logflags || forced_to_file+    = Just $ setDir (getPrefix ++ dump_suffix)      | otherwise     = Nothing@@ -387,29 +508,46 @@     getPrefix          -- dump file location is being forced          --      by the --ddump-file-prefix flag.-       | Just prefix <- dumpPrefixForce dflags-          = Just prefix-         -- dump file location chosen by GHC.Driver.Pipeline.runPipeline-       | Just prefix <- dumpPrefix dflags-          = Just prefix-         -- we haven't got a place to put a dump file.+       | Just prefix <- log_dump_prefix_override logflags+          = prefix+         -- dump file locations, module specified to [modulename] set by+         -- GHC.Driver.Pipeline.runPipeline; non-module specific, e.g. Chasing dependencies,+         -- to 'non-module' by default.        | otherwise-          = Nothing-    setDir f = case dumpDir dflags of+          = log_dump_prefix logflags+    setDir f = case log_dump_dir logflags of                  Just d  -> d </> f                  Nothing ->       f --- | This is a helper for 'dumpIfSet' to ensure that it's not duplicated--- despite the fact that 'dumpIfSet' has an @INLINE@.-doDump :: Logger -> DynFlags -> String -> SDoc -> IO ()-doDump logger dflags hdr doc =-  putLogMsg logger dflags-            NoReason-            SevDump-            noSrcSpan-            (withPprStyle defaultDumpStyle-              (mkDumpDoc hdr doc)) ++-- | Default action for 'traceAction' hook+defaultTraceAction :: TraceAction a+defaultTraceAction logflags title doc x =+  if not (log_enable_debug logflags)+    then x+    else trace (renderWithContext (log_default_dump_context logflags)+                             (sep [text title, nest 2 doc])) x+++-- | Log something+logMsg :: Logger -> MessageClass -> SrcSpan -> SDoc -> IO ()+logMsg logger mc loc msg = putLogMsg logger (logFlags logger) mc loc msg++-- | Dump something+logDumpFile :: Logger -> PprStyle -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()+logDumpFile logger = putDumpFile logger (logFlags logger)++-- | Log a trace message+logTraceMsg :: Logger -> String -> SDoc -> a -> a+logTraceMsg logger hdr doc a = putTraceMsg logger (logFlags logger) hdr doc a++-- | Log a dump message (not a dump file)+logDumpMsg :: Logger -> String -> SDoc -> IO ()+logDumpMsg logger hdr doc = logMsg logger MCDump noSrcSpan+  (withPprStyle defaultDumpStyle+  (mkDumpDoc hdr doc))+ mkDumpDoc :: String -> SDoc -> SDoc mkDumpDoc hdr doc    = vcat [blankLine,@@ -420,50 +558,41 @@         line = text "===================="  -dumpIfSet :: Logger -> DynFlags -> Bool -> String -> SDoc -> IO ()-dumpIfSet logger dflags flag hdr doc-  | not flag   = return ()-  | otherwise  = doDump logger dflags hdr doc-{-# INLINE dumpIfSet #-}  -- see Note [INLINE conditional tracing utilities]---- | A wrapper around 'dumpAction'.--- First check whether the dump flag is set--- Do nothing if it is unset-dumpIfSet_dyn :: Logger -> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()-dumpIfSet_dyn = dumpIfSet_dyn_printer alwaysQualify-{-# INLINE dumpIfSet_dyn #-}  -- see Note [INLINE conditional tracing utilities]+-- | Dump if the given DumpFlag is set+putDumpFileMaybe :: Logger -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()+putDumpFileMaybe logger = putDumpFileMaybe' logger alwaysQualify+{-# INLINE putDumpFileMaybe #-}  -- see Note [INLINE conditional tracing utilities] --- | A wrapper around 'putDumpMsg'.--- First check whether the dump flag is set--- Do nothing if it is unset+-- | Dump if the given DumpFlag is set ----- Unlike 'dumpIfSet_dyn', has a printer argument-dumpIfSet_dyn_printer-    :: PrintUnqualified-    -> Logger-    -> DynFlags+-- Unlike 'putDumpFileMaybe', has a PrintUnqualified argument+putDumpFileMaybe'+    :: Logger+    -> PrintUnqualified     -> DumpFlag     -> String     -> DumpFormat     -> SDoc     -> IO ()-dumpIfSet_dyn_printer printer logger dflags flag hdr fmt doc-  = when (dopt flag dflags) $ do-      let sty = mkDumpStyle printer-      putDumpMsg logger dflags sty flag hdr fmt doc-{-# INLINE dumpIfSet_dyn_printer #-}  -- see Note [INLINE conditional tracing utilities]---- | Ensure that a dump file is created even if it stays empty-touchDumpFile :: Logger -> DynFlags -> DumpFlag -> IO ()-touchDumpFile logger dflags flag =-    withDumpFileHandle (generated_dumps logger) dflags flag (const (return ()))+putDumpFileMaybe' logger printer flag hdr fmt doc+  = when (logHasDumpFlag logger flag) $+    logDumpFile' logger printer flag hdr fmt doc+{-# INLINE putDumpFileMaybe' #-}  -- see Note [INLINE conditional tracing utilities]  --- | Default action for 'traceAction' hook-defaultTraceAction :: TraceAction a-defaultTraceAction dflags title doc = pprTraceWithFlags dflags title doc-+logDumpFile' :: Logger -> PrintUnqualified -> DumpFlag+             -> String -> DumpFormat -> SDoc -> IO ()+{-# NOINLINE logDumpFile' #-}+-- NOINLINE: Now we are past the conditional, into the "cold" path,+--           don't inline, to reduce code size at the call site+-- See Note [INLINE conditional tracing utilities]+logDumpFile' logger printer flag hdr fmt doc+  = logDumpFile logger (mkDumpStyle printer) flag hdr fmt doc +-- | Ensure that a dump file is created even if it stays empty+touchDumpFile :: Logger -> DumpFlag -> IO ()+touchDumpFile logger flag =+    withDumpFileHandle (generated_dumps logger) (logFlags logger) flag (const (return ()))  class HasLogger m where     getLogger :: m Logger
GHC/Utils/Misc.hs view
@@ -13,12 +13,8 @@ -- | Highly random utility functions -- module GHC.Utils.Misc (-        -- * Flags dependent on the compiler build-        ghciSupported, debugIsOn,-        isWindowsHost, isDarwinHost,-         -- * Miscellaneous higher-order functions-        applyWhen, nTimes,+        applyWhen, nTimes, const2,          -- * General list processing         zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal,@@ -33,8 +29,9 @@         mapFst, mapSnd, chkAppend,         mapAndUnzip, mapAndUnzip3,         filterOut, partitionWith,+        mapAccumM, -        dropWhileEndLE, spanEnd, last2, lastMaybe,+        dropWhileEndLE, spanEnd, last2, lastMaybe, onJust,          List.foldl1', foldl2, count, countWhile, all2, @@ -46,8 +43,6 @@         isSingleton, only, expectOnly, GHC.Utils.Misc.singleton,         notNull, snocView, -        isIn, isn'tIn,-         chunkList,          changeLast,@@ -58,6 +53,10 @@         mergeListsBy,         isSortedBy, +        -- Foldable generalised functions,++        mapMaybe',+         -- * Tuples         fstOf3, sndOf3, thdOf3,         firstM, first3M, secondM,@@ -70,7 +69,7 @@         dropTail, capitalise,          -- * Sorting-        sortWith, minWith, nubSort, ordNub,+        sortWith, minWith, nubSort, ordNub, ordNubOn,          -- * Comparisons         isEqual, eqListBy, eqMaybeBy,@@ -85,15 +84,12 @@         transitiveClosure,          -- * Strictness-        seqList, strictMap, strictZipWith,+        seqList, strictMap, strictZipWith, strictZipWith3,          -- * Module names         looksLikeModuleName,         looksLikePackageName, -        -- * Argument processing-        getCmd, toCmdArgs, toArgs,-         -- * Integers         exactLog2, @@ -107,6 +103,7 @@         doesDirNameExist,         getModificationUTCTime,         modificationTimeIfExists,+        fileHashIfExists,         withAtomicRename,          -- * Filenames and paths@@ -128,18 +125,14 @@         -- * Call stacks         HasCallStack,         HasDebugCallStack,--        -- * Utils for flags-        OverridingBool(..),-        overrideWith,     ) where -#include "HsVersions.h"- import GHC.Prelude  import GHC.Utils.Exception import GHC.Utils.Panic.Plain+import GHC.Utils.Constants+import GHC.Utils.Fingerprint  import Data.Data import qualified Data.List as List@@ -166,58 +159,9 @@  import Data.Time -#if defined(DEBUG)-import {-# SOURCE #-} GHC.Utils.Outputable ( text )-import {-# SOURCE #-} GHC.Driver.Ppr ( warnPprTrace )-#endif- infixr 9 `thenCmp` -{--************************************************************************-*                                                                      *-\subsection{Is DEBUG on, are we on Windows, etc?}-*                                                                      *-************************************************************************ -These booleans are global constants, set by CPP flags.  They allow us to-recompile a single module (this one) to change whether or not debug output-appears. They sometimes let us avoid even running CPP elsewhere.--It's important that the flags are literal constants (True/False). Then,-with -0, tests of the flags in other modules will simplify to the correct-branch of the conditional, thereby dropping debug code altogether when-the flags are off.--}--ghciSupported :: Bool-#if defined(HAVE_INTERNAL_INTERPRETER)-ghciSupported = True-#else-ghciSupported = False-#endif--debugIsOn :: Bool-#if defined(DEBUG)-debugIsOn = True-#else-debugIsOn = False-#endif--isWindowsHost :: Bool-#if defined(mingw32_HOST_OS)-isWindowsHost = True-#else-isWindowsHost = False-#endif--isDarwinHost :: Bool-#if defined(darwin_HOST_OS)-isDarwinHost = True-#else-isDarwinHost = False-#endif- {- ************************************************************************ *                                                                      *@@ -237,6 +181,9 @@ nTimes 1 f = f nTimes n f = f . nTimes (n-1) f +const2 :: a -> b -> c -> a+const2 x _ _ = x+ fstOf3   :: (a,b,c) -> a sndOf3   :: (a,b,c) -> b thdOf3   :: (a,b,c) -> c@@ -281,9 +228,7 @@  filterOut :: (a->Bool) -> [a] -> [a] -- ^ Like filter, only it reverses the sense of the test-filterOut _ [] = []-filterOut p (x:xs) | p x       = filterOut p xs-                   | otherwise = x : filterOut p xs+filterOut p = filter (not . p)  partitionWith :: (a -> Either b c) -> [a] -> ([b], [c]) -- ^ Uses a function to determine which of two output lists an input element should join@@ -554,6 +499,10 @@ notNull :: Foldable f => f a -> Bool notNull = not . null +-- | Utility function to go from a singleton list to it's element.+--+-- Wether or not the argument is a singleton list is only checked+-- in debug builds. only :: [a] -> a #if defined(DEBUG) only [a] = a@@ -574,35 +523,7 @@ #endif expectOnly msg _     = panic ("expectOnly: " ++ msg) --- 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 = WARN(True, text ("Over-long elem in " ++ msg)) (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 = WARN(True, text ("Over-long notElem in " ++ msg)) (x `notElem` (y:ys))-      | otherwise = x /= y && notElem100 (i + 1) x ys-# endif /* DEBUG */-- -- | Split a list into chunks of /n/ elements chunkList :: Int -> [a] -> [[a]] chunkList _ [] = []@@ -621,6 +542,15 @@ mapLastM f [x] = (\x' -> [x']) <$> f x mapLastM f (x:xs) = (x:) <$> mapLastM f xs +mapAccumM :: (Monad m) => (r -> a -> m (r, b)) -> r -> [a] -> m (r, [b])+mapAccumM f = go+  where+    go acc [] = pure (acc,[])+    go acc (x:xs) = do+      (acc',y) <- f acc x+      (acc'',ys) <- go acc' xs+      pure (acc'', y:ys)+ whenNonEmpty :: Applicative m => [a] -> (NonEmpty a -> m ()) -> m () whenNonEmpty []     _ = pure () whenNonEmpty (x:xs) f = f (x :| xs)@@ -682,7 +612,7 @@ -}  minWith :: Ord b => (a -> b) -> [a] -> a-minWith get_key xs = ASSERT( not (null xs) )+minWith get_key xs = assert (not (null xs) )                      head (sortWith get_key xs)  nubSort :: Ord a => [a] -> [a]@@ -691,13 +621,18 @@ -- | Remove duplicates but keep elements in order. --   O(n * log n) ordNub :: Ord a => [a] -> [a]-ordNub xs+ordNub xs = ordNubOn id xs++-- | Remove duplicates but keep elements in order.+--   O(n * log n)+ordNubOn :: Ord b => (a -> b) -> [a] -> [a]+ordNubOn f xs   = go Set.empty xs   where     go _ [] = []     go s (x:xs)-      | Set.member x s = go s xs-      | otherwise = x : go (Set.insert x s) xs+      | Set.member (f x) s = go s xs+      | otherwise = x : go (Set.insert (f x) s) xs   {-@@ -795,7 +730,7 @@       go n  []     bs     = (take (I# n) ys, bs) -- = splitAt n ys       go n  (_:as) (_:bs) = go (n +# 1#) as bs --- drop from the end of a list+-- | drop from the end of a list dropTail :: Int -> [a] -> [a] -- Specification: dropTail n = reverse . drop n . reverse -- Better implementation due to Joachim Breitner@@ -840,6 +775,10 @@ lastMaybe [] = Nothing lastMaybe xs = Just $ last xs +-- | @onJust x m f@ applies f to the value inside the Just or returns the default.+onJust :: b -> Maybe a -> (a->b) -> b+onJust dflt = flip (maybe dflt)+ -- | Split a list into its last element and the initial part of the list. -- @snocView xs = Just (init xs, last xs)@ for non-empty lists. -- @snocView xs = Nothing@ otherwise.@@ -1034,10 +973,12 @@ fuzzyLookup :: String -> [(String,a)] -> [a] fuzzyLookup user_entered possibilites   = map fst $ take mAX_RESULTS $ List.sortBy (comparing snd)-    [ (poss_val, distance) | (poss_str, poss_val) <- possibilites-                       , let distance = restrictedDamerauLevenshteinDistance-                                            poss_str user_entered-                       , distance <= fuzzy_threshold ]+    [ (poss_val, sort_key)+    | (poss_str, poss_val) <- possibilites+    , let distance = restrictedDamerauLevenshteinDistance poss_str user_entered+    , distance <= fuzzy_threshold+    , let sort_key = (distance, length poss_str, poss_str)+    ]   where     -- Work out an appropriate match threshold:     -- We report a candidate if its edit distance is <= the threshold,@@ -1050,6 +991,10 @@     --     5         1     --     6         2     --+    -- Candidates with the same distance are sorted by their length. We also+    -- use the actual string as the third sorting criteria the sort key to get+    -- deterministic output, even if the input may have depended on the uniques+    -- in question     fuzzy_threshold = truncate $ fromIntegral (length user_entered + 2) / (4 :: Rational)     mAX_RESULTS = 3 @@ -1069,8 +1014,8 @@ seqList (x:xs) b = x `seq` seqList xs b  strictMap :: (a -> b) -> [a] -> [b]-strictMap _ [] = []-strictMap f (x : xs) =+strictMap _ []     = []+strictMap f (x:xs) =   let     !x' = f x     !xs' = strictMap f xs@@ -1078,16 +1023,27 @@     x' : xs'  strictZipWith :: (a -> b -> c) -> [a] -> [b] -> [c]-strictZipWith _ [] _ = []-strictZipWith _ _ [] = []-strictZipWith f (x : xs) (y: ys) =+strictZipWith _ []     _      = []+strictZipWith _ _      []     = []+strictZipWith f (x:xs) (y:ys) =   let     !x' = f x y     !xs' = strictZipWith f xs ys   in     x' : xs' +strictZipWith3 :: (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]+strictZipWith3 _ []     _      _      = []+strictZipWith3 _ _      []     _      = []+strictZipWith3 _ _      _      []     = []+strictZipWith3 f (x:xs) (y:ys) (z:zs) =+  let+    !x' = f x y z+    !xs' = strictZipWith3 f xs ys zs+  in+    x' : xs' + -- Module names:  looksLikeModuleName :: String -> Bool@@ -1102,67 +1058,6 @@ looksLikePackageName :: String -> Bool looksLikePackageName = all (all isAlphaNum <&&> not . (all isDigit)) . split '-' -{--Akin to @Prelude.words@, but acts like the Bourne shell, treating-quoted strings as Haskell Strings, and also parses Haskell [String]-syntax.--}--getCmd :: String -> Either String             -- Error-                           (String, String) -- (Cmd, Rest)-getCmd s = case break isSpace $ dropWhile isSpace s of-           ([], _) -> Left ("Couldn't find command in " ++ show s)-           res -> Right res--toCmdArgs :: String -> Either String             -- Error-                              (String, [String]) -- (Cmd, Args)-toCmdArgs s = case getCmd s of-              Left err -> Left err-              Right (cmd, s') -> case toArgs s' of-                                 Left err -> Left err-                                 Right args -> Right (cmd, args)--toArgs :: String -> Either String   -- Error-                           [String] -- Args-toArgs str-    = case dropWhile isSpace str of-      s@('[':_) -> case reads s of-                   [(args, spaces)]-                    | all isSpace spaces ->-                       Right args-                   _ ->-                       Left ("Couldn't read " ++ show str ++ " as [String]")-      s -> toArgs' s- where-  toArgs' :: String -> Either String [String]-  -- Remove outer quotes:-  -- > toArgs' "\"foo\" \"bar baz\""-  -- Right ["foo", "bar baz"]-  ---  -- Keep inner quotes:-  -- > toArgs' "-DFOO=\"bar baz\""-  -- Right ["-DFOO=\"bar baz\""]-  toArgs' s = case dropWhile isSpace s of-              [] -> Right []-              ('"' : _) -> do-                    -- readAsString removes outer quotes-                    (arg, rest) <- readAsString s-                    (arg:) `fmap` toArgs' rest-              s' -> case break (isSpace <||> (== '"')) s' of-                    (argPart1, s''@('"':_)) -> do-                        (argPart2, rest) <- readAsString s''-                        -- show argPart2 to keep inner quotes-                        ((argPart1 ++ show argPart2):) `fmap` toArgs' rest-                    (arg, s'') -> (arg:) `fmap` toArgs' s''--  readAsString :: String -> Either String (String, String)-  readAsString s = case reads s of-                [(arg, rest)]-                    -- rest must either be [] or start with a space-                    | all isSpace (take 1 rest) ->-                    Right (arg, rest)-                _ ->-                    Left ("Couldn't read " ++ show s ++ " as String") ----------------------------------------------------------------------------- -- Integers @@ -1190,7 +1085,7 @@ readRational :: String -> Rational -- NB: *does* handle a leading "-" readRational top_s   = case top_s of-      '-' : xs -> - (read_me xs)+      '-' : xs -> negate (read_me xs)       xs       -> read_me xs   where     read_me s@@ -1263,7 +1158,7 @@ readHexRational :: String -> Rational readHexRational str =   case str of-    '-' : xs -> - (readMe xs)+    '-' : xs -> negate (readMe xs)     xs       -> readMe xs   where   readMe as =@@ -1405,6 +1300,16 @@                         else ioError e  -- --------------------------------------------------------------+-- check existence & hash at the same time++fileHashIfExists :: FilePath -> IO (Maybe Fingerprint)+fileHashIfExists f =+  (do t <- getFileHash f; return (Just t))+        `catchIO` \e -> if isDoesNotExistError e+                        then return Nothing+                        else ioError e++-- -------------------------------------------------------------- -- atomic file writing by writing to a temporary file first (see #14533) -- -- This should be used in all cases where GHC writes files to disk@@ -1583,13 +1488,9 @@ type HasDebugCallStack = (() :: Constraint) #endif -data OverridingBool-  = Auto-  | Always-  | Never-  deriving Show--overrideWith :: Bool -> OverridingBool -> Bool-overrideWith b Auto   = b-overrideWith _ Always = True-overrideWith _ Never  = False+mapMaybe' :: Foldable f => (a -> Maybe b) -> f a -> [b]+mapMaybe' f = foldr g []+  where+    g x rest+      | Just y <- f x = y : rest+      | otherwise     = rest
GHC/Utils/Monad.hs view
@@ -347,14 +347,33 @@ Do note that for monads for multiple arguments more than one oneShot function might be required. For example in FCode we use: -    newtype FCode a = FCode' { doFCode :: CgInfoDownwards -> CgState -> (a, CgState) }+    newtype FCode a = FCode' { doFCode :: StgToCmmConfig -> CgState -> (a, CgState) } -    pattern FCode :: (CgInfoDownwards -> CgState -> (a, CgState))+    pattern FCode :: (StgToCmmConfig -> CgState -> (a, CgState))                   -> FCode a     pattern FCode m <- FCode' m       where         FCode m = FCode' $ oneShot (\cgInfoDown -> oneShot (\state ->m cgInfoDown state)) +INLINE pragmas and (>>)+~~~~~~~~~~~~~~~~~~~~~~~+A nasty gotcha is described in #20008.  In brief, be careful if you get (>>) via+its default method:++    instance Applicative M where+      pure a = MkM (\s -> (s, a))+      (<*>)  = ap++    instance Monad UM where+      {-# INLINE (>>=) #-}+      m >>= k  = MkM (\s -> blah)++Here we define (>>), via its default method, in terms of (>>=). If you do this,+be sure to put an INLINE pragma on (>>=), as above.  That tells it to inline+(>>=) in the RHS of (>>), even when it is applied to only two arguments, which+in turn conveys the one-shot info from (>>=) to (>>).  Lacking the INLINE, GHC+may eta-expand (>>), and with a non-one-shot lambda.  #20008 has more discussion.+ Derived instances ~~~~~~~~~~~~~~~~~ One caveat of both approaches is that derived instances don't use the smart@@ -407,7 +426,7 @@  * It helps ensure that 'm' really does inline. -Note that 'inline' evaporates in phase 0.  See Note [inlineIdMagic]+Note that 'inline' evaporates in phase 0.  See Note [inlineId magic] in GHC.Core.Opt.ConstantFold.match_inline.  The INLINE pragma on multiShotM is very important, else the
− GHC/Utils/Monad/State.hs 
@@ -1,46 +0,0 @@-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE UnboxedTuples #-}--module GHC.Utils.Monad.State where--import GHC.Prelude--newtype State s a = State { runState' :: s -> (# a, s #) }-    deriving (Functor)--instance Applicative (State s) where-   pure x   = State $ \s -> (# x, s #)-   m <*> n  = State $ \s -> case runState' m s of-                            (# f, s' #) -> case runState' n s' of-                                           (# x, s'' #) -> (# f x, s'' #)--instance Monad (State s) where-    m >>= n  = State $ \s -> case runState' m s of-                             (# r, s' #) -> runState' (n r) s'--get :: State s s-get = State $ \s -> (# s, s #)--gets :: (s -> a) -> State s a-gets f = State $ \s -> (# f s, s #)--put :: s -> State s ()-put s' = State $ \_ -> (# (), s' #)--modify :: (s -> s) -> State s ()-modify f = State $ \s -> (# (), f s #)---evalState :: State s a -> s -> a-evalState s i = case runState' s i of-                (# a, _ #) -> a---execState :: State s a -> s -> s-execState s i = case runState' s i of-                (# _, s' #) -> s'---runState :: State s a -> s -> (a, s)-runState s i = case runState' s i of-               (# a, s' #) -> (a, s')
+ GHC/Utils/Monad/State/Lazy.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE PatternSynonyms #-}++-- | A lazy state monad.+module GHC.Utils.Monad.State.Lazy+  ( -- * The State monda+    State(State)+  , state+  , evalState+  , execState+  , runState+    -- * Operations+  , get+  , gets+  , put+  , modify+  ) where++import GHC.Prelude++import GHC.Exts (oneShot)++-- | A state monad which is lazy in the state.+newtype State s a = State' { runState' :: s -> (# a, s #) }+    deriving (Functor)++pattern State :: (s -> (# a, s #))+              -> State s a++-- This pattern synonym makes the monad eta-expand,+-- which as a very beneficial effect on compiler performance+-- See #18202.+-- See Note [The one-shot state monad trick] in GHC.Utils.Monad+pattern State m <- State' m+  where+    State m = State' (oneShot $ \s -> m s)++instance Applicative (State s) where+   pure x   = State $ \s -> (# x, s #)+   m <*> n  = State $ \s -> case runState' m s of+                            (# f, s' #) -> case runState' n s' of+                                           (# x, s'' #) -> (# f x, s'' #)++instance Monad (State s) where+    m >>= n  = State $ \s -> case runState' m s of+                             (# r, s' #) -> runState' (n r) s'++state :: (s -> (a, s)) -> State s a+state f = State $ \s -> case f s of+                        (r, s') -> (# r, s' #)++get :: State s s+get = State $ \s -> (# s, s #)++gets :: (s -> a) -> State s a+gets f = State $ \s -> (# f s, s #)++put :: s -> State s ()+put s' = State $ \_ -> (# (), s' #)++modify :: (s -> s) -> State s ()+modify f = State $ \s -> (# (), f s #)+++evalState :: State s a -> s -> a+evalState s i = case runState' s i of+                (# a, _ #) -> a+++execState :: State s a -> s -> s+execState s i = case runState' s i of+                (# _, s' #) -> s'+++runState :: State s a -> s -> (a, s)+runState s i = case runState' s i of+               (# a, s' #) -> (a, s')
+ GHC/Utils/Monad/State/Strict.hs view
@@ -0,0 +1,117 @@+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE PatternSynonyms #-}++-- | A state monad which is strict in its state.+module GHC.Utils.Monad.State.Strict+  ( -- * The State monad+    State(State)+  , state+  , evalState+  , execState+  , runState+    -- * Operations+  , get+  , gets+  , put+  , modify+  ) where++import GHC.Prelude++import GHC.Exts (oneShot)++{- Note [Strict State monad]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A State monad can be strict in many ways. Which kind of strictness do we mean?++First of, since we represent the result pair as an unboxed pair, this State+monad is strict in the sense of "Control.Monad.Trans.State.Strict": The+computations and the sequencing there-of (through 'Applicative and 'Monad'+instances) are forced strictly.++Beyond the manual unboxing of one level (which CPR could achieve similarly,+yet perhaps a bit less reliably), our 'State' is even stricter than the+transformers version:+It's also strict in the state `s` (but still lazy in the value `a`). What this+means is that whenever callers examine the state component (perhaps through+'runState'), they will find that the `s` has already been evaluated.++This additional strictness maintained in a single place, by the ubiquitous+'State' pattern synonym, by forcing the state component *after* any state action+has been run. The INVARIANT is:++> Any `s` that makes it into the unboxed pair representation is evaluated.++This invariant has another nice effect: Because the evaluatedness is quite+apparent, Nested CPR will try to unbox the state component `s` nestedly if+feasible. Detecting evaluatedness of nested components is a necessary+condition for Nested CPR to trigger; see the user's guide entry on that:+https://ghc.gitlab.haskell.org/ghc/doc/users_guide/using-optimisation.html#ghc-flag--fcpr-anal++Note that this doesn't have any effects on whether Nested CPR will unbox the `a`+component (which is still lazy by default). The user still has to use the+`return $!` idiom from the user's guide to encourage Nested CPR to unbox the `a`+result of a stateful computation.+-}++-- | A state monad which is strict in the state `s`, but lazy in the value `a`.+--+-- See Note [Strict State monad] for the particular notion of strictness and+-- implementation details.+newtype State s a = State' { runState' :: s -> (# a, s #) }++pattern State :: (s -> (# a, s #))+              -> State s a++-- This pattern synonym makes the monad eta-expand,+-- which as a very beneficial effect on compiler performance+-- See #18202.+-- See Note [The one-shot state monad trick] in GHC.Utils.Monad+-- It also implements the particular notion of strictness of this monad;+-- see Note [Strict State monad].+pattern State m <- State' m+  where+    State m = State' (oneShot $ \s -> forceState (m s))++-- | Forces the state component of the unboxed representation pair of 'State'.+-- See Note [Strict State monad]. This is The Place doing the forcing!+forceState :: (# a, s #) -> (# a, s #)+forceState (# a, !s #) = (# a, s #)++instance Functor (State s) where+  fmap f m = State $ \s -> case runState' m s  of (# x, s' #) -> (# f x, s' #)++instance Applicative (State s) where+  pure x  = State $ \s -> (# x, s #)+  m <*> n = State $ \s ->+    case runState' m s  of { (# f, s' #) ->+    case runState' n s' of { (# x, s'' #) ->+                             (# f x, s'' #) }}++instance Monad (State s) where+  m >>= n = State $ \s -> case runState' m s of+    (# r, !s' #) -> runState' (n r) s'++state :: (s -> (a, s)) -> State s a+state f = State $ \s -> case f s of (r, s') -> (# r, s' #)++get :: State s s+get = State $ \s -> (# s, s #)++gets :: (s -> a) -> State s a+gets f = State $ \s -> (# f s, s #)++put :: s -> State s ()+put s' = State $ \_ -> (# (), s' #)++modify :: (s -> s) -> State s ()+modify f = State $ \s -> (# (), f s #)++evalState :: State s a -> s -> a+evalState s i = case runState' s i of (# a, _ #) -> a++execState :: State s a -> s -> s+execState s i = case runState' s i of (# _, s' #) -> s'++runState :: State s a -> s -> (a, s)+runState s i = case runState' s i of (# a, !s' #) -> (a, s')
GHC/Utils/Outputable.hs view
@@ -44,7 +44,8 @@         fsep, fcat,         hang, hangNotEmpty, punctuate, ppWhen, ppUnless,         ppWhenOption, ppUnlessOption,-        speakNth, speakN, speakNOf, plural, isOrAre, doOrDoes, itsOrTheir,+        speakNth, speakN, speakNOf, plural, singular,+        isOrAre, doOrDoes, itsOrTheir, thisOrThese, hasOrHave,         unicodeSyntax,          coloured, keyword,@@ -53,10 +54,11 @@         printSDoc, printSDocLn,         bufLeftRenderSDoc,         pprCode,+        showSDocOneLine,         showSDocUnsafe,         showPprUnsafe,-        showSDocOneLine,         renderWithContext,+        pprDebugAndThen,          pprInfixVar, pprPrefixVar,         pprHsChar, pprHsString, pprHsBytes,@@ -134,6 +136,8 @@ import Data.List (intersperse) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NEL+import Data.Time+import Data.Time.Format.ISO8601  import GHC.Fingerprint import GHC.Show         ( showMultiLineString )@@ -161,7 +165,7 @@                 -- Does not assume tidied code: non-external names                 -- are printed with uniques. -  | PprCode LabelStyle -- ^ Print code; either C or assembler+  | PprCode !LabelStyle -- ^ Print code; either C or assembler  -- | Style of label pretty-printing. --@@ -445,6 +449,7 @@   }  withPprStyle :: PprStyle -> SDoc -> SDoc+{-# INLINE CONLIKE withPprStyle #-} withPprStyle sty d = SDoc $ \ctxt -> runSDoc d ctxt{sdocStyle=sty}  pprDeeper :: SDoc -> SDoc@@ -487,15 +492,19 @@             runSDoc doc ctx  getPprStyle :: (PprStyle -> SDoc) -> SDoc+{-# INLINE CONLIKE getPprStyle #-} getPprStyle df = SDoc $ \ctx -> runSDoc (df (sdocStyle ctx)) ctx  sdocWithContext :: (SDocContext -> SDoc) -> SDoc+{-# INLINE CONLIKE sdocWithContext #-} sdocWithContext f = SDoc $ \ctx -> runSDoc (f ctx) ctx  sdocOption :: (SDocContext -> a) -> (a -> SDoc) -> SDoc+{-# INLINE CONLIKE sdocOption #-} sdocOption f g = sdocWithContext (g . f)  updSDocContext :: (SDocContext -> SDocContext) -> SDoc -> SDoc+{-# INLINE CONLIKE updSDocContext #-} updSDocContext upd doc   = SDoc $ \ctx -> runSDoc doc (upd ctx) @@ -537,14 +546,17 @@  -- | Indicate if -dppr-debug mode is enabled getPprDebug :: (Bool -> SDoc) -> SDoc+{-# INLINE CONLIKE getPprDebug #-} getPprDebug d = sdocWithContext $ \ctx -> d (sdocPprDebug ctx)  -- | Says what to do with and without -dppr-debug ifPprDebug :: SDoc -> SDoc -> SDoc+{-# INLINE CONLIKE ifPprDebug #-} ifPprDebug yes no = getPprDebug $ \dbg -> if dbg then yes else no  -- | Says what to do with -dppr-debug; without, return empty whenPprDebug :: SDoc -> SDoc        -- Empty for non-debug style+{-# INLINE CONLIKE whenPprDebug #-} whenPprDebug d = ifPprDebug d empty  -- | The analog of 'Pretty.printDoc_' for 'SDoc', which tries to make sure the@@ -571,6 +583,7 @@   Pretty.bufLeftRender bufHandle (runSDoc doc ctx)  pprCode :: LabelStyle -> SDoc -> SDoc+{-# INLINE CONLIKE pprCode #-} pprCode cs d = withPprStyle (PprCode cs) d  renderWithContext :: SDocContext -> SDoc -> String@@ -596,6 +609,13 @@ showPprUnsafe a = renderWithContext defaultSDocContext (ppr a)  +pprDebugAndThen :: SDocContext -> (String -> a) -> SDoc -> SDoc -> a+pprDebugAndThen ctx cont heading pretty_msg+ = cont (renderWithContext ctx doc)+ where+     doc = withPprStyle defaultDumpStyle (sep [heading, nest 2 pretty_msg])++ isEmpty :: SDocContext -> SDoc -> Bool isEmpty ctx sdoc = Pretty.isEmpty $ runSDoc sdoc (ctx {sdocPprDebug = True}) @@ -615,21 +635,32 @@ double   :: Double     -> SDoc rational :: Rational   -> SDoc +{-# INLINE CONLIKE empty #-} empty       = docToSDoc $ Pretty.empty+{-# INLINE CONLIKE char #-} char c      = docToSDoc $ Pretty.char c +{-# INLINE CONLIKE text #-}   -- Inline so that the RULE Pretty.text will fire text s      = docToSDoc $ Pretty.text s-{-# INLINE text #-}   -- Inline so that the RULE Pretty.text will fire +{-# INLINE CONLIKE ftext #-} ftext s     = docToSDoc $ Pretty.ftext s+{-# INLINE CONLIKE ptext #-} ptext s     = docToSDoc $ Pretty.ptext s+{-# INLINE CONLIKE ztext #-} ztext s     = docToSDoc $ Pretty.ztext s+{-# INLINE CONLIKE int #-} int n       = docToSDoc $ Pretty.int n+{-# INLINE CONLIKE integer #-} integer n   = docToSDoc $ Pretty.integer n+{-# INLINE CONLIKE float #-} float n     = docToSDoc $ Pretty.float n+{-# INLINE CONLIKE double #-} double n    = docToSDoc $ Pretty.double n+{-# INLINE CONLIKE rational #-} rational n  = docToSDoc $ Pretty.rational n               -- See Note [Print Hexadecimal Literals] in GHC.Utils.Ppr+{-# INLINE CONLIKE word #-} word n      = sdocOption sdocHexWordLiterals $ \case                True  -> docToSDoc $ Pretty.hex n                False -> docToSDoc $ Pretty.integer n@@ -642,14 +673,21 @@ parens, braces, brackets, quotes, quote,         doubleQuotes, angleBrackets :: SDoc -> SDoc +{-# INLINE CONLIKE parens #-} parens d        = SDoc $ Pretty.parens . runSDoc d+{-# INLINE CONLIKE braces #-} braces d        = SDoc $ Pretty.braces . runSDoc d+{-# INLINE CONLIKE brackets #-} brackets d      = SDoc $ Pretty.brackets . runSDoc d+{-# INLINE CONLIKE quote #-} quote d         = SDoc $ Pretty.quote . runSDoc d+{-# INLINE CONLIKE doubleQuotes #-} doubleQuotes d  = SDoc $ Pretty.doubleQuotes . runSDoc d+{-# INLINE CONLIKE angleBrackets #-} angleBrackets d = char '<' <> d <> char '>'  cparen :: Bool -> SDoc -> SDoc+{-# INLINE CONLIKE cparen #-} cparen b d = SDoc $ Pretty.maybeParens b . runSDoc d  -- 'quotes' encloses something in single quotes...@@ -670,7 +708,7 @@ arrow, lollipop, larrow, darrow, arrowt, larrowt, arrowtt, larrowtt, lambda :: SDoc lparen, rparen, lbrack, rbrack, lbrace, rbrace, blankLine :: SDoc -blankLine  = docToSDoc $ Pretty.text ""+blankLine  = docToSDoc Pretty.emptyText dcolon     = unicodeSyntax (char '∷') (docToSDoc $ Pretty.text "::") arrow      = unicodeSyntax (char '→') (docToSDoc $ Pretty.text "->") lollipop   = unicodeSyntax (char '⊸') (docToSDoc $ Pretty.text "%1 ->")@@ -731,11 +769,16 @@ ($+$) :: SDoc -> SDoc -> SDoc -- ^ Join two 'SDoc' together vertically +{-# INLINE CONLIKE nest #-} nest n d    = SDoc $ Pretty.nest n . runSDoc d-(<>) d1 d2  = SDoc $ \sty -> (Pretty.<>)  (runSDoc d1 sty) (runSDoc d2 sty)-(<+>) d1 d2 = SDoc $ \sty -> (Pretty.<+>) (runSDoc d1 sty) (runSDoc d2 sty)-($$) d1 d2  = SDoc $ \sty -> (Pretty.$$)  (runSDoc d1 sty) (runSDoc d2 sty)-($+$) d1 d2 = SDoc $ \sty -> (Pretty.$+$) (runSDoc d1 sty) (runSDoc d2 sty)+{-# INLINE CONLIKE (<>) #-}+(<>) d1 d2  = SDoc $ \ctx -> (Pretty.<>)  (runSDoc d1 ctx) (runSDoc d2 ctx)+{-# INLINE CONLIKE (<+>) #-}+(<+>) d1 d2 = SDoc $ \ctx -> (Pretty.<+>) (runSDoc d1 ctx) (runSDoc d2 ctx)+{-# INLINE CONLIKE ($$) #-}+($$) d1 d2  = SDoc $ \ctx -> (Pretty.$$)  (runSDoc d1 ctx) (runSDoc d2 ctx)+{-# INLINE CONLIKE ($+$) #-}+($+$) d1 d2 = SDoc $ \ctx -> (Pretty.$+$) (runSDoc d1 ctx) (runSDoc d2 ctx)  hcat :: [SDoc] -> SDoc -- ^ Concatenate 'SDoc' horizontally@@ -754,25 +797,37 @@ -- ^ This behaves like 'fsep', but it uses '<>' for horizontal conposition rather than '<+>'  -hcat ds = SDoc $ \sty -> Pretty.hcat [runSDoc d sty | d <- ds]-hsep ds = SDoc $ \sty -> Pretty.hsep [runSDoc d sty | d <- ds]-vcat ds = SDoc $ \sty -> Pretty.vcat [runSDoc d sty | d <- ds]-sep ds  = SDoc $ \sty -> Pretty.sep  [runSDoc d sty | d <- ds]-cat ds  = SDoc $ \sty -> Pretty.cat  [runSDoc d sty | d <- ds]-fsep ds = SDoc $ \sty -> Pretty.fsep [runSDoc d sty | d <- ds]-fcat ds = SDoc $ \sty -> Pretty.fcat [runSDoc d sty | d <- ds]+-- Inline all those wrappers to help ensure we create lists of Doc, not of SDoc+-- later applied to the same SDocContext. It helps the worker/wrapper+-- transformation extracting only the required fields from the SDocContext.+{-# INLINE CONLIKE hcat #-}+hcat ds = SDoc $ \ctx -> Pretty.hcat [runSDoc d ctx | d <- ds]+{-# INLINE CONLIKE hsep #-}+hsep ds = SDoc $ \ctx -> Pretty.hsep [runSDoc d ctx | d <- ds]+{-# INLINE CONLIKE vcat #-}+vcat ds = SDoc $ \ctx -> Pretty.vcat [runSDoc d ctx | d <- ds]+{-# INLINE CONLIKE sep #-}+sep ds  = SDoc $ \ctx -> Pretty.sep  [runSDoc d ctx | d <- ds]+{-# INLINE CONLIKE cat #-}+cat ds  = SDoc $ \ctx -> Pretty.cat  [runSDoc d ctx | d <- ds]+{-# INLINE CONLIKE fsep #-}+fsep ds = SDoc $ \ctx -> Pretty.fsep [runSDoc d ctx | d <- ds]+{-# INLINE CONLIKE fcat #-}+fcat ds = SDoc $ \ctx -> Pretty.fcat [runSDoc d ctx | d <- ds]  hang :: SDoc  -- ^ The header       -> Int  -- ^ Amount to indent the hung body       -> SDoc -- ^ The hung body, indented and placed below the header       -> SDoc+{-# INLINE CONLIKE hang #-} hang d1 n d2   = SDoc $ \sty -> Pretty.hang (runSDoc d1 sty) n (runSDoc d2 sty)  -- | This behaves like 'hang', but does not indent the second document -- when the header is empty. hangNotEmpty :: SDoc -> Int -> SDoc -> SDoc+{-# INLINE CONLIKE hangNotEmpty #-} hangNotEmpty d1 n d2 =-    SDoc $ \sty -> Pretty.hangNotEmpty (runSDoc d1 sty) n (runSDoc d2 sty)+    SDoc $ \ctx -> Pretty.hangNotEmpty (runSDoc d1 ctx) n (runSDoc d2 ctx)  punctuate :: SDoc   -- ^ The punctuation           -> [SDoc] -- ^ The list that will have punctuation added between every adjacent pair of elements@@ -784,17 +839,21 @@                      go d (e:es) = (d <> p) : go e es  ppWhen, ppUnless :: Bool -> SDoc -> SDoc+{-# INLINE CONLIKE ppWhen #-} ppWhen True  doc = doc ppWhen False _   = empty +{-# INLINE CONLIKE ppUnless #-} ppUnless True  _   = empty ppUnless False doc = doc +{-# INLINE CONLIKE ppWhenOption #-} ppWhenOption :: (SDocContext -> Bool) -> SDoc -> SDoc ppWhenOption f doc = sdocOption f $ \case    True  -> doc    False -> empty +{-# INLINE CONLIKE ppUnlessOption #-} ppUnlessOption :: (SDocContext -> Bool) -> SDoc -> SDoc ppUnlessOption f doc = sdocOption f $ \case    True  -> empty@@ -870,6 +929,9 @@ instance Outputable () where     ppr _ = text "()" +instance Outputable UTCTime where+    ppr = text . formatShow iso8601Format+ instance (Outputable a) => Outputable [a] where     ppr xs = brackets (fsep (punctuate comma (map ppr xs))) @@ -1119,7 +1181,7 @@     | CaseBind    -- ^ The x in   case scrut of x { (y,z) -> ... }     | CasePatBind -- ^ The y,z in case scrut of x { (y,z) -> ... }     | LetBind     -- ^ The x in   (let x = rhs in e)-+    deriving Eq -- | When we print a binder, we often want to print its type too. -- The @OutputableBndr@ class encapsulates this idea. class Outputable a => OutputableBndr a where@@ -1364,6 +1426,15 @@ plural [_] = empty  -- a bit frightening, but there you are plural _   = char 's' +-- | Determines the singular verb suffix appropriate for the length of a list:+--+-- > singular [] = empty+-- > singular["Hello"] = char 's'+-- > singular ["Hello", "World"] = empty+singular :: [a] -> SDoc+singular [_] = char 's'+singular _   = empty+ -- | Determines the form of to be appropriate for the length of a list: -- -- > isOrAre [] = text "are"@@ -1390,3 +1461,18 @@ itsOrTheir :: [a] -> SDoc itsOrTheir [_] = text "its" itsOrTheir _   = text "their"+++-- | Determines the form of subject appropriate for the length of a list:+--+-- > thisOrThese [x]   = text "This"+-- > thisOrThese [x,y] = text "These"+-- > thisOrThese []    = text "These"  -- probably avoid this+thisOrThese :: [a] -> SDoc+thisOrThese [_] = text "This"+thisOrThese _   = text "These"++-- | @"has"@ or @"have"@ depending on the length of a list.+hasOrHave :: [a] -> SDoc+hasOrHave [_] = text "has"+hasOrHave _   = text "have"
GHC/Utils/Panic.hs view
@@ -4,7 +4,8 @@  -} -{-# LANGUAGE CPP, ScopedTypeVariables, LambdaCase #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables, LambdaCase #-}  -- | Defines basic functions for printing error messages. --@@ -18,20 +19,22 @@    , throwGhcExceptionIO    , handleGhcException -   , GHC.Utils.Panic.Plain.progName    , pgmError    , panic    , pprPanic    , assertPanic    , assertPprPanic+   , assertPpr+   , assertPprM+   , massertPpr    , sorry-   , trace    , panicDoc    , sorryDoc    , pgmErrorDoc    , cmdLineError    , cmdLineErrorIO    , callStackDoc+   , prettyCallStackDoc     , Exception.Exception(..)    , showException@@ -48,6 +51,7 @@  import GHC.Utils.Outputable import GHC.Utils.Panic.Plain+import GHC.Utils.Constants  import GHC.Utils.Exception as Exception @@ -55,7 +59,6 @@ import qualified Control.Monad.Catch as MC import Control.Concurrent import Data.Typeable      ( cast )-import Debug.Trace        ( trace ) import System.IO.Unsafe  #if !defined(mingw32_HOST_OS)@@ -121,9 +124,7 @@     | otherwise = Nothing  instance Show GhcException where-  showsPrec _ e@(ProgramError _) = showGhcExceptionUnsafe e-  showsPrec _ e@(CmdLineError _) = showString "<command line>: " . showGhcExceptionUnsafe e-  showsPrec _ e = showString progName . showString ": " . showGhcExceptionUnsafe e+  showsPrec _ e = showGhcExceptionUnsafe e  -- | Show an exception as a string. showException :: Exception e => e -> String@@ -289,12 +290,30 @@   act `MC.finally` mayUninstallHandlers  callStackDoc :: HasCallStack => SDoc-callStackDoc =+callStackDoc = prettyCallStackDoc callStack++prettyCallStackDoc :: CallStack -> SDoc+prettyCallStackDoc cs =     hang (text "Call stack:")-       4 (vcat $ map text $ lines (prettyCallStack callStack))+       4 (vcat $ map text $ lines (prettyCallStack cs))  -- | Panic with an assertion failure, recording the given file and -- line number. Should typically be accessed with the ASSERT family of macros-assertPprPanic :: HasCallStack => String -> Int -> SDoc -> a-assertPprPanic _file _line msg-  = pprPanic "ASSERT failed!" msg+assertPprPanic :: HasCallStack => SDoc -> a+assertPprPanic msg = withFrozenCallStack (pprPanic "ASSERT failed!" msg)+++assertPpr :: HasCallStack => Bool -> SDoc -> a -> a+{-# INLINE assertPpr #-}+assertPpr cond msg a =+  if debugIsOn && not cond+    then withFrozenCallStack (assertPprPanic msg)+    else a++massertPpr :: (HasCallStack, Applicative m) => Bool -> SDoc -> m ()+{-# INLINE massertPpr #-}+massertPpr cond msg = withFrozenCallStack (assertPpr cond msg (pure ()))++assertPprM :: (HasCallStack, Monad m) => m Bool -> SDoc -> m ()+{-# INLINE assertPprM #-}+assertPprM mcond msg = withFrozenCallStack (mcond >>= \cond -> massertPpr cond msg)
GHC/Utils/Panic/Plain.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, ScopedTypeVariables, LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables, LambdaCase #-}  -- | Defines a simple exception type and utilities to throw it. The -- 'PlainGhcException' type is a subset of the 'GHC.Utils.Panic.GhcException'@@ -21,17 +21,14 @@   , panic, sorry, pgmError   , cmdLineError, cmdLineErrorIO   , assertPanic--  , progName+  , assert, assertM, massert   ) where -#include "HsVersions.h"- import GHC.Settings.Config+import GHC.Utils.Constants import GHC.Utils.Exception as Exception import GHC.Stack import GHC.Prelude-import System.Environment import System.IO.Unsafe  -- | This type is very similar to 'GHC.Utils.Panic.GhcException', but it omits@@ -69,14 +66,7 @@ instance Exception PlainGhcException  instance Show PlainGhcException where-  showsPrec _ e@(PlainProgramError _) = showPlainGhcException e-  showsPrec _ e@(PlainCmdLineError _) = showString "<command line>: " . showPlainGhcException e-  showsPrec _ e = showString progName . showString ": " . showPlainGhcException e---- | The name of this GHC.-progName :: String-progName = unsafePerformIO (getProgName)-{-# NOINLINE progName #-}+  showsPrec _ e = showPlainGhcException e  -- | Short usage information to display when we are given the wrong cmd line arguments. short_usage :: String@@ -97,13 +87,13 @@     sorryMsg :: ShowS -> ShowS     sorryMsg s =         showString "sorry! (unimplemented feature or known bug)\n"-      . showString ("  (GHC version " ++ cProjectVersion ++ ":\n\t")+      . showString ("  GHC version " ++ cProjectVersion ++ ":\n\t")       . s . showString "\n"      panicMsg :: ShowS -> ShowS     panicMsg s =         showString "panic! (the 'impossible' happened)\n"-      . showString ("  (GHC version " ++ cProjectVersion ++ ":\n\t")+      . showString ("  GHC version " ++ cProjectVersion ++ ":\n\t")       . s . showString "\n\n"       . showString "Please report this as a GHC bug:  https://www.haskell.org/ghc/reportabug\n" @@ -136,3 +126,27 @@ assertPanic file line =   Exception.throw (Exception.AssertionFailed            ("ASSERT failed! file " ++ file ++ ", line " ++ show line))+++assertPanic' :: HasCallStack => a+assertPanic' =+  let doc = unlines $ fmap ("  "++) $ lines (prettyCallStack callStack)+  in+  Exception.throw (Exception.AssertionFailed+           ("ASSERT failed!\n"+            ++ withFrozenCallStack doc))++assert :: HasCallStack => Bool -> a -> a+{-# INLINE assert #-}+assert cond a =+  if debugIsOn && not cond+    then withFrozenCallStack assertPanic'+    else a++massert :: (HasCallStack, Applicative m) => Bool -> m ()+{-# INLINE massert #-}+massert cond = withFrozenCallStack (assert cond (pure ()))++assertM :: (HasCallStack, Monad m) => m Bool -> m ()+{-# INLINE assertM #-}+assertM mcond = withFrozenCallStack (mcond >>= massert)
GHC/Utils/Ppr.hs view
@@ -22,7 +22,7 @@  {- Note [Differences between libraries/pretty and compiler/GHC/Utils/Ppr.hs]-+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ For historical reasons, there are two different copies of `Pretty` in the GHC source tree:  * `libraries/pretty` is a submodule containing@@ -71,7 +71,7 @@         -- * Constructing documents          -- ** Converting values into documents-        char, text, ftext, ptext, ztext, sizedText, zeroWidthText,+        char, text, ftext, ptext, ztext, sizedText, zeroWidthText, emptyText,         int, integer, float, double, rational, hex,          -- ** Simple derived documents@@ -309,6 +309,12 @@     forall p n. text (unpackNBytes# p n) = ptext (PtrString (Ptr p) (I# n))   #-} +-- Empty strings are desugared into [] (not "unpackCString#..."), hence they are+-- not matched by the text/str rule above.+{-# RULES "text/[]"+    text [] = emptyText+  #-}+ ftext :: FastString -> Doc ftext s = textBeside_ (PStr s) (lengthFS s) Empty @@ -327,6 +333,12 @@ zeroWidthText :: String -> Doc zeroWidthText = sizedText 0 +-- | Empty text (one line high but no width). (@emptyText = text ""@)+emptyText :: Doc+emptyText = sizedText 0 []+  -- defined as a CAF. Sharing occurs especially via the text/[] rule above.+  -- Every use of `text ""` in user code should be replaced with this.+ -- | The empty document, with no height and no width. -- 'empty' is the identity for '<>', '<+>', '$$' and '$+$', and anywhere -- in the argument list for 'sep', 'hcat', 'hsep', 'vcat', 'fcat' etc.@@ -429,12 +441,12 @@  {- Note [Print Hexadecimal Literals]-+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Relevant discussions:  * Phabricator: https://phabricator.haskell.org/D4465  * GHC Trac: https://gitlab.haskell.org/ghc/ghc/issues/14872 -There is a flag `-dword-hex-literals` that causes literals of+There is a flag `-dhex-word-literals` that causes literals of type `Word#` or `Word64#` to be displayed in hexadecimal instead of decimal when dumping GHC core. It also affects the presentation of these in GHC's error messages. Additionally, the hexadecimal
GHC/Utils/Ppr/Colour.hs view
@@ -2,7 +2,7 @@ import GHC.Prelude  import Data.Maybe (fromMaybe)-import GHC.Utils.Misc (OverridingBool(..), split)+import GHC.Data.Bool import Data.Semigroup as Semi  -- | A colour\/style for use with 'coloured'.@@ -93,6 +93,11 @@     }   )   where+    split :: Char -> String -> [String]+    split c s = case break (==c) s of+        (chunk,[])     -> [chunk]+        (chunk,_:rest) -> chunk : split c rest+     table = do       w <- split ':' input       let (k, v') = break (== '=') w
GHC/Utils/TmpFs.hs view
@@ -9,6 +9,7 @@     , FilesToClean(..)     , emptyFilesToClean     , TempFileLifetime(..)+    , TempDir (..)     , cleanTempDirs     , cleanTempFiles     , cleanCurrentModuleTempFiles@@ -24,7 +25,6 @@  import GHC.Prelude -import GHC.Driver.Session import GHC.Utils.Error import GHC.Utils.Outputable import GHC.Utils.Logger@@ -32,7 +32,6 @@ import GHC.Utils.Exception as Exception import GHC.Driver.Phases -import Control.Monad import Data.List (partition) import qualified Data.Set as Set import Data.Set (Set)@@ -92,6 +91,7 @@   -- runGhc(T)   deriving (Show) +newtype TempDir = TempDir FilePath  -- | An empty FilesToClean emptyFilesToClean :: FilesToClean@@ -135,19 +135,17 @@     src_files <- atomicModifyIORef' (tmp_files_to_clean src) (\s -> (emptyFilesToClean, s))     atomicModifyIORef' (tmp_files_to_clean dst) (\s -> (mergeFilesToClean src_files s, ())) -cleanTempDirs :: Logger -> TmpFs -> DynFlags -> IO ()-cleanTempDirs logger tmpfs dflags-   = unless (gopt Opt_KeepTmpFiles dflags)-   $ mask_+cleanTempDirs :: Logger -> TmpFs -> IO ()+cleanTempDirs logger tmpfs+   = mask_    $ do let ref = tmp_dirs_to_clean tmpfs         ds <- atomicModifyIORef' ref $ \ds -> (Map.empty, ds)-        removeTmpDirs logger dflags (Map.elems ds)+        removeTmpDirs logger (Map.elems ds)  -- | Delete all files in @tmp_files_to_clean@.-cleanTempFiles :: Logger -> TmpFs -> DynFlags -> IO ()-cleanTempFiles logger tmpfs dflags-   = unless (gopt Opt_KeepTmpFiles dflags)-   $ mask_+cleanTempFiles :: Logger -> TmpFs -> IO ()+cleanTempFiles logger tmpfs+   = mask_    $ do let ref = tmp_files_to_clean tmpfs         to_delete <- atomicModifyIORef' ref $             \FilesToClean@@ -155,21 +153,20 @@                 , ftcGhcSession = gs_files                 } -> ( emptyFilesToClean                      , Set.toList cm_files ++ Set.toList gs_files)-        removeTmpFiles logger dflags to_delete+        removeTmpFiles logger to_delete  -- | Delete all files in @tmp_files_to_clean@. That have lifetime -- TFL_CurrentModule. -- If a file must be cleaned eventually, but must survive a -- cleanCurrentModuleTempFiles, ensure it has lifetime TFL_GhcSession.-cleanCurrentModuleTempFiles :: Logger -> TmpFs -> DynFlags -> IO ()-cleanCurrentModuleTempFiles logger tmpfs dflags-   = unless (gopt Opt_KeepTmpFiles dflags)-   $ mask_+cleanCurrentModuleTempFiles :: Logger -> TmpFs -> IO ()+cleanCurrentModuleTempFiles logger tmpfs+   = mask_    $ do let ref = tmp_files_to_clean tmpfs         to_delete <- atomicModifyIORef' ref $             \ftc@FilesToClean{ftcCurrentModule = cm_files} ->                 (ftc {ftcCurrentModule = Set.empty}, Set.toList cm_files)-        removeTmpFiles logger dflags to_delete+        removeTmpFiles logger to_delete  -- | Ensure that new_files are cleaned on the next call of -- 'cleanTempFiles' or 'cleanCurrentModuleTempFiles', depending on lifetime.@@ -212,9 +209,9 @@   atomicModifyIORef' (tmp_next_suffix tmpfs) $ \n -> (n+1,n)  -- Find a temporary name that doesn't already exist.-newTempName :: Logger -> TmpFs -> DynFlags -> TempFileLifetime -> Suffix -> IO FilePath-newTempName logger tmpfs dflags lifetime extn-  = do d <- getTempDir logger tmpfs dflags+newTempName :: Logger -> TmpFs -> TempDir -> TempFileLifetime -> Suffix -> IO FilePath+newTempName logger tmpfs tmp_dir lifetime extn+  = do d <- getTempDir logger tmpfs tmp_dir        findTempName (d </> "ghc_") -- See Note [Deterministic base name]   where     findTempName :: FilePath -> IO FilePath@@ -227,9 +224,9 @@                         addFilesToClean tmpfs lifetime [filename]                         return filename -newTempDir :: Logger -> TmpFs -> DynFlags -> IO FilePath-newTempDir logger tmpfs dflags-  = do d <- getTempDir logger tmpfs dflags+newTempDir :: Logger -> TmpFs -> TempDir -> IO FilePath+newTempDir logger tmpfs tmp_dir+  = do d <- getTempDir logger tmpfs tmp_dir        findTempDir (d </> "ghc_")   where     findTempDir :: FilePath -> IO FilePath@@ -242,10 +239,10 @@                         -- see mkTempDir below; this is wrong: -> consIORef (tmp_dirs_to_clean tmpfs) filename                         return filename -newTempLibName :: Logger -> TmpFs -> DynFlags -> TempFileLifetime -> Suffix+newTempLibName :: Logger -> TmpFs -> TempDir -> TempFileLifetime -> Suffix   -> IO (FilePath, FilePath, String)-newTempLibName logger tmpfs dflags lifetime extn-  = do d <- getTempDir logger tmpfs dflags+newTempLibName logger tmpfs tmp_dir lifetime extn+  = do d <- getTempDir logger tmpfs tmp_dir        findTempName d ("ghc_")   where     findTempName :: FilePath -> String -> IO (FilePath, FilePath, String)@@ -262,8 +259,8 @@  -- Return our temporary directory within tmp_dir, creating one if we -- don't have one yet.-getTempDir :: Logger -> TmpFs -> DynFlags -> IO FilePath-getTempDir logger tmpfs dflags = do+getTempDir :: Logger -> TmpFs -> TempDir -> IO FilePath+getTempDir logger tmpfs (TempDir tmp_dir) = do     mapping <- readIORef dir_ref     case Map.lookup tmp_dir mapping of         Nothing -> do@@ -272,7 +269,6 @@             mask_ $ mkTempDir prefix         Just dir -> return dir   where-    tmp_dir = tmpDir dflags     dir_ref = tmp_dirs_to_clean tmpfs      mkTempDir :: FilePath -> IO FilePath@@ -294,13 +290,13 @@         -- directory we created.  Otherwise return the directory we created.         case their_dir of             Nothing  -> do-                debugTraceMsg logger dflags 2 $+                debugTraceMsg logger 2 $                     text "Created temporary directory:" <+> text our_dir                 return our_dir             Just dir -> do                 removeDirectory our_dir                 return dir-      `catchIO` \e -> if isAlreadyExistsError e+      `Exception.catchIO` \e -> if isAlreadyExistsError e                       then mkTempDir prefix else ioError e  {- Note [Deterministic base name]@@ -314,18 +310,18 @@  This is ok, as the temporary directory used contains the pid (see getTempDir). -}-removeTmpDirs :: Logger -> DynFlags -> [FilePath] -> IO ()-removeTmpDirs logger dflags ds-  = traceCmd logger dflags "Deleting temp dirs"+removeTmpDirs :: Logger -> [FilePath] -> IO ()+removeTmpDirs logger ds+  = traceCmd logger "Deleting temp dirs"              ("Deleting: " ++ unwords ds)-             (mapM_ (removeWith logger dflags removeDirectory) ds)+             (mapM_ (removeWith logger removeDirectory) ds) -removeTmpFiles :: Logger -> DynFlags -> [FilePath] -> IO ()-removeTmpFiles logger dflags fs+removeTmpFiles :: Logger -> [FilePath] -> IO ()+removeTmpFiles logger fs   = warnNon $-    traceCmd logger dflags "Deleting temp files"+    traceCmd logger "Deleting temp files"              ("Deleting: " ++ unwords deletees)-             (mapM_ (removeWith logger dflags removeFile) deletees)+             (mapM_ (removeWith logger removeFile) deletees)   where      -- Flat out refuse to delete files that are likely to be source input      -- files (is there a worse bug than having a compiler delete your source@@ -336,21 +332,21 @@     warnNon act      | null non_deletees = act      | otherwise         = do-        putMsg logger dflags (text "WARNING - NOT deleting source files:"-                       <+> hsep (map text non_deletees))+        putMsg logger (text "WARNING - NOT deleting source files:"+                   <+> hsep (map text non_deletees))         act      (non_deletees, deletees) = partition isHaskellUserSrcFilename fs -removeWith :: Logger -> DynFlags -> (FilePath -> IO ()) -> FilePath -> IO ()-removeWith logger dflags remover f = remover f `catchIO`+removeWith :: Logger -> (FilePath -> IO ()) -> FilePath -> IO ()+removeWith logger remover f = remover f `Exception.catchIO`   (\e ->    let msg = if isDoesNotExistError e              then text "Warning: deleting non-existent" <+> text f              else text "Warning: exception raised when deleting"                                             <+> text f <> colon                $$ text (show e)-   in debugTraceMsg logger dflags 2 msg+   in debugTraceMsg logger 2 msg   )  #if defined(mingw32_HOST_OS)@@ -394,7 +390,7 @@     (ignoringIOErrors . removeDirectoryRecursive)  ignoringIOErrors :: IO () -> IO ()-ignoringIOErrors ioe = ioe `catchIO` const (return ())+ignoringIOErrors ioe = ioe `Exception.catchIO` const (return ())   createTempDirectory :: FilePath -> String -> IO FilePath@@ -405,5 +401,5 @@             let path = dir </> template ++ show x             createDirectory path             return path-          `catchIO` \e -> if isAlreadyExistsError e+          `Exception.catchIO` \e -> if isAlreadyExistsError e                           then findTempName (x+1) else ioError e
+ GHC/Utils/Trace.hs view
@@ -0,0 +1,88 @@+-- | Tracing utilities+module GHC.Utils.Trace+  ( pprTrace+  , pprTraceM+  , pprTraceDebug+  , pprTraceIt+  , pprTraceWith+  , pprSTrace+  , pprTraceException+  , warnPprTrace+  , pprTraceUserWarning+  , trace+  )+where++import GHC.Prelude+import GHC.Utils.Outputable+import GHC.Utils.Exception+import GHC.Utils.Panic+import GHC.Utils.GlobalVars+import GHC.Utils.Constants+import GHC.Stack++import Debug.Trace (trace)+import Control.Monad.IO.Class++-- | If debug output is on, show some 'SDoc' on the screen+pprTrace :: String -> SDoc -> a -> a+pprTrace str doc x+  | unsafeHasNoDebugOutput = x+  | otherwise              = pprDebugAndThen defaultSDocContext trace (text str) doc x++pprTraceM :: Applicative f => String -> SDoc -> f ()+pprTraceM str doc = pprTrace str doc (pure ())++pprTraceDebug :: String -> SDoc -> a -> a+pprTraceDebug str doc x+   | debugIsOn && unsafeHasPprDebug = pprTrace str doc x+   | otherwise                      = x++-- | @pprTraceWith desc f x@ is equivalent to @pprTrace desc (f x) x@.+-- This allows you to print details from the returned value as well as from+-- ambient variables.+pprTraceWith :: String -> (a -> SDoc) -> a -> a+pprTraceWith desc f x = pprTrace desc (f x) x++-- | @pprTraceIt desc x@ is equivalent to @pprTrace desc (ppr x) x@+pprTraceIt :: Outputable a => String -> a -> a+pprTraceIt desc x = pprTraceWith desc ppr x++-- | @pprTraceException desc x action@ runs action, printing a message+-- if it throws an exception.+pprTraceException :: ExceptionMonad m => String -> SDoc -> m a -> m a+pprTraceException heading doc =+    handleGhcException $ \exc -> liftIO $ do+        putStrLn $ renderWithContext defaultSDocContext+                 $ withPprStyle defaultDumpStyle+                 $ sep [text heading, nest 2 doc]+        throwGhcExceptionIO exc++-- | If debug output is on, show some 'SDoc' on the screen along+-- with a call stack when available.+pprSTrace :: HasCallStack => SDoc -> a -> a+pprSTrace doc = pprTrace "" (doc $$ traceCallStackDoc)++-- | Just warn about an assertion failure, recording the given file and line number.+warnPprTrace :: HasCallStack => Bool -> String -> SDoc -> a -> a+warnPprTrace _     _s _    x | not debugIsOn     = x+warnPprTrace _     _s _msg x | unsafeHasNoDebugOutput = x+warnPprTrace False _s _msg x = x+warnPprTrace True   s  msg x+  = pprDebugAndThen defaultSDocContext trace (text "WARNING:")+                    (text s $$ msg $$ withFrozenCallStack traceCallStackDoc )+                    x++-- | For when we want to show the user a non-fatal WARNING so that they can+-- report a GHC bug, but don't want to panic.+pprTraceUserWarning :: HasCallStack => SDoc -> a -> a+pprTraceUserWarning msg x+  | unsafeHasNoDebugOutput = x+  | otherwise = pprDebugAndThen defaultSDocContext trace (text "WARNING:")+                    (msg $$ withFrozenCallStack traceCallStackDoc )+                    x++traceCallStackDoc :: HasCallStack => SDoc+traceCallStackDoc =+    hang (text "Call stack:")+       4 (vcat $ map text $ lines (prettyCallStack callStack))
− HsVersions.h 
@@ -1,56 +0,0 @@-#pragma once---- For GHC_STAGE-#include "ghcplatform.h"--#if 0--IMPORTANT!  If you put extra tabs/spaces in these macro definitions,-you will screw up the layout where they are used in case expressions!--(This is cpp-dependent, of course)--#endif--#define GLOBAL_VAR(name,value,ty)  \-{-# NOINLINE name #-};             \-name :: IORef (ty);                \-name = GHC.Utils.GlobalVars.global (value);--#define GLOBAL_VAR_M(name,value,ty) \-{-# NOINLINE name #-};              \-name :: IORef (ty);                 \-name = GHC.Utils.GlobalVars.globalM (value);---#define SHARED_GLOBAL_VAR(name,accessor,saccessor,value,ty) \-{-# NOINLINE name #-};                                      \-name :: IORef (ty);                                         \-name = GHC.Utils.GlobalVars.sharedGlobal (value) (accessor);\-foreign import ccall unsafe saccessor                       \-  accessor :: Ptr (IORef a) -> IO (Ptr (IORef a));--#define SHARED_GLOBAL_VAR_M(name,accessor,saccessor,value,ty)  \-{-# NOINLINE name #-};                                         \-name :: IORef (ty);                                            \-name = GHC.Utils.GlobalVars.sharedGlobalM (value) (accessor);  \-foreign import ccall unsafe saccessor                          \-  accessor :: Ptr (IORef a) -> IO (Ptr (IORef a));---#define ASSERT(e)      if debugIsOn && not (e) then (assertPanic __FILE__ __LINE__) else-#define ASSERT2(e,msg) if debugIsOn && not (e) then (assertPprPanic __FILE__ __LINE__ (msg)) else-#define WARN( e, msg ) (warnPprTrace (e) __FILE__ __LINE__ (msg)) $---- Examples:   Assuming   flagSet :: String -> m Bool------    do { c   <- getChar; MASSERT( isUpper c ); ... }---    do { c   <- getChar; MASSERT2( isUpper c, text "Bad" ); ... }---    do { str <- getStr;  ASSERTM( flagSet str ); .. }---    do { str <- getStr;  ASSERTM2( flagSet str, text "Bad" ); .. }---    do { str <- getStr;  WARNM2( flagSet str, text "Flag is set" ); .. }-#define MASSERT(e)      ASSERT(e) return ()-#define MASSERT2(e,msg) ASSERT2(e,msg) return ()-#define ASSERTM(e)      do { bool <- e; MASSERT(bool) }-#define ASSERTM2(e,msg) do { bool <- e; MASSERT2(bool,msg) }-#define WARNM2(e,msg)   do { bool <- e; WARN(bool, msg) return () }
Language/Haskell/Syntax.hs view
@@ -40,8 +40,8 @@  Why are these modules not 'GHC.Hs.*', or some other 'GHC.*'? The answer is that they are to be separated from GHC and put into another package,-in accordance with the final goals of Trees that Grow. (See Note [Trees-that grow] in 'Language.Haskell.Syntax.Extension'.) In short, the+in accordance with the final goals of Trees That Grow. (See Note [Trees+That Grow] in 'Language.Haskell.Syntax.Extension'.) In short, the 'Language.Haskell.Syntax.*' tree should be entirely GHC-independent. GHC-specific stuff related to source-language syntax should be in 'GHC.Hs.*'.
Language/Haskell/Syntax/Binds.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -33,11 +32,9 @@  import Language.Haskell.Syntax.Extension import Language.Haskell.Syntax.Type-import GHC.Tc.Types.Evidence-import GHC.Core.Type+import GHC.Types.Name.Reader(RdrName) import GHC.Types.Basic import GHC.Types.SourceText-import GHC.Types.SrcLoc as SrcLoc import GHC.Types.Tickish import GHC.Types.Var import GHC.Types.Fixity@@ -45,8 +42,8 @@ import GHC.Data.BooleanFormula (LBooleanFormula)  import GHC.Utils.Outputable+import GHC.Utils.Panic (pprPanic) -import Data.Data hiding ( Fixity ) import Data.Void  {-@@ -199,28 +196,11 @@     --  - 'GHC.Parser.Annotation.AnnEqual','GHC.Parser.Annotation.AnnWhere',     --    'GHC.Parser.Annotation.AnnOpen','GHC.Parser.Annotation.AnnClose', -    -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+    -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation     FunBind {          fun_ext :: XFunBind idL idR, -          -- ^ After the renamer (but before the type-checker), this contains the-          -- locally-bound free variables of this defn. See Note [Bind free vars]-          ---          -- After the type-checker, this contains 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'.-         fun_id :: LIdP idL, -- Note [fun_id in Match] in GHC.Hs.Expr          fun_matches :: MatchGroup idR (LHsExpr idR),  -- ^ The payload@@ -240,9 +220,9 @@   --       'GHC.Parser.Annotation.AnnEqual','GHC.Parser.Annotation.AnnWhere',   --       'GHC.Parser.Annotation.AnnOpen','GHC.Parser.Annotation.AnnClose', -  -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+  -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   | PatBind {-        pat_ext    :: XPatBind idL idR, -- ^ See Note [Bind free vars]+        pat_ext    :: XPatBind idL idR,         pat_lhs    :: LPat idL,         pat_rhs    :: GRHSs idR (LHsExpr idR),         pat_ticks  :: ([CoreTickish], [[CoreTickish]])@@ -260,28 +240,6 @@         var_rhs    :: LHsExpr idR    -- ^ Located only for consistency     } -  -- | 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 "GHC.Tc.TyCl.Instance"-        -- 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)@@ -291,46 +249,21 @@         --          'GHC.Parser.Annotation.AnnWhere'         --          'GHC.Parser.Annotation.AnnOpen' @'{'@,'GHC.Parser.Annotation.AnnClose' @'}'@ -        -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+        -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation    | XHsBindsLR !(XXHsBindsLR idL idR)  -        -- 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 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)-- -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnPattern', --             'GHC.Parser.Annotation.AnnEqual','GHC.Parser.Annotation.AnnLarrow', --             'GHC.Parser.Annotation.AnnWhere','GHC.Parser.Annotation.AnnOpen' @'{'@, --             'GHC.Parser.Annotation.AnnClose' @'}'@, --- For details on above see note [exact print annotations] in GHC.Parser.Annotation+-- For details on above see Note [exact print annotations] in GHC.Parser.Annotation  -- | Pattern Synonym binding data PatSynBind idL idR-  = PSB { psb_ext  :: XPSB idL idR,            -- ^ Post renaming, FVs.-                                               -- See Note [Bind free vars]+  = PSB { psb_ext  :: XPSB idL idR,           psb_id   :: LIdP idL,                -- ^ Name of the pattern synonym           psb_args :: HsPatSynDetails idR,     -- ^ Formal parameter names           psb_def  :: LPat idR,                -- ^ Right-hand side@@ -338,240 +271,7 @@      }    | XPatSynBind !(XXPatSynBind idL idR) -{--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 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 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,--  * 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--}-- {- ************************************************************************ *                                                                      *@@ -595,22 +295,17 @@ -- ^ May have 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnSemi' when in a --   list --- For details on above see note [exact print annotations] in GHC.Parser.Annotation+-- For details on above see Note [exact print annotations] in GHC.Parser.Annotation  -- | 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.--- -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnEqual' --- For details on above see note [exact print annotations] in GHC.Parser.Annotation+-- For details on above see Note [exact print annotations] in GHC.Parser.Annotation data IPBind id   = IPBind         (XCIPBind id)-        (Either (XRec id HsIPName) (IdP id))+        (XRec id HsIPName)         (LHsExpr id)   | XIPBind !(XXIPBind id) @@ -647,7 +342,7 @@       --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDcolon',       --          'GHC.Parser.Annotation.AnnComma' -      -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+      -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation     TypeSig        (XTypeSig pass)        [LIdP pass]           -- LHS of the signature; e.g.  f,g,h :: blah@@ -661,7 +356,7 @@       --           'GHC.Parser.Annotation.AnnDcolon','GHC.Parser.Annotation.AnnForall'       --           'GHC.Parser.Annotation.AnnDot','GHC.Parser.Annotation.AnnDarrow' -      -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+      -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   | PatSynSig (XPatSynSig pass) [LIdP pass] (LHsSigType pass)       -- P :: forall a b. Req => Prov => ty @@ -692,7 +387,7 @@         --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnInfix',         --           'GHC.Parser.Annotation.AnnVal' -        -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+        -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   | FixSig (XFixSig pass) (FixitySig pass)          -- | An inline pragma@@ -705,7 +400,7 @@         --       'GHC.Parser.Annotation.AnnVal','GHC.Parser.Annotation.AnnTilde',         --       'GHC.Parser.Annotation.AnnClose' -        -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+        -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   | InlineSig   (XInlineSig pass)                 (LIdP pass)        -- Function name                 InlinePragma       -- Never defaultInlinePragma@@ -721,7 +416,7 @@         --      'GHC.Parser.Annotation.AnnClose' @']'@ and @'\#-}'@,         --      'GHC.Parser.Annotation.AnnDcolon' -        -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+        -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   | SpecSig     (XSpecSig pass)                 (LIdP pass)        -- Specialise a function or datatype  ...                 [LHsSigType pass]  -- ... to these types@@ -739,7 +434,7 @@         --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen',         --      'GHC.Parser.Annotation.AnnInstance','GHC.Parser.Annotation.AnnClose' -        -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+        -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   | SpecInstSig (XSpecInstSig pass) SourceText (LHsSigType pass)                   -- Note [Pragma source text] in GHC.Types.SourceText @@ -751,7 +446,7 @@         --      'GHC.Parser.Annotation.AnnVbar','GHC.Parser.Annotation.AnnComma',         --      'GHC.Parser.Annotation.AnnClose' -        -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+        -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   | MinimalSig (XMinimalSig pass)                SourceText (LBooleanFormula (LIdP pass))                -- Note [Pragma source text] in GHC.Types.SourceText@@ -788,39 +483,6 @@ data FixitySig pass = FixitySig (XFixitySig pass) [LIdP pass] Fixity                     | XFixitySig !(XXFixitySig pass) --- | 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 :: forall p. UnXRec p => LSig p -> Bool isFixityLSig (unXRec @p -> FixSig {}) = True isFixityLSig _                 = False@@ -871,17 +533,29 @@  | 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 (SpecSig _ _ _ 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 {})              = text "XSIG TTG extension" +-- | 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)+ {- ************************************************************************ *                                                                      *@@ -931,7 +605,7 @@ making the distinction between the two names clear.  -}-instance Outputable (RecordPatSynField a) where+instance Outputable (XRec a RdrName) => Outputable (RecordPatSynField a) where     ppr (RecordPatSynField { recordPatSynField = v }) = ppr v
Language/Haskell/Syntax/Decls.hs view
@@ -1,11 +1,13 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]                                       -- in module Language.Haskell.Syntax.Extension {-# LANGUAGE ViewPatterns #-}@@ -132,7 +134,7 @@         --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnSemi'         -- --- For details on above see note [exact print annotations] in GHC.Parser.Annotation+-- For details on above see Note [exact print annotations] in GHC.Parser.Annotation  -- | A Haskell Declaration data HsDecl p@@ -149,7 +151,8 @@   | RuleD      (XRuleD p)      (RuleDecls p)     -- ^ Rule declaration   | SpliceD    (XSpliceD p)    (SpliceDecl p)    -- ^ Splice declaration                                                  -- (Includes quasi-quotes)-  | DocD       (XDocD p)       (DocDecl)  -- ^ Documentation comment declaration+  | DocD       (XDocD p)       (DocDecl p)       -- ^ Documentation comment+                                                 -- declaration   | RoleAnnotD (XRoleAnnotD p) (RoleAnnotDecl p) -- ^Role annotation declaration   | XHsDecl    !(XXHsDecl p) @@ -400,7 +403,7 @@     --             'GHC.Parser.Annotation.AnnEqual','GHC.Parser.Annotation.AnnRarrow',     --             'GHC.Parser.Annotation.AnnVbar' -    -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+    -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation     FamDecl { tcdFExt :: XFamDecl pass, tcdFam :: FamilyDecl pass }    | -- | @type@ declaration@@ -408,7 +411,7 @@     --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnType',     --             'GHC.Parser.Annotation.AnnEqual', -    -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+    -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation     SynDecl { tcdSExt   :: XSynDecl pass          -- ^ Post renameer, FVs             , tcdLName  :: LIdP pass              -- ^ Type constructor             , tcdTyVars :: LHsQTyVars pass        -- ^ Type variables; for an@@ -425,14 +428,21 @@     --              'GHC.Parser.Annotation.AnnNewType','GHC.Parser.Annotation.AnnDcolon'     --              'GHC.Parser.Annotation.AnnWhere', -    -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+    -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation     DataDecl { tcdDExt     :: XDataDecl pass       -- ^ Post renamer, CUSK flag, FVs              , tcdLName    :: LIdP pass             -- ^ Type constructor              , tcdTyVars   :: LHsQTyVars pass      -- ^ Type variables-                              -- See Note [TyVar binders for associated declarations]+                              -- See Note [TyVar binders for associated decls]              , tcdFixity   :: LexicalFixity        -- ^ Fixity used in the declaration              , tcdDataDefn :: HsDataDefn pass } +    -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnClass',+    --           'GHC.Parser.Annotation.AnnWhere','GHC.Parser.Annotation.AnnOpen',+    --           'GHC.Parser.Annotation.AnnClose'+    --   - The tcdFDs will have 'GHC.Parser.Annotation.AnnVbar',+    --                          'GHC.Parser.Annotation.AnnComma'+    --                          'GHC.Parser.Annotation.AnnRarrow'+    -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   | ClassDecl { tcdCExt    :: XClassDecl pass,         -- ^ Post renamer, FVs                 tcdCtxt    :: Maybe (LHsContext pass), -- ^ Context...                 tcdLName   :: LIdP pass,               -- ^ Name of the class@@ -445,14 +455,6 @@                 tcdATDefs  :: [LTyFamDefltDecl pass],   -- ^ Associated type defaults                 tcdDocs    :: [LDocDecl pass]           -- ^ Haddock docs     }-        -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnClass',-        --           'GHC.Parser.Annotation.AnnWhere','GHC.Parser.Annotation.AnnOpen',-        --           'GHC.Parser.Annotation.AnnClose'-        --   - The tcdFDs will have 'GHC.Parser.Annotation.AnnVbar',-        --                          'GHC.Parser.Annotation.AnnComma'-        --                          'GHC.Parser.Annotation.AnnRarrow'--        -- For details on above see note [exact print annotations] in GHC.Parser.Annotation   | XTyClDecl !(XXTyClDecl pass)  data FunDep pass@@ -797,14 +799,14 @@     NoSig (XNoSig pass)   -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : -  -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+  -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation    | KindSig  (XCKindSig pass) (LHsKind pass)   -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' :   --             'GHC.Parser.Annotation.AnnOpenP','GHC.Parser.Annotation.AnnDcolon',   --             'GHC.Parser.Annotation.AnnCloseP' -  -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+  -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation    | TyVarSig (XTyVarSig pass) (LHsTyVarBndr () pass)   -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' :@@ -812,7 +814,7 @@   --             'GHC.Parser.Annotation.AnnCloseP', 'GHC.Parser.Annotation.AnnEqual'   | XFamilyResultSig !(XXFamilyResultSig pass) -  -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+  -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   -- | Located type Family Declaration@@ -825,7 +827,7 @@   , fdTopLevel       :: TopLevelFlag                 -- used for printing only   , fdLName          :: LIdP pass                    -- type constructor   , fdTyVars         :: LHsQTyVars pass              -- type variables-                       -- See Note [TyVar binders for associated declarations]+                       -- See Note [TyVar binders for associated decls]   , fdFixity         :: LexicalFixity                -- Fixity used in the declaration   , fdResultSig      :: LFamilyResultSig pass        -- result signature   , fdInjectivityAnn :: Maybe (LInjectivityAnn pass) -- optional injectivity ann@@ -838,7 +840,7 @@   --             'GHC.Parser.Annotation.AnnEqual', 'GHC.Parser.Annotation.AnnRarrow',   --             'GHC.Parser.Annotation.AnnVbar' -  -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+  -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   -- | Located Injectivity Annotation@@ -858,7 +860,7 @@   -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' :   --             'GHC.Parser.Annotation.AnnRarrow', 'GHC.Parser.Annotation.AnnVbar' -  -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+  -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   | XInjectivityAnn !(XXInjectivityAnn pass)  data FamilyInfo pass@@ -918,7 +920,7 @@                   dd_derivs :: HsDeriving pass  -- ^ Optional 'deriving' clause -             -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+             -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation    }   | XHsDataDefn !(XXHsDataDefn pass) @@ -1021,7 +1023,7 @@       -- ^ May have 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnSemi' when       --   in a GADT constructor list -  -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+  -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation  -- | --@@ -1045,7 +1047,7 @@ --            'GHC.Parser.Annotation.AnnDarrow','GHC.Parser.Annotation.AnnDarrow', --            'GHC.Parser.Annotation.AnnForall','GHC.Parser.Annotation.AnnDot' --- For details on above see note [exact print annotations] in GHC.Parser.Annotation+-- For details on above see Note [exact print annotations] in GHC.Parser.Annotation  -- | data Constructor Declaration data ConDecl pass@@ -1063,8 +1065,8 @@       , con_g_args  :: HsConDeclGADTDetails pass -- ^ Arguments; never infix       , con_res_ty  :: LHsType pass              -- ^ Result type -      , con_doc     :: Maybe LHsDocString-          -- ^ A possible Haddock comment.+      , con_doc     :: Maybe (LHsDoc pass) -- ^ A possible Haddock+                                                 -- comment.       }    | ConDeclH98@@ -1080,8 +1082,7 @@       , con_mb_cxt :: Maybe (LHsContext pass)         -- ^ User-written context (if any)       , con_args   :: HsConDeclH98Details pass        -- ^ Arguments; can be infix -      , con_doc       :: Maybe LHsDocString-          -- ^ A possible Haddock comment.+      , con_doc    :: Maybe (LHsDoc pass) -- ^ A possible Haddock comment.       }   | XConDecl !(XXConDecl pass) @@ -1215,7 +1216,7 @@ -- GHC.Tc.TyCl—but that is an orthogonal concern.) data HsConDeclGADTDetails pass    = PrefixConGADT [HsScaled pass (LBangType pass)]-   | RecConGADT (XRec pass [LConDeclField pass])+   | RecConGADT (XRec pass [LConDeclField pass]) (LHsUniToken "->" "→" pass)  instance Outputable NewOrData where   ppr NewType  = text "newtype"@@ -1257,7 +1258,7 @@   -- ^ May have 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnSemi'   --   when in a list --- For details on above see note [exact print annotations] in GHC.Parser.Annotation+-- For details on above see Note [exact print annotations] in GHC.Parser.Annotation  -- | Haskell Type Patterns type HsTyPats pass = [LHsTypeArg pass]@@ -1317,7 +1318,7 @@     --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnType',     --           'GHC.Parser.Annotation.AnnInstance', -    -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+    -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   | XTyFamInstDecl !(XXTyFamInstDecl pass)  ----------------- Data family instances -------------@@ -1335,7 +1336,7 @@     --           'GHC.Parser.Annotation.AnnWhere','GHC.Parser.Annotation.AnnOpen',     --           'GHC.Parser.Annotation.AnnClose' -    -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+    -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation  ----------------- Family instances (common types) ------------- @@ -1358,7 +1359,7 @@     --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnEqual'   | XFamEqn !(XXFamEqn pass rhs) -    -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+    -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation  ----------------- Class instances ------------- @@ -1366,6 +1367,10 @@ type LClsInstDecl pass = XRec pass (ClsInstDecl pass)  -- | Class Instance Declaration+--  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnInstance',+--           'GHC.Parser.Annotation.AnnWhere',+--           'GHC.Parser.Annotation.AnnOpen','GHC.Parser.Annotation.AnnClose',+-- For details on above see Note [exact print annotations] in GHC.Parser.Annotation data ClsInstDecl pass   = ClsInstDecl       { cid_ext     :: XCClsInstDecl pass@@ -1380,14 +1385,8 @@          -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen',          --                                    'GHC.Parser.Annotation.AnnClose', -        -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+        -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation       }-    -- ^-    --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnInstance',-    --           'GHC.Parser.Annotation.AnnWhere',-    --           'GHC.Parser.Annotation.AnnOpen','GHC.Parser.Annotation.AnnClose',--    -- For details on above see note [exact print annotations] in GHC.Parser.Annotation   | XClsInstDecl !(XXClsInstDecl pass)  ----------------- Instances of all kinds -------------@@ -1441,7 +1440,7 @@          --        'GHC.Parser.Annotation.AnnAnyClass', 'GHC.Parser.Annotation.AnnNewtype',          --        'GHC.Parser.Annotation.AnnOpen','GHC.Parser.Annotation.AnnClose' -  -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+  -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation         }   | XDerivDecl !(XXDerivDecl pass) @@ -1500,7 +1499,7 @@         -- ^ - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnDefault',         --          'GHC.Parser.Annotation.AnnOpen','GHC.Parser.Annotation.AnnClose' -        -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+        -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   | XDefaultDecl !(XXDefaultDecl pass)  {-@@ -1538,7 +1537,7 @@         --           'GHC.Parser.Annotation.AnnImport','GHC.Parser.Annotation.AnnExport',         --           'GHC.Parser.Annotation.AnnDcolon' -        -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+        -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   | XForeignDecl !(XXForeignDecl pass)  {-@@ -1688,12 +1687,12 @@         --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen',         --     'GHC.Parser.Annotation.AnnDcolon','GHC.Parser.Annotation.AnnClose' -        -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+        -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation  collectRuleBndrSigTys :: [RuleBndr pass] -> [HsPatSigType pass] collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ _ ty <- bndrs] -pprFullRuleName :: Located (SourceText, RuleName) -> SDoc+pprFullRuleName :: GenLocated a (SourceText, RuleName) -> SDoc pprFullRuleName (L _ (st, n)) = pprWithSourceText st (doubleQuotes $ ftext n)  {-@@ -1705,21 +1704,22 @@ -}  -- | Located Documentation comment Declaration-type LDocDecl pass = XRec pass (DocDecl)+type LDocDecl pass = XRec pass (DocDecl pass)  -- | Documentation comment Declaration-data DocDecl-  = DocCommentNext HsDocString-  | DocCommentPrev HsDocString-  | DocCommentNamed String HsDocString-  | DocGroup Int HsDocString-  deriving Data+data DocDecl pass+  = DocCommentNext (LHsDoc pass)+  | DocCommentPrev (LHsDoc pass)+  | DocCommentNamed String (LHsDoc pass)+  | DocGroup Int (LHsDoc pass) +deriving instance (Data pass, Data (IdP pass)) => Data (DocDecl pass)+ -- Okay, I need to reconstruct the document comments, but for now:-instance Outputable DocDecl where+instance Outputable (DocDecl name) where   ppr _ = text "<document comment>" -docDeclDoc :: DocDecl -> HsDocString+docDeclDoc :: DocDecl pass -> LHsDoc pass docDeclDoc (DocCommentNext d) = d docDeclDoc (DocCommentPrev d) = d docDeclDoc (DocCommentNamed _ d) = d@@ -1750,9 +1750,10 @@ type LWarnDecl pass = XRec pass (WarnDecl pass)  -- | Warning pragma Declaration-data WarnDecl pass = Warning (XWarning pass) [LIdP pass] WarningTxt+data WarnDecl pass = Warning (XWarning pass) [LIdP pass] (WarningTxt pass)                    | XWarnDecl !(XXWarnDecl pass) + {- ************************************************************************ *                                                                      *@@ -1774,7 +1775,7 @@       --           'GHC.Parser.Annotation.AnnModule'       --           'GHC.Parser.Annotation.AnnClose' -      -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+      -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   | XAnnDecl !(XXAnnDecl pass)  -- | Annotation Provenance@@ -1812,5 +1813,5 @@       -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnType',       --           'GHC.Parser.Annotation.AnnRole' -      -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+      -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   | XRoleAnnotDecl !(XXRoleAnnotDecl pass)
Language/Haskell/Syntax/Expr.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-}@@ -23,9 +23,6 @@ -- | Abstract Haskell syntax for expressions. module Language.Haskell.Syntax.Expr where -#include "HsVersions.h"---- friends: import GHC.Prelude  import Language.Haskell.Syntax.Decls@@ -36,15 +33,12 @@ import Language.Haskell.Syntax.Binds  -- others:-import GHC.Tc.Types.Evidence import GHC.Core.DataCon (FieldLabelString) import GHC.Types.Name import GHC.Types.Basic import GHC.Types.Fixity import GHC.Types.SourceText import GHC.Types.SrcLoc-import GHC.Types.Tickish-import GHC.Core.ConLike import GHC.Unit.Module (ModuleName) import GHC.Utils.Outputable import GHC.Utils.Panic@@ -103,19 +97,20 @@ The results of these new rules cannot be represented by @LHsRecField GhcPs (LHsExpr GhcPs)@ values as the type is defined today. We minimize modifying existing code by having these new rules calculate-@LHsRecProj GhcPs (Located b)@ ("record projection") values instead:+@LHsRecProj GhcPs (LHsExpr GhcPs)@ ("record projection") values+instead: @-newtype FieldLabelStrings = FieldLabelStrings [Located FieldLabelString]-type RecProj arg = HsRecField' FieldLabelStrings arg-type LHsRecProj p arg = Located (RecProj arg)+newtype FieldLabelStrings = FieldLabelStrings [XRec p (DotFieldOcc p)]+type RecProj arg = HsFieldBind FieldLabelStrings arg+type LHsRecProj p arg = XRec p (RecProj arg) @  The @fbind@ rule is then given the type @fbind :: { forall b. DisambECP b => PV (Fbind b) }@ accomodating both alternatives: @ type Fbind b = Either-                  (LHsRecField GhcPs (Located b))-                  ( LHsRecProj GhcPs (Located b))+                  (LHsRecField GhcPs (LocatedA b))+                  ( LHsRecProj GhcPs (LocatedA b)) @  In @data HsExpr p@, the @RecordUpd@ constuctor indicates regular@@ -130,8 +125,8 @@ @ Here, @-type RecUpdProj p = RecProj (LHsExpr p)-type LHsRecUpdProj p = Located (RecUpdProj p)+type RecUpdProj p = RecProj p (LHsExpr p)+type LHsRecUpdProj p = XRec p (RecUpdProj p) @ and @Left@ values indicating regular record update, @Right@ values updates desugared to @setField@s.@@ -143,28 +138,34 @@  -- | RecordDotSyntax field updates +type LFieldLabelStrings p = XRec p (FieldLabelStrings p)+ newtype FieldLabelStrings p =-  FieldLabelStrings [Located (HsFieldLabel p)]+  FieldLabelStrings [XRec p (DotFieldOcc p)] -instance Outputable (FieldLabelStrings p) where+instance (UnXRec p, Outputable (XRec p FieldLabelString)) => Outputable (FieldLabelStrings p) where   ppr (FieldLabelStrings flds) =-    hcat (punctuate dot (map (ppr . unLoc) flds))+    hcat (punctuate dot (map (ppr . unXRec @p) flds)) -instance OutputableBndr (FieldLabelStrings p) where+instance (UnXRec p, Outputable (XRec p FieldLabelString)) => OutputableBndr (FieldLabelStrings p) where   pprInfixOcc = pprFieldLabelStrings   pprPrefixOcc = pprFieldLabelStrings -pprFieldLabelStrings :: FieldLabelStrings p -> SDoc+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 (map (ppr . unLoc) flds))+    hcat (punctuate dot (map (ppr . unXRec @p) flds)) -instance Outputable (HsFieldLabel p) where-  ppr (HsFieldLabel _ s) = ppr s-  ppr XHsFieldLabel{} = text "XHsFieldLabel"+instance Outputable(XRec p FieldLabelString) => Outputable (DotFieldOcc p) where+  ppr (DotFieldOcc _ s) = ppr s+  ppr XDotFieldOcc{} = text "XDotFieldOcc"  -- Field projection updates (e.g. @foo.bar.baz = 1@). See Note -- [RecordDotSyntax field updates].-type RecProj p arg = HsRecField' (FieldLabelStrings p) arg+type RecProj p arg = HsFieldBind (LFieldLabelStrings p) arg  -- The phantom type parameter @p@ is for symmetry with @LHsRecField p -- arg@ in the definition of @data Fbind@ (see GHC.Parser.Process).@@ -190,7 +191,7 @@   -- ^ May have 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnComma' when   --   in a list -  -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+  -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation  ------------------------- {- Note [NoSyntaxExpr]@@ -267,6 +268,55 @@     typecheck do-notation with (>>=) :: m1 a -> (a -> m2 b) -> m2 b.) -} +{-+Note [Record selectors in the AST]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Here is how record selectors are expressed in GHC's AST:++Example data type+  data T = MkT { size :: Int }++Record selectors:+                      |    GhcPs     |   GhcRn              |    GhcTc            |+----------------------------------------------------------------------------------|+size (assuming one    | HsVar        | HsRecSel             | HsRecSel            |+     'size' in scope) |              |                      |                     |+----------------------|--------------|----------------------|---------------------|+.size (assuming       | HsProjection | getField @"size"     | getField @"size"    |+ OverloadedRecordDot) |              |                      |                     |+----------------------|--------------|----------------------|---------------------|+e.size (assuming      | HsGetField   | getField @"size" e   | getField @"size" e  |+ OverloadedRecordDot) |              |                      |                     |++NB 1: DuplicateRecordFields makes no difference to the first row of+this table, except that if 'size' is a field of more than one data+type, then a naked use of the record selector 'size' may well be+ambiguous. You have to use a qualified name. And there is no way to do+this if both data types are declared in the same module.++NB 2: The notation getField @"size" e is short for+HsApp (HsAppType (HsVar "getField") (HsWC (HsTyLit (HsStrTy "size")) [])) e.+We track the original parsed syntax via HsExpanded.++-}++{-+Note [Non-overloaded record field selectors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+    data T = MkT { x,y :: Int }+    f r x = x + y r++This parses with HsVar for x, y, r on the RHS of f. Later, the renamer+recognises that y in the RHS of f is really a record selector, and+changes it to a HsRecSel. In contrast x is locally bound, shadowing+the record selector, and stays as an HsVar.++The renamer adds the Name of the record selector into the XCFieldOcc+extension field, The typechecker keeps HsRecSel as HsRecSel, and+transforms the record-selector Name to an Id.+-}+ -- | A Haskell expression. data HsExpr p   = HsVar     (XVar p)@@ -284,15 +334,11 @@                              --   erroring expression will be written after                              --   solving. See Note [Holes] in GHC.Tc.Types.Constraint. -  | HsConLikeOut (XConLikeOut p)-                 ConLike     -- ^ After typechecker only; must be different-                             -- HsVar for pretty printing -  | HsRecFld  (XRecFld p)-              (AmbiguousFieldOcc p) -- ^ Variable pointing to record selector-              -- The parser produces HsVars-              -- The renamer renames record-field selectors to HsRecFld-              -- The typechecker preserves HsRecFld+  | HsRecSel  (XRecSel p)+              (FieldOcc p) -- ^ Variable pointing to record selector+                           -- See Note [Non-overloaded record field selectors] and+                           -- Note [Record selectors in the AST]    | HsOverLabel (XOverLabel p) FastString      -- ^ Overloaded label (Note [Overloaded labels] in GHC.OverloadedLabels)@@ -312,15 +358,19 @@        -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLam',        --       'GHC.Parser.Annotation.AnnRarrow', -       -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+       -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation -  | HsLamCase (XLamCase p) (MatchGroup p (LHsExpr p)) -- ^ Lambda-case-       ---       -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLam',-       --           'GHC.Parser.Annotation.AnnCase','GHC.Parser.Annotation.AnnOpen',-       --           'GHC.Parser.Annotation.AnnClose'+  -- | Lambda-case+  --+  -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLam',+  --           'GHC.Parser.Annotation.AnnCase','GHC.Parser.Annotation.AnnOpen',+  --           'GHC.Parser.Annotation.AnnClose'+  -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLam',+  --           'GHC.Parser.Annotation.AnnCases','GHC.Parser.Annotation.AnnOpen',+  --           'GHC.Parser.Annotation.AnnClose' -       -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+  -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation+  | HsLamCase (XLamCase p) LamCaseVariant (MatchGroup p (LHsExpr p))    | HsApp     (XApp p) (LHsExpr p) (LHsExpr p) -- ^ Application @@ -337,7 +387,7 @@   -- NB Bracketed ops such as (+) come out as Vars.    -- NB Sadly, we need an expr for the operator in an OpApp/Section since-  -- the renamer may turn a HsVar into HsRecFld or HsUnboundVar+  -- the renamer may turn a HsVar into HsRecSel or HsUnboundVar    | OpApp       (XOpApp p)                 (LHsExpr p)       -- left operand@@ -349,7 +399,7 @@   --   --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnMinus' -  -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+  -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   | NegApp      (XNegApp p)                 (LHsExpr p)                 (SyntaxExpr p)@@ -357,9 +407,11 @@   -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'('@,   --             'GHC.Parser.Annotation.AnnClose' @')'@ -  -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+  -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   | HsPar       (XPar p)+               !(LHsToken "(" p)                 (LHsExpr p)  -- ^ Parenthesised expr; see Note [Parens in HsSyn]+               !(LHsToken ")" p)    | SectionL    (XSectionL p)                 (LHsExpr p)    -- operand; see Note [Sections in HsSyn]@@ -373,7 +425,7 @@   --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen',   --         'GHC.Parser.Annotation.AnnClose' -  -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+  -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   -- Note [ExplicitTuple]   | ExplicitTuple         (XExplicitTuple p)@@ -397,7 +449,7 @@   --       'GHC.Parser.Annotation.AnnOf','GHC.Parser.Annotation.AnnOpen' @'{'@,   --       'GHC.Parser.Annotation.AnnClose' @'}'@ -  -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+  -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   | HsCase      (XCase p)                 (LHsExpr p)                 (MatchGroup p (LHsExpr p))@@ -407,7 +459,7 @@   --       'GHC.Parser.Annotation.AnnThen','GHC.Parser.Annotation.AnnSemi',   --       'GHC.Parser.Annotation.AnnElse', -  -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+  -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   | HsIf        (XIf p)        -- GhcPs: this is a Bool; False <=> do not use                                --  rebindable syntax                 (LHsExpr p)    --  predicate@@ -419,7 +471,7 @@   -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnIf'   --       'GHC.Parser.Annotation.AnnOpen','GHC.Parser.Annotation.AnnClose', -  -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+  -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   | HsMultiIf   (XMultiIf p) [LGRHS p (LHsExpr p)]    -- | let(rec)@@ -428,9 +480,11 @@   --       'GHC.Parser.Annotation.AnnOpen' @'{'@,   --       'GHC.Parser.Annotation.AnnClose' @'}'@,'GHC.Parser.Annotation.AnnIn' -  -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+  -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   | HsLet       (XLet p)+               !(LHsToken "let" p)                 (HsLocalBinds p)+               !(LHsToken "in" p)                 (LHsExpr  p)    -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDo',@@ -438,12 +492,9 @@   --             'GHC.Parser.Annotation.AnnVbar',   --             'GHC.Parser.Annotation.AnnClose' -  -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+  -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   | HsDo        (XDo p)                  -- Type of the whole expression-                (HsStmtContext (HsDoRn p))-                -- The parameterisation of the above is unimportant-                -- because in this context we never use-                -- the PatGuard or ParStmt variant+                HsDoFlavour                 (XRec p [ExprLStmt p])   -- "do":one or more stmts    -- | Syntactic list: [a,b,c,...]@@ -451,7 +502,7 @@   --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'['@,   --              'GHC.Parser.Annotation.AnnClose' @']'@ -  -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+  -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   -- See Note [Empty lists]   | ExplicitList                 (XExplicitList p)  -- Gives type of components of list@@ -462,7 +513,7 @@   --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'{'@,   --         'GHC.Parser.Annotation.AnnDotdot','GHC.Parser.Annotation.AnnClose' @'}'@ -  -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+  -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   | RecordCon       { rcon_ext  :: XRecordCon p       , rcon_con  :: XRec p (ConLikeP p)  -- The constructor@@ -475,7 +526,7 @@   --         'GHC.Parser.Annotation.AnnComma, 'GHC.Parser.Annotation.AnnDot',   --         'GHC.Parser.Annotation.AnnClose' @'}'@ -  -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+  -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   | RecordUpd       { rupd_ext  :: XRecordUpd p       , rupd_expr :: LHsExpr p@@ -487,34 +538,36 @@   -- | Record field selection e.g @z.x@.   --   --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDot'-  ---  -- This case only arises when the OverloadedRecordDot langauge-  -- extension is enabled. +  -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation++  -- This case only arises when the OverloadedRecordDot langauge+  -- extension is enabled. See Note [Record selectors in the AST].   | HsGetField {         gf_ext :: XGetField p       , gf_expr :: LHsExpr p-      , gf_field :: Located (HsFieldLabel p)+      , gf_field :: XRec p (DotFieldOcc p)       }    -- | Record field selector. e.g. @(.x)@ or @(.x.y)@   --+  -- This case only arises when the OverloadedRecordDot langauge+  -- extensions is enabled. See Note [Record selectors in the AST].+   --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpenP'   --         'GHC.Parser.Annotation.AnnDot', 'GHC.Parser.Annotation.AnnCloseP'-  ---  -- This case only arises when the OverloadedRecordDot langauge-  -- extensions is enabled. +  -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   | HsProjection {         proj_ext :: XProjection p-      , proj_flds :: NonEmpty (Located (HsFieldLabel p))+      , proj_flds :: NonEmpty (XRec p (DotFieldOcc p))       }    -- | Expression with an explicit type signature. @e :: type@   --   --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDcolon' -  -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+  -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   | ExprWithTySig                 (XExprWithTySig p) @@ -527,14 +580,14 @@   --              'GHC.Parser.Annotation.AnnComma','GHC.Parser.Annotation.AnnDotdot',   --              'GHC.Parser.Annotation.AnnClose' @']'@ -  -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+  -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   | ArithSeq                 (XArithSeq p)                 (Maybe (SyntaxExpr p))                                   -- For OverloadedLists, the fromList witness                 (ArithSeqInfo p) -  -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+  -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation    -----------------------------------------------------------   -- MetaHaskell Extensions@@ -543,29 +596,14 @@   --         'GHC.Parser.Annotation.AnnOpenE','GHC.Parser.Annotation.AnnOpenEQ',   --         'GHC.Parser.Annotation.AnnClose','GHC.Parser.Annotation.AnnCloseQ' -  -- For details on above see note [exact print annotations] in GHC.Parser.Annotation-  | HsBracket    (XBracket p) (HsBracket p)--    -- See Note [Pending Splices]-  | HsRnBracketOut-      (XRnBracketOut p)-      (HsBracket (HsBracketRn p)) -- Output of the renamer is the *original* renamed-                                  -- expression, plus-      [PendingRnSplice' p] -- _renamed_ splices to be type checked--  | HsTcBracketOut-      (XTcBracketOut p)-      (Maybe QuoteWrapper) -- The wrapper to apply type and dictionary argument-                           -- to the quote.-      (HsBracket (HsBracketRn p)) -- Output of the type checker is the *original*-                                 -- renamed expression, plus-      [PendingTcSplice' p] -- _typechecked_ splices to be-                           -- pasted back in by the desugarer+  -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation+  | HsTypedBracket   (XTypedBracket p)   (LHsExpr p)+  | HsUntypedBracket (XUntypedBracket p) (HsQuote p)    -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen',   --         'GHC.Parser.Annotation.AnnClose' -  -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+  -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   | HsSpliceE  (XSpliceE p) (HsSplice p)    -----------------------------------------------------------@@ -576,7 +614,7 @@   --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnProc',   --          'GHC.Parser.Annotation.AnnRarrow' -  -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+  -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   | HsProc      (XProc p)                 (LPat p)               -- arrow abstraction, proc                 (LHsCmdTop p)          -- body of the abstraction@@ -586,48 +624,27 @@   -- static pointers extension   -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnStatic', -  -- For details on above see note [exact print annotations] in GHC.Parser.Annotation-  | HsStatic (XStatic p) -- Free variables of the body+  -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation+  | HsStatic (XStatic p) -- Free variables of the body, and type after typechecking              (LHsExpr p)        -- Body    ----------------------------------------  -- Haskell program coverage (Hpc) Support--  | HsTick-     (XTick p)-     CoreTickish-     (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--  ---------------------------------------   -- Expressions annotated with pragmas, written as {-# ... #-}   | HsPragE (XPragE p) (HsPragE p) (LHsExpr p)    | XExpr       !(XXExpr p)-  -- Note [Trees that Grow] extension constructor for the+  -- Note [Trees That Grow] in Language.Haskell.Syntax.Extension for the   -- general idea, and Note [Rebindable syntax and HsExpansion] in GHC.Hs.Expr   -- for an example of how we use it. --- | The AST used to hard-refer to GhcPass, which was a layer violation. For now,--- we paper it over with this new extension point.-type family HsDoRn p-type family HsBracketRn p-type family PendingRnSplice' p-type family PendingTcSplice' p- -- --------------------------------------------------------------------- -data HsFieldLabel p-  = HsFieldLabel-    { hflExt   :: XCHsFieldLabel p-    , hflLabel :: Located FieldLabelString+data DotFieldOcc p+  = DotFieldOcc+    { dfoExt   :: XCDotFieldOcc p+    , dfoLabel :: XRec p FieldLabelString     }-  | XHsFieldLabel !(XXHsFieldLabel p)+  | XDotFieldOcc !(XXDotFieldOcc p)  -- --------------------------------------------------------------------- @@ -657,14 +674,25 @@ type LHsTupArg id = XRec id (HsTupArg id) -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnComma' --- For details on above see note [exact print annotations] in GHC.Parser.Annotation+-- For details on above see Note [exact print annotations] in GHC.Parser.Annotation  -- | 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+  | XTupArg !(XXTupArg id)   -- ^ Extension point; see Note [Trees That Grow]+                             -- in Language.Haskell.Syntax.Extension +-- | Which kind of lambda case are we dealing with?+data LamCaseVariant+  = LamCase -- ^ `\case`+  | LamCases -- ^ `\cases`+  deriving (Data, Eq)++lamCaseKeyword :: LamCaseVariant -> SDoc+lamCaseKeyword LamCase  = text "\\case"+lamCaseKeyword LamCases = text "\\cases"+ {- Note [Parens in HsSyn] ~~~~~~~~~~~~~~~~~~~~~~@@ -845,7 +873,7 @@   --          'GHC.Parser.Annotation.Annrarrowtail','GHC.Parser.Annotation.AnnLarrowtail',   --          'GHC.Parser.Annotation.AnnRarrowtail' -  -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+  -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   = 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@@ -858,7 +886,7 @@   -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpenB' @'(|'@,   --         'GHC.Parser.Annotation.AnnCloseB' @'|)'@ -  -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+  -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   | HsCmdArrForm         -- Command formation,  (| e cmd1 .. cmdn |)         (XCmdArrForm id)         (LHsExpr id)     -- The operator.@@ -879,14 +907,16 @@        -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLam',        --       'GHC.Parser.Annotation.AnnRarrow', -       -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+       -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation    | HsCmdPar    (XCmdPar id)+               !(LHsToken "(" id)                 (LHsCmd id)                     -- parenthesised command+               !(LHsToken ")" id)     -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'('@,     --             'GHC.Parser.Annotation.AnnClose' @')'@ -    -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+    -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation    | HsCmdCase   (XCmdCase id)                 (LHsExpr id)@@ -895,15 +925,20 @@     --       'GHC.Parser.Annotation.AnnOf','GHC.Parser.Annotation.AnnOpen' @'{'@,     --       'GHC.Parser.Annotation.AnnClose' @'}'@ -    -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+    -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation -  | HsCmdLamCase (XCmdLamCase id)-                 (MatchGroup id (LHsCmd id))    -- bodies are HsCmd's-    -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLam',-    --       'GHC.Parser.Annotation.AnnCase','GHC.Parser.Annotation.AnnOpen' @'{'@,-    --       'GHC.Parser.Annotation.AnnClose' @'}'@+  -- | Lambda-case+  --+  -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLam',+  --     'GHC.Parser.Annotation.AnnCase','GHC.Parser.Annotation.AnnOpen' @'{'@,+  --     'GHC.Parser.Annotation.AnnClose' @'}'@+  -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLam',+  --     'GHC.Parser.Annotation.AnnCases','GHC.Parser.Annotation.AnnOpen' @'{'@,+  --     'GHC.Parser.Annotation.AnnClose' @'}'@ -    -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+  -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation+  | HsCmdLamCase (XCmdLamCase id) LamCaseVariant+                 (MatchGroup id (LHsCmd id)) -- bodies are HsCmd's    | HsCmdIf     (XCmdIf id)                 (SyntaxExpr id)         -- cond function@@ -915,16 +950,18 @@     --       'GHC.Parser.Annotation.AnnThen','GHC.Parser.Annotation.AnnSemi',     --       'GHC.Parser.Annotation.AnnElse', -    -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+    -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation    | HsCmdLet    (XCmdLet id)+               !(LHsToken "let" id)                 (HsLocalBinds id)      -- let(rec)+               !(LHsToken "in" id)                 (LHsCmd  id)     -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLet',     --       'GHC.Parser.Annotation.AnnOpen' @'{'@,     --       'GHC.Parser.Annotation.AnnClose' @'}'@,'GHC.Parser.Annotation.AnnIn' -    -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+    -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation    | HsCmdDo     (XCmdDo id)                     -- Type of the whole expression                 (XRec id [CmdLStmt id])@@ -933,15 +970,23 @@     --             'GHC.Parser.Annotation.AnnVbar',     --             'GHC.Parser.Annotation.AnnClose' -    -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+    -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation -  | XCmd        !(XXCmd id)     -- Note [Trees that Grow] extension point+  | XCmd        !(XXCmd id)     -- Extension point; see Note [Trees That Grow]+                                -- in Language.Haskell.Syntax.Extension  --- | Haskell Array Application Type-data HsArrAppType = HsHigherOrderApp | HsFirstOrderApp-  deriving Data+-- | Haskell arrow application type.+data HsArrAppType+  -- | First order arrow application '-<'+  = HsHigherOrderApp+  -- | Higher order arrow application '-<<'+  | HsFirstOrderApp+    deriving Data +pprHsArrType :: HsArrAppType -> SDoc+pprHsArrType HsHigherOrderApp = text "higher order arrow application"+pprHsArrType HsFirstOrderApp  = text "first order arrow application"  {- | Top-level command, introducing a new arrow. This may occur inside a proc (where the stack is empty) or as an@@ -955,7 +1000,8 @@ data HsCmdTop p   = HsCmdTop (XCmdTop p)              (LHsCmd p)-  | XCmdTop !(XXCmdTop p)        -- Note [Trees that Grow] extension point+  | XCmdTop !(XXCmdTop p)        -- Extension point; see Note [Trees That Grow]+                                 -- in Language.Haskell.Syntax.Extension  ----------------------- @@ -1012,12 +1058,12 @@ -- ^ May have 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnSemi' when in a --   list --- For details on above see note [exact print annotations] in GHC.Parser.Annotation+-- For details on above see Note [exact print annotations] in GHC.Parser.Annotation data Match p body   = Match {         m_ext :: XCMatch p body,-        m_ctxt :: HsMatchContext (NoGhcTc p),-          -- See note [m_ctxt in Match]+        m_ctxt :: HsMatchContext p,+          -- See Note [m_ctxt in Match]         m_pats :: [LPat p], -- The patterns         m_grhss :: (GRHSs p body)   }@@ -1075,7 +1121,7 @@ --        'GHC.Parser.Annotation.AnnOpen','GHC.Parser.Annotation.AnnClose' --        'GHC.Parser.Annotation.AnnRarrow','GHC.Parser.Annotation.AnnSemi' --- For details on above see note [exact print annotations] in GHC.Parser.Annotation+-- For details on above see Note [exact print annotations] in GHC.Parser.Annotation data GRHSs p body   = GRHSs {       grhssExt :: XCGRHSs p body,@@ -1144,7 +1190,7 @@ --         'GHC.Parser.Annotation.AnnBy','GHC.Parser.Annotation.AnnBy', --         'GHC.Parser.Annotation.AnnGroup','GHC.Parser.Annotation.AnnUsing' --- For details on above see note [exact print annotations] in GHC.Parser.Annotation+-- For details on above see Note [exact print annotations] in GHC.Parser.Annotation data StmtLR idL idR body -- body should always be (LHs**** idR)   = LastStmt  -- Always the last Stmt in ListComp, MonadComp,               -- and (after the renamer, see GHC.Rename.Expr.checkLastStmt) DoExpr, MDoExpr@@ -1162,12 +1208,12 @@             -- See Note [Monad Comprehensions]             -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLarrow' -  -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+  -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   | BindStmt (XBindStmt idL idR body)              -- ^ Post renaming has optional fail and bind / (>>=) operator.              -- Post typechecking, also has multiplicity of the argument              -- and the result type of the function passed to bind;-             -- that is, (P, S) in (>>=) :: Q -> (R # P -> S) -> T+             -- that is, (P, S) in (>>=) :: Q -> (R % P -> S) -> T              -- See Note [The type of bind in Stmts]              (LPat idL)              body@@ -1196,7 +1242,7 @@   -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLet'   --          'GHC.Parser.Annotation.AnnOpen' @'{'@,'GHC.Parser.Annotation.AnnClose' @'}'@, -  -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+  -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   | LetStmt  (XLetStmt idL idR body) (HsLocalBindsLR idL idR)    -- ParStmts only occur in a list/monad comprehension@@ -1234,7 +1280,7 @@   -- Recursive statement (see Note [How RecStmt works] below)   -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnRec' -  -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+  -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   | RecStmt      { recS_ext :: XRecStmt idL idR body      , recS_stmts :: XRec idR [LStmtLR idL idR body]@@ -1316,13 +1362,11 @@     , app_stmts         :: [ExprLStmt idL] -- stmts     , final_expr        :: HsExpr idL    -- return (v1,..,vn), or just (v1,..,vn)     , bv_pattern        :: LPat idL      -- (v1,...,vn)-    , stmt_context      :: HsStmtContext (ApplicativeArgStmCtxPass idL)+    , stmt_context      :: HsDoFlavour       -- ^ context of the do expression, used in pprArg     }   | XApplicativeArg !(XXApplicativeArg idL) -type family ApplicativeArgStmCtxPass idL- {- Note [The type of bind in Stmts] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1461,7 +1505,7 @@   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, @@ -1527,7 +1571,8 @@         (XSpliced id)         ThModFinalizers     -- TH finalizers produced by the splice.         (HsSplicedThing id) -- The result of splicing-   | XSplice !(XXSplice id) -- Note [Trees that Grow] extension point+   | XSplice !(XXSplice id) -- Extension point; see Note [Trees That Grow]+                            -- in Language.Haskell.Syntax.Extension  -- | 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@@ -1568,9 +1613,6 @@     | HsSplicedPat  (Pat id)    -- ^ Haskell Spliced Pattern  --- See Note [Pending Splices]-type SplicePointName = Name- data UntypedSpliceFlavour   = UntypedExpSplice   | UntypedPatSplice@@ -1578,22 +1620,16 @@   | UntypedDeclSplice   deriving Data --- | Haskell Bracket-data HsBracket p-  = ExpBr  (XExpBr p)   (LHsExpr p)    -- [|  expr  |]+-- | Haskell (Untyped) Quote = Expr + Pat + Type + Var+data HsQuote 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 (LIdP 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--isTypedBracket :: HsBracket id -> Bool-isTypedBracket (TExpBr {}) = True-isTypedBracket _           = False+  | VarBr  (XVarBr p)   Bool (LIdP p) -- True: 'x, False: ''T+  | XQuote !(XXQuote p) -- Extension point; see Note [Trees That Grow]+                        -- in Language.Haskell.Syntax.Extension  {- ************************************************************************@@ -1625,18 +1661,20 @@  -- | Haskell Match Context ----- Context of a pattern match. This is more subtle than it would seem. See Note--- [Varieties of pattern matches].+-- Context of a pattern match. This is more subtle than it would seem. See+-- Note [FunBind vs PatBind]. data HsMatchContext p-  = FunRhs { mc_fun        :: LIdP p    -- ^ 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+  = FunRhs+    -- ^ A pattern matching on an argument of a+    -- function binding+      { mc_fun        :: LIdP p    -- ^ function binder of @f@+      , mc_fixity     :: LexicalFixity -- ^ fixing of @f@+      , mc_strictness :: SrcStrictness -- ^ was @f@ banged?+                                       -- See Note [FunBind vs PatBind]+      }   | LambdaExpr                  -- ^Patterns of a lambda-  | CaseAlt                     -- ^Patterns and guards on a case alternative+  | CaseAlt                     -- ^Patterns and guards in a case alternative+  | LamCaseAlt LamCaseVariant   -- ^Patterns and guards in @\case@ and @\cases@   | IfAlt                       -- ^Guards of a multi-way if alternative   | ArrowMatchCtxt              -- ^A pattern match inside arrow notation       HsArrowMatchContext@@ -1664,62 +1702,87 @@  -- | Haskell Statement Context. data HsStmtContext p-  = ListComp-  | MonadComp--  | DoExpr (Maybe ModuleName)        -- ^[ModuleName.]do { ... }-  | MDoExpr (Maybe ModuleName)       -- ^[ModuleName.]mdo { ... }  ie recursive do-expression-  | ArrowExpr                        -- ^do-notation in an arrow-command context--  | GhciStmtCtxt                     -- ^A command-line Stmt in GHCi pat <- rhs+  = HsDoStmt HsDoFlavour             -- ^Context for HsDo (do-notation and comprehensions)   | PatGuard (HsMatchContext p)      -- ^Pattern guard for specified thing   | ParStmtCtxt (HsStmtContext p)    -- ^A branch of a parallel stmt   | TransStmtCtxt (HsStmtContext p)  -- ^A branch of a transform stmt+  | ArrowExpr                        -- ^do-notation in an arrow-command context  -- | Haskell arrow match context. data HsArrowMatchContext-  = ProcExpr     -- ^ A proc expression-  | ArrowCaseAlt -- ^ A case alternative inside arrow notation-  | KappaExpr    -- ^ An arrow kappa abstraction+  = ProcExpr                       -- ^ A proc expression+  | ArrowCaseAlt                   -- ^ A case alternative inside arrow notation+  | ArrowLamCaseAlt LamCaseVariant -- ^ A \case or \cases alternative inside arrow notation+  | KappaExpr                      -- ^ An arrow kappa abstraction +data HsDoFlavour+  = DoExpr (Maybe ModuleName)        -- ^[ModuleName.]do { ... }+  | MDoExpr (Maybe ModuleName)       -- ^[ModuleName.]mdo { ... }  ie recursive do-expression+  | GhciStmtCtxt                     -- ^A command-line Stmt in GHCi pat <- rhs+  | ListComp+  | MonadComp+ qualifiedDoModuleName_maybe :: HsStmtContext p -> Maybe ModuleName qualifiedDoModuleName_maybe ctxt = case ctxt of-  DoExpr m -> m-  MDoExpr m -> m+  HsDoStmt (DoExpr m) -> m+  HsDoStmt (MDoExpr m) -> m   _ -> Nothing  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+isComprehensionContext ArrowExpr = False+isComprehensionContext (PatGuard _) = False+isComprehensionContext (HsDoStmt flavour) = isDoComprehensionContext flavour +isDoComprehensionContext :: HsDoFlavour -> Bool+isDoComprehensionContext GhciStmtCtxt = False+isDoComprehensionContext (DoExpr _) = False+isDoComprehensionContext (MDoExpr _) = False+isDoComprehensionContext ListComp = True+isDoComprehensionContext MonadComp = True+ -- | Is this a monadic context? isMonadStmtContext :: HsStmtContext id -> Bool-isMonadStmtContext MonadComp            = True-isMonadStmtContext DoExpr{}             = True-isMonadStmtContext MDoExpr{}            = True-isMonadStmtContext GhciStmtCtxt         = True isMonadStmtContext (ParStmtCtxt ctxt)   = isMonadStmtContext ctxt isMonadStmtContext (TransStmtCtxt ctxt) = isMonadStmtContext ctxt-isMonadStmtContext _ = False -- ListComp, PatGuard, ArrowExpr+isMonadStmtContext (HsDoStmt flavour) = isMonadDoStmtContext flavour+isMonadStmtContext (PatGuard _) = False+isMonadStmtContext ArrowExpr = False +isMonadDoStmtContext :: HsDoFlavour -> Bool+isMonadDoStmtContext ListComp     = False+isMonadDoStmtContext MonadComp    = True+isMonadDoStmtContext DoExpr{}     = True+isMonadDoStmtContext MDoExpr{}    = True+isMonadDoStmtContext GhciStmtCtxt = True+ isMonadCompContext :: HsStmtContext id -> Bool-isMonadCompContext MonadComp = True-isMonadCompContext _         = False+isMonadCompContext (HsDoStmt flavour)   = isMonadDoCompContext flavour+isMonadCompContext (ParStmtCtxt _)   = False+isMonadCompContext (TransStmtCtxt _) = False+isMonadCompContext (PatGuard _)      = False+isMonadCompContext ArrowExpr         = False +isMonadDoCompContext :: HsDoFlavour -> Bool+isMonadDoCompContext MonadComp    = True+isMonadDoCompContext ListComp     = False+isMonadDoCompContext GhciStmtCtxt = False+isMonadDoCompContext (DoExpr _)   = False+isMonadDoCompContext (MDoExpr _)  = False+ matchSeparator :: HsMatchContext p -> SDoc-matchSeparator (FunRhs {})   = text "="-matchSeparator CaseAlt       = text "->"-matchSeparator IfAlt         = text "->"-matchSeparator LambdaExpr    = text "->"-matchSeparator (ArrowMatchCtxt{})= text "->"-matchSeparator PatBindRhs    = text "="-matchSeparator PatBindGuards = text "="-matchSeparator (StmtCtxt _)  = text "<-"-matchSeparator RecUpd        = text "=" -- This can be printed by the pattern+matchSeparator FunRhs{}         = text "="+matchSeparator CaseAlt          = text "->"+matchSeparator LamCaseAlt{}     = text "->"+matchSeparator IfAlt            = text "->"+matchSeparator LambdaExpr       = text "->"+matchSeparator ArrowMatchCtxt{} = 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"@@ -1738,48 +1801,56 @@  pprMatchContextNoun :: forall p. (Outputable (IdP p), UnXRec p)                     => HsMatchContext p -> SDoc-pprMatchContextNoun (FunRhs {mc_fun=fun})-                                    = text "equation for"-                                      <+> quotes (ppr (unXRec @p 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 (ArrowMatchCtxt c)= pprArrowMatchContextNoun c-pprMatchContextNoun (StmtCtxt ctxt) = text "pattern binding in"-                                      $$ pprAStmtContext ctxt-pprMatchContextNoun PatSyn          = text "pattern synonym declaration"+pprMatchContextNoun (FunRhs {mc_fun=fun})   = text "equation for"+                                              <+> quotes (ppr (unXRec @p fun))+pprMatchContextNoun CaseAlt                 = text "case alternative"+pprMatchContextNoun (LamCaseAlt lc_variant) = lamCaseKeyword lc_variant+                                              <+> text "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 (ArrowMatchCtxt c)      = pprArrowMatchContextNoun c+pprMatchContextNoun (StmtCtxt ctxt)         = text "pattern binding in"+                                              $$ pprAStmtContext ctxt+pprMatchContextNoun PatSyn                  = text "pattern synonym declaration" +pprMatchContextNouns :: forall p. (Outputable (IdP p), UnXRec p)+                     => HsMatchContext p -> SDoc+pprMatchContextNouns (FunRhs {mc_fun=fun})   = text "equations for"+                                               <+> quotes (ppr (unXRec @p 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 KappaExpr    = text "arrow kappa abstraction"+pprArrowMatchContextNoun ProcExpr                     = text "arrow proc pattern"+pprArrowMatchContextNoun ArrowCaseAlt                 = text "case alternative within arrow notation"+pprArrowMatchContextNoun (ArrowLamCaseAlt lc_variant) = lamCaseKeyword lc_variant+                                                        <+> text "alternative within arrow notation"+pprArrowMatchContextNoun KappaExpr                    = text "arrow kappa abstraction" +pprArrowMatchContextNouns :: HsArrowMatchContext -> SDoc+pprArrowMatchContextNouns ArrowCaseAlt                 = text "case alternatives within arrow notation"+pprArrowMatchContextNouns (ArrowLamCaseAlt lc_variant) = lamCaseKeyword lc_variant+                                                         <+> text "alternatives within arrow notation"+pprArrowMatchContextNouns ctxt                         = pprArrowMatchContextNoun ctxt <> char 's'+ ----------------- pprAStmtContext, pprStmtContext :: (Outputable (IdP p), UnXRec p)                                 => HsStmtContext p -> SDoc-pprAStmtContext ctxt = article <+> pprStmtContext ctxt-  where-    pp_an = text "an"-    pp_a  = text "a"-    article = case ctxt of-                  MDoExpr Nothing -> pp_an-                  GhciStmtCtxt  -> pp_an-                  _             -> pp_a-+pprAStmtContext (HsDoStmt flavour) = pprAHsDoFlavour flavour+pprAStmtContext ctxt = text "a" <+> pprStmtContext ctxt  ------------------pprStmtContext GhciStmtCtxt    = text "interactive GHCi command"-pprStmtContext (DoExpr m)      = prependQualified m (text "'do' block")-pprStmtContext (MDoExpr m)     = prependQualified m (text "'mdo' block")-pprStmtContext ArrowExpr       = text "'do' block in an arrow command"-pprStmtContext ListComp        = text "list comprehension"-pprStmtContext MonadComp       = text "monad comprehension"+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@@ -1792,6 +1863,21 @@ pprStmtContext (TransStmtCtxt c) =   ifPprDebug (sep [text "transformed branch of", pprAStmtContext c])              (pprStmtContext c)++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
Language/Haskell/Syntax/Extension.hs view
@@ -4,6 +4,7 @@ {-# LANGUAGE DeriveDataTypeable      #-} {-# LANGUAGE EmptyCase               #-} {-# LANGUAGE EmptyDataDeriving       #-}+{-# LANGUAGE StandaloneDeriving      #-} {-# LANGUAGE FlexibleContexts        #-} {-# LANGUAGE FlexibleInstances       #-} {-# LANGUAGE GADTs                   #-}@@ -22,12 +23,13 @@  import GHC.Prelude +import GHC.TypeLits (Symbol, KnownSymbol) import Data.Data hiding ( Fixity ) import Data.Kind (Type) import GHC.Utils.Outputable  {--Note [Trees that grow]+Note [Trees That Grow] ~~~~~~~~~~~~~~~~~~~~~~  See https://gitlab.haskell.org/ghc/ghc/wikis/implementing-trees-that-grow@@ -63,7 +65,7 @@ -- | 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+-- This should not be confused with 'DataConCantHappen', 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@@ -78,24 +80,43 @@ 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.+{-+Note [Constructor cannot occur]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Some data constructors can't occur in certain phases; e.g. the output+of the type checker never has OverLabel. We signal this by+* setting the extension field to DataConCantHappen+* using dataConCantHappen in the cases that can't happen --- See also [NoExtCon and strict fields].-data NoExtCon+For example:++   type instance XOverLabel GhcTc = DataConCantHappen++   dsExpr :: HsExpr GhcTc -> blah+   dsExpr (HsOverLabel x _) = dataConCantHappen x++The function dataConCantHappen is defined thus:+   dataConCantHappen :: DataConCantHappen -> a+   dataConCantHappen x = case x of {}+(i.e. identically to Data.Void.absurd, but more helpfully named).+Remember DataConCantHappen is a type whose only element is bottom.++This should not be confused with 'NoExtField', which are found in unused+extension /points/ (not /constructors/) and therefore can be inhabited.++It would be better to omit the pattern match altogether, but we+can only do that if the extension field was strict (#18764).+See also [DataConCantHappen and strict fields].+-}+data DataConCantHappen   deriving (Data,Eq,Ord) -instance Outputable NoExtCon where-  ppr = noExtCon+instance Outputable DataConCantHappen where+  ppr = dataConCantHappen --- | Eliminate a 'NoExtCon'. Much like 'Data.Void.absurd'.-noExtCon :: NoExtCon -> a-noExtCon x = case x of {}+-- | Eliminate a 'DataConCantHappen'. See Note [Constructor cannot occur].+dataConCantHappen :: DataConCantHappen -> a+dataConCantHappen x = case x of {}  -- | GHC's L prefixed variants wrap their vanilla variant in this type family, -- to add 'SrcLoc' info via 'Located'. Other passes than 'GhcPass' not@@ -170,14 +191,9 @@ 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' --- ABExport type families-type family XABE x-type family XXABExport x- -- PatSynBind type families type family XPSB x x' type family XXPatSynBind x x'@@ -385,8 +401,7 @@  type family XVar            x type family XUnboundVar     x-type family XConLikeOut     x-type family XRecFld         x+type family XRecSel         x type family XOverLabel      x type family XIPVar          x type family XOverLitE       x@@ -414,9 +429,8 @@ type family XProjection     x type family XExprWithTySig  x type family XArithSeq       x-type family XBracket        x-type family XRnBracketOut   x-type family XTcBracketOut   x+type family XTypedBracket   x+type family XUntypedBracket x type family XSpliceE        x type family XProc           x type family XStatic         x@@ -426,9 +440,9 @@ type family XXExpr          x  -- ---------------------------------------- FieldLabel type families-type family XCHsFieldLabel  x-type family XXHsFieldLabel  x+-- DotFieldOcc type families+type family XCDotFieldOcc  x+type family XXDotFieldOcc  x  -- ------------------------------------- -- HsPragE type families@@ -457,15 +471,14 @@ type family XXSplice       x  -- ---------------------------------------- HsBracket type families-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+-- HsQuoteBracket type families+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 XXQuote x  -- ------------------------------------- -- HsCmdTop type families@@ -506,18 +519,18 @@  -- ------------------------------------- -- HsCmd type families-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 XCmdLamCase x-type family XCmdIf      x-type family XCmdLet     x-type family XCmdDo      x-type family XCmdWrap    x-type family XXCmd       x+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 XCmdLamCase  x+type family XCmdIf       x+type family XCmdLet      x+type family XCmdDo       x+type family XCmdWrap     x+type family XXCmd        x  -- ------------------------------------- -- ParStmtBlock type families@@ -563,25 +576,25 @@ -- ===================================================================== -- 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 family XHsRecField x+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 family XHsFieldBind x  -- ===================================================================== -- Type families for the HsTypes type families@@ -694,3 +707,27 @@ -- ===================================================================== -- End of Type family definitions -- =====================================================================++++-- =====================================================================+-- Token information++type LHsToken tok p = XRec p (HsToken tok)++data HsToken (tok :: Symbol) = HsTok++deriving instance KnownSymbol tok => Data (HsToken tok)++type LHsUniToken tok utok p = XRec p (HsUniToken tok utok)++-- With UnicodeSyntax, there might be multiple ways to write the same token.+-- For example an arrow could be either "->" or "→". This choice must be+-- recorded in order to exactprint such tokens,+-- so instead of HsToken "->" we introduce HsUniToken "->" "→".+--+-- See also IsUnicodeSyntax in GHC.Parser.Annotation; we do not use here to+-- avoid a dependency.+data HsUniToken (tok :: Symbol) (utok :: Symbol) = HsNormalTok | HsUnicodeTok++deriving instance (KnownSymbol tok, KnownSymbol utok) => Data (HsUniToken tok utok)
Language/Haskell/Syntax/Lit.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP                  #-}+ {-# LANGUAGE ConstraintKinds      #-} {-# LANGUAGE DeriveDataTypeable   #-} {-# LANGUAGE FlexibleContexts     #-}@@ -18,11 +18,8 @@ -- | Source-language literals module Language.Haskell.Syntax.Lit where -#include "HsVersions.h"- import GHC.Prelude -import {-# SOURCE #-} Language.Haskell.Syntax.Expr ( HsExpr ) import GHC.Types.Basic (PprPrec(..), topPrec ) import GHC.Types.SourceText import GHC.Core.Type@@ -44,7 +41,8 @@  -- Note [Literal source text] in GHC.Types.Basic for SourceText fields in -- the following--- Note [Trees that grow] in Language.Haskell.Syntax.Extension for the Xxxxx fields in the following+-- Note [Trees That Grow] in Language.Haskell.Syntax.Extension for the Xxxxx+-- fields in the following -- | Haskell Literal data HsLit x   = HsChar (XHsChar x) {- SourceText -} Char@@ -101,8 +99,7 @@ data HsOverLit p   = OverLit {       ol_ext :: (XOverLit p),-      ol_val :: OverLitVal,-      ol_witness :: HsExpr p}         -- Note [Overloaded literal witnesses]+      ol_val :: OverLitVal}    | XOverLit       !(XXOverLit p)@@ -121,28 +118,11 @@ negateOverLitVal (HsFractional f) = HsFractional (negateFractionalLit f) negateOverLitVal _ = panic "negateOverLitVal: argument is not a number" -{--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 GHC.HsToCore.Match.Literal) instance (Eq (XXOverLit p)) => Eq (HsOverLit p) where-  (OverLit _ val1 _) == (OverLit _ val2 _) = val1 == val2-  (XOverLit  val1)   == (XOverLit  val2)   = val1 == val2+  (OverLit _ val1) == (OverLit _ val2) = val1 == val2+  (XOverLit  val1) == (XOverLit  val2) = val1 == val2   _ == _ = panic "Eq HsOverLit"  instance Eq OverLitVal where@@ -152,8 +132,8 @@   _                   == _                   = 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 (OverLit _ val1)  (OverLit _ val2) = val1 `compare` val2+  compare (XOverLit  val1)  (XOverLit  val2) = val1 `compare` val2   compare _ _ = panic "Ord HsOverLit"  instance Ord OverLitVal where@@ -163,7 +143,7 @@   compare (HsFractional f1)   (HsFractional f2)   = f1 `compare` f2   compare (HsFractional _)    (HsIntegral   _)    = GT   compare (HsFractional _)    (HsIsString _ _)    = LT-  compare (HsIsString _ s1)   (HsIsString _ s2)   = s1 `uniqCompareFS` s2+  compare (HsIsString _ s1)   (HsIsString _ s2)   = s1 `lexicalCompareFS` s2   compare (HsIsString _ _)    (HsIntegral   _)    = GT   compare (HsIsString _ _)    (HsFractional _)    = GT
Language/Haskell/Syntax/Pat.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-}@@ -9,6 +9,7 @@ {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]                                       -- in module Language.Haskell.Syntax.Extension {-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE DataKinds #-} {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998@@ -22,7 +23,7 @@         ConLikeP,          HsConPatDetails, hsConPatArgs,-        HsRecFields(..), HsRecField'(..), LHsRecField',+        HsRecFields(..), HsFieldBind(..), LHsFieldBind,         HsRecField, LHsRecField,         HsRecUpdField, LHsRecUpdField,         hsRecFields, hsRecFieldSel, hsRecFieldsArgs,@@ -49,7 +50,7 @@ -- -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnBang' --- For details on above see note [exact print annotations] in GHC.Parser.Annotation+-- For details on above see Note [exact print annotations] in GHC.Parser.Annotation data Pat p   =     ------------ Simple patterns ---------------     WildPat     (XWildPat p)        -- ^ Wildcard Pattern@@ -65,40 +66,39 @@                 (LPat p)                -- ^ Lazy Pattern     -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnTilde' -    -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+    -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation    | AsPat       (XAsPat p)                 (LIdP p) (LPat p)    -- ^ As pattern     -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnAt' -    -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+    -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation    | ParPat      (XParPat p)+               !(LHsToken "(" p)                 (LPat p)                -- ^ Parenthesised pattern+               !(LHsToken ")" p)                                         -- See Note [Parens in HsSyn] in GHC.Hs.Expr     -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'('@,     --                                    'GHC.Parser.Annotation.AnnClose' @')'@ -    -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+    -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   | BangPat     (XBangPat p)                 (LPat p)                -- ^ Bang pattern     -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnBang' -    -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+    -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation          ------------ 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     --     -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'['@,     --                                    'GHC.Parser.Annotation.AnnClose' @']'@ -    -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+    -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation    | TuplePat    (XTuplePat p)                   -- after typechecking, holds the types of the tuple components@@ -136,7 +136,7 @@     --            'GHC.Parser.Annotation.AnnOpen' @'(#'@,     --            'GHC.Parser.Annotation.AnnClose' @'#)'@ -    -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+    -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation          ------------ Constructor patterns ---------------   | ConPat {@@ -149,10 +149,8 @@         ------------ View patterns ---------------   -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnRarrow' -  -- For details on above see note [exact print annotations] in GHC.Parser.Annotation-  | ViewPat       (XViewPat p)     -- The overall type of the pattern-                                   -- (= the argument type of the view function)-                                   -- for hsPatType.+  -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation+  | ViewPat       (XViewPat p)                   (LHsExpr p)                   (LPat p)     -- ^ View Pattern@@ -161,7 +159,7 @@   -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'$('@   --        'GHC.Parser.Annotation.AnnClose' @')'@ -  -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+  -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   | SplicePat       (XSplicePat p)                     (HsSplice p)    -- ^ Splice Pattern (Includes quasi-quotes) @@ -187,7 +185,7 @@   --   -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnVal' @'+'@ -  -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+  -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   | NPlusKPat       (XNPlusKPat p)           -- Type of overall pattern                     (LIdP p)                 -- n+k pattern                     (XRec p (HsOverLit p))   -- It'll always be an HsIntegral@@ -202,7 +200,7 @@         ------------ Pattern type signatures ---------------   -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDcolon' -  -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+  -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   | SigPat          (XSigPat p)             -- After typechecker: Type                     (LPat p)                -- Pattern with a type signature                     (HsPatSigType (NoGhcTc p)) --  Signature can bind both@@ -210,7 +208,7 @@      -- ^ Pattern with a type signature -  -- | Trees that Grow extension point for new constructors+  -- Extension point; see Note [Trees That Grow] in Language.Haskell.Syntax.Extension   | XPat       !(XXPat p) @@ -225,7 +223,7 @@  hsConPatArgs :: forall p . (UnXRec p) => HsConPatDetails p -> [LPat p] hsConPatArgs (PrefixCon _ ps) = ps-hsConPatArgs (RecCon fs)      = map (hsRecFieldArg . unXRec @p) (rec_flds fs)+hsConPatArgs (RecCon fs)      = map (hfbRHS . unXRec @p) (rec_flds fs) hsConPatArgs (InfixCon p1 p2) = [p1,p2]  -- | Haskell Record Fields@@ -256,7 +254,7 @@ --                     and the remainder being 'filled in' implicitly  -- | Located Haskell Record Field-type LHsRecField' p id arg = XRec p (HsRecField' id arg)+type LHsFieldBind p id arg = XRec p (HsFieldBind id arg)  -- | Located Haskell Record Field type LHsRecField  p arg = XRec p (HsRecField  p arg)@@ -265,21 +263,21 @@ type LHsRecUpdField p   = XRec p (HsRecUpdField p)  -- | Haskell Record Field-type HsRecField    p arg = HsRecField' (FieldOcc p) arg+type HsRecField p arg   = HsFieldBind (LFieldOcc p) arg  -- | Haskell Record Update Field-type HsRecUpdField p     = HsRecField' (AmbiguousFieldOcc p) (LHsExpr p)+type HsRecUpdField p    = HsFieldBind (LAmbiguousFieldOcc p) (LHsExpr p) --- | Haskell Record Field+-- | Haskell Field Binding -- -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnEqual', ----- For details on above see note [exact print annotations] in GHC.Parser.Annotation-data HsRecField' id arg = HsRecField {-        hsRecFieldAnn :: XHsRecField id,-        hsRecFieldLbl :: Located id,-        hsRecFieldArg :: arg,           -- ^ Filled in by renamer when punning-        hsRecPun      :: Bool           -- ^ Note [Punning]+-- For details on above see Note [exact print annotations] in GHC.Parser.Annotation+data HsFieldBind lhs rhs = HsFieldBind {+        hfbAnn :: XHsFieldBind lhs,+        hfbLHS :: lhs,+        hfbRHS :: rhs,           -- ^ Filled in by renamer when punning+        hfbPun :: Bool           -- ^ Note [Punning]   } deriving (Functor, Foldable, Traversable)  @@ -324,28 +322,27 @@ -- -- The parsed HsRecUpdField corresponding to the record update will have: -----     hsRecFieldLbl = Unambiguous "x" noExtField :: AmbiguousFieldOcc RdrName+--     hfbLHS = Unambiguous "x" noExtField :: AmbiguousFieldOcc RdrName -- -- After the renamer, this will become: -----     hsRecFieldLbl = Ambiguous   "x" noExtField :: AmbiguousFieldOcc Name+--     hfbLHS = 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+--     hfbLHS = Unambiguous "x" $sel:x:MkS  :: AmbiguousFieldOcc Id -- -- See also Note [Disambiguating record fields] in GHC.Tc.Gen.Head. -hsRecFields :: forall p arg. UnXRec p => HsRecFields p arg -> [XCFieldOcc p]-hsRecFields rbinds = map (unLoc . hsRecFieldSel . unXRec @p) (rec_flds rbinds)+hsRecFields :: forall p arg.UnXRec p => HsRecFields p arg -> [XCFieldOcc p]+hsRecFields rbinds = map (hsRecFieldSel . unXRec @p) (rec_flds rbinds) --- Probably won't typecheck at once, things have changed :/ hsRecFieldsArgs :: forall p arg. UnXRec p => HsRecFields p arg -> [arg]-hsRecFieldsArgs rbinds = map (hsRecFieldArg . unXRec @p) (rec_flds rbinds)+hsRecFieldsArgs rbinds = map (hfbRHS . unXRec @p) (rec_flds rbinds) -hsRecFieldSel :: HsRecField pass arg -> Located (XCFieldOcc pass)-hsRecFieldSel = fmap extFieldOcc . hsRecFieldLbl+hsRecFieldSel :: forall p arg. UnXRec p => HsRecField p arg -> XCFieldOcc p+hsRecFieldSel = foExt . unXRec @p . hfbLHS   {-@@ -366,7 +363,7 @@           dotdot = text ".." <+> whenPprDebug (ppr (drop n flds))  instance (Outputable p, OutputableBndr p, Outputable arg)-      => Outputable (HsRecField' p arg) where-  ppr (HsRecField { hsRecFieldLbl = L _ f, hsRecFieldArg = arg,-                    hsRecPun = pun })+      => Outputable (HsFieldBind p arg) where+  ppr (HsFieldBind { hfbLHS = f, hfbRHS = arg,+                     hfbPun = pun })     = pprPrefixOcc f <+> (ppUnless pun $ equals <+> ppr arg)
Language/Haskell/Syntax/Type.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-}@@ -6,6 +6,8 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]                                       -- in module Language.Haskell.Syntax.Extension {-@@ -21,7 +23,7 @@         Mult, HsScaled(..),         hsMult, hsScaledThing,         HsArrow(..),-        hsLinear, hsUnrestricted,+        HsLinearArrowTokens(..),          HsType(..), HsCoreTy, LHsType, HsKind, LHsKind,         HsForAllTelescope(..), HsTyVarBndr(..), LHsTyVarBndr,@@ -34,7 +36,7 @@         HsContext, LHsContext,         HsTyLit(..),         HsIPName(..), hsIPNameFS,-        HsArg(..), numVisibleArgs,+        HsArg(..), numVisibleArgs, pprHsArgsApp,         LHsTypeArg,          LBangType, BangType,@@ -46,7 +48,7 @@         HsConDetails(..), noTypeArgs,          FieldOcc(..), LFieldOcc,-        AmbiguousFieldOcc(..),+        AmbiguousFieldOcc(..), LAmbiguousFieldOcc,          mapHsOuterImplicit,         hsQTvExplicit,@@ -54,8 +56,6 @@         hsPatSigType,     ) where -#include "HsVersions.h"- import GHC.Prelude  import {-# SOURCE #-} Language.Haskell.Syntax.Expr ( HsSplice )@@ -70,6 +70,7 @@ import GHC.Core.Type import GHC.Hs.Doc import GHC.Types.Basic+import GHC.Types.Fixity import GHC.Types.SrcLoc import GHC.Utils.Outputable import GHC.Data.FastString@@ -277,7 +278,7 @@ -- | Located Haskell Context type LHsContext pass = XRec pass (HsContext pass)       -- ^ 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnUnit'-      -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+      -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation  -- | Haskell Context type HsContext pass = [LHsType pass]@@ -287,7 +288,7 @@       -- ^ May have 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnComma' when       --   in a list -      -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+      -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation  -- | Haskell Kind type HsKind pass = HsType pass@@ -296,7 +297,7 @@ type LHsKind pass = XRec pass (HsKind pass)       -- ^ 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDcolon' -      -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+      -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation  -------------------------------------------------- --             LHsQTyVars@@ -709,7 +710,7 @@         --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen',         --          'GHC.Parser.Annotation.AnnDcolon', 'GHC.Parser.Annotation.AnnClose' -        -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+        -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation    | XTyVarBndr       !(XXTyVarBndr pass)@@ -730,11 +731,11 @@       }       -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnForall',       --         'GHC.Parser.Annotation.AnnDot','GHC.Parser.Annotation.AnnDarrow'-      -- For details on above see note [exact print annotations] in "GHC.Parser.Annotation"+      -- For details on above see Note [exact print annotations] in "GHC.Parser.Annotation"    | HsQualTy   -- See Note [HsType binders]       { hst_xqual :: XQualTy pass-      , hst_ctxt  :: Maybe (LHsContext pass)  -- Context C => blah+      , hst_ctxt  :: LHsContext pass  -- Context C => blah       , hst_body  :: LHsType pass }    | HsTyVar  (XTyVar pass)@@ -746,14 +747,14 @@                   -- See Note [Located RdrNames] in GHC.Hs.Expr       -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : None -      -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+      -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation    | HsAppTy             (XAppTy pass)                         (LHsType pass)                         (LHsType pass)       -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : None -      -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+      -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation    | HsAppKindTy         (XAppKindTy pass) -- type level type app                         (LHsType pass)@@ -765,14 +766,14 @@                         (LHsType pass)       -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnRarrow', -      -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+      -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation    | HsListTy            (XListTy pass)                         (LHsType pass)  -- Element type       -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'['@,       --         'GHC.Parser.Annotation.AnnClose' @']'@ -      -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+      -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation    | HsTupleTy           (XTupleTy pass)                         HsTupleSort@@ -780,20 +781,22 @@     -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'(' or '(#'@,     --         'GHC.Parser.Annotation.AnnClose' @')' or '#)'@ -    -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+    -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation    | HsSumTy             (XSumTy pass)                         [LHsType pass]  -- Element types (length gives arity)     -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'(#'@,     --         'GHC.Parser.Annotation.AnnClose' '#)'@ -    -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+    -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation    | HsOpTy              (XOpTy pass)+                        PromotionFlag    -- Whether explicitly promoted,+                                         -- for the pretty printer                         (LHsType pass) (LIdP pass) (LHsType pass)       -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : None -      -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+      -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation    | HsParTy             (XParTy pass)                         (LHsType pass)   -- See Note [Parens in HsSyn] in GHC.Hs.Expr@@ -803,7 +806,7 @@       -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'('@,       --         'GHC.Parser.Annotation.AnnClose' @')'@ -      -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+      -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation    | HsIParamTy          (XIParamTy pass)                         (XRec pass HsIPName) -- (?x :: ty)@@ -814,7 +817,7 @@       --       -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDcolon' -      -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+      -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation    | HsStarTy            (XStarTy pass)                         Bool             -- Is this the Unicode variant?@@ -830,20 +833,20 @@       -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'('@,       --         'GHC.Parser.Annotation.AnnDcolon','GHC.Parser.Annotation.AnnClose' @')'@ -      -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+      -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation    | HsSpliceTy          (XSpliceTy pass)                         (HsSplice pass)   -- Includes quasi-quotes       -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'$('@,       --         'GHC.Parser.Annotation.AnnClose' @')'@ -      -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+      -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation    | HsDocTy             (XDocTy pass)-                        (LHsType pass) LHsDocString -- A documented type+                        (LHsType pass) (LHsDoc pass) -- A documented type       -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : None -      -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+      -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation    | HsBangTy    (XBangTy pass)                 HsSrcBang (LHsType pass)   -- Bang-style type annotations@@ -852,14 +855,14 @@       --         'GHC.Parser.Annotation.AnnClose' @'#-}'@       --         'GHC.Parser.Annotation.AnnBang' @\'!\'@ -      -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+      -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation    | HsRecTy     (XRecTy pass)                 [LConDeclField pass]    -- Only in data type declarations       -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'{'@,       --         'GHC.Parser.Annotation.AnnClose' @'}'@ -      -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+      -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation    | HsExplicitListTy       -- A promoted explicit list         (XExplicitListTy pass)@@ -868,7 +871,7 @@       -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @"'["@,       --         'GHC.Parser.Annotation.AnnClose' @']'@ -      -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+      -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation    | HsExplicitTupleTy      -- A promoted explicit tuple         (XExplicitTupleTy pass)@@ -876,20 +879,20 @@       -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @"'("@,       --         'GHC.Parser.Annotation.AnnClose' @')'@ -      -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+      -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation    | HsTyLit (XTyLit pass) HsTyLit      -- A promoted numeric literal.       -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : None -      -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+      -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation    | HsWildCardTy (XWildCardTy pass)  -- A type wildcard       -- See Note [The wildcard story for types]       -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : None -      -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+      -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation -  -- For adding new constructors via Trees that Grow+  -- Extension point; see Note [Trees That Grow] in Language.Haskell.Syntax.Extension   | XHsType       !(XXType pass) @@ -913,16 +916,20 @@  -- | Denotes the type of arrows in the surface language data HsArrow pass-  = HsUnrestrictedArrow IsUnicodeSyntax+  = HsUnrestrictedArrow !(LHsUniToken "->" "→" pass)     -- ^ a -> b or a → b-  | HsLinearArrow IsUnicodeSyntax (Maybe AddEpAnn)+  | HsLinearArrow !(HsLinearArrowTokens pass)     -- ^ a %1 -> b or a %1 → b, or a ⊸ b-  | HsExplicitMult IsUnicodeSyntax (Maybe AddEpAnn) (LHsType pass)+  | HsExplicitMult !(LHsToken "%" pass) !(LHsType pass) !(LHsUniToken "->" "→" pass)     -- ^ a %m -> b or a %m → b (very much including `a %Many -> b`!     -- This is how the programmer wrote it). It is stored as an     -- `HsType` so as to preserve the syntax as written in the     -- program. +data HsLinearArrowTokens pass+  = HsPct1 !(LHsToken "%1" pass) !(LHsUniToken "->" "→" pass)+  | HsLolly !(LHsToken "⊸" pass)+ -- | This is used in the syntax. In constructor declaration. It must keep the -- arrow representation. data HsScaled pass a = HsScaled (HsArrow pass) a@@ -933,16 +940,6 @@ hsScaledThing :: HsScaled pass a -> a hsScaledThing (HsScaled _ t) = t --- | When creating syntax we use the shorthands. It's better for printing, also,--- the shorthands work trivially at each pass.-hsUnrestricted, hsLinear :: a -> HsScaled pass a-hsUnrestricted = HsScaled (HsUnrestrictedArrow NormalSyntax)-hsLinear = HsScaled (HsLinearArrow NormalSyntax Nothing)--instance Outputable a => Outputable (HsScaled pass a) where-   ppr (HsScaled _cnt t) = -- ppr cnt <> ppr t-                            ppr t- {- Note [Unit tuples] ~~~~~~~~~~~~~~~~~~@@ -1043,7 +1040,7 @@       -- ^ May have 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnComma' when       --   in a list -      -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+      -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation  -- | Constructor Declaration Field data ConDeclField pass  -- Record fields have Haddock docs on them@@ -1051,10 +1048,10 @@                    cd_fld_names :: [LFieldOcc pass],                                    -- ^ See Note [ConDeclField passs]                    cd_fld_type :: LBangType pass,-                   cd_fld_doc  :: Maybe LHsDocString }+                   cd_fld_doc  :: Maybe (LHsDoc pass)}       -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDcolon' -      -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+      -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   | XConDeclField !(XXConDeclField pass)  -- | Describes the arguments to a data constructor. This is a common@@ -1214,12 +1211,59 @@ -- type level equivalent type LHsTypeArg p = HsArg (LHsType p) (LHsKind p) +-- | @'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 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 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 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 tm ty) where-  ppr (HsValArg tm)    = ppr tm-  ppr (HsTypeArg _ ty) = char '@' <> ppr ty-  ppr (HsArgPar sp)    = text "HsArgPar"  <+> ppr sp+  ppr (HsValArg tm)     = text "HsValArg"  <+> ppr tm+  ppr (HsTypeArg sp ty) = text "HsTypeArg" <+> ppr sp <+> 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@@ -1248,34 +1292,40 @@  -- | Field Occurrence ----- Represents an *occurrence* of an unambiguous field.  This may or may not be a+-- Represents an *occurrence* of a field. This may or may not be a -- binding occurrence (e.g. this type is used in 'ConDeclField' and--- 'RecordPatSynField' which bind their fields, but also in 'HsRecField' for--- record construction and patterns, which do not).+-- 'RecordPatSynField' which bind their fields, but also in+-- 'HsRecField' for record construction and patterns, which do not). ----- We store both the 'RdrName' the user originally wrote, and after the renamer,--- the selector function.-data FieldOcc pass = FieldOcc { extFieldOcc     :: XCFieldOcc pass-                              , rdrNameFieldOcc :: LocatedN RdrName-                                 -- ^ See Note [Located RdrNames] in "GHC.Hs.Expr"-                              }--  | XFieldOcc-      !(XXFieldOcc pass)--deriving instance (Eq (XCFieldOcc pass), Eq (XXFieldOcc pass)) => Eq (FieldOcc pass)+-- We store both the 'RdrName' the user originally wrote, and after+-- the renamer we use the extension field to store the selector+-- function.+data FieldOcc pass+  = FieldOcc {+        foExt :: XCFieldOcc pass+      , foLabel :: XRec pass RdrName -- See Note [Located RdrNames] in Language.Haskell.Syntax.Expr+      }+  | XFieldOcc !(XXFieldOcc pass)+deriving instance (+    Eq (XRec pass RdrName)+  , Eq (XCFieldOcc pass)+  , Eq (XXFieldOcc pass)+  ) => Eq (FieldOcc pass) -instance Outputable (FieldOcc pass) where-  ppr = ppr . rdrNameFieldOcc+instance Outputable (XRec pass RdrName) => Outputable (FieldOcc pass) where+  ppr = ppr . foLabel -instance OutputableBndr (FieldOcc pass) where-  pprInfixOcc  = pprInfixOcc . unLoc . rdrNameFieldOcc-  pprPrefixOcc = pprPrefixOcc . unLoc . rdrNameFieldOcc+instance (UnXRec pass, OutputableBndr (XRec pass RdrName)) => OutputableBndr (FieldOcc pass) where+  pprInfixOcc  = pprInfixOcc . unXRec @pass . foLabel+  pprPrefixOcc = pprPrefixOcc . unXRec @pass . foLabel -instance OutputableBndr (GenLocated SrcSpan (FieldOcc pass)) where+instance (UnXRec pass, OutputableBndr (XRec pass RdrName)) => OutputableBndr (GenLocated SrcSpan (FieldOcc pass)) where   pprInfixOcc  = pprInfixOcc . unLoc   pprPrefixOcc = pprPrefixOcc . unLoc +-- | Located Ambiguous Field Occurence+type LAmbiguousFieldOcc pass = XRec pass (AmbiguousFieldOcc pass)+ -- | Ambiguous Field Occurrence -- -- Represents an *occurrence* of a field that is potentially@@ -1285,9 +1335,8 @@ -- (for unambiguous occurrences) or the typechecker (for ambiguous -- occurrences). ----- See Note [HsRecField and HsRecUpdField] in "GHC.Hs.Pat" and--- Note [Disambiguating record fields] in "GHC.Tc.Gen.Head".--- See Note [Located RdrNames] in "GHC.Hs.Expr"+-- See Note [HsRecField and HsRecUpdField] in "GHC.Hs.Pat".+-- See Note [Located RdrNames] in "GHC.Hs.Expr". data AmbiguousFieldOcc pass   = Unambiguous (XUnambiguous pass) (LocatedN RdrName)   | Ambiguous   (XAmbiguous pass)   (LocatedN RdrName)
+ MachRegs.h view
@@ -0,0 +1,720 @@+/* -----------------------------------------------------------------------------+ *+ * (c) The GHC Team, 1998-2014+ *+ * Registers used in STG code.  Might or might not correspond to+ * actual machine registers.+ *+ * Do not #include this file directly: #include "Rts.h" instead.+ *+ * To understand the structure of the RTS headers, see the wiki:+ *   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes+ *+ * ---------------------------------------------------------------------------*/++#pragma once++/* This file is #included into Haskell code in the compiler: #defines+ * only in here please.+ */++/*+ * Undefine these as a precaution: some of them were found to be+ * defined by system headers on ARM/Linux.+ */+#undef REG_R1+#undef REG_R2+#undef REG_R3+#undef REG_R4+#undef REG_R5+#undef REG_R6+#undef REG_R7+#undef REG_R8+#undef REG_R9+#undef REG_R10++/*+ * Defining MACHREGS_NO_REGS to 1 causes no global registers to be used.+ * MACHREGS_NO_REGS is typically controlled by NO_REGS, which is+ * typically defined by GHC, via a command-line option passed to gcc,+ * when the -funregisterised flag is given.+ *+ * NB. When MACHREGS_NO_REGS to 1, calling & return conventions may be+ * different.  For example, all function arguments will be passed on+ * the stack, and components of an unboxed tuple will be returned on+ * the stack rather than in registers.+ */+#if MACHREGS_NO_REGS == 1++/* Nothing */++#elif MACHREGS_NO_REGS == 0++/* ----------------------------------------------------------------------------+   Caller saves and callee-saves regs.++   Caller-saves regs have to be saved around C-calls made from STG+   land, so this file defines CALLER_SAVES_<reg> for each <reg> that+   is designated caller-saves in that machine's C calling convention.++   As it stands, the only registers that are ever marked caller saves+   are the RX, FX, DX and USER registers; as a result, if you+   decide to caller save a system register (e.g. SP, HP, etc), note that+   this code path is completely untested! -- EZY++   See Note [Register parameter passing] for details.+   -------------------------------------------------------------------------- */++/* -----------------------------------------------------------------------------+   The x86 register mapping++   Ok, we've only got 6 general purpose registers, a frame pointer and a+   stack pointer.  \tr{%eax} and \tr{%edx} are return values from C functions,+   hence they get trashed across ccalls and are caller saves. \tr{%ebx},+   \tr{%esi}, \tr{%edi}, \tr{%ebp} are all callee-saves.++   Reg     STG-Reg+   ---------------+   ebx     Base+   ebp     Sp+   esi     R1+   edi     Hp++   Leaving SpLim out of the picture.+   -------------------------------------------------------------------------- */++#if defined(MACHREGS_i386)++#define REG(x) __asm__("%" #x)++#if !defined(not_doing_dynamic_linking)+#define REG_Base    ebx+#endif+#define REG_Sp      ebp++#if !defined(STOLEN_X86_REGS)+#define STOLEN_X86_REGS 4+#endif++#if STOLEN_X86_REGS >= 3+# define REG_R1     esi+#endif++#if STOLEN_X86_REGS >= 4+# define REG_Hp     edi+#endif+#define REG_MachSp  esp++#define REG_XMM1    xmm0+#define REG_XMM2    xmm1+#define REG_XMM3    xmm2+#define REG_XMM4    xmm3++#define REG_YMM1    ymm0+#define REG_YMM2    ymm1+#define REG_YMM3    ymm2+#define REG_YMM4    ymm3++#define REG_ZMM1    zmm0+#define REG_ZMM2    zmm1+#define REG_ZMM3    zmm2+#define REG_ZMM4    zmm3++#define MAX_REAL_VANILLA_REG 1  /* always, since it defines the entry conv */+#define MAX_REAL_FLOAT_REG   0+#define MAX_REAL_DOUBLE_REG  0+#define MAX_REAL_LONG_REG    0+#define MAX_REAL_XMM_REG     4+#define MAX_REAL_YMM_REG     4+#define MAX_REAL_ZMM_REG     4++/* -----------------------------------------------------------------------------+  The x86-64 register mapping++  %rax          caller-saves, don't steal this one+  %rbx          YES+  %rcx          arg reg, caller-saves+  %rdx          arg reg, caller-saves+  %rsi          arg reg, caller-saves+  %rdi          arg reg, caller-saves+  %rbp          YES (our *prime* register)+  %rsp          (unavailable - stack pointer)+  %r8           arg reg, caller-saves+  %r9           arg reg, caller-saves+  %r10          caller-saves+  %r11          caller-saves+  %r12          YES+  %r13          YES+  %r14          YES+  %r15          YES++  %xmm0-7       arg regs, caller-saves+  %xmm8-15      caller-saves++  Use the caller-saves regs for Rn, because we don't always have to+  save those (as opposed to Sp/Hp/SpLim etc. which always have to be+  saved).++  --------------------------------------------------------------------------- */++#elif defined(MACHREGS_x86_64)++#define REG(x) __asm__("%" #x)++#define REG_Base  r13+#define REG_Sp    rbp+#define REG_Hp    r12+#define REG_R1    rbx+#define REG_R2    r14+#define REG_R3    rsi+#define REG_R4    rdi+#define REG_R5    r8+#define REG_R6    r9+#define REG_SpLim r15+#define REG_MachSp  rsp++/*+Map both Fn and Dn to register xmmn so that we can pass a function any+combination of up to six Float# or Double# arguments without touching+the stack. See Note [Overlapping global registers] for implications.+*/++#define REG_F1    xmm1+#define REG_F2    xmm2+#define REG_F3    xmm3+#define REG_F4    xmm4+#define REG_F5    xmm5+#define REG_F6    xmm6++#define REG_D1    xmm1+#define REG_D2    xmm2+#define REG_D3    xmm3+#define REG_D4    xmm4+#define REG_D5    xmm5+#define REG_D6    xmm6++#define REG_XMM1    xmm1+#define REG_XMM2    xmm2+#define REG_XMM3    xmm3+#define REG_XMM4    xmm4+#define REG_XMM5    xmm5+#define REG_XMM6    xmm6++#define REG_YMM1    ymm1+#define REG_YMM2    ymm2+#define REG_YMM3    ymm3+#define REG_YMM4    ymm4+#define REG_YMM5    ymm5+#define REG_YMM6    ymm6++#define REG_ZMM1    zmm1+#define REG_ZMM2    zmm2+#define REG_ZMM3    zmm3+#define REG_ZMM4    zmm4+#define REG_ZMM5    zmm5+#define REG_ZMM6    zmm6++#if !defined(mingw32_HOST_OS)+#define CALLER_SAVES_R3+#define CALLER_SAVES_R4+#endif+#define CALLER_SAVES_R5+#define CALLER_SAVES_R6++#define CALLER_SAVES_F1+#define CALLER_SAVES_F2+#define CALLER_SAVES_F3+#define CALLER_SAVES_F4+#define CALLER_SAVES_F5+#if !defined(mingw32_HOST_OS)+#define CALLER_SAVES_F6+#endif++#define CALLER_SAVES_D1+#define CALLER_SAVES_D2+#define CALLER_SAVES_D3+#define CALLER_SAVES_D4+#define CALLER_SAVES_D5+#if !defined(mingw32_HOST_OS)+#define CALLER_SAVES_D6+#endif++#define CALLER_SAVES_XMM1+#define CALLER_SAVES_XMM2+#define CALLER_SAVES_XMM3+#define CALLER_SAVES_XMM4+#define CALLER_SAVES_XMM5+#if !defined(mingw32_HOST_OS)+#define CALLER_SAVES_XMM6+#endif++#define CALLER_SAVES_YMM1+#define CALLER_SAVES_YMM2+#define CALLER_SAVES_YMM3+#define CALLER_SAVES_YMM4+#define CALLER_SAVES_YMM5+#if !defined(mingw32_HOST_OS)+#define CALLER_SAVES_YMM6+#endif++#define CALLER_SAVES_ZMM1+#define CALLER_SAVES_ZMM2+#define CALLER_SAVES_ZMM3+#define CALLER_SAVES_ZMM4+#define CALLER_SAVES_ZMM5+#if !defined(mingw32_HOST_OS)+#define CALLER_SAVES_ZMM6+#endif++#define MAX_REAL_VANILLA_REG 6+#define MAX_REAL_FLOAT_REG   6+#define MAX_REAL_DOUBLE_REG  6+#define MAX_REAL_LONG_REG    0+#define MAX_REAL_XMM_REG     6+#define MAX_REAL_YMM_REG     6+#define MAX_REAL_ZMM_REG     6++/* -----------------------------------------------------------------------------+   The PowerPC register mapping++   0            system glue?    (caller-save, volatile)+   1            SP              (callee-save, non-volatile)+   2            AIX, powerpc64-linux:+                    RTOC        (a strange special case)+                powerpc32-linux:+                                reserved for use by system++   3-10         args/return     (caller-save, volatile)+   11,12        system glue?    (caller-save, volatile)+   13           on 64-bit:      reserved for thread state pointer+                on 32-bit:      (callee-save, non-volatile)+   14-31                        (callee-save, non-volatile)++   f0                           (caller-save, volatile)+   f1-f13       args/return     (caller-save, volatile)+   f14-f31                      (callee-save, non-volatile)++   \tr{14}--\tr{31} are wonderful callee-save registers on all ppc OSes.+   \tr{0}--\tr{12} are caller-save registers.++   \tr{%f14}--\tr{%f31} are callee-save floating-point registers.++   We can do the Whole Business with callee-save registers only!+   -------------------------------------------------------------------------- */++#elif defined(MACHREGS_powerpc)++#define REG(x) __asm__(#x)++#define REG_R1          r14+#define REG_R2          r15+#define REG_R3          r16+#define REG_R4          r17+#define REG_R5          r18+#define REG_R6          r19+#define REG_R7          r20+#define REG_R8          r21+#define REG_R9          r22+#define REG_R10         r23++#define REG_F1          fr14+#define REG_F2          fr15+#define REG_F3          fr16+#define REG_F4          fr17+#define REG_F5          fr18+#define REG_F6          fr19++#define REG_D1          fr20+#define REG_D2          fr21+#define REG_D3          fr22+#define REG_D4          fr23+#define REG_D5          fr24+#define REG_D6          fr25++#define REG_Sp          r24+#define REG_SpLim       r25+#define REG_Hp          r26+#define REG_Base        r27++#define MAX_REAL_FLOAT_REG   6+#define MAX_REAL_DOUBLE_REG  6++/* -----------------------------------------------------------------------------+   The ARM EABI register mapping++   Here we consider ARM mode (i.e. 32bit isns)+   and also CPU with full VFPv3 implementation++   ARM registers (see Chapter 5.1 in ARM IHI 0042D and+   Section 9.2.2 in ARM Software Development Toolkit Reference Guide)++   r15  PC         The Program Counter.+   r14  LR         The Link Register.+   r13  SP         The Stack Pointer.+   r12  IP         The Intra-Procedure-call scratch register.+   r11  v8/fp      Variable-register 8.+   r10  v7/sl      Variable-register 7.+   r9   v6/SB/TR   Platform register. The meaning of this register is+                   defined by the platform standard.+   r8   v5         Variable-register 5.+   r7   v4         Variable register 4.+   r6   v3         Variable register 3.+   r5   v2         Variable register 2.+   r4   v1         Variable register 1.+   r3   a4         Argument / scratch register 4.+   r2   a3         Argument / scratch register 3.+   r1   a2         Argument / result / scratch register 2.+   r0   a1         Argument / result / scratch register 1.++   VFPv2/VFPv3/NEON registers+   s0-s15/d0-d7/q0-q3    Argument / result/ scratch registers+   s16-s31/d8-d15/q4-q7  callee-saved registers (must be preserved across+                         subroutine calls)++   VFPv3/NEON registers (added to the VFPv2 registers set)+   d16-d31/q8-q15        Argument / result/ scratch registers+   ----------------------------------------------------------------------------- */++#elif defined(MACHREGS_arm)++#define REG(x) __asm__(#x)++#define REG_Base        r4+#define REG_Sp          r5+#define REG_Hp          r6+#define REG_R1          r7+#define REG_R2          r8+#define REG_R3          r9+#define REG_R4          r10+#define REG_SpLim       r11++#if !defined(arm_HOST_ARCH_PRE_ARMv6)+/* d8 */+#define REG_F1    s16+#define REG_F2    s17+/* d9 */+#define REG_F3    s18+#define REG_F4    s19++#define REG_D1    d10+#define REG_D2    d11+#endif++/* -----------------------------------------------------------------------------+   The ARMv8/AArch64 ABI register mapping++   The AArch64 provides 31 64-bit general purpose registers+   and 32 128-bit SIMD/floating point registers.++   General purpose registers (see Chapter 5.1.1 in ARM IHI 0055B)++   Register | Special | Role in the procedure call standard+   ---------+---------+------------------------------------+     SP     |         | The Stack Pointer+     r30    |  LR     | The Link Register+     r29    |  FP     | The Frame Pointer+   r19-r28  |         | Callee-saved registers+     r18    |         | The Platform Register, if needed;+            |         | or temporary register+     r17    |  IP1    | The second intra-procedure-call temporary register+     r16    |  IP0    | The first intra-procedure-call scratch register+    r9-r15  |         | Temporary registers+     r8     |         | Indirect result location register+    r0-r7   |         | Parameter/result registers+++   FPU/SIMD registers++   s/d/q/v0-v7    Argument / result/ scratch registers+   s/d/q/v8-v15   callee-saved registers (must be preserved across subroutine calls,+                  but only bottom 64-bit value needs to be preserved)+   s/d/q/v16-v31  temporary registers++   ----------------------------------------------------------------------------- */++#elif defined(MACHREGS_aarch64)++#define REG(x) __asm__(#x)++#define REG_Base        r19+#define REG_Sp          r20+#define REG_Hp          r21+#define REG_R1          r22+#define REG_R2          r23+#define REG_R3          r24+#define REG_R4          r25+#define REG_R5          r26+#define REG_R6          r27+#define REG_SpLim       r28++#define REG_F1          s8+#define REG_F2          s9+#define REG_F3          s10+#define REG_F4          s11++#define REG_D1          d12+#define REG_D2          d13+#define REG_D3          d14+#define REG_D4          d15++/* -----------------------------------------------------------------------------+   The s390x register mapping++   Register    | Role(s)                                 | Call effect+   ------------+-------------------------------------+-----------------+   r0,r1       | -                                       | caller-saved+   r2          | Argument / return value                 | caller-saved+   r3,r4,r5    | Arguments                               | caller-saved+   r6          | Argument                                | callee-saved+   r7...r11    | -                                       | callee-saved+   r12         | (Commonly used as GOT pointer)          | callee-saved+   r13         | (Commonly used as literal pool pointer) | callee-saved+   r14         | Return address                          | caller-saved+   r15         | Stack pointer                           | callee-saved+   f0          | Argument / return value                 | caller-saved+   f2,f4,f6    | Arguments                               | caller-saved+   f1,f3,f5,f7 | -                                       | caller-saved+   f8...f15    | -                                       | callee-saved+   v0...v31    | -                                       | caller-saved++   Each general purpose register r0 through r15 as well as each floating-point+   register f0 through f15 is 64 bits wide. Each vector register v0 through v31+   is 128 bits wide.++   Note, the vector registers v0 through v15 overlap with the floating-point+   registers f0 through f15.++   -------------------------------------------------------------------------- */++#elif defined(MACHREGS_s390x)++#define REG(x) __asm__("%" #x)++#define REG_Base        r7+#define REG_Sp          r8+#define REG_Hp          r10+#define REG_R1          r11+#define REG_R2          r12+#define REG_R3          r13+#define REG_R4          r6+#define REG_R5          r2+#define REG_R6          r3+#define REG_R7          r4+#define REG_R8          r5+#define REG_SpLim       r9+#define REG_MachSp      r15++#define REG_F1          f8+#define REG_F2          f9+#define REG_F3          f10+#define REG_F4          f11+#define REG_F5          f0+#define REG_F6          f1++#define REG_D1          f12+#define REG_D2          f13+#define REG_D3          f14+#define REG_D4          f15+#define REG_D5          f2+#define REG_D6          f3++#define CALLER_SAVES_R5+#define CALLER_SAVES_R6+#define CALLER_SAVES_R7+#define CALLER_SAVES_R8++#define CALLER_SAVES_F5+#define CALLER_SAVES_F6++#define CALLER_SAVES_D5+#define CALLER_SAVES_D6++/* -----------------------------------------------------------------------------+   The riscv64 register mapping++   Register    | Role(s)                                 | Call effect+   ------------+-----------------------------------------+-------------+   zero        | Hard-wired zero                         | -+   ra          | Return address                          | caller-saved+   sp          | Stack pointer                           | callee-saved+   gp          | Global pointer                          | callee-saved+   tp          | Thread pointer                          | callee-saved+   t0,t1,t2    | -                                       | caller-saved+   s0          | Frame pointer                           | callee-saved+   s1          | -                                       | callee-saved+   a0,a1       | Arguments / return values               | caller-saved+   a2..a7      | Arguments                               | caller-saved+   s2..s11     | -                                       | callee-saved+   t3..t6      | -                                       | caller-saved+   ft0..ft7    | -                                       | caller-saved+   fs0,fs1     | -                                       | callee-saved+   fa0,fa1     | Arguments / return values               | caller-saved+   fa2..fa7    | Arguments                               | caller-saved+   fs2..fs11   | -                                       | callee-saved+   ft8..ft11   | -                                       | caller-saved++   Each general purpose register as well as each floating-point+   register is 64 bits wide.++   -------------------------------------------------------------------------- */++#elif defined(MACHREGS_riscv64)++#define REG(x) __asm__(#x)++#define REG_Base        s1+#define REG_Sp          s2+#define REG_Hp          s3+#define REG_R1          s4+#define REG_R2          s5+#define REG_R3          s6+#define REG_R4          s7+#define REG_R5          s8+#define REG_R6          s9+#define REG_R7          s10+#define REG_SpLim       s11++#define REG_F1          fs0+#define REG_F2          fs1+#define REG_F3          fs2+#define REG_F4          fs3+#define REG_F5          fs4+#define REG_F6          fs5++#define REG_D1          fs6+#define REG_D2          fs7+#define REG_D3          fs8+#define REG_D4          fs9+#define REG_D5          fs10+#define REG_D6          fs11++#define MAX_REAL_FLOAT_REG   6+#define MAX_REAL_DOUBLE_REG  6++#else++#error Cannot find platform to give register info for++#endif++#else++#error Bad MACHREGS_NO_REGS value++#endif++/* -----------------------------------------------------------------------------+ * These constants define how many stg registers will be used for+ * passing arguments (and results, in the case of an unboxed-tuple+ * return).+ *+ * We usually set MAX_REAL_VANILLA_REG and co. to be the number of the+ * highest STG register to occupy a real machine register, otherwise+ * the calling conventions will needlessly shuffle data between the+ * stack and memory-resident STG registers.  We might occasionally+ * set these macros to other values for testing, though.+ *+ * Registers above these values might still be used, for instance to+ * communicate with PrimOps and RTS functions.+ */++#if !defined(MAX_REAL_VANILLA_REG)+#  if   defined(REG_R10)+#  define MAX_REAL_VANILLA_REG 10+#  elif   defined(REG_R9)+#  define MAX_REAL_VANILLA_REG 9+#  elif   defined(REG_R8)+#  define MAX_REAL_VANILLA_REG 8+#  elif defined(REG_R7)+#  define MAX_REAL_VANILLA_REG 7+#  elif defined(REG_R6)+#  define MAX_REAL_VANILLA_REG 6+#  elif defined(REG_R5)+#  define MAX_REAL_VANILLA_REG 5+#  elif defined(REG_R4)+#  define MAX_REAL_VANILLA_REG 4+#  elif defined(REG_R3)+#  define MAX_REAL_VANILLA_REG 3+#  elif defined(REG_R2)+#  define MAX_REAL_VANILLA_REG 2+#  elif defined(REG_R1)+#  define MAX_REAL_VANILLA_REG 1+#  else+#  define MAX_REAL_VANILLA_REG 0+#  endif+#endif++#if !defined(MAX_REAL_FLOAT_REG)+#  if   defined(REG_F7)+#  error Please manually define MAX_REAL_FLOAT_REG for this architecture+#  elif defined(REG_F6)+#  define MAX_REAL_FLOAT_REG 6+#  elif defined(REG_F5)+#  define MAX_REAL_FLOAT_REG 5+#  elif defined(REG_F4)+#  define MAX_REAL_FLOAT_REG 4+#  elif defined(REG_F3)+#  define MAX_REAL_FLOAT_REG 3+#  elif defined(REG_F2)+#  define MAX_REAL_FLOAT_REG 2+#  elif defined(REG_F1)+#  define MAX_REAL_FLOAT_REG 1+#  else+#  define MAX_REAL_FLOAT_REG 0+#  endif+#endif++#if !defined(MAX_REAL_DOUBLE_REG)+#  if   defined(REG_D7)+#  error Please manually define MAX_REAL_DOUBLE_REG for this architecture+#  elif defined(REG_D6)+#  define MAX_REAL_DOUBLE_REG 6+#  elif defined(REG_D5)+#  define MAX_REAL_DOUBLE_REG 5+#  elif defined(REG_D4)+#  define MAX_REAL_DOUBLE_REG 4+#  elif defined(REG_D3)+#  define MAX_REAL_DOUBLE_REG 3+#  elif defined(REG_D2)+#  define MAX_REAL_DOUBLE_REG 2+#  elif defined(REG_D1)+#  define MAX_REAL_DOUBLE_REG 1+#  else+#  define MAX_REAL_DOUBLE_REG 0+#  endif+#endif++#if !defined(MAX_REAL_LONG_REG)+#  if   defined(REG_L1)+#  define MAX_REAL_LONG_REG 1+#  else+#  define MAX_REAL_LONG_REG 0+#  endif+#endif++#if !defined(MAX_REAL_XMM_REG)+#  if   defined(REG_XMM6)+#  define MAX_REAL_XMM_REG 6+#  elif defined(REG_XMM5)+#  define MAX_REAL_XMM_REG 5+#  elif defined(REG_XMM4)+#  define MAX_REAL_XMM_REG 4+#  elif defined(REG_XMM3)+#  define MAX_REAL_XMM_REG 3+#  elif defined(REG_XMM2)+#  define MAX_REAL_XMM_REG 2+#  elif defined(REG_XMM1)+#  define MAX_REAL_XMM_REG 1+#  else+#  define MAX_REAL_XMM_REG 0+#  endif+#endif++/* define NO_ARG_REGS if we have no argument registers at all (we can+ * optimise certain code paths using this predicate).+ */+#if MAX_REAL_VANILLA_REG < 2+#define NO_ARG_REGS+#else+#undef NO_ARG_REGS+#endif
+ Setup.hs view
@@ -0,0 +1,137 @@+{-# LANGUAGE RecordWildCards #-}+module Main where++import Distribution.Simple+import Distribution.Simple.BuildPaths+import Distribution.Types.LocalBuildInfo+import Distribution.Verbosity+import Distribution.Simple.Program+import Distribution.Simple.Utils+import Distribution.Simple.Setup++import System.IO+import System.Process+import System.Directory+import System.FilePath+import Control.Monad+import Data.Char+import GHC.ResponseFile+import System.Environment++main :: IO ()+main = defaultMainWithHooks ghcHooks+  where+    ghcHooks = simpleUserHooks+      { postConf = \args cfg pd lbi -> do+          let verbosity = fromFlagOrDefault minBound (configVerbosity cfg)+          ghcAutogen verbosity lbi+          postConf simpleUserHooks args cfg pd lbi+      }++-- Mapping from primop-*.hs-incl file to command+primopIncls :: [(String,String)]+primopIncls =+    [ ("primop-data-decl.hs-incl"         , "--data-decl")+    , ("primop-tag.hs-incl"               , "--primop-tag")+    , ("primop-list.hs-incl"              , "--primop-list")+    , ("primop-has-side-effects.hs-incl"  , "--has-side-effects")+    , ("primop-out-of-line.hs-incl"       , "--out-of-line")+    , ("primop-commutable.hs-incl"        , "--commutable")+    , ("primop-code-size.hs-incl"         , "--code-size")+    , ("primop-can-fail.hs-incl"          , "--can-fail")+    , ("primop-strictness.hs-incl"        , "--strictness")+    , ("primop-fixity.hs-incl"            , "--fixity")+    , ("primop-primop-info.hs-incl"       , "--primop-primop-info")+    , ("primop-vector-uniques.hs-incl"    , "--primop-vector-uniques")+    , ("primop-vector-tys.hs-incl"        , "--primop-vector-tys")+    , ("primop-vector-tys-exports.hs-incl", "--primop-vector-tys-exports")+    , ("primop-vector-tycons.hs-incl"     , "--primop-vector-tycons")+    , ("primop-docs.hs-incl"              , "--wired-in-docs")+    ]++ghcAutogen :: Verbosity -> LocalBuildInfo -> IO ()+ghcAutogen verbosity lbi@LocalBuildInfo{..} = do+  -- Get compiler/ root directory from the cabal file+  let Just compilerRoot = takeDirectory <$> pkgDescrFile++  -- Require the necessary programs+  (gcc   ,withPrograms) <- requireProgram normal gccProgram withPrograms+  (ghc   ,withPrograms) <- requireProgram normal ghcProgram withPrograms++  settings <- read <$> getProgramOutput normal ghc ["--info"]+  -- We are reinstalling GHC+  -- Write primop-*.hs-incl+  let hsCppOpts = case lookup "Haskell CPP flags" settings of+        Just fs -> unescapeArgs fs+        Nothing -> []+      primopsTxtPP = compilerRoot </> "GHC/Builtin/primops.txt.pp"+      cppOpts = hsCppOpts ++ ["-P","-x","c"]+      cppIncludes = map ("-I"++) [compilerRoot]+  -- Preprocess primops.txt.pp+  primopsStr <- getProgramOutput normal gcc (cppOpts ++ cppIncludes ++ [primopsTxtPP])+  -- Call genprimopcode to generate *.hs-incl+  forM_ primopIncls $ \(file,command) -> do+    contents <- readProcess "genprimopcode" [command] primopsStr+    rewriteFileEx verbosity (buildDir </> file) contents++  -- Write GHC.Platform.Constants+  let platformConstantsPath = autogenPackageModulesDir lbi </> "GHC/Platform/Constants.hs"+      targetOS = case lookup "target os" settings of+        Nothing -> error "no target os in settings"+        Just os -> os+  createDirectoryIfMissingVerbose verbosity True (takeDirectory platformConstantsPath)+  withTempFile (takeDirectory platformConstantsPath) "Constants_tmp.hs" $ \tmp h -> do+    hClose h+    callProcess "deriveConstants" ["--gen-haskell-type","-o",tmp,"--target-os",targetOS]+    renameFile tmp platformConstantsPath++  -- Write GHC.Settings.Config+  let configHsPath = autogenPackageModulesDir lbi </> "GHC/Settings/Config.hs"+      configHs = generateConfigHs settings+  createDirectoryIfMissingVerbose verbosity True (takeDirectory configHsPath)+  rewriteFileEx verbosity configHsPath configHs++getSetting :: [(String,String)] -> String -> String -> Either String String+getSetting settings kh kr = go settings kr+  where+    go settings k =  case lookup k settings of+      Nothing -> Left (show k ++ " not found in settings: " ++ show settings)+      Just v -> Right v++generateConfigHs :: [(String,String)] -> String+generateConfigHs settings = either error id $ do+    let getSetting' = getSetting $ (("cStage","2"):) settings+    buildPlatform  <- getSetting' "cBuildPlatformString" "Host platform"+    hostPlatform   <- getSetting' "cHostPlatformString" "Target platform"+    cProjectName   <- getSetting' "cProjectName" "Project name"+    cBooterVersion <- getSetting' "cBooterVersion" "Project version"+    cStage         <- getSetting' "cStage" "cStage"+    return $ unlines+        [ "module GHC.Settings.Config"+        , "  ( module GHC.Version"+        , "  , cBuildPlatformString"+        , "  , cHostPlatformString"+        , "  , cProjectName"+        , "  , cBooterVersion"+        , "  , cStage"+        , "  ) where"+        , ""+        , "import GHC.Prelude"+        , ""+        , "import GHC.Version"+        , ""+        , "cBuildPlatformString :: String"+        , "cBuildPlatformString = " ++ show buildPlatform+        , ""+        , "cHostPlatformString :: String"+        , "cHostPlatformString = " ++ show hostPlatform+        , ""+        , "cProjectName          :: String"+        , "cProjectName          = " ++ show cProjectName+        , ""+        , "cBooterVersion        :: String"+        , "cBooterVersion        = " ++ show cBooterVersion+        , ""+        , "cStage                :: String"+        , "cStage                = show ("++ cStage ++ " :: Int)"+        ]
+ Unique.h view
@@ -0,0 +1,5 @@+/* unique has the following structure:+ * HsInt unique =+ *    (unique_tag << (sizeof (HsInt) - UNIQUE_TAG_BITS)) | unique_number+ */+#define UNIQUE_TAG_BITS 8
cbits/genSym.c view
@@ -1,18 +1,25 @@ #include <Rts.h> #include <assert.h> #include "Unique.h"+#include <ghcversion.h> +// These global variables have been moved into the RTS.  It allows them to be+// shared with plugins even if two different instances of the GHC library are+// loaded at the same time (#19940)+//+// The CPP is thus about the RTS version GHC is linked against, and not the+// version of the GHC being built.+#if !MIN_VERSION_GLASGOW_HASKELL(9,3,0,0) HsInt ghc_unique_counter = 0; HsInt ghc_unique_inc     = 1;+#endif  #define UNIQUE_BITS (sizeof (HsInt) * 8 - UNIQUE_TAG_BITS) #define UNIQUE_MASK ((1ULL << UNIQUE_BITS) - 1)  HsInt genSym(void) {     HsInt u = atomic_inc((StgWord *)&ghc_unique_counter, ghc_unique_inc) & UNIQUE_MASK;-#if DEBUG     // Uh oh! We will overflow next time a unique is requested.-    assert(u != UNIQUE_MASK);-#endif+    ASSERT(u != UNIQUE_MASK);     return u; }
cbits/keepCAFsForGHCi.c view
@@ -1,35 +1,15 @@ #include <Rts.h>-#include <ghcversion.h> -// Note [keepCAFsForGHCi]-// ~~~~~~~~~~~~~~~~~~~~~~ // This file is only included in the dynamic library. // It contains an __attribute__((constructor)) function (run prior to main()) // which sets the keepCAFs flag in the RTS, before any Haskell code is run. // This is required so that GHCi can use dynamic libraries instead of HSxyz.o // files.-//-// For static builds we have to guarantee that the linker loads this object file-// to ensure the constructor gets run and not discarded. If the object is part of-// an archive and not otherwise referenced the linker would ignore the object.-// To avoid this:-// * When initializing a GHC session in initGhcMonad we assert keeping cafs has been-//   enabled by calling keepCAFsForGHCi.-// * This causes the GHC module from the ghc package to carry a reference to this object-//   file.-// * Which in turn ensures the linker doesn't discard this object file, causing-//   the constructor to be run, allowing the assertion to succeed in the first place-//   as keepCAFs will have been set already during initialization of constructors. ---bool keepCAFsForGHCi(void) __attribute__((constructor));+static void keepCAFsForGHCi(void) __attribute__((constructor)); -bool keepCAFsForGHCi(void)+static void keepCAFsForGHCi(void) {-    bool was_set = keepCAFs;-    setKeepCAFs();-    return was_set;+    keepCAFs = 1; }-
+ ghc-llvm-version.h view
@@ -0,0 +1,11 @@+/* compiler/ghc-llvm-version.h.  Generated from ghc-llvm-version.h.in by configure.  */+#if !defined(__GHC_LLVM_VERSION_H__)+#define __GHC_LLVM_VERSION_H__++/* The maximum supported LLVM version number */+#define sUPPORTED_LLVM_VERSION_MAX (14)++/* The minimum supported LLVM version number */+#define sUPPORTED_LLVM_VERSION_MIN (10)++#endif /* __GHC_LLVM_VERSION_H__ */
ghc.cabal view
@@ -1,10 +1,10 @@+Cabal-Version: 2.2 -- WARNING: ghc.cabal is automatically generated from ghc.cabal.in by -- ./configure.  Make sure you are editing ghc.cabal.in, not ghc.cabal. -Cabal-Version: 1.22 Name: ghc-Version: 9.2.8-License: BSD3+Version: 9.4.1+License: BSD-3-Clause License-File: LICENSE Author: The GHC Team Maintainer: glasgow-haskell-users@haskell.org@@ -21,25 +21,28 @@     See <https://gitlab.haskell.org/ghc/ghc/-/wikis/commentary/compiler>     for more information. Category: Development-Build-Type: Simple+Build-Type: Custom -Flag internal-interpreter-    Description: Build with internal interpreter support.-    Default: False-    Manual: True+extra-source-files:+    GHC/Builtin/primops.txt.pp+    GHC/Builtin/bytearray-ops.txt.pp+    Unique.h+    CodeGen.Platform.h+    -- Shared with rts via hard-link at configure time. This is safer+    -- for Windows, where symlinks don't work out of the box, so we+    -- can't just commit some in git.+    Bytecodes.h+    ClosureTypes.h+    FunTypes.h+    MachRegs.h+    ghc-llvm-version.h -Flag stage1-    Description: Is this stage 1?-    Default: False-    Manual: True -Flag stage2-    Description: Is this stage 2?-    Default: False-    Manual: True+custom-setup+    setup-depends: base >= 3 && < 5, Cabal >= 1.6 && <3.9, directory, process, filepath -Flag stage3-    Description: Is this stage 3?+Flag internal-interpreter+    Description: Build with internal interpreter support.     Default: False     Manual: True @@ -53,27 +56,44 @@     Default: True     Manual: True +-- hadrian disables this flag because the user may be building from a source+-- distribution where the parser has already been generated.+Flag build-tool-depends+    Description: Use build-tool-depends+    Default: True+ Library     Default-Language: Haskell2010     Exposed: False+    Includes: Unique.h+              -- CodeGen.Platform.h -- invalid as C, skip+              -- shared with rts via symlink+              Bytecodes.h+              ClosureTypes.h+              FunTypes.h+              ghc-llvm-version.h -    Build-Depends: base       >= 4.11 && < 4.17,+    if flag(build-tool-depends)+      build-tool-depends: alex:alex >= 3.2.6, happy:happy >= 1.20.0, genprimopcode:genprimopcode, deriveConstants:deriveConstants++    Build-Depends: base       >= 4.11 && < 4.18,                    deepseq    >= 1.4 && < 1.5,                    directory  >= 1   && < 1.4,                    process    >= 1   && < 1.7,                    bytestring >= 0.9 && < 0.12,                    binary     == 0.8.*,-                   time       >= 1.4 && < 1.12,+                   time       >= 1.4 && < 1.13,                    containers >= 0.6.2.1 && < 0.7,                    array      >= 0.1 && < 0.6,                    filepath   >= 1   && < 1.5,-                   template-haskell == 2.18.*,+                   template-haskell == 2.19.*,                    hpc        == 0.6.*,                    transformers == 0.5.*,                    exceptions == 0.10.*,-                   ghc-boot   == 9.2.8,-                   ghc-heap   == 9.2.8,-                   ghci == 9.2.8+                   stm,+                   ghc-boot   == 9.4.1,+                   ghc-heap   == 9.4.1,+                   ghci == 9.4.1      if os(windows)         Build-Depends: Win32  >= 2.3 && < 2.13@@ -89,7 +109,6 @@      if flag(internal-interpreter)         CPP-Options: -DHAVE_INTERNAL_INTERPRETER-        Include-Dirs:        -- if no dynamic system linker is available, don't try DLLs.     if flag(dynamic-system-linker)@@ -128,17 +147,6 @@     -- as it's magic.     GHC-Options: -this-unit-id ghc -    -- if flag(stage1)-    --     Include-Dirs: stage1-    -- else-    --     if flag(stage2)-    --         Include-Dirs: stage2-    --     else-    --         if flag(stage3)-    --             Include-Dirs: stage2--    Install-Includes: HsVersions.h-     c-sources:         cbits/cutils.c         cbits/genSym.c@@ -153,12 +161,14 @@        ,BangPatterns        ,ScopedTypeVariables        ,MonoLocalBinds+       ,TypeOperators      Exposed-Modules:         GHC         GHC.Builtin.Names         GHC.Builtin.Names.TH         GHC.Builtin.PrimOps+        GHC.Builtin.PrimOps.Ids         GHC.Builtin.Types         GHC.Builtin.Types.Literals         GHC.Builtin.Types.Prim@@ -174,6 +184,7 @@         GHC.Cmm.CallConv         GHC.Cmm.CLabel         GHC.Cmm.CommonBlockElim+        GHC.Cmm.Config         GHC.Cmm.ContFlowOpt         GHC.Cmm.Dataflow         GHC.Cmm.Dataflow.Block@@ -185,6 +196,7 @@         GHC.Cmm.Graph         GHC.Cmm.Info         GHC.Cmm.Info.Build+        GHC.Cmm.InitFini         GHC.Cmm.LayoutStack         GHC.Cmm.Lexer         GHC.Cmm.Lint@@ -247,7 +259,6 @@         GHC.CmmToAsm.Reg.Linear.FreeRegs         GHC.CmmToAsm.Reg.Linear.JoinToTargets         GHC.CmmToAsm.Reg.Linear.PPC-        GHC.CmmToAsm.Reg.Linear.SPARC         GHC.CmmToAsm.Reg.Linear.StackMap         GHC.CmmToAsm.Reg.Linear.State         GHC.CmmToAsm.Reg.Linear.Stats@@ -256,24 +267,6 @@         GHC.CmmToAsm.Reg.Liveness         GHC.CmmToAsm.Reg.Target         GHC.CmmToAsm.Reg.Utils-        GHC.CmmToAsm.SPARC-        GHC.CmmToAsm.SPARC.AddrMode-        GHC.CmmToAsm.SPARC.Base-        GHC.CmmToAsm.SPARC.CodeGen-        GHC.CmmToAsm.SPARC.CodeGen.Amode-        GHC.CmmToAsm.SPARC.CodeGen.Base-        GHC.CmmToAsm.SPARC.CodeGen.CondCode-        GHC.CmmToAsm.SPARC.CodeGen.Expand-        GHC.CmmToAsm.SPARC.CodeGen.Gen32-        GHC.CmmToAsm.SPARC.CodeGen.Gen64-        GHC.CmmToAsm.SPARC.CodeGen.Sanity-        GHC.CmmToAsm.SPARC.Cond-        GHC.CmmToAsm.SPARC.Imm-        GHC.CmmToAsm.SPARC.Instr-        GHC.CmmToAsm.SPARC.Ppr-        GHC.CmmToAsm.SPARC.Regs-        GHC.CmmToAsm.SPARC.ShortcutJump-        GHC.CmmToAsm.SPARC.Stack         GHC.CmmToAsm.Types         GHC.CmmToAsm.Utils         GHC.CmmToAsm.X86@@ -287,6 +280,7 @@         GHC.CmmToLlvm         GHC.CmmToLlvm.Base         GHC.CmmToLlvm.CodeGen+        GHC.CmmToLlvm.Config         GHC.CmmToLlvm.Data         GHC.CmmToLlvm.Mangler         GHC.CmmToLlvm.Ppr@@ -304,6 +298,7 @@         GHC.Core.FVs         GHC.Core.InstEnv         GHC.Core.Lint+        GHC.Core.LateCC         GHC.Core.Make         GHC.Core.Map.Expr         GHC.Core.Map.Type@@ -336,6 +331,7 @@         GHC.Core.Ppr         GHC.Types.TyThing.Ppr         GHC.Core.Predicate+        GHC.Core.Reduction         GHC.Core.Rules         GHC.Core.Seq         GHC.Core.SimpleOpt@@ -355,6 +351,7 @@         GHC.Core.TyCo.Subst         GHC.Core.TyCo.Tidy         GHC.Core.Type+        GHC.Core.RoughMap         GHC.Core.Unfold         GHC.Core.Unfold.Make         GHC.Core.Unify@@ -362,6 +359,7 @@         GHC.Core.Utils         GHC.Data.Bag         GHC.Data.Bitmap+        GHC.Data.Bool         GHC.Data.BooleanFormula         GHC.Data.EnumSet         GHC.Data.FastMutInt@@ -379,7 +377,9 @@         GHC.Data.Maybe         GHC.Data.OrdList         GHC.Data.Pair+        GHC.Data.SmallArray         GHC.Data.Stream+        GHC.Data.Strict         GHC.Data.StringBuffer         GHC.Data.TrieMap         GHC.Data.UnionFind@@ -389,10 +389,28 @@         GHC.Driver.CmdLine         GHC.Driver.CodeOutput         GHC.Driver.Config+        GHC.Driver.Config.Cmm+        GHC.Driver.Config.CmmToAsm+        GHC.Driver.Config.CmmToLlvm+        GHC.Driver.Config.Diagnostic+        GHC.Driver.Config.Finder+        GHC.Driver.Config.HsToCore+        GHC.Driver.Config.Logger+        GHC.Driver.Config.Parser+        GHC.Driver.Config.Stg.Debug+        GHC.Driver.Config.Stg.Lift+        GHC.Driver.Config.Stg.Pipeline+        GHC.Driver.Config.Stg.Ppr+        GHC.Driver.Config.StgToCmm+        GHC.Driver.Config.Tidy         GHC.Driver.Env+        GHC.Driver.Env.KnotVars         GHC.Driver.Env.Types         GHC.Driver.Errors+        GHC.Driver.Errors.Ppr+        GHC.Driver.Errors.Types         GHC.Driver.Flags+        GHC.Driver.GenerateCgIPEStub         GHC.Driver.Hooks         GHC.Driver.Main         GHC.Driver.Make@@ -400,6 +418,9 @@         GHC.Driver.Monad         GHC.Driver.Phases         GHC.Driver.Pipeline+        GHC.Driver.Pipeline.Execute+        GHC.Driver.Pipeline.LogQueue+        GHC.Driver.Pipeline.Phases         GHC.Driver.Pipeline.Monad         GHC.Driver.Plugins         GHC.Driver.Ppr@@ -408,8 +429,10 @@         GHC.Hs.Binds         GHC.Hs.Decls         GHC.Hs.Doc+        GHC.Hs.DocString         GHC.Hs.Dump         GHC.Hs.Expr+        GHC.Hs.Syn.Type         GHC.Hs.Extension         GHC.Hs.ImpExp         GHC.Hs.Instances@@ -421,6 +444,8 @@         GHC.HsToCore.Binds         GHC.HsToCore.Coverage         GHC.HsToCore.Docs+        GHC.HsToCore.Errors.Ppr+        GHC.HsToCore.Errors.Types         GHC.HsToCore.Expr         GHC.HsToCore.Foreign.Call         GHC.HsToCore.Foreign.Decl@@ -446,6 +471,7 @@         GHC.Hs.Utils         GHC.Iface.Binary         GHC.Iface.Env+        GHC.Iface.Errors         GHC.Iface.Ext.Ast         GHC.Iface.Ext.Binary         GHC.Iface.Ext.Debug@@ -469,6 +495,7 @@         GHC.Linker.Loader         GHC.Linker.MacOS         GHC.Linker.Static+        GHC.Linker.Static.Utils         GHC.Linker.Types         GHC.Linker.Unit         GHC.Linker.Windows@@ -480,10 +507,12 @@         GHC.Parser         GHC.Parser.Annotation         GHC.Parser.CharClass-        GHC.Parser.Errors+        GHC.Parser.Errors.Basic         GHC.Parser.Errors.Ppr+        GHC.Parser.Errors.Types         GHC.Parser.Header         GHC.Parser.Lexer+        GHC.Parser.HaddockLex         GHC.Parser.PostProcess         GHC.Parser.PostProcess.Haddock         GHC.Parser.Types@@ -500,13 +529,13 @@         GHC.Platform.Regs         GHC.Platform.RISCV64         GHC.Platform.S390X-        GHC.Platform.SPARC         GHC.Platform.Ways         GHC.Platform.X86         GHC.Platform.X86_64         GHC.Plugins         GHC.Prelude         GHC.Rename.Bind+        GHC.Rename.Doc         GHC.Rename.Env         GHC.Rename.Expr         GHC.Rename.Fixity@@ -530,24 +559,31 @@         GHC.Settings.Config         GHC.Settings.Constants         GHC.Settings.IO+        GHC.Stg.BcPrep         GHC.Stg.CSE         GHC.Stg.Debug-        GHC.Stg.DepAnal         GHC.Stg.FVs         GHC.Stg.Lift         GHC.Stg.Lift.Analysis+        GHC.Stg.Lift.Config         GHC.Stg.Lift.Monad         GHC.Stg.Lint+        GHC.Stg.InferTags+        GHC.Stg.InferTags.Rewrite+        GHC.Stg.InferTags.TagSig+        GHC.Stg.InferTags.Types         GHC.Stg.Pipeline         GHC.Stg.Stats         GHC.Stg.Subst         GHC.Stg.Syntax+        GHC.Stg.Utils         GHC.StgToByteCode         GHC.StgToCmm         GHC.StgToCmm.ArgRep         GHC.StgToCmm.Bind         GHC.StgToCmm.CgUtils         GHC.StgToCmm.Closure+        GHC.StgToCmm.Config         GHC.StgToCmm.DataCon         GHC.StgToCmm.Env         GHC.StgToCmm.Expr@@ -560,6 +596,8 @@         GHC.StgToCmm.Monad         GHC.StgToCmm.Prim         GHC.StgToCmm.Prof+        GHC.StgToCmm.Sequel+        GHC.StgToCmm.TagCheck         GHC.StgToCmm.Ticky         GHC.StgToCmm.Types         GHC.StgToCmm.Utils@@ -581,6 +619,8 @@         GHC.Tc.Errors         GHC.Tc.Errors.Hole         GHC.Tc.Errors.Hole.FitTypes+        GHC.Tc.Errors.Ppr+        GHC.Tc.Errors.Types         GHC.Tc.Gen.Annotation         GHC.Tc.Gen.App         GHC.Tc.Gen.Arrow@@ -605,8 +645,10 @@         GHC.Tc.Solver         GHC.Tc.Solver.Canonical         GHC.Tc.Solver.Rewrite+        GHC.Tc.Solver.InertSet         GHC.Tc.Solver.Interact         GHC.Tc.Solver.Monad+        GHC.Tc.Solver.Types         GHC.Tc.TyCl         GHC.Tc.TyCl.Build         GHC.Tc.TyCl.Class@@ -618,7 +660,9 @@         GHC.Tc.Types.Evidence         GHC.Tc.Types.EvTerm         GHC.Tc.Types.Origin+        GHC.Tc.Types.Rank         GHC.Tc.Utils.Backpack+        GHC.Tc.Utils.Concrete         GHC.Tc.Utils.Env         GHC.Tc.Utils.Instantiate         GHC.Tc.Utils.Monad@@ -631,6 +675,7 @@         GHC.Types.Annotations         GHC.Types.Avail         GHC.Types.Basic+        GHC.Types.BreakInfo         GHC.Types.CompleteMatch         GHC.Types.CostCentre         GHC.Types.CostCentre.State@@ -642,6 +687,8 @@         GHC.Types.Fixity.Env         GHC.Types.ForeignCall         GHC.Types.ForeignStubs+        GHC.Types.Hint+        GHC.Types.Hint.Ppr         GHC.Types.HpcInfo         GHC.Types.Id         GHC.Types.IPE@@ -657,6 +704,7 @@         GHC.Types.Name.Set         GHC.Types.Name.Shape         GHC.Types.Name.Ppr+        GHC.Types.PkgQual         GHC.Types.RepType         GHC.Types.SafeHaskell         GHC.Types.SourceError@@ -672,6 +720,7 @@         GHC.Types.Unique.DSet         GHC.Types.Unique.FM         GHC.Types.Unique.Map+        GHC.Types.Unique.MemoFun         GHC.Types.Unique.SDFM         GHC.Types.Unique.Set         GHC.Types.Unique.Supply@@ -708,6 +757,7 @@         GHC.Utils.Binary.Typeable         GHC.Utils.BufHandle         GHC.Utils.CliOption+        GHC.Utils.Constants         GHC.Utils.Error         GHC.Utils.Exception         GHC.Utils.Fingerprint@@ -719,13 +769,15 @@         GHC.Utils.Logger         GHC.Utils.Misc         GHC.Utils.Monad-        GHC.Utils.Monad.State+        GHC.Utils.Monad.State.Strict+        GHC.Utils.Monad.State.Lazy         GHC.Utils.Outputable         GHC.Utils.Panic         GHC.Utils.Panic.Plain         GHC.Utils.Ppr         GHC.Utils.Ppr.Colour         GHC.Utils.TmpFs+        GHC.Utils.Trace          Language.Haskell.Syntax         Language.Haskell.Syntax.Binds@@ -735,6 +787,9 @@         Language.Haskell.Syntax.Lit         Language.Haskell.Syntax.Pat         Language.Haskell.Syntax.Type++    autogen-modules: GHC.Platform.Constants+                     GHC.Settings.Config      reexported-modules:           GHC.Platform.ArchOS